v.1.6.4

helgasoft · Jun 5, 2024 · 5729c29 · 5729c29
1 parent 50e6559
commit 5729c29
Show file tree

Hide file tree

Showing 13 changed files with 94 additions and 72 deletions.
diff --git a/CRAN-SUBMISSION b/CRAN-SUBMISSION
@@ -1,3 +1,3 @@
-Version: 1.6.3
-Date: 2024-01-12 05:46:46 UTC
-SHA: 57ef62df7605f7bbeff9750de5139f27ee8e1241
+Version: 1.6.4
+Date: 2024-06-05 02:55:49 UTC
+SHA: 50e6559c12e380ccbb49f99d46228467dde8ec5e
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Package: echarty
 Title: Minimal R/Shiny Interface to JavaScript Library 'ECharts'
-Date: 2024-05-16
-Version: 1.6.3.03
+Date: 2024-06-04
+Version: 1.6.4
 Author: Larry Helgason, with initial code from John Coene's library echarts4r
 Maintainer: Larry Helgason <[email protected]>
 Description: Deliver the full functionality of 'ECharts' with minimal overhead. 'echarty' users build R lists for 'ECharts' API. Lean set of powerful commands.

diff --git a/NAMESPACE b/NAMESPACE
@@ -29,5 +29,6 @@ importFrom(htmlwidgets,sizingPolicy)
 importFrom(stats,na.omit)
 importFrom(utils,askYesNo)
 importFrom(utils,download.file)
+importFrom(utils,read.csv)
 importFrom(utils,tail)
 importFrom(utils,unzip)
diff --git a/NEWS.md b/NEWS.md
@@ -1,13 +1,15 @@
 # history of package _echarty_
 
-## v. 1.6.3.03  latest in development
+## v. 1.6.4  latest in development
 
 - upgrade ECharts to v.5.5.0, built with R v.4.4.0
