huber plot v1g

NAMESPACE

@@ -52,6 +52,7 @@ export(get_space_param)
 export(get_start)
 export(get_theo)
 export(plot_projection)
+export(prep_huber)
 export(prep_space_tour)
 export(sample_bases)
 export(scale_color_continuous_botanical)

R/huber-plot.R

@@ -5,8 +5,29 @@
 #' @param index a function, the projection pursuit index function, see examples
 #' @rdname huber
 #' @export
+#' @examples
+#' library(ggplot2)
+#' library(tourr)
+#' data(randu)
+#' randu_std <- as.data.frame(apply(randu, 2, function(x) (x-mean(x))/sd(x)))
+#' randu_std$yz <- sqrt(35)/6*randu_std$y-randu_std$z/6
+#' randu_df <- randu_std[c(1,4)]
+#' randu_huber <- prep_huber(randu_df, index = norm_bin(nr = nrow(randu_df)))
+#'
+#' ggplot() +
+#' geom_huber(data = randu_huber$idx_df, aes(x = x, y = y)) +
+#' geom_point(data = randu_df, aes(x = x, y = yz)) +
+#' geom_abline(slope = randu_huber$slope, intercept = 0) +
+#' theme_huber() +
+#' coord_fixed()
+#'
+#' ggplot(randu_huber$proj_df, aes(x = x)) +
+#' geom_histogram(breaks = seq(-2.2, 2.4, 0.12)) +
+#' xlab("") + ylab("") +
+#' theme_bw() +
+#' theme(axis.text.y = element_blank())
 geom_huber <- function(mapping = NULL, data = NULL, stat = "identity",
- position = "identity", ..., index = NULL,
+ position = "identity", ...,
  show.legend = NA, inherit.aes = TRUE) {
  ggplot2::layer(
  data = data,
@@ -16,7 +37,7 @@ geom_huber <- function(mapping = NULL, data = NULL, stat = "identity",
  position = position,
  show.legend = show.legend,
  inherit.aes = inherit.aes,
- params = list(index = list(index), ...)
+ params = list(...)
  )
 }
 
@@ -34,24 +55,7 @@ GeomHuber <- ggplot2::ggproto(
  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, ...)
  )
@@ -66,34 +70,40 @@ GeomHuber <- ggplot2::ggproto(
  )
 )
 
-huber_data_setup <- function(data, params){
- index_f <- params$index[[1]]
+huber_data_setup <- function(data, param){
+ theta <- pi/180 * (0:(nrow(data) - 1))
+ res1 <- data |> dplyr::mutate(type = "huber")
+ res2 <- data |> dplyr::mutate(
+ x = 4 * cos(theta),
+ y = 4 * sin(theta),
+ type = "circle")
+ res <- dplyr::bind_rows(res1, res2)
+ return(res)
+
+}
+
+#' @export
+#' @rdname huber
+prep_huber <- function(data, index){
+ data <- as.matrix(data)
+ index_f <- index
  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 |>
+ proj_data = list(as.matrix(cos(theta) * data[,1] + sin(theta) * data[,2])),
+ index = index_f(proj_data)) |>
+ dplyr::ungroup() |>
  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")
+ y = idx_scaled * sin(theta))
 
- 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)
+ slope <- sin(theta_best)/cos(theta_best)
+ proj_df <- tibble::tibble(x = cos(theta_best) * data[, 1] + sin(theta_best) * data[, 2])
+ return(list(idx_df = res, proj_df = proj_df, slope = slope))
 
 }
 

_pkgdown.yml

@@ -17,6 +17,7 @@ reference:
  - explore_space_tour
  - plot_projection
  - flip_sign
+ - geom_huber
 - title: Get components
  desc: >
  Extracting components from existing data object