From 232f9b658b6668aa41b429de45ab7e78c1eaade7 Mon Sep 17 00:00:00 2001 From: ShreyaSreeram27 Date: Thu, 21 Aug 2025 13:37:45 -0700 Subject: [PATCH 1/4] adding in patchwork:free functionality and defining new function that uses it --- R/ggsurvfit_align_plots.R | 34 ++++++++++++++++++++++++---------- 1 file changed, 24 insertions(+), 10 deletions(-) diff --git a/R/ggsurvfit_align_plots.R b/R/ggsurvfit_align_plots.R index 75112278..ac98c0eb 100644 --- a/R/ggsurvfit_align_plots.R +++ b/R/ggsurvfit_align_plots.R @@ -1,3 +1,15 @@ +# Internal function to combine plots using patchwork::free() for better alignment +ggsurvfit_combine_plots <- function(main_plot, + risk_table, + free_type = "space", + free_side = "l", + heights = c(6, 1)) { + + patchwork::free(main_plot, type = free_type, side = free_side) / + risk_table + + patchwork::plot_layout(heights = heights) +} + #' Align Plots #' #' Function accepts a list of ggplot objects, and aligns each plot to the same @@ -54,7 +66,6 @@ ggsurvfit_align_plots <- function(pltlist) { suppressWarnings( ggplot2::ggplot_build(pltlist[[i]])$layout$panel_params[[1]]$y.range ) - pltlist[[i]] <- pltlist[[i]] + ggplot2::coord_cartesian( @@ -63,35 +74,40 @@ ggsurvfit_align_plots <- function(pltlist) { expand = FALSE ) } - + + # Use improved patchwork alignment for better results + if (length(pltlist) >= 2) { + ggsurvfit_combine_plots( + main_plot = pltlist[[1]], + risk_table = pltlist[[2]], + free_type = "space", + free_side = "l", + heights = c(6, 1) + ) + } + # turn plots into grobs and determine number of columns plots_grobs <- lapply(pltlist, function(x) suppressWarnings(ggplot2::ggplotGrob(x))) ncols <- lapply(plots_grobs, function(x) dim(x)[[2]]) maxcols <- max(unlist(ncols)) - # Function to add more columns to compensate for eg missing legend .addcols <- function(x) { diffcols <- maxcols - dim(x)[[2]] - if (diffcols > 0) { for (i in seq(1:diffcols)) { x <- gtable::gtable_add_cols(x, widths = grid::unit(1, "null"), pos = 8) } } - x } - ### TableGrob 1 has 11 columns while the others have only 9 because lacking legend+spacer ## => add two columns and then resize plots_grobs_xcols <- lapply(plots_grobs, .addcols) - ### assign max length to ensure alignment max_width <- do.call(grid::unit.pmax, lapply(plots_grobs_xcols, "[[", "widths")) for (i in seq(1, length(plots_grobs_xcols))) { plots_grobs_xcols[[i]]$widths <- max_width } - xcol_widths <- grid::convertWidth( plots_grobs_xcols[[1]]$widths, unitTo = "cm", @@ -103,8 +119,6 @@ ggsurvfit_align_plots <- function(pltlist) { valueOnly = FALSE ) x <- xcol_widths[[4]] - grob_widths[[4]] - plots_grobs_xcols[[1]]$grobs[[13]]$children[[1]]$x <- grid::unit(x, "cm") - plots_grobs_xcols } From 9565227d2af87309a7d2d115a54e9cb5a7f3ca62 Mon Sep 17 00:00:00 2001 From: ShreyaSreeram27 Date: Tue, 26 Aug 2025 10:28:34 -0700 Subject: [PATCH 2/4] new updates to utils and test that to implement patchwork:free whilst maintaining backward compatibility; there was no change done to ggsurvift_align_plots , to ensure minimal user api changea --- R/ggsurvfit_align_plots.R | 36 +++----- R/utils-add_risktable.R | 80 +++++++++++++----- tests/testthat/test-add_risktable.R | 125 +++++++++++++++++++++++++++- 3 files changed, 191 insertions(+), 50 deletions(-) diff --git a/R/ggsurvfit_align_plots.R b/R/ggsurvfit_align_plots.R index ac98c0eb..6b66d8f2 100644 --- a/R/ggsurvfit_align_plots.R +++ b/R/ggsurvfit_align_plots.R @@ -1,15 +1,3 @@ -# Internal function to combine plots using patchwork::free() for better alignment -ggsurvfit_combine_plots <- function(main_plot, - risk_table, - free_type = "space", - free_side = "l", - heights = c(6, 1)) { - - patchwork::free(main_plot, type = free_type, side = free_side) / - risk_table + - patchwork::plot_layout(heights = heights) -} - #' Align Plots #' #' Function accepts a list of ggplot objects, and aligns each plot to the same @@ -66,6 +54,7 @@ ggsurvfit_align_plots <- function(pltlist) { suppressWarnings( ggplot2::ggplot_build(pltlist[[i]])$layout$panel_params[[1]]$y.range ) + pltlist[[i]] <- pltlist[[i]] + ggplot2::coord_cartesian( @@ -74,40 +63,35 @@ ggsurvfit_align_plots <- function(pltlist) { expand = FALSE ) } - - # Use improved patchwork alignment for better results - if (length(pltlist) >= 2) { - ggsurvfit_combine_plots( - main_plot = pltlist[[1]], - risk_table = pltlist[[2]], - free_type = "space", - free_side = "l", - heights = c(6, 1) - ) - } - + # turn plots into grobs and determine number of columns plots_grobs <- lapply(pltlist, function(x) suppressWarnings(ggplot2::ggplotGrob(x))) ncols <- lapply(plots_grobs, function(x) dim(x)[[2]]) maxcols <- max(unlist(ncols)) + # Function to add more columns to compensate for eg missing legend .addcols <- function(x) { diffcols <- maxcols - dim(x)[[2]] + if (diffcols > 0) { for (i in seq(1:diffcols)) { x <- gtable::gtable_add_cols(x, widths = grid::unit(1, "null"), pos = 8) } } + x } + ### TableGrob 1 has 11 columns while the others have only 9 because lacking legend+spacer ## => add two columns and then resize plots_grobs_xcols <- lapply(plots_grobs, .addcols) + ### assign max length to ensure alignment max_width <- do.call(grid::unit.pmax, lapply(plots_grobs_xcols, "[[", "widths")) for (i in seq(1, length(plots_grobs_xcols))) { plots_grobs_xcols[[i]]$widths <- max_width } + xcol_widths <- grid::convertWidth( plots_grobs_xcols[[1]]$widths, unitTo = "cm", @@ -119,6 +103,8 @@ ggsurvfit_align_plots <- function(pltlist) { valueOnly = FALSE ) x <- xcol_widths[[4]] - grob_widths[[4]] + plots_grobs_xcols[[1]]$grobs[[13]]$children[[1]]$x <- grid::unit(x, "cm") + plots_grobs_xcols -} +} \ No newline at end of file diff --git a/R/utils-add_risktable.R b/R/utils-add_risktable.R index ffd3a28e..d51c096e 100644 --- a/R/utils-add_risktable.R +++ b/R/utils-add_risktable.R @@ -1,9 +1,9 @@ -# this function returns a combined primary plot with risktables below. + .construct_risktable <- function(x, times, risktable_stats, stats_label, group, combine_groups, risktable_group, risktable_height, theme, combine_plots, risktable_symbol_args, ...) { - # check iputs ---------------------------------------------------------------- + # check inputs ---------------------------------------------------------------- if (!is.null(risktable_height) && (length(risktable_height) > 1 || !is.numeric(risktable_height) || !dplyr::between(risktable_height, 0, 1))) { cli_abort("The {.code add_risktable(risktable_height=)} argument must be a scalar between 0 and 1.") @@ -22,7 +22,6 @@ df_times <- .prepare_data_for_risk_tables(data = x$data, times = times, combine_groups = combine_groups) - # determine grouping if not specified ---------------------------------------- if (risktable_group == "auto") { risktable_group <- @@ -50,25 +49,62 @@ ... ) - # align all the plots -------------------------------------------------------- - gg_risktable_list_aligned <- - c(list(x), gg_risktable_list) %>% - ggsurvfit_align_plots() - - # combine all plots into single figure --------------------------------------- - if (isFALSE(combine_plots)) return(gg_risktable_list_aligned) - - risktable_n <- length(gg_risktable_list_aligned) - 1 - gg_final <- - gg_risktable_list_aligned %>% - patchwork::wrap_plots( - ncol = 1, - heights = - c(1 - risktable_height, - rep_len(risktable_height / risktable_n, length.out = risktable_n)) - ) + # PATCHWORK::FREE() integration + if (isTRUE(combine_plots)) { + # Apply patchwork::free() to main plot to solve alignment issues + + main_plot_free <- patchwork::free(x, type = "label", side = "l") + + # Combine using patchwork directly + if (length(gg_risktable_list) == 1) { + # Single risk table case + gg_combined <- main_plot_free / gg_risktable_list[[1]] + gg_combined <- gg_combined + patchwork::plot_layout( + heights = c(1 - risktable_height, risktable_height) + ) + } else { + # Multiple risk tables case + gg_combined <- main_plot_free + for (i in seq_along(gg_risktable_list)) { + gg_combined <- gg_combined / gg_risktable_list[[i]] + } + + # Calculate heights + n_tables <- length(gg_risktable_list) + table_height_each <- risktable_height / n_tables + all_heights <- c(1 - risktable_height, rep(table_height_each, n_tables)) + + gg_combined <- gg_combined + patchwork::plot_layout(heights = all_heights) + } + + return(gg_combined) + } - gg_final + # FALLBACK: Use original method when combine_plots = FALSE + # ensures backward compatibility + + # use existing ggsurvfit_align_plots function + plot_list <- c(list(x), gg_risktable_list) + lst_plots <- ggsurvfit_align_plots(plot_list) + + # apply heights using patchwork on the grobs + n_plots <- length(lst_plots) + if (n_plots == 1) { + return(lst_plots[[1]]) + } + + # calculate heights for the grob layout + n_risktables <- n_plots - 1 + risktable_height_each <- risktable_height / n_risktables + + # combine grobs with heights using patchwork::wrap_plots + heights <- c(1 - risktable_height, rep(risktable_height_each, n_risktables)) + + patchwork::wrap_plots( + plotlist = lst_plots, + ncol = 1, + heights = heights + ) } .calculate_risktable_height <- function(risktable_height, risktable_group, risktable_stats, df_times) { @@ -294,4 +330,4 @@ lst_stat_labels_default <- return(TRUE) } FALSE -} +} \ No newline at end of file diff --git a/tests/testthat/test-add_risktable.R b/tests/testthat/test-add_risktable.R index c908574e..f8dfe819 100644 --- a/tests/testthat/test-add_risktable.R +++ b/tests/testthat/test-add_risktable.R @@ -336,12 +336,12 @@ test_that("add_risktable() works with ggsurvfit() `start.time` and negative time test_that("add_risktable() works with multiple survival endpoints (Issue #212)", { - + os_data <- df_lung %>% dplyr::mutate(PARAM = "Overall Survival") pfs_data <- df_lung %>% dplyr::mutate(time = time * 0.7, PARAM = "Progression-Free Survival") combined_data <- dplyr::bind_rows(os_data, pfs_data) - - + + expect_error( p <- survfit2(Surv(time, status) ~ PARAM, data = combined_data) %>% ggsurvfit() + add_risktable(), @@ -350,3 +350,122 @@ test_that("add_risktable() works with multiple survival endpoints (Issue #212)", expect_error(print(p), NA) }) + +test_that("add_risktable() handles large numbers and long labels without overlapping (Issue #230)", { + + # Large patient cohort with descriptive strata labels + set.seed(123) # For reproducible results + + large_cohort_data <- data.frame( + time = c( + # Extended Time Since Surgery group - longer survival times + rexp(800, rate = 0.15), + # Limited Time Since Surgery group - shorter survival times + rexp(1200, rate = 0.25) + ), + status = c( + rbinom(800, 1, 0.6), # 60% event rate for extended group + rbinom(1200, 1, 0.75) # 75% event rate for limited group + ), + surgery_timing = factor(c( + rep("Extended Time Since Surgery", 800), + rep("Limited Time Since Surgery", 1200) + )) + ) + + # Create survfit object with large numbers + sf_large_cohort <- survfit2(Surv(time, status) ~ surgery_timing, data = large_cohort_data) + + # Large numbers at time 0: ~800 and ~1200 patients at risk + expect_error( + p_issue_230 <- sf_large_cohort %>% + ggsurvfit() + + add_risktable(risktable_stats = "n.risk"), + NA + ) + + expect_error(print(p_issue_230), NA) + + # Test with the format from the user's image: "At risk (censored)" + expect_error( + p_issue_230_with_censored <- sf_large_cohort %>% + ggsurvfit() + + add_risktable( + risktable_stats = "{n.risk} ({cum.censor})", + stats_label = "At risk (censored)" + ), + NA + ) + + expect_error(print(p_issue_230_with_censored), NA) + + # Test that the plot actually has large numbers at time 0 + risk_data <- sf_large_cohort %>% tidy_survfit(times = 0) + expect_true(any(risk_data$n.risk >= 500), + info = "Should have large patient numbers at baseline") + + # Test with even longer strata names that would definitely cause issues + very_long_labels_data <- large_cohort_data %>% + dplyr::mutate( + surgery_timing = factor( + surgery_timing, + levels = c("Extended Time Since Surgery", "Limited Time Since Surgery"), + labels = c( + "Extended Time Between Surgery and Treatment Initiation", + "Limited Time Between Surgery and Treatment Initiation" + ) + ) + ) + + sf_very_long <- survfit2(Surv(time, status) ~ surgery_timing, data = very_long_labels_data) + + expect_error( + p_very_long_labels <- sf_very_long %>% + ggsurvfit() + + add_risktable(risktable_stats = "n.risk"), + NA + ) + + expect_error(print(p_very_long_labels), NA) + + # Skip visual tests on CI but include them for local testing + skip_on_ci() + vdiffr::expect_doppelganger("issue-230-large-numbers", p_issue_230) + vdiffr::expect_doppelganger("issue-230-with-censored", p_issue_230_with_censored) + vdiffr::expect_doppelganger("very-long-labels", p_very_long_labels) +}) + +# Additional test specifically for the overlapping issue +test_that("add_risktable() prevents text overlapping with patchwork::free()", { + # Create a scenario guaranteed to cause overlapping without the fix + overlap_data <- data.frame( + time = rexp(2000, 0.1), # Very large cohort + status = rbinom(2000, 1, 0.5), + group = factor(c( + rep("Group with extremely long descriptive name that would cause overlap", 1000), + rep("Another group with very long name causing alignment issues", 1000) + )) + ) + + sf_overlap <- survfit2(Surv(time, status) ~ group, data = overlap_data) + + # This would definitely cause overlapping without patchwork::free() + expect_error( + p_overlap_test <- sf_overlap %>% + ggsurvfit() + + add_risktable(risktable_stats = "n.risk") + + # Force narrow margins to test the alignment fix + theme(plot.margin = margin(0.1, 0.1, 0.1, 0.1, "cm")), + NA + ) + + expect_error(print(p_overlap_test), NA) + + # Test that numbers at time 0 are indeed large (>1000) + baseline_risk <- sf_overlap %>% tidy_survfit(times = 0) + expect_true(all(baseline_risk$n.risk >= 900), + info = "All groups should have large patient numbers") + + skip_on_ci() + vdiffr::expect_doppelganger("overlap-prevention-test", p_overlap_test) +}) From 5755c399cc8cb492d5383717e5d1f73e3a00345b Mon Sep 17 00:00:00 2001 From: ShreyaSreeram27 Date: Tue, 26 Aug 2025 21:00:26 -0700 Subject: [PATCH 3/4] changing type to space --- R/utils-add_risktable.R | 28 ++++++---------------------- 1 file changed, 6 insertions(+), 22 deletions(-) diff --git a/R/utils-add_risktable.R b/R/utils-add_risktable.R index d51c096e..049b065a 100644 --- a/R/utils-add_risktable.R +++ b/R/utils-add_risktable.R @@ -53,7 +53,7 @@ if (isTRUE(combine_plots)) { # Apply patchwork::free() to main plot to solve alignment issues - main_plot_free <- patchwork::free(x, type = "label", side = "l") + main_plot_free <- patchwork::free(x, type = "space", side = "l") # Combine using patchwork directly if (length(gg_risktable_list) == 1) { @@ -81,30 +81,14 @@ } # FALLBACK: Use original method when combine_plots = FALSE - # ensures backward compatibility + # Ensures backward compatibility - return grobs directly - # use existing ggsurvfit_align_plots function plot_list <- c(list(x), gg_risktable_list) - lst_plots <- ggsurvfit_align_plots(plot_list) + lst_plots <- ggsurvfit_align_plots(plot_list) # Returns grobs - # apply heights using patchwork on the grobs - n_plots <- length(lst_plots) - if (n_plots == 1) { - return(lst_plots[[1]]) - } - - # calculate heights for the grob layout - n_risktables <- n_plots - 1 - risktable_height_each <- risktable_height / n_risktables - - # combine grobs with heights using patchwork::wrap_plots - heights <- c(1 - risktable_height, rep(risktable_height_each, n_risktables)) - - patchwork::wrap_plots( - plotlist = lst_plots, - ncol = 1, - heights = heights - ) + # Return grobs as-is for backward compatibility + # Users who set combine_plots = FALSE expect separate grob objects + return(lst_plots) } .calculate_risktable_height <- function(risktable_height, risktable_group, risktable_stats, df_times) { From a2eb6a4e0f2f52fa78b77656a10554e03c876e0a Mon Sep 17 00:00:00 2001 From: ShreyaSreeram27 Date: Thu, 28 Aug 2025 09:25:51 -0700 Subject: [PATCH 4/4] testing --- R/utils-add_risktable.R | 100 +++++++++++++++++++++++++++------------- 1 file changed, 69 insertions(+), 31 deletions(-) diff --git a/R/utils-add_risktable.R b/R/utils-add_risktable.R index 049b065a..6d061f2c 100644 --- a/R/utils-add_risktable.R +++ b/R/utils-add_risktable.R @@ -1,4 +1,4 @@ - +# this function returns a combined primary plot with risktables below. .construct_risktable <- function(x, times, risktable_stats, stats_label, group, combine_groups, risktable_group, risktable_height, theme, combine_plots, @@ -8,20 +8,20 @@ (length(risktable_height) > 1 || !is.numeric(risktable_height) || !dplyr::between(risktable_height, 0, 1))) { cli_abort("The {.code add_risktable(risktable_height=)} argument must be a scalar between 0 and 1.") } - + # build the ggplot to inspect the internals ---------------------------------- plot_build <- suppressWarnings(ggplot2::ggplot_build(x)) - + # if plot is faceted, return plot without risktable -------------------------- if (.is_faceted(plot_build)) { return(structure(x, class = setdiff(class(x), c("ggsurvfit", "ggcuminc")))) } - + # get data to place in risktables -------------------------------------------- times <- times %||% plot_build$layout$panel_params[[1]]$x$breaks df_times <- .prepare_data_for_risk_tables(data = x$data, times = times, combine_groups = combine_groups) - + # determine grouping if not specified ---------------------------------------- if (risktable_group == "auto") { risktable_group <- @@ -31,31 +31,37 @@ TRUE ~ "strata" ) } - + # determine risktable height ------------------------------------------------- risktable_height <- .calculate_risktable_height(risktable_height, risktable_group, risktable_stats, df_times) - + # create list of ggplots, one plot for each risktable ------------------------ df_stat_labels <- .construct_stat_labels(risktable_stats, stats_label) - - gg_risktable_list <- - .create_list_of_gg_risk_tables( - df_times, risktable_stats, times, - df_stat_labels, theme, risktable_group, - color_block_mapping = - .match_strata_level_to_color(plot_build, risktable_group, risktable_symbol_args), - risktable_symbol_args = risktable_symbol_args, - ... - ) - - # PATCHWORK::FREE() integration + + # PATCHWORK::FREE() APPROACH WITH COORDINATE INTEGRATION -------------------- if (isTRUE(combine_plots)) { - # Apply patchwork::free() to main plot to solve alignment issues + # Extract coordinate system from main plot BEFORE risk table construction + main_x_breaks <- plot_build$layout$panel_params[[1]]$x$breaks + main_x_range <- plot_build$layout$panel_params[[1]]$x$range + # Create risk tables WITH coordinate system built in (user's approach) + gg_risktable_list <- + .create_list_of_gg_risk_tables( + df_times, risktable_stats, times, + df_stat_labels, theme, risktable_group, + color_block_mapping = + .match_strata_level_to_color(plot_build, risktable_group, risktable_symbol_args), + risktable_symbol_args = risktable_symbol_args, + x_breaks = main_x_breaks, # Pass coordinate info + x_range = main_x_range, # Pass coordinate info + ... + ) + + # Apply patchwork::free() to main plot (prevents y-axis title shifting) main_plot_free <- patchwork::free(x, type = "space", side = "l") - # Combine using patchwork directly + # Combine using patchwork exactly like the user's successful example if (length(gg_risktable_list) == 1) { # Single risk table case gg_combined <- main_plot_free / gg_risktable_list[[1]] @@ -79,16 +85,39 @@ return(gg_combined) } - - # FALLBACK: Use original method when combine_plots = FALSE - # Ensures backward compatibility - return grobs directly - plot_list <- c(list(x), gg_risktable_list) - lst_plots <- ggsurvfit_align_plots(plot_list) # Returns grobs + # FALLBACK: ORIGINAL METHOD FOR combine_plots = FALSE ----------------------- + # Create risk tables without coordinate integration for backward compatibility + gg_risktable_list <- + .create_list_of_gg_risk_tables( + df_times, risktable_stats, times, + df_stat_labels, theme, risktable_group, + color_block_mapping = + .match_strata_level_to_color(plot_build, risktable_group, risktable_symbol_args), + risktable_symbol_args = risktable_symbol_args, + # No coordinate parameters for original method + ... + ) + + # align all the plots -------------------------------------------------------- + gg_risktable_list_aligned <- + c(list(x), gg_risktable_list) %>% + ggsurvfit_align_plots() + + # combine all plots into single figure --------------------------------------- + if (isFALSE(combine_plots)) return(gg_risktable_list_aligned) - # Return grobs as-is for backward compatibility - # Users who set combine_plots = FALSE expect separate grob objects - return(lst_plots) + risktable_n <- length(gg_risktable_list_aligned) - 1 + gg_final <- + gg_risktable_list_aligned %>% + patchwork::wrap_plots( + ncol = 1, + heights = + c(1 - risktable_height, + rep_len(risktable_height / risktable_n, length.out = risktable_n)) + ) + + gg_final } .calculate_risktable_height <- function(risktable_height, risktable_group, risktable_stats, df_times) { @@ -182,7 +211,9 @@ lst_stat_labels_default <- df_stat_labels, theme, risktable_group, color_block_mapping, - risktable_symbol_args, ...) { + risktable_symbol_args, + x_breaks = NULL, + x_range = NULL, ...) { grouping_variable <- switch(risktable_group, "strata" = "strata", @@ -244,6 +275,13 @@ lst_stat_labels_default <- ) + rlang::inject(ggplot2::geom_text(!!!geom_text_args)) + # Apply coordinate system during construction + if (!is.null(x_breaks) && !is.null(x_range)) { + gg <- gg + + ggplot2::scale_x_continuous(breaks = x_breaks) + + ggplot2::coord_cartesian(xlim = x_range, expand = FALSE, clip = "off") + } + # apply styling to the plot gg + ggtitle_group_lbl + @@ -314,4 +352,4 @@ lst_stat_labels_default <- return(TRUE) } FALSE -} \ No newline at end of file +}