helgasoft
commented
1 year ago Here is the solution
library(echarty)
set.seed(222)
cns <- data.frame(
name = c('United States','China','Russia','Canada','Australia','Brazil'),
visualMap = c(T,T,T,T,F,F),
value = runif(6, 1, 100) # last column = default for visualMap
)
# with series.data
ec.init(load= 'world',
color= c('violet','green'),
series= list(list(
type='map', geoIndex=0, colorBy= 'data',
data= ec.data(cns, 'names'))),
visualMap= list(calculable=TRUE, max=100)
)
# with dataset in "array of classes" format
ec.init(load= 'world',
# color= default palette
dataset= list(
dimensions= colnames(cns), source= ec.data(cns, 'names')),
series= list(list(
type='map', geoIndex=0, colorBy= 'data')),
visualMap= list(calculable=TRUE, max=100)
)
yogat3ch
Hi @helgasoft, Hoping you have a tip for how to handle this situation where we want to have specific series elements use their default color and not the visualMap color. It appears possible based on these extraordinarily vague comments in the example under the Configure Mapping heading in the visualMap options
This stackoverflow shows a similar situation and how to apply
visualMap: falseto thedataobject in eachseriesobject to mute the visualMap.However, in the old parallel example below the series objects refer to the
Setting an empty
datasetIndexinstead of thedatadirectly.dataobject with justvisualMap = FALSEoverrides thedatasetIndexas the data source and produces a chart with no series.Any guidance on how to turn off visualMap for specific indices where the
datasetIndexis used instead ofdata? I've added abrowserstatement to the reprex at the location where it most makes sense to see the echart and apply this modification.With appreciation for any assistance you are able to offer
Parallel Reprex
```r 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$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 } devtools::load_all() jsfn <- "() => { chart = get_e_charts('chart'); serie = chart.getModel().getSeries()[0]; indices = serie.getRawIndicesByActiveState('active'); Shiny.setInputValue('axisbrush', indices); };" ui <- fluidPage( ecs.output('chart'), DT::DTOutput('highlighted'), selectizeInput(inputId = "colormap", label = "Map color to ", choices = names(mtcars), selected = names(mtcars)[1] ), fluidRow(id = "alerts")) server <- function(input, output) { key <- NULL isolate({ .data <- mtcars |> head(8) |> tibble::rownames_to_column("ID") |> # tibble::remove_rownames() |> # does not affect layout dplyr::relocate(ID, .after = dplyr::last_col()) |> # move grouping column last dplyr::group_by(ID) key <- .data$ID # ct <- crosstalk::SharedData$new(reactiveVal(.data), key = "ID") # t_data <- crosstalk::SharedData$new(reactiveVal(.data), key = "ID") ct <- CT_data() t_data <- CT_data() }) ids <- c() # keep track of highlighted lines output$chart <- ecs.render({ ct$data_group() p <- ct |> echarty::ec.init(ctype = "parallel") |> ec.theme('dark-mushroom') 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) )) s_order <- purrr::map_chr(p$x$opts$series, ~purrr::pluck(.x, "name")) .color = RColorBrewer::brewer.pal(length(s_order), "Set3") p$x$opts$color = .color p$x$opts$series <- purrr::map( p$x$opts$series, ~purrr::list_modify(.x, !!!rlang::list2(emphasis = list( disabled = FALSE, lineStyle = list(opacity = 1, width = 3, visualMap = FALSE) ))) ) p$x$opts$legend <- purrr::list_modify(p$x$opts$legend, !!!list( type = "scroll", orient = "horizontal", bottom = 0, top = NULL, icon = "pin", itemGap = 5, imageWidth = 10, imageHeight = 10 )) browser() # This produces an empty plot # p$x$opts$series <- purrr::imap(p$x$opts$series, \(.x,.y) { # purrr::list_modify(.x, data = list(visualMap = FALSE)) # }) p }) # Renders the DT with individually clicked rows from parallel plot highlighted with color output$highlighted <- DT::renderDT({ req(t_data) # .data <- t_data$full_data() # .rows <- 1:nrow(.data) # .colors <- t_data$tracking_cols()$source_col # if (shiny::isTruthy(highlighted())) { # browser() # # l <- length(highlighted()) # .colors <- grDevices::colorRampPalette(do.call(c, color_theme[paste0("scenario_", 1:2)]))(l) # .rows <- 1:l # .data <- .data[c(highlighted() + 1, setdiff(1:nrow(.data), highlighted() + 1)), ] # } dt <- DT::datatable( t_data, selection = list(mode = "multiple", target = "row"), #style = "bootstrap4", filter = list(position = "top"), escape = FALSE, callback = DT::JS(c( "table.on('draw.dt', function(e, datatable){", glue::glue("Shiny.setInputValue('highlighted' + '_page', table.page() + 1);"), "});" # UU::glue_js("if (table.page() != *{(input$policy_chooser_page %||% 1) - 1}*) {"), # paste0('setTimeout(function() {table.page(', (input$policy_chooser_page %||% 1) - 1,').draw(false);}, 100);'), # "};" )), extensions = "KeyTable", options = list( keys = TRUE, search = list(regex = TRUE), columnDefs = list( list(orderSequence = c("desc", "asc"), targets = "_all"), list(className = "dt-center", targets = "_all") ), processing = FALSE, pageLength = 10, lengthMenu = list(c(5, 10, 25, 50, -1), c("5", "10", "25", "50", "All")) ) ) dt }, server = FALSE) observeEvent(input$axisbrush, { print(input$axisbrush) }) history <- shinyVirga::rv( chart = NULL, table = NULL ) dispatch_action <- reactiveVal() observeEvent(input$chart_click, { .s <- input$chart_click$seriesName if (.s %in% history$chart) { dispatch_action(list(type= 'downplay', seriesName = .s)) history$chart <- setdiff(history$chart, .s) } else { dispatch_action(list(type= 'highlight', seriesName = .s)) history$chart <- c(history$chart, .s) } DT::dataTableProxy("highlighted") |> DT::selectRows(which(key %in% history$chart)) history$table <- intersect(key, history$chart) #virgaUtils::dbg_msg("chart_click: {.val {paste0(history$table, collapse = ',')}}") }, priority = 1) observeEvent(sum(t_data$selection()), { .selected <- key[t_data$selection()] if (length(.selected) < length(history$chart)) { now_selected <- setdiff(history$chart, .selected) dispatch_action(list(type = "downplay", seriesName = now_selected)) history$chart <- intersect(history$chart, .selected) } else if (length(.selected) > length(history$chart)) { dispatch_action(list(type = "highlight", seriesName = setdiff(.selected, history$chart))) history$table <- history$chart <- intersect(.selected, history$chart) } #virgaUtils::dbg_msg("table_click: {.val {paste0(history$table, collapse = ',')}}") # if the table is clicked, }, priority = 1) observeEvent(dispatch_action(), { # echarty built-in event #virgaUtils::dbg_msg("dispatch_action: {.val {dispatch_action()}}") # i <- which(t_data$data()[[key]] %in% highlighted()) # # Select the corresponding row in the table # DT::dataTableProxy("highlighted") |> # DT::selectRows(i) # # Update the selection in the table data crosstalk object # t_data$selection(i) p <- echarty::ecs.proxy('chart') p$x$opts <- dispatch_action() p |> echarty::ecs.exec('p_dispatch') }) observeEvent(input$colormap, { echarty::ecs.proxy("chart") |> ec.visualMap(dimension = input$colormap, .data = mtcars) |> echarty::ecs.exec("p_dispatch") }, ignoreInit = TRUE) } shinyApp(ui= ui, server= server) ```sessionInfo()
``` R version 4.2.1 (2022-06-23) Platform: aarch64-apple-darwin20 (64-bit) Running under: macOS Ventura 13.1 Matrix products: default LAPACK: /Library/Frameworks/R.framework/Versions/4.2-arm64/Resources/lib/libRlapack.dylib locale: [1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8 attached base packages: [1] stats graphics grDevices datasets utils methods base other attached packages: [1] dmdu_0.0.0.9001 testthat_3.1.6 echarty_1.4.5 shiny_1.7.4 loaded via a namespace (and not attached): [1] colorspace_2.0-3 ellipsis_0.3.2 rprojroot_2.0.3 snakecase_0.11.0 [5] markdown_1.1 fs_1.5.2 rstudioapi_0.14 roxygen2_7.2.1 [9] remotes_2.4.2 bit64_4.0.5 DT_0.23 golem_0.3.4 [13] fansi_1.0.3 lubridate_1.9.0 xml2_1.3.3 cachem_1.0.6 [17] knitr_1.40 shinytest2_0.2.0.9000 config_0.3.1 pkgload_1.3.0 [21] jsonlite_1.8.3 yardstick_1.1.0 tippy_1.0.0 readr_2.1.2 [25] compiler_4.2.1 BOR_0.4.0 httr_1.4.4 assertthat_0.2.1 [29] fastmap_1.1.0 lazyeval_0.2.2 cli_3.4.1 later_1.3.0 [33] htmltools_0.5.4 prettyunits_1.1.1 tools_4.2.1 gtable_0.3.1 [37] glue_1.6.2 dplyr_1.1.0 Rcpp_1.0.9 sortable_0.4.6 [41] jquerylib_0.1.4 vctrs_0.5.2 crosstalk_1.2.1 parsnip_1.0.2 [45] xfun_0.36 stringr_1.5.0 ps_1.7.1 brio_1.1.3 [49] rvest_1.0.3 english_1.2-6 timechange_0.1.1 UU_1.15.0 [53] mime_0.12 miniUI_0.1.1.1 lifecycle_1.0.3 shinyvalidate_0.1.2 [57] renv_0.16.0 devtools_2.4.5 scales_1.2.1 vroom_1.5.7 [61] hms_1.1.2 promises_1.2.0.1 parallel_4.2.1 RColorBrewer_1.1-3 [65] virgaUtils_0.4.0 curl_4.3.3 rpart.plot_3.1.1 yaml_2.3.5 [69] memoise_2.0.1 ggplot2_3.3.6 sass_0.4.5 rpart_4.1.16 [73] stringi_1.7.8 desc_1.4.2 RMySQL_0.10.23 cicerone_1.0.5.9000 [77] hardhat_1.2.0 pkgbuild_1.3.1 attempt_0.3.1 rlang_1.0.6 [81] pkgconfig_2.0.3 evaluate_0.16 purrr_1.0.1 patchwork_1.1.1 [85] htmlwidgets_1.5.4 bit_4.0.4 cowplot_1.1.1 processx_3.7.0 [89] tidyselect_1.2.0 OpenMCE_1.0.0 shinyVirga_0.15.0 plyr_1.8.7 [93] magrittr_2.0.3 learnr_0.10.1 R6_2.5.1 generics_0.1.3 [97] profvis_0.3.7 DBI_1.1.3 pillar_1.8.1 withr_2.5.0 [101] tibble_3.1.8 reactable_0.3.0 crayon_1.5.2 shinyWidgets_0.7.6 [105] bs4Dash_2.2.1 utf8_1.2.2 plotly_4.10.1 tzdb_0.3.0 [109] rmarkdown_2.20 crssDB_1.0.0 urlchecker_1.0.1 tidyrules_0.1.5 [113] usethis_2.1.6 grid_4.2.1 data.table_1.14.2 callr_3.7.2 [117] digest_0.6.30 xtable_1.8-4 tidyr_1.2.1 httpuv_1.6.6 [121] pool_0.1.6 munsell_0.5.0 viridisLite_0.4.1 bslib_0.4.0 [125] sessioninfo_1.2.2 shinyjs_2.1.0 ```