Skip to content

Commit

Permalink
feat: 'update_alpha()' now available as a standalone
Browse files Browse the repository at this point in the history
* `update_alpha()` is now available as a "standalone" file.
  You may copy its source under the permissive MIT license into your own R package by either
  using `usethis::use_standalone("trevorld/gridpattern", "standalone-update_alpha.R")`
  or simply copying `standalone-update_alpha.R` into your R directory and adding
  `grDevices`, `grid`, and `rlang` to the `Imports` of your `DESCRIPTION` file.

* We now always use `update_alpha()` to update the non-fill color alpha
  values as well (which potentially could also be passed a length-one
  list of a color vector by `{ggpattern}`)

closes #72
  • Loading branch information
trevorld committed Apr 18, 2024
1 parent b174bb7 commit ef83cc5
Show file tree
Hide file tree
Showing 15 changed files with 204 additions and 133 deletions.
2 changes: 1 addition & 1 deletion DESCRIPTION
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
Package: gridpattern
Type: Package
Title: 'grid' Pattern Grobs
Version: 1.2.0-1
Version: 1.2.0-2
Authors@R: c(person("Mike", "FC", role = "aut", comment = "Code/docs adapted from ggpattern"),
person("Trevor L.", "Davis", role=c("aut", "cre"), email="[email protected]",
comment = c(ORCID = "0000-0001-6341-4639")),
Expand Down
11 changes: 7 additions & 4 deletions NEWS.md
Original file line number Diff line number Diff line change
Expand Up @@ -3,15 +3,18 @@ gridpattern v1.2.0 (development)

* `patternFill()` wraps `patternGrob()` to return a
`grid::pattern()` fill object (#70).

* The "geometry" patterns (e.g. "circle", "stripe", etc.) now allow
the `fill` to be pattern fills (#67).
* `update_alpha()` updates fill colour and/or pattern transparency.

+ It is a fork of `ggplot2::fill_alpha()` by @teunbrand.
+ It does not depend on `{ggplot2}` or `{scales}`.
+ It does not throw an error with a length one list of a vector of multiple colours.

* The "geometry" patterns (e.g. "circle", "stripe", etc.) now allow
the `fill` to be pattern fills (#67).
+ It is available as a "standalone" file.
You may copy its source under the permissive MIT license into your own R package by either
using `usethis::use_standalone("trevorld/gridpattern", "standalone-update_alpha.R")`
or simply copying `standalone-update_alpha.R` into your R directory and adding
`grDevices`, `grid`, and `rlang` to the `Imports` of your `DESCRIPTION` file.

gridpattern v1.1.1
==================
Expand Down
2 changes: 1 addition & 1 deletion R/pattern-both-rose.R
Original file line number Diff line number Diff line change
Expand Up @@ -71,7 +71,7 @@ create_pattern_rose <- function(params, boundary_df, aspect_ratio, legend = FALS

# construct grobs using subsets if certain inputs are vectorized
fill <- update_alpha(params$pattern_fill, params$pattern_alpha)
col <- alpha(params$pattern_colour, params$pattern_alpha)
col <- update_alpha(params$pattern_colour, params$pattern_alpha)
lwd <- params$pattern_linewidth * .pt
lty <- params$pattern_linetype

Expand Down
2 changes: 1 addition & 1 deletion R/pattern-both-text.R
Original file line number Diff line number Diff line change
Expand Up @@ -67,7 +67,7 @@ create_pattern_text <- function(params, boundary_df, aspect_ratio, legend = FALS
grid_xy <- get_xy_grid(params, vpm)

# vectorize fill, col, lwd, lty, density, rot, and shape
col <- alpha(params$pattern_colour, params$pattern_alpha)
col <- update_alpha_col(params$pattern_colour, params$pattern_alpha)
fontsize <- params$pattern_size
fontfamily <- params$pattern_fontfamily
fontface <- params$pattern_fontface
Expand Down
2 changes: 1 addition & 1 deletion R/pattern-geometry-crosshatch.R
Original file line number Diff line number Diff line change
Expand Up @@ -58,7 +58,7 @@ create_crosshatch_via_sf_helper <- function(params, boundary_df, add_top_hatch =
grid_xy <- get_xy_grid(params, vpm)

fill <- update_alpha(params$pattern_fill, params$pattern_alpha)
col <- alpha(params$pattern_colour, params$pattern_alpha)
col <- update_alpha(params$pattern_colour, params$pattern_alpha)
lwd <- params$pattern_linewidth * .pt
lty <- params$pattern_linetype
gp <- gpar(col = col, fill = fill, lwd = lwd, lty = lty, lineend = 'square')
Expand Down
2 changes: 1 addition & 1 deletion R/pattern-geometry-pch.R
Original file line number Diff line number Diff line change
Expand Up @@ -68,7 +68,7 @@ grid.pattern_pch <- function(x = c(0, 0, 1, 1), y = c(1, 0, 0, 1), id = 1L, ...,
create_pattern_pch <- function(params, boundary_df, aspect_ratio, legend = FALSE) {
# vectorize fill, col, lwd, lty, density, rot, and shape
fill <- update_alpha(params$pattern_fill, params$pattern_alpha)
col <- alpha(params$pattern_colour, params$pattern_alpha)
col <- update_alpha(params$pattern_colour, params$pattern_alpha)
lwd <- params$pattern_linewidth
lty <- params$pattern_linetype
params$pattern_alpha <- NA_real_
Expand Down
2 changes: 1 addition & 1 deletion R/pattern-geometry-regular_polygon.R
Original file line number Diff line number Diff line change
Expand Up @@ -106,7 +106,7 @@ create_pattern_regular_polygon_via_sf <- function(params, boundary_df, aspect_ra

# construct grobs using subsets if certain inputs are vectorized
fill <- update_alpha(params$pattern_fill, params$pattern_alpha)
col <- alpha(params$pattern_colour, params$pattern_alpha)
col <- update_alpha(params$pattern_colour, params$pattern_alpha)
lwd <- params$pattern_linewidth * .pt
lty <- params$pattern_linetype

Expand Down
2 changes: 1 addition & 1 deletion R/pattern-geometry-tiling.R
Original file line number Diff line number Diff line change
Expand Up @@ -149,7 +149,7 @@ create_pattern_polygon_tiling <- function(params, boundary_df, aspect_ratio, leg
xyi <- boundary_df

fill <- update_alpha(params$pattern_fill, params$pattern_alpha)
col <- alpha(params$pattern_colour, params$pattern_alpha)
col <- update_alpha(params$pattern_colour, params$pattern_alpha)
lwd <- params$pattern_linewidth
lty <- params$pattern_linetype
stopifnot(length(fill) < 4L, max(lengths(list(col, lwd, lty))) == 1L)
Expand Down
2 changes: 1 addition & 1 deletion R/pattern-geometry-wave.R
Original file line number Diff line number Diff line change
Expand Up @@ -63,7 +63,7 @@ create_pattern_wave_via_sf <- function(params, boundary_df, aspect_ratio,
grid_xy <- get_xy_grid(params, vpm)

fill <- update_alpha(params$pattern_fill, params$pattern_alpha)
col <- alpha(params$pattern_colour, params$pattern_alpha)
col <- update_alpha(params$pattern_colour, params$pattern_alpha)
lwd <- params$pattern_linewidth * .pt
lty <- params$pattern_linetype
density <- params$pattern_density
Expand Down
2 changes: 1 addition & 1 deletion R/pattern-geometry-weave.R
Original file line number Diff line number Diff line change
Expand Up @@ -87,7 +87,7 @@ create_warp_via_sf <- function(params, boundary_df) {
grid_xy <- get_xy_grid(params, vpm)

fill <- update_alpha(params$pattern_fill2, params$pattern_alpha)
col <- alpha(params$pattern_colour, params$pattern_alpha)
col <- update_alpha(params$pattern_colour, params$pattern_alpha)
lwd <- params$pattern_linewidth * .pt
lty <- params$pattern_linetype
gp <- gpar(col = col, fill = fill, lwd = lwd, lty = lty, lineend = 'square')
Expand Down
132 changes: 132 additions & 0 deletions R/standalone-update_alpha.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,132 @@
# ---
# repo: trevorld/gridpattern
# file: standalone-update_alpha.R
# last-updated: 2024-04-18
# license: https://spdx.org/licenses/MIT.html
# imports: [grDevices, grid, rlang]
# ---
#
# nocov start
#
# You may copy this source into your own R package
# by either using `usethis::use_standalone("trevorld/gridpattern", "standalone-update_alpha.R")`
# or simply copying this file into your `R` directory and adding `grDevices`, `grid`, and `rlang` to
# the `Imports` of your `DESCRIPTION` file.

# The MIT License (MIT)
# =====================
#
# Copyright © 2024 Trevor L. Davis
# Copyright © 2020 [email protected]
# Copyright © 2023 ggplot2 authors
#
# Permission is hereby granted, free of charge, to any person
# obtaining a copy of this software and associated documentation
# files (the “Software”), to deal in the Software without
# restriction, including without limitation the rights to use,
# copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the
# Software is furnished to do so, subject to the following
# conditions:
#
# The above copyright notice and this permission notice shall be
# included in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND,
# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
# OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
# OTHER DEALINGS IN THE SOFTWARE.

# Pattern utilities mainly added to ggplot2 by Teun van den Brand
# Tweaked by Trevor L. Davis to remove external dependencies
# and work better for {ggpattern} / {gridpattern} use cases.
update_alpha <- function(fill, alpha) {
if (!is.list(fill)) {
# Happy path of no patterns
update_alpha_col(fill, alpha)
} else if (is_pattern(fill) || any(vapply(fill, is_pattern, logical(1)))) {
# Path with patterns
update_pattern_alpha(fill, alpha)
} else if (is.list(fill) && length(fill) == 1L && !any(vapply(fill, is_pattern, logical(1)))) {
# List of length one of (possibly multiple) colours
update_alpha_col(fill[[1L]], alpha)
} else {
# We are either dealing with faulty fill specification
stop("`fill` must be a vector of colours or list of <GridPattern> objects.")
}
}

# Similar to grid:::is.pattern
is_pattern <- function(x) {
inherits(x, "GridPattern")
}

# replacement for `scales::alpha()` that only depends on {grDevices}
update_alpha_col <- function(colour, alpha = NA_real_) {
n <- max(lengths(list(colour, alpha)))
colour <- rep_len(colour, n)
alpha <- rep_len(alpha, n)
m <- grDevices::col2rgb(colour, alpha = TRUE) / 255.0
m[4, ] <- ifelse(is.na(alpha), m[4, ], alpha)
apply(m, 2, function(x) grDevices::rgb(x[1], x[2], x[3], x[4]))
}

#' Modify transparency for patterns
#'
#' This generic allows you to add your own methods for adding transparency to
#' pattern-like objects.
#'
#' @param x Object to be interpreted as pattern.
#' @param alpha A `numeric` vector between 0 and 1. If `NA`, alpha values
#' are preserved.
#'
#' @return `x` with modified transparency
#' @noRd
update_pattern_alpha <- function(x, alpha, ...) {
UseMethod("update_pattern_alpha")
}

#' @export
update_pattern_alpha.default <- function(x, alpha, ..., name = NULL) {
if (!is.atomic(x)) {
stop("Can't apply `update_pattern_alpha()` to this object.")
}
grid::pattern(grid::rectGrob(name = name),
gp = grid::gpar(fill = update_alpha_col(x, alpha)))
}

#' @export
update_pattern_alpha.GridPattern <- function(x, alpha, ...) {
x$colours <- update_alpha_col(x$colours, alpha[1])
x
}

#' @export
update_pattern_alpha.GridTilingPattern <- function(x, alpha, ...) {
if (all(is.na(alpha) | alpha == 1)) {
return(x)
}
grob <- rlang::env_get(environment(x$f), "grob")
gp <- grid::gpar(fill = update_alpha_col("white", alpha))
mask <- grid::as.mask(grid::rectGrob(gp = gp))
if (is.null(grob$vp)) {
grob$vp <- grid::viewport(mask = mask)
} else {
grob$vp <- grid::editViewport(grob$vp, mask = mask)
}
new_env <- new.env(parent = environment(x$f))
rlang::env_bind(new_env, grob = grob)
environment(x$f) <- new_env
x
}

#' @export
update_pattern_alpha.list <- function(x, alpha, ...) {
Map(update_pattern_alpha, x = x, alpha = alpha)
}

# nocov end
111 changes: 0 additions & 111 deletions R/utils-ggplot2.R
Original file line number Diff line number Diff line change
@@ -1,13 +1,3 @@
# replacement for scales::alpha that only depends on grDevices
alpha <- function(colour, alpha = NA_real_) {
n <- max(lengths(list(colour, alpha)))
colour <- rep(colour, length.out = n)
alpha <- rep(alpha, length.out = n)
m <- grDevices::col2rgb(colour, alpha=TRUE) / 255.0
m[4, ] <- ifelse(is.na(alpha), m[4, ], alpha)
apply(m, 2, function(x) grDevices::rgb(x[1], x[2], x[3], x[4]))
}

# Added to ggplot2 by Thomas Lin Pedersen
# Fast data.frame constructor and indexing
# No checking, recycling etc. unless asked for
Expand Down Expand Up @@ -36,104 +26,3 @@ data_frame <- function(...) {
new_data_frame(list(...))
}
.pt <- 2.845276 # ggplot2 constant

# Pattern utilities mainly added to ggplot2 by Teun van den Brand

#' Update fill colour and/or pattern transparency
#'
#' `update_alpha()` modifies the transparency of fill colours and/or patterns.
#'
#' * Like [ggplot2::fill_alpha()] but unlike [scales::alpha()] it also attempts
#' to set the transparency of `<GridPattern>` objects.
#' * Unlike [ggplot2::fill_alpha()] it will work on a list of length one
#' with more than one color.
#' * `update_alpha()` does not depend on `ggplot2` or `scales`.
#'
#' @param fill A fill colour given as a `character` or `integer` vector, or as a
#' (list of) `<GridPattern>` object(s) and/or colour(s).
#' @param alpha A transparency value between 0 (transparent) and 1 (opaque),
#' parallel to `fill`.
#'
#' @return A `character` vector of colours or list of `<GridPattern>` objects.
#' @export
#'
#' @examples
#' # Typical colour input
#' update_alpha("red", 0.5)
#'
#' if (utils::packageVersion("grid") > "4.1") {
#' # Pattern input
#' update_alpha(list(grid::linearGradient()), 0.5)
#' }
update_alpha <- function(fill, alpha) {
if (!is.list(fill)) {
# Happy path of no patterns
alpha(fill, alpha)
} else if (is_pattern(fill) || any(vapply(fill, is_pattern, logical(1)))) {
# Path with patterns
update_pattern_alpha(fill, alpha)
} else if (is.list(fill) && length(fill) == 1L && !any(vapply(fill, is_pattern, logical(1)))) {
# List of length one of (possibly multiple) colours
alpha(fill[[1L]], alpha)
} else {
# We are either dealing with faulty fill specification
stop("`fill` must be a vector of colours or list of <GridPattern> objects.")
}
}

# Similar to grid:::is.pattern
is_pattern <- function(x) {
inherits(x, "GridPattern")
}

#' Modify transparency for patterns
#'
#' This generic allows you to add your own methods for adding transparency to
#' pattern-like objects.
#'
#' @param x Object to be interpreted as pattern.
#' @param alpha A `numeric` vector between 0 and 1. If `NA`, alpha values
#' are preserved.
#'
#' @return `x` with modified transparency
#' @noRd
update_pattern_alpha <- function(x, alpha, ...) {
UseMethod("update_pattern_alpha")
}

#' @export
update_pattern_alpha.default <- function(x, alpha, ..., name = NULL) {
if (!is.atomic(x)) {
stop("Can't apply `update_pattern_alpha()` to this object.")
}
pattern(rectGrob(name = name), gp = gpar(fill = alpha(x, alpha)))
}

#' @export
update_pattern_alpha.GridPattern <- function(x, alpha, ...) {
x$colours <- alpha(x$colours, alpha[1])
x
}

#' @export
update_pattern_alpha.GridTilingPattern <- function(x, alpha, ...) {
if (all(is.na(alpha) | alpha == 1)) {
return(x)
}
grob <- rlang::env_get(environment(x$f), "grob")
mask <- as.mask(rectGrob(gp = gpar(fill = alpha("white", alpha))))
if (is.null(grob$vp)) {
grob$vp <- viewport(mask = mask)
} else {
grob$vp <- editViewport(grob$vp, mask = mask)
}
new_env <- new.env(parent = environment(x$f))
rlang::env_bind(new_env, grob = grob)
environment(x$f) <- new_env
x
}

#' @export
update_pattern_alpha.list <- function(x, alpha, ...) {
Map(update_pattern_alpha, x = x, alpha = alpha)
}
36 changes: 36 additions & 0 deletions R/z_update_alpha_docs.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,36 @@
# The code for this function is in `standalone-update_alpha.R`

#' Update colour and/or pattern transparency
#'
#' `update_alpha()` modifies the transparency of colours and/or patterns.
#'
#' * This is a fork of pattern utilities mainly added to `{ggplot2}` by Teun van den Brand.
#' * `update_alpha()` does not depend on `{ggplot2}` or `{scales}`.
#' * Like [ggplot2::fill_alpha()] but unlike [scales::alpha()] it also attempts
#' to set the transparency of `<GridPattern>` objects.
#' * Unlike [ggplot2::fill_alpha()] it will work on a list of length one
#' containing a vector of color strings.
#'
#' @section Usage in other packages:
#'
#' To avoid taking a dependency on `gridpattern` you may copy the source of `update_alpha()`
#' into your own package under the permissive MIT license. Either use
#' `usethis::use_standalone("trevorld/gridpattern", "standalone-update_alpha.R")`
#' or copy the file `update_alpha.R` into your `R` directory and
#' add `grDevices`, `grid`, and `rlang` to the `Imports` of your `DESCRIPTION` file.
#'
#' @param fill A fill colour given as a `character` or `integer` vector, or as a
#' (list of) `<GridPattern>` object(s) and/or colour(s).
#' @param alpha A transparency value between 0 (transparent) and 1 (opaque),
#' parallel to `fill`.
#' @return A `character` vector of colours or list of `<GridPattern>` objects.
#' @examples
#' # Typical color input
#' update_alpha("red", 0.5)
#'
#' # Pattern input
#' if (getRversion() >= "4.2" && requireNamespace("grid", quietly = TRUE)) {
#' update_alpha(list(grid::linearGradient()), 0.5)
#' }
#' @export
update_alpha <- update_alpha
Loading

0 comments on commit ef83cc5

Please sign in to comment.