more tests

helgasoft · Nov 24, 2024 · 394b0cf · 394b0cf
1 parent 8212144
commit 394b0cf
Show file tree

Hide file tree

Showing 8 changed files with 127 additions and 65 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: echarty
 Title: Minimal R/Shiny Interface to JavaScript Library 'ECharts'
-Date: 2024-10-05
+Date: 2024-11-24
 Version: 1.6.4.1
 Author: Larry Helgason, with initial code from John Coene's library echarts4r
 Maintainer: Larry Helgason <[email protected]>

diff --git a/NEWS.md b/NEWS.md
@@ -2,11 +2,12 @@
 
 ## v. 1.6.4.1  latest in development
 
-- upgrade ECharts to v.5.5.1, built with R v.4.4.1
+- upgrade ECharts to v.5.5.1, built with R v.4.4.2
 - auto-load 3D plugin when 3D attributes present (xAxis3D, bar3D, etc.)
 - auto-set 3D axes from data (name, type)
 - change in dataset: store column names in _dimensions_ instead of _source_
 - fixed bug in ecr.ebars for single series
+- add optional placeholder '%@' in title$text for timeline
 
 ## v. 1.6.4  on CRAN
 

diff --git a/R/echarty.R b/R/echarty.R
@@ -83,9 +83,10 @@ noCoord <- c('polar','radar','singleAxis','parallelAxis','calendar')
 #'  Defined by _series.param_ for the \href{https://echarts.apache.org/en/option.html#series}{options series} and a _timeline_ list for the \href{https://echarts.apache.org/en/option.html#timeline}{actual control}.
 #'  A grouped _df_ is required, each group providing data for one option serie.
 #'  Timeline \href{https://echarts.apache.org/en/option.html#timeline.data}{data} and \href{https://echarts.apache.org/en/option.html#options}{options} will be preset for the chart.\cr
+#'  Each option title can include the current timeline item by adding a placeholder '%@' in title$text. See example below.\cr
 #'  Another preset is _encode(x=1,y=2,z=3)_, which are the first 3 columns of _df_. Parameter _z_ is ignored in 2D. See Details below.\cr
 #'  Optional attribute _groupBy_, a _df_ column name, can create series groups inside each timeline option.\cr
-#'  Timeline cannot be used for hierarchical charts like graph,tree,treemap,sankey. Chart options/timeline have to be built directly, see \href{https://helgasoft.github.io/echarty/uc4.html}{example}.
+#'  Options/timeline for hierarchical charts like graph,tree,treemap,sankey have to be built directly, see \href{https://helgasoft.github.io/echarty/uc4.html}{example}.
 #'  
 #'  **\href{https://echarts.apache.org/en/option.html#series-line.encode}{Encode}** \cr
 #'  A series attribute to define which columns to use for the axes, depending on chart type and coordinate system: \cr
@@ -113,6 +114,7 @@ noCoord <- c('polar','radar','singleAxis','parallelAxis','calendar')
 #' )
 #' 
 #' data.frame(n=1:5) |> dplyr::group_by(n) |> ec.init(
+#'   title= list(text= "gauge #%@"),
 #'   timeline= list(show=TRUE, autoPlay=TRUE),
 #'   series.param= list(type='gauge', max=5)
 #' )
@@ -329,7 +331,7 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
       for(nm in grvals) { 
         k <- k+1
         txfm <- append(txfm, list(list(transform= list(
-          type= 'filter', config= list(dimension= grnm, '='=nm), id= nm))))
+          type= 'filter', config= list(dimension= grnm, '='=nm)), id= nm)))
         sers <- append(sers, list(list(  # datasetIndex will be decremented later
           type= ctype, datasetIndex= k+1, name= as.character(nm))))
         # if (colnames(df)[1]==grnm)  # grouping by 1st column - breaks prll,map,etc.
