Browse code

Merge pull request #523 from xiangpin/master

fix a bug of roundrect layout to support coord_flip and label of geom_tiplab was mapped to other variable in mapping contains when as_ylab is TRUE

Guangchuang Yu authored on 12/08/2022 15:49:48 • GitHub committed on 12/08/2022 15:49:48
Showing2 changed files

... ...
@@ -204,6 +204,9 @@ GeomCurvelink <- ggproto("GeomCurvelink", GeomSegment,
204 204
         trans$curvature <- curvature
205 205
     }else{
206 206
         trans <- coord$transform(data, panel_params)
207
+        if (inherits(coord, 'CoordFlip')){ 
208
+            trans$curvature <- -1 * trans$curvature
209
+        }
207 210
     }
208 211
     arrow.fill <- arrow.fill %|||% trans$colour
209 212
 
... ...
@@ -225,6 +228,7 @@ GeomCurvelink <- ggproto("GeomCurvelink", GeomSegment,
225 228
   }
226 229
 )
227 230
 
231
+
228 232
 # for inward curve lines
229 233
 generate_curvature <- function(starttheta, endtheta, hratio, ncp){
230 234
     flag <- endtheta - starttheta
... ...
@@ -224,11 +224,11 @@ ggplot_add.tiplab <- function(object, plot, object_name) {
224 224
         ly <- do.call(geom_tiplab_rectangular, object)
225 225
         plot <- ggplot_add(ly, plot, object_name)
226 226
         object$size <- fontsize
227
-        object$mapping <- NULL
227
+        #object$mapping <- NULL
228 228
         object$align <- NULL
229 229
         object$linetype <- NULL
230 230
         object$linesize <- NULL
231
-        object$geom <- NULL
231
+        #object$geom <- NULL
232 232
         object$offset <- NULL
233 233
         object$nodelab <- NULL
234 234
         res <- ggplot_add.tiplab_ylab(object, plot, object_name)
... ...
@@ -259,11 +259,30 @@ ggplot_add.tiplab_ylab <- function(object, plot, object_name) {
259 259
     }
260 260
 
261 261
     df <- plot$data
262
-    df <- df[df$isTip, ]
262
+    if ('label' %in% names(object$mapping)){
263
+        if (object$geom == 'text'){
264
+            xx <- do.call('geom_text', list(mapping=object$mapping))
265
+            xx$computed_mapping <- c(xx$mapping, plot$mapping[setdiff(names(plot$mapping), names(xx$mapping))])
266
+            class(xx$computed_mapping) <- "uneval"
267
+            if (!is.null(object$data)){
268
+                df <- object$data
269
+            }else{
270
+                df <- df[df$isTip,]
271
+            }
272
+            df <- suppressWarnings(xx$compute_aesthetics(data=df, plot=plot))
273
+        }else{
274
+            message('The geom is not text, as_ylab will use original tip labels of tree')
275
+            df <- df[df$isTip, ]
276
+        }
277
+    }else{
278
+        df <- df[df$isTip, ]
279
+    }
263 280
     yscale <- scale_y_continuous(breaks = df$y, labels = df$label,
264 281
                                  position = object$position, expand = expansion(0, 0.6))
265 282
 
266 283
     object$position <- NULL
284
+    object$mapping <- NULL
285
+    object$geom <- NULL
267 286
     object$node <- NULL
268 287
     ytext <- do.call(element_text, object)
269 288