Facets y2 (#65)
* decompose set scale * set scale yaxis 2 * get global chart serie for fixed yaxis
This commit is contained in:
parent
cacfcde3ce
commit
1fe6e97eee
|
@ -0,0 +1,180 @@
|
||||||
|
|
||||||
|
#' @importFrom rlang eval_tidy
|
||||||
|
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]]
|
||||||
|
attr(facet, "keys") <- strsplit(
|
||||||
|
x = names(facets)[i],
|
||||||
|
split = "|__|", fixed = TRUE
|
||||||
|
)[[1]]
|
||||||
|
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)
|
||||||
|
}
|
||||||
|
|
||||||
|
#' @importFrom rlang %||% is_list is_named
|
||||||
|
set_scale <- function(ax, values, scales = c("fixed", "free", "free_y", "free_x"), axis = c("x", "y", "y2")) {
|
||||||
|
if (is.null(scales))
|
||||||
|
return(ax)
|
||||||
|
scales <- match.arg(scales)
|
||||||
|
axis <- match.arg(axis)
|
||||||
|
if (identical(axis, "y2")) {
|
||||||
|
axis <- "y"
|
||||||
|
wyaxis <- 2
|
||||||
|
} else {
|
||||||
|
wyaxis <- 1
|
||||||
|
}
|
||||||
|
if (is.null(values))
|
||||||
|
return(ax)
|
||||||
|
|
||||||
|
if (inherits(values, c("numeric", "integer", "Date", "POSIXt"))) {
|
||||||
|
range_vals <- range(pretty(values, n = 10), na.rm = TRUE)
|
||||||
|
} else {
|
||||||
|
range_vals <- NULL
|
||||||
|
}
|
||||||
|
|
||||||
|
waxis <- switch(
|
||||||
|
axis,
|
||||||
|
"x" = "xaxis",
|
||||||
|
"y" = "yaxis"
|
||||||
|
)
|
||||||
|
|
||||||
|
this_axis <- ax$x$ax_opts[[waxis]]
|
||||||
|
if (inherits(this_axis, "yaxis2")) {
|
||||||
|
ax$x$ax_opts[[waxis]][[wyaxis]] <- set_scale_axis(
|
||||||
|
this_axis[[wyaxis]],
|
||||||
|
range_vals = range_vals,
|
||||||
|
scales = scales,
|
||||||
|
axis = axis
|
||||||
|
)
|
||||||
|
# ax$x$ax_opts[[waxis]][[2]] <- set_scale_axis(
|
||||||
|
# this_axis[[2]],
|
||||||
|
# range_vals = range_vals,
|
||||||
|
# scales = scales,
|
||||||
|
# axis = axis
|
||||||
|
# )
|
||||||
|
} else {
|
||||||
|
ax$x$ax_opts[[waxis]] <- set_scale_axis(
|
||||||
|
this_axis,
|
||||||
|
range_vals = range_vals,
|
||||||
|
scales = scales,
|
||||||
|
axis = axis
|
||||||
|
)
|
||||||
|
}
|
||||||
|
|
||||||
|
return(ax)
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
scale_fmt <- function(x, time = inherits(x, c("Date", "POSIXt"))) {
|
||||||
|
if (is.null(x))
|
||||||
|
return(NULL)
|
||||||
|
if (time)
|
||||||
|
x <- format_date(x)
|
||||||
|
x
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
set_scale_axis <- function(this_axis,
|
||||||
|
range_vals,
|
||||||
|
scales = c("fixed", "free", "free_y", "free_x"),
|
||||||
|
axis = c("x", "y")) {
|
||||||
|
scales <- match.arg(scales)
|
||||||
|
axis <- match.arg(axis)
|
||||||
|
if (scales == "fixed") {
|
||||||
|
this_axis$min <- this_axis$min %||% scale_fmt(range_vals[1])
|
||||||
|
this_axis$max <- this_axis$max %||% scale_fmt(range_vals[2])
|
||||||
|
} else if (scales == "free") {
|
||||||
|
this_axis$min <- NULL
|
||||||
|
this_axis$max <- NULL
|
||||||
|
} else if (scales == "free_x") {
|
||||||
|
if (axis == "y") {
|
||||||
|
this_axis$min <- this_axis$min %||% scale_fmt(range_vals[1])
|
||||||
|
this_axis$max <- this_axis$max %||% scale_fmt(range_vals[2])
|
||||||
|
} else {
|
||||||
|
this_axis$min <- NULL
|
||||||
|
this_axis$max <- NULL
|
||||||
|
}
|
||||||
|
} else if (scales == "free_y") {
|
||||||
|
if (axis == "x") {
|
||||||
|
this_axis$min <- this_axis$min %||% scale_fmt(range_vals[1])
|
||||||
|
this_axis$max <- this_axis$max %||% scale_fmt(range_vals[2])
|
||||||
|
} else {
|
||||||
|
this_axis$min <- NULL
|
||||||
|
this_axis$max <- NULL
|
||||||
|
}
|
||||||
|
}
|
||||||
|
return(this_axis)
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
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
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
get_yaxis_serie <- function(ax, which = 1) {
|
||||||
|
series <- ax$x$ax_opts$series
|
||||||
|
yaxis <- ax$x$ax_opts$yaxis
|
||||||
|
if (inherits(yaxis, c("yaxis", "yaxis2"))) {
|
||||||
|
yaxis <- yaxis[[which]]
|
||||||
|
name <- yaxis$serieName
|
||||||
|
if (!is.null(name)) {
|
||||||
|
series_names <- vapply(series, FUN = `[[`, "name", FUN.VALUE = character(1))
|
||||||
|
indice <- which(name == series_names)
|
||||||
|
} else {
|
||||||
|
indice <- which
|
||||||
|
}
|
||||||
|
unlist(lapply(series[[indice]]$data, FUN = `[[`, "y"))
|
||||||
|
} else {
|
||||||
|
unlist(lapply(
|
||||||
|
X = seq_along(series),
|
||||||
|
FUN = function(indice) {
|
||||||
|
unlist(lapply(series[[indice]]$data, FUN = `[[`, "y"))
|
||||||
|
}
|
||||||
|
))
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
has_yaxis2 <- function(ax) {
|
||||||
|
inherits(ax$x$ax_opts$yaxis, "yaxis2")
|
||||||
|
}
|
126
R/facets.R
126
R/facets.R
|
@ -1,125 +1,4 @@
|
||||||
|
|
||||||
#' @importFrom rlang eval_tidy
|
|
||||||
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]]
|
|
||||||
attr(facet, "keys") <- strsplit(
|
|
||||||
x = names(facets)[i],
|
|
||||||
split = "|__|", fixed = TRUE
|
|
||||||
)[[1]]
|
|
||||||
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)
|
|
||||||
}
|
|
||||||
|
|
||||||
#' @importFrom rlang %||% is_list is_named
|
|
||||||
set_scale <- function(ax, values, scales = c("fixed", "free", "free_y", "free_x"), axis = c("x", "y")) {
|
|
||||||
if (is.null(scales))
|
|
||||||
return(ax)
|
|
||||||
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, n = 10), 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
|
|
||||||
}
|
|
||||||
|
|
||||||
waxis <- switch(
|
|
||||||
axis,
|
|
||||||
"x" = "xaxis",
|
|
||||||
"y" = "yaxis"
|
|
||||||
)
|
|
||||||
|
|
||||||
this_axis <- ax$x$ax_opts[[waxis]]
|
|
||||||
if (is_list(this_axis) & !is_named(this_axis)) {
|
|
||||||
this_axis <- this_axis[[1]]
|
|
||||||
yaxis2 <- TRUE
|
|
||||||
} else {
|
|
||||||
yaxis2 <- FALSE
|
|
||||||
}
|
|
||||||
if (scales == "fixed") {
|
|
||||||
this_axis$min <- this_axis$min %||% fmt(range_vals[1])
|
|
||||||
this_axis$max <- this_axis$max %||% fmt(range_vals[2])
|
|
||||||
} else if (scales == "free") {
|
|
||||||
this_axis$min <- NULL
|
|
||||||
this_axis$max <- NULL
|
|
||||||
} else if (scales == "free_x") {
|
|
||||||
if (axis == "y") {
|
|
||||||
this_axis$min <- this_axis$min %||% fmt(range_vals[1])
|
|
||||||
this_axis$max <- this_axis$max %||% fmt(range_vals[2])
|
|
||||||
} else {
|
|
||||||
this_axis$min <- NULL
|
|
||||||
this_axis$max <- NULL
|
|
||||||
}
|
|
||||||
} else if (scales == "free_y") {
|
|
||||||
if (axis == "x") {
|
|
||||||
this_axis$min <- this_axis$min %||% fmt(range_vals[1])
|
|
||||||
this_axis$max <- this_axis$max %||% fmt(range_vals[2])
|
|
||||||
} else {
|
|
||||||
this_axis$min <- NULL
|
|
||||||
this_axis$max <- NULL
|
|
||||||
}
|
|
||||||
}
|
|
||||||
if (yaxis2) {
|
|
||||||
ax$x$ax_opts[[waxis]][[1]] <- this_axis
|
|
||||||
} else {
|
|
||||||
ax$x$ax_opts[[waxis]] <- this_axis
|
|
||||||
}
|
|
||||||
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
|
#' @importFrom rlang eval_tidy is_null is_function
|
||||||
build_facets <- function(chart) {
|
build_facets <- function(chart) {
|
||||||
|
@ -221,6 +100,10 @@ build_facets <- function(chart) {
|
||||||
# serie_name = chart$x$add_line$serie_name
|
# serie_name = chart$x$add_line$serie_name
|
||||||
# )
|
# )
|
||||||
}
|
}
|
||||||
|
if (has_yaxis2(new)) {
|
||||||
|
values <- get_yaxis_serie(chart, 2)
|
||||||
|
new <- set_scale(new, values, scales = chart$x$facet$scales, axis = "y2")
|
||||||
|
}
|
||||||
new$height <- chart$height %||% chart$x$facet$chart_height
|
new$height <- chart$height %||% chart$x$facet$chart_height
|
||||||
new$x$facet <- NULL
|
new$x$facet <- NULL
|
||||||
class(new) <- setdiff(class(new), "apex_facet")
|
class(new) <- setdiff(class(new), "apex_facet")
|
||||||
|
@ -613,4 +496,3 @@ complete_data <- function(data, vars, fill_var, fill_value = 0) {
|
||||||
return(full_data)
|
return(full_data)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -252,3 +252,21 @@ test_that("apexfacetOutput works", {
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
test_that("get_yaxis_serie works", {
|
||||||
|
mydata <- data.frame(
|
||||||
|
x = 1:10,
|
||||||
|
y = c(1:5, (16:20) * 10),
|
||||||
|
fill = rep(c("a", "b"), each = 5)
|
||||||
|
)
|
||||||
|
ax <- apex(mydata, aes(x, y), "line")
|
||||||
|
expect_equal(get_yaxis_serie(ax, 1), c(1:5, (16:20) * 10))
|
||||||
|
|
||||||
|
ax <- apex(mydata, aes(x, y, fill = fill), "line")
|
||||||
|
expect_equal(get_yaxis_serie(ax, 1), c(1:5, (16:20) * 10))
|
||||||
|
|
||||||
|
ax <- apex(mydata, aes(x, y, fill = fill), "line") %>%
|
||||||
|
ax_yaxis(title = list(text = "Y1")) %>%
|
||||||
|
ax_yaxis2(title = list(text = "Y2"))
|
||||||
|
expect_equal(get_yaxis_serie(ax, 1), c(1:5))
|
||||||
|
expect_equal(get_yaxis_serie(ax, 2), c((16:20) * 10))
|
||||||
|
})
|
Loading…
Reference in New Issue