Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Text formatting #16

Merged
merged 8 commits into from
Sep 7, 2024
Merged

Text formatting #16

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
8 commits
Select commit Hold shift + click to select a range
a439624
add `check_list_of()`
teunbrand Sep 7, 2024
829ce65
add customisation options to bracket primitive
teunbrand Sep 7, 2024
6b2a1ae
add customisation options to box primitive
teunbrand Sep 7, 2024
a3ebab6
passing text formatting to labels
teunbrand Sep 7, 2024
79f604c
adopt formatting in ranged keys
teunbrand Sep 7, 2024
87821f0
adopt formatting in regular keys
teunbrand Sep 7, 2024
b7b755f
update snapshot
teunbrand Sep 7, 2024
67fe423
redocument
teunbrand Sep 7, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
32 changes: 22 additions & 10 deletions R/key-.R
View file
Open in desktop
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
Open in desktop
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
Open in desktop
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
Loading