dev facet_wrap

dreamRs · Sep 4, 2024 · 456224c · 456224c
1 parent 2f64b5f
commit 456224c
Show file tree

Hide file tree

Showing 7 changed files with 389 additions and 189 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -15,7 +15,8 @@ Imports:
     ggplot2,
     htmlwidgets,
     magrittr,
-    rlang
+    rlang,
+    scales
 Suggests: 
     bslib,
     knitr,

diff --git a/NAMESPACE b/NAMESPACE
@@ -14,6 +14,7 @@ export(v_area)
 export(v_bar)
 export(v_boxplot)
 export(v_circlepacking)
+export(v_facet_wrap)
 export(v_gauge)
 export(v_heatmap)
 export(v_hist)
@@ -69,6 +70,7 @@ export(vmap)
 importFrom(ggplot2,aes)
 importFrom(ggplot2,geom_boxplot)
 importFrom(ggplot2,geom_jitter)
+importFrom(ggplot2,geom_smooth)
 importFrom(ggplot2,ggplot)
 importFrom(ggplot2,label_value)
 importFrom(ggplot2,layer_data)
@@ -84,13 +86,16 @@ importFrom(htmlwidgets,shinyWidgetOutput)
 importFrom(htmlwidgets,sizingPolicy)
 importFrom(magrittr,"%>%")
 importFrom(rlang,"%||%")
+importFrom(rlang,as_label)
 importFrom(rlang,eval_tidy)
 importFrom(rlang,exec)
 importFrom(rlang,has_name)
 importFrom(rlang,is_list)
 importFrom(rlang,is_named)
+importFrom(rlang,quos)
 importFrom(rlang,set_names)
 importFrom(rlang,sym)
 importFrom(rlang,syms)
 importFrom(stats,complete.cases)
+importFrom(utils,head)
 importFrom(utils,modifyList)
diff --git a/R/facets.R b/R/facets.R
@@ -1,34 +1,92 @@
 
+#' @title Facets for vchart
+#'
+#' @description Create matrix of charts by row and column faceting variable (`v_facet_grid`),
+#'  or by specified number of row and column for faceting variable(s) (`v_facet_wrap`).
+#'
+#' @param vc A chart initialized with [vchart()].
+#' @param facets Variable(s) to use for facetting, wrapped in `vars(...)`.
+#' @param nrow,ncol Number of row and column in output matrix.
+#' @param scales Should scales be fixed (`"fixed"`, the default),
+#'  free (`"free"`), or free in one dimension (`"free_x"`, `"free_y"`)?
+#' @param labeller A function with one argument containing for each facet the value of the faceting variable.
+#'
+#' @return A [vchart()] `htmlwidget` object.
+#' @export
+#'
+#' @importFrom rlang quos syms
+#'
+#' @example examples/facet_wrap.R
+v_facet_wrap <- function(vc,
+                         facets,
+                         nrow = NULL,
+                         ncol = NULL,
+                         scales = c("fixed", "free", "free_y", "free_x"),
+                         labeller = label_value) {
+  stopifnot(
+    "\'vc\' must be a chart constructed with vchart()" = inherits(vc, "vchart")
+  )
+  scales <- match.arg(scales)
+  if (is.character(facets))
+    facets <- quos(!!!syms(facets))
+  data <- get_data(vc, NULL)
+  facets_values <- get_facets_values(data, facets)
+  n <- length(unique(facets_values$facet_id))
+  dims <- get_facets_dims(n, nrow = nrow, ncol = ncol)
+  mat <- matrix(
+    data = seq_len(n)[seq_len(dims$nrow * dims$ncol)],
+    nrow = dims$nrow,
+    ncol = dims$ncol,
+    byrow = TRUE
+  )
+  vc$x$specs$layout <- create_layout(dims$ncol, dims$nrow, title = !is.null(vc$title))
+  vc$x$specs$region <- create_region(n)
+  vc$x$specs$indicator <- create_indicator(facets_values, label_fun = labeller)
+  vc$x$specs$data <- create_facet_data(vc, facet = facets_values)
+  vc$x$specs$series <- create_facet_series(vc, facet = facets_values)
+  x <- get_aes_data(vc$x$mapdata, c("x", "xmin", "xmax"))
+  y <- get_aes_data(vc$x$mapdata, c("y", "ymin", "ymax"))
+  vc$x$specs$axes <- c(
+    create_axis_x(vc, x = x, facet = facets_values, free = scales %in% c("free", "free_x"), last_row = get_last_row(mat)),
+    create_axis_y(vc, y = y, facet = facets_values, free = scales %in% c("free", "free_y"), first_col = mat[, 1])
+  )
+  return(vc)
+}
+
 
