From 89eb282350a44af28e7c4a32583b642a1b351940 Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Sun, 12 Nov 2023 20:30:11 +0000 Subject: [PATCH 01/32] allow fixed_followup_days as vector --- R/internal.R | 22 ++++++++++++++++------ R/maraca.R | 26 +++++++++++++++++++------- man/maraca.Rd | 6 ++++-- man/plot.hce.Rd | 8 ++++++-- tests/testthat/test_maraca.R | 27 ++++++++++++++++++++++++++- vignettes/maraca.Rmd | 2 ++ 6 files changed, 73 insertions(+), 18 deletions(-) diff --git a/R/internal.R b/R/internal.R index 295d467..6de360a 100644 --- a/R/internal.R +++ b/R/internal.R @@ -115,12 +115,18 @@ n <- dplyr::n num_tte_outcomes <- length(tte_outcomes) - hce_dat$t_cdf <- (num_tte_outcomes + 2) * fixed_followup_days + + if (length(fixed_followup_days) == 1) { + fixed_followup_days <- rep(fixed_followup_days, times = num_tte_outcomes) + } + + hce_dat$t_cdf <- sum(fixed_followup_days) + 2 * max(fixed_followup_days) for (i in seq_len(num_tte_outcomes)) { + add_previous_end <- ifelse(i == 1, 0, sum(fixed_followup_days[1:(i - 1)])) hce_dat[hce_dat$outcome == tte_outcomes[[i]], ]$t_cdf <- hce_dat[hce_dat$outcome == tte_outcomes[[i]], ]$value + - fixed_followup_days * (i - 1) + add_previous_end } hce_ecdf <- @@ -135,12 +141,13 @@ hce_ecdf <- hce_ecdf[order(hce_ecdf$ecdf_values), ] hce_ecdf$adjusted.time <- 0 - for (entry in tte_outcomes) { + for (i in seq_len(num_tte_outcomes)) { + entry <- tte_outcomes[i] outcome_filter <- hce_ecdf$outcome == entry hce_ecdf[outcome_filter, ]$adjusted.time <- meta[meta$outcome == entry, ]$startx + hce_ecdf[outcome_filter, ]$value / - fixed_followup_days * + fixed_followup_days[i] * meta[meta$outcome == entry, ]$proportion } @@ -302,8 +309,11 @@ if (is.null(fixed_followup_days)) { checkmate::assertNames(names(x), must.include = "TTEfixed") - checkmate::assert_int(x$TTEfixed[[1]]) - fixed_followup_days <- x$TTEfixed[[1]] + checkmate::assert_integerish(x$TTEfixed) + + fixed_followup_days <- unname(sapply(tte, function(tte_ind) { + x[x$GROUP == tte_ind, "TTEfixed"][[1]] + })) } maraca_obj <- maraca( diff --git a/R/maraca.R b/R/maraca.R index 56b3ce2..fa5cdad 100644 --- a/R/maraca.R +++ b/R/maraca.R @@ -21,8 +21,10 @@ #' in the data. The vector names must match in order "outcome", "arm", #' and "value". Note that this parameter only need to be #' specified if you have column names different from the ones above. -#' @param fixed_followup_days A mandatory specification of the integer number -#' of fixed follow-up days in the study. +#' @param fixed_followup_days A mandatory specification of the fixed follow-up +#' days in the study. Can be a single integer value +#' for all tte-outcomes or a vector with one +#' integer value per tte-outcome. #' @param compute_win_odds If TRUE compute the win odds, otherwise (default) #' don't compute them. #' @@ -71,7 +73,13 @@ maraca <- function( permutation.of = c("outcome", "arm", "value") ) - checkmate::assert_int(fixed_followup_days) + checkmate::assert_integerish(fixed_followup_days) + + if (!(length(fixed_followup_days) %in% c(1, length(tte_outcomes)))) { + stop(paste("fixed_followup_days needs to be either a single value or", + "a vector with one value for each tte outcome")) + } + checkmate::assert_flag(compute_win_odds) `%>%` <- dplyr::`%>%` @@ -101,8 +109,8 @@ maraca <- function( # discard the death event for this patient (after 500) # but will at the same time not include the MI since # we don't know about it - if (fixed_followup_days < - max(meta[meta$outcome %in% tte_outcomes, "maxday"])) { + if (any(fixed_followup_days < + unlist(meta[meta$outcome %in% tte_outcomes, "maxday"]))) { stop(paste("Time-to-event data contain events", "after the fixed_followup_days - either", "provide a longer follow-up time or", @@ -601,9 +609,13 @@ plot.maraca <- function( #' on fixed follow-up days in the study #' (column PADY or TTEfixed, #' depending on hce version). -#' Otherwise, this argument must be specified. +#' Otherwise, this argument must be specified +#' to give the fixed follow-up days in the study. +#' Can be a single integer value +#' for all tte-outcomes or a vector with one +#' integer value per tte-outcome. #' Note: If argument is specified and HCE object -#' contains PADY or TTEfixed column, then +#' also contains PADY or TTEfixed column, then #' fixed_followup_days argument is used. #' @param compute_win_odds If TRUE compute the win odds, otherwise (default) #' don't compute them. diff --git a/man/maraca.Rd b/man/maraca.Rd index ccce64c..adb84bd 100644 --- a/man/maraca.Rd +++ b/man/maraca.Rd @@ -45,8 +45,10 @@ in the data. The vector names must match in order "outcome", "arm", and "value". Note that this parameter only need to be specified if you have column names different from the ones above.} -\item{fixed_followup_days}{A mandatory specification of the integer number -of fixed follow-up days in the study.} +\item{fixed_followup_days}{A mandatory specification of the fixed follow-up +days in the study. Can be a single integer value +for all tte-outcomes or a vector with one +integer value per tte-outcome.} \item{compute_win_odds}{If TRUE compute the win odds, otherwise (default) don't compute them.} diff --git a/man/plot.hce.Rd b/man/plot.hce.Rd index 7aa8bb3..39ed227 100644 --- a/man/plot.hce.Rd +++ b/man/plot.hce.Rd @@ -47,9 +47,13 @@ Accepts "default", "violin", "box" and "scatter".} on fixed follow-up days in the study (column PADY or TTEfixed, depending on hce version). -Otherwise, this argument must be specified. +Otherwise, this argument must be specified +to give the fixed follow-up days in the study. +Can be a single integer value +for all tte-outcomes or a vector with one +integer value per tte-outcome. Note: If argument is specified and HCE object -contains PADY or TTEfixed column, then +also contains PADY or TTEfixed column, then fixed_followup_days argument is used.} \item{compute_win_odds}{If TRUE compute the win odds, otherwise (default) diff --git a/tests/testthat/test_maraca.R b/tests/testthat/test_maraca.R index ef2baf2..6f860d5 100644 --- a/tests/testthat/test_maraca.R +++ b/tests/testthat/test_maraca.R @@ -234,6 +234,31 @@ test_that("alternativeColumnNames", { expect_s3_class(mar, "maraca") }) +test_that("vectorFixedFollowUp", { + file <- fixture_path("hce_scenario_c.csv") + data <- read.csv(file, stringsAsFactors = FALSE) + + tte_outcomes <- c( + "Outcome I", "Outcome II", "Outcome III", "Outcome IV" + ) + continuous_outcome <- "Continuous outcome" + arm_levels <- c(active = "Active", control = "Control") + column_names <- c( + outcome = "GROUP", arm = "TRTP", value = "AVAL0" + ) + + fixed_followup_days <- ceiling(unname(sapply(tte_outcomes, function(tte) { + max(data[data$GROUP == tte, "AVAL0"]) + }))) + + mar <- maraca( + data, tte_outcomes, continuous_outcome, arm_levels, + column_names, + fixed_followup_days + ) + expect_s3_class(mar, "maraca") +}) + test_that("wrongParameters", { file <- fixture_path("hce_scenario_c.csv") data <- read.csv(file, stringsAsFactors = FALSE) @@ -282,7 +307,7 @@ test_that("wrongParameters", { column_names, fixed_followup_days = 12.3 ), - regexp = "single integerish value" + regexp = "Must be of type 'integerish'" ) expect_error( maraca(data, tte_outcomes, continuous_outcome, arm_levels, diff --git a/vignettes/maraca.Rmd b/vignettes/maraca.Rmd index 180afb7..2c8c7a6 100644 --- a/vignettes/maraca.Rmd +++ b/vignettes/maraca.Rmd @@ -98,6 +98,8 @@ arm_levels = c(active = "Active", control = "Control") Finally, the `original` column must contain numerical values. We also need to specify the follow-up time for the time-to event outcomes. +This can be one single timepoint (integer) for all time-to event outcomes +or individual timepoints for each. Note that there can be no observed events in the data after the follow-up time specified. From a238e6de199c8cef6067b8f8d4196bc60c310b16 Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Sun, 12 Nov 2023 20:37:53 +0000 Subject: [PATCH 02/32] Fix lintr error --- R/maraca.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/maraca.R b/R/maraca.R index fa5cdad..d803350 100644 --- a/R/maraca.R +++ b/R/maraca.R @@ -110,7 +110,7 @@ maraca <- function( # but will at the same time not include the MI since # we don't know about it if (any(fixed_followup_days < - unlist(meta[meta$outcome %in% tte_outcomes, "maxday"]))) { + unlist(meta[meta$outcome %in% tte_outcomes, "maxday"]))) { stop(paste("Time-to-event data contain events", "after the fixed_followup_days - either", "provide a longer follow-up time or", From dc76470b4c1373c1c1b5b7c9e4336fb96adb4c53 Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Sun, 12 Nov 2023 21:59:41 +0000 Subject: [PATCH 03/32] Change parameter names tte_outcomes to step_outcomes and continuous_outcome to last_outcome --- DESCRIPTION | 3 +- R/internal.R | 42 +++---- R/maraca.R | 110 ++++++++++++------ R/winOddsPlots.R | 21 ++-- man/component_plot.hce.Rd | 12 +- man/component_plot.maraca.Rd | 4 +- man/maraca.Rd | 42 +++++-- man/plot.hce.Rd | 19 +++- man/plot.maraca.Rd | 4 +- man/plot_maraca.Rd | 4 +- man/validate_maraca_plot.Rd | 4 +- tests/testthat/test_maraca.R | 212 +++++++++++++++++------------------ vignettes/maraca.Rmd | 8 +- vignettes/themes.Rmd | 4 +- vignettes/validation.Rmd | 4 +- vignettes/winOdds.Rmd | 4 +- 16 files changed, 293 insertions(+), 204 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index c52468e..ad7d4c3 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -25,7 +25,8 @@ Imports: dplyr (>= 1.0), tidyr (>= 1.2), ggplot2 (>= 3.3), - checkmate (>= 2.1) + checkmate (>= 2.1), + lifecycle RoxygenNote: 7.2.3 Suggests: knitr (>= 1.39), diff --git a/R/internal.R b/R/internal.R index 6de360a..360b4f5 100644 --- a/R/internal.R +++ b/R/internal.R @@ -107,14 +107,14 @@ # Calculates the cumulative distribution for TTE outcomes .compute_ecdf_by_outcome <- function( - hce_dat, meta, tte_outcomes, continuous_outcome, arm_levels, + hce_dat, meta, step_outcomes, last_outcome, arm_levels, fixed_followup_days ) { `%>%` <- dplyr::`%>%` n <- dplyr::n - num_tte_outcomes <- length(tte_outcomes) + num_tte_outcomes <- length(step_outcomes) if (length(fixed_followup_days) == 1) { fixed_followup_days <- rep(fixed_followup_days, times = num_tte_outcomes) @@ -124,8 +124,8 @@ for (i in seq_len(num_tte_outcomes)) { add_previous_end <- ifelse(i == 1, 0, sum(fixed_followup_days[1:(i - 1)])) - hce_dat[hce_dat$outcome == tte_outcomes[[i]], ]$t_cdf <- - hce_dat[hce_dat$outcome == tte_outcomes[[i]], ]$value + + hce_dat[hce_dat$outcome == step_outcomes[[i]], ]$t_cdf <- + hce_dat[hce_dat$outcome == step_outcomes[[i]], ]$value + add_previous_end } @@ -136,13 +136,13 @@ tmp$ecdf_values <- 100 * stats::ecdf(tmp$t_cdf)(tmp$t_cdf) tmp %>% dplyr::filter(outcome %in% outcomes) - }, df = hce_dat, outcomes = tte_outcomes)) + }, df = hce_dat, outcomes = step_outcomes)) hce_ecdf <- hce_ecdf[order(hce_ecdf$ecdf_values), ] hce_ecdf$adjusted.time <- 0 for (i in seq_len(num_tte_outcomes)) { - entry <- tte_outcomes[i] + entry <- step_outcomes[i] outcome_filter <- hce_ecdf$outcome == entry hce_ecdf[outcome_filter, ]$adjusted.time <- meta[meta$outcome == entry, ]$startx + @@ -173,14 +173,14 @@ # Computes the continuous information .compute_continuous <- function( - hce_dat, meta, ecdf_mod, tte_outcomes, continuous_outcome, arm_levels) { + hce_dat, meta, ecdf_mod, step_outcomes, last_outcome, arm_levels) { `%>%` <- dplyr::`%>%` n <- dplyr::n ctrl <- unname(arm_levels["control"]) - continuous_data <- hce_dat[hce_dat$outcome == continuous_outcome, ] - start_continuous_endpoint <- meta[meta$outcome == continuous_outcome, ]$startx + continuous_data <- hce_dat[hce_dat$outcome == last_outcome, ] + start_continuous_endpoint <- meta[meta$outcome == last_outcome, ]$startx continuous_data$x <- .to_rangeab( continuous_data$value, @@ -195,11 +195,11 @@ continuous_data$y_level <- ecdf_mod$meta[ ecdf_mod$meta$arm == unname(arm_levels["active"]) & - ecdf_mod$meta$outcome == utils::tail(tte_outcomes, 1), + ecdf_mod$meta$outcome == utils::tail(step_outcomes, 1), ]$ecdf_end continuous_data[continuous_data$arm == ctrl, ]$y_level <- ecdf_mod$meta[ ecdf_mod$meta$arm == ctrl & - ecdf_mod$meta$outcome == utils::tail(tte_outcomes, 1), + ecdf_mod$meta$outcome == utils::tail(step_outcomes, 1), ]$ecdf_end return(list( @@ -210,7 +210,7 @@ # Reformats the data coming in from outside so that it fits our expectation. .reformat_and_check_data <- function( - data, tte_outcomes, continuous_outcome, arm_levels, column_names) { + data, step_outcomes, last_outcome, arm_levels, column_names) { `%>%` <- dplyr::`%>%` vars <- dplyr::vars all_of <- dplyr::all_of @@ -223,7 +223,7 @@ hce_dat$outcome <- as.character(hce_dat$outcome) hce_dat$arm <- as.character(hce_dat$arm) - endpoints <- c(tte_outcomes, continuous_outcome) + endpoints <- c(step_outcomes, last_outcome) if (!all(as.character(unique(hce_dat[, "arm"])) %in% unname(arm_levels))) { @@ -233,8 +233,8 @@ if (!all(as.character(unique(hce_dat[, "outcome"])) %in% unname(endpoints))) { stop(paste("Outcome variable contains different values", - "then given in parameters tte_outcomes and", - "continuous_outcome")) + "then given in parameters step_outcomes and", + "last_outcome")) } hce_dat <- hce_dat %>% @@ -244,7 +244,7 @@ levels = c(arm_levels)[c("active", "control")]) # Check if the endpoints are all present - for (entry in c(tte_outcomes, continuous_outcome)) { + for (entry in c(step_outcomes, last_outcome)) { if (!any(hce_dat$outcome == entry)) { stop(paste( "Outcome", entry, "is not present in column", @@ -284,10 +284,10 @@ return(minor_grid) } -.maraca_from_hce_data <- function(x, continuous_outcome, arm_levels, +.maraca_from_hce_data <- function(x, last_outcome, arm_levels, fixed_followup_days, compute_win_odds) { - checkmate::assert_string(continuous_outcome) + checkmate::assert_string(last_outcome) checkmate::assert_names(names(x), must.include = c("GROUP", "TRTP", "AVAL0")) @@ -299,7 +299,7 @@ checkmate::assert_flag(compute_win_odds) x <- as.data.frame(x, stringsAsFactors = FALSE) - tte <- sort(unique(x$GROUP)[unique(x$GROUP) != continuous_outcome]) + tte <- sort(unique(x$GROUP)[unique(x$GROUP) != last_outcome]) # Small bugfix to allow for name change of variable TTEFixed in newer # version of HCE package @@ -318,8 +318,8 @@ maraca_obj <- maraca( data = x, - tte_outcomes = tte, - continuous_outcome = continuous_outcome, + step_outcomes = tte, + last_outcome = last_outcome, column_names = c(outcome = "GROUP", arm = "TRTP", value = "AVAL0"), arm_levels = arm_levels, fixed_followup_days = fixed_followup_days, diff --git a/R/maraca.R b/R/maraca.R index d803350..a56d9b2 100644 --- a/R/maraca.R +++ b/R/maraca.R @@ -6,10 +6,12 @@ #' labels #' - arm column, containing the arm a given row belongs to. #' - value column, containing the values. -#' @param tte_outcomes A vector of strings containing the time-to-event -#' outcome labels. The order is kept for the plot. -#' @param continuous_outcome A single string containing the continuous -#' outcome label. +#' @param step_outcomes A vector of strings containing the outcome labels +#' for all outcomes displayed as part of the step function +#' on the left side of the plot. +#' The order is kept for the plot. +#' @param last_outcome A single string containing the last outcome label +#' displayed on the right side of the plot. #' @param arm_levels A named vector of exactly two strings, mapping the #' values used for the active and control arms to the values #' used in the data. The names must be "active" and "control" @@ -27,15 +29,28 @@ #' integer value per tte-outcome. #' @param compute_win_odds If TRUE compute the win odds, otherwise (default) #' don't compute them. -#' +#' @param step_types The type of each outcome in the step_outcomes vector. +#' Can be a single string (if all outcomes of same type) or +#' a vector of same length as step_outcomes. Possible values +#' in the vector are "tte" (default) or "binary". +#' @param last_type A single string giving the type of the last outcome. +#' Possible values are "continuous" (default), "binary" or +#' "multinomial". +#' @param tte_outcomes Deprecated and substituted by the more general +#' 'step_outcomes'. A vector of strings containing the +#' time-to-event outcome labels. The order is kept for the +#' plot. +#' @param continuous_outcome Deprecated and substituted by the more general +#' 'last_outcome'. A single string containing the +#' continuous outcome label. #' @return An object of class 'maraca'. The object information must be #' considered private. #' @examples #' data(hce_scenario_a) #' hce_test <- maraca( #' data = hce_scenario_a, -#' tte_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), -#' continuous_outcome = "Continuous outcome", +#' step_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), +#' last_outcome = "Continuous outcome", #' fixed_followup_days = 3 * 365, #' column_names = c(outcome = "GROUP", arm = "TRTP", value = "AVAL0"), #' arm_levels = c(active = "Active", control = "Control"), @@ -44,8 +59,8 @@ #' @export maraca <- function( data, - tte_outcomes, - continuous_outcome, + step_outcomes, + last_outcome, arm_levels = c( active = "active", control = "control" @@ -56,12 +71,29 @@ maraca <- function( value = "value" ), fixed_followup_days, - compute_win_odds = FALSE + compute_win_odds = FALSE, + step_types = "tte", + last_type = "continuous", + tte_outcomes = lifecycle::deprecated(), + continuous_outcome = lifecycle::deprecated() ) { checkmate::assert_data_frame(data) - checkmate::assert_character(tte_outcomes, any.missing = FALSE) - checkmate::assert_string(continuous_outcome) + + if (lifecycle::is_present(tte_outcomes)) { + lifecycle::deprecate_warn("0.7.0", "maraca(tte_outcomes)", + "maraca(step_outcomes)") + step_outcomes <- tte_outcomes + } + + if (lifecycle::is_present(continuous_outcome)) { + lifecycle::deprecate_warn("0.7.0", "maraca(continuous_outcome)", + "maraca(last_outcome)") + last_outcome <- continuous_outcome + } + + checkmate::assert_character(step_outcomes, any.missing = FALSE) + checkmate::assert_string(last_outcome) checkmate::assert_character(arm_levels, len = 2, any.missing = FALSE) checkmate::assert_names( names(arm_levels), @@ -75,7 +107,7 @@ maraca <- function( checkmate::assert_integerish(fixed_followup_days) - if (!(length(fixed_followup_days) %in% c(1, length(tte_outcomes)))) { + if (!(length(fixed_followup_days) %in% c(1, length(step_outcomes)))) { stop(paste("fixed_followup_days needs to be either a single value or", "a vector with one value for each tte outcome")) } @@ -91,8 +123,8 @@ maraca <- function( # in the internal data. # Note: We use HCE to refer to our internal, normalised data frame. # and with "data" to the user-provided, external, dirty data frame. - hce_dat <- .reformat_and_check_data(data, tte_outcomes, - continuous_outcome, + hce_dat <- .reformat_and_check_data(data, step_outcomes, + last_outcome, arm_levels, column_names) # Calculate meta information from the entire HCE dataset needed for plotting @@ -110,7 +142,7 @@ maraca <- function( # but will at the same time not include the MI since # we don't know about it if (any(fixed_followup_days < - unlist(meta[meta$outcome %in% tte_outcomes, "maxday"]))) { + unlist(meta[meta$outcome %in% step_outcomes, "maxday"]))) { stop(paste("Time-to-event data contain events", "after the fixed_followup_days - either", "provide a longer follow-up time or", @@ -126,12 +158,12 @@ maraca <- function( dplyr::filter(!is.na(value)) ecdf_by_outcome <- .compute_ecdf_by_outcome( - hce_dat, meta, tte_outcomes, continuous_outcome, arm_levels, + hce_dat, meta, step_outcomes, last_outcome, arm_levels, fixed_followup_days ) continuous <- .compute_continuous( - hce_dat, meta, ecdf_by_outcome, tte_outcomes, continuous_outcome, arm_levels + hce_dat, meta, ecdf_by_outcome, step_outcomes, last_outcome, arm_levels ) win_odds <- list("win_odds" = NULL, "win_odds_outcome" = NULL) @@ -142,8 +174,8 @@ maraca <- function( return( structure( list( - tte_outcomes = tte_outcomes, - continuous_outcome = continuous_outcome, + step_outcomes = step_outcomes, + last_outcome = last_outcome, arm_levels = arm_levels, fixed_followup_days = fixed_followup_days, column_names = column_names, @@ -218,8 +250,8 @@ print.maraca <- function(x, ...) { #' data(hce_scenario_a) #' hce_test <- maraca( #' data = hce_scenario_a, -#' tte_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), -#' continuous_outcome = "Continuous outcome", +#' step_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), +#' last_outcome = "Continuous outcome", #' fixed_followup_days = 3 * 365, #' column_names = c(outcome = "GROUP", arm = "TRTP", value = "AVAL0"), #' arm_levels = c(active = "Active", control = "Control"), @@ -249,7 +281,7 @@ plot_maraca <- function( ecdf_mod <- obj$ecdf_by_outcome win_odds <- obj$win_odds start_continuous_endpoint <- - meta[meta$outcome == obj$continuous_outcome, ]$startx + meta[meta$outcome == obj$last_outcome, ]$startx plotdata_ecdf <- ecdf_mod$data[, c("outcome", "arm", "adjusted.time", "ecdf_values")] @@ -386,7 +418,7 @@ plot_maraca <- function( ggplot2::scale_x_continuous( limits = c(0, 100), breaks = c(meta$proportion / 2 + meta$startx), - labels = c(obj$tte_outcomes, obj$continuous_outcome), + labels = c(obj$step_outcomes, obj$last_outcome), minor_breaks = .to_rangeab( minor_grid, start_continuous_endpoint, @@ -458,8 +490,8 @@ plot_maraca <- function( #' data(hce_scenario_a) #' hce_test <- maraca( #' data = hce_scenario_a, -#' tte_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), -#' continuous_outcome = "Continuous outcome", +#' step_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), +#' last_outcome = "Continuous outcome", #' fixed_followup_days = 3 * 365, #' column_names = c(outcome = "GROUP", arm = "TRTP", value = "AVAL0"), #' arm_levels = c(active = "Active", control = "Control"), @@ -565,8 +597,8 @@ validate_maraca_plot <- function(x, ...) { #' data(hce_scenario_a) #' hce_test <- maraca( #' data = hce_scenario_a, -#' tte_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), -#' continuous_outcome = "Continuous outcome", +#' step_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), +#' last_outcome = "Continuous outcome", #' fixed_followup_days = 3 * 365, #' column_names = c(outcome = "GROUP", arm = "TRTP", value = "AVAL0"), #' arm_levels = c(active = "Active", control = "Control"), @@ -589,14 +621,15 @@ plot.maraca <- function( #' #' @param x an object of S3 class 'hce'. #' @param \dots not used -#' @param continuous_outcome A single string containing the continuous -#' outcome label. Default value "C". +#' @param last_outcome A single string containing the last outcome label +#' displayed on the right side of the plot. +#' Default value "C". #' @param arm_levels A named vector of exactly two strings, mapping the #' values used for the active and control arms to the values #' used in the data. The names must be "active" and "control" #' in this order. Note that this parameter only need to #' be specified if you have labels different from -#' "active" and "control". +#' "active" and "control". #' @param continuous_grid_spacing_x The spacing of the x grid to use for the #' continuous section of the plot. #' @param trans the transformation to apply to the data before plotting. @@ -619,11 +652,17 @@ plot.maraca <- function( #' fixed_followup_days argument is used. #' @param compute_win_odds If TRUE compute the win odds, otherwise (default) #' don't compute them. +#' @param last_type A single string giving the type of the last outcome. +#' Possible values are "continuous" (default), "binary" or +#' "multinomial". #' @param theme Choose theme to style the plot. The default theme is "maraca". #' Options are "maraca", "maraca_old", "color1", "color2" and none". #' For more details, check the vignette called #' "Maraca Plots - Themes and Styling". #' [companion vignette for package users](themes.html) +#' @param continuous_outcome Deprecated and substituted by the more general +#' 'last_outcome'. A single string containing the +#' continuous outcome label. #' @return Used for side effect. Returns ggplot2 plot of the hce object. #' #' @examples @@ -636,7 +675,7 @@ plot.maraca <- function( #' plot(hce_dat, fixed_followup_days = 3 * 365) #' #' @export -plot.hce <- function(x, continuous_outcome = "C", +plot.hce <- function(x, last_outcome = "C", arm_levels = c(active = "A", control = "P"), continuous_grid_spacing_x = 10, trans = "identity", @@ -644,7 +683,10 @@ plot.hce <- function(x, continuous_outcome = "C", vline_type = "median", fixed_followup_days = NULL, compute_win_odds = FALSE, - theme = "maraca", ...) { + last_type = "continuous", + theme = "maraca", + continuous_outcome = lifecycle::deprecated(), + ...) { checkmate::assert_int(continuous_grid_spacing_x) checkmate::assert_string(trans) @@ -654,7 +696,7 @@ plot.hce <- function(x, continuous_outcome = "C", vline_type, c("median", "mean", "none") ) - maraca_obj <- .maraca_from_hce_data(x, continuous_outcome, arm_levels, + maraca_obj <- .maraca_from_hce_data(x, last_outcome, arm_levels, fixed_followup_days, compute_win_odds) diff --git a/R/winOddsPlots.R b/R/winOddsPlots.R index 5c9c94b..8915e05 100644 --- a/R/winOddsPlots.R +++ b/R/winOddsPlots.R @@ -38,9 +38,9 @@ component_plot.default <- function(x, #' data(hce_scenario_a) #' #' maraca_dat <- maraca(data = hce_scenario_a, -#' tte_outcomes = c("Outcome I", "Outcome II", +#' step_outcomes = c("Outcome I", "Outcome II", #' "Outcome III", "Outcome IV"), -#' continuous_outcome = "Continuous outcome", +#' last_outcome = "Continuous outcome", #' fixed_followup_days = 3 * 365, #' column_names = c(outcome = "GROUP", #' arm = "TRTP", @@ -67,7 +67,7 @@ component_plot.maraca <- function(x, # Get win odds by outcome from maraca object win_odds_outcome <- x$win_odds_outcome # List of outcomes in order of plotting - endpoints <- c(x$tte_outcomes, x$continuous_outcome) + endpoints <- c(x$step_outcomes, x$last_outcome) # Create data set for potting wo_bar_nc <- .prep_data_component_plot(win_odds_outcome, endpoints, x$arm_levels) @@ -89,8 +89,9 @@ component_plot.maraca <- function(x, #' #' @param x an object of S3 class 'hce'. #' @param \dots not used -#' @param continuous_outcome A single string containing the continuous -#' outcome label. Default value "C". +#' @param last_outcome A single string containing the last outcome label +#' displayed on the right side of the plot. +#' Default value "C". #' @param arm_levels A named vector of exactly two strings, mapping the #' values used for the active and control arms to the values #' used in the data. The names must be "active" and "control" @@ -109,6 +110,9 @@ component_plot.maraca <- function(x, #' Options are "maraca", "color1", "color2" and none". #' For more details, check the vignette called #' "Maraca Plots - Plotting win odds". +#' @param continuous_outcome Deprecated and substituted by the more general +#' 'last_outcome'. A single string containing the +#' continuous outcome label. #' @return Component plot as a ggplot2 object. #' @examples #' Rates_A <- c(1.72, 1.74, 0.58, 1.5, 1) @@ -120,21 +124,22 @@ component_plot.maraca <- function(x, #' component_plot(hce_dat) #' @export #' -component_plot.hce <- function(x, continuous_outcome = "C", +component_plot.hce <- function(x, last_outcome = "C", arm_levels = c(active = "A", control = "P"), fixed_followup_days = NULL, theme = "maraca", + continuous_outcome = lifecycle::deprecated(), ...) { # Create maraca object - maraca_dat <- .maraca_from_hce_data(x, continuous_outcome, arm_levels, + maraca_dat <- .maraca_from_hce_data(x, last_outcome, arm_levels, fixed_followup_days, compute_win_odds = TRUE) # Get win odds by outcome from maraca object win_odds_outcome <- maraca_dat$win_odds_outcome # List of outcomes in order of plotting - endpoints <- c(maraca_dat$tte_outcomes, maraca_dat$continuous_outcome) + endpoints <- c(maraca_dat$step_outcomes, maraca_dat$last_outcome) # Create data set for potting wo_bar_nc <- .prep_data_component_plot(win_odds_outcome, endpoints, maraca_dat$arm_levels) diff --git a/man/component_plot.hce.Rd b/man/component_plot.hce.Rd index dca5cfb..43008fd 100644 --- a/man/component_plot.hce.Rd +++ b/man/component_plot.hce.Rd @@ -9,18 +9,20 @@ Check the vignette "Maraca Plots - Plotting win odds" for more details.} \usage{ \method{component_plot}{hce}( x, - continuous_outcome = "C", + last_outcome = "C", arm_levels = c(active = "A", control = "P"), fixed_followup_days = NULL, theme = "maraca", + continuous_outcome = lifecycle::deprecated(), ... ) } \arguments{ \item{x}{an object of S3 class 'hce'.} -\item{continuous_outcome}{A single string containing the continuous -outcome label. Default value "C".} +\item{last_outcome}{A single string containing the last outcome label +displayed on the right side of the plot. +Default value "C".} \item{arm_levels}{A named vector of exactly two strings, mapping the values used for the active and control arms to the values @@ -43,6 +45,10 @@ Options are "maraca", "color1", "color2" and none". For more details, check the vignette called "Maraca Plots - Plotting win odds".} +\item{continuous_outcome}{Deprecated and substituted by the more general +'last_outcome'. A single string containing the +continuous outcome label.} + \item{\dots}{not used} } \value{ diff --git a/man/component_plot.maraca.Rd b/man/component_plot.maraca.Rd index c8c4290..2a5e529 100644 --- a/man/component_plot.maraca.Rd +++ b/man/component_plot.maraca.Rd @@ -37,9 +37,9 @@ Check the vignette "Maraca Plots - Plotting win odds" for more details. data(hce_scenario_a) maraca_dat <- maraca(data = hce_scenario_a, - tte_outcomes = c("Outcome I", "Outcome II", + step_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), - continuous_outcome = "Continuous outcome", + last_outcome = "Continuous outcome", fixed_followup_days = 3 * 365, column_names = c(outcome = "GROUP", arm = "TRTP", diff --git a/man/maraca.Rd b/man/maraca.Rd index adb84bd..4e16b3c 100644 --- a/man/maraca.Rd +++ b/man/maraca.Rd @@ -9,12 +9,16 @@ \usage{ maraca( data, - tte_outcomes, - continuous_outcome, + step_outcomes, + last_outcome, arm_levels = c(active = "active", control = "control"), column_names = c(outcome = "outcome", arm = "arm", value = "value"), fixed_followup_days, - compute_win_odds = FALSE + compute_win_odds = FALSE, + step_types = "tte", + last_type = "continuous", + tte_outcomes = lifecycle::deprecated(), + continuous_outcome = lifecycle::deprecated() ) \method{print}{maraca}(x, ...) @@ -26,11 +30,13 @@ maraca( - arm column, containing the arm a given row belongs to. - value column, containing the values.} -\item{tte_outcomes}{A vector of strings containing the time-to-event -outcome labels. The order is kept for the plot.} +\item{step_outcomes}{A vector of strings containing the outcome labels +for all outcomes displayed as part of the step function +on the left side of the plot. +The order is kept for the plot.} -\item{continuous_outcome}{A single string containing the continuous -outcome label.} +\item{last_outcome}{A single string containing the last outcome label +displayed on the right side of the plot.} \item{arm_levels}{A named vector of exactly two strings, mapping the values used for the active and control arms to the values @@ -53,6 +59,24 @@ integer value per tte-outcome.} \item{compute_win_odds}{If TRUE compute the win odds, otherwise (default) don't compute them.} +\item{step_types}{The type of each outcome in the step_outcomes vector. +Can be a single string (if all outcomes of same type) or +a vector of same length as step_outcomes. Possible values +in the vector are "tte" (default) or "binary".} + +\item{last_type}{A single string giving the type of the last outcome. +Possible values are "continuous" (default), "binary" or +"multinomial".} + +\item{tte_outcomes}{Deprecated and substituted by the more general +'step_outcomes'. A vector of strings containing the +time-to-event outcome labels. The order is kept for the +plot.} + +\item{continuous_outcome}{Deprecated and substituted by the more general +'last_outcome'. A single string containing the +continuous outcome label.} + \item{x}{an object of class maraca} \item{...}{further arguments passed to or @@ -70,8 +94,8 @@ class 'maraca'. data(hce_scenario_a) hce_test <- maraca( data = hce_scenario_a, - tte_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), - continuous_outcome = "Continuous outcome", + step_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), + last_outcome = "Continuous outcome", fixed_followup_days = 3 * 365, column_names = c(outcome = "GROUP", arm = "TRTP", value = "AVAL0"), arm_levels = c(active = "Active", control = "Control"), diff --git a/man/plot.hce.Rd b/man/plot.hce.Rd index 39ed227..afab672 100644 --- a/man/plot.hce.Rd +++ b/man/plot.hce.Rd @@ -6,7 +6,7 @@ \usage{ \method{plot}{hce}( x, - continuous_outcome = "C", + last_outcome = "C", arm_levels = c(active = "A", control = "P"), continuous_grid_spacing_x = 10, trans = "identity", @@ -14,22 +14,25 @@ vline_type = "median", fixed_followup_days = NULL, compute_win_odds = FALSE, + last_type = "continuous", theme = "maraca", + continuous_outcome = lifecycle::deprecated(), ... ) } \arguments{ \item{x}{an object of S3 class 'hce'.} -\item{continuous_outcome}{A single string containing the continuous -outcome label. Default value "C".} +\item{last_outcome}{A single string containing the last outcome label +displayed on the right side of the plot. +Default value "C".} \item{arm_levels}{A named vector of exactly two strings, mapping the values used for the active and control arms to the values used in the data. The names must be "active" and "control" in this order. Note that this parameter only need to be specified if you have labels different from - "active" and "control".} +"active" and "control".} \item{continuous_grid_spacing_x}{The spacing of the x grid to use for the continuous section of the plot.} @@ -59,12 +62,20 @@ fixed_followup_days argument is used.} \item{compute_win_odds}{If TRUE compute the win odds, otherwise (default) don't compute them.} +\item{last_type}{A single string giving the type of the last outcome. +Possible values are "continuous" (default), "binary" or +"multinomial".} + \item{theme}{Choose theme to style the plot. The default theme is "maraca". Options are "maraca", "maraca_old", "color1", "color2" and none". For more details, check the vignette called "Maraca Plots - Themes and Styling". [companion vignette for package users](themes.html)} +\item{continuous_outcome}{Deprecated and substituted by the more general +'last_outcome'. A single string containing the +continuous outcome label.} + \item{\dots}{not used} } \value{ diff --git a/man/plot.maraca.Rd b/man/plot.maraca.Rd index 656fa03..6dfc482 100644 --- a/man/plot.maraca.Rd +++ b/man/plot.maraca.Rd @@ -46,8 +46,8 @@ Generic function to plot the maraca object using plot(). data(hce_scenario_a) hce_test <- maraca( data = hce_scenario_a, - tte_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), - continuous_outcome = "Continuous outcome", + step_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), + last_outcome = "Continuous outcome", fixed_followup_days = 3 * 365, column_names = c(outcome = "GROUP", arm = "TRTP", value = "AVAL0"), arm_levels = c(active = "Active", control = "Control"), diff --git a/man/plot_maraca.Rd b/man/plot_maraca.Rd index 9d52d01..9892304 100644 --- a/man/plot_maraca.Rd +++ b/man/plot_maraca.Rd @@ -45,8 +45,8 @@ Creates and returns the plot of the maraca data. data(hce_scenario_a) hce_test <- maraca( data = hce_scenario_a, - tte_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), - continuous_outcome = "Continuous outcome", + step_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), + last_outcome = "Continuous outcome", fixed_followup_days = 3 * 365, column_names = c(outcome = "GROUP", arm = "TRTP", value = "AVAL0"), arm_levels = c(active = "Active", control = "Control"), diff --git a/man/validate_maraca_plot.Rd b/man/validate_maraca_plot.Rd index bb50591..f54d498 100644 --- a/man/validate_maraca_plot.Rd +++ b/man/validate_maraca_plot.Rd @@ -21,8 +21,8 @@ This will produce the 4 validation datasets. data(hce_scenario_a) hce_test <- maraca( data = hce_scenario_a, - tte_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), - continuous_outcome = "Continuous outcome", + step_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), + last_outcome = "Continuous outcome", fixed_followup_days = 3 * 365, column_names = c(outcome = "GROUP", arm = "TRTP", value = "AVAL0"), arm_levels = c(active = "Active", control = "Control"), diff --git a/tests/testthat/test_maraca.R b/tests/testthat/test_maraca.R index 6f860d5..da26118 100644 --- a/tests/testthat/test_maraca.R +++ b/tests/testthat/test_maraca.R @@ -1,9 +1,9 @@ .maraca_args <- function(file) { data <- read.csv(file, stringsAsFactors = FALSE) - tte_outcomes <- c( + step_outcomes <- c( "Outcome I", "Outcome II", "Outcome III", "Outcome IV" ) - continuous_outcome <- "Continuous outcome" + last_outcome <- "Continuous outcome" arm_levels <- c(active = "Active", control = "Control") column_names <- c( outcome = "GROUP", arm = "TRTP", value = "AVAL0" @@ -11,8 +11,8 @@ return(list( data = data, - tte_outcomes = tte_outcomes, - continuous_outcome = continuous_outcome, + step_outcomes = step_outcomes, + last_outcome = last_outcome, arm_levels = arm_levels, column_names = column_names )) @@ -31,17 +31,17 @@ test_that("createMaracaObject", { file <- fixture_path("hce_scenario_c.csv") data <- read.csv(file, stringsAsFactors = FALSE) - tte_outcomes <- c( + step_outcomes <- c( "Outcome I", "Outcome II", "Outcome III", "Outcome IV" ) - continuous_outcome <- "Continuous outcome" + last_outcome <- "Continuous outcome" arm_levels <- c(active = "Active", control = "Control") column_names <- c( outcome = "GROUP", arm = "TRTP", value = "AVAL0" ) fixed_followup_days <- 3 * 365 mar <- maraca( - data, tte_outcomes, continuous_outcome, arm_levels, + data, step_outcomes, last_outcome, arm_levels, column_names, fixed_followup_days ) @@ -51,22 +51,22 @@ test_that("createMaracaObject", { # Internal checks file <- fixture_path("hce_scenario_c.csv") data <- read.csv(file, stringsAsFactors = FALSE) - tte_outcomes <- c( + step_outcomes <- c( "Outcome I", "Outcome II", "Outcome III", "Outcome IV" ) - continuous_outcome <- "Continuous outcome" + last_outcome <- "Continuous outcome" arm_levels <- c(active = "Active", control = "Control") column_names <- c( outcome = "GROUP", arm = "TRTP", value = "AVAL0" ) - data <- .reformat_and_check_data(data, tte_outcomes, continuous_outcome, + data <- .reformat_and_check_data(data, step_outcomes, last_outcome, arm_levels, column_names = column_names) meta <- .compute_metainfo(data) - hce_ecdf <- .compute_ecdf_by_outcome(data, meta, tte_outcomes, - continuous_outcome, + hce_ecdf <- .compute_ecdf_by_outcome(data, meta, step_outcomes, + last_outcome, arm_levels, 3 * 365) continuous <- .compute_continuous(data, meta, hce_ecdf, - tte_outcomes, continuous_outcome, + step_outcomes, last_outcome, arm_levels) expect_equal(sum(abs(continuous$data$x)), 40828.387) expect_equal(sum(abs(continuous$data$y_level)), 24451) @@ -78,41 +78,41 @@ test_that("createMaracaObject", { # Test reformatting of data file <- fixture_path("hce_scenario_c.csv") data <- read.csv(file, stringsAsFactors = FALSE) - tte_outcomes <- c( + step_outcomes <- c( "Outcome I", "Outcome II", "Outcome III", "Outcome IV" ) - continuous_outcome <- "Continuous outcome" + last_outcome <- "Continuous outcome" arm_levels <- c(active = "Active", control = "Control") column_names <- c( outcome = "GROUP", arm = "TRTP", value = "AVAL0" ) data <- .reformat_and_check_data( - data, tte_outcomes, continuous_outcome, arm_levels, column_names + data, step_outcomes, last_outcome, arm_levels, column_names ) expect_equal(class(data), "data.frame") expect_equal(class(data$arm), "factor") expect_equal(levels(data$arm), unname(arm_levels)) expect_equal(class(data$outcome), "factor") - expect_equal(levels(data$outcome), c(tte_outcomes, continuous_outcome)) + expect_equal(levels(data$outcome), c(step_outcomes, last_outcome)) # Test compute metainfo file <- fixture_path("hce_scenario_c.csv") data <- read.csv(file, stringsAsFactors = FALSE) - tte_outcomes <- c( + step_outcomes <- c( "Outcome I", "Outcome II", "Outcome III", "Outcome IV" ) - continuous_outcome <- "Continuous outcome" + last_outcome <- "Continuous outcome" arm_levels <- c(active = "Active", control = "Control") column_names <- c( outcome = "GROUP", arm = "TRTP", value = "AVAL0" ) - data <- .reformat_and_check_data(data, tte_outcomes, continuous_outcome, + data <- .reformat_and_check_data(data, step_outcomes, last_outcome, arm_levels, column_names = column_names) metainfo <- .compute_metainfo(data) expect_equal(as.character(metainfo$outcome), - c(tte_outcomes, continuous_outcome)) + c(step_outcomes, last_outcome)) expect_equal(metainfo$n, c(129, 115, 110, 77, 569)) expect_equal(metainfo$proportion, c(12.9, 11.5, 11, 7.7, 56.9)) expect_equal( @@ -130,21 +130,21 @@ test_that("createMaracaObject", { # Test Compute ECDF file <- fixture_path("hce_scenario_c.csv") data <- read.csv(file, stringsAsFactors = FALSE) - tte_outcomes <- c( + step_outcomes <- c( "Outcome I", "Outcome II", "Outcome III", "Outcome IV" ) - continuous_outcome <- "Continuous outcome" + last_outcome <- "Continuous outcome" arm_levels <- c(active = "Active", control = "Control") column_names <- c( outcome = "GROUP", arm = "TRTP", value = "AVAL0" ) - data <- .reformat_and_check_data(data, tte_outcomes, continuous_outcome, + data <- .reformat_and_check_data(data, step_outcomes, last_outcome, arm_levels, column_names ) meta <- .compute_metainfo(data) - hce_ecdf <- .compute_ecdf_by_outcome(data, meta, tte_outcomes, - continuous_outcome, arm_levels, 3 * 365) + hce_ecdf <- .compute_ecdf_by_outcome(data, meta, step_outcomes, + last_outcome, arm_levels, 3 * 365) # Checking the abssum along the columns to check that values remain the same. expect_equal(sum(abs(hce_ecdf$data$value)), 221627.7286) @@ -165,15 +165,15 @@ test_that("createMaracaObject", { # test ordered column file <- fixture_path("hce_scenario_c.csv") data <- read.csv(file, stringsAsFactors = FALSE) - tte_outcomes <- c( + step_outcomes <- c( "Outcome I", "Outcome II", "Outcome III", "Outcome IV" ) - continuous_outcome <- "Continuous outcome" + last_outcome <- "Continuous outcome" arm_levels <- c(active = "Active", control = "Control") column_names <- c( outcome = "GROUP", arm = "TRTP", value = "AVAL0" ) - hce <- .reformat_and_check_data(data, tte_outcomes, continuous_outcome, + hce <- .reformat_and_check_data(data, step_outcomes, last_outcome, arm_levels, column_names) hce <- .with_ordered_column(hce) @@ -196,17 +196,17 @@ test_that("alternativeActiveControl", { file <- fixture_path("hce_scenario_c.csv") data <- read.csv(file, stringsAsFactors = FALSE) - tte_outcomes <- c( + step_outcomes <- c( "Outcome I", "Outcome II", "Outcome III", "Outcome IV" ) - continuous_outcome <- "Continuous outcome" + last_outcome <- "Continuous outcome" arm_levels <- c(active = "Active", control = "Control") column_names <- c( outcome = "GROUP", arm = "TRTP", value = "AVAL0" ) fixed_followup_days <- 3 * 365 mar <- maraca( - data, tte_outcomes, continuous_outcome, arm_levels, + data, step_outcomes, last_outcome, arm_levels, column_names, fixed_followup_days ) @@ -217,17 +217,17 @@ test_that("alternativeColumnNames", { file <- fixture_path("hce_scenario_c.csv") data <- read.csv(file, stringsAsFactors = FALSE) - tte_outcomes <- c( + step_outcomes <- c( "Outcome I", "Outcome II", "Outcome III", "Outcome IV" ) - continuous_outcome <- "Continuous outcome" + last_outcome <- "Continuous outcome" arm_levels <- c(active = "Active", control = "Control") column_names <- c( outcome = "GROUP", arm = "TRTP", value = "AVAL0" ) fixed_followup_days <- 3 * 365 mar <- maraca( - data, tte_outcomes, continuous_outcome, arm_levels, + data, step_outcomes, last_outcome, arm_levels, column_names, fixed_followup_days ) @@ -238,21 +238,21 @@ test_that("vectorFixedFollowUp", { file <- fixture_path("hce_scenario_c.csv") data <- read.csv(file, stringsAsFactors = FALSE) - tte_outcomes <- c( + step_outcomes <- c( "Outcome I", "Outcome II", "Outcome III", "Outcome IV" ) - continuous_outcome <- "Continuous outcome" + last_outcome <- "Continuous outcome" arm_levels <- c(active = "Active", control = "Control") column_names <- c( outcome = "GROUP", arm = "TRTP", value = "AVAL0" ) - fixed_followup_days <- ceiling(unname(sapply(tte_outcomes, function(tte) { + fixed_followup_days <- ceiling(unname(sapply(step_outcomes, function(tte) { max(data[data$GROUP == tte, "AVAL0"]) }))) mar <- maraca( - data, tte_outcomes, continuous_outcome, arm_levels, + data, step_outcomes, last_outcome, arm_levels, column_names, fixed_followup_days ) @@ -262,10 +262,10 @@ test_that("vectorFixedFollowUp", { test_that("wrongParameters", { file <- fixture_path("hce_scenario_c.csv") data <- read.csv(file, stringsAsFactors = FALSE) - tte_outcomes <- c( + step_outcomes <- c( "Outcome I", "Outcome II", "Outcome III", "Outcome IV" ) - continuous_outcome <- "Continuous outcome" + last_outcome <- "Continuous outcome" arm_levels <- c(active = "Active", control = "Control") fixed_followup_days <- 3 * 365 column_names <- c( @@ -274,49 +274,49 @@ test_that("wrongParameters", { expect_error( maraca( - "hello", tte_outcomes, continuous_outcome, arm_levels, + "hello", step_outcomes, last_outcome, arm_levels, fixed_followup_days = fixed_followup_days ), regexp = "Must be of type 'data\\.frame'" ) expect_error( maraca( - data, c(1, 2, 3), continuous_outcome, arm_levels, + data, c(1, 2, 3), last_outcome, arm_levels, fixed_followup_days = fixed_followup_days ), regexp = "Must be of type 'character'" ) expect_error( - maraca(data, tte_outcomes, 3, arm_levels, + maraca(data, step_outcomes, 3, arm_levels, fixed_followup_days = fixed_followup_days ), regexp = "Must be of type 'string'" ) expect_error( - maraca(data, tte_outcomes, continuous_outcome, c(1, 2), + maraca(data, step_outcomes, last_outcome, c(1, 2), fixed_followup_days = fixed_followup_days), regexp = "Must be of type 'character'" ) expect_error( - maraca(data, tte_outcomes, continuous_outcome, + maraca(data, step_outcomes, last_outcome, c(active = "foo", control = "bar", whatever = "baz"), column_names, fixed_followup_days), regexp = "Must have length 2" ) expect_error( - maraca(data, tte_outcomes, continuous_outcome, arm_levels, + maraca(data, step_outcomes, last_outcome, arm_levels, column_names, fixed_followup_days = 12.3 ), regexp = "Must be of type 'integerish'" ) expect_error( - maraca(data, tte_outcomes, continuous_outcome, arm_levels, + maraca(data, step_outcomes, last_outcome, arm_levels, column_names, fixed_followup_days = NULL ) ) expect_error( - maraca(data, tte_outcomes, continuous_outcome, arm_levels, + maraca(data, step_outcomes, last_outcome, arm_levels, column_names, fixed_followup_days = 12 ), @@ -325,7 +325,7 @@ test_that("wrongParameters", { expect_error( maraca( - data, tte_outcomes, continuous_outcome, arm_levels, + data, step_outcomes, last_outcome, arm_levels, c("a"), fixed_followup_days ), @@ -333,7 +333,7 @@ test_that("wrongParameters", { ) expect_error( maraca( - data, tte_outcomes, continuous_outcome, arm_levels, + data, step_outcomes, last_outcome, arm_levels, c("a", "b", "c"), fixed_followup_days ), @@ -341,7 +341,7 @@ test_that("wrongParameters", { ) expect_error( maraca( - data, tte_outcomes, continuous_outcome, arm_levels, + data, step_outcomes, last_outcome, arm_levels, c(foo = "a", bar = "b", baz = "c"), fixed_followup_days ) @@ -349,7 +349,7 @@ test_that("wrongParameters", { expect_error( maraca( - data, tte_outcomes, continuous_outcome, arm_levels, + data, step_outcomes, last_outcome, arm_levels, c( outcome = "GROUP", arm = "notexistent", value = "AVAL0" @@ -360,7 +360,7 @@ test_that("wrongParameters", { expect_error( maraca( - data, tte_outcomes, continuous_outcome, + data, step_outcomes, last_outcome, arm_levels = c(active = "A", control = "C"), c( outcome = "GROUP", arm = "TRTP", @@ -373,7 +373,7 @@ test_that("wrongParameters", { expect_error( maraca( - data, tte_outcomes, continuous_outcome = "C", arm_levels, + data, step_outcomes, last_outcome = "C", arm_levels, c( outcome = "GROUP", arm = "TRTP", value = "AVAL0" @@ -381,7 +381,7 @@ test_that("wrongParameters", { ), regexp = list(paste("Outcome variable contains different", "values then given in parameters", - "tte_outcomes and continuous_outcome")) + "step_outcomes and last_outcome")) ) # Test plot functions only work with maraca objects @@ -409,48 +409,48 @@ test_that("wrongParameters", { # Check missing outcome file <- fixture_path("hce_scenario_c.csv") data <- read.csv(file, stringsAsFactors = FALSE) - tte_outcomes <- c( + step_outcomes <- c( "Outcome I", "Outcome II", "Outcome III", "Outcome XXX" ) - continuous_outcome <- "Continuous outcome" + last_outcome <- "Continuous outcome" arm_levels <- c(active = "Active", control = "Control") column_names <- c( outcome = "GROUP", arm = "TRTP", value = "AVAL0" ) expect_error( - maraca(data, tte_outcomes, continuous_outcome, arm_levels, + maraca(data, step_outcomes, last_outcome, arm_levels, column_names, 3 * 365), regexp = list(paste("Outcome variable contains different", "values then given in parameters", - "tte_outcomes and continuous_outcome")) + "step_outcomes and last_outcome")) ) }) test_that("winOddsData", { file <- fixture_path("hce_scenario_c.csv") data <- read.csv(file, stringsAsFactors = FALSE) - tte_outcomes <- c( + step_outcomes <- c( "Outcome I", "Outcome II", "Outcome III", "Outcome IV" ) - continuous_outcome <- "Continuous outcome" + last_outcome <- "Continuous outcome" arm_levels <- c(active = "Active", control = "Control") column_names <- c( outcome = "GROUP", arm = "TRTP", value = "AVAL0" ) mar <- maraca( - data, tte_outcomes, continuous_outcome, arm_levels, column_names, 3 * 365, + data, step_outcomes, last_outcome, arm_levels, column_names, 3 * 365, compute_win_odds = TRUE ) mar_no_win_odds <- maraca( - data, tte_outcomes, continuous_outcome, arm_levels, column_names, 3 * 365, + data, step_outcomes, last_outcome, arm_levels, column_names, 3 * 365, compute_win_odds = FALSE ) data$AVAL0[[3]] <- NA mar_na <- maraca( - data, tte_outcomes, continuous_outcome, arm_levels, column_names, 3 * 365, + data, step_outcomes, last_outcome, arm_levels, column_names, 3 * 365, compute_win_odds = TRUE ) @@ -498,15 +498,15 @@ test_that("winOddsData", { file <- fixture_path("hce_scenario_c.csv") data <- read.csv(file, stringsAsFactors = FALSE) - tte_outcomes <- c( + step_outcomes <- c( "Outcome I", "Outcome II", "Outcome III", "Outcome IV" ) - continuous_outcome <- "Continuous outcome" + last_outcome <- "Continuous outcome" arm_levels <- c(active = "Active", control = "Control") column_names <- c( outcome = "GROUP", arm = "TRTP", value = "AVAL0" ) - data <- .reformat_and_check_data(data, tte_outcomes, continuous_outcome, + data <- .reformat_and_check_data(data, step_outcomes, last_outcome, arm_levels, column_names = column_names ) @@ -574,17 +574,17 @@ test_that("winOddsData", { # win odds missing if set to false file <- fixture_path("hce_scenario_c.csv") data <- read.csv(file, stringsAsFactors = FALSE) - tte_outcomes <- c( + step_outcomes <- c( "Outcome I", "Outcome II", "Outcome III", "Outcome IV" ) - continuous_outcome <- "Continuous outcome" + last_outcome <- "Continuous outcome" arm_levels <- c(active = "Active", control = "Control") column_names <- c( outcome = "GROUP", arm = "TRTP", value = "AVAL0" ) mar <- maraca( - data, tte_outcomes, continuous_outcome, arm_levels, column_names, 3 * 365, + data, step_outcomes, last_outcome, arm_levels, column_names, 3 * 365, compute_win_odds = FALSE ) @@ -596,16 +596,16 @@ test_that("winOddsData", { test_that("winOddsPlot", { file <- fixture_path("hce_scenario_c.csv") data <- read.csv(file, stringsAsFactors = FALSE) - tte_outcomes <- c( + step_outcomes <- c( "Outcome I", "Outcome II", "Outcome III", "Outcome IV" ) - continuous_outcome <- "Continuous outcome" + last_outcome <- "Continuous outcome" arm_levels <- c(active = "Active", control = "Control") column_names <- c( outcome = "GROUP", arm = "TRTP", value = "AVAL0" ) mar <- maraca( - data, tte_outcomes, continuous_outcome, arm_levels, column_names, 3 * 365, + data, step_outcomes, last_outcome, arm_levels, column_names, 3 * 365, compute_win_odds = TRUE ) @@ -617,19 +617,19 @@ test_that("winOddsPlot", { win_odds_outcome <- mar$win_odds_outcome wo_smry_grp <- win_odds_outcome$summary_by_GROUP - endpoints <- c(mar$tte_outcomes, mar$continuous_outcome) + endpoints <- c(mar$step_outcomes, mar$last_outcome) wo_bar_nc <- .prep_data_component_plot(win_odds_outcome, endpoints, mar$arm_levels) expect_equal(wo_smry_grp[wo_smry_grp$TRTP == "A", "WIN"], unname(unlist(wo_bar_nc[wo_bar_nc$name == "Active wins" & wo_bar_nc$GROUP %in% - c(tte_outcomes, continuous_outcome), + c(step_outcomes, last_outcome), "value"]))) expect_equal(wo_smry_grp[wo_smry_grp$TRTP == "P", "WIN"], unname(unlist(wo_bar_nc[wo_bar_nc$name == "Control wins" & wo_bar_nc$GROUP %in% - c(tte_outcomes, continuous_outcome), + c(step_outcomes, last_outcome), "value"]))) expect_equal(win_odds_outcome$summary[win_odds_outcome$summary$TRTP == "A", "TOTAL"], @@ -643,7 +643,7 @@ test_that("winOddsPlot", { expect_file_exists(output) mar <- maraca( - data, tte_outcomes, continuous_outcome, arm_levels, column_names, 3 * 365, + data, step_outcomes, last_outcome, arm_levels, column_names, 3 * 365, compute_win_odds = FALSE ) @@ -683,27 +683,27 @@ test_that("winOddsPlot", { test_that("winOddsPrinting", { file <- fixture_path("hce_scenario_c.csv") data <- read.csv(file, stringsAsFactors = FALSE) - tte_outcomes <- c( + step_outcomes <- c( "Outcome I", "Outcome II", "Outcome III", "Outcome IV" ) - continuous_outcome <- "Continuous outcome" + last_outcome <- "Continuous outcome" arm_levels <- c(active = "Active", control = "Control") column_names <- c( outcome = "GROUP", arm = "TRTP", value = "AVAL0" ) mar <- maraca( - data, tte_outcomes, continuous_outcome, arm_levels, column_names, 3 * 365, + data, step_outcomes, last_outcome, arm_levels, column_names, 3 * 365, compute_win_odds = TRUE ) mar_no_win_odds <- maraca( - data, tte_outcomes, continuous_outcome, arm_levels, column_names, 3 * 365, + data, step_outcomes, last_outcome, arm_levels, column_names, 3 * 365, compute_win_odds = FALSE ) data$AVAL0[[3]] <- NA mar_na <- maraca( - data, tte_outcomes, continuous_outcome, arm_levels, column_names, 3 * 365, + data, step_outcomes, last_outcome, arm_levels, column_names, 3 * 365, compute_win_odds = TRUE ) @@ -754,27 +754,27 @@ test_that("winOddsPrinting", { test_that("maracaPrinting", { file <- fixture_path("hce_scenario_c.csv") data <- read.csv(file, stringsAsFactors = FALSE) - tte_outcomes <- c( + step_outcomes <- c( "Outcome I", "Outcome II", "Outcome III", "Outcome IV" ) - continuous_outcome <- "Continuous outcome" + last_outcome <- "Continuous outcome" arm_levels <- c(active = "Active", control = "Control") column_names <- c( outcome = "GROUP", arm = "TRTP", value = "AVAL0" ) mar <- maraca( - data, tte_outcomes, continuous_outcome, arm_levels, column_names, 3 * 365, + data, step_outcomes, last_outcome, arm_levels, column_names, 3 * 365, compute_win_odds = TRUE ) mar_no_win_odds <- maraca( - data, tte_outcomes, continuous_outcome, arm_levels, column_names, 3 * 365, + data, step_outcomes, last_outcome, arm_levels, column_names, 3 * 365, compute_win_odds = FALSE ) data$AVAL0[[3]] <- NA mar_na <- maraca( - data, tte_outcomes, continuous_outcome, arm_levels, column_names, 3 * 365, + data, step_outcomes, last_outcome, arm_levels, column_names, 3 * 365, compute_win_odds = TRUE ) @@ -825,17 +825,17 @@ test_that("maracaPrinting", { test_that("maracaPlotting", { file <- fixture_path("hce_scenario_c.csv") data <- read.csv(file, stringsAsFactors = FALSE) - tte_outcomes <- c( + step_outcomes <- c( "Outcome I", "Outcome II", "Outcome III", "Outcome IV" ) - continuous_outcome <- "Continuous outcome" + last_outcome <- "Continuous outcome" arm_levels <- c(active = "Active", control = "Control") fixed_followup_days <- 3 * 365 column_names <- c( outcome = "GROUP", arm = "TRTP", value = "AVAL0" ) mar <- maraca( - data, tte_outcomes, continuous_outcome, arm_levels, + data, step_outcomes, last_outcome, arm_levels, column_names, fixed_followup_days ) @@ -883,17 +883,17 @@ test_that("maracaPlotting", { test_that("validationFunction", { file <- fixture_path("hce_scenario_c.csv") data <- read.csv(file, stringsAsFactors = FALSE) - tte_outcomes <- c( + step_outcomes <- c( "Outcome I", "Outcome II", "Outcome III", "Outcome IV" ) - continuous_outcome <- "Continuous outcome" + last_outcome <- "Continuous outcome" arm_levels <- c(active = "Active", control = "Control") fixed_followup_days <- 3 * 365 column_names <- c( outcome = "GROUP", arm = "TRTP", value = "AVAL0" ) mar <- maraca( - data, tte_outcomes, continuous_outcome, arm_levels, + data, step_outcomes, last_outcome, arm_levels, column_names, fixed_followup_days, compute_win_odds = TRUE @@ -947,7 +947,7 @@ test_that("validationFunction", { expect_equal(val_res_box$plot_type, "GeomBoxplot") expect_equal(val_res_scatter$plot_type, "GeomPoint") - expected_names <- c(tte_outcomes, continuous_outcome) + expected_names <- c(step_outcomes, last_outcome) expect_named(val_res_def$proportions, expected_names, ignore.order = TRUE) expect_named(val_res_violin$proportions, expected_names, ignore.order = TRUE) expect_named(val_res_box$proportions, expected_names, ignore.order = TRUE) @@ -1044,10 +1044,10 @@ test_that("validationFunction", { test_that("handleNAData", { file <- fixture_path("hce_scenario_c.csv") data <- read.csv(file, stringsAsFactors = FALSE) - tte_outcomes <- c( + step_outcomes <- c( "Outcome I", "Outcome II", "Outcome III", "Outcome IV" ) - continuous_outcome <- "Continuous outcome" + last_outcome <- "Continuous outcome" arm_levels <- c(active = "Active", control = "Control") column_names <- c( outcome = "GROUP", arm = "TRTP", value = "AVAL0" @@ -1055,7 +1055,7 @@ test_that("handleNAData", { data$AVAL0[[3]] <- NA mar <- maraca( - data, tte_outcomes, continuous_outcome, arm_levels, column_names, 3 * 365 + data, step_outcomes, last_outcome, arm_levels, column_names, 3 * 365 ) output <- artifacts_path("handleNAData-basic.pdf") @@ -1070,8 +1070,8 @@ test_that("gridSpacing", { args <- .maraca_args(file) mar <- maraca( args$data, - args$tte_outcomes, - args$continuous_outcome, + args$step_outcomes, + args$last_outcome, args$arm_levels, args$column_names, 3 * 365 @@ -1089,8 +1089,8 @@ test_that("scaleTransform", { args <- .maraca_args(file) mar <- maraca( args$data, - args$tte_outcomes, - args$continuous_outcome, + args$step_outcomes, + args$last_outcome, args$arm_levels, args$column_names, 3 * 365 @@ -1109,8 +1109,8 @@ test_that("densityPlotType", { args <- .maraca_args(file) mar <- maraca( args$data, - args$tte_outcomes, - args$continuous_outcome, + args$step_outcomes, + args$last_outcome, args$arm_levels, args$column_names, 3 * 365 @@ -1148,8 +1148,8 @@ test_that("verticalLine", { args <- .maraca_args(file) mar <- maraca( args$data, - args$tte_outcomes, - args$continuous_outcome, + args$step_outcomes, + args$last_outcome, args$arm_levels, args$column_names, 3 * 365 diff --git a/vignettes/maraca.Rmd b/vignettes/maraca.Rmd index 2c8c7a6..1cd90f3 100644 --- a/vignettes/maraca.Rmd +++ b/vignettes/maraca.Rmd @@ -69,14 +69,14 @@ unique(data[["GROUP"]]) ``` The strings associated to each entry are arbitrary, so maraca -allows you to specify them in the `tte_outcomes` and `continuous_outcome` +allows you to specify them in the `step_outcomes` and `last_outcome` parameters. Make sure to specify the TTE outcomes in the correct order, starting from the most severe outcome to the least severe outcome. There can only be one continuous outcome. ```{r maraca4, eval = TRUE} -tte_outcomes <- c( +step_outcomes <- c( "Outcome I", "Outcome II", "Outcome III", "Outcome IV" ) -continuous_outcome <- "Continuous outcome" +last_outcome <- "Continuous outcome" ``` the `arm` column must also be a character column describing to which arm @@ -108,7 +108,7 @@ the given dataset ```{r maraca7, eval = TRUE} mar <- maraca( - data, tte_outcomes, continuous_outcome, arm_levels, column_names, + data, step_outcomes, last_outcome, arm_levels, column_names, fixed_followup_days = 3*365, compute_win_odds = TRUE ) diff --git a/vignettes/themes.Rmd b/vignettes/themes.Rmd index 2b0dc77..1692a6b 100644 --- a/vignettes/themes.Rmd +++ b/vignettes/themes.Rmd @@ -29,8 +29,8 @@ data(hce_scenario_a) maraca_dat <- maraca( data = hce_scenario_a, - tte_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), - continuous_outcome = "Continuous outcome", + step_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), + last_outcome = "Continuous outcome", fixed_followup_days = 3 * 365, column_names = c(outcome = "GROUP", arm = "TRTP", value = "AVAL0"), arm_levels = c(active = "Active", control = "Control"), diff --git a/vignettes/validation.Rmd b/vignettes/validation.Rmd index e86bf98..ecf27f6 100644 --- a/vignettes/validation.Rmd +++ b/vignettes/validation.Rmd @@ -40,8 +40,8 @@ data(hce_scenario_a) maraca_dat <- maraca( data = hce_scenario_a, - tte_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), - continuous_outcome = "Continuous outcome", + step_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), + last_outcome = "Continuous outcome", fixed_followup_days = 3 * 365, column_names = c(outcome = "GROUP", arm = "TRTP", value = "AVAL0"), arm_levels = c(active = "Active", control = "Control"), diff --git a/vignettes/winOdds.Rmd b/vignettes/winOdds.Rmd index 9d298aa..c9098f0 100644 --- a/vignettes/winOdds.Rmd +++ b/vignettes/winOdds.Rmd @@ -44,8 +44,8 @@ are included. ```{r} maraca_dat <- maraca( data = hce_scenario_a, - tte_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), - continuous_outcome = "Continuous outcome", + step_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), + last_outcome = "Continuous outcome", fixed_followup_days = 3 * 365, column_names = c(outcome = "GROUP", arm = "TRTP", value = "AVAL0"), arm_levels = c(active = "Active", control = "Control"), From 39eee59f39cfe2dbc63972794ef8b49247f7a47c Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Tue, 14 Nov 2023 09:50:21 +0000 Subject: [PATCH 04/32] Implementation of ellipsis plot for last_type binary --- R/internal.R | 122 +++++++++++++++++++++- R/maraca.R | 190 +++++++++++++++++++++-------------- tests/testthat/test_maraca.R | 14 +-- 3 files changed, 242 insertions(+), 84 deletions(-) diff --git a/R/internal.R b/R/internal.R index 360b4f5..dab20d5 100644 --- a/R/internal.R +++ b/R/internal.R @@ -193,11 +193,11 @@ dplyr::summarise(n = n(), median = stats::median(x, na.rm = TRUE), average = base::mean(x, na.rm = TRUE)) - continuous_data$y_level <- ecdf_mod$meta[ + continuous_data$y <- ecdf_mod$meta[ ecdf_mod$meta$arm == unname(arm_levels["active"]) & ecdf_mod$meta$outcome == utils::tail(step_outcomes, 1), ]$ecdf_end - continuous_data[continuous_data$arm == ctrl, ]$y_level <- ecdf_mod$meta[ + continuous_data[continuous_data$arm == ctrl, ]$y <- ecdf_mod$meta[ ecdf_mod$meta$arm == ctrl & ecdf_mod$meta$outcome == utils::tail(step_outcomes, 1), ]$ecdf_end @@ -208,6 +208,98 @@ )) } +# Computes the binary information +.compute_binary <- function( + hce_dat, meta, ecdf_mod, step_outcomes, last_outcome, arm_levels) { + + `%>%` <- dplyr::`%>%` + n <- dplyr::n + + actv <- unname(arm_levels["active"]) + ctrl <- unname(arm_levels["control"]) + + binary_data <- hce_dat[hce_dat$outcome == last_outcome, ] + start_binary_endpoint <- meta[meta$outcome == last_outcome, ]$startx + + actv_y <- ecdf_mod$meta[ + ecdf_mod$meta$arm == actv & + ecdf_mod$meta$outcome == utils::tail(step_outcomes, 1), + ]$ecdf_end + ctrl_y <- ecdf_mod$meta[ + ecdf_mod$meta$arm == ctrl & + ecdf_mod$meta$outcome == utils::tail(step_outcomes, 1), + ]$ecdf_end + + binary_meta <- binary_data %>% + dplyr::group_by(arm) %>% + dplyr::summarise(n = n(), + average = base::mean(value, na.rm = TRUE), + conf_int = 1.96 * sqrt((average * (1 - average)) / n)) + + x_radius <- (100 - start_binary_endpoint) * min(binary_meta$conf_int) + y_height <- min(c(0.4 * abs(actv_y - ctrl_y), 0.8 * x_radius)) + + actv_point <- + .create_ellipsis_points(unlist(binary_meta[binary_meta$arm == actv, + "average"]), + actv_y, + unlist(binary_meta[binary_meta$arm == actv, + "conf_int"]), + y_height) + + ctrl_point <- + .create_ellipsis_points(unlist(binary_meta[binary_meta$arm == ctrl, + "average"]), + ctrl_y, + unlist(binary_meta[binary_meta$arm == ctrl, + "conf_int"]), + y_height) + + binary_data <- rbind(data.frame("outcome" = last_outcome, + "arm" = actv, + actv_point), + data.frame("outcome" = last_outcome, + "arm" = ctrl, + ctrl_point) + ) + + binary_data$x <- .to_rangeab( + binary_data$x, + start_binary_endpoint, + 0, + 1 + ) + + binary_meta$average <- .to_rangeab( + binary_meta$average, + start_binary_endpoint, + 0, + 1 + ) + + binary_meta$y <- 0 + binary_meta[binary_meta$arm == actv, "y"] <- actv_y + binary_meta[binary_meta$arm == ctrl, "y"] <- ctrl_y + + return(list( + data = binary_data, + meta = binary_meta + )) +} + +.create_ellipsis_points <- function(x0, y0, a, b) { + + points <- seq(0, 2 * pi, length.out = 361) + cos_p <- cos(points) + sin_p <- sin(points) + x_tmp <- abs(cos_p) * a * sign(cos_p) + y_tmp <- abs(sin_p) * b * sign(sin_p) + edata <- data.frame(x = x0 + x_tmp, y = y0 + y_tmp) + + return(edata) + +} + # Reformats the data coming in from outside so that it fits our expectation. .reformat_and_check_data <- function( data, step_outcomes, last_outcome, arm_levels, column_names) { @@ -285,7 +377,8 @@ } .maraca_from_hce_data <- function(x, last_outcome, arm_levels, - fixed_followup_days, compute_win_odds) { + fixed_followup_days, compute_win_odds, + last_type = "continuous") { checkmate::assert_string(last_outcome) checkmate::assert_names(names(x), @@ -323,7 +416,8 @@ column_names = c(outcome = "GROUP", arm = "TRTP", value = "AVAL0"), arm_levels = arm_levels, fixed_followup_days = fixed_followup_days, - compute_win_odds = compute_win_odds + compute_win_odds = compute_win_odds, + last_type = last_type ) return(maraca_obj) @@ -433,3 +527,23 @@ return(p) } + +.checks_continuous_outcome <- function(density_plot_type, + vline_type) { + checkmate::assert_choice( + density_plot_type, c("default", "violin", "box", "scatter") + ) + checkmate::assert_choice( + vline_type, c("median", "mean", "none") + ) +} + +.checks_binary_outcome <- function(density_plot_type, + vline_type) { + checkmate::assert_choice( + density_plot_type, c("default") + ) + checkmate::assert_choice( + vline_type, c("mean", "none") + ) +} diff --git a/R/maraca.R b/R/maraca.R index a56d9b2..169e43e 100644 --- a/R/maraca.R +++ b/R/maraca.R @@ -107,6 +107,11 @@ maraca <- function( checkmate::assert_integerish(fixed_followup_days) + checkmate::assert_string(last_type) + checkmate::assert_subset(last_type, + choices = c("continuous", "binary"), + empty.ok = FALSE) + if (!(length(fixed_followup_days) %in% c(1, length(step_outcomes)))) { stop(paste("fixed_followup_days needs to be either a single value or", "a vector with one value for each tte outcome")) @@ -162,9 +167,17 @@ maraca <- function( fixed_followup_days ) - continuous <- .compute_continuous( - hce_dat, meta, ecdf_by_outcome, step_outcomes, last_outcome, arm_levels - ) + if (last_type == "continuous") { + data_last_outcome <- .compute_continuous( + hce_dat, meta, ecdf_by_outcome, step_outcomes, last_outcome, arm_levels + ) + } else if (last_type == "binary") { + data_last_outcome <- .compute_binary( + hce_dat, meta, ecdf_by_outcome, step_outcomes, last_outcome, arm_levels + ) + } else if (last_type == "multinomial") { + data_last_outcome <- NULL + } win_odds <- list("win_odds" = NULL, "win_odds_outcome" = NULL) if (compute_win_odds) { @@ -176,12 +189,13 @@ maraca <- function( list( step_outcomes = step_outcomes, last_outcome = last_outcome, + last_type = last_type, arm_levels = arm_levels, fixed_followup_days = fixed_followup_days, column_names = column_names, meta = meta, ecdf_by_outcome = ecdf_by_outcome, - continuous = continuous, + data_last_outcome = data_last_outcome, win_odds = win_odds[["win_odds"]], win_odds_outcome = win_odds[["win_odds_outcome"]] ), @@ -260,36 +274,51 @@ print.maraca <- function(x, ...) { #' plot <- plot_maraca(hce_test) #' @export plot_maraca <- function( - obj, continuous_grid_spacing_x = 10, trans = "identity", + obj, continuous_grid_spacing_x = NULL, + trans = "identity", density_plot_type = "default", vline_type = "median", theme = "maraca") { + checkmate::assert_class(obj, "maraca") - checkmate::assert_int(continuous_grid_spacing_x) + + if (!(is.null(continuous_grid_spacing_x) || + is.numeric(continuous_grid_spacing_x))) { + stop("continuous_grid_spacing_x has to be numeric or NULL") + } + checkmate::assert_string(trans) - checkmate::assert_choice( - density_plot_type, c("default", "violin", "box", "scatter") - ) - checkmate::assert_choice( - vline_type, c("median", "mean", "none") - ) + aes <- ggplot2::aes `%>%` <- dplyr::`%>%` meta <- obj$meta - continuous <- obj$continuous + last_data <- obj$data_last_outcome + last_type <- obj$last_type + + switch(last_type, + "continuous" = .checks_continuous_outcome(density_plot_type, + vline_type), + "binary" = .checks_binary_outcome(density_plot_type, + vline_type), + stop("Unsupported last outcome type")) + ecdf_mod <- obj$ecdf_by_outcome win_odds <- obj$win_odds - start_continuous_endpoint <- + start_last_endpoint <- meta[meta$outcome == obj$last_outcome, ]$startx + if (is.null(continuous_grid_spacing_x)) { + continuous_grid_spacing_x <- ifelse(last_type == "continuous", 10, 0.1) + } + plotdata_ecdf <- ecdf_mod$data[, c("outcome", "arm", "adjusted.time", "ecdf_values")] plotdata_ecdf$type <- "tte" names(plotdata_ecdf) <- c("outcome", "arm", "x", "y", "type") - plotdata_cont <- continuous$data[, c("outcome", "arm", "x", "y_level")] - plotdata_cont$type <- "cont" - names(plotdata_cont) <- c("outcome", "arm", "x", "y", "type") + plotdata_last <- last_data$data[, c("outcome", "arm", "x", "y")] + plotdata_last$type <- last_type + names(plotdata_last) <- c("outcome", "arm", "x", "y", "type") # Add points at (0, 0) on both curves so that they start from the origin add_points <- plotdata_ecdf %>% @@ -316,54 +345,58 @@ plot_maraca <- function( add_points ) - plotdata <- as.data.frame(rbind(plotdata_ecdf, plotdata_cont)) + plotdata <- as.data.frame(rbind(plotdata_ecdf, plotdata_last)) scale <- sign(log10(continuous_grid_spacing_x)) * floor( abs(log10(continuous_grid_spacing_x)) ) - minor_grid <- .minor_grid( - continuous$data$value, scale, continuous_grid_spacing_x - ) + if (last_type == "continuous") { + + minor_grid <- .minor_grid( + last_data$data$value, scale, continuous_grid_spacing_x + ) + + range <- c(min(last_data$data$value, na.rm = TRUE), + max(last_data$data$value, na.rm = TRUE)) + + } else if (last_type == "binary") { + + minor_grid <- seq(0, 1, continuous_grid_spacing_x) + range <- c(0, 1) + + } - zeroposition <- .to_rangeab(0, - start_continuous_endpoint, - min(continuous$data$value, na.rm = TRUE), - max(continuous$data$value, na.rm = TRUE) - ) # Plot the information in the Maraca plot plot <- ggplot2::ggplot(plotdata) + ggplot2::geom_vline( xintercept = cumsum(c(0, meta$proportion)), color = "grey80" - ) + - ggplot2::geom_vline( - xintercept = zeroposition, - color = "white", - linewidth = 1 ) if (vline_type == "median") { plot <- plot + ggplot2::geom_vline( - mapping = aes( + mapping = ggplot2::aes( xintercept = median, color = arm ), - data = continuous$meta, + data = last_data$meta, linetype = "dashed", - linewidth = 0.8 + linewidth = 0.8, + show.legend = FALSE ) } else if (vline_type == "mean") { plot <- plot + ggplot2::geom_vline( - mapping = aes( + mapping = ggplot2::aes( xintercept = average, color = arm ), - data = continuous$meta, + data = last_data$meta, linetype = "dashed", - linewidth = 0.8 + linewidth = 0.8, + show.legend = FALSE ) } @@ -374,33 +407,45 @@ plot_maraca <- function( ) if (density_plot_type == "default") { - plot <- plot + - ggplot2::geom_violin( - data = plotdata[plotdata$type == "cont", ], - aes(x = x, y = y, colour = arm, fill = arm), alpha = 0.5 - ) + ggplot2::geom_boxplot( - data = plotdata[plotdata$type == "cont", ], - aes(x = x, y = y, colour = arm, fill = arm), alpha = 0.5, - width = - abs(diff(as.numeric(unique(plotdata[plotdata$type == "cont", ]$y)))) / - 3 - ) + if (last_type == "continuous") { + plot <- plot + + ggplot2::geom_violin( + data = plotdata[plotdata$type == "continuous", ], + aes(x = x, y = y, colour = arm, fill = arm), alpha = 0.5 + ) + ggplot2::geom_boxplot( + data = plotdata[plotdata$type == "continuous", ], + aes(x = x, y = y, colour = arm, fill = arm), alpha = 0.5, + width = + abs(diff(as.numeric(unique( + plotdata[plotdata$type == "continuous", ]$y)))) / 3 + ) + } else if (last_type == "binary") { + plot <- plot + + ggplot2::geom_polygon( + data = plotdata[plotdata$type == "binary", ], + ggplot2::aes(x = x, y = y, color = arm, fill = arm), + alpha = 0.5, + show.legend = FALSE) + + ggplot2::geom_point(data = last_data$meta, + ggplot2::aes(x = average, y = y, + color = arm)) + } } else if (density_plot_type == "violin") { plot <- plot + ggplot2::geom_violin( - data = plotdata[plotdata$type == "cont", ], + data = plotdata[plotdata$type == "continuous", ], aes(x = x, y = y, colour = arm, fill = arm), alpha = 0.5 ) } else if (density_plot_type == "box") { plot <- plot + ggplot2::geom_boxplot( - data = plotdata[plotdata$type == "cont", ], + data = plotdata[plotdata$type == "continuous", ], aes(x = x, y = y, colour = arm, fill = arm), alpha = 0.5 ) } else if (density_plot_type == "scatter") { plot <- plot + ggplot2::geom_jitter( - data = plotdata[plotdata$type == "cont", ], + data = plotdata[plotdata$type == "continuous", ], aes(x = x, y = y, color = arm), # Jittering only vertically, keep the correct x-value width = 0 @@ -417,13 +462,13 @@ plot_maraca <- function( plot <- plot + ggplot2::scale_x_continuous( limits = c(0, 100), - breaks = c(meta$proportion / 2 + meta$startx), + breaks = c(meta$proportion / 2 + meta$startx + 0.1), labels = c(obj$step_outcomes, obj$last_outcome), minor_breaks = .to_rangeab( minor_grid, - start_continuous_endpoint, - min(continuous$data$value, na.rm = TRUE), - max(continuous$data$value, na.rm = TRUE) + start_last_endpoint, + range[1], + range[2] ), trans = trans ) + @@ -431,9 +476,9 @@ plot_maraca <- function( geom = "text", x = .to_rangeab( minor_grid, - start_continuous_endpoint, - min(continuous$data$value, na.rm = TRUE), - max(continuous$data$value, na.rm = TRUE) + start_last_endpoint, + range[1], + range[2] ), y = 0, label = labels, @@ -507,7 +552,7 @@ validate_maraca_plot <- function(x, ...) { `%>%` <- dplyr::`%>%` pb <- ggplot2::ggplot_build(x) - plot_type <- class(as.list(x$layers[[5]])[["geom"]])[1] + plot_type <- class(as.list(x$layers[[4]])[["geom"]])[1] proportions <- diff(pb$data[[1]][, c("xintercept")]) names(proportions) <- levels(x$data$outcome) @@ -515,7 +560,7 @@ validate_maraca_plot <- function(x, ...) { arms <- levels(pb$plot$data[, pb$plot$labels$colour]) tte_data <- - utils::tail(utils::head(pb$data[[4]][, c("group", "x", "y")], -2), -2) + utils::tail(utils::head(pb$data[[3]][, c("group", "x", "y")], -2), -2) tte_data$group <- factor(tte_data$group, labels = arms) scatter_data <- NULL @@ -523,10 +568,10 @@ validate_maraca_plot <- function(x, ...) { violin_data <- NULL if (plot_type == "GeomPoint") { - scatter_data <- pb$data[[5]][, c("group", "x", "y")] + scatter_data <- pb$data[[4]][, c("group", "x", "y")] scatter_data$group <- factor(scatter_data$group, labels = arms) } else if (plot_type == "GeomBoxplot") { - boxstat_data <- pb$data[[5]] %>% + boxstat_data <- pb$data[[4]] %>% dplyr::select(group, "x_lowest" = xmin_final, "whisker_lower" = xmin, "hinge_lower" = xlower, "median" = xmiddle, @@ -535,11 +580,11 @@ validate_maraca_plot <- function(x, ...) { boxstat_data$outliers <- lapply(boxstat_data$outliers, sort) boxstat_data$group <- factor(boxstat_data$group, labels = arms) } else if (plot_type == "GeomViolin") { - violin_data <- pb$data[[5]][, c("group", "x", "y", "density", "width")] + violin_data <- pb$data[[4]][, c("group", "x", "y", "density", "width")] violin_data$group <- factor(violin_data$group, labels = arms) - if (class(as.list(x$layers[[6]])[["geom"]])[1] == "GeomBoxplot") { + if (class(as.list(x$layers[[5]])[["geom"]])[1] == "GeomBoxplot") { plot_type <- paste(plot_type, "GeomBoxplot", sep = "+") - boxstat_data <- pb$data[[6]] %>% + boxstat_data <- pb$data[[5]] %>% dplyr::select(group, "x_lowest" = xmin_final, "whisker_lower" = xmin, "hinge_lower" = xlower, "median" = xmiddle, @@ -688,17 +733,16 @@ plot.hce <- function(x, last_outcome = "C", continuous_outcome = lifecycle::deprecated(), ...) { - checkmate::assert_int(continuous_grid_spacing_x) - checkmate::assert_string(trans) - checkmate::assert_choice(density_plot_type, - c("default", "violin", "box", "scatter")) - checkmate::assert_choice( - vline_type, c("median", "mean", "none") - ) + if (lifecycle::is_present(continuous_outcome)) { + lifecycle::deprecate_warn("0.7.0", "maraca(continuous_outcome)", + "maraca(last_outcome)") + last_outcome <- continuous_outcome + } maraca_obj <- .maraca_from_hce_data(x, last_outcome, arm_levels, fixed_followup_days, - compute_win_odds) + compute_win_odds, + last_type = last_type) plot_maraca(maraca_obj, continuous_grid_spacing_x, trans, density_plot_type, vline_type, theme) diff --git a/tests/testthat/test_maraca.R b/tests/testthat/test_maraca.R index da26118..9385a5f 100644 --- a/tests/testthat/test_maraca.R +++ b/tests/testthat/test_maraca.R @@ -69,7 +69,7 @@ test_that("createMaracaObject", { step_outcomes, last_outcome, arm_levels) expect_equal(sum(abs(continuous$data$x)), 40828.387) - expect_equal(sum(abs(continuous$data$y_level)), 24451) + expect_equal(sum(abs(continuous$data$y)), 24451) expect_equal(continuous$meta$n, c(298, 271)) expect_equal(continuous$meta$median, c(74.360287, 68.354528)) @@ -988,16 +988,16 @@ test_that("validationFunction", { expect_null(val_res_scatter$boxstat_data) expect_equal(sort(val_res_scatter$scatter_data$x), - sort(mar$continuous$data$x)) + sort(mar$data_last_outcome$data$x)) - y_values <- unique(mar$continuous$data[, c("arm", "y_level")]) + y_values <- unique(mar$data_last_outcome$data[, c("arm", "y")]) y_values <- y_values[order(y_values$arm), ] jitter_means <- val_res_scatter$scatter_data %>% dplyr::group_by(group) %>% dplyr::summarize("y_level" = mean(y)) - expect_equal(jitter_means$y_level, y_values$y_level, tolerance = 0.1) + expect_equal(jitter_means$y_level, y_values$y, tolerance = 0.1) - boxplot_stats <- mar$continuous$data %>% + boxplot_stats <- mar$data_last_outcome$data %>% dplyr::group_by(arm) %>% dplyr::summarize("perc_25th" = unname(quantile(x, probs = 0.25)), "median" = median(x), @@ -1030,13 +1030,13 @@ test_that("validationFunction", { expect_equal(val_res_box$boxstat_data$x_highest, boxplot_stats$x_highest) y_values_violin <- unique(val_res_violin$violin_data$y) - violin_stats <- mar$continuous$data %>% + violin_stats <- mar$data_last_outcome$data %>% dplyr::group_by(arm) %>% dplyr::summarize("mean" = mean(x)) violin_stats_from_plot <- val_res_violin$violin_data %>% dplyr::group_by(group) %>% dplyr::summarize("mean" = weighted.mean(x, density)) - expect_equal(y_values_violin, y_values$y_level) + expect_equal(y_values_violin, y_values$y) expect_equal(violin_stats_from_plot$mean, violin_stats$mean, tolerance = 0.1) }) From 33e69b67820d332774d6fa08b11cdec9a06e1b9b Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Tue, 14 Nov 2023 10:10:33 +0000 Subject: [PATCH 05/32] Fixing lintr error --- R/internal.R | 8 ++++---- R/maraca.R | 16 ++++++++-------- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/R/internal.R b/R/internal.R index dab20d5..49fec38 100644 --- a/R/internal.R +++ b/R/internal.R @@ -258,9 +258,9 @@ binary_data <- rbind(data.frame("outcome" = last_outcome, "arm" = actv, actv_point), - data.frame("outcome" = last_outcome, - "arm" = ctrl, - ctrl_point) + data.frame("outcome" = last_outcome, + "arm" = ctrl, + ctrl_point) ) binary_data$x <- .to_rangeab( @@ -529,7 +529,7 @@ } .checks_continuous_outcome <- function(density_plot_type, - vline_type) { + vline_type) { checkmate::assert_choice( density_plot_type, c("default", "violin", "box", "scatter") ) diff --git a/R/maraca.R b/R/maraca.R index 169e43e..e8ac988 100644 --- a/R/maraca.R +++ b/R/maraca.R @@ -283,7 +283,7 @@ plot_maraca <- function( checkmate::assert_class(obj, "maraca") if (!(is.null(continuous_grid_spacing_x) || - is.numeric(continuous_grid_spacing_x))) { + is.numeric(continuous_grid_spacing_x))) { stop("continuous_grid_spacing_x has to be numeric or NULL") } @@ -416,16 +416,16 @@ plot_maraca <- function( data = plotdata[plotdata$type == "continuous", ], aes(x = x, y = y, colour = arm, fill = arm), alpha = 0.5, width = - abs(diff(as.numeric(unique( - plotdata[plotdata$type == "continuous", ]$y)))) / 3 + abs(diff(as.numeric(unique(plotdata[plotdata$type == "continuous", + ]$y)))) / 3 ) } else if (last_type == "binary") { plot <- plot + - ggplot2::geom_polygon( - data = plotdata[plotdata$type == "binary", ], - ggplot2::aes(x = x, y = y, color = arm, fill = arm), - alpha = 0.5, - show.legend = FALSE) + + ggplot2::geom_polygon(data = plotdata[plotdata$type == "binary", ], + ggplot2::aes(x = x, y = y, color = arm, + fill = arm), + alpha = 0.5, + show.legend = FALSE) + ggplot2::geom_point(data = last_data$meta, ggplot2::aes(x = average, y = y, color = arm)) From 5ce78bc2c6ab16e8873c63ba5527f07b8e3c6666 Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Tue, 14 Nov 2023 10:17:41 +0000 Subject: [PATCH 06/32] Fixing lintr error --- R/maraca.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/maraca.R b/R/maraca.R index e8ac988..09960f4 100644 --- a/R/maraca.R +++ b/R/maraca.R @@ -283,7 +283,7 @@ plot_maraca <- function( checkmate::assert_class(obj, "maraca") if (!(is.null(continuous_grid_spacing_x) || - is.numeric(continuous_grid_spacing_x))) { + is.numeric(continuous_grid_spacing_x))) { stop("continuous_grid_spacing_x has to be numeric or NULL") } @@ -417,7 +417,7 @@ plot_maraca <- function( aes(x = x, y = y, colour = arm, fill = arm), alpha = 0.5, width = abs(diff(as.numeric(unique(plotdata[plotdata$type == "continuous", - ]$y)))) / 3 + ]$y)))) / 3 ) } else if (last_type == "binary") { plot <- plot + From 868d5b297418718e7937f25a0a5f43af5ced3916 Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Fri, 17 Nov 2023 10:16:23 +0000 Subject: [PATCH 07/32] Rework tte part to calculate and draw seperate step curves for each outcome in preparation for including different step types --- R/internal.R | 91 ++++++++++++++++++++++++++++++++++++++++++++++------ R/maraca.R | 88 ++++++++++++++++++++++++-------------------------- 2 files changed, 124 insertions(+), 55 deletions(-) diff --git a/R/internal.R b/R/internal.R index 49fec38..7924d01 100644 --- a/R/internal.R +++ b/R/internal.R @@ -121,23 +121,25 @@ } hce_dat$t_cdf <- sum(fixed_followup_days) + 2 * max(fixed_followup_days) + hce_dat$ecdf_values <- 0 for (i in seq_len(num_tte_outcomes)) { + add_previous_end <- ifelse(i == 1, 0, sum(fixed_followup_days[1:(i - 1)])) hce_dat[hce_dat$outcome == step_outcomes[[i]], ]$t_cdf <- hce_dat[hce_dat$outcome == step_outcomes[[i]], ]$value + add_previous_end - } - hce_ecdf <- - do.call("rbind", - lapply(unique(hce_dat$arm), function(a, df, outcomes) { - tmp <- df %>% dplyr::filter(arm == a) - tmp$ecdf_values <- 100 * - stats::ecdf(tmp$t_cdf)(tmp$t_cdf) - tmp %>% dplyr::filter(outcome %in% outcomes) - }, df = hce_dat, outcomes = step_outcomes)) + for (arm in arm_levels) { + idx <- hce_dat$outcome == step_outcomes[[i]] & hce_dat$arm == arm + hce_dat[idx, ]$ecdf_values <- + 100 * + stats::ecdf(hce_dat[hce_dat$arm == arm, + ]$t_cdf)(hce_dat[idx, ]$t_cdf) + } + } + hce_ecdf <- hce_dat[hce_dat$outcome %in% step_outcomes, ] hce_ecdf <- hce_ecdf[order(hce_ecdf$ecdf_values), ] hce_ecdf$adjusted.time <- 0 @@ -547,3 +549,74 @@ vline_type, c("mean", "none") ) } + +.create_validation_tte <- function(layers, x, arms) { + + tte_layers <- which(layers == "GeomStep") + + if (length(tte_layers) != 0) { + tte_data <- do.call("rbind", + lapply(tte_layers, + function(i) { + dat <- utils::head( + ggplot2::layer_data(plot = x, + i = i)[, c("x", "y", + "group")], + -2) + if (i == tte_layers[1]) { + dat <- utils::tail(dat, -2) + } + return(dat) + })) + + tte_data$group <- factor(tte_data$group, labels = arms) + + } else { + tte_data <- NULL + } + + return(tte_data) +} + +.create_validation_scatter <- function(layers, x, arms) { + scatter_data <- do.call("rbind", lapply(which(layers == "GeomPoint"), + ggplot2::layer_data, plot = x)) + if (!is.null(scatter_data)) { + scatter_data <- scatter_data[, c("group", "x", "y")] + scatter_data$group <- factor(scatter_data$group, labels = arms) + } + + return(scatter_data) +} + +.create_validation_violin <- function(layers, x, arms) { + violin_data <- do.call("rbind", lapply(which(layers == "GeomViolin"), + ggplot2::layer_data, plot = x)) + if (!is.null(violin_data)) { + violin_data <- violin_data[, c("group", "x", "y", "density", "width")] + violin_data$group <- factor(violin_data$group, labels = arms) + } + + return(violin_data) +} + +.create_validation_box <- function(layers, x, arms) { + + `%>%` <- dplyr::`%>%` + + boxstat_data <- do.call("rbind", lapply(which(layers == "GeomBoxplot"), + ggplot2::layer_data, plot = x)) + + if (!is.null(boxstat_data)) { + boxstat_data <- boxstat_data %>% + dplyr::select(group, "x_lowest" = xmin_final, + "whisker_lower" = xmin, + "hinge_lower" = xlower, "median" = xmiddle, + "hinge_upper" = xupper, "whisker_upper" = xmax, + "x_highest" = xmax_final, outliers) + boxstat_data$outliers <- lapply(boxstat_data$outliers, sort) + boxstat_data$group <- factor(boxstat_data$group, labels = arms) + } + + return(boxstat_data) +} diff --git a/R/maraca.R b/R/maraca.R index 09960f4..929999a 100644 --- a/R/maraca.R +++ b/R/maraca.R @@ -293,6 +293,7 @@ plot_maraca <- function( `%>%` <- dplyr::`%>%` meta <- obj$meta + step_outcomes <- obj$step_outcomes last_data <- obj$data_last_outcome last_type <- obj$last_type @@ -333,6 +334,27 @@ plot_maraca <- function( plotdata_ecdf ) + plotdata_ecdf <- plotdata_ecdf[order(plotdata_ecdf$x), ] + + # # Add starting point of next curve to avoid jumps + add_points <- + do.call("rbind", + lapply(1:(length(step_outcomes) - 1), + function(i) { + plotdata_ecdf %>% + dplyr::group_by(arm) %>% + dplyr::filter(outcome == step_outcomes[i + 1]) %>% + dplyr::slice_head(n = 1) %>% + dplyr::ungroup() %>% + dplyr::mutate(outcome = step_outcomes[i]) + })) + + plotdata_ecdf <- rbind( + add_points, + plotdata_ecdf + ) + plotdata_ecdf <- plotdata_ecdf[order(plotdata_ecdf$x), ] + # Add points at (100, y) on both curves so that they end at x=100% add_points <- plotdata_ecdf %>% dplyr::group_by(arm) %>% @@ -400,11 +422,14 @@ plot_maraca <- function( ) } - plot <- plot + - ggplot2::geom_step( - data = plotdata[plotdata$type == "tte", ], - aes(x = x, y = y, color = arm) - ) + for (outcome in step_outcomes) { + + plot <- plot + + ggplot2::geom_step( + data = plotdata[plotdata$type == "tte" & plotdata$outcome == outcome, ], + aes(x = x, y = y, color = arm) + ) + } if (density_plot_type == "default") { if (last_type == "continuous") { @@ -549,53 +574,24 @@ plot_maraca <- function( validate_maraca_plot <- function(x, ...) { checkmate::assert_class(x, "maracaPlot") - `%>%` <- dplyr::`%>%` - pb <- ggplot2::ggplot_build(x) - plot_type <- class(as.list(x$layers[[4]])[["geom"]])[1] + layers <- sapply(pb$plot$layers, function(lb) { + class(lb$geom)[1] + }) proportions <- diff(pb$data[[1]][, c("xintercept")]) - names(proportions) <- levels(x$data$outcome) + names(proportions) <- unique(x$data$outcome) arms <- levels(pb$plot$data[, pb$plot$labels$colour]) - tte_data <- - utils::tail(utils::head(pb$data[[3]][, c("group", "x", "y")], -2), -2) - tte_data$group <- factor(tte_data$group, labels = arms) - - scatter_data <- NULL - boxstat_data <- NULL - violin_data <- NULL - - if (plot_type == "GeomPoint") { - scatter_data <- pb$data[[4]][, c("group", "x", "y")] - scatter_data$group <- factor(scatter_data$group, labels = arms) - } else if (plot_type == "GeomBoxplot") { - boxstat_data <- pb$data[[4]] %>% - dplyr::select(group, "x_lowest" = xmin_final, - "whisker_lower" = xmin, - "hinge_lower" = xlower, "median" = xmiddle, - "hinge_upper" = xupper, "whisker_upper" = xmax, - "x_highest" = xmax_final, outliers) - boxstat_data$outliers <- lapply(boxstat_data$outliers, sort) - boxstat_data$group <- factor(boxstat_data$group, labels = arms) - } else if (plot_type == "GeomViolin") { - violin_data <- pb$data[[4]][, c("group", "x", "y", "density", "width")] - violin_data$group <- factor(violin_data$group, labels = arms) - if (class(as.list(x$layers[[5]])[["geom"]])[1] == "GeomBoxplot") { - plot_type <- paste(plot_type, "GeomBoxplot", sep = "+") - boxstat_data <- pb$data[[5]] %>% - dplyr::select(group, "x_lowest" = xmin_final, - "whisker_lower" = xmin, - "hinge_lower" = xlower, "median" = xmiddle, - "hinge_upper" = xupper, "whisker_upper" = xmax, - "x_highest" = xmax_final, outliers) - boxstat_data$outliers <- lapply(boxstat_data$outliers, sort) - boxstat_data$group <- factor(boxstat_data$group, labels = arms) - } - } else { - stop(paste0("Unrecognised plot type ", plot_type)) - } + tte_data <- .create_validation_tte(layers, x, arms) + scatter_data <- .create_validation_scatter(layers, x, arms) + boxstat_data <- .create_validation_box(layers, x, arms) + violin_data <- .create_validation_violin(layers, x, arms) + + possible_plot_types <- c("GeomViolin", "GeomBoxplot", "GeomPoint") + plot_type <- paste(possible_plot_types[possible_plot_types %in% layers], + collapse = "+") if ("win.odds" %in% names(x$labels)) { params <- x$labels$win.odds From 7b9fa06a1509b5b947aca412380c3813f2b1bead Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Fri, 17 Nov 2023 10:30:26 +0000 Subject: [PATCH 08/32] Fix lintr error --- R/internal.R | 37 ++++++++++++++++++------------------- R/maraca.R | 6 +++--- 2 files changed, 21 insertions(+), 22 deletions(-) diff --git a/R/internal.R b/R/internal.R index 7924d01..f6392c9 100644 --- a/R/internal.R +++ b/R/internal.R @@ -130,12 +130,11 @@ hce_dat[hce_dat$outcome == step_outcomes[[i]], ]$value + add_previous_end - for (arm in arm_levels) { - idx <- hce_dat$outcome == step_outcomes[[i]] & hce_dat$arm == arm - hce_dat[idx, ]$ecdf_values <- - 100 * - stats::ecdf(hce_dat[hce_dat$arm == arm, - ]$t_cdf)(hce_dat[idx, ]$t_cdf) + for (arm in arm_levels) { + idx <- hce_dat$outcome == step_outcomes[[i]] & hce_dat$arm == arm + hce_dat[idx, ]$ecdf_values <- + 100 * + stats::ecdf(hce_dat[hce_dat$arm == arm, ]$t_cdf)(hce_dat[idx, ]$t_cdf) } } @@ -555,19 +554,19 @@ tte_layers <- which(layers == "GeomStep") if (length(tte_layers) != 0) { - tte_data <- do.call("rbind", - lapply(tte_layers, - function(i) { - dat <- utils::head( - ggplot2::layer_data(plot = x, - i = i)[, c("x", "y", - "group")], - -2) - if (i == tte_layers[1]) { - dat <- utils::tail(dat, -2) - } - return(dat) - })) + tte_data <- + do.call("rbind", + lapply(tte_layers, + function(i) { + dat <- ggplot2::layer_data(plot = x, + i = i)[, c("x", "y", + "group")] + dat <- utils::head(dat, -2) + if (i == tte_layers[1]) { + dat <- utils::tail(dat, -2) + } + return(dat) + })) tte_data$group <- factor(tte_data$group, labels = arms) diff --git a/R/maraca.R b/R/maraca.R index 929999a..5e103fc 100644 --- a/R/maraca.R +++ b/R/maraca.R @@ -347,7 +347,7 @@ plot_maraca <- function( dplyr::slice_head(n = 1) %>% dplyr::ungroup() %>% dplyr::mutate(outcome = step_outcomes[i]) - })) + })) plotdata_ecdf <- rbind( add_points, @@ -576,8 +576,8 @@ validate_maraca_plot <- function(x, ...) { pb <- ggplot2::ggplot_build(x) layers <- sapply(pb$plot$layers, function(lb) { - class(lb$geom)[1] - }) + class(lb$geom)[1] + }) proportions <- diff(pb$data[[1]][, c("xintercept")]) names(proportions) <- unique(x$data$outcome) From 264ec08b8c9101b24b335453e86d4569efb83e18 Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Fri, 17 Nov 2023 10:36:13 +0000 Subject: [PATCH 09/32] Fix lintr error --- R/internal.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/internal.R b/R/internal.R index f6392c9..2488e5e 100644 --- a/R/internal.R +++ b/R/internal.R @@ -135,7 +135,7 @@ hce_dat[idx, ]$ecdf_values <- 100 * stats::ecdf(hce_dat[hce_dat$arm == arm, ]$t_cdf)(hce_dat[idx, ]$t_cdf) - } + } } hce_ecdf <- hce_dat[hce_dat$outcome %in% step_outcomes, ] From 3d39ba2224763f2c5228a15aa57c9734019e4e16 Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Tue, 13 Feb 2024 07:23:53 +0000 Subject: [PATCH 10/32] Fixed bug in step function --- R/aaa.R | 5 ++ R/internal.R | 123 ++++++++++++++++++++++++-------- R/maraca.R | 132 ++++++++++++++++++++++++++++------- tests/testthat/test_maraca.R | 24 ++++--- 4 files changed, 221 insertions(+), 63 deletions(-) diff --git a/R/aaa.R b/R/aaa.R index 4a70e96..833db8a 100644 --- a/R/aaa.R +++ b/R/aaa.R @@ -4,6 +4,8 @@ utils::globalVariables("n") utils::globalVariables("n.event") utils::globalVariables("x") utils::globalVariables("y") +utils::globalVariables("xend") +utils::globalVariables("yend") utils::globalVariables("strata") utils::globalVariables("surv") utils::globalVariables("proportion") @@ -17,6 +19,9 @@ utils::globalVariables("violiny") utils::globalVariables("violinx") utils::globalVariables("adjusted.time") utils::globalVariables("tte_outcomes") +utils::globalVariables("step_values") +utils::globalVariables("type") +utils::globalVariables("t_cdf") utils::globalVariables("continuous_outcome") utils::globalVariables("treatments") utils::globalVariables("fixed_followup_days") diff --git a/R/internal.R b/R/internal.R index 2488e5e..196df76 100644 --- a/R/internal.R +++ b/R/internal.R @@ -48,7 +48,8 @@ dplyr::group_by(outcome) %>% dplyr::summarise(min = min(value), max = max(value)) %>% dplyr::mutate(separation = max - min) %>% - dplyr::summarise(max_separation = max(separation)) + dplyr::summarise(max_separation = max(separation)) %>% + dplyr::ungroup() # With the largest window found, we know that if we offset the data at # least of this amount, they will never overlap. Bit of clever math here, @@ -84,20 +85,23 @@ endx = cumsum(proportion), starty = 0, n.groups = length(unique(outcome)) - ) + ) %>% + dplyr::ungroup() meta2 <- hce_dat %>% dplyr::filter(!is.na(value)) %>% dplyr::group_by(outcome, arm) %>% dplyr::summarise(n = n(), proportion = n / dim(hce_dat)[[1]] * 100) %>% dplyr::mutate("arm" = gsub(" ", "_", tolower(arm))) %>% - tidyr::pivot_wider(names_from = arm, values_from = c(n, proportion)) + tidyr::pivot_wider(names_from = arm, values_from = c(n, proportion)) %>% + dplyr::ungroup() meta_missing <- hce_dat %>% dplyr::group_by(outcome) %>% dplyr::summarise( missing = sum(is.na(value)) - ) + ) %>% + dplyr::ungroup() meta <- dplyr::left_join(meta1, meta2, "outcome") meta <- dplyr::left_join(meta, meta_missing, "outcome") @@ -107,42 +111,72 @@ # Calculates the cumulative distribution for TTE outcomes .compute_ecdf_by_outcome <- function( - hce_dat, meta, step_outcomes, last_outcome, arm_levels, - fixed_followup_days + hce_dat, meta, step_outcomes, step_types, + last_outcome, arm_levels, fixed_followup_days ) { `%>%` <- dplyr::`%>%` n <- dplyr::n - num_tte_outcomes <- length(step_outcomes) + num_step_outcomes <- length(step_outcomes) + + tte_outcomes <- step_outcomes[which(step_types == "tte")] + binary_outcomes <- step_outcomes[which(step_types == "binary")] if (length(fixed_followup_days) == 1) { - fixed_followup_days <- rep(fixed_followup_days, times = num_tte_outcomes) + fixed_followup_days <- sapply(step_types, function(type) { + ifelse(type == "binary", 2, fixed_followup_days) + }, USE.NAMES = FALSE) } hce_dat$t_cdf <- sum(fixed_followup_days) + 2 * max(fixed_followup_days) - hce_dat$ecdf_values <- 0 + hce_dat$step_values <- 0 - for (i in seq_len(num_tte_outcomes)) { + for (i in seq_len(num_step_outcomes)) { + idx <- hce_dat$outcome == step_outcomes[[i]] add_previous_end <- ifelse(i == 1, 0, sum(fixed_followup_days[1:(i - 1)])) - hce_dat[hce_dat$outcome == step_outcomes[[i]], ]$t_cdf <- - hce_dat[hce_dat$outcome == step_outcomes[[i]], ]$value + - add_previous_end + hce_dat[idx, ]$t_cdf <- hce_dat[idx, ]$value + add_previous_end for (arm in arm_levels) { idx <- hce_dat$outcome == step_outcomes[[i]] & hce_dat$arm == arm - hce_dat[idx, ]$ecdf_values <- + + hce_dat[idx, ]$step_values <- 100 * stats::ecdf(hce_dat[hce_dat$arm == arm, ]$t_cdf)(hce_dat[idx, ]$t_cdf) + } + } - hce_ecdf <- hce_dat[hce_dat$outcome %in% step_outcomes, ] - hce_ecdf <- hce_ecdf[order(hce_ecdf$ecdf_values), ] + hce_ecdf <- hce_dat[hce_dat$outcome %in% tte_outcomes, + c("outcome", "arm", "value", "step_values", + "t_cdf")] + + if (length(binary_outcomes) != 0) { + hce_ecdf_binary <- hce_dat[hce_dat$outcome %in% binary_outcomes, ] + hce_ecdf_binary <- hce_ecdf_binary %>% + dplyr::group_by(outcome, arm) %>% + dplyr::summarize(t_cdf = sum(value), + step_values = unique(step_values), + value = 1) %>% + dplyr::ungroup() + + hce_ecdf <- rbind(hce_ecdf, + hce_ecdf_binary[, c("outcome", "arm", "value", + "step_values", "t_cdf")]) + } + + hce_ecdf <- hce_ecdf[order(hce_ecdf$step_values), ] + + endpoint <- data.frame("outcome" = step_outcomes, + "type" = step_types) + + hce_ecdf <- dplyr::left_join(hce_ecdf, endpoint, + by = "outcome") hce_ecdf$adjusted.time <- 0 - for (i in seq_len(num_tte_outcomes)) { + for (i in seq_len(num_step_outcomes)) { entry <- step_outcomes[i] outcome_filter <- hce_ecdf$outcome == entry hce_ecdf[outcome_filter, ]$adjusted.time <- @@ -154,11 +188,16 @@ hce_ecdf_meta <- hce_ecdf %>% dplyr::group_by(arm, outcome) %>% - dplyr::summarise(max = max(ecdf_values, na.rm = TRUE), - sum.event = n()) %>% + dplyr::summarise(max = max(step_values, na.rm = TRUE), + type = unique(type), + sum.event = ifelse(type == "tte", n(), + unique(t_cdf)) + ) %>% + dplyr::arrange(max) %>% dplyr::mutate( ecdf_end = utils::tail(max, 1) - ) + ) %>% + dplyr::ungroup() return(list( data = hce_ecdf, @@ -192,7 +231,8 @@ continuous_meta <- continuous_data %>% dplyr::group_by(arm) %>% dplyr::summarise(n = n(), median = stats::median(x, na.rm = TRUE), - average = base::mean(x, na.rm = TRUE)) + average = base::mean(x, na.rm = TRUE)) %>% + dplyr::ungroup() continuous_data$y <- ecdf_mod$meta[ ecdf_mod$meta$arm == unname(arm_levels["active"]) & @@ -235,7 +275,8 @@ dplyr::group_by(arm) %>% dplyr::summarise(n = n(), average = base::mean(value, na.rm = TRUE), - conf_int = 1.96 * sqrt((average * (1 - average)) / n)) + conf_int = 1.96 * sqrt((average * (1 - average)) / n)) %>% + dplyr::ungroup() x_radius <- (100 - start_binary_endpoint) * min(binary_meta$conf_int) y_height <- min(c(0.4 * abs(actv_y - ctrl_y), 0.8 * x_radius)) @@ -379,6 +420,7 @@ .maraca_from_hce_data <- function(x, last_outcome, arm_levels, fixed_followup_days, compute_win_odds, + step_types = "tte", last_type = "continuous") { checkmate::assert_string(last_outcome) @@ -418,6 +460,7 @@ arm_levels = arm_levels, fixed_followup_days = fixed_followup_days, compute_win_odds = compute_win_odds, + step_types = step_types, last_type = last_type ) @@ -534,9 +577,21 @@ checkmate::assert_choice( density_plot_type, c("default", "violin", "box", "scatter") ) - checkmate::assert_choice( - vline_type, c("median", "mean", "none") - ) + + if (!(is.null(vline_type) || + checkmate::testString(vline_type))) { + stop("vline_type has to be a string or NULL") + } + + if (is.null(vline_type)) { + vline_type <- "median" + } else { + checkmate::assert_choice( + vline_type, c("median", "mean", "none") + ) + } + + return(vline_type) } .checks_binary_outcome <- function(density_plot_type, @@ -544,9 +599,21 @@ checkmate::assert_choice( density_plot_type, c("default") ) - checkmate::assert_choice( - vline_type, c("mean", "none") - ) + + if (!(is.null(vline_type) || + checkmate::testString(vline_type))) { + stop("vline_type has to be a string or NULL") + } + + if (is.null(vline_type)) { + vline_type <- "mean" + } else { + checkmate::assert_choice( + vline_type, c("mean", "none") + ) + } + + return(vline_type) } .create_validation_tte <- function(layers, x, arms) { diff --git a/R/maraca.R b/R/maraca.R index 5e103fc..05d4ea6 100644 --- a/R/maraca.R +++ b/R/maraca.R @@ -70,7 +70,7 @@ maraca <- function( arm = "arm", value = "value" ), - fixed_followup_days, + fixed_followup_days = NULL, compute_win_odds = FALSE, step_types = "tte", last_type = "continuous", @@ -107,12 +107,23 @@ maraca <- function( checkmate::assert_integerish(fixed_followup_days) + checkmate::assert_character(step_types) + checkmate::assert_subset(step_types, + choices = c("tte", "binary"), + empty.ok = FALSE) + + if (!(length(step_types) %in% c(1, length(step_outcomes)))) { + stop(paste("step_types needs to be either a single string or", + "a vector with one value for each tte outcome")) + } + checkmate::assert_string(last_type) checkmate::assert_subset(last_type, choices = c("continuous", "binary"), empty.ok = FALSE) - if (!(length(fixed_followup_days) %in% c(1, length(step_outcomes)))) { + if (!(length(fixed_followup_days) %in% + c(1, length(step_outcomes[step_types == "tte"])))) { stop(paste("fixed_followup_days needs to be either a single value or", "a vector with one value for each tte outcome")) } @@ -162,8 +173,14 @@ maraca <- function( hce_dat <- hce_dat %>% dplyr::filter(!is.na(value)) + # Vectorize step type if singular value + if (length(step_types) == 1) { + step_types <- rep(step_types, times = length(step_outcomes)) + } + ecdf_by_outcome <- .compute_ecdf_by_outcome( - hce_dat, meta, step_outcomes, last_outcome, arm_levels, + hce_dat, meta, step_outcomes, step_types, + last_outcome, arm_levels, fixed_followup_days ) @@ -189,6 +206,7 @@ maraca <- function( list( step_outcomes = step_outcomes, last_outcome = last_outcome, + step_types = step_types, last_type = last_type, arm_levels = arm_levels, fixed_followup_days = fixed_followup_days, @@ -277,7 +295,7 @@ plot_maraca <- function( obj, continuous_grid_spacing_x = NULL, trans = "identity", density_plot_type = "default", - vline_type = "median", + vline_type = NULL, theme = "maraca") { checkmate::assert_class(obj, "maraca") @@ -294,15 +312,19 @@ plot_maraca <- function( meta <- obj$meta step_outcomes <- obj$step_outcomes + step_types <- obj$step_types + which_tte <- which(step_types == "tte") + which_binary <- which(step_types == "binary") last_data <- obj$data_last_outcome last_type <- obj$last_type - switch(last_type, - "continuous" = .checks_continuous_outcome(density_plot_type, - vline_type), - "binary" = .checks_binary_outcome(density_plot_type, - vline_type), - stop("Unsupported last outcome type")) + vline_type <- + switch(last_type, + "continuous" = .checks_continuous_outcome(density_plot_type, + vline_type), + "binary" = .checks_binary_outcome(density_plot_type, + vline_type), + stop("Unsupported last outcome type")) ecdf_mod <- obj$ecdf_by_outcome win_odds <- obj$win_odds @@ -314,8 +336,8 @@ plot_maraca <- function( } plotdata_ecdf <- ecdf_mod$data[, c("outcome", "arm", - "adjusted.time", "ecdf_values")] - plotdata_ecdf$type <- "tte" + "adjusted.time", "step_values", + "type")] names(plotdata_ecdf) <- c("outcome", "arm", "x", "y", "type") plotdata_last <- last_data$data[, c("outcome", "arm", "x", "y")] plotdata_last$type <- last_type @@ -336,17 +358,18 @@ plot_maraca <- function( plotdata_ecdf <- plotdata_ecdf[order(plotdata_ecdf$x), ] - # # Add starting point of next curve to avoid jumps + # Add end point of previous curve to avoid jumps add_points <- do.call("rbind", - lapply(1:(length(step_outcomes) - 1), + lapply(2:length(step_outcomes), function(i) { plotdata_ecdf %>% dplyr::group_by(arm) %>% - dplyr::filter(outcome == step_outcomes[i + 1]) %>% - dplyr::slice_head(n = 1) %>% + dplyr::filter(outcome == step_outcomes[i - 1]) %>% + dplyr::slice_tail(n = 1) %>% dplyr::ungroup() %>% - dplyr::mutate(outcome = step_outcomes[i]) + dplyr::mutate(outcome = step_outcomes[i]) %>% + dplyr::ungroup() })) plotdata_ecdf <- rbind( @@ -367,6 +390,8 @@ plot_maraca <- function( add_points ) + plotdata_ecdf <- plotdata_ecdf[order(plotdata_ecdf$x), ] + plotdata <- as.data.frame(rbind(plotdata_ecdf, plotdata_last)) scale <- sign(log10(continuous_grid_spacing_x)) * floor( @@ -422,12 +447,66 @@ plot_maraca <- function( ) } - for (outcome in step_outcomes) { - + for (outcome in step_outcomes[which_tte]) { plot <- plot + ggplot2::geom_step( - data = plotdata[plotdata$type == "tte" & plotdata$outcome == outcome, ], - aes(x = x, y = y, color = arm) + data = plotdata[plotdata$outcome == outcome, ], + aes(x = x, y = y, color = arm)) + } + + if (length(which_binary) > 0) { + + tmp <- plotdata[plotdata$outcome %in% step_outcomes[which_binary], ] + + tmp <- tmp[order(tmp$x), ] + + if (step_types[length(step_types)] == "binary") { + tmp <- dplyr::slice_head(tmp, n = -2) + } + + tmp1 <- tmp %>% + dplyr::group_by(outcome, arm) %>% + dplyr::summarize("xend" = max(x), + "x" = min(x), + "y" = min(y)) %>% + dplyr::ungroup() + + tmp2 <- tmp %>% + dplyr::group_by(outcome, arm) %>% + dplyr::summarize("x" = max(x), + "yend" = max(y), + "y" = min(y)) %>% + dplyr::ungroup() + + plot <- plot + + ggplot2::geom_segment( + data = tmp1, + aes(x = x, y = y, xend = xend, yend = y, + color = arm) + ) + + ggplot2::geom_segment( + data = tmp2, + aes(x = x, y = y, xend = x, yend = yend), + color = "darkgrey", linetype = 2 + ) + } + + if (step_types[length(step_types)] == "binary") { + + tmp <- plotdata %>% + dplyr::filter(outcome == step_outcomes[length(step_types)]) %>% + dplyr::group_by(arm) %>% + dplyr::slice_tail(n = -1) %>% + dplyr::summarize("xend" = max(x), + "x" = min(x), + "y" = max(y)) %>% + dplyr::ungroup() + + plot <- plot + + ggplot2::geom_segment( + data = tmp, + aes(x = x, y = y, xend = xend, yend = y, + color = arm) ) } @@ -435,18 +514,17 @@ plot_maraca <- function( if (last_type == "continuous") { plot <- plot + ggplot2::geom_violin( - data = plotdata[plotdata$type == "continuous", ], + data = plotdata_last, aes(x = x, y = y, colour = arm, fill = arm), alpha = 0.5 ) + ggplot2::geom_boxplot( - data = plotdata[plotdata$type == "continuous", ], + data = plotdata_last, aes(x = x, y = y, colour = arm, fill = arm), alpha = 0.5, width = - abs(diff(as.numeric(unique(plotdata[plotdata$type == "continuous", - ]$y)))) / 3 + abs(diff(as.numeric(unique(plotdata_last$y)))) / 3 ) } else if (last_type == "binary") { plot <- plot + - ggplot2::geom_polygon(data = plotdata[plotdata$type == "binary", ], + ggplot2::geom_polygon(data = plotdata_last, ggplot2::aes(x = x, y = y, color = arm, fill = arm), alpha = 0.5, @@ -724,6 +802,7 @@ plot.hce <- function(x, last_outcome = "C", vline_type = "median", fixed_followup_days = NULL, compute_win_odds = FALSE, + step_types = "tte", last_type = "continuous", theme = "maraca", continuous_outcome = lifecycle::deprecated(), @@ -738,6 +817,7 @@ plot.hce <- function(x, last_outcome = "C", maraca_obj <- .maraca_from_hce_data(x, last_outcome, arm_levels, fixed_followup_days, compute_win_odds, + step_types = step_types, last_type = last_type) plot_maraca(maraca_obj, continuous_grid_spacing_x, diff --git a/tests/testthat/test_maraca.R b/tests/testthat/test_maraca.R index 9385a5f..73996ec 100644 --- a/tests/testthat/test_maraca.R +++ b/tests/testthat/test_maraca.R @@ -62,7 +62,10 @@ test_that("createMaracaObject", { data <- .reformat_and_check_data(data, step_outcomes, last_outcome, arm_levels, column_names = column_names) meta <- .compute_metainfo(data) + + step_types <- rep("tte", times = length(step_outcomes)) hce_ecdf <- .compute_ecdf_by_outcome(data, meta, step_outcomes, + step_types = step_types, last_outcome, arm_levels, 3 * 365) continuous <- .compute_continuous(data, meta, hce_ecdf, @@ -143,23 +146,26 @@ test_that("createMaracaObject", { column_names ) meta <- .compute_metainfo(data) + + step_types <- rep("tte", times = length(step_outcomes)) hce_ecdf <- .compute_ecdf_by_outcome(data, meta, step_outcomes, + step_types = step_types, last_outcome, arm_levels, 3 * 365) # Checking the abssum along the columns to check that values remain the same. expect_equal(sum(abs(hce_ecdf$data$value)), 221627.7286) expect_equal(sum(abs(hce_ecdf$data$t_cdf)), 841397.7286) - expect_equal(sum(abs(hce_ecdf$data$ecdf_values)), 9367.6) + expect_equal(sum(abs(hce_ecdf$data$step_values)), 9367.6) expect_equal(sum(abs(hce_ecdf$data$adjusted.time)), 9142.184244) expect_equal(hce_ecdf$meta$max, - c(12.6, 23.6, 33.6, 40.4, 13.2, - 25.2, 37.2, 45.8), tol = 1e-6) + c(12.6, 13.2, 23.6, 25.2, + 33.6, 37.2, 40.4, 45.8), tol = 1e-6) expect_equal(hce_ecdf$meta$sum.event, c( - 63, 55, 50, 34, 66, 60, 60, 43 + 63, 66, 55, 60, 50, 60, 34, 43 )) expect_equal(hce_ecdf$meta$ecdf_end, - c(40.4, 40.4, 40.4, 40.4, 45.8, 45.8, 45.8, 45.8), tol = 1e-6 + c(40.4, 45.8, 40.4, 45.8, 40.4, 45.8, 40.4, 45.8), tol = 1e-6 ) # test ordered column @@ -970,10 +976,10 @@ test_that("validationFunction", { expect_equal(val_res_violin$tte_data$x, mar_tte_dat$adjusted.time) expect_equal(val_res_box$tte_data$x, mar_tte_dat$adjusted.time) expect_equal(val_res_scatter$tte_data$x, mar_tte_dat$adjusted.time) - expect_equal(val_res_def$tte_data$y, mar_tte_dat$ecdf_values) - expect_equal(val_res_violin$tte_data$y, mar_tte_dat$ecdf_values) - expect_equal(val_res_box$tte_data$y, mar_tte_dat$ecdf_values) - expect_equal(val_res_scatter$tte_data$y, mar_tte_dat$ecdf_values) + expect_equal(val_res_def$tte_data$y, mar_tte_dat$step_values) + expect_equal(val_res_violin$tte_data$y, mar_tte_dat$step_values) + expect_equal(val_res_box$tte_data$y, mar_tte_dat$step_values) + expect_equal(val_res_scatter$tte_data$y, mar_tte_dat$step_values) expect_equal(val_res_def$tte_data$group, mar_tte_dat$arm) expect_equal(val_res_violin$tte_data$group, mar_tte_dat$arm) expect_equal(val_res_box$tte_data$group, mar_tte_dat$arm) From f3dc9a65543933c6f4b853b976ecf5cdef17911b Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Tue, 13 Feb 2024 08:07:24 +0000 Subject: [PATCH 11/32] Fixed lintr error --- R/internal.R | 8 ++++---- R/maraca.R | 7 +++---- 2 files changed, 7 insertions(+), 8 deletions(-) diff --git a/R/internal.R b/R/internal.R index 196df76..09a1f72 100644 --- a/R/internal.R +++ b/R/internal.R @@ -189,10 +189,10 @@ hce_ecdf_meta <- hce_ecdf %>% dplyr::group_by(arm, outcome) %>% dplyr::summarise(max = max(step_values, na.rm = TRUE), - type = unique(type), - sum.event = ifelse(type == "tte", n(), - unique(t_cdf)) - ) %>% + type = unique(type), + sum.event = ifelse(type == "tte", n(), + unique(t_cdf)) + ) %>% dplyr::arrange(max) %>% dplyr::mutate( ecdf_end = utils::tail(max, 1) diff --git a/R/maraca.R b/R/maraca.R index 05d4ea6..101ae4f 100644 --- a/R/maraca.R +++ b/R/maraca.R @@ -123,7 +123,7 @@ maraca <- function( empty.ok = FALSE) if (!(length(fixed_followup_days) %in% - c(1, length(step_outcomes[step_types == "tte"])))) { + c(1, length(step_outcomes[step_types == "tte"])))) { stop(paste("fixed_followup_days needs to be either a single value or", "a vector with one value for each tte outcome")) } @@ -449,9 +449,8 @@ plot_maraca <- function( for (outcome in step_outcomes[which_tte]) { plot <- plot + - ggplot2::geom_step( - data = plotdata[plotdata$outcome == outcome, ], - aes(x = x, y = y, color = arm)) + ggplot2::geom_step(data = plotdata[plotdata$outcome == outcome, ], + aes(x = x, y = y, color = arm)) } if (length(which_binary) > 0) { From 6c3eb883f105a9734b7674daf213917e4037aa8f Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Thu, 29 Feb 2024 08:54:01 +0000 Subject: [PATCH 12/32] Fix bug when treatment group with 0 events --- R/internal.R | 96 +++++++++++++++++++++++++++--------- R/maraca.R | 2 +- tests/testthat/test_maraca.R | 4 +- 3 files changed, 75 insertions(+), 27 deletions(-) diff --git a/R/internal.R b/R/internal.R index 09a1f72..52e3b68 100644 --- a/R/internal.R +++ b/R/internal.R @@ -92,9 +92,10 @@ dplyr::filter(!is.na(value)) %>% dplyr::group_by(outcome, arm) %>% dplyr::summarise(n = n(), proportion = n / dim(hce_dat)[[1]] * 100) %>% + dplyr::ungroup() %>% dplyr::mutate("arm" = gsub(" ", "_", tolower(arm))) %>% - tidyr::pivot_wider(names_from = arm, values_from = c(n, proportion)) %>% - dplyr::ungroup() + tidyr::pivot_wider(names_from = arm, values_from = c(n, proportion), + values_fill = 0) meta_missing <- hce_dat %>% dplyr::group_by(outcome) %>% @@ -118,60 +119,106 @@ `%>%` <- dplyr::`%>%` n <- dplyr::n + # Calculate the number of unique step outcomes num_step_outcomes <- length(step_outcomes) - tte_outcomes <- step_outcomes[which(step_types == "tte")] - binary_outcomes <- step_outcomes[which(step_types == "binary")] - + # Vectorize fixed follow-up days if there is only one value provided + # For binary values, follow-up time is always 2 (to create a jump + # in the middle of the step at 1) if (length(fixed_followup_days) == 1) { fixed_followup_days <- sapply(step_types, function(type) { ifelse(type == "binary", 2, fixed_followup_days) }, USE.NAMES = FALSE) } + # Every step outcome will be plotted over an x-axis range from 0 + # to the fixed_follow_up days associated with the outcome + + # Initialize the cumulative time-to-event (t_cdf) with a maximum + # value that is higher than the sum of all x-axis range parts + # The reason for this is that when fitting the individual step + # parts, we will go chronological and want to make sure that all + # steps at a later stage have been initialized with a later time hce_dat$t_cdf <- sum(fixed_followup_days) + 2 * max(fixed_followup_days) + # Initialize step_values column recording the size of the step (percentage + # of number t risk) at each time point hce_dat$step_values <- 0 + # Iterate over each step outcome for (i in seq_len(num_step_outcomes)) { + # Filter rows by outcome idx <- hce_dat$outcome == step_outcomes[[i]] + # By default the value recorded in the data is the actual time of the step. + # Since we add concatenate different step functions, we need to update the + # x-axis to reflect the time of the step plus the cumulation of all the + # x-axis ranges of the previous step functions add_previous_end <- ifelse(i == 1, 0, sum(fixed_followup_days[1:(i - 1)])) hce_dat[idx, ]$t_cdf <- hce_dat[idx, ]$value + add_previous_end + # Iterate over each treatment arm for (arm in arm_levels) { + # Filter rows by outcome and arm idx <- hce_dat$outcome == step_outcomes[[i]] & hce_dat$arm == arm + # Fit the ECDF to the above updated x-axis range for the + # cumulative time-to-event by treatment arm hce_dat[idx, ]$step_values <- 100 * - stats::ecdf(hce_dat[hce_dat$arm == arm, ]$t_cdf)(hce_dat[idx, ]$t_cdf) + stats::ecdf(hce_dat[hce_dat$arm == arm, + ]$t_cdf)(hce_dat[idx, ]$t_cdf) } } - hce_ecdf <- hce_dat[hce_dat$outcome %in% tte_outcomes, - c("outcome", "arm", "value", "step_values", - "t_cdf")] - - if (length(binary_outcomes) != 0) { - hce_ecdf_binary <- hce_dat[hce_dat$outcome %in% binary_outcomes, ] - hce_ecdf_binary <- hce_ecdf_binary %>% - dplyr::group_by(outcome, arm) %>% - dplyr::summarize(t_cdf = sum(value), - step_values = unique(step_values), - value = 1) %>% - dplyr::ungroup() - - hce_ecdf <- rbind(hce_ecdf, - hce_ecdf_binary[, c("outcome", "arm", "value", - "step_values", "t_cdf")]) - } + hce_ecdf <- hce_dat %>% + dplyr::filter(outcome %in% step_outcomes) %>% + unique() + + # Double-check that all combinations of treatment and outcome have + # been included (not the case if one combination has no patients) + poss_comb <- expand.grid("outcome" = step_outcomes, + "arm" = arm_levels) + missing_row <- dplyr::anti_join(poss_comb, + hce_ecdf[, c("outcome", "arm")]) + + # If there are missing rows, fill them in + if (nrow(missing_row) > 0) { + + for (i in 1:num_step_outcomes) { + # Check if current step outcome is missing + if (step_outcomes[[i]] %in% missing_row$outcome) { + tmp <- missing_row[missing_row$outcome == step_outcomes[[i]], ] + # Determine step values based on previous step if available + if (i == 1) { + step_values <- 0 + } else { + tmp2 <- hce_ecdf[hce_ecdf$outcome == step_outcomes[i - 1] & + hce_ecdf$arm == tmp$arm, ] + step_values <- max(tmp2$step_values) + } + # Fetch existing data for the same outcome but different arm + tmp3 <- hce_ecdf[hce_ecdf$outcome == step_outcomes[[i]] & + hce_ecdf$arm != tmp$arm, ] + # Append missing row to the main data frame + hce_ecdf <- + rbind(hce_ecdf, + data.frame(outcome = step_outcomes[[i]], + arm = tmp$arm, + t_cdf = mean(tmp3$t_cdf), + step_values = step_values, + value = 0)) + } + } + } + # Order the data frame by step values hce_ecdf <- hce_ecdf[order(hce_ecdf$step_values), ] + # Add names of set outcomes and associated type (tte or binary) to data endpoint <- data.frame("outcome" = step_outcomes, "type" = step_types) - hce_ecdf <- dplyr::left_join(hce_ecdf, endpoint, by = "outcome") @@ -186,6 +233,7 @@ meta[meta$outcome == entry, ]$proportion } + # Summarize maximum step values, type, and sum of events hce_ecdf_meta <- hce_ecdf %>% dplyr::group_by(arm, outcome) %>% dplyr::summarise(max = max(step_values, na.rm = TRUE), diff --git a/R/maraca.R b/R/maraca.R index 101ae4f..af959d4 100644 --- a/R/maraca.R +++ b/R/maraca.R @@ -105,7 +105,7 @@ maraca <- function( permutation.of = c("outcome", "arm", "value") ) - checkmate::assert_integerish(fixed_followup_days) + checkmate::assert_numeric(fixed_followup_days) checkmate::assert_character(step_types) checkmate::assert_subset(step_types, diff --git a/tests/testthat/test_maraca.R b/tests/testthat/test_maraca.R index 73996ec..8e4cb0d 100644 --- a/tests/testthat/test_maraca.R +++ b/tests/testthat/test_maraca.R @@ -311,9 +311,9 @@ test_that("wrongParameters", { expect_error( maraca(data, step_outcomes, last_outcome, arm_levels, column_names, - fixed_followup_days = 12.3 + fixed_followup_days = "12.3" ), - regexp = "Must be of type 'integerish'" + regexp = "Must be of type 'numeric', not 'character'." ) expect_error( maraca(data, step_outcomes, last_outcome, arm_levels, From 7d32b94b5c744481c2346258ff3adc2e583aaa58 Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Thu, 29 Feb 2024 09:42:04 +0000 Subject: [PATCH 13/32] Fix lintr error --- R/internal.R | 74 ++++++++++++++++++++++++++-------------------------- 1 file changed, 37 insertions(+), 37 deletions(-) diff --git a/R/internal.R b/R/internal.R index 52e3b68..32b9048 100644 --- a/R/internal.R +++ b/R/internal.R @@ -166,52 +166,52 @@ hce_dat[idx, ]$step_values <- 100 * stats::ecdf(hce_dat[hce_dat$arm == arm, - ]$t_cdf)(hce_dat[idx, ]$t_cdf) + ]$t_cdf)(hce_dat[idx, ]$t_cdf) } } hce_ecdf <- hce_dat %>% - dplyr::filter(outcome %in% step_outcomes) %>% - unique() - - # Double-check that all combinations of treatment and outcome have - # been included (not the case if one combination has no patients) - poss_comb <- expand.grid("outcome" = step_outcomes, - "arm" = arm_levels) - missing_row <- dplyr::anti_join(poss_comb, - hce_ecdf[, c("outcome", "arm")]) - - # If there are missing rows, fill them in - if (nrow(missing_row) > 0) { - - for (i in 1:num_step_outcomes) { - # Check if current step outcome is missing - if (step_outcomes[[i]] %in% missing_row$outcome) { - tmp <- missing_row[missing_row$outcome == step_outcomes[[i]], ] - # Determine step values based on previous step if available - if (i == 1) { - step_values <- 0 - } else { - tmp2 <- hce_ecdf[hce_ecdf$outcome == step_outcomes[i - 1] & - hce_ecdf$arm == tmp$arm, ] - step_values <- max(tmp2$step_values) - } - # Fetch existing data for the same outcome but different arm - tmp3 <- hce_ecdf[hce_ecdf$outcome == step_outcomes[[i]] & - hce_ecdf$arm != tmp$arm, ] - # Append missing row to the main data frame - hce_ecdf <- - rbind(hce_ecdf, - data.frame(outcome = step_outcomes[[i]], - arm = tmp$arm, - t_cdf = mean(tmp3$t_cdf), - step_values = step_values, - value = 0)) + dplyr::filter(outcome %in% step_outcomes) %>% + unique() + + # Double-check that all combinations of treatment and outcome have + # been included (not the case if one combination has no patients) + poss_comb <- expand.grid("outcome" = step_outcomes, + "arm" = arm_levels) + missing_row <- dplyr::anti_join(poss_comb, + hce_ecdf[, c("outcome", "arm")]) + + # If there are missing rows, fill them in + if (nrow(missing_row) > 0) { + + for (i in 1:num_step_outcomes) { + # Check if current step outcome is missing + if (step_outcomes[[i]] %in% missing_row$outcome) { + tmp <- missing_row[missing_row$outcome == step_outcomes[[i]], ] + # Determine step values based on previous step if available + if (i == 1) { + step_values <- 0 + } else { + tmp2 <- hce_ecdf[hce_ecdf$outcome == step_outcomes[i - 1] & + hce_ecdf$arm == tmp$arm, ] + step_values <- max(tmp2$step_values) } + # Fetch existing data for the same outcome but different arm + tmp3 <- hce_ecdf[hce_ecdf$outcome == step_outcomes[[i]] & + hce_ecdf$arm != tmp$arm, ] + # Append missing row to the main data frame + hce_ecdf <- + rbind(hce_ecdf, + data.frame(outcome = step_outcomes[[i]], + arm = tmp$arm, + t_cdf = mean(tmp3$t_cdf), + step_values = step_values, + value = 0)) } } + } # Order the data frame by step values hce_ecdf <- hce_ecdf[order(hce_ecdf$step_values), ] From 0cfc9314806d7296b0c6377e95b6c6f011019c58 Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Thu, 29 Feb 2024 10:06:40 +0000 Subject: [PATCH 14/32] Fix lintr error --- R/internal.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/internal.R b/R/internal.R index 32b9048..4277e93 100644 --- a/R/internal.R +++ b/R/internal.R @@ -195,12 +195,12 @@ step_values <- 0 } else { tmp2 <- hce_ecdf[hce_ecdf$outcome == step_outcomes[i - 1] & - hce_ecdf$arm == tmp$arm, ] + hce_ecdf$arm == tmp$arm, ] step_values <- max(tmp2$step_values) } # Fetch existing data for the same outcome but different arm tmp3 <- hce_ecdf[hce_ecdf$outcome == step_outcomes[[i]] & - hce_ecdf$arm != tmp$arm, ] + hce_ecdf$arm != tmp$arm, ] # Append missing row to the main data frame hce_ecdf <- rbind(hce_ecdf, From 5ae57752ef660e3804a94f17362cb0b94e8ef326 Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Fri, 1 Mar 2024 14:16:16 +0000 Subject: [PATCH 15/32] Update validation function to new endpoint types --- R/aaa.R | 1 + R/internal.R | 67 +++++++++++++++++++++++++++++++++++- R/maraca.R | 7 +++- tests/testthat/test_maraca.R | 3 +- 4 files changed, 75 insertions(+), 3 deletions(-) diff --git a/R/aaa.R b/R/aaa.R index 833db8a..9597d77 100644 --- a/R/aaa.R +++ b/R/aaa.R @@ -52,3 +52,4 @@ utils::globalVariables("TOTAL") utils::globalVariables("WIN_A") utils::globalVariables("WIN_P") utils::globalVariables("TIE_A") +utils::globalVariables("linetype") diff --git a/R/internal.R b/R/internal.R index 4277e93..23f63a6 100644 --- a/R/internal.R +++ b/R/internal.R @@ -692,10 +692,75 @@ return(tte_data) } +.create_validation_binary_step <- function(layers, x, arms) { + + binary_layers <- which(layers == "GeomSegment") + + if (length(binary_layers) != 0) { + binary_step_data <- + do.call("rbind", + lapply(binary_layers, + function(i) { + dat <- ggplot2::layer_data(plot = x, + i = i)[, c("x", "y", + "yend", + "group", + "linetype")] + return(dat) + })) + + binary_step_data <- binary_step_data %>% + dplyr::filter(linetype == 2) %>% + dplyr::mutate(proportion = yend - y) %>% + dplyr::select(x, y, proportion, group) + + binary_step_data$group <- factor(binary_step_data$group, labels = arms) + + } else { + binary_step_data <- NULL + } + + return(binary_step_data) +} + +.create_validation_binary_last <- function(layers, x, arms) { + + polygon_layers <- which(layers == "GeomPolygon") + point_layers <- which(layers == "GeomPoint") + + if (length(polygon_layers) == 1 && + length(point_layers) == 1) { + + point_data <- ggplot2::layer_data(x, point_layers) %>% + dplyr::select(x, y, group) + + polygon_data <- unique(ggplot2::layer_data(x, polygon_layers)) + polygon_data <- polygon_data %>% + dplyr::filter(y %in% point_data$y) %>% + dplyr::group_by(group) %>% + dplyr::summarise("lower_se" = base::min(x, na.rm = TRUE), + "upper_se" = base::max(x, na.rm = TRUE)) + + binary_data <- dplyr::left_join(point_data, polygon_data, + by = "group") + binary_data$se <- binary_data$x - binary_data$lower_se + binary_data$group <- factor(binary_data$group, labels = arms) + + } else { + + binary_data <- NULL + + } + + return(binary_data) +} + + + .create_validation_scatter <- function(layers, x, arms) { scatter_data <- do.call("rbind", lapply(which(layers == "GeomPoint"), ggplot2::layer_data, plot = x)) - if (!is.null(scatter_data)) { + if (!is.null(scatter_data) && nrow(scatter_data) > 2) { scatter_data <- scatter_data[, c("group", "x", "y")] scatter_data$group <- factor(scatter_data$group, labels = arms) } diff --git a/R/maraca.R b/R/maraca.R index af959d4..3c81970 100644 --- a/R/maraca.R +++ b/R/maraca.R @@ -485,7 +485,8 @@ plot_maraca <- function( ) + ggplot2::geom_segment( data = tmp2, - aes(x = x, y = y, xend = x, yend = yend), + aes(x = x, y = y, xend = x, yend = yend, + group = arm), color = "darkgrey", linetype = 2 ) } @@ -662,6 +663,8 @@ validate_maraca_plot <- function(x, ...) { arms <- levels(pb$plot$data[, pb$plot$labels$colour]) tte_data <- .create_validation_tte(layers, x, arms) + binary_step_data <- .create_validation_binary_step(layers, x, arms) + binary_last_data <- .create_validation_binary_last(layers, x, arms) scatter_data <- .create_validation_scatter(layers, x, arms) boxstat_data <- .create_validation_box(layers, x, arms) violin_data <- .create_validation_violin(layers, x, arms) @@ -685,6 +688,8 @@ validate_maraca_plot <- function(x, ...) { plot_type = plot_type, proportions = proportions, tte_data = tte_data, + binary_step_data = binary_step_data, + binary_last_data = binary_last_data, scatter_data = scatter_data, boxstat_data = boxstat_data, violin_data = violin_data, diff --git a/tests/testthat/test_maraca.R b/tests/testthat/test_maraca.R index 8e4cb0d..7bd314a 100644 --- a/tests/testthat/test_maraca.R +++ b/tests/testthat/test_maraca.R @@ -940,7 +940,8 @@ test_that("validationFunction", { expect_type(val_res_scatter, "list") expected_names <- c("plot_type", "proportions", - "tte_data", "scatter_data", + "tte_data", "binary_step_data", + "binary_last_data", "scatter_data", "boxstat_data", "violin_data", "wo_stats") expect_named(val_res_def, expected_names, ignore.order = TRUE) From 13964cd8e0fa564dfea1bd1de5ef8e4b2030aebc Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Mon, 4 Mar 2024 09:34:07 +0000 Subject: [PATCH 16/32] Fix lintr error --- R/internal.R | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/R/internal.R b/R/internal.R index 23f63a6..72dd206 100644 --- a/R/internal.R +++ b/R/internal.R @@ -728,29 +728,29 @@ polygon_layers <- which(layers == "GeomPolygon") point_layers <- which(layers == "GeomPoint") - if (length(polygon_layers) == 1 && - length(point_layers) == 1) { + if (length(polygon_layers) == 1 && + length(point_layers) == 1) { - point_data <- ggplot2::layer_data(x, point_layers) %>% - dplyr::select(x, y, group) + point_data <- ggplot2::layer_data(x, point_layers) %>% + dplyr::select(x, y, group) - polygon_data <- unique(ggplot2::layer_data(x, polygon_layers)) - polygon_data <- polygon_data %>% - dplyr::filter(y %in% point_data$y) %>% - dplyr::group_by(group) %>% - dplyr::summarise("lower_se" = base::min(x, na.rm = TRUE), - "upper_se" = base::max(x, na.rm = TRUE)) + polygon_data <- unique(ggplot2::layer_data(x, polygon_layers)) + polygon_data <- polygon_data %>% + dplyr::filter(y %in% point_data$y) %>% + dplyr::group_by(group) %>% + dplyr::summarise("lower_se" = base::min(x, na.rm = TRUE), + "upper_se" = base::max(x, na.rm = TRUE)) - binary_data <- dplyr::left_join(point_data, polygon_data, - by = "group") - binary_data$se <- binary_data$x - binary_data$lower_se - binary_data$group <- factor(binary_data$group, labels = arms) + binary_data <- dplyr::left_join(point_data, polygon_data, + by = "group") + binary_data$se <- binary_data$x - binary_data$lower_se + binary_data$group <- factor(binary_data$group, labels = arms) - } else { + } else { - binary_data <- NULL + binary_data <- NULL - } + } return(binary_data) } From f5b77f5e3e2fc50c74344167835b56dcfe2887c7 Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Mon, 4 Mar 2024 10:45:04 +0000 Subject: [PATCH 17/32] Fix bug with default vline_type --- R/maraca.R | 21 +++++++++++++++------ man/maraca.Rd | 2 +- man/plot.hce.Rd | 8 ++++++-- man/plot.maraca.Rd | 7 +++++-- man/plot_maraca.Rd | 11 +++++++---- 5 files changed, 34 insertions(+), 15 deletions(-) diff --git a/R/maraca.R b/R/maraca.R index 3c81970..2b6fffa 100644 --- a/R/maraca.R +++ b/R/maraca.R @@ -269,8 +269,11 @@ print.maraca <- function(x, ...) { #' The accepted values are the same that ggplot2::scale_x_continuous #' @param density_plot_type which type of plot to display in the continuous #' part of the plot. Options are "default", "violin", "box", "scatter". -#' @param vline_type what the vertical lines in the continuous part of the plot -#' should highlight. Options are "median", "mean", "none". +#' @param vline_type what the vertical dashed line should represent. Accepts +#' "median" (only for continuous last endpoint), "mean", "none" and +#' NULL (default). By default (vline_type = NULL), vline_type will be +#' set to "median" for a continuous last endpoint and to "mean" for +#' a binary last endpoint. #' @param theme Choose theme to style the plot. The default theme is "maraca". #' Options are "maraca", "maraca_old", "color1", "color2" and none". #' For more details, check the vignette called @@ -709,7 +712,10 @@ validate_maraca_plot <- function(x, ...) { #' @param density_plot_type The type of plot to use to represent the density. #' Accepts "default", "violin", "box" and "scatter". #' @param vline_type what the vertical dashed line should represent. Accepts -#' "median", "mean", "none". +#' "median" (only for continuous last endpoint), "mean", "none" and +#' NULL (default). By default (vline_type = NULL), vline_type will be +#' set to "median" for a continuous last endpoint and to "mean" for +#' a binary last endpoint. #' @param theme Choose theme to style the plot. The default theme is "maraca". #' Options are "maraca", "maraca_old", "color1", "color2" and none". #' For more details, check the vignette called @@ -733,7 +739,7 @@ validate_maraca_plot <- function(x, ...) { plot.maraca <- function( x, continuous_grid_spacing_x = 10, trans = "identity", density_plot_type = "default", - vline_type = "median", + vline_type = NULL, theme = "maraca", ...) { plot_maraca(x, continuous_grid_spacing_x, @@ -760,7 +766,10 @@ plot.maraca <- function( #' @param density_plot_type The type of plot to use to represent the density. #' Accepts "default", "violin", "box" and "scatter". #' @param vline_type what the vertical dashed line should represent. Accepts -#' "median", "mean", "none". +#' "median" (only for continuous last endpoint), "mean", "none" and +#' NULL (default). By default (vline_type = NULL), vline_type will be +#' set to "median" for a continuous last endpoint and to "mean" for +#' a binary last endpoint. #' @param fixed_followup_days Not needed if HCE object contains information #' on fixed follow-up days in the study #' (column PADY or TTEfixed, @@ -803,7 +812,7 @@ plot.hce <- function(x, last_outcome = "C", continuous_grid_spacing_x = 10, trans = "identity", density_plot_type = "default", - vline_type = "median", + vline_type = NULL, fixed_followup_days = NULL, compute_win_odds = FALSE, step_types = "tte", diff --git a/man/maraca.Rd b/man/maraca.Rd index 4e16b3c..20e698d 100644 --- a/man/maraca.Rd +++ b/man/maraca.Rd @@ -13,7 +13,7 @@ maraca( last_outcome, arm_levels = c(active = "active", control = "control"), column_names = c(outcome = "outcome", arm = "arm", value = "value"), - fixed_followup_days, + fixed_followup_days = NULL, compute_win_odds = FALSE, step_types = "tte", last_type = "continuous", diff --git a/man/plot.hce.Rd b/man/plot.hce.Rd index afab672..6564d63 100644 --- a/man/plot.hce.Rd +++ b/man/plot.hce.Rd @@ -11,9 +11,10 @@ continuous_grid_spacing_x = 10, trans = "identity", density_plot_type = "default", - vline_type = "median", + vline_type = NULL, fixed_followup_days = NULL, compute_win_odds = FALSE, + step_types = "tte", last_type = "continuous", theme = "maraca", continuous_outcome = lifecycle::deprecated(), @@ -44,7 +45,10 @@ The accepted values are the same that ggplot2::scale_x_continuous} Accepts "default", "violin", "box" and "scatter".} \item{vline_type}{what the vertical dashed line should represent. Accepts -"median", "mean", "none".} +"median" (only for continuous last endpoint), "mean", "none" and +NULL (default). By default (vline_type = NULL), vline_type will be +set to "median" for a continuous last endpoint and to "mean" for +a binary last endpoint.} \item{fixed_followup_days}{Not needed if HCE object contains information on fixed follow-up days in the study diff --git a/man/plot.maraca.Rd b/man/plot.maraca.Rd index 6dfc482..a05c92d 100644 --- a/man/plot.maraca.Rd +++ b/man/plot.maraca.Rd @@ -9,7 +9,7 @@ continuous_grid_spacing_x = 10, trans = "identity", density_plot_type = "default", - vline_type = "median", + vline_type = NULL, theme = "maraca", ... ) @@ -27,7 +27,10 @@ The accepted values are the same that ggplot2::scale_x_continuous} Accepts "default", "violin", "box" and "scatter".} \item{vline_type}{what the vertical dashed line should represent. Accepts -"median", "mean", "none".} +"median" (only for continuous last endpoint), "mean", "none" and +NULL (default). By default (vline_type = NULL), vline_type will be +set to "median" for a continuous last endpoint and to "mean" for +a binary last endpoint.} \item{theme}{Choose theme to style the plot. The default theme is "maraca". Options are "maraca", "maraca_old", "color1", "color2" and none". diff --git a/man/plot_maraca.Rd b/man/plot_maraca.Rd index 9892304..d48954c 100644 --- a/man/plot_maraca.Rd +++ b/man/plot_maraca.Rd @@ -6,10 +6,10 @@ \usage{ plot_maraca( obj, - continuous_grid_spacing_x = 10, + continuous_grid_spacing_x = NULL, trans = "identity", density_plot_type = "default", - vline_type = "median", + vline_type = NULL, theme = "maraca" ) } @@ -25,8 +25,11 @@ The accepted values are the same that ggplot2::scale_x_continuous} \item{density_plot_type}{which type of plot to display in the continuous part of the plot. Options are "default", "violin", "box", "scatter".} -\item{vline_type}{what the vertical lines in the continuous part of the plot -should highlight. Options are "median", "mean", "none".} +\item{vline_type}{what the vertical dashed line should represent. Accepts +"median" (only for continuous last endpoint), "mean", "none" and +NULL (default). By default (vline_type = NULL), vline_type will be +set to "median" for a continuous last endpoint and to "mean" for +a binary last endpoint.} \item{theme}{Choose theme to style the plot. The default theme is "maraca". Options are "maraca", "maraca_old", "color1", "color2" and none". From b1b7db85641980589027ebf9a89281213a0608d0 Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Mon, 4 Mar 2024 21:55:46 +0000 Subject: [PATCH 18/32] Update binary endpoint standard error calculation --- R/internal.R | 44 ++++++++++++++++++++++++++++++++++---------- R/maraca.R | 4 ++-- 2 files changed, 36 insertions(+), 12 deletions(-) diff --git a/R/internal.R b/R/internal.R index 72dd206..61c8afc 100644 --- a/R/internal.R +++ b/R/internal.R @@ -181,7 +181,8 @@ poss_comb <- expand.grid("outcome" = step_outcomes, "arm" = arm_levels) missing_row <- dplyr::anti_join(poss_comb, - hce_ecdf[, c("outcome", "arm")]) + hce_ecdf[, c("outcome", "arm")], + by = c("outcome", "arm")) # If there are missing rows, fill them in if (nrow(missing_row) > 0) { @@ -304,12 +305,16 @@ `%>%` <- dplyr::`%>%` n <- dplyr::n + # Extract the active and control arm treatment names actv <- unname(arm_levels["active"]) ctrl <- unname(arm_levels["control"]) + # Retrieve hce data for the last outcome as well as the x-axis position + # to start from binary_data <- hce_dat[hce_dat$outcome == last_outcome, ] start_binary_endpoint <- meta[meta$outcome == last_outcome, ]$startx + # Get the y-values that the step outcomes ended on for both arms actv_y <- ecdf_mod$meta[ ecdf_mod$meta$arm == actv & ecdf_mod$meta$outcome == utils::tail(step_outcomes, 1), @@ -319,30 +324,41 @@ ecdf_mod$meta$outcome == utils::tail(step_outcomes, 1), ]$ecdf_end + # Calculate difference of proportion statistics for each arm (estimate + # and lower confidence interval boundary) using prop.test + # Note: we are using percentages rather than proportions (*100) binary_meta <- binary_data %>% dplyr::group_by(arm) %>% dplyr::summarise(n = n(), - average = base::mean(value, na.rm = TRUE), - conf_int = 1.96 * sqrt((average * (1 - average)) / n)) %>% + x = base::sum(value, na.rm = TRUE), + average = 100 * + as.numeric(stats::prop.test(x, n)$estimate), + se = abs(average - (100 * + as.numeric(stats::prop.test(x, n)$conf.int)[1]))) %>% dplyr::ungroup() - x_radius <- (100 - start_binary_endpoint) * min(binary_meta$conf_int) - y_height <- min(c(0.4 * abs(actv_y - ctrl_y), 0.8 * x_radius)) + # To create ellipsis shape and avoid overlapping between both of them, + # set the height to 80% of the SE (minimum scaled in x-axis or y-axis range) + width <- (100 - start_binary_endpoint) * min(binary_meta$se) / 100 + y_range <- (max(actv_y, ctrl_y) + 10) * min(binary_meta$se) / 100 + y_height <- min(c(0.4 * abs(actv_y - ctrl_y), 0.8 * min(width, y_range))) + # Create ellipsis centered around proportion estimate (x0) as well as + # y-value that the step outcomes ended on for each arm, + # with the standard error as width and the height as calculated above actv_point <- .create_ellipsis_points(unlist(binary_meta[binary_meta$arm == actv, "average"]), actv_y, unlist(binary_meta[binary_meta$arm == actv, - "conf_int"]), + "se"]), y_height) - ctrl_point <- .create_ellipsis_points(unlist(binary_meta[binary_meta$arm == ctrl, "average"]), ctrl_y, unlist(binary_meta[binary_meta$arm == ctrl, - "conf_int"]), + "se"]), y_height) binary_data <- rbind(data.frame("outcome" = last_outcome, @@ -357,14 +373,14 @@ binary_data$x, start_binary_endpoint, 0, - 1 + 100 ) binary_meta$average <- .to_rangeab( binary_meta$average, start_binary_endpoint, 0, - 1 + 100 ) binary_meta$y <- 0 @@ -377,13 +393,21 @@ )) } +# Create ellipsis centered around point (x0,y0), +# with range (x0+a,y0+b) .create_ellipsis_points <- function(x0, y0, a, b) { + # First create equally spaced points on a unit + # circle (with x-coordinates cos_p and y-coordinates + # sin_p), ranging from -1 to 1 points <- seq(0, 2 * pi, length.out = 361) cos_p <- cos(points) sin_p <- sin(points) + # Change the shape by changing the x-axis range (to 2*a) + # and y axis range (to 2*b) x_tmp <- abs(cos_p) * a * sign(cos_p) y_tmp <- abs(sin_p) * b * sign(sin_p) + # Move x and y values to be centered around x0 and y0 edata <- data.frame(x = x0 + x_tmp, y = y0 + y_tmp) return(edata) diff --git a/R/maraca.R b/R/maraca.R index 2b6fffa..71b00ef 100644 --- a/R/maraca.R +++ b/R/maraca.R @@ -412,8 +412,8 @@ plot_maraca <- function( } else if (last_type == "binary") { - minor_grid <- seq(0, 1, continuous_grid_spacing_x) - range <- c(0, 1) + minor_grid <- seq(0, 100, continuous_grid_spacing_x) + range <- c(0, 100) } From 14fc721e783b32d353022cf1e82d18bd8d2c119d Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Mon, 4 Mar 2024 23:08:32 +0000 Subject: [PATCH 19/32] Add forest plot calculation --- R/aaa.R | 3 +++ R/internal.R | 48 +++++++++++++++++++++++++++++++++--- R/maraca.R | 10 +++++--- tests/testthat/test_maraca.R | 3 ++- 4 files changed, 56 insertions(+), 8 deletions(-) diff --git a/R/aaa.R b/R/aaa.R index 9597d77..9377b05 100644 --- a/R/aaa.R +++ b/R/aaa.R @@ -53,3 +53,6 @@ utils::globalVariables("WIN_A") utils::globalVariables("WIN_P") utils::globalVariables("TIE_A") utils::globalVariables("linetype") +utils::globalVariables("wins") +utils::globalVariables("losses") +utils::globalVariables("ties") diff --git a/R/internal.R b/R/internal.R index 61c8afc..a77716a 100644 --- a/R/internal.R +++ b/R/internal.R @@ -12,7 +12,9 @@ } # Computes the win odds from the internal data. -.compute_win_odds <- function(hce_dat, arm_levels) { +.compute_win_odds <- function(hce_dat, arm_levels, + step_outcomes, last_outcome) { + hce_dat <- base::as.data.frame(hce_dat) hce_dat <- .with_ordered_column(hce_dat) fit <- hce::calcWO(x = hce_dat, AVAL = "ordered", @@ -27,8 +29,45 @@ ref = unname(arm_levels["control"]), GROUP = "outcome") + endpoints <- c(step_outcomes, last_outcome) + hce_dat <- hce_dat %>% + dplyr::mutate_at(dplyr::vars(outcome), factor, levels = c(endpoints, "X")) + + calcs_lst <- lapply(seq_along(endpoints), function(x) { + idx <- !(hce_dat$outcome %in% endpoints[1:x]) + hce_dat[idx, "outcome"] <- "X" + hce_dat[idx, "ordered"] <- 1000000 + wins <- hce::calcWINS(hce_dat, AVAL = "ordered", TRTP = "arm", + ref = unname(arm_levels["control"]), + GROUP = "outcome") + wo <- hce::summaryWO(hce_dat, AVAL = "ordered", TRTP = "arm", + ref = unname(arm_levels["control"]), + GROUP = "outcome") + list("wins" = wins, "wo" = wo) + }) + + wins_forest <- do.call("rbind", lapply(calcs_lst, function(c_lst) { + wins <- c_lst$wins + nm <- c("value", "LCL", "UCL", "p value") + rbind(data.frame(setNames(wins$WO, nm), "method" = "win odds"), + data.frame(setNames(wins$WR1, nm), "method" = "win ratio")) + })) + + wo_bar <- do.call("rbind", lapply(seq_along(calcs_lst), function(i) { + wo <- head(calcs_lst[[i]]$wo$summary, 1) + wo$outcome <- endpoints[i] + wo %>% + dplyr::rename(dplyr::all_of(c(wins = "WIN", losses = "LOSS", + ties = "TIE"))) %>% + tidyr::pivot_longer(cols = c(wins, losses, ties)) %>% + dplyr::mutate_at(dplyr::vars(name), factor, + levels = c("wins", "losses", "ties")) + })) + return(list("win_odds" = win_odds, - "win_odds_outcome" = win_odds_outcome)) + "win_odds_outcome" = win_odds_outcome, + "wins_forest" = wins_forest, + "wo_bar" = wo_bar)) } @@ -333,8 +372,9 @@ x = base::sum(value, na.rm = TRUE), average = 100 * as.numeric(stats::prop.test(x, n)$estimate), - se = abs(average - (100 * - as.numeric(stats::prop.test(x, n)$conf.int)[1]))) %>% + se = abs(average - + (100 * as.numeric( + stats::prop.test(x, n)$conf.int)[1]))) %>% dplyr::ungroup() # To create ellipsis shape and avoid overlapping between both of them, diff --git a/R/maraca.R b/R/maraca.R index 71b00ef..5c3423d 100644 --- a/R/maraca.R +++ b/R/maraca.R @@ -196,9 +196,11 @@ maraca <- function( data_last_outcome <- NULL } - win_odds <- list("win_odds" = NULL, "win_odds_outcome" = NULL) + win_odds <- list("win_odds" = NULL, "win_odds_outcome" = NULL, + "wins_forest" = NULL, "wo_bar" = NULL) if (compute_win_odds) { - win_odds <- .compute_win_odds(hce_dat, arm_levels) + win_odds <- .compute_win_odds(hce_dat, arm_levels, + step_outcomes, last_outcome) } return( @@ -215,7 +217,9 @@ maraca <- function( ecdf_by_outcome = ecdf_by_outcome, data_last_outcome = data_last_outcome, win_odds = win_odds[["win_odds"]], - win_odds_outcome = win_odds[["win_odds_outcome"]] + win_odds_outcome = win_odds[["win_odds_outcome"]], + wins_forest = win_odds[["wins_forest"]], + wo_bar = win_odds[["wo_bar"]] ), class = c("maraca") ) diff --git a/tests/testthat/test_maraca.R b/tests/testthat/test_maraca.R index 7bd314a..b6900d0 100644 --- a/tests/testthat/test_maraca.R +++ b/tests/testthat/test_maraca.R @@ -516,7 +516,8 @@ test_that("winOddsData", { arm_levels, column_names = column_names ) - win_odds_list <- .compute_win_odds(data, arm_levels) + win_odds_list <- .compute_win_odds(data, arm_levels, + step_outcomes, last_outcome) win_odds <- win_odds_list[["win_odds"]] expect_equal(class(win_odds), "numeric") From 94c6d7a3b8e35213aecfdc0fe84e3c6b07400b57 Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Tue, 5 Mar 2024 10:44:18 +0000 Subject: [PATCH 20/32] Add cumulative plot --- DESCRIPTION | 5 +- NAMESPACE | 4 + R/aaa.R | 6 + R/internal.R | 340 +--------------------------------- R/internal_validation.R | 136 ++++++++++++++ R/internal_winOdds.R | 261 ++++++++++++++++++++++++++ R/themes.R | 1 - R/winOddsPlots.R | 141 ++++++++++++++ man/cumulative_plot.Rd | 19 ++ man/cumulative_plot.hce.Rd | 71 +++++++ man/cumulative_plot.maraca.Rd | 54 ++++++ 11 files changed, 697 insertions(+), 341 deletions(-) create mode 100644 R/internal_validation.R create mode 100644 R/internal_winOdds.R create mode 100644 man/cumulative_plot.Rd create mode 100644 man/cumulative_plot.hce.Rd create mode 100644 man/cumulative_plot.maraca.Rd diff --git a/DESCRIPTION b/DESCRIPTION index ad7d4c3..e296396 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -20,12 +20,13 @@ Encoding: UTF-8 LazyData: true Depends: R (>= 3.5), - hce (>= 0.5) + hce (>= 0.5), + ggplot2 (>= 3.3) Imports: dplyr (>= 1.0), tidyr (>= 1.2), - ggplot2 (>= 3.3), checkmate (>= 2.1), + patchwork(>= 1.0.0), lifecycle RoxygenNote: 7.2.3 Suggests: diff --git a/NAMESPACE b/NAMESPACE index a7aaf9c..e44ad23 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,10 +3,14 @@ S3method(component_plot,default) S3method(component_plot,hce) S3method(component_plot,maraca) +S3method(cumulative_plot,default) +S3method(cumulative_plot,hce) +S3method(cumulative_plot,maraca) S3method(plot,hce) S3method(plot,maraca) S3method(print,maraca) export(component_plot) +export(cumulative_plot) export(maraca) export(plot_maraca) export(validate_maraca_plot) diff --git a/R/aaa.R b/R/aaa.R index 9377b05..5fa9513 100644 --- a/R/aaa.R +++ b/R/aaa.R @@ -56,3 +56,9 @@ utils::globalVariables("linetype") utils::globalVariables("wins") utils::globalVariables("losses") utils::globalVariables("ties") +utils::globalVariables("method") +utils::globalVariables("UCL") +utils::globalVariables("LCL") +utils::globalVariables("wins") +utils::globalVariables("losses") +utils::globalVariables("tot") diff --git a/R/internal.R b/R/internal.R index a77716a..ab9664a 100644 --- a/R/internal.R +++ b/R/internal.R @@ -11,101 +11,6 @@ }) } -# Computes the win odds from the internal data. -.compute_win_odds <- function(hce_dat, arm_levels, - step_outcomes, last_outcome) { - - hce_dat <- base::as.data.frame(hce_dat) - hce_dat <- .with_ordered_column(hce_dat) - fit <- hce::calcWO(x = hce_dat, AVAL = "ordered", - TRTP = "arm", - ref = unname(arm_levels["control"])) - ci <- base::as.numeric(fit[, base::c("WO", "LCL", "UCL")]) - p <- fit$Pvalue - win_odds <- base::c(ci, p) - names(win_odds) <- base::c("estimate", "lower", "upper", "p-value") - - win_odds_outcome <- hce::summaryWO(hce_dat, AVAL = "ordered", TRTP = "arm", - ref = unname(arm_levels["control"]), - GROUP = "outcome") - - endpoints <- c(step_outcomes, last_outcome) - hce_dat <- hce_dat %>% - dplyr::mutate_at(dplyr::vars(outcome), factor, levels = c(endpoints, "X")) - - calcs_lst <- lapply(seq_along(endpoints), function(x) { - idx <- !(hce_dat$outcome %in% endpoints[1:x]) - hce_dat[idx, "outcome"] <- "X" - hce_dat[idx, "ordered"] <- 1000000 - wins <- hce::calcWINS(hce_dat, AVAL = "ordered", TRTP = "arm", - ref = unname(arm_levels["control"]), - GROUP = "outcome") - wo <- hce::summaryWO(hce_dat, AVAL = "ordered", TRTP = "arm", - ref = unname(arm_levels["control"]), - GROUP = "outcome") - list("wins" = wins, "wo" = wo) - }) - - wins_forest <- do.call("rbind", lapply(calcs_lst, function(c_lst) { - wins <- c_lst$wins - nm <- c("value", "LCL", "UCL", "p value") - rbind(data.frame(setNames(wins$WO, nm), "method" = "win odds"), - data.frame(setNames(wins$WR1, nm), "method" = "win ratio")) - })) - - wo_bar <- do.call("rbind", lapply(seq_along(calcs_lst), function(i) { - wo <- head(calcs_lst[[i]]$wo$summary, 1) - wo$outcome <- endpoints[i] - wo %>% - dplyr::rename(dplyr::all_of(c(wins = "WIN", losses = "LOSS", - ties = "TIE"))) %>% - tidyr::pivot_longer(cols = c(wins, losses, ties)) %>% - dplyr::mutate_at(dplyr::vars(name), factor, - levels = c("wins", "losses", "ties")) - })) - - return(list("win_odds" = win_odds, - "win_odds_outcome" = win_odds_outcome, - "wins_forest" = wins_forest, - "wo_bar" = wo_bar)) - -} - -# This function does a bit of dirty magic to distribute the values -# onto different "floors", each floor being a numeric offset that is higher -# for each passing tte variable (and highest for the continuous). -# In practice, we are translating the values for each tte variable group. -# Explanation inline -.with_ordered_column <- function(hce_dat) { - # We create a data frame, grouping according to the outcome, - # then we get the minimum and maximum values of the value. - # What we want to know is the "window" where data are for each of the groups - # We then select the largest window. - `%>%` <- dplyr::`%>%` - - tmp <- hce_dat %>% - dplyr::group_by(outcome) %>% - dplyr::summarise(min = min(value), max = max(value)) %>% - dplyr::mutate(separation = max - min) %>% - dplyr::summarise(max_separation = max(separation)) %>% - dplyr::ungroup() - - # With the largest window found, we know that if we offset the data at - # least of this amount, they will never overlap. Bit of clever math here, - # we use a gap that is larger, amounting to the number of digits, so we - # have nicer gap value such as 10, 100, or 1000 etc. - gap <- 10 ^ ceiling(log10(tmp$max_separation)) # nolint - - # apply the gap to all values. outcome is a factor, so we use its numeric - # value to multiply the offset, and end up having each value "translated up" - # of the proper amount. - hce_dat <- hce_dat %>% - dplyr::mutate(ordered = .env$gap * (as.numeric(outcome) - 1) + value) - - # and now we have a new data set with the column added. - return(hce_dat) -} - # Computes the metainfo from the internal HCE data. .compute_metainfo <- function(hce_dat) { n <- dplyr::n @@ -373,8 +278,8 @@ average = 100 * as.numeric(stats::prop.test(x, n)$estimate), se = abs(average - - (100 * as.numeric( - stats::prop.test(x, n)$conf.int)[1]))) %>% + (100 * as.numeric(stats::prop.test(x, n)$conf.int)[1]) + )) %>% dplyr::ungroup() # To create ellipsis shape and avoid overlapping between both of them, @@ -579,111 +484,6 @@ return(maraca_obj) } - -# Preparing dataset to be used for plotting components -.prep_data_component_plot <- function(win_odds_outcome, endpoints, arms) { - - `%>%` <- dplyr::`%>%` - - # Win odds summary for each outcome from maraca object - wo_bar_nc <- win_odds_outcome$summary_by_GROUP - - # Add overall numbers - wo_tot <- win_odds_outcome$summary - wo_tot <- wo_tot %>% - dplyr::mutate("GROUP" = "Overall") %>% - dplyr::select(names(win_odds_outcome$summary_by_GROUP)) - - wo_bar_nc <- rbind(wo_tot, wo_bar_nc) - - wo_bar_nc <- wo_bar_nc %>% - # Order according to outcome - dplyr::arrange(match(GROUP, endpoints)) %>% - # Wide format to get 1 line per outcome - tidyr::pivot_wider(names_from = TRTP, - values_from = c(WIN, LOSS, TIE, TOTAL)) %>% - # Selecting variables of interest and renaming for plotting - dplyr::select(GROUP, "A_wins" = WIN_A, "P_wins" = WIN_P, - "Ties" = TIE_A) %>% - # Long format for plotting - tidyr::pivot_longer(cols = c("A_wins", "P_wins", "Ties"), - names_to = "name", values_to = "value") - - # Total number of wins/losses/ties to get relative results - wo_bar_nc$total <- wo_tot$TOTAL[1] - - # Calculate percentage results - wo_bar_nc$percentage <- 100 * (wo_bar_nc$value / wo_bar_nc$total) - - labels <- c(paste(arms["active"], "wins"), - paste(arms["control"], "wins"), - "Ties") - - wo_bar_nc$name <- ifelse(wo_bar_nc$name == "A_wins", - labels[1], - ifelse(wo_bar_nc$name == "P_wins", - labels[2], labels[3])) - - wo_bar_nc$name <- factor(wo_bar_nc$name, levels = labels) - - return(wo_bar_nc) -} - - -# The main plotting function creating the component plot -.create_component_plot <- function(wo_bar_nc, endpoints, theme) { - - aes <- ggplot2::aes - - wo_bar_nc$GROUP <- factor(wo_bar_nc$GROUP, - levels = rev(c("Overall", endpoints))) - - plot <- - ggplot2::ggplot(data = wo_bar_nc, aes(x = GROUP, y = percentage, - fill = name)) + - # Bars - ggplot2::geom_bar(stat = "identity", position = ggplot2::position_dodge(), - width = .8) + - # Flip to show bars horizontally - ggplot2::coord_flip() + - # Add wins/losses/ties as labels - ggplot2::geom_text(aes(label = round(percentage, 1)), - position = ggplot2::position_dodge(width = .8), - vjust = 0.5, hjust = -0.2) - - plot <- switch(theme, - "maraca" = .theme_maraca_cp(plot), - "color1" = .theme_color1_cp(plot), - "color2" = .theme_color2_cp(plot), - "none" = plot, - stop("Please provide theme that exists")) - - # Add class to plot - componentPlot - class(plot) <- c("componentPlot", class(plot)) - - return(plot) -} - -.add_win_odds_to_plot <- function(p, win_odds, x, y, hjust) { - - p <- p + - ggplot2::annotate( - geom = "label", - x = x, - y = y, - label = paste( - "Win odds: ", round(win_odds[[1]], 2), - "\n95% CI: ", round(win_odds[[2]], 2), " - ", - round(win_odds[[3]], 2), "\n", - "p-value: ", format.pval(win_odds[[4]], digits = 3, eps = 0.001), - sep = "" - ), - hjust = hjust, vjust = 1.4, size = 3 - ) - - return(p) -} - .checks_continuous_outcome <- function(density_plot_type, vline_type) { checkmate::assert_choice( @@ -727,139 +527,3 @@ return(vline_type) } - -.create_validation_tte <- function(layers, x, arms) { - - tte_layers <- which(layers == "GeomStep") - - if (length(tte_layers) != 0) { - tte_data <- - do.call("rbind", - lapply(tte_layers, - function(i) { - dat <- ggplot2::layer_data(plot = x, - i = i)[, c("x", "y", - "group")] - dat <- utils::head(dat, -2) - if (i == tte_layers[1]) { - dat <- utils::tail(dat, -2) - } - return(dat) - })) - - tte_data$group <- factor(tte_data$group, labels = arms) - - } else { - tte_data <- NULL - } - - return(tte_data) -} - -.create_validation_binary_step <- function(layers, x, arms) { - - binary_layers <- which(layers == "GeomSegment") - - if (length(binary_layers) != 0) { - binary_step_data <- - do.call("rbind", - lapply(binary_layers, - function(i) { - dat <- ggplot2::layer_data(plot = x, - i = i)[, c("x", "y", - "yend", - "group", - "linetype")] - return(dat) - })) - - binary_step_data <- binary_step_data %>% - dplyr::filter(linetype == 2) %>% - dplyr::mutate(proportion = yend - y) %>% - dplyr::select(x, y, proportion, group) - - binary_step_data$group <- factor(binary_step_data$group, labels = arms) - - } else { - binary_step_data <- NULL - } - - return(binary_step_data) -} - -.create_validation_binary_last <- function(layers, x, arms) { - - polygon_layers <- which(layers == "GeomPolygon") - point_layers <- which(layers == "GeomPoint") - - if (length(polygon_layers) == 1 && - length(point_layers) == 1) { - - point_data <- ggplot2::layer_data(x, point_layers) %>% - dplyr::select(x, y, group) - - polygon_data <- unique(ggplot2::layer_data(x, polygon_layers)) - polygon_data <- polygon_data %>% - dplyr::filter(y %in% point_data$y) %>% - dplyr::group_by(group) %>% - dplyr::summarise("lower_se" = base::min(x, na.rm = TRUE), - "upper_se" = base::max(x, na.rm = TRUE)) - - binary_data <- dplyr::left_join(point_data, polygon_data, - by = "group") - binary_data$se <- binary_data$x - binary_data$lower_se - binary_data$group <- factor(binary_data$group, labels = arms) - - } else { - - binary_data <- NULL - - } - - return(binary_data) -} - - - -.create_validation_scatter <- function(layers, x, arms) { - scatter_data <- do.call("rbind", lapply(which(layers == "GeomPoint"), - ggplot2::layer_data, plot = x)) - if (!is.null(scatter_data) && nrow(scatter_data) > 2) { - scatter_data <- scatter_data[, c("group", "x", "y")] - scatter_data$group <- factor(scatter_data$group, labels = arms) - } - - return(scatter_data) -} - -.create_validation_violin <- function(layers, x, arms) { - violin_data <- do.call("rbind", lapply(which(layers == "GeomViolin"), - ggplot2::layer_data, plot = x)) - if (!is.null(violin_data)) { - violin_data <- violin_data[, c("group", "x", "y", "density", "width")] - violin_data$group <- factor(violin_data$group, labels = arms) - } - - return(violin_data) -} - -.create_validation_box <- function(layers, x, arms) { - - `%>%` <- dplyr::`%>%` - - boxstat_data <- do.call("rbind", lapply(which(layers == "GeomBoxplot"), - ggplot2::layer_data, plot = x)) - - if (!is.null(boxstat_data)) { - boxstat_data <- boxstat_data %>% - dplyr::select(group, "x_lowest" = xmin_final, - "whisker_lower" = xmin, - "hinge_lower" = xlower, "median" = xmiddle, - "hinge_upper" = xupper, "whisker_upper" = xmax, - "x_highest" = xmax_final, outliers) - boxstat_data$outliers <- lapply(boxstat_data$outliers, sort) - boxstat_data$group <- factor(boxstat_data$group, labels = arms) - } - - return(boxstat_data) -} diff --git a/R/internal_validation.R b/R/internal_validation.R new file mode 100644 index 0000000..a964534 --- /dev/null +++ b/R/internal_validation.R @@ -0,0 +1,136 @@ + +.create_validation_tte <- function(layers, x, arms) { + + tte_layers <- which(layers == "GeomStep") + + if (length(tte_layers) != 0) { + tte_data <- + do.call("rbind", + lapply(tte_layers, + function(i) { + dat <- ggplot2::layer_data(plot = x, + i = i)[, c("x", "y", + "group")] + dat <- utils::head(dat, -2) + if (i == tte_layers[1]) { + dat <- utils::tail(dat, -2) + } + return(dat) + })) + + tte_data$group <- factor(tte_data$group, labels = arms) + + } else { + tte_data <- NULL + } + + return(tte_data) +} + +.create_validation_binary_step <- function(layers, x, arms) { + + binary_layers <- which(layers == "GeomSegment") + + if (length(binary_layers) != 0) { + binary_step_data <- + do.call("rbind", + lapply(binary_layers, + function(i) { + dat <- ggplot2::layer_data(plot = x, + i = i)[, c("x", "y", + "yend", + "group", + "linetype")] + return(dat) + })) + + binary_step_data <- binary_step_data %>% + dplyr::filter(linetype == 2) %>% + dplyr::mutate(proportion = yend - y) %>% + dplyr::select(x, y, proportion, group) + + binary_step_data$group <- factor(binary_step_data$group, labels = arms) + + } else { + binary_step_data <- NULL + } + + return(binary_step_data) +} + +.create_validation_binary_last <- function(layers, x, arms) { + + polygon_layers <- which(layers == "GeomPolygon") + point_layers <- which(layers == "GeomPoint") + + if (length(polygon_layers) == 1 && + length(point_layers) == 1) { + + point_data <- ggplot2::layer_data(x, point_layers) %>% + dplyr::select(x, y, group) + + polygon_data <- unique(ggplot2::layer_data(x, polygon_layers)) + polygon_data <- polygon_data %>% + dplyr::filter(y %in% point_data$y) %>% + dplyr::group_by(group) %>% + dplyr::summarise("lower_se" = base::min(x, na.rm = TRUE), + "upper_se" = base::max(x, na.rm = TRUE)) + + binary_data <- dplyr::left_join(point_data, polygon_data, + by = "group") + binary_data$se <- binary_data$x - binary_data$lower_se + binary_data$group <- factor(binary_data$group, labels = arms) + + } else { + + binary_data <- NULL + + } + + return(binary_data) +} + + + +.create_validation_scatter <- function(layers, x, arms) { + scatter_data <- do.call("rbind", lapply(which(layers == "GeomPoint"), + ggplot2::layer_data, plot = x)) + if (!is.null(scatter_data) && nrow(scatter_data) > 2) { + scatter_data <- scatter_data[, c("group", "x", "y")] + scatter_data$group <- factor(scatter_data$group, labels = arms) + } + + return(scatter_data) +} + +.create_validation_violin <- function(layers, x, arms) { + violin_data <- do.call("rbind", lapply(which(layers == "GeomViolin"), + ggplot2::layer_data, plot = x)) + if (!is.null(violin_data)) { + violin_data <- violin_data[, c("group", "x", "y", "density", "width")] + violin_data$group <- factor(violin_data$group, labels = arms) + } + + return(violin_data) +} + +.create_validation_box <- function(layers, x, arms) { + + `%>%` <- dplyr::`%>%` + + boxstat_data <- do.call("rbind", lapply(which(layers == "GeomBoxplot"), + ggplot2::layer_data, plot = x)) + + if (!is.null(boxstat_data)) { + boxstat_data <- boxstat_data %>% + dplyr::select(group, "x_lowest" = xmin_final, + "whisker_lower" = xmin, + "hinge_lower" = xlower, "median" = xmiddle, + "hinge_upper" = xupper, "whisker_upper" = xmax, + "x_highest" = xmax_final, outliers) + boxstat_data$outliers <- lapply(boxstat_data$outliers, sort) + boxstat_data$group <- factor(boxstat_data$group, labels = arms) + } + + return(boxstat_data) +} diff --git a/R/internal_winOdds.R b/R/internal_winOdds.R new file mode 100644 index 0000000..2bbddbc --- /dev/null +++ b/R/internal_winOdds.R @@ -0,0 +1,261 @@ +# This function does a bit of dirty magic to distribute the values +# onto different "floors", each floor being a numeric offset that is higher +# for each passing tte variable (and highest for the continuous). +# In practice, we are translating the values for each tte variable group. +# Explanation inline +.with_ordered_column <- function(hce_dat) { + # We create a data frame, grouping according to the outcome, + # then we get the minimum and maximum values of the value. + # What we want to know is the "window" where data are for each of the groups + # We then select the largest window. + `%>%` <- dplyr::`%>%` + + tmp <- hce_dat %>% + dplyr::group_by(outcome) %>% + dplyr::summarise(min = min(value), max = max(value)) %>% + dplyr::mutate(separation = max - min) %>% + dplyr::summarise(max_separation = max(separation)) %>% + dplyr::ungroup() + + # With the largest window found, we know that if we offset the data at + # least of this amount, they will never overlap. Bit of clever math here, + # we use a gap that is larger, amounting to the number of digits, so we + # have nicer gap value such as 10, 100, or 1000 etc. + gap <- 10 ^ ceiling(log10(tmp$max_separation)) # nolint + + # apply the gap to all values. outcome is a factor, so we use its numeric + # value to multiply the offset, and end up having each value "translated up" + # of the proper amount. + hce_dat <- hce_dat %>% + dplyr::mutate(ordered = .env$gap * (as.numeric(outcome) - 1) + value) + + # and now we have a new data set with the column added. + return(hce_dat) +} + +# Computes the win odds from the internal data. +.compute_win_odds <- function(hce_dat, arm_levels, + step_outcomes, last_outcome) { + + `%>%` <- dplyr::`%>%` + + hce_dat <- base::as.data.frame(hce_dat) + hce_dat <- .with_ordered_column(hce_dat) + fit <- hce::calcWO(x = hce_dat, AVAL = "ordered", + TRTP = "arm", + ref = unname(arm_levels["control"])) + ci <- base::as.numeric(fit[, base::c("WO", "LCL", "UCL")]) + p <- fit$Pvalue + win_odds <- base::c(ci, p) + names(win_odds) <- base::c("estimate", "lower", "upper", "p-value") + + win_odds_outcome <- hce::summaryWO(hce_dat, AVAL = "ordered", TRTP = "arm", + ref = unname(arm_levels["control"]), + GROUP = "outcome") + + endpoints <- c(step_outcomes, last_outcome) + labs <- c(Reduce(paste, as.character(endpoints[1:(length(endpoints) - 1)]), + accumulate = TRUE), "All") + + hce_dat <- hce_dat %>% + dplyr::mutate_at(dplyr::vars(outcome), factor, levels = c(endpoints, "X")) + + calcs_lst <- lapply(seq_along(endpoints), function(x) { + idx <- !(hce_dat$outcome %in% endpoints[1:x]) + hce_dat[idx, "outcome"] <- "X" + hce_dat[idx, "ordered"] <- 1000000 + wins <- hce::calcWINS(hce_dat, AVAL = "ordered", TRTP = "arm", + ref = unname(arm_levels["control"]), + GROUP = "outcome") + wo <- hce::summaryWO(hce_dat, AVAL = "ordered", TRTP = "arm", + ref = unname(arm_levels["control"]), + GROUP = "outcome") + list("wins" = wins, "wo" = wo) + }) + + wins_forest <- do.call("rbind", lapply(seq_along(calcs_lst), function(i) { + wins <- calcs_lst[[i]]$wins + nm <- c("value", "LCL", "UCL", "p value") + f <- rbind(data.frame(setNames(wins$WO, nm), "method" = "win odds"), + data.frame(setNames(wins$WR1, nm), "method" = "win ratio")) + f$GROUP <- labs[i] + return(f) + })) + + wo_bar <- do.call("rbind", lapply(seq_along(calcs_lst), function(i) { + wo <- head(calcs_lst[[i]]$wo$summary, 1) + wo$outcome <- endpoints[i] + wo$GROUP <- labs[i] + wo %>% + dplyr::rename(dplyr::all_of(c(wins = "WIN", losses = "LOSS", + ties = "TIE"))) %>% + tidyr::pivot_longer(cols = c(wins, losses, ties)) %>% + dplyr::mutate_at(dplyr::vars(name), factor, + levels = c("wins", "losses", "ties")) + })) + + wins_forest$GROUP <- factor(wins_forest$GROUP, levels = rev(labs)) + wins_forest$method <- factor(wins_forest$method, + levels = c("win ratio", "win odds")) + wo_bar$GROUP <- factor(wo_bar$GROUP, levels = rev(labs)) + wo_bar$proportion <- wo_bar$value / win_odds_outcome$summary$TOTAL[1] + + return(list("win_odds" = win_odds, + "win_odds_outcome" = win_odds_outcome, + "wins_forest" = wins_forest, + "wo_bar" = wo_bar)) + +} + +# Preparing dataset to be used for plotting components +.prep_data_component_plot <- function(win_odds_outcome, endpoints, arms) { + + `%>%` <- dplyr::`%>%` + + # Win odds summary for each outcome from maraca object + wo_bar_nc <- win_odds_outcome$summary_by_GROUP + + # Add overall numbers + wo_tot <- win_odds_outcome$summary + wo_tot <- wo_tot %>% + dplyr::mutate("GROUP" = "Overall") %>% + dplyr::select(names(win_odds_outcome$summary_by_GROUP)) + + wo_bar_nc <- rbind(wo_tot, wo_bar_nc) + + wo_bar_nc <- wo_bar_nc %>% + # Order according to outcome + dplyr::arrange(match(GROUP, endpoints)) %>% + # Wide format to get 1 line per outcome + tidyr::pivot_wider(names_from = TRTP, + values_from = c(WIN, LOSS, TIE, TOTAL)) %>% + # Selecting variables of interest and renaming for plotting + dplyr::select(GROUP, "A_wins" = WIN_A, "P_wins" = WIN_P, + "Ties" = TIE_A) %>% + # Long format for plotting + tidyr::pivot_longer(cols = c("A_wins", "P_wins", "Ties"), + names_to = "name", values_to = "value") + + # Total number of wins/losses/ties to get relative results + wo_bar_nc$total <- wo_tot$TOTAL[1] + + # Calculate percentage results + wo_bar_nc$percentage <- 100 * (wo_bar_nc$value / wo_bar_nc$total) + + labels <- c(paste(arms["active"], "wins"), + paste(arms["control"], "wins"), + "Ties") + + wo_bar_nc$name <- ifelse(wo_bar_nc$name == "A_wins", + labels[1], + ifelse(wo_bar_nc$name == "P_wins", + labels[2], labels[3])) + + wo_bar_nc$name <- factor(wo_bar_nc$name, levels = labels) + + return(wo_bar_nc) +} + + +# The main plotting function creating the component plot +.create_component_plot <- function(wo_bar_nc, endpoints, theme) { + + aes <- ggplot2::aes + + wo_bar_nc$GROUP <- factor(wo_bar_nc$GROUP, + levels = rev(c("Overall", endpoints))) + + plot <- + ggplot2::ggplot(data = wo_bar_nc, aes(x = GROUP, y = percentage, + fill = name)) + + # Bars + ggplot2::geom_bar(stat = "identity", position = ggplot2::position_dodge(), + width = .8) + + # Flip to show bars horizontally + ggplot2::coord_flip() + + # Add wins/losses/ties as labels + ggplot2::geom_text(aes(label = round(percentage, 1)), + position = ggplot2::position_dodge(width = .8), + vjust = 0.5, hjust = -0.2) + + plot <- switch(theme, + "maraca" = .theme_maraca_cp(plot), + "color1" = .theme_color1_cp(plot), + "color2" = .theme_color2_cp(plot), + "none" = plot, + stop("Please provide theme that exists")) + + # Add class to plot - componentPlot + class(plot) <- c("componentPlot", class(plot)) + + return(plot) +} + +# Create forest plot part of cumulative plot +.create_forest_plot <- function(wins_forest, theme) { + + plot <- ggplot(data = wins_forest) + + geom_errorbar(aes(x = GROUP, y = value, ymin = LCL, ymax = UCL, + col = method, group = method), linewidth = 0.3, + width = 0.1, + position = ggplot2::position_dodge(width = 0.3)) + + geom_point(aes(x = GROUP, y = value, col = method, shape = method), + size = 3, position = ggplot2::position_dodge(width = 0.3)) + + geom_hline(yintercept = 1, linetype = "dashed", color = "#676767") + + coord_flip() + + scale_y_continuous() + + scale_x_discrete(labels = NULL, name = NULL) + + if (theme != "none") { + plot <- plot + + theme_bw() + + theme(legend.position = "bottom", legend.title = element_blank()) + + scale_color_manual(values = c("black", "grey50")) + + scale_fill_manual(values = c("black", "grey50")) + + ylab("Win Odds / Win Ratio") + } + + return(plot) + +} + +# Create bar plot part of cumulative plot +.create_bar_plot <- function(wo_bar, theme) { + + plot <- ggplot(data = wo_bar, aes(x = GROUP, y = proportion, fill = name)) + + geom_bar(stat = "identity", position = position_dodge(), width = .9) + + coord_flip() + # make bar plot horizontal + geom_text(aes(label = round(proportion, 3) * 100), + position = ggplot2::position_dodge(width = .9), + vjust = 0.5, hjust = 1.2) + + plot <- switch(theme, + "maraca" = .theme_maraca_cp(plot), + "color1" = .theme_color1_cp(plot), + "color2" = .theme_color2_cp(plot), + "none" = plot, + stop("Please provide theme that exists")) + + return(plot) + +} + +.add_win_odds_to_plot <- function(p, win_odds, x, y, hjust) { + + p <- p + + ggplot2::annotate( + geom = "label", + x = x, + y = y, + label = paste( + "Win odds: ", round(win_odds[[1]], 2), + "\n95% CI: ", round(win_odds[[2]], 2), " - ", + round(win_odds[[3]], 2), "\n", + "p-value: ", format.pval(win_odds[[4]], digits = 3, eps = 0.001), + sep = "" + ), + hjust = hjust, vjust = 1.4, size = 3 + ) + + return(p) +} diff --git a/R/themes.R b/R/themes.R index 618185d..d34ab48 100644 --- a/R/themes.R +++ b/R/themes.R @@ -38,7 +38,6 @@ } - .theme_maraca_cp <- function(p) { p <- .theme_common_cp(p) diff --git a/R/winOddsPlots.R b/R/winOddsPlots.R index 8915e05..15988bf 100644 --- a/R/winOddsPlots.R +++ b/R/winOddsPlots.R @@ -153,3 +153,144 @@ component_plot.hce <- function(x, last_outcome = "C", return(plot) } + +#' Function to create a plot showing the components used in +#' calculating win odds (wins and ties) cumulated for all +#' outcomes for a hierarchical endpoint. +#' +#' Implemented for objects of type 'maraca' and 'hce'. +#' +#' @param x an object of S3 class 'maraca' or 'hce'. +#' @param \dots further arguments to be passed to the +#' object-specific functions +#' @export +cumulative_plot <- function(x, ...) { + UseMethod("cumulative_plot", x) +} + +#' @export +cumulative_plot.default <- function(x, + ...) { + paste0("cumulative_plot() function can only handle inputs of class ", + "'hce' or 'maraca'. Your input has class ", class(x), ".") +} + +#' Generic function to create a plot showing the components used in +#' calculating win odds (wins and ties) cumulated for all +#' outcomes directly from a maraca object. +#' Note that for this plot, when creating the maraca object using the maraca() +#' function, the argument "compute_win_odds" has to be set to TRUE. +#' Check the vignette "Maraca Plots - Plotting win odds" for more details. +#' +#' @param x an object of S3 class 'maraca'. +#' @param \dots not used +#' @param theme Choose theme to style the plot. The default theme is "maraca". +#' Options are "maraca", "color1", "color2" and none". +#' For more details, check the vignette called +#' "Maraca Plots - Plotting win odds". +#' @return Cumulative plot as a patchwork object. +#' @examples +#' +#' data(hce_scenario_a) +#' +#' maraca_dat <- maraca(data = hce_scenario_a, +#' step_outcomes = c("Outcome I", "Outcome II", +#' "Outcome III", "Outcome IV"), +#' last_outcome = "Continuous outcome", +#' fixed_followup_days = 3 * 365, +#' column_names = c(outcome = "GROUP", +#' arm = "TRTP", +#' value = "AVAL0"), +#' arm_levels = c(active = "Active", +#' control = "Control"), +#' compute_win_odds = TRUE +#' ) +#' +#' cumulative_plot(maraca_dat) +#' +#' @export +cumulative_plot.maraca <- function(x, + theme = "maraca", + ...) { + + # Check that win odds were calculated for the maraca object + if (is.null(x[["wins_forest"]]) || is.null(x[["wo_bar"]])) { + stop(paste0("Win odds not calculated for maraca object.\n", + " Make sure to set compute_win_odds = TRUE when ", + "creating the maraca object.")) + } + + # Get win odds by outcome from maraca object + wo_bar <- x$wo_bar + wins_forest <- x$wins_forest + # Create forest plot + plot_bar <- .create_bar_plot(wo_bar, theme) + plot_forest <- .create_forest_plot(wins_forest, theme) + + plot <- patchwork:::"|.ggplot"(plot_bar, plot_forest) + + patchwork::plot_layout(widths = c(3, 1), nrow = 1) + + # Add class to plot - cumulativePlot + class(plot) <- c("cumulativePlot", class(plot)) + + return(plot) +} + +#' Generic function to create a plot showing the components used in +#' calculating win odds (wins and ties) cumulated for all +#' outcomes directly from an hce object. +#' Check the vignette "Maraca Plots - Plotting win odds" for more details. +#' +#' @param x an object of S3 class 'hce'. +#' @param \dots not used +#' @param last_outcome A single string containing the last outcome label +#' displayed on the right side of the plot. +#' Default value "C". +#' @param arm_levels A named vector of exactly two strings, mapping the +#' values used for the active and control arms to the values +#' used in the data. The names must be "active" and "control" +#' in this order. Note that this parameter only need to +#' be specified if you have labels different from +#' "active" and "control". +#' @param fixed_followup_days Not needed if HCE object contains information +#' on fixed follow-up days in the study +#' (column PADY or TTEfixed, +#' depending on hce version). +#' Otherwise, this argument must be specified. +#' Note: If argument is specified and HCE object +#' contains PADY or TTEfixed column, then +#' fixed_followup_days argument is used. +#' @param theme Choose theme to style the plot. The default theme is "maraca". +#' Options are "maraca", "color1", "color2" and none". +#' For more details, check the vignette called +#' "Maraca Plots - Plotting win odds". +#' @param continuous_outcome Deprecated and substituted by the more general +#' 'last_outcome'. A single string containing the +#' continuous outcome label. +#' @return Cumulative plot as a patchwork object. +#' @examples +#' Rates_A <- c(1.72, 1.74, 0.58, 1.5, 1) +#' Rates_P <- c(2.47, 2.24, 2.9, 4, 6) +#' hce_dat <- hce::simHCE(n = 2500, TTE_A = Rates_A, TTE_P = Rates_P, +#' CM_A = -3, CM_P = -6, CSD_A = 16, CSD_P = 15, fixedfy = 3, +#' seed = 31337) +#' +#' cumulative_plot(hce_dat) +#' @export +#' +cumulative_plot.hce <- function(x, last_outcome = "C", + arm_levels = c(active = "A", control = "P"), + fixed_followup_days = NULL, + theme = "maraca", + continuous_outcome = lifecycle::deprecated(), + ...) { + + # Create maraca object + maraca_dat <- .maraca_from_hce_data(x, last_outcome, arm_levels, + fixed_followup_days, + compute_win_odds = TRUE) + + plot <- cumulative_plot(maraca_dat, theme = theme) + + return(plot) +} diff --git a/man/cumulative_plot.Rd b/man/cumulative_plot.Rd new file mode 100644 index 0000000..51da6f3 --- /dev/null +++ b/man/cumulative_plot.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/winOddsPlots.R +\name{cumulative_plot} +\alias{cumulative_plot} +\title{Function to create a plot showing the components used in +calculating win odds (wins and ties) cumulated for all +outcomes for a hierarchical endpoint.} +\usage{ +cumulative_plot(x, ...) +} +\arguments{ +\item{x}{an object of S3 class 'maraca' or 'hce'.} + +\item{\dots}{further arguments to be passed to the +object-specific functions} +} +\description{ +Implemented for objects of type 'maraca' and 'hce'. +} diff --git a/man/cumulative_plot.hce.Rd b/man/cumulative_plot.hce.Rd new file mode 100644 index 0000000..82f27e7 --- /dev/null +++ b/man/cumulative_plot.hce.Rd @@ -0,0 +1,71 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/winOddsPlots.R +\name{cumulative_plot.hce} +\alias{cumulative_plot.hce} +\title{Generic function to create a plot showing the components used in +calculating win odds (wins and ties) cumulated for all +outcomes directly from an hce object. +Check the vignette "Maraca Plots - Plotting win odds" for more details.} +\usage{ +\method{cumulative_plot}{hce}( + x, + last_outcome = "C", + arm_levels = c(active = "A", control = "P"), + fixed_followup_days = NULL, + theme = "maraca", + continuous_outcome = lifecycle::deprecated(), + ... +) +} +\arguments{ +\item{x}{an object of S3 class 'hce'.} + +\item{last_outcome}{A single string containing the last outcome label +displayed on the right side of the plot. +Default value "C".} + +\item{arm_levels}{A named vector of exactly two strings, mapping the +values used for the active and control arms to the values +used in the data. The names must be "active" and "control" +in this order. Note that this parameter only need to +be specified if you have labels different from + "active" and "control".} + +\item{fixed_followup_days}{Not needed if HCE object contains information +on fixed follow-up days in the study +(column PADY or TTEfixed, +depending on hce version). +Otherwise, this argument must be specified. +Note: If argument is specified and HCE object +contains PADY or TTEfixed column, then +fixed_followup_days argument is used.} + +\item{theme}{Choose theme to style the plot. The default theme is "maraca". +Options are "maraca", "color1", "color2" and none". +For more details, check the vignette called +"Maraca Plots - Plotting win odds".} + +\item{continuous_outcome}{Deprecated and substituted by the more general +'last_outcome'. A single string containing the +continuous outcome label.} + +\item{\dots}{not used} +} +\value{ +Cumulative plot as a patchwork object. +} +\description{ +Generic function to create a plot showing the components used in +calculating win odds (wins and ties) cumulated for all +outcomes directly from an hce object. +Check the vignette "Maraca Plots - Plotting win odds" for more details. +} +\examples{ +Rates_A <- c(1.72, 1.74, 0.58, 1.5, 1) +Rates_P <- c(2.47, 2.24, 2.9, 4, 6) +hce_dat <- hce::simHCE(n = 2500, TTE_A = Rates_A, TTE_P = Rates_P, + CM_A = -3, CM_P = -6, CSD_A = 16, CSD_P = 15, fixedfy = 3, + seed = 31337) + +cumulative_plot(hce_dat) +} diff --git a/man/cumulative_plot.maraca.Rd b/man/cumulative_plot.maraca.Rd new file mode 100644 index 0000000..f400843 --- /dev/null +++ b/man/cumulative_plot.maraca.Rd @@ -0,0 +1,54 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/winOddsPlots.R +\name{cumulative_plot.maraca} +\alias{cumulative_plot.maraca} +\title{Generic function to create a plot showing the components used in +calculating win odds (wins and ties) cumulated for all +outcomes directly from a maraca object. +Note that for this plot, when creating the maraca object using the maraca() +function, the argument "compute_win_odds" has to be set to TRUE. +Check the vignette "Maraca Plots - Plotting win odds" for more details.} +\usage{ +\method{cumulative_plot}{maraca}(x, theme = "maraca", ...) +} +\arguments{ +\item{x}{an object of S3 class 'maraca'.} + +\item{theme}{Choose theme to style the plot. The default theme is "maraca". +Options are "maraca", "color1", "color2" and none". +For more details, check the vignette called +"Maraca Plots - Plotting win odds".} + +\item{\dots}{not used} +} +\value{ +Cumulative plot as a patchwork object. +} +\description{ +Generic function to create a plot showing the components used in +calculating win odds (wins and ties) cumulated for all +outcomes directly from a maraca object. +Note that for this plot, when creating the maraca object using the maraca() +function, the argument "compute_win_odds" has to be set to TRUE. +Check the vignette "Maraca Plots - Plotting win odds" for more details. +} +\examples{ + +data(hce_scenario_a) + +maraca_dat <- maraca(data = hce_scenario_a, + step_outcomes = c("Outcome I", "Outcome II", + "Outcome III", "Outcome IV"), + last_outcome = "Continuous outcome", + fixed_followup_days = 3 * 365, + column_names = c(outcome = "GROUP", + arm = "TRTP", + value = "AVAL0"), + arm_levels = c(active = "Active", + control = "Control"), + compute_win_odds = TRUE + ) + +cumulative_plot(maraca_dat) + +} From 7fb285a48e78fe33fd8752bdc8c3c1f94e9a9f1f Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Tue, 5 Mar 2024 10:55:40 +0000 Subject: [PATCH 21/32] Fix lintr errors --- R/internal.R | 4 ++-- R/internal_winOdds.R | 2 +- R/winOddsPlots.R | 17 +++++++---------- 3 files changed, 10 insertions(+), 13 deletions(-) diff --git a/R/internal.R b/R/internal.R index ab9664a..8c87607 100644 --- a/R/internal.R +++ b/R/internal.R @@ -278,8 +278,8 @@ average = 100 * as.numeric(stats::prop.test(x, n)$estimate), se = abs(average - - (100 * as.numeric(stats::prop.test(x, n)$conf.int)[1]) - )) %>% + (100 * as.numeric(stats::prop.test(x, n)$conf.int)[1]) + )) %>% dplyr::ungroup() # To create ellipsis shape and avoid overlapping between both of them, diff --git a/R/internal_winOdds.R b/R/internal_winOdds.R index 2bbddbc..6d4f051 100644 --- a/R/internal_winOdds.R +++ b/R/internal_winOdds.R @@ -77,7 +77,7 @@ wins <- calcs_lst[[i]]$wins nm <- c("value", "LCL", "UCL", "p value") f <- rbind(data.frame(setNames(wins$WO, nm), "method" = "win odds"), - data.frame(setNames(wins$WR1, nm), "method" = "win ratio")) + data.frame(setNames(wins$WR1, nm), "method" = "win ratio")) f$GROUP <- labs[i] return(f) })) diff --git a/R/winOddsPlots.R b/R/winOddsPlots.R index 15988bf..14c4a7e 100644 --- a/R/winOddsPlots.R +++ b/R/winOddsPlots.R @@ -169,8 +169,7 @@ cumulative_plot <- function(x, ...) { } #' @export -cumulative_plot.default <- function(x, - ...) { +cumulative_plot.default <- function(x, ...) { paste0("cumulative_plot() function can only handle inputs of class ", "'hce' or 'maraca'. Your input has class ", class(x), ".") } @@ -209,9 +208,7 @@ cumulative_plot.default <- function(x, #' cumulative_plot(maraca_dat) #' #' @export -cumulative_plot.maraca <- function(x, - theme = "maraca", - ...) { +cumulative_plot.maraca <- function(x, theme = "maraca", ...) { # Check that win odds were calculated for the maraca object if (is.null(x[["wins_forest"]]) || is.null(x[["wo_bar"]])) { @@ -279,11 +276,11 @@ cumulative_plot.maraca <- function(x, #' @export #' cumulative_plot.hce <- function(x, last_outcome = "C", - arm_levels = c(active = "A", control = "P"), - fixed_followup_days = NULL, - theme = "maraca", - continuous_outcome = lifecycle::deprecated(), - ...) { + arm_levels = c(active = "A", control = "P"), + fixed_followup_days = NULL, + theme = "maraca", + continuous_outcome = lifecycle::deprecated(), + ...) { # Create maraca object maraca_dat <- .maraca_from_hce_data(x, last_outcome, arm_levels, From c6d258541dc2df76375f0b4fe91c18fb7990e60a Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Tue, 5 Mar 2024 11:01:08 +0000 Subject: [PATCH 22/32] Fix lintr errors --- R/internal.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/internal.R b/R/internal.R index 8c87607..4067840 100644 --- a/R/internal.R +++ b/R/internal.R @@ -279,7 +279,7 @@ as.numeric(stats::prop.test(x, n)$estimate), se = abs(average - (100 * as.numeric(stats::prop.test(x, n)$conf.int)[1]) - )) %>% + )) %>% dplyr::ungroup() # To create ellipsis shape and avoid overlapping between both of them, From f9b2cc7e71b164ea274693cf2d1ee093df591077 Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Tue, 5 Mar 2024 11:10:10 +0000 Subject: [PATCH 23/32] Fix x-axis for cumulative plot --- R/internal_winOdds.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/R/internal_winOdds.R b/R/internal_winOdds.R index 6d4f051..2dcc0a6 100644 --- a/R/internal_winOdds.R +++ b/R/internal_winOdds.R @@ -98,7 +98,7 @@ wins_forest$method <- factor(wins_forest$method, levels = c("win ratio", "win odds")) wo_bar$GROUP <- factor(wo_bar$GROUP, levels = rev(labs)) - wo_bar$proportion <- wo_bar$value / win_odds_outcome$summary$TOTAL[1] + wo_bar$percentage <- 100 * (wo_bar$value / win_odds_outcome$summary$TOTAL[1]) return(list("win_odds" = win_odds, "win_odds_outcome" = win_odds_outcome, @@ -222,10 +222,10 @@ # Create bar plot part of cumulative plot .create_bar_plot <- function(wo_bar, theme) { - plot <- ggplot(data = wo_bar, aes(x = GROUP, y = proportion, fill = name)) + + plot <- ggplot(data = wo_bar, aes(x = GROUP, y = percentage, fill = name)) + geom_bar(stat = "identity", position = position_dodge(), width = .9) + coord_flip() + # make bar plot horizontal - geom_text(aes(label = round(proportion, 3) * 100), + geom_text(aes(label = round(percentage, 1)), position = ggplot2::position_dodge(width = .9), vjust = 0.5, hjust = 1.2) From bed64817b20f6ea54866c32130cdb338c43758c7 Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Wed, 6 Mar 2024 10:15:55 +0000 Subject: [PATCH 24/32] Update vignettes with new functionality --- R/internal.R | 2 +- R/internal_winOdds.R | 18 +++- R/winOddsPlots.R | 2 +- vignettes/otherEndpoints.Rmd | 180 +++++++++++++++++++++++++++++++++++ vignettes/winOdds.Rmd | 48 +++++++++- 5 files changed, 240 insertions(+), 10 deletions(-) create mode 100644 vignettes/otherEndpoints.Rmd diff --git a/R/internal.R b/R/internal.R index 4067840..e765bb3 100644 --- a/R/internal.R +++ b/R/internal.R @@ -285,7 +285,7 @@ # To create ellipsis shape and avoid overlapping between both of them, # set the height to 80% of the SE (minimum scaled in x-axis or y-axis range) width <- (100 - start_binary_endpoint) * min(binary_meta$se) / 100 - y_range <- (max(actv_y, ctrl_y) + 10) * min(binary_meta$se) / 100 + y_range <- ((max(actv_y, ctrl_y) + 10) * min(binary_meta$se) / 100) * 0.6 y_height <- min(c(0.4 * abs(actv_y - ctrl_y), 0.8 * min(width, y_range))) # Create ellipsis centered around proportion estimate (x0) as well as diff --git a/R/internal_winOdds.R b/R/internal_winOdds.R index 2dcc0a6..a25bb51 100644 --- a/R/internal_winOdds.R +++ b/R/internal_winOdds.R @@ -54,8 +54,9 @@ GROUP = "outcome") endpoints <- c(step_outcomes, last_outcome) - labs <- c(Reduce(paste, as.character(endpoints[1:(length(endpoints) - 1)]), - accumulate = TRUE), "All") + labs <- c(sapply(head(seq_along(endpoints), -1), function(i) { + paste(endpoints[1:i], collapse = " +\n") + }), "All") hce_dat <- hce_dat %>% dplyr::mutate_at(dplyr::vars(outcome), factor, levels = c(endpoints, "X")) @@ -208,11 +209,18 @@ if (theme != "none") { plot <- plot + - theme_bw() + - theme(legend.position = "bottom", legend.title = element_blank()) + + ggplot2::geom_vline(xintercept = + seq(0.5, length(levels(wins_forest$GROUP)) + 1.5, + 1), + linetype = 2, linewidth = 0.3, color = "darkgray") + scale_color_manual(values = c("black", "grey50")) + scale_fill_manual(values = c("black", "grey50")) + - ylab("Win Odds / Win Ratio") + ylab("Win Odds / Win Ratio") + + theme_bw() + + theme(legend.position = "bottom", + legend.title = element_blank(), + panel.grid.major.y = ggplot2::element_blank(), + panel.grid.minor.y = ggplot2::element_blank()) } return(plot) diff --git a/R/winOddsPlots.R b/R/winOddsPlots.R index 14c4a7e..5cec958 100644 --- a/R/winOddsPlots.R +++ b/R/winOddsPlots.R @@ -225,7 +225,7 @@ cumulative_plot.maraca <- function(x, theme = "maraca", ...) { plot_forest <- .create_forest_plot(wins_forest, theme) plot <- patchwork:::"|.ggplot"(plot_bar, plot_forest) + - patchwork::plot_layout(widths = c(3, 1), nrow = 1) + patchwork::plot_layout(widths = c(2.5, 1), nrow = 1) # Add class to plot - cumulativePlot class(plot) <- c("cumulativePlot", class(plot)) diff --git a/vignettes/otherEndpoints.Rmd b/vignettes/otherEndpoints.Rmd new file mode 100644 index 0000000..47112e3 --- /dev/null +++ b/vignettes/otherEndpoints.Rmd @@ -0,0 +1,180 @@ +--- +title: "Maraca Plots - Alternative Endpoints" +author: "Monika Huhn" +date: "`r Sys.Date()`" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Maraca Plots - Alternative Endpoints} + %\VignetteEngine{knitr::rmarkdown} + \usepackage[utf8]{inputenc} +--- + +```{r setup, include = FALSE} +knitr::opts_chunk$set(echo = TRUE, collapse = TRUE) +library(dplyr) +library(maraca) +``` + +The maraca package can also be used for hierarchical endpoints containing other type of endpoints than +time-to-event and continuous. Currently binary endpoints are also supported with further type of +endpoints under development + + +## Binary endpoints + +### Last outcome + +First we go through an example where the final outcome instead of being continuous, is a binary outcome. +As an example, this could for example be weight loss above a certain threshold at the end of the study. +The way the outcome should be included in the data is as a numeric vector with 1 for those patients that +had the outcome and 0 for those that had not. + +We do not have any example dataset with a final binary endpoint included in the package, so for +this vignette we modify an existing dataset: + +```{r} +data("hce_scenario_a") +# Create data with binary version of continuous final endpoint +bin_data <- hce_scenario_a +# Index of all continuous outcome rows +idx_cont <- bin_data$GROUP == "Continuous outcome" +# Rename outcome +bin_data[idx_cont,"GROUP"] <- "Binary outcome" +# Binary version (>= 0/< 0) +bin_data[idx_cont,"AVAL0"] <- bin_data[idx_cont,"AVAL0"] >= 0 +bin_data[idx_cont,"AVAL"] <- bin_data[idx_cont,"AVAL0"] + + bin_data[idx_cont,"GROUPN"] +head(bin_data) +``` + +If we now want to create a maraca object for this data, we need to slightly update +the default code. By default, maraca expects the last outcome to be continuous. In +order for the function to know that the last outcome is binary, we have to update +the parameter `last_type`. The parameter currently accepts the inputs `"binary"` and +`"continuous"`. +```{r} +column_names <- c( + outcome = "GROUP", + arm = "TRTP", + value = "AVAL0" +) + +step_outcomes <- c("Outcome I", "Outcome II", + "Outcome III", "Outcome IV") + +last_outcome <- "Binary outcome" + +arm_levels <- c(active = "Active", + control = "Control") + +mar <- maraca( + bin_data, step_outcomes, last_outcome, + arm_levels, column_names, + fixed_followup_days = 3*365, + compute_win_odds = TRUE, + # Important change: Add information that last endpoint is + # not continuous (the default) + last_type = "binary" +) +``` + +The maraca object can now be plotted. A binary endpoint is plotted +as an ellipsis. The point in the middle of the ellipsis indicates the +proportion that has met the binary endpoint. The width of the ellipsis +(x-axis range) shows the confidence interval. +Specifying `vline_type = "mean"` (the default) will add vertical lines +indicating the proportions in each treatment group for easier readibility. +Note that `vline_type = "median"` (the default for continuous endpoints) +will result in an error. The same is true for setting `density_plot_type` to +anything other than `"default"`. +```{r fig.width = 7, fig.height = 6} +plot(mar) +``` + + +### Step outcome + +What if the binary outcome is not the last outcome of the hierarchical endpoint +but rather one (or several) of the previous outcomes? So rather than solely having +time-to-event endpoints within the step function part of the plot, we also have +at least one binary (so not time depending) variable. +To include a binary variable, we expect the data for this outcome to include only +patients that had the outcome and they all have to have the original analysis value 1. + +Let's create a dataset with 2 binary outcomes. +```{r} +data("hce_scenario_a") +# Create data with binary version of continuous final endpoint +bin_data2 <- hce_scenario_a +# Index of all continuous outcome rows +idx_bin <- bin_data2$GROUP %in% c("Outcome III", "Outcome IV") +# Binary version (>= 0/< 0), coded as 1 +bin_data2[idx_bin,"AVAL0"] <- bin_data2[idx_bin,"AVAL0"] >= 500 +bin_data2[idx_bin,"AVAL"] <- bin_data2[idx_bin,"AVAL0"] + + bin_data2[idx_bin,"GROUPN"] +# Remove 0 rows (only include patients that had the outcome) +bin_data2 <- bin_data2[bin_data2$AVAL0 != 0,] +head(bin_data2) +``` + +Again we need to slightly update the default code if we want to create a maraca object +for this data. By default, maraca expects all the step outcomes to be time-to-event +endpoints. In order for the function to know that there are binary outcomes, we have to +update the parameter `step_types`. The parameter currently accepts the inputs `"binary"` and +`"tte"`. If all the step outcomes are of the same type, the user can give the type as a string +(such as by default `step_types = "tte"`). If there are different endpoint types, then the user +has to provide a vector with one element for each step outcome. +Similarly, the fixed-follow up time can be given as a single number or a vector. Note that the +fixed-follow-up time is only needed for time-to-event endpoints, so if providing a vector then +it should contain one value for each time-to-event endpoint. +```{r} +column_names <- c( + outcome = "GROUP", + arm = "TRTP", + value = "AVAL0" +) + +step_outcomes <- c("Outcome I", "Outcome II", + "Outcome III", "Outcome IV") + +last_outcome <- "Continuous outcome" + +arm_levels <- c(active = "Active", + control = "Control") + +mar <- maraca( + bin_data2, step_outcomes, last_outcome, + arm_levels, column_names, + fixed_followup_days = 3*365, + compute_win_odds = TRUE, + # Important change: Add information that last endpoint is + # not continuous (the default) + step_types = c("tte","tte","binary","binary") +) +``` + +Again, we can plot the final object. +```{r fig.width = 7, fig.height = 6} +plot(mar) +``` + + +As with all maraca objects, the different plotting parameters can be +used. + +```{r fig.width = 7, fig.height = 6} +plot(mar, continuous_grid_spacing_x = 20, + theme = "color1") +``` + +Also, the win odds plots can be created as usual. +```{r fig.width = 7, fig.height = 6} +component_plot(mar, + theme = "color2") +``` + +```{r fig.width = 7, fig.height = 6} +cumulative_plot(mar, + theme = "color1") +``` + diff --git a/vignettes/winOdds.Rmd b/vignettes/winOdds.Rmd index c9098f0..846021d 100644 --- a/vignettes/winOdds.Rmd +++ b/vignettes/winOdds.Rmd @@ -76,9 +76,51 @@ hce_dat <- simHCE(n = 2500, TTE_A = Rates_A, TTE_P = Rates_P, component_plot(hce_dat) ``` +## Cumulative plot + +Furthermore, there is also a plot called `"cumulative_plot"`. +Similar as above, this plot shows the different components that +make up the win odds calculation. Different to the component plot, +this plot shows the endpoint cumulated instead (adding one +hierarchical endpoint at a time). +As explained above, the plot shows how +often patients in the active arm "won" or "lost" against the other +arm or if they had a "tie". + +As before, in order to use the `cumulative_plot`, we have to first create a +`maraca` object. Important here is to set the argument +`compute_win_odds = TRUE`, so that the necessary calculations +are included. +```{r} +maraca_dat <- maraca( + data = hce_scenario_a, + step_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), + last_outcome = "Continuous outcome", + fixed_followup_days = 3 * 365, + column_names = c(outcome = "GROUP", arm = "TRTP", value = "AVAL0"), + arm_levels = c(active = "Active", control = "Control"), + # Make sure to calculate the win odds + compute_win_odds = TRUE +) +``` + +Now we can just plot the object using the `cumulative_plot()` function. +```{r fig.width=7, fig.height=6} +cumulative_plot(maraca_dat) +``` + +It is also possible to use the `cumulative_plot()` function directly on +an `hce` object (created using the +[hce package](https://cran.r-project.org/package=hce)). + +```{r fig.width=7, fig.height=6} +cumulative_plot(hce_dat) +``` + ## Styling -The resulting plot is a normal ggplot2 object that can be styled accordingly. +The resulting plots for both the `component_plot()` and `cumulative_plot()` functions +are normal ggplot2 objects that can be styled accordingly. There are also different themes available to style the plot. The default style is called `theme = "maraca"`. @@ -89,7 +131,7 @@ component_plot(maraca_dat, theme = "maraca") There are 2 different themes with different color schemes, `theme = "color1"` and `theme = "color2"`. ```{r fig.width=7, fig.height=6} -component_plot(maraca_dat, theme = "color1") +cumulative_plot(maraca_dat, theme = "color1") ``` ```{r fig.width=7, fig.height=6} @@ -98,5 +140,5 @@ component_plot(maraca_dat, theme = "color2") There is also a theme without any styling `theme = "none"`. ```{r fig.width=8, fig.height=6} -component_plot(maraca_dat, theme = "none") +cumulative_plot(maraca_dat, theme = "none") ``` From d98ed038286c1651d6c780df108fcbf7f126d53c Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Wed, 6 Mar 2024 10:26:33 +0000 Subject: [PATCH 25/32] Fix lintr error and small change to ensure ellipsis shape --- R/internal.R | 2 +- R/internal_winOdds.R | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/R/internal.R b/R/internal.R index e765bb3..28fcbe2 100644 --- a/R/internal.R +++ b/R/internal.R @@ -285,7 +285,7 @@ # To create ellipsis shape and avoid overlapping between both of them, # set the height to 80% of the SE (minimum scaled in x-axis or y-axis range) width <- (100 - start_binary_endpoint) * min(binary_meta$se) / 100 - y_range <- ((max(actv_y, ctrl_y) + 10) * min(binary_meta$se) / 100) * 0.6 + y_range <- (max(actv_y, ctrl_y) + 10) * (width / 100) y_height <- min(c(0.4 * abs(actv_y - ctrl_y), 0.8 * min(width, y_range))) # Create ellipsis centered around proportion estimate (x0) as well as diff --git a/R/internal_winOdds.R b/R/internal_winOdds.R index a25bb51..cbc6da8 100644 --- a/R/internal_winOdds.R +++ b/R/internal_winOdds.R @@ -211,7 +211,7 @@ plot <- plot + ggplot2::geom_vline(xintercept = seq(0.5, length(levels(wins_forest$GROUP)) + 1.5, - 1), + 1), linetype = 2, linewidth = 0.3, color = "darkgray") + scale_color_manual(values = c("black", "grey50")) + scale_fill_manual(values = c("black", "grey50")) + @@ -219,8 +219,8 @@ theme_bw() + theme(legend.position = "bottom", legend.title = element_blank(), - panel.grid.major.y = ggplot2::element_blank(), - panel.grid.minor.y = ggplot2::element_blank()) + panel.grid.major.y = ggplot2::element_blank(), + panel.grid.minor.y = ggplot2::element_blank()) } return(plot) From 4eb49ee2833c810405b108e5dc4e413b61883010 Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Mon, 11 Mar 2024 21:38:07 +0000 Subject: [PATCH 26/32] Fix transform x-axis functionality --- R/internal.R | 24 +++- R/internal_winOdds.R | 63 +++++++--- R/maraca.R | 217 ++++++++++++++++++++++++---------- R/winOddsPlots.R | 38 ++++-- man/component_plot.hce.Rd | 8 ++ man/cumulative_plot.hce.Rd | 13 ++ man/cumulative_plot.maraca.Rd | 6 +- man/maraca.Rd | 8 ++ man/plot.hce.Rd | 18 ++- man/plot.maraca.Rd | 10 +- man/plot_maraca.Rd | 10 +- tests/testthat/test_maraca.R | 8 +- 12 files changed, 317 insertions(+), 106 deletions(-) diff --git a/R/internal.R b/R/internal.R index 28fcbe2..e4c714f 100644 --- a/R/internal.R +++ b/R/internal.R @@ -204,6 +204,22 @@ (maxval - minval) + start_continuous_endpoint } +.logTicks <- function(range) { + a <- floor(log2(range[1])) + b <- ceiling(log2(range[2])) + steps <- unique(round(pretty(c(a, b)))) + return((2 ^ steps)) +} + +.log10Ticks <- function(range) { + range <- log10(range) + get_axp <- function(x) 10^c(floor(x[1]), ceiling(x[2])) + n <- ifelse(range[2] > 4, 1, 2) + steps <- axTicks(side = 1, usr = range, axp = c(get_axp(range), n = n), + log = TRUE) + return((steps)) +} + # Computes the continuous information .compute_continuous <- function( hce_dat, meta, ecdf_mod, step_outcomes, last_outcome, arm_levels) { @@ -308,9 +324,11 @@ binary_data <- rbind(data.frame("outcome" = last_outcome, "arm" = actv, + "value" = 1, actv_point), data.frame("outcome" = last_outcome, "arm" = ctrl, + "value" = 1, ctrl_point) ) @@ -438,7 +456,8 @@ .maraca_from_hce_data <- function(x, last_outcome, arm_levels, fixed_followup_days, compute_win_odds, step_types = "tte", - last_type = "continuous") { + last_type = "continuous", + lowerBetter = FALSE) { checkmate::assert_string(last_outcome) checkmate::assert_names(names(x), @@ -478,7 +497,8 @@ fixed_followup_days = fixed_followup_days, compute_win_odds = compute_win_odds, step_types = step_types, - last_type = last_type + last_type = last_type, + lowerBetter = lowerBetter ) return(maraca_obj) diff --git a/R/internal_winOdds.R b/R/internal_winOdds.R index cbc6da8..72279e5 100644 --- a/R/internal_winOdds.R +++ b/R/internal_winOdds.R @@ -35,11 +35,22 @@ # Computes the win odds from the internal data. .compute_win_odds <- function(hce_dat, arm_levels, - step_outcomes, last_outcome) { + step_outcomes, last_outcome, + lowerBetter) { `%>%` <- dplyr::`%>%` hce_dat <- base::as.data.frame(hce_dat) + idx_last <- hce_dat$outcome == last_outcome + + # Reversing continous outcome variables if lower is considered better + if (lowerBetter) { + hce_dat[idx_last, "value"] <- + (min(hce_dat[idx_last, "value"], na.rm = TRUE) - + hce_dat[idx_last, "value"] + + max(hce_dat[idx_last, "value"], na.rm = TRUE)) + } + hce_dat <- .with_ordered_column(hce_dat) fit <- hce::calcWO(x = hce_dat, AVAL = "ordered", TRTP = "arm", @@ -56,7 +67,7 @@ endpoints <- c(step_outcomes, last_outcome) labs <- c(sapply(head(seq_along(endpoints), -1), function(i) { paste(endpoints[1:i], collapse = " +\n") - }), "All") + }), "Overall") hce_dat <- hce_dat %>% dplyr::mutate_at(dplyr::vars(outcome), factor, levels = c(endpoints, "X")) @@ -88,13 +99,17 @@ wo$outcome <- endpoints[i] wo$GROUP <- labs[i] wo %>% - dplyr::rename(dplyr::all_of(c(wins = "WIN", losses = "LOSS", - ties = "TIE"))) %>% - tidyr::pivot_longer(cols = c(wins, losses, ties)) %>% - dplyr::mutate_at(dplyr::vars(name), factor, - levels = c("wins", "losses", "ties")) + dplyr::rename(dplyr::all_of(c(A_wins = "WIN", P_wins = "LOSS", + Ties = "TIE"))) %>% + tidyr::pivot_longer(cols = c("A_wins", "P_wins", "Ties"), + names_to = "name", values_to = "value") + # %>% + # dplyr::mutate_at(dplyr::vars(name), factor, + # levels = c("wins", "losses", "ties")) })) + wo_bar <- .label_win_odds_plots(wo_bar, arm_levels) + wins_forest$GROUP <- factor(wins_forest$GROUP, levels = rev(labs)) wins_forest$method <- factor(wins_forest$method, levels = c("win ratio", "win odds")) @@ -143,21 +158,26 @@ # Calculate percentage results wo_bar_nc$percentage <- 100 * (wo_bar_nc$value / wo_bar_nc$total) + wo_bar_nc <- .label_win_odds_plots(wo_bar_nc, arms) + + return(wo_bar_nc) +} + +.label_win_odds_plots <- function(bar_data, arms) { labels <- c(paste(arms["active"], "wins"), paste(arms["control"], "wins"), "Ties") - wo_bar_nc$name <- ifelse(wo_bar_nc$name == "A_wins", - labels[1], - ifelse(wo_bar_nc$name == "P_wins", - labels[2], labels[3])) + bar_data$name <- ifelse(bar_data$name == "A_wins", + labels[1], + ifelse(bar_data$name == "P_wins", + labels[2], labels[3])) - wo_bar_nc$name <- factor(wo_bar_nc$name, levels = labels) + bar_data$name <- factor(bar_data$name, levels = labels) - return(wo_bar_nc) + return(bar_data) } - # The main plotting function creating the component plot .create_component_plot <- function(wo_bar_nc, endpoints, theme) { @@ -193,7 +213,12 @@ } # Create forest plot part of cumulative plot -.create_forest_plot <- function(wins_forest, theme) { +.create_forest_plot <- function(wins_forest, theme, reverse) { + + if (reverse) { + wins_forest$GROUP <- factor(wins_forest$GROUP, + levels = rev(levels(wins_forest$GROUP))) + } plot <- ggplot(data = wins_forest) + geom_errorbar(aes(x = GROUP, y = value, ymin = LCL, ymax = UCL, @@ -228,14 +253,18 @@ } # Create bar plot part of cumulative plot -.create_bar_plot <- function(wo_bar, theme) { +.create_bar_plot <- function(wo_bar, theme, reverse) { + + if (reverse) { + wo_bar$GROUP <- factor(wo_bar$GROUP, levels = rev(levels(wo_bar$GROUP))) + } plot <- ggplot(data = wo_bar, aes(x = GROUP, y = percentage, fill = name)) + geom_bar(stat = "identity", position = position_dodge(), width = .9) + coord_flip() + # make bar plot horizontal geom_text(aes(label = round(percentage, 1)), position = ggplot2::position_dodge(width = .9), - vjust = 0.5, hjust = 1.2) + vjust = 0.5, hjust = -0.2) plot <- switch(theme, "maraca" = .theme_maraca_cp(plot), diff --git a/R/maraca.R b/R/maraca.R index 5c3423d..3ef0af6 100644 --- a/R/maraca.R +++ b/R/maraca.R @@ -36,6 +36,12 @@ #' @param last_type A single string giving the type of the last outcome. #' Possible values are "continuous" (default), "binary" or #' "multinomial". +#' @param lowerBetter Flag for the final outcome variable, indicating if +#' lower values are considered better/advantageous. +#' This flag is need to make sure the win odds are +#' calculated correctly. +#' Default value is FALSE, meaning higher values +#' are considered advantageous. #' @param tte_outcomes Deprecated and substituted by the more general #' 'step_outcomes'. A vector of strings containing the #' time-to-event outcome labels. The order is kept for the @@ -74,6 +80,7 @@ maraca <- function( compute_win_odds = FALSE, step_types = "tte", last_type = "continuous", + lowerBetter = FALSE, tte_outcomes = lifecycle::deprecated(), continuous_outcome = lifecycle::deprecated() ) { @@ -122,6 +129,8 @@ maraca <- function( choices = c("continuous", "binary"), empty.ok = FALSE) + checkmate::assert_flag(lowerBetter) + if (!(length(fixed_followup_days) %in% c(1, length(step_outcomes[step_types == "tte"])))) { stop(paste("fixed_followup_days needs to be either a single value or", @@ -200,7 +209,8 @@ maraca <- function( "wins_forest" = NULL, "wo_bar" = NULL) if (compute_win_odds) { win_odds <- .compute_win_odds(hce_dat, arm_levels, - step_outcomes, last_outcome) + step_outcomes, last_outcome, + lowerBetter) } return( @@ -219,7 +229,8 @@ maraca <- function( win_odds = win_odds[["win_odds"]], win_odds_outcome = win_odds[["win_odds_outcome"]], wins_forest = win_odds[["wins_forest"]], - wo_bar = win_odds[["wo_bar"]] + wo_bar = win_odds[["wo_bar"]], + lowerBetter = lowerBetter ), class = c("maraca") ) @@ -269,8 +280,10 @@ print.maraca <- function(x, ...) { #' @param obj an object of S3 class 'maraca' #' @param continuous_grid_spacing_x The spacing of the x grid to use for the #' continuous section of the plot. -#' @param trans the transformation to apply to the data before plotting. -#' The accepted values are the same that ggplot2::scale_x_continuous +#' @param trans the transformation to apply to the x-axis scale for the last +#' outcome. Possible values are "identity", "log" (only for continuous +#' endpoint), "log10" (only for continuous endpoint), "sqrt" (only for +#' continuous endpoint) and "reverse". The default value is "identity". #' @param density_plot_type which type of plot to display in the continuous #' part of the plot. Options are "default", "violin", "box", "scatter". #' @param vline_type what the vertical dashed line should represent. Accepts @@ -300,8 +313,8 @@ print.maraca <- function(x, ...) { #' @export plot_maraca <- function( obj, continuous_grid_spacing_x = NULL, - trans = "identity", - density_plot_type = "default", + trans = c("identity", "log", "log10", "sqrt", "reverse")[1], + density_plot_type = c("default", "violin", "box", "scatter")[1], vline_type = NULL, theme = "maraca") { @@ -313,6 +326,10 @@ plot_maraca <- function( } checkmate::assert_string(trans) + checkmate::assert_subset(trans, + choices = c("identity", "log", "log10", + "sqrt", "reverse"), + empty.ok = FALSE) aes <- ggplot2::aes `%>%` <- dplyr::`%>%` @@ -325,6 +342,11 @@ plot_maraca <- function( last_data <- obj$data_last_outcome last_type <- obj$last_type + if (last_type == "binary" && trans %in% c("log", "log10", "sqrt")) { + stop(paste(trans, "transformation only implemented for continuous", + "last endpoint.")) + } + vline_type <- switch(last_type, "continuous" = .checks_continuous_outcome(density_plot_type, @@ -339,16 +361,15 @@ plot_maraca <- function( meta[meta$outcome == obj$last_outcome, ]$startx if (is.null(continuous_grid_spacing_x)) { - continuous_grid_spacing_x <- ifelse(last_type == "continuous", 10, 0.1) + continuous_grid_spacing_x <- 10 } - plotdata_ecdf <- ecdf_mod$data[, c("outcome", "arm", + plotdata_ecdf <- ecdf_mod$data[, c("outcome", "arm", "value", "adjusted.time", "step_values", "type")] - names(plotdata_ecdf) <- c("outcome", "arm", "x", "y", "type") - plotdata_last <- last_data$data[, c("outcome", "arm", "x", "y")] + names(plotdata_ecdf) <- c("outcome", "arm", "value", "x", "y", "type") + plotdata_last <- last_data$data[, c("outcome", "arm", "value", "x", "y")] plotdata_last$type <- last_type - names(plotdata_last) <- c("outcome", "arm", "x", "y", "type") # Add points at (0, 0) on both curves so that they start from the origin add_points <- plotdata_ecdf %>% @@ -399,7 +420,7 @@ plot_maraca <- function( plotdata_ecdf <- plotdata_ecdf[order(plotdata_ecdf$x), ] - plotdata <- as.data.frame(rbind(plotdata_ecdf, plotdata_last)) + plotdata <- rbind(plotdata_ecdf, plotdata_last) scale <- sign(log10(continuous_grid_spacing_x)) * floor( abs(log10(continuous_grid_spacing_x)) @@ -407,18 +428,78 @@ plot_maraca <- function( if (last_type == "continuous") { - minor_grid <- .minor_grid( - last_data$data$value, scale, continuous_grid_spacing_x - ) - - range <- c(min(last_data$data$value, na.rm = TRUE), - max(last_data$data$value, na.rm = TRUE)) + range <- c(min(plotdata_last$value, na.rm = TRUE), + max(plotdata_last$value, na.rm = TRUE)) + + if (trans %in% c("log", "log10", "sqrt")) { + minor_grid <- switch(trans, + "log" = .logTicks(range), + "log10" = .log10Ticks(range), + "sqrt" = pretty(range)) + minor_grid <- minor_grid[minor_grid >= range[1] & + minor_grid <= range[2]] + minor_grid_x <- eval(parse(text = paste0(trans, "(minor_grid)"))) + } else { + minor_grid <- .minor_grid(plotdata_last$value, scale, + continuous_grid_spacing_x) + minor_grid_x <- minor_grid + } } else if (last_type == "binary") { - minor_grid <- seq(0, 100, continuous_grid_spacing_x) - range <- c(0, 100) + lowest_value <- min(plotdata_last$value, na.rm = TRUE) + highest_value <- max(plotdata_last$value, na.rm = TRUE) + range <- c(min(0, floor(lowest_value / 10) * 10), + max(100, ceiling(highest_value / 10) * 10)) + minor_grid <- seq(range[1], range[2], continuous_grid_spacing_x) + minor_grid_x <- minor_grid + + } + + vline_data <- NULL + if (vline_type == "median") { + vline_data <- last_data$meta %>% + dplyr::select("x" = median, arm) + } else if (vline_type == "mean") { + vline_data <- last_data$meta %>% + dplyr::select("x" = median, arm) + } + + if (trans %in% c("log", "log10", "sqrt")) { + if (range[1] < 0) { + warning(paste("Continuous endpoint has negative values - the", + trans, "transformation will result in missing values")) + } + plotdata_last$value <- eval(parse(text = paste0(trans, + "(plotdata_last$value)"))) + range <- c(min(plotdata_last$value, na.rm = TRUE), + max(plotdata_last$value, na.rm = TRUE)) + plotdata_last$x <- .to_rangeab(plotdata_last$value, start_last_endpoint, + range[1], range[2]) + + if (!is.null(vline_data)) { + vline_data$x <- eval(parse(text = paste0(trans, "(vline_data$x)"))) + } + } + + if (trans == "reverse") { + if (!is.null(win_odds) && !obj$lowerBetter) { + message(paste("Last endpoint axis has been reversed, which might", + "indicate that lower values are considered advantageuos.", + "Note that the win odds were calculated assuming that", + "higher values are better. If that is not correct, please", + "use the parameter lowerBetter = TRUE in the", + "maraca function.")) + } + + minor_grid_x <- rev(minor_grid_x) + minor_grid <- rev(minor_grid) + plotdata_last$x <- start_last_endpoint - plotdata_last$x + 100 + + if (!is.null(vline_data)) { + vline_data$x <- start_last_endpoint - plotdata_last$x + 100 + } } # Plot the information in the Maraca plot @@ -428,26 +509,14 @@ plot_maraca <- function( color = "grey80" ) - if (vline_type == "median") { - plot <- plot + - ggplot2::geom_vline( - mapping = ggplot2::aes( - xintercept = median, - color = arm - ), - data = last_data$meta, - linetype = "dashed", - linewidth = 0.8, - show.legend = FALSE - ) - } else if (vline_type == "mean") { + if (!is.null(vline_data)) { plot <- plot + ggplot2::geom_vline( mapping = ggplot2::aes( - xintercept = average, + xintercept = x, color = arm ), - data = last_data$meta, + data = vline_data, linetype = "dashed", linewidth = 0.8, show.legend = FALSE @@ -456,14 +525,15 @@ plot_maraca <- function( for (outcome in step_outcomes[which_tte]) { plot <- plot + - ggplot2::geom_step(data = plotdata[plotdata$outcome == outcome, ], + ggplot2::geom_step(data = + plotdata_ecdf[plotdata_ecdf$outcome == outcome, ], aes(x = x, y = y, color = arm)) } if (length(which_binary) > 0) { - tmp <- plotdata[plotdata$outcome %in% step_outcomes[which_binary], ] - + tmp <- plotdata_ecdf[plotdata_ecdf$outcome %in% + step_outcomes[which_binary], ] tmp <- tmp[order(tmp$x), ] if (step_types[length(step_types)] == "binary") { @@ -500,7 +570,7 @@ plot_maraca <- function( if (step_types[length(step_types)] == "binary") { - tmp <- plotdata %>% + tmp <- plotdata_ecdf %>% dplyr::filter(outcome == step_outcomes[length(step_types)]) %>% dplyr::group_by(arm) %>% dplyr::slice_tail(n = -1) %>% @@ -543,19 +613,19 @@ plot_maraca <- function( } else if (density_plot_type == "violin") { plot <- plot + ggplot2::geom_violin( - data = plotdata[plotdata$type == "continuous", ], + data = plotdata_last, aes(x = x, y = y, colour = arm, fill = arm), alpha = 0.5 ) } else if (density_plot_type == "box") { plot <- plot + ggplot2::geom_boxplot( - data = plotdata[plotdata$type == "continuous", ], + data = plotdata_last, aes(x = x, y = y, colour = arm, fill = arm), alpha = 0.5 ) } else if (density_plot_type == "scatter") { plot <- plot + ggplot2::geom_jitter( - data = plotdata[plotdata$type == "continuous", ], + data = plotdata_last, aes(x = x, y = y, color = arm), # Jittering only vertically, keep the correct x-value width = 0 @@ -569,27 +639,28 @@ plot_maraca <- function( return(as.character(round(x, -s + 1))) } ) + + m_breaks <- .to_rangeab( + minor_grid_x, + start_last_endpoint, + range[1], + range[2] + ) + + if (trans == "reverse") { + m_breaks <- start_last_endpoint - m_breaks + 100 + } + plot <- plot + ggplot2::scale_x_continuous( limits = c(0, 100), breaks = c(meta$proportion / 2 + meta$startx + 0.1), labels = c(obj$step_outcomes, obj$last_outcome), - minor_breaks = .to_rangeab( - minor_grid, - start_last_endpoint, - range[1], - range[2] - ), - trans = trans + minor_breaks = m_breaks ) + ggplot2::annotate( geom = "text", - x = .to_rangeab( - minor_grid, - start_last_endpoint, - range[1], - range[2] - ), + x = m_breaks, y = 0, label = labels, color = "grey60" @@ -667,7 +738,7 @@ validate_maraca_plot <- function(x, ...) { proportions <- diff(pb$data[[1]][, c("xintercept")]) names(proportions) <- unique(x$data$outcome) - arms <- levels(pb$plot$data[, pb$plot$labels$colour]) + arms <- levels(unlist(pb$plot$data[, pb$plot$labels$colour])) tte_data <- .create_validation_tte(layers, x, arms) binary_step_data <- .create_validation_binary_step(layers, x, arms) @@ -711,8 +782,10 @@ validate_maraca_plot <- function(x, ...) { #' @param \dots not used #' @param continuous_grid_spacing_x The spacing of the x grid to use for the #' continuous section of the plot. -#' @param trans the transformation to apply to the data before plotting. -#' The accepted values are the same that ggplot2::scale_x_continuous +#' @param trans the transformation to apply to the x-axis scale for the last +#' outcome. Possible values are "identity", "log" (only for continuous +#' endpoint), "log10" (only for continuous endpoint), "sqrt" (only for +#' continuous endpoint) and "reverse". The default value is "identity". #' @param density_plot_type The type of plot to use to represent the density. #' Accepts "default", "violin", "box" and "scatter". #' @param vline_type what the vertical dashed line should represent. Accepts @@ -741,8 +814,10 @@ validate_maraca_plot <- function(x, ...) { #' #' @export plot.maraca <- function( - x, continuous_grid_spacing_x = 10, trans = "identity", - density_plot_type = "default", + x, + continuous_grid_spacing_x = 10, + trans = c("identity", "log", "log10", "sqrt", "reverse")[1], + density_plot_type = c("default", "violin", "box", "scatter")[1], vline_type = NULL, theme = "maraca", ...) { @@ -765,8 +840,10 @@ plot.maraca <- function( #' "active" and "control". #' @param continuous_grid_spacing_x The spacing of the x grid to use for the #' continuous section of the plot. -#' @param trans the transformation to apply to the data before plotting. -#' The accepted values are the same that ggplot2::scale_x_continuous +#' @param trans the transformation to apply to the x-axis scale for the last +#' outcome. Possible values are "identity", "log" (only for continuous +#' endpoint), "log10" (only for continuous endpoint), "sqrt" (only for +#' continuous endpoint) and "reverse". The default value is "identity". #' @param density_plot_type The type of plot to use to represent the density. #' Accepts "default", "violin", "box" and "scatter". #' @param vline_type what the vertical dashed line should represent. Accepts @@ -796,6 +873,12 @@ plot.maraca <- function( #' For more details, check the vignette called #' "Maraca Plots - Themes and Styling". #' [companion vignette for package users](themes.html) +#' @param lowerBetter Flag for the final outcome variable, indicating if +#' lower values are considered better/advantageous. +#' This flag is need to make sure the win odds are +#' calculated correctly. +#' Default value is FALSE, meaning higher values +#' are considered advantageous. #' @param continuous_outcome Deprecated and substituted by the more general #' 'last_outcome'. A single string containing the #' continuous outcome label. @@ -814,14 +897,17 @@ plot.maraca <- function( plot.hce <- function(x, last_outcome = "C", arm_levels = c(active = "A", control = "P"), continuous_grid_spacing_x = 10, - trans = "identity", - density_plot_type = "default", + trans = c("identity", "log", "log10", + "sqrt", "reverse")[1], + density_plot_type = c("default", "violin", + "box", "scatter")[1], vline_type = NULL, fixed_followup_days = NULL, compute_win_odds = FALSE, step_types = "tte", last_type = "continuous", theme = "maraca", + lowerBetter = FALSE, continuous_outcome = lifecycle::deprecated(), ...) { @@ -835,7 +921,8 @@ plot.hce <- function(x, last_outcome = "C", fixed_followup_days, compute_win_odds, step_types = step_types, - last_type = last_type) + last_type = last_type, + lowerBetter = lowerBetter) plot_maraca(maraca_obj, continuous_grid_spacing_x, trans, density_plot_type, vline_type, theme) diff --git a/R/winOddsPlots.R b/R/winOddsPlots.R index 5cec958..e82a90d 100644 --- a/R/winOddsPlots.R +++ b/R/winOddsPlots.R @@ -110,6 +110,12 @@ component_plot.maraca <- function(x, #' Options are "maraca", "color1", "color2" and none". #' For more details, check the vignette called #' "Maraca Plots - Plotting win odds". +#' @param lowerBetter Flag for the final outcome variable, indicating if +#' lower values are considered better/advantageous. +#' This flag is need to make sure the win odds are +#' calculated correctly. +#' Default value is FALSE, meaning higher values +#' are considered advantageous. #' @param continuous_outcome Deprecated and substituted by the more general #' 'last_outcome'. A single string containing the #' continuous outcome label. @@ -128,13 +134,15 @@ component_plot.hce <- function(x, last_outcome = "C", arm_levels = c(active = "A", control = "P"), fixed_followup_days = NULL, theme = "maraca", + lowerBetter = FALSE, continuous_outcome = lifecycle::deprecated(), ...) { # Create maraca object maraca_dat <- .maraca_from_hce_data(x, last_outcome, arm_levels, fixed_followup_days, - compute_win_odds = TRUE) + compute_win_odds = TRUE, + lowerBetter = lowerBetter) # Get win odds by outcome from maraca object win_odds_outcome <- maraca_dat$win_odds_outcome @@ -182,11 +190,14 @@ cumulative_plot.default <- function(x, ...) { #' Check the vignette "Maraca Plots - Plotting win odds" for more details. #' #' @param x an object of S3 class 'maraca'. -#' @param \dots not used #' @param theme Choose theme to style the plot. The default theme is "maraca". #' Options are "maraca", "color1", "color2" and none". #' For more details, check the vignette called #' "Maraca Plots - Plotting win odds". +#' @param reverse Flag indicating if the cumulated outcomes should be +#' displayed in order from top to bottom (FALSE, the default) +#' or in reverse (TRUE). +#' @param \dots not used #' @return Cumulative plot as a patchwork object. #' @examples #' @@ -208,7 +219,8 @@ cumulative_plot.default <- function(x, ...) { #' cumulative_plot(maraca_dat) #' #' @export -cumulative_plot.maraca <- function(x, theme = "maraca", ...) { +cumulative_plot.maraca <- function(x, theme = "maraca", + reverse = FALSE, ...) { # Check that win odds were calculated for the maraca object if (is.null(x[["wins_forest"]]) || is.null(x[["wo_bar"]])) { @@ -221,8 +233,8 @@ cumulative_plot.maraca <- function(x, theme = "maraca", ...) { wo_bar <- x$wo_bar wins_forest <- x$wins_forest # Create forest plot - plot_bar <- .create_bar_plot(wo_bar, theme) - plot_forest <- .create_forest_plot(wins_forest, theme) + plot_bar <- .create_bar_plot(wo_bar, theme, reverse) + plot_forest <- .create_forest_plot(wins_forest, theme, reverse) plot <- patchwork:::"|.ggplot"(plot_bar, plot_forest) + patchwork::plot_layout(widths = c(2.5, 1), nrow = 1) @@ -261,6 +273,15 @@ cumulative_plot.maraca <- function(x, theme = "maraca", ...) { #' Options are "maraca", "color1", "color2" and none". #' For more details, check the vignette called #' "Maraca Plots - Plotting win odds". +#' @param reverse Flag indicating if the cumulated outcomes should be +#' displayed in order from top to bottom (FALSE, the default) +#' or in reverse (TRUE). +#' @param lowerBetter Flag for the final outcome variable, indicating if +#' lower values are considered better/advantageous. +#' This flag is need to make sure the win odds are +#' calculated correctly. +#' Default value is FALSE, meaning higher values +#' are considered advantageous. #' @param continuous_outcome Deprecated and substituted by the more general #' 'last_outcome'. A single string containing the #' continuous outcome label. @@ -279,15 +300,18 @@ cumulative_plot.hce <- function(x, last_outcome = "C", arm_levels = c(active = "A", control = "P"), fixed_followup_days = NULL, theme = "maraca", + reverse = FALSE, + lowerBetter = FALSE, continuous_outcome = lifecycle::deprecated(), ...) { # Create maraca object maraca_dat <- .maraca_from_hce_data(x, last_outcome, arm_levels, fixed_followup_days, - compute_win_odds = TRUE) + compute_win_odds = TRUE, + lowerBetter = lowerBetter) - plot <- cumulative_plot(maraca_dat, theme = theme) + plot <- cumulative_plot(maraca_dat, theme = theme, reverse = reverse) return(plot) } diff --git a/man/component_plot.hce.Rd b/man/component_plot.hce.Rd index 43008fd..8b676fc 100644 --- a/man/component_plot.hce.Rd +++ b/man/component_plot.hce.Rd @@ -13,6 +13,7 @@ Check the vignette "Maraca Plots - Plotting win odds" for more details.} arm_levels = c(active = "A", control = "P"), fixed_followup_days = NULL, theme = "maraca", + lowerBetter = FALSE, continuous_outcome = lifecycle::deprecated(), ... ) @@ -45,6 +46,13 @@ Options are "maraca", "color1", "color2" and none". For more details, check the vignette called "Maraca Plots - Plotting win odds".} +\item{lowerBetter}{Flag for the final outcome variable, indicating if +lower values are considered better/advantageous. +This flag is need to make sure the win odds are +calculated correctly. +Default value is FALSE, meaning higher values +are considered advantageous.} + \item{continuous_outcome}{Deprecated and substituted by the more general 'last_outcome'. A single string containing the continuous outcome label.} diff --git a/man/cumulative_plot.hce.Rd b/man/cumulative_plot.hce.Rd index 82f27e7..13973b1 100644 --- a/man/cumulative_plot.hce.Rd +++ b/man/cumulative_plot.hce.Rd @@ -13,6 +13,8 @@ Check the vignette "Maraca Plots - Plotting win odds" for more details.} arm_levels = c(active = "A", control = "P"), fixed_followup_days = NULL, theme = "maraca", + reverse = FALSE, + lowerBetter = FALSE, continuous_outcome = lifecycle::deprecated(), ... ) @@ -45,6 +47,17 @@ Options are "maraca", "color1", "color2" and none". For more details, check the vignette called "Maraca Plots - Plotting win odds".} +\item{reverse}{Flag indicating if the cumulated outcomes should be +displayed in order from top to bottom (FALSE, the default) +or in reverse (TRUE).} + +\item{lowerBetter}{Flag for the final outcome variable, indicating if +lower values are considered better/advantageous. +This flag is need to make sure the win odds are +calculated correctly. +Default value is FALSE, meaning higher values +are considered advantageous.} + \item{continuous_outcome}{Deprecated and substituted by the more general 'last_outcome'. A single string containing the continuous outcome label.} diff --git a/man/cumulative_plot.maraca.Rd b/man/cumulative_plot.maraca.Rd index f400843..a268459 100644 --- a/man/cumulative_plot.maraca.Rd +++ b/man/cumulative_plot.maraca.Rd @@ -9,7 +9,7 @@ Note that for this plot, when creating the maraca object using the maraca() function, the argument "compute_win_odds" has to be set to TRUE. Check the vignette "Maraca Plots - Plotting win odds" for more details.} \usage{ -\method{cumulative_plot}{maraca}(x, theme = "maraca", ...) +\method{cumulative_plot}{maraca}(x, theme = "maraca", reverse = FALSE, ...) } \arguments{ \item{x}{an object of S3 class 'maraca'.} @@ -19,6 +19,10 @@ Options are "maraca", "color1", "color2" and none". For more details, check the vignette called "Maraca Plots - Plotting win odds".} +\item{reverse}{Flag indicating if the cumulated outcomes should be +displayed in order from top to bottom (FALSE, the default) +or in reverse (TRUE).} + \item{\dots}{not used} } \value{ diff --git a/man/maraca.Rd b/man/maraca.Rd index 20e698d..78e73e6 100644 --- a/man/maraca.Rd +++ b/man/maraca.Rd @@ -17,6 +17,7 @@ maraca( compute_win_odds = FALSE, step_types = "tte", last_type = "continuous", + lowerBetter = FALSE, tte_outcomes = lifecycle::deprecated(), continuous_outcome = lifecycle::deprecated() ) @@ -68,6 +69,13 @@ in the vector are "tte" (default) or "binary".} Possible values are "continuous" (default), "binary" or "multinomial".} +\item{lowerBetter}{Flag for the final outcome variable, indicating if +lower values are considered better/advantageous. +This flag is need to make sure the win odds are +calculated correctly. +Default value is FALSE, meaning higher values +are considered advantageous.} + \item{tte_outcomes}{Deprecated and substituted by the more general 'step_outcomes'. A vector of strings containing the time-to-event outcome labels. The order is kept for the diff --git a/man/plot.hce.Rd b/man/plot.hce.Rd index 6564d63..ab0f862 100644 --- a/man/plot.hce.Rd +++ b/man/plot.hce.Rd @@ -9,14 +9,15 @@ last_outcome = "C", arm_levels = c(active = "A", control = "P"), continuous_grid_spacing_x = 10, - trans = "identity", - density_plot_type = "default", + trans = c("identity", "log", "log10", "sqrt", "reverse")[1], + density_plot_type = c("default", "violin", "box", "scatter")[1], vline_type = NULL, fixed_followup_days = NULL, compute_win_odds = FALSE, step_types = "tte", last_type = "continuous", theme = "maraca", + lowerBetter = FALSE, continuous_outcome = lifecycle::deprecated(), ... ) @@ -38,8 +39,10 @@ be specified if you have labels different from \item{continuous_grid_spacing_x}{The spacing of the x grid to use for the continuous section of the plot.} -\item{trans}{the transformation to apply to the data before plotting. -The accepted values are the same that ggplot2::scale_x_continuous} +\item{trans}{the transformation to apply to the x-axis scale for the last +outcome. Possible values are "identity", "log" (only for continuous +endpoint), "log10" (only for continuous endpoint), "sqrt" (only for +continuous endpoint) and "reverse". The default value is "identity".} \item{density_plot_type}{The type of plot to use to represent the density. Accepts "default", "violin", "box" and "scatter".} @@ -76,6 +79,13 @@ For more details, check the vignette called "Maraca Plots - Themes and Styling". [companion vignette for package users](themes.html)} +\item{lowerBetter}{Flag for the final outcome variable, indicating if +lower values are considered better/advantageous. +This flag is need to make sure the win odds are +calculated correctly. +Default value is FALSE, meaning higher values +are considered advantageous.} + \item{continuous_outcome}{Deprecated and substituted by the more general 'last_outcome'. A single string containing the continuous outcome label.} diff --git a/man/plot.maraca.Rd b/man/plot.maraca.Rd index a05c92d..3e26618 100644 --- a/man/plot.maraca.Rd +++ b/man/plot.maraca.Rd @@ -7,8 +7,8 @@ \method{plot}{maraca}( x, continuous_grid_spacing_x = 10, - trans = "identity", - density_plot_type = "default", + trans = c("identity", "log", "log10", "sqrt", "reverse")[1], + density_plot_type = c("default", "violin", "box", "scatter")[1], vline_type = NULL, theme = "maraca", ... @@ -20,8 +20,10 @@ \item{continuous_grid_spacing_x}{The spacing of the x grid to use for the continuous section of the plot.} -\item{trans}{the transformation to apply to the data before plotting. -The accepted values are the same that ggplot2::scale_x_continuous} +\item{trans}{the transformation to apply to the x-axis scale for the last +outcome. Possible values are "identity", "log" (only for continuous +endpoint), "log10" (only for continuous endpoint), "sqrt" (only for +continuous endpoint) and "reverse". The default value is "identity".} \item{density_plot_type}{The type of plot to use to represent the density. Accepts "default", "violin", "box" and "scatter".} diff --git a/man/plot_maraca.Rd b/man/plot_maraca.Rd index d48954c..207c820 100644 --- a/man/plot_maraca.Rd +++ b/man/plot_maraca.Rd @@ -7,8 +7,8 @@ plot_maraca( obj, continuous_grid_spacing_x = NULL, - trans = "identity", - density_plot_type = "default", + trans = c("identity", "log", "log10", "sqrt", "reverse")[1], + density_plot_type = c("default", "violin", "box", "scatter")[1], vline_type = NULL, theme = "maraca" ) @@ -19,8 +19,10 @@ plot_maraca( \item{continuous_grid_spacing_x}{The spacing of the x grid to use for the continuous section of the plot.} -\item{trans}{the transformation to apply to the data before plotting. -The accepted values are the same that ggplot2::scale_x_continuous} +\item{trans}{the transformation to apply to the x-axis scale for the last +outcome. Possible values are "identity", "log" (only for continuous +endpoint), "log10" (only for continuous endpoint), "sqrt" (only for +continuous endpoint) and "reverse". The default value is "identity".} \item{density_plot_type}{which type of plot to display in the continuous part of the plot. Options are "default", "violin", "box", "scatter".} diff --git a/tests/testthat/test_maraca.R b/tests/testthat/test_maraca.R index b6900d0..c1a118d 100644 --- a/tests/testthat/test_maraca.R +++ b/tests/testthat/test_maraca.R @@ -517,7 +517,8 @@ test_that("winOddsData", { ) win_odds_list <- .compute_win_odds(data, arm_levels, - step_outcomes, last_outcome) + step_outcomes, last_outcome, + lowerBetter = FALSE) win_odds <- win_odds_list[["win_odds"]] expect_equal(class(win_odds), "numeric") @@ -1095,8 +1096,11 @@ test_that("gridSpacing", { test_that("scaleTransform", { file <- fixture_path("hce_scenario_c.csv") args <- .maraca_args(file) + dat <- args$data + dat[dat$GROUP == "Continuous outcome", "AVAL0"] <- + dat[dat$GROUP == "Continuous outcome", "AVAL0"] + 50 mar <- maraca( - args$data, + dat, args$step_outcomes, args$last_outcome, args$arm_levels, From c200f6a0dcbb85ebce0c88030f95b6a9e7701f02 Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Mon, 11 Mar 2024 21:57:19 +0000 Subject: [PATCH 27/32] Fix lintr error --- R/internal_winOdds.R | 8 ++++---- R/maraca.R | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/R/internal_winOdds.R b/R/internal_winOdds.R index 72279e5..7dffa1b 100644 --- a/R/internal_winOdds.R +++ b/R/internal_winOdds.R @@ -47,8 +47,8 @@ if (lowerBetter) { hce_dat[idx_last, "value"] <- (min(hce_dat[idx_last, "value"], na.rm = TRUE) - - hce_dat[idx_last, "value"] + - max(hce_dat[idx_last, "value"], na.rm = TRUE)) + hce_dat[idx_last, "value"] + + max(hce_dat[idx_last, "value"], na.rm = TRUE)) } hce_dat <- .with_ordered_column(hce_dat) @@ -102,7 +102,7 @@ dplyr::rename(dplyr::all_of(c(A_wins = "WIN", P_wins = "LOSS", Ties = "TIE"))) %>% tidyr::pivot_longer(cols = c("A_wins", "P_wins", "Ties"), - names_to = "name", values_to = "value") + names_to = "name", values_to = "value") # %>% # dplyr::mutate_at(dplyr::vars(name), factor, # levels = c("wins", "losses", "ties")) @@ -171,7 +171,7 @@ bar_data$name <- ifelse(bar_data$name == "A_wins", labels[1], ifelse(bar_data$name == "P_wins", - labels[2], labels[3])) + labels[2], labels[3])) bar_data$name <- factor(bar_data$name, levels = labels) diff --git a/R/maraca.R b/R/maraca.R index 3ef0af6..13a25a4 100644 --- a/R/maraca.R +++ b/R/maraca.R @@ -433,9 +433,9 @@ plot_maraca <- function( if (trans %in% c("log", "log10", "sqrt")) { minor_grid <- switch(trans, - "log" = .logTicks(range), - "log10" = .log10Ticks(range), - "sqrt" = pretty(range)) + "log" = .logTicks(range), + "log10" = .log10Ticks(range), + "sqrt" = pretty(range)) minor_grid <- minor_grid[minor_grid >= range[1] & minor_grid <= range[2]] minor_grid_x <- eval(parse(text = paste0(trans, "(minor_grid)"))) @@ -645,7 +645,7 @@ plot_maraca <- function( start_last_endpoint, range[1], range[2] - ) + ) if (trans == "reverse") { m_breaks <- start_last_endpoint - m_breaks + 100 From 6d5a5de5b994dfda4c7baae1df5bd18cb7d680ea Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Tue, 12 Mar 2024 19:49:58 +0000 Subject: [PATCH 28/32] Add tests for new functionalities --- R/aaa.R | 6 +- R/internal.R | 34 ++-- R/internal_validation.R | 9 +- R/internal_winOdds.R | 4 +- R/maraca.R | 12 +- R/themes.R | 4 +- tests/testthat/test_maraca.R | 365 ++++++++++++++++++++++++++++++++++- 7 files changed, 398 insertions(+), 36 deletions(-) diff --git a/R/aaa.R b/R/aaa.R index 5fa9513..73aaecd 100644 --- a/R/aaa.R +++ b/R/aaa.R @@ -26,6 +26,7 @@ utils::globalVariables("continuous_outcome") utils::globalVariables("treatments") utils::globalVariables("fixed_followup_days") utils::globalVariables("average") +utils::globalVariables("estimate") utils::globalVariables("value") utils::globalVariables("percentage") utils::globalVariables("name") @@ -53,12 +54,7 @@ utils::globalVariables("WIN_A") utils::globalVariables("WIN_P") utils::globalVariables("TIE_A") utils::globalVariables("linetype") -utils::globalVariables("wins") -utils::globalVariables("losses") -utils::globalVariables("ties") utils::globalVariables("method") utils::globalVariables("UCL") utils::globalVariables("LCL") -utils::globalVariables("wins") -utils::globalVariables("losses") utils::globalVariables("tot") diff --git a/R/internal.R b/R/internal.R index e4c714f..f9a7299 100644 --- a/R/internal.R +++ b/R/internal.R @@ -212,6 +212,9 @@ } .log10Ticks <- function(range) { + if (range[1] <= 0) { + range[1] <- 0.0000001 + } range <- log10(range) get_axp <- function(x) 10^c(floor(x[1]), ceiling(x[2])) n <- ifelse(range[2] > 4, 1, 2) @@ -291,16 +294,16 @@ dplyr::group_by(arm) %>% dplyr::summarise(n = n(), x = base::sum(value, na.rm = TRUE), - average = 100 * + estimate = 100 * as.numeric(stats::prop.test(x, n)$estimate), - se = abs(average - + ci_diff = abs(estimate - (100 * as.numeric(stats::prop.test(x, n)$conf.int)[1]) )) %>% dplyr::ungroup() # To create ellipsis shape and avoid overlapping between both of them, - # set the height to 80% of the SE (minimum scaled in x-axis or y-axis range) - width <- (100 - start_binary_endpoint) * min(binary_meta$se) / 100 + # set the height to 80% of the CI (minimum scaled in x-axis or y-axis range) + width <- (100 - start_binary_endpoint) * min(binary_meta$ci_diff) / 100 y_range <- (max(actv_y, ctrl_y) + 10) * (width / 100) y_height <- min(c(0.4 * abs(actv_y - ctrl_y), 0.8 * min(width, y_range))) @@ -309,17 +312,17 @@ # with the standard error as width and the height as calculated above actv_point <- .create_ellipsis_points(unlist(binary_meta[binary_meta$arm == actv, - "average"]), + "estimate"]), actv_y, unlist(binary_meta[binary_meta$arm == actv, - "se"]), + "ci_diff"]), y_height) ctrl_point <- .create_ellipsis_points(unlist(binary_meta[binary_meta$arm == ctrl, - "average"]), + "estimate"]), ctrl_y, unlist(binary_meta[binary_meta$arm == ctrl, - "se"]), + "ci_diff"]), y_height) binary_data <- rbind(data.frame("outcome" = last_outcome, @@ -332,18 +335,23 @@ ctrl_point) ) + lowest_value <- binary_meta$estimate - binary_meta$ci_diff + highest_value <- binary_meta$estimate + binary_meta$ci_diff + x_range <- c(min(0, floor(lowest_value / 10) * 10), + max(100, ceiling(highest_value / 10) * 10)) + binary_data$x <- .to_rangeab( binary_data$x, start_binary_endpoint, - 0, - 100 + x_range[1], + x_range[2] ) binary_meta$average <- .to_rangeab( - binary_meta$average, + binary_meta$estimate, start_binary_endpoint, - 0, - 100 + x_range[1], + x_range[2] ) binary_meta$y <- 0 diff --git a/R/internal_validation.R b/R/internal_validation.R index a964534..61d2831 100644 --- a/R/internal_validation.R +++ b/R/internal_validation.R @@ -29,6 +29,8 @@ .create_validation_binary_step <- function(layers, x, arms) { + `%>%` <- dplyr::`%>%` + binary_layers <- which(layers == "GeomSegment") if (length(binary_layers) != 0) { @@ -60,6 +62,8 @@ .create_validation_binary_last <- function(layers, x, arms) { + `%>%` <- dplyr::`%>%` + polygon_layers <- which(layers == "GeomPolygon") point_layers <- which(layers == "GeomPoint") @@ -73,12 +77,11 @@ polygon_data <- polygon_data %>% dplyr::filter(y %in% point_data$y) %>% dplyr::group_by(group) %>% - dplyr::summarise("lower_se" = base::min(x, na.rm = TRUE), - "upper_se" = base::max(x, na.rm = TRUE)) + dplyr::summarise("lower_ci" = base::min(x, na.rm = TRUE), + "upper_ci" = base::max(x, na.rm = TRUE)) binary_data <- dplyr::left_join(point_data, polygon_data, by = "group") - binary_data$se <- binary_data$x - binary_data$lower_se binary_data$group <- factor(binary_data$group, labels = arms) } else { diff --git a/R/internal_winOdds.R b/R/internal_winOdds.R index 7dffa1b..edebf0c 100644 --- a/R/internal_winOdds.R +++ b/R/internal_winOdds.R @@ -260,10 +260,10 @@ } plot <- ggplot(data = wo_bar, aes(x = GROUP, y = percentage, fill = name)) + - geom_bar(stat = "identity", position = position_dodge(), width = .9) + + geom_bar(stat = "identity", position = position_dodge(), width = .8) + coord_flip() + # make bar plot horizontal geom_text(aes(label = round(percentage, 1)), - position = ggplot2::position_dodge(width = .9), + position = ggplot2::position_dodge(width = .8), vjust = 0.5, hjust = -0.2) plot <- switch(theme, diff --git a/R/maraca.R b/R/maraca.R index 13a25a4..c575217 100644 --- a/R/maraca.R +++ b/R/maraca.R @@ -447,8 +447,8 @@ plot_maraca <- function( } else if (last_type == "binary") { - lowest_value <- min(plotdata_last$value, na.rm = TRUE) - highest_value <- max(plotdata_last$value, na.rm = TRUE) + lowest_value <- last_data$meta$estimate - last_data$meta$ci_diff + highest_value <- last_data$meta$estimate + last_data$meta$ci_diff range <- c(min(0, floor(lowest_value / 10) * 10), max(100, ceiling(highest_value / 10) * 10)) minor_grid <- seq(range[1], range[2], continuous_grid_spacing_x) @@ -462,14 +462,14 @@ plot_maraca <- function( dplyr::select("x" = median, arm) } else if (vline_type == "mean") { vline_data <- last_data$meta %>% - dplyr::select("x" = median, arm) + dplyr::select("x" = average, arm) } if (trans %in% c("log", "log10", "sqrt")) { if (range[1] < 0) { warning(paste("Continuous endpoint has negative values - the", - trans, "transformation will result in missing values")) + trans, "transformation will result in missing values.")) } plotdata_last$value <- eval(parse(text = paste0(trans, "(plotdata_last$value)"))) @@ -486,7 +486,7 @@ plot_maraca <- function( if (trans == "reverse") { if (!is.null(win_odds) && !obj$lowerBetter) { message(paste("Last endpoint axis has been reversed, which might", - "indicate that lower values are considered advantageuos.", + "indicate that lower values are considered advantageous.", "Note that the win odds were calculated assuming that", "higher values are better. If that is not correct, please", "use the parameter lowerBetter = TRUE in the", @@ -498,7 +498,7 @@ plot_maraca <- function( plotdata_last$x <- start_last_endpoint - plotdata_last$x + 100 if (!is.null(vline_data)) { - vline_data$x <- start_last_endpoint - plotdata_last$x + 100 + vline_data$x <- start_last_endpoint - vline_data$x + 100 } } diff --git a/R/themes.R b/R/themes.R index d34ab48..d97ed91 100644 --- a/R/themes.R +++ b/R/themes.R @@ -25,8 +25,8 @@ ggplot2::geom_vline(xintercept = seq(0.5, n + 1.5, 1), linetype = 2, linewidth = 0.3, color = "darkgray") + # Axis showing percentages - ggplot2::scale_y_continuous(labels = - function(x) paste0(round(x, 2), "%")) + + ggplot2::scale_y_continuous(labels = function(x) paste0(round(x, 2), "%"), + expand = expansion(mult = c(0, .2))) + ggplot2::ylab("Percent of all comparisons") + ggplot2::theme_bw() + ggplot2::theme(legend.position = "bottom", diff --git a/tests/testthat/test_maraca.R b/tests/testthat/test_maraca.R index c1a118d..4ab9c95 100644 --- a/tests/testthat/test_maraca.R +++ b/tests/testthat/test_maraca.R @@ -601,6 +601,176 @@ test_that("winOddsData", { }) +test_that("binaryEndpoints", { + + file <- fixture_path("hce_scenario_a.csv") + data <- read.csv(file, stringsAsFactors = FALSE) + + # Create binary data for last outcome + idx_cont <- data$GROUP == "Continuous outcome" + data[idx_cont, "GROUP"] <- "Binary outcome" + data[idx_cont, "AVAL0"] <- data[idx_cont, "AVAL0"] >= 0 + data[idx_cont, "AVAL"] <- data[idx_cont, "AVAL0"] + + data[idx_cont, "GROUPN"] + + column_names <- c( + outcome = "GROUP", + arm = "TRTP", + value = "AVAL0" + ) + step_outcomes <- c("Outcome I", "Outcome II", + "Outcome III", "Outcome IV") + last_outcome <- "Binary outcome" + arm_levels <- c(active = "Active", + control = "Control") + + mar <- maraca( + data, step_outcomes, last_outcome, arm_levels, column_names, + fixed_followup_days = 3 * 365, compute_win_odds = TRUE, + last_type = "binary" + ) + dt_last <- mar$data_last_outcome$meta + + binary_data <- data[idx_cont, ] + idx_active <- binary_data$TRTP == "Active" + idx_control <- binary_data$TRTP == "Control" + prop_active <- prop.test(sum(binary_data[idx_active, "AVAL0"] == 1), + nrow(binary_data[idx_active, ])) + prop_control <- prop.test(sum(binary_data[idx_control, "AVAL0"] == 1), + nrow(binary_data[idx_control, ])) + + expect_equal(as.numeric(dt_last[dt_last$arm == "Active", "estimate"]), + 100 * unname(prop_active$estimate)) + expect_equal(as.numeric(dt_last[dt_last$arm == "Control", "estimate"]), + 100 * unname(prop_control$estimate)) + + lowest_value <- dt_last$estimate - dt_last$ci_diff + highest_value <- dt_last$estimate + dt_last$ci_diff + range <- c(min(0, floor(lowest_value / 10) * 10), + max(100, ceiling(highest_value / 10) * 10)) + + expect_equal(as.numeric(dt_last[dt_last$arm == "Active", "average"]), + unname(.to_rangeab(100 * prop_active$estimate, + max(mar$meta$startx), range[1], range[2]))) + expect_equal(as.numeric(dt_last[dt_last$arm == "Control", "average"]), + unname(.to_rangeab(100 * prop_control$estimate, + max(mar$meta$startx), range[1], range[2]))) + + expect_equal(as.numeric(dt_last[dt_last$arm == "Active", "ci_diff"]), + 100 * unname(prop_active$estimate - prop_active$conf.int[1])) + expect_equal(as.numeric(dt_last[dt_last$arm == "Control", "ci_diff"]), + 100 * unname(prop_control$estimate - prop_control$conf.int[1])) + + output <- artifacts_path("binary_plot-last.pdf") + expect_file_not_exists(output) + set_pdf_output(output) + plot(mar) + expect_file_exists(output) + + p <- plot(mar) + val <- validate_maraca_plot(p) + + expect_equal(as.numeric(dt_last[dt_last$arm == "Active", "average"]), + val$binary_last_data[val$binary_last_data$group == "Active", + "x"]) + expect_equal(as.numeric(dt_last[dt_last$arm == "Control", "average"]), + val$binary_last_data[val$binary_last_data$group == "Control", + "x"]) + + expect_equal(.to_rangeab((as.numeric(dt_last[dt_last$arm == "Active", + "estimate"]) - + as.numeric(dt_last[dt_last$arm == "Active", + "ci_diff"])), + max(mar$meta$startx), range[1], range[2]), + val$binary_last_data[val$binary_last_data$group == "Active", + "lower_ci"]) + + expect_equal(.to_rangeab((as.numeric(dt_last[dt_last$arm == "Control", + "estimate"]) + + as.numeric(dt_last[dt_last$arm == "Control", + "ci_diff"])), + max(mar$meta$startx), range[1], range[2]), + val$binary_last_data[val$binary_last_data$group == "Control", + "upper_ci"]) + + file <- fixture_path("hce_scenario_a.csv") + data <- read.csv(file, stringsAsFactors = FALSE) + + # Create binary data for step outcome + idx_bin <- data$GROUP %in% c("Outcome III", "Outcome IV") + data[idx_bin, "AVAL0"] <- data[idx_bin, "AVAL0"] >= 500 + data[idx_bin, "AVAL"] <- data[idx_bin, "AVAL0"] + data[idx_bin, "GROUPN"] + data <- data[data$AVAL0 != 0, ] + + column_names <- c( + outcome = "GROUP", + arm = "TRTP", + value = "AVAL0" + ) + step_outcomes <- c("Outcome I", "Outcome II", + "Outcome III", "Outcome IV") + last_outcome <- "Continuous outcome" + arm_levels <- c(active = "Active", + control = "Control") + mar <- maraca( + data, step_outcomes, last_outcome, arm_levels, column_names, + fixed_followup_days = 3 * 365, compute_win_odds = TRUE, + step_types = c("tte", "tte", "binary", "binary") + ) + + act <- data[data$TRTP == "Active", ] + ctrl <- data[data$TRTP == "Control", ] + + step_dt <- mar$ecdf_by_outcome$data + step_act <- step_dt[step_dt$arm == "Active", ] + step_ctrl <- step_dt[step_dt$arm == "Control", ] + + expect_equal((step_act[step_act$outcome == "Outcome III", "step_values"] - + max(step_act[step_act$outcome == "Outcome II", + "step_values"])), + 100 * nrow(act[act$GROUP == "Outcome III", ]) / nrow(act)) + expect_equal((step_ctrl[step_ctrl$outcome == "Outcome III", "step_values"] - + max(step_ctrl[step_ctrl$outcome == "Outcome II", + "step_values"])), + 100 * nrow(ctrl[ctrl$GROUP == "Outcome III", ]) / nrow(ctrl)) + + expect_equal((step_act[step_act$outcome == "Outcome IV", "step_values"] - + step_act[step_act$outcome == "Outcome III", "step_values"]), + 100 * nrow(act[act$GROUP == "Outcome IV", ]) / nrow(act)) + expect_equal((step_ctrl[step_ctrl$outcome == "Outcome IV", "step_values"] - + step_ctrl[step_ctrl$outcome == "Outcome III", + "step_values"]), + 100 * nrow(ctrl[ctrl$GROUP == "Outcome IV", ]) / nrow(ctrl)) + + output <- artifacts_path("binary_plot-steps.pdf") + expect_file_not_exists(output) + set_pdf_output(output) + plot(mar) + expect_file_exists(output) + + p <- plot(mar) + val <- validate_maraca_plot(p) + val_step <- val$binary_step_data + + expect_equal((step_act[step_act$outcome == "Outcome III", "step_values"] - + max(step_act[step_act$outcome == "Outcome II", + "step_values"])), + val_step[val_step$group == "Active", "proportion"][1]) + expect_equal((step_ctrl[step_ctrl$outcome == "Outcome III", "step_values"] - + max(step_ctrl[step_ctrl$outcome == "Outcome II", + "step_values"])), + val_step[val_step$group == "Control", "proportion"][1]) + + expect_equal((step_act[step_act$outcome == "Outcome IV", "step_values"] - + step_act[step_act$outcome == "Outcome III", "step_values"]), + val_step[val_step$group == "Active", "proportion"][2]) + expect_equal((step_ctrl[step_ctrl$outcome == "Outcome IV", "step_values"] - + step_ctrl[step_ctrl$outcome == "Outcome III", + "step_values"]), + val_step[val_step$group == "Control", "proportion"][2]) + +}) + test_that("winOddsPlot", { file <- fixture_path("hce_scenario_c.csv") data <- read.csv(file, stringsAsFactors = FALSE) @@ -650,10 +820,49 @@ test_that("winOddsPlot", { component_plot(mar) expect_file_exists(output) - mar <- maraca( - data, step_outcomes, last_outcome, arm_levels, column_names, 3 * 365, - compute_win_odds = FALSE - ) + output <- artifacts_path("cumulative_plot-with.pdf") + expect_file_not_exists(output) + set_pdf_output(output) + cumulative_plot(mar) + expect_file_exists(output) + + output <- artifacts_path("cumulative_plot-reverse.pdf") + expect_file_not_exists(output) + set_pdf_output(output) + cumulative_plot(mar, reverse = TRUE) + expect_file_exists(output) + + bar_p <- mar$wo_bar + forest_p <- mar$wins_forest + sry_by_grp <- win_odds_outcome$summary_by_GROUP + summary <- win_odds_outcome$summary + + expect_equal(as.numeric(bar_p[bar_p$GROUP == "Outcome I" & + bar_p$name == "Active wins", "value"]), + sry_by_grp[sry_by_grp$GROUP == "Outcome I" & + sry_by_grp$TRTP == "P", "LOSS"]) + + expect_equal(as.numeric(bar_p[bar_p$GROUP == "Outcome I" & + bar_p$name == "Control wins", "value"]), + sry_by_grp[sry_by_grp$GROUP == "Outcome I" & + sry_by_grp$TRTP == "A", "LOSS"]) + + expect_equal(as.numeric(bar_p[bar_p$GROUP == "Overall" & + bar_p$name == "Active wins", "value"]), + summary[summary$TRTP == "P", "LOSS"]) + + expect_equal(as.numeric(bar_p[bar_p$GROUP == "Overall" & + bar_p$name == "Control wins", "value"]), + summary[summary$TRTP == "A", "LOSS"]) + + expect_equal(forest_p[forest_p$GROUP == "Overall" & + forest_p$method == "win odds", "value"], + win_odds_outcome$WO$WO) + + expect_equal(forest_p[forest_p$GROUP == "Overall" & + forest_p$method == "win odds", "LCL"], + exp(log(win_odds_outcome$WO$WO) - + qnorm(0.975) * win_odds_outcome$WO$SE)) output <- artifacts_path("winOddsPlot-without.pdf") expect_file_not_exists(output) @@ -661,6 +870,11 @@ test_that("winOddsPlot", { plot(mar) expect_file_exists(output) + mar <- maraca( + data, step_outcomes, last_outcome, arm_levels, column_names, 3 * 365, + compute_win_odds = FALSE + ) + expect_error(component_plot(mar), regexp = list(paste0("Win odds not calculated for maraca object.\n", " Make sure to set compute_win_odds = TRUE when ", @@ -671,6 +885,16 @@ test_that("winOddsPlot", { "inputs of class 'hce' or 'maraca'. ", "Your input has class data.frame."))) + expect_error(cumulative_plot(mar), regexp = + list(paste0("Win odds not calculated for maraca object.\n", + " Make sure to set compute_win_odds = TRUE when ", + "creating the maraca object."))) + + expect_text_equal(cumulative_plot(data), + list(paste0("cumulative_plot() function can only handle ", + "inputs of class 'hce' or 'maraca'. ", + "Your input has class data.frame."))) + rates_a <- c(1.72, 1.74, 0.58, 1.5, 1) rates_p <- c(2.47, 2.24, 2.9, 4, 6) hce_dat <- hce::simHCE(n = 2500, TTE_A = rates_a, @@ -685,6 +909,12 @@ test_that("winOddsPlot", { component_plot(hce_dat) expect_file_exists(output) + output <- artifacts_path("cumulative_plot-hce.pdf") + expect_file_not_exists(output) + set_pdf_output(output) + cumulative_plot(hce_dat) + expect_file_exists(output) + }) @@ -1097,6 +1327,26 @@ test_that("scaleTransform", { file <- fixture_path("hce_scenario_c.csv") args <- .maraca_args(file) dat <- args$data + + mar <- maraca( + dat, + args$step_outcomes, + args$last_outcome, + args$arm_levels, + args$column_names, + 3 * 365 + ) + + expect_warning(plot(mar, trans = "log10"), + paste("Continuous endpoint has negative values - the log10", + "transformation will result in missing values.")) + expect_warning(plot(mar, trans = "log"), + paste("Continuous endpoint has negative values - the log", + "transformation will result in missing values.")) + expect_warning(plot(mar, trans = "sqrt"), + paste("Continuous endpoint has negative values - the sqrt", + "transformation will result in missing values.")) + dat[dat$GROUP == "Continuous outcome", "AVAL0"] <- dat[dat$GROUP == "Continuous outcome", "AVAL0"] + 50 mar <- maraca( @@ -1105,15 +1355,120 @@ test_that("scaleTransform", { args$last_outcome, args$arm_levels, args$column_names, - 3 * 365 + 3 * 365, + compute_win_odds = TRUE ) + orig_dat <- mar$data_last_outcome$data + + p_log10 <- plot(mar, trans = "log10", density_plot_type = "scatter") + p_log <- plot(mar, trans = "log", density_plot_type = "scatter") + p_sqrt <- plot(mar, trans = "sqrt", density_plot_type = "scatter") + val_log10 <- validate_maraca_plot(p_log10) + val_log <- validate_maraca_plot(p_log) + val_sqrt <- validate_maraca_plot(p_sqrt) + log10_data <- .to_rangeab(log10(orig_dat$value), max(mar$meta$startx), + min(log10(orig_dat$value)), + max(log10(orig_dat$value))) + + expect_equal(log10_data, + val_log10$scatter_data$x) + expect_equal(.to_rangeab(log(orig_dat$value), max(mar$meta$startx), + min(log(orig_dat$value)), + max(log(orig_dat$value))), + val_log$scatter_data$x) + expect_equal(.to_rangeab(sqrt(orig_dat$value), max(mar$meta$startx), + min(sqrt(orig_dat$value)), + max(sqrt(orig_dat$value))), + val_sqrt$scatter_data$x) + + p_log10 <- plot(mar, trans = "log10") + val_log10 <- validate_maraca_plot(p_log10) + box_dat <- val_log10$boxstat_data + + idx_act <- orig_dat$arm == "Active" + idx_ctrl <- orig_dat$arm == "Control" + + expect_equal(median(log10_data[idx_act]), + box_dat[box_dat$group == "Active", "median"]) + expect_equal(unname(quantile(log10_data[idx_act], probs = 0.25)), + box_dat[box_dat$group == "Active", "hinge_lower"]) + expect_equal(unname(quantile(log10_data[idx_act], probs = 0.75)), + box_dat[box_dat$group == "Active", "hinge_upper"]) + expect_equal(median(log10_data[idx_ctrl]), + box_dat[box_dat$group == "Control", "median"]) + expect_equal(unname(quantile(log10_data[idx_ctrl], probs = 0.25)), + box_dat[box_dat$group == "Control", "hinge_lower"]) + expect_equal(unname(quantile(log10_data[idx_ctrl], probs = 0.75)), + box_dat[box_dat$group == "Control", "hinge_upper"]) + output <- artifacts_path("scaleTransform-basic.pdf") expect_file_not_exists(output) set_pdf_output(output) plot(mar, trans = "sqrt") expect_file_exists(output) + expect_message(plot(mar, trans = "reverse"), + regexp = paste("Last endpoint axis has been reversed, which", + "might indicate that lower values are", + "considered advantageous. Note that the win", + "odds were calculated assuming that higher", + "values are better. If that is not correct,", + "please use the parameter lowerBetter = TRUE", + "in the maraca function.")) + mar <- maraca( + dat, + args$step_outcomes, + args$last_outcome, + args$arm_levels, + args$column_names, + 3 * 365, + lowerBetter = TRUE + ) + + p_reverse <- plot(mar, trans = "reverse", density_plot_type = "scatter") + val_reverse <- validate_maraca_plot(p_reverse) + + expect_equal(max(mar$meta$startx) - mar$data_last_outcome$data$x + 100, + val_reverse$scatter_data$x) + + file <- fixture_path("hce_scenario_a.csv") + data <- read.csv(file, stringsAsFactors = FALSE) + + # Create binary data for last outcome + idx_cont <- data$GROUP == "Continuous outcome" + data[idx_cont, "GROUP"] <- "Binary outcome" + data[idx_cont, "AVAL0"] <- data[idx_cont, "AVAL0"] >= 0 + data[idx_cont, "AVAL"] <- data[idx_cont, "AVAL0"] + + data[idx_cont, "GROUPN"] + + column_names <- c( + outcome = "GROUP", + arm = "TRTP", + value = "AVAL0" + ) + step_outcomes <- c("Outcome I", "Outcome II", + "Outcome III", "Outcome IV") + last_outcome <- "Binary outcome" + arm_levels <- c(active = "Active", + control = "Control") + + mar <- maraca( + data, step_outcomes, last_outcome, arm_levels, column_names, + fixed_followup_days = 3 * 365, compute_win_odds = TRUE, + last_type = "binary" + ) + + expect_error(plot(mar, trans = "log10"), + paste("log10 transformation only implemented for continuous", + "last endpoint.")) + expect_error(plot(mar, trans = "log"), + paste("log transformation only implemented for continuous", + "last endpoint.")) + expect_error(plot(mar, trans = "sqrt"), + paste("sqrt transformation only implemented for continuous", + "last endpoint.")) + }) test_that("densityPlotType", { From 814d7479ce6496b4d3e8cf3d7623ce50cf0d6cac Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Tue, 12 Mar 2024 20:24:55 +0000 Subject: [PATCH 29/32] Added updated documentation --- tests/testthat/test_maraca.R | 12 ++-- vignettes/faq.Rmd | 129 +++++++++++++++++++++++++++++++++++ vignettes/maraca.Rmd | 20 ++++++ 3 files changed, 155 insertions(+), 6 deletions(-) diff --git a/tests/testthat/test_maraca.R b/tests/testthat/test_maraca.R index 4ab9c95..5ec07bd 100644 --- a/tests/testthat/test_maraca.R +++ b/tests/testthat/test_maraca.R @@ -703,9 +703,9 @@ test_that("binaryEndpoints", { data <- data[data$AVAL0 != 0, ] column_names <- c( - outcome = "GROUP", - arm = "TRTP", - value = "AVAL0" + outcome = "GROUP", + arm = "TRTP", + value = "AVAL0" ) step_outcomes <- c("Outcome I", "Outcome II", "Outcome III", "Outcome IV") @@ -845,7 +845,7 @@ test_that("winOddsPlot", { expect_equal(as.numeric(bar_p[bar_p$GROUP == "Outcome I" & bar_p$name == "Control wins", "value"]), sry_by_grp[sry_by_grp$GROUP == "Outcome I" & - sry_by_grp$TRTP == "A", "LOSS"]) + sry_by_grp$TRTP == "A", "LOSS"]) expect_equal(as.numeric(bar_p[bar_p$GROUP == "Overall" & bar_p$name == "Active wins", "value"]), @@ -861,8 +861,8 @@ test_that("winOddsPlot", { expect_equal(forest_p[forest_p$GROUP == "Overall" & forest_p$method == "win odds", "LCL"], - exp(log(win_odds_outcome$WO$WO) - - qnorm(0.975) * win_odds_outcome$WO$SE)) + exp(log(win_odds_outcome$WO$WO) - + qnorm(0.975) * win_odds_outcome$WO$SE)) output <- artifacts_path("winOddsPlot-without.pdf") expect_file_not_exists(output) diff --git a/vignettes/faq.Rmd b/vignettes/faq.Rmd index 370399d..170b93a 100644 --- a/vignettes/faq.Rmd +++ b/vignettes/faq.Rmd @@ -63,4 +63,133 @@ plot <- plot ``` +## For my continuous outcome, lower values are better + +In some cases, for the continuous outcome, lower values might be considered better +than higher values. By default, the win odds are calculated assuming that higher +values are better. In order to calculate the correct win odds, the user can set +the `lowerBetter` parameter in the `maraca()` or `plot.hce()` function to `TRUE`. + +Additionally, it is possible to display the continuous outcome on a reverse scale +using the parameter `trans = "reverse"` in the plotting functions. +```{r fig.width = 7, fig.height = 6} +Rates_A <- c(10, 15) +Rates_P <- c(12, 15) +dat <- simHCE(n = 2500, TTE_A = Rates_A, TTE_P = Rates_P, + CM_A = 6, CM_P = 10, CSD_A = 16, CSD_P = 15, fixedfy = 3, seed = 1) + +plot(dat, lowerBetter = TRUE, trans = "reverse") +``` + +## Outcome axis labels are overlapping + +Sometimes for some of the outcomes, only very few patients +had an event. Since the x-axis range for each endpoint is based +on the proportion of patients that had the event, this can lead +to close x-axis ticks and overlapping labels. +```{r fig.width = 7, fig.height = 6} +data(hce_scenario_a, package = "maraca") +data <- hce_scenario_a + +column_names <- c( + outcome = "GROUP", + arm = "TRTP", + value = "AVAL0" +) +step_outcomes <- c( + "Outcome I", "Outcome II", "Outcome III", "Outcome IV" +) + +last_outcome <- "Continuous outcome" + +arm_levels = c(active = "Active", control = "Control") + +# We will only include a few patients with outcome III +data2 <- data[data$GROUP == "Outcome II",] +data3 <- data[data$GROUP == "Outcome III",] +data <- rbind(data2[sample(1:nrow(data2),5),], + data3[sample(1:nrow(data3),5),], + data[!(data$GROUP %in% c("Outcome II","Outcome III")),]) + +mar <- maraca( + data, step_outcomes, last_outcome, arm_levels, column_names, + fixed_followup_days = 3*365, + compute_win_odds = TRUE +) + +# Now the x-axis labels are overlapping +plot(mar) +``` + +One potential workaround in this situation is to add a line break after or before +one of the outcomes in order to space them further apart. +```{r fig.width = 7, fig.height = 6} +data[data$GROUP == "Outcome II","GROUP"] <- "Outcome II\n" +step_outcomes <- c( + "Outcome I", "Outcome II\n", "Outcome III", "Outcome IV" +) +mar <- maraca( + data, step_outcomes, last_outcome, arm_levels, column_names, + fixed_followup_days = 3*365, + compute_win_odds = TRUE +) + +plot(mar) +``` + + +## I get the error "outcome [XY] is not present in column" + +The maraca package expects that for every outcome specified in the +`step_outcomes` parameter, at least one patient has had that event. +```{r error = TRUE} +data(hce_scenario_a, package = "maraca") +data <- hce_scenario_a + +column_names <- c( + outcome = "GROUP", + arm = "TRTP", + value = "AVAL0" +) +step_outcomes <- c( + "Outcome I", "Outcome II", "Outcome III", "Outcome IV" +) + +last_outcome <- "Continuous outcome" + +arm_levels = c(active = "Active", control = "Control") + +# Let's pretend no one in the study had outcome II +data <- data[data$GROUP != "Outcome II", ] + +# Now we will get an error +mar <- maraca( + data, step_outcomes, last_outcome, arm_levels, column_names, + fixed_followup_days = 3*365, + compute_win_odds = TRUE +) +``` + +If the outcome is not part of the data at all, it cannot be displayed +as part of the plot. The outcome has to be removed from the +`step_outcomes` parameter. Additionally, the user can for example +add a footnote explaining why the outcome is not included in the +plot. + +```{r fig.width = 7, fig.height = 6} +step_outcomes <- c( + "Outcome I", "Outcome III", "Outcome IV" +) + +# Now we will get an error +mar <- maraca( + data, step_outcomes, last_outcome, arm_levels, column_names, + fixed_followup_days = 3*365, + compute_win_odds = TRUE +) + +plot(mar) + + labs(caption = paste("No patient experienced Outcome II", + "and it is therefore not included in the graph.")) +``` diff --git a/vignettes/maraca.Rmd b/vignettes/maraca.Rmd index 1cd90f3..75c6c3e 100644 --- a/vignettes/maraca.Rmd +++ b/vignettes/maraca.Rmd @@ -159,6 +159,26 @@ Note that some styling settings are already specified in the default plot versio themes for the convenience of the user, including a version without any preset stylings. For more details, please take a look at the vignette [Maraca Plots - Themes and Styling](themes.html). +The user can also use transformations on the x-axis for the +continuous outcomes in order to make the plot more readable, +such as log-transforming it. +One such transformation is to reverse the x-axis scale by +setting `trans = "reverse"`. This +could be of interest when lower values of the continuous outcome +are better than higher ones. In such a case, one also has to make +sure that the win odds are calculated correctly by +including the parameter `lowerBetter = TRUE` in the `maraca()` or +`plot.hce()` function. +```{r fig.width = 7, fig.height = 6} +Rates_A <- c(1.72, 1.74, 0.58, 1.5, 1) +Rates_P <- c(2.47, 2.24, 2.9, 4, 6) +hce_dat <- hce::simHCE(n = 2500, TTE_A = Rates_A, TTE_P = Rates_P, + CM_A = -6, CM_P = 3, CSD_A = 15, CSD_P = 16, fixedfy = 3, + seed = 31337) +plot(hce_dat, compute_win_odds = TRUE, lowerBetter = TRUE, + trans = "reverse") +``` + # References Martin Karpefors, Daniel Lindholm and Samvel B. Gasparyan, "The maraca plot -- a novel visualization of hierarchical composite endpoints", Clinical Trials (2022). From b60acb54fbbd9310dfade397e58860a40b082f0b Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Tue, 12 Mar 2024 21:32:50 +0000 Subject: [PATCH 30/32] Updated NEWS and version number --- DESCRIPTION | 2 +- NEWS.md | 32 +++++++++++++++++++++++++++++++- R/internal_winOdds.R | 2 +- R/themes.R | 2 +- R/winOddsPlots.R | 8 ++++---- vignettes/validation.Rmd | 19 ++++++++++++++----- vignettes/winOdds.Rmd | 4 ++-- 7 files changed, 54 insertions(+), 15 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index e296396..1ac387d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,5 +1,5 @@ Package: maraca -Version: 0.6 +Version: 0.7 Type: Package Title: The Maraca Plot: Visualization of Hierarchical Composite Endpoints in Clinical Trials License: Apache License (>= 2) diff --git a/NEWS.md b/NEWS.md index da54fa3..5cd2265 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,33 @@ +# maraca 0.7 + +## New features + +- The maraca package has been re-factored to allow flexibility in the type of + outcomes that can be visualized. The user can now also include binary endpoints + in their hierarchical endpoint. Details are given in the new vignette + "Maraca Plots - Alternative Endpoints". +- Additionally to the `component_plot()`, there has been a new plot added called + `cumulative_plot()`. As opposed to the previous plot showing the individual + components of the win odds computation, this plot is displaying + the endpoints cumulated instead (adding one component of hierarchical endpoint + at a time). Details can be found in the vignette "Maraca Plots - Plotting win odds". + +## Parameter change +- As part of the re-factoring to allow for other endpoint types, the parameter + `tte_outcomes` has been changed to `step_outcomes` and the parameter + `continuous_outcome` to `last_outcome`. + +## Dependency change + +- The `ggplot2` is now automatically attached when loading `maraca`. +- `maraca` has a new dependency - the `patchwork` package. + +## Bug fixes + +- The `trans` parameter in the plotting functions was not working as + intended. It now enables x-axis transformation for the continuous + endpoint part of the plot. + # maraca 0.6 ## New features @@ -15,7 +45,7 @@ - `maraca` now has increased the version dependency for the package `hce` to >= 0.5. -- The `hce` is now automatically attached when loading `maraca`. +- The `hce` package is now automatically attached when loading `maraca`. # maraca 0.5.1 diff --git a/R/internal_winOdds.R b/R/internal_winOdds.R index edebf0c..fb01ae2 100644 --- a/R/internal_winOdds.R +++ b/R/internal_winOdds.R @@ -223,7 +223,7 @@ plot <- ggplot(data = wins_forest) + geom_errorbar(aes(x = GROUP, y = value, ymin = LCL, ymax = UCL, col = method, group = method), linewidth = 0.3, - width = 0.1, + width = 0.15, position = ggplot2::position_dodge(width = 0.3)) + geom_point(aes(x = GROUP, y = value, col = method, shape = method), size = 3, position = ggplot2::position_dodge(width = 0.3)) + diff --git a/R/themes.R b/R/themes.R index d97ed91..cffcb9f 100644 --- a/R/themes.R +++ b/R/themes.R @@ -26,7 +26,7 @@ linetype = 2, linewidth = 0.3, color = "darkgray") + # Axis showing percentages ggplot2::scale_y_continuous(labels = function(x) paste0(round(x, 2), "%"), - expand = expansion(mult = c(0, .2))) + + expand = expansion(mult = c(0, .3))) + ggplot2::ylab("Percent of all comparisons") + ggplot2::theme_bw() + ggplot2::theme(legend.position = "bottom", diff --git a/R/winOddsPlots.R b/R/winOddsPlots.R index e82a90d..7d27acd 100644 --- a/R/winOddsPlots.R +++ b/R/winOddsPlots.R @@ -76,8 +76,8 @@ component_plot.maraca <- function(x, plot <- .add_win_odds_to_plot(plot, x$win_odds, x = (length(endpoints) + 1.5), - y = max(wo_bar_nc$percentage) * 1.5, - hjust = 0.85) + y = max(wo_bar_nc$percentage) * 1.2, + hjust = 0.1) return(plot) } @@ -156,8 +156,8 @@ component_plot.hce <- function(x, last_outcome = "C", plot <- .add_win_odds_to_plot(plot, maraca_dat$win_odds, x = (length(endpoints) + 1.5), - y = max(wo_bar_nc$percentage) * 1.4, - hjust = 0.85) + y = max(wo_bar_nc$percentage) * 1.2, + hjust = 0.1) return(plot) } diff --git a/vignettes/validation.Rmd b/vignettes/validation.Rmd index ecf27f6..4757a04 100644 --- a/vignettes/validation.Rmd +++ b/vignettes/validation.Rmd @@ -71,14 +71,23 @@ with the following items: 1. `plot_type`: depending on which `density_plot_type` was selected for the plot either `GeomPoint`, `GeomViolin` and/or `GeomBoxplot` 2. `proportions`: the proportions of the HCE components -3. `tte_data`: the time-to-event data -4. `scatter_data`: if plot was created with `density_plot_type = "scatter"` then contains +3. `tte_data`: time-to-event data if part of the step outcomes has type tte, +otherwise `NULL` +4. `binary_step_data`: binary data if part of the step outcomes has type binary, +otherwise `NULL` +5. `binary_step_data`: if last endpoint was binary then contains the data +for the minimum, maximum and middle point x values displayed in the ellipsis, +otherwise `NULL` +6. `scatter_data`: if last endpoint was continuous and +plot was created with `density_plot_type = "scatter"` then contains dataset that was plotted in scatter plot, otherwise `NULL` -5. `boxstat_data`: if plot was created with `density_plot_type = "box"` or +7. `boxstat_data`: if last endpoint was continuous and +if plot was created with `density_plot_type = "box"` or `density_plot_type = "default"` then contains the boxplot statistics, otherwise `NULL` -6. `violin_data`: if plot was created with `density_plot_type = "violin"` or +8. `violin_data`: if last endpoint was continuous and +if plot was created with `density_plot_type = "violin"` or `density_plot_type = "default"` then contains the violin distribution data, otherwise `NULL` -7. `wo_stats`: if maraca object was created with `compute_win_odds = TRUE` then contains +9. `wo_stats`: if maraca object was created with `compute_win_odds = TRUE` then contains the win odds statistics, otherwise `NULL` diff --git a/vignettes/winOdds.Rmd b/vignettes/winOdds.Rmd index 846021d..32d4138 100644 --- a/vignettes/winOdds.Rmd +++ b/vignettes/winOdds.Rmd @@ -81,8 +81,8 @@ component_plot(hce_dat) Furthermore, there is also a plot called `"cumulative_plot"`. Similar as above, this plot shows the different components that make up the win odds calculation. Different to the component plot, -this plot shows the endpoint cumulated instead (adding one -hierarchical endpoint at a time). +this plot shows the endpoints cumulated instead (adding one +component of the hierarchical endpoint at a time). As explained above, the plot shows how often patients in the active arm "won" or "lost" against the other arm or if they had a "tie". From d2315cccdb922ec5789a561efcf136b97a4ed5ba Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Wed, 13 Mar 2024 17:00:44 +0000 Subject: [PATCH 31/32] Prepare version 0.7 for CRAN release --- NAMESPACE | 1 + R/aaa.R | 2 +- R/general.R | 1 + R/internal.R | 22 +++++--- R/internal_winOdds.R | 101 ++++++++++++++++++++-------------- R/maraca.R | 37 +++++++++++-- R/themes.R | 3 +- R/winOddsPlots.R | 65 +++++++++++++++------- man/component_plot.hce.Rd | 14 +++-- man/cumulative_plot.hce.Rd | 22 ++++++-- man/cumulative_plot.maraca.Rd | 15 ++++- man/plot.hce.Rd | 22 +++++++- man/plot.maraca.Rd | 2 +- tests/testthat/test_maraca.R | 14 ++--- vignettes/winOdds.Rmd | 53 ++++++++++++++---- 15 files changed, 264 insertions(+), 110 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index e44ad23..58702e0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -14,4 +14,5 @@ export(cumulative_plot) export(maraca) export(plot_maraca) export(validate_maraca_plot) +import(ggplot2) import(hce) diff --git a/R/aaa.R b/R/aaa.R index 73aaecd..3846389 100644 --- a/R/aaa.R +++ b/R/aaa.R @@ -29,7 +29,7 @@ utils::globalVariables("average") utils::globalVariables("estimate") utils::globalVariables("value") utils::globalVariables("percentage") -utils::globalVariables("name") +utils::globalVariables("count") utils::globalVariables(".env") utils::globalVariables("separation") utils::globalVariables("gap") diff --git a/R/general.R b/R/general.R index d3c3a66..1e5a880 100644 --- a/R/general.R +++ b/R/general.R @@ -3,6 +3,7 @@ #' @docType package #' @name maraca #' @import hce +#' @import ggplot2 #' @aliases maraca-package NULL diff --git a/R/internal.R b/R/internal.R index f9a7299..bee8360 100644 --- a/R/internal.R +++ b/R/internal.R @@ -218,8 +218,9 @@ range <- log10(range) get_axp <- function(x) 10^c(floor(x[1]), ceiling(x[2])) n <- ifelse(range[2] > 4, 1, 2) - steps <- axTicks(side = 1, usr = range, axp = c(get_axp(range), n = n), - log = TRUE) + steps <- graphics::axTicks(side = 1, usr = range, axp = c(get_axp(range), + n = n), + log = TRUE) return((steps)) } @@ -461,7 +462,7 @@ return(minor_grid) } -.maraca_from_hce_data <- function(x, last_outcome, arm_levels, +.maraca_from_hce_data <- function(x, step_outcomes, last_outcome, arm_levels, fixed_followup_days, compute_win_odds, step_types = "tte", last_type = "continuous", @@ -479,7 +480,14 @@ checkmate::assert_flag(compute_win_odds) x <- as.data.frame(x, stringsAsFactors = FALSE) - tte <- sort(unique(x$GROUP)[unique(x$GROUP) != last_outcome]) + + if (is.null(step_outcomes)) { + if (!(last_outcome %in% x$GROUP)) { + stop(paste("last_outcome", last_outcome, + "is not in the outcome variable")) + } + step_outcomes <- sort(unique(x$GROUP)[unique(x$GROUP) != last_outcome]) + } # Small bugfix to allow for name change of variable TTEFixed in newer # version of HCE package @@ -491,14 +499,14 @@ checkmate::assertNames(names(x), must.include = "TTEfixed") checkmate::assert_integerish(x$TTEfixed) - fixed_followup_days <- unname(sapply(tte, function(tte_ind) { - x[x$GROUP == tte_ind, "TTEfixed"][[1]] + fixed_followup_days <- unname(sapply(step_outcomes, function(tte) { + x[x$GROUP == tte, "TTEfixed"][[1]] })) } maraca_obj <- maraca( data = x, - step_outcomes = tte, + step_outcomes = step_outcomes, last_outcome = last_outcome, column_names = c(outcome = "GROUP", arm = "TRTP", value = "AVAL0"), arm_levels = arm_levels, diff --git a/R/internal_winOdds.R b/R/internal_winOdds.R index fb01ae2..57048df 100644 --- a/R/internal_winOdds.R +++ b/R/internal_winOdds.R @@ -65,7 +65,7 @@ GROUP = "outcome") endpoints <- c(step_outcomes, last_outcome) - labs <- c(sapply(head(seq_along(endpoints), -1), function(i) { + labs <- c(sapply(utils::head(seq_along(endpoints), -1), function(i) { paste(endpoints[1:i], collapse = " +\n") }), "Overall") @@ -88,31 +88,29 @@ wins_forest <- do.call("rbind", lapply(seq_along(calcs_lst), function(i) { wins <- calcs_lst[[i]]$wins nm <- c("value", "LCL", "UCL", "p value") - f <- rbind(data.frame(setNames(wins$WO, nm), "method" = "win odds"), - data.frame(setNames(wins$WR1, nm), "method" = "win ratio")) + f <- rbind(data.frame(stats::setNames(wins$WO, nm), "method" = "win odds"), + data.frame(stats::setNames(wins$WR1, nm), + "method" = "win ratio")) f$GROUP <- labs[i] return(f) })) wo_bar <- do.call("rbind", lapply(seq_along(calcs_lst), function(i) { - wo <- head(calcs_lst[[i]]$wo$summary, 1) + wo <- utils::head(calcs_lst[[i]]$wo$summary, 1) wo$outcome <- endpoints[i] wo$GROUP <- labs[i] wo %>% dplyr::rename(dplyr::all_of(c(A_wins = "WIN", P_wins = "LOSS", Ties = "TIE"))) %>% tidyr::pivot_longer(cols = c("A_wins", "P_wins", "Ties"), - names_to = "name", values_to = "value") - # %>% - # dplyr::mutate_at(dplyr::vars(name), factor, - # levels = c("wins", "losses", "ties")) + names_to = "count", values_to = "value") })) wo_bar <- .label_win_odds_plots(wo_bar, arm_levels) wins_forest$GROUP <- factor(wins_forest$GROUP, levels = rev(labs)) wins_forest$method <- factor(wins_forest$method, - levels = c("win ratio", "win odds")) + levels = c("win odds", "win ratio")) wo_bar$GROUP <- factor(wo_bar$GROUP, levels = rev(labs)) wo_bar$percentage <- 100 * (wo_bar$value / win_odds_outcome$summary$TOTAL[1]) @@ -150,7 +148,7 @@ "Ties" = TIE_A) %>% # Long format for plotting tidyr::pivot_longer(cols = c("A_wins", "P_wins", "Ties"), - names_to = "name", values_to = "value") + names_to = "count", values_to = "value") # Total number of wins/losses/ties to get relative results wo_bar_nc$total <- wo_tot$TOTAL[1] @@ -168,12 +166,12 @@ paste(arms["control"], "wins"), "Ties") - bar_data$name <- ifelse(bar_data$name == "A_wins", - labels[1], - ifelse(bar_data$name == "P_wins", - labels[2], labels[3])) + bar_data$count <- ifelse(bar_data$count == "A_wins", + labels[1], + ifelse(bar_data$count == "P_wins", + labels[2], labels[3])) - bar_data$name <- factor(bar_data$name, levels = labels) + bar_data$count <- factor(bar_data$count, levels = labels) return(bar_data) } @@ -188,7 +186,7 @@ plot <- ggplot2::ggplot(data = wo_bar_nc, aes(x = GROUP, y = percentage, - fill = name)) + + fill = count)) + # Bars ggplot2::geom_bar(stat = "identity", position = ggplot2::position_dodge(), width = .8) + @@ -213,24 +211,29 @@ } # Create forest plot part of cumulative plot -.create_forest_plot <- function(wins_forest, theme, reverse) { +.create_forest_plot <- function(wins_forest, theme, include, reverse) { + xlab <- paste(include, collapse = " / ") if (reverse) { wins_forest$GROUP <- factor(wins_forest$GROUP, levels = rev(levels(wins_forest$GROUP))) } - plot <- ggplot(data = wins_forest) + - geom_errorbar(aes(x = GROUP, y = value, ymin = LCL, ymax = UCL, - col = method, group = method), linewidth = 0.3, - width = 0.15, - position = ggplot2::position_dodge(width = 0.3)) + - geom_point(aes(x = GROUP, y = value, col = method, shape = method), - size = 3, position = ggplot2::position_dodge(width = 0.3)) + - geom_hline(yintercept = 1, linetype = "dashed", color = "#676767") + - coord_flip() + - scale_y_continuous() + - scale_x_discrete(labels = NULL, name = NULL) + plot <- ggplot2::ggplot(data = wins_forest) + + ggplot2::geom_errorbar(ggplot2::aes(x = GROUP, y = value, ymin = LCL, + ymax = UCL, col = method, + group = method), + linewidth = 0.3, width = 0.15, + position = ggplot2::position_dodge(width = 0.3)) + + ggplot2::geom_point(ggplot2::aes(x = GROUP, y = value, + col = method, shape = method), + size = 3, + position = ggplot2::position_dodge(width = 0.3)) + + ggplot2::geom_hline(yintercept = 1, linetype = "dashed", + color = "#676767") + + ggplot2::coord_flip() + + ggplot2::scale_y_continuous() + + ggplot2::scale_x_discrete(labels = NULL, name = NULL, breaks = NULL) if (theme != "none") { plot <- plot + @@ -238,14 +241,25 @@ seq(0.5, length(levels(wins_forest$GROUP)) + 1.5, 1), linetype = 2, linewidth = 0.3, color = "darkgray") + - scale_color_manual(values = c("black", "grey50")) + - scale_fill_manual(values = c("black", "grey50")) + - ylab("Win Odds / Win Ratio") + - theme_bw() + - theme(legend.position = "bottom", - legend.title = element_blank(), - panel.grid.major.y = ggplot2::element_blank(), - panel.grid.minor.y = ggplot2::element_blank()) + ggplot2::ylab(xlab) + + ggplot2::theme_bw() + + if (length(include) == 1) { + plot <- plot + + ggplot2::scale_color_manual(values = "black") + + ggplot2::scale_fill_manual(values = "black") + + ggplot2::guides(shape = "none", color = "none", fill = "none") + + ggplot2::theme(panel.grid.major.y = ggplot2::element_blank(), + panel.grid.minor.y = ggplot2::element_blank()) + } else { + plot <- plot + + ggplot2::scale_color_manual(values = c("black", "grey50")) + + ggplot2::scale_fill_manual(values = c("black", "grey50")) + + ggplot2::theme(legend.position = "bottom", + legend.title = ggplot2::element_blank(), + panel.grid.major.y = ggplot2::element_blank(), + panel.grid.minor.y = ggplot2::element_blank()) + } } return(plot) @@ -259,12 +273,15 @@ wo_bar$GROUP <- factor(wo_bar$GROUP, levels = rev(levels(wo_bar$GROUP))) } - plot <- ggplot(data = wo_bar, aes(x = GROUP, y = percentage, fill = name)) + - geom_bar(stat = "identity", position = position_dodge(), width = .8) + - coord_flip() + # make bar plot horizontal - geom_text(aes(label = round(percentage, 1)), - position = ggplot2::position_dodge(width = .8), - vjust = 0.5, hjust = -0.2) + plot <- ggplot2::ggplot(data = wo_bar, ggplot2::aes(x = GROUP, + y = percentage, + fill = count)) + + ggplot2::geom_bar(stat = "identity", position = ggplot2::position_dodge(), + width = .8) + + ggplot2::coord_flip() + # make bar plot horizontal + ggplot2::geom_text(ggplot2::aes(label = round(percentage, 1)), + position = ggplot2::position_dodge(width = .8), + vjust = 0.5, hjust = -0.2) plot <- switch(theme, "maraca" = .theme_maraca_cp(plot), diff --git a/R/maraca.R b/R/maraca.R index c575217..5000317 100644 --- a/R/maraca.R +++ b/R/maraca.R @@ -779,7 +779,6 @@ validate_maraca_plot <- function(x, ...) { #' Generic function to plot the maraca object using plot(). #' #' @param x An object of S3 class 'maraca'. -#' @param \dots not used #' @param continuous_grid_spacing_x The spacing of the x grid to use for the #' continuous section of the plot. #' @param trans the transformation to apply to the x-axis scale for the last @@ -797,7 +796,8 @@ validate_maraca_plot <- function(x, ...) { #' Options are "maraca", "maraca_old", "color1", "color2" and none". #' For more details, check the vignette called #' "Maraca Plots - Themes and Styling". -#' @return Used for side effect. Returns ggplot2 plot of the maraca object. +#' @param \dots not used +#' @return Returns ggplot2 plot of the maraca object. #' #' @examples #' data(hce_scenario_a) @@ -828,7 +828,13 @@ plot.maraca <- function( #' Generic function to plot the hce object using plot(). #' #' @param x an object of S3 class 'hce'. -#' @param \dots not used +#' @param step_outcomes A vector of strings containing the outcome labels +#' for all outcomes displayed as part of the step function +#' on the left side of the plot. +#' The order is kept for the plot. +#' By default (when set to NULL) this is automatically +#' updated by taking the non-continuous outcomes from +#' the GROUP variable in alphabetical order. #' @param last_outcome A single string containing the last outcome label #' displayed on the right side of the plot. #' Default value "C". @@ -865,6 +871,10 @@ plot.maraca <- function( #' fixed_followup_days argument is used. #' @param compute_win_odds If TRUE compute the win odds, otherwise (default) #' don't compute them. +#' @param step_types The type of each outcome in the step_outcomes vector. +#' Can be a single string (if all outcomes of same type) or +#' a vector of same length as step_outcomes. Possible values +#' in the vector are "tte" (default) or "binary". #' @param last_type A single string giving the type of the last outcome. #' Possible values are "continuous" (default), "binary" or #' "multinomial". @@ -879,10 +889,15 @@ plot.maraca <- function( #' calculated correctly. #' Default value is FALSE, meaning higher values #' are considered advantageous. +#' @param tte_outcomes Deprecated and substituted by the more general +#' 'step_outcomes'. A vector of strings containing the +#' time-to-event outcome labels. The order is kept for the +#' plot. #' @param continuous_outcome Deprecated and substituted by the more general #' 'last_outcome'. A single string containing the #' continuous outcome label. -#' @return Used for side effect. Returns ggplot2 plot of the hce object. +#' @param \dots not used +#' @return Returns ggplot2 plot of the hce object. #' #' @examples #' Rates_A <- c(1.72, 1.74, 0.58, 1.5, 1) @@ -894,7 +909,9 @@ plot.maraca <- function( #' plot(hce_dat, fixed_followup_days = 3 * 365) #' #' @export -plot.hce <- function(x, last_outcome = "C", +plot.hce <- function(x, + step_outcomes = NULL, + last_outcome = "C", arm_levels = c(active = "A", control = "P"), continuous_grid_spacing_x = 10, trans = c("identity", "log", "log10", @@ -908,16 +925,24 @@ plot.hce <- function(x, last_outcome = "C", last_type = "continuous", theme = "maraca", lowerBetter = FALSE, + tte_outcomes = lifecycle::deprecated(), continuous_outcome = lifecycle::deprecated(), ...) { + if (lifecycle::is_present(tte_outcomes)) { + lifecycle::deprecate_warn("0.7.0", "maraca(tte_outcomes)", + "maraca(step_outcomes)") + step_outcomes <- tte_outcomes + } + if (lifecycle::is_present(continuous_outcome)) { lifecycle::deprecate_warn("0.7.0", "maraca(continuous_outcome)", "maraca(last_outcome)") last_outcome <- continuous_outcome } - maraca_obj <- .maraca_from_hce_data(x, last_outcome, arm_levels, + maraca_obj <- .maraca_from_hce_data(x, step_outcomes, + last_outcome, arm_levels, fixed_followup_days, compute_win_odds, step_types = step_types, diff --git a/R/themes.R b/R/themes.R index cffcb9f..c1dc716 100644 --- a/R/themes.R +++ b/R/themes.R @@ -26,10 +26,11 @@ linetype = 2, linewidth = 0.3, color = "darkgray") + # Axis showing percentages ggplot2::scale_y_continuous(labels = function(x) paste0(round(x, 2), "%"), - expand = expansion(mult = c(0, .3))) + + expand = ggplot2::expansion(mult = c(0, .3))) + ggplot2::ylab("Percent of all comparisons") + ggplot2::theme_bw() + ggplot2::theme(legend.position = "bottom", + legend.title = ggplot2::element_blank(), axis.title.y = ggplot2::element_blank(), panel.grid.major.y = ggplot2::element_blank(), panel.grid.minor.y = ggplot2::element_blank()) diff --git a/R/winOddsPlots.R b/R/winOddsPlots.R index 7d27acd..6355e84 100644 --- a/R/winOddsPlots.R +++ b/R/winOddsPlots.R @@ -27,11 +27,11 @@ component_plot.default <- function(x, #' Check the vignette "Maraca Plots - Plotting win odds" for more details. #' #' @param x an object of S3 class 'maraca'. -#' @param \dots not used #' @param theme Choose theme to style the plot. The default theme is "maraca". #' Options are "maraca", "color1", "color2" and none". #' For more details, check the vignette called #' "Maraca Plots - Plotting win odds". +#' @param \dots not used #' @return Component plot as a ggplot2 object. #' @examples #' @@ -88,7 +88,13 @@ component_plot.maraca <- function(x, #' Check the vignette "Maraca Plots - Plotting win odds" for more details. #' #' @param x an object of S3 class 'hce'. -#' @param \dots not used +#' @param step_outcomes A vector of strings containing the outcome labels +#' for all outcomes displayed as part of the step function +#' on the left side of the plot. +#' The order is kept for the plot. +#' By default (when set to NULL) this is automatically +#' updated by taking the non-continuous outcomes from +#' the GROUP variable in alphabetical order. #' @param last_outcome A single string containing the last outcome label #' displayed on the right side of the plot. #' Default value "C". @@ -116,9 +122,7 @@ component_plot.maraca <- function(x, #' calculated correctly. #' Default value is FALSE, meaning higher values #' are considered advantageous. -#' @param continuous_outcome Deprecated and substituted by the more general -#' 'last_outcome'. A single string containing the -#' continuous outcome label. +#' @param \dots not used #' @return Component plot as a ggplot2 object. #' @examples #' Rates_A <- c(1.72, 1.74, 0.58, 1.5, 1) @@ -130,16 +134,17 @@ component_plot.maraca <- function(x, #' component_plot(hce_dat) #' @export #' -component_plot.hce <- function(x, last_outcome = "C", +component_plot.hce <- function(x, step_outcomes = NULL, + last_outcome = "C", arm_levels = c(active = "A", control = "P"), fixed_followup_days = NULL, theme = "maraca", lowerBetter = FALSE, - continuous_outcome = lifecycle::deprecated(), ...) { # Create maraca object - maraca_dat <- .maraca_from_hce_data(x, last_outcome, arm_levels, + maraca_dat <- .maraca_from_hce_data(x, step_outcomes, + last_outcome, arm_levels, fixed_followup_days, compute_win_odds = TRUE, lowerBetter = lowerBetter) @@ -194,11 +199,15 @@ cumulative_plot.default <- function(x, ...) { #' Options are "maraca", "color1", "color2" and none". #' For more details, check the vignette called #' "Maraca Plots - Plotting win odds". +#' @param include Vector or single string indicating which statistics to +#' include in the right hand side plot. Acceptable values are +#' "win odds" and/or "win ratio". Default is c("win odds", "win ratio"). #' @param reverse Flag indicating if the cumulated outcomes should be #' displayed in order from top to bottom (FALSE, the default) #' or in reverse (TRUE). #' @param \dots not used -#' @return Cumulative plot as a patchwork object. +#' @return Cumulative plot as a patchwork list. Individual plots can +#' be accessed like list items (plot[[1]] and plot[[2]]). #' @examples #' #' data(hce_scenario_a) @@ -220,8 +229,13 @@ cumulative_plot.default <- function(x, ...) { #' #' @export cumulative_plot.maraca <- function(x, theme = "maraca", + include = c("win odds", "win ratio"), reverse = FALSE, ...) { + checkmate::assert_subset(include, + choices = c("win odds", "win ratio"), + empty.ok = FALSE) + # Check that win odds were calculated for the maraca object if (is.null(x[["wins_forest"]]) || is.null(x[["wo_bar"]])) { stop(paste0("Win odds not calculated for maraca object.\n", @@ -232,9 +246,11 @@ cumulative_plot.maraca <- function(x, theme = "maraca", # Get win odds by outcome from maraca object wo_bar <- x$wo_bar wins_forest <- x$wins_forest + # Include only methods of interest + wins_forest <- wins_forest[wins_forest$method %in% include, ] # Create forest plot plot_bar <- .create_bar_plot(wo_bar, theme, reverse) - plot_forest <- .create_forest_plot(wins_forest, theme, reverse) + plot_forest <- .create_forest_plot(wins_forest, theme, include, reverse) plot <- patchwork:::"|.ggplot"(plot_bar, plot_forest) + patchwork::plot_layout(widths = c(2.5, 1), nrow = 1) @@ -251,7 +267,13 @@ cumulative_plot.maraca <- function(x, theme = "maraca", #' Check the vignette "Maraca Plots - Plotting win odds" for more details. #' #' @param x an object of S3 class 'hce'. -#' @param \dots not used +#' @param step_outcomes A vector of strings containing the outcome labels +#' for all outcomes displayed as part of the step function +#' on the left side of the plot. +#' The order is kept for the plot. +#' By default (when set to NULL) this is automatically +#' updated by taking the non-continuous outcomes from +#' the GROUP variable in alphabetical order. #' @param last_outcome A single string containing the last outcome label #' displayed on the right side of the plot. #' Default value "C". @@ -273,6 +295,9 @@ cumulative_plot.maraca <- function(x, theme = "maraca", #' Options are "maraca", "color1", "color2" and none". #' For more details, check the vignette called #' "Maraca Plots - Plotting win odds". +#' @param include Vector or single string indicating which statistics to +#' include in the right hand side plot. Acceptable values are +#' "win odds" and/or "win ratio". Default is c("win odds", "win ratio"). #' @param reverse Flag indicating if the cumulated outcomes should be #' displayed in order from top to bottom (FALSE, the default) #' or in reverse (TRUE). @@ -282,10 +307,9 @@ cumulative_plot.maraca <- function(x, theme = "maraca", #' calculated correctly. #' Default value is FALSE, meaning higher values #' are considered advantageous. -#' @param continuous_outcome Deprecated and substituted by the more general -#' 'last_outcome'. A single string containing the -#' continuous outcome label. -#' @return Cumulative plot as a patchwork object. +#' @param \dots not used +#' @return Cumulative plot as a patchwork list. Individual plots can +#' be accessed like list items (plot[[1]] and plot[[2]]). #' @examples #' Rates_A <- c(1.72, 1.74, 0.58, 1.5, 1) #' Rates_P <- c(2.47, 2.24, 2.9, 4, 6) @@ -296,22 +320,25 @@ cumulative_plot.maraca <- function(x, theme = "maraca", #' cumulative_plot(hce_dat) #' @export #' -cumulative_plot.hce <- function(x, last_outcome = "C", +cumulative_plot.hce <- function(x, step_outcomes = NULL, + last_outcome = "C", arm_levels = c(active = "A", control = "P"), fixed_followup_days = NULL, theme = "maraca", + include = c("win odds", "win ratio"), reverse = FALSE, lowerBetter = FALSE, - continuous_outcome = lifecycle::deprecated(), ...) { # Create maraca object - maraca_dat <- .maraca_from_hce_data(x, last_outcome, arm_levels, + maraca_dat <- .maraca_from_hce_data(x, step_outcomes, + last_outcome, arm_levels, fixed_followup_days, compute_win_odds = TRUE, lowerBetter = lowerBetter) - plot <- cumulative_plot(maraca_dat, theme = theme, reverse = reverse) + plot <- cumulative_plot(maraca_dat, theme = theme, include = include, + reverse = reverse) return(plot) } diff --git a/man/component_plot.hce.Rd b/man/component_plot.hce.Rd index 8b676fc..d02d5bf 100644 --- a/man/component_plot.hce.Rd +++ b/man/component_plot.hce.Rd @@ -9,18 +9,26 @@ Check the vignette "Maraca Plots - Plotting win odds" for more details.} \usage{ \method{component_plot}{hce}( x, + step_outcomes = NULL, last_outcome = "C", arm_levels = c(active = "A", control = "P"), fixed_followup_days = NULL, theme = "maraca", lowerBetter = FALSE, - continuous_outcome = lifecycle::deprecated(), ... ) } \arguments{ \item{x}{an object of S3 class 'hce'.} +\item{step_outcomes}{A vector of strings containing the outcome labels +for all outcomes displayed as part of the step function +on the left side of the plot. +The order is kept for the plot. +By default (when set to NULL) this is automatically +updated by taking the non-continuous outcomes from +the GROUP variable in alphabetical order.} + \item{last_outcome}{A single string containing the last outcome label displayed on the right side of the plot. Default value "C".} @@ -53,10 +61,6 @@ calculated correctly. Default value is FALSE, meaning higher values are considered advantageous.} -\item{continuous_outcome}{Deprecated and substituted by the more general -'last_outcome'. A single string containing the -continuous outcome label.} - \item{\dots}{not used} } \value{ diff --git a/man/cumulative_plot.hce.Rd b/man/cumulative_plot.hce.Rd index 13973b1..b962dc7 100644 --- a/man/cumulative_plot.hce.Rd +++ b/man/cumulative_plot.hce.Rd @@ -9,19 +9,28 @@ Check the vignette "Maraca Plots - Plotting win odds" for more details.} \usage{ \method{cumulative_plot}{hce}( x, + step_outcomes = NULL, last_outcome = "C", arm_levels = c(active = "A", control = "P"), fixed_followup_days = NULL, theme = "maraca", + include = c("win odds", "win ratio"), reverse = FALSE, lowerBetter = FALSE, - continuous_outcome = lifecycle::deprecated(), ... ) } \arguments{ \item{x}{an object of S3 class 'hce'.} +\item{step_outcomes}{A vector of strings containing the outcome labels +for all outcomes displayed as part of the step function +on the left side of the plot. +The order is kept for the plot. +By default (when set to NULL) this is automatically +updated by taking the non-continuous outcomes from +the GROUP variable in alphabetical order.} + \item{last_outcome}{A single string containing the last outcome label displayed on the right side of the plot. Default value "C".} @@ -47,6 +56,10 @@ Options are "maraca", "color1", "color2" and none". For more details, check the vignette called "Maraca Plots - Plotting win odds".} +\item{include}{Vector or single string indicating which statistics to +include in the right hand side plot. Acceptable values are +"win odds" and/or "win ratio". Default is c("win odds", "win ratio").} + \item{reverse}{Flag indicating if the cumulated outcomes should be displayed in order from top to bottom (FALSE, the default) or in reverse (TRUE).} @@ -58,14 +71,11 @@ calculated correctly. Default value is FALSE, meaning higher values are considered advantageous.} -\item{continuous_outcome}{Deprecated and substituted by the more general -'last_outcome'. A single string containing the -continuous outcome label.} - \item{\dots}{not used} } \value{ -Cumulative plot as a patchwork object. +Cumulative plot as a patchwork list. Individual plots can + be accessed like list items (plot[[1]] and plot[[2]]). } \description{ Generic function to create a plot showing the components used in diff --git a/man/cumulative_plot.maraca.Rd b/man/cumulative_plot.maraca.Rd index a268459..0582984 100644 --- a/man/cumulative_plot.maraca.Rd +++ b/man/cumulative_plot.maraca.Rd @@ -9,7 +9,13 @@ Note that for this plot, when creating the maraca object using the maraca() function, the argument "compute_win_odds" has to be set to TRUE. Check the vignette "Maraca Plots - Plotting win odds" for more details.} \usage{ -\method{cumulative_plot}{maraca}(x, theme = "maraca", reverse = FALSE, ...) +\method{cumulative_plot}{maraca}( + x, + theme = "maraca", + include = c("win odds", "win ratio"), + reverse = FALSE, + ... +) } \arguments{ \item{x}{an object of S3 class 'maraca'.} @@ -19,6 +25,10 @@ Options are "maraca", "color1", "color2" and none". For more details, check the vignette called "Maraca Plots - Plotting win odds".} +\item{include}{Vector or single string indicating which statistics to +include in the right hand side plot. Acceptable values are +"win odds" and/or "win ratio". Default is c("win odds", "win ratio").} + \item{reverse}{Flag indicating if the cumulated outcomes should be displayed in order from top to bottom (FALSE, the default) or in reverse (TRUE).} @@ -26,7 +36,8 @@ or in reverse (TRUE).} \item{\dots}{not used} } \value{ -Cumulative plot as a patchwork object. +Cumulative plot as a patchwork list. Individual plots can + be accessed like list items (plot[[1]] and plot[[2]]). } \description{ Generic function to create a plot showing the components used in diff --git a/man/plot.hce.Rd b/man/plot.hce.Rd index ab0f862..419c144 100644 --- a/man/plot.hce.Rd +++ b/man/plot.hce.Rd @@ -6,6 +6,7 @@ \usage{ \method{plot}{hce}( x, + step_outcomes = NULL, last_outcome = "C", arm_levels = c(active = "A", control = "P"), continuous_grid_spacing_x = 10, @@ -18,6 +19,7 @@ last_type = "continuous", theme = "maraca", lowerBetter = FALSE, + tte_outcomes = lifecycle::deprecated(), continuous_outcome = lifecycle::deprecated(), ... ) @@ -25,6 +27,14 @@ \arguments{ \item{x}{an object of S3 class 'hce'.} +\item{step_outcomes}{A vector of strings containing the outcome labels +for all outcomes displayed as part of the step function +on the left side of the plot. +The order is kept for the plot. +By default (when set to NULL) this is automatically +updated by taking the non-continuous outcomes from +the GROUP variable in alphabetical order.} + \item{last_outcome}{A single string containing the last outcome label displayed on the right side of the plot. Default value "C".} @@ -69,6 +79,11 @@ fixed_followup_days argument is used.} \item{compute_win_odds}{If TRUE compute the win odds, otherwise (default) don't compute them.} +\item{step_types}{The type of each outcome in the step_outcomes vector. +Can be a single string (if all outcomes of same type) or +a vector of same length as step_outcomes. Possible values +in the vector are "tte" (default) or "binary".} + \item{last_type}{A single string giving the type of the last outcome. Possible values are "continuous" (default), "binary" or "multinomial".} @@ -86,6 +101,11 @@ calculated correctly. Default value is FALSE, meaning higher values are considered advantageous.} +\item{tte_outcomes}{Deprecated and substituted by the more general +'step_outcomes'. A vector of strings containing the +time-to-event outcome labels. The order is kept for the +plot.} + \item{continuous_outcome}{Deprecated and substituted by the more general 'last_outcome'. A single string containing the continuous outcome label.} @@ -93,7 +113,7 @@ continuous outcome label.} \item{\dots}{not used} } \value{ -Used for side effect. Returns ggplot2 plot of the hce object. +Returns ggplot2 plot of the hce object. } \description{ Generic function to plot the hce object using plot(). diff --git a/man/plot.maraca.Rd b/man/plot.maraca.Rd index 3e26618..7bdbd94 100644 --- a/man/plot.maraca.Rd +++ b/man/plot.maraca.Rd @@ -42,7 +42,7 @@ For more details, check the vignette called \item{\dots}{not used} } \value{ -Used for side effect. Returns ggplot2 plot of the maraca object. +Returns ggplot2 plot of the maraca object. } \description{ Generic function to plot the maraca object using plot(). diff --git a/tests/testthat/test_maraca.R b/tests/testthat/test_maraca.R index 5ec07bd..822dae9 100644 --- a/tests/testthat/test_maraca.R +++ b/tests/testthat/test_maraca.R @@ -800,18 +800,18 @@ test_that("winOddsPlot", { mar$arm_levels) expect_equal(wo_smry_grp[wo_smry_grp$TRTP == "A", "WIN"], - unname(unlist(wo_bar_nc[wo_bar_nc$name == "Active wins" & + unname(unlist(wo_bar_nc[wo_bar_nc$count == "Active wins" & wo_bar_nc$GROUP %in% c(step_outcomes, last_outcome), "value"]))) expect_equal(wo_smry_grp[wo_smry_grp$TRTP == "P", "WIN"], - unname(unlist(wo_bar_nc[wo_bar_nc$name == "Control wins" & + unname(unlist(wo_bar_nc[wo_bar_nc$count == "Control wins" & wo_bar_nc$GROUP %in% c(step_outcomes, last_outcome), "value"]))) expect_equal(win_odds_outcome$summary[win_odds_outcome$summary$TRTP == "A", "TOTAL"], - unname(unlist(wo_bar_nc[wo_bar_nc$name == "Active wins", + unname(unlist(wo_bar_nc[wo_bar_nc$count == "Active wins", "total"][1, ]))) output <- artifacts_path("componentPlot-with.pdf") @@ -838,21 +838,21 @@ test_that("winOddsPlot", { summary <- win_odds_outcome$summary expect_equal(as.numeric(bar_p[bar_p$GROUP == "Outcome I" & - bar_p$name == "Active wins", "value"]), + bar_p$count == "Active wins", "value"]), sry_by_grp[sry_by_grp$GROUP == "Outcome I" & sry_by_grp$TRTP == "P", "LOSS"]) expect_equal(as.numeric(bar_p[bar_p$GROUP == "Outcome I" & - bar_p$name == "Control wins", "value"]), + bar_p$count == "Control wins", "value"]), sry_by_grp[sry_by_grp$GROUP == "Outcome I" & sry_by_grp$TRTP == "A", "LOSS"]) expect_equal(as.numeric(bar_p[bar_p$GROUP == "Overall" & - bar_p$name == "Active wins", "value"]), + bar_p$count == "Active wins", "value"]), summary[summary$TRTP == "P", "LOSS"]) expect_equal(as.numeric(bar_p[bar_p$GROUP == "Overall" & - bar_p$name == "Control wins", "value"]), + bar_p$count == "Control wins", "value"]), summary[summary$TRTP == "A", "LOSS"]) expect_equal(forest_p[forest_p$GROUP == "Overall" & diff --git a/vignettes/winOdds.Rmd b/vignettes/winOdds.Rmd index 32d4138..6045732 100644 --- a/vignettes/winOdds.Rmd +++ b/vignettes/winOdds.Rmd @@ -24,8 +24,8 @@ different components that make up the win odds calculation. More specifically, for each outcome, the plot shows how often patients in each treatment arm "won" against the other arm. For the time-to-event endpoints, this means counting how many -patients of the other arm had no event prior. For the continuous -outcome this means counting how many patients had a lower value. +patients of the other arm had no more prioritized event prior. +For the continuous outcome this means counting how many patients had a lower value. The results are separated for each outcome (non-cumulative) and also include ties (patients from 2 treatment arms having same outcome at the same time/same continuous outcome value). @@ -79,13 +79,14 @@ component_plot(hce_dat) ## Cumulative plot Furthermore, there is also a plot called `"cumulative_plot"`. -Similar as above, this plot shows the different components that +Similar to the `component_plot`, this plot shows the different HCE components that make up the win odds calculation. Different to the component plot, -this plot shows the endpoints cumulated instead (adding one -component of the hierarchical endpoint at a time). -As explained above, the plot shows how -often patients in the active arm "won" or "lost" against the other -arm or if they had a "tie". +this plot provides insight into the contributed effect for each of the components as +they are added in sequence (from top to bottom). +Additionally, there is also a right-hand panel that shows a forest plot with the win odds +and win ratio corresponding to the same cumulative sequence. To understand the contribution +from each outcome, we artificially set all the less prioritized outcomes as ties and calculate +the win odds/ratio. Thus, for each added outcome there will be less ties. As before, in order to use the `cumulative_plot`, we have to first create a `maraca` object. Important here is to set the argument @@ -117,11 +118,38 @@ an `hce` object (created using the cumulative_plot(hce_dat) ``` +The user can also choose to only display one of the statistics (win odds or win ratio) +by specifying so in the `include` parameter. +```{r fig.width=7, fig.height=6} +cumulative_plot(maraca_dat, include = "win odds") +``` + +The y-axis can easily be reversed using the `reverse` parameter. +```{r fig.width=7, fig.height=6} +cumulative_plot(hce_dat, reverse = TRUE) +``` + ## Styling -The resulting plots for both the `component_plot()` and `cumulative_plot()` functions -are normal ggplot2 objects that can be styled accordingly. -There are also different themes available to style the plot. +The resulting plot for the `component_plot()` functions +is a normal ggplot2 object that can be styled accordingly. +```{r fig.width=7, fig.height=6} +component_plot(maraca_dat) + + ggplot2::scale_fill_manual(values = c("seagreen", "red", "grey"), name = NULL) +``` + +Note that the `cumulative_plot()` function is using the +patchwork package to combine 2 ggplot2 objects. They +can be accessed as list items and styled accordingly. +```{r fig.width=7, fig.height=6} +p <- cumulative_plot(maraca_dat) +p[[1]] <- p[[1]] + + ggplot2::scale_fill_manual(values = c("seagreen", "red", "grey"), name = NULL) +p +``` + +For the users convenience, there are also different themes +available to style the plot. The default style is called `theme = "maraca"`. ```{r fig.width=7, fig.height=6} @@ -138,7 +166,8 @@ cumulative_plot(maraca_dat, theme = "color1") component_plot(maraca_dat, theme = "color2") ``` -There is also a theme without any styling `theme = "none"`. +There is also a theme without any styling `theme = "none"` that +can be used as a base when the user wants to style the plot themselves. ```{r fig.width=8, fig.height=6} cumulative_plot(maraca_dat, theme = "none") ``` From abc21c9ef3af471988068ac143d4f159bb347020 Mon Sep 17 00:00:00 2001 From: "Huhn, Monika" Date: Fri, 15 Mar 2024 12:22:12 +0000 Subject: [PATCH 32/32] Update author list with IDs --- DESCRIPTION | 11 +- vignettes/winOdds.Rmd | 349 +++++++++++++++++++++--------------------- 2 files changed, 183 insertions(+), 177 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 1ac387d..73e6a5b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -4,10 +4,13 @@ Type: Package Title: The Maraca Plot: Visualization of Hierarchical Composite Endpoints in Clinical Trials License: Apache License (>= 2) Authors@R: c( - person("Martin Karpefors", "", email = "martin.karpefors@astrazeneca.com", role = "aut"), - person("Samvel B. Gasparyan", "", email = "samvel.gasparyan@astrazeneca.com", role = "aut"), - person("Monika Huhn", "", email = "monika.huhn@astrazeneca.com", role = c("aut", "cre")), - person("Stefano Borini", "", email = "stefano.borini@astrazeneca.com", role = c("ctb"))) + person("Martin Karpefors", "", email = "martin.karpefors@astrazeneca.com", role = "aut", + comment = c(ORCID = "0000-0003-3136-9882")), + person("Samvel B. Gasparyan", "", email = "samvel.gasparyan@astrazeneca.com", role = "aut", + comment = c(ORCID = "0000-0002-4797-2208")), + person("Stefano Borini", "", email = "stefano.borini@astrazeneca.com", role = c("ctb")), + person("Monika Huhn", "", email = "monika.huhn@astrazeneca.com", role = c("aut", "cre"), + comment = c(ORCID = "0009-0000-7865-6008"))) Description: Library that supports visual interpretation of hierarchical composite endpoints (HCEs). HCEs are complex constructs used as primary endpoints in clinical trials, combining outcomes of different types into ordinal endpoints, diff --git a/vignettes/winOdds.Rmd b/vignettes/winOdds.Rmd index 6045732..c38efed 100644 --- a/vignettes/winOdds.Rmd +++ b/vignettes/winOdds.Rmd @@ -1,173 +1,176 @@ ---- -title: "Maraca Plots - Plotting win odds" -author: "Monika Huhn" -date: "10/10/2023" -output: rmarkdown::html_vignette -vignette: > - %\VignetteIndexEntry{Maraca Plots - Plotting win odds} - %\VignetteEngine{knitr::rmarkdown} - \usepackage[utf8]{inputenc} ---- - -```{r setup, include = FALSE} -knitr::opts_chunk$set(echo = TRUE, collapse = TRUE) -library(dplyr) -library(ggplot2) -library(maraca) -``` - -## Component plot - -The maraca package also contains an additional plot -called `"component_plot"`. This one allows to plot the -different components that make up the win odds calculation. -More specifically, for each outcome, the plot shows how -often patients in each treatment arm "won" against the other -arm. For the time-to-event endpoints, this means counting how many -patients of the other arm had no more prioritized event prior. -For the continuous outcome this means counting how many patients had a lower value. -The results are separated for each outcome (non-cumulative) -and also include ties (patients from 2 treatment arms having same -outcome at the same time/same continuous outcome value). - -Let us first read in some data. -```{r maraca1, eval = TRUE} -library(maraca) - -data(hce_scenario_a) -``` - -In order to use the `component_plot`, we have to first create a -`maraca` object. Important here is to set the argument -`compute_win_odds = TRUE`, so that the necessary calculations -are included. -```{r} -maraca_dat <- maraca( - data = hce_scenario_a, - step_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), - last_outcome = "Continuous outcome", - fixed_followup_days = 3 * 365, - column_names = c(outcome = "GROUP", arm = "TRTP", value = "AVAL0"), - arm_levels = c(active = "Active", control = "Control"), - # Make sure to calculate the win odds - compute_win_odds = TRUE -) -``` - -Now we can just plot the object using the `component_plot()` function. -```{r fig.width=7, fig.height=6} -component_plot(maraca_dat) -``` - -It is also possible to use the `component_plot()` function directly on -an `hce` object (created using the -[hce package](https://cran.r-project.org/package=hce)). - -```{r fig.width=7, fig.height=6} -library(hce) - -Rates_A <- c(1.72, 1.74, 0.58, 1.5, 1) -Rates_P <- c(2.47, 2.24, 2.9, 4, 6) - -hce_dat <- simHCE(n = 2500, TTE_A = Rates_A, TTE_P = Rates_P, - CM_A = -3, CM_P = -6, CSD_A = 16, CSD_P = 15, fixedfy = 3, - seed = 31337) - -component_plot(hce_dat) -``` - -## Cumulative plot - -Furthermore, there is also a plot called `"cumulative_plot"`. -Similar to the `component_plot`, this plot shows the different HCE components that -make up the win odds calculation. Different to the component plot, -this plot provides insight into the contributed effect for each of the components as -they are added in sequence (from top to bottom). -Additionally, there is also a right-hand panel that shows a forest plot with the win odds -and win ratio corresponding to the same cumulative sequence. To understand the contribution -from each outcome, we artificially set all the less prioritized outcomes as ties and calculate -the win odds/ratio. Thus, for each added outcome there will be less ties. - -As before, in order to use the `cumulative_plot`, we have to first create a -`maraca` object. Important here is to set the argument -`compute_win_odds = TRUE`, so that the necessary calculations -are included. -```{r} -maraca_dat <- maraca( - data = hce_scenario_a, - step_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), - last_outcome = "Continuous outcome", - fixed_followup_days = 3 * 365, - column_names = c(outcome = "GROUP", arm = "TRTP", value = "AVAL0"), - arm_levels = c(active = "Active", control = "Control"), - # Make sure to calculate the win odds - compute_win_odds = TRUE -) -``` - -Now we can just plot the object using the `cumulative_plot()` function. -```{r fig.width=7, fig.height=6} -cumulative_plot(maraca_dat) -``` - -It is also possible to use the `cumulative_plot()` function directly on -an `hce` object (created using the -[hce package](https://cran.r-project.org/package=hce)). - -```{r fig.width=7, fig.height=6} -cumulative_plot(hce_dat) -``` - -The user can also choose to only display one of the statistics (win odds or win ratio) -by specifying so in the `include` parameter. -```{r fig.width=7, fig.height=6} -cumulative_plot(maraca_dat, include = "win odds") -``` - -The y-axis can easily be reversed using the `reverse` parameter. -```{r fig.width=7, fig.height=6} -cumulative_plot(hce_dat, reverse = TRUE) -``` - -## Styling - -The resulting plot for the `component_plot()` functions -is a normal ggplot2 object that can be styled accordingly. -```{r fig.width=7, fig.height=6} -component_plot(maraca_dat) + - ggplot2::scale_fill_manual(values = c("seagreen", "red", "grey"), name = NULL) -``` - -Note that the `cumulative_plot()` function is using the -patchwork package to combine 2 ggplot2 objects. They -can be accessed as list items and styled accordingly. -```{r fig.width=7, fig.height=6} -p <- cumulative_plot(maraca_dat) -p[[1]] <- p[[1]] + - ggplot2::scale_fill_manual(values = c("seagreen", "red", "grey"), name = NULL) -p -``` - -For the users convenience, there are also different themes -available to style the plot. - -The default style is called `theme = "maraca"`. -```{r fig.width=7, fig.height=6} -component_plot(maraca_dat, theme = "maraca") -``` - -There are 2 different themes with different color -schemes, `theme = "color1"` and `theme = "color2"`. -```{r fig.width=7, fig.height=6} -cumulative_plot(maraca_dat, theme = "color1") -``` - -```{r fig.width=7, fig.height=6} -component_plot(maraca_dat, theme = "color2") -``` - -There is also a theme without any styling `theme = "none"` that -can be used as a base when the user wants to style the plot themselves. -```{r fig.width=8, fig.height=6} -cumulative_plot(maraca_dat, theme = "none") -``` +--- +title: "Maraca Plots - Plotting win odds" +author: "Monika Huhn" +date: "10/10/2023" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Maraca Plots - Plotting win odds} + %\VignetteEngine{knitr::rmarkdown} + \usepackage[utf8]{inputenc} +--- + +```{r setup, include = FALSE} +knitr::opts_chunk$set(echo = TRUE, collapse = TRUE) +library(dplyr) +library(ggplot2) +library(maraca) +``` + +## Component plot + +The maraca package also contains an additional plot +called `"component_plot"`. This one allows to plot the +different components that make up the win odds calculation. +More specifically, for each outcome, the plot shows how +often patients in each treatment arm "won" against the other +arm. For the time-to-event endpoints, this means counting how many +patients of the other arm had no more prioritized event prior. +For the continuous outcome this means counting how many patients had a lower value. +The results are separated for each outcome (non-cumulative) +and also include ties (patients from 2 treatment arms having same +outcome at the same time/same continuous outcome value). + +Let us first read in some data. +```{r maraca1, eval = TRUE} +library(maraca) + +data(hce_scenario_a) +``` + +In order to use the `component_plot`, we have to first create a +`maraca` object. Important here is to set the argument +`compute_win_odds = TRUE`, so that the necessary calculations +are included. +```{r} +maraca_dat <- maraca( + data = hce_scenario_a, + step_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), + last_outcome = "Continuous outcome", + fixed_followup_days = 3 * 365, + column_names = c(outcome = "GROUP", arm = "TRTP", value = "AVAL0"), + arm_levels = c(active = "Active", control = "Control"), + # Make sure to calculate the win odds + compute_win_odds = TRUE +) +``` + +Now we can just plot the object using the `component_plot()` function. +```{r fig.width=7, fig.height=6} +component_plot(maraca_dat) +``` + +It is also possible to use the `component_plot()` function directly on +an `hce` object (created using the +[hce package](https://cran.r-project.org/package=hce)). + +```{r fig.width=7, fig.height=6} +library(hce) + +Rates_A <- c(1.72, 1.74, 0.58, 1.5, 1) +Rates_P <- c(2.47, 2.24, 2.9, 4, 6) + +hce_dat <- simHCE(n = 2500, TTE_A = Rates_A, TTE_P = Rates_P, + CM_A = -3, CM_P = -6, CSD_A = 16, CSD_P = 15, fixedfy = 3, + seed = 31337) + +component_plot(hce_dat) +``` + +## Cumulative plot + +Furthermore, there is a plot called `"cumulative_plot"`. +Similar to the `component_plot`, this plot shows the different HCE components that +make up the win odds calculation. Different to the component plot, +this plot provides insight into the contributed effect for each of the components as +they are added in sequence (from top to bottom). +Additionally, there is also a right-hand panel that shows a forest plot with the win odds +and win ratio corresponding to the same cumulative sequence. To understand the contribution +from each outcome, we artificially set all the less prioritized outcomes as ties and calculate +the win odds/ratio. Thus, for each added outcome there will be less ties. + +As before, in order to use the `cumulative_plot`, we have to first create a +`maraca` object. Important here is to set the argument +`compute_win_odds = TRUE`, so that the necessary calculations +are included. +```{r} +maraca_dat <- maraca( + data = hce_scenario_a, + step_outcomes = c("Outcome I", "Outcome II", "Outcome III", "Outcome IV"), + last_outcome = "Continuous outcome", + fixed_followup_days = 3 * 365, + column_names = c(outcome = "GROUP", arm = "TRTP", value = "AVAL0"), + arm_levels = c(active = "Active", control = "Control"), + # Make sure to calculate the win odds + compute_win_odds = TRUE +) +``` + +Now we can just plot the object using the `cumulative_plot()` function. +```{r fig.width=7, fig.height=6} +cumulative_plot(maraca_dat) +``` + +It is also possible to use the `cumulative_plot()` function directly on +an `hce` object (created using the +[hce package](https://cran.r-project.org/package=hce)). + +```{r fig.width=7, fig.height=6} +cumulative_plot(hce_dat) +``` + +The user can also choose to only display one of the statistics (win odds or win ratio) +by specifying so in the `include` parameter. +```{r fig.width=7, fig.height=6} +cumulative_plot(maraca_dat, include = "win odds") +``` + +The y-axis can easily be reversed using the `reverse` parameter. +```{r fig.width=7, fig.height=6} +cumulative_plot(hce_dat, reverse = TRUE) +``` + +## Styling + +The resulting plot for the `component_plot()` functions +is a normal ggplot2 object that can be styled accordingly. +```{r fig.width=7, fig.height=6} +component_plot(maraca_dat) + + ggplot2::scale_fill_manual(values = c("seagreen", "red", "grey"), name = NULL) +``` + +Note that the `cumulative_plot()` function is using the +patchwork package to combine 2 ggplot2 objects - the +bar plot and the forest plot that together make up the +`cumulative_plot()`. They +can be accessed as list items and styled accordingly. +```{r fig.width=7, fig.height=6} +p <- cumulative_plot(maraca_dat) +# Accessing the first ggplot2 object and adding styling (bar plot) +p[[1]] <- p[[1]] + + ggplot2::scale_fill_manual(values = c("seagreen", "red", "grey"), name = NULL) +p +``` + +For the users convenience, there are also different themes +available to style the plot. + +The default style is called `theme = "maraca"`. +```{r fig.width=7, fig.height=6} +component_plot(maraca_dat, theme = "maraca") +``` + +There are 2 different themes with different color +schemes, `theme = "color1"` and `theme = "color2"`. +```{r fig.width=7, fig.height=6} +cumulative_plot(maraca_dat, theme = "color1") +``` + +```{r fig.width=7, fig.height=6} +component_plot(maraca_dat, theme = "color2") +``` + +There is also a theme without any styling `theme = "none"` that +can be used as a base when the user wants to style the plot themselves. +```{r fig.width=8, fig.height=6} +cumulative_plot(maraca_dat, theme = "none") +```