Use {shinytest2} and fix final hint behavior (#695)

DESCRIPTION

@@ -62,7 +62,7 @@ Suggests:
     later,
     RSQLite,
     rstudioapi (>= 0.11),
-    shinytest (>= 1.5.0),
+    shinytest2,
     testthat (>= 3.0.3)
 VignetteBuilder:
     knitr

NEWS.md

@@ -178,6 +178,8 @@
 
 -   `learnr::tutorial()` now allows authors to adjust the value of `lib_dir` (#648).
 
+-   learnr now uses and suggests [shinytest2](https://rstudio.github.io/shinytest2) for automated testing of tutorials in the browser. If you were previously using [shinytest](https://rstudio.github.io/shinytest) to test your tutorials, you may find the [Migrating from shinytest](https://rstudio.github.io/shinytest2/articles/z-migration.html) article to be helpful (#694).
+
 # learnr 0.10.1
 
 ## New features

R/exercise.R

@@ -301,7 +301,7 @@ standardize_code <- function(code) {
     return("")
   }
   # convert CRLF to POSIX line endings
-  code <- gsub("\r", "", code, fixed = TRUE)
+  code <- gsub("\r\n", "\n", code, fixed = TRUE)
   str_trim(paste0(code, collapse = "\n"))
 }
 

R/shinytest.R

@@ -1,7 +1,7 @@
 # Input processor, for generating code in shinytest Recorder app
 register_shinytest_inputprocessor <- function() {
-  if (is_installed("shinytest", "1.4.0.9002")) {
-    shinytest::registerInputProcessor("learnr.exercise", function(value) {
+  if (is_installed("shinytest2", "0.1.0")) {
+    shinytest2::register_input_processor("learnr.exercise", function(value) {
       # Drop all information from `value` except `code`.
       value <- value["code"]
       dput_to_string(value)

R/zzz.R

@@ -22,11 +22,11 @@
   })
 
 
-  if ("shinytest" %in% loadedNamespaces()) {
+  if ("shinytest2" %in% loadedNamespaces()) {
     register_shinytest_inputprocessor()
   }
   setHook(
-    packageEvent("shinytest", "onLoad"),
+    packageEvent("shinytest2", "onLoad"),
     function(...) register_shinytest_inputprocessor()
   )
 }

learnr-js/tutorial/tutorial.js

@@ -1360,11 +1360,13 @@ Tutorial.prototype.$addSolution = function (exercise, panelHeading, editor) {
               solutionEditor.setValue(hints[hintIndex], -1)
               if (hintIndex === hints.length - 1) {
                 nextHintButton.addClass('disabled')
+                nextHintButton.prop('disabled', true)
               }
               recordHintRequest(hintIndex)
             })
             if (hintIndex === hints.length - 1) {
               nextHintButton.addClass('disabled')
+              nextHintButton.prop('disabled', true)
             }
             popoverTitle.append(nextHintButton)
           }

tests/manual/.gitignore

@@ -1 +1,2 @@
 *.html
+rsconnect/*

tests/testthat/helpers-shinytest2.R

@@ -0,0 +1,200 @@
+library(shinytest2)
+
+selector_exists <- function(selector, ...) {
+  if (length(c(...))) {
+    selector <- paste(selector, paste(c(...), collapse = " "))
+  }
+  sprintf(
+    "document.querySelector('%s') ? true : false",
+    selector
+  )
+}
+
+selector_doesnt_exist <- function(selector, ...) {
+  if (length(c(...))) {
+    selector <- paste(selector, paste(c(...), collapse = " "))
+  }
+  sprintf(
+    "document.querySelector('%s') ? false : true",
+    selector
+  )
+}
+
+selector_classlist <- function(selector, ...) {
+  if (length(c(...))) {
+    selector <- paste(selector, paste(c(...), collapse = " "))
+  }
+  sprintf(
+    "[...document.querySelector('%s').classList]",
+    selector
+  )
+}
+
+selector_attributes <- function(selector, ...) {
+  if (length(c(...))) {
+    selector <- paste(selector, paste(c(...), collapse = " "))
+  }
+  sprintf(
+    "{
+const el = document.querySelector('%s')
+!el ? {} : el.getAttributeNames()
+  .reduce((acc, attr) => {
+    acc[attr] = el.getAttribute(attr)
+    return acc
+  }, {})
+}",
+    selector
+  )
+}
+
+selector_coordinates <- function(selector, ...) {
+  if (length(c(...))) {
+    selector <- paste(selector, paste(c(...), collapse = " "))
+  }
+  sprintf(
+    "(function() {
+      const el = document.querySelector('%s')
+      if (!el) {
+        return undefined
+      }
+      const {top, right, bottom, left, width, height, x, y} = el.getBoundingClientRect()
+      return {top, right, bottom, left, width, height, x, y}
+    })()",
+    selector
+  )
+}
+
+get_editor_value <- function(selector, ...) {
+  if (length(c(...))) {
+    selector <- paste(selector, paste(c(...), collapse = " "))
+  }
+  sprintf(
+    "ace.edit(document.querySelector('%s')).getValue()",
+    selector
+  )
+}
+
+editor_has_focus <- function(selector, ...) {
+ if (length(c(...))) {
+    selector <- paste(selector, paste(c(...), collapse = " "))
+  }
+  sprintf(
+    "$(':focus')[0] === document.querySelector('%s textarea')",
+    selector
+  )
+}
+
+exercise_selector <- function(id) {
+  sprintf(
+    "#tutorial-exercise-%s-input",
+    id
+  )
+}
+
+exercise_selector_editor <- function(id) {
+  sprintf(
+    "%s .ace_editor",
+    exercise_selector(id)
+  )
+}
+
+exercise_selector_hint_btn <- function(id) {
+  sprintf(
+    "%s .btn-tutorial-hint",
+    exercise_selector(id)
+  )
+}
+
+exercise_selector_run_btn <- function(id) {
+  sprintf(
+    "%s .btn-tutorial-run",
+    exercise_selector(id)
+  )
+}
+
+exercise_selector_hint_popover <- function(id) {
+  sprintf(
+    "%s > .tutorial-panel-heading .tutorial-solution-popover",
+    exercise_selector(id)
+  )
+}
+
+exercise_selector_output <- function(id) {
+  sprintf(
+    "#tutorial-exercise-%s-output",
+    id
+  )
+}
+
+exercise_has_output <- function(id) {
+  sprintf(
+    "document.querySelector('%s').children.length > 0 ? true : false",
+    exercise_selector_output(id)
+  )
+}
+
+app_real_click <- function(app, selector, ...) {
+  chrome <- app$get_chromote_session()
+
+  dims <- app$get_js(selector_coordinates(selector, ...))
+
+  for (event in c("mousePressed", "mouseReleased")) {
+    chrome$Input$dispatchMouseEvent(
+      type = event,
+      x = dims$left + dims$width / 2,
+      y = dims$top  + dims$height / 2,
+      clickCount = 1,
+      pointerType = "mouse",
+      button = "left",
+      buttons = 1
+    )
+  }
+
+  invisible(app)
+}
+
+if (!"expect" %in% names(shinytest2::AppDriver$public_methods)) {
+  # shinytest2::AppDriver$set("public", "with", function(expr) {
+  #   expr <- rlang::enexpr(expr)
+  #   rlang::eval_tidy(expr, data = rlang::new_data_mask(self))
+  #   invisible(self)
+  # })
+
+  shinytest2::AppDriver$set("public", "expect", function(name, object, expected, ...) {
+    stopifnot(length(name) == 1)
+    name <- tolower(name)
+    if (identical(name, "succeed")) {
+      testthat::succeed(...)
+      return(invisible(self))
+    }
+
+    allowed_expectactions <- c(
+      "null", "true", "equal", "match", "false", "length", "no_match", "setequal"
+    )
+
+    if (!name %in% allowed_expectactions) {
+      rlang::abort(sprintf(
+        "'%s' is not one of the supported expectations: %s",
+        name,
+        paste(allowed_expectactions, collapse = ", ")
+      ))
+    }
+
+    dots <- list(...)
+    self_mask <- rlang::new_data_mask(self)
+
+    if (!missing(object)) {
+      object <- rlang::enquo(object)
+      dots$object <- rlang::eval_tidy(object, self_mask)
+    }
+    if (!missing(expected)) {
+      expected <- rlang::enquo(expected)
+      dots$expected <- rlang::eval_tidy(expected, self_mask)
+    }
+
+    call <- rlang::call2(.fn = paste0("expect_", name), !!!dots, .ns = "testthat")
+    rlang::eval_bare(call)
+
+    invisible(self)
+  })
+}

tests/testthat/test-shinytest2-aaa.R

@@ -0,0 +1,17 @@
+# https://github.com/rstudio/shinytest2/blob/c29b78e9/tests/testthat/test-aaa.R
+skip_on_cran() # Uses chromote
+
+# Try to warm up chromote. IDK why it fails on older versions of R.
+test_that("Chromote loads", {
+  on_ci <- isTRUE(as.logical(Sys.getenv("CI")))
+  skip_if(!on_ci, "Not on CI")
+
+  # Wrap in a `try()` as the test doesn't matter
+  # Only the action of trying to open chromote matters
+  try({
+    chromote <- utils::getFromNamespace("default_chromote_object", "chromote")()
+    chromote$new_session()
+  })
+
+  expect_true(TRUE)
+})