Support source-module wrapped analysis replay

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: jaspBase
 Type: Package
 Title: JASP Base
-Version: 0.20.4
+Version: 0.20.5
 Author: JASP Team
 Maintainer: Bruno Boutin <B.Boutin@uva.nl>
 Description: Package contains the JASP Bayesian and Frequentist analyses.

R/common.R

@@ -629,6 +629,7 @@ jaspResultsStrings <- function() {
     ".requestTempFileNameNative",
     ".requestTempRootNameNative",
     ".readDatasetToEndNative",
+    ".readFullDatasetToEnd",
     ".readDataSetHeaderNative",
     ".readDataSetRequestedNative",
     ".requestStateFileNameNative",
@@ -659,19 +660,20 @@ jaspResultsStrings <- function() {
 
 }
 
+.stateFilePath <- function(location) {
+  if (is.list(location) && !is.null(location$root) && !is.null(location$relativePath))
+    return(file.path(location$root, location$relativePath))
+
+  location$relativePath
+}
+
 .saveState <- function(state) {
   location <- .fromRCPP(".requestStateFileNameNative")
   relativePath <- location$relativePath
+  statePath <- .stateFilePath(location)
+  dir.create(dirname(statePath), recursive = TRUE, showWarnings = FALSE)
 
-  # when run through jaspTools do not save the state, but store it internally
-  if ("jaspTools" %in% loadedNamespaces()) {
-    # fool renv so it does not try to install jaspTools
-    .setInternal <- utils::getFromNamespace(".setInternal", asNamespace("jaspTools"))
-    .setInternal("state", state)
-    return(list(relativePath = relativePath))
-  }
-
-  try(suppressWarnings(base::save(state, file=relativePath, compress=FALSE)), silent = FALSE)
+  try(suppressWarnings(base::save(state, file=statePath, compress=FALSE)), silent = FALSE)
 
   return(list(relativePath = relativePath))
 }
@@ -683,9 +685,10 @@ jaspResultsStrings <- function() {
   if (base::exists(".requestStateFileNameNative")) {
 
     location <- .fromRCPP(".requestStateFileNameNative")
+    statePath <- .stateFilePath(location)
 
     base::tryCatch(
-      base::load(location$relativePath),
+      base::load(statePath),
       error=function(e) e
       #,warning=function(w) w #Commented out because if there *is* a warning, which there of course shouldnt be, the state wont be loaded *at all*.
     )
@@ -1163,18 +1166,49 @@ storeDataSet <- function(dataset) {
   jaspSyntax::loadDataSet(dataset)
 }
 
+.wrappedAnalysisQmlFile <- function(moduleName, qmlFileName, modulePath = NULL, qmlFile = NULL) {
+  isNonEmptyString <- function(x) is.character(x) && length(x) == 1 && !is.na(x) && nzchar(x)
+
+  if (isNonEmptyString(qmlFile))
+    return(normalizePath(qmlFile, winslash = "/", mustWork = FALSE))
+
+  if (isNonEmptyString(modulePath)) {
+    qmlCandidates <- file.path(modulePath, c("inst/qml", "qml"), qmlFileName)
+    existingQml <- qmlCandidates[file.exists(qmlCandidates)]
+    if (length(existingQml) > 0)
+      return(normalizePath(existingQml[[1]], winslash = "/", mustWork = FALSE))
+
+    return(normalizePath(qmlCandidates[[1]], winslash = "/", mustWork = FALSE))
+  }
+
+  normalizePath(file.path(find.package(moduleName), "qml", qmlFileName), winslash = "/", mustWork = FALSE)
+}
+
 #' @export
-runWrappedAnalysis <- function(moduleName, analysisName, qmlFileName, options, version, preloadData) {
+runWrappedAnalysis <- function(moduleName, analysisName, qmlFileName, options, version, preloadData, modulePath = NULL, qmlFile = NULL) {
   if (jaspResultsCalledFromJasp()) {
     # In this case, it is JASP Desktop that called the wrapper. This was done to parse the R code, and to get the arguments
     # in a structured way. In this way the Desktop can then set the options to the QML controls of the form, and this will run the analysis.
     # So here, just give back the parsed options.
-    return(toJSON(list("options" = options, "module" = moduleName, "analysis" = analysisName, "version" = version)))
+    response <- list(
+      "options"         = options,
+      "module"          = moduleName,
+      "analysis"        = analysisName,
+      "version"         = version,
+      "qmlFileName"     = qmlFileName,
+      "jaspBaseVersion" = as.character(utils::packageVersion("jaspBase")),
+      "source"          = "jaspBase::runWrappedAnalysis"
+    )
+    if (!is.null(modulePath))
+      response[["modulePath"]] <- modulePath
+    if (!is.null(qmlFile))
+      response[["qmlFile"]] <- qmlFile
+    return(toJSON(response))
 
   } else {
     # The wrapper is called inside an R environment (R Studio probably).
     # The options must be parsed and checked by the QML form, and then the real analysis can be called.
-    qmlFile <- file.path(find.package(moduleName), "qml", qmlFileName)
+    qmlFile <- .wrappedAnalysisQmlFile(moduleName, qmlFileName, modulePath, qmlFile)
     # Load the qml form, and set the right options (formula should be parsed and all logics set in QML should be checked), and run the analysis
     options <- jaspSyntax::loadQmlAndParseOptions(moduleName, analysisName, qmlFile, as.character(toJSON(options)), version, preloadData)
 

R/commonerrorcheck.R

@@ -432,6 +432,9 @@
     validValues <- x[is.finite(x)]
     variance <- -1 # Prevents the function from returning NA's
     if (length(validValues) > 1) {
+      if (is.factor(validValues)) {
+        validValues <- as.numeric(validValues)
+      }
       variance <- stats::var(validValues)
     }
     return(variance)

src/jaspResults.cpp

@@ -131,12 +131,18 @@ std::string jaspResults::getStatus()
 
 void jaspResults::prepareForWriting()
 {
+	if(_writeSealRoot + _writeSealRelative == "")
+		return;
+
 	//Remove the seal if it is there or not doesnt matter
 	BREMOVE((_writeSealRoot + _writeSealRelative).c_str());
 }
 
 void jaspResults::finishWriting()
 {
+	if(_writeSealRoot + _writeSealRelative == "")
+		return;
+
 	//Let us write a small file that tells us writing stuff went well ( https://github.com/jasp-stats/INTERNAL-jasp/issues/884 )
 	bofstream sealMe((_writeSealRoot + _writeSealRelative).c_str(), std::ios_base::trunc);
 
@@ -279,6 +285,9 @@ void jaspResults::send(std::string otherMsg)
 	jaspPrint("send was called!");
 #endif
 
+	if(!_insideJASP)
+		return;
+
 	if(_ipccSendFunc != nullptr)
 		(*_ipccSendFunc)(otherMsg == "" ? constructResultJson() : otherMsg.c_str());
 }

tests/testthat/test-commonerrorcheck.R

@@ -0,0 +1,8 @@
+testthat::test_that("variance checks handle factor variables", {
+  dataset <- data.frame(x = factor(c("a", "b", "a")))
+
+  result <- jaspBase:::.checkVariance(dataset, target = "x", equalTo = 0)
+
+  testthat::expect_false(result$error)
+  testthat::expect_null(result$errorVars)
+})

tests/testthat/test-runWrappedAnalysis.R

@@ -0,0 +1,118 @@
+testthat::test_that("wrapped analysis QML paths prefer explicit files", {
+  explicitFile <- tempfile(fileext = ".qml")
+  writeLines("import QtQuick", explicitFile)
+
+  qmlFile <- jaspBase:::.wrappedAnalysisQmlFile(
+    moduleName = "jaspBase",
+    qmlFileName = "Ignored.qml",
+    qmlFile = explicitFile
+  )
+
+  testthat::expect_equal(qmlFile, normalizePath(explicitFile, winslash = "/", mustWork = FALSE))
+})
+
+testthat::test_that("wrapped analysis QML paths resolve checkout module paths", {
+  modulePath <- tempfile("module")
+  qmlDir <- file.path(modulePath, "inst", "qml")
+  dir.create(qmlDir, recursive = TRUE)
+  qmlPath <- file.path(qmlDir, "Analysis.qml")
+  writeLines("import QtQuick", qmlPath)
+
+  qmlFile <- jaspBase:::.wrappedAnalysisQmlFile(
+    moduleName = "jaspBase",
+    qmlFileName = "Analysis.qml",
+    modulePath = modulePath
+  )
+
+  testthat::expect_equal(qmlFile, normalizePath(qmlPath, winslash = "/", mustWork = FALSE))
+})
+
+testthat::test_that("standalone bridge can read the full dataset callback", {
+  oldCallback <- if (exists(".readFullDatasetToEnd", envir = .GlobalEnv, inherits = FALSE)) {
+    get(".readFullDatasetToEnd", envir = .GlobalEnv, inherits = FALSE)
+  } else {
+    NULL
+  }
+  hadCallback <- exists(".readFullDatasetToEnd", envir = .GlobalEnv, inherits = FALSE)
+  on.exit({
+    if (hadCallback) {
+      assign(".readFullDatasetToEnd", oldCallback, envir = .GlobalEnv)
+    } else if (exists(".readFullDatasetToEnd", envir = .GlobalEnv, inherits = FALSE)) {
+      rm(".readFullDatasetToEnd", envir = .GlobalEnv)
+    }
+  }, add = TRUE)
+
+  assign(
+    ".readFullDatasetToEnd",
+    function() data.frame(x = 1, check.names = FALSE),
+    envir = .GlobalEnv
+  )
+
+  testthat::expect_equal(
+    jaspBase:::.fromRCPP(".readFullDatasetToEnd"),
+    data.frame(x = 1, check.names = FALSE)
+  )
+})
+
+testthat::test_that("standalone state saving uses the callback file contract", {
+  oldCallback <- if (exists(".requestStateFileNameNative", envir = .GlobalEnv, inherits = FALSE)) {
+    get(".requestStateFileNameNative", envir = .GlobalEnv, inherits = FALSE)
+  } else {
+    NULL
+  }
+  hadCallback <- exists(".requestStateFileNameNative", envir = .GlobalEnv, inherits = FALSE)
+  on.exit({
+    if (hadCallback) {
+      assign(".requestStateFileNameNative", oldCallback, envir = .GlobalEnv)
+    } else if (exists(".requestStateFileNameNative", envir = .GlobalEnv, inherits = FALSE)) {
+      rm(".requestStateFileNameNative", envir = .GlobalEnv)
+    }
+  }, add = TRUE)
+
+  stateFile <- tempfile("jasp-state-")
+  assign(
+    ".requestStateFileNameNative",
+    function() list(root = dirname(stateFile), relativePath = basename(stateFile)),
+    envir = .GlobalEnv
+  )
+
+  savedState <- list(figures = list(), other = list(answer = 42))
+  result <- jaspBase:::.saveState(savedState)
+  loaded <- load(stateFile)
+
+  testthat::expect_equal(result$relativePath, basename(stateFile))
+  testthat::expect_identical(loaded, "state")
+  testthat::expect_equal(state, savedState)
+})
+
+testthat::test_that("standalone state retrieval uses the callback root", {
+  oldCallback <- if (exists(".requestStateFileNameNative", envir = .GlobalEnv, inherits = FALSE)) {
+    get(".requestStateFileNameNative", envir = .GlobalEnv, inherits = FALSE)
+  } else {
+    NULL
+  }
+  hadCallback <- exists(".requestStateFileNameNative", envir = .GlobalEnv, inherits = FALSE)
+  on.exit({
+    if (hadCallback) {
+      assign(".requestStateFileNameNative", oldCallback, envir = .GlobalEnv)
+    } else if (exists(".requestStateFileNameNative", envir = .GlobalEnv, inherits = FALSE)) {
+      rm(".requestStateFileNameNative", envir = .GlobalEnv)
+    }
+  }, add = TRUE)
+
+  stateFile <- tempfile("jasp-state-")
+  assign(
+    ".requestStateFileNameNative",
+    function() list(root = dirname(stateFile), relativePath = basename(stateFile)),
+    envir = .GlobalEnv
+  )
+
+  state <- list(figures = list(), other = list(answer = 42))
+  save(state, file = stateFile, compress = FALSE)
+  rm(state)
+
+  testthat::expect_equal(
+    jaspBase:::.retrieveState(),
+    list(figures = list(), other = list(answer = 42))
+  )
+})