modifications as suggested by Alessandro

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),

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)) +