Skip to content

Commit

Permalink
Merge 5aa71fe into f534dcf
Browse files Browse the repository at this point in the history
  • Loading branch information
@helgasoft
helgasoft committed Jan 6, 2021
2 parents f534dcf + 5aa71fe commit 4b1ee2e
Show file tree
Hide file tree
Showing 13 changed files with 306 additions and 150 deletions.
1 change: 0 additions & 1 deletion NAMESPACE
View file
Expand Up @@ -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)
Expand Down
19 changes: 15 additions & 4 deletions R/add.R
View file
Expand Up @@ -3548,6 +3548,7 @@ e_band.echarts4rProxy <- function(e, min, max, stack = "confidence-band", symbol
legend = legend,
...
)
return(e)
}

#' Correlation
Expand Down Expand Up @@ -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 \emph{riErrorBar}
#' @param itemStyle mostly used for borderWidth, default 1.5
#'
#' @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) %>%
#' e_line(open) %>%
#' e_error_bar(low, high, hwidth=10, color='red') %>%
#' e_execute()
#'
#' @examples
#' df <- data.frame(
#' x = factor(c(1, 2)),
Expand All @@ -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(
Expand All @@ -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,
Expand Down Expand Up @@ -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) %>%
Expand Down Expand Up @@ -3773,4 +3783,5 @@ e_band2.echarts4rProxy <- function(e, lower, upper, ...) {
deparse(substitute(upper)),
...
)
return(e)
}
94 changes: 44 additions & 50 deletions R/add_.R
View file
Expand Up @@ -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)
Expand All @@ -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")
Expand All @@ -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)
Expand Down Expand Up @@ -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,
Expand All @@ -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'
}
91 changes: 67 additions & 24 deletions R/append.R
View file
Expand Up @@ -193,42 +193,85 @@ 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 \emph{e_send_p}.
#'
#' @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) {
if (missing(proxy)) {
e_execute <- function(proxy, cmd='e_send_p') {
if (missing(proxy))
stop("missing proxy", call. = FALSE)
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
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",
list(id = proxy$id, opts = proxy$chart$x$opts)
)

proxy$session$sendCustomMessage(cmd, plist )
return(proxy)
}

#' @rdname e_execute
#' @export
e_execute_p <- e_execute

#' Merge options in chart, used in e_mark
#'
#' @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)
}

0 comments on commit 4b1ee2e

Please sign in to comment.