Skip to content

Commit

Permalink
Text formatting (#16)
Browse files Browse the repository at this point in the history 
* add `check_list_of()`

* add customisation options to bracket primitive

* add customisation options to box primitive

* passing text formatting to labels

* adopt formatting in ranged keys

* adopt formatting in regular keys

* update snapshot

* redocument
  • Loading branch information
@teunbrand
teunbrand authored Sep 7, 2024
1 parent 55ef655 commit a685b86
Show file tree
Hide file tree
Showing 16 changed files with 350 additions and 127 deletions.
32 changes: 22 additions & 10 deletions R/key-.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -79,20 +79,23 @@ NULL

#' @rdname key_standard
#' @export
key_auto <- function() {
key_auto <- function(...) {
function(scale, aesthetic = NULL) {
aesthetic <- aesthetic %||% scale$aesthetics[1]
df <- Guide$extract_key(scale, aesthetic)
df <- data_frame0(df, !!!label_args(...))
class(df) <- c("key_standard", "key_guide", class(df))
df
}
}

#' @rdname key_standard
#' @export
key_manual <- function(aesthetic, value = aesthetic, label = as.character(value), type = NULL) {
key_manual <- function(aesthetic, value = aesthetic,
label = as.character(value), type = NULL,
...) {
df <- data_frame0(aesthetic = aesthetic, value = value,
label = label, type = type)
label = label, type = type, !!!label_args(...))
check_columns(df, c("aesthetic", "value", "label"))
df <- rename(df, c("value", "label", "type"), c(".value", ".label", ".type"))
class(df) <- c("key_standard", "key_guide", class(df))
Expand All @@ -109,25 +112,31 @@ key_map <- function(data, ..., .call = caller_env()) {
df <- eval_aes(
data, mapping,
required = c("aesthetic"),
optional = c("value", "label"),
optional = c("value", "label", .label_params),
call = .call, arg_mapping = "mapping", arg_data = "data"
)
df$value <- df$value %||% df$aesthetic
df$label <- df$label %||% as.character(df$aesthetic)
check_columns(df, c("aesthetic", "value", "label"))

df <- rename(df, c("value", "label"), c(".value", ".label"))
df <- rename(
df,
c("value", "label", .label_params),
c(".value", ".label", paste0(".", .label_params))
)
class(df) <- c("key_standard", "key_guide", class(df))
df
}


#' @rdname key_standard
#' @export
key_minor <- function() {
key_minor <- function(...) {
dots <- label_args(...)
function(scale, aesthetic = NULL) {
aesthetic <- aesthetic %||% scale$aesthetics[1]
df <- GuideAxis$extract_key(scale, aesthetic, minor.ticks = TRUE)
df <- data_frame0(df, !!!dots)
class(df) <- c("key_standard", "key_guide", class(df))
df
}
Expand All @@ -137,7 +146,7 @@ key_minor <- function() {
#' @export
key_log <- function(
prescale_base = NULL, negative_small = 0.1, expanded = TRUE,
labeller = NULL
labeller = NULL, ...
) {
check_number_decimal(
negative_small, min = 1e-100,
Expand All @@ -150,13 +159,14 @@ key_log <- function(
force(prescale_base)
force(negative_small)
force(expanded)
dots <- label_args(...)
call <- expr(key_log())
function(scale, aesthetic = NULL) {
log10_keys(
key <- log10_keys(
scale = scale, aesthetic = aesthetic,
prescale_base = prescale_base,
negative_small = negative_small,
expanded = expanded, call = call
expanded = expanded, extra_args = dots, call = call
)
}
}
Expand Down Expand Up @@ -201,6 +211,7 @@ log10_keys <- function(scale, aesthetic,
negative_small = 0.1,
expanded = TRUE,
labeller = NULL,
extra_args = NULL,
call = caller_env()) {
aesthetic <- aesthetic %||% scale$aesthetics[1]
if (scale$is_discrete()) {
Expand Down Expand Up @@ -263,7 +274,8 @@ log10_keys <- function(scale, aesthetic,
!!aesthetic := ticks,
.value = ticks,
.label = labels,
.type = rep(c("major", "minor", "mini"), times = nticks)
.type = rep(c("major", "minor", "mini"), times = nticks),
!!!extra_args
)

if (expanded) {
Expand Down
37 changes: 25 additions & 12 deletions R/key-range.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -31,8 +31,10 @@
#' argument is evaluated.
#' @param ... [`<data-masking>`][rlang::topic-data-mask] A set of mappings
#' similar to those provided to [`aes()`][ggplot2::aes], which will be
#' evaluated in the `data` argument. These must contain `start` and `end`
#' mappings.
#' evaluated in the `data` argument.
#' For `key_range_map()`, these *must* contain `start` and `end` mappings.
#' Can contain additional parameters for text styling, namely `colour`,
#' `family`, `face`, `size`, `hjust`, `vjust`, `angle` and `lineheight`.
#' @param .call A [call][rlang::topic-error-call] to display in messages.
#'
#' @details
Expand Down Expand Up @@ -77,25 +79,29 @@ NULL

#' @rdname key_range
#' @export
key_range_auto <- function(sep = "[^[:alnum:]]+", reverse = FALSE) {
key_range_auto <- function(sep = "[^[:alnum:]]+", reverse = FALSE, ...) {
check_string(sep)
check_bool(reverse)
force(sep)
force(reverse)
dots <- label_args(...)
call <- current_call()
function(scale, aesthetic = NULL) {
range_from_label(
scale = scale, aesthetic = aesthetic,
sep = sep, reverse = reverse,
sep = sep, reverse = reverse, extra_args = dots,
call = call
)
}
}

#' @rdname key_range
#' @export
key_range_manual <- function(start, end, name = NULL, level = NULL) {
df <- data_frame0(start = start, end = end, .label = name, .level = level)
key_range_manual <- function(start, end, name = NULL, level = NULL, ...) {
df <- data_frame0(
start = start, end = end, .label = name, .level = level,
!!!label_args(...)
)
check_columns(df, c("start", "end"))
class(df) <- c("key_range", "key_guide", class(df))
df
Expand All @@ -111,20 +117,25 @@ key_range_map <- function(data, ..., .call = caller_env()) {
df <- eval_aes(
data, mapping,
required = c("start", "end"),
optional = c("name", "level"),
optional = c("name", "level", .label_params),
call = .call, arg_mapping = "mapping", arg_data = "data"
)

df <- rename(df, c("name", "level"), c(".label", ".level"))
df <- rename(
df, c("name", "level", .label_params),
c(".label", ".level", paste0(".", .label_params))
)
df$colour <- df$color
df$color <- NULL
class(df) <- c("key_range", "key_guide", class(df))
df
}

key_range_rle <- function(x) {
key_range_rle <- function(x, ...) {
rle <- vec_unrep(x)
end <- cumsum(rle$times) + 0.5
start <- end - rle$times
key_range_manual(start, end, name = rle$key, level = 1L)
key_range_manual(start, end, name = rle$key, level = 1L, ...)
}

# Extractor ---------------------------------------------------------------
Expand Down Expand Up @@ -213,7 +224,8 @@ range_censor <- function(ranges, limits) {
## Other helpers ----------------------------------------------------------

range_from_label <- function(
scale, aesthetic = NULL, sep = "[^[:alnum:]]+", reverse = FALSE, call = caller_env()
scale, aesthetic = NULL, sep = "[^[:alnum:]]+", reverse = FALSE,
extra_args = list(), call = caller_env()
) {
# Extract a standard key from the scale
aesthetic <- aesthetic %||% scale$aesthetics[1]
Expand Down Expand Up @@ -258,7 +270,7 @@ range_from_label <- function(
start = value, end = value, .label = key$.label, .level = 0
)
if (is_empty(labels)) {
return(key)
return(data_frame0(key, !!!extra_args))
}
ranges <- apply(labels, 2, function(labs) {
rle <- vec_unrep(labs)
Expand All @@ -274,6 +286,7 @@ range_from_label <- function(
ranges$.level <- rep.int(seq_along(nrows), nrows)
range <- vec_slice(ranges, !is.na(ranges$.label))
df <- vec_rbind(key, range)
df <- data_frame0(df, !!!extra_args)
class(df) <- c("key_range", "key_guide", class(df))
df
}
Expand Down
82 changes: 61 additions & 21 deletions R/primitive-box.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7,6 +7,8 @@
#' @inheritParams primitive_bracket
#' @param min_size A [`<grid::unit[1]>`][grid::unit] setting the minimal size
#' of a box.
#' @param levels_box A list of `<element_rect>` objects to customise how
#' boxes appear at every level.
#'
#' @return A `<PrimitiveBox>` primitive guide that can be used inside other
#' guides.
Expand Down Expand Up @@ -54,6 +56,8 @@ primitive_box <- function(
drop_zero = TRUE,
pad_discrete = 0.4,
min_size = NULL,
levels_box = NULL,
levels_text = NULL,
theme = NULL,
position = waiver()
) {
Expand All @@ -62,6 +66,16 @@ primitive_box <- function(
oob <- arg_match0(oob, c("squish", "censor", "none"))
check_bool(drop_zero)
check_number_decimal(pad_discrete, allow_infinite = FALSE)
check_list_of(
levels_box,
c("element_rect", "element_blank", "NULL"),
allow_null = TRUE
)
check_list_of(
levels_text,
c("element_text", "element_blank", "NULL"),
allow_null = TRUE
)

new_guide(
key = key,
Expand All @@ -70,6 +84,8 @@ primitive_box <- function(
drop_zero = drop_zero,
pad_discrete = pad_discrete,
min_size = min_size,
levels_box = levels_box,
levels_text = levels_text,
theme = theme,
position = position,
available_aes = c("any", "x", "y", "r", "theta"),
Expand All @@ -90,7 +106,8 @@ PrimitiveBox <- ggproto(

params = new_params(
key = NULL, oob = "squish", drop_zero = TRUE,
pad_discrete = 0.4, angle = waiver(), min_size = NULL
pad_discrete = 0.4, angle = waiver(), min_size = NULL,
levels_text = NULL, levels_box = NULL
),

elements = list(
Expand Down Expand Up @@ -149,13 +166,29 @@ PrimitiveBox <- ggproto(

build_box = function(key, decor, elements, params) {

levels <- unique(c(key$.level, decor$.level))
levels <- unique(c(key$.level, decor$.level))
nlevels <- length(levels)
position <- params$position

# Recycle custom elements per level to appropriate length
box_levels <- rep0(params$levels_box, length.out = nlevels)
text_levels <- rep0(params$levels_text, length.out = nlevels)

# Justify labels along their ranges
if (!is_blank(elements$text)) {

hjust <- elements$text$hjust
vjust <- elements$text$vjust
if (is_theta(params$position)) {
add <- if (params$position == "theta.sec") pi else 0

if (!is.null(text_levels)) {
hjust <- vapply(text_levels, function(x) x$hjust %||% hjust, numeric(1))
hjust <- hjust[match(key$.level, levels)]
vjust <- vapply(text_levels, function(x) x$vjust %||% vjust, numeric(1))
vjust <- vjust[match(key$.label, levels)]
}

if (is_theta(position)) {
add <- if (position == "theta.sec") pi else 0
key$theta <- justify_range(key$theta, key$thetaend, hjust, theta = TRUE)
key <- polar_xy(key, key$r, key$theta + add, params$bbox)
} else if ("xend" %in% names(key)) {
Expand All @@ -165,35 +198,42 @@ PrimitiveBox <- ggproto(
}
}

elements$text <- angle_labels(elements$text, params$angle, params$position)
grobs <- list()
grobs <- vector("list", nlevels)
offset <- elements$offset
angle <- params$angle %|W|% NULL
min_size <- cm(params$min_size %||% 0.2)
sizes <- numeric()
sizes <- numeric(nlevels)
text <- angle_labels(elements$text, angle, position)

measure <- switch(
params$position,
position,
left = , right = width_cm,
top = , bottom = height_cm,
function(x) attr(x, "size") %||% 0
get_size_attr
)

for (i in levels) {
text <- draw_labels(
vec_slice(key, key$.level == i),
elements$text, angle = angle, offset = offset, params$position
for (i in seq_len(nlevels)) {

# Render text
labels <- draw_labels(
vec_slice(key, key$.level == levels[[i]]),
combine_elements(text_levels[[i]], text),
angle = angle, offset = offset, position = position
)
size <- max(measure(text), min_size)
sizes <- c(sizes, size)
sizes[i] <- max(measure(labels), min_size)

# Render box
box <- draw_box(
vec_slice(decor, decor$.level == i),
elements$box, size = size, params$position, offset = offset
vec_slice(decor, decor$.level == levels[[i]]),
combine_elements(box_levels[[i]], elements$box),
size = sizes[i], offset = offset, position = position
)
offset <- offset + size
grobs <- c(grobs, list(grobTree(box, text)))

offset <- offset + sizes[i]
grobs[[i]] <- grobTree(box, labels)
}
if (params$position %in% c("top", "left")) {

if (position %in% c("top", "left")) {
grobs <- rev(grobs)
sizes <- rev(sizes)
}
Expand Down Expand Up @@ -226,7 +266,7 @@ PrimitiveBox <- ggproto(

# Helpers -----------------------------------------------------------------

draw_box = function(decor, element, size, position, offset) {
draw_box = function(decor, element, size, offset, position) {
if (nrow(decor) < 2 || is_blank(element)) {
return(zeroGrob())
}
Expand Down
Loading

0 comments on commit a685b86

Please sign in to comment.