From e9a23c18bb30e3c5d304879b8e34ca3d1127186a Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Sat, 3 Sep 2022 10:18:06 +0200 Subject: [PATCH 01/17] Removed revdep folder --- revdep/.gitignore | 1 - revdep/check.R | 5 ----- 2 files changed, 6 deletions(-) delete mode 100644 revdep/.gitignore delete mode 100644 revdep/check.R diff --git a/revdep/.gitignore b/revdep/.gitignore deleted file mode 100644 index 530234e..0000000 --- a/revdep/.gitignore +++ /dev/null @@ -1 +0,0 @@ -**/ diff --git a/revdep/check.R b/revdep/check.R deleted file mode 100644 index cfa9e6e..0000000 --- a/revdep/check.R +++ /dev/null @@ -1,5 +0,0 @@ -library("devtools") - -res <- revdep_check() -revdep_check_save_summary(res) -revdep_check_save_logs(res) From 76992e4aa169553f24cb410076fb0ca9b7d153f9 Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Sat, 3 Sep 2022 10:23:10 +0200 Subject: [PATCH 02/17] Changed to native R pipe --- vignettes/forestplot.Rmd | 88 ++++++++++++++++++++-------------------- 1 file changed, 44 insertions(+), 44 deletions(-) diff --git a/vignettes/forestplot.Rmd b/vignettes/forestplot.Rmd index 5226b35..0dac2cc 100644 --- a/vignettes/forestplot.Rmd +++ b/vignettes/forestplot.Rmd @@ -70,7 +70,7 @@ tabletext <- cbind(c("", "Study", "Auckland", "Block", "Doran", "Gamsu", "Morris c("Deaths", "(placebo)", "60", "5", "11", "20", "7", "7", "10", NA, NA), c("", "OR", "0.58", "0.16", "0.25", "0.70", "0.35", "0.14", "1.02", NA, "0.53")) -cochrane_from_rmeta %>% +cochrane_from_rmeta |> forestplot(labeltext = tabletext, is.summary = c(rep(TRUE, 2), rep(FALSE, 8), TRUE), clip = c(0.1, 2.5), @@ -115,7 +115,7 @@ cochrane_output_df <- bind_rows(header, empty_row, summary) -cochrane_output_df %>% +cochrane_output_df |> forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), is.summary = summary, clip = c(0.1, 2.5), @@ -132,7 +132,7 @@ Summary lines The same as above but with lines based on the summary elements and also using a direct call with matrix input instead of relying on dplyr. ```{r, fig.height=4, fig.width=8, message=FALSE} -cochrane_output_df %>% +cochrane_output_df |> forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), is.summary = summary, clip = c(0.1, 2.5), @@ -146,7 +146,7 @@ cochrane_output_df %>% We can also choose what lines we want by providing a list where the name is the line number affected, in the example below 3rd line and 11th counting the first line to be above the first row (not that there is an empty row before summary): ```{r, fig.height=4, fig.width=8, message=FALSE} -cochrane_output_df %>% +cochrane_output_df |> forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), is.summary = summary, clip = c(0.1, 2.5), @@ -165,7 +165,7 @@ Adding vertices to the whiskers For marking the start/end points it is common to add a vertical line at the end of each whisker. In forestplot you simply specify the `vertices` argument: ```{r, fig.height=4, fig.width=8, message=FALSE} -cochrane_output_df %>% +cochrane_output_df |> forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), is.summary = summary, hrzl_lines = list("3" = gpar(lty = 2), @@ -185,7 +185,7 @@ Positioning the graph element You can also choose to have the graph positioned within the text table by specifying the `graph.pos` argument: ```{r} -cochrane_output_df %>% +cochrane_output_df |> forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), is.summary = summary, graph.pos = 4, @@ -204,15 +204,15 @@ If we present a regression output it is sometimes convenient to have non-ascii l ```{r} data(dfHRQoL) -dfHRQoL <- dfHRQoL %>% mutate(est = sprintf("%.2f", mean), .after = labeltext) +dfHRQoL <- dfHRQoL |> mutate(est = sprintf("%.2f", mean), .after = labeltext) clrs <- fpColors(box = "royalblue",line = "darkblue", summary = "royalblue") -tabletext <- list(c(NA, dfHRQoL %>% filter(group == "Sweden") %>% pull(labeltext)), - append(list(expression(beta)), dfHRQoL %>% filter(group == "Sweden") %>% pull(est))) +tabletext <- list(c(NA, dfHRQoL |> filter(group == "Sweden") |> pull(labeltext)), + append(list(expression(beta)), dfHRQoL |> filter(group == "Sweden") |> pull(est))) -dfHRQoL %>% - filter(group == "Sweden") %>% - bind_rows(tibble(mean = NA_real_), .) %>% +dfHRQoL |> + filter(group == "Sweden") |> + bind_rows(tibble(mean = NA_real_), .) |> forestplot(labeltext = tabletext, col = clrs, xlab = "EQ-5D index") @@ -229,8 +229,8 @@ font <- "mono" if (grepl("Ubuntu", Sys.info()["version"])) { font <- "HersheyGothicEnglish" } -dfHRQoL %>% - filter(group == "Sweden") %>% +dfHRQoL |> + filter(group == "Sweden") |> forestplot(labeltext = c(labeltext, est), txt_gp = fpTxtGp(label = gpar(fontfamily = font)), col = clrs, @@ -240,8 +240,8 @@ dfHRQoL %>% There is also the possibility of being selective in gp-styles: ```{r} -dfHRQoL %>% - filter(group == "Sweden") %>% +dfHRQoL |> + filter(group == "Sweden") |> forestplot(labeltext = c(labeltext, est), txt_gp = fpTxtGp(label = list(gpar(fontfamily = font), gpar(fontfamily = "", @@ -258,8 +258,8 @@ Confidence intervals Clipping the interval is convenient for uncertain estimates in order to retain the resolution for those of more interest. The clipping simply adds an arrow to the confidence interval, see the bottom estimate below: ```{r} -dfHRQoL %>% - filter(group == "Sweden") %>% +dfHRQoL |> + filter(group == "Sweden") |> forestplot(labeltext = c(labeltext, est), clip = c(-.1, Inf), col = clrs, @@ -272,8 +272,8 @@ Custom box size You can force the box size to a certain size through the `boxsize` argument. ```{r} -dfHRQoL %>% - filter(group == "Sweden") %>% +dfHRQoL |> + filter(group == "Sweden") |> forestplot(labeltext = c(labeltext, est), boxsize = 0.2, clip = c(-.1, Inf), @@ -297,8 +297,8 @@ pushViewport(viewport(layout = grid.layout(nrow = 1, ) pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 1)) -dfHRQoL %>% - filter(group == "Sweden") %>% +dfHRQoL |> + filter(group == "Sweden") |> forestplot(labeltext = c(labeltext, est), title = "Sweden", clip = c(-.1, Inf), @@ -313,8 +313,8 @@ upViewport() pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 3)) -dfHRQoL %>% - filter(group == "Denmark") %>% +dfHRQoL |> + filter(group == "Denmark") |> forestplot(labeltext = c(labeltext, est), title = "Denmark", clip = c(-.1, Inf), @@ -331,10 +331,10 @@ Multiple confidence bands When combining similar outcomes for the same exposure I've found it useful to use multiple bands per row. This efficiently increases the data-ink ratio while making the comparison between the two bands trivial. The first time I've used this was in [my paper](https://doi.org/10.1186/1471-2474-14-316) comparing Swedish with Danish patients 1 year after total hip arthroplasty. Here the clipping also becomes obvious as the Danish sample was much smaller, resulting in wider confidence intervals. With the new *2.0* dplyr adapted version we can merge the groups into one table and group ```{r} -dfHRQoL %>% - group_by(group) %>% +dfHRQoL |> + group_by(group) |> forestplot(clip = c(-.1, 0.075), - shapes_gp = fpShapesGp(box = c("blue", "darkred") %>% lapply(function(x) gpar(fill = x, col = "#555555")), + shapes_gp = fpShapesGp(box = c("blue", "darkred") |> lapply(function(x) gpar(fill = x, col = "#555555")), default = gpar(vertices = TRUE)), ci.vertices = TRUE, ci.vertices.height = 0.05, @@ -349,13 +349,13 @@ Estimate indicator You can choose between a number of different estimate indicators. Using the example above we can set the Danish results to circles. ```{r} -dfHRQoL %>% - group_by(group) %>% +dfHRQoL |> + group_by(group) |> forestplot(fn.ci_norm = c(fpDrawNormalCI, fpDrawCircleCI), boxsize = .25, # We set the box size to better visualize the type line.margin = .1, # We need to add this to avoid crowding clip = c(-.125, 0.075), - shapes_gp = fpShapesGp(box = c("blue", "darkred") %>% lapply(function(x) gpar(fill = x, col = "#555555")), + shapes_gp = fpShapesGp(box = c("blue", "darkred") |> lapply(function(x) gpar(fill = x, col = "#555555")), default = gpar(vertices = TRUE)), xlab = "EQ-5D index") ``` @@ -368,8 +368,8 @@ Choosing line type You can furthermore choose between all available line types through the *lty.ci* that can also be specified element specific. ```{r} -dfHRQoL %>% - group_by(group) %>% +dfHRQoL |> + group_by(group) |> forestplot(fn.ci_norm = c(fpDrawNormalCI, fpDrawCircleCI), boxsize = .25, # We set the box size to better visualize the type line.margin = .1, # We need to add this to avoid crowding @@ -386,8 +386,8 @@ Legends Legends are automatically added when using `group_by` but we can also control them directly through the `legend` argument: ```{r} -dfHRQoL %>% - group_by(group) %>% +dfHRQoL |> + group_by(group) |> forestplot(legend = c("Swedes", "Danes"), fn.ci_norm = c(fpDrawNormalCI, fpDrawCircleCI), boxsize = .25, # We set the box size to better visualize the type @@ -400,8 +400,8 @@ dfHRQoL %>% This can be further customized by setting the `legend_args` argument using the `fpLegend` function: ```{r} -dfHRQoL %>% - group_by(group) %>% +dfHRQoL |> + group_by(group) |> forestplot(legend = c("Swedes", "Danes"), legend_args = fpLegend(pos = list(x = .85, y = 0.25), gp = gpar(col = "#CCCCCC", fill = "#F9F9F9")), @@ -420,8 +420,8 @@ Ticks and grids If the automated ticks don't match the desired once it is easy to change these using the xticks argument: ```{r} -dfHRQoL %>% - group_by(group) %>% +dfHRQoL |> + group_by(group) |> forestplot(fn.ci_norm = c(fpDrawNormalCI, fpDrawCircleCI), boxsize = .25, # We set the box size to better visualize the type line.margin = .1, # We need to add this to avoid crowding @@ -438,8 +438,8 @@ xticks <- seq(from = -.1, to = .05, by = 0.025) xtlab <- rep(c(TRUE, FALSE), length.out = length(xticks)) attr(xticks, "labels") <- xtlab -dfHRQoL %>% - group_by(group) %>% +dfHRQoL |> + group_by(group) |> forestplot(fn.ci_norm = c(fpDrawNormalCI, fpDrawCircleCI), boxsize = .25, # We set the box size to better visualize the type line.margin = .1, # We need to add this to avoid crowding @@ -454,8 +454,8 @@ to make it easier to see the tick marks. This can be useful in non-inferiority or equivalence studies. You can do this through the `grid` argument: ```{r} -dfHRQoL %>% - group_by(group) %>% +dfHRQoL |> + group_by(group) |> forestplot(fn.ci_norm = c(fpDrawNormalCI, fpDrawCircleCI), boxsize = .25, # We set the box size to better visualize the type line.margin = .1, # We need to add this to avoid crowding @@ -470,8 +470,8 @@ dfHRQoL %>% You can easily customize both what grid lines to use and what type they should be by adding the gpar object to a vector: ```{r} -dfHRQoL %>% - group_by(group) %>% +dfHRQoL |> + group_by(group) |> forestplot(fn.ci_norm = c(fpDrawNormalCI, fpDrawCircleCI), boxsize = .25, # We set the box size to better visualize the type line.margin = .1, # We need to add this to avoid crowding From 66d07a5ba4534f5e5b5b79f0d1173ec8a1d7bfc6 Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Sun, 4 Sep 2022 00:02:36 +0200 Subject: [PATCH 03/17] * Fixed bug with how grouped data frames are processed and presented. * Expressions are now allowed in data.frame tidyverse input * Moved to native R-pipe operator (|> instead of %>%) --- DESCRIPTION | 12 +- NAMESPACE | 1 - NEWS.md | 6 + R/assertAndRetrieveTidyValue.R | 4 +- R/forestplot.data.frame.R | 2 +- R/forestplot.grouped_df.R | 169 +++++++++++++----- R/forestplot_helpers.R | 17 +- inst/examples/forestplot_example.R | 49 ++--- man/forestplot.Rd | 49 ++--- .../test-forestplot_1_compatibility.R | 6 +- tests/testthat/test-inputs.R | 6 +- tests/vtest_from_vignette.R | 114 ++++++++---- vignettes/forestplot.Rmd | 2 +- 13 files changed, 267 insertions(+), 170 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 5af3a06..c5235dc 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,5 +1,5 @@ Package: forestplot -Version: 2.0.2 +Version: 2.1.0 Title: Advanced Forest Plot Using 'grid' Graphics Authors@R: c(person(given = "Max", family = "Gordon", @@ -23,19 +23,21 @@ Biarch: yes Depends: R (>= 3.5.0), grid, - magrittr, checkmate Suggests: - testthat, abind, + dplyr, knitr, + purrr, rmarkdown, rmeta, - dplyr, + testthat, + tibble, tidyr, + tidyselect, rlang Encoding: UTF-8 NeedsCompilation: no VignetteBuilder: knitr Roxygen: list() -RoxygenNote: 7.1.1 +RoxygenNote: 7.2.1 diff --git a/NAMESPACE b/NAMESPACE index 5903b5f..10c0838 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -20,7 +20,6 @@ export(fpTxtGp) export(getTicks) export(prGetShapeGp) import(grid) -import(magrittr) importFrom(checkmate,assert) importFrom(checkmate,assert_class) importFrom(checkmate,assert_matrix) diff --git a/NEWS.md b/NEWS.md index 58043b6..7b8c094 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,11 @@ NEWS for the forestplot package +Changes for 2.1.0 +----------------- +* Fixed bug with how grouped data frames are processed and presented. +* Expressions are now allowed in data.frame tidyverse input +* Moved to native R-pipe operator (|> instead of %>%) + Changes for 2.0.2 ----------------- * Fixed case when all rows are summaries (Thanks Christian Röver) diff --git a/R/assertAndRetrieveTidyValue.R b/R/assertAndRetrieveTidyValue.R index 5e39e7b..674509b 100644 --- a/R/assertAndRetrieveTidyValue.R +++ b/R/assertAndRetrieveTidyValue.R @@ -24,7 +24,7 @@ assertAndRetrieveTidyValue <- function(x, stop( "You have not provided an argument", " and the data frame does not have a '", name, "' column: ", - names(x) %>% paste(collapse = ", ") + names(x) |> paste(collapse = ", ") ) } return(structure(value, tidyFormat = TRUE)) @@ -33,7 +33,7 @@ assertAndRetrieveTidyValue <- function(x, # We are one-caller removed from the original call so we need to # do this nasty hack to get the parameter of the parent function orgName <- eval(substitute(substitute(value)), envir = parent.frame()) - tryCatch(dplyr::select(x, {{ orgName }}) %>% structure(tidyFormat = TRUE), + tryCatch(dplyr::select(x, {{ orgName }}) |> structure(tidyFormat = TRUE), error = function(e) { return(structure(value, tidyFormat = FALSE diff --git a/R/forestplot.data.frame.R b/R/forestplot.data.frame.R index 5d5b6f8..dcaa353 100644 --- a/R/forestplot.data.frame.R +++ b/R/forestplot.data.frame.R @@ -21,7 +21,7 @@ forestplot.data.frame <- function(x, mean, lower, upper, labeltext, is.summary, if (!missing(is.summary)) { sumid <- substitute(is.summary) - is.summary <- tryCatch(x %>% dplyr::pull({{ sumid }}) %>% sapply(function(x) ifelse(is.na(x), FALSE, x)), + is.summary <- tryCatch(x |> dplyr::pull({{ sumid }}) |> sapply(function(x) ifelse(is.na(x), FALSE, x)), error = function(e) is.summary ) } else { diff --git a/R/forestplot.grouped_df.R b/R/forestplot.grouped_df.R index 550d951..c06e443 100644 --- a/R/forestplot.grouped_df.R +++ b/R/forestplot.grouped_df.R @@ -3,7 +3,9 @@ #' @export forestplot.grouped_df <- function(x, labeltext, mean, lower, upper, legend, is.summary, ...) { safeLoadPackage("dplyr") + safeLoadPackage("tidyr") safeLoadPackage("rlang") + safeLoadPackage("tidyselect") groups <- attr(x, "groups") if (missing(mean)) { @@ -29,66 +31,135 @@ forestplot.grouped_df <- function(x, labeltext, mean, lower, upper, legend, is.s } else { lblid <- substitute(labeltext) } - ret <- tryCatch(suppressMessages(x %>% dplyr::select({{ lblid }})), - error = function(e) e - ) - if (inherits(ret, "error")) { - # Note, we re-throw the original error if it fails - ret <- tryCatch(labeltext, error = function(e) stop(ret)) + + if (!missing(is.summary)) { + sumid <- substitute(is.summary) + is.summary <- tryCatch(x |> dplyr::pull({{ sumid }}) |> sapply(function(x) ifelse(is.na(x), FALSE, x)), + error = function(e) is.summary) } else { - # Remove the group variable - ret <- ret %>% - tidyr::nest() %>% - dplyr::pull(data) %>% - Reduce(function(x, y) { - if (nrow(x) != nrow(y)) { - stop("The groups must be identical in the number of rows, check your") - } - for (col_no in 1:ncol(x)) { - x[[col_no]] <- apply(cbind(x[[col_no]], y[[col_no]]), MARGIN = 1, unique) %>% - sapply(paste, collapse = ", ") - } - x - }, .) + is.summary <- FALSE } - labeltext <- ret + groups <- attr(x, "groups") |> + dplyr::select(-.rows & where(\(col) length(unique(col)) > 1)) |> + colnames() - estimates <- list( - mean = x %>% dplyr::pull({{ mean }}), - lower = x %>% dplyr::pull({{ lower }}), - upper = x %>% dplyr::pull({{ upper }}) - ) - estimates <- sapply(estimates, - function(est) { - suppressMessages(groups$.rows %>% - lapply(function(row_numbers) est[row_numbers]) %>% - dplyr::bind_cols() %>% - as.matrix()) - }, - simplify = FALSE - ) + # Convert into a clean dataset + core_data <- x |> + dplyr::ungroup() |> + dplyr::select({{ lblid }}, + mean = {{ mean }}, + lower = {{ lower }}, + upper = {{ upper }}) |> + dplyr::bind_cols(x |> + tidyr::unite(".fp_groups", dplyr::all_of(groups), sep = " > ") |> + tidyr::unite(".fp_labels", {{lblid}}, sep = " > ") |> + dplyr::select(dplyr::starts_with(".fp"))) |> + dplyr::group_by(.fp_groups) + if (length(is.summary) %in% c(1, nrow(core_data))) { + core_data <- dplyr::mutate(core_data, is.summary = is.summary) + is.summary <- NULL + } - if (missing(legend)) { - legend <- groups %>% - dplyr::select(-.rows) %>% - apply(MARGIN = 1, function(x) paste(x, collapse = ", ")) + all_labels <- core_data |> + tidyr::nest() |> + dplyr::pull(data) |> + lapply(\(x) x$.fp_labels) |> + unlist() |> + unique() + + # Check for bad data assumptions + bad_rows <- core_data |> + dplyr::mutate(level = sapply(.fp_labels, \(lbl) which(all_labels == lbl)[[1]])) |> + dplyr::filter(level > dplyr::lead(level)) + if (nrow(bad_rows) > 0) { + stop("There are seem be invalid the labels: ", bad_rows$.fp_labels |> paste(collapse = ", "), + "\n appear in the wrong position.") } - if (!missing(is.summary)) { - sumid <- substitute(is.summary) - is.summary <- tryCatch(x %>% dplyr::pull({{ sumid }}) %>% sapply(function(x) ifelse(is.na(x), FALSE, x)), - error = function(e) is.summary - ) - } else { - is.summary <- FALSE + bad_rows <- core_data |> + dplyr::group_by(.fp_groups, .fp_labels) |> + dplyr::summarise(n = dplyr::n(), .groups = "drop") |> + dplyr::filter(n > 1) + if (nrow(bad_rows) > 0) { + stop("There are seem be non-unique labels: ", bad_rows$.fp_labels |> paste(collapse = ", ")) + } + + # Add missing rows to those groups that don't have the given category + fixed_data <- core_data |> + tidyr::nest() |> + dplyr::mutate(data = lapply(data, function(df) { + for (i in 1:length(all_labels)) { + if (df$.fp_labels[i] != all_labels[i]) { + new_row <- core_data |> + dplyr::ungroup() |> + dplyr::select({{lblid}}, .fp_labels) |> + dplyr::filter(.fp_labels == all_labels[i]) |> + dplyr::distinct(.fp_labels, .keep_all = TRUE) + + df <- tibble::add_row(df, + new_row, + .before = i) + } + } + return(df) + })) |> + tidyr::unnest(cols = data) + + if (!is.null(is.summary)) { + fixed_is.summary <- rep(is.summary, times = nrow(attr(fixed_data, "groups"))) + if (length(fixed_is.summary) != nrow(fixed_data)) { + stop("Expected is.summary to have the length ", fixed_data |> dplyr::filter(.fp_groups == .fp_groups[1]) |> nrow(), + " but got instead length of ", length(is.summary), + ". Note that you may also provide length of 1 or the entire initial data size.") + } + fixed_data$is.summary <- fixed_is.summary } + if (missing(legend)) { + legend <- attr(fixed_data, "groups") |> + dplyr::select(-.rows) |> + tidyr::unite(col = "legend", dplyr::everything(), sep = " > ") |> + purrr::pluck("legend") + } + + # Retrieve the final data for the forestplot.default + labeltext <- fixed_data |> + dplyr::ungroup() |> + dplyr::filter(.fp_groups == .fp_groups[1]) |> + dplyr::select({{lblid}}) |> + # The list is important as the labeltext can contain expressions + # see forestplot example + as.list() + + is.summary <- fixed_data |> + dplyr::ungroup() |> + dplyr::filter(.fp_groups == .fp_groups[1]) |> + purrr::pluck("is.summary") + + # Convert estimates to two-dimensional matrices + estimates <- sapply(c("mean", "lower", "upper"), + \(n) fixed_data[[n]] |> + (\(raw_data) + lapply(attr(fixed_data, "groups")$.rows, + \(row_numbers) raw_data[row_numbers]))() |> + (\(cols) { + names(cols) <- attr(fixed_data, "groups")$.fp_groups + suppressMessages(dplyr::bind_cols(cols)) + })() |> + as.matrix(), + simplify = FALSE) + forestplot.default( - labeltext = labeltext, mean = estimates$mean, lower = estimates$lower, upper = estimates$upper, legend = legend, - is.summary = is.summary, ... + labeltext = labeltext, + mean = estimates$mean, + lower = estimates$lower, + upper = estimates$upper, + legend = legend, + is.summary = is.summary, + ... ) } -globalVariables(c("data", ".", ".rows")) +globalVariables(c("data", ".rows", ".fp_labels", ".fp_groups", "n", "level", "where")) diff --git a/R/forestplot_helpers.R b/R/forestplot_helpers.R index 7449ce5..a6fef72 100644 --- a/R/forestplot_helpers.R +++ b/R/forestplot_helpers.R @@ -148,7 +148,6 @@ prDefaultGp <- function(col, lwd, lty) { #' @param vertices_gp A \code{\link[grid]{gpar}} for drawing the vertices. #' unspecified attributes in vertices_gp default to line_gp. #' @keywords internal -#' @import magrittr #' @importFrom grid gpar #' @return \code{void} prFpDrawLine <- function(lower_limit, upper_limit, clr.line, lwd, lty, y.offset, @@ -256,7 +255,7 @@ prFpDrawLine <- function(lower_limit, upper_limit, clr.line, lwd, lty, y.offset, y_mm - vertices.height_mm ), "mm" - ) %>% + ) |> convertY("npc") ) gp_list$lty <- 1 @@ -268,7 +267,7 @@ prFpDrawLine <- function(lower_limit, upper_limit, clr.line, lwd, lty, y.offset, x - unit(arrow_length, "mm"), x, x - unit(arrow_length, "mm") - ) %>% + ) |> convertX("npc") arrow_args$x <- x do.call(grid.lines, arrow_args) @@ -280,7 +279,7 @@ prFpDrawLine <- function(lower_limit, upper_limit, clr.line, lwd, lty, y.offset, x + unit(arrow_length, "mm"), x, x + unit(arrow_length, "mm") - ) %>% + ) |> convertX("npc") arrow_args$x <- x do.call(grid.lines, arrow_args) @@ -1022,7 +1021,7 @@ fpTxtGp <- function(label, ) if (!missing(title)) { - if (class(title) != "gpar") { + if (!inherits(title, "gpar")) { stop("You can only provide arguments from gpar() to the function") } ret$title <- prGparMerge( @@ -1038,7 +1037,7 @@ fpTxtGp <- function(label, ) if (!missing(xlab)) { - if (class(xlab) != "gpar") { + if (!inherits(xlab, "gpar")) { stop("You can only provide arguments from gpar() to the function") } ret$xlab <- prGparMerge( @@ -1054,7 +1053,7 @@ fpTxtGp <- function(label, ) if (!missing(ticks)) { - if (class(ticks) != "gpar") { + if (!inherits(ticks, "gpar")) { stop("You can only provide arguments from gpar() to the function") } ret$ticks <- prGparMerge( @@ -1072,7 +1071,7 @@ fpTxtGp <- function(label, attr(ret$legend, "txt_dim") <- 0 if (!missing(legend)) { - if (class(legend) != "gpar") { + if (!inherits(legend, "gpar")) { stop("You can only provide arguments from gpar() to the function") } @@ -1092,7 +1091,7 @@ fpTxtGp <- function(label, ) if (!missing(legend.title)) { - if (class(legend.title) != "gpar") { + if (!inherits(legend.title, "gpar")) { stop("You can only provide arguments from gpar() to the function") } ret$legend.title <- prGparMerge( diff --git a/inst/examples/forestplot_example.R b/inst/examples/forestplot_example.R index b085474..e7268f1 100644 --- a/inst/examples/forestplot_example.R +++ b/inst/examples/forestplot_example.R @@ -11,7 +11,7 @@ test_data <- data.frame( low = c(1.4, 0.78), high = c(1.8, 1.55) ) -test_data %>% +test_data |> forestplot(labeltext = row_names, mean = coef, lower = low, @@ -26,7 +26,7 @@ test_data %>% grid.newpage() pushViewport(viewport(layout = grid.layout(1, 2))) pushViewport(viewport(layout.pos.col = 1)) -test_data %>% +test_data |> forestplot(labeltext = row_names, mean = coef, lower = low, @@ -38,7 +38,7 @@ test_data %>% new_page = FALSE) popViewport() pushViewport(viewport(layout.pos.col = 2)) -test_data %>% +test_data |> forestplot(labeltext = row_names, mean = coef, lower = low, @@ -63,38 +63,27 @@ test_data <- data.frame(id = 1:4, high2 = c(1, 1.8, 1.55, 1.33)) # Convert into dplyr formatted data -out_data <- test_data %>% - pivot_longer(cols = everything() & -id) %>% +out_data <- test_data |> + pivot_longer(cols = everything() & -id) |> mutate(group = gsub("(.+)([12])$", "\\2", name), - name = gsub("(.+)([12])$", "\\1", name)) %>% - pivot_wider() %>% + name = gsub("(.+)([12])$", "\\1", name)) |> + pivot_wider() |> + group_by(id) |> + mutate(col1 = lapply(id, \(x) ifelse(x < 4, + paste("Category", id), + expression(Category >= 4))), + col2 = lapply(1:n(), \(i) substitute(expression(bar(x) == val), + list(val = mean(coef) |> round(2)))), + col2 = if_else(id == 1, + rep("ref", n()) |> as.list(), + col2)) |> group_by(group) -col_no <- grep("coef", colnames(test_data)) -row_names <- list( - list("Category 1", "Category 2", "Category 3", expression(Category >= 4)), - list( - "ref", - substitute( - expression(bar(x) == val), - list(val = round(rowMeans(test_data[2, col_no]), 2)) - ), - substitute( - expression(bar(x) == val), - list(val = round(rowMeans(test_data[3, col_no]), 2)) - ), - substitute( - expression(bar(x) == val), - list(val = round(rowMeans(test_data[4, col_no]), 2)) - ) - ) -) - -out_data %>% +out_data |> forestplot(mean = coef, lower = low, upper = high, - labeltext = row_names, + labeltext = c(col1, col2), title = "Cool study", zero = c(0.98, 1.02), grid = structure(c(2^-.5, 2^.5), @@ -125,7 +114,7 @@ row_names <- cbind( c("Name", "Variable A", "Variable B"), c("HR", test_data$coef) ) -test_data <- rbind(rep(NA, 3), test_data) +test_data <- rbind(rep(NA, ncol(test_data)), test_data) forestplot( labeltext = row_names, diff --git a/man/forestplot.Rd b/man/forestplot.Rd index 55db474..315416d 100644 --- a/man/forestplot.Rd +++ b/man/forestplot.Rd @@ -291,7 +291,7 @@ test_data <- data.frame( low = c(1.4, 0.78), high = c(1.8, 1.55) ) -test_data \%>\% +test_data |> forestplot(labeltext = row_names, mean = coef, lower = low, @@ -306,7 +306,7 @@ test_data \%>\% grid.newpage() pushViewport(viewport(layout = grid.layout(1, 2))) pushViewport(viewport(layout.pos.col = 1)) -test_data \%>\% +test_data |> forestplot(labeltext = row_names, mean = coef, lower = low, @@ -318,7 +318,7 @@ test_data \%>\% new_page = FALSE) popViewport() pushViewport(viewport(layout.pos.col = 2)) -test_data \%>\% +test_data |> forestplot(labeltext = row_names, mean = coef, lower = low, @@ -343,38 +343,27 @@ test_data <- data.frame(id = 1:4, high2 = c(1, 1.8, 1.55, 1.33)) # Convert into dplyr formatted data -out_data <- test_data \%>\% - pivot_longer(cols = everything() & -id) \%>\% +out_data <- test_data |> + pivot_longer(cols = everything() & -id) |> mutate(group = gsub("(.+)([12])$", "\\\\2", name), - name = gsub("(.+)([12])$", "\\\\1", name)) \%>\% - pivot_wider() \%>\% + name = gsub("(.+)([12])$", "\\\\1", name)) |> + pivot_wider() |> + group_by(id) |> + mutate(col1 = lapply(id, \(x) ifelse(x < 4, + paste("Category", id), + expression(Category >= 4))), + col2 = lapply(1:n(), \(i) substitute(expression(bar(x) == val), + list(val = mean(coef) |> round(2)))), + col2 = if_else(id == 1, + rep("ref", n()) |> as.list(), + col2)) |> group_by(group) -col_no <- grep("coef", colnames(test_data)) -row_names <- list( - list("Category 1", "Category 2", "Category 3", expression(Category >= 4)), - list( - "ref", - substitute( - expression(bar(x) == val), - list(val = round(rowMeans(test_data[2, col_no]), 2)) - ), - substitute( - expression(bar(x) == val), - list(val = round(rowMeans(test_data[3, col_no]), 2)) - ), - substitute( - expression(bar(x) == val), - list(val = round(rowMeans(test_data[4, col_no]), 2)) - ) - ) -) - -out_data \%>\% +out_data |> forestplot(mean = coef, lower = low, upper = high, - labeltext = row_names, + labeltext = c(col1, col2), title = "Cool study", zero = c(0.98, 1.02), grid = structure(c(2^-.5, 2^.5), @@ -405,7 +394,7 @@ row_names <- cbind( c("Name", "Variable A", "Variable B"), c("HR", test_data$coef) ) -test_data <- rbind(rep(NA, 3), test_data) +test_data <- rbind(rep(NA, ncol(test_data)), test_data) forestplot( labeltext = row_names, diff --git a/tests/testthat/test-forestplot_1_compatibility.R b/tests/testthat/test-forestplot_1_compatibility.R index 2e40b0e..4b74c21 100644 --- a/tests/testthat/test-forestplot_1_compatibility.R +++ b/tests/testthat/test-forestplot_1_compatibility.R @@ -8,12 +8,12 @@ test_that("Feeding a data.frame", { labels = LETTERS[1:3] ) - obj <- forestplot(df %>% dplyr::select("labels"), + obj <- forestplot(df |> dplyr::select("labels"), mean = df$est, lower = df$lb, upper = df$ub ) expect_class(obj, "gforge_forestplot") - expect_equal(obj$labels %>% length(), 1) - expect_equal(obj$labels[[1]] %>% length(), 3) + expect_equal(obj$labels |> length(), 1) + expect_equal(obj$labels[[1]] |> length(), 3) }) diff --git a/tests/testthat/test-inputs.R b/tests/testthat/test-inputs.R index e5a997d..274a0ce 100644 --- a/tests/testthat/test-inputs.R +++ b/tests/testthat/test-inputs.R @@ -9,7 +9,7 @@ test_that("Check different input formats", { abind(basic_data, basic_data + 1, along = 3 - ) %>% + ) |> forestplot(labeltext = 1:3) ) @@ -17,7 +17,7 @@ test_that("Check different input formats", { abind(basic_data, basic_data + 1, along = 3 - ) %>% + ) |> forestplot() ) @@ -52,7 +52,7 @@ test_that("Check different input formats", { abind(basic_data, cbind(0:2, 3:1, 2:4), along = 3 - ) %>% + ) |> forestplot() ) }) diff --git a/tests/vtest_from_vignette.R b/tests/vtest_from_vignette.R index bd2546a..9fb2116 100644 --- a/tests/vtest_from_vignette.R +++ b/tests/vtest_from_vignette.R @@ -243,52 +243,94 @@ xticks <- seq(from = -.1, to = .05, by = 0.025) xtlab <- rep(c(TRUE, FALSE), length.out = length(xticks)) attr(xticks, "labels") <- xtlab forestplot(tabletext, - legend = c("Sweden", "Denmark"), - fn.ci_norm = c(fpDrawNormalCI, fpDrawCircleCI), - boxsize = .25, # We set the box size to better visualize the type - line.margin = .1, # We need to add this to avoid crowding - mean = cbind(HRQoL$Sweden[, "coef"], HRQoL$Denmark[, "coef"]), - lower = cbind(HRQoL$Sweden[, "lower"], HRQoL$Denmark[, "lower"]), - upper = cbind(HRQoL$Sweden[, "upper"], HRQoL$Denmark[, "upper"]), - clip = c(-.125, 0.075), - col = fpColors(box = c("blue", "darkred")), - xticks = xticks, - xlab = "EQ-5D index" + legend = c("Sweden", "Denmark"), + fn.ci_norm = c(fpDrawNormalCI, fpDrawCircleCI), + boxsize = .25, # We set the box size to better visualize the type + line.margin = .1, # We need to add this to avoid crowding + mean = cbind(HRQoL$Sweden[, "coef"], HRQoL$Denmark[, "coef"]), + lower = cbind(HRQoL$Sweden[, "lower"], HRQoL$Denmark[, "lower"]), + upper = cbind(HRQoL$Sweden[, "upper"], HRQoL$Denmark[, "upper"]), + clip = c(-.125, 0.075), + col = fpColors(box = c("blue", "darkred")), + xticks = xticks, + xlab = "EQ-5D index" ) ## ------------------------------------------------------------------------ forestplot(tabletext, - legend = c("Sweden", "Denmark"), - fn.ci_norm = c(fpDrawNormalCI, fpDrawCircleCI), - boxsize = .25, # We set the box size to better visualize the type - line.margin = .1, # We need to add this to avoid crowding - mean = cbind(HRQoL$Sweden[, "coef"], HRQoL$Denmark[, "coef"]), - lower = cbind(HRQoL$Sweden[, "lower"], HRQoL$Denmark[, "lower"]), - upper = cbind(HRQoL$Sweden[, "upper"], HRQoL$Denmark[, "upper"]), - clip = c(-.125, 0.075), - col = fpColors(box = c("blue", "darkred")), - grid = TRUE, - xticks = c(-.1, -0.05, 0, .05), - xlab = "EQ-5D index" + legend = c("Sweden", "Denmark"), + fn.ci_norm = c(fpDrawNormalCI, fpDrawCircleCI), + boxsize = .25, # We set the box size to better visualize the type + line.margin = .1, # We need to add this to avoid crowding + mean = cbind(HRQoL$Sweden[, "coef"], HRQoL$Denmark[, "coef"]), + lower = cbind(HRQoL$Sweden[, "lower"], HRQoL$Denmark[, "lower"]), + upper = cbind(HRQoL$Sweden[, "upper"], HRQoL$Denmark[, "upper"]), + clip = c(-.125, 0.075), + col = fpColors(box = c("blue", "darkred")), + grid = TRUE, + xticks = c(-.1, -0.05, 0, .05), + xlab = "EQ-5D index" ) ## ------------------------------------------------------------------------ forestplot(tabletext, - legend = c("Sweden", "Denmark"), - fn.ci_norm = c(fpDrawNormalCI, fpDrawCircleCI), - boxsize = .25, # We set the box size to better visualize the type - line.margin = .1, # We need to add this to avoid crowding - mean = cbind(HRQoL$Sweden[, "coef"], HRQoL$Denmark[, "coef"]), - lower = cbind(HRQoL$Sweden[, "lower"], HRQoL$Denmark[, "lower"]), - upper = cbind(HRQoL$Sweden[, "upper"], HRQoL$Denmark[, "upper"]), - clip = c(-.125, 0.075), - col = fpColors(box = c("blue", "darkred")), - grid = structure(c(-.1, -.05, .05), - gp = gpar(lty = 2, col = "#CCCCFF") - ), - xlab = "EQ-5D index" + legend = c("Sweden", "Denmark"), + fn.ci_norm = c(fpDrawNormalCI, fpDrawCircleCI), + boxsize = .25, # We set the box size to better visualize the type + line.margin = .1, # We need to add this to avoid crowding + mean = cbind(HRQoL$Sweden[, "coef"], HRQoL$Denmark[, "coef"]), + lower = cbind(HRQoL$Sweden[, "lower"], HRQoL$Denmark[, "lower"]), + upper = cbind(HRQoL$Sweden[, "upper"], HRQoL$Denmark[, "upper"]), + clip = c(-.125, 0.075), + col = fpColors(box = c("blue", "darkred")), + grid = structure(c(-.1, -.05, .05), + gp = gpar(lty = 2, col = "#CCCCFF") + ), + xlab = "EQ-5D index" ) +##----Test group_by with tidy-syntax-------------------------------- +HRQoL |> + sapply(\(x) data.frame(x) |> tibble::rownames_to_column(), + simplify = FALSE) |> + dplyr::bind_rows(.id = "Country") |> + dplyr::group_by(Country) |> + forestplot(mean = coef, + lower = lower, + upper = upper, + labeltext = rowname, + legend = c("Sweden", "Denmark"), + fn.ci_norm = c(fpDrawNormalCI, fpDrawCircleCI), + boxsize = .25, # We set the box size to better visualize the type + line.margin = .1, # We need to add this to avoid crowding + clip = c(-.125, 0.075), + col = fpColors(box = c("blue", "darkred")), + xticks = c(-.1, -0.05, 0, .05), + xlab = "EQ-5D index" + ) + +##----How to handle missing rows when group_by have ---------------- +##----different names-------------------------------- +HRQoL |> + sapply(\(x) data.frame(x) |> tibble::rownames_to_column(), + simplify = FALSE) |> + dplyr::bind_rows(.id = "Country") |> + dplyr::filter(Country == "Sweden" | rowname != "Males vs Female") |> + dplyr::group_by(Country) |> + forestplot(mean = coef, + lower = lower, + upper = upper, + labeltext = rowname, + legend = c("Sweden", "Denmark"), + fn.ci_norm = c(fpDrawNormalCI, fpDrawCircleCI), + boxsize = .25, # We set the box size to better visualize the type + line.margin = .1, # We need to add this to avoid crowding + clip = c(-.125, 0.075), + col = fpColors(box = c("blue", "darkred")), + xticks = c(-.1, -0.05, 0, .05), + xlab = "EQ-5D index" + ) + ## ---- eval=FALSE, echo=TRUE---------------------------------------------- # grid_arg <- c(-.1, -.05, .05) # attr(grid_arg, "gp") <- gpar(lty = 2, col = "#CCCCFF") diff --git a/vignettes/forestplot.Rmd b/vignettes/forestplot.Rmd index 0dac2cc..a848a11 100644 --- a/vignettes/forestplot.Rmd +++ b/vignettes/forestplot.Rmd @@ -212,7 +212,7 @@ tabletext <- list(c(NA, dfHRQoL |> filter(group == "Sweden") |> pull(labeltext)) dfHRQoL |> filter(group == "Sweden") |> - bind_rows(tibble(mean = NA_real_), .) |> + tibble::add_row(tibble(mean = NA_real_), .before = 1) |> forestplot(labeltext = tabletext, col = clrs, xlab = "EQ-5D index") From 1d3cfa66ed185beab41dd75e01c2c17e023d0f7a Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Sun, 4 Sep 2022 10:54:59 +0200 Subject: [PATCH 04/17] Fixed sorting bug in group_df --- R/forestplot.grouped_df.R | 28 +++++++----- tests/testthat/test-forestplot.group_df.R | 54 +++++++++++++++++++++++ tests/vtest_from_vignette.R | 42 ------------------ 3 files changed, 71 insertions(+), 53 deletions(-) create mode 100644 tests/testthat/test-forestplot.group_df.R diff --git a/R/forestplot.grouped_df.R b/R/forestplot.grouped_df.R index c06e443..4074365 100644 --- a/R/forestplot.grouped_df.R +++ b/R/forestplot.grouped_df.R @@ -52,9 +52,9 @@ forestplot.grouped_df <- function(x, labeltext, mean, lower, upper, legend, is.s lower = {{ lower }}, upper = {{ upper }}) |> dplyr::bind_cols(x |> - tidyr::unite(".fp_groups", dplyr::all_of(groups), sep = " > ") |> + tidyr::unite(".fp_groups", dplyr::all_of(groups), sep = " > ", remove = FALSE) |> tidyr::unite(".fp_labels", {{lblid}}, sep = " > ") |> - dplyr::select(dplyr::starts_with(".fp"))) |> + dplyr::select(dplyr::starts_with(".fp"), dplyr::all_of(groups))) |> dplyr::group_by(.fp_groups) if (length(is.summary) %in% c(1, nrow(core_data))) { @@ -118,8 +118,13 @@ forestplot.grouped_df <- function(x, labeltext, mean, lower, upper, legend, is.s } if (missing(legend)) { - legend <- attr(fixed_data, "groups") |> + grouped_columns <- attr(x, "groups") |> dplyr::select(-.rows) |> + colnames() + legend <- fixed_data |> + dplyr::ungroup() |> + dplyr::select({{grouped_columns}}) |> + dplyr::distinct() |> tidyr::unite(col = "legend", dplyr::everything(), sep = " > ") |> purrr::pluck("legend") } @@ -140,14 +145,15 @@ forestplot.grouped_df <- function(x, labeltext, mean, lower, upper, legend, is.s # Convert estimates to two-dimensional matrices estimates <- sapply(c("mean", "lower", "upper"), - \(n) fixed_data[[n]] |> - (\(raw_data) - lapply(attr(fixed_data, "groups")$.rows, - \(row_numbers) raw_data[row_numbers]))() |> - (\(cols) { - names(cols) <- attr(fixed_data, "groups")$.fp_groups - suppressMessages(dplyr::bind_cols(cols)) - })() |> + \(value_col) fixed_data |> + dplyr::select(.fp_labels, + .fp_groups, + {{value_col}}) |> + tidyr::pivot_wider(names_from = .fp_groups, values_from = {{value_col}}, names_prefix = "@estimates@") |> + dplyr::select(starts_with("@estimates@")) |> + dplyr::rename_with(\(x) sub(pattern = "^@estimates@", + replacement = "", + x = x)) |> as.matrix(), simplify = FALSE) diff --git a/tests/testthat/test-forestplot.group_df.R b/tests/testthat/test-forestplot.group_df.R new file mode 100644 index 0000000..577c8ac --- /dev/null +++ b/tests/testthat/test-forestplot.group_df.R @@ -0,0 +1,54 @@ +library("testthat") + +data("HRQoL") + +test_that("Basic", { + out <- HRQoL |> + sapply(\(x) data.frame(x) |> tibble::rownames_to_column(), + simplify = FALSE) |> + dplyr::bind_rows(.id = "Country") |> + dplyr::group_by(Country) |> + forestplot(mean = coef, + lower = lower, + upper = upper, + labeltext = rowname, + fn.ci_norm = c(fpDrawNormalCI, fpDrawCircleCI), + boxsize = .25, # We set the box size to better visualize the type + line.margin = .1, # We need to add this to avoid crowding + clip = c(-.125, 0.075), + col = fpColors(box = c("blue", "darkred")), + xticks = c(-.1, -0.05, 0, .05), + xlab = "EQ-5D index" + ) + + expect_equivalent(out$mean, + lapply(HRQoL, \(x) x[,"coef"]) |> unlist()) +}) + + +test_that("How to handle missing rows when group_by have different names", { + out <- HRQoL |> + sapply(\(x) data.frame(x) |> tibble::rownames_to_column(), + simplify = FALSE) |> + dplyr::bind_rows(.id = "Country") |> + dplyr::filter(Country == "Sweden" | rowname != "Males vs Female") |> + dplyr::group_by(Country) |> + forestplot(mean = coef, + lower = lower, + upper = upper, + labeltext = rowname, + legend = c("Sweden", "Denmark"), + fn.ci_norm = c(fpDrawNormalCI, fpDrawCircleCI), + boxsize = .25, # We set the box size to better visualize the type + line.margin = .1, # We need to add this to avoid crowding + clip = c(-.125, 0.075), + col = fpColors(box = c("blue", "darkred")), + xticks = c(-.1, -0.05, 0, .05), + xlab = "EQ-5D index" + ) + expect_equivalent(out$mean[1:4], + HRQoL[[1]][,"coef"]) + expect_scalar_na(out$mean[5]) + expect_equivalent(out$mean[6:8], + HRQoL[[2]][2:4,"coef"]) +}) diff --git a/tests/vtest_from_vignette.R b/tests/vtest_from_vignette.R index 9fb2116..6eafe35 100644 --- a/tests/vtest_from_vignette.R +++ b/tests/vtest_from_vignette.R @@ -289,48 +289,6 @@ forestplot(tabletext, xlab = "EQ-5D index" ) -##----Test group_by with tidy-syntax-------------------------------- -HRQoL |> - sapply(\(x) data.frame(x) |> tibble::rownames_to_column(), - simplify = FALSE) |> - dplyr::bind_rows(.id = "Country") |> - dplyr::group_by(Country) |> - forestplot(mean = coef, - lower = lower, - upper = upper, - labeltext = rowname, - legend = c("Sweden", "Denmark"), - fn.ci_norm = c(fpDrawNormalCI, fpDrawCircleCI), - boxsize = .25, # We set the box size to better visualize the type - line.margin = .1, # We need to add this to avoid crowding - clip = c(-.125, 0.075), - col = fpColors(box = c("blue", "darkred")), - xticks = c(-.1, -0.05, 0, .05), - xlab = "EQ-5D index" - ) - -##----How to handle missing rows when group_by have ---------------- -##----different names-------------------------------- -HRQoL |> - sapply(\(x) data.frame(x) |> tibble::rownames_to_column(), - simplify = FALSE) |> - dplyr::bind_rows(.id = "Country") |> - dplyr::filter(Country == "Sweden" | rowname != "Males vs Female") |> - dplyr::group_by(Country) |> - forestplot(mean = coef, - lower = lower, - upper = upper, - labeltext = rowname, - legend = c("Sweden", "Denmark"), - fn.ci_norm = c(fpDrawNormalCI, fpDrawCircleCI), - boxsize = .25, # We set the box size to better visualize the type - line.margin = .1, # We need to add this to avoid crowding - clip = c(-.125, 0.075), - col = fpColors(box = c("blue", "darkred")), - xticks = c(-.1, -0.05, 0, .05), - xlab = "EQ-5D index" - ) - ## ---- eval=FALSE, echo=TRUE---------------------------------------------- # grid_arg <- c(-.1, -.05, .05) # attr(grid_arg, "gp") <- gpar(lty = 2, col = "#CCCCFF") From 8eee86b1f7364fc21f17ae0432df8f95890e503f Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Thu, 22 Sep 2022 22:45:09 +0200 Subject: [PATCH 05/17] Move all plot to print method (#48) * Refactored print to contain all grid moments This allows for better debugging by returning a forestplot object that can be used for checking output and also making it easy to save an object and put it later into a plot with different dimensions than during plotting. This also allows for chaining with a pipe in the same way as ggplot() does. * Added NULL as explicit default instead of using `missing()` - if a parameter can be omitted then this should be obvious be reading the code. * Fixed bad legend --- R/drawForestplotObject.R | 742 ++++++++++----------------- R/forestplot.default.R | 322 +++--------- R/forestplot.grouped_df.R | 2 +- R/prFpDrawLegend.R | 67 +-- R/prFpGetGraphTicksAndClips.R | 44 +- R/prepGridMargins.R | 20 + R/private.R | 249 +-------- R/private_buildLegend.R | 173 +++++++ R/private_getColWidths.R | 48 ++ R/private_plot.forestplot_legend.R | 105 ++++ R/private_prGetLabelsList.R | 152 ++++++ R/private_prepAlign.R | 28 + R/private_prepGraphPositions.R | 34 ++ R/private_prepLabelText.R | 119 +++++ man/forestplot.Rd | 26 +- man/prFpDrawLegend.Rd | 66 --- man/prFpGetGraphTicksAndClips.Rd | 83 --- man/prFpGetLabels.Rd | 49 -- man/prFpGetLayoutVP.Rd | 4 +- man/prFpGetLegendGrobs.Rd | 27 - man/prFpGetLines.Rd | 2 +- man/prFpPrintXaxis.Rd | 28 - man/prGetLabelsList.Rd | 32 ++ man/prepAlign.Rd | 21 + man/prepGraphPositions.Rd | 21 + man/prepGridMargins.Rd | 21 + man/prepLabelText.Rd | 43 ++ tests/test_visual_w_cochrane_mdata.R | 26 +- tests/vtest_from_vignette.R | 14 +- 29 files changed, 1284 insertions(+), 1284 deletions(-) create mode 100644 R/prepGridMargins.R create mode 100644 R/private_buildLegend.R create mode 100644 R/private_getColWidths.R create mode 100644 R/private_plot.forestplot_legend.R create mode 100644 R/private_prGetLabelsList.R create mode 100644 R/private_prepAlign.R create mode 100644 R/private_prepGraphPositions.R create mode 100644 R/private_prepLabelText.R delete mode 100644 man/prFpDrawLegend.Rd delete mode 100644 man/prFpGetGraphTicksAndClips.Rd delete mode 100644 man/prFpGetLabels.Rd delete mode 100644 man/prFpGetLegendGrobs.Rd delete mode 100644 man/prFpPrintXaxis.Rd create mode 100644 man/prGetLabelsList.Rd create mode 100644 man/prepAlign.Rd create mode 100644 man/prepGraphPositions.Rd create mode 100644 man/prepGridMargins.Rd create mode 100644 man/prepLabelText.Rd diff --git a/R/drawForestplotObject.R b/R/drawForestplotObject.R index 84ef9bb..fd20aae 100644 --- a/R/drawForestplotObject.R +++ b/R/drawForestplotObject.R @@ -1,505 +1,329 @@ +#' @noRd drawForestplotObject <- function(obj) { ################## # Build the plot # ################## - with(obj, { - # Adjust for the margins and the x-axis + label - marList <- list() - - # This breaks without separate variables - marList$bottom <- convertY(mar[1], "npc") - marList$left <- convertX(mar[2], "npc") - marList$top <- convertY(mar[3], "npc") - marList$right <- convertX(mar[4], "npc") - - prPushMarginViewport( - bottom = marList$bottom, - left = marList$left, - top = marList$top, - right = marList$right, - name = "forestplot_margins" + hrzl_lines <- prFpGetLines(hrzl_lines = obj$hrzl_lines, + is.summary = obj$is.summary, + total_columns = attr(obj$labels, "no_cols") + 1, + col = obj$col, + shapes_gp = obj$shapes_gp) + + labels <- prGetLabelsList(labels = obj$labels, + align = obj$align, + is.summary = obj$is.summary, + txt_gp = obj$txt_gp, + col = obj$col) + obj$labels <- NULL + + + xRange <- prFpXrange(upper = obj$upper, + lower = obj$lower, + clip = obj$clip, + zero = obj$zero, + xticks = obj$xticks, + xlog = obj$xlog) + + axisList <- prFpGetGraphTicksAndClips(xticks = obj$xticks, + xticks.digits = obj$xticks.digits, + grid = obj$grid, + xlog = obj$xlog, + xlab = obj$xlab, + lwd.xaxis = obj$lwd.xaxis, + txt_gp = obj$txt_gp, + col = obj$col, + clip = obj$clip, + zero = obj$zero, + x_range = xRange, + mean = obj$org_mean, + graph.pos = obj$graph.pos, + shapes_gp = obj$shapes_gp) + + marList <- prepGridMargins(mar = obj$mar) + prPushMarginViewport(bottom = marList$bottom, + left = marList$left, + top = marList$top, + right = marList$right, + name = "forestplot_margins") + + if (!all(is.na(obj$title))) { + prGridPlotTitle(title = obj$title, gp = obj$txt_gp$title) + } + + legend <- buildLegend(obj$legend, + obj$txt_gp, + obj$legend_args, + obj$colgap, + col = obj$col, + shapes_gp = obj$shapes_gp, + lineheight = obj$lineheight, + fn.legend = obj$fn.legend) + + plot(legend, margin = TRUE) + + colwidths <- getColWidths(labels = labels, + graphwidth = obj$graphwidth, + colgap = obj$colgap, + graph.pos = obj$graph.pos) + + + # Add space for the axis and the label + axis_height <- unit(0, "npc") + if (is.grob(axisList$axisGrob)) { + axis_height <- axis_height + grobHeight(axisList$axisGrob) + } + + if (is.grob(axisList$labGrob)) { + gp_lab_cex <- prGetTextGrobCex(axisList$labGrob) + + # The lab grob y actually includes the axis (note negative) + axis_height <- axis_height + + unit(gp_lab_cex + .5, "line") + } + + axis_layout <- grid.layout( + nrow = 2, + ncol = 1, + heights = unit.c( + unit(1, "npc") - axis_height, + axis_height + ) + ) + pushViewport(viewport( + layout = axis_layout, + name = "axis_margin" + )) + pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 1)) + + # The base viewport, set the increase.line_height paremeter if it seems a little + # crowded between the lines that might happen when having multiple comparisons + main_grid_layout <- grid.layout(nrow = attr(labels, "no_rows"), + ncol = length(colwidths), + widths = colwidths, + heights = unit(rep(1 / attr(labels, "no_rows"), attr(labels, "no_rows")), "npc"), + respect = TRUE) + + pushViewport(viewport( + layout = main_grid_layout, + name = "BaseGrid" + )) + + # Create the fourth argument 4 the fpDrawNormalCI() function + if (!is.null(obj$boxsize)) { + # If matrix is provided this will convert it + # to a vector but it doesn't matter in this case + info <- rep(obj$boxsize, length = length(obj$mean)) + } else { + # Get width of the lines + cwidth <- (obj$upper - obj$lower) + # Set cwidth to min value if the value is invalid + # this can be the case for reference points + cwidth[cwidth <= 0 | is.na(cwidth)] <- min(cwidth[cwidth > 0]) + textHeight <- convertUnit(grobHeight(textGrob("A", gp = do.call(gpar, obj$txt_gp$label))), + unitTo = "npc", + valueOnly = TRUE ) - if (!all(is.na(title))) { - prGridPlotTitle(title = title, gp = txt_gp$title) - } - - # Initiate the legend - if (!all(is.na(legend))) { - lGrobs <- prFpGetLegendGrobs( - legend = legend, - txt_gp = txt_gp, - title = legend_args$title - ) - legend_colgap <- colgap - if (convertUnit(legend_colgap, unitTo = "mm", valueOnly = TRUE) > - convertUnit(attr(lGrobs, "max_height"), unitTo = "mm", valueOnly = TRUE)) { - legend_colgap <- attr(lGrobs, "max_height") - } - - legend_horizontal_height <- - sum( - legend_args$padding, - attr(lGrobs, "max_height"), - legend_args$padding - ) - if (!is.null(attr(lGrobs, "title"))) { - legend_horizontal_height <- - sum( - attr(lGrobs, "titleHeight"), - attr(lGrobs, "line_height_and_spacing")[2], - legend_horizontal_height - ) - } - legend_vertical_width <- - sum(unit.c( - legend_args$padding, - attr(lGrobs, "max_height"), - legend_colgap, - attr(lGrobs, "max_width"), - legend_args$padding - )) - - - - # Prepare the viewports if the legend is not - # positioned inside the forestplot, i.e. on the top or right side - if ((!is.list(legend_args$pos) && legend_args$pos == "top") || - ("align" %in% names(legend_args$pos) && legend_args$pos[["align"]] == "horizontal")) { - legend_layout <- grid.layout( - nrow = 3, ncol = 1, - heights = unit.c( - legend_horizontal_height, - legend_colgap + legend_colgap, - unit(1, "npc") - - legend_horizontal_height - - legend_colgap - - legend_colgap - ) - ) + info <- 1 / cwidth * 0.75 + if (!all(obj$is.summary)) { + info <- info / max(info[!obj$is.summary], na.rm = TRUE) - legend_pos <- list( - row = 1, - col = 1 - ) - main_pos <- list( - row = 3, - col = 1 - ) - } else { - legend_layout <- grid.layout( - nrow = 1, ncol = 3, - widths = unit.c( - unit(1, "npc") - - legend_colgap - - legend_vertical_width, - legend_colgap, - legend_vertical_width - ) - ) - legend_pos <- list( - row = 1, - col = 3 - ) - main_pos <- list( - row = 1, - col = 1 - ) + # Adjust the dots as it gets ridiculous with small text and huge dots + if (any(textHeight * (attr(labels, "no_rows") + .5) * 1.5 < info)) { + info <- textHeight * (attr(labels, "no_rows") + .5) * 1.5 * info / max(info, na.rm = TRUE) + textHeight * (attr(labels, "no_rows") + .5) * 1.5 / 4 } } - # If the legend should be positioned within the plot then wait - # until after the plot has been drawn - if (!all(is.na(legend)) > 0 && !is.list(legend_args$pos)) { - pushViewport(prFpGetLayoutVP( - lineheight = lineheight, - labels = labels, - nr = nr, - legend_layout = legend_layout - )) - vp <- viewport( - layout.pos.row = legend_pos$row, - layout.pos.col = legend_pos$col, - name = "legend" - ) - pushViewport(vp) - - # Draw the legend - prFpDrawLegend( - lGrobs = lGrobs, - col = col, - shapes_gp = shapes_gp, - colgap = convertUnit(legend_colgap, unitTo = "mm"), - pos = legend_args$pos, - gp = legend_args$gp, - r = legend_args$r, - padding = legend_args$padding, - fn.legend = fn.legend - ) - upViewport() - - # Reset to the main plot - vp <- viewport( - layout.pos.row = main_pos$row, - layout.pos.col = main_pos$col, - name = "main" - ) - pushViewport(vp) - } else { - pushViewport(prFpGetLayoutVP( - lineheight = lineheight, - labels = labels, nr = nr - )) - } - - ########################################### - # Normalize the widths to cover the whole # - # width of the graph space. # - ########################################### - if (!is.unit(graphwidth) && - graphwidth == "auto") { - # If graph width is not provided as a unit the autosize it to the - # rest of the space available - npc_colwidths <- convertUnit(unit.c(colwidths, colgap), "npc", valueOnly = TRUE) - graphwidth <- unit(max(.05, 1 - sum(npc_colwidths)), "npc") - } else if (!is.unit(graphwidth)) { - stop( - "You have to provide graph width either as a unit() object or as 'auto'.", - " Auto sizes the graph to maximally use the available space.", - " If you want to have exact mm width then use graphwidth = unit(34, 'mm')." - ) - } - - # Add the base grapwh width to the total column width - # default is 2 inches - if (graph.pos == 1) { - colwidths <- unit.c(graphwidth, colgap, colwidths) - } else if (graph.pos == nc + 1) { - colwidths <- unit.c(colwidths, colgap, graphwidth) - } else { - spl_position <- ((graph.pos - 1) * 2 - 1) - colwidths <- unit.c( - colwidths[1:spl_position], - colgap, - graphwidth, - colwidths[(spl_position + 1):length(colwidths)] - ) - } - - # Add space for the axis and the label - axis_height <- unit(0, "npc") - if (is.grob(axisList$axisGrob)) { - axis_height <- axis_height + grobHeight(axisList$axisGrob) - } - if (is.grob(axisList$labGrob)) { - gp_lab_cex <- prGetTextGrobCex(axisList$labGrob) - - # The lab grob y actually includes the axis (note negative) - axis_height <- axis_height + - unit(gp_lab_cex + .5, "line") - } - - axis_layout <- grid.layout( - nrow = 2, - ncol = 1, - heights = unit.c( - unit(1, "npc") - axis_height, - axis_height - ) - ) - pushViewport(viewport( - layout = axis_layout, - name = "axis_margin" - )) - pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 1)) - - # The base viewport, set the increase.line_height paremeter if it seems a little - # crowded between the lines that might happen when having multiple comparisons - main_grid_layout <- grid.layout( - nrow = nr, - ncol = length(colwidths), - widths = colwidths, - heights = unit(rep(1 / nr, nr), "npc"), - respect = TRUE - ) - pushViewport(viewport( - layout = main_grid_layout, - name = "BaseGrid" - )) - - # Create the fourth argument 4 the fpDrawNormalCI() function - if (!all(is.na(boxsize))) { - # If matrix is provided this will convert it - # to a vector but it doesn't matter in this case - info <- rep(boxsize, length = length(mean)) + # Set summary to maximum size + info[obj$is.summary] <- 1 / NCOL(obj$org_mean) + } + + prFpPrintLabels( + labels = labels, + nc = attr(labels, "no_cols"), + nr = attr(labels, "no_rows"), + graph.pos = obj$graph.pos + ) + + prFpDrawLines(hrzl_lines = hrzl_lines, + nr = attr(labels, "no_rows"), + colwidths = colwidths, + graph.pos = obj$graph.pos) + + prFpPrintXaxis(axisList = axisList, + col = obj$col, + lwd.zero = obj$lwd.zero, + shapes_gp = obj$shapes_gp) + + # Output the different confidence intervals + for (i in 1:attr(labels, "no_rows")) { + if (is.matrix(obj$org_mean)) { + low_values <- obj$org_lower[i, ] + mean_values <- obj$org_mean[i, ] + up_values <- obj$org_upper[i, ] + info_values <- matrix(info, ncol = length(low_values))[i, ] } else { - # Get width of the lines - cwidth <- (upper - lower) - # Set cwidth to min value if the value is invalid - # this can be the case for reference points - cwidth[cwidth <= 0 | is.na(cwidth)] <- min(cwidth[cwidth > 0]) - textHeight <- convertUnit(grobHeight(textGrob("A", gp = do.call(gpar, txt_gp$label))), - unitTo = "npc", - valueOnly = TRUE - ) - - info <- 1 / cwidth * 0.75 - if (!all(is.summary)) { - info <- info / max(info[!is.summary], na.rm = TRUE) - - # Adjust the dots as it gets ridiculous with small text and huge dots - if (any(textHeight * (nr + .5) * 1.5 < info)) { - info <- textHeight * (nr + .5) * 1.5 * info / max(info, na.rm = TRUE) + textHeight * (nr + .5) * 1.5 / 4 - } - } - - # Set summary to maximum size - info[is.summary] <- 1 / NCOL(org_mean) + low_values <- obj$org_lower[i] + mean_values <- obj$org_mean[i] + up_values <- obj$org_upper[i] + info_values <- info[i] } - prFpPrintLabels( - labels = labels, - nc = nc, - nr = nr, - graph.pos = graph.pos - ) + # The line and box colors may vary + clr.line <- rep(obj$col$line, length.out = length(low_values)) + clr.marker <- rep(obj$col$box, length.out = length(low_values)) + clr.summary <- rep(obj$col$summary, length.out = length(low_values)) - prFpDrawLines( - hrzl_lines = hrzl_lines, nr = nr, colwidths = colwidths, - graph.pos = graph.pos + line_vp <- viewport( + layout.pos.row = i, + layout.pos.col = obj$graph.pos * 2 - 1, + xscale = axisList$x_range, + name = sprintf("Line_%d_%d", i, obj$graph.pos * 2 - 1) ) + pushViewport(line_vp) - - prFpPrintXaxis( - axisList = axisList, - col = col, - lwd.zero = lwd.zero, - shapes_gp = shapes_gp - ) - - # Output the different confidence intervals - for (i in 1:nr) { - if (is.matrix(org_mean)) { - low_values <- org_lower[i, ] - mean_values <- org_mean[i, ] - up_values <- org_upper[i, ] - info_values <- matrix(info, ncol = length(low_values))[i, ] - } else { - low_values <- org_lower[i] - mean_values <- org_mean[i] - up_values <- org_upper[i] - info_values <- info[i] + # Draw multiple confidence intervals + if (length(low_values) > 1) { + b_height <- max(info_values) + if (is.unit(b_height)) { + b_height <- convertUnit(b_height, unitTo = "npc", valueOnly = TRUE) } - # The line and box colors may vary - clr.line <- rep(col$line, length.out = length(low_values)) - clr.marker <- rep(col$box, length.out = length(low_values)) - clr.summary <- rep(col$summary, length.out = length(low_values)) - - line_vp <- viewport( - layout.pos.row = i, - layout.pos.col = graph.pos * 2 - 1, - xscale = axisList$x_range, - name = sprintf("Line_%d_%d", i, graph.pos * 2 - 1) - ) - pushViewport(line_vp) - - # Draw multiple confidence intervals - if (length(low_values) > 1) { - b_height <- max(info_values) - if (is.unit(b_height)) { - b_height <- convertUnit(b_height, unitTo = "npc", valueOnly = TRUE) - } - - if (is.na(line.margin)) { - line.margin <- .1 + .2 / (length(low_values) - 1) - } else if (is.unit(line.margin)) { - line.margin <- convertUnit(line.margin, unitTo = "npc", valueOnly = TRUE) + if (is.null(obj$line.margin)) { + obj$line.margin <- .1 + .2 / (length(low_values) - 1) + } else if (is.unit(obj$line.margin)) { + obj$line.margin <- convertUnit(obj$line.margin, unitTo = "npc", valueOnly = TRUE) + } + y.offset_base <- b_height / 2 + obj$line.margin + y.offset_increase <- (1 - obj$line.margin * 2 - b_height) / (length(low_values) - 1) + + for (j in length(low_values):1) { + # Start from the bottom and plot up + # the one on top should always be + # above the one below + current_y.offset <- y.offset_base + (length(low_values) - j) * y.offset_increase + if (is.na(mean_values[j])) { + next } - y.offset_base <- b_height / 2 + line.margin - y.offset_increase <- (1 - line.margin * 2 - b_height) / (length(low_values) - 1) - - for (j in length(low_values):1) { - # Start from the bottom and plot up - # the one on top should always be - # above the one below - current_y.offset <- y.offset_base + (length(low_values) - j) * y.offset_increase - if (is.na(mean_values[j])) { - next - } - - shape_coordinates <- c(i, j) - attr(shape_coordinates, "max.coords") <- c(nr, length(low_values)) - - if (is.summary[i]) { - call_list <- - list(fn.ci_sum[[i]][[j]], - lower_limit = low_values[j], - estimate = mean_values[j], - upper_limit = up_values[j], - size = info_values[j], - y.offset = current_y.offset, - col = clr.summary[j], - shapes_gp = shapes_gp, - shape_coordinates = shape_coordinates - ) - } else { - call_list <- - list(fn.ci_norm[[i]][[j]], - lower_limit = low_values[j], - estimate = mean_values[j], - upper_limit = up_values[j], - size = info_values[j], - y.offset = current_y.offset, - clr.line = clr.line[j], - clr.marker = clr.marker[j], - lty = lty.ci[[i]][[j]], - vertices.height = ci.vertices.height, - shapes_gp = shapes_gp, - shape_coordinates = shape_coordinates - ) - - if (!all(is.na(ci.vertices))) { - call_list$vertices <- ci.vertices - } - - if (!all(is.na(lwd.ci))) { - call_list$lwd <- lwd.ci - } - } + shape_coordinates <- c(i, j) + attr(shape_coordinates, "max.coords") <- c(attr(labels, "no_rows"), length(low_values)) - # Add additional arguments that are passed on - # from the original parameters - for (name in names(extra_arguments)) { - call_list[[name]] <- extra_arguments[[name]] - } - - # Do the actual drawing of the object - tryCatch(eval(as.call(call_list)), - error = function(e) { - stop("On row ", i, " the print of the estimate failed: ", e$message) - } - ) - } - } else { - shape_coordinates <- c(i, 1) - attr(shape_coordinates, "max.coords") <- c(nr, 1) - - if (is.summary[i]) { + if (obj$is.summary[i]) { call_list <- - list(fn.ci_sum[[i]], - lower_limit = low_values, - estimate = mean_values, - upper_limit = up_values, - size = info_values, - col = clr.summary, - shapes_gp = shapes_gp, - shape_coordinates = shape_coordinates + list(obj$fn.ci_sum[[i]][[j]], + lower_limit = low_values[j], + estimate = mean_values[j], + upper_limit = up_values[j], + size = info_values[j], + y.offset = current_y.offset, + col = clr.summary[j], + shapes_gp = obj$shapes_gp, + shape_coordinates = shape_coordinates ) } else { call_list <- - list(fn.ci_norm[[i]], - lower_limit = low_values, - estimate = mean_values, - upper_limit = up_values, - size = info_values, - clr.line = clr.line, - clr.marker = clr.marker, - lty = lty.ci[[i]], - vertices.height = ci.vertices.height, - shapes_gp = shapes_gp, - shape_coordinates = shape_coordinates + list(obj$fn.ci_norm[[i]][[j]], + lower_limit = low_values[j], + estimate = mean_values[j], + upper_limit = up_values[j], + size = info_values[j], + y.offset = current_y.offset, + clr.line = clr.line[j], + clr.marker = clr.marker[j], + lty = obj$lty.ci[[i]][[j]], + vertices.height = obj$ci.vertices.height, + shapes_gp = obj$shapes_gp, + shape_coordinates = shape_coordinates ) - if (!all(is.na(ci.vertices))) { - call_list$vertices <- ci.vertices + if (!is.null(obj$ci.vertices)) { + call_list$vertices <- obj$ci.vertices } - if (!all(is.na(lwd.ci))) { - call_list$lwd <- lwd.ci + if (!is.null(obj$lwd.ci)) { + call_list$lwd <- obj$lwd.ci } } + # Add additional arguments that are passed on # from the original parameters - for (name in names(extra_arguments)) { - call_list[[name]] <- extra_arguments[[name]] + for (name in names(obj$extra_arguments)) { + call_list[[name]] <- obj$extra_arguments[[name]] } # Do the actual drawing of the object - if (!all(is.na(mean_values))) { - tryCatch(eval(as.call(call_list)), - error = function(e) { - stop("On row ", i, " the print of the estimate failed: ", e$message) - } - ) - } + tryCatch(eval(as.call(call_list)), + error = function(e) { + stop("On row ", i, " the print of the estimate failed: ", e$message) + } + ) } - - upViewport() - } - - # Output the legend if it is inside the main plot - if (!all(is.na(legend)) && - is.list(legend_args$pos)) { - plot_vp <- viewport( - layout.pos.row = 1:nr, - layout.pos.col = 2 * graph.pos - 1, - name = "main_plot_area" - ) - pushViewport(plot_vp) - - if ("align" %in% names(legend_args$pos) && legend_args$pos[["align"]] == "horizontal") { - # Calculated with padding above - height <- legend_horizontal_height - # Calculate the horizontal width by iterating througha all elements - # as each element may have a different width - width <- 0 - for (i in 1:length(lGrobs)) { - if (width > 0) { - width <- width + convertUnit(legend_colgap, unitTo = "npc", valueOnly = TRUE) - } - width <- width + convertUnit(attr(lGrobs, "max_height") + legend_colgap + attr(lGrobs[[i]], "width"), unitTo = "npc", valueOnly = TRUE) - } - # Add the padding - width <- unit(width + convertUnit(legend_args$padding, unitTo = "npc", valueOnly = TRUE) * 2, "npc") + } else { + shape_coordinates <- c(i, 1) + attr(shape_coordinates, "max.coords") <- c(attr(labels, "no_rows"), 1) + + if (obj$is.summary[i]) { + call_list <- + list(obj$fn.ci_sum[[i]], + lower_limit = low_values, + estimate = mean_values, + upper_limit = up_values, + size = info_values, + col = clr.summary, + shapes_gp = obj$shapes_gp, + shape_coordinates = shape_coordinates + ) } else { - legend_height <- attr(lGrobs, "line_height_and_spacing")[rep(1:2, length.out = length(legend) * 2 - 1)] - if (!is.null(attr(lGrobs, "title"))) { - legend_height <- unit.c( - attr(lGrobs, "titleHeight"), - attr(lGrobs, "line_height_and_spacing")[2], legend_height + call_list <- + list(obj$fn.ci_norm[[i]], + lower_limit = low_values, + estimate = mean_values, + upper_limit = up_values, + size = info_values, + clr.line = clr.line, + clr.marker = clr.marker, + lty = obj$lty.ci[[i]], + vertices.height = obj$ci.vertices.height, + shapes_gp = obj$shapes_gp, + shape_coordinates = shape_coordinates ) + + if (!is.null(obj$ci.vertices)) { + call_list$vertices <- obj$ci.vertices } - height <- sum(legend_args$padding, legend_height, legend_args$padding) - width <- legend_vertical_width + if (!is.null(obj$lwd.ci)) { + call_list$lwd <- obj$lwd.ci + } + } + + # Add additional arguments that are passed on + # from the original parameters + for (name in names(obj$extra_arguments)) { + call_list[[name]] <- obj$extra_arguments[[name]] + } + + # Do the actual drawing of the object + if (!all(is.na(mean_values))) { + tryCatch(eval(as.call(call_list)), + error = function(e) { + stop("On row ", i, " the print of the estimate failed: ", e$message) + } + ) } - pushViewport(viewport( - x = legend_args$pos[["x"]], - y = legend_args$pos[["y"]], - width = width, - height = height, - just = legend_args$pos[["just"]] - )) - # Draw the legend - prFpDrawLegend( - lGrobs = lGrobs, - col = col, - shapes_gp = shapes_gp, - colgap = legend_colgap, - pos = legend_args$pos, - gp = legend_args$gp, - r = legend_args$r, - padding = legend_args$padding, - fn.legend = fn.legend - ) - upViewport(2) } - # Go back to the original viewport - seekViewport("forestplot_margins") - upViewport(2) - }) + upViewport() + } + + if (length(legend) > 0 && + is.list(obj$legend_args$pos)) { + plot(legend, margin = FALSE, legend_args = obj$legend_args, col = obj$col, graph.pos = obj$graph.pos, shapes_gp = obj$shapes_gp, legend_colgap = obj$legend_colgap) + } + + # Go back to the original viewport + seekViewport("forestplot_margins") + upViewport(2) } diff --git a/R/forestplot.default.R b/R/forestplot.default.R index 32e4883..1fde88f 100644 --- a/R/forestplot.default.R +++ b/R/forestplot.default.R @@ -4,41 +4,41 @@ #' @importFrom checkmate assert_class assert_vector assert_matrix check_matrix check_array assert check_integer forestplot.default <- function(labeltext, mean, lower, upper, - align, + align = NULL, is.summary = FALSE, graph.pos = "right", - hrzl_lines, + hrzl_lines = NULL, clip = c(-Inf, Inf), xlab = "", zero = ifelse(xlog, 1, 0), graphwidth = "auto", - colgap, + colgap = NULL, lineheight = "auto", - line.margin, + line.margin = NULL, col = fpColors(), txt_gp = fpTxtGp(), xlog = FALSE, - xticks, + xticks = NULL, xticks.digits = 2, grid = FALSE, - lwd.xaxis, - lwd.zero, - lwd.ci, + lwd.xaxis = NULL, + lwd.zero = 1, + lwd.ci = NULL, lty.ci = 1, - ci.vertices, + ci.vertices = NULL, ci.vertices.height = .1, - boxsize, + boxsize = NULL, mar = unit(rep(5, times = 4), "mm"), - title, - legend, + title = NULL, + legend = NULL, legend_args = fpLegend(), new_page = getOption("forestplot_new_page", TRUE), fn.ci_norm = fpDrawNormalCI, fn.ci_sum = fpDrawSummaryCI, - fn.legend, + fn.legend = NULL, shapes_gp = fpShapesGp(), ...) { - if (missing(colgap)) { + if (is.null(colgap)) { colgap <- convertUnit(unit(6, "mm"), "npc", valueOnly = TRUE) if (colgap < .1) { colgap <- unit(.05, "npc") @@ -57,8 +57,8 @@ forestplot.default <- function(labeltext, assert_class(col, "fpColors") if (missing(lower) && - missing(upper) && - missing(mean)) { + missing(upper) && + missing(mean)) { if (missing(labeltext)) { stop( "You need to provide the labeltext or", @@ -71,7 +71,7 @@ forestplot.default <- function(labeltext, } if (missing(lower) && - missing(upper)) { + missing(upper)) { assert( check_matrix(mean, ncols = 3), check_array(mean, d = 3), @@ -94,7 +94,7 @@ forestplot.default <- function(labeltext, # Assume that lower and upper are contained within # the mean variable if (missing(lower) && - missing(upper)) { + missing(upper)) { if (NCOL(mean) != 3) { stop("If you do not provide lower/upper arguments your mean needs to have 3 columns") } @@ -110,8 +110,8 @@ forestplot.default <- function(labeltext, } if (NCOL(mean) != NCOL(lower) || - NCOL(lower) != NCOL(upper) || - NCOL(mean) == 0) { + NCOL(lower) != NCOL(upper) || + NCOL(mean) == 0) { stop( "Mean, lower and upper contain invalid number of columns", " Mean columns:", ncol(mean), @@ -126,7 +126,7 @@ forestplot.default <- function(labeltext, } # Prepare the legend marker - if (!missing(legend)) { + if (!is.null(legend)) { fn.legend <- prFpPrepareLegendMarker( fn.legend = fn.legend, col_no = NCOL(mean), @@ -142,7 +142,7 @@ forestplot.default <- function(labeltext, ) } - if (!missing(legend)) { + if (!is.null(legend)) { if (length(legend) != ncol(mean)) { stop( "If you want a legend you need to provide the same number of", @@ -191,17 +191,15 @@ forestplot.default <- function(labeltext, # from the original forestplot needs some changing to the parameters if (xlog) { if (any(mean < 0, na.rm = TRUE) || - any(lower < 0, na.rm = TRUE) || - any(upper < 0, na.rm = TRUE) || - (!is.na(zero) && zero <= 0) || - (!missing(clip) && any(clip <= 0, na.rm = TRUE)) || - (!missing(grid) && any(grid <= 0, na.rm = TRUE))) { - stop( - "All argument values (mean, lower, upper, zero, grid and clip)", - " should be provided in exponential form when using the log scale.", - " This is an intentional break with the original forestplot function in order", - " to simplify other arguments such as ticks, clips, and more." - ) + any(lower < 0, na.rm = TRUE) || + any(upper < 0, na.rm = TRUE) || + (!is.na(zero) && zero <= 0) || + (!is.null(clip) && any(Filter(Negate(is.infinite), clip) <= 0, na.rm = TRUE)) || + (!is.null(grid) && !isFALSE(grid) && any(grid <= 0, na.rm = TRUE))) { + stop("All argument values (mean, lower, upper, zero, grid and clip)", + " should be provided in exponential form when using the log scale.", + " This is an intentional break with the original forestplot function in order", + " to simplify other arguments such as ticks, clips, and more.") } # Change all the values along the log scale @@ -223,114 +221,12 @@ forestplot.default <- function(labeltext, upper <- as.vector(upper) } - nr <- NROW(org_mean) - - # Get the number of columns (nc) and number of rows (nr) - # if any columns are to be spacers the widthcolumn variable - if (is.expression(labeltext)) { - widthcolumn <- c(TRUE) - # Can't figure out multiple levels of expressions - nc <- 1 - label_type <- "expression" - label_nr <- length(labeltext) - } else if (is.list(labeltext)) { - if (all(sapply(labeltext, function(x) { - length(x) == 1 && - !is.list(x) - }))) { - labeltext <- - list(labeltext) - } - if (!prFpValidateLabelList(labeltext)) { - stop("Invalid labellist, it has to be formed as a matrix m x n elements") - } - - # Can't figure out multiple levels of expressions - nc <- length(labeltext) - - widthcolumn <- c() - # Should mark the columns that don't contain - # epressions, text or numbers as widthcolumns - for (col.no in seq(along = labeltext)) { - empty_row <- TRUE - for (row.no in seq(along = labeltext[[col.no]])) { - if (is.expression(labeltext[[col.no]][[row.no]]) || - !is.na(labeltext[[col.no]][[row.no]])) { - empty_row <- FALSE - break - } - } - widthcolumn <- append(widthcolumn, empty_row) - } - - label_type <- "list" - label_nr <- length(labeltext[[1]]) - } else if (is.vector(labeltext)) { - widthcolumn <- c(FALSE) - nc <- 1 - - labeltext <- matrix(labeltext, ncol = 1) - label_type <- "matrix" - label_nr <- NROW(labeltext) - } else { - # Original code for matrixes - widthcolumn <- !apply(is.na(labeltext), 1, any) - nc <- NCOL(labeltext) - label_type <- "matrix" - label_nr <- NROW(labeltext) - } - - if (nr != label_nr) { - stop( - "You have provided ", nr, " rows in your", - " mean arguement while the labels have ", label_nr, " rows" - ) - } - - if (is.character(graph.pos)) { - graph.pos <- - switch(graph.pos, - right = nc + 1, - last = nc + 1, - left = 1, - first = 1, - stop( - "The graph.pos argument has an invalid text argument.", - " The only values accepted are 'left'/'right' or 'first'/'last'.", - " You have provided the value '", graph.pos, "'" - ) - ) - } else if (is.numeric(graph.pos)) { - if (!graph.pos %in% 1:(nc + 1)) { - stop( - "The graph position must be between 1 and ", (nc + 1), ".", - " You have provided the value '", graph.pos, "'." - ) - } - } else { - stop( - "The graph pos must either be a string consisting of 'left'/'right' (alt. 'first'/'last')", - ", or an integer value between 1 and ", (nc + 1) - ) - } - - # Prepare the summary and align variables - if (missing(align)) { - if (graph.pos == 1) { - align <- rep("l", nc) - } else if (graph.pos == nc + 1) { - align <- c("l", rep("r", nc - 1)) - } else { - align <- c( - "l", - rep("c", nc - 1) - ) - } - } else { - align <- rep(align, length.out = nc) - } - - is.summary <- rep(is.summary, length = nr) + # Prep basics + labels <- prepLabelText(labeltext = labeltext, + nr = NROW(org_mean)) + graph.pos <- prepGraphPositions(graph.pos, nc = attr(labels, "no_cols")) + align <- prepAlign(align, graph.pos = graph.pos, nc = attr(labels, "no_cols")) + is.summary <- rep(is.summary, length.out = attr(labels, "no_rows")) if (is.matrix(mean)) { missing_rows <- apply(mean, 2, function(row) all(is.na(row))) @@ -360,111 +256,45 @@ forestplot.default <- function(labeltext, no_cols = NCOL(org_mean) ) - - hrzl_lines <- prFpGetLines( - hrzl_lines = hrzl_lines, - is.summary = is.summary, - total_columns = nc + 1, - col = col, - shapes_gp = shapes_gp - ) - - labels <- prFpGetLabels( - label_type = label_type, - labeltext = labeltext, - align = align, - nc = nc, - nr = nr, - is.summary = is.summary, - txt_gp = txt_gp, - col = col - ) - - # There is always at least one column so grab the widest one - # and have that as the base for the column widths - colwidths <- unit.c(prFpFindWidestGrob(labels[[1]])) - - # If multiple row label columns, add the other column widths - if (nc > 1) { - for (i in 2:nc) { - colwidths <- unit.c( - colwidths, - colgap, - prFpFindWidestGrob(labels[[i]]) - ) - } - } - - axisList <- prFpGetGraphTicksAndClips( - xticks = xticks, - xticks.digits = xticks.digits, - grid = grid, - xlog = xlog, - xlab = xlab, - lwd.xaxis = lwd.xaxis, - txt_gp = txt_gp, - col = col, - clip = clip, - zero = zero, - x_range = prFpXrange( - upper = upper, - lower = lower, - clip = clip, - zero = zero, - xticks = xticks, - xlog = xlog - ), - mean = org_mean, - graph.pos = graph.pos, - shapes_gp = shapes_gp - ) - - handleMissing <- function(x, default = NA) { - if (missing(x)) { - return(default) - } - x - } - - structure(list( - labels = labels, - mean = mean, - upper = upper, - lower = lower, - mar = mar, - title = handleMissing(title), - legend = handleMissing(legend), - legend_args = legend_args, - txt_gp = txt_gp, - colgap = colgap, - lineheight = lineheight, - nc = nc, - nr = nr, - col = col, - graphwidth = graphwidth, - colwidths = colwidths, - graph.pos = graph.pos, - axisList = axisList, - boxsize = handleMissing(boxsize), - is.summary = is.summary, - org_mean = org_mean, - hrzl_lines = hrzl_lines, - shapes_gp = shapes_gp, - org_lower = org_lower, - org_upper = org_upper, - line.margin = handleMissing(line.margin), - fn.legend = handleMissing(fn.legend), - fn.ci_sum = fn.ci_sum, - fn.ci_norm = fn.ci_norm, - lty.ci = lty.ci, - ci.vertices.height = ci.vertices.height, - ci.vertices = handleMissing(ci.vertices), - lwd.zero = handleMissing(lwd.zero, default = 1), - lwd.ci = handleMissing(lwd.ci), - extra_arguments = list(...) - ), - class = "gforge_forestplot" - ) + list(labels = labels, + mean = mean, + upper = upper, + lower = lower, + mar = mar, + align = align, + title = title, + legend = legend, + legend_args = legend_args, + txt_gp = txt_gp, + colgap = colgap, + lineheight = lineheight, + col = col, + graphwidth = graphwidth, + graph.pos = graph.pos, + boxsize = boxsize, + is.summary = is.summary, + org_mean = org_mean, + shapes_gp = shapes_gp, + hrzl_lines = hrzl_lines, + org_lower = org_lower, + org_upper = org_upper, + line.margin = line.margin, + fn.legend = fn.legend, + fn.ci_sum = fn.ci_sum, + fn.ci_norm = fn.ci_norm, + lty.ci = lty.ci, + ci.vertices.height = ci.vertices.height, + ci.vertices = ci.vertices, + lwd.zero = lwd.zero, + lwd.ci = lwd.ci, + xticks = xticks, + xticks.digits = xticks.digits, + xlog = xlog, + clip = clip, + zero = zero, + lwd.xaxis = lwd.xaxis, + extra_arguments = list(...)) |> + structure(class = "gforge_forestplot") } #' @rdname forestplot diff --git a/R/forestplot.grouped_df.R b/R/forestplot.grouped_df.R index 4074365..be24d81 100644 --- a/R/forestplot.grouped_df.R +++ b/R/forestplot.grouped_df.R @@ -150,7 +150,7 @@ forestplot.grouped_df <- function(x, labeltext, mean, lower, upper, legend, is.s .fp_groups, {{value_col}}) |> tidyr::pivot_wider(names_from = .fp_groups, values_from = {{value_col}}, names_prefix = "@estimates@") |> - dplyr::select(starts_with("@estimates@")) |> + dplyr::select(dplyr::starts_with("@estimates@")) |> dplyr::rename_with(\(x) sub(pattern = "^@estimates@", replacement = "", x = x)) |> diff --git a/R/prFpDrawLegend.R b/R/prFpDrawLegend.R index 5cc870a..99334dd 100644 --- a/R/prFpDrawLegend.R +++ b/R/prFpDrawLegend.R @@ -5,7 +5,6 @@ #' #' @param lGrobs A list with all the grobs, see \code{\link{prFpGetLegendGrobs}} #' @param col The colors of the legends. -#' @param colgap The gap between the box and the text #' @param fn.legend The function for drawing the marker #' @param ... Passed to the legend \code{fn.legend} #' @return \code{void} @@ -13,34 +12,33 @@ #' @inheritParams forestplot #' @inheritParams fpLegend #' -#' @keywords internal +#' @noRd prFpDrawLegend <- function(lGrobs, - col, - shapes_gp, - colgap, - pos, - gp, + fn.legend, r, padding, - fn.legend, ...) { - if (!inherits(lGrobs, "Legend")) { - stop("The lGrobs object should be created by the internal Gmisc:::prFpGetLegendGrobs and be of class 'Legend'.") + if (!inherits(lGrobs, "forestplot_legend")) { + stop("The lGrobs object should be created by the internal Gmisc:::buildLegend and be of class 'forestplot_legend'.") } # Draw the rounded rectangle at first # if there is a gpar specified. - if (length(gp) > 0) { - grid.roundrect(gp = gp, r = r) - inner_vp <- viewport( + decorateWithRoundRect <- length(attr(lGrobs, "gp")) > 0 + if (decorateWithRoundRect) { + grid.roundrect(gp = attr(lGrobs, "gp"), r = r) + viewport( width = unit(1, "npc") - padding - padding, height = unit(1, "npc") - padding - padding - ) - pushViewport(inner_vp) + ) |> + pushViewport() } - if ((!is.list(pos) && pos == "top") || - (is.list(pos) && "align" %in% names(pos) && pos[["align"]] == "horizontal")) { + pos <- attr(lGrobs, "pos") + if (inherits(pos, "forestplot_legend_position")) { + orientation <- pos$orientation + } else if ((!is.list(pos) && pos == "top") || + (is.list(pos) && "align" %in% names(pos) && pos[["align"]] == "horizontal")) { orientation <- "horizontal" } else { orientation <- "vertical" @@ -48,25 +46,29 @@ prFpDrawLegend <- function(lGrobs, boxSize <- attr(lGrobs, "max_height") - drawBox <- function(vp, i, col, lGrobs) { + drawBox <- function(vp, i, lGrobs) { pushViewport(vp) shape_coordinates <- c(1, i) attr(shape_coordinates, "max.coords") <- c(1, length(lGrobs)) + col <- attr(lGrobs, "col") + clr.marker <- rep(col$box, length.out = length(lGrobs))[i] + clr.line <- rep(col$lines, length.out = length(lGrobs))[i] + call_list <- list(fn.legend[[i]], - lower_limit = 0, - estimate = .5, - upper_limit = 1, - size = attr(lGrobs, "max_height"), - y.offset = .5, - clr.marker = col$box[i], - clr.line = col$lines[i], - shapes_gp = shapes_gp, - shape_coordinates = shape_coordinates, - lwd = 1, - ... = ... + lower_limit = 0, + estimate = .5, + upper_limit = 1, + size = attr(lGrobs, "max_height"), + y.offset = .5, + clr.marker = clr.marker, + clr.line = clr.line, + shape_coordinates = shape_coordinates, + lwd = 1, + shapes_gp = attr(lGrobs, "shapes_gp"), + ... = ... ) # Do the actual drawing of the object @@ -75,6 +77,7 @@ prFpDrawLegend <- function(lGrobs, upViewport() } + colgap <- attr(lGrobs, "colgap") if (orientation == "horizontal") { # Output the horizontal boxes and texts widths <- NULL @@ -123,7 +126,7 @@ prFpDrawLegend <- function(lGrobs, layout.pos.col = 1 + offset, xscale = c(0, 1) ) - drawBox(vp, i, col, lGrobs) + drawBox(vp, i, lGrobs) vp <- viewport( layout.pos.row = row, layout.pos.col = 3 + offset @@ -177,7 +180,7 @@ prFpDrawLegend <- function(lGrobs, layout.pos.col = 1, xscale = c(0, 1) ) - drawBox(vp, i, col, lGrobs) + drawBox(vp, i, lGrobs) vp <- viewport( layout.pos.row = row_start + (i - 1) * 2, @@ -190,7 +193,7 @@ prFpDrawLegend <- function(lGrobs, upViewport() } - if (length(gp) > 0) { + if (decorateWithRoundRect) { upViewport() } } diff --git a/R/prFpGetGraphTicksAndClips.R b/R/prFpGetGraphTicksAndClips.R index 99501ef..87089fd 100644 --- a/R/prFpGetGraphTicksAndClips.R +++ b/R/prFpGetGraphTicksAndClips.R @@ -10,7 +10,7 @@ #' #' #' @inheritParams forestplot -#' @keywords internal +#' @noRd prFpGetGraphTicksAndClips <- function(xticks, xticks.digits, grid, @@ -47,22 +47,22 @@ prFpGetGraphTicksAndClips <- function(xticks, clip <- log(clip) zero <- log(zero) - if (missing(xticks)) { + if (is.null(xticks)) { ticks <- getTicks(exp(x_range), - clip = clip, - exp = xlog, - digits = xticks.digits + clip = clip, + exp = xlog, + digits = xticks.digits ) # Add the endpoint ticks to the tick list if # it's not already there if (is.infinite(clip[1]) == FALSE && - min(ticks, na.rm = TRUE) < clip[1]) { + min(ticks, na.rm = TRUE) < clip[1]) { ticks <- unique(c(exp(clip[1]), ticks)) } if (is.infinite(clip[2]) == FALSE && - max(ticks, na.rm = TRUE) > clip[2]) { + max(ticks, na.rm = TRUE) > clip[2]) { ticks <- unique(c(ticks, exp(clip[2]))) } @@ -92,8 +92,8 @@ prFpGetGraphTicksAndClips <- function(xticks, # Decide on the number of digits, if below zero then there should # be by default one more digit ticklabels <- ifelse(ticks < 1 | abs(floor(ticks * 10) - ticks * 10) > 0, - format(ticks, digits = 2, nsmall = 2), - format(ticks, digits = 1, nsmall = 1) + format(ticks, digits = 2, nsmall = 2), + format(ticks, digits = 1, nsmall = 1) ) ticks <- log(ticks) } else { @@ -101,22 +101,22 @@ prFpGetGraphTicksAndClips <- function(xticks, ticklabels <- FALSE } } else { - if (missing(xticks)) { + if (is.null(xticks)) { ticks <- getTicks(x_range, - clip = clip, - exp = xlog, - digits = xticks.digits + clip = clip, + exp = xlog, + digits = xticks.digits ) # Add the endpoint ticks to the tick list if # it's not already there if (is.infinite(clip[1]) == FALSE && - min(ticks, na.rm = TRUE) < clip[1]) { + min(ticks, na.rm = TRUE) < clip[1]) { ticks <- unique(c(clip[1], ticks)) } if (is.infinite(clip[2]) == FALSE && - max(ticks, na.rm = TRUE) > clip[2]) { + max(ticks, na.rm = TRUE) > clip[2]) { ticks <- unique(c(ticks, clip[2])) } @@ -144,9 +144,9 @@ prFpGetGraphTicksAndClips <- function(xticks, # Clean if (any(ticks < .Machine$double.eps & - ticks > -.Machine$double.eps)) { + ticks > -.Machine$double.eps)) { ticks[ticks < .Machine$double.eps & - ticks > -.Machine$double.eps] <- 0 + ticks > -.Machine$double.eps] <- 0 } @@ -162,13 +162,13 @@ prFpGetGraphTicksAndClips <- function(xticks, if (length(ticks) != 1 || ticks != 0) { gp_list <- txt_gp$ticks gp_list$col <- col$axes - if (!missing(lwd.xaxis)) { + if (!is.null(lwd.xaxis)) { gp_list$lwd <- lwd.xaxis } gp_axis <- prGetShapeGp(shapes_gp, NULL, "axes", default = do.call(grid::gpar, gp_list)) - if (!missing(xticks) && - !is.null(attr(xticks, "labels"))) { + if (!is.null(xticks) && + !is.null(attr(xticks, "labels"))) { labattr <- attr(xticks, "labels") if (length(labattr) != length(ticks)) { stop( @@ -194,7 +194,7 @@ prFpGetGraphTicksAndClips <- function(xticks, ) if (length(grid) == 1) { if (is.logical(grid) && - grid == TRUE) { + grid == TRUE) { grid <- ticks } } @@ -236,7 +236,7 @@ prFpGetGraphTicksAndClips <- function(xticks, gp_list$col <- col$axes # Write the label for the x-axis labGrob <- textGrob(xlab, - gp = do.call(gpar, gp_list) + gp = do.call(gpar, gp_list) ) } else { labGrob <- FALSE diff --git a/R/prepGridMargins.R b/R/prepGridMargins.R new file mode 100644 index 0000000..e441b81 --- /dev/null +++ b/R/prepGridMargins.R @@ -0,0 +1,20 @@ +#' Convert margins to viewport npc margins +#' +#' @param mar A vector of margins, at positions: +#' - 1 = bottom +#' - 2 = left +#' - 3 = top +#' - 4 = right +#' +#' @return Returns a list with `bottom`, `left`, `top`, and `right` as `unit("npc")` +prepGridMargins <- function(mar) { + mar <- rep(mar, length.out = 4) + marList <- list() + + # This breaks without separate variables + marList$bottom <- convertY(mar[1], "npc") + marList$left <- convertX(mar[2], "npc") + marList$top <- convertY(mar[3], "npc") + marList$right <- convertX(mar[4], "npc") + return(marList) +} diff --git a/R/private.R b/R/private.R index 26ad238..0f1d99b 100644 --- a/R/private.R +++ b/R/private.R @@ -270,7 +270,7 @@ prPopulateList <- function(elmnt, no_rows, no_cols, missing_rows, is.summary, su #' @return void #' #' @inheritParams forestplot -#' @keywords internal +#' @noRd prFpPrintXaxis <- function(axisList, col, lwd.zero, @@ -404,68 +404,6 @@ prListRep <- function(x, length.out) { ) } -#' Gets the forestplot legend grobs -#' -#' @return \code{list} A "Legend" class that derives from a -#' list with all the different legends. The list also contains -#' attributes such as height, width, max_height, -#' max_width, line_height_and_spacing. The title of the -#' legend is saved inside \code{attr("title")} -#' -#' @inheritParams forestplot -#' @inheritParams fpLegend -#' @keywords internal -prFpGetLegendGrobs <- function(legend, - txt_gp, - title) { - lGrobs <- list() - max_width <- 0 - max_height <- 0 - gp <- prListRep(txt_gp$legend, length.out = length(legend)) - for (n in 1:length(legend)) { - lGrobs[[n]] <- textGrob(legend[n], - x = 0, just = "left", - gp = do.call(gpar, gp[[n]]) - ) - - gw <- convertUnit(grobWidth(lGrobs[[n]]), "mm", valueOnly = TRUE) - gh <- convertUnit(grobHeight(lGrobs[[n]]), "mm", valueOnly = TRUE) - if (gw > max_width) { - max_width <- gw - } - if (gh > max_height) { - max_height <- gh - } - - attr(lGrobs[[n]], "width") <- unit(gw, "mm") - attr(lGrobs[[n]], "height") <- unit(gh, "mm") - } - attr(lGrobs, "max_height") <- unit(max_height, "mm") - attr(lGrobs, "max_width") <- unit(max_width, "mm") - attr(lGrobs, "line_height_and_spacing") <- unit.c( - attr(lGrobs, "max_height"), - unit(.5, "lines") - ) - - # Do title stuff if present - if (is.character(title)) { - title <- textGrob(title, - x = 0, just = "left", - gp = do.call(gpar, txt_gp$legend.title) - ) - attr(lGrobs, "title") <- title - - attr(lGrobs, "titleHeight") <- grobHeight(title) - attr(lGrobs, "titleWidth") <- grobHeight(title) - if (convertUnit(attr(lGrobs, "titleWidth"), unitTo = "npc", valueOnly = TRUE) > - convertUnit(attr(lGrobs, "max_width"), unitTo = "npc", valueOnly = TRUE)) { - attr(lGrobs, "max_width") <- attr(lGrobs, "titleWidth") - } - } - class(lGrobs) <- c("Legend", class(lGrobs)) - return(lGrobs) -} - #' Gets the x-axis range #' #' If the borders are smaller than the upper/lower limits @@ -487,7 +425,7 @@ prFpXrange <- function(upper, lower, clip, zero, xticks, xlog) { # endpoints unless there are pre-specified # ticks indicating that the end-points aren't # included in the x-axis - if (missing(xticks)) { + if (is.null(xticks)) { ret <- c( min( zero, @@ -520,159 +458,6 @@ prFpXrange <- function(upper, lower, clip, zero, xticks, xlog) { } } -#' Gets the forestplot labels -#' -#' A function that gets all the labels -#' -#' @param label_type The type of text labels -#' @param align Alignment, should be equal to \code{length(nc} -#' @param nc Number of columns -#' @param nr Number of rows -#' @return \code{list} A list with \code{length(nc)} where each element contains -#' a list of \code{length(nr)} elements with attributes width/height for each -#' element and max_width/max_height for the total -#' -#' @inheritParams forestplot -#' @keywords internal -prFpGetLabels <- function(label_type, labeltext, align, - nc, nr, - is.summary, - txt_gp, - col) { - labels <- vector("list", nc) - - if (attr(txt_gp$label, "txt_dim") %in% 0:1) { - txt_gp$label <- prListRep(list(prListRep(txt_gp$label, nc)), sum(!is.summary)) - } else { - ncols <- sapply(txt_gp$label, length) - if (all(ncols != ncols[1])) { - stop( - "Your fpTxtGp$label list has invalid number of columns", - ", they should all be of equal length - yours have ", - "'", paste(ncols, collapse = "', '"), "'" - ) - } - if (length(txt_gp$label) != sum(!is.summary)) { - stop( - "Your fpTxtGp$label list has invalid number of rows", - ", the should be equal the of the number rows that aren't summaries.", - " you have '", length(txt_gp$label), "' rows in the fpTxtGp$label", - ", while the labeltext argument has '", nr, "' rows", - " where '", sum(!is.summary), "' are not summaries." - ) - } - } - - if (attr(txt_gp$summary, "txt_dim") %in% 0:1) { - txt_gp$summary <- - prListRep(list(prListRep(txt_gp$summary, nc)), sum(is.summary)) - } else { - ncols <- sapply(txt_gp$summary, length) - if (all(ncols != ncols[1])) { - stop( - "Your fpTxtGp$summary list has invalid number of columns", - ", they should all be of equal length - yours have ", - "'", paste(ncols, collapse = "', '"), "'" - ) - } - if (length(txt_gp$summary) != sum(is.summary)) { - stop( - "Your fpTxtGp$summary list has invalid number of rows", - ", the should be equal the of the number rows that aren't summaries.", - " you have '", length(txt_gp$summary), "' rows in the fpTxtGp$summary", - ", while the labeltext argument has '", nr, "' rows", - " where '", sum(is.summary), "' are not summaries." - ) - } - } - - max_height <- NULL - max_width <- NULL - # Walk through the labeltext - # Creates a list matrix with - # The column part - for (j in 1:nc) { - labels[[j]] <- vector("list", nr) - - # The row part - for (i in 1:nr) { - txt_out <- prFpFetchRowLabel(label_type, labeltext, i, j) - # If it's a call created by bquote or similar it - # needs evaluating - if (is.call(txt_out)) { - txt_out <- eval(txt_out) - } - - if (is.expression(txt_out) || is.character(txt_out) || is.numeric(txt_out) || is.factor(txt_out)) { - x <- switch(align[j], - l = 0, - r = 1, - c = 0.5 - ) - - just <- switch(align[j], - l = "left", - r = "right", - c = "center" - ) - - # Bold the text if this is a summary - if (is.summary[i]) { - x <- switch(align[j], - l = 0, - r = 1, - c = 0.5 - ) - - gp_list <- txt_gp$summary[[sum(is.summary[1:i])]][[j]] - gp_list[["col"]] <- rep(col$text, length = nr)[i] - - # Create a textGrob for the summary - # The row/column order is in this order - # in order to make the following possible: - # list(rownames(x), list(expression(1 >= a), "b", "c")) - labels[[j]][[i]] <- - textGrob(txt_out, - x = x, - just = just, - gp = do.call(gpar, gp_list) - ) - } else { - gp_list <- txt_gp$label[[sum(!is.summary[1:i])]][[j]] - if (is.null(gp_list$col)) { - gp_list[["col"]] <- rep(col$text, length = nr)[i] - } - - # Create a textGrob with the current row-cell for the label - labels[[j]][[i]] <- - textGrob(txt_out, - x = x, - just = just, - gp = do.call(gpar, gp_list) - ) - } - - attr(labels[[j]][[i]], "height") <- grobHeight(labels[[j]][[i]]) - attr(labels[[j]][[i]], "width") <- grobWidth(labels[[j]][[i]]) - if (is.null(max_height)) { - max_height <- attr(labels[[j]][[i]], "height") - max_width <- attr(labels[[j]][[i]], "width") - } else { - max_height <- max(max_height, attr(labels[[j]][[i]], "height")) - max_width <- max(max_width, attr(labels[[j]][[i]], "width")) - } - } - } - } - attr(labels, "max_height") <- max_height - attr(labels, "max_width") <- max_width - attr(labels, "cex") <- ifelse(any(is.summary), - txt_gp$summary[[1]][[1]]$cex, - txt_gp$label[[1]][[1]]$cex - ) - return(labels) -} - #' Get the label #' #' A function used for fetching the text or @@ -715,29 +500,25 @@ prFpFetchRowLabel <- function(label_type, labeltext, i, j) { #' The layout makes space for a legend if needed #' #' @param labels The labels -#' @param nr Number of rows #' @param legend_layout A legend layout object if applicable #' @return \code{viewport} Returns the `viewport` needed #' #' @inheritParams forestplot #' @keywords internal -prFpGetLayoutVP <- function(lineheight, labels, nr, legend_layout = NULL) { +prFpGetLayoutVP <- function(lineheight, labels, legend_layout = NULL) { if (!is.unit(lineheight)) { if (lineheight == "auto") { lvp_height <- unit(1, "npc") } else if (lineheight == "lines") { - lvp_height <- unit(nr * attr(labels, "cex") * 1.5, "lines") + lvp_height <- unit(attr(labels, "no_rows") * attr(labels, "cex") * 1.5, "lines") } else { stop("The lineheight option '", lineheight, "'is yet not implemented") } } else { - lvp_height <- unit( - convertY(lineheight, - unitTo = "lines", - valueOnly = TRUE - ) * nr, - "lines" - ) + lvp_height <- (convertY(lineheight, + unitTo = "lines", + valueOnly = TRUE) * attr(labels, "no_rows")) |> + unit("lines") } # If there is a legend on top then the size should be adjusted @@ -904,7 +685,7 @@ prFpGetLegendBoxPosition <- function(pos) { #' #' @keywords internal prFpPrepareLegendMarker <- function(fn.legend, col_no, row_no, fn.ci_norm) { - if (!missing(fn.legend)) { + if (!is.null(fn.legend)) { if (is.function(fn.legend)) { return(lapply(1:col_no, function(x) fn.legend)) } @@ -1173,17 +954,17 @@ prGetTextGrobCex <- function(x) { #' @inheritParams forestplot #' @keywords internal #' @importFrom utils tail -prFpGetLines <- function(hrzl_lines, +prFpGetLines <- function(hrzl_lines = NULL, is.summary, total_columns, col, shapes_gp = fpShapesGp()) { ret_lines <- lapply(1:(length(is.summary) + 1), function(x) NULL) - if (missing(hrzl_lines) || - (is.logical(hrzl_lines) && - all(hrzl_lines == FALSE)) || - (is.list(hrzl_lines) && - all(sapply(hrzl_lines, is.null)))) { + if (is.null(hrzl_lines) || + (is.logical(hrzl_lines) && + all(hrzl_lines == FALSE)) || + (is.list(hrzl_lines) && + all(sapply(hrzl_lines, is.null)))) { return(ret_lines) } diff --git a/R/private_buildLegend.R b/R/private_buildLegend.R new file mode 100644 index 0000000..948a364 --- /dev/null +++ b/R/private_buildLegend.R @@ -0,0 +1,173 @@ +#' Gets the legend to output +#' +#' @param legend The legend to output +#' @param txt_gp The text styling +#' @param legend_args Legend arguments +#' @param colgap The column gap +#' @param lineheight The line height +#' @param fn.legend The function for plotting the legend +#' +#' @inheritParams forestplot.default +#' @returns `forestplot_legend` object with attributes `main` and `pos` +#' @noRd +buildLegend <- function(legend, + txt_gp, + legend_args, + colgap, + col, + shapes_gp, + lineheight, + fn.legend) { + if (is.null(legend)) { + return(structure(list(), + pos = NULL, + main = NULL, + class = "forestplot_legend" + )) + } + + lGrobs <- list() + max_width <- 0 + max_height <- 0 + gp <- prListRep(txt_gp$legend, length.out = length(legend)) + for (n in 1:length(legend)) { + lGrobs[[n]] <- textGrob(legend[n], + x = 0, just = "left", + gp = do.call(gpar, gp[[n]]) + ) + + gw <- convertUnit(grobWidth(lGrobs[[n]]), "mm", valueOnly = TRUE) + gh <- convertUnit(grobHeight(lGrobs[[n]]), "mm", valueOnly = TRUE) + if (gw > max_width) { + max_width <- gw + } + if (gh > max_height) { + max_height <- gh + } + + attr(lGrobs[[n]], "width") <- unit(gw, "mm") + attr(lGrobs[[n]], "height") <- unit(gh, "mm") + } + max_height <- unit(max_height, "mm") + max_width <- unit(max_width, "mm") + line_height_and_spacing <- unit.c(max_height, unit(.5, "lines")) + + title_attributes <- list() + # Do title stuff if present + if (is.character(legend_args$title)) { + title <- textGrob(legend_args$title, + x = 0, just = "left", + gp = do.call(gpar, txt_gp$legend.title)) + title_attributes$title <- title + + title_attributes$titleHeight <- grobHeight(title) + title_attributes$titleWidth <- grobHeight(title) + if (convertUnit(title_attributes$titleWidth, unitTo = "npc", valueOnly = TRUE) > + convertUnit(max_width, unitTo = "npc", valueOnly = TRUE)) { + max_width <- title_attributes$titleWidth + } + } + + + legend_colgap <- colgap + if (convertUnit(legend_colgap, unitTo = "mm", valueOnly = TRUE) > + convertUnit(max_height, unitTo = "mm", valueOnly = TRUE)) { + legend_colgap <- max_height + } + + legend_horizontal_height <- sum( + legend_args$padding, + max_height, + legend_args$padding + ) + if (!is.null(title_attributes$title)) { + legend_horizontal_height <- unit.c( + title_attributes$titleHeight, + line_height_and_spacing[2], + legend_horizontal_height) |> + sum() + } + + legend_vertical_width <- unit.c( + legend_args$padding, + max_height, + legend_colgap, + max_width, + legend_args$padding + ) |> sum() + + # Prepare the viewports if the legend is not + # positioned inside the forestplot, i.e. on the top or right side + if ((!is.list(legend_args$pos) && legend_args$pos == "top") || + ("align" %in% names(legend_args$pos) && legend_args$pos[["align"]] == "horizontal")) { + legend_layout <- grid.layout( + nrow = 3, ncol = 1, + heights = unit.c( + legend_horizontal_height, + legend_colgap + legend_colgap, + unit(1, "npc") - + legend_horizontal_height - + legend_colgap - + legend_colgap + ) + ) + + legend_pos <- list( + row = 1, + col = 1, + orientation = "horizontal" + ) + main_pos <- list( + row = 3, + col = 1 + ) + } else { + legend_layout <- grid.layout( + nrow = 1, ncol = 3, + widths = unit.c( + unit(1, "npc") - + legend_colgap - + legend_vertical_width, + legend_colgap, + legend_vertical_width + ) + ) + legend_pos <- list( + row = 1, + col = 3, + orientation = "vertical" + ) + main_pos <- list( + row = 1, + col = 1 + ) + } + + position_desc <- legend_args$pos + if (!is.list(position_desc)) { + position_desc <- structure(legend_pos, + class = "forestplot_legend_position") + } + + lGrobs |> + structure(layout = legend_layout, + pos = position_desc, + main = main_pos, + gp = legend_args$gp, + r = legend_args$r, + padding = legend_args$padding, + col = col, + shapes_gp = shapes_gp, + max_height = max_height, + max_width = max_width, + line_height_and_spacing = line_height_and_spacing, + title = title_attributes$title, + titleHeight = title_attributes$titleHeight, + titleWidth = title_attributes$titleWidth, + colgap = legend_colgap, + lineheight = lineheight, + fn.legend = fn.legend, + legend_vertical_width = legend_vertical_width, + legend_horizontal_height = legend_horizontal_height, + class = c("forestplot_legend", class(lGrobs))) +} diff --git a/R/private_getColWidths.R b/R/private_getColWidths.R new file mode 100644 index 0000000..bb464ac --- /dev/null +++ b/R/private_getColWidths.R @@ -0,0 +1,48 @@ +getColWidths <- function(labels, graphwidth, colgap, graph.pos, nc) { + # There is always at least one column so grab the widest one + # and have that as the base for the column widths + colwidths <- unit.c(prFpFindWidestGrob(labels[[1]])) + # If multiple row label columns, add the other column widths + if (attr(labels, "no_cols") > 1) { + for (i in 2:attr(labels, "no_cols")) { + colwidths <- unit.c(colwidths, + colgap, + prFpFindWidestGrob(labels[[i]])) + } + } + + ########################################### + # Normalize the widths to cover the whole # + # width of the graph space. # + ########################################### + if (!is.unit(graphwidth) && + graphwidth == "auto") { + # If graph width is not provided as a unit the autosize it to the + # rest of the space available + npc_colwidths <- convertUnit(unit.c(colwidths, colgap), "npc", valueOnly = TRUE) + graphwidth <- unit(max(.05, 1 - sum(npc_colwidths)), "npc") + } else if (!is.unit(graphwidth)) { + stop( + "You have to provide graph width either as a unit() object or as 'auto'.", + " Auto sizes the graph to maximally use the available space.", + " If you want to have exact mm width then use graphwidth = unit(34, 'mm')." + ) + } + + # Add the base grapwh width to the total column width + # default is 2 inches + if (graph.pos == 1) { + colwidths <- unit.c(graphwidth, colgap, colwidths) + } else if (graph.pos == attr(labels, "no_cols") + 1) { + colwidths <- unit.c(colwidths, colgap, graphwidth) + } else { + spl_position <- ((graph.pos - 1) * 2 - 1) + colwidths <- unit.c( + colwidths[1:spl_position], + colgap, + graphwidth, + colwidths[(spl_position + 1):length(colwidths)] + ) + } + +} diff --git a/R/private_plot.forestplot_legend.R b/R/private_plot.forestplot_legend.R new file mode 100644 index 0000000..9ddf314 --- /dev/null +++ b/R/private_plot.forestplot_legend.R @@ -0,0 +1,105 @@ +plot.forestplot_legend <- function(x, margin, legend_args, graph.pos, legend_colgap, ...) { + # No forestplot to output + if (length(x) == 0) { + return() + } + + if (margin) { + return(pr_plot_forestplot_legend_at_margin(x)) + } + + return(pr_plot_forestplot_legend_inside_plot(x, legend_args = legend_args, graph.pos = graph.pos, legend_colgap = legend_colgap)) +} + +pr_plot_forestplot_legend_at_margin <- function(x) { + # If the legend should be positioned within the plot then wait + # until after the plot has been drawn + if (!inherits(attr(x, "pos"), "forestplot_legend_position")) { + return(prFpGetLayoutVP( + lineheight = attr(x, "lineheight"), + labels = x + ) |> + pushViewport()) + } + + prFpGetLayoutVP( + labels = x, + lineheight = attr(x, "lineheight"), + legend_layout = attr(x, "layout") + ) |> + pushViewport() + viewport( + layout.pos.row = attr(x, "pos")$row, + layout.pos.col = attr(x, "pos")$col, + name = "legend" + ) |> + pushViewport() + + # Draw the legend + prFpDrawLegend( + lGrobs = x, + fn.legend = attr(x, "fn.legend") + ) + upViewport() + + # Reset to the main plot + return(viewport( + layout.pos.row = attr(x, "main")$row, + layout.pos.col = attr(x, "main")$col, + name = "main" + ) |> + pushViewport()) +} + +pr_plot_forestplot_legend_inside_plot <- function(x, graph.pos, shapes_gp, legend_args, legend_colgap) { + plot_vp <- viewport( + layout.pos.col = 2 * graph.pos - 1, + name = "main_plot_area" + ) + pushViewport(plot_vp) + + if ("align" %in% names(legend_args$pos) && legend_args$pos[["align"]] == "horizontal") { + # Calculated with padding above + height <- attr(x, "legend_horizontal_height") + # Calculate the horizontal width by iterating througha all elements + # as each element may have a different width + width <- 0 + for (i in 1:length(x)) { + if (width > 0) { + width <- width + convertUnit(legend_colgap, unitTo = "npc", valueOnly = TRUE) + } + width <- width + convertUnit(attr(x, "max_height") + legend_colgap + attr(x[[i]], "width"), unitTo = "npc", valueOnly = TRUE) + } + # Add the padding + width <- unit(width + convertUnit(legend_args$padding, unitTo = "npc", valueOnly = TRUE) * 2, "npc") + } else { + legend_height <- attr(x, "line_height_and_spacing")[rep(1:2, length.out = length(x) * 2 - 1)] + if (!is.null(attr(x, "title"))) { + legend_height <- unit.c( + attr(x, "titleHeight"), + attr(x, "line_height_and_spacing")[2], legend_height + ) + } + + height <- sum(legend_args$padding, legend_height, legend_args$padding) + width <- attr(x, "legend_vertical_width") + } + pushViewport(viewport( + x = legend_args$pos[["x"]], + y = legend_args$pos[["y"]], + width = width, + height = height, + just = legend_args$pos[["just"]] + )) + # Draw the legend + prFpDrawLegend( + lGrobs = x, + colgap = legend_colgap, + pos = legend_args$pos, + gp = legend_args$gp, + r = legend_args$r, + padding = legend_args$padding, + fn.legend = attr(x, "fn.legend") + ) + upViewport(2) +} diff --git a/R/private_prGetLabelsList.R b/R/private_prGetLabelsList.R new file mode 100644 index 0000000..0969c7a --- /dev/null +++ b/R/private_prGetLabelsList.R @@ -0,0 +1,152 @@ +#' Gets the forestplot labels +#' +#' A function that gets all the labels +#' +#' @param labels A `forestplot_labeltext` object +#' @param align Alignment, should be equal to \code{attr(labels, "no_cols")} +#' @return \code{list} A list with \code{attr(labels, "no_cols")} where each element contains +#' a list of \code{attr(labels, "no_rows")} elements with attributes width/height for each +#' element and max_width/max_height for the total +#' +#' @inheritParams forestplot +#' @keywords internal +prGetLabelsList <- function(labels, + align, + is.summary, + txt_gp, + col) { + if (attr(txt_gp$label, "txt_dim") %in% 0:1) { + txt_gp$label <- prListRep(list(prListRep(txt_gp$label, attr(labels, "no_cols"))), sum(!is.summary)) + } else { + ncols <- sapply(txt_gp$label, length) + if (all(ncols != ncols[1])) { + stop( + "Your fpTxtGp$label list has invalid number of columns", + ", they should all be of equal length - yours have ", + "'", paste(ncols, collapse = "', '"), "'" + ) + } + if (length(txt_gp$label) != sum(!is.summary)) { + stop( + "Your fpTxtGp$label list has invalid number of rows", + ", the should be equal the of the number rows that aren't summaries.", + " you have '", length(txt_gp$label), "' rows in the fpTxtGp$label", + ", while the labeltext argument has '", attr(labels, "no_rows"), "' rows", + " where '", sum(!is.summary), "' are not summaries." + ) + } + } + + if (attr(txt_gp$summary, "txt_dim") %in% 0:1) { + txt_gp$summary <- + prListRep(list(prListRep(txt_gp$summary, attr(labels, "no_cols"))), sum(is.summary)) + } else { + ncols <- sapply(txt_gp$summary, length) + if (all(ncols != ncols[1])) { + stop( + "Your fpTxtGp$summary list has invalid number of columns", + ", they should all be of equal length - yours have ", + "'", paste(ncols, collapse = "', '"), "'" + ) + } + if (length(txt_gp$summary) != sum(is.summary)) { + stop( + "Your fpTxtGp$summary list has invalid number of rows", + ", the should be equal the of the number rows that aren't summaries.", + " you have '", length(txt_gp$summary), "' rows in the fpTxtGp$summary", + ", while the labeltext argument has '", attr(labels, "no_rows"), "' rows", + " where '", sum(is.summary), "' are not summaries." + ) + } + } + + fixed_labels <- vector("list", attr(labels, "no_cols")) + max_height <- NULL + max_width <- NULL + # Walk through the labeltext + # Creates a list matrix with + # The column part + for (j in 1:attr(labels, "no_cols")) { + fixed_labels[[j]] <- vector("list", attr(labels, "no_rows")) + + # The row part + for (i in 1:attr(labels, "no_rows")) { + txt_out <- labels[i, j] + + # If it's a call created by bquote or similar it + # needs evaluating + if (is.call(txt_out)) { + txt_out <- eval(txt_out) + } + + if (is.expression(txt_out) || is.character(txt_out) || is.numeric(txt_out) || is.factor(txt_out)) { + x <- switch(align[j], + l = 0, + r = 1, + c = 0.5 + ) + + just <- switch(align[j], + l = "left", + r = "right", + c = "center" + ) + + # Bold the text if this is a summary + if (is.summary[i]) { + x <- switch(align[j], + l = 0, + r = 1, + c = 0.5 + ) + + gp_list <- txt_gp$summary[[sum(is.summary[1:i])]][[j]] + gp_list[["col"]] <- rep(col$text, length = attr(labels, "no_rows"))[i] + + # Create a textGrob for the summary + # The row/column order is in this order + # in order to make the following possible: + # list(rownames(x), list(expression(1 >= a), "b", "c")) + fixed_labels[[j]][[i]] <- + textGrob(txt_out, + x = x, + just = just, + gp = do.call(gpar, gp_list) + ) + } else { + gp_list <- txt_gp$label[[sum(!is.summary[1:i])]][[j]] + if (is.null(gp_list$col)) { + gp_list[["col"]] <- rep(col$text, length = attr(labels, "no_rows"))[i] + } + + # Create a textGrob with the current row-cell for the label + fixed_labels[[j]][[i]] <- + textGrob(txt_out, + x = x, + just = just, + gp = do.call(gpar, gp_list) + ) + } + + attr(fixed_labels[[j]][[i]], "height") <- grobHeight(fixed_labels[[j]][[i]]) + attr(fixed_labels[[j]][[i]], "width") <- grobWidth(fixed_labels[[j]][[i]]) + if (is.null(max_height)) { + max_height <- attr(fixed_labels[[j]][[i]], "height") + max_width <- attr(fixed_labels[[j]][[i]], "width") + } else { + max_height <- max(max_height, attr(fixed_labels[[j]][[i]], "height")) + max_width <- max(max_width, attr(fixed_labels[[j]][[i]], "width")) + } + } + } + } + + structure(fixed_labels, + max_height = max_height, + max_width = max_width, + cex = ifelse(any(is.summary), + txt_gp$summary[[1]][[1]]$cex, + txt_gp$label[[1]][[1]]$cex), + no_cols = attr(labels, "no_cols"), + no_rows = attr(labels, "no_rows")) +} diff --git a/R/private_prepAlign.R b/R/private_prepAlign.R new file mode 100644 index 0000000..126bb85 --- /dev/null +++ b/R/private_prepAlign.R @@ -0,0 +1,28 @@ +#' Prepares graph position +#' +#' Prepares the graph position so that it matches the label size +#' +#' @param nc The number of columns +#' @param graph.pos An integer indicating the position of the graph +#' @inheritParams forestplot +#' +#' @return Returns vector of `"l", "c", "r"` values +prepAlign <- function(align, graph.pos, nc) { + # Prepare the summary and align variables + if (is.null(align)) { + if (graph.pos == 1) { + return(rep("l", nc)) + } + + if (graph.pos == nc + 1) { + return(c("l", rep("r", nc - 1))) + } + + return(c("l", rep("c", nc - 1))) + } + + if (any(!c("l", "c", "r") %in% align)) { + stop("The align argument must only contain 'l', 'c', or 'r'. You provided: ", align) + } + rep(align, length.out = nc) +} diff --git a/R/private_prepGraphPositions.R b/R/private_prepGraphPositions.R new file mode 100644 index 0000000..cac547a --- /dev/null +++ b/R/private_prepGraphPositions.R @@ -0,0 +1,34 @@ +#' Prepares graph position +#' +#' Prepares the graph position so that it matches the label size +#' +#' @param nc The number of columns +#' @inheritParams forestplot +#' +#' @return Returns number indicating the graph position +prepGraphPositions <- function(graph.pos, nc) { + if (is.character(graph.pos)) { + return(switch(graph.pos, + right = nc + 1L, + last = nc + 1L, + left = 1L, + first = 1L, + stop( + "The graph.pos argument has an invalid text argument.", + " The only values accepted are 'left'/'right' or 'first'/'last'.", + " You have provided the value '", graph.pos, "'"))) + } + + if (is.numeric(graph.pos)) { + if (!graph.pos %in% 1:(nc + 1)) { + stop( + "The graph position must be between 1 and ", (nc + 1), ".", + " You have provided the value '", graph.pos, "'." + ) + } + return(graph.pos) + } + + stop("The graph pos must either be a string consisting of 'left'/'right' (alt. 'first'/'last')", + ", or an integer value between 1 and ", (nc + 1)) +} diff --git a/R/private_prepLabelText.R b/R/private_prepLabelText.R new file mode 100644 index 0000000..af05743 --- /dev/null +++ b/R/private_prepLabelText.R @@ -0,0 +1,119 @@ +#' Prepares label text +#' +#' Prepares an object that contains the number of columns and rows +#' +#' @param labeltext The label text input, either `expression`, `list` +#' `vector` or `matrix` +#' @param nr The number of rows +#' +#' @return Returns a `forestplot_labeltext` object with attributes: +#' - no_cols +#' - no_rows +#' - widthcolumn +#' - label_type +#' @rdname prepLabelText +prepLabelText <- function(labeltext, nr) { + # Get the number of columns (nc) and number of rows (nr) + # if any columns are to be spacers the widthcolumn variable + if (is.expression(labeltext)) { + widthcolumn <- c(TRUE) + # Can't figure out multiple levels of expressions + nc <- 1 + label_type <- "expression" + label_nr <- length(labeltext) + } else if (is.list(labeltext)) { + if (sapply(labeltext, \(x) length(x) == 1 && !is.list(x)) |> all()) { + labeltext <- list(labeltext) + } + + if (!prFpValidateLabelList(labeltext)) { + stop("Invalid labellist, it has to be formed as a matrix m x n elements") + } + + # Can't figure out multiple levels of expressions + nc <- length(labeltext) + + widthcolumn <- c() + # Should mark the columns that don't contain + # epressions, text or numbers as widthcolumns + for (col.no in seq(along = labeltext)) { + empty_row <- TRUE + for (row.no in seq(along = labeltext[[col.no]])) { + if (is.expression(labeltext[[col.no]][[row.no]]) || + !is.na(labeltext[[col.no]][[row.no]])) { + empty_row <- FALSE + break + } + } + widthcolumn <- append(widthcolumn, empty_row) + } + + label_type <- "list" + label_nr <- length(labeltext[[1]]) + } else if (is.vector(labeltext)) { + widthcolumn <- c(FALSE) + nc <- 1 + + labeltext <- matrix(labeltext, ncol = 1) + label_type <- "matrix" + label_nr <- NROW(labeltext) + } else { + # Original code for matrixes + widthcolumn <- !apply(is.na(labeltext), 1, any) + nc <- NCOL(labeltext) + label_type <- "matrix" + label_nr <- NROW(labeltext) + } + + if (nr != label_nr) { + stop( + "You have provided ", nr, " rows in your", + " mean arguement while the labels have ", label_nr, " rows" + ) + } + + structure(labeltext, + no_cols = nc, + no_rows = label_nr, + widthcolumn = widthcolumn, + label_type = label_type, + class = "forestplot_labeltext") +} + +#' @describeIn prepLabelText Pick the value that corresponds to the row and column. +#' Returns `expression`, `call`, or `text`. +#' @param x A `forestplot_labeltext` object +#' @param i The row +#' @param j The column +#' +#' @inheritParams forestplot +#' @keywords internal +`[.forestplot_labeltext` <- function(x, i, j, ...) +{ + label_type <- attr(x, "label_type") + if (label_type == "expression") { + # Haven't figured out it this is possible with + # a multilevel expression + row_column_text <- x[[i]] + } else if (label_type == "list") { + # I get annoying warnings with this + # if (!is.expression(x[[j]][[i]]) && is.na(x[[j]][[i]])) + # return(FALSE) + row_column_text <- x[[j]][[i]] + } else { + ret <- NextMethod() + if (is.na(ret)) { + return(FALSE) + } + row_column_text <- ret + } + + if (!is.expression(row_column_text) && + !is.call(row_column_text) && + (is.na(row_column_text) || + is.null(row_column_text))) { + return("") + } + + return(row_column_text) +} diff --git a/man/forestplot.Rd b/man/forestplot.Rd index 315416d..d3071bd 100644 --- a/man/forestplot.Rd +++ b/man/forestplot.Rd @@ -19,38 +19,38 @@ forestplot(...) mean, lower, upper, - align, + align = NULL, is.summary = FALSE, graph.pos = "right", - hrzl_lines, + hrzl_lines = NULL, clip = c(-Inf, Inf), xlab = "", zero = ifelse(xlog, 1, 0), graphwidth = "auto", - colgap, + colgap = NULL, lineheight = "auto", - line.margin, + line.margin = NULL, col = fpColors(), txt_gp = fpTxtGp(), xlog = FALSE, - xticks, + xticks = NULL, xticks.digits = 2, grid = FALSE, - lwd.xaxis, - lwd.zero, - lwd.ci, + lwd.xaxis = NULL, + lwd.zero = 1, + lwd.ci = NULL, lty.ci = 1, - ci.vertices, + ci.vertices = NULL, ci.vertices.height = 0.1, - boxsize, + boxsize = NULL, mar = unit(rep(5, times = 4), "mm"), - title, - legend, + title = NULL, + legend = NULL, legend_args = fpLegend(), new_page = getOption("forestplot_new_page", TRUE), fn.ci_norm = fpDrawNormalCI, fn.ci_sum = fpDrawSummaryCI, - fn.legend, + fn.legend = NULL, shapes_gp = fpShapesGp(), ... ) diff --git a/man/prFpDrawLegend.Rd b/man/prFpDrawLegend.Rd deleted file mode 100644 index f1fa993..0000000 --- a/man/prFpDrawLegend.Rd +++ /dev/null @@ -1,66 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prFpDrawLegend.R -\name{prFpDrawLegend} -\alias{prFpDrawLegend} -\title{Draw the forestplot legend} -\usage{ -prFpDrawLegend( - lGrobs, - col, - shapes_gp, - colgap, - pos, - gp, - r, - padding, - fn.legend, - ... -) -} -\arguments{ -\item{lGrobs}{A list with all the grobs, see \code{\link{prFpGetLegendGrobs}}} - -\item{col}{The colors of the legends.} - -\item{shapes_gp}{Sets graphical parameters (squares and lines widths, styles, etc.) -of all shapes drawn (squares, lines, diamonds, etc.). This overrides \code{col}, -\code{lwd.xaxis}, \code{lwd.zero}, \code{lwd.ci} and \code{lty.ci}.} - -\item{colgap}{The gap between the box and the text} - -\item{pos}{The position of the legend, either at the "top" or the "right" unless -positioned inside the plot. If you want the legend to be positioned inside the plot -then you have to provide a list with the same x & y qualities as \code{\link[graphics]{legend}}. -For instance if you want the legend to be positioned at the top right corner then -use \code{pos = list("topright")} - this is equivalent to \code{pos = list(x = 1, y = 1)}. -If you want to have a distance from the edge of the graph then add a inset to the list, -e.g. \code{pos = list("topright", "inset" = .1)} - the inset should be either a \code{\link[grid]{unit}} -element or a value between 0 and 1. The default is to have the boxes aligned vertical, if -you want them to be in a line then you can specify the "align" option, e.g. -\code{pos = list("topright", "inset" = .1, "align" = "horizontal")}} - -\item{gp}{The \code{\link[grid]{gpar}} options for the legend. If you want -the background color to be light grey then use \code{gp = gpar(fill = "lightgrey")}. -If you want a border then set the col argument: \code{gp = gpar(fill = "lightgrey", col = "black")}. -You can also use the lwd and lty argument as usual, \code{gp = gpar(lwd = 2, lty = 1)}, will result -in a black border box of line type 1 and line width 2.} - -\item{r}{The box can have rounded edges, check out \code{\link[grid]{grid.roundrect}}. The -r option should be a \code{\link[grid]{unit}} object. This is by default \code{unit(0, "snpc")} -but you can choose any value that you want. The \code{"snpc"} unit is the preferred option.} - -\item{padding}{The padding for the legend box, only used if box is drawn. This is -the distance from the border to the text/boxes of the legend.} - -\item{fn.legend}{The function for drawing the marker} - -\item{...}{Passed to the legend \code{fn.legend}} -} -\value{ -\code{void} -} -\description{ -Takes the grobs and outputs the legend -inside the current viewport. -} -\keyword{internal} diff --git a/man/prFpGetGraphTicksAndClips.Rd b/man/prFpGetGraphTicksAndClips.Rd deleted file mode 100644 index a9d97c3..0000000 --- a/man/prFpGetGraphTicksAndClips.Rd +++ /dev/null @@ -1,83 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/prFpGetGraphTicksAndClips.R -\name{prFpGetGraphTicksAndClips} -\alias{prFpGetGraphTicksAndClips} -\title{A helper function to forestplot} -\usage{ -prFpGetGraphTicksAndClips( - xticks, - xticks.digits, - grid, - xlog, - xlab, - lwd.xaxis, - col, - txt_gp, - clip, - zero, - x_range, - mean, - graph.pos, - shapes_gp = fpShapesGp() -) -} -\arguments{ -\item{xticks}{Optional user-specified x-axis tick marks. Specify NULL to use -the defaults, numeric(0) to omit the x-axis. By adding a labels-attribute, -\code{attr(my_ticks, "labels") <- ...} you can dictate the outputted text -at each tick. If you specify a boolean vector then ticks indicated with -FALSE wont be printed. Note that the labels have to be the same length -as the main variable.} - -\item{xticks.digits}{The number of digits to allow in the x-axis if this -is created by default} - -\item{grid}{If you want a discrete gray dashed grid at the level of the -ticks you can set this parameter to \code{TRUE}. If you set the parameter -to a vector of values lines will be drawn at the corresponding positions. -If you want to specify the \code{\link[grid]{gpar}} of the lines then either -directly pass a \code{\link[grid]{gpar}} object or set the gp attribute e.g. -\code{attr(line_vector, "gp") <- \link[grid]{gpar}(lty = 2, col = "red")}} - -\item{xlog}{If TRUE, x-axis tick marks are to follow a logarithmic scale, e.g. for -logistic regression (OR), survival estimates (HR), Poisson regression etc. -\emph{Note:} This is an intentional break with the original \code{forestplot} -function as I've found that exponentiated ticks/clips/zero effect are more -difficult to for non-statisticians and there are sometimes issues with rounding -the tick marks properly.} - -\item{xlab}{x-axis label} - -\item{lwd.xaxis}{lwd for the xaxis, see \code{\link[grid]{gpar}}} - -\item{col}{Set the colors for all the elements. See \code{\link{fpColors}} for -details} - -\item{txt_gp}{Set the fonts etc for all text elements. See \code{\link{fpTxtGp}} -for details} - -\item{clip}{Lower and upper limits for clipping confidence intervals to arrows} - -\item{zero}{x-axis coordinate for zero line. If you provide a vector of length 2 it -will print a rectangle instead of just a line. If you provide NA the line is suppressed.} - -\item{x_range}{The range that the values from the different confidence -interval span} - -\item{mean}{The original means, either matrix or vector} - -\item{graph.pos}{The position of the graph element within the table of text. The -position can be \code{1-(ncol(labeltext) + 1)}. You can also choose set the position -to \code{"left"} or \code{"right"}.} - -\item{shapes_gp}{Sets graphical parameters (squares and lines widths, styles, etc.) -of all shapes drawn (squares, lines, diamonds, etc.). This overrides \code{col}, -\code{lwd.xaxis}, \code{lwd.zero}, \code{lwd.ci} and \code{lty.ci}.} -} -\value{ -\code{list} Returns a list with axis_vp, axisGrob, labGrob, zero and clip -} -\description{ -Gets the x-label and zero-bar details -} -\keyword{internal} diff --git a/man/prFpGetLabels.Rd b/man/prFpGetLabels.Rd deleted file mode 100644 index 21bffca..0000000 --- a/man/prFpGetLabels.Rd +++ /dev/null @@ -1,49 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/private.R -\name{prFpGetLabels} -\alias{prFpGetLabels} -\title{Gets the forestplot labels} -\usage{ -prFpGetLabels(label_type, labeltext, align, nc, nr, is.summary, txt_gp, col) -} -\arguments{ -\item{label_type}{The type of text labels} - -\item{labeltext}{A list, matrix, vector or expression with the names of each -row or the name of the column if using the *dplyr* select syntax - defaults to "labeltext". -Note that when using `group_by` a separate labeltext is not allowed. -The list should be wrapped in m x n number to resemble a matrix: -\code{list(list("rowname 1 col 1", "rowname 2 col 1"), list("r1c2", expression(beta))}. -You can also provide a matrix although this cannot have expressions by design: -\code{matrix(c("rowname 1 col 1", "rowname 2 col 1", "r1c2", "beta"), ncol = 2)}. -Use \code{NA}:s for blank spaces and if you provide a full column with \code{NA} then -that column is a empty column that adds some space. \emph{Note:} If you do not -provide the mean/lower/upper arguments the function expects the label text -to be a matrix containing the labeltext in the rownames and then columns for -mean, lower, and upper.} - -\item{align}{Alignment, should be equal to \code{length(nc}} - -\item{nc}{Number of columns} - -\item{nr}{Number of rows} - -\item{is.summary}{A vector indicating by \code{TRUE}/\code{FALSE} if -the value is a summary value which means that it will have a different -font-style} - -\item{txt_gp}{Set the fonts etc for all text elements. See \code{\link{fpTxtGp}} -for details} - -\item{col}{Set the colors for all the elements. See \code{\link{fpColors}} for -details} -} -\value{ -\code{list} A list with \code{length(nc)} where each element contains - a list of \code{length(nr)} elements with attributes width/height for each - element and max_width/max_height for the total -} -\description{ -A function that gets all the labels -} -\keyword{internal} diff --git a/man/prFpGetLayoutVP.Rd b/man/prFpGetLayoutVP.Rd index 4a27438..bf91fef 100644 --- a/man/prFpGetLayoutVP.Rd +++ b/man/prFpGetLayoutVP.Rd @@ -4,7 +4,7 @@ \alias{prFpGetLayoutVP} \title{Get the main `forestplot`} \usage{ -prFpGetLayoutVP(lineheight, labels, nr, legend_layout = NULL) +prFpGetLayoutVP(lineheight, labels, legend_layout = NULL) } \arguments{ \item{lineheight}{Height of the graph. By default this is \code{auto} and adjusts to the @@ -19,8 +19,6 @@ text height is as your line height} \item{labels}{The labels} -\item{nr}{Number of rows} - \item{legend_layout}{A legend layout object if applicable} } \value{ diff --git a/man/prFpGetLegendGrobs.Rd b/man/prFpGetLegendGrobs.Rd deleted file mode 100644 index 3f04bb4..0000000 --- a/man/prFpGetLegendGrobs.Rd +++ /dev/null @@ -1,27 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/private.R -\name{prFpGetLegendGrobs} -\alias{prFpGetLegendGrobs} -\title{Gets the forestplot legend grobs} -\usage{ -prFpGetLegendGrobs(legend, txt_gp, title) -} -\arguments{ -\item{legend}{Legend corresponding to the number of bars} - -\item{txt_gp}{Set the fonts etc for all text elements. See \code{\link{fpTxtGp}} -for details} - -\item{title}{The title of the plot if any} -} -\value{ -\code{list} A "Legend" class that derives from a - list with all the different legends. The list also contains - attributes such as height, width, max_height, - max_width, line_height_and_spacing. The title of the - legend is saved inside \code{attr("title")} -} -\description{ -Gets the forestplot legend grobs -} -\keyword{internal} diff --git a/man/prFpGetLines.Rd b/man/prFpGetLines.Rd index cf0cdb1..62a0ce4 100644 --- a/man/prFpGetLines.Rd +++ b/man/prFpGetLines.Rd @@ -5,7 +5,7 @@ \title{Prepares the hrzl_lines for the plot} \usage{ prFpGetLines( - hrzl_lines, + hrzl_lines = NULL, is.summary, total_columns, col, diff --git a/man/prFpPrintXaxis.Rd b/man/prFpPrintXaxis.Rd deleted file mode 100644 index 518df01..0000000 --- a/man/prFpPrintXaxis.Rd +++ /dev/null @@ -1,28 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/private.R -\name{prFpPrintXaxis} -\alias{prFpPrintXaxis} -\title{Plots the x-axis for forestplot} -\usage{ -prFpPrintXaxis(axisList, col, lwd.zero, shapes_gp = fpShapesGp()) -} -\arguments{ -\item{axisList}{The list from \code{\link{prFpGetGraphTicksAndClips}}} - -\item{col}{Set the colors for all the elements. See \code{\link{fpColors}} for -details} - -\item{lwd.zero}{lwd for the vertical line that gives the no-effect line, see \code{\link[grid]{gpar}}} - -\item{shapes_gp}{Sets graphical parameters (squares and lines widths, styles, etc.) -of all shapes drawn (squares, lines, diamonds, etc.). This overrides \code{col}, -\code{lwd.xaxis}, \code{lwd.zero}, \code{lwd.ci} and \code{lty.ci}.} -} -\value{ -void -} -\description{ -A helper function to the \code{\link{forestplot}} -function. -} -\keyword{internal} diff --git a/man/prGetLabelsList.Rd b/man/prGetLabelsList.Rd new file mode 100644 index 0000000..6eb1e09 --- /dev/null +++ b/man/prGetLabelsList.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/private_prGetLabelsList.R +\name{prGetLabelsList} +\alias{prGetLabelsList} +\title{Gets the forestplot labels} +\usage{ +prGetLabelsList(labels, align, is.summary, txt_gp, col) +} +\arguments{ +\item{labels}{A `forestplot_labeltext` object} + +\item{align}{Alignment, should be equal to \code{attr(labels, "no_cols")}} + +\item{is.summary}{A vector indicating by \code{TRUE}/\code{FALSE} if +the value is a summary value which means that it will have a different +font-style} + +\item{txt_gp}{Set the fonts etc for all text elements. See \code{\link{fpTxtGp}} +for details} + +\item{col}{Set the colors for all the elements. See \code{\link{fpColors}} for +details} +} +\value{ +\code{list} A list with \code{attr(labels, "no_cols")} where each element contains + a list of \code{attr(labels, "no_rows")} elements with attributes width/height for each + element and max_width/max_height for the total +} +\description{ +A function that gets all the labels +} +\keyword{internal} diff --git a/man/prepAlign.Rd b/man/prepAlign.Rd new file mode 100644 index 0000000..66357f1 --- /dev/null +++ b/man/prepAlign.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/private_prepAlign.R +\name{prepAlign} +\alias{prepAlign} +\title{Prepares graph position} +\usage{ +prepAlign(align, graph.pos, nc) +} +\arguments{ +\item{align}{Vector giving alignment (l,r,c) for the table columns} + +\item{graph.pos}{An integer indicating the position of the graph} + +\item{nc}{The number of columns} +} +\value{ +Returns vector of `"l", "c", "r"` values +} +\description{ +Prepares the graph position so that it matches the label size +} diff --git a/man/prepGraphPositions.Rd b/man/prepGraphPositions.Rd new file mode 100644 index 0000000..c76c8d1 --- /dev/null +++ b/man/prepGraphPositions.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/private_prepGraphPositions.R +\name{prepGraphPositions} +\alias{prepGraphPositions} +\title{Prepares graph position} +\usage{ +prepGraphPositions(graph.pos, nc) +} +\arguments{ +\item{graph.pos}{The position of the graph element within the table of text. The +position can be \code{1-(ncol(labeltext) + 1)}. You can also choose set the position +to \code{"left"} or \code{"right"}.} + +\item{nc}{The number of columns} +} +\value{ +Returns number indicating the graph position +} +\description{ +Prepares the graph position so that it matches the label size +} diff --git a/man/prepGridMargins.Rd b/man/prepGridMargins.Rd new file mode 100644 index 0000000..0a506bc --- /dev/null +++ b/man/prepGridMargins.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/prepGridMargins.R +\name{prepGridMargins} +\alias{prepGridMargins} +\title{Convert margins to viewport npc margins} +\usage{ +prepGridMargins(mar) +} +\arguments{ +\item{mar}{A vector of margins, at positions: +- 1 = bottom +- 2 = left +- 3 = top +- 4 = right} +} +\value{ +Returns a list with `bottom`, `left`, `top`, and `right` as `unit("npc")` +} +\description{ +Convert margins to viewport npc margins +} diff --git a/man/prepLabelText.Rd b/man/prepLabelText.Rd new file mode 100644 index 0000000..4dfc4ec --- /dev/null +++ b/man/prepLabelText.Rd @@ -0,0 +1,43 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/private_prepLabelText.R +\name{prepLabelText} +\alias{prepLabelText} +\alias{[.forestplot_labeltext} +\title{Prepares label text} +\usage{ +prepLabelText(labeltext, nr) + +\method{[}{forestplot_labeltext}(x, i, j, ...) +} +\arguments{ +\item{labeltext}{The label text input, either `expression`, `list` +`vector` or `matrix`} + +\item{nr}{The number of rows} + +\item{x}{A `forestplot_labeltext` object} + +\item{i}{The row} + +\item{j}{The column} + +\item{...}{Passed on to the \code{fn.ci_norm} and +\code{fn.ci_sum} arguments} +} +\value{ +Returns a `forestplot_labeltext` object with attributes: + - no_cols + - no_rows + - widthcolumn + - label_type +} +\description{ +Prepares an object that contains the number of columns and rows +} +\section{Functions}{ +\itemize{ +\item \code{[}: Pick the value that corresponds to the row and column. +Returns `expression`, `call`, or `text`. + +}} +\keyword{internal} diff --git a/tests/test_visual_w_cochrane_mdata.R b/tests/test_visual_w_cochrane_mdata.R index e2e6367..f316b26 100644 --- a/tests/test_visual_w_cochrane_mdata.R +++ b/tests/test_visual_w_cochrane_mdata.R @@ -110,17 +110,17 @@ sum.arg <- c( ) forestplot(tabletext, - mean = cochrane_from_rmeta[, c("mean", "mean2")], - lower = cochrane_from_rmeta[, c("lower", "lower2")], - upper = cochrane_from_rmeta[, c("upper", "upper2")], - is.summary = c(TRUE, TRUE, rep(FALSE, 8), TRUE, TRUE), - fn.ci_norm = norm.arg, - fn.ci_sum = sum.arg, - col = fpColors( - box = c("black", "grey45"), - lines = c("black", "grey45"), - summary = "grey30" - ), - xlog = TRUE, - boxsize = c(rep(0.25, 11), 0.125) + mean = cochrane_from_rmeta[, c("mean", "mean2")], + lower = cochrane_from_rmeta[, c("lower", "lower2")], + upper = cochrane_from_rmeta[, c("upper", "upper2")], + is.summary = c(TRUE, TRUE, rep(FALSE, 8), TRUE, TRUE), + fn.ci_norm = norm.arg, + fn.ci_sum = sum.arg, + col = fpColors( + box = c("black", "grey45"), + lines = c("black", "grey45"), + summary = "grey30" + ), + xlog = TRUE, + boxsize = c(rep(0.25, 11), 0.125) ) diff --git a/tests/vtest_from_vignette.R b/tests/vtest_from_vignette.R index 6eafe35..789ab2e 100644 --- a/tests/vtest_from_vignette.R +++ b/tests/vtest_from_vignette.R @@ -37,13 +37,12 @@ tabletext <- cbind( # Test summary forestplot(tabletext, - cochrane_from_rmeta, - new_page = TRUE, - is.summary = c(TRUE, TRUE, rep(FALSE, 8), TRUE), - clip = c(0.1, 2.5), - xlog = TRUE, - col = fpColors(box = "royalblue", line = "darkblue", summary = "royalblue") -) + cochrane_from_rmeta, + new_page = TRUE, + is.summary = c(TRUE, TRUE, rep(FALSE, 8), TRUE), + clip = c(0.1, 2.5), + xlog = TRUE, + col = fpColors(box = "royalblue", line = "darkblue", summary = "royalblue")) # Test lines forestplot(tabletext, @@ -297,3 +296,4 @@ forestplot(tabletext, # structure(c(-.1, -.05, .05), # gp = gpar(lty = 2, col = "#CCCCFF"))) # # Returns TRUE + From 7d8a2e82490080bf395432c8e046c3a640b16088 Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Sun, 25 Sep 2022 20:51:10 +0200 Subject: [PATCH 06/17] Fixed xlab and foresplot example --- R/drawForestplotObject.R | 6 +-- R/forestplot.default.R | 3 +- R/prFpGetGraphTicksAndClips.R | 33 ++++++------ R/private.R | 82 ------------------------------ R/private_plot.forestplot_xaxis.R | 78 ++++++++++++++++++++++++++++ inst/examples/forestplot_example.R | 25 +++++---- man/forestplot.Rd | 27 +++++----- tests/vtest_from_vignette.R | 13 +++-- 8 files changed, 134 insertions(+), 133 deletions(-) create mode 100644 R/private_plot.forestplot_xaxis.R diff --git a/R/drawForestplotObject.R b/R/drawForestplotObject.R index fd20aae..b9d1b38 100644 --- a/R/drawForestplotObject.R +++ b/R/drawForestplotObject.R @@ -30,6 +30,7 @@ drawForestplotObject <- function(obj) { xlog = obj$xlog, xlab = obj$xlab, lwd.xaxis = obj$lwd.xaxis, + lwd.zero = obj$lwd.zero, txt_gp = obj$txt_gp, col = obj$col, clip = obj$clip, @@ -150,10 +151,7 @@ drawForestplotObject <- function(obj) { colwidths = colwidths, graph.pos = obj$graph.pos) - prFpPrintXaxis(axisList = axisList, - col = obj$col, - lwd.zero = obj$lwd.zero, - shapes_gp = obj$shapes_gp) + plot(axisList) # Output the different confidence intervals for (i in 1:attr(labels, "no_rows")) { diff --git a/R/forestplot.default.R b/R/forestplot.default.R index 1fde88f..e3c14a7 100644 --- a/R/forestplot.default.R +++ b/R/forestplot.default.R @@ -9,7 +9,7 @@ forestplot.default <- function(labeltext, graph.pos = "right", hrzl_lines = NULL, clip = c(-Inf, Inf), - xlab = "", + xlab = NULL, zero = ifelse(xlog, 1, 0), graphwidth = "auto", colgap = NULL, @@ -289,6 +289,7 @@ forestplot.default <- function(labeltext, lwd.ci = lwd.ci, xticks = xticks, xticks.digits = xticks.digits, + xlab = xlab, xlog = xlog, clip = clip, zero = zero, diff --git a/R/prFpGetGraphTicksAndClips.R b/R/prFpGetGraphTicksAndClips.R index 87089fd..91ef1f0 100644 --- a/R/prFpGetGraphTicksAndClips.R +++ b/R/prFpGetGraphTicksAndClips.R @@ -17,6 +17,7 @@ prFpGetGraphTicksAndClips <- function(xticks, xlog, xlab, lwd.xaxis, + lwd.zero, col, txt_gp, clip, @@ -107,6 +108,7 @@ prFpGetGraphTicksAndClips <- function(xticks, exp = xlog, digits = xticks.digits ) + ticks <- c(min(x_range), ticks) # Add the endpoint ticks to the tick list if # it's not already there @@ -187,11 +189,9 @@ prFpGetGraphTicksAndClips <- function(xticks, ticklabels <- labattr } } - dg <- xaxisGrob( - at = ticks, - label = ticklabels, - gp = gp_axis - ) + dg <- xaxisGrob(at = ticks, + label = FALSE, + gp = gp_axis) if (length(grid) == 1) { if (is.logical(grid) && grid == TRUE) { @@ -231,7 +231,7 @@ prFpGetGraphTicksAndClips <- function(xticks, } } - if (length(xlab) == 1 && nchar(xlab) > 0) { + if (!is.null(xlab) && nchar(xlab) > 0) { gp_list <- txt_gp$xlab gp_list$col <- col$axes # Write the label for the x-axis @@ -242,14 +242,15 @@ prFpGetGraphTicksAndClips <- function(xticks, labGrob <- FALSE } - ret <- list( - axis_vp = axis_vp, - axisGrob = dg, - gridList = gridList, - labGrob = labGrob, - zero = zero, - clip = clip, - x_range = x_range - ) - return(ret) + list(axis_vp = axis_vp, + axisGrob = dg, + gridList = gridList, + labGrob = labGrob, + zero = zero, + clip = clip, + x_range = x_range, + col = col, + shapes_gp = shapes_gp, + lwd.zero = lwd.zero) |> + structure(class = "forestplot_xaxis") } diff --git a/R/private.R b/R/private.R index 0f1d99b..f624152 100644 --- a/R/private.R +++ b/R/private.R @@ -261,88 +261,6 @@ prPopulateList <- function(elmnt, no_rows, no_cols, missing_rows, is.summary, su return(ret) } -#' Plots the x-axis for forestplot -#' -#' A helper function to the \code{\link{forestplot}} -#' function. -#' -#' @param axisList The list from \code{\link{prFpGetGraphTicksAndClips}} -#' @return void -#' -#' @inheritParams forestplot -#' @noRd -prFpPrintXaxis <- function(axisList, - col, - lwd.zero, - shapes_gp = fpShapesGp()) { - # Now plot the axis inkluding the horizontal bar - pushViewport(axisList$axis_vp) - - # Plot the vertical "zero" axis - gp_list <- list(col = col$zero) - if (!missing(lwd.zero)) { - gp_list$lwd <- lwd.zero - } - zero_gp <- prGetShapeGp(shapes_gp, NULL, "zero", default = do.call(gpar, gp_list)) - - if (length(axisList$zero) > 1 || !is.na(axisList$zero)) { - if (length(axisList$zero) == 1) { - grid.lines( - x = unit(axisList$zero, "native"), - y = 0:1, - gp = zero_gp - ) - } else if (length(axisList$zero) == 2) { - gp_list$fill <- gp_list$col - grid.polygon( - x = unit( - c( - axisList$zero, - rev(axisList$zero) - ), - "native" - ), - y = c(0, 0, 1, 1), - gp = zero_gp - ) - } - } - - if (is.grob(axisList$gridList)) { - grid.draw(axisList$gridList) - } - - lab_y <- unit(0, "mm") - lab_grob_height <- unit(-2, "mm") - # Omit the axis if specified as 0 - if (is.grob(axisList$axisGrob)) { - # Plot the actual x-axis - grid.draw(axisList$axisGrob) - lab_grob_height <- grobHeight(axisList$axisGrob) - lab_y <- lab_y - lab_grob_height - } - - if (is.grob(axisList$labGrob)) { - # Add some padding between text and ticks proportional to the ticks height - padding <- - unit( - convertY(lab_grob_height, "lines", valueOnly = TRUE) * 0.1, - "lines" - ) - - # The text is strangely messy - # and needs its own viewport - pushViewport(viewport( - height = grobHeight(axisList$labGrob), - y = lab_y - padding, just = "top" - )) - grid.draw(axisList$labGrob) - upViewport() - } - upViewport() -} - - #' Plots the labels #' #' This is a helper function to the \code{\link{forestplot}} diff --git a/R/private_plot.forestplot_xaxis.R b/R/private_plot.forestplot_xaxis.R new file mode 100644 index 0000000..f819d4b --- /dev/null +++ b/R/private_plot.forestplot_xaxis.R @@ -0,0 +1,78 @@ +#' Plots the x-axis for forestplot +#' +#' A helper function to the \code{\link{forestplot}} +#' function. +#' +#' @param axisList The list from \code{\link{prFpGetGraphTicksAndClips}} +#' @return void +#' +#' @inheritParams forestplot +#' @noRd +plot.forestplot_xaxis <- function(axisList) { + # Now plot the axis inkluding the horizontal bar + pushViewport(axisList$axis_vp) + + # Plot the vertical "zero" axis + gp_list <- list(col = axisList$col$zero) + if (!is.null(axisList$lwd.zero)) { + gp_list$lwd <- axisList$lwd.zero + } + zero_gp <- prGetShapeGp(axisList$shapes_gp, NULL, "zero", default = do.call(gpar, gp_list)) + + if (length(axisList$zero) > 1 || !is.na(axisList$zero)) { + if (length(axisList$zero) == 1) { + grid.lines( + x = unit(axisList$zero, "native"), + y = 0:1, + gp = zero_gp + ) + } else if (length(axisList$zero) == 2) { + gp_list$fill <- gp_list$col + grid.polygon( + x = unit( + c( + axisList$zero, + rev(axisList$zero) + ), + "native" + ), + y = c(0, 0, 1, 1), + gp = zero_gp + ) + } + } + + if (is.grob(axisList$gridList)) { + grid.draw(axisList$gridList) + } + + lab_y <- unit(0, "mm") + lab_grob_height <- unit(-2, "mm") + # Omit the axis if specified as 0 + if (is.grob(axisList$axisGrob)) { + # Plot the actual x-axis + grid.draw(axisList$axisGrob) + lab_grob_height <- grobHeight(axisList$axisGrob) + lab_y <- lab_y - lab_grob_height + } + + if (is.grob(axisList$labGrob)) { + # Add some padding between text and ticks proportional to the ticks height + padding <- + unit( + convertY(lab_grob_height, "lines", valueOnly = TRUE) * 0.1, + "lines" + ) + + # The text is strangely messy + # and needs its own viewport + pushViewport(viewport( + height = grobHeight(axisList$labGrob), + y = lab_y - padding, just = "top" + )) + grid.draw(axisList$labGrob) + upViewport() + } + upViewport() +} + diff --git a/inst/examples/forestplot_example.R b/inst/examples/forestplot_example.R index e7268f1..651fd4a 100644 --- a/inst/examples/forestplot_example.R +++ b/inst/examples/forestplot_example.R @@ -23,10 +23,7 @@ test_data |> # Print two plots side by side using the grid # package's layout option for viewports -grid.newpage() -pushViewport(viewport(layout = grid.layout(1, 2))) -pushViewport(viewport(layout.pos.col = 1)) -test_data |> +fp1 <- test_data |> forestplot(labeltext = row_names, mean = coef, lower = low, @@ -34,11 +31,9 @@ test_data |> zero = 1, cex = 2, lineheight = "auto", - xlab = "Lab axis txt", - new_page = FALSE) -popViewport() -pushViewport(viewport(layout.pos.col = 2)) -test_data |> + title = "Plot 1", + xlab = "Lab axis txt") +fp2 <- test_data |> forestplot(labeltext = row_names, mean = coef, lower = low, @@ -47,11 +42,19 @@ test_data |> cex = 2, lineheight = "auto", xlab = "Lab axis txt", + title = "Plot 2", new_page = FALSE) -popViewport(2) +grid.newpage() +pushViewport(viewport(layout = grid.layout(1, 2))) +pushViewport(viewport(layout.pos.col = 1)) +plot(fp1) +popViewport() +pushViewport(viewport(layout.pos.col = 2)) +plot(fp2) +popViewport(2) -# An advanced test +# An advanced example library(dplyr) library(tidyr) test_data <- data.frame(id = 1:4, diff --git a/man/forestplot.Rd b/man/forestplot.Rd index d3071bd..59c2de7 100644 --- a/man/forestplot.Rd +++ b/man/forestplot.Rd @@ -24,7 +24,7 @@ forestplot(...) graph.pos = "right", hrzl_lines = NULL, clip = c(-Inf, Inf), - xlab = "", + xlab = NULL, zero = ifelse(xlog, 1, 0), graphwidth = "auto", colgap = NULL, @@ -303,10 +303,7 @@ test_data |> # Print two plots side by side using the grid # package's layout option for viewports -grid.newpage() -pushViewport(viewport(layout = grid.layout(1, 2))) -pushViewport(viewport(layout.pos.col = 1)) -test_data |> +fp1 <- test_data |> forestplot(labeltext = row_names, mean = coef, lower = low, @@ -314,11 +311,9 @@ test_data |> zero = 1, cex = 2, lineheight = "auto", - xlab = "Lab axis txt", - new_page = FALSE) -popViewport() -pushViewport(viewport(layout.pos.col = 2)) -test_data |> + title = "Plot 1", + xlab = "Lab axis txt") +fp2 <- test_data |> forestplot(labeltext = row_names, mean = coef, lower = low, @@ -327,11 +322,19 @@ test_data |> cex = 2, lineheight = "auto", xlab = "Lab axis txt", + title = "Plot 2", new_page = FALSE) -popViewport(2) +grid.newpage() +pushViewport(viewport(layout = grid.layout(1, 2))) +pushViewport(viewport(layout.pos.col = 1)) +plot(fp1) +popViewport() +pushViewport(viewport(layout.pos.col = 2)) +plot(fp2) +popViewport(2) -# An advanced test +# An advanced example library(dplyr) library(tidyr) test_data <- data.frame(id = 1:4, diff --git a/tests/vtest_from_vignette.R b/tests/vtest_from_vignette.R index 789ab2e..eeb0e65 100644 --- a/tests/vtest_from_vignette.R +++ b/tests/vtest_from_vignette.R @@ -154,13 +154,12 @@ forestplot(tabletext, # test two lines tabletext <- tabletext[, 1] forestplot(tabletext, - mean = cbind(HRQoL$Sweden[, "coef"], HRQoL$Denmark[, "coef"]), - lower = cbind(HRQoL$Sweden[, "lower"], HRQoL$Denmark[, "lower"]), - upper = cbind(HRQoL$Sweden[, "upper"], HRQoL$Denmark[, "upper"]), - clip = c(-.1, 0.075), - col = fpColors(box = c("blue", "darkred")), - xlab = "EQ-5D index" -) + mean = cbind(HRQoL$Sweden[, "coef"], HRQoL$Denmark[, "coef"]), + lower = cbind(HRQoL$Sweden[, "lower"], HRQoL$Denmark[, "lower"]), + upper = cbind(HRQoL$Sweden[, "upper"], HRQoL$Denmark[, "upper"]), + clip = c(-.1, 0.075), + col = fpColors(box = c("blue", "darkred")), + xlab = "EQ-5D index") ## ------------------------------------------------------------------------ From 160f9243763d0f4c01284a91975f8094e91a1adc Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Sun, 25 Sep 2022 20:51:39 +0200 Subject: [PATCH 07/17] Labeltext is now always in the form of a nested 2D list --- R/private_prepLabelText.R | 41 +++++++++++++++------------------------ 1 file changed, 16 insertions(+), 25 deletions(-) diff --git a/R/private_prepLabelText.R b/R/private_prepLabelText.R index af05743..2de5a96 100644 --- a/R/private_prepLabelText.R +++ b/R/private_prepLabelText.R @@ -19,12 +19,19 @@ prepLabelText <- function(labeltext, nr) { widthcolumn <- c(TRUE) # Can't figure out multiple levels of expressions nc <- 1 - label_type <- "expression" label_nr <- length(labeltext) + labeltext <- as.list(labeltext) } else if (is.list(labeltext)) { if (sapply(labeltext, \(x) length(x) == 1 && !is.list(x)) |> all()) { labeltext <- list(labeltext) } + labeltext <- lapply(labeltext, function(x) { + if (is.list(x)) { + return(x) + } + + return(as.list(x)) + }) if (!prFpValidateLabelList(labeltext)) { stop("Invalid labellist, it has to be formed as a matrix m x n elements") @@ -35,7 +42,7 @@ prepLabelText <- function(labeltext, nr) { widthcolumn <- c() # Should mark the columns that don't contain - # epressions, text or numbers as widthcolumns + # expressions, text or numbers as width columns for (col.no in seq(along = labeltext)) { empty_row <- TRUE for (row.no in seq(along = labeltext[[col.no]])) { @@ -48,21 +55,19 @@ prepLabelText <- function(labeltext, nr) { widthcolumn <- append(widthcolumn, empty_row) } - label_type <- "list" label_nr <- length(labeltext[[1]]) } else if (is.vector(labeltext)) { widthcolumn <- c(FALSE) nc <- 1 + label_nr <- length(labeltext) - labeltext <- matrix(labeltext, ncol = 1) - label_type <- "matrix" - label_nr <- NROW(labeltext) + labeltext <- list(as.list(labeltext)) } else { # Original code for matrixes widthcolumn <- !apply(is.na(labeltext), 1, any) nc <- NCOL(labeltext) - label_type <- "matrix" label_nr <- NROW(labeltext) + labeltext <- (\(x) lapply(seq(NCOL(labeltext)), function(i) as.list(x[,i])))(labeltext) } if (nr != label_nr) { @@ -76,7 +81,6 @@ prepLabelText <- function(labeltext, nr) { no_cols = nc, no_rows = label_nr, widthcolumn = widthcolumn, - label_type = label_type, class = "forestplot_labeltext") } @@ -90,23 +94,10 @@ prepLabelText <- function(labeltext, nr) { #' @keywords internal `[.forestplot_labeltext` <- function(x, i, j, ...) { - label_type <- attr(x, "label_type") - if (label_type == "expression") { - # Haven't figured out it this is possible with - # a multilevel expression - row_column_text <- x[[i]] - } else if (label_type == "list") { - # I get annoying warnings with this - # if (!is.expression(x[[j]][[i]]) && is.na(x[[j]][[i]])) - # return(FALSE) - row_column_text <- x[[j]][[i]] - } else { - ret <- NextMethod() - if (is.na(ret)) { - return(FALSE) - } - row_column_text <- ret - } + # I get annoying warnings with this + # if (!is.expression(x[[j]][[i]]) && is.na(x[[j]][[i]])) + # return(FALSE) + row_column_text <- x[[j]][[i]] if (!is.expression(row_column_text) && !is.call(row_column_text) && From 8e597d1023e218afd1ca3fe4d84ac9794ea479ea Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Mon, 26 Sep 2022 22:37:46 +0200 Subject: [PATCH 08/17] Convert to estimate to 3D array (#49) Instead of having mean, lower, upper there is now one array of 3 dimensions, * Estimate * Lower * Upper The third dimension is for multiple confidence bands. This change allows for easier additions of empty rows. --- DESCRIPTION | 4 +- NAMESPACE | 1 + R/drawForestplotObject.R | 119 ++++++--------- R/forestplot.default.R | 170 +++++----------------- R/getTicks.R | 2 +- R/prFpGetGraphTicksAndClips.R | 75 +++++----- R/private.R | 69 ++++----- R/private_buildEstimateArray.R | 76 ++++++++++ R/private_prepBoxSize.R | 39 +++++ man/prFpGetConfintFnList.Rd | 4 +- man/prPopulateList.Rd | 4 +- tests/forestplot2_vtests.R | 17 +-- tests/testthat/test-forestplot.group_df.R | 10 +- 13 files changed, 279 insertions(+), 311 deletions(-) create mode 100644 R/private_buildEstimateArray.R create mode 100644 R/private_prepBoxSize.R diff --git a/DESCRIPTION b/DESCRIPTION index c5235dc..bf1363e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -23,9 +23,9 @@ Biarch: yes Depends: R (>= 3.5.0), grid, - checkmate + checkmate, + abind Suggests: - abind, dplyr, knitr, purrr, diff --git a/NAMESPACE b/NAMESPACE index 10c0838..c704ce0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -20,6 +20,7 @@ export(fpTxtGp) export(getTicks) export(prGetShapeGp) import(grid) +importFrom(abind,adrop) importFrom(checkmate,assert) importFrom(checkmate,assert_class) importFrom(checkmate,assert_matrix) diff --git a/R/drawForestplotObject.R b/R/drawForestplotObject.R index b9d1b38..153abdf 100644 --- a/R/drawForestplotObject.R +++ b/R/drawForestplotObject.R @@ -17,12 +17,12 @@ drawForestplotObject <- function(obj) { obj$labels <- NULL - xRange <- prFpXrange(upper = obj$upper, - lower = obj$lower, - clip = obj$clip, - zero = obj$zero, - xticks = obj$xticks, - xlog = obj$xlog) + xRange <- prFpXrange(upper = obj$estimates[,3,], + lower = obj$estimates[,2,], + clip = obj$clip, + zero = obj$zero, + xticks = obj$xticks, + xlog = obj$xlog) axisList <- prFpGetGraphTicksAndClips(xticks = obj$xticks, xticks.digits = obj$xticks.digits, @@ -36,7 +36,7 @@ drawForestplotObject <- function(obj) { clip = obj$clip, zero = obj$zero, x_range = xRange, - mean = obj$org_mean, + estimates = obj$estimates, graph.pos = obj$graph.pos, shapes_gp = obj$shapes_gp) @@ -109,35 +109,10 @@ drawForestplotObject <- function(obj) { name = "BaseGrid" )) - # Create the fourth argument 4 the fpDrawNormalCI() function - if (!is.null(obj$boxsize)) { - # If matrix is provided this will convert it - # to a vector but it doesn't matter in this case - info <- rep(obj$boxsize, length = length(obj$mean)) - } else { - # Get width of the lines - cwidth <- (obj$upper - obj$lower) - # Set cwidth to min value if the value is invalid - # this can be the case for reference points - cwidth[cwidth <= 0 | is.na(cwidth)] <- min(cwidth[cwidth > 0]) - textHeight <- convertUnit(grobHeight(textGrob("A", gp = do.call(gpar, obj$txt_gp$label))), - unitTo = "npc", - valueOnly = TRUE - ) - - info <- 1 / cwidth * 0.75 - if (!all(obj$is.summary)) { - info <- info / max(info[!obj$is.summary], na.rm = TRUE) - - # Adjust the dots as it gets ridiculous with small text and huge dots - if (any(textHeight * (attr(labels, "no_rows") + .5) * 1.5 < info)) { - info <- textHeight * (attr(labels, "no_rows") + .5) * 1.5 * info / max(info, na.rm = TRUE) + textHeight * (attr(labels, "no_rows") + .5) * 1.5 / 4 - } - } - - # Set summary to maximum size - info[obj$is.summary] <- 1 / NCOL(obj$org_mean) - } + info <- prepBoxSize(boxsize = obj$boxsize, + estimates = obj$estimates, + is.summary = obj$is.summary, + txt_gp = obj$txt_gp) prFpPrintLabels( labels = labels, @@ -154,23 +129,11 @@ drawForestplotObject <- function(obj) { plot(axisList) # Output the different confidence intervals - for (i in 1:attr(labels, "no_rows")) { - if (is.matrix(obj$org_mean)) { - low_values <- obj$org_lower[i, ] - mean_values <- obj$org_mean[i, ] - up_values <- obj$org_upper[i, ] - info_values <- matrix(info, ncol = length(low_values))[i, ] - } else { - low_values <- obj$org_lower[i] - mean_values <- obj$org_mean[i] - up_values <- obj$org_upper[i] - info_values <- info[i] - } - + for (i in 1:nrow(obj$estimates)) { # The line and box colors may vary - clr.line <- rep(obj$col$line, length.out = length(low_values)) - clr.marker <- rep(obj$col$box, length.out = length(low_values)) - clr.summary <- rep(obj$col$summary, length.out = length(low_values)) + clr.line <- rep(obj$col$line, length.out = dim(obj$estimates)[3]) + clr.marker <- rep(obj$col$box, length.out = dim(obj$estimates)[3]) + clr.summary <- rep(obj$col$summary, length.out = dim(obj$estimates)[3]) line_vp <- viewport( layout.pos.row = i, @@ -181,39 +144,39 @@ drawForestplotObject <- function(obj) { pushViewport(line_vp) # Draw multiple confidence intervals - if (length(low_values) > 1) { - b_height <- max(info_values) + if (dim(obj$estimates)[3] > 1) { + b_height <- max(info[i,]) if (is.unit(b_height)) { b_height <- convertUnit(b_height, unitTo = "npc", valueOnly = TRUE) } if (is.null(obj$line.margin)) { - obj$line.margin <- .1 + .2 / (length(low_values) - 1) + obj$line.margin <- .1 + .2 / (dim(obj$estimates)[3] - 1) } else if (is.unit(obj$line.margin)) { obj$line.margin <- convertUnit(obj$line.margin, unitTo = "npc", valueOnly = TRUE) } y.offset_base <- b_height / 2 + obj$line.margin - y.offset_increase <- (1 - obj$line.margin * 2 - b_height) / (length(low_values) - 1) + y.offset_increase <- (1 - obj$line.margin * 2 - b_height) / (dim(obj$estimates)[3] - 1) - for (j in length(low_values):1) { + for (j in dim(obj$estimates)[3]:1) { # Start from the bottom and plot up # the one on top should always be # above the one below - current_y.offset <- y.offset_base + (length(low_values) - j) * y.offset_increase - if (is.na(mean_values[j])) { + current_y.offset <- y.offset_base + (dim(obj$estimates)[3] - j) * y.offset_increase + if (is.na(obj$estimates[i, 1, j])) { next } shape_coordinates <- c(i, j) - attr(shape_coordinates, "max.coords") <- c(attr(labels, "no_rows"), length(low_values)) + attr(shape_coordinates, "max.coords") <- c(attr(labels, "no_rows"), dim(obj$estimates)[3]) if (obj$is.summary[i]) { call_list <- list(obj$fn.ci_sum[[i]][[j]], - lower_limit = low_values[j], - estimate = mean_values[j], - upper_limit = up_values[j], - size = info_values[j], + estimate = obj$estimates[i, 1, j], + lower_limit = obj$estimates[i, 2, j], + upper_limit = obj$estimates[i, 3, j], + size = info[i, j], y.offset = current_y.offset, col = clr.summary[j], shapes_gp = obj$shapes_gp, @@ -222,10 +185,10 @@ drawForestplotObject <- function(obj) { } else { call_list <- list(obj$fn.ci_norm[[i]][[j]], - lower_limit = low_values[j], - estimate = mean_values[j], - upper_limit = up_values[j], - size = info_values[j], + estimate = obj$estimates[i, 1, j], + lower_limit = obj$estimates[i, 2, j], + upper_limit = obj$estimates[i, 3, j], + size = info[i, j], y.offset = current_y.offset, clr.line = clr.line[j], clr.marker = clr.marker[j], @@ -265,10 +228,10 @@ drawForestplotObject <- function(obj) { if (obj$is.summary[i]) { call_list <- list(obj$fn.ci_sum[[i]], - lower_limit = low_values, - estimate = mean_values, - upper_limit = up_values, - size = info_values, + estimate = obj$estimates[i, 1, 1], + lower_limit = obj$estimates[i, 2, 1], + upper_limit = obj$estimates[i, 3, 1], + size = info[i, 1], col = clr.summary, shapes_gp = obj$shapes_gp, shape_coordinates = shape_coordinates @@ -276,13 +239,13 @@ drawForestplotObject <- function(obj) { } else { call_list <- list(obj$fn.ci_norm[[i]], - lower_limit = low_values, - estimate = mean_values, - upper_limit = up_values, - size = info_values, + estimate = obj$estimates[i, 1, 1], + lower_limit = obj$estimates[i, 2, 1], + upper_limit = obj$estimates[i, 3, 1], + size = info[i, 1], clr.line = clr.line, clr.marker = clr.marker, - lty = obj$lty.ci[[i]], + lty = obj$lty.ci[[i]][[1]], vertices.height = obj$ci.vertices.height, shapes_gp = obj$shapes_gp, shape_coordinates = shape_coordinates @@ -304,7 +267,7 @@ drawForestplotObject <- function(obj) { } # Do the actual drawing of the object - if (!all(is.na(mean_values))) { + if (!all(is.na(obj$estimates[i, 1, 1]))) { tryCatch(eval(as.call(call_list)), error = function(e) { stop("On row ", i, " the print of the estimate failed: ", e$message) diff --git a/R/forestplot.default.R b/R/forestplot.default.R index e3c14a7..0f2c1c0 100644 --- a/R/forestplot.default.R +++ b/R/forestplot.default.R @@ -55,82 +55,25 @@ forestplot.default <- function(labeltext, assert_class(txt_gp, "fpTxtGp") assert_class(col, "fpColors") - - if (missing(lower) && - missing(upper) && - missing(mean)) { - if (missing(labeltext)) { - stop( - "You need to provide the labeltext or", - " the mean/lower/upper arguments" - ) - } - - mean <- labeltext - labeltext <- rownames(mean) - } - - if (missing(lower) && - missing(upper)) { - assert( - check_matrix(mean, ncols = 3), - check_array(mean, d = 3), - check_integer(dim(mean)[2], lower = 3, upper = 3) - ) - } - assert_vector(zero, max.len = 2) - if (missing(labeltext)) { - labeltext <- rownames(mean) - } - - if (is.null(labeltext)) { - stop( - "You must provide labeltext either in the direct form as an argument", - " or as rownames for the mean argument." - ) - } - # Assume that lower and upper are contained within - # the mean variable - if (missing(lower) && - missing(upper)) { - if (NCOL(mean) != 3) { - stop("If you do not provide lower/upper arguments your mean needs to have 3 columns") - } - - # If the mean can in this case be eithe 2D-matrix - # that generates a regular forest plot or - # it can be a 3D-array where the 3:rd level - # constitutes the different bands - all <- prFpConvertMultidimArray(mean) - mean <- all$mean - lower <- all$lower - upper <- all$upper - } - - if (NCOL(mean) != NCOL(lower) || - NCOL(lower) != NCOL(upper) || - NCOL(mean) == 0) { - stop( - "Mean, lower and upper contain invalid number of columns", - " Mean columns:", ncol(mean), - " Lower bound columns:", ncol(lower), - " Upper bound columns:", ncol(upper) - ) + coreData <- buildEstimateArray(labeltext, lower, upper, mean) + rm(labeltext) + if (!missing(mean)) { + rm(lower, upper, mean) } - if (NCOL(mean) != length(col$box)) { - col$box <- rep(col$box, length.out = NCOL(mean)) - col$line <- rep(col$lines, length.out = NCOL(mean)) + if (dim(coreData$estimates)[3] != length(col$box)) { + col$box <- rep(col$box, length.out = dim(coreData$estimates)[3]) + col$line <- rep(col$lines, length.out = dim(coreData$estimates)[3]) } # Prepare the legend marker if (!is.null(legend)) { fn.legend <- prFpPrepareLegendMarker( fn.legend = fn.legend, - col_no = NCOL(mean), - row_no = NROW(mean), + col_no = dim(coreData$estimates)[3], + row_no = nrow(coreData$estimates), fn.ci_norm = fn.ci_norm ) } @@ -143,11 +86,11 @@ forestplot.default <- function(labeltext, } if (!is.null(legend)) { - if (length(legend) != ncol(mean)) { + if (length(legend) != dim(coreData$estimates)[3]) { stop( "If you want a legend you need to provide the same number of", " legend descriptors as you have boxes per line, currently you have ", - ncol(mean), " boxes and ", + dim(coreData$estimates)[3], " boxes and ", length(legend), " legends." ) } @@ -173,27 +116,13 @@ forestplot.default <- function(labeltext, } } - # Fix if data.frames were provided in the arguments - if (is.data.frame(mean)) { - mean <- as.matrix(mean) - } - if (is.data.frame(lower)) { - lower <- as.matrix(lower) - } - if (is.data.frame(upper)) { - upper <- as.matrix(upper) - } - # Instantiate a new page - forced if no device exists if (new_page || dev.cur() == 1) grid.newpage() # Save the original values since the function due to it's inheritance # from the original forestplot needs some changing to the parameters if (xlog) { - if (any(mean < 0, na.rm = TRUE) || - any(lower < 0, na.rm = TRUE) || - any(upper < 0, na.rm = TRUE) || - (!is.na(zero) && zero <= 0) || + if (any(coreData$estimates < 0, na.rm = TRUE) || (!is.null(clip) && any(Filter(Negate(is.infinite), clip) <= 0, na.rm = TRUE)) || (!is.null(grid) && !isFALSE(grid) && any(grid <= 0, na.rm = TRUE))) { stop("All argument values (mean, lower, upper, zero, grid and clip)", @@ -203,63 +132,39 @@ forestplot.default <- function(labeltext, } # Change all the values along the log scale - org_mean <- log(mean) - org_lower <- log(lower) - org_upper <- log(upper) - } else { - org_mean <- mean - org_lower <- lower - org_upper <- upper - } - - # For border calculations etc it's - # convenient to have the matrix as a - # vector - if (NCOL(mean) > 1) { - mean <- as.vector(mean) - lower <- as.vector(lower) - upper <- as.vector(upper) + coreData$estimates <- log(coreData$estimates) + clip[clip < 0] <- 0 + clip <- log(clip) + zero <- log(zero) } # Prep basics - labels <- prepLabelText(labeltext = labeltext, - nr = NROW(org_mean)) + labels <- prepLabelText(labeltext = coreData$labeltext, + nr = nrow(coreData$estimates)) graph.pos <- prepGraphPositions(graph.pos, nc = attr(labels, "no_cols")) align <- prepAlign(align, graph.pos = graph.pos, nc = attr(labels, "no_cols")) - is.summary <- rep(is.summary, length.out = attr(labels, "no_rows")) - - if (is.matrix(mean)) { - missing_rows <- apply(mean, 2, function(row) all(is.na(row))) - } else { - missing_rows <- sapply(mean, is.na) - } - - fn.ci_norm <- prFpGetConfintFnList( - fn = fn.ci_norm, - no_rows = NROW(org_mean), - no_cols = NCOL(org_mean), - missing_rows = missing_rows, - is.summary = is.summary, - summary = FALSE - ) - fn.ci_sum <- prFpGetConfintFnList( - fn = fn.ci_sum, - no_rows = NROW(org_mean), - no_cols = NCOL(org_mean), - missing_rows = missing_rows, - is.summary = is.summary, - summary = TRUE - ) + is.summary <- rep(is.summary, length.out = nrow(coreData$estimates)) + missing_rows <- apply(coreData$estimates, 2, \(row) all(is.na(row))) + + fn.ci_norm <- prFpGetConfintFnList(fn = fn.ci_norm, + no_rows = nrow(coreData$estimates), + no_depth = dim(coreData$estimates)[3], + missing_rows = missing_rows, + is.summary = is.summary, + summary = FALSE) + fn.ci_sum <- prFpGetConfintFnList(fn = fn.ci_sum, + no_rows = nrow(coreData$estimates), + no_depth = dim(coreData$estimates)[3], + missing_rows = missing_rows, + is.summary = is.summary, + summary = TRUE) lty.ci <- prPopulateList(lty.ci, - no_rows = NROW(org_mean), - no_cols = NCOL(org_mean) - ) + no_rows = nrow(coreData$estimates), + no_depth = dim(coreData$estimates)[3]) list(labels = labels, - mean = mean, - upper = upper, - lower = lower, + estimates = coreData$estimates, mar = mar, align = align, title = title, @@ -273,11 +178,8 @@ forestplot.default <- function(labeltext, graph.pos = graph.pos, boxsize = boxsize, is.summary = is.summary, - org_mean = org_mean, shapes_gp = shapes_gp, hrzl_lines = hrzl_lines, - org_lower = org_lower, - org_upper = org_upper, line.margin = line.margin, fn.legend = fn.legend, fn.ci_sum = fn.ci_sum, diff --git a/R/getTicks.R b/R/getTicks.R index f6113ac..e3295e6 100644 --- a/R/getTicks.R +++ b/R/getTicks.R @@ -25,7 +25,7 @@ getTicks <- function(low, # Get the right ticks lowest <- max(min(low, na.rm = TRUE), clip[1]) bottom <- floor(lowest * 2) / 2 - if (bottom == 0 & exp) { + if (bottom == 0 && exp) { bottom <- 2^(round(log2(lowest) * 2) / 2) } diff --git a/R/prFpGetGraphTicksAndClips.R b/R/prFpGetGraphTicksAndClips.R index 91ef1f0..112b005 100644 --- a/R/prFpGetGraphTicksAndClips.R +++ b/R/prFpGetGraphTicksAndClips.R @@ -5,7 +5,7 @@ #' #' @param x_range The range that the values from the different confidence #' interval span -#' @param mean The original means, either matrix or vector +#' @param estimates The estimates as a 3D array #' @return \code{list} Returns a list with axis_vp, axisGrob, labGrob, zero and clip #' #' @@ -23,37 +23,17 @@ prFpGetGraphTicksAndClips <- function(xticks, clip, zero, x_range, - mean, + estimates, graph.pos, shapes_gp = fpShapesGp()) { - # Active rows are all excluding the top ones with NA in the mean value - if (is.matrix(mean)) { - for (from in 1:nrow(mean)) { - if (!all(is.na(mean[from, ]))) { - break - } - } - to <- nrow(mean) - } else { - for (from in 1:length(mean)) { - if (!is.na(mean[from])) { - break - } - } - to <- length(mean) - } + layoutRowSpan <- getActiveRowSpan(estimates) if (xlog) { - clip[clip < 0] <- 0 - clip <- log(clip) - zero <- log(zero) - if (is.null(xticks)) { ticks <- getTicks(exp(x_range), clip = clip, exp = xlog, - digits = xticks.digits - ) + digits = xticks.digits) # Add the endpoint ticks to the tick list if # it's not already there @@ -78,12 +58,10 @@ prFpGetGraphTicksAndClips <- function(xticks, ticks <- xticks } - axis_vp <- viewport( - layout.pos.col = graph.pos * 2 - 1, - layout.pos.row = from:to, - xscale = x_range, - name = "axis" - ) + axis_vp <- viewport(layout.pos.col = graph.pos * 2 - 1, + layout.pos.row = layoutRowSpan, + xscale = x_range, + name = "axis") @@ -94,8 +72,7 @@ prFpGetGraphTicksAndClips <- function(xticks, # be by default one more digit ticklabels <- ifelse(ticks < 1 | abs(floor(ticks * 10) - ticks * 10) > 0, format(ticks, digits = 2, nsmall = 2), - format(ticks, digits = 1, nsmall = 1) - ) + format(ticks, digits = 1, nsmall = 1)) ticks <- log(ticks) } else { ticks <- NULL @@ -108,7 +85,6 @@ prFpGetGraphTicksAndClips <- function(xticks, exp = xlog, digits = xticks.digits ) - ticks <- c(min(x_range), ticks) # Add the endpoint ticks to the tick list if # it's not already there @@ -136,12 +112,10 @@ prFpGetGraphTicksAndClips <- function(xticks, ticklabels <- TRUE } - axis_vp <- viewport( - layout.pos.col = 2 * graph.pos - 1, - layout.pos.row = from:to, - xscale = x_range, - name = "axis" - ) + axis_vp <- viewport(layout.pos.col = 2 * graph.pos - 1, + layout.pos.row = layoutRowSpan, + xscale = x_range, + name = "axis") } # Clean @@ -190,7 +164,7 @@ prFpGetGraphTicksAndClips <- function(xticks, } } dg <- xaxisGrob(at = ticks, - label = FALSE, + label = ticklabels, gp = gp_axis) if (length(grid) == 1) { if (is.logical(grid) && @@ -207,7 +181,7 @@ prFpGetGraphTicksAndClips <- function(xticks, # Actually identical to the ticks viewport grid_vp <- viewport( layout.pos.col = 2 * graph.pos - 1, - layout.pos.row = from:to, + layout.pos.row = layoutRowSpan, xscale = x_range, name = "grid_vp" ) @@ -254,3 +228,22 @@ prFpGetGraphTicksAndClips <- function(xticks, lwd.zero = lwd.zero) |> structure(class = "forestplot_xaxis") } + +#' Retrieve rows with actual data, i.e. not headers +#' +#' Active rows are all excluding the top ones with NA in the mean value +#' +#' @inheritParams prFpGetGraphTicksAndClips +#' @return vector with all active rows (i.e. `from:to`) +#' +#' @noRd +getActiveRowSpan <- function(estimates) { + mean <- estimates[,1,,drop = FALSE] + to <- nrow(estimates) + for (from in 1:to) { + if (!all(is.na(mean[from,,]))) { + return(from:to) + } + } + stop("Could not identify rows with actual data") +} diff --git a/R/private.R b/R/private.R index f624152..b7450c6 100644 --- a/R/private.R +++ b/R/private.R @@ -10,7 +10,7 @@ #' and rows are the same it will not know what is a column #' and what is a row. #' @param no_rows Number of rows -#' @param no_cols Number of columns +#' @param no_depth Number of columns #' @param missing_rows The rows that don't have a CI #' @return \code{list} The function returns a list that has #' the format [[row]][[col]] where each element contains the @@ -19,12 +19,13 @@ #' #' @inheritParams forestplot #' @keywords internal -prFpGetConfintFnList <- function(fn, no_rows, no_cols, missing_rows, is.summary, summary) { +prFpGetConfintFnList <- function(fn, no_rows, no_depth, missing_rows, is.summary, summary) { ret <- prPopulateList(fn, - no_rows = no_rows, no_cols = no_cols, - missing_rows = missing_rows, - is.summary = is.summary, summary = summary - ) + no_rows = no_rows, + no_depth = no_depth, + missing_rows = missing_rows, + is.summary = is.summary, + summary = summary) makeCalleable <- function(value) { if (is.function(value)) { @@ -61,7 +62,7 @@ prFpGetConfintFnList <- function(fn, no_rows, no_cols, missing_rows, is.summary, #' and rows are the same it will not know what is a column #' and what is a row. #' @param no_rows Number of rows -#' @param no_cols Number of columns +#' @param no_depth Number of outcomes per row, i.e. depth #' @param missing_rows The rows that don't have data #' @return \code{list} The function returns a list that has #' the format [[row]][[col]] where each element contains the @@ -69,7 +70,7 @@ prFpGetConfintFnList <- function(fn, no_rows, no_cols, missing_rows, is.summary, #' #' @inheritParams forestplot #' @keywords internal -prPopulateList <- function(elmnt, no_rows, no_cols, missing_rows, is.summary, summary) { +prPopulateList <- function(elmnt, no_rows, no_depth, missing_rows, is.summary, summary) { # Return a list that has # a two dim structure of [[row]][[col]] # if you have a matrix provided but if you @@ -78,14 +79,14 @@ prPopulateList <- function(elmnt, no_rows, no_cols, missing_rows, is.summary, su # If the fn is a character or a matrix then ret <- list() if (is.function(elmnt)) { - if (no_cols == 1) { + if (no_depth == 1) { for (i in 1:no_rows) { ret[[i]] <- elmnt } } else { for (i in 1:no_rows) { ret[[i]] <- list() - for (ii in 1:no_cols) { + for (ii in 1:no_depth) { ret[[i]][[ii]] <- elmnt } } @@ -93,11 +94,11 @@ prPopulateList <- function(elmnt, no_rows, no_cols, missing_rows, is.summary, su } else if (is.character(elmnt) || is.numeric(elmnt)) { if (is.matrix(elmnt)) { - if (ncol(elmnt) != no_cols) { + if (ncol(elmnt) != no_depth) { stop( "Your columns do not add upp for your", " confidence interval funcitons, ", - ncol(elmnt), " != ", no_cols + ncol(elmnt), " != ", no_depth ) } if (nrow(elmnt) != no_rows) { @@ -107,32 +108,32 @@ prPopulateList <- function(elmnt, no_rows, no_cols, missing_rows, is.summary, su nrow(elmnt), " != ", no_rows ) } - } else if (length(elmnt) == no_cols) { - elmnt <- matrix(elmnt, nrow = no_rows, ncol = no_cols, byrow = TRUE) + } else if (length(elmnt) == no_depth) { + elmnt <- matrix(elmnt, nrow = no_rows, ncol = no_depth, byrow = TRUE) } else if (length(elmnt) %in% c(1, no_rows)) { - elmnt <- matrix(elmnt, nrow = no_rows, ncol = no_cols) + elmnt <- matrix(elmnt, nrow = no_rows, ncol = no_depth) } else { stop( "You have not provided the expected", " number of elements: ", - length(elmnt), " is not 1, ", no_cols, " (columns), or ", no_rows, " (rows)" + length(elmnt), " is not 1, ", no_depth, " (columns), or ", no_rows, " (rows)" ) } # Convert into function format for (i in 1:no_rows) { - if (no_cols == 1) { + if (no_depth == 1) { ret[[i]] <- elmnt[i, 1] } else { ret[[i]] <- list() - for (ii in 1:no_cols) { + for (ii in 1:no_depth) { ## Go by row for the elmnt ret[[i]][[ii]] <- elmnt[i, ii] } } } } else if (is.list(elmnt)) { - if (no_cols == 1) { + if (no_depth == 1) { # Actually correct if the lengths add up if (length(elmnt) != no_rows) { if (length(elmnt) == sum(is.summary == summary)) { @@ -180,7 +181,7 @@ prPopulateList <- function(elmnt, no_rows, no_cols, missing_rows, is.summary, su if (!is.list(elmnt[[1]])) { for (i in 1:no_rows) { ret[[i]] <- list() - for (ii in 1:no_cols) { + for (ii in 1:no_depth) { ## Go by row for the elmnt ret[[i]][[ii]] <- elmnt[[i]] } @@ -190,7 +191,7 @@ prPopulateList <- function(elmnt, no_rows, no_cols, missing_rows, is.summary, su # is provided as a valid matrix # with the correct size n <- sapply(elmnt, length) - if (any(n != no_cols)) { + if (any(n != no_depth)) { stop( "You need to provide a 'square' list (of dim. n x m)", " of the same dimension as the number of lines", @@ -198,19 +199,19 @@ prPopulateList <- function(elmnt, no_rows, no_cols, missing_rows, is.summary, su " confidence interval function has the format", " ", no_rows, " x ", paste(n, collapse = "/"), " where you want all of the second argument to be", - " equal to ", no_cols + " equal to ", no_depth ) } ret <- elmnt } - } else if (length(elmnt) == no_cols) { + } else if (length(elmnt) == no_depth) { # One dim-list provided # now generate a two-dim list if (!is.list(elmnt[[1]])) { for (i in 1:no_rows) { ret[[i]] <- list() - for (ii in 1:no_cols) { + for (ii in 1:no_depth) { ## Go by row for the elmnt ret[[i]][[ii]] <- elmnt[[ii]] } @@ -227,14 +228,14 @@ prPopulateList <- function(elmnt, no_rows, no_cols, missing_rows, is.summary, su " confidence interval function has the format", " ", no_rows, " x ", paste(n, collapse = "/"), " where you want all of the second argument to be", - " equal to ", no_cols + " equal to ", no_depth ) } # Change to the [[row]][[col]] format for (i in 1:no_rows) { ret[[i]] <- list() - for (ii in 1:no_cols) { + for (ii in 1:no_depth) { ## Go by row for the elmnt ret[[i]][[ii]] <- elmnt[[ii]][[i]] } @@ -246,7 +247,7 @@ prPopulateList <- function(elmnt, no_rows, no_cols, missing_rows, is.summary, su " functions, ", length(elmnt), ", ", " does not seem to match up with either", " number of rows, ", no_rows, - " or number of cols, ", no_cols + " or number of cols, ", no_depth ) } } @@ -369,11 +370,7 @@ prFpXrange <- function(upper, lower, clip, zero, xticks, xlog) { ) } - if (xlog) { - return(log(ret)) - } else { - return(ret) - } + return(ret) } #' Get the label @@ -645,11 +642,9 @@ prFpPrepareLegendMarker <- function(fn.legend, col_no, row_no, fn.ci_norm) { } if (length(fn.ci_norm) == col_no) { - return(prFpGetConfintFnList( - fn = fn.ci_norm, - no_rows = row_no, - no_cols = col_no - )[[1]]) + return(prFpGetConfintFnList(fn = fn.ci_norm, + no_rows = row_no, + no_depth = col_no)[[1]]) } # Not sure what to do if the number don't match the number of legends diff --git a/R/private_buildEstimateArray.R b/R/private_buildEstimateArray.R new file mode 100644 index 0000000..4dc37ce --- /dev/null +++ b/R/private_buildEstimateArray.R @@ -0,0 +1,76 @@ +buildEstimateArray <- function(labeltext, lower, upper, mean) { + if (missing(lower) && + missing(upper) && + missing(mean)) { + if (missing(labeltext)) { + stop( + "You need to provide the labeltext or", + " the mean/lower/upper arguments" + ) + } + + mean <- labeltext + labeltext <- rownames(mean) + } + + if (missing(lower) && + missing(upper)) { + assert( + check_matrix(mean, ncols = 3), + check_array(mean, d = 3), + check_integer(dim(mean)[2], lower = 3, upper = 3) + ) + } + + if (missing(labeltext)) { + labeltext <- rownames(mean) + } + + if (is.null(labeltext)) { + stop( + "You must provide labeltext either in the direct form as an argument", + " or as rownames for the mean argument." + ) + } + # Assume that lower and upper are contained within + # the mean variable + if (missing(lower) && + missing(upper)) { + if (NCOL(mean) != 3) { + stop("If you do not provide lower/upper arguments your mean needs to have 3 columns") + } + + # If the mean can in this case be eithe 2D-matrix + # that generates a regular forest plot or + # it can be a 3D-array where the 3:rd level + # constitutes the different bands + all <- prFpConvertMultidimArray(mean) + mean <- all$mean + lower <- all$lower + upper <- all$upper + } + + if (NCOL(mean) != NCOL(lower) || + NCOL(lower) != NCOL(upper) || + NCOL(mean) == 0) { + stop( + "Mean, lower and upper contain invalid number of columns", + " Mean columns:", ncol(mean), + " Lower bound columns:", ncol(lower), + " Upper bound columns:", ncol(upper) + ) + } + + if (NCOL(mean) == 1) { + estimates <- array(NA, dim = c(NROW(mean), 3, 1)) + estimates[,,1] <- cbind(mean, lower, upper) |> as.matrix() + } else { + estimates <- array(dim = c(NROW(mean), 3, NCOL(mean))) + for (i in 1:NCOL(mean)) { + estimates[,,i] <- cbind(mean[,i], lower[,i], upper[,i]) + } + } + + list(labeltext = labeltext, + estimates = estimates) +} diff --git a/R/private_prepBoxSize.R b/R/private_prepBoxSize.R new file mode 100644 index 0000000..1e065dd --- /dev/null +++ b/R/private_prepBoxSize.R @@ -0,0 +1,39 @@ +#' @importFrom abind adrop +prepBoxSize <- function(boxsize, estimates, is.summary, txt_gp) { + # Create the fourth argument 4 the fpDrawNormalCI() function + if (!is.null(boxsize)) { + # If matrix is provided this will convert it + # to a vector but it doesn't matter in this case + return(matrix(boxsize, + nrow = nrow(estimates), + ncol = dim(estimates)[3])) + } + + + # Get width of the lines, upper CI - lower CI + cwidth <- (estimates[,3,,drop = FALSE] - estimates[,2,,drop = FALSE]) + + # Set cwidth to min value if the value is invalid + # this can be the case for reference points + cwidth[cwidth <= 0] <- min(cwidth[cwidth > 0], na.rm = TRUE) + cwidth[is.na(cwidth)] <- min(cwidth, na.rm = TRUE) + + # As the line may be very high we want the box to relate to actual box height + textHeight <- convertUnit(grobHeight(textGrob("A", gp = do.call(gpar, txt_gp$label))), + unitTo = "npc", + valueOnly = TRUE) + + boxsize <- 1 / cwidth * 0.75 + if (!all(is.summary)) { + boxsize <- boxsize / max(boxsize[!is.summary,,], na.rm = TRUE) + + # Adjust the dots as it gets ridiculous with small text and huge dots + if (any(textHeight * (nrow(estimates) + .5) * 1.5 < boxsize)) { + boxsize <- textHeight * (nrow(estimates) + .5) * 1.5 * boxsize / max(boxsize, na.rm = TRUE) + textHeight * (nrow(estimates) + .5) * 1.5 / 4 + } + } + + # Set summary to maximum size + boxsize[is.summary,,] <- 1 / dim(estimates)[3] + return(abind::adrop(boxsize, drop = 2)) +} diff --git a/man/prFpGetConfintFnList.Rd b/man/prFpGetConfintFnList.Rd index 3c478df..2387aa2 100644 --- a/man/prFpGetConfintFnList.Rd +++ b/man/prFpGetConfintFnList.Rd @@ -4,7 +4,7 @@ \alias{prFpGetConfintFnList} \title{Get a function list} \usage{ -prFpGetConfintFnList(fn, no_rows, no_cols, missing_rows, is.summary, summary) +prFpGetConfintFnList(fn, no_rows, no_depth, missing_rows, is.summary, summary) } \arguments{ \item{fn}{The function list/matrix. If a list it @@ -15,7 +15,7 @@ and what is a row.} \item{no_rows}{Number of rows} -\item{no_cols}{Number of columns} +\item{no_depth}{Number of columns} \item{missing_rows}{The rows that don't have a CI} diff --git a/man/prPopulateList.Rd b/man/prPopulateList.Rd index c196fa8..56d3138 100644 --- a/man/prPopulateList.Rd +++ b/man/prPopulateList.Rd @@ -4,7 +4,7 @@ \alias{prPopulateList} \title{Populate a list corresponding to matrix specs} \usage{ -prPopulateList(elmnt, no_rows, no_cols, missing_rows, is.summary, summary) +prPopulateList(elmnt, no_rows, no_depth, missing_rows, is.summary, summary) } \arguments{ \item{elmnt}{The element item/list/matrix. If a list it @@ -15,7 +15,7 @@ and what is a row.} \item{no_rows}{Number of rows} -\item{no_cols}{Number of columns} +\item{no_depth}{Number of outcomes per row, i.e. depth} \item{missing_rows}{The rows that don't have data} diff --git a/tests/forestplot2_vtests.R b/tests/forestplot2_vtests.R index 5c4d39b..d873649 100644 --- a/tests/forestplot2_vtests.R +++ b/tests/forestplot2_vtests.R @@ -335,15 +335,14 @@ test_data <- data.frame( ) forestplot(row_names, - test_data$coef, - test_data$low, - test_data$high, - zero = 1, - cex = 1, - lineheight = "auto", - xlab = "Odds", - xlog = TRUE -) + test_data$coef, + test_data$low, + test_data$high, + zero = 1, + cex = 1, + lineheight = "auto", + xlab = "Odds", + xlog = TRUE) ##################### # Check square data # diff --git a/tests/testthat/test-forestplot.group_df.R b/tests/testthat/test-forestplot.group_df.R index 577c8ac..f2e1fe0 100644 --- a/tests/testthat/test-forestplot.group_df.R +++ b/tests/testthat/test-forestplot.group_df.R @@ -21,8 +21,8 @@ test_that("Basic", { xlab = "EQ-5D index" ) - expect_equivalent(out$mean, - lapply(HRQoL, \(x) x[,"coef"]) |> unlist()) + expect_equivalent(out$estimates[,1,], + lapply(HRQoL, \(x) x[,"coef"]) |> do.call(cbind, args = _)) }) @@ -46,9 +46,9 @@ test_that("How to handle missing rows when group_by have different names", { xticks = c(-.1, -0.05, 0, .05), xlab = "EQ-5D index" ) - expect_equivalent(out$mean[1:4], + expect_equivalent(out$estimates[,1,1], HRQoL[[1]][,"coef"]) - expect_scalar_na(out$mean[5]) - expect_equivalent(out$mean[6:8], + expect_scalar_na(out$estimates[1,1,2]) + expect_equivalent(out$estimates[2:4,1,2], HRQoL[[2]][2:4,"coef"]) }) From 2885542514fe6b4b1cf756cdc2843a0e89bf3a18 Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Tue, 27 Sep 2022 14:54:25 +0200 Subject: [PATCH 09/17] WIP - add rows to foresplot --- NAMESPACE | 3 + R/drawForestplotObject.R | 32 ++++- R/forestplot.default.R | 17 --- R/fp_insert_row.R | 169 ++++++++++++++++++++++++++ R/private_buildEstimateArray.R | 3 + R/private_prepLabelText.R | 18 ++- inst/examples/fp_insert_row_example.R | 25 ++++ man/row_manipulation.Rd | 74 +++++++++++ vignettes/forestplot.Rmd | 17 +-- 9 files changed, 321 insertions(+), 37 deletions(-) create mode 100644 R/fp_insert_row.R create mode 100644 inst/examples/fp_insert_row_example.R create mode 100644 man/row_manipulation.Rd diff --git a/NAMESPACE b/NAMESPACE index c704ce0..d89c996 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -17,6 +17,9 @@ export(fpDrawSummaryCI) export(fpLegend) export(fpShapesGp) export(fpTxtGp) +export(fp_add_header) +export(fp_append_row) +export(fp_insert_row) export(getTicks) export(prGetShapeGp) import(grid) diff --git a/R/drawForestplotObject.R b/R/drawForestplotObject.R index 153abdf..d5354c0 100644 --- a/R/drawForestplotObject.R +++ b/R/drawForestplotObject.R @@ -16,6 +16,26 @@ drawForestplotObject <- function(obj) { col = obj$col) obj$labels <- NULL + missing_rows <- apply(obj$estimates, 2, \(row) all(is.na(row))) + + fn.ci_norm <- prFpGetConfintFnList(fn = obj$fn.ci_norm, + no_rows = nrow(obj$estimates), + no_depth = dim(obj$estimates)[3], + missing_rows = missing_rows, + is.summary = obj$is.summary, + summary = FALSE) + obj$fn.ci_norm <- NULL + fn.ci_sum <- prFpGetConfintFnList(fn = obj$fn.ci_sum, + no_rows = nrow(obj$estimates), + no_depth = dim(obj$estimates)[3], + missing_rows = missing_rows, + is.summary = obj$is.summary, + summary = TRUE) + obj$fn.ci_sum <- NULL + lty.ci <- prPopulateList(obj$lty.ci, + no_rows = nrow(obj$estimates), + no_depth = dim(obj$estimates)[3]) + obj$lty.ci <- NULL xRange <- prFpXrange(upper = obj$estimates[,3,], lower = obj$estimates[,2,], @@ -172,7 +192,7 @@ drawForestplotObject <- function(obj) { if (obj$is.summary[i]) { call_list <- - list(obj$fn.ci_sum[[i]][[j]], + list(fn.ci_sum[[i]][[j]], estimate = obj$estimates[i, 1, j], lower_limit = obj$estimates[i, 2, j], upper_limit = obj$estimates[i, 3, j], @@ -184,7 +204,7 @@ drawForestplotObject <- function(obj) { ) } else { call_list <- - list(obj$fn.ci_norm[[i]][[j]], + list(fn.ci_norm[[i]][[j]], estimate = obj$estimates[i, 1, j], lower_limit = obj$estimates[i, 2, j], upper_limit = obj$estimates[i, 3, j], @@ -192,7 +212,7 @@ drawForestplotObject <- function(obj) { y.offset = current_y.offset, clr.line = clr.line[j], clr.marker = clr.marker[j], - lty = obj$lty.ci[[i]][[j]], + lty = lty.ci[[i]][[j]], vertices.height = obj$ci.vertices.height, shapes_gp = obj$shapes_gp, shape_coordinates = shape_coordinates @@ -227,7 +247,7 @@ drawForestplotObject <- function(obj) { if (obj$is.summary[i]) { call_list <- - list(obj$fn.ci_sum[[i]], + list(fn.ci_sum[[i]], estimate = obj$estimates[i, 1, 1], lower_limit = obj$estimates[i, 2, 1], upper_limit = obj$estimates[i, 3, 1], @@ -238,14 +258,14 @@ drawForestplotObject <- function(obj) { ) } else { call_list <- - list(obj$fn.ci_norm[[i]], + list(fn.ci_norm[[i]], estimate = obj$estimates[i, 1, 1], lower_limit = obj$estimates[i, 2, 1], upper_limit = obj$estimates[i, 3, 1], size = info[i, 1], clr.line = clr.line, clr.marker = clr.marker, - lty = obj$lty.ci[[i]][[1]], + lty = lty.ci[[i]][[1]], vertices.height = obj$ci.vertices.height, shapes_gp = obj$shapes_gp, shape_coordinates = shape_coordinates diff --git a/R/forestplot.default.R b/R/forestplot.default.R index 0f2c1c0..7c0b8c6 100644 --- a/R/forestplot.default.R +++ b/R/forestplot.default.R @@ -145,23 +145,6 @@ forestplot.default <- function(labeltext, align <- prepAlign(align, graph.pos = graph.pos, nc = attr(labels, "no_cols")) is.summary <- rep(is.summary, length.out = nrow(coreData$estimates)) - missing_rows <- apply(coreData$estimates, 2, \(row) all(is.na(row))) - - fn.ci_norm <- prFpGetConfintFnList(fn = fn.ci_norm, - no_rows = nrow(coreData$estimates), - no_depth = dim(coreData$estimates)[3], - missing_rows = missing_rows, - is.summary = is.summary, - summary = FALSE) - fn.ci_sum <- prFpGetConfintFnList(fn = fn.ci_sum, - no_rows = nrow(coreData$estimates), - no_depth = dim(coreData$estimates)[3], - missing_rows = missing_rows, - is.summary = is.summary, - summary = TRUE) - lty.ci <- prPopulateList(lty.ci, - no_rows = nrow(coreData$estimates), - no_depth = dim(coreData$estimates)[3]) list(labels = labels, estimates = coreData$estimates, diff --git a/R/fp_insert_row.R b/R/fp_insert_row.R new file mode 100644 index 0000000..41b04e1 --- /dev/null +++ b/R/fp_insert_row.R @@ -0,0 +1,169 @@ +#' Insert/append rows into forestplot +#' +#' These functions are used for inserting or appending +#' a row into a forestplot object. Can be used for inputting multiple +#' rows. Just make sure that all elements are of equal length. +#' +#' @param x The forestplot object +#' @param ... Either named arguments that correspond to the original column +#' names or unnamed arguments that will map in appearing order. +#' @param mean Either a mean or all the values if three columns (mean, lower, upper) +#' @param lower A vector or matrix with the lower confidence interval +#' @param upper A vector or matrix with the upper confidence interval +#' @param position The row position to input at. Either a row number or "last". +#' @param is.summary Whether the row is a summary. +#' +#' @return The foresplot object with the added rows +#' @export +#' +#' @example inst/examples/fp_insert_row_example.R + +#' @rdname row_manipulation +fp_insert_row <- function(x, + ..., + mean = NULL, lower = NULL, upper = NULL, + position = 1, + is.summary = FALSE){ + labels <- sapply(list(...), + function(var) { + if (is.list(var)) { + return(var) + } + + return(as.list(var)) + }, + simplify = FALSE, + USE.NAMES = TRUE) + estimates <- pr_convert_insert_estimates(mean = mean, + lower = lower, + upper = upper, + label_length = length(labels[[1]]), + xlog = x$xlog) + stopifnot(all(nrow(estimates) == sapply(labels, length))) + + if (position == "last") { + x$estimates <- abind::abind(x$estimates, estimates, along = 1) + } else { + x$estimates <- abind::abind(x$estimates[0:(position - 1),,,drop = FALSE], + estimates, + x$estimates[position:nrow(x$estimates),,,drop = FALSE], + along = 1) + + } + + if (is.null(labels)) { + if (length(labels) > attr(x$labels, "no_cols")) { + stop("Mismatch between number of columns in labels and provided number of columns") + } + } else if (is.null(x$labels)) { + stop("Original data lacks labels and columns, i.e. names ", + paste(names(labels), collapse = ", "), + " can't be matched to original labels") + } else { + desired_colnames <- names(labels) + lacking_match <- desired_colnames[!(desired_colnames %in% names(x$labels))] + if (length(lacking_match) > 0) { + stop("Unkown label columns ", paste(lacking_match, collapse = ", "), + " not present among: ", paste(names(x$labels), collapse = ", ")) + } + } + + + for (i in 1:attr(x$labels, "no_cols")) { + if (i > length(labels)) { + val <- as.list(rep(NA, length.out = nrow(estimates))) + } else { + if (is.null(names(labels))) { + val <- labels[[i]] + } else { + n <- names(x$labels)[i] + val <- labels[[n]] + if (is.null(val)) { + val <- list(NA) + } + } + } + + if (position == "last") { + x$labels[[i]] <- c(x$labels[[i]], val) + } else { + x$labels[[i]] <- c(x$labels[[i]][0:(position - 1)], + val, + x$labels[[i]][position:length(x$labels[[i]])]) + } + } + + attr(x$labels, "no_rows") <- nrow(x$estimates) + + is.summary <- rep(is.summary, length.out = nrow(estimates)) + if (position == "last") { + x$is.summary <- c(x$is.summary, is.summary) + } else { + x$is.summary <- c(x$is.summary[0:(position - 1)], + is.summary, + x$is.summary[position:length(x$is.summary)]) + } + + return(x) +} + +#' @rdname row_manipulation +#' @export +fp_add_header <- function(x, ..., position = 1, is.summary = TRUE) { + fp_insert_row(x, ..., position = position, is.summary = is.summary) +} + +#' @rdname row_manipulation +#' @export +fp_append_row <- function(x, ..., position = "last", is.summary = FALSE) { + fp_insert_row(x, ..., position = position, is.summary = is.summary) +} + +pr_convert_insert_estimates <- function(mean, lower, upper, label_length, xlog) { + stopifnot(is.null(lower) == is.null(upper)) + if (is.null(mean)) { + return(array(NA, dim = c(label_length,3,1), dimnames = list(NULL, c("mean", "lower", "upper"), NULL))) + } + + if (is.null(lower)) { + stopifnot(!is.null(dim(mean)) && ncol(mean) == 3) + if (length(dim(mean)) == 2) { + mean <- array(mean, dim = c(dim(mean), 1)) + } + lower <- mean[,2,,drop = FALSE] + upper <- mean[,3,,drop = FALSE] + mean <- mean[,1,,drop = FALSE] + } else { + stopifnot(all.equal(dim(mean), dim(lower), dim(upper))) + base_dims <- dim(mean) + if (is.null(base_dims)) { + base_dims <- c(1, 1) + } + if (length(base_dims) < 3) { + mean <- array(mean, dim = c(base_dims, 1)) + lower <- array(lower, dim = c(base_dims, 1)) + upper <- array(upper, dim = c(base_dims, 1)) + } + } + + if (label_length != nrow(mean)) { + stop("Label length is not equal to values", label_length, " != ", nrow(mean)) + } + + estimates <- abind::abind(mean, lower, upper, along = 2, new.names = list(NULL, c("mean", "lower", "upper"), NULL)) + if (xlog) { + estimates <- log(estimates) + } + return(estimates) +} + +if (FALSE) { + base_data |> + forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), + clip = c(0.1, 2.5), + xlog = TRUE, + col = fpColors(box = "royalblue", + line = "darkblue", + summary = "royalblue")) |> + fp_insert_row(c("asdasd", "Asd")) +} diff --git a/R/private_buildEstimateArray.R b/R/private_buildEstimateArray.R index 4dc37ce..b702ac8 100644 --- a/R/private_buildEstimateArray.R +++ b/R/private_buildEstimateArray.R @@ -71,6 +71,9 @@ buildEstimateArray <- function(labeltext, lower, upper, mean) { } } + d <- dimnames(estimates) + d[[2]] <- c("mean", "lower", "upper") + dimnames(estimates) <- d list(labeltext = labeltext, estimates = estimates) } diff --git a/R/private_prepLabelText.R b/R/private_prepLabelText.R index 2de5a96..37d6e34 100644 --- a/R/private_prepLabelText.R +++ b/R/private_prepLabelText.R @@ -20,18 +20,22 @@ prepLabelText <- function(labeltext, nr) { # Can't figure out multiple levels of expressions nc <- 1 label_nr <- length(labeltext) + # Names are retained labeltext <- as.list(labeltext) } else if (is.list(labeltext)) { if (sapply(labeltext, \(x) length(x) == 1 && !is.list(x)) |> all()) { labeltext <- list(labeltext) } - labeltext <- lapply(labeltext, function(x) { - if (is.list(x)) { - return(x) - } + labeltext <- sapply(labeltext, + function(x) { + if (is.list(x)) { + return(x) + } - return(as.list(x)) - }) + return(as.list(x)) + }, + simplify = FALSE, + USE.NAMES = TRUE) if (!prFpValidateLabelList(labeltext)) { stop("Invalid labellist, it has to be formed as a matrix m x n elements") @@ -67,7 +71,9 @@ prepLabelText <- function(labeltext, nr) { widthcolumn <- !apply(is.na(labeltext), 1, any) nc <- NCOL(labeltext) label_nr <- NROW(labeltext) + label_colnames <- colnames(labeltext) labeltext <- (\(x) lapply(seq(NCOL(labeltext)), function(i) as.list(x[,i])))(labeltext) + names(labeltext) <- label_colnames } if (nr != label_nr) { diff --git a/inst/examples/fp_insert_row_example.R b/inst/examples/fp_insert_row_example.R new file mode 100644 index 0000000..2dd028e --- /dev/null +++ b/inst/examples/fp_insert_row_example.R @@ -0,0 +1,25 @@ +base_data <- tibble(mean = c(0.578, 0.165, 0.246, 0.700, 0.348, 0.139, 1.017), + lower = c(0.372, 0.018, 0.072, 0.333, 0.083, 0.016, 0.365), + upper = c(0.898, 1.517, 0.833, 1.474, 1.455, 1.209, 2.831), + study = c("Auckland", "Block", "Doran", "Gamsu", "Morrison", "Papageorgiou", "Tauesch"), + deaths_steroid = c("36", "1", "4", "14", "3", "1", "8"), + deaths_placebo = c("60", "5", "11", "20", "7", "7", "10"), + OR = c("0.58", "0.16", "0.25", "0.70", "0.35", "0.14", "1.02")) + +base_data |> + forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), + clip = c(0.1, 2.5), + xlog = TRUE, + col = fpColors(box = "royalblue", + line = "darkblue", + summary = "royalblue")) |> + fp_add_header(study = c("", "Study"), + deaths_steroid = c("Deaths", "(steroid)"), + deaths_placebo = c("Deaths", "(placebo)"), + OR = c("", "OR")) |> + fp_append_row(mean = 0.531, + lower = 0.386, + upper = 0.731, + study = "Summary", + OR = "0.53", + is.summary = TRUE) diff --git a/man/row_manipulation.Rd b/man/row_manipulation.Rd new file mode 100644 index 0000000..c265a6d --- /dev/null +++ b/man/row_manipulation.Rd @@ -0,0 +1,74 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fp_insert_row.R +\name{fp_insert_row} +\alias{fp_insert_row} +\alias{fp_add_header} +\alias{fp_append_row} +\title{Insert row into table} +\usage{ +fp_insert_row( + x, + ..., + mean = NULL, + lower = NULL, + upper = NULL, + position = 1, + is.summary = FALSE +) + +fp_add_header(x, ...) + +fp_append_row(x, ...) +} +\arguments{ +\item{x}{The forestplot object} + +\item{...}{Either named arguments that correspond to the original column +names or unnamed arguments that will map in appearing order.} + +\item{mean}{Either a mean or all the values if three columns (mean, lower, upper)} + +\item{lower}{A vector or matrix with the lower confidence interval} + +\item{upper}{A vector or matrix with the upper confidence interval} + +\item{position}{The row position to input at. Either a row number or "last".} + +\item{is.summary}{Whether the row is a summary.} +} +\value{ +The foresplot object with the added rows +} +\description{ +Inserts a row into a forestplot object. Can be used for inputting multiple +rows. Just make sure that all elements are of equal length. +} +\examples{ +base_data <- tibble(mean = c(0.578, 0.165, 0.246, 0.700, 0.348, 0.139, 1.017), + lower = c(0.372, 0.018, 0.072, 0.333, 0.083, 0.016, 0.365), + upper = c(0.898, 1.517, 0.833, 1.474, 1.455, 1.209, 2.831), + study = c("Auckland", "Block", "Doran", "Gamsu", "Morrison", "Papageorgiou", "Tauesch"), + deaths_steroid = c("36", "1", "4", "14", "3", "1", "8"), + deaths_placebo = c("60", "5", "11", "20", "7", "7", "10"), + OR = c("0.58", "0.16", "0.25", "0.70", "0.35", "0.14", "1.02")) + +base_data |> + forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), + clip = c(0.1, 2.5), + xlog = TRUE, + col = fpColors(box = "royalblue", + line = "darkblue", + summary = "royalblue")) |> + fp_insert_row(study = c("", "Study"), + deaths_steroid = c("Deaths", "(steroid)"), + deaths_placebo = c("Deaths", "(placebo)"), + OR = c("", "OR"), + is.summary = TRUE) |> + fp_insert_row(mean = 0.531, + lower = 0.386, + upper = 0.731, + study = "Summary", + OR = "0.53", + summary = TRUE, + position = "last") +} diff --git a/vignettes/forestplot.Rmd b/vignettes/forestplot.Rmd index a848a11..e969620 100644 --- a/vignettes/forestplot.Rmd +++ b/vignettes/forestplot.Rmd @@ -49,21 +49,22 @@ Text A forest plot is closely connected to text and the ability to customize the text is central. +```{r} +library(forestplot) +library(dplyr) +``` + + Table of text ------------- Below is a basic example from the original `forestplot` function that shows how to use a table of text: ```{r, fig.height=4, fig.width=8, message=FALSE} -library(forestplot) -library(dplyr) # Cochrane data from the 'rmeta'-package -cochrane_from_rmeta <- structure(list(mean = c(NA, NA, 0.578, 0.165, 0.246, 0.700, 0.348, 0.139, 1.017, NA, 0.531), - lower = c(NA, NA, 0.372, 0.018, 0.072, 0.333, 0.083, 0.016, 0.365, NA, 0.386), - upper = c(NA, NA, 0.898, 1.517, 0.833, 1.474, 1.455, 1.209, 2.831, NA, 0.731)), - .Names = c("mean", "lower", "upper"), - row.names = c(NA, -11L), - class = "data.frame") +cochrane_from_rmeta <- data.frame(mean = c(NA, NA, 0.578, 0.165, 0.246, 0.7, 0.348, 0.139, 1.017, NA, 0.531), + lower = c(NA, NA, 0.372, 0.018, 0.072, 0.333, 0.083, 0.016, 0.365, NA, 0.386), + upper = c(NA, NA, 0.898, 1.517, 0.833, 1.474, 1.455, 1.209, 2.831, NA, 0.731)) tabletext <- cbind(c("", "Study", "Auckland", "Block", "Doran", "Gamsu", "Morrison", "Papageorgiou", "Tauesch", NA, "Summary"), c("Deaths", "(steroid)", "36", "1", "4", "14", "3", "1", "8", NA, NA), From 49c6f72036ca7339e9efe3f1cac5c01ee4177572 Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Tue, 27 Sep 2022 22:00:38 +0200 Subject: [PATCH 10/17] Finished withNew additive syntax with row manipulation: `fp_insert_row`, `fp_add_header`, `fp_append_row` --- NEWS.md | 16 +++-- R/forestplot.default.R | 6 +- R/fp_insert_row.R | 11 +++- R/private.R | 5 +- inst/examples/fp_insert_row_example.R | 15 +++-- man/forestplot.Rd | 2 +- man/row_manipulation.Rd | 34 +++++----- tests/testthat/test-inputs.R | 1 - tests/testthat/test-insert_row.R | 75 +++++++++++++++++++++ vignettes/forestplot.Rmd | 93 +++++++++------------------ 10 files changed, 157 insertions(+), 101 deletions(-) create mode 100644 tests/testthat/test-insert_row.R diff --git a/NEWS.md b/NEWS.md index 7b8c094..071f60f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,14 +1,20 @@ NEWS for the forestplot package -Changes for 2.1.0 +Changes for 3.0.0 ----------------- +* The `forestplot()` now returns an object with raw data that can be manipulated + by subsequent functions prior to plotting. All visual output is now generated + during the actual generation of the graph - this allows saving the plot and + plotting it when explicitly requested. BREAKING - this may be a breaking + feature although most of the old syntax should work without much need for + adaptation. +* New additive syntax with: + * Row manipulation: `fp_insert_row`, `fp_add_header`, `fp_append_row` * Fixed bug with how grouped data frames are processed and presented. -* Expressions are now allowed in data.frame tidyverse input +* Expressions are now allowed in data.frame tidyverse input. * Moved to native R-pipe operator (|> instead of %>%) - -Changes for 2.0.2 ------------------ * Fixed case when all rows are summaries (Thanks Christian Röver) +* Fixed automated ticks. Changes for 2.0.1 ----------------- diff --git a/R/forestplot.default.R b/R/forestplot.default.R index 7c0b8c6..4b83759 100644 --- a/R/forestplot.default.R +++ b/R/forestplot.default.R @@ -198,6 +198,10 @@ print.gforge_forestplot <- function(x, ...) { #' @rdname forestplot #' @param y Ignored #' @export -plot.gforge_forestplot <- function(x, y, ...) { +plot.gforge_forestplot <- function(x, y, ..., new_page = FALSE) { + if (new_page) { + grid.newpage() + } + print(x, ...) } diff --git a/R/fp_insert_row.R b/R/fp_insert_row.R index 41b04e1..963b6cf 100644 --- a/R/fp_insert_row.R +++ b/R/fp_insert_row.R @@ -24,12 +24,17 @@ fp_insert_row <- function(x, mean = NULL, lower = NULL, upper = NULL, position = 1, is.summary = FALSE){ - labels <- sapply(list(...), - function(var) { + args <- list(...) + labels <- sapply(args, + FUN = function(var) { if (is.list(var)) { return(var) } + if (is.expression(var)) { + return(lapply(1:length(var), \(i) var[i])) + } + return(as.list(var)) }, simplify = FALSE, @@ -70,7 +75,7 @@ fp_insert_row <- function(x, for (i in 1:attr(x$labels, "no_cols")) { - if (i > length(labels)) { + if (is.null(names(labels)) && i > length(labels)) { val <- as.list(rep(NA, length.out = nrow(estimates))) } else { if (is.null(names(labels))) { diff --git a/R/private.R b/R/private.R index b7450c6..f1a5838 100644 --- a/R/private.R +++ b/R/private.R @@ -401,9 +401,10 @@ prFpFetchRowLabel <- function(label_type, labeltext, i, j) { } row_column_text <- labeltext[i, j] } + if (!is.expression(row_column_text) && - !is.call(row_column_text) && - is.na(row_column_text)) { + !is.call(row_column_text) && + is.na(row_column_text)) { return("") } diff --git a/inst/examples/fp_insert_row_example.R b/inst/examples/fp_insert_row_example.R index 2dd028e..577650f 100644 --- a/inst/examples/fp_insert_row_example.R +++ b/inst/examples/fp_insert_row_example.R @@ -1,10 +1,11 @@ -base_data <- tibble(mean = c(0.578, 0.165, 0.246, 0.700, 0.348, 0.139, 1.017), - lower = c(0.372, 0.018, 0.072, 0.333, 0.083, 0.016, 0.365), - upper = c(0.898, 1.517, 0.833, 1.474, 1.455, 1.209, 2.831), - study = c("Auckland", "Block", "Doran", "Gamsu", "Morrison", "Papageorgiou", "Tauesch"), - deaths_steroid = c("36", "1", "4", "14", "3", "1", "8"), - deaths_placebo = c("60", "5", "11", "20", "7", "7", "10"), - OR = c("0.58", "0.16", "0.25", "0.70", "0.35", "0.14", "1.02")) +base_data <- tibble::tibble(mean = c(0.578, 0.165, 0.246, 0.700, 0.348, 0.139, 1.017), + lower = c(0.372, 0.018, 0.072, 0.333, 0.083, 0.016, 0.365), + upper = c(0.898, 1.517, 0.833, 1.474, 1.455, 1.209, 2.831), + study = c("Auckland", "Block", "Doran", "Gamsu", + "Morrison", "Papageorgiou", "Tauesch"), + deaths_steroid = c("36", "1", "4", "14", "3", "1", "8"), + deaths_placebo = c("60", "5", "11", "20", "7", "7", "10"), + OR = c("0.58", "0.16", "0.25", "0.70", "0.35", "0.14", "1.02")) base_data |> forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), diff --git a/man/forestplot.Rd b/man/forestplot.Rd index 59c2de7..3a16afd 100644 --- a/man/forestplot.Rd +++ b/man/forestplot.Rd @@ -57,7 +57,7 @@ forestplot(...) \method{print}{gforge_forestplot}(x, ...) -\method{plot}{gforge_forestplot}(x, y, ...) +\method{plot}{gforge_forestplot}(x, y, ..., new_page = FALSE) \method{forestplot}{grouped_df}(x, labeltext, mean, lower, upper, legend, is.summary, ...) } diff --git a/man/row_manipulation.Rd b/man/row_manipulation.Rd index c265a6d..f5122f2 100644 --- a/man/row_manipulation.Rd +++ b/man/row_manipulation.Rd @@ -4,7 +4,7 @@ \alias{fp_insert_row} \alias{fp_add_header} \alias{fp_append_row} -\title{Insert row into table} +\title{Insert/append rows into forestplot} \usage{ fp_insert_row( x, @@ -16,9 +16,9 @@ fp_insert_row( is.summary = FALSE ) -fp_add_header(x, ...) +fp_add_header(x, ..., position = 1, is.summary = TRUE) -fp_append_row(x, ...) +fp_append_row(x, ..., position = "last", is.summary = FALSE) } \arguments{ \item{x}{The forestplot object} @@ -40,17 +40,19 @@ names or unnamed arguments that will map in appearing order.} The foresplot object with the added rows } \description{ -Inserts a row into a forestplot object. Can be used for inputting multiple +These functions are used for inserting or appending +a row into a forestplot object. Can be used for inputting multiple rows. Just make sure that all elements are of equal length. } \examples{ -base_data <- tibble(mean = c(0.578, 0.165, 0.246, 0.700, 0.348, 0.139, 1.017), - lower = c(0.372, 0.018, 0.072, 0.333, 0.083, 0.016, 0.365), - upper = c(0.898, 1.517, 0.833, 1.474, 1.455, 1.209, 2.831), - study = c("Auckland", "Block", "Doran", "Gamsu", "Morrison", "Papageorgiou", "Tauesch"), - deaths_steroid = c("36", "1", "4", "14", "3", "1", "8"), - deaths_placebo = c("60", "5", "11", "20", "7", "7", "10"), - OR = c("0.58", "0.16", "0.25", "0.70", "0.35", "0.14", "1.02")) +base_data <- tibble::tibble(mean = c(0.578, 0.165, 0.246, 0.700, 0.348, 0.139, 1.017), + lower = c(0.372, 0.018, 0.072, 0.333, 0.083, 0.016, 0.365), + upper = c(0.898, 1.517, 0.833, 1.474, 1.455, 1.209, 2.831), + study = c("Auckland", "Block", "Doran", "Gamsu", + "Morrison", "Papageorgiou", "Tauesch"), + deaths_steroid = c("36", "1", "4", "14", "3", "1", "8"), + deaths_placebo = c("60", "5", "11", "20", "7", "7", "10"), + OR = c("0.58", "0.16", "0.25", "0.70", "0.35", "0.14", "1.02")) base_data |> forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), @@ -59,16 +61,14 @@ base_data |> col = fpColors(box = "royalblue", line = "darkblue", summary = "royalblue")) |> - fp_insert_row(study = c("", "Study"), + fp_add_header(study = c("", "Study"), deaths_steroid = c("Deaths", "(steroid)"), deaths_placebo = c("Deaths", "(placebo)"), - OR = c("", "OR"), - is.summary = TRUE) |> - fp_insert_row(mean = 0.531, + OR = c("", "OR")) |> + fp_append_row(mean = 0.531, lower = 0.386, upper = 0.731, study = "Summary", OR = "0.53", - summary = TRUE, - position = "last") + is.summary = TRUE) } diff --git a/tests/testthat/test-inputs.R b/tests/testthat/test-inputs.R index 274a0ce..210a678 100644 --- a/tests/testthat/test-inputs.R +++ b/tests/testthat/test-inputs.R @@ -1,6 +1,5 @@ library(testthat) library(abind) -context("Tests for forestplot inputs") test_that("Check different input formats", { basic_data <- cbind(0:2, 1:3, 2:4) diff --git a/tests/testthat/test-insert_row.R b/tests/testthat/test-insert_row.R new file mode 100644 index 0000000..cd550d5 --- /dev/null +++ b/tests/testthat/test-insert_row.R @@ -0,0 +1,75 @@ +library(testthat) + +test_that("Check that header row is added", { + out <- data.frame(labels = LETTERS[1:4], + mean = 1:4, + lower = 1:4 - 1, + upper = 1:4 + 1) |> + forestplot(labeltext = labels, + mean = mean, + lower = lower, + upper = upper) + + expect_equivalent(out$labels |> unlist(), + LETTERS[1:4]) + + expect_equivalent(out$estimates[,,1], + cbind(mean = 1:4, lower = 1:4 - 1, upper = 1:4 + 1)) + + out_with_header <- out |> + fp_add_header(expression(beta)) + expect_equivalent(out_with_header$labels[[1]][[1]], + expression(beta)) + + expect_true(all(sapply(out_with_header$estimates[1,,], is.na))) +}) + +test_that("Check that row is added", { + out <- data.frame(labels = LETTERS[1:4], + mean = 1:4, + lower = 1:4 - 1, + upper = 1:4 + 1) |> + forestplot(labeltext = labels, + mean = mean, + lower = lower, + upper = upper) + + out_with_header <- out |> + fp_insert_row("Data", + mean = matrix(c(3, 1, 4), ncol = 3), + position = 2) + expect_equivalent(out_with_header$labels[[1]][[2]], + "Data") + + expect_equivalent(out_with_header$estimates[2,,], + matrix(c(3, 1, 4), ncol = 3)) + + expect_equivalent(nrow(out_with_header$estimates), 5) +}) + + +test_that("Check that row is appended", { + out <- data.frame(label_1 = LETTERS[1:4], + label_2 = LETTERS[1:4 + 1], + label_3 = LETTERS[1:4 + 2], + mean = 1:4, + lower = 1:4 - 1, + upper = 1:4 + 1) |> + forestplot(labeltext = c(label_1, label_2, label_3), + mean = mean, + lower = lower, + upper = upper) + + out_with_header <- out |> + fp_append_row(label_1 = "AA", + label_3 = "BB", + mean = matrix(c(3, 1, 4), ncol = 3)) + expect_equivalent(out_with_header$labels[[1]] |> tail(1), + list("AA")) + + expect_equivalent(out_with_header$labels[[2]] |> tail(1), + list(NA)) + + expect_equivalent(out_with_header$labels[[3]] |> tail(1), + list("BB")) +}) diff --git a/vignettes/forestplot.Rmd b/vignettes/forestplot.Rmd index e969620..abcc442 100644 --- a/vignettes/forestplot.Rmd +++ b/vignettes/forestplot.Rmd @@ -62,69 +62,34 @@ Below is a basic example from the original `forestplot` function that shows how ```{r, fig.height=4, fig.width=8, message=FALSE} # Cochrane data from the 'rmeta'-package -cochrane_from_rmeta <- data.frame(mean = c(NA, NA, 0.578, 0.165, 0.246, 0.7, 0.348, 0.139, 1.017, NA, 0.531), - lower = c(NA, NA, 0.372, 0.018, 0.072, 0.333, 0.083, 0.016, 0.365, NA, 0.386), - upper = c(NA, NA, 0.898, 1.517, 0.833, 1.474, 1.455, 1.209, 2.831, NA, 0.731)) - -tabletext <- cbind(c("", "Study", "Auckland", "Block", "Doran", "Gamsu", "Morrison", "Papageorgiou", "Tauesch", NA, "Summary"), - c("Deaths", "(steroid)", "36", "1", "4", "14", "3", "1", "8", NA, NA), - c("Deaths", "(placebo)", "60", "5", "11", "20", "7", "7", "10", NA, NA), - c("", "OR", "0.58", "0.16", "0.25", "0.70", "0.35", "0.14", "1.02", NA, "0.53")) - -cochrane_from_rmeta |> - forestplot(labeltext = tabletext, - is.summary = c(rep(TRUE, 2), rep(FALSE, 8), TRUE), - clip = c(0.1, 2.5), - xlog = TRUE, - col = fpColors(box = "royalblue", - line = "darkblue", - summary = "royalblue")) -``` - -The `dplyr` syntax ------------------- - -As of version *2.0* the forestplot package is compatible with standard `dplyr` syntax. Above is a minor adaptation for the old code using this syntax. If you provide a `data.frame` it will assume that the names are `mean`, `lower`, `upper` and `labeltext` unless you specify otherwise. Below is perhaps a more natural way of achieving the same as above that most likely better corresponds to a modern work flow. - -```{r} -# Cochrane data from the 'rmeta'-package -base_data <- tibble(mean = c(0.578, 0.165, 0.246, 0.700, 0.348, 0.139, 1.017), - lower = c(0.372, 0.018, 0.072, 0.333, 0.083, 0.016, 0.365), - upper = c(0.898, 1.517, 0.833, 1.474, 1.455, 1.209, 2.831), - study = c("Auckland", "Block", "Doran", "Gamsu", "Morrison", "Papageorgiou", "Tauesch"), - deaths_steroid = c("36", "1", "4", "14", "3", "1", "8"), - deaths_placebo = c("60", "5", "11", "20", "7", "7", "10"), - OR = c("0.58", "0.16", "0.25", "0.70", "0.35", "0.14", "1.02")) - -summary <- tibble(mean = 0.531, - lower = 0.386, - upper = 0.731, - study = "Summary", - OR = "0.53", - summary = TRUE) - -header <- tibble(study = c("", "Study"), - deaths_steroid = c("Deaths", "(steroid)"), - deaths_placebo = c("Deaths", "(placebo)"), - OR = c("", "OR"), - summary = TRUE) - -empty_row <- tibble(mean = NA_real_) - -cochrane_output_df <- bind_rows(header, - base_data, - empty_row, - summary) - -cochrane_output_df |> - forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), - is.summary = summary, - clip = c(0.1, 2.5), - xlog = TRUE, - col = fpColors(box = "royalblue", - line = "darkblue", - summary = "royalblue")) - +base_data <- tibble::tibble(mean = c(0.578, 0.165, 0.246, 0.700, 0.348, 0.139, 1.017), + lower = c(0.372, 0.018, 0.072, 0.333, 0.083, 0.016, 0.365), + upper = c(0.898, 1.517, 0.833, 1.474, 1.455, 1.209, 2.831), + study = c("Auckland", "Block", "Doran", "Gamsu", + "Morrison", "Papageorgiou", "Tauesch"), + deaths_steroid = c("36", "1", "4", "14", "3", "1", "8"), + deaths_placebo = c("60", "5", "11", "20", "7", "7", "10"), + OR = c("0.58", "0.16", "0.25", "0.70", "0.35", "0.14", "1.02")) + +base_data |> + forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), + clip = c(0.1, 2.5), + xlog = TRUE, + shapes_gp = fpShapesGp(box = gpar(fill = "royalblue", + col = "royalblue"), + line = gpar(col = "darkblue"), + summary = gpar(fill = "royalblue", + col = "royalblue"))) |> + fp_add_header(study = c("", "Study"), + deaths_steroid = c("Deaths", "(steroid)"), + deaths_placebo = c("Deaths", "(placebo)"), + OR = c("", "OR")) |> + fp_append_row(mean = 0.531, + lower = 0.386, + upper = 0.731, + study = "Summary", + OR = "0.53", + is.summary = TRUE) ``` Summary lines @@ -133,7 +98,7 @@ Summary lines The same as above but with lines based on the summary elements and also using a direct call with matrix input instead of relying on dplyr. ```{r, fig.height=4, fig.width=8, message=FALSE} -cochrane_output_df |> +base_data |> forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), is.summary = summary, clip = c(0.1, 2.5), From fdef536195161d5a7c89c6a5323f9a13aa9725d7 Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Wed, 28 Sep 2022 00:25:06 +0200 Subject: [PATCH 11/17] Added font style, updated docs and bumped version --- DESCRIPTION | 4 +- NAMESPACE | 7 + NEWS.md | 2 + R/forestplot-package.R | 22 +- R/forestplot.R | 51 ++--- R/forestplot.data.frame.R | 21 +- R/forestplot.grouped_df.R | 14 +- R/forestplot_helpers.R | 111 ++++++---- R/fp_insert_row.R | 28 ++- R/fp_set_style.R | 47 ++++ R/private_prGetLabelsList.R | 23 +- R/text_styling.R | 102 +++++++++ inst/examples/forestplot_example.R | 88 ++++---- inst/examples/fp_insert_row_example.R | 5 +- inst/examples/fp_set_style_example.R | 21 ++ man/assertAndRetrieveTidyValue.Rd | 4 +- man/forestplot-package.Rd | 20 +- man/forestplot.Rd | 150 ++++++------- man/fpColors.Rd | 8 +- man/fpDrawCI.Rd | 2 +- man/fpShapesGp.Rd | 57 +++-- man/prDefaultGp.Rd | 2 +- man/prFpFetchRowLabel.Rd | 4 +- man/prFpFindWidestGrob.Rd | 2 +- man/prFpGetConfintFnList.Rd | 4 +- man/prFpGetLayoutVP.Rd | 6 +- man/prFpGetLegendBoxPosition.Rd | 2 +- man/prGetLabelsList.Rd | 6 +- man/prPopulateList.Rd | 6 +- man/prepAlign.Rd | 2 +- man/prepGridMargins.Rd | 12 +- man/prepLabelText.Rd | 20 +- man/row_manipulation.Rd | 10 +- man/style_manipulation.Rd | 95 ++++++++ man/text_styling.Rd | 35 +++ tests/testthat/test-forestplot.group_df.R | 25 +++ vignettes/forestplot.Rmd | 253 +++++++++++++--------- 37 files changed, 857 insertions(+), 414 deletions(-) create mode 100644 R/fp_set_style.R create mode 100644 R/text_styling.R create mode 100644 inst/examples/fp_set_style_example.R create mode 100644 man/style_manipulation.Rd create mode 100644 man/text_styling.Rd diff --git a/DESCRIPTION b/DESCRIPTION index bf1363e..10a4338 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,5 +1,5 @@ Package: forestplot -Version: 2.1.0 +Version: 3.0.0 Title: Advanced Forest Plot Using 'grid' Graphics Authors@R: c(person(given = "Max", family = "Gordon", @@ -39,5 +39,5 @@ Suggests: Encoding: UTF-8 NeedsCompilation: no VignetteBuilder: knitr -Roxygen: list() +Roxygen: list(markdown = TRUE) RoxygenNote: 7.2.1 diff --git a/NAMESPACE b/NAMESPACE index d89c996..d0db4ac 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -18,8 +18,15 @@ export(fpLegend) export(fpShapesGp) export(fpTxtGp) export(fp_add_header) +export(fp_align_center) +export(fp_align_left) +export(fp_align_right) export(fp_append_row) export(fp_insert_row) +export(fp_set_style) +export(fp_txt_bold) +export(fp_txt_italic) +export(fp_txt_plain) export(getTicks) export(prGetShapeGp) import(grid) diff --git a/NEWS.md b/NEWS.md index 071f60f..854176e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -10,6 +10,8 @@ Changes for 3.0.0 adaptation. * New additive syntax with: * Row manipulation: `fp_insert_row`, `fp_add_header`, `fp_append_row` + * Style functions: `fp_set_style` and txt styling `fp_txt_bold`, `fp_txt_italic`, ... + * Align functions: `fp_align_left`, `fp_align_center`, `fp_align_right` * Fixed bug with how grouped data frames are processed and presented. * Expressions are now allowed in data.frame tidyverse input. * Moved to native R-pipe operator (|> instead of %>%) diff --git a/R/forestplot-package.R b/R/forestplot-package.R index 62da92a..3fff4a8 100644 --- a/R/forestplot-package.R +++ b/R/forestplot-package.R @@ -1,22 +1,20 @@ #' Package description #' -#' The forest plot function, \code{\link{forestplot}}, is a more general +#' The forest plot function, [`forestplot()`], is a more general #' version of the original \pkg{rmeta}-packages \code{forestplot} #' implementation. The aim is at using forest plots for more than #' just meta-analyses. #' #' The forestplot: -#' \enumerate{ -#' \item Allows for multiple confidence intervals per row -#' \item Custom fonts for each text element -#' \item Custom confidence intervals -#' \item Text mixed with expressions -#' \item Legends both on top/left of the plot and within the graph -#' \item Custom line height including auto-adapt height -#' \item Graph width that auto-adapts -#' \item Flexible arguments -#' \item and more -#' } +#' 1. Allows for multiple confidence intervals per row +#' 1. Custom fonts for each text element +#' 1. Custom confidence intervals +#' 1. Text mixed with expressions +#' 1. Legends both on top/left of the plot and within the graph +#' 1. Custom line height including auto-adapt height +#' 1. Graph width that auto-adapts +#' 1. Flexible arguments +#' 1. and more #' #' @section Additional functions: #' diff --git a/R/forestplot.R b/R/forestplot.R index f1ac8fa..29115fc 100644 --- a/R/forestplot.R +++ b/R/forestplot.R @@ -1,16 +1,15 @@ #' Draws a forest plot #' -#' The \emph{forestplot} is based on the \pkg{rmeta}-package`s -#' \code{forestplot} function. This -#' function resolves some limitations of the original +#' The **forestplot** is based on the \pkg{rmeta}-package`s +#' `forestplot()` function. This function resolves some limitations of the original #' functions such as: -#' \itemize{ -#' \item{Adding expressions: }{Allows use of expressions, e.g. \code{expression(beta)}} -#' \item{Multiple bands: }{Using multiple confidence bands for the same label} -#' \item{Autosize: }{Adapts to viewport (graph) size} -#' } #' -#' See \code{vignette("forestplot")} for details. +#' * Adding expressions: Allows use of expressions, e.g. `expression(beta)` +#' * Multiple bands: Using multiple confidence bands for the same label +#' * Autosize: Adapts to viewport (graph) size +#' * Convenient dplyr syntax +#' +#' See `vignette("forestplot")` for details. #' #' @section Multiple bands: #' @@ -25,19 +24,16 @@ #' The argument \code{hrzl_lines} can be either \code{TRUE} or a \code{list} with \code{\link[grid]{gpar}} #' elements: #' -#' \itemize{ -#' \item{\code{TRUE}}{A line will be added based upon the \code{is.summary} rows. If the first line is a summary it} -#' \item{\code{\link[grid]{gpar}}}{The same as above but the lines will be formatted according to the -#' \code{\link[grid]{gpar}} element} -#' \item{\code{list}}{The list must either be numbered, i.e. \code{list("2" = gpar(lty = 1))}, or have the same length -#' as the \code{NROW(mean) + 1}. If the list is numbered the numbers should not exceed the \code{NROW(mean) + 1}. -#' The no. \emph{1 row designates the top}, i.e. the line above the first row, all other correspond to -#' \emph{the row below}. Each element in the list needs to be \code{TRUE}, \code{NULL}, or -#' \code{\link[grid]{gpar}} element. The \code{TRUE} defaults to a standard line, the \code{NULL} -#' skips a line, while \code{\link[grid]{gpar}} corresponds to the fully customized line. Apart from -#' allowing standard \code{\link[grid]{gpar}} line descriptions, \code{lty}, \code{lwd}, \code{col}, and more -#' you can also specify \code{gpar(columns = c(1:3, 5))} if you for instance want the line to skip a column.} -#' } +#' * `TRUE`: A line will be added based upon the \code{is.summary} rows. If the first line is a summary it +#' * [grid::gpar]: The same as above but the lines will be formatted according to the [grid::gpar] element +#' * `list`: The list must either be numbered, i.e. \code{list("2" = gpar(lty = 1))}, or have the same length +#' as the \code{NROW(mean) + 1}. If the list is numbered the numbers should not exceed the \code{NROW(mean) + 1}. +#' The no. \emph{1 row designates the top}, i.e. the line above the first row, all other correspond to +#' \emph{the row below}. Each element in the list needs to be \code{TRUE}, \code{NULL}, or +#' \code{\link[grid]{gpar}} element. The \code{TRUE} defaults to a standard line, the \code{NULL} +#' skips a line, while \code{\link[grid]{gpar}} corresponds to the fully customized line. Apart from +#' allowing standard \code{\link[grid]{gpar}} line descriptions, \code{lty}, \code{lwd}, \code{col}, and more +#' you can also specify \code{gpar(columns = c(1:3, 5))} if you for instance want the line to skip a column. #' #' @section Known issues: #' @@ -45,10 +41,9 @@ #' always the best option, try to set these manually as much as possible. #' #' @section API-changes from \pkg{rmeta}-package`s \code{forestplot}: -#' \itemize{ -#' \item{xlog: }{The xlog outputs the axis in log() format but the input data should be in antilog/exp format} -#' \item{col: }{The corresponding function is \code{\link{fpColors}} for this package} -#' } +#' +#' * xlog: The xlog outputs the axis in log() format but the input data should be in antilog/exp format +#' * col: The corresponding function is \code{\link{fpColors}} for this package #' #' @param labeltext A list, matrix, vector or expression with the names of each #' row or the name of the column if using the *dplyr* select syntax - defaults to "labeltext". @@ -96,7 +91,7 @@ #' line height, then you set this variable to a certain height, note this should #' be provided as a \code{\link[grid]{unit}} object. A good option #' is to set the line height to \code{unit(2, "cm")}. A third option -#' is to set line height to "lines" and then you get 50 \% more than what the +#' is to set line height to "lines" and then you get 50% more than what the #' text height is as your line height #' @param line.margin Set the margin between rows, provided in numeric or \code{\link[grid]{unit}} form. #' When having multiple confidence lines per row setting the correct @@ -134,7 +129,7 @@ #' any other line type than 1 since there is a risk of a dash occurring #' at the very end, i.e. showing incorrectly narrow confidence interval. #' @param ci.vertices.height The height hoft the vertices. Defaults to npc units -#' corresponding to 10\% of the row height. +#' corresponding to 10% of the row height. #' \emph{Note that the arrows correspond to the vertices heights.} #' @param boxsize Override the default box size based on precision #' @param mar A numerical vector of the form \code{c(bottom, left, top, right)} of diff --git a/R/forestplot.data.frame.R b/R/forestplot.data.frame.R index dcaa353..5eefee5 100644 --- a/R/forestplot.data.frame.R +++ b/R/forestplot.data.frame.R @@ -2,7 +2,7 @@ #' @method forestplot data.frame #' @param x The data frame with or without grouping #' @export -forestplot.data.frame <- function(x, mean, lower, upper, labeltext, is.summary, ...) { +forestplot.data.frame <- function(x, mean, lower, upper, labeltext, is.summary, boxsize, ...) { safeLoadPackage("dplyr") safeLoadPackage("tidyr") safeLoadPackage("rlang") @@ -19,14 +19,31 @@ forestplot.data.frame <- function(x, mean, lower, upper, labeltext, is.summary, labeltext <- assertAndRetrieveTidyValue(x, labeltext) } + if (!missing(boxsize)) { + boxid <- substitute(boxsize) + boxsize <- tryCatch(x |> dplyr::pull({{ boxid }}) |> sapply(function(x) ifelse(is.na(x), NA, x)), + error = function(e) boxsize) + } else { + boxsize <- NULL + } + if (!missing(is.summary)) { sumid <- substitute(is.summary) is.summary <- tryCatch(x |> dplyr::pull({{ sumid }}) |> sapply(function(x) ifelse(is.na(x), FALSE, x)), error = function(e) is.summary ) + if (is.function(is.summary)) { + stop("Invalid summary input, does column, '", sumid, "', actually exist?") + } } else { is.summary <- FALSE } - forestplot.default(labeltext = labeltext, mean = estimates$mean, lower = estimates$lower, upper = estimates$upper, is.summary = is.summary, ...) + forestplot.default(labeltext = labeltext, + mean = estimates$mean, + lower = estimates$lower, + upper = estimates$upper, + is.summary = is.summary, + boxsize = boxsize, + ...) } diff --git a/R/forestplot.grouped_df.R b/R/forestplot.grouped_df.R index be24d81..30df2d1 100644 --- a/R/forestplot.grouped_df.R +++ b/R/forestplot.grouped_df.R @@ -1,7 +1,7 @@ #' @rdname forestplot #' @method forestplot grouped_df #' @export -forestplot.grouped_df <- function(x, labeltext, mean, lower, upper, legend, is.summary, ...) { +forestplot.grouped_df <- function(x, labeltext, mean, lower, upper, legend, is.summary, boxsize, ...) { safeLoadPackage("dplyr") safeLoadPackage("tidyr") safeLoadPackage("rlang") @@ -36,10 +36,21 @@ forestplot.grouped_df <- function(x, labeltext, mean, lower, upper, legend, is.s sumid <- substitute(is.summary) is.summary <- tryCatch(x |> dplyr::pull({{ sumid }}) |> sapply(function(x) ifelse(is.na(x), FALSE, x)), error = function(e) is.summary) + if (is.function(is.summary)) { + stop("Invalid summary input, does column, '", sumid, "', actually exist?") + } } else { is.summary <- FALSE } + if (!missing(boxsize)) { + boxid <- substitute(boxsize) + boxsize <- tryCatch(x |> dplyr::pull({{ boxid }}) |> sapply(function(x) ifelse(is.na(x), NA, x)), + error = function(e) boxsize) + } else { + boxsize <- NULL + } + groups <- attr(x, "groups") |> dplyr::select(-.rows & where(\(col) length(unique(col)) > 1)) |> colnames() @@ -164,6 +175,7 @@ forestplot.grouped_df <- function(x, labeltext, mean, lower, upper, legend, is.s upper = estimates$upper, legend = legend, is.summary = is.summary, + boxsize = boxsize, ... ) } diff --git a/R/forestplot_helpers.R b/R/forestplot_helpers.R index a6fef72..01f0f6b 100644 --- a/R/forestplot_helpers.R +++ b/R/forestplot_helpers.R @@ -36,7 +36,7 @@ #' any other line type than 1 since there is a risk of a dash occurring #' at the very end, i.e. showing incorrectly narrow confidence interval. #' @param vertices.height The height hoft the vertices. Defaults to npc units -#' corresponding to 10\% of the row height. +#' corresponding to 10% of the row height. #' @param ... Allows additional parameters for sibling functions #' @return \code{void} The function outputs the line using grid compatible #' functions and does not return anything. @@ -554,13 +554,7 @@ fpDrawBarCI <- function(lower_limit, estimate, upper_limit, size, col, y.offset #' @param text The color of the text #' @param axes The color of the x-axis at the bottom #' @param hrz_lines The color of the horizontal lines -#' @return list A list with the elements: -#' \item{box}{the color of the box/marker} -#' \item{lines}{the color of the lines} -#' \item{summary}{the color of the summary} -#' \item{zero}{the color of the zero vertical line} -#' \item{text}{the color of the text} -#' \item{axes}{the color of the axes} +#' @return A list with key elements #' #' @author Max Gordon, Thomas Lumley #' @importFrom grDevices colorRampPalette @@ -633,66 +627,73 @@ fpColors <- function(all.elements, )) } -#' A function for graphical parameters of the shapes used in forestplot() +#' A function for graphical parameters of the shapes used in `forestplot()` #' #' This function encapsulates all the non-text elements that are used in the -#' \code{\link{forestplot}} function. As there are plenty of shapes +#' [`forestplot()`] function. As there are plenty of shapes #' options this function gathers them all in one place. #' -#' This function obsoletes \code{\link{fpColors}}. +#' This function obsoletes [`fpColors()`]. #' #' If some, but not all parameters of a shape (e.g. box) are specified in gpar() #' such as setting lwd but not line color, the unspecified parameters default -#' to the ones specified in \code{default}, then, default to legacy parameters -#' of \code{forestplot} such as \code{col}. +#' to the ones specified in `default`, then, default to legacy parameters +#' of `forestplot` such as `col`. #' -#' Parameters \code{box}, \code{lines}, \code{vertices}, \code{summary} may be set as list +#' Parameters `box`, `lines`, `vertices`, `summary` may be set as list #' containing several gpars. The length of the list must either be equal to the number of bands #' per label or to the number of bands multiplied by the number of labels, allowing specification #' of different styles for different parts of the forest plot. #' -#' The parameter \code{grid} can either be a single gpar or a list of gpars with as many -#' elements as there are lines in the grid (as set by the \code{xticks} or \code{grid} +#' The parameter `grid` can either be a single gpar or a list of gpars with as many +#' elements as there are lines in the grid (as set by the `xticks` or `grid` #' arguments of forestplot) #' -#' Parameters \code{zero}, \code{axes}, \code{hrz_lines} must either be NULL or gpar +#' Parameters `zero`, `axes`, `hrz_lines` must either be NULL or gpar #' but cannot be lists of gpars. #' -#' @param default A fallback \code{\link[grid]{gpar}} for all unspecified attributes. +#' @param default A fallback [grid::gpar] for all unspecified attributes. #' If set to NULL then it defaults to legacy parameters, including -#' the \code{col}, \code{lwd.xaxis}, \code{lwd.ci} and \code{lty.ci} -#' parameter of \code{fpColors}. -#' @param box The graphical parameters (\code{gpar}) of the box, circle +#' the `col`, `lwd.xaxis`, `lwd.ci` and `lty.ci` +#' parameter of `fpColors`. +#' @param box The graphical parameters (`gpar`, `character`) of the box, circle #' or point indicating the point estimate, i.e. the middle -#' of the confidence interval (may be a list of gpars) -#' @param lines The graphical parameters (\code{gpar}) of the confidence lines -#' (may be a list of gpars) -#' @param vertices The graphical parameters (\code{gpar}) of the vertices +#' of the confidence interval (may be a list of gpars). If provided +#' a string a `gpar` will be generated with `col`, and `fill` for +#' those arguments. +#' @param lines The graphical parameters (`gpar`, `character`) of the confidence lines +#' (may be a list of gpars). If provided a string a `gpar` will be generated +#' with `col` as the only arguments. +#' @param vertices The graphical parameters (`gpar`, `character`) of the vertices #' (may be a list of gpars). -#' If \code{ci.vertices} is set to TRUE in \code{forestplot} -#' \code{vertices} inherits from \code{lines} all its parameters but lty that is set +#' If `ci.vertices` is set to TRUE in `forestplot` +#' `vertices` inherits from `lines` all its parameters but lty that is set #' to "solid" by default. -#' @param summary The graphical parameters (\code{gpar}) of the summary -#' (may be a list of gpars) -#' @param zero The graphical parameters (\code{gpar}) of the zero line -#' (may not be a list of gpars) -#' @param axes The graphical parameters (\code{gpar}) of the x-axis at the bottom -#' (may not be a list of gpars) -#' @param hrz_lines The graphical parameters (\code{gpar}) of the horizontal lines -#' (may not be a list of gpars) -#' @param grid The graphical parameters (\code{gpar}) of the grid (vertical lines) -#' (may be a list of gpars) +#' @param summary The graphical parameters (`gpar`, `character`) of the summary +#' (may be a list of gpars). If provided a string a `gpar` will be generated with +#' `col`, and `fill` for those arguments. +#' @param zero The graphical parameters (`gpar`) of the zero line +#' (may not be a list of gpars). If provided a string a `gpar` will be generated +#' with `col` as the only arguments. +#' @param axes The graphical parameters (`gpar`) of the x-axis at the bottom +#' (may not be a list of gpars). +#' @param hrz_lines The graphical parameters (`gpar`) of the horizontal lines +#' (may not be a list of gpars). If provided a string a `gpar` will be generated +#' with `col` as the only arguments. +#' @param grid The graphical parameters (`gpar`) of the grid (vertical lines) +#' (may be a list of gpars). If provided a string a `gpar` will be generated +#' with `col` as the only arguments. #' #' @return list A list with the elements: -#' \item{default}{the gpar for default attributes} -#' \item{box}{the gpar or list of gpars of the box/marker} -#' \item{lines}{the gpar or list of gpars of the lines} -#' \item{vertices}{the gpar or list of gpars of the vertices} -#' \item{summary}{the gpar or list of gpars of the summary} -#' \item{zero}{the gpar of the zero vertical line} -#' \item{axes}{the gpar of the x-axis} -#' \item{hrz_lines}{the gpar of the horizontal lines} -#' \item{grid}{the gpar or list of gpars of the grid lines} +#' * default: the gpar for default attributes +#' * box: the gpar or list of gpars of the box/marker +#' * lines: the gpar or list of gpars of the lines +#' * vertices: the gpar or list of gpars of the vertices +#' * summary: the gpar or list of gpars of the summary +#' * zero: the gpar of the zero vertical line +#' * axes: the gpar of the x-axis +#' * hrz_lines: the gpar of the horizontal lines +#' * grid: the gpar or list of gpars of the grid lines #' #' @author Andre GILLIBERT #' @importFrom grid gpar @@ -722,6 +723,24 @@ fpShapesGp <- function(default = NULL, grid = grid ) + for (clr_grp in c("box", "summary", "lines", "zero", "hrz_lines", "grid", "vertices")) { + gpar_generator <- \(clr) gpar(col = clr) + if (clr_grp %in% c("box", "summary")) { + gpar_generator <- \(clr) gpar(col = clr, fill = clr) + } + + if (is.character(ret[[clr_grp]])) { + ret[[clr_grp]] <- sapply(ret[[clr_grp]], + FUN = gpar_generator, + USE.NAMES = TRUE, + simplify = FALSE) + + if (length(ret[[clr_grp]]) == 1) { + ret[[clr_grp]] <- ret[[clr_grp]][[1]] + } + } + } + # check that objects have the correct type for (nm in names(ret)) { obj <- ret[[nm]] diff --git a/R/fp_insert_row.R b/R/fp_insert_row.R index 963b6cf..d83ae2b 100644 --- a/R/fp_insert_row.R +++ b/R/fp_insert_row.R @@ -12,6 +12,7 @@ #' @param upper A vector or matrix with the upper confidence interval #' @param position The row position to input at. Either a row number or "last". #' @param is.summary Whether the row is a summary. +#' @param boxsize The box size for the drawn estimate line #' #' @return The foresplot object with the added rows #' @export @@ -23,7 +24,8 @@ fp_insert_row <- function(x, ..., mean = NULL, lower = NULL, upper = NULL, position = 1, - is.summary = FALSE){ + is.summary = FALSE, + boxsize = NA){ args <- list(...) labels <- sapply(args, FUN = function(var) { @@ -31,7 +33,7 @@ fp_insert_row <- function(x, return(var) } - if (is.expression(var)) { + if (is.expression(var) || is.character(var)) { return(lapply(1:length(var), \(i) var[i])) } @@ -43,7 +45,8 @@ fp_insert_row <- function(x, lower = lower, upper = upper, label_length = length(labels[[1]]), - xlog = x$xlog) + xlog = x$xlog, + depth = dim(x$estimates)[3]) stopifnot(all(nrow(estimates) == sapply(labels, length))) if (position == "last") { @@ -109,6 +112,18 @@ fp_insert_row <- function(x, x$is.summary[position:length(x$is.summary)]) } + if (!is.null(x$boxsize)) { + boxsize <- rep(boxsize, length.out = nrow(estimates)) + if (position == "last") { + x$boxsize <- c(x$boxsize, boxsize) + } else { + x$boxsize <- c(x$boxsize[0:(position - 1)], + boxsize, + x$boxsize[position:length(x$boxsize)]) + } + } + + return(x) } @@ -124,10 +139,10 @@ fp_append_row <- function(x, ..., position = "last", is.summary = FALSE) { fp_insert_row(x, ..., position = position, is.summary = is.summary) } -pr_convert_insert_estimates <- function(mean, lower, upper, label_length, xlog) { +pr_convert_insert_estimates <- function(mean, lower, upper, label_length, xlog, depth) { stopifnot(is.null(lower) == is.null(upper)) if (is.null(mean)) { - return(array(NA, dim = c(label_length,3,1), dimnames = list(NULL, c("mean", "lower", "upper"), NULL))) + return(array(NA, dim = c(label_length, 3, depth), dimnames = list(NULL, c("mean", "lower", "upper"), NULL))) } if (is.null(lower)) { @@ -156,6 +171,9 @@ pr_convert_insert_estimates <- function(mean, lower, upper, label_length, xlog) } estimates <- abind::abind(mean, lower, upper, along = 2, new.names = list(NULL, c("mean", "lower", "upper"), NULL)) + if (depth != dim(estimates)[3]) { + stop("Expected the dimension of the estimates to be of ", depth, " and not ", dim(estimates)[3]) + } if (xlog) { estimates <- log(estimates) } diff --git a/R/fp_set_style.R b/R/fp_set_style.R new file mode 100644 index 0000000..d546201 --- /dev/null +++ b/R/fp_set_style.R @@ -0,0 +1,47 @@ +#' Set the style of the graph +#' +#' Sets the output style associated with the `foresplot` +#' +#' @inheritParams fp_insert_row +#' @inheritParams fpShapesGp +#' @param txt_gp Set the fonts etc for all text elements. See [`fpTxtGp()`] +#' for details +#' +#' @return The foresplot object with the styles +#' @export +#' +#' @example inst/examples/fp_set_style_example.R +#' @rdname style_manipulation +fp_set_style <- function(x, + default = NULL, + box = NULL, + lines = NULL, + vertices = NULL, + summary = NULL, + zero = NULL, + axes = NULL, + hrz_lines = NULL, + grid = NULL, + txt_gp = NULL) { + new_gp <- fpShapesGp(default = default, + box = box, + lines = lines, + vertices = vertices, + summary = summary, + zero = zero, + axes = axes, + hrz_lines = hrz_lines, + grid = grid) + for (n in names(x$shapes_gp)) { + if (!is.null(new_gp[[n]])) { + x$shapes_gp[[n]] <- new_gp[[n]] + } + } + + if (!is.null(txt_gp)) { + x$txt_gp <- txt_gp + } + + return(x) +} + diff --git a/R/private_prGetLabelsList.R b/R/private_prGetLabelsList.R index 0969c7a..d03d629 100644 --- a/R/private_prGetLabelsList.R +++ b/R/private_prGetLabelsList.R @@ -72,6 +72,10 @@ prGetLabelsList <- function(labels, # The row part for (i in 1:attr(labels, "no_rows")) { txt_out <- labels[i, j] + txt_align <- attr(txt_out, "align") + if (is.null(txt_align)) { + txt_align <- align[j] + } # If it's a call created by bquote or similar it # needs evaluating @@ -80,28 +84,27 @@ prGetLabelsList <- function(labels, } if (is.expression(txt_out) || is.character(txt_out) || is.numeric(txt_out) || is.factor(txt_out)) { - x <- switch(align[j], + x <- switch(txt_align, l = 0, r = 1, - c = 0.5 - ) + c = 0.5) - just <- switch(align[j], + just <- switch(txt_align, l = "left", r = "right", - c = "center" - ) + c = "center") # Bold the text if this is a summary if (is.summary[i]) { - x <- switch(align[j], + x <- switch(txt_align, l = 0, r = 1, - c = 0.5 - ) + c = 0.5) gp_list <- txt_gp$summary[[sum(is.summary[1:i])]][[j]] gp_list[["col"]] <- rep(col$text, length = attr(labels, "no_rows"))[i] + gp_list <- merge_with_txt_gp(gp_list = gp_list, + txt_out = txt_out) # Create a textGrob for the summary # The row/column order is in this order @@ -118,6 +121,8 @@ prGetLabelsList <- function(labels, if (is.null(gp_list$col)) { gp_list[["col"]] <- rep(col$text, length = attr(labels, "no_rows"))[i] } + gp_list <- merge_with_txt_gp(gp_list = gp_list, + txt_out = txt_out) # Create a textGrob with the current row-cell for the label fixed_labels[[j]][[i]] <- diff --git a/R/text_styling.R b/R/text_styling.R new file mode 100644 index 0000000..05d54b0 --- /dev/null +++ b/R/text_styling.R @@ -0,0 +1,102 @@ +#' Text styling +#' +#' This is a collection of functions to allow styling of text +#' +#' @param txt The text to styl +#' @returns A list of txt with style attributes +#' +#' @examples +#' fp_txt_italic("Italic text") +#' @export +#' @rdname text_styling +fp_txt_italic <- function(txt) { + sapply(txt, \(str) { + txt_gp <- attr(str, "txt_gp") + if (is.null(txt_gp)) { + txt_gp <- gpar() + } + txt_gp$fontface <- "italic" + attr(str, "txt_gp") <- txt_gp + return(str) + }, + simplify = FALSE, + USE.NAMES = FALSE) +} + +#' @export +#' @rdname text_styling +fp_txt_bold <- function(txt) { + sapply(txt, \(str) { + txt_gp <- attr(str, "txt_gp") + if (is.null(txt_gp)) { + txt_gp <- gpar() + } + txt_gp$fontface <- "bold" + attr(str, "txt_gp") <- txt_gp + return(str) + }, + simplify = FALSE, + USE.NAMES = FALSE) +} + +#' @export +#' @rdname text_styling +fp_txt_plain <- function(txt) { + sapply(txt, \(str) { + txt_gp <- attr(str, "txt_gp") + if (is.null(txt_gp)) { + txt_gp <- gpar() + } + txt_gp$fontface <- "plain" + attr(str, "txt_gp") <- txt_gp + return(str) + }, + simplify = FALSE, + USE.NAMES = FALSE) +} + +#' @export +#' @rdname text_styling +fp_align_left <- function(txt) { + sapply(txt, \(str) { + attr(str, "align") <- "l" + return(str) + }, + simplify = FALSE, + USE.NAMES = FALSE) +} + +#' @export +#' @rdname text_styling +fp_align_center <- function(txt) { + sapply(txt, \(str) { + attr(str, "align") <- "c" + return(str) + }, + simplify = FALSE, + USE.NAMES = FALSE) +} + +#' @export +#' @rdname text_styling +fp_align_right <- function(txt) { + sapply(txt, \(str) { + attr(str, "align") <- "r" + return(str) + }, + simplify = FALSE, + USE.NAMES = FALSE) +} + +merge_with_txt_gp <- function(gp_list, txt_out) { + txt_gp <- attr(txt_out, "txt_gp") + if (is.null(txt_gp)) { + return(gp_list) + } + + for (n in names(txt_gp)) { + gp_list[[n]] <- txt_gp[[n]] + } + + return(gp_list) +} diff --git a/inst/examples/forestplot_example.R b/inst/examples/forestplot_example.R index 651fd4a..74b33db 100644 --- a/inst/examples/forestplot_example.R +++ b/inst/examples/forestplot_example.R @@ -19,7 +19,9 @@ test_data |> zero = 1, cex = 2, lineheight = "auto", - xlab = "Lab axis txt") + xlab = "Lab axis txt") |> + fp_add_header("Group") |> + fp_set_style(lines = gpar(col = "darkblue")) # Print two plots side by side using the grid # package's layout option for viewports @@ -93,11 +95,6 @@ out_data |> gp = gpar(col = "steelblue", lty = 2) ), boxsize = 0.25, - col = fpColors( - box = c("royalblue", "gold"), - line = c("darkblue", "orange"), - summary = c("darkblue", "red") - ), xlab = "The estimates", new_page = TRUE, legend = c("Treatment", "Placebo"), @@ -106,51 +103,46 @@ out_data |> title = "Group", r = unit(.1, "snpc"), gp = gpar(col = "#CCCCCC", lwd = 1.5) - )) + )) |> + fp_set_style(box = c("royalblue", "gold"), + line = c("darkblue", "orange"), + summary = c("darkblue", "red")) # An example of how the exponential works -test_data <- data.frame(coef = c(2.45, 0.43), - low = c(1.5, 0.25), - high = c(4, 0.75), - boxsize = c(0.25, 0.25)) -row_names <- cbind( - c("Name", "Variable A", "Variable B"), - c("HR", test_data$coef) -) -test_data <- rbind(rep(NA, ncol(test_data)), test_data) - -forestplot( - labeltext = row_names, - test_data[, c("coef", "low", "high")], - is.summary = c(TRUE, FALSE, FALSE), - boxsize = test_data$boxsize, - zero = 1, - xlog = TRUE, - col = fpColors(lines = "red", box = "darkred") -) +data.frame(coef = c(2.45, 0.43), + low = c(1.5, 0.25), + high = c(4, 0.75), + boxsize = c(0.25, 0.25), + variables = c("Variable A", "Variable B")) |> + forestplot(labeltext = c(variables, coef), + mean = coef, + lower = low, + upper = high, + boxsize = boxsize, + zero = 1, + xlog = TRUE) |> + fp_set_style(lines = "red", box = "darkred") |> + fp_add_header(coef = "HR" |> fp_txt_plain() |> fp_align_center(), + variables = "Measurements") -# An example using shapes_gp -forestplot( - labeltext = cbind(Author = c("Smith et al", "Smooth et al", "Al et al")), - mean = cbind(1:3, 1.5:3.5), - lower = cbind(0:2, 0.5:2.5), - upper = cbind(4:6, 5.5:7.5), - is.summary = c(FALSE, FALSE, TRUE), - shapes_gp = fpShapesGp( - default = gpar(lineend = "square", linejoin = "mitre", lwd = 3, col = "pink"), - box = gpar(fill = "black", col = "red"), # only one parameter - lines = list( # as many parameters as CI - gpar(lwd = 10), gpar(lwd = 5), - gpar(), gpar(), - gpar(lwd = 2), gpar(lwd = 1) - ), - summary = list( # as many parameters as band per label - gpar(fill = "violet", col = "gray", lwd = 10), - gpar(fill = "orange", col = "gray", lwd = 10) - ) - ), - vertices = TRUE -) +# An example using style +forestplot(labeltext = cbind(Author = c("Smith et al", "Smooth et al", "Al et al")), + mean = cbind(1:3, 1.5:3.5), + lower = cbind(0:2, 0.5:2.5), + upper = cbind(4:6, 5.5:7.5), + is.summary = c(FALSE, FALSE, TRUE), + vertices = TRUE) |> + fp_set_style(default = gpar(lineend = "square", linejoin = "mitre", lwd = 3, col = "pink"), + box = gpar(fill = "black", col = "red"), # only one parameter + lines = list( # as many parameters as CI + gpar(lwd = 10), gpar(lwd = 5), + gpar(), gpar(), + gpar(lwd = 2), gpar(lwd = 1) + ), + summary = list( # as many parameters as band per label + gpar(fill = "violet", col = "gray", lwd = 10), + gpar(fill = "orange", col = "gray", lwd = 10) + )) par(ask = ask) # See vignette for a more detailed description diff --git a/inst/examples/fp_insert_row_example.R b/inst/examples/fp_insert_row_example.R index 577650f..1579bcc 100644 --- a/inst/examples/fp_insert_row_example.R +++ b/inst/examples/fp_insert_row_example.R @@ -10,10 +10,7 @@ base_data <- tibble::tibble(mean = c(0.578, 0.165, 0.246, 0.700, 0.348, 0.139, base_data |> forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), clip = c(0.1, 2.5), - xlog = TRUE, - col = fpColors(box = "royalblue", - line = "darkblue", - summary = "royalblue")) |> + xlog = TRUE) |> fp_add_header(study = c("", "Study"), deaths_steroid = c("Deaths", "(steroid)"), deaths_placebo = c("Deaths", "(placebo)"), diff --git a/inst/examples/fp_set_style_example.R b/inst/examples/fp_set_style_example.R new file mode 100644 index 0000000..bf008b0 --- /dev/null +++ b/inst/examples/fp_set_style_example.R @@ -0,0 +1,21 @@ +base_data <- tibble::tibble(mean = c(0.578, 0.165, 0.246, 0.700, 0.348, 0.139, 1.017), + lower = c(0.372, 0.018, 0.072, 0.333, 0.083, 0.016, 0.365), + upper = c(0.898, 1.517, 0.833, 1.474, 1.455, 1.209, 2.831), + study = c("Auckland", "Block", "Doran", "Gamsu", + "Morrison", "Papageorgiou", "Tauesch"), + deaths_steroid = c("36", "1", "4", "14", "3", "1", "8"), + deaths_placebo = c("60", "5", "11", "20", "7", "7", "10"), + OR = c("0.58", "0.16", "0.25", "0.70", "0.35", "0.14", "1.02")) + +base_data |> + forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), + clip = c(0.1, 2.5), + xlog = TRUE) |> + fp_add_header(study = c("", "Study"), + deaths_steroid = c("Deaths", "(steroid)"), + deaths_placebo = c("Deaths", "(placebo)"), + OR = c("", "OR")) |> + fp_set_style(box = "royalblue", + line = "darkblue", + summary = gpar(fill = "royalblue", clr = "black"), + txt_gp = fpTxtGp(label = gpar(fontfamily = "mono"))) diff --git a/man/assertAndRetrieveTidyValue.Rd b/man/assertAndRetrieveTidyValue.Rd index 4fd3507..899ae18 100644 --- a/man/assertAndRetrieveTidyValue.Rd +++ b/man/assertAndRetrieveTidyValue.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/assertAndRetrieveTidyValue.R \name{assertAndRetrieveTidyValue} \alias{assertAndRetrieveTidyValue} -\title{Retriever of `tidyselect`} +\title{Retriever of \code{tidyselect}} \usage{ assertAndRetrieveTidyValue( x, @@ -24,6 +24,6 @@ assertAndRetrieveTidyValue( value with attribute } \description{ -As forestpot has evolved we now primarily use `tidyverse` select style. This +As forestpot has evolved we now primarily use \code{tidyverse} select style. This function helps with backward compatibility } diff --git a/man/forestplot-package.Rd b/man/forestplot-package.Rd index 602f277..786e4db 100644 --- a/man/forestplot-package.Rd +++ b/man/forestplot-package.Rd @@ -5,7 +5,7 @@ \alias{forestplot-package} \title{Package description} \description{ -The forest plot function, \code{\link{forestplot}}, is a more general +The forest plot function, \code{\link[=forestplot]{forestplot()}}, is a more general version of the original \pkg{rmeta}-packages \code{forestplot} implementation. The aim is at using forest plots for more than just meta-analyses. @@ -13,15 +13,15 @@ just meta-analyses. \details{ The forestplot: \enumerate{ - \item Allows for multiple confidence intervals per row - \item Custom fonts for each text element - \item Custom confidence intervals - \item Text mixed with expressions - \item Legends both on top/left of the plot and within the graph - \item Custom line height including auto-adapt height - \item Graph width that auto-adapts - \item Flexible arguments - \item and more +\item Allows for multiple confidence intervals per row +\item Custom fonts for each text element +\item Custom confidence intervals +\item Text mixed with expressions +\item Legends both on top/left of the plot and within the graph +\item Custom line height including auto-adapt height +\item Graph width that auto-adapts +\item Flexible arguments +\item and more } } \section{Additional functions}{ diff --git a/man/forestplot.Rd b/man/forestplot.Rd index 3a16afd..b3b98ab 100644 --- a/man/forestplot.Rd +++ b/man/forestplot.Rd @@ -12,7 +12,7 @@ \usage{ forestplot(...) -\method{forestplot}{data.frame}(x, mean, lower, upper, labeltext, is.summary, ...) +\method{forestplot}{data.frame}(x, mean, lower, upper, labeltext, is.summary, boxsize, ...) \method{forestplot}{default}( labeltext, @@ -59,15 +59,15 @@ forestplot(...) \method{plot}{gforge_forestplot}(x, y, ..., new_page = FALSE) -\method{forestplot}{grouped_df}(x, labeltext, mean, lower, upper, legend, is.summary, ...) +\method{forestplot}{grouped_df}(x, labeltext, mean, lower, upper, legend, is.summary, boxsize, ...) } \arguments{ \item{...}{Passed on to the \code{fn.ci_norm} and \code{fn.ci_sum} arguments} -\item{x}{The `gforge_forestplot` object to be printed} +\item{x}{The \code{gforge_forestplot} object to be printed} -\item{mean}{The name of the column if using the *dplyr* select syntax - defaults to "mean", +\item{mean}{The name of the column if using the \emph{dplyr} select syntax - defaults to "mean", else it should be a vector or a matrix with the averages. You can also provide a 2D/3D matrix that is automatically converted to the lower/upper parameters. The values should be in exponentiated form if they follow this interpretation, e.g. use @@ -80,8 +80,8 @@ to be the same format as the mean.} to be the same format as the mean.} \item{labeltext}{A list, matrix, vector or expression with the names of each -row or the name of the column if using the *dplyr* select syntax - defaults to "labeltext". -Note that when using `group_by` a separate labeltext is not allowed. +row or the name of the column if using the \emph{dplyr} select syntax - defaults to "labeltext". +Note that when using \code{group_by} a separate labeltext is not allowed. The list should be wrapped in m x n number to resemble a matrix: \code{list(list("rowname 1 col 1", "rowname 2 col 1"), list("r1c2", expression(beta))}. You can also provide a matrix although this cannot have expressions by design: @@ -96,6 +96,8 @@ mean, lower, and upper.} the value is a summary value which means that it will have a different font-style} +\item{boxsize}{Override the default box size based on precision} + \item{align}{Vector giving alignment (l,r,c) for the table columns} \item{graph.pos}{The position of the graph element within the table of text. The @@ -126,7 +128,7 @@ instance if you have several forestplots you may want to standardize their line height, then you set this variable to a certain height, note this should be provided as a \code{\link[grid]{unit}} object. A good option is to set the line height to \code{unit(2, "cm")}. A third option -is to set line height to "lines" and then you get 50 \% more than what the +is to set line height to "lines" and then you get 50\% more than what the text height is as your line height} \item{line.margin}{Set the margin between rows, provided in numeric or \code{\link[grid]{unit}} form. @@ -180,8 +182,6 @@ at the very end, i.e. showing incorrectly narrow confidence interval.} corresponding to 10\% of the row height. \emph{Note that the arrows correspond to the vertices heights.}} -\item{boxsize}{Override the default box size based on precision} - \item{mar}{A numerical vector of the form \code{c(bottom, left, top, right)} of the type \code{\link[grid]{unit}}} @@ -218,17 +218,17 @@ of all shapes drawn (squares, lines, diamonds, etc.). This overrides \code{col}, \code{NULL} } \description{ -The \emph{forestplot} is based on the \pkg{rmeta}-package`s -\code{forestplot} function. This -function resolves some limitations of the original +The \strong{forestplot} is based on the \pkg{rmeta}-package\code{s }forestplot()` function. This function resolves some limitations of the original functions such as: -\itemize{ - \item{Adding expressions: }{Allows use of expressions, e.g. \code{expression(beta)}} - \item{Multiple bands: }{Using multiple confidence bands for the same label} - \item{Autosize: }{Adapts to viewport (graph) size} -} } \details{ +\itemize{ +\item Adding expressions: Allows use of expressions, e.g. \code{expression(beta)} +\item Multiple bands: Using multiple confidence bands for the same label +\item Autosize: Adapts to viewport (graph) size +\item Convenient dplyr syntax +} + See \code{vignette("forestplot")} for details. } \section{Multiple bands}{ @@ -246,19 +246,17 @@ crude and adjusted estimates as separate bands. The argument \code{hrzl_lines} can be either \code{TRUE} or a \code{list} with \code{\link[grid]{gpar}} elements: - \itemize{ - \item{\code{TRUE}}{A line will be added based upon the \code{is.summary} rows. If the first line is a summary it} - \item{\code{\link[grid]{gpar}}}{The same as above but the lines will be formatted according to the - \code{\link[grid]{gpar}} element} - \item{\code{list}}{The list must either be numbered, i.e. \code{list("2" = gpar(lty = 1))}, or have the same length - as the \code{NROW(mean) + 1}. If the list is numbered the numbers should not exceed the \code{NROW(mean) + 1}. - The no. \emph{1 row designates the top}, i.e. the line above the first row, all other correspond to - \emph{the row below}. Each element in the list needs to be \code{TRUE}, \code{NULL}, or - \code{\link[grid]{gpar}} element. The \code{TRUE} defaults to a standard line, the \code{NULL} - skips a line, while \code{\link[grid]{gpar}} corresponds to the fully customized line. Apart from - allowing standard \code{\link[grid]{gpar}} line descriptions, \code{lty}, \code{lwd}, \code{col}, and more - you can also specify \code{gpar(columns = c(1:3, 5))} if you for instance want the line to skip a column.} +\item \code{TRUE}: A line will be added based upon the \code{is.summary} rows. If the first line is a summary it +\item \link[grid:gpar]{grid::gpar}: The same as above but the lines will be formatted according to the \link[grid:gpar]{grid::gpar} element +\item \code{list}: The list must either be numbered, i.e. \code{list("2" = gpar(lty = 1))}, or have the same length +as the \code{NROW(mean) + 1}. If the list is numbered the numbers should not exceed the \code{NROW(mean) + 1}. +The no. \emph{1 row designates the top}, i.e. the line above the first row, all other correspond to +\emph{the row below}. Each element in the list needs to be \code{TRUE}, \code{NULL}, or +\code{\link[grid]{gpar}} element. The \code{TRUE} defaults to a standard line, the \code{NULL} +skips a line, while \code{\link[grid]{gpar}} corresponds to the fully customized line. Apart from +allowing standard \code{\link[grid]{gpar}} line descriptions, \code{lty}, \code{lwd}, \code{col}, and more +you can also specify \code{gpar(columns = c(1:3, 5))} if you for instance want the line to skip a column. } } @@ -272,8 +270,8 @@ always the best option, try to set these manually as much as possible. \section{API-changes from \pkg{rmeta}-package`s \code{forestplot}}{ \itemize{ - \item{xlog: }{The xlog outputs the axis in log() format but the input data should be in antilog/exp format} - \item{col: }{The corresponding function is \code{\link{fpColors}} for this package} +\item xlog: The xlog outputs the axis in log() format but the input data should be in antilog/exp format +\item col: The corresponding function is \code{\link{fpColors}} for this package } } @@ -299,7 +297,9 @@ test_data |> zero = 1, cex = 2, lineheight = "auto", - xlab = "Lab axis txt") + xlab = "Lab axis txt") |> + fp_add_header("Group") |> + fp_set_style(lines = gpar(col = "darkblue")) # Print two plots side by side using the grid # package's layout option for viewports @@ -373,11 +373,6 @@ out_data |> gp = gpar(col = "steelblue", lty = 2) ), boxsize = 0.25, - col = fpColors( - box = c("royalblue", "gold"), - line = c("darkblue", "orange"), - summary = c("darkblue", "red") - ), xlab = "The estimates", new_page = TRUE, legend = c("Treatment", "Placebo"), @@ -386,51 +381,46 @@ out_data |> title = "Group", r = unit(.1, "snpc"), gp = gpar(col = "#CCCCCC", lwd = 1.5) - )) + )) |> + fp_set_style(box = c("royalblue", "gold"), + line = c("darkblue", "orange"), + summary = c("darkblue", "red")) # An example of how the exponential works -test_data <- data.frame(coef = c(2.45, 0.43), - low = c(1.5, 0.25), - high = c(4, 0.75), - boxsize = c(0.25, 0.25)) -row_names <- cbind( - c("Name", "Variable A", "Variable B"), - c("HR", test_data$coef) -) -test_data <- rbind(rep(NA, ncol(test_data)), test_data) - -forestplot( - labeltext = row_names, - test_data[, c("coef", "low", "high")], - is.summary = c(TRUE, FALSE, FALSE), - boxsize = test_data$boxsize, - zero = 1, - xlog = TRUE, - col = fpColors(lines = "red", box = "darkred") -) - -# An example using shapes_gp -forestplot( - labeltext = cbind(Author = c("Smith et al", "Smooth et al", "Al et al")), - mean = cbind(1:3, 1.5:3.5), - lower = cbind(0:2, 0.5:2.5), - upper = cbind(4:6, 5.5:7.5), - is.summary = c(FALSE, FALSE, TRUE), - shapes_gp = fpShapesGp( - default = gpar(lineend = "square", linejoin = "mitre", lwd = 3, col = "pink"), - box = gpar(fill = "black", col = "red"), # only one parameter - lines = list( # as many parameters as CI - gpar(lwd = 10), gpar(lwd = 5), - gpar(), gpar(), - gpar(lwd = 2), gpar(lwd = 1) - ), - summary = list( # as many parameters as band per label - gpar(fill = "violet", col = "gray", lwd = 10), - gpar(fill = "orange", col = "gray", lwd = 10) - ) - ), - vertices = TRUE -) +data.frame(coef = c(2.45, 0.43), + low = c(1.5, 0.25), + high = c(4, 0.75), + boxsize = c(0.25, 0.25), + variables = c("Variable A", "Variable B")) |> + forestplot(labeltext = c(variables, coef), + mean = coef, + lower = low, + upper = high, + boxsize = boxsize, + zero = 1, + xlog = TRUE) |> + fp_set_style(lines = "red", box = "darkred") |> + fp_add_header(coef = "HR" |> fp_txt_plain() |> fp_align_center(), + variables = "Measurements") + +# An example using style +forestplot(labeltext = cbind(Author = c("Smith et al", "Smooth et al", "Al et al")), + mean = cbind(1:3, 1.5:3.5), + lower = cbind(0:2, 0.5:2.5), + upper = cbind(4:6, 5.5:7.5), + is.summary = c(FALSE, FALSE, TRUE), + vertices = TRUE) |> + fp_set_style(default = gpar(lineend = "square", linejoin = "mitre", lwd = 3, col = "pink"), + box = gpar(fill = "black", col = "red"), # only one parameter + lines = list( # as many parameters as CI + gpar(lwd = 10), gpar(lwd = 5), + gpar(), gpar(), + gpar(lwd = 2), gpar(lwd = 1) + ), + summary = list( # as many parameters as band per label + gpar(fill = "violet", col = "gray", lwd = 10), + gpar(fill = "orange", col = "gray", lwd = 10) + )) par(ask = ask) # See vignette for a more detailed description diff --git a/man/fpColors.Rd b/man/fpColors.Rd index 296fd99..dd998e6 100644 --- a/man/fpColors.Rd +++ b/man/fpColors.Rd @@ -34,13 +34,7 @@ it's set to the par("fg") color} \item{hrz_lines}{The color of the horizontal lines} } \value{ -list A list with the elements: -\item{box}{the color of the box/marker} -\item{lines}{the color of the lines} -\item{summary}{the color of the summary} -\item{zero}{the color of the zero vertical line} -\item{text}{the color of the text} -\item{axes}{the color of the axes} +A list with key elements } \description{ This function encapsulates all the colors that are used in the diff --git a/man/fpDrawCI.Rd b/man/fpDrawCI.Rd index 18b7fc5..bedda39 100644 --- a/man/fpDrawCI.Rd +++ b/man/fpDrawCI.Rd @@ -160,7 +160,7 @@ This is used together with shapes_gp to retrieve graphical parameters for that i } \value{ \code{void} The function outputs the line using grid compatible - functions and does not return anything. +functions and does not return anything. } \description{ A function that is used to draw the different diff --git a/man/fpShapesGp.Rd b/man/fpShapesGp.Rd index 76301c8..dbd1864 100644 --- a/man/fpShapesGp.Rd +++ b/man/fpShapesGp.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/forestplot_helpers.R \name{fpShapesGp} \alias{fpShapesGp} -\title{A function for graphical parameters of the shapes used in forestplot()} +\title{A function for graphical parameters of the shapes used in \code{forestplot()}} \usage{ fpShapesGp( default = NULL, @@ -17,58 +17,67 @@ fpShapesGp( ) } \arguments{ -\item{default}{A fallback \code{\link[grid]{gpar}} for all unspecified attributes. +\item{default}{A fallback \link[grid:gpar]{grid::gpar} for all unspecified attributes. If set to NULL then it defaults to legacy parameters, including the \code{col}, \code{lwd.xaxis}, \code{lwd.ci} and \code{lty.ci} parameter of \code{fpColors}.} -\item{box}{The graphical parameters (\code{gpar}) of the box, circle +\item{box}{The graphical parameters (\code{gpar}, \code{character}) of the box, circle or point indicating the point estimate, i.e. the middle -of the confidence interval (may be a list of gpars)} +of the confidence interval (may be a list of gpars). If provided +a string a \code{gpar} will be generated with \code{col}, and \code{fill} for +those arguments.} -\item{lines}{The graphical parameters (\code{gpar}) of the confidence lines -(may be a list of gpars)} +\item{lines}{The graphical parameters (\code{gpar}, \code{character}) of the confidence lines +(may be a list of gpars). If provided a string a \code{gpar} will be generated +with \code{col} as the only arguments.} -\item{vertices}{The graphical parameters (\code{gpar}) of the vertices +\item{vertices}{The graphical parameters (\code{gpar}, \code{character}) of the vertices (may be a list of gpars). If \code{ci.vertices} is set to TRUE in \code{forestplot} \code{vertices} inherits from \code{lines} all its parameters but lty that is set to "solid" by default.} -\item{summary}{The graphical parameters (\code{gpar}) of the summary -(may be a list of gpars)} +\item{summary}{The graphical parameters (\code{gpar}, \code{character}) of the summary +(may be a list of gpars). If provided a string a \code{gpar} will be generated with +\code{col}, and \code{fill} for those arguments.} \item{zero}{The graphical parameters (\code{gpar}) of the zero line -(may not be a list of gpars)} +(may not be a list of gpars). If provided a string a \code{gpar} will be generated +with \code{col} as the only arguments.} \item{axes}{The graphical parameters (\code{gpar}) of the x-axis at the bottom -(may not be a list of gpars)} +(may not be a list of gpars).} \item{hrz_lines}{The graphical parameters (\code{gpar}) of the horizontal lines -(may not be a list of gpars)} +(may not be a list of gpars). If provided a string a \code{gpar} will be generated +with \code{col} as the only arguments.} \item{grid}{The graphical parameters (\code{gpar}) of the grid (vertical lines) -(may be a list of gpars)} +(may be a list of gpars). If provided a string a \code{gpar} will be generated +with \code{col} as the only arguments.} } \value{ list A list with the elements: -\item{default}{the gpar for default attributes} -\item{box}{the gpar or list of gpars of the box/marker} -\item{lines}{the gpar or list of gpars of the lines} -\item{vertices}{the gpar or list of gpars of the vertices} -\item{summary}{the gpar or list of gpars of the summary} -\item{zero}{the gpar of the zero vertical line} -\item{axes}{the gpar of the x-axis} -\item{hrz_lines}{the gpar of the horizontal lines} -\item{grid}{the gpar or list of gpars of the grid lines} +\itemize{ +\item default: the gpar for default attributes +\item box: the gpar or list of gpars of the box/marker +\item lines: the gpar or list of gpars of the lines +\item vertices: the gpar or list of gpars of the vertices +\item summary: the gpar or list of gpars of the summary +\item zero: the gpar of the zero vertical line +\item axes: the gpar of the x-axis +\item hrz_lines: the gpar of the horizontal lines +\item grid: the gpar or list of gpars of the grid lines +} } \description{ This function encapsulates all the non-text elements that are used in the -\code{\link{forestplot}} function. As there are plenty of shapes +\code{\link[=forestplot]{forestplot()}} function. As there are plenty of shapes options this function gathers them all in one place. } \details{ -This function obsoletes \code{\link{fpColors}}. +This function obsoletes \code{\link[=fpColors]{fpColors()}}. If some, but not all parameters of a shape (e.g. box) are specified in gpar() such as setting lwd but not line color, the unspecified parameters default diff --git a/man/prDefaultGp.Rd b/man/prDefaultGp.Rd index e1cd329..be9d90c 100644 --- a/man/prDefaultGp.Rd +++ b/man/prDefaultGp.Rd @@ -15,7 +15,7 @@ prDefaultGp(col, lwd, lty) } \value{ a \code{\link[grid]{gpar}} object - containing these three attributes +containing these three attributes } \description{ Construct default parameters from arguments that may include missing arguments diff --git a/man/prFpFetchRowLabel.Rd b/man/prFpFetchRowLabel.Rd index ebe927b..ddef72c 100644 --- a/man/prFpFetchRowLabel.Rd +++ b/man/prFpFetchRowLabel.Rd @@ -10,8 +10,8 @@ prFpFetchRowLabel(label_type, labeltext, i, j) \item{label_type}{The type of label} \item{labeltext}{A list, matrix, vector or expression with the names of each -row or the name of the column if using the *dplyr* select syntax - defaults to "labeltext". -Note that when using `group_by` a separate labeltext is not allowed. +row or the name of the column if using the \emph{dplyr} select syntax - defaults to "labeltext". +Note that when using \code{group_by} a separate labeltext is not allowed. The list should be wrapped in m x n number to resemble a matrix: \code{list(list("rowname 1 col 1", "rowname 2 col 1"), list("r1c2", expression(beta))}. You can also provide a matrix although this cannot have expressions by design: diff --git a/man/prFpFindWidestGrob.Rd b/man/prFpFindWidestGrob.Rd index cebe12f..735b56c 100644 --- a/man/prFpFindWidestGrob.Rd +++ b/man/prFpFindWidestGrob.Rd @@ -13,7 +13,7 @@ prFpFindWidestGrob(grob.list, return_unit = "mm") } \value{ \code{grid::unit} Returns the width \code{\link[grid]{unit}} - for the widest grob +for the widest grob } \description{ Finds the widest grob in the current list of grobs diff --git a/man/prFpGetConfintFnList.Rd b/man/prFpGetConfintFnList.Rd index 2387aa2..f490a7f 100644 --- a/man/prFpGetConfintFnList.Rd +++ b/man/prFpGetConfintFnList.Rd @@ -8,7 +8,7 @@ prFpGetConfintFnList(fn, no_rows, no_depth, missing_rows, is.summary, summary) } \arguments{ \item{fn}{The function list/matrix. If a list it -should be in the format [[row]][[col]], the function +should be in the format [\link{row}][\link{col}], the function tries to handle this but in cases where the columns and rows are the same it will not know what is a column and what is a row.} @@ -25,7 +25,7 @@ font-style} } \value{ \code{list} The function returns a list that has -the format [[row]][[col]] where each element contains the +the format [\link{row}][\link{col}] where each element contains the function that you need to call using the \code{\link[base]{as.call}} and \code{\link[base]{eval}} functions: \code{eval(as.call(list(fn[[row]][[col]], arg_1 = 1, arg_2 = 2)))} } diff --git a/man/prFpGetLayoutVP.Rd b/man/prFpGetLayoutVP.Rd index bf91fef..d9e64a6 100644 --- a/man/prFpGetLayoutVP.Rd +++ b/man/prFpGetLayoutVP.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/private.R \name{prFpGetLayoutVP} \alias{prFpGetLayoutVP} -\title{Get the main `forestplot`} +\title{Get the main \code{forestplot}} \usage{ prFpGetLayoutVP(lineheight, labels, legend_layout = NULL) } @@ -14,7 +14,7 @@ instance if you have several forestplots you may want to standardize their line height, then you set this variable to a certain height, note this should be provided as a \code{\link[grid]{unit}} object. A good option is to set the line height to \code{unit(2, "cm")}. A third option -is to set line height to "lines" and then you get 50 \% more than what the +is to set line height to "lines" and then you get 50\% more than what the text height is as your line height} \item{labels}{The labels} @@ -22,7 +22,7 @@ text height is as your line height} \item{legend_layout}{A legend layout object if applicable} } \value{ -\code{viewport} Returns the `viewport` needed +\code{viewport} Returns the \code{viewport} needed } \description{ The layout makes space for a legend if needed diff --git a/man/prFpGetLegendBoxPosition.Rd b/man/prFpGetLegendBoxPosition.Rd index 52b406b..5be9ecf 100644 --- a/man/prFpGetLegendBoxPosition.Rd +++ b/man/prFpGetLegendBoxPosition.Rd @@ -20,7 +20,7 @@ you want them to be in a line then you can specify the "align" option, e.g. } \value{ \code{list} Returns the \code{pos} list with - the correct x/y/adjust values +the correct x/y/adjust values } \description{ Used for the forestplot legend box. diff --git a/man/prGetLabelsList.Rd b/man/prGetLabelsList.Rd index 6eb1e09..49d8455 100644 --- a/man/prGetLabelsList.Rd +++ b/man/prGetLabelsList.Rd @@ -7,7 +7,7 @@ prGetLabelsList(labels, align, is.summary, txt_gp, col) } \arguments{ -\item{labels}{A `forestplot_labeltext` object} +\item{labels}{A \code{forestplot_labeltext} object} \item{align}{Alignment, should be equal to \code{attr(labels, "no_cols")}} @@ -23,8 +23,8 @@ details} } \value{ \code{list} A list with \code{attr(labels, "no_cols")} where each element contains - a list of \code{attr(labels, "no_rows")} elements with attributes width/height for each - element and max_width/max_height for the total +a list of \code{attr(labels, "no_rows")} elements with attributes width/height for each +element and max_width/max_height for the total } \description{ A function that gets all the labels diff --git a/man/prPopulateList.Rd b/man/prPopulateList.Rd index 56d3138..58492f4 100644 --- a/man/prPopulateList.Rd +++ b/man/prPopulateList.Rd @@ -8,7 +8,7 @@ prPopulateList(elmnt, no_rows, no_depth, missing_rows, is.summary, summary) } \arguments{ \item{elmnt}{The element item/list/matrix. If a list it -should be in the format [[row]][[col]], the function +should be in the format [\link{row}][\link{col}], the function tries to handle this but in cases where the columns and rows are the same it will not know what is a column and what is a row.} @@ -25,8 +25,8 @@ font-style} } \value{ \code{list} The function returns a list that has - the format [[row]][[col]] where each element contains the - corresponding element +the format [\link{row}][\link{col}] where each element contains the +corresponding element } \description{ This function helps the \code{\link{forestplot}} diff --git a/man/prepAlign.Rd b/man/prepAlign.Rd index 66357f1..136f1e0 100644 --- a/man/prepAlign.Rd +++ b/man/prepAlign.Rd @@ -14,7 +14,7 @@ prepAlign(align, graph.pos, nc) \item{nc}{The number of columns} } \value{ -Returns vector of `"l", "c", "r"` values +Returns vector of \verb{"l", "c", "r"} values } \description{ Prepares the graph position so that it matches the label size diff --git a/man/prepGridMargins.Rd b/man/prepGridMargins.Rd index 0a506bc..7ac1fe8 100644 --- a/man/prepGridMargins.Rd +++ b/man/prepGridMargins.Rd @@ -8,13 +8,15 @@ prepGridMargins(mar) } \arguments{ \item{mar}{A vector of margins, at positions: -- 1 = bottom -- 2 = left -- 3 = top -- 4 = right} +\itemize{ +\item 1 = bottom +\item 2 = left +\item 3 = top +\item 4 = right +}} } \value{ -Returns a list with `bottom`, `left`, `top`, and `right` as `unit("npc")` +Returns a list with \code{bottom}, \code{left}, \code{top}, and \code{right} as \code{unit("npc")} } \description{ Convert margins to viewport npc margins diff --git a/man/prepLabelText.Rd b/man/prepLabelText.Rd index 4dfc4ec..8bec90f 100644 --- a/man/prepLabelText.Rd +++ b/man/prepLabelText.Rd @@ -10,12 +10,12 @@ prepLabelText(labeltext, nr) \method{[}{forestplot_labeltext}(x, i, j, ...) } \arguments{ -\item{labeltext}{The label text input, either `expression`, `list` -`vector` or `matrix`} +\item{labeltext}{The label text input, either \code{expression}, \code{list} +\code{vector} or \code{matrix}} \item{nr}{The number of rows} -\item{x}{A `forestplot_labeltext` object} +\item{x}{A \code{forestplot_labeltext} object} \item{i}{The row} @@ -25,11 +25,13 @@ prepLabelText(labeltext, nr) \code{fn.ci_sum} arguments} } \value{ -Returns a `forestplot_labeltext` object with attributes: - - no_cols - - no_rows - - widthcolumn - - label_type +Returns a \code{forestplot_labeltext} object with attributes: +\itemize{ +\item no_cols +\item no_rows +\item widthcolumn +\item label_type +} } \description{ Prepares an object that contains the number of columns and rows @@ -37,7 +39,7 @@ Prepares an object that contains the number of columns and rows \section{Functions}{ \itemize{ \item \code{[}: Pick the value that corresponds to the row and column. -Returns `expression`, `call`, or `text`. +Returns \code{expression}, \code{call}, or \code{text}. }} \keyword{internal} diff --git a/man/row_manipulation.Rd b/man/row_manipulation.Rd index f5122f2..8f82dc5 100644 --- a/man/row_manipulation.Rd +++ b/man/row_manipulation.Rd @@ -13,7 +13,8 @@ fp_insert_row( lower = NULL, upper = NULL, position = 1, - is.summary = FALSE + is.summary = FALSE, + boxsize = NA ) fp_add_header(x, ..., position = 1, is.summary = TRUE) @@ -35,6 +36,8 @@ names or unnamed arguments that will map in appearing order.} \item{position}{The row position to input at. Either a row number or "last".} \item{is.summary}{Whether the row is a summary.} + +\item{boxsize}{The box size for the drawn estimate line} } \value{ The foresplot object with the added rows @@ -57,10 +60,7 @@ base_data <- tibble::tibble(mean = c(0.578, 0.165, 0.246, 0.700, 0.348, 0.139, base_data |> forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), clip = c(0.1, 2.5), - xlog = TRUE, - col = fpColors(box = "royalblue", - line = "darkblue", - summary = "royalblue")) |> + xlog = TRUE) |> fp_add_header(study = c("", "Study"), deaths_steroid = c("Deaths", "(steroid)"), deaths_placebo = c("Deaths", "(placebo)"), diff --git a/man/style_manipulation.Rd b/man/style_manipulation.Rd new file mode 100644 index 0000000..d2306fc --- /dev/null +++ b/man/style_manipulation.Rd @@ -0,0 +1,95 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fp_set_style.R +\name{fp_set_style} +\alias{fp_set_style} +\title{Set the style of the graph} +\usage{ +fp_set_style( + x, + default = NULL, + box = NULL, + lines = NULL, + vertices = NULL, + summary = NULL, + zero = NULL, + axes = NULL, + hrz_lines = NULL, + grid = NULL, + txt_gp = NULL +) +} +\arguments{ +\item{x}{The forestplot object} + +\item{default}{A fallback \link[grid:gpar]{grid::gpar} for all unspecified attributes. +If set to NULL then it defaults to legacy parameters, including +the \code{col}, \code{lwd.xaxis}, \code{lwd.ci} and \code{lty.ci} +parameter of \code{fpColors}.} + +\item{box}{The graphical parameters (\code{gpar}, \code{character}) of the box, circle +or point indicating the point estimate, i.e. the middle +of the confidence interval (may be a list of gpars). If provided +a string a \code{gpar} will be generated with \code{col}, and \code{fill} for +those arguments.} + +\item{lines}{The graphical parameters (\code{gpar}, \code{character}) of the confidence lines +(may be a list of gpars). If provided a string a \code{gpar} will be generated +with \code{col} as the only arguments.} + +\item{vertices}{The graphical parameters (\code{gpar}, \code{character}) of the vertices +(may be a list of gpars). +If \code{ci.vertices} is set to TRUE in \code{forestplot} +\code{vertices} inherits from \code{lines} all its parameters but lty that is set +to "solid" by default.} + +\item{summary}{The graphical parameters (\code{gpar}, \code{character}) of the summary +(may be a list of gpars). If provided a string a \code{gpar} will be generated with +\code{col}, and \code{fill} for those arguments.} + +\item{zero}{The graphical parameters (\code{gpar}) of the zero line +(may not be a list of gpars). If provided a string a \code{gpar} will be generated +with \code{col} as the only arguments.} + +\item{axes}{The graphical parameters (\code{gpar}) of the x-axis at the bottom +(may not be a list of gpars).} + +\item{hrz_lines}{The graphical parameters (\code{gpar}) of the horizontal lines +(may not be a list of gpars). If provided a string a \code{gpar} will be generated +with \code{col} as the only arguments.} + +\item{grid}{The graphical parameters (\code{gpar}) of the grid (vertical lines) +(may be a list of gpars). If provided a string a \code{gpar} will be generated +with \code{col} as the only arguments.} + +\item{txt_gp}{Set the fonts etc for all text elements. See \code{\link[=fpTxtGp]{fpTxtGp()}} +for details} +} +\value{ +The foresplot object with the styles +} +\description{ +Sets the output style associated with the \code{foresplot} +} +\examples{ +base_data <- tibble::tibble(mean = c(0.578, 0.165, 0.246, 0.700, 0.348, 0.139, 1.017), + lower = c(0.372, 0.018, 0.072, 0.333, 0.083, 0.016, 0.365), + upper = c(0.898, 1.517, 0.833, 1.474, 1.455, 1.209, 2.831), + study = c("Auckland", "Block", "Doran", "Gamsu", + "Morrison", "Papageorgiou", "Tauesch"), + deaths_steroid = c("36", "1", "4", "14", "3", "1", "8"), + deaths_placebo = c("60", "5", "11", "20", "7", "7", "10"), + OR = c("0.58", "0.16", "0.25", "0.70", "0.35", "0.14", "1.02")) + +base_data |> + forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), + clip = c(0.1, 2.5), + xlog = TRUE) |> + fp_add_header(study = c("", "Study"), + deaths_steroid = c("Deaths", "(steroid)"), + deaths_placebo = c("Deaths", "(placebo)"), + OR = c("", "OR")) |> + fp_set_style(box = "royalblue", + line = "darkblue", + summary = gpar(fill = "royalblue", clr = "black"), + txt_gp = fpTxtGp(label = gpar(fontfamily = "mono"))) +} diff --git a/man/text_styling.Rd b/man/text_styling.Rd new file mode 100644 index 0000000..0dc9be9 --- /dev/null +++ b/man/text_styling.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/text_styling.R +\name{fp_txt_italic} +\alias{fp_txt_italic} +\alias{fp_txt_bold} +\alias{fp_txt_plain} +\alias{fp_align_left} +\alias{fp_align_center} +\alias{fp_align_right} +\title{Text styling} +\usage{ +fp_txt_italic(txt) + +fp_txt_bold(txt) + +fp_txt_plain(txt) + +fp_align_left(txt) + +fp_align_center(txt) + +fp_align_right(txt) +} +\arguments{ +\item{txt}{The text to styl} +} +\value{ +A list of txt with style attributes +} +\description{ +This is a collection of functions to allow styling of text +} +\examples{ +fp_txt_italic("Italic text") +} diff --git a/tests/testthat/test-forestplot.group_df.R b/tests/testthat/test-forestplot.group_df.R index f2e1fe0..5142e94 100644 --- a/tests/testthat/test-forestplot.group_df.R +++ b/tests/testthat/test-forestplot.group_df.R @@ -26,6 +26,31 @@ test_that("Basic", { }) +test_that("Basic add header", { + out <- HRQoL |> + sapply(\(x) data.frame(x) |> tibble::rownames_to_column(), + simplify = FALSE) |> + dplyr::bind_rows(.id = "Country") |> + dplyr::group_by(Country) |> + forestplot(mean = coef, + lower = lower, + upper = upper, + labeltext = rowname, + fn.ci_norm = c(fpDrawNormalCI, fpDrawCircleCI), + boxsize = .25, # We set the box size to better visualize the type + line.margin = .1, # We need to add this to avoid crowding + clip = c(-.125, 0.075), + col = fpColors(box = c("blue", "darkred")), + xticks = c(-.1, -0.05, 0, .05), + xlab = "EQ-5D index" + ) |> + fp_add_header("A header") + + expect_equivalent(out$labels[[1]][[1]], + "A header") +}) + + test_that("How to handle missing rows when group_by have different names", { out <- HRQoL |> sapply(\(x) data.frame(x) |> tibble::rownames_to_column(), diff --git a/vignettes/forestplot.Rmd b/vignettes/forestplot.Rmd index abcc442..83780ed 100644 --- a/vignettes/forestplot.Rmd +++ b/vignettes/forestplot.Rmd @@ -74,12 +74,10 @@ base_data <- tibble::tibble(mean = c(0.578, 0.165, 0.246, 0.700, 0.348, 0.139, base_data |> forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), clip = c(0.1, 2.5), - xlog = TRUE, - shapes_gp = fpShapesGp(box = gpar(fill = "royalblue", - col = "royalblue"), - line = gpar(col = "darkblue"), - summary = gpar(fill = "royalblue", - col = "royalblue"))) |> + xlog = TRUE) |> + fp_set_style(box = "royalblue", + line = "darkblue", + summary = "royalblue") |> fp_add_header(study = c("", "Study"), deaths_steroid = c("Deaths", "(steroid)"), deaths_placebo = c("Deaths", "(placebo)"), @@ -100,29 +98,48 @@ The same as above but with lines based on the summary elements and also using a ```{r, fig.height=4, fig.width=8, message=FALSE} base_data |> forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), - is.summary = summary, clip = c(0.1, 2.5), - hrzl_lines = gpar(col = "#444444"), - xlog = TRUE, - col = fpColors(box = "royalblue", - line = "darkblue", - summary = "royalblue")) + hrzl_lines = TRUE, + xlog = TRUE) |> + fp_set_style(box = "royalblue", + line = "darkblue", + summary = "royalblue", + hrz_lines = "#999999") |> + fp_add_header(study = c("", "Study"), + deaths_steroid = c("Deaths", "(steroid)"), + deaths_placebo = c("Deaths", "(placebo)"), + OR = c("", "OR")) |> + fp_append_row(mean = 0.531, + lower = 0.386, + upper = 0.731, + study = "Summary", + OR = "0.53", + is.summary = TRUE) ``` We can also choose what lines we want by providing a list where the name is the line number affected, in the example below 3rd line and 11th counting the first line to be above the first row (not that there is an empty row before summary): ```{r, fig.height=4, fig.width=8, message=FALSE} -cochrane_output_df |> +base_data |> forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), - is.summary = summary, clip = c(0.1, 2.5), hrzl_lines = list("3" = gpar(lty = 2), "11" = gpar(lwd = 1, columns = 1:4, col = "#000044")), - xlog = TRUE, - col = fpColors(box = "royalblue", - line = "darkblue", - summary = "royalblue", - hrz_lines = "#444444")) + xlog = TRUE) |> + fp_set_style(box = "royalblue", + line = "darkblue", + summary = "royalblue", + hrz_lines = "#999999") |> + fp_add_header(study = c("", "Study"), + deaths_steroid = c("Deaths", "(steroid)"), + deaths_placebo = c("Deaths", "(placebo)"), + OR = c("", "OR")) |> + fp_append_row(mean = 0.531, + lower = 0.386, + upper = 0.731, + study = "Summary", + OR = "0.53", + is.summary = TRUE) ``` Adding vertices to the whiskers @@ -131,18 +148,27 @@ Adding vertices to the whiskers For marking the start/end points it is common to add a vertical line at the end of each whisker. In forestplot you simply specify the `vertices` argument: ```{r, fig.height=4, fig.width=8, message=FALSE} -cochrane_output_df |> +base_data |> forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), - is.summary = summary, + clip = c(0.1, 2.5), hrzl_lines = list("3" = gpar(lty = 2), "11" = gpar(lwd = 1, columns = 1:4, col = "#000044")), - clip = c(0.1, 2.5), - xlog = TRUE, - col = fpColors(box = "royalblue", - line = "darkblue", - summary = "royalblue", - hrz_lines = "#444444"), - vertices = TRUE) + vertices = TRUE, + xlog = TRUE) |> + fp_set_style(box = "royalblue", + line = "darkblue", + summary = "royalblue", + hrz_lines = "#999999") |> + fp_add_header(study = c("", "Study"), + deaths_steroid = c("Deaths", "(steroid)"), + deaths_placebo = c("Deaths", "(placebo)"), + OR = c("", "OR")) |> + fp_append_row(mean = 0.531, + lower = 0.386, + upper = 0.731, + study = "Summary", + OR = "0.53", + is.summary = TRUE) ``` Positioning the graph element @@ -151,16 +177,28 @@ Positioning the graph element You can also choose to have the graph positioned within the text table by specifying the `graph.pos` argument: ```{r} -cochrane_output_df |> +base_data |> forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), - is.summary = summary, - graph.pos = 4, + clip = c(0.1, 2.5), hrzl_lines = list("3" = gpar(lty = 2), - "11" = gpar(lwd = 1, columns = c(1:3,5), col = "#000044"), - "12" = gpar(lwd = 1, lty = 2, columns = c(1:3,5), col = "#000044")), - clip = c(0.1,2.5), - xlog = TRUE, - col = fpColors(box = "royalblue",line = "darkblue", summary = "royalblue", hrz_lines = "#444444")) + "11" = gpar(lwd = 1, columns = 1:4, col = "#000044")), + graph.pos = 4, + vertices = TRUE, + xlog = TRUE) |> + fp_set_style(box = "royalblue", + line = "darkblue", + summary = "royalblue", + hrz_lines = "#999999") |> + fp_add_header(study = c("", "Study"), + deaths_steroid = c("Deaths", "(steroid)"), + deaths_placebo = c("Deaths", "(placebo)"), + OR = c("", "OR")) |> + fp_append_row(mean = 0.531, + lower = 0.386, + upper = 0.731, + study = "Summary", + OR = "0.53", + is.summary = TRUE) ``` Using expressions @@ -170,18 +208,16 @@ If we present a regression output it is sometimes convenient to have non-ascii l ```{r} data(dfHRQoL) -dfHRQoL <- dfHRQoL |> mutate(est = sprintf("%.2f", mean), .after = labeltext) - -clrs <- fpColors(box = "royalblue",line = "darkblue", summary = "royalblue") -tabletext <- list(c(NA, dfHRQoL |> filter(group == "Sweden") |> pull(labeltext)), - append(list(expression(beta)), dfHRQoL |> filter(group == "Sweden") |> pull(est))) dfHRQoL |> filter(group == "Sweden") |> - tibble::add_row(tibble(mean = NA_real_), .before = 1) |> - forestplot(labeltext = tabletext, - col = clrs, - xlab = "EQ-5D index") + mutate(est = sprintf("%.2f", mean), .after = labeltext) |> + forestplot(labeltext = c(labeltext, est), + xlab = "EQ-5D index") |> + fp_add_header(est = expression(beta)) |> + fp_set_style(box = "royalblue", + line = "darkblue", + summary = "royalblue") ``` Altering fonts @@ -197,10 +233,14 @@ if (grepl("Ubuntu", Sys.info()["version"])) { } dfHRQoL |> filter(group == "Sweden") |> + mutate(est = sprintf("%.2f", mean), .after = labeltext) |> forestplot(labeltext = c(labeltext, est), - txt_gp = fpTxtGp(label = gpar(fontfamily = font)), - col = clrs, - xlab = "EQ-5D index") + xlab = "EQ-5D index") |> + fp_add_header(est = "Est.") |> + fp_set_style(box = "royalblue", + line = "darkblue", + summary = "royalblue", + txt_gp = fpTxtGp(label = gpar(fontfamily = font))) ``` There is also the possibility of being selective in gp-styles: @@ -208,14 +248,18 @@ There is also the possibility of being selective in gp-styles: ```{r} dfHRQoL |> filter(group == "Sweden") |> + mutate(est = sprintf("%.2f", mean), .after = labeltext) |> forestplot(labeltext = c(labeltext, est), - txt_gp = fpTxtGp(label = list(gpar(fontfamily = font), - gpar(fontfamily = "", - col = "#660000")), - ticks = gpar(fontfamily = "", cex = 1), - xlab = gpar(fontfamily = font, cex = 1.5)), - col = clrs, - xlab = "EQ-5D index") + xlab = "EQ-5D index") |> + fp_add_header(est = "Est.") |> + fp_set_style(box = "royalblue", + line = "darkblue", + summary = "royalblue", + txt_gp = fpTxtGp(label = list(gpar(fontfamily = font), + gpar(fontfamily = "", + col = "#660000")), + ticks = gpar(fontfamily = "", cex = 1), + xlab = gpar(fontfamily = font, cex = 1.5))) ``` Confidence intervals @@ -226,10 +270,13 @@ Clipping the interval is convenient for uncertain estimates in order to retain t ```{r} dfHRQoL |> filter(group == "Sweden") |> + mutate(est = sprintf("%.2f", mean), .after = labeltext) |> forestplot(labeltext = c(labeltext, est), clip = c(-.1, Inf), - col = clrs, - xlab = "EQ-5D index") + xlab = "EQ-5D index") |> + fp_set_style(box = "royalblue", + line = "darkblue", + summary = "royalblue") ``` Custom box size @@ -240,16 +287,37 @@ You can force the box size to a certain size through the `boxsize` argument. ```{r} dfHRQoL |> filter(group == "Sweden") |> + mutate(est = sprintf("%.2f", mean), .after = labeltext) |> forestplot(labeltext = c(labeltext, est), boxsize = 0.2, clip = c(-.1, Inf), - col = clrs, - xlab = "EQ-5D index") + xlab = "EQ-5D index") |> + fp_set_style(box = "royalblue", + line = "darkblue", + summary = "royalblue") ``` If you want to keep the relative sizes you need to provide a wrapper to the draw function that transforms the boxes. Below shows how this is done, also how you combine multiple forestplots into one image: ```{r fig.width=10, fig.height=4} +fp_sweden <- dfHRQoL |> + filter(group == "Sweden") |> + mutate(est = sprintf("%.2f", mean), .after = labeltext) |> + forestplot(labeltext = c(labeltext, est), + title = "Sweden", + clip = c(-.1, Inf), + xlab = "EQ-5D index", + new_page = FALSE) + +fp_denmark <- dfHRQoL |> + filter(group == "Denmark") |> + mutate(est = sprintf("%.2f", mean), .after = labeltext) |> + forestplot(labeltext = c(labeltext, est), + title = "Denmark", + clip = c(-.1, Inf), + xlab = "EQ-5D index", + new_page = FALSE) + library(grid) grid.newpage() borderWidth <- unit(4, "pt") @@ -263,14 +331,10 @@ pushViewport(viewport(layout = grid.layout(nrow = 1, ) pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 1)) -dfHRQoL |> - filter(group == "Sweden") |> - forestplot(labeltext = c(labeltext, est), - title = "Sweden", - clip = c(-.1, Inf), - col = clrs, - xlab = "EQ-5D index", - new_page = FALSE) +fp_sweden |> + fp_set_style(box = "royalblue", + line = "darkblue", + summary = "royalblue") upViewport() pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 2)) @@ -278,15 +342,10 @@ grid.rect(gp = gpar(fill = "#dddddd", col = "#eeeeee")) upViewport() pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 3)) - -dfHRQoL |> - filter(group == "Denmark") |> - forestplot(labeltext = c(labeltext, est), - title = "Denmark", - clip = c(-.1, Inf), - col = clrs, - xlab = "EQ-5D index", - new_page = FALSE) +fp_denmark |> + fp_set_style(box = "royalblue", + line = "darkblue", + summary = "royalblue") upViewport(2) ``` @@ -300,15 +359,14 @@ When combining similar outcomes for the same exposure I've found it useful to us dfHRQoL |> group_by(group) |> forestplot(clip = c(-.1, 0.075), - shapes_gp = fpShapesGp(box = c("blue", "darkred") |> lapply(function(x) gpar(fill = x, col = "#555555")), - default = gpar(vertices = TRUE)), ci.vertices = TRUE, ci.vertices.height = 0.05, boxsize = .1, - xlab = "EQ-5D index") + xlab = "EQ-5D index") |> + fp_set_style(box = c("blue", "darkred") |> lapply(function(x) gpar(fill = x, col = "#555555")), + default = gpar(vertices = TRUE)) ``` - Estimate indicator ------------------ @@ -321,9 +379,9 @@ dfHRQoL |> boxsize = .25, # We set the box size to better visualize the type line.margin = .1, # We need to add this to avoid crowding clip = c(-.125, 0.075), - shapes_gp = fpShapesGp(box = c("blue", "darkred") |> lapply(function(x) gpar(fill = x, col = "#555555")), - default = gpar(vertices = TRUE)), - xlab = "EQ-5D index") + xlab = "EQ-5D index") |> + fp_set_style(box = c("blue", "darkred") |> lapply(function(x) gpar(fill = x, col = "#555555")), + default = gpar(vertices = TRUE)) ``` The confidence interval/box drawing functions are fully customizeable. You can write your own function that accepts the parameters: lower_limit, estimate, upper_limit, size, y.offset, clr.line, clr.marker, and lwd. @@ -341,8 +399,9 @@ dfHRQoL |> line.margin = .1, # We need to add this to avoid crowding clip = c(-.125, 0.075), lty.ci = c(1, 2), - col = fpColors(box = c("blue", "darkred")), - xlab = "EQ-5D index") + xlab = "EQ-5D index") |> + fp_set_style(box = c("blue", "darkred") |> lapply(function(x) gpar(fill = x, col = "#555555")), + default = gpar(vertices = TRUE)) ``` @@ -359,8 +418,8 @@ dfHRQoL |> boxsize = .25, # We set the box size to better visualize the type line.margin = .1, # We need to add this to avoid crowding clip = c(-.125, 0.075), - col = fpColors(box = c("blue", "darkred")), - xlab = "EQ-5D index") + xlab = "EQ-5D index") |> + fp_set_style(box = c("blue", "darkred") |> lapply(function(x) gpar(fill = x, col = "#555555"))) ``` This can be further customized by setting the `legend_args` argument using the `fpLegend` function: @@ -375,8 +434,8 @@ dfHRQoL |> boxsize = .25, # We set the box size to better visualize the type line.margin = .1, # We need to add this to avoid crowding clip = c(-.125, 0.075), - col = fpColors(box = c("blue", "darkred")), - xlab = "EQ-5D index") + xlab = "EQ-5D index") |> + fp_set_style(box = c("blue", "darkred") |> lapply(function(x) gpar(fill = x, col = "#555555"))) ``` @@ -392,9 +451,9 @@ dfHRQoL |> boxsize = .25, # We set the box size to better visualize the type line.margin = .1, # We need to add this to avoid crowding clip = c(-.125, 0.075), - col = fpColors(box = c("blue", "darkred")), xticks = c(-.1, -0.05, 0, .05), - xlab = "EQ-5D index") + xlab = "EQ-5D index") |> + fp_set_style(box = c("blue", "darkred") |> lapply(function(x) gpar(fill = x, col = "#555555"))) ``` By adding a "labels" attribute to the ticks you can tailor the ticks even further, here's an example the suppresses tick text for every other tick: @@ -410,9 +469,9 @@ dfHRQoL |> boxsize = .25, # We set the box size to better visualize the type line.margin = .1, # We need to add this to avoid crowding clip = c(-.125, 0.075), - col = fpColors(box = c("blue", "darkred")), xticks = xticks, - xlab = "EQ-5D index") + xlab = "EQ-5D index") |> + fp_set_style(box = c("blue", "darkred") |> lapply(function(x) gpar(fill = x, col = "#555555"))) ``` Sometimes you have a very tall graph and you want to add helper lines in order @@ -426,11 +485,11 @@ dfHRQoL |> boxsize = .25, # We set the box size to better visualize the type line.margin = .1, # We need to add this to avoid crowding clip = c(-.125, 0.075), - col = fpColors(box = c("blue", "darkred")), grid = TRUE, xticks = c(-.1, -0.05, 0, .05), zero = 0, - xlab = "EQ-5D index") + xlab = "EQ-5D index") |> + fp_set_style(box = c("blue", "darkred") |> lapply(function(x) gpar(fill = x, col = "#555555"))) ``` You can easily customize both what grid lines to use and what type they should be by adding the gpar object to a vector: @@ -442,10 +501,10 @@ dfHRQoL |> boxsize = .25, # We set the box size to better visualize the type line.margin = .1, # We need to add this to avoid crowding clip = c(-.125, 0.075), - col = fpColors(box = c("blue", "darkred")), grid = structure(c(-.1, -.05, .05), gp = gpar(lty = 2, col = "#CCCCFF")), - xlab = "EQ-5D index") + xlab = "EQ-5D index") |> + fp_set_style(box = c("blue", "darkred") |> lapply(function(x) gpar(fill = x, col = "#555555"))) ``` If you are unfamiliar with the structure call it is equivalent to generating a vector and then setting an attribute, eg: From 1228e62e839d30531b9817a41d459c811870f5b3 Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Wed, 28 Sep 2022 21:52:24 +0200 Subject: [PATCH 12/17] Fixed bug width calculating the graph width --- R/private_getColWidths.R | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/R/private_getColWidths.R b/R/private_getColWidths.R index bb464ac..d6899de 100644 --- a/R/private_getColWidths.R +++ b/R/private_getColWidths.R @@ -19,8 +19,13 @@ getColWidths <- function(labels, graphwidth, colgap, graph.pos, nc) { graphwidth == "auto") { # If graph width is not provided as a unit the autosize it to the # rest of the space available - npc_colwidths <- convertUnit(unit.c(colwidths, colgap), "npc", valueOnly = TRUE) - graphwidth <- unit(max(.05, 1 - sum(npc_colwidths)), "npc") + graphwidth <- unit(1, "npc") - sum(colwidths) + # While the logic makes sense it seems that the auto calculating + # function is off and we shouldn't rely on the logic below + if (convertWidth(graphwidth, unitTo = "npc", valueOnly = TRUE) < 0.05) { + graphwidth <- unit(0.05, "npc") + } + # graphwidth <- unit(max(.05, graphwidth), "npc") } else if (!is.unit(graphwidth)) { stop( "You have to provide graph width either as a unit() object or as 'auto'.", From 6589eb6560cb04f208fa2c1d51ca0117e407e32d Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Wed, 28 Sep 2022 21:53:23 +0200 Subject: [PATCH 13/17] Moved confidence interval drawing into separate function --- R/drawForestplotObject.R | 157 ++----------------------------------- R/plotConfidenceInterval.R | 153 ++++++++++++++++++++++++++++++++++++ 2 files changed, 160 insertions(+), 150 deletions(-) create mode 100644 R/plotConfidenceInterval.R diff --git a/R/drawForestplotObject.R b/R/drawForestplotObject.R index d5354c0..a885ef1 100644 --- a/R/drawForestplotObject.R +++ b/R/drawForestplotObject.R @@ -148,156 +148,13 @@ drawForestplotObject <- function(obj) { plot(axisList) - # Output the different confidence intervals - for (i in 1:nrow(obj$estimates)) { - # The line and box colors may vary - clr.line <- rep(obj$col$line, length.out = dim(obj$estimates)[3]) - clr.marker <- rep(obj$col$box, length.out = dim(obj$estimates)[3]) - clr.summary <- rep(obj$col$summary, length.out = dim(obj$estimates)[3]) - - line_vp <- viewport( - layout.pos.row = i, - layout.pos.col = obj$graph.pos * 2 - 1, - xscale = axisList$x_range, - name = sprintf("Line_%d_%d", i, obj$graph.pos * 2 - 1) - ) - pushViewport(line_vp) - - # Draw multiple confidence intervals - if (dim(obj$estimates)[3] > 1) { - b_height <- max(info[i,]) - if (is.unit(b_height)) { - b_height <- convertUnit(b_height, unitTo = "npc", valueOnly = TRUE) - } - - if (is.null(obj$line.margin)) { - obj$line.margin <- .1 + .2 / (dim(obj$estimates)[3] - 1) - } else if (is.unit(obj$line.margin)) { - obj$line.margin <- convertUnit(obj$line.margin, unitTo = "npc", valueOnly = TRUE) - } - y.offset_base <- b_height / 2 + obj$line.margin - y.offset_increase <- (1 - obj$line.margin * 2 - b_height) / (dim(obj$estimates)[3] - 1) - - for (j in dim(obj$estimates)[3]:1) { - # Start from the bottom and plot up - # the one on top should always be - # above the one below - current_y.offset <- y.offset_base + (dim(obj$estimates)[3] - j) * y.offset_increase - if (is.na(obj$estimates[i, 1, j])) { - next - } - - shape_coordinates <- c(i, j) - attr(shape_coordinates, "max.coords") <- c(attr(labels, "no_rows"), dim(obj$estimates)[3]) - - if (obj$is.summary[i]) { - call_list <- - list(fn.ci_sum[[i]][[j]], - estimate = obj$estimates[i, 1, j], - lower_limit = obj$estimates[i, 2, j], - upper_limit = obj$estimates[i, 3, j], - size = info[i, j], - y.offset = current_y.offset, - col = clr.summary[j], - shapes_gp = obj$shapes_gp, - shape_coordinates = shape_coordinates - ) - } else { - call_list <- - list(fn.ci_norm[[i]][[j]], - estimate = obj$estimates[i, 1, j], - lower_limit = obj$estimates[i, 2, j], - upper_limit = obj$estimates[i, 3, j], - size = info[i, j], - y.offset = current_y.offset, - clr.line = clr.line[j], - clr.marker = clr.marker[j], - lty = lty.ci[[i]][[j]], - vertices.height = obj$ci.vertices.height, - shapes_gp = obj$shapes_gp, - shape_coordinates = shape_coordinates - ) - - if (!is.null(obj$ci.vertices)) { - call_list$vertices <- obj$ci.vertices - } - - if (!is.null(obj$lwd.ci)) { - call_list$lwd <- obj$lwd.ci - } - } - - - # Add additional arguments that are passed on - # from the original parameters - for (name in names(obj$extra_arguments)) { - call_list[[name]] <- obj$extra_arguments[[name]] - } - - # Do the actual drawing of the object - tryCatch(eval(as.call(call_list)), - error = function(e) { - stop("On row ", i, " the print of the estimate failed: ", e$message) - } - ) - } - } else { - shape_coordinates <- c(i, 1) - attr(shape_coordinates, "max.coords") <- c(attr(labels, "no_rows"), 1) - - if (obj$is.summary[i]) { - call_list <- - list(fn.ci_sum[[i]], - estimate = obj$estimates[i, 1, 1], - lower_limit = obj$estimates[i, 2, 1], - upper_limit = obj$estimates[i, 3, 1], - size = info[i, 1], - col = clr.summary, - shapes_gp = obj$shapes_gp, - shape_coordinates = shape_coordinates - ) - } else { - call_list <- - list(fn.ci_norm[[i]], - estimate = obj$estimates[i, 1, 1], - lower_limit = obj$estimates[i, 2, 1], - upper_limit = obj$estimates[i, 3, 1], - size = info[i, 1], - clr.line = clr.line, - clr.marker = clr.marker, - lty = lty.ci[[i]][[1]], - vertices.height = obj$ci.vertices.height, - shapes_gp = obj$shapes_gp, - shape_coordinates = shape_coordinates - ) - - if (!is.null(obj$ci.vertices)) { - call_list$vertices <- obj$ci.vertices - } - - if (!is.null(obj$lwd.ci)) { - call_list$lwd <- obj$lwd.ci - } - } - - # Add additional arguments that are passed on - # from the original parameters - for (name in names(obj$extra_arguments)) { - call_list[[name]] <- obj$extra_arguments[[name]] - } - - # Do the actual drawing of the object - if (!all(is.na(obj$estimates[i, 1, 1]))) { - tryCatch(eval(as.call(call_list)), - error = function(e) { - stop("On row ", i, " the print of the estimate failed: ", e$message) - } - ) - } - } - - upViewport() - } + plotConfidenceInterval(obj = obj, + axisList = axisList, + info = info, + labels = labels, + fn.ci_sum = fn.ci_sum, + fn.ci_norm = fn.ci_norm, + lty.ci = lty.ci) if (length(legend) > 0 && is.list(obj$legend_args$pos)) { diff --git a/R/plotConfidenceInterval.R b/R/plotConfidenceInterval.R new file mode 100644 index 0000000..fdbd291 --- /dev/null +++ b/R/plotConfidenceInterval.R @@ -0,0 +1,153 @@ +plotConfidenceInterval <- function(obj, axisList, info, labels, fn.ci_sum, fn.ci_norm, lty.ci) { + # Output the different confidence intervals + for (i in 1:nrow(obj$estimates)) { + # The line and box colors may vary + clr.line <- rep(obj$col$line, length.out = dim(obj$estimates)[3]) + clr.marker <- rep(obj$col$box, length.out = dim(obj$estimates)[3]) + clr.summary <- rep(obj$col$summary, length.out = dim(obj$estimates)[3]) + + line_vp <- viewport( + layout.pos.row = i, + layout.pos.col = obj$graph.pos * 2 - 1, + xscale = axisList$x_range, + name = sprintf("Line_%d_%d", i, obj$graph.pos * 2 - 1) + ) + pushViewport(line_vp) + + # Draw multiple confidence intervals + if (dim(obj$estimates)[3] > 1) { + b_height <- max(info[i,]) + if (is.unit(b_height)) { + b_height <- convertUnit(b_height, unitTo = "npc", valueOnly = TRUE) + } + + if (is.null(obj$line.margin)) { + obj$line.margin <- .1 + .2 / (dim(obj$estimates)[3] - 1) + } else if (is.unit(obj$line.margin)) { + obj$line.margin <- convertUnit(obj$line.margin, unitTo = "npc", valueOnly = TRUE) + } + y.offset_base <- b_height / 2 + obj$line.margin + y.offset_increase <- (1 - obj$line.margin * 2 - b_height) / (dim(obj$estimates)[3] - 1) + + for (j in dim(obj$estimates)[3]:1) { + # Start from the bottom and plot up + # the one on top should always be + # above the one below + current_y.offset <- y.offset_base + (dim(obj$estimates)[3] - j) * y.offset_increase + if (is.na(obj$estimates[i, 1, j])) { + next + } + + shape_coordinates <- c(i, j) + attr(shape_coordinates, "max.coords") <- c(attr(labels, "no_rows"), dim(obj$estimates)[3]) + + if (obj$is.summary[i]) { + call_list <- + list(fn.ci_sum[[i]][[j]], + estimate = obj$estimates[i, 1, j], + lower_limit = obj$estimates[i, 2, j], + upper_limit = obj$estimates[i, 3, j], + size = info[i, j], + y.offset = current_y.offset, + col = clr.summary[j], + shapes_gp = obj$shapes_gp, + shape_coordinates = shape_coordinates + ) + } else { + call_list <- + list(fn.ci_norm[[i]][[j]], + estimate = obj$estimates[i, 1, j], + lower_limit = obj$estimates[i, 2, j], + upper_limit = obj$estimates[i, 3, j], + size = info[i, j], + y.offset = current_y.offset, + clr.line = clr.line[j], + clr.marker = clr.marker[j], + lty = lty.ci[[i]][[j]], + vertices.height = obj$ci.vertices.height, + shapes_gp = obj$shapes_gp, + shape_coordinates = shape_coordinates + ) + + if (!is.null(obj$ci.vertices)) { + call_list$vertices <- obj$ci.vertices + } + + if (!is.null(obj$lwd.ci)) { + call_list$lwd <- obj$lwd.ci + } + } + + + # Add additional arguments that are passed on + # from the original parameters + for (name in names(obj$extra_arguments)) { + call_list[[name]] <- obj$extra_arguments[[name]] + } + + # Do the actual drawing of the object + tryCatch(eval(as.call(call_list)), + error = function(e) { + stop("On row ", i, " the print of the estimate failed: ", e$message) + } + ) + } + } else { + shape_coordinates <- c(i, 1) + attr(shape_coordinates, "max.coords") <- c(attr(labels, "no_rows"), 1) + + if (obj$is.summary[i]) { + call_list <- + list(fn.ci_sum[[i]], + estimate = obj$estimates[i, 1, 1], + lower_limit = obj$estimates[i, 2, 1], + upper_limit = obj$estimates[i, 3, 1], + size = info[i, 1], + col = clr.summary, + shapes_gp = obj$shapes_gp, + shape_coordinates = shape_coordinates + ) + } else { + call_list <- + list(fn.ci_norm[[i]], + estimate = obj$estimates[i, 1, 1], + lower_limit = obj$estimates[i, 2, 1], + upper_limit = obj$estimates[i, 3, 1], + size = info[i, 1], + clr.line = clr.line, + clr.marker = clr.marker, + lty = lty.ci[[i]][[1]], + vertices.height = obj$ci.vertices.height, + shapes_gp = obj$shapes_gp, + shape_coordinates = shape_coordinates + ) + + if (!is.null(obj$ci.vertices)) { + call_list$vertices <- obj$ci.vertices + } + + if (!is.null(obj$lwd.ci)) { + call_list$lwd <- obj$lwd.ci + } + } + + # Add additional arguments that are passed on + # from the original parameters + for (name in names(obj$extra_arguments)) { + call_list[[name]] <- obj$extra_arguments[[name]] + } + + # Do the actual drawing of the object + if (!all(is.na(obj$estimates[i, 1, 1]))) { + tryCatch(eval(as.call(call_list)), + error = function(e) { + stop("On row ", i, " the print of the estimate failed: ", e$message) + } + ) + } + } + + upViewport() + } +} + From 5345e90df5828bab2db5ffb50e7e73b2252327f0 Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Wed, 28 Sep 2022 22:30:31 +0200 Subject: [PATCH 14/17] Added a fp_decorate_graph modifier (fixes issue #12) --- NAMESPACE | 1 + NEWS.md | 1 + R/drawForestplotObject.R | 4 ++ R/fp_decorate_graph.R | 46 ++++++++++++++++++++ R/fp_insert_row.R | 1 + R/fp_set_style.R | 1 + R/private_getColWidths.R | 3 +- inst/examples/fp_decorate_graph_example.R | 22 ++++++++++ man/fp_decorate_graph.Rd | 52 +++++++++++++++++++++++ man/prepLabelText.Rd | 4 +- man/row_manipulation.Rd | 6 +++ man/style_manipulation.Rd | 6 +++ 12 files changed, 144 insertions(+), 3 deletions(-) create mode 100644 R/fp_decorate_graph.R create mode 100644 inst/examples/fp_decorate_graph_example.R create mode 100644 man/fp_decorate_graph.Rd diff --git a/NAMESPACE b/NAMESPACE index d0db4ac..9d7ee2f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -22,6 +22,7 @@ export(fp_align_center) export(fp_align_left) export(fp_align_right) export(fp_append_row) +export(fp_decorate_graph) export(fp_insert_row) export(fp_set_style) export(fp_txt_bold) diff --git a/NEWS.md b/NEWS.md index 854176e..60cfeaa 100644 --- a/NEWS.md +++ b/NEWS.md @@ -17,6 +17,7 @@ Changes for 3.0.0 * Moved to native R-pipe operator (|> instead of %>%) * Fixed case when all rows are summaries (Thanks Christian Röver) * Fixed automated ticks. +* Fixed bug calculating graph width Changes for 2.0.1 ----------------- diff --git a/R/drawForestplotObject.R b/R/drawForestplotObject.R index a885ef1..497e36f 100644 --- a/R/drawForestplotObject.R +++ b/R/drawForestplotObject.R @@ -146,6 +146,10 @@ drawForestplotObject <- function(obj) { colwidths = colwidths, graph.pos = obj$graph.pos) + plotGraphBox(boxGrob = obj$graph_box, + estimates = obj$estimates, + graph.pos = obj$graph.pos) + plot(axisList) plotConfidenceInterval(obj = obj, diff --git a/R/fp_decorate_graph.R b/R/fp_decorate_graph.R new file mode 100644 index 0000000..53aa009 --- /dev/null +++ b/R/fp_decorate_graph.R @@ -0,0 +1,46 @@ +#' Decorate the graph +#' +#' @param x The forestplot object +#' @param box Decorate the graph by framing it in a box. If provided `TRUE` it +#' will simply frame the graph in a black box. If you provide a string it is +#' assumed to be the color of the graph. Acceptable arguments are also `gpar()` +#' and a `grob` object to draw. +#' +#' @return The forestplot object with the extended decoration +#' @export +#' +#' @example inst/examples/fp_decorate_graph_example.R +#' @family graph modifiers +fp_decorate_graph <- function(x, + box = NULL) { + if (!is.null(box)) { + if (isTRUE(box)) { + boxGrob <- rectGrob() + } else if (is.grob(box)) { + boxGrob <- box + } else if (is.character(box)) { + boxGrob <- rectGrob(gp = gpar(col = box)) + } else if (is.list(box)) { + boxGrob <- rectGrob(gp = box) + } else { + stop("Invalid box argument, expected color as string, grob or a gpar()") + } + x$graph_box <- boxGrob + } + + return(x) +} + +plotGraphBox <- function(boxGrob, estimates, graph.pos) { + if (is.null(boxGrob)) return(); + + first_regular_row <- which(apply(estimates, \(x) all(is.na(x)), MARGIN = 1)) |> tail(1) + 1 + pushViewport(viewport( + layout.pos.row = first_regular_row:nrow(estimates), + layout.pos.col = graph.pos * 2 - 1, + name = "Graph decorator" + )) + + grid.draw(boxGrob) + upViewport() +} diff --git a/R/fp_insert_row.R b/R/fp_insert_row.R index d83ae2b..693fd86 100644 --- a/R/fp_insert_row.R +++ b/R/fp_insert_row.R @@ -17,6 +17,7 @@ #' @return The foresplot object with the added rows #' @export #' +#' @family graph modifiers #' @example inst/examples/fp_insert_row_example.R #' @rdname row_manipulation diff --git a/R/fp_set_style.R b/R/fp_set_style.R index d546201..627cbf3 100644 --- a/R/fp_set_style.R +++ b/R/fp_set_style.R @@ -12,6 +12,7 @@ #' #' @example inst/examples/fp_set_style_example.R #' @rdname style_manipulation +#' @family graph modifiers fp_set_style <- function(x, default = NULL, box = NULL, diff --git a/R/private_getColWidths.R b/R/private_getColWidths.R index d6899de..6a7beea 100644 --- a/R/private_getColWidths.R +++ b/R/private_getColWidths.R @@ -22,8 +22,9 @@ getColWidths <- function(labels, graphwidth, colgap, graph.pos, nc) { graphwidth <- unit(1, "npc") - sum(colwidths) # While the logic makes sense it seems that the auto calculating # function is off and we shouldn't rely on the logic below + # as the number is smaller than the graph actually turns out if (convertWidth(graphwidth, unitTo = "npc", valueOnly = TRUE) < 0.05) { - graphwidth <- unit(0.05, "npc") + graphwidth <- unit(0.3, "npc") } # graphwidth <- unit(max(.05, graphwidth), "npc") } else if (!is.unit(graphwidth)) { diff --git a/inst/examples/fp_decorate_graph_example.R b/inst/examples/fp_decorate_graph_example.R new file mode 100644 index 0000000..8eb307f --- /dev/null +++ b/inst/examples/fp_decorate_graph_example.R @@ -0,0 +1,22 @@ +base_data <- tibble::tibble(mean = c(0.578, 0.165, 0.246, 0.700, 0.348, 0.139, 1.017), + lower = c(0.372, 0.018, 0.072, 0.333, 0.083, 0.016, 0.365), + upper = c(0.898, 1.517, 0.833, 1.474, 1.455, 1.209, 2.831), + study = c("Auckland", "Block", "Doran", "Gamsu", + "Morrison", "Papageorgiou", "Tauesch"), + deaths_steroid = c("36", "1", "4", "14", "3", "1", "8"), + deaths_placebo = c("60", "5", "11", "20", "7", "7", "10"), + OR = c("0.58", "0.16", "0.25", "0.70", "0.35", "0.14", "1.02")) + +base_data |> + forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), + clip = c(0.1, 2.5), + xlog = TRUE) |> + fp_add_header(study = c("", "Study"), + deaths_steroid = c("Deaths", "(steroid)"), + deaths_placebo = c("Deaths", "(placebo)"), + OR = c("", "OR")) |> + fp_set_style(box = "royalblue", + line = "darkblue", + summary = gpar(fill = "royalblue", clr = "black"), + txt_gp = fpTxtGp(label = gpar(fontfamily = "mono"))) |> + fp_decorate_graph(box = "lightgray") diff --git a/man/fp_decorate_graph.Rd b/man/fp_decorate_graph.Rd new file mode 100644 index 0000000..f9f2fc5 --- /dev/null +++ b/man/fp_decorate_graph.Rd @@ -0,0 +1,52 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fp_decorate_graph.R +\name{fp_decorate_graph} +\alias{fp_decorate_graph} +\title{Decorate the graph} +\usage{ +fp_decorate_graph(x, box = NULL) +} +\arguments{ +\item{x}{The forestplot object} + +\item{box}{Decorate the graph by framing it in a box. If provided \code{TRUE} it +will simply frame the graph in a black box. If you provide a string it is +assumed to be the color of the graph. Acceptable arguments are also \code{gpar()} +and a \code{grob} object to draw.} +} +\value{ +The forestplot object with the extended decoration +} +\description{ +Decorate the graph +} +\examples{ +base_data <- tibble::tibble(mean = c(0.578, 0.165, 0.246, 0.700, 0.348, 0.139, 1.017), + lower = c(0.372, 0.018, 0.072, 0.333, 0.083, 0.016, 0.365), + upper = c(0.898, 1.517, 0.833, 1.474, 1.455, 1.209, 2.831), + study = c("Auckland", "Block", "Doran", "Gamsu", + "Morrison", "Papageorgiou", "Tauesch"), + deaths_steroid = c("36", "1", "4", "14", "3", "1", "8"), + deaths_placebo = c("60", "5", "11", "20", "7", "7", "10"), + OR = c("0.58", "0.16", "0.25", "0.70", "0.35", "0.14", "1.02")) + +base_data |> + forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), + clip = c(0.1, 2.5), + xlog = TRUE) |> + fp_add_header(study = c("", "Study"), + deaths_steroid = c("Deaths", "(steroid)"), + deaths_placebo = c("Deaths", "(placebo)"), + OR = c("", "OR")) |> + fp_set_style(box = "royalblue", + line = "darkblue", + summary = gpar(fill = "royalblue", clr = "black"), + txt_gp = fpTxtGp(label = gpar(fontfamily = "mono"))) |> + fp_decorate_graph(box = "lightgray") +} +\seealso{ +Other graph modifiers: +\code{\link{fp_insert_row}()}, +\code{\link{fp_set_style}()} +} +\concept{graph modifiers} diff --git a/man/prepLabelText.Rd b/man/prepLabelText.Rd index 8bec90f..f08884e 100644 --- a/man/prepLabelText.Rd +++ b/man/prepLabelText.Rd @@ -36,10 +36,10 @@ Returns a \code{forestplot_labeltext} object with attributes: \description{ Prepares an object that contains the number of columns and rows } -\section{Functions}{ +\section{Methods (by generic)}{ \itemize{ \item \code{[}: Pick the value that corresponds to the row and column. Returns \code{expression}, \code{call}, or \code{text}. - }} + \keyword{internal} diff --git a/man/row_manipulation.Rd b/man/row_manipulation.Rd index 8f82dc5..e933fe7 100644 --- a/man/row_manipulation.Rd +++ b/man/row_manipulation.Rd @@ -72,3 +72,9 @@ base_data |> OR = "0.53", is.summary = TRUE) } +\seealso{ +Other graph modifiers: +\code{\link{fp_decorate_graph}()}, +\code{\link{fp_set_style}()} +} +\concept{graph modifiers} diff --git a/man/style_manipulation.Rd b/man/style_manipulation.Rd index d2306fc..6d39e53 100644 --- a/man/style_manipulation.Rd +++ b/man/style_manipulation.Rd @@ -93,3 +93,9 @@ base_data |> summary = gpar(fill = "royalblue", clr = "black"), txt_gp = fpTxtGp(label = gpar(fontfamily = "mono"))) } +\seealso{ +Other graph modifiers: +\code{\link{fp_decorate_graph}()}, +\code{\link{fp_insert_row}()} +} +\concept{graph modifiers} From f8e7723cd7a02879286e02e9ad8ccb514efae3b5 Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Wed, 28 Sep 2022 23:06:33 +0200 Subject: [PATCH 15/17] Added graph decoration (fixes issue #11) --- NAMESPACE | 1 + NEWS.md | 3 +- R/drawForestplotObject.R | 1 + R/fp_decorate_graph.R | 73 ++++++++++++++++++++++- R/text_styling.R | 22 +++++++ inst/examples/fp_decorate_graph_example.R | 6 +- man/fp_decorate_graph.Rd | 27 ++++++++- man/text_styling.Rd | 5 ++ 8 files changed, 133 insertions(+), 5 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 9d7ee2f..6dd2dbb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -26,6 +26,7 @@ export(fp_decorate_graph) export(fp_insert_row) export(fp_set_style) export(fp_txt_bold) +export(fp_txt_gp) export(fp_txt_italic) export(fp_txt_plain) export(getTicks) diff --git a/NEWS.md b/NEWS.md index 60cfeaa..f4a5dbf 100644 --- a/NEWS.md +++ b/NEWS.md @@ -17,7 +17,8 @@ Changes for 3.0.0 * Moved to native R-pipe operator (|> instead of %>%) * Fixed case when all rows are summaries (Thanks Christian Röver) * Fixed automated ticks. -* Fixed bug calculating graph width +* Fixed bug calculating graph width +* Added graph decoration (fixes issue #11) Changes for 2.0.1 ----------------- diff --git a/R/drawForestplotObject.R b/R/drawForestplotObject.R index 497e36f..516ade3 100644 --- a/R/drawForestplotObject.R +++ b/R/drawForestplotObject.R @@ -151,6 +151,7 @@ drawForestplotObject <- function(obj) { graph.pos = obj$graph.pos) plot(axisList) + plotGraphText(obj = obj) plotConfidenceInterval(obj = obj, axisList = axisList, diff --git a/R/fp_decorate_graph.R b/R/fp_decorate_graph.R index 53aa009..fec6e97 100644 --- a/R/fp_decorate_graph.R +++ b/R/fp_decorate_graph.R @@ -5,6 +5,14 @@ #' will simply frame the graph in a black box. If you provide a string it is #' assumed to be the color of the graph. Acceptable arguments are also `gpar()` #' and a `grob` object to draw. +#' @param right_bottom_txt Text to appear at the right bottom of the graph. Can +#' be decorated fp_txt_* functions. +#' @param leftt_bottom_txt Text to appear at the left bottom of the graph. Can +#' be decorated fp_txt_* functions. +#' @param right_top_txt Text to appear at the right top of the graph. Can +#' be decorated fp_txt_* functions. +#' @param leftt_top_txt Text to appear at the left top of the graph. Can +#' be decorated fp_txt_* functions. #' #' @return The forestplot object with the extended decoration #' @export @@ -12,7 +20,11 @@ #' @example inst/examples/fp_decorate_graph_example.R #' @family graph modifiers fp_decorate_graph <- function(x, - box = NULL) { + box = NULL, + right_bottom_txt = NULL, + left_bottom_txt = NULL, + right_top_txt = NULL, + left_top_txt = NULL) { if (!is.null(box)) { if (isTRUE(box)) { boxGrob <- rectGrob() @@ -28,6 +40,11 @@ fp_decorate_graph <- function(x, x$graph_box <- boxGrob } + x$graph_right_bottom_txt <- right_bottom_txt + x$graph_left_bottom_txt <- left_bottom_txt + x$graph_right_top_txt <- right_top_txt + x$graph_left_top_txt <- left_top_txt + return(x) } @@ -44,3 +61,57 @@ plotGraphBox <- function(boxGrob, estimates, graph.pos) { grid.draw(boxGrob) upViewport() } + +plotGraphText <- function(obj) { + txt_names <- paste0("graph_", c("leftt_bottom_txt", "right_bottom_txt")) + txt_elements <- obj[which(names(obj) %in% txt_names)] + if (length(txt_elements) == 0) return() + estimates <- obj$estimates + graph.pos <- obj$graph.pos + + first_regular_row <- which(apply(estimates, \(x) all(is.na(x)), MARGIN = 1)) |> tail(1) + 1 + pushViewport(viewport( + layout.pos.row = first_regular_row:nrow(estimates), + layout.pos.col = graph.pos * 2 - 1, + name = "Graph text" + )) + + drawBox <- function(name, ...) { + elmnt <- obj[[name]] + if (is.null(elmnt)) return(null) + if (is.list(elmnt)) { + elmnt <- elmnt[[1]] + } + + grid.text(elmnt, + gp = attr(elmnt, "txt_gp"), + ...) + } + + + drawBox("graph_left_top_txt", + x = unit(2, "mm"), + y = unit(1, "npc") - unit(2, "mm"), + hjust = 0, + vjust = 1) + + drawBox("graph_right_top_txt", + x = unit(1, "npc") - unit(2, "mm"), + y = unit(1, "npc") - unit(2, "mm"), + hjust = 1, + vjust = 1) + + drawBox("graph_left_bottom_txt", + x = unit(2, "mm"), + y = unit(2, "mm"), + hjust = 0, + vjust = 0) + + drawBox("graph_right_bottom_txt", + x = unit(1, "npc") - unit(2, "mm"), + y = unit(2, "mm"), + hjust = 1, + vjust = 0) + + upViewport() +} diff --git a/R/text_styling.R b/R/text_styling.R index 05d54b0..ccfe0b5 100644 --- a/R/text_styling.R +++ b/R/text_styling.R @@ -55,6 +55,26 @@ fp_txt_plain <- function(txt) { USE.NAMES = FALSE) } +#' @export +#' @rdname text_styling +#' @param gp A [grid::gpar()] style to apply +fp_txt_gp <- function(txt, gp) { + sapply(txt, \(str) { + txt_gp <- attr(str, "txt_gp") + if (is.null(txt_gp)) { + txt_gp <- gpar() + } + for (n in names(gp)) { + txt_gp[[n]] <- gp[[n]] + } + + attr(str, "txt_gp") <- txt_gp + return(str) + }, + simplify = FALSE, + USE.NAMES = FALSE) +} + #' @export #' @rdname text_styling fp_align_left <- function(txt) { @@ -88,6 +108,8 @@ fp_align_right <- function(txt) { USE.NAMES = FALSE) } + + merge_with_txt_gp <- function(gp_list, txt_out) { txt_gp <- attr(txt_out, "txt_gp") if (is.null(txt_gp)) { diff --git a/inst/examples/fp_decorate_graph_example.R b/inst/examples/fp_decorate_graph_example.R index 8eb307f..a1ce0cd 100644 --- a/inst/examples/fp_decorate_graph_example.R +++ b/inst/examples/fp_decorate_graph_example.R @@ -19,4 +19,8 @@ base_data |> line = "darkblue", summary = gpar(fill = "royalblue", clr = "black"), txt_gp = fpTxtGp(label = gpar(fontfamily = "mono"))) |> - fp_decorate_graph(box = "lightgray") + fp_decorate_graph(box = "lightgray", + right_bottom_txt = fp_txt_gp("RB", gp = gpar(cex = .5)), + left_bottom_txt = fp_txt_gp("LB", gp = gpar(cex = .5)), + right_top_txt = "RT", + left_top_txt = "LT") diff --git a/man/fp_decorate_graph.Rd b/man/fp_decorate_graph.Rd index f9f2fc5..c384c22 100644 --- a/man/fp_decorate_graph.Rd +++ b/man/fp_decorate_graph.Rd @@ -4,7 +4,14 @@ \alias{fp_decorate_graph} \title{Decorate the graph} \usage{ -fp_decorate_graph(x, box = NULL) +fp_decorate_graph( + x, + box = NULL, + right_bottom_txt = NULL, + left_bottom_txt = NULL, + right_top_txt = NULL, + left_top_txt = NULL +) } \arguments{ \item{x}{The forestplot object} @@ -13,6 +20,18 @@ fp_decorate_graph(x, box = NULL) will simply frame the graph in a black box. If you provide a string it is assumed to be the color of the graph. Acceptable arguments are also \code{gpar()} and a \code{grob} object to draw.} + +\item{right_bottom_txt}{Text to appear at the right bottom of the graph. Can +be decorated fp_txt_* functions.} + +\item{right_top_txt}{Text to appear at the right top of the graph. Can +be decorated fp_txt_* functions.} + +\item{leftt_bottom_txt}{Text to appear at the left bottom of the graph. Can +be decorated fp_txt_* functions.} + +\item{leftt_top_txt}{Text to appear at the left top of the graph. Can +be decorated fp_txt_* functions.} } \value{ The forestplot object with the extended decoration @@ -42,7 +61,11 @@ base_data |> line = "darkblue", summary = gpar(fill = "royalblue", clr = "black"), txt_gp = fpTxtGp(label = gpar(fontfamily = "mono"))) |> - fp_decorate_graph(box = "lightgray") + fp_decorate_graph(box = "lightgray", + right_bottom_txt = fp_txt_gp("RB", gp = gpar(cex = .5)), + left_bottom_txt = fp_txt_gp("LB", gp = gpar(cex = .5)), + right_top_txt = "RT", + left_top_txt = "LT") } \seealso{ Other graph modifiers: diff --git a/man/text_styling.Rd b/man/text_styling.Rd index 0dc9be9..6b544b7 100644 --- a/man/text_styling.Rd +++ b/man/text_styling.Rd @@ -4,6 +4,7 @@ \alias{fp_txt_italic} \alias{fp_txt_bold} \alias{fp_txt_plain} +\alias{fp_txt_gp} \alias{fp_align_left} \alias{fp_align_center} \alias{fp_align_right} @@ -15,6 +16,8 @@ fp_txt_bold(txt) fp_txt_plain(txt) +fp_txt_gp(txt, gp) + fp_align_left(txt) fp_align_center(txt) @@ -23,6 +26,8 @@ fp_align_right(txt) } \arguments{ \item{txt}{The text to styl} + +\item{gp}{A \code{\link[grid:gpar]{grid::gpar()}} style to apply} } \value{ A list of txt with style attributes From 72b7a13b0c0dc03f95649f0fc85718608d063b35 Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Wed, 28 Sep 2022 23:45:58 +0200 Subject: [PATCH 16/17] Added zebra style --- .Rbuildignore | 1 + NAMESPACE | 1 + NEWS.md | 5 ++- R/drawForestplotObject.R | 2 + R/fp_decorate_graph.R | 6 +-- R/fp_set_zebra_style.R | 55 ++++++++++++++++++++++++++++ inst/examples/fp_set_zebra_example.R | 21 +++++++++++ man/fp_decorate_graph.Rd | 9 +++-- man/fp_set_zebra_style.Rd | 49 +++++++++++++++++++++++++ man/prepLabelText.Rd | 4 +- man/row_manipulation.Rd | 3 +- man/style_manipulation.Rd | 3 +- vignettes/forestplot.Rmd | 3 +- 13 files changed, 148 insertions(+), 14 deletions(-) create mode 100644 R/fp_set_zebra_style.R create mode 100644 inst/examples/fp_set_zebra_example.R create mode 100644 man/fp_set_zebra_style.Rd diff --git a/.Rbuildignore b/.Rbuildignore index 9863431..ce00fdd 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -8,3 +8,4 @@ cran-comments.md ^doc$ ^Meta$ ^cran-comments\.md$ +^CRAN-SUBMISSION$ diff --git a/NAMESPACE b/NAMESPACE index 6dd2dbb..7ef8158 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -25,6 +25,7 @@ export(fp_append_row) export(fp_decorate_graph) export(fp_insert_row) export(fp_set_style) +export(fp_set_zebra_style) export(fp_txt_bold) export(fp_txt_gp) export(fp_txt_italic) diff --git a/NEWS.md b/NEWS.md index f4a5dbf..ab521f8 100644 --- a/NEWS.md +++ b/NEWS.md @@ -9,8 +9,9 @@ Changes for 3.0.0 feature although most of the old syntax should work without much need for adaptation. * New additive syntax with: - * Row manipulation: `fp_insert_row`, `fp_add_header`, `fp_append_row` - * Style functions: `fp_set_style` and txt styling `fp_txt_bold`, `fp_txt_italic`, ... + * Row manipulation: `fp_insert_row`, `fp_add_header`, and `fp_append_row` + * Style functions: `fp_set_style`, `fp_set_zebra_style`, and `fp_decorate_graph` + * Text styling: `fp_txt_bold`, `fp_txt_italic`, ... * Align functions: `fp_align_left`, `fp_align_center`, `fp_align_right` * Fixed bug with how grouped data frames are processed and presented. * Expressions are now allowed in data.frame tidyverse input. diff --git a/R/drawForestplotObject.R b/R/drawForestplotObject.R index 516ade3..a811347 100644 --- a/R/drawForestplotObject.R +++ b/R/drawForestplotObject.R @@ -129,6 +129,8 @@ drawForestplotObject <- function(obj) { name = "BaseGrid" )) + plotZebraStyle(obj) + info <- prepBoxSize(boxsize = obj$boxsize, estimates = obj$estimates, is.summary = obj$is.summary, diff --git a/R/fp_decorate_graph.R b/R/fp_decorate_graph.R index fec6e97..397ecb3 100644 --- a/R/fp_decorate_graph.R +++ b/R/fp_decorate_graph.R @@ -7,11 +7,11 @@ #' and a `grob` object to draw. #' @param right_bottom_txt Text to appear at the right bottom of the graph. Can #' be decorated fp_txt_* functions. -#' @param leftt_bottom_txt Text to appear at the left bottom of the graph. Can +#' @param left_bottom_txt Text to appear at the left bottom of the graph. Can #' be decorated fp_txt_* functions. #' @param right_top_txt Text to appear at the right top of the graph. Can #' be decorated fp_txt_* functions. -#' @param leftt_top_txt Text to appear at the left top of the graph. Can +#' @param left_top_txt Text to appear at the left top of the graph. Can #' be decorated fp_txt_* functions. #' #' @return The forestplot object with the extended decoration @@ -78,7 +78,7 @@ plotGraphText <- function(obj) { drawBox <- function(name, ...) { elmnt <- obj[[name]] - if (is.null(elmnt)) return(null) + if (is.null(elmnt)) return() if (is.list(elmnt)) { elmnt <- elmnt[[1]] } diff --git a/R/fp_set_zebra_style.R b/R/fp_set_zebra_style.R new file mode 100644 index 0000000..5931f50 --- /dev/null +++ b/R/fp_set_zebra_style.R @@ -0,0 +1,55 @@ +#' Decorate the plot with a zebra pattern +#' +#' @param x The forestplot object +#' @param ... The styles for each row +#' +#' @return The forestplot object with the zebra style +#' @export +#' @family graph modifiers +#' +#' @example inst/examples/fp_set_zebra_example.R +fp_set_zebra_style <- function(x, ...) { + zebra_styles <- list(...) |> + lapply(function(style) { + if (is.grob(style)) return(style) + + if (is.character(style)) { + return(gpar(fill = style, col = style)) + } + + if (is.list(style)) { + return(style) + } + + stop("Unknown style: ", style, + " only grob, character and gpar() allowed") + }) + + if (length(zebra_styles) == 1) { + zebra_styles <- c(list(NA), zebra_styles) + } + + x$zebra_styles <- zebra_styles + + return(x) +} + +plotZebraStyle <- function(obj) { + if (is.null(obj$zebra_styles)) return() + estimates <- obj$estimates + + last_header <- which(apply(estimates, \(x) all(is.na(x)), MARGIN = 1)) |> tail(1) + styles <- rep(obj$zebra_styles, length.out = nrow(estimates) - last_header) + for (i in 1:(nrow(estimates) - last_header)) { + pushViewport(viewport( + layout.pos.row = last_header + i, + name = paste("Zebra", i) + )) + if (is.grob(styles[[i]])) { + grid.draw(styles[[i]]) + } else if (!all(is.na(styles[[i]]))){ + grid.rect(gp = styles[[i]]) + } + upViewport() + } +} diff --git a/inst/examples/fp_set_zebra_example.R b/inst/examples/fp_set_zebra_example.R new file mode 100644 index 0000000..e3df2f4 --- /dev/null +++ b/inst/examples/fp_set_zebra_example.R @@ -0,0 +1,21 @@ +base_data <- tibble::tibble(mean = c(0.578, 0.165, 0.246, 0.700, 0.348, 0.139, 1.017), + lower = c(0.372, 0.018, 0.072, 0.333, 0.083, 0.016, 0.365), + upper = c(0.898, 1.517, 0.833, 1.474, 1.455, 1.209, 2.831), + study = c("Auckland", "Block", "Doran", "Gamsu", + "Morrison", "Papageorgiou", "Tauesch"), + deaths_steroid = c("36", "1", "4", "14", "3", "1", "8"), + deaths_placebo = c("60", "5", "11", "20", "7", "7", "10"), + OR = c("0.58", "0.16", "0.25", "0.70", "0.35", "0.14", "1.02")) + +base_data |> + forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), + clip = c(0.1, 2.5), + xlog = TRUE) |> + fp_add_header(study = c("", "Study"), + deaths_steroid = c("Deaths", "(steroid)"), + deaths_placebo = c("Deaths", "(placebo)"), + OR = c("", "OR")) |> + fp_set_style(box = "royalblue", + line = "darkblue", + summary = gpar(fill = "royalblue", clr = "black")) |> + fp_set_zebra_style("#EFEFEF") diff --git a/man/fp_decorate_graph.Rd b/man/fp_decorate_graph.Rd index c384c22..bfe40e7 100644 --- a/man/fp_decorate_graph.Rd +++ b/man/fp_decorate_graph.Rd @@ -24,13 +24,13 @@ and a \code{grob} object to draw.} \item{right_bottom_txt}{Text to appear at the right bottom of the graph. Can be decorated fp_txt_* functions.} -\item{right_top_txt}{Text to appear at the right top of the graph. Can +\item{left_bottom_txt}{Text to appear at the left bottom of the graph. Can be decorated fp_txt_* functions.} -\item{leftt_bottom_txt}{Text to appear at the left bottom of the graph. Can +\item{right_top_txt}{Text to appear at the right top of the graph. Can be decorated fp_txt_* functions.} -\item{leftt_top_txt}{Text to appear at the left top of the graph. Can +\item{left_top_txt}{Text to appear at the left top of the graph. Can be decorated fp_txt_* functions.} } \value{ @@ -70,6 +70,7 @@ base_data |> \seealso{ Other graph modifiers: \code{\link{fp_insert_row}()}, -\code{\link{fp_set_style}()} +\code{\link{fp_set_style}()}, +\code{\link{fp_set_zebra_style}()} } \concept{graph modifiers} diff --git a/man/fp_set_zebra_style.Rd b/man/fp_set_zebra_style.Rd new file mode 100644 index 0000000..402a858 --- /dev/null +++ b/man/fp_set_zebra_style.Rd @@ -0,0 +1,49 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fp_set_zebra_style.R +\name{fp_set_zebra_style} +\alias{fp_set_zebra_style} +\title{Decorate the plot with a zebra pattern} +\usage{ +fp_set_zebra_style(x, ...) +} +\arguments{ +\item{x}{The forestplot object} + +\item{...}{The styles for each row} +} +\value{ +The forestplot object with the zebra style +} +\description{ +Decorate the plot with a zebra pattern +} +\examples{ +base_data <- tibble::tibble(mean = c(0.578, 0.165, 0.246, 0.700, 0.348, 0.139, 1.017), + lower = c(0.372, 0.018, 0.072, 0.333, 0.083, 0.016, 0.365), + upper = c(0.898, 1.517, 0.833, 1.474, 1.455, 1.209, 2.831), + study = c("Auckland", "Block", "Doran", "Gamsu", + "Morrison", "Papageorgiou", "Tauesch"), + deaths_steroid = c("36", "1", "4", "14", "3", "1", "8"), + deaths_placebo = c("60", "5", "11", "20", "7", "7", "10"), + OR = c("0.58", "0.16", "0.25", "0.70", "0.35", "0.14", "1.02")) + +base_data |> + forestplot(labeltext = c(study, deaths_steroid, deaths_placebo, OR), + clip = c(0.1, 2.5), + xlog = TRUE) |> + fp_add_header(study = c("", "Study"), + deaths_steroid = c("Deaths", "(steroid)"), + deaths_placebo = c("Deaths", "(placebo)"), + OR = c("", "OR")) |> + fp_set_style(box = "royalblue", + line = "darkblue", + summary = gpar(fill = "royalblue", clr = "black")) |> + fp_set_zebra_style("#EFEFEF") +} +\seealso{ +Other graph modifiers: +\code{\link{fp_decorate_graph}()}, +\code{\link{fp_insert_row}()}, +\code{\link{fp_set_style}()} +} +\concept{graph modifiers} diff --git a/man/prepLabelText.Rd b/man/prepLabelText.Rd index f08884e..8bec90f 100644 --- a/man/prepLabelText.Rd +++ b/man/prepLabelText.Rd @@ -36,10 +36,10 @@ Returns a \code{forestplot_labeltext} object with attributes: \description{ Prepares an object that contains the number of columns and rows } -\section{Methods (by generic)}{ +\section{Functions}{ \itemize{ \item \code{[}: Pick the value that corresponds to the row and column. Returns \code{expression}, \code{call}, or \code{text}. -}} +}} \keyword{internal} diff --git a/man/row_manipulation.Rd b/man/row_manipulation.Rd index e933fe7..3d403c0 100644 --- a/man/row_manipulation.Rd +++ b/man/row_manipulation.Rd @@ -75,6 +75,7 @@ base_data |> \seealso{ Other graph modifiers: \code{\link{fp_decorate_graph}()}, -\code{\link{fp_set_style}()} +\code{\link{fp_set_style}()}, +\code{\link{fp_set_zebra_style}()} } \concept{graph modifiers} diff --git a/man/style_manipulation.Rd b/man/style_manipulation.Rd index 6d39e53..579279f 100644 --- a/man/style_manipulation.Rd +++ b/man/style_manipulation.Rd @@ -96,6 +96,7 @@ base_data |> \seealso{ Other graph modifiers: \code{\link{fp_decorate_graph}()}, -\code{\link{fp_insert_row}()} +\code{\link{fp_insert_row}()}, +\code{\link{fp_set_zebra_style}()} } \concept{graph modifiers} diff --git a/vignettes/forestplot.Rmd b/vignettes/forestplot.Rmd index 83780ed..5c8d7e5 100644 --- a/vignettes/forestplot.Rmd +++ b/vignettes/forestplot.Rmd @@ -87,7 +87,8 @@ base_data |> upper = 0.731, study = "Summary", OR = "0.53", - is.summary = TRUE) + is.summary = TRUE) |> + fp_set_zebra_style("#EFEFEF") ``` Summary lines From eff28a34c6ddb0522b3e445fd70af20f19a2bb4b Mon Sep 17 00:00:00 2001 From: Max Gordon Date: Wed, 28 Sep 2022 23:46:58 +0200 Subject: [PATCH 17/17] Minor CRAN note fixed --- R/forestplot_helpers.R | 2 +- man/fpColors.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/forestplot_helpers.R b/R/forestplot_helpers.R index 01f0f6b..06ded47 100644 --- a/R/forestplot_helpers.R +++ b/R/forestplot_helpers.R @@ -540,7 +540,7 @@ fpDrawBarCI <- function(lower_limit, estimate, upper_limit, size, col, y.offset #' If you have several values per row in a forestplot you can set #' a color to a vector where the first value represents the first #' line/box, second the second line/box etc. The vectors are only -#' valid for the \code{box} \& \code{lines} options. +#' valid for the \code{box} & \code{lines} options. #' #' This function is a copy of the \code{\link[rmeta]{meta.colors}} #' function in the \pkg{rmeta} package. diff --git a/man/fpColors.Rd b/man/fpColors.Rd index dd998e6..4c8da9e 100644 --- a/man/fpColors.Rd +++ b/man/fpColors.Rd @@ -50,7 +50,7 @@ backwards compatibility. If you have several values per row in a forestplot you can set a color to a vector where the first value represents the first line/box, second the second line/box etc. The vectors are only -valid for the \code{box} \& \code{lines} options. +valid for the \code{box} & \code{lines} options. This function is a copy of the \code{\link[rmeta]{meta.colors}} function in the \pkg{rmeta} package.