hmap,vmap

helgasoft · Nov 5, 2023 · 1ea3dc3 · 1ea3dc3
1 parent a80f8d4
commit 1ea3dc3
Show file tree

Hide file tree

Showing 7 changed files with 67 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: 2023-10-20
+Date: 2023-11-05
 Version: 1.6.2.01
 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
@@ -4,6 +4,7 @@
 
 - make crosstalk work with improved ec.clmn
 - add _ecStat_ to built-in plugins
+- dataset,geo,polar,etc. indexes in series now with R-counting
 
 ## v.1.6.2  on CRAN
 

diff --git a/R/echarty.R b/R/echarty.R
@@ -144,6 +144,7 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
   opts$useDirtyRect <- opts$elementId <- opts$xtKey <- NULL
   noAxis <- c('radar','parallel','map','gauge','pie','funnel','polar', #'graph', 
               'sunburst','tree','treemap','sankey')
+  axis2d <- c('line','scatter','bar','pictorialBar','candlestick','boxplot','heatmap','custom','effectScatter')
 
   doType <- function(idx, axx) {
     # get one axis type & name
@@ -190,14 +191,14 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
       }
     })
 
-    if (!is.null(tmp$x)) {
-      if (is.null(x$opts$xAxis$name))
+    if (!is.null(tmp$x)) {   # dont name multiple xAxis
+      if (is.null(x$opts$xAxis$name) && !is.null(names(lengths(x$opts$xAxis))))
         x$opts$xAxis$name <<- trimws(paste(unique(tmp$x), collapse=','))
       tt <- tmp$x[1]
       colX <<- if (is.numeric(tt)) tt else which(colnames(df)==tt)[1]
     }
     if (!is.null(tmp$y)) {
-      if (is.null(x$opts$yAxis$name))
+      if (is.null(x$opts$yAxis$name) && !is.null(names(lengths(x$opts$yAxis))))
         x$opts$yAxis$name <<- trimws(paste(unique(tmp$y), collapse=','))
       tt <- tmp$y[1]
       colY <<- if (is.numeric(tt)) tt else which(colnames(df)==tt)[1]
@@ -208,7 +209,7 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
     xtem <- 'x'; ytem <- 'y'
     if (is.null(ser$coordinateSystem))
       ser$coordinateSystem <- 'unknown'
-    if (ser$type %in% c('line','scatter','bar','pictorialBar','candlestick','boxplot'))
+    if (ser$type %in% axis2d)
       ser$coordinateSystem <- 'cartesian2d'
     #if (startsWith(ser$coordinateSystem, 'cartesian')) { 
     #  xtem <- 'x'; ytem <- 'y' } #,ztem <- 'z' }
@@ -260,15 +261,15 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
         k <- k+1
         txfm <- append(txfm, list(list(transform = list(
           type='filter', config=list(dimension=grnm, '='=nm)))))
-        sers <- append(sers, list(list(
-          type= ctype, datasetIndex= k, name= as.character(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.
         legd$data <- append(legd$data, list(list(name=as.character(nm))))
       }
       if (preset) {
         #if (is.null(tl.series) && is.null(x$opts$options))
           x$opts$series <- sers
-        x$opts$legend <- legd
+        x$opts$legend <- .merlis(x$opts$legend, legd)
       }
       x$opts$dataset <- append(x$opts$dataset, txfm)
     } 
@@ -311,8 +312,13 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
         if (is.null(vm$type) || (vm$type == 'continuous')) {
           xx <- length(colnames(df))   # last column by default in ECharts
           if (!is.null(vm$dimension)) xx <- vm$dimension
-          x$opts$visualMap$min <- min(df[,xx])
-          x$opts$visualMap$max <- max(df[,xx])
+          #x$opts$visualMap$min <- min(na.omit(df[,xx]))
+          #x$opts$visualMap$max <- max(na.omit(df[,xx]))
+          x$opts$visualMap <- .merlis(x$opts$visualMap, list(
+            min= min(na.omit(df[,xx])),
+            max= max(na.omit(df[,xx])),
+            calculable= TRUE
+          ))
         }
       }
     }  # colX,colY, visualMap
@@ -424,10 +430,6 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
       wt$x$opts$yAxis <- NULL
       if (!is.null(df)) {   # coordinateSystem='geo' needed for all series
         wt$x$opts$series <- .merlis(wt$x$opts$series, list(coordinateSystem='geo'))
-        # tmp <- sapply(wt$x$opts$series, \(x) {x$type} )
-        # if (!'map' %in% tmp)  # add map serie if missing
-        #   wt$x$opts$series <- append(wt$x$opts$series,
-        #                               list(list(type='map', geoIndex=0)))
       }
       # WARN: map will duplicate if series have map='world' too
       if (!'geo' %in% names(wt$x$opts))
@@ -589,7 +591,7 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
       tmp <- gp
       names(tmp)[names(tmp)==tl.series$encode[xtem]] <- 'name'
       names(tmp)[names(tmp)==tl.series$encode[ytem]] <- 'value'
-      series <- list(list(type= "map", geoIndex=0,
+      series <- list(list(type= "map", geoIndex= 1,
                           data= ec.data(tmp, 'names')))
       tmp <- list(title= list(text= as.character(unique(gp[gvar]))),  
                   series= series)
@@ -602,9 +604,8 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
       df <- df |> group_modify(~ { .x |> mutate(XcolX = 1:nrow(.)) })
       tl.series$encode[xtem] <- 'XcolX'    # instead of relocate(XcolX)
       # replace only source, transforms stay
-      wt$x$opts$dataset[[1]] <- list(source=ec.data(df, header=TRUE))
+      wt$x$opts$dataset[[1]] <- list(source= ec.data(df, header=TRUE))
     }
-    # paste0("tl.series: encode '",ytem,"' is required for ",tl.series$coordinateSystem)
     stopifnot("tl.series: bad second parameter name for encode"= !is.null(unlist(tl.series$encode[ytem])))
 
     # dataset is already in, now loop group column(s)
@@ -618,12 +619,8 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
       # multiple series for each Y, like y=c('col1', 'col3')
       series <- lapply(unname(unlist(tl.series$encode[ytem])), 
         \(sname) {
-          append(list(datasetIndex= di), tl.series)  # , name= sname
+          append(list(datasetIndex= di +1), tl.series)  # , name= sname
       })
-      # series <- lapply(series, \(s) {
-      #   s$encode[ytem] <- s$name   # replace multiple col.names with one
-      #   s
-      # })
 
       #tmp <- list(title= list(text= as.character(unique(gp[gvar]))),  
       tmp <- list(title= list(text= unique(unlist(lapply(gp[gvar], as.character)))),
@@ -643,33 +640,35 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
     tgrp <- tl.series$groupBy
     # define additional filter transformations and option series based on preset ones
     dsf <- list()  # new filters
-    opts <- list() 
+    optm <- list() 
     filterIdx <- 0
-    for (i in 1:length(unlist(unname(lapply(unique(df[gvar]), as.list))))) {
+    #for (ii in 1:length(unlist(unname(lapply(unique(df[gvar]), as.list))))) {
+    for (ii in 1:length(unname(unlist(unique(df[gvar])))) ) {
       snames <- c()
-      for (x2 in unlist(unname(lapply(unique(df[tgrp]), as.list)))) {
-        dst <- wt$x$opts$dataset[[i+1]]  # skip source-dataset 1st
+      #for (x2 in unlist(unname(lapply(unique(df[tgrp]), as.list)))) {
+      for (x2 in unname(unlist(unique(df[tgrp]))) ) {
+        dst <- wt$x$opts$dataset[[ii+1]]  # skip source-dataset 1st
         dst$transform$config <- list(and= list(
           dst$transform$config,
           list(dimension= tgrp, `=`= x2)
         ))
         dsf <- append(dsf, list(dst))
         snames <- c(snames, x2)
       }
-      ooo <- wt$x$opts$options[[i]]
+      ooo <- wt$x$opts$options[[ii]]
       sss <- lapply(snames, \(s) {
         filterIdx <<- filterIdx + 1
         tmp <- ooo$series[[1]]
         tmp$name <- s
-        tmp$datasetIndex <- filterIdx
+        tmp$datasetIndex <- filterIdx +1 # will be decremented
         tmp$groupBy <- NULL
         tmp
       })
-      opts <- append(opts, list(
+      optm <- append(optm, list(
         list(title= ooo$title, series= sss)))
     }
     wt$x$opts$dataset <- append(wt$x$opts$dataset[1], dsf)   # keep source-dataset [1]
-    wt$x$opts$options <- opts
+    wt$x$opts$options <- optm
     wt$x$opts$legend <- .merlis(wt$x$opts$legend, list(show=TRUE))  # needed for sub-group
   }
 
@@ -689,7 +688,7 @@ ec.init <- function( df= NULL, preset= TRUE, ctype= 'scatter', ...,
 #'
 #' @details ec.upd makes changes to chart elements already set by ec.init.\cr
 #' It should be always piped after ec.init.\cr
-#' Numerical indexes for series,visualMap,etc. are JS-counted (0,1...)\cr
+#' All numerical indexes for series,visualMap,etc. are JS-counted (0,1...)\cr
 #' Replaces syntax\cr
 #'   \verb{   }p <- ec.init(...)\cr
 #'   \verb{   }p$x$opts$series <- ...\cr
@@ -891,7 +890,7 @@ ecr.ebars <- function(wt, encode=list(x=1, y=c(2,3,4)), hwidth=6, ...) {
             out <- which(ds$dimensions %in% out)
           else {
             if (!is.null(ds$sourceHeader) && ds$sourceHeader)
-              # series.seriesLayoutBy
+              # TODO: series.seriesLayoutBy 
               out <- which(ds$source[[1]] %in% out)
             else {
               if (!class(ds$source[[1]]) %in% class(ds$source[[2]]))
@@ -910,17 +909,17 @@ 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'))
-    }
-  }
+  # # 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'
   oneSerie <- function(liss, ...) {
@@ -1157,7 +1156,11 @@ ec.plugjs <- function(wt=NULL, source=NULL, ask=FALSE) {
   }
   if (!is.null(ss$xAxisIndex)) ss$xAxisIndex <- ss$xAxisIndex -1
   if (!is.null(ss$yAxisIndex)) ss$yAxisIndex <- ss$yAxisIndex -1
-  #if (!is.null(ss$datasetIndex)) ss$datasetIndex <- ss$datasetIndex -1
+  if (!is.null(ss$datasetIndex)) ss$datasetIndex <- ss$datasetIndex -1
+  if (!is.null(ss$geoIndex)) ss$geoIndex <- ss$geoIndex -1
+  if (!is.null(ss$polarIndex)) ss$polarIndex <- ss$polarIndex -1
+  if (!is.null(ss$calendarIndex)) ss$calendarIndex <- ss$calendarIndex -1
+  if (!is.null(ss$radarIndex)) ss$radarIndex <- ss$radarIndex -1
   ss
 }
 

diff --git a/R/util.R b/R/util.R
@@ -766,7 +766,7 @@ ec.data <- function(df, format='dataset', header=FALSE, ...) {
           name= tmp[[i]][[grpcol]][1], 
           #tooltip= list(formatter= tbox), 
           encode= list(tooltip= ttip),
-          type= 'boxplot', datasetIndex= i+length(tmp)-1) ))
+          type= 'boxplot', datasetIndex= i+length(tmp)) ))  # will be decremented
       }
 	    axe <- paste0("function(v) { return ['",axe,"'][v]; }")
 

diff --git a/man/ec.upd.Rd b/man/ec.upd.Rd
diff --git a/tests/testthat/test-other.R b/tests/testthat/test-other.R
@@ -9,30 +9,29 @@ test_that("registerMap", {
      {"type":"Feature", "geometry":{"type":"MultiPolygon", "coordinates":[[[[2.333466,48.866204],[2.333061,48.86588],[2.332897,48.865906],[2.332466,48.865801],[2.332165,48.865776],[2.331811,48.865475],[2.331621,48.86532],[2.331466,48.865265],[2.331274,48.865283]]]]},
      	"properties":{"lat":48.859475,"lon":2.329466,"name":"bic2","range":1000, "id":"1 min"} },
      {"type":"Feature", "geometry":{"type":"MultiPolygon", "coordinates":[[[[2.335466,48.869736],[2.335037,48.870046],[2.334836,48.870105],[2.334466,48.870265],[2.334289,48.870298],[2.333577,48.870364],[2.333466,48.870381],[2.333364,48.870373],[2.332485,48.870456]]]]},
-     	"properties": {"lat":48.859475, "lon":2.329466, "name":"bic3", "range":1500, "id":"1.5 min"} }
+     	"properties": {"lat":48.859475,"lon":2.329466,"name":"bic3","range":1500, "id":"1.5 min"} }
   ]}')
   ext <- function(dd) { unlist(unname(sapply(gjson$features, \(f) {f$properties[dd]}))) }
-  vals <- ext('range')
-  dparis <- data.frame(name= ext('name'), value= vals)
+  #vals <- ext('range')
+  dparis <- data.frame(name= ext('name'), value= ext('range'))
   p <- ec.init(preset= FALSE,
     geo= list(map= 'paris', roam= TRUE),
     series =list(list(
-      type= 'map', geoIndex=0, coordinateSystem= 'geo',
+      type= 'map', coordinateSystem= 'geo', geoIndex=1,
       data= ec.data(dparis, 'names')
     )),
     visualMap= list(type='continuous', calculable=TRUE,
-      inRange= list(color = rainbow(8)),
-      min= min(vals), max= max(vals))
+      inRange= list(color = rainbow(8)) )
+      #,min= min(vals), max= max(vals))
   )
   p$x$registerMap <- list(list(mapName= 'paris', geoJSON= gjson))
   p
   expect_equal(length(p$x$registerMap[[1]]$geoJSON), 3)
   expect_equal(p$x$opts$geo$map, 'paris')
-  expect_equal(p$x$opts$series[[1]]$geoIndex, 0)
   expect_equal(p$x$opts$series[[1]]$data[[2]]$value, 1000)
 })
 
