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/DESCRIPTION b/DESCRIPTION index 5af3a06..10a4338 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,5 +1,5 @@ Package: forestplot -Version: 2.0.2 +Version: 3.0.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 + checkmate, + abind 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 +Roxygen: list(markdown = TRUE) +RoxygenNote: 7.2.1 diff --git a/NAMESPACE b/NAMESPACE index 5903b5f..7ef8158 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -17,10 +17,23 @@ export(fpDrawSummaryCI) 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_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) +export(fp_txt_plain) export(getTicks) export(prGetShapeGp) import(grid) -import(magrittr) +importFrom(abind,adrop) importFrom(checkmate,assert) importFrom(checkmate,assert_class) importFrom(checkmate,assert_matrix) diff --git a/NEWS.md b/NEWS.md index 58043b6..ab521f8 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,8 +1,25 @@ NEWS for the forestplot package -Changes for 2.0.2 +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`, 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. +* 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 +* Added graph decoration (fixes issue #11) Changes for 2.0.1 ----------------- 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/drawForestplotObject.R b/R/drawForestplotObject.R index 84ef9bb..a811347 100644 --- a/R/drawForestplotObject.R +++ b/R/drawForestplotObject.R @@ -1,505 +1,174 @@ +#' @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" - ) - - 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 - ) - ) - - 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 - ) - } - } - - # 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)) - } 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) - } - - prFpPrintLabels( - labels = labels, - nc = nc, - nr = nr, - graph.pos = graph.pos - ) - - prFpDrawLines( - hrzl_lines = hrzl_lines, nr = nr, colwidths = colwidths, - graph.pos = graph.pos - ) - - - prFpPrintXaxis( - axisList = axisList, - col = col, - lwd.zero = lwd.zero, - shapes_gp = shapes_gp + 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 + + 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,], + 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, + lwd.zero = obj$lwd.zero, + txt_gp = obj$txt_gp, + col = obj$col, + clip = obj$clip, + zero = obj$zero, + x_range = xRange, + estimates = obj$estimates, + 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 ) - - # 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] - } - - # 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) - } - 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 - } - } - - - # 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]) { - 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 - ) - } 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 - ) - - if (!all(is.na(ci.vertices))) { - call_list$vertices <- ci.vertices - } - - if (!all(is.na(lwd.ci))) { - call_list$lwd <- 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]] - } - - # 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) - } - ) - } - } - - 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 { - 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 - ) - } - - height <- sum(legend_args$padding, legend_height, legend_args$padding) - width <- 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 = 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) - }) + ) + 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" + )) + + plotZebraStyle(obj) + + info <- prepBoxSize(boxsize = obj$boxsize, + estimates = obj$estimates, + is.summary = obj$is.summary, + txt_gp = obj$txt_gp) + + 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) + + plotGraphBox(boxGrob = obj$graph_box, + estimates = obj$estimates, + graph.pos = obj$graph.pos) + + plot(axisList) + plotGraphText(obj = obj) + + 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)) { + 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-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 5d5b6f8..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)), + 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.default.R b/R/forestplot.default.R index 32e4883..4b83759 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 = "", + xlab = NULL, 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") @@ -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 (!missing(legend)) { + 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 ) } @@ -142,12 +85,12 @@ forestplot.default <- function(labeltext, ) } - if (!missing(legend)) { - if (length(legend) != ncol(mean)) { + if (!is.null(legend)) { + 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,298 +116,71 @@ 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) || - (!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." - ) + 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)", + " 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 - 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) - } - - 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) - - 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 - ) - - lty.ci <- prPopulateList(lty.ci, - no_rows = NROW(org_mean), - 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" - ) + coreData$estimates <- log(coreData$estimates) + clip[clip < 0] <- 0 + clip <- log(clip) + zero <- log(zero) + } + + # Prep basics + 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 = nrow(coreData$estimates)) + + list(labels = labels, + estimates = coreData$estimates, + 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, + shapes_gp = shapes_gp, + hrzl_lines = hrzl_lines, + 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, + xlab = xlab, + xlog = xlog, + clip = clip, + zero = zero, + lwd.xaxis = lwd.xaxis, + extra_arguments = list(...)) |> + structure(class = "gforge_forestplot") } #' @rdname forestplot @@ -482,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/forestplot.grouped_df.R b/R/forestplot.grouped_df.R index 550d951..30df2d1 100644 --- a/R/forestplot.grouped_df.R +++ b/R/forestplot.grouped_df.R @@ -1,9 +1,11 @@ #' @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") + safeLoadPackage("tidyselect") groups <- attr(x, "groups") if (missing(mean)) { @@ -29,66 +31,153 @@ 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) + if (is.function(is.summary)) { + stop("Invalid summary input, does column, '", sumid, "', actually exist?") + } } 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 + 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 + } - 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 - ) + groups <- attr(x, "groups") |> + dplyr::select(-.rows & where(\(col) length(unique(col)) > 1)) |> + colnames() + # 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 = " > ", remove = FALSE) |> + tidyr::unite(".fp_labels", {{lblid}}, sep = " > ") |> + dplyr::select(dplyr::starts_with(".fp"), dplyr::all_of(groups))) |> + dplyr::group_by(.fp_groups) - if (missing(legend)) { - legend <- groups %>% - dplyr::select(-.rows) %>% - apply(MARGIN = 1, function(x) paste(x, collapse = ", ")) + 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(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 + 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.") + } + + 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)) { + 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") + } + + # 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"), + \(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(dplyr::starts_with("@estimates@")) |> + dplyr::rename_with(\(x) sub(pattern = "^@estimates@", + replacement = "", + x = x)) |> + 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, + boxsize = boxsize, + ... ) } -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..06ded47 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. @@ -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) @@ -541,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. @@ -555,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 @@ -634,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 @@ -723,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]] @@ -1022,7 +1040,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 +1056,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 +1072,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 +1090,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 +1110,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/R/fp_decorate_graph.R b/R/fp_decorate_graph.R new file mode 100644 index 0000000..397ecb3 --- /dev/null +++ b/R/fp_decorate_graph.R @@ -0,0 +1,117 @@ +#' 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. +#' @param right_bottom_txt Text to appear at the right bottom of the graph. Can +#' be decorated fp_txt_* functions. +#' @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 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 +#' @export +#' +#' @example inst/examples/fp_decorate_graph_example.R +#' @family graph modifiers +fp_decorate_graph <- function(x, + 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() + } 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 + } + + 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) +} + +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() +} + +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() + 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/fp_insert_row.R b/R/fp_insert_row.R new file mode 100644 index 0000000..693fd86 --- /dev/null +++ b/R/fp_insert_row.R @@ -0,0 +1,193 @@ +#' 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. +#' @param boxsize The box size for the drawn estimate line +#' +#' @return The foresplot object with the added rows +#' @export +#' +#' @family graph modifiers +#' @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, + boxsize = NA){ + args <- list(...) + labels <- sapply(args, + FUN = function(var) { + if (is.list(var)) { + return(var) + } + + if (is.expression(var) || is.character(var)) { + return(lapply(1:length(var), \(i) var[i])) + } + + 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, + depth = dim(x$estimates)[3]) + 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 (is.null(names(labels)) && 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)]) + } + + 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) +} + +#' @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, depth) { + stopifnot(is.null(lower) == is.null(upper)) + if (is.null(mean)) { + return(array(NA, dim = c(label_length, 3, depth), 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 (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) + } + 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/fp_set_style.R b/R/fp_set_style.R new file mode 100644 index 0000000..627cbf3 --- /dev/null +++ b/R/fp_set_style.R @@ -0,0 +1,48 @@ +#' 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 +#' @family graph modifiers +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/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/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/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() + } +} + 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..112b005 100644 --- a/R/prFpGetGraphTicksAndClips.R +++ b/R/prFpGetGraphTicksAndClips.R @@ -5,64 +5,45 @@ #' #' @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 #' #' #' @inheritParams forestplot -#' @keywords internal +#' @noRd prFpGetGraphTicksAndClips <- function(xticks, xticks.digits, grid, xlog, xlab, lwd.xaxis, + lwd.zero, col, txt_gp, 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 (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]))) } @@ -77,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") @@ -92,31 +71,30 @@ 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 { ticks <- NULL 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])) } @@ -134,19 +112,17 @@ 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 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 +138,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( @@ -187,14 +163,12 @@ prFpGetGraphTicksAndClips <- function(xticks, ticklabels <- labattr } } - dg <- xaxisGrob( - at = ticks, - label = ticklabels, - gp = gp_axis - ) + dg <- xaxisGrob(at = ticks, + label = ticklabels, + gp = gp_axis) if (length(grid) == 1) { if (is.logical(grid) && - grid == TRUE) { + grid == TRUE) { grid <- ticks } } @@ -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" ) @@ -231,25 +205,45 @@ 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 labGrob <- textGrob(xlab, - gp = do.call(gpar, gp_list) + gp = do.call(gpar, gp_list) ) } else { 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") +} + +#' 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/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..f1a5838 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 ) } } @@ -261,88 +262,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 -#' @keywords internal -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}} @@ -404,68 +323,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 +344,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, @@ -513,164 +370,7 @@ prFpXrange <- function(upper, lower, clip, zero, xticks, xlog) { ) } - if (xlog) { - return(log(ret)) - } else { - return(ret) - } -} - -#' 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) + return(ret) } #' Get the label @@ -701,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("") } @@ -715,29 +416,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 +601,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)) } @@ -946,11 +643,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 @@ -1173,17 +868,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_buildEstimateArray.R b/R/private_buildEstimateArray.R new file mode 100644 index 0000000..b702ac8 --- /dev/null +++ b/R/private_buildEstimateArray.R @@ -0,0 +1,79 @@ +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]) + } + } + + d <- dimnames(estimates) + d[[2]] <- c("mean", "lower", "upper") + dimnames(estimates) <- d + list(labeltext = labeltext, + estimates = estimates) +} 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..6a7beea --- /dev/null +++ b/R/private_getColWidths.R @@ -0,0 +1,54 @@ +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 + 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.3, "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'.", + " 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_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/R/private_prGetLabelsList.R b/R/private_prGetLabelsList.R new file mode 100644 index 0000000..d03d629 --- /dev/null +++ b/R/private_prGetLabelsList.R @@ -0,0 +1,157 @@ +#' 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] + 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 + 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(txt_align, + l = 0, + r = 1, + c = 0.5) + + just <- switch(txt_align, + l = "left", + r = "right", + c = "center") + + # Bold the text if this is a summary + if (is.summary[i]) { + x <- switch(txt_align, + 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] + 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 + # 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] + } + 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]] <- + 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_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/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..37d6e34 --- /dev/null +++ b/R/private_prepLabelText.R @@ -0,0 +1,116 @@ +#' 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_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 <- sapply(labeltext, + function(x) { + if (is.list(x)) { + return(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") + } + + # Can't figure out multiple levels of expressions + nc <- length(labeltext) + + widthcolumn <- c() + # Should mark the columns that don't contain + # 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]])) { + 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_nr <- length(labeltext[[1]]) + } else if (is.vector(labeltext)) { + widthcolumn <- c(FALSE) + nc <- 1 + label_nr <- length(labeltext) + + labeltext <- list(as.list(labeltext)) + } else { + # Original code for matrixes + 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) { + 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, + 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, ...) +{ + # 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) && + (is.na(row_column_text) || + is.null(row_column_text))) { + return("") + } + + return(row_column_text) +} diff --git a/R/text_styling.R b/R/text_styling.R new file mode 100644 index 0000000..ccfe0b5 --- /dev/null +++ b/R/text_styling.R @@ -0,0 +1,124 @@ +#' 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 +#' @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) { + 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 b085474..74b33db 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, @@ -19,14 +19,13 @@ 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 -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 +33,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 +44,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, @@ -63,49 +68,33 @@ 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), 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"), @@ -114,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, 3), 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_decorate_graph_example.R b/inst/examples/fp_decorate_graph_example.R new file mode 100644 index 0000000..a1ce0cd --- /dev/null +++ b/inst/examples/fp_decorate_graph_example.R @@ -0,0 +1,26 @@ +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", + 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/inst/examples/fp_insert_row_example.R b/inst/examples/fp_insert_row_example.R new file mode 100644 index 0000000..1579bcc --- /dev/null +++ b/inst/examples/fp_insert_row_example.R @@ -0,0 +1,23 @@ +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_append_row(mean = 0.531, + lower = 0.386, + upper = 0.731, + study = "Summary", + OR = "0.53", + is.summary = TRUE) 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/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/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 55db474..b3b98ab 100644 --- a/man/forestplot.Rd +++ b/man/forestplot.Rd @@ -12,62 +12,62 @@ \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, mean, lower, upper, - align, + align = NULL, is.summary = FALSE, graph.pos = "right", - hrzl_lines, + hrzl_lines = NULL, clip = c(-Inf, Inf), - xlab = "", + xlab = NULL, 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(), ... ) \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, ...) +\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 } } @@ -291,7 +289,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, @@ -299,14 +297,13 @@ 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 -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, @@ -343,49 +346,33 @@ 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), 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"), @@ -394,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, 3), 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..4c8da9e 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 @@ -56,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. 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/fp_decorate_graph.Rd b/man/fp_decorate_graph.Rd new file mode 100644 index 0000000..bfe40e7 --- /dev/null +++ b/man/fp_decorate_graph.Rd @@ -0,0 +1,76 @@ +% 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, + right_bottom_txt = NULL, + left_bottom_txt = NULL, + right_top_txt = NULL, + left_top_txt = 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.} + +\item{right_bottom_txt}{Text to appear at the right bottom of the graph. Can +be decorated fp_txt_* functions.} + +\item{left_bottom_txt}{Text to appear at the left 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{left_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 +} +\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", + 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: +\code{\link{fp_insert_row}()}, +\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/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/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/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 3c478df..f490a7f 100644 --- a/man/prFpGetConfintFnList.Rd +++ b/man/prFpGetConfintFnList.Rd @@ -4,18 +4,18 @@ \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 -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.} \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} @@ -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/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..d9e64a6 100644 --- a/man/prFpGetLayoutVP.Rd +++ b/man/prFpGetLayoutVP.Rd @@ -2,9 +2,9 @@ % 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, 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 @@ -14,17 +14,15 @@ 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} -\item{nr}{Number of rows} - \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/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..49d8455 --- /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 \code{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/prPopulateList.Rd b/man/prPopulateList.Rd index c196fa8..58492f4 100644 --- a/man/prPopulateList.Rd +++ b/man/prPopulateList.Rd @@ -4,18 +4,18 @@ \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 -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.} \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} @@ -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 new file mode 100644 index 0000000..136f1e0 --- /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 \verb{"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..7ac1fe8 --- /dev/null +++ b/man/prepGridMargins.Rd @@ -0,0 +1,23 @@ +% 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: +\itemize{ +\item 1 = bottom +\item 2 = left +\item 3 = top +\item 4 = right +}} +} +\value{ +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 new file mode 100644 index 0000000..8bec90f --- /dev/null +++ b/man/prepLabelText.Rd @@ -0,0 +1,45 @@ +% 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 \code{expression}, \code{list} +\code{vector} or \code{matrix}} + +\item{nr}{The number of rows} + +\item{x}{A \code{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 \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 +} +\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 new file mode 100644 index 0000000..3d403c0 --- /dev/null +++ b/man/row_manipulation.Rd @@ -0,0 +1,81 @@ +% 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/append rows into forestplot} +\usage{ +fp_insert_row( + x, + ..., + mean = NULL, + lower = NULL, + upper = NULL, + position = 1, + is.summary = FALSE, + boxsize = NA +) + +fp_add_header(x, ..., position = 1, is.summary = TRUE) + +fp_append_row(x, ..., position = "last", is.summary = FALSE) +} +\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.} + +\item{boxsize}{The box size for the drawn estimate line} +} +\value{ +The foresplot object with the added rows +} +\description{ +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::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_append_row(mean = 0.531, + lower = 0.386, + upper = 0.731, + study = "Summary", + OR = "0.53", + is.summary = TRUE) +} +\seealso{ +Other graph modifiers: +\code{\link{fp_decorate_graph}()}, +\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 new file mode 100644 index 0000000..579279f --- /dev/null +++ b/man/style_manipulation.Rd @@ -0,0 +1,102 @@ +% 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"))) +} +\seealso{ +Other graph modifiers: +\code{\link{fp_decorate_graph}()}, +\code{\link{fp_insert_row}()}, +\code{\link{fp_set_zebra_style}()} +} +\concept{graph modifiers} diff --git a/man/text_styling.Rd b/man/text_styling.Rd new file mode 100644 index 0000000..6b544b7 --- /dev/null +++ b/man/text_styling.Rd @@ -0,0 +1,40 @@ +% 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_txt_gp} +\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_txt_gp(txt, gp) + +fp_align_left(txt) + +fp_align_center(txt) + +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 +} +\description{ +This is a collection of functions to allow styling of text +} +\examples{ +fp_txt_italic("Italic text") +} 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) 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/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/testthat/test-forestplot.group_df.R b/tests/testthat/test-forestplot.group_df.R new file mode 100644 index 0000000..5142e94 --- /dev/null +++ b/tests/testthat/test-forestplot.group_df.R @@ -0,0 +1,79 @@ +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$estimates[,1,], + lapply(HRQoL, \(x) x[,"coef"]) |> do.call(cbind, args = _)) +}) + + +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(), + 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$estimates[,1,1], + HRQoL[[1]][,"coef"]) + expect_scalar_na(out$estimates[1,1,2]) + expect_equivalent(out$estimates[2:4,1,2], + HRQoL[[2]][2:4,"coef"]) +}) 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..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) @@ -9,7 +8,7 @@ test_that("Check different input formats", { abind(basic_data, basic_data + 1, along = 3 - ) %>% + ) |> forestplot(labeltext = 1:3) ) @@ -17,7 +16,7 @@ test_that("Check different input formats", { abind(basic_data, basic_data + 1, along = 3 - ) %>% + ) |> forestplot() ) @@ -52,7 +51,7 @@ test_that("Check different input formats", { abind(basic_data, cbind(0:2, 3:1, 2:4), along = 3 - ) %>% + ) |> forestplot() ) }) 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/tests/vtest_from_vignette.R b/tests/vtest_from_vignette.R index bd2546a..eeb0e65 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, @@ -155,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") ## ------------------------------------------------------------------------ @@ -243,50 +241,50 @@ 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" ) ## ---- eval=FALSE, echo=TRUE---------------------------------------------- @@ -297,3 +295,4 @@ forestplot(tabletext, # structure(c(-.1, -.05, .05), # gp = gpar(lty = 2, col = "#CCCCFF"))) # # Returns TRUE + diff --git a/vignettes/forestplot.Rmd b/vignettes/forestplot.Rmd index 5226b35..5c8d7e5 100644 --- a/vignettes/forestplot.Rmd +++ b/vignettes/forestplot.Rmd @@ -49,81 +49,46 @@ Text A forest plot is closely connected to text and the ability to customize the text is central. -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} +```{r} 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") - -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. +Table of text +------------- -```{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")) +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} +# Cochrane data from the 'rmeta'-package +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_set_style(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) |> + fp_set_zebra_style("#EFEFEF") ``` Summary lines @@ -132,31 +97,50 @@ 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), - 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 @@ -165,18 +149,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 @@ -185,16 +178,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 @@ -204,18 +209,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") %>% - bind_rows(tibble(mean = NA_real_), .) %>% - forestplot(labeltext = tabletext, - col = clrs, - xlab = "EQ-5D index") + +dfHRQoL |> + filter(group == "Sweden") |> + 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 @@ -229,27 +232,35 @@ font <- "mono" if (grepl("Ubuntu", Sys.info()["version"])) { font <- "HersheyGothicEnglish" } -dfHRQoL %>% - filter(group == "Sweden") %>% +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: ```{r} -dfHRQoL %>% - filter(group == "Sweden") %>% +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 @@ -258,12 +269,15 @@ 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") |> + 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 @@ -272,18 +286,39 @@ 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") |> + 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") @@ -297,14 +332,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)) @@ -312,15 +343,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) ``` @@ -331,33 +357,32 @@ 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")), - 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 ------------------ 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")), - 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. @@ -368,15 +393,16 @@ 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 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)) ``` @@ -386,22 +412,22 @@ 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 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: ```{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")), @@ -409,8 +435,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"))) ``` @@ -420,15 +446,15 @@ 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 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: @@ -438,15 +464,15 @@ 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 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 @@ -454,32 +480,32 @@ 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 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: ```{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), - 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: