diff --git a/NAMESPACE b/NAMESPACE index c20697c..cf92480 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,10 @@ # Generated by roxygen2: do not edit by hand +S3method("$<-",marquee_style) +S3method("[",marquee_skip_inherit) +S3method("[<-",marquee_style) +S3method("[[",marquee_skip_inherit) +S3method("[[<-",marquee_style) S3method(format,marquee_em) S3method(format,marquee_relative) S3method(format,marquee_rem) diff --git a/R/geom_marquee.R b/R/geom_marquee.R index fc4ab9e..7d31621 100644 --- a/R/geom_marquee.R +++ b/R/geom_marquee.R @@ -126,16 +126,18 @@ make_marquee_geom <- function() { !all(vapply(data$fill, function(x) is.character(x) || inherits(x, "GridPattern"), logical(1)))) { stop_input_type(data$fill, "a character vector or a list of strings and patters", arg = "fill") } - for (i in seq_along(styles)) { - styles[[i]]$base$family <- data$family[[i]] - styles[[i]]$base$size <- size[[i]] - styles[[i]]$base$lineheight <- data$lineheight[[i]] - styles[[i]]$base$color <- colour[[i]] - if (!"body" %in% names(styles[[i]])) { - styles[[i]]$body <- style() - } - styles[[i]]$body$background <- skip_inherit(data$fill[[i]]) - } + + styles <- modify_style(styles, + "base", + family = data$family, + size = size, + lineheight = data$lineheight, + color = colour + ) + styles <- modify_style(styles, + "body", + background = skip_inherit(data$fill) + ) data <- coord$transform(data, panel_params) diff --git a/R/style.R b/R/style.R index d513a70..87305df 100644 --- a/R/style.R +++ b/R/style.R @@ -207,6 +207,21 @@ str.marquee_style <- function(object, ...) { return(invisible(NULL)) } +#' @export +`$<-.marquee_style` <- function(x, name, value) { + cli::cli_abort("Setting style values using {.arg $}, {.arg []}, or {.arg [[]]} are not permitted. Please use {.fun modify_style}") +} + +#' @export +`[[<-.marquee_style` <- function(x, ..., value) { + cli::cli_abort("Setting style values using {.arg $}, {.arg []}, or {.arg [[]]} are not permitted. Please use {.fun modify_style}") +} + +#' @export +`[<-.marquee_style` <- function(x, ..., value) { + cli::cli_abort("Setting style values using {.arg $}, {.arg []}, or {.arg [[]]} are not permitted. Please use {.fun modify_style}") +} + #' @rdname style #' @export base_style <- function(family = "", weight = "normal", italic = FALSE, diff --git a/R/style_helpers.R b/R/style_helpers.R index b9f5d56..0c3a552 100644 --- a/R/style_helpers.R +++ b/R/style_helpers.R @@ -126,6 +126,16 @@ format.marquee_skip_inherit <- function(x, ...) { paste0(str, " (no inheritance)") } +#' @export +`[[.marquee_skip_inherit` <- function(x, ..., value) { + skip_inherit(NextMethod()) +} + +#' @export +`[.marquee_skip_inherit` <- function(x, ..., value) { + skip_inherit(NextMethod()) +} + #' @export print.marquee_skip_inherit <- print.marquee_relative diff --git a/R/style_set.R b/R/style_set.R index 20d9eb3..2e1795c 100644 --- a/R/style_set.R +++ b/R/style_set.R @@ -10,10 +10,11 @@ #' @param ... Named arguments providing a style for the specific tags. For #' `modify_style()` a number of style options to change. If the first argument #' is a marquee style it will overwrite the tag and subsequent arguments are -#' ignored -#' @param style_set A style set to modify -#' @param tag The name of a tag to modify or remove. Tags are internally all -#' lowercase and `tag` will be converted to lowercase before matching +#' ignored. This only holds if `x` is a style set. +#' @param x A style or style set to modify +#' @param tag The name of the tag to modify or remove if `x` is a style set. Tags +#' are internally all lowercase and `tag` will be converted to lowercase before +#' matching #' #' @return A `marquee_style_set` object #' @@ -71,67 +72,80 @@ format.marquee_style_set <- function(x, ...) { #' @rdname style_set #' @export -modify_style <- function(style_set, tag, ...) { +modify_style <- function(x, tag, ...) { + opts <- list2(...) + args <- names(opts) + expand <- args %in% c("margin", "padding", "border_size") + if (any(expand)) { + args <- c(args[!expand], paste0(rep(args[expand], each = 4), "_", c("top", "right", "bottom", "left"))) + } + + if (is_style(x)) { + new_style <- style(...) + cls <- class(x) + class(x) <- NULL + x[args] <- new_style[args] + class(x) <- cls + return(x) + } + tag <- tolower(tag) - if (!is_style_set(style_set)) { - stop_input_type(style_set, "a style set object") + if (!is_style_set(x)) { + stop_input_type(x, "a style set object") } check_character(tag) - tag <- vctrs::vec_recycle(tag, length(style_set)) + tag <- vctrs::vec_recycle(tag, length(x)) - opts <- list2(...) for (i in seq_along(opts)) { opt <- opts[[i]] if (is.null(opt) || is_style(opt) || is_modifier(opt) || - is_trbl(opt) || inherits(opt, "marquee_skip_inherit") || - inherits(opt, "font_feature") || inherits(opt, "GridPattern")) { + is_trbl(opt) || inherits(opt, "font_feature") || + inherits(opt, "GridPattern")) { opt <- list(opt) } - opts[[i]] <- vctrs::vec_recycle(opt, length(style_set), x_arg = names(opts)[i]) + opts[[i]] <- vctrs::vec_recycle(opt, length(x), x_arg = names(opts)[i]) } - args <- names(opts) - expand <- args %in% c("margin", "padding", "border_size") - if (any(expand)) { - args <- c(args[!expand], paste0(rep(args[expand], each = 4), "_", c("top", "right", "bottom", "left"))) - } - for (i in seq_along(style_set)) { + for (i in seq_along(x)) { if (is_style(opts[[1]][[i]])) { if (tag[i] == "base" && any(vapply(opts[[1]][[i]], is.null, logical(1)))) { cli::cli_abort("The base tag must be set to a complete style") } - style_set[[i]][[tag[i]]] <- opts[[1]][[i]] + x[[i]][[tag[i]]] <- opts[[1]][[i]] } else { new_style <- inject(style(!!!lapply(opts, `[[`, i))) - old_style <- style_set[[i]][[tag[i]]] + old_style <- x[[i]][[tag[i]]] if (is.null(old_style)) { - style_set[[i]][[tag[i]]] <- new_style + x[[i]][[tag[i]]] <- new_style } else { if (tag[i] == "base" && any(vapply(new_style[args], is.null, logical(1)))) { cli::cli_abort("The base tag cannot have any styles set to {.val NULL}") } - style_set[[i]][[tag[i]]][args] <- new_style[args] + cls <- class(x[[i]][[tag[i]]]) + class(x[[i]][[tag[i]]]) <- NULL + x[[i]][[tag[i]]][args] <- new_style[args] + class(x[[i]][[tag[i]]]) <- cls } } } - style_set + x } #' @rdname style_set #' @export -remove_style <- function(style_set, tag) { +remove_style <- function(x, tag) { tag <- tolower(tag) - if (!is_style_set(style_set)) { - stop_input_type(style_set, "a style set object") + if (!is_style_set(x)) { + stop_input_type(x, "a style set object") } check_character(tag) if (any(tag == "base")) { cli::cli_abort("The base style cannot be removed") } - tag <- vctrs::vec_recycle(tag, length(style_set)) - for (i in seq_along(style_set)) { - style_set[[i]][tag[i]] <- NULL + tag <- vctrs::vec_recycle(tag, length(x)) + for (i in seq_along(x)) { + x[[i]][tag[i]] <- NULL } - style_set + x } diff --git a/man/style_set.Rd b/man/style_set.Rd index 0726528..64f50c8 100644 --- a/man/style_set.Rd +++ b/man/style_set.Rd @@ -8,20 +8,21 @@ \usage{ style_set(...) -modify_style(style_set, tag, ...) +modify_style(x, tag, ...) -remove_style(style_set, tag) +remove_style(x, tag) } \arguments{ \item{...}{Named arguments providing a style for the specific tags. For \code{modify_style()} a number of style options to change. If the first argument is a marquee style it will overwrite the tag and subsequent arguments are -ignored} +ignored. This only holds if \code{x} is a style set.} -\item{style_set}{A style set to modify} +\item{x}{A style or style set to modify} -\item{tag}{The name of a tag to modify or remove. Tags are internally all -lowercase and \code{tag} will be converted to lowercase before matching} +\item{tag}{The name of the tag to modify or remove if \code{x} is a style set. Tags +are internally all lowercase and \code{tag} will be converted to lowercase before +matching} } \value{ A \code{marquee_style_set} object diff --git a/tests/testthat/Rplots.pdf b/tests/testthat/Rplots.pdf index 6433eb8..f76a532 100644 Binary files a/tests/testthat/Rplots.pdf and b/tests/testthat/Rplots.pdf differ diff --git a/tests/testthat/test-style_set.R b/tests/testthat/test-style_set.R index 4842f1e..f28e0d4 100644 --- a/tests/testthat/test-style_set.R +++ b/tests/testthat/test-style_set.R @@ -45,6 +45,15 @@ test_that("modify_style() does correct modification", { expect_snapshot_error(modify_style(ss, "body", size = 1:2)) }) +test_that("modify_style works on style objects", { + s <- base_style() + s <- modify_style(s, size = 6, color = "grey", padding = trbl(em(3), 0)) + expect_equal(s$size, 6) + expect_equal(s$color, "grey") + expect_equal(s$padding_top, em(3)) + expect_equal(s$padding_right, 0) +}) + test_that("remove_style() works", { ss <- style_set(base = base_style(), body = style())