From 1fe6e97eeea89ebe57bb5d5451308211338eb1ff Mon Sep 17 00:00:00 2001 From: Victor Perrier Date: Fri, 9 Dec 2022 09:36:32 +0100 Subject: [PATCH] Facets y2 (#65) * decompose set scale * set scale yaxis 2 * get global chart serie for fixed yaxis --- R/facets-utils.R | 180 +++++++++++++++++++++++++++++++++++ R/facets.R | 126 +----------------------- tests/testthat/test-facets.R | 18 ++++ 3 files changed, 202 insertions(+), 122 deletions(-) create mode 100644 R/facets-utils.R diff --git a/R/facets-utils.R b/R/facets-utils.R new file mode 100644 index 0000000..6085481 --- /dev/null +++ b/R/facets-utils.R @@ -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") +} diff --git a/R/facets.R b/R/facets.R index bb1bf94..7915b24 100644 --- a/R/facets.R +++ b/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 build_facets <- function(chart) { @@ -221,6 +100,10 @@ build_facets <- function(chart) { # 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$x$facet <- NULL class(new) <- setdiff(class(new), "apex_facet") @@ -613,4 +496,3 @@ complete_data <- function(data, vars, fill_var, fill_value = 0) { return(full_data) } - diff --git a/tests/testthat/test-facets.R b/tests/testthat/test-facets.R index e1136c9..302adf0 100644 --- a/tests/testthat/test-facets.R +++ b/tests/testthat/test-facets.R @@ -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)) +}) \ No newline at end of file