-
-
Save helgasoft/d8f8f24198874ed5a132cd9744972683 to your computer and use it in GitHub Desktop.
library(dplyr) | |
library(lubridate) | |
# add event for clicking on blank area | |
jscode <- c('','',"chart.getZr().on('click', function(e) { | |
if (!e.target) alert('blank area: '+JSON.stringify(e.event)); });") | |
set.seed(421) | |
df1 <- tibble(date= as_date("2021-11-01") + months(0:11), | |
x= 12*10^6 + rnorm(12,0,2000000), | |
y= 12*10^6 + rnorm(12,0,1000000)) | |
library(echarty) | |
p <- df1 %>% ec.init(js= jscode) | |
p$x$opts$yAxis <- list(axisLabel= list(formatter=ec.clmn('%@M', -1, scale=0.000001))) | |
p$x$opts$series <- list( | |
list(type='line', name='lx', encode=list(y='x'), areaStyle=list(opacity=0.2,color="blue"), itemStyle=list(color='blue')), | |
list(type='line', name='ly', encode=list(y='y'), areaStyle=list(opacity=0.2,color="red"), itemStyle=list(color='red'))) | |
p$x$opts$legend <- list(show=TRUE) | |
p$x$on <- list( # event(s) with Javascript handler | |
list(event= 'legendselectchanged', | |
handler= htmlwidgets::JS("(evt) => alert('selected: '+evt.name);")) | |
) | |
p |
Thanks a lot! This is a solution but I was looking for a solution within echarts4r
package. Perhaps I can find a workaround. Aha echarty
is also a new package for echarts, I didn't know! I will check that also.
Code updated to address two ways of event handling. Blank area click query by @astro-nomad, @troyjcross
If you like this solution, please consider granting a Github star ⭐ to echarty.
another example of event handling, inquiry by @yogat3ch
library(shiny); library(echarty)
jsfn <- "() => {
chart = get_e_charts('pchart');
serie = chart.getModel().getSeries()[0];
indices = serie.getRawIndicesByActiveState('active');
Shiny.setInputValue('axisbrush', indices);
};"
ui <- fluidPage( ecs.output('pchart'))
server <- function(input, output) {
ids <- c() # keep track of highlighted lines
output$pchart <- ecs.render({
p <- mtcars |> ec.init(ctype= 'parallel') |> ec.theme('dark-mushroom')
p$x$opts$series[[1]]$emphasis <- list(disabled= FALSE,
lineStyle= list(opacity= 1, width= 3)) # ,color= 'green'
p$x$opts$visualMap <- list(type= 'continuous', calculable= TRUE,
inRange= list(color= c('deepskyblue','pink','red')),
min= min(mtcars$mpg), max= max(mtcars$mpg),
dimension= 0 # mpg is first column, index 0 in JS
)
p$x$on <- list(list(event= 'axisareaselected',
handler= htmlwidgets::JS(jsfn) ))
p
})
observeEvent(input$axisbrush, {
print(input$axisbrush)
})
observeEvent(input$pchart_click, { # echarty built-in event
id <- input$pchart_click$dataIndex
p <- ecs.proxy('pchart')
if (id %in% ids) {
p$x$opts <- list(type= 'downplay', dataIndex= id)
ids <<- ids[! ids==id ]
} else {
p$x$opts <- list(type= 'highlight', dataIndex= id)
ids <<- c(ids, id)
}
p |> ecs.exec('p_dispatch')
})
}
shinyApp(ui= ui, server= server)
If you like this solution, please consider granting a Github star ⭐ to echarty.
Attn. @yogat3ch
Code above updated with hover highlight/downplay + click event: first to set highlight, second - to downplay back to normal.
See also gallery code
If you like this solution, please consider granting a Github star ⭐ to echarty.
Well @helgasoft,
You've certainly outdone yourself with this one!
This nails all the functionality we want to have in this parallel plot - thank you for whipping this up for us 🙏
I just transitioned all the code in this module to echarty
with surprising ease - thanks for you work on this!
Hi @helgasoft,
I'm trying to update the visualMap properties so the dimension can be changed for the visualMap. I created some helper functions for doing so, but it doesn't seem to want to update.
I'm not sure I understand how the proxy objects options are formatted, but it may be something else?
library(shiny); library(echarty)
ec.visualMap <- function(ec,
.data,
type = 'continuous',
calculable = TRUE,
inRange = list(color = c('deepskyblue', 'pink', 'pink', 'red')),
min = NULL,
max = NULL,
dimension = 1,
top = "middle",
textGap = 5,
padding = 2,
itemHeight = 390,
...) {
if (ncol(.data)) {
.dimension <- ec.col_locate(dimension, .data)
.min <- min %||% min(.data[[.dimension]], na.rm = TRUE)
.max <- max %||% max(.data[[.dimension]], na.rm = TRUE)
mods <- list(
type = type,
calculable = calculable,
inRange = inRange,
min = .min,
max = .max,
dimension = ec.dim(.dimension, .data),
top = top,
textGap = textGap,
padding = padding,
itemHeight = itemHeight,
...
) |>
purrr::compact()
ec$x$opts <- list(visualMap = mods)
}
return(ec)
}
`%||%` <- rlang::`%||%`
#' Convert R data dimension into JS dimension
#'
#' @param dim \code{chr/dbl} Column name or index
#' @param ec \code{echarty}
#'
#' @return \code{dbl}
#' @export
ec.dim <- function(dim, ec) {
UseMethod("ec.dim")
}
ec.data_extract <- function(ec) {
ec$x$opts$dataset[[1]]$source[-1] |>
purrr::map(unlist) |>
as.data.frame.list() |>
t() |>
as.data.frame() |>
tibble::remove_rownames() |>
rlang::set_names(ec$x$opts$dataset[[1]]$source[[1]])
}
ec.col_locate <- function(x, .data) {
which(names(.data) == x)
}
#' @export
ec.dim.character <- function(x, ec) {
ec.col_locate(x, ec) - 1
}
#' @export
ec.dim.numeric <- function(x, ec) {
x - 1
}
#' @export
ec.dim.default <- function(x, ec) {
x
}
jsfn <- "() => {
chart = get_e_charts('pchart');
serie = chart.getModel().getSeries()[0];
indices = serie.getRawIndicesByActiveState('active');
Shiny.setInputValue('axisbrush', indices);
};"
ui <- fluidPage( ecs.output('pchart'),
selectizeInput(inputId = "colormap",
label = "Map color to ",
choices = names(mtcars),
selected = names(mtcars)[1]
))
server <- function(input, output) {
ids <- c() # keep track of highlighted lines
output$pchart <- ecs.render({
p <- mtcars |> ec.init(ctype= 'parallel') |> ec.theme('dark-mushroom')
p$x$opts$series[[1]]$emphasis <- list(disabled= FALSE,
lineStyle= list(opacity= 1, width= 3)) # ,color= 'green'
p$x$opts$visualMap <- list(type= 'continuous', calculable= TRUE,
inRange= list(color= c('deepskyblue','pink','red')),
min= min(mtcars$mpg), max= max(mtcars$mpg),
dimension= 0 # mpg is first column, index 0 in JS
)
p$x$on <- list(list(event= 'axisareaselected',
handler= htmlwidgets::JS(jsfn) ))
p
})
observeEvent(input$axisbrush, {
print(input$axisbrush)
})
observeEvent(input$pchart_click, { # echarty built-in event
id <- input$pchart_click$dataIndex
p <- ecs.proxy('pchart')
if (id %in% ids) {
p$x$opts <- list(type= 'downplay', dataIndex= id)
ids <<- ids[! ids==id ]
} else {
p$x$opts <- list(type= 'highlight', dataIndex= id)
ids <<- c(ids, id)
}
p |> ecs.exec('p_dispatch')
})
observeEvent(input$colormap, {
echarty::ecs.proxy("pchart") |>
ec.visualMap(dimension = input$colormap, .data =mtcars) |>
echarty::ecs.exec("p_dispatch")
}, ignoreInit = TRUE)
}
shinyApp(ui= ui, server= server)
Thank you for trusting our code. Glad to see you are taking it further.
For documentation purposes, please copy your question in Issues.
There is a solution and will be given there.
@berkorbay, the above code will work for you I guess