-test_that("tl.series, timeline options, groupby", {
+test_that("tl.series, timeline options, groupBy", {  # also in test-presets
   p <- Orange |> dplyr::group_by(age) |> ec.init(
     timeline= list(autoPlay=TRUE),
     tl.series= list(type='bar', encode=list(x='Tree', y='circumference'))
@@ -61,7 +60,6 @@ test_that("tl.series, timeline options, groupby", {
 })
 
 test_that("tl.series type 'map'", {
-#  if (interactive()) {
     cns <- data.frame(
       country = c('United States','China','Russia'),
       value = runif(3, 1, 100)
@@ -71,8 +69,7 @@ test_that("tl.series type 'map'", {
         visualMap= list(calculable=TRUE, max=100)
     )
     expect_equal(p$x$opts$options[[1]]$series[[1]]$data[[1]]$name, "China")
-#  }
-#  else expect_equal(1,1)
+    expect_equal(p$x$opts$options[[1]]$series[[1]]$geoIndex, 0)  # decremented
 })
 
 test_that("leaflet with ec.clmn and timeline", {

diff --git a/tests/testthat/test-presets.R b/tests/testthat/test-presets.R
@@ -37,13 +37,14 @@ test_that("ec.init presets for non-grouped data.frame", {
 
 test_that("ec.init presets for grouped data.frame", {
   p <- df |> dplyr::group_by(symbol) |> ec.init(yAxis= list(scale=TRUE, name='yaxe'))
-  expect_equal(p$x$opts$xAxis$type, 'category')
-  expect_equal(p$x$opts$yAxis$name, 'yaxe')
-  expect_equal(length(p$x$opts$dataset[[1]]$source), 11)
-  expect_equal(length(p$x$opts$legend$data), 3)
-  expect_equal(p$x$opts$series[[1]]$type, 'scatter')
-  expect_equal(p$x$opts$series[[1]]$datasetIndex, 1)
-  expect_equal(p$x$opts$series[[1]]$name, 'circle')
+  po <- p$x$opts
+  expect_equal(po$xAxis$type, 'category')
+  expect_equal(po$yAxis$name, 'yaxe')
+  expect_equal(length(po$dataset[[1]]$source), 11)
+  expect_equal(length(po$legend$data), 3)
+  expect_equal(po$series[[1]]$type, 'scatter')
+  expect_equal(po$series[[1]]$name, 'circle')
+  expect_equal(po$series[[2]]$datasetIndex, 2)
 })
 
 test_that("ec.init presets for timeline", {
@@ -78,11 +79,11 @@ test_that("ec.init presets for timeline groupBy", {
     x5 = abs(runif(16))
   ) 
   p <- dat |> group_by(x1) |> ec.init(
+    legend= list(show=TRUE),
     tl.series= list(encode= list(x= 'x3', y= 'x5'), 
                     symbolSize= ec.clmn('x4', scale=30),
                     groupBy= 'x2') 
   )
-  p$x$opts$legend <- list(show=TRUE)
   expect_equal(p$x$opts$options[[4]]$series[[1]]$type, 'scatter')
   expect_equal(p$x$opts$options[[4]]$series[[1]]$encode$y, 'x5')
   expect_equal(p$x$opts$yAxis$name, 'x5')