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/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) diff --git a/R/apply_theme.R b/R/apply_theme.R index e6c5496e..ab7fa699 100644 --- a/R/apply_theme.R +++ b/R/apply_theme.R @@ -1,181 +1,8 @@ -#' @title Provides a simple wrapper for themes -#' -#' @description This function collects several lists if they are present. If absent, reasonable defaults are used. -#' -#' @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" -#' ), -#' "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 = 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) - -} - #' @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 @@ -204,7 +31,6 @@ define_theme <- function(strata = NULL, #' gg <- adtte %>% #' visR::estimate_KM(strata = "SEX") %>% #' visR::visr() %>% -#' visR::add_CI() %>% #' visR::apply_theme(theme) #' gg #' @@ -214,7 +40,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 @@ -233,6 +59,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) @@ -264,6 +93,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,6 +109,34 @@ 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]])) + + # 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(colneed) > length(coldefault)){ + ## too many strata, keep as is + # layer <- ggplot2::layer_data(gg) + # cols <- layer[unique(layer[["group"]]), "colour"] + # names(cols) <- colneed + 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 + } } # fonts and text ----------------------------------------------------------- @@ -443,9 +303,27 @@ 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") + + 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 + - ggplot2::scale_colour_manual(values = cols, - aesthetics = c("colour", "fill")) + ggplot2::theme( text = font_family, axis.title.x = axis_title, @@ -460,6 +338,8 @@ apply_theme <- function(gg, visR_theme_dict = NULL) { legend.position = legend_position ) + return(gg) } +# END OF CODE ------------------------------------------------------------- diff --git a/R/define_theme.R b/R/define_theme.R new file mode 100644 index 00000000..69831347 --- /dev/null +++ b/R/define_theme.R @@ -0,0 +1,176 @@ +#' @title Provides a simple wrapper for themes +#' +#' @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 +#' @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/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/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/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 23239136..ba8e43f2 100644 --- a/man/apply_theme.Rd +++ b/man/apply_theme.Rd @@ -15,6 +15,7 @@ apply_theme(gg, visR_theme_dict = NULL) object of class \code{ggplot} } \description{ +\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{ @@ -39,7 +40,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 b54c2fb4..3c6ffa23 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,33 +14,33 @@ 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 } \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. } \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/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/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 889eede3..eb8f91e4 100644 --- a/tests/testthat/test-apply_theme.R +++ b/tests/testthat/test-apply_theme.R @@ -1,245 +1,61 @@ #' @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: 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. +#' 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 T1 ---------------------------------------------------------- -# Requirement T2 ------------------------------------------------------------------------------------------------------- +testthat::context("apply_theme - T1. The function applies the specified changes to a `ggplot` object.") -testthat::context("apply_theme - T2. The `apply_theme` function applies the specified changes to a `ggplot` object.") +testthat::test_that("T1.1 No error when a `ggplot` plot is provided, but no theme.", { -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.", { - +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") %>% 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.", { - +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") %>% visR::visr() - + theme <- visR::define_theme(strata = list("SEX" = list("F" = "red", "M" = "blue"), "TRTA" = list("Placebo" = "cyan", @@ -250,239 +66,210 @@ 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.", { - +testthat::test_that("T1.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.", { - +testthat::test_that("T1.5 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.", { - +testthat::test_that("T1.6 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.", { - +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") %>% 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.", { - +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") %>% 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.", { - +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") %>% 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"))) - - 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_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"))) }) -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") %>% 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'.", { - +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") %>% 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.", { - +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") %>% 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.", { - +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") %>% 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.", { - +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") %>% visR::visr(legend_position = "top") @@ -495,7 +282,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 +292,256 @@ 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("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"), + "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::apply_theme(theme) + + ggb <- ggplot2::ggplot_build(gg) + + 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.", { + + ## 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) %>% + 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.", { + + ## 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() %>% apply_theme(theme)) +}) + +testthat::test_that("T1.19 The named list is used in the legend title.", { + + 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::apply_theme(theme) + + + testthat::expect_equal(get_legend_title(gg), "SEX") + + ## example 2 + theme <- visR::define_theme( + strata = list("Sex, ph.ecog" = list("Female" = "red", + "Male" = "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"), CNSR = "Status", AVAL = "Days") + + gg <-survobj %>% + visR::visr() %>% + visR::apply_theme(theme) + + testthat::expect_equal(get_legend_title(gg), "Sex, ph.ecog") + +}) + +# 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 ------------------------------------------------------------- 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() -```