@@ -490,8 +492,8 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
   # autoload 3D 
   cnd1 <- any(c('xAxis3D','yAxis3D','zAxis3D','grid3D','globe','geo3D') %in% names(opt1))
   styp <- ctype
-  if ('series.param' %in% names(opt1) && !is.null(opt1$series.param$type))
-    styp <- opt1$series.param$type
+  if (!is.null(series.param) && !is.null(series.param$type))
+    styp <- series.param$type
   cnd2 <- any(endsWith(styp, c('3D','GL')))
   if ((cnd1 || cnd2) && !'3D' %in% load) load <- c(load, '3D')
 
@@ -505,7 +507,7 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
         wt$x$opts$series <- .merlis(wt$x$opts$series, list(coordinateSystem='geo'))
       }
       # WARN: duplicate maps if series have map='world' too
-      if (!'geo' %in% names(opt1))
+      if (!'geo' %in% names(opt1) && !'3D' %in% load)
         wt$x$opts$geo = list(map='world', roam=TRUE)
       # else {
       #   wt$x$opts$geo = .merlis(wt$x$opts$geo, list(map='world'))
@@ -583,19 +585,23 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
     if ('3D' %in% load) {
       if (preset) {       # replace 2D presets with 3D
       isGL <- any(unlist(lapply(opt1$series, \(k){ endsWith(k$type, 'GL') })))  # all GL are 2D
-      if (!is.null(opt1$series.param)) isGL <- endsWith(opt1$series.param$type, 'GL')
-      if (!is.null(opt1$globe) || !is.null(opt1$geo3D) ) isGL <- FALSE
+      if (!isGL) isGL <- endsWith(styp, 'GL')
+      isMap3d <- !is.null(opt1$globe) || !is.null(opt1$geo3D)
+      if (isMap3d) isGL <- FALSE
       if (!isGL) {  
         # check for series types ending in 3D or GL
-        stypes <- ifelse(!is.null(opt1$series.param), opt1$series.param$type, 
+        stypes <- ifelse(!is.null(series.param), styp, 
                          unlist(lapply(opt1$series, \(k){k$type})) )
         stypes <- stypes[stypes!='surface']
         if (!is.null(stypes)) stopifnot("Non-3D series type detected"= all(endsWith(stypes, '3D')) )
-
-        nops <- names(opt1)   # add defaults 3D
-        for(x in c('xAxis3D','yAxis3D','zAxis3D','grid3D')) {
-          a2d <- sub('3D','',x)
-          if (!(x %in% nops)) wt$x$opts[[x]] <- if (!is.null(wt$x$opts[[a2d]])) wt$x$opts[[a2d]] else list(show=T)
+        if (!isMap3d) {
+          nops <- names(opt1)   # add defaults 3D
+          for(x in c('xAxis3D','yAxis3D','zAxis3D','grid3D')) {
+            a2d <- sub('3D','',x)
+            if (!(x %in% nops)) 
+              wt$x$opts[[x]] <- if (!is.null(wt$x$opts[[a2d]])) wt$x$opts[[a2d]]
+                                else list(show=TRUE)
+          }
         }
         wt$x$opts$xAxis <- wt$x$opts$yAxis <- NULL
       }
@@ -679,8 +685,9 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
       di <<- di+1
       steps <<- c(steps, unique(unlist(lapply(gp[grnm], as.character))))
       series <- list(list(type= 'map', geoIndex= 1, datasetIndex= di +1))
-      tmp <- list( #title= list(text= as.character(unique(gp[grnm]))),  
-                  series= series)
+      tmp <- list(series= series)
+      if (!is.null(opt1$title$text) && grepl('%@', opt1$title$text))
+        tmp$title= list(text= sub('%@', as.character(unique(gp[grnm])), opt1$title$text) )
       tmp <- .renumber(tmp)
     })
   } 
@@ -709,8 +716,9 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
           append(list(datasetIndex= di +1), tl.series)  # , name= sname
       })
 
