Skip to content

Commit

Permalink
Merge branch 'Use.match.arg'
Browse files Browse the repository at this point in the history
  • Loading branch information
@aphalo
aphalo committed Feb 20, 2023
2 parents f412ad1 + 5c5201b commit 530f4bd
Show file tree
Hide file tree
Showing 48 changed files with 739 additions and 641 deletions.
4 changes: 2 additions & 2 deletions DESCRIPTION
View file
Original file line number Diff line number Diff line change
@@ -1,8 +1,8 @@
Package: ggpp
Type: Package
Title: Grammar Extensions to 'ggplot2'
Version: 0.5.1.9000
Date: 2023-02-17
Version: 0.5.1.9001
Date: 2023-02-19
Authors@R:
c(
person("Pedro J.", "Aphalo", email = "[email protected]", role = c("aut", "cre"), comment = c(ORCID = "0000-0003-3385-972X")),
Expand Down
3 changes: 2 additions & 1 deletion R/dark-or-light.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -41,7 +41,8 @@ dark_or_light <- function(colors,
{
if (!length(colors))
return(character())
stopifnot(length(threshold) == 1L && threshold >= 0 && threshold <= 1)
stopifnot("'threshold' should have length = 1" = length(threshold) == 1L,
"'threshold' should be within 0..1" = threshold >= 0 && threshold <= 1)
threshold <- trunc(threshold * 255)
# approximate luminance in 0..255
lum <- sapply(colors, function(x) {
Expand Down
145 changes: 87 additions & 58 deletions R/geom-grob.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -9,7 +9,10 @@
#' objects rather than text. \code{\link{geom_grob_npc}} is used to add grobs
#' as annotations to plots, but contrary to layer function \code{annotate()},
#' \code{\link{geom_grob_npc}} is data driven and respects grouping and facets,
#' thus plot insets can differ among panels.
#' thus plot insets can differ among panels. Of these two geoms only
#' \code{\link{geom_grob}} supports the plotting of segments, as
#' \code{\link{geom_grob_npc}} uses a coordinate system that is unrelated
#' to data units and data.
#'
#' @details You can modify the size of insets with the \code{vp.width} and
#' \code{vp.height} aesthetics. These can take a number between 0 (smallest
Expand Down Expand Up @@ -93,12 +96,12 @@
#' @param default.colour A colour definition to use for elements not targeted by
#' the colour aesthetic.
#' @param colour.target A vector of character strings; \code{"all"},
#' \code{"text"}, \code{"box"} and \code{"segment"}.
#' \code{"text"}, \code{"box"} and \code{"segment"} or \code{"none"}.
#' @param default.alpha numeric in [0..1] A transparency value to use for
#' elements not targeted by the alpha aesthetic.
#' @param alpha.target A vector of character strings; \code{"all"},
#' \code{"text"}, \code{"segment"}, \code{"box"}, \code{"box.line"}, and
#' \code{"box.fill"}.
#' \code{"box.fill"} or \code{"none"}.
#' @param add.segments logical Display connecting segments or arrows between
#' original positions and displaced ones if both are available.
#' @param box.padding,point.padding numeric By how much each end of the segments
Expand Down Expand Up @@ -137,7 +140,20 @@
#' geom_grob(data = df,
#' aes(x, y, label = grob),
#' nudge_x = 0.5,
#' colour = "red")
#' colour = "red",
#' hjust = 0.5,
#' vjust = 0.5)
#'
#' ggplot(data = mtcars,
#' aes(wt, mpg)) +
#' geom_point(aes(colour = factor(cyl))) +
#' geom_grob(data = df,
#' aes(x, y, label = grob),
#' nudge_x = 0.5,
#' colour = "red",
#' colour.target = "none",
#' hjust = 0.5,
#' vjust = 0.5)
#'
#' # with nudging plotting of segments can be disabled
#' ggplot(data = mtcars,
Expand All @@ -146,62 +162,75 @@
#' geom_grob(data = df,
#' aes(x, y, label = grob),
#' add.segments = FALSE,
#' nudge_x = 0.5)
#' nudge_x = 0.5,
#' hjust = 0.5,
#' vjust = 0.5)
#'
geom_grob <- function(mapping = NULL,
data = NULL,
stat = "identity",
position = "identity",
...,
nudge_x = 0,
nudge_y = 0,
default.colour = "black",
colour.target = "segment",
default.alpha = 1,
alpha.target = "segment",
add.segments = TRUE,
box.padding = 0.25,
point.padding = 1e-06,
segment.linewidth = 0.5,
min.segment.length = 0,
arrow = NULL,
na.rm = FALSE,
show.legend = FALSE,
inherit.aes = FALSE) {

if (!missing(nudge_x) || !missing(nudge_y)) {
if (!missing(position) && position != "identity") {
rlang::abort("You must specify either `position` or `nudge_x`/`nudge_y`.")
geom_grob <-
function(mapping = NULL,
data = NULL,
stat = "identity",
position = "identity",
...,
nudge_x = 0,
nudge_y = 0,
default.colour = "black",
colour.target = "segment",
default.alpha = 1,
alpha.target = "segment",
add.segments = TRUE,
box.padding = 0.25,
point.padding = 1e-06,
segment.linewidth = 0.5,
min.segment.length = 0,
arrow = NULL,
na.rm = FALSE,
show.legend = FALSE,
inherit.aes = FALSE) {

colour.target <-
rlang::arg_match(colour.target,
values = c("segment", "all", "grob", "box", "none"),
multiple = TRUE)
alpha.target <-
rlang::arg_match(alpha.target,
values = c("segment", "all", "grob", "box",
"box.line", "box.fill", "none"),
multiple = TRUE)

if (!missing(nudge_x) || !missing(nudge_y)) {
if (!missing(position) && position != "identity") {
rlang::abort("You must specify either `position` or `nudge_x`/`nudge_y`.")
}
# original position needed for "position" justification
position <-
position_nudge_center(nudge_x, nudge_y, kept.origin = "original")
}
# original position needed for "position" justification
position <-
position_nudge_center(nudge_x, nudge_y, kept.origin = "original")
}

ggplot2::layer(
data = data,
mapping = mapping,
stat = stat,
geom = GeomGrob,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
default.colour = default.colour,
colour.target = colour.target,
default.alpha = default.alpha,
alpha.target = alpha.target,
add.segments = add.segments,
box.padding = box.padding,
point.padding = point.padding,
segment.linewidth = segment.linewidth,
min.segment.length = min.segment.length,
arrow = arrow,
na.rm = na.rm,
...
ggplot2::layer(
data = data,
mapping = mapping,
stat = stat,
geom = GeomGrob,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
default.colour = default.colour,
colour.target = colour.target,
default.alpha = default.alpha,
alpha.target = alpha.target,
add.segments = add.segments,
box.padding = box.padding,
point.padding = point.padding,
segment.linewidth = segment.linewidth,
min.segment.length = min.segment.length,
arrow = arrow,
na.rm = na.rm,
...
)
)
)
}
}

#' @rdname ggpp-ggproto
#' @format NULL
Expand All @@ -214,8 +243,8 @@ GeomGrob <-
default_aes = ggplot2::aes(
colour = "black",
angle = 0,
hjust = "position",
vjust = "position",
hjust = 0.5,
vjust = 0.5,
alpha = NA,
family = "",
fontface = 1,
Expand Down
74 changes: 43 additions & 31 deletions R/geom-label-linked.r
View file
Original file line number Diff line number Diff line change
Expand Up @@ -5,39 +5,51 @@
#'
#' @export
#'
geom_label_s <- function(mapping = NULL,
data = NULL,
stat = "identity",
position = "identity",
...,
parse = FALSE,
nudge_x = 0,
nudge_y = 0,
default.colour = "black",
colour.target = "all",
default.alpha = 1,
alpha.target = "box.fill",
label.padding = grid::unit(0.25, "lines"),
label.r = grid::unit(0.15, "lines"),
segment.linewidth = 0.5,
add.segments = TRUE,
box.padding = 1e-06,
point.padding = 1e-06,
min.segment.length = 0,
arrow = NULL,
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE)
{
if (!missing(nudge_x) || !missing(nudge_y)) {
if (!missing(position) && position != "identity") {
rlang::abort("You must specify either `position` or `nudge_x`/`nudge_y`.")
geom_label_s <-
function(mapping = NULL,
data = NULL,
stat = "identity",
position = "identity",
...,
parse = FALSE,
nudge_x = 0,
nudge_y = 0,
default.colour = "black",
colour.target = c("text", "box"),
default.alpha = 1,
alpha.target = "all",
label.padding = grid::unit(0.25, "lines"),
label.r = grid::unit(0.15, "lines"),
segment.linewidth = 0.5,
add.segments = TRUE,
box.padding = 1e-06,
point.padding = 1e-06,
min.segment.length = 0,
arrow = NULL,
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE) {

colour.target <-
rlang::arg_match(colour.target,
values = c("all", "text", "box", "box.line",
"segment", "none"),
multiple = TRUE)
alpha.target <-
rlang::arg_match(alpha.target,
values = c("all", "text", "box", "box.line", "box.fill",
"segment", "none"),
multiple = TRUE)

if (!missing(nudge_x) || !missing(nudge_y)) {
if (!missing(position) && position != "identity") {
rlang::abort("You must specify either `position` or `nudge_x`/`nudge_y`.")
}
# by default we keep the original positions
position <- position_nudge_keep(nudge_x, nudge_y)
}
# by default we keep the original positions
position <- position_nudge_keep(nudge_x, nudge_y)
}

ggplot2::layer(
ggplot2::layer(
data = data,
mapping = mapping,
stat = stat,
Expand Down
93 changes: 0 additions & 93 deletions R/geom-margin-point.r
View file
Original file line number Diff line number Diff line change
Expand Up @@ -287,96 +287,3 @@ GeomYMarginPoint <-

draw_key = ggplot2:::draw_key_point
)


## utils

# copied from 'ggplo2' 3.1.0 geom-point.r as this function is not exported.
translate_shape_string <- function(shape_string) {
# strings of length 0 or 1 are interpreted as symbols by grid
if (nchar(shape_string[1]) <= 1) {
return(shape_string)
}

pch_table <- c(
"square open" = 0,
"circle open" = 1,
"triangle open" = 2,
"plus" = 3,
"cross" = 4,
"diamond open" = 5,
"triangle down open" = 6,
"square cross" = 7,
"asterisk" = 8,
"diamond plus" = 9,
"circle plus" = 10,
"star" = 11,
"square plus" = 12,
"circle cross" = 13,
"square triangle" = 14,
"triangle square" = 14,
"square" = 15,
"circle small" = 16,
"triangle" = 17,
"diamond" = 18,
"circle" = 19,
"bullet" = 20,
"circle filled" = 21,
"square filled" = 22,
"diamond filled" = 23,
"triangle filled" = 24,
"triangle down filled" = 25
)

shape_match <- charmatch(shape_string, names(pch_table))

invalid_strings <- is.na(shape_match)
nonunique_strings <- shape_match == 0

if (any(invalid_strings)) {
bad_string <- unique(shape_string[invalid_strings])
n_bad <- length(bad_string)

collapsed_names <- sprintf("\n* '%s'", bad_string[1:min(5, n_bad)])

more_problems <- if (n_bad > 5) {
sprintf("\n* ... and %d more problem%s", n_bad - 5, ifelse(n_bad > 6, "s", ""))
}

stop(
"Can't find shape name:",
collapsed_names,
more_problems,
call. = FALSE
)
}

if (any(nonunique_strings)) {
bad_string <- unique(shape_string[nonunique_strings])
n_bad <- length(bad_string)

n_matches <- vapply(
bad_string[1:min(5, n_bad)],
function(shape_string) sum(grepl(paste0("^", shape_string), names(pch_table))),
integer(1)
)

collapsed_names <- sprintf(
"\n* '%s' partially matches %d shape names",
bad_string[1:min(5, n_bad)], n_matches
)

more_problems <- if (n_bad > 5) {
sprintf("\n* ... and %d more problem%s", n_bad - 5, ifelse(n_bad > 6, "s", ""))
}

stop(
"Shape names must be unambiguous:",
collapsed_names,
more_problems,
call. = FALSE
)
}

unname(pch_table[shape_match])
}
Loading

0 comments on commit 530f4bd

Please sign in to comment.