-- added _nasep_ parameter to ec.data('names') for easier setting of nested lists from a _data.frame_
-- tested web freedom [with WebR](https://helgasoft.github.io/echarty/test/coder.html)
-- added explicit _leaflet_ dependency, not provided since leaflet v.2.2.0
-- added optional tooltip formatter (tipFmt) in _ecr.band_
+- add _nasep_ parameter to _ec.data('names')_ - easily set nested lists from a _data.frame_
+- add [WebR](https://docs.r-wasm.org/webr/latest/) support and [test](https://helgasoft.github.io/echarty/test/coder.html)
+- add explicit _leaflet_ dependency since dependencies changed in leaflet v.2.2.0
+- add optional tooltip formatter (tipFmt) in _ecr.band_
 - refactoring (leaflet, geo, geoJson, tests)
+- add debug flags for messages in JS and R
+- fix _crosstalk_ bug for checkboxes unselect
 
 ## v. 1.6.3  on CRAN
 

diff --git a/R/echarty.R b/R/echarty.R
@@ -30,8 +30,8 @@ noCoord <- c('polar','radar','singleAxis','parallelAxis','calendar')
 #' @param ctype Chart type, default is 'scatter'.
 #' @param preset Boolean (default TRUE). Build preset attributes like dataset, series, xAxis, yAxis, etc.
 #' @param series.param  Additional attributes for preset series, default is NULL.\cr
-#'  Can be used for non-timeline and timeline series (instead of _tl.series_). A single list defines one series type only.\cr
-#'  One could also define all series directly with _series=list(list(...),list...)_ instead.
+#'  Defines a single series type. Can be used for both non-timeline and timeline series. \cr
+#'  Multiple series types need to be defined directly with _series=list(list(...),list...)_ or added with [ec.upd].
 #' @param tl.series Deprecated, use _timeline_ and _series.param_ instead.\cr
 #' @param ...  Optional widget attributes. See Details. \cr
 #' @param width,height Optional valid CSS unit (like \code{'100\%'},
@@ -120,6 +120,7 @@ noCoord <- c('polar','radar','singleAxis','parallelAxis','calendar')
 #' )
 #' 
 #' @importFrom htmlwidgets createWidget sizingPolicy getDependency JS shinyWidgetOutput shinyRenderWidget
+#' @importFrom utils read.csv
 #' @import dplyr
 #' 
 #' @export
@@ -156,9 +157,11 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
   useDirtyRect <- if (is.null(opt1$useDirtyRect)) FALSE else opt1$useDirtyRect
   xtKey <- if (is.null(opt1$xtKey)) 'XkeyX' else opt1$xtKey
   if (xtKey=='XkeyX') df$XkeyX <- dfKey   # add new column for Xtalk filtering, if needed
+  # allow debug feedback thru cat() in JS and R code:
+  dbg <- if (is.null(opt1$dbg)) FALSE else opt1$dbg   
   # remove the above attributes since they are not valid ECharts options
   opt1$ask <- opt1$js <- opt1$renderer <- opt1$locale <- NULL
-  opt1$useDirtyRect <- opt1$elementId <- opt1$xtKey <- NULL
+  opt1$useDirtyRect <- opt1$elementId <- opt1$xtKey <- opt1$dbg <- NULL
   axis2d <- c('pictorialBar','candlestick','boxplot','scatterGL') #'custom',
 
   # forward widget options using x
@@ -168,7 +171,7 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
     renderer = renderer,
     locale = locale,
     useDirtyRect = useDirtyRect,
-    jcode = js,
+    jcode = js, dbg = dbg,
     opts = opt1,
     settings = list(
       crosstalk_key = key,
@@ -285,11 +288,11 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
     return(list(x=xtem, y=ytem, z='z', c=ser$coordinateSystem))
   }
   doVMap <- function(wid) {
-    # visualMap assist
+    # visualMap assist: auto add min/max/calculable   (categories==piecewise)
     vm <- wid$opts$visualMap
     out <- NULL
     if (!is.null(df) && !is.null(vm) &&
-        is.null(vm$min) && is.null(vm$max) &&
+        is.null(vm$min) && is.null(vm$max) && is.null(vm$categories) &&
         (is.null(vm$type) || (vm$type == 'continuous')) ) {
 
         xx <- length(colnames(df))   # last numeric column by default
@@ -300,7 +303,6 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
         ) xx <- 'value'
         if (!is.null(vm$dimension)) xx <- vm$dimension
         out <- list(
-          #dimension= xx,
           min= min(na.omit(df[,xx])),
           max= max(na.omit(df[,xx])),
           calculable= TRUE
@@ -471,6 +473,7 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
     ),
     dependencies = deps
   )
+  #if (dbg) cat('\naxis2d=',axis2d)
 
   tmp <- getOption('echarty.font')
   if (!is.null(tmp))
@@ -482,20 +485,14 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
 
   # ------------- plugins loading -----------------------------
   opt1 <- wt$x$opts
-  load <- opt1$load;
-  wt$x$opts$load <- NULL
+  load <- opt1$load;  wt$x$opts$load <- NULL
   if (length(load)==1 && grepl(',', load, fixed=TRUE))
       load <- unlist(strsplit(load, ','))
 
   path <- system.file('js', package= 'echarty')
   dep <- NULL
 
   if ('world' %in% load) {
-    dep <- htmltools::htmlDependency(
-      name = 'world', version = '1.0.0', 
-      src = c(file = path), script= 'world.js')
-    wt$dependencies <- append(wt$dependencies, list(dep))
-
     if (preset) {
       wt$x$opts$xAxis <- wt$x$opts$yAxis <- NULL
       if (!is.null(df)) {   # coordinateSystem='geo' needed for all series
@@ -511,11 +508,14 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
       # if (!is.null(df))  # cancelled: don't know if df first 2 cols are 'lng','lat'
       #   wt$x$opts$geo$center= c(mean(unlist(df[,1])), mean(unlist(df[,2])))
     }
+    dep <- htmltools::htmlDependency(
+      name = 'world', version = '1.0.0', 
+      src = c(file = path), script= 'world.js')
+    wt$dependencies <- append(wt$dependencies, list(dep))
   }
-
   if ('leaflet' %in% load) {
-    # coveralls pops error, win/linux ok :
-    #stopifnot("ec.init: library 'leaflet' not installed"= file.exists(file.path(.libPaths(), 'leaflet')[[1]]))
+      # coveralls pops error, win/linux ok :
+      #stopifnot("ec.init: library 'leaflet' not installed"= file.exists(file.path(.libPaths(), 'leaflet')[[1]]))
     if (!file.exists(file.path(.libPaths(), 'leaflet')[[1]])) warning("ec.init: library 'leaflet' not installed")
     if (preset) {
       # customizations for leaflet
@@ -572,9 +572,10 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
   }
 
   # Plugins implemented as dynamic load on-demand
-  cdn <- 'https://cdn.jsdelivr.net/npm/'
-  if ('3D' %in% load) {
-    if (preset) {       # replace 2D presets with 3D
+  if (any(load %in% c('3D','liquid','gmodular','wordcloud'))) {
+    plf <- read.csv(system.file('plugins.csv', package='echarty'), header=TRUE, stringsAsFactors=FALSE)
+    if ('3D' %in% load) {
+      if (preset) {       # replace 2D presets with 3D
       isScatGL <- 'scatterGL' %in% unlist(lapply(opt1$series, \(k){k$type}))  # scatterGL is 2D
       if (!isScatGL && is.null(opt1$globe) && is.null(opt1$geo3D) ) {  
         wt$x$opts$xAxis <- wt$x$opts$yAxis <- NULL
@@ -593,21 +594,12 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
           \(s) { s$type= if (s$type=='scatter') 'scatter3D' else s$type; s })
       }
     }
-    wt <- ec.plugjs(wt, 
-      paste0(cdn,'[email protected]/dist/echarts-gl.min.js'), ask)
-  }
-  if ('liquid' %in% load) 
-    wt <- ec.plugjs(wt, 
-      paste0(cdn,'echarts-liquidfill@latest/dist/echarts-liquidfill.min.js'), ask)
-
-  if ('gmodular' %in% load) 
-    wt <- ec.plugjs(wt, 
-      paste0(cdn,'echarts-graph-modularity@latest/dist/echarts-graph-modularity.min.js'), ask)
-
-  if ('wordcloud' %in% load) 
-    wt <- ec.plugjs(wt, 
-      paste0(cdn,'echarts-wordcloud@latest/dist/echarts-wordcloud.min.js'), ask)
-
+      wt <- ec.plugjs(wt, plf[plf$name=='3D',]$url, ask)
+    }
+    if ('liquid' %in% load) wt <- ec.plugjs(wt, plf[plf$name=='liquid',]$url, ask)
+    if ('gmodular' %in% load) wt <- ec.plugjs(wt, plf[plf$name=='gmodular',]$url, ask)
+    if ('wordcloud' %in% load) wt <- ec.plugjs(wt, plf[plf$name=='wordcloud',]$url, ask)
+  }  
   # load unknown plugins
   unk <- load[! load %in% c('leaflet','custom','world','lottie','ecStat',
                             '3D','liquid','gmodular','wordcloud')]
@@ -653,6 +645,7 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
   tmp <- xyNamesCS(tl.series)
   xtem <- tmp$x; ytem <- tmp$y
   if (!is.null(tmp$c)) tl.series$coordinateSystem <- tmp$c
+  #if (dbg) cat('\ntl=',tmp$x,' ',tmp$y,' ',tmp$c)
 
   if (any(c('geo','leaflet') %in% tl.series$coordinateSystem)) {
       klo <- 'lng'; kla <- 'lat'
@@ -670,7 +663,7 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
         if (tl.series$coordinateSystem=='leaflet') 
           wt$x$opts$leaflet$center <- center
       }
-  } 
+  }
 
   if (tl.series$type == 'map') {
     xtem <- 'name'; ytem <- 'value'
@@ -1209,9 +1202,9 @@ ec.plugjs <- function(wt=NULL, source=NULL, ask=FALSE) {
               startsWith(source, 'http') || startsWith(source, 'file://'))
   fname <- basename(source)
   fname <- unlist(strsplit(fname, '?', fixed=TRUE))[1]  # when 'X.js?key=Y'
-  # if (!endsWith(fname, '.js'))
-  #   stop('ec.plugjs expecting .js suffix', call. = FALSE)
+  # if (!endsWith(fname, '.js')) stop('ec.plugjs expecting .js suffix', call. = FALSE)
   path <- system.file('js', package = 'echarty')
+
   ffull <- paste0(path,'/',fname)
   if (!file.exists(ffull)) {
     if (ask) {
@@ -1223,19 +1216,20 @@ ec.plugjs <- function(wt=NULL, source=NULL, ask=FALSE) {
       if (is.na(ans)) ans <- FALSE  # was cancelled
     } else
       ans <- TRUE
-    if (ans) {
-      try(withCallingHandlers(
-        download.file(source, ffull, quiet=TRUE), # method = "libcurl"),
-        error = function(w) { ans <- FALSE },
-        warning = function(w) { ans <- FALSE }
-        #cat('ec.plugjs Error:', sub(".+HTTP status was ", "", w, source))
-      ))  #,silent=TRUE)
+    if (ans && !exists('ec.webR')) {  # WebR dislikes download.file
+      #try(withCallingHandlers(    # function(w) { ans <- FALSE }
+      errw <- function(w) { ans <- FALSE
+        cat('ec.plugjs:', sub(".+HTTP status was ", "", w, source)) }
+      tryCatch({
+        download.file(source, ffull, quiet=TRUE) }, # method = "libcurl"),
+        error = errw, warning = errw
+      )
     } 
     if (!ans) return(wt)    # error
   }
   dep <- htmltools::htmlDependency(
-    name = fname, version = '1.0.0', src = c(file = path),
-    script = fname
+    name= fname, version= '1.1.1', src= c(file = path),
+    script= fname
   )
   wt$dependencies <- append(wt$dependencies, list(dep))
   return(wt)

diff --git a/R/util.R b/R/util.R
@@ -614,6 +614,7 @@ body { padding: 10px; }
 #' # attribute names separator (nasep) is "_"
 #' df <- data.frame(name= c('A','B','C'), value= c(1,2,3), 
 #'      itemStyle_color= c('chartreuse','lightblue','pink'),
+#'      itemStyle_decal_symbol= c('rect','diamond','none'),
 #'      emphasis_itemStyle_color= c('darkgreen','blue','red')
 #' )
 #' ec.init(series.param= list(type='pie', data= ec.data(df, 'names', nasep='_')))
@@ -879,19 +880,23 @@ ec.data <- function(df, format='dataset', header=FALSE, ...) {
       stopifnot("data('names'): nasep should be 1 char"= nchar(args$nasep)==1)
       # names separator is present, replace compound names with nested lists
       tmp <- lapply(tmp, \(rr) {
+        lst <- rr
         for(cc in names(rr)) {
           if (grepl(args$nasep, cc, fixed=T)) {
+            lst[[cc]] <- NULL
             nlis <- strsplit(cc, args$nasep, fixed=T)
             out <- rr[[cc]]; 
             for(nn in rev(nlis[[1]][-1])) {
-              cur <- list(); cur[[nn]] <- out;
-              out <- cur
+              cur <- list();  cur[[nn]] <- out;  out <- cur
             }
-            rr[[cc]] <- NULL
-            rr[[ nlis[[1]][1] ]] <- out
+            col <- nlis[[1]][1]
+            if ( col %in% names(lst) )
+              lst[[col]] <- .merlis(lst[[col]], out)
+            else
+              lst[[col]] <- out
           }
         }
-        rr
+        lst
       })
     }
     datset <- tmp;

diff --git a/README.md b/README.md
@@ -54,7 +54,7 @@ Please consider granting a Github star ⭐ to show your support.
 ## Installation
 
 <!-- [![Github version](https://img.shields.io/github/v/release/helgasoft/echarty?label=github)](https://github.com/helgasoft/echarty/releases)  <sup>.02</sup>  -->
-Latest development build **1.6.3.03**
+Latest development build **1.6.4**
 
 ``` r
 if (!requireNamespace('remotes')) install.packages('remotes')

diff --git a/inst/htmlwidgets/echarty.js b/inst/htmlwidgets/echarty.js
@@ -1,5 +1,5 @@
 /*global HTMLWidgets, echarts, Shiny*/
-/*eslint no-undef: "error"*/
+/* eslint no-undef: "error" */
 
 // extra functions
 ecf = {
@@ -9,6 +9,7 @@ ecf = {
   geoz2: 0,
   zoom: {s: 0, e: 100 },  // dataZoom values
   fs: false,              // fullscreen flag Y/N
+  dbg: false,             // debug flag: if (ecf.dbg) console.log(' change s:'+v)
 
   IsFullScreen: function() {
     	var full_screen_element = document.fullscreenElement || document.webkitFullscreenElement || document.mozFullScreenElement || document.msFullscreenElement || null;
@@ -154,6 +155,7 @@ HTMLWidgets.widget({
             eva3 = x.jcode;
         }
       }
+      if (x.hasOwnProperty('dbg')) { ecf.dbg= x.dbg; }
 
       chart = echarts.init(document.getElementById(el.id), x.theme, 
       	{ renderer: x.renderer, locale: x.locale, useDirtyRect: x.useDirtyRect }
@@ -323,15 +325,14 @@ HTMLWidgets.widget({
 
       	ct_filter.on('change', function(e) {    // external keys to filter
       		if (e.sender == ct_filter) return;
-      		if (e.value == undefined) e.value = [];  // sent by filter_checkbox ?!
+      		if (e.value == undefined) e.value = chart.akeys; // sent by filter_checkbox
 
-          rexp = (e.value.length == chart.akeys.length) //|| e.value.length == 0) 
+          rexp = (e.value.length == chart.akeys.length)
                   ? '^' : '^('+ e.value.join('|') +')$';
           opt = chart.getOption();
           dtf = opt.dataset.find(x => x.id === 'Xtalk');
           //dtf.transform = {type:'filter', config: {dimension: 'XkeyX', reg: rexp } }
           dtf.transform.config.reg = rexp;
-          // chart.filk = e.value.map(x=>Number(x)).sort((a, b) => a - b);
           chart.filk = e.value.sort((a, b) => a - b);
           chart.setOption(opt, false);
       	});

diff --git a/inst/plugins.csv b/inst/plugins.csv
@@ -0,0 +1,5 @@
+name,url
+3D,https://cdn.jsdelivr.net/npm/[email protected]/dist/echarts-gl.min.js
+liquid,https://cdn.jsdelivr.net/npm/echarts-liquidfill@latest/dist/echarts-liquidfill.min.js
+gmodular,https://cdn.jsdelivr.net/npm/echarts-graph-modularity@latest/dist/echarts-graph-modularity.min.js
+wordcloud,https://cdn.jsdelivr.net/npm/echarts-wordcloud@latest/dist/echarts-wordcloud.min.js
diff --git a/man/ec.data.Rd b/man/ec.data.Rd
diff --git a/man/ec.init.Rd b/man/ec.init.Rd
diff --git a/tests/testthat/test-ec.util.R b/tests/testthat/test-ec.util.R
@@ -367,12 +367,16 @@ test_that("ec.data treeTK", {
 })
 
 test_that("ec.data 'names' + nasep", {
-  df <- data.frame(name= c('A','B','C'), value= c(1,2,3), 
+  df <- data.frame(name= c('A','B','C'), value= c(1,2,3),
+        itemStyle_color= c('chartreuse','lightblue','pink'),
+        itemStyle_decal_symbol= c('rect','diamond','none'),                   
         emphasis_itemStyle_color= c('green','blue','red')
   )
   p <- ec.init(series.param= list(
     type='pie', data= ec.data(df, 'names', nasep='_')))
   expect_equal(p$x$opts$series[[1]]$data[[1]]$emphasis$itemStyle$color, 'green')
+  expect_equal(p$x$opts$series[[1]]$data[[2]]$itemStyle$decal$symbol, 'diamond')
+  expect_equal(p$x$opts$series[[1]]$data[[3]]$itemStyle$color, 'pink')
 })
 
 test_that("ec.inspect and ec.fromJson", {