-      tmp <- list( #title= list(text= unique(unlist(lapply(gp[grnm], as.character)))),
-                  series= unname(series))
+      tmp <- list(series= unname(series))
+      if (!is.null(opt1$title$text) && grepl('%@', opt1$title$text))
+        tmp$title= list(text= sub('%@', as.character(unique(gp[grnm])), opt1$title$text) )
       tmp <- .renumber(tmp)
     })
   }
@@ -932,20 +940,29 @@ str='high <b>'+(lo+hi)+'</b>'+lin+'<br>low <b>'+lo+'</b>'; return str;}"  # stac
 #' 
 #' @examples
 #' library(dplyr)
-#' df <- mtcars |> group_by(cyl,gear) |> summarise(yy= round(mean(mpg),2)) |>
-#'   mutate(low= round(yy-cyl*runif(1),2), high= round(yy+cyl*runif(1),2))
-#' ec.init(df, load= 'custom', ctype= 'bar', tooltip= list(show=TRUE), 
-#'       xAxis= list(type='category')) |> 
-#' ecr.ebars(encode= list(y=c(3,4,5), x=2))
-#'      
+#' df <- mtcars |> group_by(cyl,gear) |> summarise(avg.mpg= round(mean(mpg),2)) |>
+#'   mutate(low = round(avg.mpg-cyl*runif(1),2), 
+#'          high= round(avg.mpg+cyl*runif(1),2))
+#' ec.init(df, load= 'custom', ctype= 'bar',
+#'       xAxis= list(type='category'), tooltip= list(show=TRUE)) |>
+#' ecr.ebars(encode= list(y=c('avg.mpg','low','high'), x='gear'))
+#' #ecr.ebars(encode= list(y=c(3,4,5), x=2))  # ok: data indexes
+#'
+#' # same but horizontal
+#' ec.init(df, load= 'custom',
+#'   yAxis= list(type='category'), tooltip= list(show=TRUE),
+#'   series.param= list(type='bar', encode= list(x='avg.mpg', y='gear') )) |>
+#' ecr.ebars(encode= list(x=c('avg.mpg','low','high'), y='gear'))
+#' 
 #' # ----- riErrBarSimple ------
-#' df <- mtcars |> mutate(x=1:nrow(mtcars),hi=hp-drat*3, lo=hp+wt*3) |> select(x,hp,hi,lo)
-#' ec.init(df, load= 'custom', legend= list(show= TRUE)) |> 
+#' df <- mtcars |> mutate(name= row.names(mtcars), hi= hp-drat*3, lo= hp+wt*3) |> 
+#'   filter(cyl==4) |> select(name,hp,hi,lo)
+#' ec.init(df, load= 'custom', legend= list(show=TRUE)) |>
 #' ec.upd({ series <- append(series, list(
-#'     list(type= 'custom', name= 'error',
-#'          data= ec.data(df |> select(x,hi,lo)),
-#'          renderItem= htmlwidgets::JS('riErrBarSimple')
-#'     )))
+#'   list(type= 'custom', name= 'error',
+#'     data= ec.data(df |> select(name,hi,lo)),
+#'     renderItem= htmlwidgets::JS('riErrBarSimple')
+#'   )))
 #' })
 #' 
 #' @export
