Merge pull request #461 from teunbrand/main

Compatibility with incoming version of ggplot2

R/add_highlight.R

@@ -84,26 +84,32 @@ add_highlight.ggsurvfit <- function(gg = NULL,
 
   # Extract names of strata objects
   gg_gb <- ggplot2::ggplot_build(gg)
-  gg_gtable <- ggplot2::ggplot_gtable(gg_gb)
-  gg_guidebox_id <- base::which(base::sapply(
-    gg_gtable$grobs,
-    function(x) x$name
-  ) == "guide-box")
-  gg_table_grob <- gg_gtable$grobs[[gg_guidebox_id]]$grobs[[1]]
 
-  # Get IDs of elements containing strata labels
-  strata_label_ids <- base::grep("label", gg_table_grob$layout$name)
+  if ("get_guide_data" %in% getNamespaceExports("ggplot2")) {
+    get_guide_data <- get("get_guide_data", asNamespace("ggplot2"))
+    strata_labels  <- get_guide_data(gg_gb, "colour")$.label
+  } else {
+    gg_gtable <- ggplot2::ggplot_gtable(gg_gb)
+    gg_guidebox_id <- base::which(base::sapply(
+      gg_gtable$grobs,
+      function(x) x$name
+    ) == "guide-box")
+    gg_table_grob <- gg_gtable$grobs[[gg_guidebox_id]]$grobs[[1]]
 
-  extract_strata_name_by_id <- function(gg_table_grob, id) {
-    label <- gg_table_grob$grobs[[id]]$children[[1]]$children[[1]]$label
+    # Get IDs of elements containing strata labels
+    strata_label_ids <- base::grep("label", gg_table_grob$layout$name)
 
-    return(label)
-  }
+    extract_strata_name_by_id <- function(gg_table_grob, id) {
+      label <- gg_table_grob$grobs[[id]]$children[[1]]$children[[1]]$label
+
+      return(label)
+    }
 
-  strata_labels <- base::sapply(strata_label_ids,
-    extract_strata_name_by_id,
-    gg_table_grob = gg_table_grob
-  )
+    strata_labels <- base::sapply(strata_label_ids,
+                                  extract_strata_name_by_id,
+                                  gg_table_grob = gg_table_grob
+    )
+  }
 
   base::sapply(c(strata), function(s) {
     if (!(s %in% strata_labels)) {

tests/testthat/helper.R

@@ -207,6 +207,11 @@ get_legend_title <- function(gg) {
   ggb <- ggplot2::ggplot_build(gg)
   ggt <- ggplot2::ggplot_gtable(ggb)
 
+  if (inherits(ggb$plot$guides, "Guides")) {
+    params <- ggb$plot$guides$get_params(1)
+    return(params$title)
+  }
+
   legend_grob_id <- which(sapply(ggt$grobs, function(x) x$name) == "guide-box")
   legend_grob <- ggt$grobs[[legend_grob_id]]
 

tests/testthat/test-utils_visR.R

@@ -92,6 +92,10 @@ testthat::test_that("T1.3 An error when a list containing non-`ggplot` objects i
 testthat::context("utils_visr - T2. `align_plots()` aligns multiple `ggplot` objects, taking the legend into account.")
 
 testthat::test_that("T2.1 Columns are added to the grob-converted plot.", {
+  # From ggplot2 3.5.0 onwards ggplots have stable gtable dimensions with
+  # regards to legend placement
+  skip_if(utils::packageVersion("ggplot2") >= "3.5.0")
+
   gg_sex <- adtte %>%
     visR::estimate_KM("SEX") %>%
     visR::visr()