Robot
/
apexcharter
mirror of https://github.com/dreamRs/apexcharter.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #39 from dreamRs/facet-grid 

Facet grid
This commit is contained in:
Victor Perrier 2021-01-06 10:18:27 +01:00 committed by GitHub
parent 90aac1901b 55e19f60c4
commit 4b82ddb922
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
10 changed files with 346 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
NAMESPACE
View File

@ -26,6 +26,7 @@ export(ax_chart)
export(ax_colors)
export(ax_colors_manual)
export(ax_dataLabels)
export(ax_facet_grid)
export(ax_facet_wrap)
export(ax_fill)
export(ax_grid)

215
R/facets.R
View File

@ -1,9 +1,11 @@
#' @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(
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(
X = seq_along(facets),
FUN = function(i) {
facet <- facets[[i]]
@ -14,8 +16,29 @@ get_facets <- function(data, vars) {
facet
}
)
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)
}
set_scale <- function(ax, values, scales = c("fixed", "free", "free_y", "free_x"), axis = c("x", "y")) {
if (is.null(scales))
return(ax)
@ -24,7 +47,7 @@ set_scale <- function(ax, values, scales = c("fixed", "free", "free_y", "free_x"
if (is.null(values))
return(ax)
if (inherits(values, c("numeric", "integer", "Date", "POSIXt"))) {
range_vals <- range(pretty(values), na.rm = TRUE)
range_vals <- range(pretty(values, n = 10), na.rm = TRUE)
} else {
range_vals <- NULL
}
@ -36,44 +59,34 @@ set_scale <- function(ax, values, scales = c("fixed", "free", "free_y", "free_x"
x <- format_date(x)
x
}
fun_axis <- switch(
waxis <- switch(
axis,
"x" = ax_xaxis,
"y" = ax_yaxis
"x" = "xaxis",
"y" = "yaxis"
)
if (scales == "fixed") {
ax <- fun_axis(
ax = ax,
min = fmt(range_vals[1]),
max = fmt(range_vals[2])
)
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 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)
)
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
}
if (scales == "free_y" & axis == "y") {
ax <- fun_axis(
ax = ax,
min = character(0),
max = character(0)
)
} 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
}
}
@ -85,9 +98,17 @@ 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$facets)
facets_list <- get_facets(
data = data,
rows = chart$x$facet$facets_row,
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
nums <- seq_along(facets_data)
dims <- get_grid_dims(nums, nrow = chart$x$facet$nrow, ncol = chart$x$facet$ncol)
dims <- get_grid_dims(nums, nrow = nrow_, ncol = ncol_)
grid <- matrix(
data = c(
nums,
@ -98,12 +119,12 @@ build_facets <- function(chart) {
byrow = TRUE
)
lrow <- get_last_row(grid)
lapply(
facets <- lapply(
X = nums,
FUN = function(i) {
new <- chart
facet <- facets_data[[i]]
if (!is_null(labeller) && is_function(labeller)) {
if (identical(chart$x$facet$type, "wrap") && !is_null(labeller) && is_function(labeller)) {
keys <- attr(facet, "keys")
text <- labeller(keys)
new <- ax_title(new, text = text, margin = 0, floating = length(text) <= 1)
@ -136,6 +157,14 @@ build_facets <- function(chart) {
return(new)
}
)
list(
facets = facets,
type = chart$x$facet$type,
nrow = facets_list$nrow,
ncol = facets_list$ncol,
label_row = facets_list$label_row,
label_col = facets_list$label_col
)
}
@ -161,6 +190,8 @@ get_last_row <- function(mat) {
#' @return An \code{apexcharts} \code{htmlwidget} object.
#' @export
#'
#' @name apex-facets
#'
#' @importFrom rlang quos syms
#'
#' @example examples/facet_wrap.R
@ -177,18 +208,103 @@ ax_facet_wrap <- function(ax,
if (is.character(facets))
facets <- quos(!!!syms(facets))
ax$x$facet <- list(
facets = facets,
facets_row = facets,
nrow = nrow,
ncol = ncol,
scales = scales,
labeller = labeller,
chart_height = chart_height
chart_height = chart_height,
type = "wrap"
)
class(ax) <- c("apex_facet", class(ax))
return(ax)
}
#' @param rows,cols A set of variables or expressions quoted by vars() and defining faceting groups on the rows or columns dimension.
#' @export
#'
#' @rdname apex-facets
#'
#' @example examples/facet_grid.R
ax_facet_grid <- function(ax,
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"
)
class(ax) <- c("apex_facet", class(ax))
return(ax)
}
# Tag ---------------------------------------------------------------------
build_facet_tag <- function(x) {
facets <- build_facets(x)
if (identical(facets$type, "wrap")) {
TAG <- build_grid(facets$facets, nrow = x$x$facet$nrow, ncol = x$x$facet$ncol)
} else if (identical(facets$type, "grid")) {
content <- facets$facets
if (!is.null(facets$nrow)) {
for (i in seq_along(facets$label_row)) {
content <- append(
x = content,
values = tagList(tags$div(
class = "apexcharter-facet-row-label",
x$x$facet$labeller(facets$label_row[i])
)),
after = ((facets$ncol %||% 1 + 1) * i) - 1
)
}
}
if (!is.null(facets$ncol)) {
content <- tagList(
lapply(
X = facets$label_col,
FUN = function(label_col) {
tags$div(x$x$facet$labeller(label_col), class = "apexcharter-facet-col-label")
}
),
if (!is.null(facets$nrow)) tags$div(),
content
)
}
TAG <- build_grid(
content,
nrow = facets$nrow %||% 1,
ncol = facets$ncol %||% 1,
row_label = if (!is.null(facets$ncol)) "30px" else NULL,
col_label = if (!is.null(facets$nrow)) "30px" else NULL,
row_gap = "3px",
col_gap = "3px"
)
} else {
stop("Facetting must be wrap or grid", call. = FALSE)
}
}
@ -243,12 +359,7 @@ renderApexfacet <- function(expr, env = parent.frame(), quoted = FALSE) {
call. = FALSE
)
}
facets_charts <- build_facets(result)
TAG <- build_grid(
content = facets_charts,
nrow = result$x$facet$nrow,
ncol = result$x$facet$ncol
)
TAG <- build_facet_tag(result)
rendered <- renderTags(TAG)
deps <- lapply(
X = resolveDependencies(rendered$dependencies),
@ -270,14 +381,12 @@ renderApexfacet <- function(expr, env = parent.frame(), quoted = FALSE) {
#' @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)
TAG <- build_facet_tag(x)
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)
TAG <- build_facet_tag(x)
knitr::knit_print(htmltools::browsable(TAG), options = options, ...)
}

34
R/grid.R
View File

@ -1,5 +1,5 @@
get_grid_dims <- function(content, nrow, ncol) {
get_grid_dims <- function(content, nrow = NULL, ncol = NULL) {
n <- length(content)
if (is.null(nrow) & !is.null(ncol))
nrow <- ceiling(n / ncol)
@ -21,19 +21,43 @@ get_grid_dims <- function(content, nrow, ncol) {
#' @importFrom htmltools tags
build_grid <- function(content,
nrow = NULL,
ncol = NULL,
ncol = NULL,
row_gap = "5px",
col_gap = "0px",
row_gap = "5px",
row_label = NULL,
col_label = NULL,
height = NULL,
width = NULL) {
d <- get_grid_dims(content, nrow, ncol)
if (is.null(col_label)) {
col_style <- sprintf(
"-ms-grid-columns: repeat(%1$s, 1fr); grid-template-columns: repeat(%1$s, 1fr);",
d$ncol
)
} else {
col_style <- sprintf(
"-ms-grid-columns: repeat(%1$s, 1fr) %2$s; grid-template-columns: repeat(%1$s, 1fr) %2$s;",
d$ncol, col_label
)
}
if (is.null(row_label)) {
row_style <- sprintf(
"-ms-grid-rows: repeat(%1$s, 1fr); grid-template-rows: repeat(%1$s, 1fr);",
d$nrow
)
} else {
row_style <- sprintf(
"-ms-grid-rows: %2$s repeat(%1$s, 1fr); grid-template-rows: %2$s repeat(%1$s, 1fr);",
d$nrow, row_label
)
}
tags$div(
class = "apexcharter-grid-container",
style = if (!is.null(height)) paste0("height:", height, ";"),
style = if (!is.null(width)) paste0("width:", width, ";"),
style = "display:-ms-grid; display: grid;",
style = sprintf("-ms-grid-columns: repeat(%1$s, 1fr); grid-template-columns: repeat(%1$s, 1fr);", d$ncol),
style = sprintf("-ms-grid-rows: repeat(%1$s, 1fr); grid-template-rows: repeat(%1$s, 1fr);", d$nrow),
style = col_style,
style = row_style,
style = sprintf("grid-column-gap: %s;", col_gap),
style = sprintf("grid-row-gap: %s;", row_gap),
content

4
examples/facet-shiny.R
View File

@ -19,9 +19,9 @@ ui <- fluidPage(
server <- function(input, output, session) {
output$myfacet <- renderApexfacet({
apex(refugees, aes(date, n), type = "line") %>%
apex(refugees, aes(date, n), type = "column") %>%
ax_yaxis(tickAmount = 5) %>%
ax_facet_wrap(vars(continent_origin))
ax_facet_wrap(vars(continent_origin), scales = "free")
})
}

40
examples/facet_grid.R Normal file
View File

@ -0,0 +1,40 @@
### Grid --------
library(apexcharter)
# Scatter ----
data("mpg", package = "ggplot2")
# Only rows
apex(mpg, aes(displ, cty), type = "scatter") %>%
ax_facet_grid(rows = vars(drv), chart_height = "200px")
# Only cols
apex(mpg, aes(displ, cty), type = "scatter") %>%
ax_facet_grid(cols = vars(year))
# Rows and Cols
apex(mpg, aes(displ, cty), type = "scatter") %>%
ax_facet_grid(rows = vars(drv), cols = vars(year))
apex(mpg, aes(displ, cty), type = "scatter") %>%
ax_chart(toolbar = list(show = FALSE)) %>%
ax_facet_grid(vars(drv), vars(cyl))
# Labels
apex(mpg, aes(displ, cty), type = "scatter") %>%
ax_facet_grid(
vars(drv),
labeller = function(x) {
switch(
x,
"f" = "front-wheel drive",
"r" = "rear wheel drive",
"4" = "4wd"
)
}
)

7
examples/facet_wrap.R
View File

@ -1,3 +1,4 @@
### Wrap --------
library(apexcharter)
# Scatter ----
@ -36,6 +37,9 @@ apex(mpg, aes(displ, cty), type = "scatter") %>%
apex(mpg, aes(displ, cty), type = "scatter") %>%
ax_facet_wrap(vars(year, drv))
apex(mpg, aes(displ, cty), type = "scatter") %>%
ax_facet_wrap(vars(year, drv), ncol = 2, nrow = 3)
apex(mpg, aes(displ, cty), type = "scatter") %>%
ax_chart(toolbar = list(show = FALSE)) %>%
ax_facet_wrap(
@ -47,8 +51,6 @@ apex(mpg, aes(displ, cty), type = "scatter") %>%
# Lines ----
data("unhcr_ts")
@ -72,7 +74,6 @@ apex(refugees, aes(date, n), type = "line", synchronize = "my-id") %>%
# Bars ----
data("unhcr_ts")

17
inst/htmlwidgets/apexcharter.css
View File

@ -9,3 +9,20 @@
.apexcharter-grid-container > div {
min-width: 0;
}
.apexcharter-facet-col-label {
background:#E6E6E6;
text-align: center;
font-weight: bold;
line-height: 30px;
}
.apexcharter-facet-row-label {
background:#E6E6E6;
text-align: center;
font-weight: bold;
writing-mode: vertical-rl;
text-orientation: mixed;
line-height: 30px;
}

62
man/ax_facet_wrap.Rd → man/apex-facets.Rd
View File

@ -1,7 +1,9 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/facets.R
\name{ax_facet_wrap}
\name{apex-facets}
\alias{apex-facets}
\alias{ax_facet_wrap}
\alias{ax_facet_grid}
\title{Facet wrap for ApexCharts}
\usage{
ax_facet_wrap(
@ -13,6 +15,15 @@ ax_facet_wrap(
labeller = label_value,
chart_height = "300px"
)
ax_facet_grid(
ax,
rows = NULL,
cols = NULL,
scales = c("fixed", "free", "free_y", "free_x"),
labeller = label_value,
chart_height = "300px"
)
}
\arguments{
\item{ax}{An \code{apexcharts} \code{htmlwidget} object.}
@ -27,6 +38,8 @@ free (\code{"free"}), or free in one dimension (\code{"free_x"}, \code{"free_y"}
\item{labeller}{A function with one argument containing for each facet the value of the faceting variable.}
\item{chart_height}{Individual chart height.}
\item{rows, cols}{A set of variables or expressions quoted by vars() and defining faceting groups on the rows or columns dimension.}
}
\value{
An \code{apexcharts} \code{htmlwidget} object.
@ -35,6 +48,7 @@ An \code{apexcharts} \code{htmlwidget} object.
Facet wrap for ApexCharts
}
\examples{
### Wrap --------
library(apexcharter)
# Scatter ----
@ -73,6 +87,9 @@ apex(mpg, aes(displ, cty), type = "scatter") \%>\%
apex(mpg, aes(displ, cty), type = "scatter") \%>\%
ax_facet_wrap(vars(year, drv))
apex(mpg, aes(displ, cty), type = "scatter") \%>\%
ax_facet_wrap(vars(year, drv), ncol = 2, nrow = 3)
apex(mpg, aes(displ, cty), type = "scatter") \%>\%
ax_chart(toolbar = list(show = FALSE)) \%>\%
ax_facet_wrap(
@ -84,8 +101,6 @@ apex(mpg, aes(displ, cty), type = "scatter") \%>\%
# Lines ----
data("unhcr_ts")
@ -109,7 +124,6 @@ apex(refugees, aes(date, n), type = "line", synchronize = "my-id") \%>\%
# Bars ----
data("unhcr_ts")
@ -126,4 +140,44 @@ apex(refugees, aes(continent_origin, n), type = "column") \%>\%
ax_facet_wrap(vars(population_type), ncol = 2)
### Grid --------
library(apexcharter)
# Scatter ----
data("mpg", package = "ggplot2")
# Only rows
apex(mpg, aes(displ, cty), type = "scatter") \%>\%
ax_facet_grid(rows = vars(drv), chart_height = "200px")
# Only cols
apex(mpg, aes(displ, cty), type = "scatter") \%>\%
ax_facet_grid(cols = vars(year))
# Rows and Cols
apex(mpg, aes(displ, cty), type = "scatter") \%>\%
ax_facet_grid(rows = vars(drv), cols = vars(year))
apex(mpg, aes(displ, cty), type = "scatter") \%>\%
ax_chart(toolbar = list(show = FALSE)) \%>\%
ax_facet_grid(vars(drv), vars(cyl))
# Labels
apex(mpg, aes(displ, cty), type = "scatter") \%>\%
ax_facet_grid(
vars(drv),
labeller = function(x) {
switch(
x,
"f" = "front-wheel drive",
"r" = "rear wheel drive",
"4" = "4wd"
)
}
)
}

4
man/apexcharter-shiny-facets.Rd
View File

@ -49,9 +49,9 @@ ui <- fluidPage(
server <- function(input, output, session) {
output$myfacet <- renderApexfacet({
apex(refugees, aes(date, n), type = "line") \%>\%
apex(refugees, aes(date, n), type = "column") \%>\%
ax_yaxis(tickAmount = 5) \%>\%
ax_facet_wrap(vars(continent_origin))
ax_facet_wrap(vars(continent_origin), scales = "free")
})
}

43
vignettes/facets.Rmd
View File

@ -39,10 +39,11 @@ Current limitations are :
## Facet wrap
Create a grid of charts with `ax_facet_wrap()` :
Create a grid of charts according to a variable of the data with `ax_facet_wrap()` :
```{r}
```{r facet-wrap}
data("mpg", package = "ggplot2")
apex(mpg, aes(displ, cty), type = "scatter") %>%
ax_facet_wrap(vars(drv), ncol = 2)
```
@ -50,26 +51,44 @@ apex(mpg, aes(displ, cty), type = "scatter") %>%
Synchronized line charts with free y-axis :
```{r}
data("unhcr_ts")
refugees <- unhcr_ts %>%
subset(population_type == "Refugees (incl. refugee-like situations)") %>%
transform(date = as.Date(paste0(year, "-01-01")))
```{r facet-wrap-sync}
data("economics_long", package = "ggplot2")
apex(refugees, aes(date, n), type = "line", synchronize = "sync-it") %>%
ax_yaxis(tickAmount = 5, labels = list(formatter = format_num("~s"))) %>%
ax_xaxis(tooltip = list(enabled = FALSE)) %>%
apex(economics_long, aes(date, value), type = "line", synchronize = "sync-it") %>%
ax_yaxis(
decimalsInFloat = 0,
labels = list(
formatter = format_num("~s"),
minWidth = 40
)
) %>%
ax_tooltip(x = list(format = "yyyy")) %>%
ax_facet_wrap(vars(continent_origin), scales = "free_y")
ax_facet_wrap(vars(variable), scales = "free_y")
```
Don't forget to set a `minWidth` for y axis labels when synchronizing charts, otherwise unexpected results can occurs.
## Facet grid
Create a matrix of charts defined by row and column faceting variables with `ax_facet_grid()` :
```{r facet-grid}
data("mpg", package = "ggplot2")
apex(mpg, aes(displ, cty), type = "scatter") %>%
ax_facet_grid(rows = vars(drv), cols = vars(year))
```
## Grid
You can construct a grid of (unrelated) charts with `apex_grid()`, construct your charts independently then assemble them in the grid:
```{r}
```{r apex-grid}
a1 <- apex(mpg, aes(manufacturer), type = "bar")
a2 <- apex(mpg, aes(trans), type = "column")
a3 <- apex(mpg, aes(drv), type = "pie")