added marginal plots

Author: egenn

R/dplot3_calibration.R

@@ -4,6 +4,7 @@
 
 #' Draw calibration plot
 #'
+#' @inheritParams dplot3_xy
 #' @param true.labels Factor or list of factors with true class labels
 #' @param est.prob Numeric vector or list of numeric vectors with predicted probabilities
 #' @param bin.method Character: "quantile" or "equidistant": Method to bin the estimated
@@ -14,6 +15,7 @@
 #' @param subtitle Character: Subtitle, placed bottom right of plot
 #' @param xlab Character: x-axis label
 #' @param ylab Character: y-axis label
+#' @param show.marginal.x Logical: Add marginal plot of distribution of estimated probabilities
 #' @param mode Character: Plot mode
 #' @param filename Character: Path to save output.
 #' @param ... Additional arguments passed to [dplot3_xy]
@@ -52,10 +54,17 @@ dplot3_calibration <- function(true.labels, est.prob,
                                subtitle = NULL,
                                xlab = "Mean estimated probability",
                                ylab = "Empirical risk",
+                               show.marginal.x = TRUE,
+                               marginal.x.y = -.02,
+                               marginal.col = NULL,
+                               marginal.size = 10,
+                               show.bins = TRUE,
                                #    conf_level = .95,
                                mode = "markers+lines",
                                print.brier = TRUE,
+                               theme = rtTheme,
                                filename = NULL, ...) {
+  # Arguments ----
   bin.method <- match.arg(bin.method)
   if (is.null(pos.class)) {
     pos.class <- rtenv$binclasspos
@@ -69,6 +78,10 @@ dplot3_calibration <- function(true.labels, est.prob,
   # Ensure same number of inputs
   stopifnot(length(true.labels) == length(est.prob))
 
+  # Theme ----
+  if (is.character(theme)) {
+    theme <- do.call(paste0("theme_", theme), list())
+  }
   pos_class <- lapply(true.labels, \(x) {
     levels(x)[pos.class]
   })
@@ -136,22 +149,52 @@ dplot3_calibration <- function(true.labels, est.prob,
     )
   }
   # if (is.null(subtitle) && !is.na(subtitle)) .subtitle <- paste0(subtitle, "\n", .subtitle)
-  dplot3_xy(
+  plt <- dplot3_xy(
     x = mean_bin_prob,
     y = window_empirical_risk,
     main = main,
     # subtitle = paste("<i>", .subtitle, "</i>"),
     subtitle = subtitle,
     subtitle.x = 1,
-    subtitle.y = .01,
+    subtitle.y = 0,
+    subtitle.yref = "y",
     subtitle.xanchor = "right",
     subtitle.yanchor = "bottom",
     xlab = xlab,
     ylab = ylab,
-    axes.square = TRUE, diagonal = TRUE,
+    show.marginal.x = show.marginal.x,
+    marginal.x = est.prob,
+    marginal.x.y = marginal.x.y,
+    marginal.size = marginal.size,
+    axes.square = TRUE,
+    diagonal = TRUE,
     xlim = c(0, 1), ylim = c(0, 1),
     mode = mode,
+    theme = theme,
     filename = filename, ...
   )
 
+  # Add marginal.x ----
+  # Using estimated probabilities
+  # if (marginal.x) {
+  #   if (is.null(marginal.col)) marginal.col <- plotly::toRGB(theme$fg, alpha = .5)
+  #   for (i in seq_along(mean_bin_prob)) {
+  #     plt <- plotly::add_trace(
+  #       plt,
+  #       x = est.prob[[i]],
+  #       y = rep(-.02, length(est.prob[[i]])),
+  #       type = "scatter",
+  #       mode = "markers",
+  #       marker = list(
+  #         color = marginal.col,
+  #         size = marginal.size,
+  #         symbol = "line-ns-open"
+  #       ),
+  #       showlegend = FALSE,
+  #       hoverinfo = "x"
+  #     )
+  #   }
+  # } # /marginal.x
+
+  plt
 } # rtemis::dplot3_calibration

R/dplot3_xy.R

@@ -45,6 +45,8 @@
 #' @param main.yanchor Character: "top", "middle", "bottom"
 #' @param subtitle.x Numeric: X position of subtitle relative to paper
 #' @param subtitle.y Numeric: Y position of subtitle relative to paper
+#' @param subtitle.xref Character: "paper", "x", "y"
+#' @param subtitle.yref Character: "paper", "x", "y"
 #' @param subtitle.xanchor Character: "left", "center", "right"
 #' @param subtitle.yanchor Character: "top", "middle", "bottom"
 #' @param scrollZoom Logical: If TRUE, enable scroll zoom
@@ -53,6 +55,16 @@
 #' @param symbol Character: Marker symbol.
 #' @param scatter.type Character: "scatter", "scattergl", "scatter3d", "scatterternary",
 #' "scatterpolar", "scattermapbox",
+#' @param show.marginal.x Logical: If TRUE, add marginal distribution line markers on x-axis
+#' @param show.marginal.y Logical: If TRUE, add marginal distribution line markers on y-axis
+#' @param marginal.x Numeric: Data whose distribution will be shown on x-axis. Only 
+#' specify if different from `x`
+#' @param marginal.y Numeric: Data whose distribution will be shown on y-axis. Only
+#' specify if different from `y`
+#' @param marginal.x.y Numeric: Y position of marginal markers on x-axis
+#' @param marginal.col Color for marginal markers
+#' @param marginal.alpha Numeric: Alpha for marginal markers
+#' @param marginal.size Numeric: Size of marginal markers
 #'
 #' @author E.D. Gennatas
 #' @export
@@ -98,6 +110,16 @@ dplot3_xy <- function(x, y = NULL,
                       se.col = NULL,
                       se.alpha = .4,
                       scatter.type = "scatter",
+                      # Marginal plots
+                      show.marginal.x = FALSE,
+                      show.marginal.y = FALSE,
+                      marginal.x = x,
+                      marginal.y = y,
+                      marginal.x.y = NULL,
+                      marginal.y.x = NULL,
+                      marginal.col = NULL,
+                      marginal.alpha = .333,
+                      marginal.size = 5,
                       legend = NULL,
                       legend.xy = c(0, .98),
                       legend.xanchor = "left",
@@ -120,6 +142,8 @@ dplot3_xy <- function(x, y = NULL,
                       main.yanchor = "bottom",
                       subtitle.x = 0.02,
                       subtitle.y = 0.99,
+                      subtitle.xref = "paper",
+                      subtitle.yref = "paper",
                       subtitle.xanchor = "left",
                       subtitle.yanchor = "top",
                       automargin.x = TRUE,
@@ -267,6 +291,10 @@ dplot3_xy <- function(x, y = NULL,
     }
   }
 
+  # Marginal data ----
+  if (show.marginal.x && is.null(marginal.x)) marginal.x <- x
+  if (show.marginal.y && is.null(marginal.y)) marginal.y <- y
+
   # Reorder ----
   if (order.on.x) {
     index <- lapply(x, order)
@@ -496,8 +524,57 @@ dplot3_xy <- function(x, y = NULL,
       legendgroup = .names[i],
       showlegend = legend
     )
+    # Marginal plots ----
+    # Add marginal plots by plotting short vertical markers on the x and y axes
+    if (show.marginal.x) {
+      if (is.null(marginal.col)) {
+        marginal.col <- plotly::toRGB(marker.col, alpha = marginal.alpha)
+      }
+      if (is.null(marginal.x.y)) marginal.x.y <- ylim[1]
+      for (i in seq_len(n.groups)) {
+        plt <- plotly::add_trace(plt,
+          x = marginal.x[[i]],
+          y = rep(marginal.x.y, length(marginal.x[[i]])),
+          type = "scatter",
+          mode = "markers",
+          marker = list(
+            color = marginal.col[[i]],
+            size = marginal.size,
+            symbol = "line-ns-open"
+          ),
+          showlegend = FALSE,
+          hoverinfo = "x"
+          # legendgroup = .names[i],
+          # inherit = FALSE
+        )
+      }
+    } # /show.marginal.x
+
+    if (show.marginal.y) {
+      if (is.null(marginal.col)) {
+        marginal.col <- plotly::toRGB(marker.col, alpha = marginal.alpha)
+      }
+      if (is.null(marginal.y.x)) marginal.y.x <- xlim[1]
+      for (i in seq_len(n.groups)) {
+        plt <- plotly::add_trace(plt,
+          x = rep(marginal.y.x, length(marginal.y[[i]])),
+          y = marginal.y[[i]],
+          type = "scatter",
+          mode = "markers",
+          marker = list(
+            color = marginal.col[[i]],
+            size = marginal.size,
+            symbol = "line-ew-open"
+          ),
+          showlegend = FALSE,
+          hoverinfo = "y"
+          # legendgroup = .names[i]
+        )
+      }
+    } # /show.marginal.y
+
+    ## { SE band } ----
     if (se.fit) {
-      ## { SE band } ----
       plt <- plotly::add_trace(plt,
         x = x[[i]],
         y = fitted[[i]] + se.times * se[[i]],
@@ -678,8 +755,8 @@ dplot3_xy <- function(x, y = NULL,
     plt <- plt |> plotly::add_annotations(
       x = subtitle.x,
       y = subtitle.y,
-      xref = "paper",
-      yref = "paper",
+      xref = subtitle.xref,
+      yref = subtitle.yref,
       xanchor = subtitle.xanchor,
       yanchor = subtitle.yanchor,
       text = subtitle,