From ae14529d67e2d61e35fe217d69b39953a0b1e73c Mon Sep 17 00:00:00 2001 From: huizezhang-sherry Date: Tue, 10 Sep 2024 11:36:52 -0500 Subject: [PATCH] a basic version of creating huber plot using ggplot2 --- DESCRIPTION | 2 +- NAMESPACE | 2 + R/huber-plot.R | 113 +++++++++++++++++++++++++++++++++++++++++ docs/LICENSE-text.html | 14 ++--- docs/LICENSE.html | 14 ++--- docs/authors.html | 17 +++---- docs/pkgdown.yml | 7 ++- man/ferrn-package.Rd | 2 +- man/huber.Rd | 111 ++++++++++++++++++++++++++++++++++++++++ 9 files changed, 253 insertions(+), 29 deletions(-) create mode 100644 R/huber-plot.R create mode 100644 man/huber.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 3ec98c8..22c3dbf 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -35,7 +35,7 @@ Imports: progress, glue, GpGp, -RoxygenNote: 7.3.1 +RoxygenNote: 7.3.2 Depends: R (>= 2.10) Suggests: diff --git a/NAMESPACE b/NAMESPACE index e1f347e..76ccb40 100644 --- a/NAMESPACE +++ b/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%") diff --git a/R/huber-plot.R b/R/huber-plot.R new file mode 100644 index 0000000..a41147c --- /dev/null +++ b/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")) diff --git a/docs/LICENSE-text.html b/docs/LICENSE-text.html index 4888855..e1dfe5d 100644 --- a/docs/LICENSE-text.html +++ b/docs/LICENSE-text.html @@ -9,7 +9,7 @@ gtag('config', 'G-SPC6B94B10'); - +
@@ -37,14 +37,14 @@
- +
@@ -71,15 +71,15 @@

License

-

Site built with pkgdown 2.0.8.

+

Site built with pkgdown 2.1.0.

- - + + diff --git a/docs/LICENSE.html b/docs/LICENSE.html index 0f682a8..6e2d5bc 100644 --- a/docs/LICENSE.html +++ b/docs/LICENSE.html @@ -9,7 +9,7 @@ gtag('config', 'G-SPC6B94B10'); - +
@@ -37,14 +37,14 @@
- +
@@ -75,15 +75,15 @@

MIT License

-

Site built with pkgdown 2.0.8.

+

Site built with pkgdown 2.1.0.

- - + + diff --git a/docs/authors.html b/docs/authors.html index 4fe8864..8d35f3c 100644 --- a/docs/authors.html +++ b/docs/authors.html @@ -9,7 +9,7 @@ gtag('config', 'G-SPC6B94B10'); - +
@@ -37,14 +37,14 @@
- +
@@ -53,7 +53,7 @@

Authors and Citation

- +
-

Site built with pkgdown 2.0.8.

+

Site built with pkgdown 2.1.0.

