11# ' Draw links between genomes
22# '
3- # ' @description Draws connections between genomes, such as genome/gene/protein
4- # ' alignments and gene/protein clusters. `geom_link()` draws links as filled
5- # ' polygons, `geom_link_line()` draws a single connecting line.
3+ # ' @description Draw connections between genomes, such as genome/gene/protein
4+ # ' alignments and gene/protein clusters. `geom_link()` and
5+ # ' `geom_link_curved()` create filled polygons between regions,
6+ # ' `geom_link_line()` a single connecting line.
67# '
78# ' Note that by default only links between adjacent genomes are computed and
89# ' shown. To compute and show all links between all genomes, set
1920# ' @inheritParams ggplot2::geom_polygon
2021# ' @param offset distance between seq center and link start. Use two values
2122# ' `c(<offset_top>, <offset_bottom>)` for different top and bottom offsets
23+ # ' @param curve curvature of the link. If `NA` or `0`, the link edges will be
24+ # ' straight. For curved links, higher values lead to stronger curvature.
25+ # ' Typical values are between `5` and `15`.
2226# ' @return A ggplot2 layer with links.
2327# ' @export
2428# ' @examples
4145# '
4246# ' library(patchwork) # combine plots in one figure
4347# ' p1 + p2 + p3 + p4 + plot_layout(nrow = 1)
48+ # '
49+ # ' q0 <- gggenomes(emale_genes, emale_seqs) |>
50+ # ' add_clusters(emale_cogs) +
51+ # ' geom_seq() + geom_gene()
52+ # '
53+ # ' qq <-
54+ # ' # link gene clusters with polygon
55+ # ' q0 + geom_link(aes(fill = cluster_id)) +
56+ # ' # link with curved polygons (bezier-like)
57+ # ' q0 + geom_link_curved(aes(fill = cluster_id)) +
58+ # ' # link gene clusters with lines
59+ # ' q0 + geom_link_line(aes(color = cluster_id))
60+ # '
61+ # ' qq + plot_layout(nrow = 1, guides = "collect")
4462geom_link <- function (
4563 mapping = NULL , data = links(), stat = " identity"
4664 position = " identity" na.rm = FALSE , show.legend = NA , inherit.aes = TRUE ,
47- offset = 0.15 , ... ) {
65+ offset = 0.15 , curve = NA , ... ) {
4866 if (length(offset ) == 1 ) offset <- offset [c(1 , 1 )]
4967
50- default_aes <- aes(y = .data $ y , x = .data $ x , xend = .data $ xend , yend = .data $ yend , xmin = .data $ xmin , xmax = .data $ xmax )
68+ default_aes <- aes(y = .data $ y , x = .data $ x , xend = .data $ xend ,
69+ yend = .data $ yend , xmin = .data $ xmin , xmax = .data $ xmax )
5170 mapping <- aes_intersect(mapping , default_aes )
5271
5372 layer(
5473 geom = GeomLink , mapping = mapping , data = data , stat = stat ,
5574 position = position , show.legend = show.legend , inherit.aes = inherit.aes ,
56- params = list (na.rm = na.rm , offset = offset , ... )
75+ params = list (na.rm = na.rm , offset = offset , curve = curve , ... )
5776 )
5877}
5978# ' @rdname geom_link
79+ # ' @return A ggplot2 layer with links.
80+ # ' @export
81+ geom_link_curved <- function (
82+ mapping = NULL , data = links(), stat = " identity"
83+ position = " identity" na.rm = FALSE , show.legend = NA , inherit.aes = TRUE ,
84+ offset = 0.15 , curve = 10 , ... ){
85+
86+ geom_link(mapping = mapping , data = data , stat = stat , position = position ,
87+ show.legend = show.legend , inherit.aes = inherit.aes , na.rm = na.rm ,
88+ offset = offset , curve = curve , ... )
89+ }
90+ # ' @rdname geom_link
91+ # ' @return A ggplot2 layer with links.
6092# ' @export
61- # ' @examples
62- # ' q0 <- gggenomes(emale_genes, emale_seqs) |>
63- # ' add_clusters(emale_cogs) +
64- # ' geom_seq() + geom_gene()
65- # '
66- # ' # link gene clusters with polygon
67- # ' q1 <- q0 + geom_link(aes(fill = cluster_id))
68- # '
69- # ' # link gene clusters with lines
70- # ' q2 <- q0 + geom_link_line(aes(color = cluster_id))
71- # '
72- # ' q1 + q2 + plot_layout(nrow = 1, guides = "collect")
73- # '
7493geom_link_line <- function (
7594 mapping = NULL , data = links(), stat = " identity"
7695 position = " identity" na.rm = FALSE , show.legend = NA , inherit.aes = TRUE ,
7796 ... ) {
78- default_aes <- aes(y = .data $ y , yend = .data $ yend , x = (.data $ x + .data $ xend ) / 2 , xend = (.data $ xmin + .data $ xmax ) / 2 )
97+ default_aes <- aes(y = .data $ y , yend = .data $ yend ,
98+ x = (.data $ x + .data $ xend ) / 2 , xend = (.data $ xmin + .data $ xmax ) / 2 )
7999 mapping <- aes_intersect(mapping , default_aes )
80100
81101 layer(
@@ -88,18 +108,20 @@ geom_link_line <- function(
88108GeomLink <- ggproto(
89109 " GeomLink" Geom ,
90110 default_aes = aes(
91- colour = " honeydew3" fill = " honeydew3" size = 0.5 , linetype = 1 ,
111+ colour = " honeydew3" fill = " honeydew3" linewidth = 0.5 , linetype = 1 ,
92112 alpha = 0.7
93113 ),
94114 required_aes = c(" x" " xend" " y" " xmin" " xmax" " yend"
95- draw_panel = function (self , data , panel_params , coord , linejoin = " mitre" offset = c(0.15 , 0.15 )) {
115+ draw_panel = function (self , data , panel_params , coord , linejoin = " mitre"
116+ offset = c(0.15 , 0.15 ), curve = NA ) {
96117 if (TRUE ) { # !coord$is_linear()) {
97118 aesthetics <- setdiff(
98119 names(data ), c(" x" " xend" " y" " xmin" " xmax" " yend"
99120 )
100121 polys <- lapply(split(data , seq_len(nrow(data ))), function (row ) {
101- poly <- link_to_poly(row $ x , row $ xend , row $ y , row $ xmin , row $ xmax , row $ yend , offset )
102- aes <- vctrs :: data_frame(row [aesthetics ])[rep(1 , 5 ), ]
122+ poly <- link_to_poly(row $ x , row $ xend , row $ y , row $ xmin , row $ xmax ,
123+ row $ yend , offset , curve )
124+ aes <- vctrs :: data_frame(row [aesthetics ])[rep(1 , nrow(poly )), ]
103125 GeomPolygon $ draw_panel(cbind(poly , aes ), panel_params , coord )
104126 })
105127
@@ -109,7 +131,7 @@ GeomLink <- ggproto(
109131 draw_key = draw_key_polygon
110132)
111133
112- link_to_poly <- function (x , xend , y , xmin , xmax , yend , offset ) {
134+ link_to_poly <- function (x , xend , y , xmin , xmax , yend , offset , curve = NA ) {
113135 if (y > yend ) {
114136 y <- y - offset [1 ]
115137 yend <- yend + offset [2 ]
@@ -118,9 +140,35 @@ link_to_poly <- function(x, xend, y, xmin, xmax, yend, offset) {
118140 yend <- yend - offset [1 ]
119141 }
120142
121- vctrs :: data_frame(
122- .name_repair = " minimal"
123- y = c(y , y , yend , yend , y ),
124- x = c(x , xend , xmax , xmin , x )
125- )
143+ if (is.na(curve ) || curve == 0 ) {
144+ vctrs :: data_frame(
145+ .name_repair = " minimal"
146+ y = c(y , yend , yend , y ),
147+ x = c(xend , xmax , xmin , x )
148+ )
149+ } else {
150+ z1 <- sigmoid(xend , y , xmax , yend , curve )
151+ z2 <- sigmoid(xmin , yend , x , y , curve )
152+ vctrs :: data_frame(
153+ .name_repair = " minimal"
154+ y = c(z1 $ y , z2 $ y ),
155+ x = c(z1 $ x , z2 $ x )
156+ )
157+ }
126158}
159+
160+ sigmoid <- function (x1 , y1 , x2 , y2 , curve = 10 , breaks = 100 ) {
161+ # parameter along the segment
162+ t <- seq(0 , 1 , length.out = breaks )
163+ # linear interpolation for y
164+ y <- y1 + t * (y2 - y1 )
165+
166+ # logistic “S” curve between 0 and 1
167+ s <- 1 / (1 + exp(- curve * (t - 0.5 )))
168+ s <- (s - min(s )) / (max(s ) - min(s )) # normalize 0–1
169+
170+ # x follows sigmoid between endpoints
171+ x <- x1 + s * (x2 - x1 )
172+
173+ vctrs :: data_frame(x = x , y = y )
174+ }
0 commit comments