facet: added labeller
This commit is contained in:
parent
4470756c38
commit
716e96b16c
39
R/facets.R
39
R/facets.R
|
@ -2,20 +2,35 @@
|
||||||
#' @importFrom rlang eval_tidy
|
#' @importFrom rlang eval_tidy
|
||||||
get_facets <- function(data, vars) {
|
get_facets <- function(data, vars) {
|
||||||
byvars <- lapply(X = vars, FUN = eval_tidy, data = data)
|
byvars <- lapply(X = vars, FUN = eval_tidy, data = data)
|
||||||
split(x = data, f = byvars, sep = "|__|")
|
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)
|
||||||
|
facet
|
||||||
|
}
|
||||||
|
)
|
||||||
}
|
}
|
||||||
|
|
||||||
#' @importFrom rlang eval_tidy
|
#' @importFrom rlang eval_tidy is_null is_function
|
||||||
buil_facets <- function(chart, data, vars, mapping, type, serie_name, height) {
|
buil_facets <- function(chart, data, facets_args, mapping, type, serie_name) {
|
||||||
facets_data <- get_facets(data, vars)
|
labeller <- facets_args$labeller
|
||||||
|
facets_data <- get_facets(data, facets_args$vars)
|
||||||
lapply(
|
lapply(
|
||||||
X = seq_along(facets_data),
|
X = seq_along(facets_data),
|
||||||
FUN = function(i) {
|
FUN = function(i) {
|
||||||
new <- chart
|
new <- chart
|
||||||
mapdata <- lapply(mapping, eval_tidy, data = facets_data[[i]])
|
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(mapping, eval_tidy, data = facet)
|
||||||
new$x$ax_opts$series <- make_series(mapdata, mapping, type, serie_name)
|
new$x$ax_opts$series <- make_series(mapdata, mapping, type, serie_name)
|
||||||
new$x$facet <- NULL
|
new$x$facet <- NULL
|
||||||
new$height <- height
|
new$height <- facets_args$chart_height
|
||||||
class(new) <- setdiff(class(new), "apex_facet")
|
class(new) <- setdiff(class(new), "apex_facet")
|
||||||
return(new)
|
return(new)
|
||||||
}
|
}
|
||||||
|
@ -53,14 +68,12 @@ print.apex_facet <- function(x, ...) {
|
||||||
facets_charts <- buil_facets(
|
facets_charts <- buil_facets(
|
||||||
chart = x,
|
chart = x,
|
||||||
data = x$x$data,
|
data = x$x$data,
|
||||||
vars = x$x$facet$vars,
|
|
||||||
mapping = x$x$mapping,
|
mapping = x$x$mapping,
|
||||||
type = x$x$type,
|
type = x$x$type,
|
||||||
serie_name = x$x$serie_name,
|
serie_name = x$x$serie_name,
|
||||||
height = x$x$facet$chart_height
|
facets_args = x$x$facet
|
||||||
)
|
)
|
||||||
TAG <- build_grid(facets_charts, nrow = x$x$facet$nrow, ncol = x$x$facet$ncol)
|
TAG <- build_grid(facets_charts, nrow = x$x$facet$nrow, ncol = x$x$facet$ncol)
|
||||||
print(str(TAG, max.level = 1))
|
|
||||||
print(htmltools::browsable(TAG))
|
print(htmltools::browsable(TAG))
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -76,13 +89,19 @@ print.apex_facet <- function(x, ...) {
|
||||||
#' @export
|
#' @export
|
||||||
#'
|
#'
|
||||||
#' @examples
|
#' @examples
|
||||||
ax_facet_wrap <- function(ax, vars, nrow = NULL, ncol = NULL, chart_height = "300px") {
|
ax_facet_wrap <- function(ax,
|
||||||
|
vars,
|
||||||
|
nrow = NULL,
|
||||||
|
ncol = NULL,
|
||||||
|
labeller = ggplot2::label_value,
|
||||||
|
chart_height = "300px") {
|
||||||
if (!inherits(ax, "apex"))
|
if (!inherits(ax, "apex"))
|
||||||
stop("ax_facet_wrap only works with charts generated with apex()", call. = FALSE)
|
stop("ax_facet_wrap only works with charts generated with apex()", call. = FALSE)
|
||||||
ax$x$facet <- list(
|
ax$x$facet <- list(
|
||||||
vars = vars,
|
vars = vars,
|
||||||
nrow = nrow,
|
nrow = nrow,
|
||||||
ncol = ncol,
|
ncol = ncol,
|
||||||
|
labeller = labeller,
|
||||||
chart_height = chart_height
|
chart_height = chart_height
|
||||||
)
|
)
|
||||||
class(ax) <- c("apex_facet", class(ax))
|
class(ax) <- c("apex_facet", class(ax))
|
||||||
|
|
Loading…
Reference in New Issue