From b8b69634f19f4f403edd8acb48e10fe3736d0ce6 Mon Sep 17 00:00:00 2001 From: Guizzaro Lorenzo Date: Fri, 8 Dec 2023 14:19:01 +0100 Subject: [PATCH] modifications as suggested by Alessandro --- R/autoplot.simsum.R | 6 +++--- R/plot-types.R | 30 ++++++++++++++++-------------- 2 files changed, 19 insertions(+), 17 deletions(-) diff --git a/R/autoplot.simsum.R b/R/autoplot.simsum.R index 1fa0fbd..c4a21a5 100644 --- a/R/autoplot.simsum.R +++ b/R/autoplot.simsum.R @@ -10,7 +10,7 @@ #' @param top Should the legend for a nested loop plot be on the top side of the plot? Defaults to `TRUE`. #' @param density.legend Should the legend for density and hexbin plots be included? Defaults to `TRUE`. #' @param zoom A numeric value between 0 and 1 signalling that a zip plot should _zoom_ on the top x% of the plot (to ease interpretation). Defaults to 1, where the whole zip plot is displayed. -#' @param ci_colors A numeric value between 1 and 3: if 1, CI lines in the zipper plot are yellow, if 2, green for appropriate coverage and red for over and undercoverage, if 3, under- and over-coverage are of different colors. +#' @param zip_ci_colors a string with a hex code if the CI intervals of the CI of the zipper plot are to be shown with one colour regardless of coverage, a list of 2 hex codes for optimal coverage (first) and over/under coverage (second) or a lsit of 3 hex codes for optimal coverage (first), uncercoverage(second) and overcoverage (third). Defaults to "yellow" #' @param ... Not used. #' #' @return A `ggplot` object. @@ -36,7 +36,7 @@ #' methodvar = "model", by = c("baseline", "ss", "esigma") #' ) #' autoplot(s1, stats = "bias", type = "nlp") -autoplot.simsum <- function(object, type = "forest", stats = "nsim", target = NULL, fitted = TRUE, scales = "fixed", top = TRUE, density.legend = TRUE, zoom = 1, ci_colors, ...) { +autoplot.simsum <- function(object, type = "forest", stats = "nsim", target = NULL, fitted = TRUE, scales = "fixed", top = TRUE, density.legend = TRUE, zoom = 1, zip_ci_colors = "yellow", ...) { # object <- s.nlp.subset # type <- "nlp" # stats <- "bias" @@ -118,7 +118,7 @@ autoplot.simsum <- function(object, type = "forest", stats = "nsim", target = NU plot <- switch(type, "forest" = .forest_plot(data = df, methodvar = object$methodvar, by = object$by, stats = stats, ci = ci, target = target, scales = scales), "lolly" = .lolly_plot(data = df, methodvar = object$methodvar, by = object$by, stats = stats, ci = ci, target = target, scales = scales), - "zip" = .zip_plot(data = object$x, estvarname = object$estvarname, se = object$se, true = object$true, methodvar = object$methodvar, by = object$by, ci.limits = object$ci.limits, df = object$df, control = object$control, summ = object$summ, zoom = zoom, ci_colors = ci_colors), # zip for coverage + "zip" = .zip_plot(data = object$x, estvarname = object$estvarname, se = object$se, true = object$true, methodvar = object$methodvar, by = object$by, ci.limits = object$ci.limits, df = object$df, control = object$control, summ = object$summ, zoom = zoom, zip_ci_colors = zip_ci_colors), # zip for coverage "est" = .vs_plot(data = object$x, b = object$estvarname, methodvar = object$methodvar, by = object$by, fitted = fitted, scales = scales, ba = FALSE), "se" = .vs_plot(data = object$x, b = object$se, methodvar = object$methodvar, by = object$by, fitted = fitted, scales = scales, ba = FALSE), "est_ba" = .vs_plot(data = object$x, b = object$estvarname, methodvar = object$methodvar, by = object$by, fitted = fitted, scales = scales, ba = TRUE), diff --git a/R/plot-types.R b/R/plot-types.R index 9f1185e..7e96bc4 100644 --- a/R/plot-types.R +++ b/R/plot-types.R @@ -76,7 +76,7 @@ ### Zip plot #' @keywords internal -.zip_plot <- function(data, estvarname, se, true, methodvar, by, ci.limits, df, control, summ, zoom, ci_colors) { +.zip_plot <- function(data, estvarname, se, true, methodvar, by, ci.limits, df, control, summ, zoom, zip_ci_colors) { ### Extract overall coverage summ <- summ[summ$stat == "cover", ] summ$cover <- summ$est @@ -139,23 +139,25 @@ ylab <- ifelse(is.null(df), "Fractional centile of |z-score|", "Fractional centile of |t-score|") ### Define CI lines colors - if (ci_colors == 2) { - data$line_color_lower <- ifelse(data$cover_lower <= 0.95 & 0.95 <= data$cover_upper, "#1a9850", "#d73027") - data$line_color_upper <- ifelse(data$cover_lower <= 0.95 & 0.95 <= data$cover_upper, "#1a9850", "#d73027") - } else if (ci_colors == 3) { - data$line_color_lower <- ifelse(data$cover_lower > 0.95 & data$cover_upper > 0.95, "#377eb8", - ifelse(data$cover_lower < 0.95 & data$cover_upper < 0.95, "#e41a1c", - ifelse(data$cover_lower <= 0.95 & 0.95 <= data$cover_upper, "#4daf4a", NA))) - - data$line_color_upper <- ifelse(data$cover_lower > 0.95 & data$cover_upper > 0.95, "#377eb8", - ifelse(data$cover_lower < 0.95 & data$cover_upper < 0.95, "#e41a1c", - ifelse(data$cover_lower <= 0.95 & 0.95 <= data$cover_upper, "#4daf4a", NA))) + if (length(zip_ci_colors) == 2) { + data$line_color_lower <- ifelse(data$cover_lower <= 0.95 & 0.95 <= data$cover_upper, zip_ci_colors[1], zip_ci_colors[2]) + data$line_color_upper <- ifelse(data$cover_lower <= 0.95 & 0.95 <= data$cover_upper, zip_ci_colors[1], zip_ci_colors[2]) + } else if (length(zip_ci_colors) == 3) { + data$line_color_lower <- ifelse(data$cover_lower > 0.95 & data$cover_upper > 0.95, zip_ci_colors[3], + ifelse(data$cover_lower < 0.95 & data$cover_upper < 0.95, zip_ci_colors[2], + ifelse(data$cover_lower <= 0.95 & 0.95 <= data$cover_upper, zip_ci_colors[1], NA))) + + data$line_color_upper <- ifelse(data$cover_lower > 0.95 & data$cover_upper > 0.95, zip_ci_colors[3], + ifelse(data$cover_lower < 0.95 & data$cover_upper < 0.95, zip_ci_colors[2], + ifelse(data$cover_lower <= 0.95 & 0.95 <= data$cover_upper, zip_ci_colors[1], NA))) } else { - data$line_color_lower <- "#ffffb3" - data$line_color_upper <- "#ffffb3" + data$line_color_lower <- zip_ci_colors[1] + data$line_color_upper <- zip_ci_colors[1] } + + ### Build plot gg <- ggplot2::ggplot(data, ggplot2::aes(y = rank, x = lower, color = covering)) + ggplot2::geom_segment(ggplot2::aes(yend = rank, xend = upper)) +