apexcharter/R/facets.R

198 lines
5.0 KiB
R

#' @importFrom rlang eval_tidy
get_facets <- function(data, vars) {
byvars <- lapply(X = vars, FUN = eval_tidy, data = data)
facets <- split(x = data, f = byvars, sep = "|__|")
lapply(
X = seq_along(facets),
FUN = function(i) {
facet <- facets[[i]]
attr(facet, "keys") <- strsplit(
x = names(facets)[i],
split = "|__|", fixed = TRUE
)[[1]]
facet
}
)
}
set_scale <- function(ax, values, scales = c("fixed", "free", "free_y", "free_x"), axis = c("x", "y")) {
scales <- match.arg(scales)
axis <- match.arg(axis)
if (is.null(values))
return(ax)
if (inherits(values, c("numeric", "integer", "Date", "POSIXt"))) {
range_vals <- range(pretty(values), na.rm = TRUE)
} else {
range_vals <- NULL
}
fmt <- function(x, time = inherits(values, c("Date", "POSIXt"))) {
if (is.null(x))
return(NULL)
if (time)
x <- format_date(x)
x
}
fun_axis <- switch(
axis,
"x" = ax_xaxis,
"y" = ax_yaxis
)
if (scales == "fixed") {
ax <- fun_axis(
ax = ax,
min = fmt(range_vals[1]),
max = fmt(range_vals[2])
)
} else if (scales == "free") {
ax <- fun_axis(
ax = ax,
min = character(0),
max = character(0)
)
} else {
ax <- fun_axis(
ax = ax,
min = fmt(range_vals[1]),
max = fmt(range_vals[2])
)
if (scales == "free_x" & axis == "x") {
ax <- fun_axis(
ax = ax,
min = character(0),
max = character(0)
)
}
if (scales == "free_y" & axis == "y") {
ax <- fun_axis(
ax = ax,
min = character(0),
max = character(0)
)
}
}
return(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
facets_data <- get_facets(data, chart$x$facet$vars)
lapply(
X = seq_along(facets_data),
FUN = function(i) {
new <- chart
facet <- facets_data[[i]]
if (!is_null(labeller) && is_function(labeller)) {
keys <- attr(facet, "keys")
# browser()
new <- ax_title(new, text = labeller(keys))
}
mapdata <- lapply(chart$x$mapping, eval_tidy, data = facet)
new$x$ax_opts$series <- make_series(mapdata, chart$x$mapping, chart$x$type, chart$x$serie_name)
new <- set_scale(new, mapall$x, scales = chart$x$facet$scales, axis = "x")
new <- set_scale(new, mapall$y, scales = chart$x$facet$scales, axis = "y")
new$height <- chart$x$facet$chart_height
new$x$facet <- NULL
class(new) <- setdiff(class(new), "apex_facet")
return(new)
}
)
}
build_grid <- function(content, nrow = NULL, ncol = NULL, col_gap = "0px", row_gap = "0px") {
n <- length(content)
if (is.null(nrow) & !is.null(ncol))
nrow <- ceiling(n / ncol)
if (!is.null(nrow) & is.null(ncol))
ncol <- ceiling(n / nrow)
if (is.null(nrow) & is.null(ncol)) {
if (n %% 3 < 1) {
ncol <- 3
nrow <- ceiling(n / ncol)
} else {
ncol <- 2
nrow <- ceiling(n / ncol)
}
}
htmltools::tags$div(
class = "apexcharter-facet-container",
style = "display: grid;",
style = sprintf("grid-template-columns: repeat(%s, 1fr);", ncol),
style = sprintf("grid-template-rows: repeat(%s, 1fr);", nrow),
style = sprintf("grid-column-gap: %s;", col_gap),
style = sprintf("grid-row-gap: %s;", row_gap),
content
)
}
#' Facet wrap for ApexCharts
#'
#' @param ax An \code{apexcharts} \code{htmlwidget} object.
#' @param vars Variable(s) to use for facetting, wrapped in \code{vars(...)}.
#' @param nrow,ncol Number of row and column in output matrix.
#' @param chart_height Individual chart height.
#'
#' @return An \code{apexcharts} \code{htmlwidget} object.
#' @export
#'
#' @examples
ax_facet_wrap <- function(ax,
vars,
nrow = NULL,
ncol = NULL,
scales = c("fixed", "free", "free_y", "free_x"),
labeller = label_value,
chart_height = "300px") {
if (!inherits(ax, "apex"))
stop("ax_facet_wrap only works with charts generated with apex()", call. = FALSE)
scales <- match.arg(scales)
ax$x$facet <- list(
vars = vars,
nrow = nrow,
ncol = ncol,
scales = scales,
labeller = labeller,
chart_height = chart_height
)
class(ax) <- c("apex_facet", class(ax))
return(ax)
}
# Print methods -----------------------------------------------------------
#' @export
print.apex_facet <- function(x, ...) {
facets_charts <- build_facets(x)
TAG <- build_grid(facets_charts, nrow = x$x$facet$nrow, ncol = x$x$facet$ncol)
print(htmltools::browsable(TAG))
}
knit_print.apex_facet <- function(x, ..., options = NULL) {
facets_charts <- build_facets(x)
TAG <- build_grid(facets_charts, nrow = x$x$facet$nrow, ncol = x$x$facet$ncol)
knitr::knit_print(htmltools::browsable(TAG), options = options, ...)
}