a basic version of creating huber plot using ggplot2

DESCRIPTION

@@ -35,7 +35,7 @@ Imports:
     progress,
     glue,
     GpGp,
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 Depends: 
     R (>= 2.10)
 Suggests: 

NAMESPACE

@@ -38,6 +38,7 @@ export(fit_ks)
 export(fit_nls)
 export(flip_sign)
 export(format_label)
+export(geom_huber)
 export(get_anchor)
 export(get_basis_matrix)
 export(get_best)
@@ -58,6 +59,7 @@ export(scale_color_discrete_botanical)
 export(scale_fill_continuous_botanical)
 export(scale_fill_discrete_botanical)
 export(theme_fern)
+export(theme_huber)
 importFrom(GpGp,fit_model)
 importFrom(cli,cli_abort)
 importFrom(ggplot2,"%+replace%")

R/huber-plot.R

@@ -0,0 +1,113 @@
+#' Create Huber plot with ggplot2
+#'
+#' @inheritParams ggplot2::layer
+#' @inheritParams ggplot2::geom_path
+#' @param index a function, the projection pursuit index function, see examples
+#' @rdname huber
+#' @export
+geom_huber <- function(mapping = NULL, data = NULL, stat = "identity",
+                       position = "identity", ..., index = NULL,
+                       show.legend = NA, inherit.aes = TRUE) {
+  ggplot2::layer(
+    data = data,
+    mapping = mapping,
+    stat = stat,
+    geom = GeomHuber,
+    position = position,
+    show.legend = show.legend,
+    inherit.aes = inherit.aes,
+    params = list(index = list(index),  ...)
+  )
+}
+
+GeomHuber <- ggplot2::ggproto(
+  "GeomHuber",
+  ggplot2::Geom,
+  setup_data = function(data, params) {
+    huber_data_setup(data, params)
+  },
+
+  draw_panel = function(data, panel_params, coord, lineend = "butt", ...) {
+
+    data_circle <- data |>
+      dplyr::filter(type == "circle") |>
+      dplyr::mutate(linetype = "dashed")
+    data_huber <- data |> dplyr::filter(type == "huber")
+
+    # https://github.com/tidyverse/ggplot2/blob/HEAD/R/geom-abline.R
+    ranges <- coord$backtransform_range(panel_params)
+    if (coord$clip == "on" && coord$is_linear()) {
+      # Ensure the line extends well outside the panel to avoid visible line
+      # ending for thick lines
+      ranges$x <- ranges$x + c(-1, 1) * diff(ranges$x)
+    }
+
+    data_best <- data
+    data_best$x    <- ranges$x[1]
+    data_best$xend <- ranges$x[2]
+    data_best$y    <- ranges$x[1] * unique(data$slope) # intercept is always 0
+    data_best$yend <- ranges$x[2] * unique(data$slope)
+    data_best$linetype <- "solid"
+
+    grid::gList(
+      ggplot2::GeomSegment$draw_panel(data_best, panel_params, coord,
+                                      lineend = lineend),
+      ggplot2::GeomPath$draw_panel(data_circle, panel_params, coord, ...),
+      ggplot2::GeomPath$draw_panel(data_huber, panel_params, coord, ...)
+    )
+
+  },
+
+
+  required_aes = c("x", "y"),
+  default_aes = ggplot2::aes(
+    colour = "black", linewidth = 0.5, linetype = "solid", alpha = 1,
+    index = NULL
+  )
+)
+
+huber_data_setup <- function(data, params){
+  index_f <- params$index[[1]]
+  res <- tibble::tibble(i = 0:360, theta = pi/180 * i) |>
+    dplyr::rowwise() |>
+    dplyr::mutate(
+      proj_data = list(as.matrix(cos(theta) * data$x + sin(theta) * data$y)),
+      index = index_f(proj_data),
+      PANEL = 1, group = -1, alpha = params$alpha) |>
+    dplyr::ungroup()
+
+  res1 <- res |>
+    dplyr::mutate(
+      range = round(max(index) - min(index), 5),
+      idx_scaled = (index - min(index))/range * 2 + 3,
+      x = idx_scaled * cos(theta),
+      y = idx_scaled * sin(theta),
+      type = "huber")
+
+  res2 <- res |> dplyr::mutate(
+      x = 4 * cos(theta),
+      y = 4 * sin(theta),
+      type = "circle")
+
+  res <- dplyr::bind_rows(res1, res2)
+  sel_idx <- which(res$index[1:360] > signif(max(res$index), 6) - 1e-06)
+  theta_best <- pi/180 * (sel_idx - 1)
+  res <- res |> dplyr::mutate(slope = sin(theta_best)/cos(theta_best))
+  return(res)
+
+}
+
+#' @rdname huber
+#' @export
+theme_huber <- function(...) {
+  ggplot2::theme_bw(...) %+replace%
+    ggplot2::theme(
+      panel.border = ggplot2::element_blank(),
+      panel.grid = ggplot2::element_blank(),
+      axis.ticks = ggplot2::element_blank(),
+      axis.text = ggplot2::element_blank(),
+      axis.title = ggplot2::element_blank(),
+      complete = TRUE
+    )
+}
+globalVariables(c("i", "theta", "proj_data", "idx_scaled"))

docs/pkgdown.yml

@@ -1,9 +1,8 @@
-pandoc: 3.1.1
-pkgdown: 2.0.8
+pandoc: 3.2.1
+pkgdown: 2.1.0
 pkgdown_sha: ~
 articles: {}
-last_built: 2024-06-18T16:57Z
+last_built: 2024-09-07T15:44Z
 urls:
   reference: https://huizezhang-sherry.github.io/ferrn/reference
   article: https://huizezhang-sherry.github.io/ferrn/articles
-