-create_layout <- function(ncol, nrow) {
 
+create_layout <- function(ncol, nrow, title = FALSE) {
+
   create_matrix <- function(data, byrow) {
     matrix(data = data, nrow = nrow, ncol = ncol, byrow = byrow)
   }
-
+  
   n <- ncol * nrow
-
+  
   mat <- matrix(data = seq_len(n), nrow = nrow, ncol = ncol, byrow = TRUE)
   mat_axe_y_col <- create_matrix(rep(0 + ((seq_len(ncol) - 1) * 2), rep = nrow), TRUE)
-  mat_axe_y_row <- create_matrix(rep(1 + ((seq_len(nrow) - 1) * 3), rep = ncol), FALSE)
+  mat_axe_y_row <- create_matrix(rep(1 + ((seq_len(nrow) - 1) * 3), rep = ncol), FALSE) + title
   mat_axe_x_col <- create_matrix(rep(1 + ((seq_len(ncol) - 1) * 2), rep = nrow), TRUE)
-  mat_axe_x_row <- create_matrix(rep(2 + ((seq_len(nrow) - 1) * 3), rep = ncol), FALSE)
+  mat_axe_x_row <- create_matrix(rep(2 + ((seq_len(nrow) - 1) * 3), rep = ncol), FALSE) + title
   mat_chart_col <- create_matrix(rep(1 + ((seq_len(ncol) - 1) * 2), rep = nrow), TRUE)
-  mat_chart_row <- create_matrix(rep(1 + ((seq_len(nrow) - 1) * 3), rep = ncol), FALSE)
+  mat_chart_row <- create_matrix(rep(1 + ((seq_len(nrow) - 1) * 3), rep = ncol), FALSE) + title
   mat_ind_col <- create_matrix(rep(0 + ((seq_len(ncol) - 1) * 2), rep = nrow), TRUE)
-  mat_ind_row <- create_matrix(rep(0 + ((seq_len(nrow) - 1) * 3), rep = ncol), FALSE)
-
+  mat_ind_row <- create_matrix(rep(0 + ((seq_len(nrow) - 1) * 3), rep = ncol), FALSE) + title
+  
   list(
     type = "grid",
     col = ncol * 2,
-    row = nrow * 3,
+    row = nrow * 3 + title,
     rowHeight = lapply(
-      X = 0 + (seq_len(nrow) - 1) * 3,
+      X = title + (seq_len(nrow) - 1) * 3,
       FUN = function(index) {
         list(index = index, size = 30)
       }
     ),
     elements = c(
+      if (title) {
+        list(list(modelId = "title", col = 0, row = 0, colSpan = ncol * 2))
+      },
       lapply(
         X = seq_len(n),
         FUN = function(num) {
@@ -87,9 +145,7 @@ create_layout <- function(ncol, nrow) {
 }
 
 
-create_region <- function(ncol, nrow) {
-  mat <- matrix(data = seq_len(ncol * nrow), nrow = nrow, ncol = ncol, byrow = TRUE)
-  n <- length(mat)
+create_region <- function(n) {
   c(
     lapply(
       X = seq_len(n),
@@ -111,13 +167,13 @@ create_facet_data <- function(vc, facet) {
   list_data <- lapply(
     X = seq_along(vc$x$specs$data),
     FUN = function(i) {
-      split_data <- split(vc$x$specs$data[[i]]$values, f = as.character(facet))
+      split_data <- split(vc$x$specs$data[[i]]$values, f = facet$facet_id)
       lapply(
         X = seq_along(split_data),
         FUN = function(ii) {
           list(
             id = paste0("data_", ii, "_", i),
-            name = names(split_data)[ii],
+            name = get_facet_name(facet, names(split_data)[ii]),
             values = split_data[[ii]]
           )
         }
@@ -130,18 +186,17 @@ create_facet_data <- function(vc, facet) {
 
 
 create_facet_series <- function(vc, facet) {
-  facets <- unique(as.character(facet))
   list_data <- lapply(
-    X = seq_along(facets),
-    FUN = function(i) {
+    X = unique(facet$facet_id),
+    FUN = function(id) {
       serie <- vc$x$specs$series
       lapply(
         X = seq_along(serie),
-        FUN = function(ii) {
-          this <- serie[[ii]]
-          this$id <- paste0("serie_", i, "_", ii)
-          this$dataId <- paste0("data_", i, "_", ii)
-          this$regionId <- paste0("chart_", i)
+        FUN = function(i) {
+          this <- serie[[i]]
+          this$id <- paste0("serie_", id, "_", i)
+          this$dataId <- paste0("data_", id, "_", i)
+          this$regionId <- paste0("chart_", id)
           return(this)
         }
       )
@@ -151,35 +206,130 @@ create_facet_series <- function(vc, facet) {
 }
 
 
-create_indicator <- function(facet, label_fun = identity) {
-  values <- unique(facet)
+create_indicator <- function(facet, label_fun = ggplot2::label_value) {
   lapply(
-    X = seq_along(values),
-    FUN = function(i) {
-      value <- label_fun(values[i])
-      regionId <- paste0("indicator_", i)
-      if (is.null(value) || is.na(value)) {
+    X = unique(facet$facet_id),
+    FUN = function(id) {
+      value <- get_facet_name(facet, id, use_names = TRUE)
+      value <- label_fun(value)
+      regionId <- paste0("indicator_", id)
+      if (is.null(value) || all(is.na(value))) {
         return(list(regionId = regionId, visible = FALSE))
       }
-      if (is.character(value)) {
-        return(list(
-          regionId = regionId,
-          visible = TRUE,
-          title = list(
-            style = list(
-              text = value,
-              textAlign = "center",
-              fontSize = 16
-            )
-          )
-        ))
-      }
       list(
         regionId = regionId,
         visible = TRUE,
-        title = list(style = value)
+        content = list(
+          style = list(
+            text = unname(value),
+            textAlign = "center",
+            fontSize = 16
+          )
+        )
       )
     }
   )
 }
 
+
+
+create_axis_x <- function(vc, x, facet, free = TRUE, last_row = numeric(0)) {
+  index <- get_axes_index(vc, position = "bottom")
+  axe_x <- vc$x$specs$axes[[index]]
+  lapply(
+    X = unique(facet$facet_id),
+    FUN = function(id) {
+      this <- axe_x
+      this$id <- paste0("axe_x_", id)
+      this$regionId <- paste0("chart_", id)
+      if (identical(this$type, "linear") & isFALSE(free)) {
+        valrange <-  scales::expand_range(
+          range = range(x, na.rm = TRUE),
+          mul = 0.05,
+          add = 0
+        )
+        this$softMin <- valrange[1]
+        this$softMax <- valrange[2]
+      }
+      this$label$visible <- isTRUE(free) | id %in% last_row
+      this$domainLine$visible <- isTRUE(free) | id %in% last_row
+      this$minHeight <- ifelse(isTRUE(free), 30, 20)
+      return(this)
+    }
+  )
+}
+
+
+
+
+create_axis_y <- function(vc, y, facet, free = TRUE, first_col = numeric(0)) {
+  index <- get_axes_index(vc, position = "left")
+  axe_y <- vc$x$specs$axes[[index]]
+  lapply(
+    X = unique(facet$facet_id),
+    FUN = function(id) {
+      this <- axe_y
+      this$id <- paste0("axe_y_", id)
+      this$regionId <- paste0("chart_", id)
+      if (identical(this$type, "linear") & isFALSE(free)) {
+        valrange <-  scales::expand_range(
+          range = range(y, na.rm = TRUE),
+          mul = 0.05,
+          add = 0
+        )
+        this$softMin <- valrange[1]
+        this$softMax <- valrange[2]
+      }
+      this$label$visible <- isTRUE(free) | id %in% first_col
+      this$domainLine$visible <- isTRUE(free) | id %in% first_col
+      this$minWidth <- ifelse(isTRUE(free), 35, 20)
+      return(this)
+    }
+  )
+}
+
+
+
+get_facets_dims <- function(n, nrow = NULL, ncol = NULL) {
+  if (is.null(nrow) & !is.null(ncol))
+    nrow <- ceiling(n / ncol)
+  if (!is.null(nrow) & is.null(ncol))
+    ncol <- ceiling(n / nrow)
+  if (is.null(nrow) & is.null(ncol)) {
+    if (n %% 3 < 1) {
+      ncol <- 3
+      nrow <- ceiling(n / ncol)
+    } else {
+      ncol <- 2
+      nrow <- ceiling(n / ncol)
+    }
+  }
+  list(nrow = nrow, ncol = ncol)
+}
+
+
+#' @importFrom rlang as_label
+get_facets_values <- function(data, facets) {
+  all_values <- eval_mapping_(data, facets)
+  all_values <- as.data.frame(all_values, col.names = lapply(facets, as_label))
+  # all_values <- all_values[do.call(order, unname(all_values)), , drop = FALSE]
+  unique_values <- unique(all_values)
+  unique_values$facet_id <- seq_along(unique_values[[1]])
+  merge(x = all_values, y = unique_values, sort = FALSE)
+}
+
+#' @importFrom utils head
+get_facet_name <- function(facet, id, use_names = FALSE) {
+  unlist(head(facet[facet$facet_id == id, -ncol(facet)], 1), use.names = use_names)
+}
+
+
+
+get_last_row <- function(mat) {
+  apply(X = mat, MARGIN = 2, FUN = function(x) {
+    x <- x[!is.na(x)]
+    x[length(x)]
+  })
+}
+
+