- - + + diff --git a/docs/pkgdown.yml b/docs/pkgdown.yml index 598d3da..b726071 100644 --- a/docs/pkgdown.yml +++ b/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 - diff --git a/man/ferrn-package.Rd b/man/ferrn-package.Rd index 9c88acf..d5ab74a 100644 --- a/man/ferrn-package.Rd +++ b/man/ferrn-package.Rd @@ -26,7 +26,7 @@ Authors: \item Dianne Cook \email{dicook@monash.edu} (\href{https://orcid.org/0000-0002-3813-7155}{ORCID}) \item Ursula Laa \email{ursula.laa@boku.ac.at} (\href{https://orcid.org/0000-0002-0249-6439}{ORCID}) \item Nicolas Langrené \email{nicolaslangrene@uic.edu.cn} (\href{https://orcid.org/0000-0001-7601-4618}{ORCID}) - \item Patricia Menéndez \email{patricia.menendez@unimelb.edu.au } (\href{https://orcid.org/0000-0003-0701-6315}{ORCID}) + \item Patricia Menéndez \email{patricia.menendez@unimelb.edu.au} (\href{https://orcid.org/0000-0003-0701-6315}{ORCID}) } } diff --git a/man/huber.Rd b/man/huber.Rd new file mode 100644 index 0000000..443985f --- /dev/null +++ b/man/huber.Rd @@ -0,0 +1,111 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/huber-plot.R +\name{geom_huber} +\alias{geom_huber} +\alias{theme_huber} +\title{Create Huber plot with ggplot2} +\usage{ +geom_huber( + mapping = NULL, + data = NULL, + stat = "identity", + position = "identity", + ..., + index = NULL, + show.legend = NA, + inherit.aes = TRUE +) + +theme_huber(...) +} +\arguments{ +\item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and +\code{inherit.aes = TRUE} (the default), it is combined with the default mapping +at the top level of the plot. You must supply \code{mapping} if there is no plot +mapping.} + +\item{data}{The data to be displayed in this layer. There are three +options: + +If \code{NULL}, the default, the data is inherited from the plot +data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}. + +A \code{data.frame}, or other object, will override the plot +data. All objects will be fortified to produce a data frame. See +\code{\link[ggplot2:fortify]{fortify()}} for which variables will be created. + +A \code{function} will be called with a single argument, +the plot data. The return value must be a \code{data.frame}, and +will be used as the layer data. A \code{function} can be created +from a \code{formula} (e.g. \code{~ head(.x, 10)}).} + +\item{stat}{The statistical transformation to use on the data for this layer. +When using a \verb{geom_*()} function to construct a layer, the \code{stat} +argument can be used the override the default coupling between geoms and +stats. The \code{stat} argument accepts the following: +\itemize{ +\item A \code{Stat} ggproto subclass, for example \code{StatCount}. +\item A string naming the stat. To give the stat as a string, strip the +function name of the \code{stat_} prefix. For example, to use \code{stat_count()}, +give the stat as \code{"count"}. +\item For more information and other ways to specify the stat, see the +\link[ggplot2:layer_stats]{layer stat} documentation. +}} + +\item{position}{A position adjustment to use on the data for this layer. This +can be used in various ways, including to prevent overplotting and +improving the display. The \code{position} argument accepts the following: +\itemize{ +\item The result of calling a position function, such as \code{position_jitter()}. +This method allows for passing extra arguments to the position. +\item A string naming the position adjustment. To give the position as a +string, strip the function name of the \code{position_} prefix. For example, +to use \code{position_jitter()}, give the position as \code{"jitter"}. +\item For more information and other ways to specify the position, see the +\link[ggplot2:layer_positions]{layer position} documentation. +}} + +\item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}'s \code{params} argument. These +arguments broadly fall into one of 4 categories below. Notably, further +arguments to the \code{position} argument, or aesthetics that are required +can \emph{not} be passed through \code{...}. Unknown arguments that are not part +of the 4 categories below are ignored. +\itemize{ +\item Static aesthetics that are not mapped to a scale, but are at a fixed +value and apply to the layer as a whole. For example, \code{colour = "red"} +or \code{linewidth = 3}. The geom's documentation has an \strong{Aesthetics} +section that lists the available options. The 'required' aesthetics +cannot be passed on to the \code{params}. Please note that while passing +unmapped aesthetics as vectors is technically possible, the order and +required length is not guaranteed to be parallel to the input data. +\item When constructing a layer using +a \verb{stat_*()} function, the \code{...} argument can be used to pass on +parameters to the \code{geom} part of the layer. An example of this is +\code{stat_density(geom = "area", outline.type = "both")}. The geom's +documentation lists which parameters it can accept. +\item Inversely, when constructing a layer using a +\verb{geom_*()} function, the \code{...} argument can be used to pass on parameters +to the \code{stat} part of the layer. An example of this is +\code{geom_area(stat = "density", adjust = 0.5)}. The stat's documentation +lists which parameters it can accept. +\item The \code{key_glyph} argument of \code{\link[ggplot2:layer]{layer()}} may also be passed on through +\code{...}. This can be one of the functions described as +\link[ggplot2:draw_key]{key glyphs}, to change the display of the layer in the legend. +}} + +\item{index}{a function, the projection pursuit index function, see examples} + +\item{show.legend}{logical. Should this layer be included in the legends? +\code{NA}, the default, includes if any aesthetics are mapped. +\code{FALSE} never includes, and \code{TRUE} always includes. +It can also be a named logical vector to finely select the aesthetics to +display.} + +\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, +rather than combining with them. This is most useful for helper functions +that define both data and aesthetics and shouldn't inherit behaviour from +the default plot specification, e.g. \code{\link[ggplot2:borders]{borders()}}.} +} +\description{ +Create Huber plot with ggplot2 +}