diff --git a/.Rbuildignore b/.Rbuildignore index e6e2ad9930..8b0acebf7e 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -22,6 +22,7 @@ LICENSE # pkgdown ^_pkgdown\.yml$ pkgdown +^pkgdown$ # rstudio ^.*\.Rproj$ diff --git a/.github/ISSUE_TEMPLATE/cran-release.yaml b/.github/ISSUE_TEMPLATE/cran-release.yaml index 49a81e67c5..bab34fcff5 100644 --- a/.github/ISSUE_TEMPLATE/cran-release.yaml +++ b/.github/ISSUE_TEMPLATE/cran-release.yaml @@ -29,12 +29,13 @@ body: validations: required: true - type: textarea - id: pre-requisites + id: pre-release attributes: - label: Pre-requisites + label: Pre-release description: Pre-requisites that must be fulfilled before initiating the release process. placeholder: Add your list of pre-requisites here. value: | + - [ ] Make sure you adhere to CRAN submission policy: https://cran.r-project.org/web/packages/submission_checklist.html; https://cran.r-project.org/web/packages/policies.html. - [ ] Make sure that high priority bugs (label "priority" + "bug") have been resolved before going into the release. - [ ] Review old/hanging PRs before going into the release (Optional). - [ ] Revisit R-package's lifecycle badges (Optional). @@ -42,54 +43,76 @@ body: - [ ] Make sure integration tests are green 2-3 days before the release. Look carefully through logs (check for warnings and notes). - [ ] Decide what gets merged in before starting release activities. - type: textarea - id: release-checklist + id: release attributes: - label: Release Checklist + label: Release description: The steps to be taken in order to create a release. placeholder: Steps to create a release. value: | + ### Prepare the release + + - [ ] Create a new release candidate branch + `git checkout -b release-candidate-vX.Y.Z` - [ ] Update NEWS.md file: make sure it reflects a holistic summary of what has changed in the package. - - [ ] Remove the additional fields (`Remotes` and `Config/Needs/*`) from the DESCRIPTION file where applicable. - - [ ] Increase versioned dependency on {package name} to >=X.X.X (Optional). + - [ ] Remove the additional fields (`Remotes`) from the DESCRIPTION file where applicable. - [ ] Make sure that the minimum dependency versions are updated in the DESCRIPTION file for the package and its reverse dependencies (Optional). - - [ ] Create a pull request to make necessary bug fixes/changes (add "[skip vbump]" in the pr title), and after merging the PR, tag the update(s) as a release candidate v < intended release version > -rc < release candidate iteration > on the main branch. + - [ ] Increase versioned dependency on {package name} to >=X.Y.Z (Optional). + - [ ] Commit your changes and create the PR on GitHub (add "[skip vbump]" in the PR title). Add all updates, commit, and push changes: + `# Make the necessary modifications to your files + # Stage the changes + git add + # Commit the changes + git commit -m "[skip vbump] " + git push origin release-candidate-vX.Y.Z` + + ### Test the release + + - [ ] Execute the manual tests on Shiny apps that are deployed on various hosting providers (Posit connect and shinyapps.io) - track the results in GitHub issue (Applicable only for frameworks that use Shiny). + - [ ] Monitor integration tests, if integration fails, create priority issues on the board. + - [ ] Execute UAT tests (Optional). + + ### CRAN submission + + - [ ] Tag the update(s) as a release candidate vX.Y.Z-rc (e.g. v0.5.3-rc1) on the release candidate branch (release-candidate-vX.Y.Z). + `# Create rc tag for submission for internal validation + git tag vX.Y.Z-rc + git push origin vX.Y.Z-rc` - [ ] Build the package locally using the command:`R CMD build .` which will generate a .tar.gz file necessary for the CRAN submission. - - [ ] Submit the package that was build in the previous step via this form: https://cran.r-project.org/submit.html. - - [ ] Address CRAN feedback, tag the package vX.X.X-rc(n+1) and repeat the submission to CRAN whenever necessary. + - [ ] Submit the package to https://win-builder.r-project.org/upload.aspx for testing, for more details please see "Building and checking R source packages for Windows": https://win-builder.r-project.org/. + - [ ] Once tested, send the package that was built in the previous steps to CRAN via this form: https://cran.r-project.org/submit.html. + - [ ] Address CRAN feedback, tag the package vX.Y.Z-rc(n+1) and repeat the submission to CRAN whenever necessary. - [ ] Get the package accepted and published on CRAN. - - [ ] If the additional fields were removed, add them back in a separate PR, and then merge the PR back to main. Note: Take precautionary measures to ensure that the version bump does not take place on a merge. - - [ ] Create a git tag with the final version set to X.X.X on the main branch. - - type: textarea - id: testing - attributes: - label: Testing - description: Summary of testing activities - integration tests, UAT, other - placeholder: Tests results - value: | - - [ ] Integration tests results - accepted. - - [ ] UAT results - accepted. - - [ ] All testing activities are finalized. - - type: textarea - id: feedback - attributes: - label: Release Feedback - description: Feedback received from CRAN/testers. - placeholder: Feedback to be implemented after CRAN submission/testing. - value: | - - [ ] Fix 1 - - [ ] Enhancement 1 - - [ ] Defect 1 + + ### Tag the release + + - [ ] If the additional fields were removed, add them back in a separate PR, and then merge the PR back to main (add "[skip vbump]" in the PR title). If nothing was removed just merge the PR you created in the "Prepare the release" section to 'main'. Note the commit hash of the merged commit. **Note:** additional commits might be added to the `main` branch by a bot or an automation - we do **NOT** want to tag this commit. + + ### Make sure of the following before continuing + + - [ ] CI checks are passing in GH before releasing the package. + - [ ] Shiny apps are deployable and there are no errors/warnings (Applicable only for frameworks that use Shiny). + + - [ ] Create a git tag with the final version set to vX.Y.Z on the main branch. In order to do this: + 1. Checkout the commit hash. + `git checkout ` + 2. Tag the hash with the release version (vX.Y.Z). + `git tag vX.Y.Z` + 3. Push the tag to make the final release. + `git push origin vX.Y.Z` + - [ ] Update downstream package dependencies to (>=X.Y.Z) in {package name}. + Note: Once the release tag is created, the package is automatically published to internal repositories. - type: textarea id: post-release attributes: - label: Post-release Checklist + label: Post-release description: The list of activities to be completed after the release. placeholder: The steps that must be taken after the release. value: | + - [ ] Ensure that CRAN checks are passing for the package. - [ ] Make sure that the package is published to internal repositories. + - [ ] Make sure internal documentation is up to date. - [ ] Review and update installation instructions for the package wherever needed (Optional). - [ ] Update all integration tests to reference the new release. - - [ ] Ensure a new dev version (.9XXX) is added to the NEWS.md file and DESCRIPTION file as a placeholder for release notes. - [ ] Announce the release on ________. - type: textarea id: decision-tree diff --git a/.github/ISSUE_TEMPLATE/release.yaml b/.github/ISSUE_TEMPLATE/release.yaml index 1d97dff5a3..73bb11dc88 100644 --- a/.github/ISSUE_TEMPLATE/release.yaml +++ b/.github/ISSUE_TEMPLATE/release.yaml @@ -28,72 +28,87 @@ body: validations: required: true - type: textarea - id: pre-requisites + id: pre-release attributes: - label: Pre-requisites + label: Pre-release description: Pre-requisites that must be fulfilled before initiating the release process. placeholder: Add your list of pre-requisites here. value: | - [ ] Make sure that high priority bugs (label "priority" + "bug") have been resolved before going into the release. - [ ] Review old/hanging PRs before going into the release. - [ ] Revisit R-package's lifecycle badges (Optional). - - [ ] Discuss package dependencies before going into release activities. - - [ ] Create a plan to sequentially close release activities and submit groups of packages for internal validation (Applicable only for regulatory release). + - [ ] Release Manager: Discuss package dependencies, create a plan to sequentially close release activities and submit groups of packages for internal validation (Applicable only for regulatory release). + - [ ] Check Validation Pipeline dry-run results for the package. - [ ] Make sure all relevant integration tests are green 2-3 days before the release. Look carefully through logs (check for warnings and notes). - - [ ] Check if a package is installable on our supported internal systems (Optional). - [ ] Inform about the soft code freeze, decide what gets merged in before starting release activities. - type: textarea - id: release-checklist + id: release attributes: - label: Release Checklist + label: Release description: The steps to be taken in order to create a release. placeholder: Steps to create a release. value: | - - [ ] Recurring tasks: Execute the manual tests on Shiny apps that are deployed on various hosting providers (Posit connect and shinyapps.io) - track the results in GitHub issue (Applicable only for frameworks that use Shiny). - - [ ] Recurring tasks: Monitor integration tests, if integration fails, create priority issues on the board. - - [ ] Sanity checks for Shiny applications e.g. checking if Shiny apps are deployable and making sure there are no errors/warnings. + ### Prepare the release + + - [ ] Create a new release candidate branch + `git checkout -b release-candidate-vX.Y.Z` - [ ] Update NEWS.md file: make sure it reflects a holistic summary of what has changed in the package, check README. - - [ ] Remove the additional fields (`Remotes` and `Config/Needs/*`) from the DESCRIPTION file where applicable. + - [ ] Remove the additional fields (`Remotes`) from the DESCRIPTION file where applicable. - [ ] Make sure that the minimum dependency versions are updated in the DESCRIPTION file for the package. - - [ ] Increase versioned dependency on {package name} to >=X.X.X. - - [ ] Create a pull request to make necessary bug fixes/changes (add "[skip vbump]" in the PR title), and after merging the PR, tag the update(s) as a release candidate v < intended release version > -rc < release candidate iteration > on the main branch. Note that tags are created in GitHub and synchronized with GitLab automatically. - - [ ] The package is submitted for internal validation by Release Coordinator (Applicable only for regulatory release). - - [ ] Address any feedback (internal validation/user testing), retag the package as a release candidate vX.X.X-rc(n+1). Repeat the submission for internal validation if necessary. - - [ ] Get the package validated (Applicable only for regulatory release). - - [ ] If the additional fields were removed, add them back in a separate PR, and then merge the PR back to main (add "[skip vbump]" in the PR title). - - [ ] Create a git tag with the final version set to X.X.X on the main branch. - - [ ] Update downstream package dependencies to (>=X.X.X) in {package name}. - - type: textarea - id: testing - attributes: - label: Testing - description: Summary of testing activities - integration tests, UAT, other. - placeholder: Tests results - value: | - - [ ] Integration tests results - accepted. - - [ ] UAT results - accepted. - - [ ] Shiny apps test results - accepted (Applicable only for Shiny apps). - - [ ] Necessary testing on target environment - performed (up to ETL). - - type: textarea - id: feedback - attributes: - label: Release Feedback - description: Feedback received from internal validation/UAT testers. - placeholder: Feedback to be implemented after submission for internal validation/testing. - value: | - - [ ] Fix 1 - - [ ] Enhancement 1 - - [ ] Defect 1 + - [ ] Increase versioned dependency on {package name} to >=X.Y.Z. + - [ ] Commit your changes and create the PR on GitHub (add "[skip vbump]" in the PR title). Add all updates, commit, and push changes: + `# Make the necessary modifications to your files + # Stage the changes + git add + # Commit the changes + git commit -m "[skip vbump] " + git push origin release-candidate-vX.Y.Z` + + ### Test the release + + - [ ] Execute the manual tests on Shiny apps that are deployed on various hosting providers (Posit connect and shinyapps.io) - track the results in GitHub issue (Applicable only for frameworks that use Shiny). + - [ ] Monitor integration tests, if integration fails, create priority issues on the board. + - [ ] Execute UAT tests (Optional). + + ### Validation loop + + Note: This section is applicable only for regulatory packages. + + - [ ] Tag the update(s) as a release candidate vX.Y.Z-rc (e.g. v0.5.3-rc1) on the release candidate branch (release-candidate-vX.Y.Z). + `# Create rc tag for submission for internal validation + git tag vX.Y.Z-rc + git push origin vX.Y.Z-rc` + - [ ] Submit the package for internal validation. + - [ ] Address any feedback (internal validation/user testing), retag the package as a release candidate vX.Y.Z-rc(n+1). Repeat the submission for internal validation if necessary. + - [ ] Get the package validated. + + ### Tag the release + + - [ ] If the additional fields were removed, add them back in a separate PR, and then merge the PR back to main (add "[skip vbump]" in the PR title). If nothing was removed just merge the PR you created in the "Prepare the release" section to `main`. Note the commit hash of the merged commit. **Note:** additional commits might be added to the `main` branch by a bot or an automation - we do **NOT** want to tag this commit. + + #### Make sure of the following before continuing with the release: + + - [ ] CI checks are passing in GH. + - [ ] Shiny apps are deployable and there are no errors/warnings (Applicable only for frameworks that use Shiny). + + - [ ] Create a git tag with the final version set to vX.Y.Z on the main branch. In order to do this: + 1. Checkout the commit hash. + `git checkout ` + 2. Tag the hash with the release version (vX.Y.Z). + `git tag vX.Y.Z` + 3. Push the tag to make the final release. + `git push origin vX.Y.Z` + - [ ] Update downstream package dependencies to (>=X.Y.Z) in {package name}. + Note: Once the release tag is created, the package is automatically published to internal repositories. - type: textarea id: post-release attributes: - label: Post-release Checklist + label: Post-release description: The list of activities to be completed after the release. placeholder: The steps that must be taken after the release. value: | - [ ] Make sure that the package is published to internal repositories (Validated and/or Non-Validated repository). - [ ] Review and update installation instructions for the package if needed. - - [ ] Verify if a new dev version (.9XXX) has been added to the NEWS.md file and DESCRIPTION file as a placeholder for release notes by automation. - [ ] Make sure internal documentation/documentation catalogs are up to date. - [ ] Notify the IDR team to start post-release/clean-up activities. - [ ] Announce the release on ________. diff --git a/.github/workflows/check.yaml b/.github/workflows/check.yaml index 52f6c2a8a5..00485be494 100644 --- a/.github/workflows/check.yaml +++ b/.github/workflows/check.yaml @@ -37,6 +37,7 @@ jobs: checking S3 generic/method consistency .* NOTE checking Rd .usage sections .* NOTE checking for unstated dependencies in vignettes .* NOTE + checking top-level files .* NOTE unit-test-report-brand: >- https://raw.githubusercontent.com/insightsengineering/hex-stickers/main/thumbs/tern.png coverage: diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml index 1786fbf5ed..b623ff6482 100644 --- a/.github/workflows/release.yaml +++ b/.github/workflows/release.yaml @@ -52,6 +52,7 @@ jobs: checking R code for possible problems .* NOTE checking examples .* NOTE checking Rd line widths .* NOTE + checking top-level files .* NOTE unit-test-report-brand: >- https://raw.githubusercontent.com/insightsengineering/hex-stickers/main/thumbs/tern.png coverage: diff --git a/.pre-commit-config.yaml b/.pre-commit-config.yaml index d7f7c94ffa..9ff0944acc 100644 --- a/.pre-commit-config.yaml +++ b/.pre-commit-config.yaml @@ -52,9 +52,9 @@ repos: .*\.sh| .*\.svg| .*\.xml| - (.*/|)\_pkgdown.y[a]ml| + (.*/|)\_pkgdown.y[a]?ml| (.*/|)\.gitignore| - (.*/|)\.gitlab-ci\.yml| + (.*/|)\.gitlab-ci\.y[a]?ml| (.*/|)\.lintr| (.*/|)\.pre-commit-.*| (.*/|)\.Rbuildignore| @@ -64,8 +64,8 @@ repos: (.*/|)DESCRIPTION| (.*/|)LICENSE| (.*/|)NAMESPACE| - (.*/|)staged_dependencies\.yaml| + (.*/|)staged_dependencies\.y[a]?ml| (.*/|)WORDLIST| - \.github/.*\.yaml| + \.github/.*\.y[a]?ml| data/.* )$ diff --git a/DESCRIPTION b/DESCRIPTION index e01671eb04..d5a930fb26 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: tern Title: Create Common TLGs Used in Clinical Trials -Version: 0.9.3.9000 -Date: 2023-12-08 +Version: 0.9.3.9001 +Date: 2023-12-13 Authors@R: c( person("Joe", "Zhu", , "joe.zhu@roche.com", role = c("aut", "cre")), person("Daniel", "Sabanés Bové", , "daniel.sabanes_bove@roche.com", role = "aut"), diff --git a/NEWS.md b/NEWS.md index d748281afa..032c210e52 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,13 @@ -# tern 0.9.3.9000 +# tern 0.9.3.9001 + +### New Features +* Refactored `g_forest` to output a `ggplot` object instead of a `grob` object. + +### Bug Fixes +* Fixed nested column split label overlay issue in `rtable2gg` to clean up appearance of text labels. + +### Miscellaneous +* Added function `expect_snapshot_ggplot` to test setup file to process plot snapshot tests and allow plot dimensions to be set. # tern 0.9.3 diff --git a/R/g_forest.R b/R/g_forest.R index 1c965a4fad..5a2c116d3c 100644 --- a/R/g_forest.R +++ b/R/g_forest.R @@ -1,40 +1,55 @@ -#' Create a Forest Plot based on a Table +#' Create a forest plot from an `rtable` #' -#' Create a forest plot from any [rtables::rtable()] object that has a -#' column with a single value and a column with 2 values. +#' Given a [rtables::rtable()] object with at least one column with a single value and one column with 2 +#' values, converts table to a [ggplot2::ggplot()] object and generates an accompanying forest plot. The +#' table and forest plot are printed side-by-side. #' #' @description `r lifecycle::badge("stable")` #' -#' @inheritParams grid::gTree +#' @inheritParams rtable2gg #' @inheritParams argument_convention -#' @param tbl (`rtable`) +#' @param tbl (`rtable`)\cr table with at least one column with a single value and one column with 2 values. #' @param col_x (`integer`)\cr column index with estimator. By default tries to get this from -#' `tbl` attribute `col_x`, otherwise needs to be manually specified. -#' @param col_ci (`integer`)\cr column index with confidence intervals. By default tries -#' to get this from `tbl` attribute `col_ci`, otherwise needs to be manually specified. -#' @param vline (`number`)\cr x coordinate for vertical line, if `NULL` then the line is omitted. +#' `tbl` attribute `col_x`, otherwise needs to be manually specified. If `NULL`, points will be excluded +#' from forest plot. +#' @param col_ci (`integer`)\cr column index with confidence intervals. By default tries to get this from +#' `tbl` attribute `col_ci`, otherwise needs to be manually specified. If `NULL`, lines will be excluded +#' from forest plot. +#' @param vline (`numeric`)\cr x coordinate for vertical line, if `NULL` then the line is omitted. #' @param forest_header (`character`, length 2)\cr text displayed to the left and right of `vline`, respectively. -#' If `vline = NULL` then `forest_header` needs to be `NULL` too. -#' By default tries to get this from `tbl` attribute `forest_header`. +#' If `vline = NULL` then `forest_header` is not printed. By default tries to get this from `tbl` attribute +#' `forest_header`. If `NULL`, defaults will be extracted from the table if possible, and set to +#' `"Comparison\nBetter"` and `"Treatment\nBetter"` if not. #' @param xlim (`numeric`)\cr limits for x axis. #' @param logx (`flag`)\cr show the x-values on logarithm scale. -#' @param x_at (`numeric`)\cr x-tick locations, if `NULL` they get automatically chosen. -#' @param width_row_names (`unit`)\cr width for row names. -#' If `NULL` the widths get automatically calculated. See [grid::unit()]. -#' @param width_columns (`unit`)\cr widths for the table columns. -#' If `NULL` the widths get automatically calculated. See [grid::unit()]. -#' @param width_forest (`unit`)\cr width for the forest column. -#' If `NULL` the widths get automatically calculated. See [grid::unit()]. +#' @param x_at (`numeric`)\cr x-tick locations, if `NULL`, `x_at` is set to `vline` and both `xlim` values. +#' @param width_row_names `r lifecycle::badge("deprecated")` Please use the `lbl_col_padding` argument instead. +#' @param width_columns (`vector` of `numeric`)\cr a vector of column widths. Each element's position in +#' `colwidths` corresponds to the column of `tbl` in the same position. If `NULL`, column widths are calculated +#' according to maximum number of characters per column. +#' @param width_forest `r lifecycle::badge("deprecated")` Please use the `rel_width_forest` argument instead. +#' @param rel_width_forest (`proportion`)\cr proportion of total width to allocate to the forest plot. Relative +#' width of table is then `1 - rel_width_forest`. If `as_list = TRUE`, this parameter is ignored. +#' @param font_size (`numeric`)\cr font size. #' @param col_symbol_size (`integer`)\cr column index from `tbl` containing data to be used #' to determine relative size for estimator plot symbol. Typically, the symbol size is proportional #' to the sample size used to calculate the estimator. If `NULL`, the same symbol size is used for all subgroups. #' By default tries to get this from `tbl` attribute `col_symbol_size`, otherwise needs to be manually specified. #' @param col (`character`)\cr color(s). +#' @param ggtheme (`theme`)\cr a graphical theme as provided by `ggplot2` to control styling of the plot. +#' @param as_list (`flag`)\cr whether the two `ggplot` objects should be returned as a list. If `TRUE`, a named list +#' with two elements, `table` and `plot`, will be returned. If `FALSE` (default) the table and forest plot are +#' printed side-by-side via [cowplot::plot_grid()]. +#' @param gp `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument +#' is no longer used. +#' @param draw `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument +#' is no longer used. +#' @param newpage `r lifecycle::badge("deprecated")` `g_forest` is now generated as a `ggplot` object. This argument +#' is no longer used. #' -#' @return `gTree` object containing the forest plot and table. +#' @return `ggplot` forest plot and table. #' #' @examples -#' \donttest{ #' library(dplyr) #' library(forcats) #' library(nestcolor) @@ -61,22 +76,17 @@ #' #' tbl <- basic_table() %>% #' tabulate_rsp_subgroups(df) -#' p <- g_forest(tbl, gp = grid::gpar(fontsize = 10)) -#' -#' draw_grob(p) +#' g_forest(tbl) #' #' # Odds ratio only table. #' #' tbl_or <- basic_table() %>% #' tabulate_rsp_subgroups(df, vars = c("n_tot", "or", "ci")) -#' tbl_or -#' p <- g_forest( +#' g_forest( #' tbl_or, #' forest_header = c("Comparison\nBetter", "Treatment\nBetter") #' ) #' -#' draw_grob(p) -#' #' # Survival forest plot example. #' adtte <- tern_ex_adtte #' # Save variable labels before data processing steps. @@ -112,6 +122,7 @@ #' table_hr <- basic_table() %>% #' tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1]) #' g_forest(table_hr) +#' #' # Works with any `rtable`. #' tbl <- rtable( #' header = c("E", "CI", "N"), @@ -126,6 +137,7 @@ #' x_at = c(0.5, 1, 2), #' col_symbol_size = 3 #' ) +#' #' tbl <- rtable( #' header = rheader( #' rrow("", rcell("A", colspan = 2)), @@ -143,7 +155,6 @@ #' vline = 1, #' forest_header = c("Hello", "World") #' ) -#' } #' #' @export g_forest <- function(tbl, @@ -154,105 +165,270 @@ g_forest <- function(tbl, xlim = c(0.1, 10), logx = TRUE, x_at = c(0.1, 1, 10), - width_row_names = NULL, + width_row_names = lifecycle::deprecated(), width_columns = NULL, - width_forest = grid::unit(1, "null"), + width_forest = lifecycle::deprecated(), + lbl_col_padding = 0, + rel_width_forest = 0.25, + font_size = 12, col_symbol_size = attr(tbl, "col_symbol_size"), col = getOption("ggplot2.discrete.colour")[1], - gp = NULL, - draw = TRUE, - newpage = TRUE) { + ggtheme = NULL, + as_list = FALSE, + gp = lifecycle::deprecated(), + draw = lifecycle::deprecated(), + newpage = lifecycle::deprecated()) { + # Deprecated argument warnings + if (lifecycle::is_present(width_row_names)) { + lifecycle::deprecate_warn( + "0.9.3", "g_forest(width_row_names)", "g_forest(lbl_col_padding)", + details = "The width of the row label column can be adjusted via the `lbl_col_padding` parameter." + ) + } + if (lifecycle::is_present(width_forest)) { + lifecycle::deprecate_warn( + "0.9.3", "g_forest(width_forest)", "g_forest(rel_width_forest)", + details = "Relative width of the forest plot (as a proportion) can be set via the `rel_width_forest` parameter." + ) + } + if (lifecycle::is_present(gp)) { + lifecycle::deprecate_warn( + "0.9.3", "g_forest(gp)", "g_forest(ggtheme)", + details = paste( + "`g_forest` is now generated as a `ggplot` object.", + "Additional display settings should be supplied via the `ggtheme` parameter." + ) + ) + } + if (lifecycle::is_present(draw)) { + lifecycle::deprecate_warn( + "0.9.3", "g_forest(draw)", + details = "`g_forest` now generates `ggplot` objects. This parameter has no effect." + ) + } + if (lifecycle::is_present(newpage)) { + lifecycle::deprecate_warn( + "0.9.3", "g_forest(newpage)", + details = "`g_forest` now generates `ggplot` objects. This parameter has no effect." + ) + } + checkmate::assert_class(tbl, "VTableTree") + checkmate::assert_number(col_x, lower = 0, upper = ncol(tbl), null.ok = TRUE) + checkmate::assert_number(col_ci, lower = 0, upper = ncol(tbl), null.ok = TRUE) + checkmate::assert_number(col_symbol_size, lower = 0, upper = ncol(tbl), null.ok = TRUE) + checkmate::assert_number(font_size, lower = 0) + checkmate::assert_character(col, null.ok = TRUE) + checkmate::assert_true(is.null(col) | length(col) == 1 | length(col) == nrow(tbl)) + + # Extract info from table + mat <- matrix_form(tbl) + mat_strings <- formatters::mf_strings(mat) + nlines_hdr <- formatters::mf_nlheader(mat) + nrows_body <- nrow(mat_strings) - nlines_hdr + tbl_stats <- mat_strings[nlines_hdr, -1] + + # Generate and modify table as ggplot object + gg_table <- rtable2gg(tbl, fontsize = font_size, colwidths = width_columns, lbl_col_padding = lbl_col_padding) + + theme(plot.margin = margin(0, 0, 0, 0.025, "npc")) + gg_table$scales$scales[[1]]$expand <- c(0.01, 0.01) + gg_table$scales$scales[[2]]$limits[2] <- nrow(mat_strings) + 1 + if (nlines_hdr == 2) { + gg_table$scales$scales[[2]]$expand <- c(0, 0) + arms <- unique(mat_strings[1, ][nzchar(trimws(mat_strings[1, ]))]) + } else { + arms <- NULL + } - nr <- nrow(tbl) - nc <- ncol(tbl) - if (is.null(col)) { - col <- "blue" + tbl_df <- as_result_df(tbl) + dat_cols <- seq(which(names(tbl_df) == "node_class") + 1, ncol(tbl_df)) + tbl_df <- tbl_df[, c(which(names(tbl_df) == "row_num"), dat_cols)] + names(tbl_df) <- c("row_num", tbl_stats) + + # Check table data columns + if (!is.null(col_ci)) { + ci_col <- col_ci + 1 + } else { + tbl_df[["empty_ci"]] <- rep(list(c(NA_real_, NA_real_)), nrow(tbl_df)) + ci_col <- which(names(tbl_df) == "empty_ci") } + if (length(tbl_df[, ci_col][[1]]) != 2) stop("CI column must have two elements (lower and upper limits).") - checkmate::assert_number(col_x, lower = 0, upper = nc, null.ok = FALSE) - checkmate::assert_number(col_ci, lower = 0, upper = nc, null.ok = FALSE) - checkmate::assert_number(col_symbol_size, lower = 0, upper = nc, null.ok = TRUE) - checkmate::assert_true(col_x > 0) - checkmate::assert_true(col_ci > 0) - checkmate::assert_character(col) + if (!is.null(col_x)) { + x_col <- col_x + 1 + } else { + tbl_df[["empty_x"]] <- NA_real_ + x_col <- which(names(tbl_df) == "empty_x") + } if (!is.null(col_symbol_size)) { - checkmate::assert_true(col_symbol_size > 0) + sym_size <- unlist(tbl_df[, col_symbol_size + 1]) + } else { + sym_size <- 1 } - x_e <- vapply(seq_len(nr), function(i) { - # If a label row is selected NULL is returned with a warning (suppressed) - xi <- suppressWarnings(as.vector(tbl[i, col_x, drop = TRUE])) + tbl_df[, c("ci_lwr", "ci_upr")] <- t(sapply(tbl_df[, ci_col], unlist)) + x <- unlist(tbl_df[, x_col]) + lwr <- unlist(tbl_df[["ci_lwr"]]) + upr <- unlist(tbl_df[["ci_upr"]]) + row_num <- nrow(mat_strings) - tbl_df[["row_num"]] - as.numeric(nlines_hdr == 2) - if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) { - xi - } else { - NA_real_ - } - }, numeric(1)) + if (is.null(col)) col <- "#343cff" + if (length(col) == 1) col <- rep(col, nrow(tbl_df)) + if (is.null(x_at)) x_at <- union(xlim, vline) + x_labels <- x_at - x_ci <- lapply(seq_len(nr), function(i) { - xi <- suppressWarnings(as.vector(tbl[i, col_ci, drop = TRUE])) # as above + # Apply log transformation + if (logx) { + x_t <- log(x) + lwr_t <- log(lwr) + upr_t <- log(upr) + xlim_t <- log(xlim) + } else { + x_t <- x + lwr_t <- lwr + upr_t <- upr + xlim_t <- xlim + } - if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) { - if (length(xi) != 2) { - stop("ci column needs two elements") - } - xi + # Set up plot area + gg_plt <- ggplot(data = tbl_df) + + theme( + panel.background = element_rect(fill = "transparent", color = NA_character_), + plot.background = element_rect(fill = "transparent", color = NA_character_), + panel.grid.major = element_blank(), + panel.grid.minor = element_blank(), + axis.title.x = element_blank(), + axis.title.y = element_blank(), + axis.line.x = element_line(), + axis.text = element_text(size = font_size), + legend.position = "none", + plot.margin = margin(0, 0.1, 0.05, 0, "npc") + ) + + scale_x_continuous( + trans = ifelse(logx, "log", "identity"), + limits = xlim, + breaks = x_at, + labels = x_labels, + expand = c(0.01, 0) + ) + + scale_y_continuous( + limits = c(0, nrow(mat_strings) + 1), + breaks = NULL, + expand = c(0, 0) + ) + + coord_cartesian(clip = "off") + + if (is.null(ggtheme)) { + gg_plt <- gg_plt + geom_rect( + data = NULL, + aes( + xmin = xlim[1], + xmax = xlim[2], + ymin = 0, + ymax = nrows_body + 0.5 + ), + fill = "grey92" + ) + } + + if (!is.null(vline)) { + # Set default forest header + if (is.null(forest_header)) { + forest_header <- c( + paste(if (length(arms) == 2) arms[1] else "Comparison", "Better", sep = "\n"), + paste(if (length(arms) == 2) arms[2] else "Treatment", "Better", sep = "\n") + ) + } + + # Add vline and forest header labels + mid_pts <- if (logx) { + c(exp(mean(log(c(xlim[1], vline)))), exp(mean(log(c(vline, xlim[2]))))) } else { - c(NA_real_, NA_real_) + c(mean(c(xlim[1], vline)), mean(c(vline, xlim[2]))) } - }) + gg_plt <- gg_plt + + annotate( + "segment", + x = vline, xend = vline, y = 0, yend = nrows_body + 0.5 + ) + + annotate( + "text", + x = mid_pts[1], y = nrows_body + 1.25, + label = forest_header[1], + size = font_size / .pt, + lineheight = 0.9 + ) + + annotate( + "text", + x = mid_pts[2], y = nrows_body + 1.25, + label = forest_header[2], + size = font_size / .pt, + lineheight = 0.9 + ) + } - lower <- vapply(x_ci, `[`, numeric(1), 1) - upper <- vapply(x_ci, `[`, numeric(1), 2) + # Add points to plot + if (any(!is.na(x_t))) { + x_t[x < xlim[1] | x > xlim[2]] <- NA + gg_plt <- gg_plt + geom_point( + x = x_t, + y = row_num, + color = col, + aes(size = sym_size), + na.rm = TRUE + ) + } - symbol_size <- if (!is.null(col_symbol_size)) { - tmp_symbol_size <- vapply(seq_len(nr), function(i) { - suppressWarnings(xi <- as.vector(tbl[i, col_symbol_size, drop = TRUE])) + for (i in seq_len(nrow(tbl_df))) { + # Determine which arrow(s) to add to CI lines + which_arrow <- c(lwr_t[i] < xlim_t[1], upr_t[i] > xlim_t[2]) + which_arrow <- dplyr::case_when( + all(which_arrow) ~ "both", + which_arrow[1] ~ "first", + which_arrow[2] ~ "last", + TRUE ~ NA + ) - if (!is.null(xi) && !(length(xi) <= 0) && is.numeric(xi)) { - xi + # Add CI lines + gg_plt <- gg_plt + + if (!is.na(which_arrow)) { + annotate( + "segment", + x = if (!which_arrow %in% c("first", "both")) lwr[i] else xlim[1], + xend = if (!which_arrow %in% c("last", "both")) upr[i] else xlim[2], + y = row_num[i], yend = row_num[i], + color = if (length(col) == 1) col else col[i], + arrow = arrow(length = unit(0.05, "npc"), ends = which_arrow), + na.rm = TRUE + ) } else { - NA_real_ + annotate( + "segment", + x = lwr[i], xend = upr[i], + y = row_num[i], yend = row_num[i], + color = if (length(col) == 1) col else col[i], + na.rm = TRUE + ) } - }, numeric(1)) - - # Scale symbol size. - tmp_symbol_size <- sqrt(tmp_symbol_size) - max_size <- max(tmp_symbol_size, na.rm = TRUE) - # Biggest points have radius is 2 * (1/3.5) lines not to overlap. - # See forest_dot_line. - 2 * tmp_symbol_size / max_size - } else { - NULL } - grob_forest <- forest_grob( - tbl, - x_e, - lower, - upper, - vline, - forest_header, - xlim, - logx, - x_at, - width_row_names, - width_columns, - width_forest, - symbol_size = symbol_size, - col = col, - gp = gp, - vp = grid::plotViewport(margins = rep(1, 4)) - ) + # Apply custom ggtheme to plot + if (!is.null(ggtheme)) gg_plt <- gg_plt + ggtheme - if (draw) { - if (newpage) grid::grid.newpage() - grid::grid.draw(grob_forest) + if (as_list) { + list( + table = gg_table, + plot = gg_plt + ) + } else { + cowplot::plot_grid( + gg_table, + gg_plt, + align = "h", + axis = "tblr", + rel_widths = c(1 - rel_width_forest, rel_width_forest) + ) } - - invisible(grob_forest) } #' Forest Plot Grob @@ -497,7 +673,6 @@ forest_grob <- function(tbl, ) } - cell_in_rows <- function(row_name, cells, cell_spans, @@ -699,6 +874,12 @@ forest_viewport <- function(tbl, gap_column = grid::unit(1, "lines"), gap_header = grid::unit(1, "lines"), mat_form = NULL) { + lifecycle::deprecate_warn( + "0.9.3", + "forest_viewport()", + details = "`g_forest` now generates `ggplot` objects. This function is no longer used within `tern`." + ) + checkmate::assert_class(tbl, "VTableTree") checkmate::assert_true(grid::is.unit(width_forest)) if (!is.null(width_row_names)) { diff --git a/R/utils_ggplot.R b/R/utils_ggplot.R index ccd9288e5c..aa4c4dbd84 100644 --- a/R/utils_ggplot.R +++ b/R/utils_ggplot.R @@ -32,10 +32,10 @@ #' #' rtable2gg(tbl) #' -#' rtable2gg(tbl, fontsize = 5, colwidths = c(2, 1, 1, 1)) +#' rtable2gg(tbl, fontsize = 15, colwidths = c(2, 1, 1, 1)) #' #' @export -rtable2gg <- function(tbl, fontsize = 4, colwidths = NULL, lbl_col_padding = 0) { +rtable2gg <- function(tbl, fontsize = 12, colwidths = NULL, lbl_col_padding = 0) { mat <- rtables::matrix_form(tbl) mat_strings <- formatters::mf_strings(mat) mat_aligns <- formatters::mf_aligns(mat) @@ -69,10 +69,11 @@ rtable2gg <- function(tbl, fontsize = 4, colwidths = NULL, lbl_col_padding = 0) theme_void() + scale_x_continuous(limits = c(0, tot_width)) + scale_y_continuous(limits = c(0, nrow(mat_strings))) + - geom_segment(aes( + annotate( + "segment", x = 0, xend = tot_width, y = nrow(mat_strings) - nlines_hdr + 0.5, yend = nrow(mat_strings) - nlines_hdr + 0.5 - )) + ) # If header content spans multiple columns, center over these columns if (length(shared_hdr_rows) > 0) { @@ -95,13 +96,15 @@ rtable2gg <- function(tbl, fontsize = 4, colwidths = NULL, lbl_col_padding = 0) ) res <- res + - geom_text( + annotate( + "text", x = mean(line_pos), y = nrow(mat_strings) + 1 - hr, label = cur_lbl, - size = fontsize + size = fontsize / .pt ) + - geom_segment( + annotate( + "segment", x = line_pos[1], xend = line_pos[2], y = nrow(mat_strings) - hr + 0.5, @@ -113,12 +116,13 @@ rtable2gg <- function(tbl, fontsize = 4, colwidths = NULL, lbl_col_padding = 0) # Add table columns for (i in seq_len(ncol(tbl_df))) { - res <- res + geom_text( + res <- res + annotate( + "text", x = if (i == 1) 0 else sum(colwidths[1:i]) - 0.5 * colwidths[i] + lbl_col_padding, y = rev(seq_len(nrow(tbl_df))), label = tbl_df[, i], hjust = mat_aligns[, i], - size = fontsize + size = fontsize / .pt ) } diff --git a/man/g_forest.Rd b/man/g_forest.Rd index 36d161cd12..eeebbde6e6 100644 --- a/man/g_forest.Rd +++ b/man/g_forest.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/g_forest.R \name{g_forest} \alias{g_forest} -\title{Create a Forest Plot based on a Table} +\title{Create a forest plot from an \code{rtable}} \usage{ g_forest( tbl, @@ -13,45 +13,61 @@ g_forest( xlim = c(0.1, 10), logx = TRUE, x_at = c(0.1, 1, 10), - width_row_names = NULL, + width_row_names = lifecycle::deprecated(), width_columns = NULL, - width_forest = grid::unit(1, "null"), + width_forest = lifecycle::deprecated(), + lbl_col_padding = 0, + rel_width_forest = 0.25, + font_size = 12, col_symbol_size = attr(tbl, "col_symbol_size"), col = getOption("ggplot2.discrete.colour")[1], - gp = NULL, - draw = TRUE, - newpage = TRUE + ggtheme = NULL, + as_list = FALSE, + gp = lifecycle::deprecated(), + draw = lifecycle::deprecated(), + newpage = lifecycle::deprecated() ) } \arguments{ -\item{tbl}{(\code{rtable})} +\item{tbl}{(\code{rtable})\cr table with at least one column with a single value and one column with 2 values.} \item{col_x}{(\code{integer})\cr column index with estimator. By default tries to get this from -\code{tbl} attribute \code{col_x}, otherwise needs to be manually specified.} +\code{tbl} attribute \code{col_x}, otherwise needs to be manually specified. If \code{NULL}, points will be excluded +from forest plot.} -\item{col_ci}{(\code{integer})\cr column index with confidence intervals. By default tries -to get this from \code{tbl} attribute \code{col_ci}, otherwise needs to be manually specified.} +\item{col_ci}{(\code{integer})\cr column index with confidence intervals. By default tries to get this from +\code{tbl} attribute \code{col_ci}, otherwise needs to be manually specified. If \code{NULL}, lines will be excluded +from forest plot.} -\item{vline}{(\code{number})\cr x coordinate for vertical line, if \code{NULL} then the line is omitted.} +\item{vline}{(\code{numeric})\cr x coordinate for vertical line, if \code{NULL} then the line is omitted.} \item{forest_header}{(\code{character}, length 2)\cr text displayed to the left and right of \code{vline}, respectively. -If \code{vline = NULL} then \code{forest_header} needs to be \code{NULL} too. -By default tries to get this from \code{tbl} attribute \code{forest_header}.} +If \code{vline = NULL} then \code{forest_header} is not printed. By default tries to get this from \code{tbl} attribute +\code{forest_header}. If \code{NULL}, defaults will be extracted from the table if possible, and set to +\code{"Comparison\\nBetter"} and \code{"Treatment\\nBetter"} if not.} \item{xlim}{(\code{numeric})\cr limits for x axis.} \item{logx}{(\code{flag})\cr show the x-values on logarithm scale.} -\item{x_at}{(\code{numeric})\cr x-tick locations, if \code{NULL} they get automatically chosen.} +\item{x_at}{(\code{numeric})\cr x-tick locations, if \code{NULL}, \code{x_at} is set to \code{vline} and both \code{xlim} values.} -\item{width_row_names}{(\code{unit})\cr width for row names. -If \code{NULL} the widths get automatically calculated. See \code{\link[grid:unit]{grid::unit()}}.} +\item{width_row_names}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Please use the \code{lbl_col_padding} argument instead.} -\item{width_columns}{(\code{unit})\cr widths for the table columns. -If \code{NULL} the widths get automatically calculated. See \code{\link[grid:unit]{grid::unit()}}.} +\item{width_columns}{(\code{vector} of \code{numeric})\cr a vector of column widths. Each element's position in +\code{colwidths} corresponds to the column of \code{tbl} in the same position. If \code{NULL}, column widths are calculated +according to maximum number of characters per column.} -\item{width_forest}{(\code{unit})\cr width for the forest column. -If \code{NULL} the widths get automatically calculated. See \code{\link[grid:unit]{grid::unit()}}.} +\item{width_forest}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} Please use the \code{rel_width_forest} argument instead.} + +\item{lbl_col_padding}{(\code{numeric})\cr additional padding to use when calculating spacing between +the first (label) column and the second column of \code{tbl}. If \code{colwidths} is specified, +the width of the first column becomes \code{colwidths[1] + lbl_col_padding}. Defaults to 0.} + +\item{rel_width_forest}{(\code{proportion})\cr proportion of total width to allocate to the forest plot. Relative +width of table is then \code{1 - rel_width_forest}. If \code{as_list = TRUE}, this parameter is ignored.} + +\item{font_size}{(\code{numeric})\cr font size.} \item{col_symbol_size}{(\code{integer})\cr column index from \code{tbl} containing data to be used to determine relative size for estimator plot symbol. Typically, the symbol size is proportional @@ -60,27 +76,33 @@ By default tries to get this from \code{tbl} attribute \code{col_symbol_size}, o \item{col}{(\code{character})\cr color(s).} -\item{gp}{A \code{"gpar"} object, typically the output - from a call to the function \code{\link[grid]{gpar}}. This is basically - a list of graphical parameter settings.} +\item{ggtheme}{(\code{theme})\cr a graphical theme as provided by \code{ggplot2} to control styling of the plot.} -\item{draw}{(\code{flag})\cr whether the plot should be drawn.} +\item{as_list}{(\code{flag})\cr whether the two \code{ggplot} objects should be returned as a list. If \code{TRUE}, a named list +with two elements, \code{table} and \code{plot}, will be returned. If \code{FALSE} (default) the table and forest plot are +printed side-by-side via \code{\link[cowplot:plot_grid]{cowplot::plot_grid()}}.} -\item{newpage}{(\code{flag})\cr whether the plot should be drawn on a new page. -Only considered if \code{draw = TRUE} is used.} +\item{gp}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} \code{g_forest} is now generated as a \code{ggplot} object. This argument +is no longer used.} + +\item{draw}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} \code{g_forest} is now generated as a \code{ggplot} object. This argument +is no longer used.} + +\item{newpage}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} \code{g_forest} is now generated as a \code{ggplot} object. This argument +is no longer used.} } \value{ -\code{gTree} object containing the forest plot and table. +\code{ggplot} forest plot and table. } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} } \details{ -Create a forest plot from any \code{\link[rtables:rtable]{rtables::rtable()}} object that has a -column with a single value and a column with 2 values. +Given a \code{\link[rtables:rtable]{rtables::rtable()}} object with at least one column with a single value and one column with 2 +values, converts table to a \code{\link[ggplot2:ggplot]{ggplot2::ggplot()}} object and generates an accompanying forest plot. The +table and forest plot are printed side-by-side. } \examples{ -\donttest{ library(dplyr) library(forcats) library(nestcolor) @@ -107,22 +129,17 @@ df <- extract_rsp_subgroups( tbl <- basic_table() \%>\% tabulate_rsp_subgroups(df) -p <- g_forest(tbl, gp = grid::gpar(fontsize = 10)) - -draw_grob(p) +g_forest(tbl) # Odds ratio only table. tbl_or <- basic_table() \%>\% tabulate_rsp_subgroups(df, vars = c("n_tot", "or", "ci")) -tbl_or -p <- g_forest( +g_forest( tbl_or, forest_header = c("Comparison\nBetter", "Treatment\nBetter") ) -draw_grob(p) - # Survival forest plot example. adtte <- tern_ex_adtte # Save variable labels before data processing steps. @@ -158,6 +175,7 @@ df <- extract_survival_subgroups( table_hr <- basic_table() \%>\% tabulate_survival_subgroups(df, time_unit = adtte_f$AVALU[1]) g_forest(table_hr) + # Works with any `rtable`. tbl <- rtable( header = c("E", "CI", "N"), @@ -172,6 +190,7 @@ g_forest( x_at = c(0.5, 1, 2), col_symbol_size = 3 ) + tbl <- rtable( header = rheader( rrow("", rcell("A", colspan = 2)), @@ -189,6 +208,5 @@ g_forest( vline = 1, forest_header = c("Hello", "World") ) -} } diff --git a/man/rtable2gg.Rd b/man/rtable2gg.Rd index dd96b5d0f6..243ef464c7 100644 --- a/man/rtable2gg.Rd +++ b/man/rtable2gg.Rd @@ -4,7 +4,7 @@ \alias{rtable2gg} \title{Convert \code{rtable} object to \code{ggplot} object} \usage{ -rtable2gg(tbl, fontsize = 4, colwidths = NULL, lbl_col_padding = 0) +rtable2gg(tbl, fontsize = 12, colwidths = NULL, lbl_col_padding = 0) } \arguments{ \item{tbl}{(\code{rtable})\cr a \code{rtable} object.} @@ -44,6 +44,6 @@ tbl <- build_table(lyt, df = dta) rtable2gg(tbl) -rtable2gg(tbl, fontsize = 5, colwidths = c(2, 1, 1, 1)) +rtable2gg(tbl, fontsize = 15, colwidths = c(2, 1, 1, 1)) } diff --git a/tests/testthat/_snaps/g_forest/g-forest-custom.svg b/tests/testthat/_snaps/g_forest/g-forest-custom.svg deleted file mode 100644 index 347699fec9..0000000000 --- a/tests/testthat/_snaps/g_forest/g-forest-custom.svg +++ /dev/null @@ -1,50 +0,0 @@ - - - - - - - - - - - - -A - -c1 -c2 -row 1 -1 -0.8, 1.2 -row 2 -1.2 -1.1, 1.4 - -Hello -World - - - - - - -0.5 -1 -2 - - - - - - - - diff --git a/tests/testthat/_snaps/g_forest/g-forest.svg b/tests/testthat/_snaps/g_forest/g-forest.svg deleted file mode 100644 index 3c1e0223ed..0000000000 --- a/tests/testthat/_snaps/g_forest/g-forest.svg +++ /dev/null @@ -1,113 +0,0 @@ - - - - - - - - - - - - - -A: Drug X - -B: Placebo - - -Baseline Risk Factors -Total n -n -Response (%) -n -Response (%) -Odds Ratio -95% CI -All Patients -20 -11 -72.7% -9 -77.8% -1.31 -(0.17, 10.26) -Sex - F -11 -6 -100.0% -5 -80.0% -<0.01 -(0.00, >999.99) - M -9 -5 -40.0% -4 -75.0% -4.50 -(0.25, 80.57) -Stratification Factor 2 - S1 -10 -5 -80.0% -5 -80.0% -1.00 -(0.05, 22.18) - S2 -10 -6 -66.7% -4 -75.0% -1.50 -(0.09, 25.39) - -A: Drug X -Better -B: Placebo -Better - - - - - - -0.1 -1 -10 - - - - - - - - - - - - - - - - - - - - - - - diff --git a/tests/testthat/_snaps/g_forest/g_forest.svg b/tests/testthat/_snaps/g_forest/g_forest.svg new file mode 100644 index 0000000000..b8127830d8 --- /dev/null +++ b/tests/testthat/_snaps/g_forest/g_forest.svg @@ -0,0 +1,134 @@ + + + + + + + + + + + + + + + + + + + + +A: Drug X + +B: Placebo + +Baseline Risk Factors +All Patients +Sex + F + M +Stratification Factor 2 + S1 + S2 +Total n +20 +11 +9 +10 +10 +n +11 +6 +5 +5 +6 +Response (%) +72.7% +100.0% +40.0% +80.0% +66.7% +n +9 +5 +4 +5 +4 +Response (%) +77.8% +80.0% +75.0% +80.0% +75.0% +Odds Ratio +1.31 +<0.01 +4.50 +1.00 +1.50 +95% CI +(0.17, 10.26) +(0.00, >999.99) +(0.25, 80.57) +(0.05, 22.18) +(0.09, 25.39) + + + + + + + + + + + + + + + + + + + +A: Drug X +Better +B: Placebo +Better + + + + + + + + + + + + + + + + + + + + + +0.1 +1 +10 + + diff --git a/tests/testthat/_snaps/g_forest/g_forest_custom_1.svg b/tests/testthat/_snaps/g_forest/g_forest_custom_1.svg new file mode 100644 index 0000000000..d2baeebc16 --- /dev/null +++ b/tests/testthat/_snaps/g_forest/g_forest_custom_1.svg @@ -0,0 +1,72 @@ + + + + + + + + + + + + + + + + + + + + +A + +row 1 +row 2 +c1 +1 +1.2 +c2 +0.8, 1.2 +1.1, 1.4 + + + + + + + + + + + + + + + + +Hello +World + + + + + + + + +0.5 +1 +2 + + diff --git a/tests/testthat/_snaps/g_forest/g_forest_custom_2.svg b/tests/testthat/_snaps/g_forest/g_forest_custom_2.svg new file mode 100644 index 0000000000..4291776deb --- /dev/null +++ b/tests/testthat/_snaps/g_forest/g_forest_custom_2.svg @@ -0,0 +1,80 @@ + + + + + + + + + + + + + + + + + + + + +A + +row 1 +row 2 +c1 +1 +1.2 +c2 +0.8, 1.2 +1.1, 1.4 + + + + + + + + + + + + + + + + +Comparison +Better +Treatment +Better + + + + + + + + + + + +0.5 +0.7 +0.9 +1.1 +1.3 +1.5 + + diff --git a/tests/testthat/_snaps/g_forest/g_forest_custom_3.svg b/tests/testthat/_snaps/g_forest/g_forest_custom_3.svg new file mode 100644 index 0000000000..8fdf9c335e --- /dev/null +++ b/tests/testthat/_snaps/g_forest/g_forest_custom_3.svg @@ -0,0 +1,76 @@ + + + + + + + + + + + + + + + + + + + + +A + +row 1 +row 2 +c1 +1 +1.2 +c2 +0.8, 1.2 +1.1, 1.4 + + + + + + + + + + + + + + + + +c1 +is +better +c2 +is +better + + + + + + + + +0.5 +1 +2 + + diff --git a/tests/testthat/_snaps/g_forest/g_forest_or.svg b/tests/testthat/_snaps/g_forest/g_forest_or.svg new file mode 100644 index 0000000000..bd5b17519d --- /dev/null +++ b/tests/testthat/_snaps/g_forest/g_forest_or.svg @@ -0,0 +1,106 @@ + + + + + + + + + + + + + + + + + + + + +Baseline Risk Factors +All Patients +Sex + F + M +Stratification Factor 2 + S1 + S2 +Total n +20 +11 +9 +10 +10 +Odds Ratio +1.31 +<0.01 +4.50 +1.00 +1.50 +95% CI +(0.17, 10.26) +(0.00, >999.99) +(0.25, 80.57) +(0.05, 22.18) +(0.09, 25.39) + + + + + + + + + + + + + + + + + + + +Comparison +Better +Treatment +Better + + + + + + + + + + + + + + + + + + + + + +0.1 +1 +10 + + diff --git a/tests/testthat/_snaps/g_forest/g_forest_plot_only.svg b/tests/testthat/_snaps/g_forest/g_forest_plot_only.svg new file mode 100644 index 0000000000..edc2367fec --- /dev/null +++ b/tests/testthat/_snaps/g_forest/g_forest_plot_only.svg @@ -0,0 +1,61 @@ + + + + + + + + + + + + + + + + + + + + +A: Drug X +Better +B: Placebo +Better + + + + + + + + + + + + + + + + + + + + + +0.1 +1 +10 + + diff --git a/tests/testthat/_snaps/g_forest/g_forest_table_only.svg b/tests/testthat/_snaps/g_forest/g_forest_table_only.svg new file mode 100644 index 0000000000..e6a78b50db --- /dev/null +++ b/tests/testthat/_snaps/g_forest/g_forest_table_only.svg @@ -0,0 +1,89 @@ + + + + + + + + + + + + + + + + + + + + +A: Drug X + +B: Placebo + +Baseline Risk Factors +All Patients +Sex + F + M +Stratification Factor 2 + S1 + S2 +Total n +20 +11 +9 +10 +10 +n +11 +6 +5 +5 +6 +Response (%) +72.7% +100.0% +40.0% +80.0% +66.7% +n +9 +5 +4 +5 +4 +Response (%) +77.8% +80.0% +75.0% +80.0% +75.0% +Odds Ratio +1.31 +<0.01 +4.50 +1.00 +1.50 +95% CI +(0.17, 10.26) +(0.00, >999.99) +(0.25, 80.57) +(0.05, 22.18) +(0.09, 25.39) + + + + diff --git a/tests/testthat/_snaps/utils_ggplot/rtable2gg_colsplits.svg b/tests/testthat/_snaps/utils_ggplot/rtable2gg_colsplits.svg index f58c5b11a0..cc2bf0a6db 100644 --- a/tests/testthat/_snaps/utils_ggplot/rtable2gg_colsplits.svg +++ b/tests/testthat/_snaps/utils_ggplot/rtable2gg_colsplits.svg @@ -22,134 +22,69 @@ - - - - - -A -A -A -A -A -A - - - - +A - -B -B -B -B -B -B - - - - +B - -V1 -V1 -V1 -V1 -V1 -V1 - - - +V1 - - -V2 -V2 -V2 -V2 -V2 -V2 - - - +V2 - - -V1 -V1 -V1 -V1 -V1 -V1 - - +V1 - - - -V2 -V2 -V2 -V2 -V2 -V2 - - - - - +V2 -n -Mean (SD) -Median -Min - Max -M -(N=4) -4 -5.0 (3.7) -5.0 -1.0 - 9.0 -F -(N=1) -1 -5.0 (NA) -5.0 -5.0 - 5.0 -M -(N=2) -2 -5.0 (1.4) -5.0 -4.0 - 6.0 -F -(N=2) -2 -5.0 (4.2) -5.0 -2.0 - 8.0 -M -(N=2) -2 -14.0 (1.4) -14.0 -13.0 - 15.0 -F -(N=2) -1 -11.0 (NA) -11.0 -11.0 - 11.0 -M -(N=4) -2 -11.0 (1.4) -11.0 -10.0 - 12.0 -F -(N=1) -1 -14.0 (NA) -14.0 -14.0 - 14.0 +n +Mean (SD) +Median +Min - Max +M +(N=4) +4 +5.0 (3.7) +5.0 +1.0 - 9.0 +F +(N=1) +1 +5.0 (NA) +5.0 +5.0 - 5.0 +M +(N=2) +2 +5.0 (1.4) +5.0 +4.0 - 6.0 +F +(N=2) +2 +5.0 (4.2) +5.0 +2.0 - 8.0 +M +(N=2) +2 +14.0 (1.4) +14.0 +13.0 - 15.0 +F +(N=2) +1 +11.0 (NA) +11.0 +11.0 - 11.0 +M +(N=4) +2 +11.0 (1.4) +11.0 +10.0 - 12.0 +F +(N=1) +1 +14.0 (NA) +14.0 +14.0 - 14.0 diff --git a/tests/testthat/_snaps/utils_ggplot/rtable2gg_cw.svg b/tests/testthat/_snaps/utils_ggplot/rtable2gg_cw.svg index d01fda867d..6bbf589ca3 100644 --- a/tests/testthat/_snaps/utils_ggplot/rtable2gg_cw.svg +++ b/tests/testthat/_snaps/utils_ggplot/rtable2gg_cw.svg @@ -22,74 +22,59 @@ - - - - - - - - - - - - - - - -V1 - n - Mean (SD) - Median - Min - Max -V2 - n - Mean (SD) - Median - Min - Max -V3 - n - Mean (SD) - Median - Min - Max -A -2 -7.5 (2.1) -7.5 -6.0 - 9.0 -2 -6.5 (2.1) -6.5 -5.0 - 8.0 -2 -5.5 (2.1) -5.5 -4.0 - 7.0 -B -1 -3.0 (NA) -3.0 -3.0 - 3.0 -1 -2.0 (NA) -2.0 -2.0 - 2.0 -1 -1.0 (NA) -1.0 -1.0 - 1.0 -C -0 -NA -NA -NA -0 -NA -NA -NA -0 -NA -NA -NA +V1 + n + Mean (SD) + Median + Min - Max +V2 + n + Mean (SD) + Median + Min - Max +V3 + n + Mean (SD) + Median + Min - Max +A +2 +7.5 (2.1) +7.5 +6.0 - 9.0 +2 +6.5 (2.1) +6.5 +5.0 - 8.0 +2 +5.5 (2.1) +5.5 +4.0 - 7.0 +B +1 +3.0 (NA) +3.0 +3.0 - 3.0 +1 +2.0 (NA) +2.0 +2.0 - 2.0 +1 +1.0 (NA) +1.0 +1.0 - 1.0 +C +0 +NA +NA +NA +0 +NA +NA +NA +0 +NA +NA +NA diff --git a/tests/testthat/_snaps/utils_ggplot/rtable2gg_default.svg b/tests/testthat/_snaps/utils_ggplot/rtable2gg_default.svg index 0220875d71..510ec9d680 100644 --- a/tests/testthat/_snaps/utils_ggplot/rtable2gg_default.svg +++ b/tests/testthat/_snaps/utils_ggplot/rtable2gg_default.svg @@ -22,74 +22,59 @@ - - - - - - - - - - - - - - - -V1 - n - Mean (SD) - Median - Min - Max -V2 - n - Mean (SD) - Median - Min - Max -V3 - n - Mean (SD) - Median - Min - Max -A -2 -7.5 (2.1) -7.5 -6.0 - 9.0 -2 -6.5 (2.1) -6.5 -5.0 - 8.0 -2 -5.5 (2.1) -5.5 -4.0 - 7.0 -B -1 -3.0 (NA) -3.0 -3.0 - 3.0 -1 -2.0 (NA) -2.0 -2.0 - 2.0 -1 -1.0 (NA) -1.0 -1.0 - 1.0 -C -0 -NA -NA -NA -0 -NA -NA -NA -0 -NA -NA -NA +V1 + n + Mean (SD) + Median + Min - Max +V2 + n + Mean (SD) + Median + Min - Max +V3 + n + Mean (SD) + Median + Min - Max +A +2 +7.5 (2.1) +7.5 +6.0 - 9.0 +2 +6.5 (2.1) +6.5 +5.0 - 8.0 +2 +5.5 (2.1) +5.5 +4.0 - 7.0 +B +1 +3.0 (NA) +3.0 +3.0 - 3.0 +1 +2.0 (NA) +2.0 +2.0 - 2.0 +1 +1.0 (NA) +1.0 +1.0 - 1.0 +C +0 +NA +NA +NA +0 +NA +NA +NA +0 +NA +NA +NA diff --git a/tests/testthat/_snaps/utils_ggplot/rtable2gg_fs.svg b/tests/testthat/_snaps/utils_ggplot/rtable2gg_fs.svg index 86e578d532..a60809180e 100644 --- a/tests/testthat/_snaps/utils_ggplot/rtable2gg_fs.svg +++ b/tests/testthat/_snaps/utils_ggplot/rtable2gg_fs.svg @@ -22,74 +22,59 @@ - - - - - - - - - - - - - - - -V1 - n - Mean (SD) - Median - Min - Max -V2 - n - Mean (SD) - Median - Min - Max -V3 - n - Mean (SD) - Median - Min - Max -A -2 -7.5 (2.1) -7.5 -6.0 - 9.0 -2 -6.5 (2.1) -6.5 -5.0 - 8.0 -2 -5.5 (2.1) -5.5 -4.0 - 7.0 -B -1 -3.0 (NA) -3.0 -3.0 - 3.0 -1 -2.0 (NA) -2.0 -2.0 - 2.0 -1 -1.0 (NA) -1.0 -1.0 - 1.0 -C -0 -NA -NA -NA -0 -NA -NA -NA -0 -NA -NA -NA +V1 + n + Mean (SD) + Median + Min - Max +V2 + n + Mean (SD) + Median + Min - Max +V3 + n + Mean (SD) + Median + Min - Max +A +2 +7.5 (2.1) +7.5 +6.0 - 9.0 +2 +6.5 (2.1) +6.5 +5.0 - 8.0 +2 +5.5 (2.1) +5.5 +4.0 - 7.0 +B +1 +3.0 (NA) +3.0 +3.0 - 3.0 +1 +2.0 (NA) +2.0 +2.0 - 2.0 +1 +1.0 (NA) +1.0 +1.0 - 1.0 +C +0 +NA +NA +NA +0 +NA +NA +NA +0 +NA +NA +NA diff --git a/tests/testthat/_snaps/utils_ggplot/rtable2gg_lblpad.svg b/tests/testthat/_snaps/utils_ggplot/rtable2gg_lblpad.svg index 542dbcfcc3..7b6993377d 100644 --- a/tests/testthat/_snaps/utils_ggplot/rtable2gg_lblpad.svg +++ b/tests/testthat/_snaps/utils_ggplot/rtable2gg_lblpad.svg @@ -22,74 +22,59 @@ - - - - - - - - - - - - - - - -V1 - n - Mean (SD) - Median - Min - Max -V2 - n - Mean (SD) - Median - Min - Max -V3 - n - Mean (SD) - Median - Min - Max -A -2 -7.5 (2.1) -7.5 -6.0 - 9.0 -2 -6.5 (2.1) -6.5 -5.0 - 8.0 -2 -5.5 (2.1) -5.5 -4.0 - 7.0 -B -1 -3.0 (NA) -3.0 -3.0 - 3.0 -1 -2.0 (NA) -2.0 -2.0 - 2.0 -1 -1.0 (NA) -1.0 -1.0 - 1.0 -C -0 -NA -NA -NA -0 -NA -NA -NA -0 -NA -NA -NA +V1 + n + Mean (SD) + Median + Min - Max +V2 + n + Mean (SD) + Median + Min - Max +V3 + n + Mean (SD) + Median + Min - Max +A +2 +7.5 (2.1) +7.5 +6.0 - 9.0 +2 +6.5 (2.1) +6.5 +5.0 - 8.0 +2 +5.5 (2.1) +5.5 +4.0 - 7.0 +B +1 +3.0 (NA) +3.0 +3.0 - 3.0 +1 +2.0 (NA) +2.0 +2.0 - 2.0 +1 +1.0 (NA) +1.0 +1.0 - 1.0 +C +0 +NA +NA +NA +0 +NA +NA +NA +0 +NA +NA +NA diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index 80d93d308d..9c74d4d29f 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -20,3 +20,16 @@ skip_if_too_deep <- function(depth) { testthat::skip(paste("testing depth", testing_depth, "is below current testing specification", depth)) } } + +# expect_snapshot_ggplot - set custom plot dimensions +expect_snapshot_ggplot <- function(title, fig, width = NA, height = NA) { + skip_if_not_installed("svglite") + + name <- paste0(title, ".svg") + path <- tempdir() + suppressMessages(ggplot2::ggsave(name, fig, path = path, width = width, height = height)) + path <- file.path(path, name) + + testthat::announce_snapshot_file(name = name) + testthat::expect_snapshot_file(path, name) +} diff --git a/tests/testthat/test-g_forest.R b/tests/testthat/test-g_forest.R index 0da842ce2d..2448229020 100644 --- a/tests/testthat/test-g_forest.R +++ b/tests/testthat/test-g_forest.R @@ -19,7 +19,20 @@ testthat::test_that("g_forest default plot works", { tabulate_rsp_subgroups(df) g_forest <- g_forest(tbl) - vdiffr::expect_doppelganger(title = "g_forest", fig = g_forest) + + expect_snapshot_ggplot("g_forest", g_forest, width = 15, height = 3) + + # Odds ratio only + tbl_or <- basic_table() %>% + tabulate_rsp_subgroups(df, vars = c("n_tot", "or", "ci")) + + g_forest_or <- g_forest( + tbl_or, + forest_header = c("Comparison\nBetter", "Treatment\nBetter"), + rel_width_forest = 0.4 + ) + + expect_snapshot_ggplot("g_forest_or", g_forest_or, width = 8, height = 3) }) testthat::test_that("g_forest works with custom arguments", { @@ -32,16 +45,56 @@ testthat::test_that("g_forest works with custom arguments", { rrow("row 2", 1.2, c(1.1, 1.4)) ) - g_forest_custom <- - g_forest( - tbl = tbl, - col_x = 1, - col_ci = 2, - xlim = c(0.5, 2), - x_at = c(0.5, 1, 2), - vline = 1, - forest_header = c("Hello", "World") - ) - - vdiffr::expect_doppelganger(title = "g_forest_custom", fig = g_forest_custom) + g_forest_custom_1 <- g_forest( + tbl = tbl, + col_x = 1, + col_ci = 2, + xlim = c(0.5, 2), + x_at = c(0.5, 1, 2), + vline = 0.9, + forest_header = c("Hello", "World") + ) + + expect_snapshot_ggplot("g_forest_custom_1", g_forest_custom_1, width = 4, height = 2) + + g_forest_custom_2 <- g_forest( + tbl = tbl, + col_x = 1, + col_ci = 2, + logx = FALSE, + xlim = c(0.5, 1.5), + x_at = seq(0.5, 1.5, by = 0.2), + lbl_col_padding = -3, + width_columns = c(4, 3, 3), + col = "purple" + ) + + expect_snapshot_ggplot("g_forest_custom_2", g_forest_custom_2, width = 10, height = 5) + + g_forest_custom_3 <- g_forest( + tbl = tbl, + col_x = 1, + col_ci = 2, + xlim = c(0.5, 2), + x_at = c(0.5, 1, 2), + vline = 0.9, + forest_header = c("c1\nis\nbetter", "c2\nis\nbetter"), + rel_width_forest = 0.6, + font_size = 6, + col = c("red", "green") + ) + + expect_snapshot_ggplot("g_forest_custom_3", g_forest_custom_3, width = 10, height = 5) +}) + +testthat::test_that("g_forest as_list argument works", { + tbl <- basic_table() %>% + tabulate_rsp_subgroups(df) + + f <- g_forest(tbl, as_list = TRUE) + g_forest_table_only <- f$table + g_forest_plot_only <- f$plot + + expect_snapshot_ggplot("g_forest_table_only", g_forest_table_only, width = 9, height = 3) + expect_snapshot_ggplot("g_forest_plot_only", g_forest_plot_only, width = 2, height = 3) }) diff --git a/tests/testthat/test-utils_ggplot.R b/tests/testthat/test-utils_ggplot.R index 1313062e81..e270fb6266 100644 --- a/tests/testthat/test-utils_ggplot.R +++ b/tests/testthat/test-utils_ggplot.R @@ -1,6 +1,4 @@ -skip_if_not_installed("svglite") - -testthat::test_that("rtables2gg works as expected", { +testthat::test_that("rtable2gg works as expected", { dta <- data.frame( USUBJID = rep(1:6, each = 3), PARAMCD = rep("lab", 6 * 3), @@ -17,43 +15,23 @@ testthat::test_that("rtables2gg works as expected", { tbl <- build_table(lyt, df = dta) # defaults - testthat::expect_snapshot_file( - tbl %>% - rtable2gg() %>% - ggplot2::ggsave(filename = "rtable2gg_default.svg", path = "./_snaps/utils_ggplot", width = 5) %>% - suppressMessages(), - "rtable2gg_default.svg" - ) + rtable2gg_default <- tbl %>% rtable2gg() + expect_snapshot_ggplot("rtable2gg_default", rtable2gg_default, width = 5) # custom fontsize - testthat::expect_snapshot_file( - tbl %>% - rtable2gg(fontsize = 5) %>% - ggplot2::ggsave(filename = "rtable2gg_fs.svg", path = "./_snaps/utils_ggplot", width = 5) %>% - suppressMessages(), - "rtable2gg_fs.svg" - ) + rtable2gg_fs <- tbl %>% rtable2gg(fontsize = 5) + expect_snapshot_ggplot("rtable2gg_fs", rtable2gg_fs, width = 5) # custom colwidths - testthat::expect_snapshot_file( - tbl %>% - rtable2gg(colwidths = c(4, 2, 2, 3)) %>% - ggplot2::ggsave(filename = "rtable2gg_cw.svg", path = "./_snaps/utils_ggplot", width = 5) %>% - suppressMessages(), - "rtable2gg_cw.svg" - ) + rtable2gg_cw <- tbl %>% rtable2gg(colwidths = c(4, 2, 2, 3)) + expect_snapshot_ggplot("rtable2gg_cw", rtable2gg_cw, width = 5) # custom lbl_col_padding - testthat::expect_snapshot_file( - tbl %>% - rtable2gg(lbl_col_padding = -5) %>% - ggplot2::ggsave(filename = "rtable2gg_lblpad.svg", path = "./_snaps/utils_ggplot", width = 5) %>% - suppressMessages(), - "rtable2gg_lblpad.svg" - ) + rtable2gg_lblpad <- tbl %>% rtable2gg(lbl_col_padding = -5) + expect_snapshot_ggplot("rtable2gg_lblpad", rtable2gg_lblpad, width = 5) }) -testthat::test_that("rtables2gg works with multiple column splits", { +testthat::test_that("rtable2gg works with multiple column splits", { dta2 <- data.frame( USUBJID = rep(1:6, each = 3), PARAMCD = rep("lab", 6 * 3), @@ -71,10 +49,6 @@ testthat::test_that("rtables2gg works with multiple column splits", { tbl <- build_table(lyt, df = dta2) - testthat::expect_snapshot_file( - tbl %>% - rtable2gg() %>% - ggplot2::ggsave(filename = "rtable2gg_colsplits.svg", path = "./_snaps/utils_ggplot", height = 3, width = 10), - "rtable2gg_colsplits.svg" - ) + rtable2gg_colsplits <- tbl %>% rtable2gg() + expect_snapshot_ggplot("rtable2gg_colsplits", rtable2gg_colsplits, width = 10, height = 3) })