facets: title and subtitle

This commit is contained in:
pvictor 2021-01-08 10:12:23 +01:00
parent f91a6c69c6
commit 67680c48f3
3 changed files with 83 additions and 17 deletions

View File

@ -93,11 +93,32 @@ set_scale <- function(ax, values, scales = c("fixed", "free", "free_y", "free_x"
return(ax)
}
get_option <- function(ax, opt1, opt2 = NULL) {
if (is.null(opt2)) {
ax$x$ax_opts[[opt1]]
} else {
ax$x$ax_opts[[opt1]][[opt2]]
}
}
remove_option <- function(ax, opt1, opt2 = NULL) {
if (is.null(opt2)) {
ax$x$ax_opts[[opt1]] <- NULL
} else {
ax$x$ax_opts[[opt1]][[opt2]] <- NULL
}
ax
}
#' @importFrom rlang eval_tidy is_null is_function
build_facets <- function(chart) {
data <- chart$x$data
mapall <- lapply(chart$x$mapping, eval_tidy, data = data)
labeller <- chart$x$facet$labeller
title <- get_option(chart, "title")
chart <- remove_option(chart, "title")
subtitle <- get_option(chart, "subtitle")
chart <- remove_option(chart, "subtitle")
facets_list <- get_facets(
data = data,
rows = chart$x$facet$facets_row,
@ -163,7 +184,9 @@ build_facets <- function(chart) {
nrow = facets_list$nrow,
ncol = facets_list$ncol,
label_row = facets_list$label_row,
label_col = facets_list$label_col
label_col = facets_list$label_col,
title = title,
subtitle = subtitle
)
}
@ -302,6 +325,27 @@ build_facet_tag <- function(x) {
} else {
stop("Facetting must be wrap or grid", call. = FALSE)
}
if (!is.null(facets$subtitle)) {
TAG <- tagList(
tags$div(
class = "apexcharter-facet-subtitle",
facets$subtitle$text,
style = make_styles(facets$subtitle$style)
),
TAG
)
}
if (!is.null(facets$title)) {
TAG <- tagList(
tags$div(
class = "apexcharter-facet-title",
facets$title$text,
style = make_styles(facets$title$style)
),
TAG
)
}
return(TAG)
}

View File

@ -42,6 +42,19 @@ to_posix <- function(x) {
}
to_hyphen <- function(x) {
tolower(gsub("([A-Z])", "-\\1", x))
}
make_styles <- function(styles) {
styles <- dropNulls(styles)
if (length(styles) < 1)
return(NULL)
styles <- sprintf("%s:%s", to_hyphen(names(styles)), unlist(styles, use.names = FALSE))
paste(styles, collapse = ";")
}
#' Utility function to create ApexChart parameters JSON
#'
@ -50,18 +63,18 @@ to_posix <- function(x) {
#' @param ... Arguments for the slot
#'
#' @return A \code{apexcharts} \code{htmlwidget} object.
#'
#'
#' @importFrom utils modifyList
#'
#' @noRd
.ax_opt <- function(ax, name, ...) {
if (is.null(ax$x$ax_opts[[name]])) {
ax$x$ax_opts[[name]] <- list(...)
} else {
ax$x$ax_opts[[name]] <- modifyList(
x = ax$x$ax_opts[[name]],
val = list(...),
x = ax$x$ax_opts[[name]],
val = list(...),
keep.null = TRUE
)
}
@ -81,13 +94,13 @@ to_posix <- function(x) {
#'
#' @noRd
.ax_opt2 <- function(ax, name, l) {
if (is.null(ax$x$ax_opts[[name]])) {
ax$x$ax_opts[[name]] <- l
} else {
ax$x$ax_opts[[name]] <- modifyList(
x = ax$x$ax_opts[[name]],
val = l,
x = ax$x$ax_opts[[name]],
val = l,
keep.null = TRUE
)
}
@ -109,17 +122,17 @@ register_s3_method <- function(pkg, generic, class, fun = NULL) { # nocov start
stopifnot(is.character(pkg), length(pkg) == 1)
stopifnot(is.character(generic), length(generic) == 1)
stopifnot(is.character(class), length(class) == 1)
if (is.null(fun)) {
fun <- get(paste0(generic, ".", class), envir = parent.frame())
} else {
stopifnot(is.function(fun))
}
if (pkg %in% loadedNamespaces()) {
registerS3method(generic, class, fun, envir = asNamespace(pkg))
}
# Always register hook in case package is later unloaded & reloaded
setHook(
packageEvent(pkg, "onLoad"),

View File

@ -11,18 +11,27 @@
}
.apexcharter-facet-col-label {
background:#E6E6E6;
background:#E6E6E6;
text-align: center;
font-weight: bold;
font-weight: bold;
line-height: 30px;
}
.apexcharter-facet-row-label {
background:#E6E6E6;
text-align: center;
background:#E6E6E6;
text-align: center;
font-weight: bold;
writing-mode: vertical-rl;
text-orientation: mixed;
writing-mode: vertical-rl;
text-orientation: mixed;
line-height: 30px;
}
.apexcharter-facet-subtitle {
font-family: Helvetica, Arial, sans-serif;
}
.apexcharter-facet-title {
font-family: Helvetica, Arial, sans-serif;
}