Minor proposal for readability of CI lines in the zipper plot (#55)

* Minor proposal for readability of CI lines in the zipper plot

* modifications as suggested by Alessandro

---------

Co-authored-by: Guizzaro Lorenzo <lorenzo.guizzaro@ema.europa.eu>

R/autoplot.simsum.R

@@ -10,6 +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 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.
@@ -35,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, ...) {
+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"
@@ -117,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), # 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) {
+.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
@@ -138,14 +138,35 @@
   ### Label of the y-axis
   ylab <- ifelse(is.null(df), "Fractional centile of |z-score|", "Fractional centile of |t-score|")
 
+  ### Define CI lines colors
+  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 <- 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)) +
-    ggplot2::geom_vline(xintercept = true, color = "yellow", linetype = "dashed") +
-    ggplot2::geom_hline(ggplot2::aes(yintercept = cover_lower), color = "yellow", linetype = "dashed") +
-    ggplot2::geom_hline(ggplot2::aes(yintercept = cover_upper), color = "yellow", linetype = "dashed") +
-    ggplot2::labs(y = ylab, x = paste0(100 * control$level, "% confidence intervals"), color = "") +
-    theme(legend.position = "bottom")
+  	ggplot2::geom_segment(ggplot2::aes(yend = rank, xend = upper)) +
+  	ggplot2::geom_vline(xintercept = true, color = "black", linetype = "dashed") +
+  	ggplot2::geom_hline(ggplot2::aes(yintercept = cover_lower), color = data$line_color_lower, linetype = "dashed", size = 1) +
+  	ggplot2::geom_hline(ggplot2::aes(yintercept = 0.95), color = "black", linetype = "dashed") +
+  	ggplot2::geom_hline(ggplot2::aes(yintercept = cover_upper), color = data$line_color_upper, linetype = "dashed", size = 1) +
+  	ggplot2::labs(y = ylab, x = paste0(100 * control$level, "% confidence intervals"), color = "") +
+  	theme(legend.position = "bottom")
 
   ### If 'by', use facet_grid; facet_wrap otherwise
   if (!is.null(by) & !is.null(methodvar)) {