select + scale breaks

dreamRs · Jun 6, 2018 · 5d2c190 · 5d2c190
1 parent 6c53ee4
commit 5d2c190
Show file tree

Hide file tree

Showing 12 changed files with 306 additions and 109 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -9,6 +9,7 @@ export(add_discrete_scale)
 export(add_discrete_scale2)
 export(add_labs)
 export(add_legend)
+export(add_select_input)
 export(add_tooltip)
 export(add_zoom)
 export(d3_cartogram)
@@ -24,6 +25,7 @@ importFrom(geojsonio,geojson_list)
 importFrom(geojsonio,geojson_sf)
 importFrom(glue,glue)
 importFrom(glue,glue_data)
+importFrom(htmltools,doRenderTags)
 importFrom(htmltools,htmlDependency)
 importFrom(jsonlite,toJSON)
 importFrom(magrittr,"%>%")
@@ -39,7 +41,9 @@ importFrom(scales,rescale)
 importFrom(scales,seq_gradient_pal)
 importFrom(scales,viridis_pal)
 importFrom(shiny,getDefaultReactiveDomain)
+importFrom(shiny,selectInput)
 importFrom(stats,model.frame)
+importFrom(stats,setNames)
 importFrom(utils,modifyList)
 importFrom(utils,packageVersion)
 importFrom(utils,type.convert)