@@ -1008,17 +1025,6 @@ ecr.ebars <- function(wt, encode=list(x=1, y=c(2,3,4)), hwidth=6, ...) {
   # assuming all attached series from same dataset
   encode$y <- enc2num(encode$y, tmp[[1]])
   encode$x <- enc2num(encode$x, tmp[[1]])
-  # # set correct axis to type 'category' (char or factor)
-  # enc <- wt$x$opts$dataset[[1]]$source[[2]]$encode
-  # if (!is.null(enc)) {
-  #   if (length(encode$y)==1) {
-  #     if (is.character(enc$y) || is.factor(enc$y))
-  #       wt$x$opts$yAxis <- .merlis(wt$x$opts$yAxis, list(type='category'))
-  #   } else {
-  #     if (is.character(enc$x) || is.factor(enc$x))
-  #       wt$x$opts$xAxis <- .merlis(wt$x$opts$xAxis, list(type='category'))
-  #   }
-  # }
 
   rim <- if (!is.null(args$renderItem)) args$renderItem else 'riErrBars'
   decds <- ifelse(length(tmp)>1, 0, 1)   # single or grouped

diff --git a/man/ec.init.Rd b/man/ec.init.Rd
diff --git a/man/ecr.ebars.Rd b/man/ecr.ebars.Rd
diff --git a/tests/testthat/test-other.R b/tests/testthat/test-other.R
@@ -33,14 +33,13 @@ test_that("registerMap", {
 
 test_that("tl.series, timeline options, groupBy", {  # also in test-presets
   p <- Orange |> dplyr::group_by(age) |> ec.init(
-    timeline= list(autoPlay=TRUE),
+    timeline= list(autoPlay=TRUE), title= list(text='age %@ days'),
     series.param= list(type='bar', encode=list(x='Tree', y='circumference'))
-  ) |> ec.upd({
-    options <- lapply(seq_along(options), 
-      \(i) { 
-        options[[i]]$title$text <- paste('age',timeline$data[[i]],'days'); 
-        options[[i]] })
-  })
+  ) # |> ec.upd({
+  #   options <- lapply(seq_along(options), \(i) { 
+  #       options[[i]]$title$text <- paste('age',timeline$data[[i]],'days'); 
+  #       options[[i]] })
+  # })
   expect_equal(p$x$opts$options[[5]]$title$text, "age 1231 days")
   expect_equal(p$x$opts$options[[5]]$series[[1]]$datasetIndex, 5)
   expect_equal(p$x$opts$options[[7]]$series[[1]]$encode$x, "Tree")
@@ -60,6 +59,13 @@ test_that("tl.series, timeline options, groupBy", {  # also in test-presets
   )
   expect_equal(p$x$opts$options[[4]]$series[[2]]$name, 'B')
   expect_true(p$x$opts$dataset[[9]]$transform$config$and[[2]]$dimension=='x2')
+
+  p <- data.frame(name=c('Brazil','Australia'), value=c(111,222)) |> group_by(name) |>
+  ec.init(load= 'world', title= list(text='map %@'), visualMap=list(show=T), 
+        timeline= list(show=T), series.param= list(type='map') )
+  expect_equal(p$x$opts$options[[2]]$title$text, "map Brazil")
+  expect_equal(p$x$opts$visualMap$min, 111)
+
 })
 
 test_that("leaflet with ec.clmn and timeline", {
@@ -170,6 +176,25 @@ test_that("3D globe & autoload 3D", {
   lif <- paste0(system.file('js', package='echarty'), '/echarts-gl.min.js')
   expect_true(file.exists(lif))
   expect_equal(p$x$opts$series[[1]]$coordinateSystem, 'globe')
+
+  p <- ec.init(load='world', geo3D= list(map= 'world', roam=T),
+    series.param= list(type= 'scatter3D', data=list(c(115, 22, 10), c(-116, 32, -11)))
+  ) 
+  expect_equal(p$x$opts$series[[1]]$coordinateSystem, 'geo3D')
+})
+
+test_that("radar and polar", {  # for coverage
+  p <- ec.init(
+  	radar= list(indicator= lapply(LETTERS[1:5], \(x) { list(name=x)} ) ),
+  	series= list(list(type='radar', radarIndex=1,
+  	                  data= list(c(10,22,5,9,11), c(12,18,15,15,7))))
+  )
+  expect_equal(p$x$opts$series[[1]]$radarIndex, 0)
+
+  p <- data.frame(x = 1:10, y = seq(1, 20, by = 2)) |>
+  ec.init(polar= list(show=T), series.param= list(type='line', polarIndex=1))
+  expect_equal(p$x$opts$series[[1]]$polarIndex, 0)
+
 })
 
 test_that("calendar", {
@@ -178,9 +203,10 @@ test_that("calendar", {
   p <- df |> ec.init( 
     visualMap= list(show= FALSE, min= 0, max= 100), 
     calendar = list(range= c('2023-01','2023-04')),
-    series.param= list(type= 'scatter', name='scat', symbolSize=11)
+    series.param= list(type= 'scatter', name='scat', symbolSize=11, calendarIndex=1)
   )
   expect_equal(p$x$opts$series[[1]]$coordinateSystem, "calendar")
+  expect_equal(p$x$opts$series[[1]]$calendarIndex, 0)
 })
 
 test_that("ec.plugjs", {
@@ -243,7 +269,7 @@ test_that('stops are working in echarty.R', {
   expect_silent(ec.init(mtcars |> group_by(gear), tl.series= list(type='map'))) # no name/value, can use encode
   expect_silent(ec.init(df |> group_by(y), series.param= list(type='bar')))
   expect_silent(ec.init(df |> group_by(y), series.param= list(type='bar'), 
-                        timeline= list(s=T)))
+                        timeline= list(show=T)))
   # expect_error(cars |> group_by(speed) |> ec.init()) # 3 cols min
   # expect_error(ec.init(data.frame(name='n',value=1) |> group_by(name), 
   #     tl.series= list(type='bar')))  # 3 cols min

diff --git a/tests/testthat/test-presets.R b/tests/testthat/test-presets.R
@@ -57,7 +57,7 @@ test_that("ec.init presets for grouped data.frame", {
   expect_equal(po$xAxis$type, 'category')
   expect_equal(po$yAxis$name, 'yaxe')
   expect_equal(length(po$dataset[[1]]$source), 10)
-  expect_equal(po$dataset[[4]]$transform$id, "triangle")
+  expect_equal(po$dataset[[4]]$id, "triangle")
   expect_equal(length(po$legend$data), 3)
   expect_equal(po$series[[1]]$type, 'scatter')
   expect_equal(po$series[[1]]$name, 'circle')

diff --git a/tests/testthat/test-renderers.R b/tests/testthat/test-renderers.R
@@ -48,6 +48,24 @@ test_that("ecr.ebars", {
   expect_equal(p$x$opts$series[[2]]$encode$y, c(2,3,4))
   expect_equal(p$x$opts$series[[2]]$itemStyle$borderDashOffset, 12)
 
+  df <- Orange |> arrange(Tree) |> mutate(up= circumference+runif(5)*6, 
+                                          lo= circumference-runif(5)*6 ) |> filter(age==1231)
+  tmp <- ec.init(df, load= 'custom', legend= list(show=T), tooltip= list(show=T), 
+                 xAxis=list(type='category'),
+      series= list(list(type='bar', name='data', encode= list(x='Tree',y='circumference')
+  )))
+  p <- ecr.ebars(tmp, encode= list(x='Tree', y=c('circumference','lo','up')), hwidth=12, name='err',
+        itemStyle= list(borderWidth= 2.5, color= "red")
+  )
+  expect_equal(p$x$opts$series[[2]]$encode$y, c(2,3,4))
+  expect_equal(p$x$opts$series[[2]]$itemStyle$borderDashOffset, 12)
+  p <- tmp |> ec.upd({   # for cov only
+    dataset[[1]]$source[[1]] <- dataset[[1]]$dimensions
+    dataset[[1]]$dimensions <- NULL
+    dataset[[1]]$sourceHeader <- T  # TODO: should work without it too
+  }) |> ecr.ebars( encode= list(x='Tree', y=c('circumference','lo','up')), hwidth=12 )
+  expect_equal(p$x$opts$dataset[[1]]$source[[1]][1], 'Tree')
+
   # grouped + non-categorical
   tmp <- round(rnorm(24, sin(1:24/2)*10, .5))
   df <- data.frame(x = 1:24, val = tmp,