Merge pull request #185 from animint/fix-tour-in-Rmd

fix tour in Rmd

NEWS.md

@@ -1,5 +1,9 @@
 # Changes in version 2025.1.26
 
+## PR#185
+
+- Tour highlights the geom in the correct plot (instead of always the first viz on the page).
+
 ## PR#186
 
 - `geom_abline()`: fix and vectorize `pre_process()` method.
@@ -8,6 +12,7 @@
 
 - Add simple Hello world example to ?animint.
 - Increase text size of "a" in legend SVG.
+>>>>>>> master
 
 # Changes in version 2025.1.25 (PR#182)
 

inst/htmljs/animint.js

@@ -186,7 +186,6 @@ var animint = function (to_select, json_file) {
   var add_geom = function (g_name, g_info) {
     // Determine if data will be an object or an array.
     // added geom properties in steps array
-    console.log(g_info);
     var geom = g_info.classed;
     var title = g_info.params.title || g_info.classed;
     var helpText = g_info.params.help || '';
@@ -205,7 +204,7 @@ var animint = function (to_select, json_file) {
       description = "No interactions available";
     }
     steps.push({  // this add the geom to the steps array for guided tour
-      element: '.' + geom,
+      element: '#' + viz_id + ' .' + geom,
       popover: {
         title: title,
         description: description

tests/testthat/test-renderer2-param-off.R

@@ -161,7 +161,7 @@ col.vec <- paste("col", c(1:3))
 heat.data <- data.table(row.name = row.vec,
   col.name = rep(col.vec, each=length(row.vec)),
   value = c(2,8,-5,-7,15,3,-1,6,-7.5))
-viz.tile <- list(
+viz.tile <- animint(
   default=ggplot() +
     geom_tile(aes(
       x = row.name, y = col.name, fill = value),

tests/testthat/test-renderer1-knit-print.R → tests/testthat/test-renderer3-knit-print.R

@@ -155,43 +155,88 @@ test_that("bottom widget adds/remove points", {
   expect_equal(get_circles(), list(10, 10))
 })
 
+click_center <- function(id){
+  script <- sprintf("document.getElementById('%s').scrollIntoView(true);", id)
+  runtime_evaluate(script=script)
+  x <- remDr$DOM$getDocument()
+  x <- remDr$DOM$querySelector(x$root$nodeId, paste0("#",id))
+  x <- remDr$DOM$getBoxModel(x$nodeId)
+  m <- matrix(as.numeric(x$model$content), 4, 2,byrow=TRUE, dimnames=list(
+    corner=c("left_top", "right_top", "right_bottom", "left_bottom"),
+    dim=c("x","y")))
+  xy <- as.list((m["left_top",]+m["right_bottom",])/2)
+  for(type in c("mousePressed", "mouseReleased")){
+    L <- c(xy, button="left", clickCount=1, type=type)
+    ## https://github.com/rstudio/chromote/issues/32
+    do.call(remDr$Input$dispatchMouseEvent, L)
+  }
+}
+
 djs.init.list <- driverjs_get(html)
+expected.driver.empty <- list(title=list(), description=list())
 test_that("knit driver initially shows nothing", {
-  expect_identical(djs.init.list, list(title=list(), description=list()))
+  expect_identical(djs.init.list, expected.driver.empty)
 })
 
 djs.start0.list <- driverjs_start(0)
+expected.driver.top <- list(
+  title = list(
+    text = "geom1_point_q",
+    .attrs = c(
+      class = "driver-popover-title", 
+      style = "display: block;")),
+  description = list(
+    text = "first plot",
+    br=NULL,
+    text="Data are shown for the current selection of: label",
+    .attrs = c(
+      class = "driver-popover-description",
+      style = "display: block;"
+    )))
 test_that("knit driver start first plot", {
-  expect_identical(djs.start0.list, list(
-    title = list(
-      text = "geom1_point_q",
-      .attrs = c(
-        class = "driver-popover-title", 
-        style = "display: block;")),
-    description = list(
-      text = "first plot",
-      br=NULL,
-      text="Data are shown for the current selection of: label",
-      .attrs = c(
-        class = "driver-popover-description",
-        style = "display: block;"
-    ))))
+  expect_identical(djs.start0.list, expected.driver.top)
+})
+
+click_center("plot1top_q")
+djs.start0.top.list <- driverjs_get()
+test_that("clicking top plot keeps driver open", {
+  expect_identical(djs.start0.top.list, expected.driver.top)
+})
+
+click_center("plot1bottom_q")
+djs.start0.bottom.list <- driverjs_get()
+test_that("clicking bottom plot closes driver", {
+  expect_identical(djs.start0.bottom.list, expected.driver.empty)
 })
 
+expected.driver.bottom <- list(
+  title = list(
+    text = "geom1_point_q",
+    .attrs = c(
+      class = "driver-popover-title", 
+      style = "display: block;")),
+  description = list(
+    text = "second plot", 
+    br=NULL,
+    text="Data are shown for the current selection of: label",
+    .attrs = c(
+      class = "driver-popover-description",
+      style = "display: block;"
+    )))
 djs.start1.list <- driverjs_start(1)
 test_that("knit driver start second plot", {
-  expect_identical(djs.start1.list, list(
-    title = list(
-      text = "geom1_point_q",
-      .attrs = c(
-        class = "driver-popover-title", 
-        style = "display: block;")),
-    description = list(
-      text = "second plot", 
-      br=NULL,
-      text="Data are shown for the current selection of: label",
-      .attrs = c(
-        class = "driver-popover-description",
-        style = "display: block;"
-    ))))
+  expect_identical(djs.start1.list, expected.driver.bottom)
+})
+
+click_center("plot1bottom_q")
+djs.start1.bottom.list <- driverjs_get()
+test_that("clicking bottom plot keeps driver open", {
+  expect_identical(djs.start1.bottom.list, expected.driver.bottom)
 })
+
+click_center("plot1top_q")
+djs.start1.top.list <- driverjs_get()
+test_that("clicking top plot closes driver", {
+  expect_identical(djs.start1.top.list, expected.driver.empty)
+})
+