From e8eba5b2294dee48963b0310fd237a6a1b255b7b Mon Sep 17 00:00:00 2001 From: shaesen2 Date: Thu, 16 Jun 2022 07:20:49 -0400 Subject: [PATCH 1/9] fix issues associated with this function --- R/apply_theme.R | 36 ++++++++++++++++++++++++++++-------- 1 file changed, 28 insertions(+), 8 deletions(-) diff --git a/R/apply_theme.R b/R/apply_theme.R index e6c5496e..ff67bb7d 100644 --- a/R/apply_theme.R +++ b/R/apply_theme.R @@ -1,7 +1,7 @@ #' @title Provides a simple wrapper for themes #' #' @description This function collects several lists if they are present. If absent, reasonable defaults are used. -#' +#' When strata are not defined in the theme, they default to grey50 and will not be presented in the legend. #' @param strata list containing the different strata and name:colour value pairs #' @param fontsizes list containing the font sizes for different options #' @param fontfamily string with the name of a supported font @@ -16,10 +16,6 @@ #' theme <- visR::define_theme( #' strata = list("SEX" = list("F" = "red", #' "M" = "blue" -#' ), -#' "TRTA" = list("Placebo" = "cyan", -#' "Xanomeline High Dose" = "purple", -#' "Xanomeline Low Dose" = "brown" #' ) #' ), #' fontsizes = list("axis" = 12, @@ -277,6 +273,24 @@ apply_theme <- function(gg, visR_theme_dict = NULL) { cols <- unlist(cols) + # find group used in plot and extract levels from the data => select these from cols + # if these levels were not defined, use default as present in plot + colneed <- as.character(unique(gg$data[[gg$labels$group]])) + + skipcolor <- FALSE + # from the strata in the theme, which were used in the estimation + lvl1 <- lapply(visR_theme_dict[["strata"]], unlist) + lvl2 <- lapply(lvl1, function(x) any(colneed %in% names(x))) + ttl <- names(which(lvl2 == TRUE)) + + if (!any(colneed %in% names(cols))) { + skipcolor <- TRUE + } + + if (length(intersect(names(cols), colneed))>0){ + cols <- cols[intersect(names(cols), colneed)] + } + } # fonts and text ----------------------------------------------------------- @@ -443,9 +457,15 @@ apply_theme <- function(gg, visR_theme_dict = NULL) { # Reset background gg <- gg + ggplot2::theme_minimal() + if (!skipcolor) { + gg <- gg + + ggplot2::scale_colour_manual(labels = names(cols), + values = cols, + aesthetics = c("colour", "fill"), na.value = "grey50") + + guides(color=guide_legend(ttl)) + } + gg <- gg + - ggplot2::scale_colour_manual(values = cols, - aesthetics = c("colour", "fill")) + ggplot2::theme( text = font_family, axis.title.x = axis_title, @@ -460,6 +480,6 @@ apply_theme <- function(gg, visR_theme_dict = NULL) { legend.position = legend_position ) + return(gg) } - From b6a00c4d0fefcf732456542cd38804c7dea37bbd Mon Sep 17 00:00:00 2001 From: shaesen2 Date: Fri, 17 Jun 2022 01:10:07 -0400 Subject: [PATCH 2/9] issue fix --- R/apply_theme.R | 37 +++++++++++++++++++++++++++++----- R/utils_pipe.R | 2 +- vignettes/Styling_KM_plots.Rmd | 12 ----------- 3 files changed, 33 insertions(+), 18 deletions(-) diff --git a/R/apply_theme.R b/R/apply_theme.R index ff67bb7d..3441beb3 100644 --- a/R/apply_theme.R +++ b/R/apply_theme.R @@ -210,7 +210,7 @@ apply_theme <- function(gg, visR_theme_dict = NULL) { # Manually define colour-blind friendly palette, taken from # http://mkweb.bcgsc.ca/biovis2012/krzywinski-visualizing-biological-data.pdf - cols <- c( + coldefault <- c( grDevices::rgb( 0, 0, 0, maxColorValue = 255), # 1 grDevices::rgb( 73, 0, 146, maxColorValue = 255), # 6 grDevices::rgb(146, 0, 0, maxColorValue = 255), # 11 @@ -229,6 +229,9 @@ apply_theme <- function(gg, visR_theme_dict = NULL) { grDevices::rgb( 36, 255, 36, maxColorValue = 255) # 14 ) + skipcolordef <- FALSE + skipcolor <- TRUE + font_family <- ggplot2::element_text(family = "Helvetica") legend_title <- ggplot2::element_text(size = 12) @@ -260,6 +263,9 @@ apply_theme <- function(gg, visR_theme_dict = NULL) { if ("strata" %in% base::names(visR_theme_dict)) { cols <- c() + skipcolordef <- TRUE + skipcolor <- FALSE + named_strata <- base::names(visR_theme_dict[["strata"]]) for (s in named_strata) { @@ -277,20 +283,29 @@ apply_theme <- function(gg, visR_theme_dict = NULL) { # if these levels were not defined, use default as present in plot colneed <- as.character(unique(gg$data[[gg$labels$group]])) - skipcolor <- FALSE - # from the strata in the theme, which were used in the estimation + # Take title to match strata in theme lvl1 <- lapply(visR_theme_dict[["strata"]], unlist) lvl2 <- lapply(lvl1, function(x) any(colneed %in% names(x))) ttl <- names(which(lvl2 == TRUE)) + # from the strata in the theme, which were used in the estimation if (!any(colneed %in% names(cols))) { skipcolor <- TRUE } if (length(intersect(names(cols), colneed))>0){ cols <- cols[intersect(names(cols), colneed)] + } else if (length(colneed) <= length(coldefault)) { + cols <- coldefault[1:length(colneed)] + names(cols) <- colneed + } else { + ## too many strata, keep as is + # layer <- ggplot2::layer_data(gg) + # cols <- layer[unique(layer[["group"]]), "colour"] + # names(cols) <- colneed + skipcolordef <- TRUE + skipcolor <- TRUE } - } # fonts and text ----------------------------------------------------------- @@ -458,11 +473,23 @@ apply_theme <- function(gg, visR_theme_dict = NULL) { gg <- gg + ggplot2::theme_minimal() if (!skipcolor) { + gg <- gg + ggplot2::scale_colour_manual(labels = names(cols), values = cols, aesthetics = c("colour", "fill"), na.value = "grey50") + - guides(color=guide_legend(ttl)) + ggplot2::guides(color=ggplot2::guide_legend(ttl)) + + } else if (!skipcolordef){ + + ## apply color friendly palette + if (length(unique(ggplot2::layer_data(gg)[["group"]])) > length(coldefault)) { + warning(paste0(length(coldefault), " is the max. number of strata supported.")) + } else { + gg <- gg + + ggplot2::scale_colour_manual(values = coldefault, + aesthetics = c("colour", "fill"), na.value = "grey50") + } } gg <- gg + diff --git a/R/utils_pipe.R b/R/utils_pipe.R index a680da0b..4932f2b2 100644 --- a/R/utils_pipe.R +++ b/R/utils_pipe.R @@ -26,7 +26,7 @@ the_lhs <- function() { #' @title Find the character that represents the data argument in a call list #' #' @description This function returns character that represents the data argument in a call list. -#' +#' @param call_list A list from a call #' @return Character representing the data. #' @noRd diff --git a/vignettes/Styling_KM_plots.Rmd b/vignettes/Styling_KM_plots.Rmd index 1da658c3..90a78e63 100644 --- a/vignettes/Styling_KM_plots.Rmd +++ b/vignettes/Styling_KM_plots.Rmd @@ -22,7 +22,6 @@ knitr::opts_chunk$set( # Introduction ```{r libraries, include = TRUE} -library(ggplot2) library(visR) ``` @@ -145,14 +144,3 @@ lung_suvival_object %>% visR::visr() %>% visR::apply_theme(theme) ``` - -Applying a theme does not prevent the user from further applying modifications, as for example the addition of confidence intervals, censoring indicators or risk tables. - -```{r visr-apply_theme-non-empty-fancy, warning=FALSE} -lung_suvival_object %>% - visR::visr() %>% - visR::apply_theme(theme) %>% - visR::add_CI() %>% - visR::add_CNSR() %>% - visR::add_risktable() -``` From 214152af606ab26f154dc66d811911cf3643757c Mon Sep 17 00:00:00 2001 From: Tim Treis Date: Sat, 18 Jun 2022 00:09:49 +0200 Subject: [PATCH 3/9] Added test for case when not all colours are defined. --- R/apply_theme.R | 2 +- man/define_theme.Rd | 5 +- man/visR-package.Rd | 4 +- tests/testthat/test-apply_theme.R | 293 +++++++++++++++++------------- 4 files changed, 166 insertions(+), 138 deletions(-) diff --git a/R/apply_theme.R b/R/apply_theme.R index 3441beb3..92a4d6e8 100644 --- a/R/apply_theme.R +++ b/R/apply_theme.R @@ -293,7 +293,7 @@ apply_theme <- function(gg, visR_theme_dict = NULL) { skipcolor <- TRUE } - if (length(intersect(names(cols), colneed))>0){ + if (length(intersect(names(cols), colneed)) > 0) { cols <- cols[intersect(names(cols), colneed)] } else if (length(colneed) <= length(coldefault)) { cols <- coldefault[1:length(colneed)] diff --git a/man/define_theme.Rd b/man/define_theme.Rd index b54c2fb4..7001b62f 100644 --- a/man/define_theme.Rd +++ b/man/define_theme.Rd @@ -31,16 +31,13 @@ Nested list with styling preferences for a ggplot object } \description{ This function collects several lists if they are present. If absent, reasonable defaults are used. +When strata are not defined in the theme, they default to grey50 and will not be presented in the legend. } \examples{ theme <- visR::define_theme( strata = list("SEX" = list("F" = "red", "M" = "blue" - ), - "TRTA" = list("Placebo" = "cyan", - "Xanomeline High Dose" = "purple", - "Xanomeline Low Dose" = "brown" ) ), fontsizes = list("axis" = 12, diff --git a/man/visR-package.Rd b/man/visR-package.Rd index 5038986a..fa3793e4 100644 --- a/man/visR-package.Rd +++ b/man/visR-package.Rd @@ -6,9 +6,9 @@ \alias{visR-package} \title{visR: Clinical Graphs and Tables Adhering to Graphical Principles} \description{ -\if{html}{\figure{logo.png}{options: style='float: right' alt='logo' width='120'}} +\if{html}{\figure{logo.png}{options: align='right' alt='logo' width='120'}} -To enable fit-for-purpose, reusable clinical and medical research focused visualizations and tables with sensible defaults and based on graphical principles as described in: "Vandemeulebroecke et al. (2018)" \doi{10.1002/pst.1912}, "Vandemeulebroecke et al. (2019)" \doi{10.1002/psp4.12455}, and "Morris et al. (2019)" \doi{10.1136/bmjopen-2019-030215}. +To enable fit-for-purpose, reusable clinical and medical research focused visualizations and tables with sensible defaults and based on graphical principles as described in: "Vandemeulebroecke et al. (2018)" , "Vandemeulebroecke et al. (2019)" , and "Morris et al. (2019)" . } \seealso{ Useful links: diff --git a/tests/testthat/test-apply_theme.R b/tests/testthat/test-apply_theme.R index 889eede3..45c5a4a1 100644 --- a/tests/testthat/test-apply_theme.R +++ b/tests/testthat/test-apply_theme.R @@ -1,6 +1,6 @@ #' @title Specifications test-apply_theme.R -#' @section Last updated by: Tim Treis (tim.treis@@outlook.de) -#' @section Last update date: 2022-02-09T15:22:32 +#' @section Last updated by: ardeeshany (ardeeshany@@gmail.com) +#' @section Last update date: 2022-05-22T03:20:16 #' #' @section List of tested specifications #' T1. The `define_theme()` function returns a `visR_theme` object can contain valid input parameters for `apply_theme()`. @@ -50,161 +50,161 @@ testthat::context("apply_theme - T1. The `define_theme()` function returns a `visR_theme` object can contain valid input parameters for `apply_theme()`.") testthat::test_that("T1.1 No error when no parameters are specified.", { - + testthat::expect_error(visR::define_theme(), NA) - + }) testthat::test_that("T1.2 Not specifying any parameters returns a list.", { - + theme <- visR::define_theme() - + testthat::expect_true(is.list(theme)) - + }) testthat::test_that("T1.3 No error when `strata` is `NULL`.", { - + testthat::expect_error(visR::define_theme(strata = NULL), NA) - + }) testthat::test_that("T1.4 A warning when `strata` is an empty `list`.", { - + testthat::expect_warning(visR::define_theme(strata = list())) - + }) testthat::test_that("T1.5 A warning when `strata` is an unnamed `list`.", { - + testthat::expect_warning(visR::define_theme(strata = list("v", "i", "s", "R"))) - + }) testthat::test_that("T1.6 No warning when `strata` is a named `list`.", { - + testthat::expect_warning(visR::define_theme(strata = list("visR" = "visR")), NA) - + }) testthat::test_that("T1.7 No error when `fontsizes` is `NULL`.", { - + testthat::expect_error(visR::define_theme(fontsizes = NULL), NA) - + }) testthat::test_that("T1.8 A warning when `fontsizes` is an empty `list`.", { - + testthat::expect_warning(visR::define_theme(fontsizes = list())) - + }) testthat::test_that("T1.9 A warning when `fontsizes` is an unnamed `list`.", { - + testthat::expect_warning(visR::define_theme(fontsizes = list("s", "R"))) - + }) testthat::test_that("T1.10 No warning when `fontsizes` is a named `list`.", { - + testthat::expect_warning(visR::define_theme(fontsizes = list("a" = "a")), NA) - + }) testthat::test_that("T1.11 A message when `fontsizes` is a numerical value.", { - + testthat::expect_message(visR::define_theme(fontsizes = 12)) - + }) testthat::test_that("T1.12 A warning when `fontsizes` is neither `NULL`, a `list` or a `numeric`.", { - + testthat::expect_warning(visR::define_theme(fontsizes = "visR")) - + }) testthat::test_that("T1.13 No error when `fontfamily` is a string.", { - + testthat::expect_error(visR::define_theme(fontfamily = "Times"), NA) - + }) testthat::test_that("T1.14 A warning when `fontfamily` is an empty string.", { - + testthat::expect_warning(visR::define_theme(fontfamily = "")) testthat::expect_warning(visR::define_theme(fontfamily = c(""))) - + }) testthat::test_that("T1.15 A warning when `fontfamily` is a vector of strings.", { - + testthat::expect_warning(visR::define_theme(fontfamily = c("a", "a"))) - + }) testthat::test_that("T1.16 A warning when `fontfamily` is anything but a string.", { - + testthat::expect_warning(visR::define_theme(fontfamily = NULL)) testthat::expect_warning(visR::define_theme(fontfamily = 12)) testthat::expect_warning(visR::define_theme(fontfamily = TRUE)) testthat::expect_warning(visR::define_theme(fontfamily = list())) - + }) testthat::test_that("T1.17 No error when `grid` is a boolean.", { - + testthat::expect_error(visR::define_theme(grid = TRUE), NA) testthat::expect_error(visR::define_theme(grid = FALSE), NA) - + }) testthat::test_that("T1.18 A warning when `grid` is a list but its members are not `major` or `minor`.", { - + testthat::expect_warning(visR::define_theme(grid = list("visR" = TRUE))) - + }) testthat::test_that("T1.19 A warning when `grid` is anything but a boolean or a list.", { - + testthat::expect_warning(visR::define_theme(grid = NULL)) testthat::expect_warning(visR::define_theme(grid = 12)) testthat::expect_warning(visR::define_theme(grid = "visR")) testthat::expect_warning(visR::define_theme(grid = c())) - + }) testthat::test_that("T1.20 No error when `bg` is a character.", { - + testthat::expect_error(visR::define_theme(bg = "blue"), NA) - + }) testthat::test_that("T1.21 A warning when `bg` is anything but a character.", { - + testthat::expect_warning(visR::define_theme(bg = NULL)) testthat::expect_warning(visR::define_theme(bg = 12)) testthat::expect_warning(visR::define_theme(bg = list())) - + }) testthat::test_that("T1.22 No warning when `legend_position` is a `character` or `NULL`.", { - + testthat::expect_warning(visR::define_theme(legend_position = "top"), NA) testthat::expect_warning(visR::define_theme(legend_position = NULL), NA) - + }) testthat::test_that("T1.23 A warning when `legend_position` is not a `character` or `NULL`.", { - + testthat::expect_warning(visR::define_theme(legend_position = 12)) testthat::expect_warning(visR::define_theme(legend_position = list())) - + }) testthat::test_that("T1.24 The returned theme object is of class `visR_theme`.", { - + testthat::expect_true(inherits(visR::define_theme(), "visR_theme")) - + }) # Requirement T2 ------------------------------------------------------------------------------------------------------- @@ -212,34 +212,34 @@ testthat::test_that("T1.24 The returned theme object is of class `visR_theme`.", testthat::context("apply_theme - T2. The `apply_theme` function applies the specified changes to a `ggplot` object.") testthat::test_that("T2.1 No error when a `ggplot` plot is provided, but no theme.", { - + gg <- adtte %>% visR::estimate_KM("SEX") %>% visR::visr() - + testthat::expect_error(visR::apply_theme(gg), NA) - + }) testthat::test_that("T2.2 No error when a `ggplot` plot and a minimal `visR::define_theme` object are provided.", { - + gg <- adtte %>% visR::estimate_KM("SEX") %>% visR::visr() - + theme <- visR::define_theme() - + testthat::expect_error(visR::apply_theme(gg, theme), NA) testthat::expect_error(gg %>% visR::apply_theme(theme), NA) - + }) testthat::test_that("T2.3 No error when a `ggplot` plot and a complex `visR::define_theme` object are provided.", { - + gg <- adtte %>% visR::estimate_KM("SEX") %>% visR::visr() - + theme <- visR::define_theme(strata = list("SEX" = list("F" = "red", "M" = "blue"), "TRTA" = list("Placebo" = "cyan", @@ -250,239 +250,239 @@ testthat::test_that("T2.3 No error when a `ggplot` plot and a complex `visR::def fontfamily = "Helvetica", grid = FALSE, bg = "transparent") - + testthat::expect_error(visR::apply_theme(gg, theme), NA) testthat::expect_error(gg %>% visR::apply_theme(theme), NA) - + }) testthat::test_that("T2.4 A message when a theme not generated through `visR::define_theme` is provided.", { - + gg <- adtte %>% visR::estimate_KM("SEX") %>% visR::visr() - + theme <- list("fontfamily" = "Palatino") - + testthat::expect_error(visR::apply_theme(gg, theme), NA) testthat::expect_error(gg %>% visR::apply_theme(theme), NA) - + testthat::expect_message(visR::apply_theme(gg, theme)) testthat::expect_message(gg %>% visR::apply_theme(theme)) - + }) testthat::test_that("T2.5 Colours applied through `visR::apply_theme()` are used in the resulting `ggplot` object.", { - + gg <- adtte %>% visR::estimate_KM("SEX") %>% visR::visr() - + theme <- visR::define_theme(strata = list("SEX" = list("F" = "red", "M" = "blue"), "TRTA" = list("Placebo" = "cyan", "Xanomeline High Dose" = "purple", "Xanomeline Low Dose" = "brown"))) - + gg <- gg %>% visR::apply_theme(theme) ggb <- ggplot2::ggplot_build(gg) - + testthat::expect_equal(unique(unlist(theme$strata$SEX)), unique(ggb$data[[1]]$colour)) - + }) testthat::test_that("T2.6 If `fontsizes` is a `numeric`, the other font occurrences are derived from it.", { - + gg <- adtte %>% visR::estimate_KM("SEX") %>% visR::visr() - + theme <- visR::define_theme(fontsizes = 12) - + gg <- gg %>% visR::apply_theme(theme) ggb <- ggplot2::ggplot_build(gg) - + testthat::expect_equal(theme$fontsizes, ggb$plot$theme$axis.title.x$size) testthat::expect_equal(theme$fontsizes, ggb$plot$theme$axis.title.y$size) testthat::expect_equal(theme$fontsizes, ggb$plot$theme$axis.text$size) testthat::expect_equal(theme$fontsizes, ggb$plot$theme$legend.title$size) testthat::expect_equal(theme$fontsizes, ggb$plot$theme$legend.text$size) - + }) testthat::test_that("T2.7 If `fontsizes` is a `list`, the individual fonts are extracted and used.", { - + gg <- adtte %>% visR::estimate_KM("SEX") %>% visR::visr() - + theme <- visR::define_theme(fontsizes = list("axis" = 12, "ticks" = 10, "legend_title" = 10, "legend_text" = 8)) - + gg <- gg %>% visR::apply_theme(theme) ggb <- ggplot2::ggplot_build(gg) - + testthat::expect_equal(theme$fontsizes$axis, ggb$plot$theme$axis.title.x$size) testthat::expect_equal(theme$fontsizes$axis, ggb$plot$theme$axis.title.y$size) testthat::expect_equal(theme$fontsizes$ticks, ggb$plot$theme$axis.text$size) testthat::expect_equal(theme$fontsizes$legend_title, ggb$plot$theme$legend.title$size) testthat::expect_equal(theme$fontsizes$legend_text, ggb$plot$theme$legend.text$size) - + }) testthat::test_that("T2.8 The fontfamily applied through `visR::apply_theme()` is used in the resulting `ggplot` object.", { - + gg <- adtte %>% visR::estimate_KM("SEX") %>% visR::visr() - + theme <- visR::define_theme(fontfamily = "Helvetica") - + gg <- gg %>% visR::apply_theme(theme) ggb <- ggplot2::ggplot_build(gg) - + testthat::expect_equal(theme$fontfamily, ggb$plot$theme$text$family) - + }) testthat::test_that("T2.9 If `grid` is a single `logical`, it is used for both major and minor grid.", { - + gg <- adtte %>% visR::estimate_KM("SEX") %>% visR::visr() - + theme_grid_false <- visR::define_theme(grid = FALSE) # Equal to major = minor = FALSE - - # Construct "grid = TRUE" case manually since visR::define_theme(grid = TRUE) + + # Construct "grid = TRUE" case manually since visR::define_theme(grid = TRUE) # would result in "major = TRUE; minor = FALSE)" due to our opinionated position theme_grid_true <- theme_grid_false theme_grid_true$grid <- TRUE - + gg_grid_true <- gg %>% visR::apply_theme(theme_grid_true) gg_grid_false <- gg %>% visR::apply_theme(theme_grid_false) - + ggb_grid_true <- ggplot2::ggplot_build(gg_grid_true) ggb_grid_false <- ggplot2::ggplot_build(gg_grid_false) - + testthat::expect_true((inherits(ggb_grid_true$plot$theme$panel.grid.major, "element_line")) & - (inherits(ggb_grid_true$plot$theme$panel.grid.minor, "element_line"))) - + (inherits(ggb_grid_true$plot$theme$panel.grid.minor, "element_line"))) + testthat::expect_true((inherits(ggb_grid_false$plot$theme$panel.grid.major, "element_blank")) & - (inherits(ggb_grid_false$plot$theme$panel.grid.minor, "element_blank"))) - + (inherits(ggb_grid_false$plot$theme$panel.grid.minor, "element_blank"))) + }) testthat::test_that("T2.10 If `grid` is a named list containing 'major' and/or 'minor' as single `logical`s, these are used for their respective options.", { - + gg <- adtte %>% visR::estimate_KM("SEX") %>% visR::visr() - + theme_grid_none <- visR::define_theme(grid = list("major" = FALSE, "minor" = FALSE)) theme_grid_only_minor <- visR::define_theme(grid = list("major" = FALSE, "minor" = TRUE)) theme_grid_minor_and_major <- visR::define_theme(grid = list("major" = TRUE, "minor" = TRUE)) - + gg_grid_none <- gg %>% visR::apply_theme(theme_grid_none) gg_grid_only_minor <- gg %>% visR::apply_theme(theme_grid_only_minor) gg_grid_minor_and_major <- gg %>% visR::apply_theme(theme_grid_minor_and_major) - + ggb_grid_none <- ggplot2::ggplot_build(gg_grid_none) ggb_grid_only_minor <- ggplot2::ggplot_build(gg_grid_only_minor) ggb_grid_minor_and_major <- ggplot2::ggplot_build(gg_grid_minor_and_major) - + testthat::expect_true((inherits(ggb_grid_none$plot$theme$panel.grid.major, "element_blank")) & - (inherits(ggb_grid_none$plot$theme$panel.grid.minor, "element_blank"))) + (inherits(ggb_grid_none$plot$theme$panel.grid.minor, "element_blank"))) testthat::expect_true((inherits(ggb_grid_only_minor$plot$theme$panel.grid.major, "element_blank")) & - (inherits(ggb_grid_only_minor$plot$theme$panel.grid.minor, "element_line"))) - + (inherits(ggb_grid_only_minor$plot$theme$panel.grid.minor, "element_line"))) + testthat::expect_true((inherits(ggb_grid_minor_and_major$plot$theme$panel.grid.major, "element_line")) & - (inherits(ggb_grid_minor_and_major$plot$theme$panel.grid.minor, "element_line"))) + (inherits(ggb_grid_minor_and_major$plot$theme$panel.grid.minor, "element_line"))) }) testthat::test_that("T2.11 A warning when `grid` is a named list containing 'major' and/or 'minor' that are not single `logical`s.", { - + gg <- adtte %>% visR::estimate_KM("SEX") %>% visR::visr() - + theme_major_correct <- visR::define_theme(grid = list("major" = TRUE, "minor" = "visR")) theme_minor_correct <- visR::define_theme(grid = list("major" = "visR", "minor" = TRUE)) - + testthat::expect_warning(gg %>% visR::apply_theme(theme_major_correct)) testthat::expect_warning(gg %>% visR::apply_theme(theme_minor_correct)) - + }) testthat::test_that("T2.12 A warning when `grid` is a named list that does not contain 'major' and/or 'minor'.", { - + gg <- adtte %>% visR::estimate_KM("SEX") %>% visR::visr() - + theme <- visR::define_theme(grid = list("major" = "visR", "minor" = "Rsiv")) - + names(theme$grid) <- c("visR", "Rsiv") - + testthat::expect_warning(gg %>% visR::apply_theme(theme)) - + }) testthat::test_that("T2.13 The background applied through `visR::apply_theme()` is used in the resulting `ggplot` object.", { - + gg <- adtte %>% visR::estimate_KM("SEX") %>% visR::visr() - + theme <- visR::define_theme(bg = "transparent") - + gg <- gg %>% visR::apply_theme(theme) ggb <- ggplot2::ggplot_build(gg) - + testthat::expect_equal(theme$bg, ggb$plot$theme$panel.background$fill) - + }) testthat::test_that("T2.14 The legend_position applied through `visR::apply_theme()` is used in the resulting `ggplot` object.", { - + gg <- adtte %>% visR::estimate_KM("SEX") %>% visR::visr() - + theme_top <- visR::define_theme(legend_position = "top") theme_right <- visR::define_theme(legend_position = "right") theme_bottom <- visR::define_theme(legend_position = "bottom") theme_left <- visR::define_theme(legend_position = "left") - + gg_top <- gg %>% visR::apply_theme(theme_top) gg_right <- gg %>% visR::apply_theme(theme_right) gg_bottom <- gg %>% visR::apply_theme(theme_bottom) gg_left <- gg %>% visR::apply_theme(theme_left) - + ggb_top <- ggplot2::ggplot_build(gg_top) ggb_right <- ggplot2::ggplot_build(gg_right) ggb_bottom <- ggplot2::ggplot_build(gg_bottom) ggb_left <- ggplot2::ggplot_build(gg_left) - + testthat::expect_equal(theme_top$legend_position, ggb_top$plot$theme$legend.position) testthat::expect_equal(theme_right$legend_position, ggb_right$plot$theme$legend.position) testthat::expect_equal(theme_bottom$legend_position, ggb_bottom$plot$theme$legend.position) testthat::expect_equal(theme_left$legend_position, ggb_left$plot$theme$legend.position) - + }) testthat::test_that("T2.15 The legend_position defined in `visR::visr()` is correctly passed through to the resulting `ggplot` object.", { - + gg_top <- adtte %>% visR::estimate_KM("SEX") %>% visR::visr(legend_position = "top") @@ -495,7 +495,7 @@ testthat::test_that("T2.15 The legend_position defined in `visR::visr()` is corr gg_left <- adtte %>% visR::estimate_KM("SEX") %>% visR::visr(legend_position = "left") - + gg_top <- gg_top %>% visR::apply_theme() gg_right <- gg_right %>% visR::apply_theme() gg_bottom <- gg_bottom %>% visR::apply_theme() @@ -505,12 +505,43 @@ testthat::test_that("T2.15 The legend_position defined in `visR::visr()` is corr ggb_right <- ggplot2::ggplot_build(gg_right) ggb_bottom <- ggplot2::ggplot_build(gg_bottom) ggb_left <- ggplot2::ggplot_build(gg_left) - + testthat::expect_true("top" %in% ggb_top$plot$theme$legend.position) testthat::expect_true("right" %in% ggb_right$plot$theme$legend.position) testthat::expect_true("bottom" %in% ggb_bottom$plot$theme$legend.position) testthat::expect_true("left" %in% ggb_left$plot$theme$legend.position) - + }) +testthat::test_that("T2.16 If a strata has no colour assigned, the default colour (grey50) is used.", { + + theme <- visR::define_theme(strata = list("SEX" = list("F" = NULL, + "M" = "blue"), + "TRTA" = list("Placebo" = "cyan", + "Xanomeline High Dose" = "purple", + "Xanomeline Low Dose" = "brown")), + fontsizes = list("axis" = 12, + "ticks" = 10, + "legend_title" = 10, + "legend_text" = 8), + fontfamily = "Helvetica", + grid = FALSE, + bg = "transparent", + legend_position = "top") + + gg <- adtte %>% + visR::estimate_KM(strata = "SEX") %>% + visR::visr() %>% + visR::add_CI() %>% + visR::apply_theme(theme) + + ggb <- ggplot2::ggplot_build(gg) + + # F is set to NULL, so it should be filled with grey50. + testthat::expect_true("grey50" %in% unlist(unique(ggb$data[[1]]["fill"]))) + +}) + + + # END OF CODE ------------------------------------------------------------- From bf5436ae2311df0192070efa11890419cd3ebce3 Mon Sep 17 00:00:00 2001 From: Tim Treis Date: Sat, 18 Jun 2022 01:01:06 +0200 Subject: [PATCH 4/9] Tiny bugfix, two more tests --- R/apply_theme.R | 5 ++- tests/testthat/test-apply_theme.R | 75 +++++++++++++++++++++++++++++-- 2 files changed, 75 insertions(+), 5 deletions(-) diff --git a/R/apply_theme.R b/R/apply_theme.R index 92a4d6e8..fe3ee129 100644 --- a/R/apply_theme.R +++ b/R/apply_theme.R @@ -298,6 +298,7 @@ apply_theme <- function(gg, visR_theme_dict = NULL) { } else if (length(colneed) <= length(coldefault)) { cols <- coldefault[1:length(colneed)] names(cols) <- colneed + skipcolordef <- FALSE } else { ## too many strata, keep as is # layer <- ggplot2::layer_data(gg) @@ -478,9 +479,9 @@ apply_theme <- function(gg, visR_theme_dict = NULL) { ggplot2::scale_colour_manual(labels = names(cols), values = cols, aesthetics = c("colour", "fill"), na.value = "grey50") + - ggplot2::guides(color=ggplot2::guide_legend(ttl)) + ggplot2::guides(color = ggplot2::guide_legend(ttl)) - } else if (!skipcolordef){ + } else if (!skipcolordef) { ## apply color friendly palette if (length(unique(ggplot2::layer_data(gg)[["group"]])) > length(coldefault)) { diff --git a/tests/testthat/test-apply_theme.R b/tests/testthat/test-apply_theme.R index 45c5a4a1..51ca4cdf 100644 --- a/tests/testthat/test-apply_theme.R +++ b/tests/testthat/test-apply_theme.R @@ -1,6 +1,6 @@ #' @title Specifications test-apply_theme.R -#' @section Last updated by: ardeeshany (ardeeshany@@gmail.com) -#' @section Last update date: 2022-05-22T03:20:16 +#' @section Last updated by: Tim Treis (tim.treis@@outlook.de) +#' @section Last update date: 2022-06-18T00:09:49 #' #' @section List of tested specifications #' T1. The `define_theme()` function returns a `visR_theme` object can contain valid input parameters for `apply_theme()`. @@ -44,6 +44,9 @@ #' T2.13 The background applied through `visR::apply_theme()` is used in the resulting `ggplot` object. #' T2.14 The legend_position applied through `visR::apply_theme()` is used in the resulting `ggplot` object. #' T2.15 The legend_position defined in `visR::visr()` is correctly passed through to the resulting `ggplot` object. +#' T2.16 If a strata has no colour assigned, the default colour (grey50) is used. +#' T2.17 When the theme dict contains no colour information for the strata of the ggplot object, the default visR colours are used. +#' T2.18 When the strata requires more colours than the visR palette holds, the default ggplot2 ones are chosen. # Requirement T1 ---------------------------------------------------------- @@ -537,11 +540,77 @@ testthat::test_that("T2.16 If a strata has no colour assigned, the default colou ggb <- ggplot2::ggplot_build(gg) - # F is set to NULL, so it should be filled with grey50. + # The colour for strata "F" is set to NULL, so it should be filled with "grey50". testthat::expect_true("grey50" %in% unlist(unique(ggb$data[[1]]["fill"]))) }) +testthat::test_that("T2.17 When the theme dict contains no colour information for the strata of the ggplot object, the default visR colours are used.", { + theme <- visR::define_theme(strata = list("TRTA" = list("Placebo" = "cyan", + "Xanomeline High Dose" = "purple", + "Xanomeline Low Dose" = "brown")), + fontsizes = list("axis" = 12, + "ticks" = 10, + "legend_title" = 10, + "legend_text" = 8), + fontfamily = "Helvetica", + grid = FALSE, + bg = "transparent", + legend_position = "top") + + gg <- adtte %>% + visR::estimate_KM(strata = "SEX") %>% + visR::visr() %>% + visR::add_CI() %>% + visR::apply_theme(theme) + + ggb <- ggplot2::ggplot_build(gg) + + # No colours for strata "SEX" given, so the first two colours of the visR + # palette will be used -> "#000000" and "#490092" + testthat::expect_true("#000000" %in% unlist(unique(ggb$data[[1]]["fill"]))) + testthat::expect_true("#490092" %in% unlist(unique(ggb$data[[1]]["fill"]))) + +}) + +testthat::test_that("T2.18 When the strata requires more colours than the visR palette holds, the default ggplot2 ones are chosen.", { + + theme <- visR::define_theme(strata = list("TRTDUR" = list("F" = "red", + "M" = "blue")), + fontsizes = list("axis" = 12, + "ticks" = 10, + "legend_title" = 10, + "legend_text" = 8), + fontfamily = "Helvetica", + grid = FALSE, + bg = "transparent", + legend_position = "top") + + adtte2 <- adtte + adtte2$TRTDUR <- round(adtte$TRTDUR/10) + gg <- adtte2 %>% + visR::estimate_KM(strata = "TRTDUR") %>% + visR::visr() %>% + visR::add_CI() %>% + visR::apply_theme(theme) + + # Get expected colours + # https://stackoverflow.com/questions/8197559/emulate-ggplot2-default-color-palette + gg_colour_hue <- function(n) { + hues = seq(15, 375, length = n + 1) + hcl(h = hues, l = 65, c = 100)[1:n] + } + cols_expected <- gg_colour_hue(length(unique(adtte2$TRTDUR))) + + # Get used colours and strip off the alpha part + ggb <- ggplot2::ggplot_build(gg) + cols_observed <- unlist(unique(ggb$data[[1]]["fill"])) + cols_observed <- gsub(".{2}$", "", cols_observed) + names(cols_observed) <- NULL + + testthat::expect_equal(cols_expected, cols_observed) + +}) # END OF CODE ------------------------------------------------------------- From 3f8722570b091d2c713bc587ab2ebb59ad432092 Mon Sep 17 00:00:00 2001 From: shaesen2 Date: Mon, 20 Jun 2022 07:51:04 -0400 Subject: [PATCH 5/9] Update testing of theming --- DESCRIPTION | 2 +- R/apply_theme.R | 174 +--------- R/define_theme.R | 175 ++++++++++ tests/testthat/test-apply_theme.R | 498 ++++++++++++----------------- tests/testthat/test-define_theme.R | 222 +++++++++++++ 5 files changed, 602 insertions(+), 469 deletions(-) create mode 100644 R/define_theme.R create mode 100644 tests/testthat/test-define_theme.R diff --git a/DESCRIPTION b/DESCRIPTION index 77b8ab8d..4936cda9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Type: Package Package: visR Title: Clinical Graphs and Tables Adhering to Graphical Principles -Version: 0.2.0.9011 +Version: 0.2.0.9012 Authors@R: c( person("Mark", "Baillie", , "bailliem@gmail.com", role = c("aut", "cre")), person("Diego", "Saldana", , "diego.saldana@roche.com", role = "aut"), diff --git a/R/apply_theme.R b/R/apply_theme.R index fe3ee129..81a93404 100644 --- a/R/apply_theme.R +++ b/R/apply_theme.R @@ -1,174 +1,4 @@ -#' @title Provides a simple wrapper for themes -#' -#' @description This function collects several lists if they are present. If absent, reasonable defaults are used. -#' When strata are not defined in the theme, they default to grey50 and will not be presented in the legend. -#' @param strata list containing the different strata and name:colour value pairs -#' @param fontsizes list containing the font sizes for different options -#' @param fontfamily string with the name of a supported font -#' @param grid boolean that specifies whether the grid should be drawn or not -#' @param bg string giving the colour for the background of the plot -#' @param legend_position string indicating the legend position -#' -#' @return Nested list with styling preferences for a ggplot object -#' -#' @examples -#' -#' theme <- visR::define_theme( -#' strata = list("SEX" = list("F" = "red", -#' "M" = "blue" -#' ) -#' ), -#' fontsizes = list("axis" = 12, -#' "ticks" = 10, -#' "legend_title" = 10, -#' "legend_text" = 8), -#' fontfamily = "Helvetica", -#' grid = list("major" = FALSE, -#' "minor" = FALSE -#' ), -#' bg = "transparent", -#' legend_position = "top" -#') -#' -#' @export - -define_theme <- function(strata = NULL, - fontsizes = NULL, - fontfamily = "Helvetica", - grid = FALSE, - bg = "transparent", - legend_position = NULL) { - theme <- list() - - if (!base::is.null(strata)) { - - if (base::is.list(strata)) { - - if (base::length(base::names(strata)) > 0) { - - theme[["strata"]] <- strata - - } else { - - base::warning("Invalid argument for `strata`. Please provide a named list as described in the documentation. Setting strata to `NULL` (which results in no specific theming for stratification).") - theme[["strata"]] <- NULL - - } - } - } - - if (!base::is.null(fontsizes)) { - - if (base::is.list(fontsizes)) { - - if (base::length(base::names(fontsizes)) > 0) { - - theme[["fontsizes"]] <- fontsizes - - } else { - - base::warning("Invalid argument for `fontsizes`. Please provide a named list for the individual plot elements as described in the documentation. Setting fontsizes to `NULL`.") - theme[["fontsizes"]] <- NULL - - } - - } else if (base::is.numeric(fontsizes)) { - - base::message("Setting all fontsizes to the provided numeric value. It is recommended to use a named list as described in the documentation.") - theme[["fontsizes"]] <- fontsizes - - } else { - - base::warning("Invalid argument for `fontsizes`. Please provide a named list as described in the documentation. Setting fontsizes to `NULL`.") - theme[["fontsizes"]] <- NULL - - } - } - - if (!base::is.character(fontfamily)) { - - base::warning("Invalid argument for `fontfamily`. Please provide the name of a valid font family as a string. Setting to default `Helvetica`.") - theme[["fontfamily"]] <- "Helvetica" - - } else if (base::is.character(fontfamily) & (base::length(fontfamily) > 1)) { - - base::warning(paste0("Invalid amount of arguments for `fontfamily`. Using the first one: ", fontfamily[[1]])) - theme[["fontfamily"]] <- fontfamily[[1]] - - } else if (base::is.character(fontfamily) & - (base::length(fontfamily) == 1) & - (base::nchar(fontfamily) == 0)) { - - base::warning("Invalid argument for `fontfamily`. Please provide the name of a valid font family as a string. Setting to default `Helvetica`.") - theme[["fontfamily"]] <- "Helvetica" - - } else { - - theme[["fontfamily"]] <- fontfamily - - } - - if (base::is.logical(grid)) { - - if (grid == TRUE) { - - theme[["grid"]] <- list("major" = TRUE, - "minor" = FALSE) - - } else { - - theme[["grid"]] <- grid - - } - - } else if (is.list(grid)) { - - if (("major" %in% names(grid)) | ("minor" %in% names(grid))) { - - theme[["grid"]] <- grid - - } else { - - base::warning("Invalid argument for `grid`. Please use a boolean or a list to indicate whether you want a background grid. Setting to default `FALSE`.") - theme[["grid"]] <- FALSE - - } - - } else { - - base::warning("Invalid argument for `grid`. Please use a boolean or a list to indicate whether you want a background grid. Setting to default `FALSE`.") - theme[["grid"]] <- FALSE - - } - - if (!base::is.character(bg)) { - - base::warning("Invalid argument for `bg`. Please provide the name of a valid colour as a string. Setting to default `transparent`.") - theme[["bg"]] <- "transparent" - - } else { - - theme[["bg"]] <- bg - - } - - if (base::is.null(legend_position) | base::is.character(legend_position)) { - - theme[["legend_position"]] <- legend_position - - } else { - - base::warning("Invalid argument for `legend_position`. Setting it to default \"right\".") - theme[["legend_position"]] <- "right" - - } - - base::class(theme) <- c( "visR_theme", class(theme)) - - return(theme) - -} - +#' `r lifecycle::badge("experimental")` #' @title Applies a theme to a ggplot object. #' #' @description Takes in the styling options defined through `visR::define_theme` and applies them to a plot. @@ -511,3 +341,5 @@ apply_theme <- function(gg, visR_theme_dict = NULL) { return(gg) } + +# END OF CODE ------------------------------------------------------------- diff --git a/R/define_theme.R b/R/define_theme.R new file mode 100644 index 00000000..65f5f7ed --- /dev/null +++ b/R/define_theme.R @@ -0,0 +1,175 @@ +#' `r lifecycle::badge("experimental")` +#' @title Provides a simple wrapper for themes +#' +#' @description This function collects several lists if they are present. If absent, reasonable defaults are used. +#' When strata are not defined in the theme, they default to grey50 and will not be presented in the legend. +#' @param strata named list containing the different strata and name:colour value pairs +#' @param fontsizes named list containing the font sizes for different options +#' @param fontfamily string with the name of a supported font +#' @param grid boolean that specifies whether the major and minor grid should be drawn. The drawing of major and minor +#' gridlines can be manipulated seperately by using a boolean indicator in a named `list` with elements `major` +#' and `minor`. +#' @param bg string defining the colour for the background of the plot +#' @param legend_position string defining the legend position. Valid options are NULL, 'top' 'bottom' 'right' 'left' +#' +#' @return Nested list with styling preferences for a ggplot object +#' +#' @examples +#' +#' theme <- visR::define_theme( +#' strata = list("SEX" = list("F" = "red", +#' "M" = "blue" +#' ) +#' ), +#' fontsizes = list("axis" = 12, +#' "ticks" = 10, +#' "legend_title" = 10, +#' "legend_text" = 8), +#' fontfamily = "Helvetica", +#' grid = list("major" = FALSE, +#' "minor" = FALSE +#' ), +#' bg = "transparent", +#' legend_position = "top" +#') +#' +#' @export + +define_theme <- function(strata = NULL, + fontsizes = NULL, + fontfamily = "Helvetica", + grid = FALSE, + bg = "transparent", + legend_position = NULL) { + theme <- list() + + if (!base::is.null(strata)) { + + if (base::is.list(strata)) { + + if (base::length(base::names(strata)) > 0) { + + theme[["strata"]] <- strata + + } else { + + base::warning("Invalid argument for `strata`. Please provide a named list as described in the documentation. Setting strata to `NULL` (which results in no specific theming for stratification).") + theme[["strata"]] <- NULL + + } + } + } + + if (!base::is.null(fontsizes)) { + + if (base::is.list(fontsizes)) { + + if (base::length(base::names(fontsizes)) > 0) { + + theme[["fontsizes"]] <- fontsizes + + } else { + + base::warning("Invalid argument for `fontsizes`. Please provide a named list for the individual plot elements as described in the documentation. Setting fontsizes to `NULL`.") + theme[["fontsizes"]] <- NULL + + } + + } else if (base::is.numeric(fontsizes)) { + + base::message("Setting all fontsizes to the provided numeric value. It is recommended to use a named list as described in the documentation.") + theme[["fontsizes"]] <- fontsizes + + } else { + + base::warning("Invalid argument for `fontsizes`. Please provide a named list as described in the documentation. Setting fontsizes to `NULL`.") + theme[["fontsizes"]] <- NULL + + } + } + + if (!base::is.character(fontfamily)) { + + base::warning("Invalid argument for `fontfamily`. Please provide the name of a valid font family as a string. Setting to default `Helvetica`.") + theme[["fontfamily"]] <- "Helvetica" + + } else if (base::is.character(fontfamily) & (base::length(fontfamily) > 1)) { + + base::warning(paste0("Invalid amount of arguments for `fontfamily`. Using the first one: ", fontfamily[[1]])) + theme[["fontfamily"]] <- fontfamily[[1]] + + } else if (base::is.character(fontfamily) & + (base::length(fontfamily) == 1) & + (base::nchar(fontfamily) == 0)) { + + base::warning("Invalid argument for `fontfamily`. Please provide the name of a valid font family as a string. Setting to default `Helvetica`.") + theme[["fontfamily"]] <- "Helvetica" + + } else { + + theme[["fontfamily"]] <- fontfamily + + } + + if (base::is.logical(grid)) { + + if (grid == TRUE) { + + theme[["grid"]] <- list("major" = TRUE, + "minor" = FALSE) + + } else { + + theme[["grid"]] <- grid + + } + + } else if (is.list(grid)) { + + if (("major" %in% names(grid)) | ("minor" %in% names(grid))) { + + theme[["grid"]] <- grid + + } else { + + base::warning("Invalid argument for `grid`. Please use a boolean or a list to indicate whether you want a background grid. Setting to default `FALSE`.") + theme[["grid"]] <- FALSE + + } + + } else { + + base::warning("Invalid argument for `grid`. Please use a boolean or a list to indicate whether you want a background grid. Setting to default `FALSE`.") + theme[["grid"]] <- FALSE + + } + + if (!base::is.character(bg)) { + + base::warning("Invalid argument for `bg`. Please provide the name of a valid colour as a string. Setting to default `transparent`.") + theme[["bg"]] <- "transparent" + + } else { + + theme[["bg"]] <- bg + + } + + if (base::is.null(legend_position) | isTRUE(legend_position %in% c("top", "right", "left", "bottom"))) { + + theme[["legend_position"]] <- legend_position + + } else { + + base::warning("Invalid argument for `legend_position`. Setting it to default \"right\".") + theme[["legend_position"]] <- "right" + + } + + base::class(theme) <- c( "visR_theme", class(theme)) + + return(theme) + +} + +# END OF CODE ------------------------------------------------------------- diff --git a/tests/testthat/test-apply_theme.R b/tests/testthat/test-apply_theme.R index 51ca4cdf..6f63885e 100644 --- a/tests/testthat/test-apply_theme.R +++ b/tests/testthat/test-apply_theme.R @@ -1,230 +1,44 @@ #' @title Specifications test-apply_theme.R -#' @section Last updated by: Tim Treis (tim.treis@@outlook.de) -#' @section Last update date: 2022-06-18T00:09:49 +#' @section Last updated by: Steven Haesendonckx (shaesen2@@its.jnj.com) +#' @section Last update date: 2022-06-20 #' #' @section List of tested specifications -#' T1. The `define_theme()` function returns a `visR_theme` object can contain valid input parameters for `apply_theme()`. -#' T1.1 No error when no parameters are specified. -#' T1.2 Not specifying any parameters returns a list. -#' T1.3 No error when `strata` is `NULL`. -#' T1.4 A warning when `strata` is an empty `list`. -#' T1.5 A warning when `strata` is an unnamed `list`. -#' T1.6 No warning when `strata` is a named `list`. -#' T1.7 No error when `fontsizes` is `NULL`. -#' T1.8 A warning when `fontsizes` is an empty `list`. -#' T1.9 A warning when `fontsizes` is an unnamed `list`. -#' T1.10 No warning when `fontsizes` is a named `list`. -#' T1.11 A message when `fontsizes` is a numerical value. -#' T1.12 A warning when `fontsizes` is neither `NULL`, a `list` or a `numeric`. -#' T1.13 No error when `fontfamily` is a string. -#' T1.14 A warning when `fontfamily` is an empty string. -#' T1.15 A warning when `fontfamily` is a vector of strings. -#' T1.16 A warning when `fontfamily` is anything but a string. -#' T1.17 No error when `grid` is a boolean. -#' T1.18 A warning when `grid` is a list but its members are not `major` or `minor`. -#' T1.19 A warning when `grid` is anything but a boolean or a list. -#' T1.20 No error when `bg` is a character. -#' T1.21 A warning when `bg` is anything but a character. -#' T1.22 No warning when `legend_position` is a `character` or `NULL`. -#' T1.23 A warning when `legend_position` is not a `character` or `NULL`. -#' T1.24 The returned theme object is of class `visR_theme`. -#' T2. The `apply_theme` function applies the specified changes to a `ggplot` object. -#' T2.1 No error when a `ggplot` plot is provided, but no theme. -#' T2.2 No error when a `ggplot` plot and a minimal `visR::define_theme` object are provided. -#' T2.3 No error when a `ggplot` plot and a complex `visR::define_theme` object are provided. -#' T2.4 A message when a theme not generated through `visR::define_theme` is provided. -#' T2.5 Colours applied through `visR::apply_theme()` are used in the resulting `ggplot` object. -#' T2.6 If `fontsizes` is a `numeric`, the other font occurrences are derived from it. -#' T2.7 If `fontsizes` is a `list`, the individual fonts are extracted and used. -#' T2.8 The fontfamily applied through `visR::apply_theme()` is used in the resulting `ggplot` object. -#' T2.9 If `grid` is a single `logical`, it is used for both major and minor grid. -#' T2.10 If `grid` is a named list containing 'major' and/or 'minor' as single `logical`s, these are used for their respective options. -#' T2.11 A warning when `grid` is a named list containing 'major' and/or 'minor' that are not single `logical`s. -#' T2.12 A warning when `grid` is a named list that does not contain 'major' and/or 'minor'. -#' T2.13 The background applied through `visR::apply_theme()` is used in the resulting `ggplot` object. -#' T2.14 The legend_position applied through `visR::apply_theme()` is used in the resulting `ggplot` object. -#' T2.15 The legend_position defined in `visR::visr()` is correctly passed through to the resulting `ggplot` object. -#' T2.16 If a strata has no colour assigned, the default colour (grey50) is used. -#' T2.17 When the theme dict contains no colour information for the strata of the ggplot object, the default visR colours are used. -#' T2.18 When the strata requires more colours than the visR palette holds, the default ggplot2 ones are chosen. +#' T1. The function applies the specified changes to a `ggplot` object. +#' T1.1 No error when a `ggplot` plot is provided, but no theme. +#' T1.2 No error when a `ggplot` plot and a minimal `visR::define_theme` object are provided. +#' T1.3 No error when a `ggplot` plot and a complex `visR::define_theme` object are provided. +#' T1.4 A message when a theme not generated through `visR::define_theme` is provided. +#' T1.5 If `fontsizes` is a `numeric`, the other font occurrences are derived from it. +#' T1.6 If `fontsizes` is a `list`, the individual fonts are extracted and used. +#' T1.7 The fontfamily applied through `visR::apply_theme()` is used in the resulting `ggplot` object. +#' T1.8 If `grid` is a single `logical`, it is used for both major and minor grid. +#' T1.9 If `grid` is a named list containing 'major' and/or 'minor' as single `logical`s, these are used for their respective options. +#' T1.10 A warning when `grid` is a named list containing 'major' and/or 'minor' that are not single `logical`s. +#' T1.11 A warning when `grid` is a named list that does not contain 'major' and/or 'minor'. +#' T1.12 The background applied through `visR::apply_theme()` is used in the resulting `ggplot` object. +#' T1.13 T1.14 The legend_position defined in `visR::visr()` is used when not defined through `visR::apply_theme()`.. +#' T1.14 The legend_position defined in `visR::visr()` is correctly passed through to the resulting `ggplot` object. +#' T1.15 If a stratum has no colour assigned, the default colour (grey50) is used. +#' T1.16 When the theme dict contains no colour information for the strata of the ggplot object, the default visR colours are used. +#' T1.17 When the stratum requires more colours than the visR palette holds, the default ggplot2 ones are chosen. +#' T1.18 If no strata colors can be mapped to the graph, a warning about the presence of more than 15 strata levels. +#' T1.19 The named list is used in the legend title. -# Requirement T1 ---------------------------------------------------------- - -testthat::context("apply_theme - T1. The `define_theme()` function returns a `visR_theme` object can contain valid input parameters for `apply_theme()`.") - -testthat::test_that("T1.1 No error when no parameters are specified.", { - - testthat::expect_error(visR::define_theme(), NA) - -}) - -testthat::test_that("T1.2 Not specifying any parameters returns a list.", { - - theme <- visR::define_theme() - - testthat::expect_true(is.list(theme)) - -}) - -testthat::test_that("T1.3 No error when `strata` is `NULL`.", { - - testthat::expect_error(visR::define_theme(strata = NULL), NA) - -}) - -testthat::test_that("T1.4 A warning when `strata` is an empty `list`.", { - - testthat::expect_warning(visR::define_theme(strata = list())) - -}) - -testthat::test_that("T1.5 A warning when `strata` is an unnamed `list`.", { - - testthat::expect_warning(visR::define_theme(strata = list("v", "i", "s", "R"))) - -}) - -testthat::test_that("T1.6 No warning when `strata` is a named `list`.", { - - testthat::expect_warning(visR::define_theme(strata = list("visR" = "visR")), NA) - -}) - -testthat::test_that("T1.7 No error when `fontsizes` is `NULL`.", { - - testthat::expect_error(visR::define_theme(fontsizes = NULL), NA) - -}) - -testthat::test_that("T1.8 A warning when `fontsizes` is an empty `list`.", { - - testthat::expect_warning(visR::define_theme(fontsizes = list())) - -}) - -testthat::test_that("T1.9 A warning when `fontsizes` is an unnamed `list`.", { - - testthat::expect_warning(visR::define_theme(fontsizes = list("s", "R"))) - -}) - -testthat::test_that("T1.10 No warning when `fontsizes` is a named `list`.", { - - testthat::expect_warning(visR::define_theme(fontsizes = list("a" = "a")), NA) - -}) - -testthat::test_that("T1.11 A message when `fontsizes` is a numerical value.", { - - testthat::expect_message(visR::define_theme(fontsizes = 12)) - -}) - -testthat::test_that("T1.12 A warning when `fontsizes` is neither `NULL`, a `list` or a `numeric`.", { - - testthat::expect_warning(visR::define_theme(fontsizes = "visR")) - -}) - -testthat::test_that("T1.13 No error when `fontfamily` is a string.", { - - testthat::expect_error(visR::define_theme(fontfamily = "Times"), NA) - -}) - -testthat::test_that("T1.14 A warning when `fontfamily` is an empty string.", { - - testthat::expect_warning(visR::define_theme(fontfamily = "")) - testthat::expect_warning(visR::define_theme(fontfamily = c(""))) - -}) - -testthat::test_that("T1.15 A warning when `fontfamily` is a vector of strings.", { - - testthat::expect_warning(visR::define_theme(fontfamily = c("a", "a"))) - -}) - -testthat::test_that("T1.16 A warning when `fontfamily` is anything but a string.", { - - testthat::expect_warning(visR::define_theme(fontfamily = NULL)) - testthat::expect_warning(visR::define_theme(fontfamily = 12)) - testthat::expect_warning(visR::define_theme(fontfamily = TRUE)) - testthat::expect_warning(visR::define_theme(fontfamily = list())) - -}) - -testthat::test_that("T1.17 No error when `grid` is a boolean.", { - - testthat::expect_error(visR::define_theme(grid = TRUE), NA) - testthat::expect_error(visR::define_theme(grid = FALSE), NA) - -}) - -testthat::test_that("T1.18 A warning when `grid` is a list but its members are not `major` or `minor`.", { - - testthat::expect_warning(visR::define_theme(grid = list("visR" = TRUE))) - -}) - -testthat::test_that("T1.19 A warning when `grid` is anything but a boolean or a list.", { - - testthat::expect_warning(visR::define_theme(grid = NULL)) - testthat::expect_warning(visR::define_theme(grid = 12)) - testthat::expect_warning(visR::define_theme(grid = "visR")) - testthat::expect_warning(visR::define_theme(grid = c())) - -}) - -testthat::test_that("T1.20 No error when `bg` is a character.", { - - testthat::expect_error(visR::define_theme(bg = "blue"), NA) - -}) - -testthat::test_that("T1.21 A warning when `bg` is anything but a character.", { - - testthat::expect_warning(visR::define_theme(bg = NULL)) - testthat::expect_warning(visR::define_theme(bg = 12)) - testthat::expect_warning(visR::define_theme(bg = list())) - -}) - -testthat::test_that("T1.22 No warning when `legend_position` is a `character` or `NULL`.", { - - testthat::expect_warning(visR::define_theme(legend_position = "top"), NA) - testthat::expect_warning(visR::define_theme(legend_position = NULL), NA) - -}) - -testthat::test_that("T1.23 A warning when `legend_position` is not a `character` or `NULL`.", { - - testthat::expect_warning(visR::define_theme(legend_position = 12)) - testthat::expect_warning(visR::define_theme(legend_position = list())) - -}) - -testthat::test_that("T1.24 The returned theme object is of class `visR_theme`.", { - - testthat::expect_true(inherits(visR::define_theme(), "visR_theme")) - -}) -# Requirement T2 ------------------------------------------------------------------------------------------------------- +# Requirement T1 ---------------------------------------------------------- -testthat::context("apply_theme - T2. The `apply_theme` function applies the specified changes to a `ggplot` object.") +testthat::context("apply_theme - T1. The function applies the specified changes to a `ggplot` object.") -testthat::test_that("T2.1 No error when a `ggplot` plot is provided, but no theme.", { +testthat::test_that("T1.1 No error when a `ggplot` plot is provided, but no theme.", { gg <- adtte %>% visR::estimate_KM("SEX") %>% visR::visr() testthat::expect_error(visR::apply_theme(gg), NA) - }) -testthat::test_that("T2.2 No error when a `ggplot` plot and a minimal `visR::define_theme` object are provided.", { +testthat::test_that("T1.2 No error when a `ggplot` plot and a minimal `visR::define_theme` object are provided.", { gg <- adtte %>% visR::estimate_KM("SEX") %>% @@ -234,10 +48,9 @@ testthat::test_that("T2.2 No error when a `ggplot` plot and a minimal `visR::def testthat::expect_error(visR::apply_theme(gg, theme), NA) testthat::expect_error(gg %>% visR::apply_theme(theme), NA) - }) -testthat::test_that("T2.3 No error when a `ggplot` plot and a complex `visR::define_theme` object are provided.", { +testthat::test_that("T1.3 No error when a `ggplot` plot and a complex `visR::define_theme` object are provided.", { gg <- adtte %>% visR::estimate_KM("SEX") %>% @@ -259,7 +72,7 @@ testthat::test_that("T2.3 No error when a `ggplot` plot and a complex `visR::def }) -testthat::test_that("T2.4 A message when a theme not generated through `visR::define_theme` is provided.", { +testthat::test_that("T1.4 A message when a theme not generated through `visR::define_theme` is provided.", { gg <- adtte %>% visR::estimate_KM("SEX") %>% @@ -275,27 +88,7 @@ testthat::test_that("T2.4 A message when a theme not generated through `visR::de }) -testthat::test_that("T2.5 Colours applied through `visR::apply_theme()` are used in the resulting `ggplot` object.", { - - gg <- adtte %>% - visR::estimate_KM("SEX") %>% - visR::visr() - - theme <- visR::define_theme(strata = list("SEX" = list("F" = "red", - "M" = "blue"), - "TRTA" = list("Placebo" = "cyan", - "Xanomeline High Dose" = "purple", - "Xanomeline Low Dose" = "brown"))) - - gg <- gg %>% visR::apply_theme(theme) - ggb <- ggplot2::ggplot_build(gg) - - testthat::expect_equal(unique(unlist(theme$strata$SEX)), - unique(ggb$data[[1]]$colour)) - -}) - -testthat::test_that("T2.6 If `fontsizes` is a `numeric`, the other font occurrences are derived from it.", { +testthat::test_that("T1.5 If `fontsizes` is a `numeric`, the other font occurrences are derived from it.", { gg <- adtte %>% visR::estimate_KM("SEX") %>% @@ -311,10 +104,9 @@ testthat::test_that("T2.6 If `fontsizes` is a `numeric`, the other font occurren testthat::expect_equal(theme$fontsizes, ggb$plot$theme$axis.text$size) testthat::expect_equal(theme$fontsizes, ggb$plot$theme$legend.title$size) testthat::expect_equal(theme$fontsizes, ggb$plot$theme$legend.text$size) - }) -testthat::test_that("T2.7 If `fontsizes` is a `list`, the individual fonts are extracted and used.", { +testthat::test_that("T1.6 If `fontsizes` is a `list`, the individual fonts are extracted and used.", { gg <- adtte %>% visR::estimate_KM("SEX") %>% @@ -333,10 +125,9 @@ testthat::test_that("T2.7 If `fontsizes` is a `list`, the individual fonts are e testthat::expect_equal(theme$fontsizes$ticks, ggb$plot$theme$axis.text$size) testthat::expect_equal(theme$fontsizes$legend_title, ggb$plot$theme$legend.title$size) testthat::expect_equal(theme$fontsizes$legend_text, ggb$plot$theme$legend.text$size) - }) -testthat::test_that("T2.8 The fontfamily applied through `visR::apply_theme()` is used in the resulting `ggplot` object.", { +testthat::test_that("T1.7 The fontfamily applied through `visR::apply_theme()` is used in the resulting `ggplot` object.", { gg <- adtte %>% visR::estimate_KM("SEX") %>% @@ -348,10 +139,9 @@ testthat::test_that("T2.8 The fontfamily applied through `visR::apply_theme()` i ggb <- ggplot2::ggplot_build(gg) testthat::expect_equal(theme$fontfamily, ggb$plot$theme$text$family) - }) -testthat::test_that("T2.9 If `grid` is a single `logical`, it is used for both major and minor grid.", { +testthat::test_that("T1.8 If `grid` is a single `logical`, it is used for both major and minor grid.", { gg <- adtte %>% visR::estimate_KM("SEX") %>% @@ -375,10 +165,9 @@ testthat::test_that("T2.9 If `grid` is a single `logical`, it is used for both m testthat::expect_true((inherits(ggb_grid_false$plot$theme$panel.grid.major, "element_blank")) & (inherits(ggb_grid_false$plot$theme$panel.grid.minor, "element_blank"))) - }) -testthat::test_that("T2.10 If `grid` is a named list containing 'major' and/or 'minor' as single `logical`s, these are used for their respective options.", { +testthat::test_that("T1.9 If `grid` is a named list containing 'major' and/or 'minor' as single `logical`s, these are used for their respective options.", { gg <- adtte %>% visR::estimate_KM("SEX") %>% @@ -407,10 +196,9 @@ testthat::test_that("T2.10 If `grid` is a named list containing 'major' and/or ' testthat::expect_true((inherits(ggb_grid_minor_and_major$plot$theme$panel.grid.major, "element_line")) & (inherits(ggb_grid_minor_and_major$plot$theme$panel.grid.minor, "element_line"))) - }) -testthat::test_that("T2.11 A warning when `grid` is a named list containing 'major' and/or 'minor' that are not single `logical`s.", { +testthat::test_that("T1.10 A warning when `grid` is a named list containing 'major' and/or 'minor' that are not single `logical`s.", { gg <- adtte %>% visR::estimate_KM("SEX") %>% @@ -423,10 +211,9 @@ testthat::test_that("T2.11 A warning when `grid` is a named list containing 'maj testthat::expect_warning(gg %>% visR::apply_theme(theme_major_correct)) testthat::expect_warning(gg %>% visR::apply_theme(theme_minor_correct)) - }) -testthat::test_that("T2.12 A warning when `grid` is a named list that does not contain 'major' and/or 'minor'.", { +testthat::test_that("T1.11 A warning when `grid` is a named list that does not contain 'major' and/or 'minor'.", { gg <- adtte %>% visR::estimate_KM("SEX") %>% @@ -438,10 +225,9 @@ testthat::test_that("T2.12 A warning when `grid` is a named list that does not c names(theme$grid) <- c("visR", "Rsiv") testthat::expect_warning(gg %>% visR::apply_theme(theme)) - }) -testthat::test_that("T2.13 The background applied through `visR::apply_theme()` is used in the resulting `ggplot` object.", { +testthat::test_that("T1.12 The background applied through `visR::apply_theme()` is used in the resulting `ggplot` object.", { gg <- adtte %>% visR::estimate_KM("SEX") %>% @@ -453,10 +239,9 @@ testthat::test_that("T2.13 The background applied through `visR::apply_theme()` ggb <- ggplot2::ggplot_build(gg) testthat::expect_equal(theme$bg, ggb$plot$theme$panel.background$fill) - }) -testthat::test_that("T2.14 The legend_position applied through `visR::apply_theme()` is used in the resulting `ggplot` object.", { +testthat::test_that("T1.13 The legend_position applied through `visR::apply_theme()` is used in the resulting `ggplot` object.", { gg <- adtte %>% visR::estimate_KM("SEX") %>% @@ -481,10 +266,9 @@ testthat::test_that("T2.14 The legend_position applied through `visR::apply_them testthat::expect_equal(theme_right$legend_position, ggb_right$plot$theme$legend.position) testthat::expect_equal(theme_bottom$legend_position, ggb_bottom$plot$theme$legend.position) testthat::expect_equal(theme_left$legend_position, ggb_left$plot$theme$legend.position) - }) -testthat::test_that("T2.15 The legend_position defined in `visR::visr()` is correctly passed through to the resulting `ggplot` object.", { +testthat::test_that("T1.14 The legend_position defined in `visR::visr()` is used when not defined through `visR::apply_theme()`.", { gg_top <- adtte %>% visR::estimate_KM("SEX") %>% @@ -513,10 +297,9 @@ testthat::test_that("T2.15 The legend_position defined in `visR::visr()` is corr testthat::expect_true("right" %in% ggb_right$plot$theme$legend.position) testthat::expect_true("bottom" %in% ggb_bottom$plot$theme$legend.position) testthat::expect_true("left" %in% ggb_left$plot$theme$legend.position) - }) -testthat::test_that("T2.16 If a strata has no colour assigned, the default colour (grey50) is used.", { +testthat::test_that("T1.15 If a stratum has no colour assigned, the default colour (grey50) is used.", { theme <- visR::define_theme(strata = list("SEX" = list("F" = NULL, "M" = "blue"), @@ -535,19 +318,130 @@ testthat::test_that("T2.16 If a strata has no colour assigned, the default colou gg <- adtte %>% visR::estimate_KM(strata = "SEX") %>% visR::visr() %>% - visR::add_CI() %>% visR::apply_theme(theme) ggb <- ggplot2::ggplot_build(gg) - # The colour for strata "F" is set to NULL, so it should be filled with "grey50". testthat::expect_true("grey50" %in% unlist(unique(ggb$data[[1]]["fill"]))) + testthat::expect_true("blue" %in% unlist(unique(ggb$data[[1]]["fill"]))) + + ## example 2 + theme <- visR::define_theme( + strata = list("Sex, ph.ecog" = list("Female, 0" = "red", + "Male, 0" = "blue"))) + + survobj <- survival::lung %>% + dplyr::mutate(sex = as.factor(ifelse(sex == 1, "Male", "Female"))) %>% + dplyr::mutate(status = status - 1) %>% + dplyr::rename(Age = "age", Sex = "sex", Status = "status", Days = "time") %>% + visR::estimate_KM(strata = c("Sex", "ph.ecog"), CNSR = "Status", AVAL = "Days") + + gg <-survobj %>% + visR::visr() %>% + visR::apply_theme(theme) + + ggb <- ggplot2::ggplot_build(gg) + + cols <- unlist(unique(ggb$data[[1]]["fill"])) + testthat::expect_true("grey50" %in% cols) + testthat::expect_true("red" %in% cols) + testthat::expect_true("blue" %in% cols) +}) + +testthat::test_that("T1.16 If no strata colors can be mapped to the graph, the default visR palette is used as long as there are less than 15 strata levels.", { + + ## example 1 + theme <- visR::define_theme( + strata = list("Sex" = list("Female" = "blue", + "Male" = "red"), + "ph.ecog" = list("0" = "cyan", + "1" = "purple", + "2" = "brown"))) + + + survobj <- survival::lung %>% + dplyr::mutate(sex = as.factor(ifelse(sex == 1, "Male", "Female"))) %>% + dplyr::mutate(status = status - 1) %>% + dplyr::rename(Age = "age", Sex = "sex", Status = "status", Days = "time") %>% + visR::estimate_KM(strata = c("ph.ecog", "Sex"), CNSR = "Status", AVAL = "Days") + + gg <- survobj%>% + visR::visr() %>% + visR::apply_theme(theme) + + ggb <- ggplot2::ggplot_build(gg) + + cols <- unlist(unique(ggb$data[[1]]["fill"])) + names(cols) <- NULL + + testthat::expect_true(length(setdiff(c("#000000", "#490092", "#920000", "#009292", "#B66DFF", "#DBD100", "#FFB677"), cols)) == 0) + + ## example 2 + theme <- visR::define_theme() + + survobj <- survival::lung %>% + dplyr::mutate(sex = as.factor(ifelse(sex == 1, "Male", "Female"))) %>% + dplyr::mutate(status = status - 1) %>% + dplyr::rename(Age = "age", Sex = "sex", Status = "status", Days = "time") %>% + visR::estimate_KM(strata = NULL, CNSR = "Status", AVAL = "Days") + + gg <- survobj%>% + visR::visr() %>% + visR::apply_theme(theme) + + ggb <- ggplot2::ggplot_build(gg) + + cols <- unlist(unique(ggb$data[[1]]["fill"])) + names(cols) <- NULL + + testthat::expect_true(length(setdiff(c("#000000"), cols)) == 0) +}) + +testthat::test_that("T1.17 If no strata colors can be mapped to the graph, the original colors are retained if there are more than 15 strata levels.", { + + survobj <- survival::lung %>% + dplyr::mutate(sex = as.factor(ifelse(sex == 1, "Male", "Female"))) %>% + dplyr::mutate(status = status - 1) %>% + dplyr::rename(Age = "age", Sex = "sex", Status = "status", Days = "time") %>% + visR::estimate_KM(strata = c("Age", "pat.karno"), CNSR = "Status", AVAL = "Days") + + gg <- suppressWarnings(survobj %>% + visR::visr() %>% + visR::apply_theme(theme)) + + ggb <- ggplot2::ggplot_build(gg) + + # Get expected colours + # https://stackoverflow.com/questions/8197559/emulate-ggplot2-default-color-palette + gg_colour_hue <- function(n) { + hues = seq(15, 375, length = n + 1) + hcl(h = hues, l = 65, c = 100)[1:n] + } + + cols_expected <- gg_colour_hue(n=length(unique(names(survobj$strata)))) + + cols <- unlist(unique(ggb$data[[1]]["fill"])) + names(cols) <- NULL + + testthat::expect_true(length(cols_expected %in% cols)>1) +}) + +testthat::test_that("T1.18 If no strata colors can be mapped to the graph, a warning about the presence of more than 15 strata levels.", { + survobj <- survival::lung %>% + dplyr::mutate(sex = as.factor(ifelse(sex == 1, "Male", "Female"))) %>% + dplyr::mutate(status = status - 1) %>% + dplyr::rename(Age = "age", Sex = "sex", Status = "status", Days = "time") %>% + visR::estimate_KM(strata = c("Age", "pat.karno"), CNSR = "Status", AVAL = "Days") + + testthat::expect_warning(survobj %>% visR::visr() %>% visR::apply_theme(theme)) }) -testthat::test_that("T2.17 When the theme dict contains no colour information for the strata of the ggplot object, the default visR colours are used.", { +testthat::test_that("T1.19 The named list is used in the legend title.", { - theme <- visR::define_theme(strata = list("TRTA" = list("Placebo" = "cyan", + theme <- visR::define_theme(strata = list("SEX" = list("F" = NULL, + "M" = "blue"), + "TRTA" = list("Placebo" = "cyan", "Xanomeline High Dose" = "purple", "Xanomeline Low Dose" = "brown")), fontsizes = list("axis" = 12, @@ -562,55 +456,65 @@ testthat::test_that("T2.17 When the theme dict contains no colour information fo gg <- adtte %>% visR::estimate_KM(strata = "SEX") %>% visR::visr() %>% - visR::add_CI() %>% visR::apply_theme(theme) ggb <- ggplot2::ggplot_build(gg) - # No colours for strata "SEX" given, so the first two colours of the visR - # palette will be used -> "#000000" and "#490092" - testthat::expect_true("#000000" %in% unlist(unique(ggb$data[[1]]["fill"]))) - testthat::expect_true("#490092" %in% unlist(unique(ggb$data[[1]]["fill"]))) -}) + testthat::expect_error("We need a test to see if legend says SEX", NA) -testthat::test_that("T2.18 When the strata requires more colours than the visR palette holds, the default ggplot2 ones are chosen.", { + ## example 2 + theme <- visR::define_theme( + strata = list("Sex, ph.ecog" = list("Female" = "red", + "Male" = "blue"))) - theme <- visR::define_theme(strata = list("TRTDUR" = list("F" = "red", - "M" = "blue")), - fontsizes = list("axis" = 12, - "ticks" = 10, - "legend_title" = 10, - "legend_text" = 8), - fontfamily = "Helvetica", - grid = FALSE, - bg = "transparent", - legend_position = "top") + survobj <- survival::lung %>% + dplyr::mutate(sex = as.factor(ifelse(sex == 1, "Male", "Female"))) %>% + dplyr::mutate(status = status - 1) %>% + dplyr::rename(Age = "age", Sex = "sex", Status = "status", Days = "time") %>% + visR::estimate_KM(strata = c("Sex"), CNSR = "Status", AVAL = "Days") - adtte2 <- adtte - adtte2$TRTDUR <- round(adtte$TRTDUR/10) - gg <- adtte2 %>% - visR::estimate_KM(strata = "TRTDUR") %>% + gg <-survobj %>% visR::visr() %>% - visR::add_CI() %>% visR::apply_theme(theme) - # Get expected colours - # https://stackoverflow.com/questions/8197559/emulate-ggplot2-default-color-palette - gg_colour_hue <- function(n) { - hues = seq(15, 375, length = n + 1) - hcl(h = hues, l = 65, c = 100)[1:n] - } - cols_expected <- gg_colour_hue(length(unique(adtte2$TRTDUR))) - - # Get used colours and strip off the alpha part ggb <- ggplot2::ggplot_build(gg) - cols_observed <- unlist(unique(ggb$data[[1]]["fill"])) - cols_observed <- gsub(".{2}$", "", cols_observed) - names(cols_observed) <- NULL - testthat::expect_equal(cols_expected, cols_observed) - -}) + testthat::expect_error("We need a test to see if legend says Sex, Ph.ecog if it does not make sense", NA) + +}) + +# testthat::test_that("T1.18 When the strata requires more colours than the visR palette holds, the default ggplot2 ones are chosen.", { +# +# theme <- visR::define_theme(strata = list("TRTDUR" = list("F" = "red", +# "M" = "blue")), +# fontsizes = list("axis" = 12, +# "ticks" = 10, +# "legend_title" = 10, +# "legend_text" = 8), +# fontfamily = "Helvetica", +# grid = FALSE, +# bg = "transparent", +# legend_position = "top") +# +# adtte2 <- adtte +# adtte2$TRTDUR <- round(adtte$TRTDUR/10) +# gg <- adtte2 %>% +# visR::estimate_KM(strata = "TRTDUR") %>% +# visR::visr() %>% +# visR::apply_theme(theme) +# +# cols_expected <- gg_colour_hue(length(unique(adtte2$TRTDUR))) +# +# # Get used colours and strip off the alpha part +# ggb <- ggplot2::ggplot_build(gg) +# cols_observed <- unlist(unique(ggb$data[[1]]["fill"])) +# cols_observed <- gsub(".{2}$", "", cols_observed) +# names(cols_observed) <- NULL +# +# testthat::expect_equal(cols_expected, cols_observed) +# +# }) # END OF CODE ------------------------------------------------------------- + diff --git a/tests/testthat/test-define_theme.R b/tests/testthat/test-define_theme.R new file mode 100644 index 00000000..b0b7a065 --- /dev/null +++ b/tests/testthat/test-define_theme.R @@ -0,0 +1,222 @@ +#' @title Specifications test-define_theme.R +#' @section Last updated by: Steven Haesendonckx (shaesen2@@its.jnj.com) +#' @section Last update date: 2022-06-20 +#' +#' @section List of tested specifications +#' T1. The function returns a `visR_theme` object. +#' T1.1 The function returns a list of class `visR_theme`. +#' T1.2 No error when no parameters are specified. +#' T2. The function accepts `strata` as argument. +#' T2.1 No error when `strata` is `NULL`. +#' T2.2 A warning when `strata` is an empty `list`. +#' T2.3 A warning when `strata` is an unnamed `list`. +#' T2.4 No warning when `strata` is a named `list`. +#' T3. The function accepts `fontsizes` as argument. +#' T3.1 No error when `fontsizes` is undefined. +#' T3.2 A warning when `fontsizes` is an empty `list`. +#' T3.3 A warning when `fontsizes` is `character`. +#' T3.4 A message when `fontsizes` is a numerical value. +#' T3.5 A warning when `fontsizes` is an unnamed `list`. +#' T3.6 No warning when `fontsizes` is a named `list`. +#' T4. The function accepts `fontfamily` as argument. +#' T4.1 No error when `fontfamily` is a string. +#' T4.2 A warning when `fontfamily` is an empty string. +#' T4.3 A warning when `fontfamily` is a vector of strings. +#' T4.4 A warning when `fontfamily` is anything but a string. +#' T5. The function accepts `grid` as argument. +#' T5.1 No error when `grid` is a boolean. +#' T5.2 No error when `grid` is a named list with elements `major` `minor`. +#' T5.3 A warning when `grid` is a unnmaed list. +#' T5.4 A warning when `grid` is a named list without elements `major` `minor`. +#' T5.5 A warning when `grid` is anything but a boolean or a list. +#' T6. The function accepts `bg` as argument. +#' T6.1 No error when `bg` is a character. +#' T6.2 A warning when `bg` is anything but a character. +#' T7. The function accepts `legend_position` as argument. +#' T7.1 `legend_position` accept 4 different strings `top` `right` `bottom` `left`. +#' T7.2 `legend_position` accepts NULL. +#' T7.3 A warning when `legend_position` is not NULL nor a string equal to `top` `right` `bottom` `left`. + + +# Requirement T1 ---------------------------------------------------------- + +testthat::context("define_theme - T1. `define_theme()` returns a `visR_theme` object.") + +testthat::test_that("T1.1 `define_theme()` returns a list of class `visR_theme`.", { + + testthat::expect_true(inherits(visR::define_theme(), "visR_theme")) + testthat::expect_true(inherits(visR::define_theme(), "list")) +}) + +testthat::test_that("T1.2 No error when no parameters are specified.", { + + testthat::expect_error(visR::define_theme(), NA) +}) + +# Requirement T2 ---------------------------------------------------------- + +testthat::context("define_theme - T2. The function accepts `strata` as argument.") + +testthat::test_that("T2.1 No error when `strata` is `NULL`.", { + + testthat::expect_error(visR::define_theme(strata = NULL), NA) +}) + +testthat::test_that("T2.2 A warning when `strata` is an empty `list`.", { + + testthat::expect_warning(visR::define_theme(strata = list())) +}) + +testthat::test_that("T2.3 A warning when `strata` is an unnamed `list`.", { + + testthat::expect_warning(visR::define_theme(strata = list("v", "i", "s", "R"))) +}) + +testthat::test_that("T2.4 No warning when `strata` is a named `list`.", { + + testthat::expect_warning(visR::define_theme(strata = list("visR" = "visR")), NA) +}) + +# Requirement T3 ---------------------------------------------------------- + +testthat::context("define_theme - T3. The function accepts `fontsizes` as argument.") + +testthat::test_that("T3.1 No error when `fontsizes` is undefined.", { + + testthat::expect_error(visR::define_theme(), NA) +}) + +testthat::test_that("T3.2 A warning when `fontsizes` is an empty `list`.", { + + testthat::expect_warning(visR::define_theme(fontsizes = list())) +}) + +testthat::test_that("T3.3 A warning when `fontsizes` is `character`.", { + + testthat::expect_warning(visR::define_theme(fontsizes = "NULL")) +}) + +testthat::test_that("T3.4 A message when `fontsizes` is a numerical value.", { + + testthat::expect_message(visR::define_theme(fontsizes = 12)) +}) + +testthat::test_that("T3.5 A warning when `fontsizes` is an unnamed `list`.", { + + testthat::expect_warning(visR::define_theme(fontsizes = list("s", "R"))) +}) + +testthat::test_that("T3.6 No warning when `fontsizes` is a named `list`.", { + + testthat::expect_warning(visR::define_theme(fontsizes = list("a" = "a")), NA) +}) + +# Requirement T4 ---------------------------------------------------------- + +testthat::context("define_theme - T4. The function accepts `fontfamily` as argument.") + +testthat::test_that("T4.1 No error when `fontfamily` is a string.", { + + testthat::expect_error(visR::define_theme(fontfamily = "Times"), NA) +}) + +testthat::test_that("T4.2 A warning when `fontfamily` is an empty string.", { + + testthat::expect_warning(visR::define_theme(fontfamily = "")) + testthat::expect_warning(visR::define_theme(fontfamily = c(""))) +}) + +testthat::test_that("T4.3 A warning when `fontfamily` is a vector of strings.", { + + testthat::expect_warning(visR::define_theme(fontfamily = c("a", "a"))) +}) + +testthat::test_that("T4.4 A warning when `fontfamily` is anything but a string.", { + + testthat::expect_warning(visR::define_theme(fontfamily = NULL)) + testthat::expect_warning(visR::define_theme(fontfamily = 12)) + testthat::expect_warning(visR::define_theme(fontfamily = TRUE)) + testthat::expect_warning(visR::define_theme(fontfamily = list())) +}) + +# Requirement T5 ---------------------------------------------------------- + +testthat::context("define_theme - T5. The function accepts `grid` as argument.") + +testthat::test_that("T5.1 No error when `grid` is a boolean.", { + + testthat::expect_error(visR::define_theme(grid = TRUE), NA) + testthat::expect_error(visR::define_theme(grid = FALSE), NA) +}) + +testthat::test_that("T5.2 No error when `grid` is a named list with elements `major` `minor`.", { + + testthat::expect_error(visR::define_theme(grid = list("major" = TRUE, "minor" = FALSE)), NA) + testthat::expect_error(visR::define_theme(grid = list("major" = TRUE)), NA) + testthat::expect_error(visR::define_theme(grid = list("minor" = TRUE)), NA) +}) + +testthat::test_that("T5.3 A warning when `grid` is a unnmaed list.", { + + testthat::expect_warning(visR::define_theme(grid = list(TRUE,TRUE))) +}) + +testthat::test_that("T5.4 A warning when `grid` is a named list without elements `major` `minor`.", { + + testthat::expect_warning(visR::define_theme(grid = list("visR" = TRUE))) +}) + +testthat::test_that("T5.5 A warning when `grid` is anything but a boolean or a list.", { + + testthat::expect_warning(visR::define_theme(grid = NULL)) + testthat::expect_warning(visR::define_theme(grid = 12)) + testthat::expect_warning(visR::define_theme(grid = "visR")) + testthat::expect_warning(visR::define_theme(grid = c())) +}) + +# Requirement T6 ---------------------------------------------------------- + +testthat::context("define_theme - T6. The function accepts `bg` as argument.") + +testthat::test_that("T6.1 No error when `bg` is a character.", { + + testthat::expect_error(visR::define_theme(bg = "blue"), NA) +}) + +testthat::test_that("T6.2 A warning when `bg` is anything but a character.", { + + testthat::expect_warning(visR::define_theme(bg = NULL)) + testthat::expect_warning(visR::define_theme(bg = 12)) + testthat::expect_warning(visR::define_theme(bg = list())) +}) + +# Requirement T7 ---------------------------------------------------------- + +testthat::context("define_theme - T7. The function accepts `legend_position` as argument.") + +testthat::test_that("T7.1 `legend_position` accept 4 different strings `top` `right` `bottom` `left`.", { + + testthat::expect_error(visR::define_theme(legend_position = "top"), NA) + testthat::expect_error(visR::define_theme(legend_position = "bottom"), NA) + testthat::expect_error(visR::define_theme(legend_position = "left"), NA) + testthat::expect_error(visR::define_theme(legend_position = "right"), NA) + testthat::expect_warning(visR::define_theme(legend_position = "top"), NA) + testthat::expect_warning(visR::define_theme(legend_position = "bottom"), NA) + testthat::expect_warning(visR::define_theme(legend_position = "left"), NA) + testthat::expect_warning(visR::define_theme(legend_position = "right"), NA) +}) + +testthat::test_that("T7.2 `legend_position` accepts NULL.", { + + testthat::expect_error(visR::define_theme(legend_position = NULL), NA) + testthat::expect_warning(visR::define_theme(legend_position = NULL), NA) +}) + +testthat::test_that("T7.3 A warning when `legend_position` is not NULL nor a string equal to `top` `right` `bottom` `left`.", { + + testthat::expect_warning(visR::define_theme(legend_position = "visR")) + testthat::expect_warning(visR::define_theme(legend_position = 12)) + testthat::expect_warning(visR::define_theme(legend_position = list())) +}) + +# END OF CODE ------------------------------------------------------------- From 42b5b945c7137736fdd11d40a731a898c87823ff Mon Sep 17 00:00:00 2001 From: shaesen2 Date: Mon, 20 Jun 2022 09:19:48 -0400 Subject: [PATCH 6/9] Updated code/testing for coverage --- R/apply_theme.R | 17 ++++++++-------- man/apply_theme.Rd | 4 +++- man/define_theme.Rd | 17 ++++++++++------ man/visR-package.Rd | 7 ++++++- tests/testthat/test-apply_theme.R | 33 ++++++++++++++++++++++++++++++- 5 files changed, 60 insertions(+), 18 deletions(-) diff --git a/R/apply_theme.R b/R/apply_theme.R index 81a93404..5617fd65 100644 --- a/R/apply_theme.R +++ b/R/apply_theme.R @@ -30,7 +30,6 @@ #' gg <- adtte %>% #' visR::estimate_KM(strata = "SEX") %>% #' visR::visr() %>% -#' visR::add_CI() %>% #' visR::apply_theme(theme) #' gg #' @@ -123,19 +122,19 @@ apply_theme <- function(gg, visR_theme_dict = NULL) { skipcolor <- TRUE } - if (length(intersect(names(cols), colneed)) > 0) { - cols <- cols[intersect(names(cols), colneed)] - } else if (length(colneed) <= length(coldefault)) { - cols <- coldefault[1:length(colneed)] - names(cols) <- colneed - skipcolordef <- FALSE - } else { + if (length(colneed) > length(coldefault)){ ## too many strata, keep as is # layer <- ggplot2::layer_data(gg) # cols <- layer[unique(layer[["group"]]), "colour"] # names(cols) <- colneed - skipcolordef <- TRUE + skipcolordef <- FALSE skipcolor <- TRUE + } else if (length(intersect(names(cols), colneed)) > 0) { + cols <- cols[intersect(names(cols), colneed)] + } else if (length(colneed) <= length(coldefault)) { + cols <- coldefault[1:length(colneed)] + names(cols) <- colneed + skipcolordef <- FALSE } } diff --git a/man/apply_theme.Rd b/man/apply_theme.Rd index 23239136..bf08c31f 100644 --- a/man/apply_theme.Rd +++ b/man/apply_theme.Rd @@ -17,6 +17,9 @@ object of class \code{ggplot} \description{ Takes in the styling options defined through \code{visR::define_theme} and applies them to a plot. } +\details{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} +} \examples{ library(visR) @@ -39,7 +42,6 @@ theme <- visR::define_theme(strata = list("SEX" = list("F" = "red", gg <- adtte \%>\% visR::estimate_KM(strata = "SEX") \%>\% visR::visr() \%>\% - visR::add_CI() \%>\% visR::apply_theme(theme) gg diff --git a/man/define_theme.Rd b/man/define_theme.Rd index 7001b62f..c070ee3e 100644 --- a/man/define_theme.Rd +++ b/man/define_theme.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/apply_theme.R +% Please edit documentation in R/define_theme.R \name{define_theme} \alias{define_theme} \title{Provides a simple wrapper for themes} @@ -14,17 +14,19 @@ define_theme( ) } \arguments{ -\item{strata}{list containing the different strata and name:colour value pairs} +\item{strata}{named list containing the different strata and name:colour value pairs} -\item{fontsizes}{list containing the font sizes for different options} +\item{fontsizes}{named list containing the font sizes for different options} \item{fontfamily}{string with the name of a supported font} -\item{grid}{boolean that specifies whether the grid should be drawn or not} +\item{grid}{boolean that specifies whether the major and minor grid should be drawn. The drawing of major and minor +gridlines can be manipulated seperately by using a boolean indicator in a named \code{list} with elements \code{major} +and \code{minor}.} -\item{bg}{string giving the colour for the background of the plot} +\item{bg}{string defining the colour for the background of the plot} -\item{legend_position}{string indicating the legend position} +\item{legend_position}{string defining the legend position. Valid options are NULL, 'top' 'bottom' 'right' 'left'} } \value{ Nested list with styling preferences for a ggplot object @@ -33,6 +35,9 @@ Nested list with styling preferences for a ggplot object This function collects several lists if they are present. If absent, reasonable defaults are used. When strata are not defined in the theme, they default to grey50 and will not be presented in the legend. } +\details{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} +} \examples{ theme <- visR::define_theme( diff --git a/man/visR-package.Rd b/man/visR-package.Rd index fa3793e4..41bf0b18 100644 --- a/man/visR-package.Rd +++ b/man/visR-package.Rd @@ -8,7 +8,12 @@ \description{ \if{html}{\figure{logo.png}{options: align='right' alt='logo' width='120'}} -To enable fit-for-purpose, reusable clinical and medical research focused visualizations and tables with sensible defaults and based on graphical principles as described in: "Vandemeulebroecke et al. (2018)" , "Vandemeulebroecke et al. (2019)" , and "Morris et al. (2019)" . +To enable fit-for-purpose, reusable clinical and medical + research focused visualizations and tables with sensible defaults and + based on graphical principles as described in: "Vandemeulebroecke et + al. (2018)" , "Vandemeulebroecke et al. (2019)" + , and "Morris et al. (2019)" + . } \seealso{ Useful links: diff --git a/tests/testthat/test-apply_theme.R b/tests/testthat/test-apply_theme.R index 6f63885e..138ca988 100644 --- a/tests/testthat/test-apply_theme.R +++ b/tests/testthat/test-apply_theme.R @@ -399,6 +399,14 @@ testthat::test_that("T1.16 If no strata colors can be mapped to the graph, the d testthat::test_that("T1.17 If no strata colors can be mapped to the graph, the original colors are retained if there are more than 15 strata levels.", { + ## not a relevant strata list, but is required to test the requirement easily + theme <- visR::define_theme( + strata = list("Sex" = list("Female" = "blue", + "Male" = "red"), + "ph.ecog" = list("0" = "cyan", + "1" = "purple", + "2" = "brown"))) + survobj <- survival::lung %>% dplyr::mutate(sex = as.factor(ifelse(sex == 1, "Male", "Female"))) %>% dplyr::mutate(status = status - 1) %>% @@ -428,13 +436,36 @@ testthat::test_that("T1.17 If no strata colors can be mapped to the graph, the o testthat::test_that("T1.18 If no strata colors can be mapped to the graph, a warning about the presence of more than 15 strata levels.", { + ## not a relevant strata list, but is required to test the requirement easily + theme <- visR::define_theme( + strata = list("Age*pat.karno" = list("39, 90 " = "red", + "40, 80 " = "blue", + "41, 80 " = "blue", + "42, 80 " = "blue", + "43, 90 " = "blue", + "44, 80 " = "blue", + "44, 90 " = "blue", + "44, 100" = "blue", + "45, 100" = "blue", + "46, 100" = "blue", + "47, 90 " = "blue", + "48, 60 " = "blue", + "48, 80 " = "blue", + "48, 90 " = "blue", + "49, 60 " = "blue", + "49, 70 " = "blue", + "50, 60 " = "blue", + "50, 80 " = "blue", + "50, 100" = "blue"))) + + survobj <- survival::lung %>% dplyr::mutate(sex = as.factor(ifelse(sex == 1, "Male", "Female"))) %>% dplyr::mutate(status = status - 1) %>% dplyr::rename(Age = "age", Sex = "sex", Status = "status", Days = "time") %>% visR::estimate_KM(strata = c("Age", "pat.karno"), CNSR = "Status", AVAL = "Days") - testthat::expect_warning(survobj %>% visR::visr() %>% visR::apply_theme(theme)) + testthat::expect_warning(survobj %>% visR::visr() %>% apply_theme(theme)) }) testthat::test_that("T1.19 The named list is used in the legend title.", { From eb314ded6353e8ed487d97ece86b28b8fb5450c3 Mon Sep 17 00:00:00 2001 From: shaesen2 Date: Tue, 21 Jun 2022 05:00:24 -0400 Subject: [PATCH 7/9] Include legend title testing --- tests/testthat/helper.R | 113 +++++++++++++++++------------- tests/testthat/test-apply_theme.R | 8 +-- 2 files changed, 66 insertions(+), 55 deletions(-) diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R index b6e9d351..21f461ea 100644 --- a/tests/testthat/helper.R +++ b/tests/testthat/helper.R @@ -4,34 +4,34 @@ #' @keywords internal .check_traceback_stack_for_ggplot_aesthetics_warning <- function() { - + # ggplot returns its errors for aesthetics as overloaded arguments to the # a print call (I think?) which makes them non-catchable through testthat. # This part retrieves it anyway. - + traceback_stack <- base::.traceback(1) - + # Collapse elements of stack in case they are multiline for (i in 1:base::length(traceback_stack)) { - + traceback_stack[i] <- base::paste0(base::paste0(traceback_stack[i])) - + } - + abortive_warning <- base::grep("[^_]Aesthetics", traceback_stack, value = TRUE) - + return(abortive_warning) - + } #' A helper function for map numbers to an arbitrary range #' @keywords internal .map_numbers_to_new_range <- function(numbers, lower, upper) { - + # Used to artificially generated a set amount of strata for testing # https://stackoverflow.com/a/18303620/10169453 - + # Shifting the vector so that min(x) == 0 numbers <- numbers - min(numbers) # Scaling to the range of [0, 1] @@ -40,11 +40,11 @@ numbers <- numbers * (upper - lower) # Shifting to the needed level return(as.factor(round(numbers + lower, 0))) - + } -#' A helper function that returns the full paths of the package files as a vector. -#' It is used as part of the watchdogs documented here at +#' A helper function that returns the full paths of the package files as a vector. +#' It is used as part of the watchdogs documented here at #' https://github.com/openpharma/visR/wiki/Coding-principles#package-maintenance #' @keywords internal @@ -53,98 +53,98 @@ documentation = FALSE, vignettes = FALSE, remove_watchdog = TRUE) { - + files <- list() wd <- getwd() - + if (functions) { - - R_files <- list.files(path = file.path(wd, "/../../R"), - pattern = "*.R", + + R_files <- list.files(path = file.path(wd, "/../../R"), + pattern = "*.R", full.names = TRUE) files <- c(files, unlist(R_files)) - + } - + if (tests) { - + test_files <- list.files(path = wd, - pattern = "*.R", + pattern = "*.R", full.names = TRUE) files <- c(files, unlist(test_files)) - + } - + if (documentation) { - - man_files <- list.files(path = file.path(wd, "/../../man"), - pattern = "*.Rd", + + man_files <- list.files(path = file.path(wd, "/../../man"), + pattern = "*.Rd", full.names = TRUE) files <- c(files, unlist(man_files)) } - + if (vignettes) { - + vignette_files <- list.files(path = file.path(wd, "/../../vignettes"), - pattern = "*.Rmd", + pattern = "*.Rmd", full.names = TRUE) files <- c(files, unlist(vignette_files)) - + } - + if (remove_watchdog) { files <- files[!grepl("test-watchdog_CRAN.R", files)] } - + return(unlist(files)) - + } -#' A helper function that returns a formatted table containing a table of -#' content based on the `testthat` context and name info given in the file. +#' A helper function that returns a formatted table containing a table of +#' content based on the `testthat` context and name info given in the file. #' @keywords internal .get_test_TOC <- function(path_to_file) { - + txt <- paste(readLines(path_to_file, warn = FALSE), collapse = "\n") tests <- gregexpr("testthat::test_that\\(\\\"(.+?)\"", txt) contexts <- gregexpr("context\\(\\\"(.+?)\"", txt) - + context_df <- data.frame("pos" = unlist(contexts)) - context_df["match.length"] <- attributes(contexts[[1]])$match.length + context_df["match.length"] <- attributes(contexts[[1]])$match.length context_df["index.type"] <- attributes(contexts[[1]])$index.type context_df["useBytes"] <- attributes(contexts[[1]])$useBytes context_df["type"] = "context" context_df["content"] <- regmatches(txt, contexts) - + context_df$content <- base::lapply(context_df$content, function(c) { c <- gsub(pattern = "context\\(\"(.+?)T", replacement = "T", x = c) c <- gsub(pattern = "\"", replacement = "", x = c) c }) %>% unlist() - + test_df <- data.frame("pos" = unlist(tests)) - test_df["match.length"] <- attributes(tests[[1]])$match.length + test_df["match.length"] <- attributes(tests[[1]])$match.length test_df["index.type"] <- attributes(tests[[1]])$index.type test_df["useBytes"] <- attributes(tests[[1]])$useBytes test_df["type"] <- "test" test_df["content"] <- regmatches(txt, tests) - + test_df$content <- base::lapply(test_df$content, function(c) { c <- gsub(pattern = "testthat::test_that\\(\\\"T", replacement = "T", x = c) c <- gsub(pattern = "\"", replacement = "", x = c) c }) %>% unlist() - + matches <- rbind(context_df, test_df) matches <- matches[order(matches$pos),] - - + + toc <- "" toc <- base::lapply(matches$content, function(line) { toc <- paste0(toc, "#' ", line, "\n") }) %>% unlist() %>% paste0(collapse = "") - + return(toc) - + } # get_pvalue - Results to compare against --------------------------------- @@ -204,4 +204,19 @@ get_pvalue_ref134 <- base::rbind.data.frame( get_pvalue_ref3, get_pvalue_ref4, make.row.names = FALSE -) \ No newline at end of file +) + +get_legend_title <- function(gg) { + + ggb <- ggplot2::ggplot_build(gg) + ggt <- ggplot2::ggplot_gtable(ggb) + + legend_grob_id <- which(sapply(ggt$grobs, function(x) x$name) == "guide-box") + legend_grob <- ggt$grobs[[legend_grob_id]] + + legend_title_id <- which(sapply(legend_grob$grobs[[1]]$layout$name, function(x) x) == "title") + legend_gtree <- legend_grob$grobs[[1]]$grobs[[legend_title_id]] + legend_title <- legend_gtree$children[[1]]$children[[1]]$label + + return(legend_title) +} diff --git a/tests/testthat/test-apply_theme.R b/tests/testthat/test-apply_theme.R index 138ca988..eb8f91e4 100644 --- a/tests/testthat/test-apply_theme.R +++ b/tests/testthat/test-apply_theme.R @@ -489,10 +489,8 @@ testthat::test_that("T1.19 The named list is used in the legend title.", { visR::visr() %>% visR::apply_theme(theme) - ggb <- ggplot2::ggplot_build(gg) - - testthat::expect_error("We need a test to see if legend says SEX", NA) + testthat::expect_equal(get_legend_title(gg), "SEX") ## example 2 theme <- visR::define_theme( @@ -509,9 +507,7 @@ testthat::test_that("T1.19 The named list is used in the legend title.", { visR::visr() %>% visR::apply_theme(theme) - ggb <- ggplot2::ggplot_build(gg) - - testthat::expect_error("We need a test to see if legend says Sex, Ph.ecog if it does not make sense", NA) + testthat::expect_equal(get_legend_title(gg), "Sex, ph.ecog") }) From 224c31501f2b66262ec1dfa300fc4ded57b73e0e Mon Sep 17 00:00:00 2001 From: Mark Baillie Date: Tue, 21 Jun 2022 16:15:21 +0200 Subject: [PATCH 8/9] Knit readme Move lifecycle badges to under description Add questioning badge to tabelone --- R/apply_theme.R | 5 +++-- R/define_theme.R | 7 ++++--- R/get_tableone.R | 5 +++-- README.md | 22 +--------------------- man/apply_theme.Rd | 4 +--- man/define_theme.Rd | 4 +--- man/get_tableone.Rd | 3 +-- man/visR-package.Rd | 9 ++------- 8 files changed, 16 insertions(+), 43 deletions(-) diff --git a/R/apply_theme.R b/R/apply_theme.R index 5617fd65..ab7fa699 100644 --- a/R/apply_theme.R +++ b/R/apply_theme.R @@ -1,7 +1,8 @@ -#' `r lifecycle::badge("experimental")` #' @title Applies a theme to a ggplot object. #' -#' @description Takes in the styling options defined through `visR::define_theme` and applies them to a plot. +#' @description +#' `r lifecycle::badge("experimental")` +#' Takes in the styling options defined through `visR::define_theme` and applies them to a plot. #' #' @param gg object of class \code{ggplot} #' @param visR_theme_dict nested list containing possible font options diff --git a/R/define_theme.R b/R/define_theme.R index 65f5f7ed..69831347 100644 --- a/R/define_theme.R +++ b/R/define_theme.R @@ -1,8 +1,9 @@ -#' `r lifecycle::badge("experimental")` #' @title Provides a simple wrapper for themes #' -#' @description This function collects several lists if they are present. If absent, reasonable defaults are used. -#' When strata are not defined in the theme, they default to grey50 and will not be presented in the legend. +#' @description +#' `r lifecycle::badge("experimental")` +#' This function collects several lists if they are present. If absent, reasonable defaults are used. +#' When strata are not defined in the theme, they default to grey50 and will not be presented in the legend. #' @param strata named list containing the different strata and name:colour value pairs #' @param fontsizes named list containing the font sizes for different options #' @param fontfamily string with the name of a supported font diff --git a/R/get_tableone.R b/R/get_tableone.R index a3be1925..796a9487 100644 --- a/R/get_tableone.R +++ b/R/get_tableone.R @@ -1,7 +1,8 @@ -#' `r lifecycle::badge("experimental")` #' @title Calculate summary statistics #' -#' @description S3 method for creating a table of summary statistics. +#' @description +#' `r lifecycle::badge("questioning")` +#' S3 method for creating a table of summary statistics. #' The summary statistics can be used for presentation in tables such as table one or baseline and demography tables. #' #' The summary statistics estimated are conditional on the variable type: continuous, binary, categorical, etc. diff --git a/README.md b/README.md index 953328ed..c6638496 100644 --- a/README.md +++ b/README.md @@ -14,7 +14,7 @@ coverage](https://codecov.io/gh/openpharma/visR/branch/develop/graph/badge.svg)] [![pkgdown](https://github.com/openpharma/visR/actions/workflows/makedocs.yml/badge.svg)](https://github.com/openpharma/visR/actions/workflows/makedocs.yml) [![CRAN status](https://www.r-pkg.org/badges/version/visR)](https://CRAN.R-project.org/package=visR) - + The goal of visR is to enable fit-for-purpose, reusable clinical and @@ -93,26 +93,6 @@ adtte %>% -#### Summary Table - -The `tableone()` function presents summary statistics in a table format. - -``` r -## table by treatment - without overall and render with GT -tableone <- - adtte %>% - dplyr::select(AGE, SEX, TRTA) %>% - visR::tableone( - strata = "TRTA", - overall = TRUE, - title = "Cohort Summary", - datasource = "ADaM Interim Dataset for Time-to-Event Analysis", - engine = "gt" - ) -``` - - - ## Cite visR ``` text diff --git a/man/apply_theme.Rd b/man/apply_theme.Rd index bf08c31f..ba8e43f2 100644 --- a/man/apply_theme.Rd +++ b/man/apply_theme.Rd @@ -15,10 +15,8 @@ apply_theme(gg, visR_theme_dict = NULL) object of class \code{ggplot} } \description{ -Takes in the styling options defined through \code{visR::define_theme} and applies them to a plot. -} -\details{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} +Takes in the styling options defined through \code{visR::define_theme} and applies them to a plot. } \examples{ diff --git a/man/define_theme.Rd b/man/define_theme.Rd index c070ee3e..3c6ffa23 100644 --- a/man/define_theme.Rd +++ b/man/define_theme.Rd @@ -32,12 +32,10 @@ and \code{minor}.} Nested list with styling preferences for a ggplot object } \description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} This function collects several lists if they are present. If absent, reasonable defaults are used. When strata are not defined in the theme, they default to grey50 and will not be presented in the legend. } -\details{ -\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} -} \examples{ theme <- visR::define_theme( diff --git a/man/get_tableone.Rd b/man/get_tableone.Rd index 11dd370c..8acddba8 100644 --- a/man/get_tableone.Rd +++ b/man/get_tableone.Rd @@ -33,6 +33,7 @@ object of class tableone. That is a list of data specified summaries for all input variables. } \description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#questioning}{\figure{lifecycle-questioning.svg}{options: alt='[Questioning]'}}}{\strong{[Questioning]}} S3 method for creating a table of summary statistics. The summary statistics can be used for presentation in tables such as table one or baseline and demography tables. @@ -46,8 +47,6 @@ By default the following summary stats are calculated: } } \details{ -\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} - It is possible to provide your own summary function. Please have a loot at summary for inspiration. } \note{ diff --git a/man/visR-package.Rd b/man/visR-package.Rd index 41bf0b18..5038986a 100644 --- a/man/visR-package.Rd +++ b/man/visR-package.Rd @@ -6,14 +6,9 @@ \alias{visR-package} \title{visR: Clinical Graphs and Tables Adhering to Graphical Principles} \description{ -\if{html}{\figure{logo.png}{options: align='right' alt='logo' width='120'}} +\if{html}{\figure{logo.png}{options: style='float: right' alt='logo' width='120'}} -To enable fit-for-purpose, reusable clinical and medical - research focused visualizations and tables with sensible defaults and - based on graphical principles as described in: "Vandemeulebroecke et - al. (2018)" , "Vandemeulebroecke et al. (2019)" - , and "Morris et al. (2019)" - . +To enable fit-for-purpose, reusable clinical and medical research focused visualizations and tables with sensible defaults and based on graphical principles as described in: "Vandemeulebroecke et al. (2018)" \doi{10.1002/pst.1912}, "Vandemeulebroecke et al. (2019)" \doi{10.1002/psp4.12455}, and "Morris et al. (2019)" \doi{10.1136/bmjopen-2019-030215}. } \seealso{ Useful links: From ce81d7297a99376450faeecfb001031754780fa0 Mon Sep 17 00:00:00 2001 From: Mark Baillie Date: Tue, 21 Jun 2022 16:30:29 +0200 Subject: [PATCH 9/9] add update to news,md --- NEWS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/NEWS.md b/NEWS.md index 9ac685bd..823b7381 100644 --- a/NEWS.md +++ b/NEWS.md @@ -15,6 +15,7 @@ * The strata variable is now removed from the body of `tableone()` results. (#254) * The `visr.survfit()` function no longer warns about x-axis label when `PARAM` column not found in original data set. (#378) * The call saved in the `estimate_KM()` object has been updated to a quosure--ensuring the original function call can always be recalled. +* `define_theme()`updated to ensure that only the strata present in the theme are displayed. (#388) * Improved documentation for `visr()` and other generic functions. (#301)