Merge 74e76f8 into b56eb75

DESCRIPTION

@@ -4,7 +4,8 @@ Date: 2020-10-15
 Version: 0.3.4
 Authors@R: c(
   person("John", "Coene", email = "jcoenep@gmail.com", role = c("aut", "cre", "cph")), 
-  person(given = "Wei", family = "Su", email = "swsoyee@gmail.com", role = "ctb"))
+  person(given = "Wei", family = "Su", email = "swsoyee@gmail.com", role = "ctb"),
+  person("Helgasoft", ".com", email="contact@helgasoft.com", role = "ctb"))
 Description: Easily create interactive charts by leveraging the 'Echarts Javascript' library which includes
     36 chart types, themes, 'Shiny' proxies and animations.
 License: Apache License (>= 2.0)

R/add.R

@@ -3625,14 +3625,14 @@ e_correlations.echarts4rProxy <- function(e, order = NULL, visual_map = TRUE, ..
 #'   e_error_bar(lower, upper)
 #' @rdname errorbar
 #' @export
-e_error_bar <- function(e, lower, upper, name = NULL, legend = TRUE, y_index = 0, x_index = 0,
+e_error_bar <- function(e, lower, upper, name = NULL, legend = FALSE, y_index = 0, x_index = 0,
                         coord_system = "cartesian2d", ...) {
   UseMethod("e_error_bar")
 }
 
 #' @export
 #' @method e_error_bar echarts4r
-e_error_bar.echarts4r <- function(e, lower, upper, name = NULL, legend = TRUE, y_index = 0, x_index = 0,
+e_error_bar.echarts4r <- function(e, lower, upper, name = NULL, legend = FALSE, y_index = 0, x_index = 0,
                                   coord_system = "cartesian2d", ...) {
   if (missing(e)) {
     stop("must pass e", call. = FALSE)
@@ -3651,7 +3651,7 @@ e_error_bar.echarts4r <- function(e, lower, upper, name = NULL, legend = TRUE, y
 
 #' @export
 #' @method e_error_bar echarts4rProxy
-e_error_bar.echarts4rProxy <- function(e, lower, upper, name = NULL, legend = TRUE, y_index = 0, x_index = 0,
+e_error_bar.echarts4rProxy <- function(e, lower, upper, name = NULL, legend = FALSE, y_index = 0, x_index = 0,
                                        coord_system = "cartesian2d", ...) {
   if (missing(e)) {
     stop("must pass e", call. = FALSE)

R/add_.R

@@ -2128,8 +2128,17 @@ e_band_ <- function(e, min, max, stack = "confidence-band", symbol = c("none", "
 
 #' @rdname errorbar
 #' @export
-e_error_bar_ <- function(e, lower, upper, name = NULL, legend = TRUE, y_index = 0, x_index = 0,
-                         coord_system = "cartesian2d", ...) {
+#'    comments on changes, by helgasoft.com
+#' It's convenient to "attach" error bars to their related main bars
+#' so they'll show/hide together when user clicks on the legend buttons.
+#' This is done by having the same name for error and main bars.
+#' Default legend = FALSE, since we'll have only main bars in legend.
+#' Error bars will inherit color from their main bars, so it is preferable
+#' to set a specific color, like e_error_bar(..., color='black'), which
+#' is now set as default. See test code in renderer.js.
+
+e_error_bar_ <- function(e, lower, upper, name=NULL, legend=FALSE, y_index=0, x_index=0,
+                         coord_system="cartesian2d", ...) {
   if (missing(e)) {
     stop("must pass e", call. = FALSE)
   }
@@ -2139,8 +2148,12 @@ e_error_bar_ <- function(e, lower, upper, name = NULL, legend = TRUE, y_index =
   }
 
   args <- list(...)
-  names(args) <- names(args)
-
+
+  # save series to be read by renderErrorBar2
+  # renderers.js works in a very isolated environment, so we send data thru sessionStorage
+  renderJS <- htmlwidgets::JS(paste0("sessionStorage.setItem('ErrorBar.oss','",
+                        jsonlite::toJSON(e$x$opts$series),"'); renderErrorBar2"))
+
   for (i in 1:length(e$x$data)) {
     .build_data2(e$x$data[[i]], e$x$mapping$x, lower, upper) -> vector
 
@@ -2168,7 +2181,7 @@ e_error_bar_ <- function(e, lower, upper, name = NULL, legend = TRUE, y_index =
         nm <- name
       } else {
         nm <- .name_it(e, NULL, name, i)
-        nm <- paste(nm, "error")
+        # nm <- paste(nm, "error")	    # comm.out: now adopts main bar's name
         nm <- trimws(nm)
       }
 
@@ -2177,21 +2190,23 @@ e_error_bar_ <- function(e, lower, upper, name = NULL, legend = TRUE, y_index =
         type = "custom",
         yAxisIndex = y_index,
         xAxisIndex = x_index,
-        z = ifelse("z" %in% names(args), args$z, 3),
+        # z = ifelse("z" %in% names(args), args$z, 3),  # comm.out: bug - adds extra 'z'
         coordinateSystem = coord_system,
         itemStyle = list(
           normal = list(
             borderWidth = 1.5
           )
         ),
-        renderItem = htmlwidgets::JS("renderErrorBar"),
+        renderItem = renderJS,
         encode = list(
           x = 0,
           y = list(1, 2)
         ),
         ...
       )
-
+      if (!("z" %in% names(args))) opts$z <- 3      # keep error bar in front
+      if (!("color" %in% names(args))) opts$color <- 'black'  # set, or it will blend with main bar
+
       e_serie <- append(e_serie, opts)
 
       if (isTRUE(legend)) {
@@ -2214,21 +2229,22 @@ e_error_bar_ <- function(e, lower, upper, name = NULL, legend = TRUE, y_index =
       type = "custom",
       yAxisIndex = y_index,
       xAxisIndex = x_index,
-      z = ifelse("z" %in% names(args), args$z, 3),
       coordinateSystem = coord_system,
       itemStyle = list(
         normal = list(
           borderWidth = 1.5
         )
       ),
-      renderItem = htmlwidgets::JS("renderErrorBar"),
+      renderItem = renderJS,
       encode = list(
         x = 0,
         y = list(1, 2)
       ),
       ...
     )
-
+    if (!("z" %in% names(args))) series_opts$z <- 3
+    if (!("color" %in% names(args))) series_opts$color <- 'black'
+
     if (isTRUE(legend)) {
       e$x$opts$baseOption$legend$data <- append(e$x$opts$baseOption$legend$data, list(name))
     }
@@ -2240,7 +2256,7 @@ e_error_bar_ <- function(e, lower, upper, name = NULL, legend = TRUE, y_index =
   path <- system.file("htmlwidgets/lib/echarts-4.8.0/custom", package = "echarts4r")
   dep <- htmltools::htmlDependency(
     name = "echarts-renderers",
-    version = "1.0.0",
+    version = "1.0.1",
     src = c(file = path),
     script = "renderers.js"
   )

inst/htmlwidgets/lib/echarts-4.8.0/custom/renderers.js

@@ -1,4 +1,5 @@
 // render error bars
+//   the original - works for non-grouped bars only
 function renderErrorBar(params, api) {
   var xValue = api.value(0);
   var highPoint = api.coord([xValue, api.value(1)]);
@@ -35,3 +36,93 @@ function renderErrorBar(params, api) {
       }]
   };
 }
+
+
+/*
+  added support for grouped bars, barGap and barCategoryGap by helgasoft.com
+	To test in R:
+  grps <- 5; rpt <- grps*2
+  df <- data.frame('Category' = c(rep(LETTERS[1:grps], each=rpt)),
+    'Xaxis' = rep(paste(rep(LETTERS[1:grps], each=2), 1:grps*2, sep='.'), grps*rpt/(grps*2)), 
+    'Yaxis' = 50 * abs(rnorm(grps*rpt))) %>%
+    mutate(Lower = Yaxis - 5 * runif(grps*rpt),
+           Upper = Yaxis + 5 * runif(grps*rpt))
+  df %>% group_by(Category) %>% 
+    e_charts(Xaxis) %>% 
+    e_bar(Yaxis) %>%  #, barGap ='22%', barCategoryGap='55%') %>%
+    e_error_bar(Lower, Upper) %>%
+    e_datazoom(start = 50)
+*/
+function renderErrorBar2(params, api) {
+  let oss = JSON.parse(sessionStorage.getItem('ErrorBar.oss'));
+  if (oss===null || !Object.keys(oss).length) return null;   // cant work without it
+
+  function findMax(xx) {  	
+  	// find max barGap or barCategoryGap
+  	// if caller is e_bar they are all the same, but could be different if caller is e_list
+  	let out = null;
+  	let tmp = oss.map(d => d[xx]).filter(d => d);
+  	if (tmp.length > 0) {
+  		tmp = Math.max(...tmp.map(d => Number(d[0].replace('%', ''))) ); 
+  		if (isFinite(tmp)) out = tmp + '%';
+  	}
+  	return out;
+  }
+
+  let xValue = api.value(0);
+  let highPoint = api.coord([xValue, api.value(1)]);
+  let lowPoint = api.coord([xValue, api.value(2)]);
+  let halfWidth = api.size([1, 0])[0] * 0.1;
+
+  let csil = api.currentSeriesIndices().length;		// always even
+  if (csil > 2) {
+  	let bgm = findMax('barGap');
+  	let bcgm = findMax('barCategoryGap');
+  	let olay = { count: csil/2 };
+  	olay.barGap = bgm!==null ? bgm : '30%';		// '30%' is default for e_bar
+  	olay.barCategoryGap = bcgm!==null ? bcgm : '20%';
+  	let barLayouts = api.barLayout(olay);
+
+	  let idx = params.seriesIndex - (params.seriesIndex<oss.length ? 0 : oss.length);	
+  	// idx is index of related main bar
+  	let mbar = 0;
+  	api.currentSeriesIndices().forEach( (item, index) => {
+  		if (item == idx) {
+  			highPoint[0] += barLayouts[mbar].offsetCenter;
+  			halfWidth = barLayouts[mbar].width /2;
+  		}
+  		mbar++;
+  	});
+  }
+  lowPoint[0] = highPoint[0];
+
+  var style = api.style({
+      stroke: api.visual('color'),
+      fill: null
+  });
+  return {
+      type: 'group',
+      children: [{
+          type: 'line',
+          shape: {
+              x1: highPoint[0] - halfWidth, y1: highPoint[1],
+              x2: highPoint[0] + halfWidth, y2: highPoint[1]
+          },
+          style: style
+      }, {
+          type: 'line',		// vertical
+          shape: {
+              x1: highPoint[0], y1: highPoint[1],
+              x2: lowPoint[0], y2: lowPoint[1]
+          },
+          style: style
+      }, {
+          type: 'line',
+          shape: {
+              x1: lowPoint[0] - halfWidth, y1: lowPoint[1],
+              x2: lowPoint[0] + halfWidth, y2: lowPoint[1]
+          },
+          style: style
+      }]
+  };
+}