diff --git a/R/add_highlight.R b/R/add_highlight.R index 4b03b5e8..771d28d9 100644 --- a/R/add_highlight.R +++ b/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)) { diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R index f8ccd161..3ea11c57 100644 --- a/tests/testthat/helper.R +++ b/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]] diff --git a/tests/testthat/test-utils_visR.R b/tests/testthat/test-utils_visR.R index 3a62d217..85f1d187 100644 --- a/tests/testthat/test-utils_visR.R +++ b/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()