From 9ea6a2de968b741913f8727c6c4e9757450ce9d4 Mon Sep 17 00:00:00 2001 From: helgasoft Date: Tue, 29 Dec 2020 16:46:46 -0800 Subject: [PATCH 1/4] improve e_error_bar, e_band2, e_band --- R/add.R | 19 +++- R/add_.R | 94 +++++++++---------- R/append.R | 25 +++-- R/mark.R | 12 ++- inst/htmlwidgets/echarts4r.js | 11 ++- .../lib/echarts-4.8.0/custom/renderers.js | 53 +++++++---- man/band2.Rd | 3 + man/e_mark_p.Rd | 13 ++- man/e_merge.Rd | 7 +- man/errorbar.Rd | 11 ++- tests/testthat/test-statistical.R | 8 +- 11 files changed, 155 insertions(+), 101 deletions(-) diff --git a/R/add.R b/R/add.R index e4b71716..932ba84e 100644 --- a/R/add.R +++ b/R/add.R @@ -3548,6 +3548,7 @@ e_band.echarts4rProxy <- function(e, min, max, stack = "confidence-band", symbol legend = legend, ... ) + return(e) } #' Correlation @@ -3635,10 +3636,17 @@ e_correlations.echarts4rProxy <- function(e, order = NULL, visual_map = TRUE, .. #' Add error bars. #' #' @inheritParams e_bar -#' @param lower,upper Lower and upper error bands. -#' @param renderer mame of render function from renderers.js +#' @param lower,upper Lower and upper error band points. +#' @param renderer name of render function, default 'riErrorBar' #' @param itemStyle mostly used for borderWidth, default 1.5 -#' +#' @param hwidth width of error bar in pixels, default 6 +#' +#' @details under echarts4rProxy, it needs a bar/line/scatter to attach to, like so: +#' echarts4rProxy('plot', data=df, x=date) %>% +#' e_line(open) %>% +#' e_error_bar(low, high, hwidth=10, color='red') %>% +#' e_execute() +#' #' @examples #' df <- data.frame( #' x = factor(c(1, 2)), @@ -3650,7 +3658,7 @@ e_correlations.echarts4rProxy <- function(e, order = NULL, visual_map = TRUE, .. #' df %>% #' e_charts(x) %>% #' e_bar(y) %>% -#' e_error_bar(lower, upper) +#' e_error_bar(lower, upper, color='blue') #' #' # timeline #' df <- data.frame( @@ -3666,6 +3674,7 @@ e_correlations.echarts4rProxy <- function(e, order = NULL, visual_map = TRUE, .. #' e_charts(x, timeline = TRUE) %>% #' e_bar(y) %>% #' e_error_bar(lower, upper) +#' #' @rdname errorbar #' @export e_error_bar <- function(e, lower, upper, name = NULL, legend = FALSE, y_index = 0, x_index = 0, @@ -3722,6 +3731,7 @@ e_error_bar.echarts4rProxy <- function(e, lower, upper, name = NULL, legend = FA #' @param itemStyle mostly used for borderWidth, default 0.5 #' @param ... additional options #' +#' @author helgasoft.com #' @examples #' data(EuStockMarkets) #' as.data.frame(EuStockMarkets) %>% dplyr::slice_head(n=200) %>% @@ -3773,4 +3783,5 @@ e_band2.echarts4rProxy <- function(e, lower, upper, ...) { deparse(substitute(upper)), ... ) + return(e) } diff --git a/R/add_.R b/R/add_.R index 7de8e0e8..55a9ad0f 100644 --- a/R/add_.R +++ b/R/add_.R @@ -2150,13 +2150,25 @@ e_band2_ <- function(e, lower, upper, name=NULL, legend=TRUE, stop("must pass lower, or upper", call. = FALSE) if (coord_system != "cartesian2d") stop("only cartesian2d supported", call. = FALSE) - - args <- list(...) + + opts <- function(name) { + list(name = name, type = "custom", yAxisIndex = y_index, + xAxisIndex = x_index, coordinateSystem = coord_system, + itemStyle = itemStyle, + renderItem = htmlwidgets::JS('riPolygon'), + encode = list(x = 0, y = list(1, 2)), ...) + } for (i in seq_along(e$x$data)) { - vector <- .build_data2(e$x$data[[i]], e$x$mapping$x, - lower, upper) - e_serie <- list(data = vector) + #vector <- .build_data2(e$x$data[[i]], e$x$mapping$x, lower, upper) + #e_serie <- list(data = vector) # obsolete version with separate lower/upper, changed below + l1 <- e$x$data[[i]] %>% dplyr::select(e$x$mapping$x, lower) + l2 <- e$x$data[[i]] %>% dplyr::select(e$x$mapping$x, upper) + l2 <- l2[order(nrow(l2):1),] # reverse + colnames(l2) <- colnames(l1) # needed for bind_rows + poly <- .build_data2(dplyr::bind_rows(list(l1), list(l2)), e$x$mapping$x, lower) + e_serie <- list(data = poly) # all points in single list + if (y_index != 0) e <- .set_y_axis(e, upper, y_index, i) if (x_index != 0) @@ -2166,37 +2178,23 @@ e_band2_ <- function(e, lower, upper, name=NULL, legend=TRUE, if (!e$x$tl) { - opts <- list(name = nm, type = "custom", yAxisIndex = y_index, - xAxisIndex = x_index, coordinateSystem = coord_system, - itemStyle = itemStyle, - renderItem = htmlwidgets::JS('renderBand'), - encode = list(x = 0, y = list(1, 2)), ...) + e_serie <- append(opts(nm), e_serie) # data is used for Y-sizing only, renderItem is used for plot - e_serie <- append(opts, e_serie) # data after renderItem, data used for Y-sizing only - - if (isTRUE(legend)) - e$x$opts$legend$data <- append(e$x$opts$legend$data, list(nm)) e$x$opts$series <- append(e$x$opts$series, list(e_serie)) } else { - if (isTRUE(legend)) - e$x$opts$legend$data <- append(e$x$opts$legend$data, - list(nm)) e$x$opts$options[[i]]$series <- append(e$x$opts$options[[i]]$series, list(e_serie)) } + if (isTRUE(legend)) + e$x$opts$legend$data <- append(e$x$opts$legend$data, list(nm)) } if (isTRUE(e$x$tl)) { - series_opts <- list(name = name, type = "custom", - yAxisIndex = y_index, xAxisIndex = x_index, coordinateSystem = coord_system, - itemStyle = itemStyle, - renderItem = htmlwidgets::JS('renderBand'), - encode = list(x = 0, y = list(1, 2)), ...) + e$x$opts$baseOption$series <- append(e$x$opts$baseOption$series, + list(opts(name))) if (isTRUE(legend)) e$x$opts$baseOption$legend$data <- append(e$x$opts$baseOption$legend$data, list(name)) - e$x$opts$baseOption$series <- append(e$x$opts$baseOption$series, - list(series_opts)) } path <- system.file("htmlwidgets/lib/echarts-4.8.0/custom", package = "echarts4r") dep <- htmltools::htmlDependency(name = "echarts-renderers", version = "1.0.2", src = c(file = path), script = "renderers.js") @@ -2211,7 +2209,7 @@ e_error_bar_ <- function (e, lower, upper, name = NULL, legend = FALSE, y_index = 0, x_index = 0, coord_system = "cartesian2d", itemStyle = list(borderWidth = 1.5), - renderer = 'renderErrorBar2', ...) + renderer = 'riErrorBar', hwidth = 6, ...) { if (missing(e)) stop("must pass e", call. = FALSE) @@ -2244,14 +2242,22 @@ e_error_bar_ <- function (e, lower, upper, if (info==0) return(e) # no bars/lines/scatter, nothing to attach to - # save minimal info to be read by renderErrorBar2 + # save minimal info to be read by the renderer # renderers.js works in a very isolated environment, so we send data thru sessionStorage # info is last barGap, last barCategoryGap, number of bars - info <- c(lbg, lcg, as.character(info)) + info <- c(lbg, lcg, as.character(info), hwidth) info <- paste0("sessionStorage.setItem('ErrorBar.oss','" ,jsonlite::toJSON(info),"'); ", renderer) renderJS <- htmlwidgets::JS(info) + optbase <- function(name) { + list(name = name, type = "custom", + yAxisIndex = y_index, xAxisIndex = x_index, + coordinateSystem = coord_system, + itemStyle = itemStyle, + renderItem = renderJS, + encode = list(x = 0, y = list(1, 2)), ...) + } for (i in seq_along(e$x$data)) { vector <- .build_data2(e$x$data[[i]], e$x$mapping$x, @@ -2262,53 +2268,41 @@ e_error_bar_ <- function (e, lower, upper, if (x_index != 0) e <- .set_x_axis(e, x_index, i) if (coord_system == "polar") { - e_serie$data <- e$x$data[[i]] %>% dplyr::select(lower, - upper) %>% unlist %>% unname %>% as.list + e_serie$data <- e$x$data[[i]] %>% dplyr::select(lower, upper) %>% + unlist %>% unname %>% as.list } nm <- .name_it(e, ser[[i]]$name, name, i) if (!e$x$tl) { - opts <- list(name = nm, type = "custom", - yAxisIndex = y_index, xAxisIndex = x_index, - coordinateSystem = coord_system, - itemStyle = itemStyle, - renderItem = renderJS, - encode = list(x = 0, y = list(1, 2)), ...) + opts <- optbase(nm) if (!("z" %in% names(args))) opts$z <- 3 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)) - e$x$opts$legend$data <- append(e$x$opts$legend$data, list(nm)) e$x$opts$series <- append(e$x$opts$series, list(e_serie)) } else { - if (isTRUE(legend)) - e$x$opts$legend$data <- append(e$x$opts$legend$data, list(nm)) e$x$opts$options[[i]]$series <- append(e$x$opts$options[[i]]$series, list(e_serie)) } + if (isTRUE(legend)) + e$x$opts$legend$data <- append(e$x$opts$legend$data, list(nm)) } if (isTRUE(e$x$tl)) { - series_opts <- list(type = "custom", - yAxisIndex = y_index, xAxisIndex = x_index, - coordinateSystem = coord_system, - itemStyle = itemStyle, - renderItem = renderJS, - encode = list(x = 0, y = list(1, 2)), ...) - if (!is.null(name)) series_opts$name <- name + series_opts <- optbase(name) + #if (!is.null(name)) series_opts$name <- name if (!("z" %in% names(args))) series_opts$z <- 3 if (!("color" %in% names(args))) series_opts$color <- 'black' # set, or it will blend with main bar - if (isTRUE(legend) && !is.null(name)) - e$x$opts$baseOption$legend$data <- append(e$x$opts$baseOption$legend$data, list(name)) e$x$opts$baseOption$series <- append(e$x$opts$baseOption$series, list(series_opts)) + if (isTRUE(legend) && !is.null(name)) + e$x$opts$baseOption$legend$data <- append(e$x$opts$baseOption$legend$data, list(name)) } path <- system.file("htmlwidgets/lib/echarts-4.8.0/custom", package = "echarts4r") - dep <- htmltools::htmlDependency(name = "echarts-renderers", version = "1.0.2", src = c(file = path), script = "renderers.js") - + dep <- htmltools::htmlDependency(name = "echarts-renderers", version = "1.0.2", src = c(file = path), script = "renderers.js") e$dependencies <- append(e$dependencies, list(dep)) + e %>% e_x_axis(type = 'category') # wont work with type 'value' } diff --git a/R/append.R b/R/append.R index a66cd7b9..b504aae9 100644 --- a/R/append.R +++ b/R/append.R @@ -205,11 +205,17 @@ e_execute <- function(proxy) { if (missing(proxy)) { stop("missing proxy", call. = FALSE) } - - proxy$session$sendCustomMessage( - "e_send_p", - list(id = proxy$id, opts = proxy$chart$x$opts) - ) + # proxy$session$sendCustomMessage("e_send_p", list(id = proxy$id, opts = proxy$chart$x$opts) ) # prev.version + + plist <- list(id = proxy$id, opts = proxy$chart$x$opts) + # create web dependencies for JS if present + if (!is.null(proxy$chart$dependencies)) { + deps <- list(shiny::createWebDependency( + htmltools::resolveDependencies( proxy$chart$dependencies )[[1]] + )) + plist$deps <- deps + } + proxy$session$sendCustomMessage('e_send_p', plist ) return(proxy) } @@ -217,18 +223,19 @@ e_execute <- function(proxy) { #' @export e_execute_p <- e_execute -#' Merge options in chart, used in e_mark +#' Merge options in chart, used in e_mark_p +#' @author helgasoft.com #' #' @inheritParams e_highlight_p #' #' @name e_merge #' @export e_merge <- function (proxy) { - if (missing(proxy)) stop("missing proxy", call. = FALSE) + if (missing(proxy)) stop("missing proxy", call. = FALSE) - proxy$session$sendCustomMessage("e_merge_p", + proxy$session$sendCustomMessage("e_merge_p", list(id = proxy$id, opts = proxy$chart$x$opts) ) - return(proxy) + return(proxy) } diff --git a/R/mark.R b/R/mark.R index 31bc0fb6..a2931fbe 100644 --- a/R/mark.R +++ b/R/mark.R @@ -198,18 +198,22 @@ e_mark_area <- function(e, serie = NULL, data = NULL, ..., title = NULL, title_p e } -#' Mark +#' Marks #' -#' Mark points, lines, and areas with a proxy ([echarts4rProxy()]). +#' Mark points, lines, and areas with Shiny proxy \code{\link{echarts4rProxy}}. #' #' @inheritParams e_bar #' @param type Type of mark: 'point','line' or 'area', defaults to 'point'. #' @param serie_index Single index of serie to mark on, defaults to 1. -#' Proxy doesn't know series' names, so it only uses index. +#' Proxy doesn't know serie's name, so only the index can be used. #' @param data Location of point, line or area, defaults to NULL. #' -#' @details Allows the three type of marks to work with [echarts4rProxy()] +#' @details Allows the three type of marks to work with \code{\link{echarts4rProxy}}. Should be followed by \code{\link{e_merge}} instead of \code{\link{e_execute}}. #' +#' @seealso \href{https://echarts.apache.org/en/option.html#series-line.markPoint}{Additional point arguments}, +#' \href{https://echarts.apache.org/en/option.html#series-line.markLine}{Additional line arguments}, +#' \href{https://echarts.apache.org/en/option.html#series-line.markArea}{Additional area arguments} +#' #' @examples #' library(shiny) #' library(dplyr) diff --git a/inst/htmlwidgets/echarts4r.js b/inst/htmlwidgets/echarts4r.js index 5fde40a3..6de5b0e8 100644 --- a/inst/htmlwidgets/echarts4r.js +++ b/inst/htmlwidgets/echarts4r.js @@ -363,12 +363,18 @@ if (HTMLWidgets.shinyMode) { var chart = get_e_charts(data.id); if (typeof chart != 'undefined') { let opts = chart.getOption(); + // add JS dependencies if any + if (data.deps) Shiny.renderDependencies(data.deps); // add series if(!opts.series) opts.series = []; data.opts.series.forEach(function(serie){ + // for some reason JS_EVAL does not survive passing thru echarts4rProxy + // below is a harmless remedy, works for e_band2 or others which use renderItem + if (typeof serie.renderItem == 'string') serie.renderItem = eval(serie.renderItem); + opts.series.push(serie); }) @@ -422,9 +428,12 @@ if (HTMLWidgets.shinyMode) { } }); + /* + called by e_merge(), add e_mark_p to serie + author: helgasoft.com + */ Shiny.addCustomMessageHandler('e_merge_p', function(data) { - // called by e_merge, add marks to serie var chart = get_e_charts(data.id); if (typeof chart != 'undefined') { chart.setOption(data.opts); diff --git a/inst/htmlwidgets/lib/echarts-4.8.0/custom/renderers.js b/inst/htmlwidgets/lib/echarts-4.8.0/custom/renderers.js index ab070107..3e09ce5c 100644 --- a/inst/htmlwidgets/lib/echarts-4.8.0/custom/renderers.js +++ b/inst/htmlwidgets/lib/echarts-4.8.0/custom/renderers.js @@ -1,4 +1,5 @@ -// render error bars and bands +// JS renderers for error bars, bands, etc. + // the original - works for non-grouped bars only function renderErrorBar(params, api) { var xValue = api.value(0); @@ -39,9 +40,22 @@ function renderErrorBar(params, api) { /* - added support for grouped bars, barGap and barCategoryGap by helgasoft.com + added ErrorBar support for grouped bars, barGap and barCategoryGap + author: helgasoft.com + Notes: + Prefix 'ri' stands for 'renderItem' function. + Error bars can have chart bars, lines and scatter points as "hosts". + It's convenient to "attach" error bars to their related chart bars + so they'll show/hide together when user clicks on a legend button. + This is done by having the same name for error and chart bars. + Default legend = FALSE, since we'll have only chart bars in legend. + Error bars will inherit color from their chart bar, blending with them. + Therefore it is preferable to set a different color, like so - + e_error_bar(..., color='blue'). Black is now set as default color. + To test in R: - grps <- 5; rpt <- grps*2 + grps <- 5 # customizable number of groups + 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))) %>% @@ -53,18 +67,19 @@ function renderErrorBar(params, api) { e_error_bar(Lower, Upper) %>% e_datazoom(start = 50) */ -function renderErrorBar2(params, api) { +function riErrorBar(params, api) { - // oss is [last.barGap, last.barCategoryGap, totSeries] + // input oss contains + // [last.barGap, last.barCategoryGap, series.count, ends.width] let oss = JSON.parse(sessionStorage.getItem('ErrorBar.oss')); - if (oss===null || !Object.keys(oss).length) return null; // cant work without it + if (oss===null || !Object.keys(oss).length) return null; // needs 4 input values let totSeries = Number(oss[2]); 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 endsWidth = Number(oss[3]); //api.size([1, 0])[0] * 0.1; let csil = api.currentSeriesIndices().length / 2; // idx is index of related main bar @@ -83,7 +98,7 @@ function renderErrorBar2(params, api) { api.currentSeriesIndices().some( (item, index) => { if (item == idx) { highPoint[0] += barLayouts[mbar].offsetCenter; - halfWidth = barLayouts[mbar].width /2; + // endsWidth = barLayouts[mbar].width /2; return true; } mbar++; @@ -102,8 +117,8 @@ function renderErrorBar2(params, api) { children: [{ type: 'line', shape: { - x1: highPoint[0] - halfWidth, y1: highPoint[1], - x2: highPoint[0] + halfWidth, y2: highPoint[1] + x1: highPoint[0] - endsWidth, y1: highPoint[1], + x2: highPoint[0] + endsWidth, y2: highPoint[1] }, style: style }, { @@ -116,17 +131,20 @@ function renderErrorBar2(params, api) { }, { type: 'line', shape: { - x1: lowPoint[0] - halfWidth, y1: lowPoint[1], - x2: lowPoint[0] + halfWidth, y2: lowPoint[1] + x1: lowPoint[0] - endsWidth, y1: lowPoint[1], + x2: lowPoint[0] + endsWidth, y2: lowPoint[1] }, style: style }] }; } - -// renderer for e_band2 -function renderBand(params, api) { +/* + renderItem function for Polygon + author: helgasoft.com + used also by e_band2 +*/ +function riPolygon(params, api) { if (params.context.rendered) return; params.context.rendered = true; @@ -134,12 +152,9 @@ function renderBand(params, api) { let points = []; let i = 0; while (typeof api.value(0,i) != 'undefined' && !isNaN(api.value(0,i))) { - points.push(api.coord([api.value(0,i), api.value(1,i)])); // lo + points.push(api.coord([api.value(0,i), api.value(1,i)])); i++; } - for (var k = i-1; k > -1 ; k--) { - points.push(api.coord([api.value(0,k), api.value(2,k)])); // up - } var color = api.visual('color'); return { diff --git a/man/band2.Rd b/man/band2.Rd index 3398a0ea..0f549ad0 100644 --- a/man/band2.Rd +++ b/man/band2.Rd @@ -56,3 +56,6 @@ as.data.frame(EuStockMarkets) \%>\% dplyr::slice_head(n=200) \%>\% e_datazoom(start = 50) } +\author{ +helgasoft.com +} diff --git a/man/e_mark_p.Rd b/man/e_mark_p.Rd index 4ffa590d..2f811ab9 100644 --- a/man/e_mark_p.Rd +++ b/man/e_mark_p.Rd @@ -3,7 +3,7 @@ \name{e_mark_p} \alias{e_mark_p} \alias{e_mark_p_} -\title{Mark} +\title{Marks} \usage{ e_mark_p(e, type, serie_index, data, ...) @@ -16,17 +16,17 @@ a proxy as returned by \code{\link{echarts4rProxy}}.} \item{type}{Type of mark: 'point','line' or 'area', defaults to 'point'.} \item{serie_index}{Single index of serie to mark on, defaults to 1. -Proxy doesn't know series' names, so it only uses index.} +Proxy doesn't know serie's name, so only the index can be used.} \item{data}{Location of point, line or area, defaults to NULL.} \item{...}{Any other option to pass, check See Also section.} } \description{ -Mark points, lines, and areas with a proxy ([echarts4rProxy()]). +Mark points, lines, and areas with Shiny proxy \code{\link{echarts4rProxy}}. } \details{ -Allows the three type of marks to work with [echarts4rProxy()] +Allows the three type of marks to work with \code{\link{echarts4rProxy}}. Should be followed by \code{\link{e_merge}} instead of \code{\link{e_execute}}. } \examples{ library(shiny) @@ -108,3 +108,8 @@ if (interactive()) shinyApp(ui, server) } +\seealso{ +\href{https://echarts.apache.org/en/option.html#series-line.markPoint}{Additional point arguments}, + \href{https://echarts.apache.org/en/option.html#series-line.markLine}{Additional line arguments}, + \href{https://echarts.apache.org/en/option.html#series-line.markArea}{Additional area arguments} +} diff --git a/man/e_merge.Rd b/man/e_merge.Rd index 91e262a3..8346bd68 100644 --- a/man/e_merge.Rd +++ b/man/e_merge.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/append.R \name{e_merge} \alias{e_merge} -\title{Merge options in chart, used in e_mark} +\title{Merge options in chart, used in e_mark_p} \usage{ e_merge(proxy) } @@ -10,5 +10,8 @@ e_merge(proxy) \item{proxy}{An echarts4r proxy as returned by \code{\link{echarts4rProxy}}.} } \description{ -Merge options in chart, used in e_mark +Merge options in chart, used in e_mark_p +} +\author{ +helgasoft.com } diff --git a/man/errorbar.Rd b/man/errorbar.Rd index f6e9d953..740f6fae 100644 --- a/man/errorbar.Rd +++ b/man/errorbar.Rd @@ -27,7 +27,8 @@ e_error_bar_( x_index = 0, coord_system = "cartesian2d", itemStyle = list(borderWidth = 1.5), - renderer = "renderErrorBar2", + renderer = "riErrorBar", + hwidth = 6, ... ) } @@ -35,7 +36,7 @@ e_error_bar_( \item{e}{An \code{echarts4r} object as returned by \code{\link{e_charts}} or a proxy as returned by \code{\link{echarts4rProxy}}.} -\item{lower, upper}{Lower and upper error bands.} +\item{lower, upper}{Lower and upper error band points.} \item{name}{name of the serie.} @@ -51,7 +52,9 @@ a proxy as returned by \code{\link{echarts4rProxy}}.} \item{itemStyle}{mostly used for borderWidth, default 1.5} -\item{renderer}{mame of render function from renderers.js} +\item{renderer}{name of render function, default 'riErrorBar'} + +\item{hwidth}{width of horizontal bar ends in pixels, default 6} } \description{ Add error bars. @@ -67,7 +70,7 @@ df <- data.frame( df \%>\% e_charts(x) \%>\% e_bar(y) \%>\% - e_error_bar(lower, upper) + e_error_bar(lower, upper, color='blue') # timeline df <- data.frame( diff --git a/tests/testthat/test-statistical.R b/tests/testthat/test-statistical.R index 62dcd46b..eb4cc1e6 100644 --- a/tests/testthat/test-statistical.R +++ b/tests/testthat/test-statistical.R @@ -49,11 +49,11 @@ test_that("e_band2 plot has good data structure and type", { expect_equal( plot$x$opts$series[[1]]$renderItem, - htmlwidgets::JS('renderBand') + htmlwidgets::JS('riPolygon') ) expect_equal( plot$x$opts$series[[1]]$data[[2]]$value, - c(2, 3, 4) + c(2, 3) ) }) @@ -87,7 +87,7 @@ test_that("e_correlations plot has the good data structure and type", { ) }) -test_that("e_error_bar plot has the good data structure and type", { +test_that("e_error_bar plot has good data structure and type", { df <- data.frame( x = factor(c(1, 2)), y = c(1, 5), @@ -116,7 +116,7 @@ test_that("e_error_bar plot has the good data structure and type", { ) expect_equal( plot$x$opts$series[[2]]$renderItem, - htmlwidgets::JS("sessionStorage.setItem('ErrorBar.oss','[\"\",\"\",\"1\"]'); renderErrorBar2") + htmlwidgets::JS("sessionStorage.setItem('ErrorBar.oss','[\"\",\"\",\"1\",\"6\"]'); riErrorBar") ) }) From 4419c3047f1b1a5f5c067b4e1b26bd494df2cab9 Mon Sep 17 00:00:00 2001 From: helgasoft Date: Wed, 30 Dec 2020 22:24:32 -0800 Subject: [PATCH 2/4] simplify and DRY --- NAMESPACE | 1 - R/append.R | 39 ++++++++++++++--------------------- R/mark.R | 4 ++-- inst/htmlwidgets/echarts4r.js | 6 ++++-- man/e_execute.Rd | 15 ++++++++++---- man/e_mark_p.Rd | 4 ++-- man/e_merge.Rd | 17 --------------- man/errorbar.Rd | 10 ++++++++- 8 files changed, 43 insertions(+), 53 deletions(-) delete mode 100644 man/e_merge.Rd diff --git a/NAMESPACE b/NAMESPACE index 56a8acd6..404e2cee 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -238,7 +238,6 @@ export(e_mark_line) export(e_mark_p) export(e_mark_p_) export(e_mark_point) -export(e_merge) export(e_modularity) export(e_off) export(e_on) diff --git a/R/append.R b/R/append.R index b504aae9..6dc1509c 100644 --- a/R/append.R +++ b/R/append.R @@ -193,29 +193,36 @@ e_remove_serie_p <- function(proxy, serie_name = NULL, serie_index = NULL) { #' @export e_remove_serie <- e_remove_serie_p -#' Send +#' Execute #' -#' Send new series to chart. +#' Executes a \code{\link{echarts4rProxy}} command #' #' @inheritParams e_highlight_p +#' @param cmd Name of command, default is 'e_send_p'. +#' +#' @details Currently two commands are supported. They are related to parameter notMerge of \href{https://echarts.apache.org/en/api.html#echartsInstance.setOption}{setOption}.\cr +#' 'e_send_p' is used to send new series to a chart (notMerge=true)\cr +#' 'e_merge_p' is used to add marks(\code{\link{e_mark_p}}) to a serie (notMerge=false)\cr #' #' @name e_execute #' @export -e_execute <- function(proxy) { - if (missing(proxy)) { +e_execute <- function(proxy, cmd='e_send_p') { + if (missing(proxy)) stop("missing proxy", call. = FALSE) - } - # proxy$session$sendCustomMessage("e_send_p", list(id = proxy$id, opts = proxy$chart$x$opts) ) # prev.version + if (!"echarts4rProxy" %in% class(proxy)) + stop("must pass echarts4rProxy object", call. = FALSE) plist <- list(id = proxy$id, opts = proxy$chart$x$opts) - # create web dependencies for JS if present + + # create web dependencies for JS, if present if (!is.null(proxy$chart$dependencies)) { deps <- list(shiny::createWebDependency( htmltools::resolveDependencies( proxy$chart$dependencies )[[1]] )) plist$deps <- deps } - proxy$session$sendCustomMessage('e_send_p', plist ) + + proxy$session$sendCustomMessage(cmd, plist ) return(proxy) } @@ -223,19 +230,3 @@ e_execute <- function(proxy) { #' @export e_execute_p <- e_execute -#' Merge options in chart, used in e_mark_p -#' @author helgasoft.com -#' -#' @inheritParams e_highlight_p -#' -#' @name e_merge -#' @export -e_merge <- function (proxy) { - if (missing(proxy)) stop("missing proxy", call. = FALSE) - - proxy$session$sendCustomMessage("e_merge_p", - list(id = proxy$id, opts = proxy$chart$x$opts) - ) - return(proxy) -} - diff --git a/R/mark.R b/R/mark.R index a2931fbe..37e47e74 100644 --- a/R/mark.R +++ b/R/mark.R @@ -208,7 +208,7 @@ e_mark_area <- function(e, serie = NULL, data = NULL, ..., title = NULL, title_p #' Proxy doesn't know serie's name, so only the index can be used. #' @param data Location of point, line or area, defaults to NULL. #' -#' @details Allows the three type of marks to work with \code{\link{echarts4rProxy}}. Should be followed by \code{\link{e_merge}} instead of \code{\link{e_execute}}. +#' @details Allows the three type of marks to work with \code{\link{echarts4rProxy}}. Should be followed by \code{\link{e_execute}}('e_merge_p'). #' #' @seealso \href{https://echarts.apache.org/en/option.html#series-line.markPoint}{Additional point arguments}, #' \href{https://echarts.apache.org/en/option.html#series-line.markLine}{Additional line arguments}, @@ -271,7 +271,7 @@ e_mark_area <- function(e, serie = NULL, data = NULL, ..., title = NULL, title_p #' itemStyle = list(color='lightblue'), #' label = list(formatter='X-area', position='middle') #' ) %>% -#' e_merge() +#' e_execute('e_merge_p') #' }) #' #' react <- eventReactive(input$tln, { diff --git a/inst/htmlwidgets/echarts4r.js b/inst/htmlwidgets/echarts4r.js index 6de5b0e8..71adf995 100644 --- a/inst/htmlwidgets/echarts4r.js +++ b/inst/htmlwidgets/echarts4r.js @@ -429,14 +429,16 @@ if (HTMLWidgets.shinyMode) { }); /* - called by e_merge(), add e_mark_p to serie + helps adding e_mark_p to serie author: helgasoft.com */ Shiny.addCustomMessageHandler('e_merge_p', function(data) { var chart = get_e_charts(data.id); if (typeof chart != 'undefined') { - chart.setOption(data.opts); + // add JS dependencies if any + if (data.deps) Shiny.renderDependencies(data.deps); + chart.setOption(data.opts); } }); diff --git a/man/e_execute.Rd b/man/e_execute.Rd index b4c14f17..66d8d8e3 100644 --- a/man/e_execute.Rd +++ b/man/e_execute.Rd @@ -3,15 +3,22 @@ \name{e_execute} \alias{e_execute} \alias{e_execute_p} -\title{Send} +\title{Execute} \usage{ -e_execute(proxy) +e_execute(proxy, cmd = "e_send_p") -e_execute_p(proxy) +e_execute_p(proxy, cmd = "e_send_p") } \arguments{ \item{proxy}{An echarts4r proxy as returned by \code{\link{echarts4rProxy}}.} + +\item{cmd}{Name of command, default is 'e_send_p'.} } \description{ -Send new series to chart. +Executes a \code{\link{echarts4rProxy}} command +} +\details{ +Currently two commands are supported. They are related to parameter notMerge of \href{https://echarts.apache.org/en/api.html#echartsInstance.setOption}{setOption}.\cr + 'e_send_p' is used to send new series to a chart (notMerge=true)\cr + 'e_merge_p' is used to add marks(\code{\link{e_mark_p}}) to a serie (notMerge=false)\cr } diff --git a/man/e_mark_p.Rd b/man/e_mark_p.Rd index 2f811ab9..84aedbc6 100644 --- a/man/e_mark_p.Rd +++ b/man/e_mark_p.Rd @@ -26,7 +26,7 @@ Proxy doesn't know serie's name, so only the index can be used.} Mark points, lines, and areas with Shiny proxy \code{\link{echarts4rProxy}}. } \details{ -Allows the three type of marks to work with \code{\link{echarts4rProxy}}. Should be followed by \code{\link{e_merge}} instead of \code{\link{e_execute}}. +Allows the three type of marks to work with \code{\link{echarts4rProxy}}. Should be followed by \code{\link{e_execute}}('e_merge_p'). } \examples{ library(shiny) @@ -85,7 +85,7 @@ server <- function(input, output) { itemStyle = list(color='lightblue'), label = list(formatter='X-area', position='middle') ) \%>\% - e_merge() + e_execute('e_merge_p') }) react <- eventReactive(input$tln, { diff --git a/man/e_merge.Rd b/man/e_merge.Rd deleted file mode 100644 index 8346bd68..00000000 --- a/man/e_merge.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/append.R -\name{e_merge} -\alias{e_merge} -\title{Merge options in chart, used in e_mark_p} -\usage{ -e_merge(proxy) -} -\arguments{ -\item{proxy}{An echarts4r proxy as returned by \code{\link{echarts4rProxy}}.} -} -\description{ -Merge options in chart, used in e_mark_p -} -\author{ -helgasoft.com -} diff --git a/man/errorbar.Rd b/man/errorbar.Rd index 740f6fae..ee83faf7 100644 --- a/man/errorbar.Rd +++ b/man/errorbar.Rd @@ -54,11 +54,18 @@ a proxy as returned by \code{\link{echarts4rProxy}}.} \item{renderer}{name of render function, default 'riErrorBar'} -\item{hwidth}{width of horizontal bar ends in pixels, default 6} +\item{hwidth}{width of error bar in pixels, default 6} } \description{ Add error bars. } +\details{ +under echarts4rProxy, it needs a bar/line/scatter to attach to, like so: + echarts4rProxy('plot', data=df, x=date) %>% + e_line(open) %>% + e_error_bar(low, high, hwidth=10, color='red') %>% + e_execute() +} \examples{ df <- data.frame( x = factor(c(1, 2)), @@ -86,4 +93,5 @@ df \%>\% e_charts(x, timeline = TRUE) \%>\% e_bar(y) \%>\% e_error_bar(lower, upper) + } From 0812484d48c62358598e6b469c961960b4f7e885 Mon Sep 17 00:00:00 2001 From: helgasoft Date: Thu, 31 Dec 2020 10:54:33 -0800 Subject: [PATCH 3/4] added e_replace_p with example --- R/add.R | 4 +-- R/append.R | 53 +++++++++++++++++++++++++++++++--- inst/htmlwidgets/echarts4r.js | 18 ++++++++++-- man/e_execute.Rd | 54 ++++++++++++++++++++++++++++++++--- man/errorbar.Rd | 4 +-- 5 files changed, 119 insertions(+), 14 deletions(-) diff --git a/R/add.R b/R/add.R index 932ba84e..3a6f2a6e 100644 --- a/R/add.R +++ b/R/add.R @@ -3637,9 +3637,9 @@ e_correlations.echarts4rProxy <- function(e, order = NULL, visual_map = TRUE, .. #' #' @inheritParams e_bar #' @param lower,upper Lower and upper error band points. -#' @param renderer name of render function, default 'riErrorBar' +#' @param renderer name of render function, default \emph{riErrorBar} #' @param itemStyle mostly used for borderWidth, default 1.5 -#' @param hwidth width of error bar in pixels, default 6 +#' @param hwidth half width of error bar in pixels, default 6 #' #' @details under echarts4rProxy, it needs a bar/line/scatter to attach to, like so: #' echarts4rProxy('plot', data=df, x=date) %>% diff --git a/R/append.R b/R/append.R index 6dc1509c..5cd4f3b9 100644 --- a/R/append.R +++ b/R/append.R @@ -198,12 +198,57 @@ e_remove_serie <- e_remove_serie_p #' Executes a \code{\link{echarts4rProxy}} command #' #' @inheritParams e_highlight_p -#' @param cmd Name of command, default is 'e_send_p'. +#' @param cmd Name of command, default is \emph{e_send_p}. #' -#' @details Currently two commands are supported. They are related to parameter notMerge of \href{https://echarts.apache.org/en/api.html#echartsInstance.setOption}{setOption}.\cr -#' 'e_send_p' is used to send new series to a chart (notMerge=true)\cr -#' 'e_merge_p' is used to add marks(\code{\link{e_mark_p}}) to a serie (notMerge=false)\cr +#' @details Currently three commands are supported. They are related to parameter notMerge of \href{https://echarts.apache.org/en/api.html#echartsInstance.setOption}{setOption}.\cr +#' \emph{e_send_p} - to send new series to a chart (notMerge=true)\cr +#' \emph{e_merge_p} - to add marks(\code{\link{e_mark_p}}) to a serie (notMerge=false)\cr +#' \emph{e_replace_p} - to replace all options (notMerge=true)\cr #' +#' @examples +#' library(shiny) +#' +#' ui <- fluidPage( +#' actionButton("pxy", "Proxy"), +#' echarts4rOutput("plot") +#' ) +#' server <- function(input, output) { +#' data(EuStockMarkets) +#' df <- as.data.frame(EuStockMarkets) %>% +#' dplyr::slice_head(n=50) %>% dplyr::mutate(day=1:dplyr::n()) +#' hsp <- NULL # store plot as global +#' +#' output$plot <- renderEcharts4r({ +#' hsp <<- df %>% e_charts(day) %>% +#' e_y_axis(scale=TRUE) %>% +#' e_line(CAC) +#' hsp %>% e_datazoom(start=50) +#' }) +#' +#' observeEvent(input$pxy, { +#' chart <- hsp %>% +#' e_grid(height = "33%", top = "50%") %>% +#' e_grid(height = "32%") %>% +#' e_bar(SMI, x_index=1, y_index=1, color="green") %>% +#' e_y_axis(gridIndex = 1, scale=TRUE) %>% +#' e_x_axis(gridIndex = 1) %>% +#' e_tooltip(trigger='axis') %>% +#' e_axis_pointer(link=list(xAxisIndex='all')) %>% +#' e_datazoom(start=50, xAxisIndex=c(0,1)) +#' # fine tuning +#' chart$x$opts$yAxis[[1]]$show <- NULL +#' chart$x$opts$xAxis[[1]]$show <- FALSE +#' chart$x$opts$yAxis[[2]]$scale <- TRUE +#' +#' proxy <- list(id = 'plot', session = shiny::getDefaultReactiveDomain(), +#' chart = chart) +#' class(proxy) <- "echarts4rProxy" +#' proxy %>% e_execute('e_replace_p') +#' }) +#' } +#' if (interactive()) +#' shinyApp(ui, server) +#' #' @name e_execute #' @export e_execute <- function(proxy, cmd='e_send_p') { diff --git a/inst/htmlwidgets/echarts4r.js b/inst/htmlwidgets/echarts4r.js index 71adf995..0f778230 100644 --- a/inst/htmlwidgets/echarts4r.js +++ b/inst/htmlwidgets/echarts4r.js @@ -429,8 +429,8 @@ if (HTMLWidgets.shinyMode) { }); /* - helps adding e_mark_p to serie - author: helgasoft.com + Helps adding e_mark_p to serie + author: helgasoft.com */ Shiny.addCustomMessageHandler('e_merge_p', function(data) { @@ -441,5 +441,19 @@ if (HTMLWidgets.shinyMode) { chart.setOption(data.opts); } }); + + /* + Replace all options + author: helgasoft.com + */ + Shiny.addCustomMessageHandler('e_replace_p', + function(data) { + var chart = get_e_charts(data.id); + if (typeof chart != 'undefined') { + // add JS dependencies if any + if (data.deps) Shiny.renderDependencies(data.deps); + chart.setOption(data.opts, true); + } + }); } diff --git a/man/e_execute.Rd b/man/e_execute.Rd index 66d8d8e3..1f005d04 100644 --- a/man/e_execute.Rd +++ b/man/e_execute.Rd @@ -12,13 +12,59 @@ e_execute_p(proxy, cmd = "e_send_p") \arguments{ \item{proxy}{An echarts4r proxy as returned by \code{\link{echarts4rProxy}}.} -\item{cmd}{Name of command, default is 'e_send_p'.} +\item{cmd}{Name of command, default is \emph{e_send_p}.} } \description{ Executes a \code{\link{echarts4rProxy}} command } \details{ -Currently two commands are supported. They are related to parameter notMerge of \href{https://echarts.apache.org/en/api.html#echartsInstance.setOption}{setOption}.\cr - 'e_send_p' is used to send new series to a chart (notMerge=true)\cr - 'e_merge_p' is used to add marks(\code{\link{e_mark_p}}) to a serie (notMerge=false)\cr +Currently three commands are supported. They are related to parameter notMerge of \href{https://echarts.apache.org/en/api.html#echartsInstance.setOption}{setOption}.\cr + \emph{e_send_p} - to send new series to a chart (notMerge=true)\cr + \emph{e_merge_p} - to add marks(\code{\link{e_mark_p}}) to a serie (notMerge=false)\cr + \emph{e_replace_p} - to replace all options (notMerge=true)\cr +} +\examples{ +library(shiny) + +ui <- fluidPage( + actionButton("pxy", "Proxy"), + echarts4rOutput("plot") +) +server <- function(input, output) { + data(EuStockMarkets) + df <- as.data.frame(EuStockMarkets) \%>\% + dplyr::slice_head(n=50) \%>\% dplyr::mutate(day=1:dplyr::n()) + hsp <- NULL # store plot as global + + output$plot <- renderEcharts4r({ + hsp <<- df \%>\% e_charts(day) \%>\% + e_y_axis(scale=TRUE) \%>\% + e_line(CAC) + hsp \%>\% e_datazoom(start=50) + }) + + observeEvent(input$pxy, { + chart <- hsp \%>\% + e_grid(height = "33\%", top = "50\%") \%>\% + e_grid(height = "32\%") \%>\% + e_bar(SMI, x_index=1, y_index=1, color="green") \%>\% + e_y_axis(gridIndex = 1, scale=TRUE) \%>\% + e_x_axis(gridIndex = 1) \%>\% + e_tooltip(trigger='axis') \%>\% + e_axis_pointer(link=list(xAxisIndex='all')) \%>\% + e_datazoom(start=50, xAxisIndex=c(0,1)) + # fine tuning + chart$x$opts$yAxis[[1]]$show <- NULL + chart$x$opts$xAxis[[1]]$show <- FALSE + chart$x$opts$yAxis[[2]]$scale <- TRUE + + proxy <- list(id = 'plot', session = shiny::getDefaultReactiveDomain(), + chart = chart) + class(proxy) <- "echarts4rProxy" + proxy \%>\% e_execute('e_replace_p') + }) +} +if (interactive()) + shinyApp(ui, server) + } diff --git a/man/errorbar.Rd b/man/errorbar.Rd index ee83faf7..1ed532b5 100644 --- a/man/errorbar.Rd +++ b/man/errorbar.Rd @@ -52,9 +52,9 @@ a proxy as returned by \code{\link{echarts4rProxy}}.} \item{itemStyle}{mostly used for borderWidth, default 1.5} -\item{renderer}{name of render function, default 'riErrorBar'} +\item{renderer}{name of render function, default \emph{riErrorBar}} -\item{hwidth}{width of error bar in pixels, default 6} +\item{hwidth}{half width of error bar in pixels, default 6} } \description{ Add error bars. From 5aa71fed02139ced396205958dd124affbc64620 Mon Sep 17 00:00:00 2001 From: helgasoft Date: Tue, 5 Jan 2021 22:18:21 -0800 Subject: [PATCH 4/4] e_mark_p fixed for multiple points --- R/mark.R | 28 +++++++++++++++++----------- man/e_mark_p.Rd | 7 ++++--- 2 files changed, 21 insertions(+), 14 deletions(-) diff --git a/R/mark.R b/R/mark.R index 37e47e74..961432b5 100644 --- a/R/mark.R +++ b/R/mark.R @@ -247,10 +247,11 @@ e_mark_area <- function(e, serie = NULL, data = NULL, ..., title = NULL, title_p #' data = list(type='average'), #' lineStyle = list(type='dashed', color='cyan') #' ) %>% -#' e_mark_p( +#' e_mark_p( # type='point' by default #' serie_index=2, -#' data = list(xAxis=bb$day[60], -#' yAxis=bb$SMI[60], value='pnt') +#' data = list( +#' list(xAxis=bb$day[60], yAxis=bb$SMI[60], value='pnt'), +#' list(coord=c(80, bb$SMI[80]), value='80') ) #' ) %>% #' e_mark_p( #' type='line', @@ -317,6 +318,7 @@ e_mark_p.echarts4rProxy <- function(e, type='point', serie_index=NULL, data=NULL e_mark_p_ <- function(e, type, serie_index, data=NULL, ...) { if (missing(e)) stop("must pass e", call. = FALSE) if (missing(type)) stop("must pass type", call. = FALSE) + if (is.null(data)) stop("must provide data for marks", call. = FALSE) mtype <- type if (!startsWith(mtype, 'mark')) mtype <- switch(type, 'point'='markPoint', 'line'='markLine', 'area'='markArea') @@ -325,24 +327,28 @@ e_mark_p_ <- function(e, type, serie_index, data=NULL, ...) { index <- ifelse(is.null(serie_index), 1, as.numeric(serie_index)) for (i in 1:index) { - if (length(e$x$opts$series) < i) - e$x$opts$series[[i]] <- list() # init - if (i\% - e_mark_p( + e_mark_p( # type='point' by default serie_index=2, - data = list(xAxis=bb$day[60], - yAxis=bb$SMI[60], value='pnt') + data = list( + list(xAxis=bb$day[60], yAxis=bb$SMI[60], value='pnt'), + list(coord=c(80, bb$SMI[80]), value='80') ) ) \%>\% e_mark_p( type='line',