diff --git a/R/add-select.R b/R/add-select.R
@@ -0,0 +1,45 @@
+
+
+#' Add a select menu above a map
+#'
+#' Use this to update variable used in \code{d3_cartogram}.
+#'
+#' @param map A \code{d3_cartogram} \code{htmlwidget} object.
+#' @param label Display label for the control, or \code{NULL} for no label.
+#' @param choices List of values to select from. Can be a named list. Values must be variables names.
+#'
+#' @export
+#'
+#' @importFrom shiny selectInput
+#' @importFrom htmltools doRenderTags
+#'
+#' @examples
+#' # todo
+add_select_input <- function(map, label = NULL, choices) {
+  id <- paste0("select-", sample.int(1e9, 1))
+  select_ <- selectInput(
+    inputId = id,
+    label = label,
+    choices = choices,
+    multiple = FALSE,
+    selectize = FALSE
+  )
+  select_$children[[2]]$children[[1]]$attribs$class <- "form-control custom-select"
+  select_html <- doRenderTags(select_)
+  choices <- unlist(choices, use.names = FALSE)
+  if (is.null(map$x$options$data))
+    stop("No data !", call. = FALSE)
+  data_ <- map$x$options$data
+  if (!all(choices %in% names(data_)))
+    stop("Choices are not all columns names !", call. = FALSE)
+  map$x$options$select <- TRUE
+  .r2d3map_opt(
+    map, "select_opts",
+    select_html = select_html,
+    id = id, choices = choices
+  )
+}
+
+
+
+
diff --git a/R/d3_cartogram.R b/R/d3_cartogram.R
@@ -41,7 +41,9 @@ d3_cartogram <- function(shape, projection = "Mercator", stroke_col = "#fff", st
   raw_data$id <- as.character(seq_len(nrow(raw_data)))
 
   r2d3(
-    data = geo_topo, d3_version = 5,
+    data = geo_topo,
+    d3_version = 5,
+    container = "div",
     dependencies = c(
       system.file("js/topojson.min.js", package = "r2d3maps"),
       system.file("js/d3-cartogram.min.js", package = "r2d3maps")

diff --git a/R/d3_map.R b/R/d3_map.R
@@ -46,19 +46,17 @@ d3_map <- function(shape, projection = "Mercator", stroke_col = "#fff", stroke_w
 
   # convert to geojson
   suppressWarnings({
-    shape <- geojson_json(input = shape)
+    shape_json <- geojson_json(input = shape)
   })
 
   # keep data
-  data <- geojson_sf(shape)
-  data <- as.data.frame(data)
-  data$geometry <- NULL
+  data <- extract_data(shape)
 
   # convert to topojson
-  shape <- geo2topo(x = shape, object_name = "states")
+  shape_topo <- geo2topo(x = shape_json, object_name = "states")
 
   map <- r2d3(
-    data = shape,
+    data = shape_topo,
     d3_version = 5, container = "div",
     dependencies = c(
       system.file("js/topojson.min.js", package = "r2d3maps"),

diff --git a/R/d3_map_proxy.R b/R/d3_map_proxy.R
@@ -54,27 +54,6 @@ d3_map_proxy <- function(shinyId, data = NULL, session = shiny::getDefaultReacti
 
 
 
-# helper to extract data
-extract_data <- function(x) {
-  UseMethod("extract_data")
-}
-extract_data.SpatialPolygonsDataFrame <- function(x) {
-  return(x@data)
-}
-extract_data.data.frame <- function(x) {
-  return(x)
-}
-extract_data.sf <- function(x) {
-  x <- as.data.frame(x)
-  colsf <- attr(x, "sf_column")
-  x[[colsf]] <- NULL
-  return(x)
-}
-extract_data.NULL <- function(x) {
-  NULL
-}
-
-
 #' Update a continuous scale in Shiny
 #'
 #' @param proxy A \code{d3_map_proxy} object.
@@ -99,13 +78,6 @@ extract_data.NULL <- function(x) {
 update_continuous_breaks <- function(proxy, var, palette = NULL, direction = 1, n_breaks = 5, style = "pretty") {
   if (!"d3_map_proxy" %in% class(proxy))
     stop("This function must be used with a d3_map_proxy object", call. = FALSE)
-  palette <- match.arg(
-    arg = palette,
-    choices = c("viridis", "magma", "plasma", "inferno", "cividis",
-                "Blues", "BuGn", "BuPu", "GnBu", "Greens",
-                "Greys", "Oranges", "OrRd", "PuBu", "PuBuGn", "PuRd", "Purples",
-                "RdPu", "Reds", "YlGn", "YlGnBu", "YlOrBr", "YlOrRd")
-  )
   data <- proxy$x$data
   if (is.null(data))
     stop("No data provided!", call. = FALSE)
@@ -114,29 +86,18 @@ update_continuous_breaks <- function(proxy, var, palette = NULL, direction = 1,
     warning("Invalid variable!", call. = FALSE)
     return(invisible(proxy))
   }
-  range_col <- classIntervals(var = var_, n = n_breaks, style = style)$brks
-  n_breaks <- length(range_col) - 1
-  if (!is.null(palette)) {
-    if (palette %in% c("viridis", "magma", "plasma", "inferno", "cividis")) {
-      colors <- viridis_pal(option = palette, direction = direction)(n_breaks)
-      colors <- substr(colors, 1, 7)
-    } else {
-      pal <- col_numeric(palette = palette, domain = 0:100, na.color = "#808080")
-      colors <- pal(seq(from = 20, to = 100, length.out = n_breaks + 1))
-      if (direction > 0) {
-        colors <- rev(colors)
-      }
-    }
-  } else {
-    colors <- NULL
-  }
   .r2d3maps_proxy(
     proxy = proxy,
     name = "continuous-breaks",
     color_var = var,
-    range_var = c(0, max(var_, na.rm = TRUE)),
-    range_col = range_col,
-    colors = if (!is.null(colors)) c("#fafafa", colors) else NULL
+    scale = scale_breaks(
+      data = data,
+      vars = var,
+      palette = palette,
+      direction = direction,
+      n_breaks = n_breaks,
+      style = style
+    )
   )
 }
 

diff --git a/R/scale-continuous.R b/R/scale-continuous.R
@@ -16,9 +16,7 @@
 #'
 #' @export
 #'
-#' @importFrom scales col_numeric viridis_pal
 #' @importFrom utils type.convert
-#' @importFrom classInt classIntervals
 #'
 #' @examples
 #' library( r2d3maps )
@@ -79,47 +77,75 @@
 #'
 add_continuous_breaks <- function(map, var, palette = "viridis", direction = 1,
                                  n_breaks = 5, style = "pretty", na_color = "#b8b8b8") {
-  palette <- match.arg(
-    arg = palette,
-    choices = c("viridis", "magma", "plasma", "inferno", "cividis",
-                "Blues", "BuGn", "BuPu", "GnBu", "Greens",
-                "Greys", "Oranges", "OrRd", "PuBu", "PuBuGn", "PuRd", "Purples",
-                "RdPu", "Reds", "YlGn", "YlGnBu", "YlOrBr", "YlOrRd")
-  )
   if (is.null(map$x$options$data))
     stop("No data !", call. = FALSE)
   var_ <- map$x$options$data[[var]]
   if (is.null(var_))
     stop("Invalid variable supplied to continuous scale !", call. = FALSE)
-
-  if (is.character(var_))
-    var_ <- type.convert(var_)
-  if (!is.numeric(var_))
-    stop("'var' must be a numeric vector!", call. = FALSE)
-  range_col <- classIntervals(var = var_, n = n_breaks, style = style)$brks
-  n_breaks <- length(range_col) - 1
-  if (palette %in% c("viridis", "magma", "plasma", "inferno", "cividis")) {
-    colors <- viridis_pal(option = palette, direction = direction)(n_breaks)
-    colors <- substr(colors, 1, 7)
-  } else {
-    pal <- col_numeric(palette = palette, domain = 0:100, na.color = "#808080")
-    colors <- pal(seq(from = 20, to = 100, length.out = n_breaks + 1))
-    if (direction > 0) {
-      colors <- rev(colors)
-    }
-  }
   map$x$options$cartogram <- TRUE
   .r2d3map_opt(
     map = map, name = "colors",
     color_type = "continuous-breaks",
     color_var = var,
-    range_var = c(0, max(var_, na.rm = TRUE)),
-    range_col = range_col,
-    na_color = na_color,
-    colors = c("#fafafa", colors)
+    scale = scale_breaks(
+      data = map$x$options$data,
+      vars = base::union(var, map$x$options$select_opts$choices),
+      palette = palette,
+      direction = direction,
+      n_breaks = n_breaks,
+      style = style
+    ),
+    na_color = na_color
   )
 }
 
+#' @importFrom scales col_numeric viridis_pal
+#' @importFrom classInt classIntervals
+#' @importFrom stats setNames
+scale_breaks <- function(data, vars, palette = "viridis", direction = 1, n_breaks = 5, style = "pretty") {
+  if (is.null(vars)) {
+    return(NULL)
+  } else {
+    if (!is.null(palette)) {
+      palette <- match.arg(
+        arg = palette,
+        choices = c("viridis", "magma", "plasma", "inferno", "cividis",
+                    "Blues", "BuGn", "BuPu", "GnBu", "Greens",
+                    "Greys", "Oranges", "OrRd", "PuBu", "PuBuGn", "PuRd", "Purples",
+                    "RdPu", "Reds", "YlGn", "YlGnBu", "YlOrBr", "YlOrRd")
+      )
+    }
+    lapply(
+      X = setNames(vars, vars),
+      FUN = function(x) {
+        var <- data[[x]]
+        breaks_var <- classIntervals(var = var, n = n_breaks, style = style)$brks
+        n_breaks <- length(breaks_var) - 1
+        if (is.null(palette)) {
+          colors <- NULL
+        } else {
+          if (palette %in% c("viridis", "magma", "plasma", "inferno", "cividis")) {
+            colors <- viridis_pal(option = palette, direction = direction)(n_breaks)
+            colors <- substr(colors, 1, 7)
+          } else {
+            pal <- col_numeric(palette = palette, domain = 0:100, na.color = "#808080")
+            colors <- pal(seq(from = 10, to = 100, length.out = n_breaks + 1))
+            if (direction > 0) {
+              colors <- rev(colors)
+            }
+          }
+        }
+        list(
+          range_var = c(0, max(var, na.rm = TRUE)),
+          breaks_var = breaks_var,
+          colors = if (!is.null(colors)) c("#fafafa", colors) else NULL
+        )
+      }
+    )
+  }
+}
+
+
 
 
 

diff --git a/R/utils.R b/R/utils.R
@@ -0,0 +1,24 @@
+
+
+# helper to extract data
+extract_data <- function(x) {
+  UseMethod("extract_data")
+}
+extract_data.SpatialPolygonsDataFrame <- function(x) {
+  return(x@data)
+}
+extract_data.data.frame <- function(x) {
+  return(x)
+}
+extract_data.sf <- function(x) {
+  x <- as.data.frame(x)
+  colsf <- attr(x, "sf_column")
+  x[[colsf]] <- NULL
+  return(x)
+}
+extract_data.NULL <- function(x) {
+  NULL
+}
+
+
+
diff --git a/dev/dev-cartogram.R b/dev/dev-cartogram.R
@@ -5,6 +5,8 @@
 
 
 
+# Ireland -----------------------------------------------------------------
+
 library( r2d3maps )
 library( rnaturalearth )
 
@@ -24,3 +26,23 @@ d3_cartogram(shape = ireland)
 d3_cartogram(shape = ireland) %>%
   add_continuous_breaks(var = "foo2", palette = "Blues")
 
+
+
+
+
+# Paris -------------------------------------------------------------------
+
+library(r2d3maps)
+data("paris")
+
+d3_cartogram(shape = paris) %>%
+  add_continuous_breaks(var = "AGE_00", palette = "Blues")
+
+
+d3_cartogram(shape = paris) %>%
+  add_select_input(label = "Choose a var:", choices = grep(pattern = "AGE", x = names(paris), value = TRUE)) %>%
+  add_continuous_breaks(var = "AGE_03", palette = "Blues")
+
+
+
+