plot.deriv

Author: Carol-seven

NAMESPACE

@@ -1,5 +1,6 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(plot,deriv)
 S3method(plot,grasps)
 S3method(plot,pen)
 export(deriv)

R/plot.deriv.R

@@ -0,0 +1,94 @@
+#' Plot for Object of Class "deriv"
+#'
+#' @description
+#' Generate a visualization of penalty derivatives produced by \code{deriv()}.
+#' The plot automatically summarizes multiple configurations of penalty type,
+#' \eqn{\lambda}, and \eqn{\gamma}. Optional zooming is supported through
+#' \code{\link[ggforce]{facet_zoom}}.
+#'
+#' @param x An object of S3 class "deriv".
+#'
+#' @param ... Optional arguments passed to \code{\link[ggforce]{facet_zoom}}
+#' to zoom in on a subset of the data, while keeping the view of the full
+#' dataset as a separate panel.
+#'
+#' @import ggplot2
+#' @import ggforce
+#'
+#' @return
+#' An object of class \code{ggplot}.
+#'
+#' @export
+#'
+#' @noRd
+
+plot.deriv <- function(x, ...) {
+
+  ## identify which configuration columns vary across rows
+  target <- c("penalty", "lambda", "gamma")
+  cols_keep <- target[sapply(x[target], function(col) {
+    col_na_rm <- col[!is.na(col)]
+    length(col_na_rm) && (anyNA(col) || any(col_na_rm != col_na_rm[1]))
+  })]
+
+  ## clean data
+  df <- x[, (names(x) %in% c("omega", "value", cols_keep)), drop = FALSE]
+  key <- paste(cols_keep, collapse = "_")
+
+  ## build facet_zoom() layer if zooming arguments are provided
+  fz <- if (length(list(...)) > 0L) {
+    do.call(facet_zoom, list(...))
+  } else {
+    NULL
+  }
+
+  ## declare
+  group <- omega <- value <- NULL
+
+  ## all configurations identical (only one curve)
+  if (key == "") {
+    ggplot(df, aes(x = omega, y = value)) +
+      geom_line() +
+      fz +
+      labs(x = expression(italic(omega)),
+           y = expression("Derivative Function" ~ italic(lambda) * italic(p) ~ "'(" * italic(omega) * ")")) +
+      theme_bw() +
+      theme(legend.position = "bottom")
+
+  ## multiple configurations, use color grouping and legend
+  } else {
+
+    ## nicely formatted labels for lambda and gamma
+    lambda_fmt <- paste0("\u03BB = ", df$lambda)
+    gamma_fmt <- ifelse(is.na(df$gamma), "", paste0("\u03B3 = ", df$gamma))
+
+    ## group labels based on which parameter(s) vary
+    df$group <- switch(
+      key,
+      "penalty" = df$penalty,
+      "lambda" = lambda_fmt,
+      "gamma" = gamma_fmt,
+      "penalty_lambda" = paste0(df$penalty, " (", lambda_fmt, ")"),
+      "penalty_gamma" = paste0(df$penalty, " (", gamma_fmt, ")"),
+      "lambda_gamma" = paste0(lambda_fmt, ", ", gamma_fmt),
+      "penalty_lambda_gamma" = paste0(df$penalty, " (", lambda_fmt, ", ", gamma_fmt, ")")
+    )
+
+    ## legend label based on which parameter(s) vary
+    legend_name <- switch(
+      key,
+      lambda = "\u03BB",
+      gamma  = "\u03B3",
+      "Penalty Type"
+    )
+
+    ggplot(df, aes(x = omega, y = value, color = group)) +
+      geom_line() +
+      fz +
+      labs(x = expression(italic(omega)),
+           y = expression("Derivative Function Function" ~ italic(lambda) * italic(p) ~ "'(" * italic(omega) * ")"),
+           color = legend_name) +
+      theme_bw() +
+      theme(legend.position = "bottom")
+  }
+}

vignettes/pen_est.qmd

@@ -223,17 +223,16 @@ while the inset panel (left) magnifies the region near zero $[-1, 1]$.
 library(grasps) ## for penalty computation
 library(ggplot2) ## for visualization
 
-omegas <- seq(-4, 4, by = 0.01)
 penalties <- c("atan", "exp", "lasso", "lq", "lsp", "mcp", "scad")
 
-df <- grasps::pen(omegas, penalties, lambda = 1)
-plot(df, xlim = c(-1, 1), ylim = c(0, 1), zoom.size = 1) +
+pen_df <- grasps::pen(seq(-4, 4, by = 0.01), penalties, lambda = 1)
+plot(pen_df, xlim = c(-1, 1), ylim = c(0, 1), zoom.size = 1) +
   guides(color = guide_legend(nrow = 2, byrow = TRUE))
 ```
 
 
 ```{r echo=FALSE, fig.show='hide'}
-plot <- plot(df, xlim = c(-1, 1), ylim = c(0, 1), zoom.size = 1) +
+plot <- plot(pen_df, xlim = c(-1, 1), ylim = c(0, 1), zoom.size = 1) +
   guides(color = guide_legend(nrow = 2, byrow = TRUE))
 ```
 
@@ -257,28 +256,26 @@ $\vert\omega\vert$ increases, reflecting their tendency to shrink small
 $\vert\omega\vert$ strongly while exerting little to no shrinkage on large ones.
 
 
-::: {#fig-deriv}
-```{r fig.cap="Figure 2: Illustrative penalty derivatives."}
-df <- grasps::deriv(omegas, penalties, lambda = 1)
-ggplot(df, aes(x = omega, y = value, color = penalty)) +
-  geom_line() +
-  scale_x_continuous(limits = c(0, 4)) +
+```{r fig.show='hide'}
+deriv_df <- grasps::deriv(seq(0, 4, by = 0.01), penalties, lambda = 1)
+plot(deriv_df) +
+  scale_y_continuous(limits = c(0, 1.5)) +
+  guides(color = guide_legend(nrow = 2, byrow = TRUE))
+```
+
+
+```{r echo=FALSE, fig.show='hide'}
+plot <- plot(deriv_df) +
   scale_y_continuous(limits = c(0, 1.5)) +
-  xlab(expression(italic(omega))) +
-  ylab(expression("Derivative Function" ~ italic(p) * "'(" * italic(omega) * ")")) +
-  scale_color_discrete(name = "Penalty Type",
-                       labels = c(expression(atan ~ "(" * gamma == 0.005 * ")"),
-                                  expression(exp ~ "(" * gamma == 0.01 * ")"),
-                                  "lasso",
-                                  expression(lq ~ "(" * gamma == 0.5 * ")"),
-                                  expression(lsp ~ "(" * gamma == 0.1 * ")"),
-                                  expression(mcp ~ "(" * gamma == 3 * ")"),
-                                  expression(scad ~ "(" * gamma == 3.7 * ")"))) +
-  guides(color = guide_legend(nrow = 2, byrow = TRUE)) +
-  theme_bw() +
-  theme(aspect.ratio = 1,
-        legend.position = "bottom")
+  guides(color = guide_legend(nrow = 2, byrow = TRUE))
+```
+
+
+::: {#fig-deriv}
+```{r echo=FALSE}
+print(plot)
 ```
+Illustrative penalty derivatives.
 :::