2020-12-02 15:50:03 +01:00
|
|
|
|
|
|
|
#' @importFrom rlang eval_tidy
|
2021-01-04 17:10:29 +01:00
|
|
|
get_facets <- function(data, rows, cols, type = c("wrap", "grid")) {
|
|
|
|
type <- match.arg(type)
|
|
|
|
byrows <- lapply(X = rows, FUN = eval_tidy, data = data)
|
|
|
|
bycols <- lapply(X = cols, FUN = eval_tidy, data = data)
|
|
|
|
facets <- split(x = data, f = c(bycols, byrows), sep = "|__|")
|
|
|
|
facets <- lapply(
|
2020-12-03 10:11:40 +01:00
|
|
|
X = seq_along(facets),
|
|
|
|
FUN = function(i) {
|
|
|
|
facet <- facets[[i]]
|
2020-12-03 10:33:20 +01:00
|
|
|
attr(facet, "keys") <- strsplit(
|
2021-01-07 20:17:06 +01:00
|
|
|
x = names(facets)[i],
|
2020-12-03 10:33:20 +01:00
|
|
|
split = "|__|", fixed = TRUE
|
|
|
|
)[[1]]
|
2020-12-03 10:11:40 +01:00
|
|
|
facet
|
|
|
|
}
|
|
|
|
)
|
2021-01-04 17:10:29 +01:00
|
|
|
label_row <- lapply(byrows, unique)
|
|
|
|
label_row <- lapply(label_row, sort)
|
|
|
|
label_row <- apply(expand.grid(label_row), 1, paste, collapse = "*")
|
|
|
|
label_col <- lapply(bycols, unique)
|
|
|
|
label_col <- lapply(label_col, sort)
|
|
|
|
label_col <- apply(expand.grid(label_col), 1, paste, collapse = "*")
|
|
|
|
list(
|
|
|
|
facets = facets,
|
|
|
|
nrow = if (identical(type, "grid")) n_facet(byrows) else NULL,
|
|
|
|
ncol = if (identical(type, "grid")) n_facet(bycols) else NULL,
|
|
|
|
label_row = label_row,
|
|
|
|
label_col = label_col
|
|
|
|
)
|
|
|
|
}
|
|
|
|
|
|
|
|
n_facet <- function(l) {
|
|
|
|
l <- lapply(l, function(x) {
|
|
|
|
length(unique(x))
|
|
|
|
})
|
|
|
|
Reduce(`*`, l)
|
2020-12-02 15:50:03 +01:00
|
|
|
}
|
|
|
|
|
2021-01-04 17:10:29 +01:00
|
|
|
|
2020-12-03 17:31:04 +01:00
|
|
|
set_scale <- function(ax, values, scales = c("fixed", "free", "free_y", "free_x"), axis = c("x", "y")) {
|
2020-12-14 17:20:32 +01:00
|
|
|
if (is.null(scales))
|
|
|
|
return(ax)
|
2020-12-03 17:31:04 +01:00
|
|
|
scales <- match.arg(scales)
|
|
|
|
axis <- match.arg(axis)
|
|
|
|
if (is.null(values))
|
|
|
|
return(ax)
|
|
|
|
if (inherits(values, c("numeric", "integer", "Date", "POSIXt"))) {
|
2021-01-06 09:52:25 +01:00
|
|
|
range_vals <- range(pretty(values, n = 10), na.rm = TRUE)
|
2020-12-03 17:31:04 +01:00
|
|
|
} else {
|
|
|
|
range_vals <- NULL
|
|
|
|
}
|
2021-01-07 20:17:06 +01:00
|
|
|
|
2020-12-03 17:31:04 +01:00
|
|
|
fmt <- function(x, time = inherits(values, c("Date", "POSIXt"))) {
|
|
|
|
if (is.null(x))
|
|
|
|
return(NULL)
|
|
|
|
if (time)
|
|
|
|
x <- format_date(x)
|
|
|
|
x
|
|
|
|
}
|
2021-01-05 11:11:24 +01:00
|
|
|
|
|
|
|
waxis <- switch(
|
2020-12-03 17:31:04 +01:00
|
|
|
axis,
|
2021-01-05 11:11:24 +01:00
|
|
|
"x" = "xaxis",
|
|
|
|
"y" = "yaxis"
|
2020-12-03 17:31:04 +01:00
|
|
|
)
|
2021-01-07 20:17:06 +01:00
|
|
|
|
2020-12-03 17:31:04 +01:00
|
|
|
if (scales == "fixed") {
|
2021-01-05 11:11:24 +01:00
|
|
|
ax$x$ax_opts[[waxis]]$min <- ax$x$ax_opts[[waxis]]$min %||% fmt(range_vals[1])
|
|
|
|
ax$x$ax_opts[[waxis]]$max <- ax$x$ax_opts[[waxis]]$max %||% fmt(range_vals[2])
|
2020-12-03 17:31:04 +01:00
|
|
|
} else if (scales == "free") {
|
2021-01-05 15:08:13 +01:00
|
|
|
ax$x$ax_opts[[waxis]]$min <- NULL
|
|
|
|
ax$x$ax_opts[[waxis]]$max <- NULL
|
|
|
|
} else if (scales == "free_x") {
|
|
|
|
if (axis == "y") {
|
|
|
|
ax$x$ax_opts[[waxis]]$min <- ax$x$ax_opts[[waxis]]$min %||% fmt(range_vals[1])
|
|
|
|
ax$x$ax_opts[[waxis]]$max <- ax$x$ax_opts[[waxis]]$max %||% fmt(range_vals[2])
|
|
|
|
} else {
|
|
|
|
ax$x$ax_opts[[waxis]]$min <- NULL
|
|
|
|
ax$x$ax_opts[[waxis]]$max <- NULL
|
2020-12-03 17:31:04 +01:00
|
|
|
}
|
2021-01-05 15:08:13 +01:00
|
|
|
} else if (scales == "free_y") {
|
|
|
|
if (axis == "x") {
|
|
|
|
ax$x$ax_opts[[waxis]]$min <- ax$x$ax_opts[[waxis]]$min %||% fmt(range_vals[1])
|
|
|
|
ax$x$ax_opts[[waxis]]$max <- ax$x$ax_opts[[waxis]]$max %||% fmt(range_vals[2])
|
|
|
|
} else {
|
|
|
|
ax$x$ax_opts[[waxis]]$min <- NULL
|
|
|
|
ax$x$ax_opts[[waxis]]$max <- NULL
|
2020-12-03 17:31:04 +01:00
|
|
|
}
|
|
|
|
}
|
2021-01-07 20:17:06 +01:00
|
|
|
|
2020-12-03 17:31:04 +01:00
|
|
|
return(ax)
|
|
|
|
}
|
|
|
|
|
2021-01-08 10:12:23 +01:00
|
|
|
|
|
|
|
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
|
|
|
|
}
|
|
|
|
|
2020-12-03 10:11:40 +01:00
|
|
|
#' @importFrom rlang eval_tidy is_null is_function
|
2020-12-03 10:46:01 +01:00
|
|
|
build_facets <- function(chart) {
|
|
|
|
data <- chart$x$data
|
2020-12-03 17:31:04 +01:00
|
|
|
mapall <- lapply(chart$x$mapping, eval_tidy, data = data)
|
2020-12-03 10:46:01 +01:00
|
|
|
labeller <- chart$x$facet$labeller
|
2021-01-08 10:12:23 +01:00
|
|
|
title <- get_option(chart, "title")
|
|
|
|
chart <- remove_option(chart, "title")
|
|
|
|
subtitle <- get_option(chart, "subtitle")
|
|
|
|
chart <- remove_option(chart, "subtitle")
|
2021-01-08 14:17:17 +01:00
|
|
|
xaxis_title <- get_option(chart, "xaxis", "title")
|
|
|
|
chart <- remove_option(chart, "xaxis", "title")
|
|
|
|
yaxis_title <- get_option(chart, "yaxis", "title")
|
|
|
|
chart <- remove_option(chart, "yaxis", "title")
|
2021-01-04 17:10:29 +01:00
|
|
|
facets_list <- get_facets(
|
2021-01-07 20:17:06 +01:00
|
|
|
data = data,
|
|
|
|
rows = chart$x$facet$facets_row,
|
2021-01-04 17:10:29 +01:00
|
|
|
cols = chart$x$facet$facets_col,
|
|
|
|
type = chart$x$facet$type
|
|
|
|
)
|
|
|
|
facets_data <- facets_list$facets
|
|
|
|
nrow_ <- facets_list$nrow %||% chart$x$facet$nrow
|
|
|
|
ncol_ <- facets_list$ncol %||% chart$x$facet$ncol
|
2020-12-04 14:02:52 +01:00
|
|
|
nums <- seq_along(facets_data)
|
2021-01-04 17:10:29 +01:00
|
|
|
dims <- get_grid_dims(nums, nrow = nrow_, ncol = ncol_)
|
2020-12-04 14:02:52 +01:00
|
|
|
grid <- matrix(
|
|
|
|
data = c(
|
|
|
|
nums,
|
|
|
|
rep(NA, times = (dims$nrow * dims$ncol) - length(nums))
|
2021-01-07 20:17:06 +01:00
|
|
|
),
|
|
|
|
nrow = dims$nrow,
|
|
|
|
ncol = dims$ncol,
|
2020-12-04 14:02:52 +01:00
|
|
|
byrow = TRUE
|
|
|
|
)
|
|
|
|
lrow <- get_last_row(grid)
|
2021-01-04 17:10:29 +01:00
|
|
|
facets <- lapply(
|
2020-12-04 14:02:52 +01:00
|
|
|
X = nums,
|
2020-12-02 15:50:03 +01:00
|
|
|
FUN = function(i) {
|
|
|
|
new <- chart
|
2020-12-03 10:11:40 +01:00
|
|
|
facet <- facets_data[[i]]
|
2021-01-04 17:10:29 +01:00
|
|
|
if (identical(chart$x$facet$type, "wrap") && !is_null(labeller) && is_function(labeller)) {
|
2020-12-03 10:11:40 +01:00
|
|
|
keys <- attr(facet, "keys")
|
2020-12-30 11:12:28 +01:00
|
|
|
text <- labeller(keys)
|
|
|
|
new <- ax_title(new, text = text, margin = 0, floating = length(text) <= 1)
|
2020-12-03 10:11:40 +01:00
|
|
|
}
|
2020-12-03 10:46:01 +01:00
|
|
|
mapdata <- lapply(chart$x$mapping, eval_tidy, data = facet)
|
2020-12-14 17:20:32 +01:00
|
|
|
if (chart$x$facet$scales %in% c("fixed", "free_y") & chart$x$type %in% c("bar")) {
|
|
|
|
mapdata <- complete_mapdata(mapdata, mapall)
|
|
|
|
}
|
|
|
|
if (chart$x$facet$scales %in% c("fixed", "free_x") & chart$x$type %in% c("column")) {
|
|
|
|
mapdata <- complete_mapdata(mapdata, mapall)
|
|
|
|
}
|
2020-12-03 10:46:01 +01:00
|
|
|
new$x$ax_opts$series <- make_series(mapdata, chart$x$mapping, chart$x$type, chart$x$serie_name)
|
2020-12-03 17:31:04 +01:00
|
|
|
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")
|
2020-12-04 14:02:52 +01:00
|
|
|
if (chart$x$facet$scales %in% c("fixed", "free_x")) {
|
|
|
|
new <- ax_yaxis(new, show = i %in% grid[, 1])
|
|
|
|
}
|
|
|
|
# if (chart$x$facet$scales %in% c("fixed", "free_y")) {
|
|
|
|
# new <- ax_xaxis(new, labels = list(show = i %in% lrow), axisTicks = list(show = TRUE))
|
|
|
|
# }
|
2020-12-14 17:20:32 +01:00
|
|
|
if (chart$x$facet$scales %in% c("fixed", "free_y") & chart$x$type %in% c("bar", "column")) {
|
|
|
|
new <- ax_xaxis(new, labels = list(show = i %in% lrow))
|
|
|
|
}
|
2020-12-30 11:12:28 +01:00
|
|
|
if (!is.null(new$x$colors_manual)) {
|
|
|
|
new <- ax_colors_manual(ax = new, values = new$x$colors_manual)
|
|
|
|
}
|
2020-12-03 10:46:01 +01:00
|
|
|
new$height <- chart$x$facet$chart_height
|
2020-12-03 11:03:59 +01:00
|
|
|
new$x$facet <- NULL
|
2020-12-02 15:50:03 +01:00
|
|
|
class(new) <- setdiff(class(new), "apex_facet")
|
|
|
|
return(new)
|
|
|
|
}
|
|
|
|
)
|
2021-01-04 17:10:29 +01:00
|
|
|
list(
|
|
|
|
facets = facets,
|
|
|
|
type = chart$x$facet$type,
|
2021-01-07 20:17:06 +01:00
|
|
|
nrow = facets_list$nrow,
|
2021-01-04 17:10:29 +01:00
|
|
|
ncol = facets_list$ncol,
|
|
|
|
label_row = facets_list$label_row,
|
2021-01-08 10:12:23 +01:00
|
|
|
label_col = facets_list$label_col,
|
|
|
|
title = title,
|
2021-01-08 14:17:17 +01:00
|
|
|
subtitle = subtitle,
|
|
|
|
xaxis_title = xaxis_title,
|
|
|
|
yaxis_title = yaxis_title
|
2021-01-04 17:10:29 +01:00
|
|
|
)
|
2020-12-02 15:50:03 +01:00
|
|
|
}
|
|
|
|
|
2020-12-04 14:02:52 +01:00
|
|
|
|
|
|
|
get_last_row <- function(mat) {
|
|
|
|
apply(X = mat, MARGIN = 2, FUN = function(x) {
|
|
|
|
x <- x[!is.na(x)]
|
|
|
|
x[length(x)]
|
|
|
|
})
|
|
|
|
}
|
|
|
|
|
2020-12-30 11:12:28 +01:00
|
|
|
|
|
|
|
|
2020-12-02 15:50:03 +01:00
|
|
|
#' Facet wrap for ApexCharts
|
|
|
|
#'
|
|
|
|
#' @param ax An \code{apexcharts} \code{htmlwidget} object.
|
2020-12-04 18:00:04 +01:00
|
|
|
#' @param facets Variable(s) to use for facetting, wrapped in \code{vars(...)}.
|
2020-12-02 15:50:03 +01:00
|
|
|
#' @param nrow,ncol Number of row and column in output matrix.
|
2020-12-08 16:22:24 +01:00
|
|
|
#' @param scales Should scales be fixed (\code{"fixed"}, the default),
|
|
|
|
#' free (\code{"free"}), or free in one dimension (\code{"free_x"}, \code{"free_y"})?
|
|
|
|
#' @param labeller A function with one argument containing for each facet the value of the faceting variable.
|
2020-12-02 15:50:03 +01:00
|
|
|
#' @param chart_height Individual chart height.
|
|
|
|
#'
|
|
|
|
#' @return An \code{apexcharts} \code{htmlwidget} object.
|
|
|
|
#' @export
|
2021-01-07 20:17:06 +01:00
|
|
|
#'
|
2021-01-04 17:10:29 +01:00
|
|
|
#' @name apex-facets
|
2021-01-07 20:17:06 +01:00
|
|
|
#'
|
2020-12-04 18:00:04 +01:00
|
|
|
#' @importFrom rlang quos syms
|
2020-12-02 15:50:03 +01:00
|
|
|
#'
|
2020-12-08 16:22:24 +01:00
|
|
|
#' @example examples/facet_wrap.R
|
2021-01-07 20:17:06 +01:00
|
|
|
ax_facet_wrap <- function(ax,
|
|
|
|
facets,
|
2020-12-03 10:11:40 +01:00
|
|
|
nrow = NULL,
|
|
|
|
ncol = NULL,
|
2020-12-03 17:31:04 +01:00
|
|
|
scales = c("fixed", "free", "free_y", "free_x"),
|
2020-12-03 10:33:20 +01:00
|
|
|
labeller = label_value,
|
2020-12-03 10:11:40 +01:00
|
|
|
chart_height = "300px") {
|
2020-12-02 15:50:03 +01:00
|
|
|
if (!inherits(ax, "apex"))
|
|
|
|
stop("ax_facet_wrap only works with charts generated with apex()", call. = FALSE)
|
2020-12-03 17:31:04 +01:00
|
|
|
scales <- match.arg(scales)
|
2020-12-04 18:00:04 +01:00
|
|
|
if (is.character(facets))
|
|
|
|
facets <- quos(!!!syms(facets))
|
2020-12-02 15:50:03 +01:00
|
|
|
ax$x$facet <- list(
|
2021-01-04 17:10:29 +01:00
|
|
|
facets_row = facets,
|
2020-12-02 15:50:03 +01:00
|
|
|
nrow = nrow,
|
|
|
|
ncol = ncol,
|
2020-12-03 17:31:04 +01:00
|
|
|
scales = scales,
|
2020-12-03 10:11:40 +01:00
|
|
|
labeller = labeller,
|
2021-01-04 17:10:29 +01:00
|
|
|
chart_height = chart_height,
|
|
|
|
type = "wrap"
|
|
|
|
)
|
|
|
|
class(ax) <- c("apex_facet", class(ax))
|
|
|
|
return(ax)
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2021-01-07 20:17:06 +01:00
|
|
|
#' @param rows,cols A set of variables or expressions quoted by vars() and defining faceting groups on the rows or columns dimension.
|
2021-01-04 17:10:29 +01:00
|
|
|
#' @export
|
2021-01-07 20:17:06 +01:00
|
|
|
#'
|
2021-01-04 17:10:29 +01:00
|
|
|
#' @rdname apex-facets
|
2021-01-07 20:17:06 +01:00
|
|
|
#'
|
2021-01-05 15:08:13 +01:00
|
|
|
#' @example examples/facet_grid.R
|
2021-01-07 20:17:06 +01:00
|
|
|
ax_facet_grid <- function(ax,
|
2021-01-04 17:10:29 +01:00
|
|
|
rows = NULL,
|
|
|
|
cols = 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)
|
|
|
|
if (!is.null(rows) && is.character(rows))
|
|
|
|
rows <- quos(!!!syms(rows))
|
|
|
|
if (!is.null(cols) && is.character(cols))
|
|
|
|
cols <- quos(!!!syms(cols))
|
|
|
|
ax$x$facet <- list(
|
|
|
|
facets_row = rows,
|
|
|
|
facets_col = cols,
|
|
|
|
nrow = NULL,
|
|
|
|
ncol = NULL,
|
|
|
|
scales = scales,
|
|
|
|
labeller = labeller,
|
|
|
|
chart_height = chart_height,
|
|
|
|
type = "grid"
|
2020-12-02 15:50:03 +01:00
|
|
|
)
|
|
|
|
class(ax) <- c("apex_facet", class(ax))
|
|
|
|
return(ax)
|
|
|
|
}
|
|
|
|
|
2020-12-03 11:03:59 +01:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
2021-01-04 17:10:29 +01:00
|
|
|
# Tag ---------------------------------------------------------------------
|
|
|
|
|
|
|
|
build_facet_tag <- function(x) {
|
|
|
|
facets <- build_facets(x)
|
2021-01-08 14:17:17 +01:00
|
|
|
content <- facets$facets
|
|
|
|
d <- get_grid_dims(content, x$x$facet$nrow, x$x$facet$ncol)
|
|
|
|
row_after <- col_before <- NULL
|
|
|
|
if (!is.null(facets$xaxis_title)) {
|
|
|
|
if (identical(facets$type, "wrap")) {
|
|
|
|
area <- paste(
|
|
|
|
d$nrow + 1,
|
|
|
|
1,
|
|
|
|
d$nrow + 1,
|
|
|
|
d$ncol + 2,
|
|
|
|
sep = " / "
|
|
|
|
)
|
|
|
|
} else {
|
|
|
|
area <- paste(
|
|
|
|
(facets$nrow %||% 1) + 1 + !is.null(facets$ncol),
|
|
|
|
1,
|
|
|
|
(facets$nrow %||% 1) + 1 + !is.null(facets$ncol),
|
|
|
|
(facets$ncol %||% 1) + 2,
|
|
|
|
sep = " / "
|
|
|
|
)
|
|
|
|
}
|
|
|
|
TAGX <- tags$div(
|
|
|
|
class = "apexcharter-facet-xaxis-title",
|
|
|
|
facets$xaxis_title$text,
|
|
|
|
style = make_styles(facets$xaxis_title$style),
|
|
|
|
style = paste("grid-area:", area, ";")
|
|
|
|
)
|
|
|
|
content <- c(content, list(TAGX))
|
|
|
|
row_after <- "30px"
|
|
|
|
}
|
|
|
|
if (!is.null(facets$yaxis_title)) {
|
|
|
|
if (identical(facets$type, "wrap")) {
|
|
|
|
area <- paste(
|
|
|
|
1,
|
|
|
|
1,
|
|
|
|
d$nrow + 1,
|
|
|
|
2,
|
|
|
|
sep = " / "
|
|
|
|
)
|
|
|
|
} else {
|
|
|
|
area <- paste(
|
|
|
|
1,
|
|
|
|
1,
|
|
|
|
(facets$nrow %||% 1) + 1 + !is.null(facets$ncol),
|
|
|
|
2,
|
|
|
|
sep = " / "
|
|
|
|
)
|
|
|
|
}
|
|
|
|
TAGY <- tags$div(
|
|
|
|
class = "apexcharter-facet-yaxis-title apexcharter-facet-rotate180",
|
|
|
|
facets$yaxis_title$text,
|
|
|
|
style = make_styles(facets$yaxis_title$style),
|
|
|
|
style = paste("grid-area:", area, ";")
|
|
|
|
)
|
|
|
|
content <- c(content, list(TAGY))
|
|
|
|
col_before <- "30px"
|
|
|
|
}
|
2021-01-04 17:10:29 +01:00
|
|
|
if (identical(facets$type, "wrap")) {
|
2021-01-08 14:17:17 +01:00
|
|
|
TAG <- build_grid(
|
|
|
|
content = content,
|
|
|
|
nrow = d$nrow,
|
|
|
|
ncol = d$ncol,
|
|
|
|
row_after = row_after,
|
|
|
|
col_before = col_before
|
|
|
|
)
|
2021-01-04 17:10:29 +01:00
|
|
|
} else if (identical(facets$type, "grid")) {
|
|
|
|
if (!is.null(facets$nrow)) {
|
|
|
|
for (i in seq_along(facets$label_row)) {
|
|
|
|
content <- append(
|
2021-01-07 20:17:06 +01:00
|
|
|
x = content,
|
2021-01-05 12:14:48 +01:00
|
|
|
values = tagList(tags$div(
|
2021-01-07 20:17:06 +01:00
|
|
|
class = "apexcharter-facet-row-label",
|
2021-01-05 12:14:48 +01:00
|
|
|
x$x$facet$labeller(facets$label_row[i])
|
|
|
|
)),
|
2021-01-04 17:10:29 +01:00
|
|
|
after = ((facets$ncol %||% 1 + 1) * i) - 1
|
|
|
|
)
|
|
|
|
}
|
|
|
|
}
|
|
|
|
if (!is.null(facets$ncol)) {
|
|
|
|
content <- tagList(
|
2021-01-05 12:14:48 +01:00
|
|
|
lapply(
|
2021-01-07 20:17:06 +01:00
|
|
|
X = facets$label_col,
|
2021-01-05 15:08:13 +01:00
|
|
|
FUN = function(label_col) {
|
|
|
|
tags$div(x$x$facet$labeller(label_col), class = "apexcharter-facet-col-label")
|
2021-01-05 12:14:48 +01:00
|
|
|
}
|
|
|
|
),
|
2021-01-04 17:10:29 +01:00
|
|
|
if (!is.null(facets$nrow)) tags$div(),
|
|
|
|
content
|
|
|
|
)
|
|
|
|
}
|
|
|
|
TAG <- build_grid(
|
2021-01-07 20:17:06 +01:00
|
|
|
content,
|
|
|
|
nrow = facets$nrow %||% 1,
|
2021-01-04 17:10:29 +01:00
|
|
|
ncol = facets$ncol %||% 1,
|
2021-01-07 20:17:06 +01:00
|
|
|
row_before = if (!is.null(facets$ncol)) "30px",
|
|
|
|
col_after = if (!is.null(facets$nrow)) "30px",
|
|
|
|
row_gap = "3px",
|
2021-01-08 14:17:17 +01:00
|
|
|
col_gap = "3px",
|
|
|
|
row_after = row_after,
|
|
|
|
col_before = col_before
|
2021-01-04 17:10:29 +01:00
|
|
|
)
|
|
|
|
} else {
|
|
|
|
stop("Facetting must be wrap or grid", call. = FALSE)
|
|
|
|
}
|
2021-01-08 10:12:23 +01:00
|
|
|
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)
|
2021-01-04 17:10:29 +01:00
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
2020-12-08 14:49:16 +01:00
|
|
|
# Shiny -------------------------------------------------------------------
|
|
|
|
|
2020-12-08 16:22:24 +01:00
|
|
|
|
|
|
|
#' @title Shiny bindings for faceting with apexcharter
|
|
|
|
#'
|
|
|
|
#' @description Output and render functions for using apexcharter faceting within Shiny
|
|
|
|
#' applications and interactive Rmd documents.
|
|
|
|
#'
|
|
|
|
#' @param outputId output variable to read from
|
|
|
|
#'
|
|
|
|
#' @return An Apexcharts output that can be included in the application UI.
|
2020-12-08 14:49:16 +01:00
|
|
|
#' @export
|
2021-01-07 20:17:06 +01:00
|
|
|
#'
|
2020-12-08 16:22:24 +01:00
|
|
|
#' @name apexcharter-shiny-facets
|
2021-01-07 20:17:06 +01:00
|
|
|
#'
|
2020-12-08 16:22:24 +01:00
|
|
|
#' @importFrom htmltools tagList
|
|
|
|
#' @importFrom shiny uiOutput
|
|
|
|
#' @importFrom htmlwidgets getDependency
|
|
|
|
#'
|
2021-01-06 11:34:27 +01:00
|
|
|
#' @example examples/facet-wrap-shiny.R
|
2020-12-08 14:49:16 +01:00
|
|
|
apexfacetOutput <- function(outputId) {
|
2020-12-08 16:22:24 +01:00
|
|
|
tagList(
|
|
|
|
uiOutput(outputId = outputId),
|
|
|
|
getDependency(name = "apexcharter", package = "apexcharter")
|
2020-12-08 14:49:16 +01:00
|
|
|
)
|
|
|
|
}
|
|
|
|
|
2021-01-04 12:02:48 +01:00
|
|
|
#' @param expr An expression that generates a apexcharter facet.
|
2020-12-08 16:22:24 +01:00
|
|
|
#' @param env The environment in which to evaluate \code{expr}.
|
|
|
|
#' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
|
|
|
|
#' is useful if you want to save an expression in a variable.
|
2021-01-07 20:17:06 +01:00
|
|
|
#'
|
2020-12-08 14:49:16 +01:00
|
|
|
#' @export
|
2021-01-07 20:17:06 +01:00
|
|
|
#'
|
2020-12-08 16:22:24 +01:00
|
|
|
#' @rdname apexcharter-shiny-facets
|
2021-01-07 20:17:06 +01:00
|
|
|
#'
|
2020-12-08 14:49:16 +01:00
|
|
|
#' @importFrom shiny exprToFunction createRenderFunction createWebDependency
|
|
|
|
#' @importFrom htmltools renderTags resolveDependencies
|
2021-01-06 14:47:34 +01:00
|
|
|
renderApexfacet <- function(expr, env = parent.frame(), quoted = FALSE) { # nocov start
|
2020-12-08 14:49:16 +01:00
|
|
|
func <- exprToFunction(expr, env, quoted)
|
|
|
|
createRenderFunction(
|
|
|
|
func = func,
|
|
|
|
transform = function(result, shinysession, name, ...) {
|
|
|
|
if (is.null(result) || length(result) == 0)
|
|
|
|
return(NULL)
|
|
|
|
if (!inherits(result, "apex_facet")) {
|
|
|
|
stop(
|
2020-12-08 16:22:24 +01:00
|
|
|
"renderApexfacet: 'expr' must return an apexcharter facet object.",
|
2020-12-08 14:49:16 +01:00
|
|
|
call. = FALSE
|
|
|
|
)
|
|
|
|
}
|
2021-01-04 17:10:29 +01:00
|
|
|
TAG <- build_facet_tag(result)
|
2020-12-08 14:49:16 +01:00
|
|
|
rendered <- renderTags(TAG)
|
|
|
|
deps <- lapply(
|
|
|
|
X = resolveDependencies(rendered$dependencies),
|
|
|
|
FUN = createWebDependency
|
|
|
|
)
|
|
|
|
list(
|
|
|
|
html = rendered$html,
|
|
|
|
deps = deps
|
|
|
|
)
|
|
|
|
}, apexfacetOutput, list()
|
|
|
|
)
|
2021-01-06 14:47:34 +01:00
|
|
|
} # nocov end
|
2020-12-08 14:49:16 +01:00
|
|
|
|
2020-12-03 11:03:59 +01:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
# Print methods -----------------------------------------------------------
|
|
|
|
|
|
|
|
#' @export
|
2021-01-06 14:47:34 +01:00
|
|
|
print.apex_facet <- function(x, ...) { # nocov start
|
2021-01-04 17:10:29 +01:00
|
|
|
TAG <- build_facet_tag(x)
|
2020-12-03 11:03:59 +01:00
|
|
|
print(htmltools::browsable(TAG))
|
2021-01-06 14:47:34 +01:00
|
|
|
} # nocov end
|
2020-12-03 11:03:59 +01:00
|
|
|
|
2021-01-06 14:47:34 +01:00
|
|
|
knit_print.apex_facet <- function(x, ..., options = NULL) { # nocov start
|
2021-01-04 17:10:29 +01:00
|
|
|
TAG <- build_facet_tag(x)
|
2020-12-03 11:03:59 +01:00
|
|
|
knitr::knit_print(htmltools::browsable(TAG), options = options, ...)
|
2021-01-06 14:47:34 +01:00
|
|
|
} # nocov end
|
2020-12-03 11:03:59 +01:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
2020-12-14 17:20:32 +01:00
|
|
|
# Complete ----------------------------------------------------------------
|
|
|
|
|
|
|
|
complete_mapdata <- function(mapdata, mapall) {
|
|
|
|
data <- as.data.frame(mapdata)
|
2021-01-12 17:35:53 +01:00
|
|
|
full_x <- unique(mapall$x)
|
|
|
|
full_data <- data.frame(
|
|
|
|
xorder = seq_along(full_x),
|
|
|
|
x = full_x,
|
|
|
|
stringsAsFactors = FALSE
|
|
|
|
)
|
2020-12-14 17:20:32 +01:00
|
|
|
full_data <- merge(
|
|
|
|
x = full_data,
|
|
|
|
y = data,
|
|
|
|
by = "x",
|
|
|
|
all.x = TRUE,
|
2021-01-12 17:35:53 +01:00
|
|
|
sort = FALSE
|
2020-12-14 17:20:32 +01:00
|
|
|
)
|
2021-01-12 17:35:53 +01:00
|
|
|
full_data <- full_data[order(full_data$xorder), ]
|
|
|
|
full_data$xorder <- NULL
|
2020-12-14 17:20:32 +01:00
|
|
|
full_data$y[is.na(full_data$y)] <- 0
|
|
|
|
return(as.list(full_data))
|
|
|
|
}
|
|
|
|
|
|
|
|
complete_data <- function(data, vars, fill_var, fill_value = 0) {
|
|
|
|
full_data <- expand.grid(lapply(
|
2021-01-07 20:17:06 +01:00
|
|
|
X = data[, vars],
|
2020-12-14 17:20:32 +01:00
|
|
|
FUN = unique
|
|
|
|
))
|
|
|
|
full_data <- merge(
|
|
|
|
x = full_data,
|
|
|
|
y = data,
|
|
|
|
by = vars,
|
|
|
|
all.x = TRUE,
|
|
|
|
sort = FALSE
|
|
|
|
)
|
|
|
|
full_data[[fill_var]][is.na(full_data[[fill_var]])] <- fill_value
|
|
|
|
return(full_data)
|
|
|
|
}
|
2020-12-03 11:03:59 +01:00
|
|
|
|
|
|
|
|