Merge pull request #66 from andbe/master

Bug fixes to plots and related docs

R/ceac_plot_graph.R

@@ -158,18 +158,69 @@ ceac_ggplot <- function(he,
 
 #' @rdname ceac_plot_graph
 #' 
+#' @keywords hplot
+#' 
 ceac_plot_plotly <- function(he,
-                             pos_legend = "bottomright",
-                             graph_params) {
+                             pos_legend,
+                             graph_params, ...)
+  UseMethod("ceac_plot_plotly", he)
+
+
+#' @rdname ceac_plot_graph
+#' @keywords hplot
+#' 
+ceac_plot_plotly.pairwise <- function(he,
+                                      pos_legend,
+                                      graph_params, ...) {
+  ceac_plotly(he,
+              pos_legend,
+              graph_params,
+              "p_best_interv", ...)
+}
+
+#' @rdname ceac_plot_graph
+#' @keywords hplot
+#' 
+ceac_plot_plotly.bcea <- function(he,
+                                  pos_legend,
+                                  graph_params, ...) {
+  ceac_plotly(he,
+              pos_legend,
+              graph_params,
+              "ceac", ...)
+}
+
+#' @rdname ceac_plot_graph
+#' @param ceac ceac index in `he`
+#' @importFrom scales label_dollar
+#' @keywords internal hplot
+#' @md
+ceac_plotly <- function(he,
+                        pos_legend = "bottomright",
+                        graph_params, 
+                        ceac, ...) {
+
+  complabs = if(ncol(he[[ceac]]) == length(he$interventions)) {
+    he$interventions |> unique() 
+  } else {
+    he$ceac |> colnames()
+  }
+
   data.psa <- data.frame(
-    k = rep(he$k, he$ceac |> ncol()),
-    ceac = he$ceac |> c(),
-    comparison = he$ceac |> colnames() |> as.factor() |> as.numeric() |> sapply(function(x) rep(x, length(he$k))) |> c(),
-    single_label = he$ceac |> colnames() |> as.factor() |> sapply(function(x) rep(x, length(he$k))) |> c()
+    k = rep(he$k, he[[ceac]] |> ncol()),
+    ceac = he[[ceac]] |> c(),
+    comparison = complabs |> as.factor() |> as.numeric() |> sapply(function(x) rep(x, length(he$k))) |> c(),
+    single_label = complabs |> as.factor() |> sapply(function(x) rep(x, length(he$k))) |> c()
   )
-  data.psa$label = paste0(he$interventions[he$ref], " vs ", data.psa$single_label)
 
-  graph_params$line$type <- graph_params$line$type %||% rep_len(1:6, he$n_comparisons)
+  if (length(complabs) != length(he$interventions)) {
+    data.psa$label = paste0(he$interventions[he$ref], " vs ", data.psa$single_label)
+  } else {
+    data.psa$label = he$interventions[data.psa$comparison]
+  }
+  # graph_params$line$type <- graph_params$line$type %||% rep_len(1:6, length(complabs))# he$n_comparisons)
+  if (length(graph_params$line$type) != length(complabs))
+    graph_params$line$type = rep(graph_params$line$type[1], length(complabs))
 
   # opacities
   if (!is.null(graph_params$area$color))
@@ -179,10 +230,10 @@ ceac_plot_plotly <- function(he,
              yes = x,
              no = plotly::toRGB(x, 0.4)))
 
-  ceac <- plotly::plot_ly(data.psa, x = ~k)
-  ceac <-
+  ceac_plot <- plotly::plot_ly(data.psa, x = ~k)
+  ceac_plot <-
     plotly::add_trace(
-      ceac,
+      ceac_plot,
       y = ~ ceac,
       type = "scatter",
       mode = "lines",
@@ -196,9 +247,9 @@ ceac_plot_plotly <- function(he,
 
   legend_params <- make_legend_plotly(pos_legend)
 
-  ceac <-
+  ceac_plot <-
     plotly::layout(
-      ceac,
+      ceac_plot,
       title = graph_params$annot$title,
       xaxis = list(
         hoverformat = ".2f",
@@ -210,6 +261,6 @@ ceac_plot_plotly <- function(he,
       legend = legend_params) |>
     plotly::hide_colorbar()
 
-  plotly::config(ceac, displayModeBar = FALSE)
+  plotly::config(ceac_plot, displayModeBar = FALSE)
 }
 

R/ceaf.plot.R

@@ -69,19 +69,18 @@
 #' @export
 #' 
 ceaf.plot.pairwise <- function(mce,
-                               graph = c("base", "ggplot2"),
+                               graph = c("base", "ggplot2", "plotly"),
                                ...) {
 
   graph <- match.arg(graph)
-  base_graphics <- all(pmatch(graph, c("base", "ggplot2")) != 2)
 
   if (!(requireNamespace("ggplot2", quietly = TRUE) &&
         requireNamespace("grid", quietly = TRUE))) {
     message("Falling back to base graphics\n")
     base_graphics <- TRUE
   }
 
-  if (base_graphics) {
+  if (is_baseplot(graph)) {
     plot(NULL,
          ylim = c(0, 1),
          xlim = c(0, max(mce$k)),
@@ -98,7 +97,7 @@ ceaf.plot.pairwise <- function(mce,
           type = "l",
           lty = 1,
           lwd = 4)
-  } else {
+  } else if (is_ggplot(graph)) {
     df <- data.frame(k = mce$k,
                      ceaf = mce$ceaf)
 
@@ -119,6 +118,26 @@ ceaf.plot.pairwise <- function(mce,
               face = "bold",
               size = 14.3,
               hjust = 0.5))
+  } else if (is_plotly(graph)) {
+    df <- data.frame(k = mce$k, ceaf = mce$ceaf)
+
+    ceaf_plot <- plotly::plot_ly(df, x = ~k, y = ~ceaf)
+    ceaf_plot <-
+      plotly::add_lines(ceaf_plot)
+
+    ceaf_plot <-
+      plotly::layout(
+        ceaf_plot,
+        title = "Cost-effectiveness acceptability frontier",
+        xaxis = list(
+          hoverformat = ".2f",
+          title = "Willingness to pay"),
+        yaxis = list(
+          title = "Probability of most cost-effectiveness",
+          range = c(0, 1.005))) |>
+      plotly::hide_colorbar()
+
+    plotly::config(ceaf_plot, displayModeBar = FALSE)
   }
 }
 

R/eib.plot.R

@@ -21,16 +21,16 @@
 #' @param ...  If `graph="ggplot2"` and a named theme object is supplied,
 #'   it will be added to the ggplot object. Additional arguments:
 #'  \itemize{
-#'   \item `alpha` can be used to set the CrI level when `plot.cri=TRUE`,
-#'   with a default value of `alpha=0.05`.
+#'   \item `alpha_cri` can be used to set the CrI level when `plot.cri=TRUE`,
+#'   with a default value of `alpha_cri=0.05`.
 #'   \item `cri.quantile` controls the the method of calculation of the credible
 #'   intervals. The default value `cri.quantile=TRUE` defines the CrI as the
 #'   interval between the `alpha/2`-th and `1-alpha/2`-th quantiles of
 #'   the IB distribution. Setting `cri.quantile=FALSE` will use a normal
 #'   approximation on the IB distribution to calculate the intervals.
 #'   \item `currency`: Currency prefix to willingness to pay values - ggplot2 only.
-#'   \item `line_colors`: specifies the line colour(s) - all graph types.
-#'   \item `line_types`: specifies the line type(s) as lty numeric values - all graph types.
+#'   \item `line_color`: specifies the line colour(s) - all graph types.
+#'   \item `line_type`: specifies the line type(s) as lty numeric values - all graph types.
 #'   \item `area_include`: include area under the EIB curve - plotly only.
 #'   \item `area_color`: specifies the AUC curve - plotly only.}
 #'   

R/eib_params_ggplot.R

@@ -18,7 +18,7 @@ eib_params_ggplot <- function(he,
 
   default_params <- 
     list(
-      size = rel(3.5),
+      size = ggplot2::rel(3.5),
       kstar = list(
         geom = "text",
         label = paste0("k* = ", format(he$kstar, digits = 6)),

R/eib_plot_graph.R

@@ -166,16 +166,16 @@ eib_plot_plotly <- function(he,
 
   n_comp <- length(comparison)
 
-  graph_params$line$types <- graph_params$line$type %||% rep(1:6, ceiling(he$n_comparisons/6))[1:he$n_comparisons]
+  graph_params$line$type <- graph_params$line$type %||% rep(1:6, ceiling(he$n_comparisons/6))[1:he$n_comparisons]
 
   comparisons.label <-
     paste0(he$interventions[he$ref], " vs ", he$interventions[he$comp])
 
-  if (length(graph_params$line$types) < n_comp)
-    graph_params$line$types <- rep_len(graph_params$line$types, n_comp)
+  if (length(graph_params$line$type) < n_comp)
+    graph_params$line$type <- rep_len(graph_params$line$type[1], n_comp)
 
   if (length(graph_params$line$color) < n_comp)
-    graph_params$line$colors <- rep_len(graph_params$line$color, n_comp)
+    graph_params$line$color <- rep_len(graph_params$line$color[1], n_comp)
 
   # opacities
   graph_params$line$cri_colors <-
@@ -213,9 +213,9 @@ eib_plot_plotly <- function(he,
       name = ~label,
       fillcolor = graph_params$area$color,
       color = ~comparison,
-      colors = graph_params$line$colors,
+      colors = graph_params$line$color,
       linetype = ~comparison,
-      linetypes = graph_params$line$types,
+      linetypes = graph_params$line$type,
       legendgroup = ~comparison)
 
   # decision change points not included
@@ -240,7 +240,7 @@ eib_plot_plotly <- function(he,
         legendgroup = ~comparison,
         fillcolor = "rgba(1, 1, 1, 0)",
         linetype = ~comparison,
-        linetypes = graph_params$line$types,
+        linetypes = graph_params$line$type,
         showlegend = FALSE)
     }
   }

R/kstar_vlines.R

@@ -14,6 +14,7 @@ kstar_vlines <- function(he, plot_params) {
 
     text(x = he$kstar,
          y = min(plot_params$ylim),
+         cex = ifelse(is.null(plot_params$kstar$size), 1, plot_params$kstar$size),
          paste("k* = ", he$kstar , sep = ""))
   }
 }

R/make_legend_base.R

@@ -94,7 +94,8 @@ where_legend_always <- function(he,
       return("bottomright")
   }
 
-  if (grepl("(bottom|top)(left|right)", pos_legend))
+  if (pos_legend != "")
+    if (grepl("^(bottom|top)*(left|right)*$", pos_legend))
       return(pos_legend)
 
   message("Legend position not recognised.")

R/plot.bcea.R

@@ -128,7 +128,7 @@ plot.bcea <- function(x,
       evi.plot(x,
                graph = "base", ...)
     })
-  } else if (is_baseplot("ggplot2")) {
+  } else if (is_ggplot(graph)) {
 
     is_req_pkgs <- map_lgl(c("ggplot2","grid"), requireNamespace, quietly = TRUE)
 

R/prep_eib_params.R

@@ -31,8 +31,8 @@ prep_eib_params <- function(he, plot.cri, ...) {
       line = list(
         type = rep_len(1:6, he$n_comparisons),
         lwd = ifelse(he$n_comparisons > 6, 1.5, 1),
-        color = 1, #1:he$n_comparisons,
-        colors = "black",
+        # color = 1, #1:he$n_comparisons,
+        color = "black",
         cri_col = "grey50",
         cri_lty = 2),
       plot.cri = ifelse((is.null(plot.cri) && he$n_comparisons == 1) ||