From fd212e4724b258d20efc734be6c67d98d86fcb41 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Thu, 14 May 2026 13:57:17 +0200 Subject: [PATCH 1/9] Migrate local analysis replay to jaspSyntax --- DESCRIPTION | 5 +- Developers-note.md | 9 +- NAMESPACE | 15 +- R/dataset.R | 1003 ++++------------ R/option-state.R | 8 + R/options-parser-qml.R | 329 ----- R/options.R | 681 +++++------ R/pkg-setup.R | 3 + R/rbridge.R | 138 ++- R/run.R | 457 ++++++- R/subprocess.R | 167 +++ R/test-generator.R | 315 +++-- R/testthat-helper-tables.R | 37 +- R/view.R | 3 +- R/zzz.R | 5 +- README.md | 27 +- man/addTypedDataSet.Rd | 49 - man/analysisOptions.Rd | 14 +- man/analysisRuntimeOptions.Rd | 26 + man/createEncodedDataset.Rd | 20 - man/encodeOptionsAndDataset.Rd | 66 - man/encodeOptionsWithMap.Rd | 22 - man/extractDatasetFromJASPFile.Rd | 30 +- man/extractPairsFromValueAndType.Rd | 22 - man/extractVariableTypePairs.Rd | 20 - man/generateExampleTestBlock.Rd | 3 +- man/generateExampleTestBlockBasic.Rd | 3 +- man/makeTestsFromExamples.Rd | 11 +- man/makeTestsFromSingleJASPFile.Rd | 3 +- man/runAnalysis.Rd | 18 +- man/view.Rd | 2 +- tests/testthat/test-analysisOptions.R | 329 +++-- tests/testthat/test-encodeOptionsAndDataset.R | 605 ---------- tests/testthat/test-expect-equal-tables.R | 41 + .../test-extractDatasetFromJASPfile.R | 9 +- tests/testthat/test-generated-example-tests.R | 220 ++++ tests/testthat/test-jaspSyntax-lifecycle.R | 1057 +++++++++++++++++ tests/testthat/test-rbridge-shim.R | 218 ++++ 38 files changed, 3368 insertions(+), 2622 deletions(-) create mode 100644 R/option-state.R delete mode 100644 R/options-parser-qml.R create mode 100644 R/subprocess.R delete mode 100644 man/addTypedDataSet.Rd create mode 100644 man/analysisRuntimeOptions.Rd delete mode 100644 man/createEncodedDataset.Rd delete mode 100644 man/encodeOptionsAndDataset.Rd delete mode 100644 man/encodeOptionsWithMap.Rd delete mode 100644 man/extractPairsFromValueAndType.Rd delete mode 100644 man/extractVariableTypePairs.Rd delete mode 100644 tests/testthat/test-encodeOptionsAndDataset.R create mode 100644 tests/testthat/test-expect-equal-tables.R create mode 100644 tests/testthat/test-generated-example-tests.R create mode 100644 tests/testthat/test-jaspSyntax-lifecycle.R create mode 100644 tests/testthat/test-rbridge-shim.R diff --git a/DESCRIPTION b/DESCRIPTION index c47d586..bf254ac 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -12,17 +12,16 @@ License: GNU General Public License Encoding: UTF-8 LazyData: true Imports: - archive (>= 1.1.6), cli, data.table, - DBI, httr, + jaspBase (>= 0.20.5), + jaspSyntax (>= 1.3.2), jsonlite, lifecycle, pkgload, remotes, rjson, - RSQLite, stringi, stringr, testthat (>= 3.2.2), diff --git a/Developers-note.md b/Developers-note.md index 07e0fc7..d3bcd84 100644 --- a/Developers-note.md +++ b/Developers-note.md @@ -10,7 +10,7 @@ jasptools uses three different mechanisms to share variables between inner funct 1. `.internal`: environment that holds internal variables; these are used to pass information between functions. The state entry is special, because it interfaces directly with the JASP code. Rather than storing and then loading the state, it is passed to jasptools, which is much faster. 2. `.pkgOptions`: environment that holds variables to be changed by users; mainly paths to resources. -3. global variables: the rbridge in JASP defines certain global variables that JASP assumes are always globally accessible and these need to be matched in jasptools. They include `perform`, `.ppi` and `.baseCitation` (the global functions on the other hand are defined in the jasptools file rbridge.R). Global variables are set every time `run` is called through `.setRCPPMasks`. +3. rbridge namespace objects: JASP Desktop defines Rcpp-backed objects that `jaspBase:::.fromRCPP()` can request while an analysis runs. `jaspTools` now keeps only the local developer-execution subset in its namespace, such as `.ppi`, `.baseCitation`, plot/state file providers, and `.imageBackground`. Dataset loading and column encode/decode semantics belong to `jaspSyntax`/SyntaxInterface or Desktop. #### Handling of S3 methods Currently it is necessary to export the S3 methods used for generic functions in JASP (e.g., those defined in `common.R`). @@ -22,8 +22,5 @@ jasp-desktop follows a fixed structure, meaning that in every development enviro Once jasptools verifies that it is located within /Tools/ it converts the relative paths to the resources to absolute paths. Now, if these resources are changed, jasptools will need to be adjusted. Firstly, `zzz.R` needs to be modified where it states `# set locations of all required resources (json, analyses, html, packages)` and secondly `.pkgOptions` in `pkg-settings.R` must reflect the same changes. -#### Changing to TOML -At the moment jasptools only supports JSON format for the description files. -Should we decide to change this in the future, then the functions that interface with the description file must be adapted. -These functions can be found in `options.R` (`.analysisOptionsFromFile`), `main.R` (`run`) and in `utils.R` (`.getJSON`). -It is not a problem that the code that is send to `view` still uses JSON as this is unlikely to change. \ No newline at end of file +#### jaspSyntax boundary +jaspTools now delegates module description parsing, QML option parsing, saved `.jasp` option extraction, and `.jasp` dataset extraction to `jaspSyntax`. The developer-facing contract lives in `options.R`, `dataset.R`, `run.R`, and `test-generator.R`; lower-level Desktop/SyntaxInterface behavior should stay in `jaspSyntax` rather than being reimplemented here. diff --git a/NAMESPACE b/NAMESPACE index 31dc490..05a3235 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,24 +2,11 @@ S3method(expect_doppelganger_fallback,default) S3method(expect_doppelganger_fallback,ggplot) -S3method(extractData,AssignedVariablesList) -S3method(extractData,CIField) -S3method(extractData,CheckBox) -S3method(extractData,Chi2TestTableView) -S3method(extractData,DoubleField) -S3method(extractData,DropDown) -S3method(extractData,IntegerField) -S3method(extractData,PercentField) -S3method(extractData,RadioButtonGroup) -S3method(extractData,Slider) -S3method(extractData,default) -S3method(extractData,repeatedMeasuresFactorsList) S3method(print,jaspAgentTestResults) -export(addTypedDataSet) export(agentTestAll) export(agentTestAnalysis) export(analysisOptions) -export(encodeOptionsAndDataset) +export(analysisRuntimeOptions) export(expect_equal_plots) export(expect_equal_tables) export(extractDatasetFromJASPFile) diff --git a/R/dataset.R b/R/dataset.R index 11ae89b..96f84c5 100644 --- a/R/dataset.R +++ b/R/dataset.R @@ -1,32 +1,20 @@ #' Extract a Dataset from a JASP File #' -#' This function extracts the dataset from a saved JASP file (.jasp) and returns -#' it as a data.frame. JASP files are zip archives containing an SQLite database -#' with the data and metadata. +#' Thin compatibility wrapper around `jaspSyntax::readDatasetFromJaspFile()`. #' #' @param jaspFile Character string specifying the path to the .jasp file. #' @param dataSetIndex Integer specifying which dataset to extract if the JASP -#' file contains multiple datasets. Default is 1 (the first dataset). +#' file contains multiple datasets. Currently only `1L` is supported because +#' that is the index supported by the `jaspSyntax` backend. #' -#' @return A data.frame containing the extracted dataset with proper column names, -#' types, and factor levels. +#' @return Either a data.frame containing the extracted dataset or `NULL` when +#' the `.jasp` file does not contain tabular data. #' #' @details -#' The function performs the following steps: -#' \itemize{ -#' \item Unpacking the .jasp archive (which is a zip file) -#' \item Reading the internal.sqlite database -#' \item Converting Column_N_DBL and Column_N_INT columns to properly named columns -#' \item Mapping factor levels from the Labels table to create proper R factors -#' \item Handling both explicitly nominal columns and columns with label mappings -#' } -#' -#' Special values like NA, NaN, and Inf are handled appropriately: -#' \itemize{ -#' \item "nan" values in DBL columns are converted to NA -#' \item "inf" values in DBL columns are converted to Inf -#' \item -1 values in INT columns typically indicate missing values -#' } +#' `jaspTools` now relies on `jaspSyntax` for reading datasets from saved JASP +#' files, so the native `.jasp` decoding and dataset reconstruction logic lives +#' in one place. Numeric columns, including `Inf` and `-Inf`, are returned +#' directly from the `jaspSyntax` backend without additional post-processing. #' #' @examples #' \dontrun{ @@ -39,162 +27,135 @@ #' #' @export extractDatasetFromJASPFile <- function(jaspFile, dataSetIndex = 1L) { + .jaspSyntaxReadDatasetFromJaspFile(jaspFile, dataSetIndex = dataSetIndex) +} - if (!file.exists(jaspFile)) { - stop("File not found: ", jaspFile) - } - - if (!grepl("\\.jasp$", jaspFile, ignore.case = TRUE)) { - stop("File must have a .jasp extension") +.jaspSyntaxReadDatasetFromJaspFile <- function(jaspFile, dataSetIndex = 1L) { + if (!exists("readDatasetFromJaspFile", envir = asNamespace("jaspSyntax"), inherits = FALSE)) { + stop( + "Installed jaspSyntax does not provide `readDatasetFromJaspFile()`. ", + "Install the jaspSyntax build that contains the dataset reader API." + ) } - # Create a temporary directory to extract the JASP file - tempDir <- tempfile("jasp_extract_") - dir.create(tempDir) - on.exit(unlink(tempDir, recursive = TRUE), add = TRUE) - - # Extract the JASP file (it's a zip archive) - utils::unzip(jaspFile, exdir = tempDir) + jaspSyntax::readDatasetFromJaspFile(jaspFile, dataSetIndex = dataSetIndex) +} +.jaspSyntaxHelper <- function(names, required = TRUE, feature = "jaspSyntax bridge API") { + helperName <- .jaspSyntaxHelperName(names, required = required, feature = feature) + if (is.null(helperName)) + return(NULL) - # Check for internal.sqlite + get(helperName, envir = asNamespace("jaspSyntax"), inherits = FALSE) +} - sqlitePath <- file.path(tempDir, "internal.sqlite") - if (!file.exists(sqlitePath)) { - stop("No internal.sqlite found in the JASP file. The file may be corrupted or from an incompatible version.") +.jaspSyntaxHelperName <- function(names, required = TRUE, feature = "jaspSyntax bridge API") { + namespace <- asNamespace("jaspSyntax") + for (name in names) { + if (exists(name, envir = namespace, inherits = FALSE)) + return(name) } - con <- DBI::dbConnect(RSQLite::SQLite(), sqlitePath) - on.exit(DBI::dbDisconnect(con), add = TRUE) + if (isTRUE(required)) { + stop( + "Installed jaspSyntax does not provide `", names[[1L]], "()`. ", + "Install the jaspSyntax build that exposes the ", feature, "." + ) + } - # Get column metadata - columns <- DBI::dbGetQuery(con, sprintf( - "SELECT id, name, columnType, colIdx FROM Columns WHERE dataSet = %d ORDER BY colIdx", - dataSetIndex - )) + NULL +} - if (nrow(columns) == 0) { - # No data in this JASP file - return NULL - return(NULL) +.callWithSupportedArgs <- function(fun, args, requiredArgs = names(args), + requiredArgGroups = list(), + functionName = "jaspSyntax bridge function", + feature = "jaspSyntax bridge API") { + funFormals <- tryCatch(names(formals(fun)), error = function(e) NULL) + if (is.null(funFormals) || "..." %in% funFormals) + return(do.call(fun, args)) + + missingRequired <- setdiff(requiredArgs, funFormals) + missingGroups <- vapply(requiredArgGroups, function(group) { + !any(group %in% funFormals) + }, logical(1L)) + + if (length(missingRequired) > 0L || any(missingGroups)) { + missingArgs <- c( + missingRequired, + vapply(requiredArgGroups[missingGroups], paste, character(1L), collapse = " or ") + ) + stop( + "Installed ", functionName, " does not support required bridge argument", + if (length(missingArgs) == 1L) "" else "s", + ": ", paste(missingArgs, collapse = ", "), ". ", + "Install the jaspSyntax build that exposes the ", feature, ".", + call. = FALSE + ) } - # Get the labels table - include originalValueJson for value reconstruction - labels <- DBI::dbGetQuery(con, "SELECT columnId, value, label, originalValueJson FROM Labels ORDER BY columnId, value") + do.call(fun, args[intersect(names(args), funFormals)]) +} - # Get the data from DataSet_N table - dataTableName <- paste0("DataSet_", dataSetIndex) - if (!dataTableName %in% DBI::dbListTables(con)) { - # No data table in this JASP file - return NULL +.jaspSyntaxCall <- function(names, args = list(), required = TRUE, + feature = "jaspSyntax bridge API", + requiredArgs = names(args), + requiredArgGroups = list()) { + helperName <- .jaspSyntaxHelperName(names, required = required, feature = feature) + if (is.null(helperName)) return(NULL) - } - # Build a query that casts DBL columns to TEXT to preserve nan/inf values - # SQLite's R driver coerces mixed-type columns, losing "nan" values - dataColNames <- DBI::dbListFields(con, dataTableName) - selectParts <- vapply(dataColNames, function(colName) { - if (grepl("_DBL$", colName)) { - sprintf("CAST(%s AS TEXT) AS %s", colName, colName) - } else { - colName - } - }, character(1L)) - selectQuery <- sprintf("SELECT %s FROM %s ORDER BY rowNumber", - paste(selectParts, collapse = ", "), dataTableName) - - # Read the raw data with DBL columns as text - rawData <- DBI::dbGetQuery(con, selectQuery) - - # Build the result data.frame - result <- data.frame(row.names = seq_len(nrow(rawData))) - - for (i in seq_len(nrow(columns))) { - colId <- columns$id[i] - colName <- columns$name[i] - colType <- columns$columnType[i] - colIdx <- columns$colIdx[i] + 1 # SQLite uses 0-based indexing - - # Column names in the raw data - dblColName <- paste0("Column_", colIdx, "_DBL") - intColName <- paste0("Column_", colIdx, "_INT") - - # Get labels for this column - colLabels <- labels[labels$columnId == colId, ] - - if (colType %in% c("nominal", "nominalText", "ordinal")) { - # This is a categorical column - use INT values mapped to labels - intValues <- rawData[[intColName]] - - # Check if there are labels with actual text - hasTextLabels <- nrow(colLabels) > 0 && any(nzchar(colLabels$label)) - - if (hasTextLabels) { - # Create a lookup from value to label - labelLookup <- stats::setNames(colLabels$label, as.character(colLabels$value)) - - # Map integer values to labels - # -1 typically means NA - charValues <- ifelse(intValues == -1, NA_character_, labelLookup[as.character(intValues)]) - result[[colName]] <- charValues - } else { - # No text labels - check if we have originalValueJson to reconstruct values - # This handles cases like binary 0/1 columns where JASP stores the original values - if (nrow(colLabels) > 0 && any(nzchar(colLabels$originalValueJson))) { - # Parse original values from JSON - they're typically "value\n" format - originalValues <- gsub("\\s*\n$", "", colLabels$originalValueJson) - # Try to convert to numeric - numericOriginal <- suppressWarnings(as.numeric(originalValues)) - - if (!any(is.na(numericOriginal))) { - # All values are numeric - create a lookup - valueLookup <- stats::setNames(numericOriginal, as.character(colLabels$value)) - result[[colName]] <- ifelse(intValues == -1, NA_integer_, - as.integer(valueLookup[as.character(intValues)])) - } else { - # Non-numeric original values - use as character - valueLookup <- stats::setNames(originalValues, as.character(colLabels$value)) - result[[colName]] <- ifelse(intValues == -1, NA_character_, - valueLookup[as.character(intValues)]) - } - } else { - # Fallback: use the integer values directly - result[[colName]] <- ifelse(intValues == -1, NA_integer_, intValues) - } - } - } else { - # Scale (numeric) column - use DBL values - dblValues <- rawData[[dblColName]] - - # Handle special string values in DBL column - if (is.character(dblValues) || (is.list(dblValues))) { - dblValues <- as.character(dblValues) - dblValuesLower <- tolower(dblValues) - - # Check if this column contains infinity values - hasInf <- any(dblValuesLower == "inf" | dblValuesLower == "-inf") - - if (hasInf) { - # Column has infinity - convert to character with Unicode infinity symbol - charValues <- dblValues - charValues[dblValuesLower == "nan"] <- NA_character_ - charValues[dblValuesLower == "inf"] <- "\u221e" # ∞ - charValues[dblValuesLower == "-inf"] <- "-\u221e" # -∞ - - # Try to convert non-special values to maintain precision display - normalIdx <- !dblValuesLower %in% c("nan", "inf", "-inf") - # Keep as character since the column has infinity - result[[colName]] <- charValues - } else { - # No infinity - convert to numeric - numValues <- suppressWarnings(as.numeric(dblValues)) - numValues[dblValuesLower == "nan"] <- NA_real_ - result[[colName]] <- numValues - } - } else { - result[[colName]] <- dblValues - } - } - } + fun <- get(helperName, envir = asNamespace("jaspSyntax"), inherits = FALSE) + .callWithSupportedArgs( + fun, + args, + requiredArgs = requiredArgs, + requiredArgGroups = requiredArgGroups, + functionName = paste0("jaspSyntax::", helperName, "()"), + feature = feature + ) +} - return(result) +.jaspSyntaxClearDatasetState <- function(required = TRUE) { + .jaspSyntaxCall( + "clearDatasetState", + required = required, + feature = "native dataset lifecycle API" + ) + invisible(NULL) +} + +.jaspSyntaxClearNativeState <- function(required = TRUE) { + .jaspSyntaxCall( + c("clearNativeState", "clearAllNativeState"), + required = required, + feature = "native lifecycle API" + ) + invisible(NULL) +} + +.jaspSyntaxClearQmlForms <- function(required = FALSE) { + .jaspSyntaxCall( + c("clearQmlForms", "clearQmlFormCache"), + required = required, + feature = "native QML lifecycle API" + ) + invisible(NULL) +} + +.jaspSyntaxLoadAnalysisDataset <- function(dataset, modulePath = NULL, + analysisName = NULL, + options = NULL) { + .jaspSyntaxCall( + "loadAnalysisDataset", + args = list( + dataset = dataset, + modulePath = modulePath, + analysisName = analysisName, + options = options + ), + required = TRUE, + feature = "native analysis dataset API", + requiredArgs = c("dataset", "modulePath", "analysisName", "options") + ) } loadCorrectDataset <- function(x) { @@ -236,665 +197,143 @@ loadCorrectDataset <- function(x) { stop(paste("Cannot handle data of type", mode(x))) } -findAllColumnNamesInOptions <- function(options, allColumnNames) { - rapply(options, classes = "character", how = "unlist", f = function(x) { - check <- x %in% allColumnNames - if (any(check)) { - x[check] - } else { - NULL - } - }) -} - -preloadDataset <- function(datasetPathOrObject, options, encodedDataset = FALSE) { +preloadDataset <- function(datasetPathOrObject, options, modulePath = NULL, + analysisName = NULL) { + .jaspSyntaxClearDatasetState(required = TRUE) if (is.null(datasetPathOrObject)) { .setInternal("preloadedDataset", data.frame()) - return() + .setInternal("preloadedColumnMapping", character(0)) + return(invisible(NULL)) } dataset <- loadCorrectDataset(datasetPathOrObject) - # If encodedDataset is TRUE, the dataset is already encoded and typed correctly - # so we skip the column name repair and type detection logic - if (!encodedDataset) { - # repair any names like "", which cause false positives in findAllColumnNamesAndTypes - # because empty options are often "" - cnms <- colnames(dataset) - if (any(cnms == "")) { - - bad <- which(cnms == "") - newCnms <- make.names(cnms) - cnms[bad] <- newCnms[bad] - colnames(dataset) <- cnms - - } - # columns <- findAllColumnNamesInOptions(options, colnames(dataset)) - temp <- findAllColumnNamesAndTypes(options, colnames(dataset)) - - variables <- temp[["variables"]] - types <- temp[["types"]] - - # remove any duplicated variables for now - nonDuplicatedIdx <- !duplicated(variables) - variables <- variables[nonDuplicatedIdx] - types <- types[nonDuplicatedIdx] - - dataset <- convertToTypes(dataset[variables], types, datasetPathOrObject) + if (is.matrix(dataset)) { + dataset <- as.data.frame(dataset, stringsAsFactors = FALSE) } - .setInternal("preloadedDataset", dataset) - -} + datasetState <- .jaspSyntaxLoadAnalysisDataset( + dataset = dataset, + modulePath = modulePath, + analysisName = analysisName, + options = options + ) -convertToTypes <- function(dataset, types, datasetPathOrObject) { + loadedDataset <- .jaspSyntaxDatasetStateValue(datasetState, "loadedDataset") + if (is.null(loadedDataset)) + loadedDataset <- .jaspSyntaxReadLoadedDataset(required = TRUE) - typesEnv <- if (is.character(datasetPathOrObject)) { - datasetName <- basename(datasetPathOrObject) - if (exists(datasetName, where = .jaspDataSets)) - get(datasetName, envir = .jaspDataSets) - else NULL - } + requestedDataset <- .jaspSyntaxDatasetStateValue(datasetState, "requestedDataset") + if (is.null(requestedDataset)) + requestedDataset <- .jaspSyntaxReadRequestedDataset(required = FALSE) + if (is.null(requestedDataset)) + requestedDataset <- loadedDataset - for (i in seq_along(dataset)) { + resultDecodingDataset <- .jaspSyntaxDatasetStateValue(datasetState, "resultDecodingDataset") + if (is.null(resultDecodingDataset)) + resultDecodingDataset <- requestedDataset - dataset[[i]] <- switch(types[i], - "scale" = as.numeric(dataset[[i]]), - "ordinal" = as.ordered(dataset[[i]]), - "nominal" = as.factor(dataset[[i]]), - autodetectType(dataset[[i]], colnames(dataset)[i], typesEnv) - ) + columnMapping <- .jaspSyntaxDatasetStateColumnMapping(datasetState) - } - return(dataset) + .setInternal("preloadedDataset", resultDecodingDataset) + .setInternal("preloadedColumnMapping", columnMapping) + invisible(requestedDataset) } -autodetectType <- function(column, name, typesEnv) { - - if (!is.null(typesEnv)) { - - if (!exists(name, envir = typesEnv)) { - devcat(sprintf("No type information found for column '%s' in dataset %s.\n", name, getFilename(typesEnv))) - } else { - type <- get(name, envir = typesEnv) - devcat(sprintf("type information found for column '%s' in dataset '%s': '%s'.\n", name, getFilename(typesEnv), type)) - return( - switch(type, - "scale" = as.numeric(column), - "ordered" = as.ordered(column), - "nominal" = as.factor( column) - )) - } - - } - - if (is.character(column)) { - devcat(sprintf("Converting column '%s' from character to factor.\n", name)) - return(as.factor(column)) - } else { - devcat(sprintf("Leaving column '%s' as is.\n", name)) - } - - return(column) +.jaspSyntaxReadLoadedDataset <- function(required = TRUE) { + dataset <- .jaspSyntaxCall( + "readLoadedDataset", + required = required, + feature = "native loaded dataset API" + ) + .validateJaspSyntaxDataset(dataset, "jaspSyntax::readLoadedDataset()", required) } -setFilename <- function(x, name) { - attr(x, "filename") <- name - x -} -getFilename <- function(x) { - attr(x, "filename") +.jaspSyntaxReadRequestedDataset <- function(required = FALSE) { + dataset <- .jaspSyntaxCall( + "readRequestedDataset", + required = required, + feature = "native requested dataset API" + ) + .validateJaspSyntaxDataset(dataset, "jaspSyntax::readRequestedDataset()", required) } -.debug.csvTypes <- list2env(list( - V1 = "scale", - contNormal = "scale", - contGamma = "scale", - contBinom = "nominal", - contExpon = "scale", - contWide = "scale", - contNarrow = "scale", - contOutlier = "scale", - contcor1 = "scale", - contcor2 = "scale", - facGender = "nominal", - facExperim = "nominal", - facFive = "scale", - facFifty = "scale", - facOutlier = "nominal", - debString = "nominal", - debMiss1 = "scale", - debMiss30 = "scale", - debMiss80 = "scale", - debMiss99 = "scale", - debBinMiss20 = "nominal", - debNaN = "scale", - debNaN10 = "scale", - debInf = "scale", - debCollin1 = "scale", - debCollin2 = "scale", - debCollin3 = "scale", - debEqual1 = "scale", - debEqual2 = "scale", - debSame = "scale", - unicode = "nominal" -)) - -.jaspDataSets <- list2env(list( - "debug.csv" = setFilename(name = "debug.csv", .debug.csvTypes), - "test.csv" = setFilename(name = "test.csv", .debug.csvTypes) -)) - - -#' Add types for a dataset. -#' -#' @param name The path to the dataset on disk. -#' @param lst A list of column names and their types. -#' -#' @details Note that this has already been done for debug.csv and test.csv. -#' This is an alternative interface to specify types in jaspTools. -#' The usual way is to specify a key in the options object with the types. -#' For example, if `options[["variables"]] == c("contNormal", "facFive", "contBinom")` -#' then one could indicate the types by writing -#' `options[["variables.types"]] == c("scale", "ordinal", "nominal")`. -#' With `addTypedDataSet` this becomes: -#' ```r -#' addTypedDataSet( -#' "test.csv", -#' list( -#' contNormal = "scale", -#' facFive = "ordinal", -#' contBinom = "nominal" -#' ) -#' ) -#' ```` -#' the main benefit is that this only needs to be done once, -#' instead of being repeated for each options object. -#' @export -#' -#' @examples -#' addTypedDataSet( -#' "test.csv", -#' list( -#' V1 = "scale", -#' contNormal = "scale", -#' contGamma = "scale", -#' contBinom = "nominal" -#' ) -#' ) -addTypedDataSet <- function(name, lst) { - - if (!is.list(lst) || any(names(lst) == "")) - stop("lst should be a named list") - - if (!all(vapply(lst, function(x) is.character(x) && x %in% c("scale", "ordinal", "nominal"), logical(1L)))) - stop("all elements of lst should be charcter and one of \"scale\", \"ordinal\", or \"nominal\"") - - .jaspDataSets[[name]] <- setFilename(name = basename(name), list2env(lst)) - -} - -predicateVariables <- function(x, allColumnNames) { - is.character(x) && all(x %in% allColumnNames) -} - -predicateVariableTypes <- function(lst, nm) { - nm2 <- paste0(nm, ".types") - is.character(lst[[nm2]]) && length(lst[[nm2]]) == length(lst[[nm]]) && all(lst[[nm2]] %in% c("scale", "ordinal", "nominal")) +.jaspSyntaxReadDatasetHeader <- function(required = FALSE) { + dataset <- .jaspSyntaxCall( + "readDatasetHeader", + required = required, + feature = "native dataset header API" + ) + .validateJaspSyntaxDataset(dataset, "jaspSyntax::readDatasetHeader()", required) } -recursivelyLoopOptions <- function(x, allColumnNames, resultEnv) { - - if (is.list(x)) { - - idx <- which(vapply(x, predicateVariables, logical(1L), allColumnNames = allColumnNames)) - - if (length(idx) > 0) { - resultEnv$variables <- c(resultEnv$variables, unlist(x[idx], use.names = FALSE)) - - nm <- names(x)[idx] - idx2 <- vapply(nm, predicateVariableTypes, logical(1L), lst = x) - - for (i in seq_along(idx2)) { - if (idx2[i]) { - idx3 <- paste0(nm[idx[i]], ".types") - resultEnv$types <- c(resultEnv$types, unlist(x[idx3], use.names = FALSE)) - } else { - resultEnv$types <- c(resultEnv$types, rep(NA_character_, length(x[idx[i]]))) - } - } - - } +.jaspSyntaxDecodeColumnNames <- function(x, strict = FALSE, required = strict) { + if (!is.character(x) || length(x) == 0L) + return(x) - for (i in seq_along(x)) { - if (is.list(x[[i]])) - Recall(x[[i]], allColumnNames, resultEnv) + decoded <- tryCatch( + .jaspSyntaxCall( + "decodeColumnNames", + args = list(columnNames = x, strict = strict), + required = required, + feature = "native column decoding API", + requiredArgs = c("columnNames", if (isTRUE(strict)) "strict" else character(0L)) + ), + error = function(e) { + if (isTRUE(required)) + stop(e) + + x } - } - -} - -findAllColumnNamesAndTypes <- function(options, allColumnNames) { - - resultEnv <- new.env() - resultEnv$variables <- character(0L) - resultEnv$types <- character(0L) - - recursivelyLoopOptions(options, allColumnNames, resultEnv) - - return(as.list(resultEnv)) -} - -devcat <- function(..., file = "", sep = " ", fill = FALSE, labels = NULL, - append = FALSE) { - - if (getOption("jasptools_devcat", FALSE)) - return(cat(..., file = file, sep = sep, fill = fill, labels = labels, append = append)) - invisible(NULL) -} - - -#' Encode Options and Dataset for JASP Analysis -#' -#' This function processes options with `.types` properties and creates an -#' encoded version of both the options and the dataset. Variables are encoded -#' to generic names like "jaspColumn1", "jaspColumn2", etc., and the dataset -#' is filtered and formatted according to the specified types. -#' -#' @param options A named list of analysis options, typically from \code{analysisOptions()}. -#' @param dataset A data.frame or the name/path of a dataset to be encoded. -#' -#' @param forceEncode Optional character vector of option names that should be -#' forcibly encoded using regular expression replacement. This is useful for -#' options like \code{model} that contain variable names embedded in strings -#' (e.g., formula syntax "A~B") but do not have a parallel \code{.types} entry. -#' These options will have all column names replaced with their encoded equivalents -#' using word-boundary-aware regex matching. -#' -#' @return A list with three components: -#' \itemize{ -#' \item \code{options}: The encoded options with variable names replaced by "jaspColumnN". -#' \item \code{dataset}: The encoded dataset containing only the relevant columns, -#' renamed and formatted according to their types. -#' \item \code{encodingMap}: A data.frame with columns \code{original}, \code{encoded}, -#' and \code{type} showing the mapping from original variable names to encoded names. -#' } -#' -#' @details -#' The function performs the following steps: -#' \enumerate{ -#' \item Scans all options for those with a parallel \code{.types} entry -#' (e.g., \code{variables} and \code{variables.types}). -#' \item Extracts unique variable-type combinations. -#' \item Creates an encoding map from original names to "jaspColumn1", "jaspColumn2", etc. -#' \item Replaces all variable references in the options with their encoded names. -#' \item Subsets and transforms the dataset to contain only the encoded columns, -#' applying type coercion: -#' \itemize{ -#' \item \code{"nominal"}: Converted to factor via \code{as.factor()}. -#' \item \code{"ordinal"}: Converted to ordered factor. -#' \item \code{"scale"}: Converted to numeric via \code{as.numeric()}. -#' } -#' } -#' -#' @examples -#' \dontrun{ -#' options <- analysisOptions("BinomialTest") -#' options$variables <- "contBinom" -#' options$variables.types <- "nominal" -#' -#' result <- encodeOptionsAndDataset(options, "debug.csv") -#' # result$options$variables is now "jaspColumn1" -#' # result$dataset has column "jaspColumn1" as a factor -#' # result$encodingMap shows the mapping -#' } -#' -#' @export -encodeOptionsAndDataset <- function(options, dataset, forceEncode = NULL) { - - # Handle NULL dataset (analysis doesn't require data) - if (is.null(dataset)) { - return(list( - options = options, - dataset = NULL, - encodingMap = data.frame(original = character(0), encoded = character(0), type = character(0)) - )) - } - - # Load the dataset if it's a path or name - dataset <- loadCorrectDataset(dataset) - allColumnNames <- colnames(dataset) - - # If variableNameSeparator is present, derive component variable names from - - # composite columns (e.g., "y1_y1" split by "_" yields "y1") so they are - # recognised during variable extraction even when not standalone columns. - sep <- options[["variableNameSeparator"]] - if (!is.null(sep) && nzchar(sep)) { - splits <- strsplit(allColumnNames, sep, fixed = TRUE) - componentNames <- unique(unlist(splits[lengths(splits) == 2L])) - allColumnNames <- unique(c(allColumnNames, componentNames)) - } - - # Step 1 & 2: Find all variable-type pairs from options - varTypePairs <- extractVariableTypePairs(options, allColumnNames) - - if (nrow(varTypePairs) == 0) { - warning("No variable-type pairs found in options. Returning original options and dataset.") - return(list( - options = options, - dataset = dataset, - encodingMap = data.frame(original = character(0), encoded = character(0), type = character(0)) - )) - } - - # Step 3: Keep only unique variable-type combinations and create encoding map - uniquePairs <- unique(varTypePairs) - uniquePairs$encoded <- paste0("jaspColumn", seq_len(nrow(uniquePairs))) - - encodingMap <- uniquePairs[, c("variable", "encoded", "type")] - names(encodingMap)[1] <- "original" - - # Step 4: Encode the options - encodedOptions <- encodeOptionsWithMap(options, encodingMap, forceEncode) - - # Step 5: Create the encoded dataset - encodedDataset <- createEncodedDataset(dataset, encodingMap) - - return(list( - options = encodedOptions, - dataset = encodedDataset, - encodingMap = encodingMap - )) -} - + ) -#' Extract Variable-Type Pairs from Options -#' -#' Internal function that scans options for variable references with associated types. -#' -#' @param options The options list. -#' @param allColumnNames Vector of valid column names in the dataset. -#' -#' @return A data.frame with columns \code{variable} and \code{type}. -#' @keywords internal -extractVariableTypePairs <- function(options, allColumnNames) { - - result <- data.frame(variable = character(0), type = character(0), stringsAsFactors = FALSE) - - # Find all options that have a parallel .types entry - optionNames <- names(options) - optionNames <- optionNames[!grepl("\\.types$", optionNames) & optionNames != ".meta"] - - for (nm in optionNames) { - typesKey <- paste0(nm, ".types") - - if (typesKey %in% names(options)) { - # This option has a .types entry - values <- options[[nm]] - types <- options[[typesKey]] - - pairs <- extractPairsFromValueAndType(values, types, allColumnNames) - if (nrow(pairs) > 0) { - result <- rbind(result, pairs) - } - } - } + if (is.null(decoded)) + return(x) - return(result) + as.character(decoded) } +.jaspSyntaxDatasetStateValue <- function(datasetState, name) { + if (is.null(datasetState)) + return(NULL) -#' Extract Pairs from Value and Type Structures -#' -#' Recursively extracts variable-type pairs from potentially nested value and type structures. -#' -#' @param values The values (can be character vector, list, or nested structure). -#' @param types The parallel types structure. -#' @param allColumnNames Vector of valid column names. -#' -#' @return A data.frame with columns \code{variable} and \code{type}. -#' @keywords internal -extractPairsFromValueAndType <- function(values, types, allColumnNames) { - - result <- data.frame(variable = character(0), type = character(0), stringsAsFactors = FALSE) - - # Special case: values is a list with a "value" element (from flattened types/value structure that preserved - # additional fields like "model" and "modelOriginal"). In this case, the actual variable names are in values$value - if (is.list(values) && "value" %in% names(values) && is.character(types)) { - return(extractPairsFromValueAndType(values$value, types, allColumnNames)) - } - - # Simple case: both are character vectors of same length - - if (is.character(values) && is.character(types) && length(values) == length(types)) { - # Filter to only include valid column names - validIdx <- values %in% allColumnNames - if (any(validIdx)) { - result <- data.frame( - variable = values[validIdx], - type = types[validIdx], - stringsAsFactors = FALSE - ) - } - return(result) - } - - # Simple case: values is a single character matching a column name - if (is.character(values) && length(values) == 1 && values %in% allColumnNames) { - if (is.character(types) && length(types) == 1) { - return(data.frame(variable = values, type = types, stringsAsFactors = FALSE)) - } - } - - # Complex case: both are lists (parallel structure) - if (is.list(values) && is.list(types) && length(values) == length(types)) { - for (i in seq_along(values)) { - subPairs <- extractPairsFromValueAndType(values[[i]], types[[i]], allColumnNames) - if (nrow(subPairs) > 0) { - result <- rbind(result, subPairs) - } - } - return(result) - } + if (is.data.frame(datasetState) && identical(name, "loadedDataset")) + return(datasetState) - # Named list case: match by names - if (is.list(values) && !is.null(names(values)) && is.list(types) && !is.null(names(types))) { - commonNames <- intersect(names(values), names(types)) - for (nm in commonNames) { - subPairs <- extractPairsFromValueAndType(values[[nm]], types[[nm]], allColumnNames) - if (nrow(subPairs) > 0) { - result <- rbind(result, subPairs) - } - } - return(result) - } + if (!is.list(datasetState) || is.null(datasetState[[name]])) + return(NULL) - return(result) + .validateJaspSyntaxDataset( + datasetState[[name]], + paste0("jaspSyntax::loadAnalysisDataset()$", name), + required = TRUE + ) } +.jaspSyntaxDatasetStateColumnMapping <- function(datasetState) { + if (!is.list(datasetState) || is.null(datasetState[["columnMapping"]])) + return(character(0)) -#' Encode Options Using Encoding Map -#' -#' Replaces variable names in options with their encoded equivalents. -#' -#' @param options The options list. -#' @param encodingMap Data.frame with columns \code{original}, \code{encoded}, \code{type}. -#' @param forceEncode Optional character vector of option names to force-encode via regex. -#' -#' @return The options list with encoded variable names. -#' @keywords internal -encodeOptionsWithMap <- function(options, encodingMap, forceEncode = NULL) { - - # Simple lookup from original name to encoded name, deduplicated so each - # variable maps to exactly one encoded column (the first occurrence). - # Used as fallback when no type info is available and by regexEncodeString. - firstOccurrence <- !duplicated(encodingMap$original) - lookup <- stats::setNames(encodingMap$encoded[firstOccurrence], - encodingMap$original[firstOccurrence]) - - # Check if any variable appears with multiple types (needs type-aware encoding) - hasMultiTypeVars <- anyDuplicated(encodingMap$original) > 0 - - # Type-aware lookup: given variable name and type, find the correct encoding. - # Always returns a single string. - typeAwareLookup <- function(varName, varType) { - idx <- which(encodingMap$original == varName & encodingMap$type == varType) - if (length(idx) >= 1L) { - return(encodingMap$encoded[idx[1L]]) - } - # Fallback: use the deduplicated lookup (first occurrence) - pos <- match(varName, names(lookup)) - if (!is.na(pos)) { - return(unname(lookup[pos])) - } - return(varName) - } - - # Replace column names embedded in a string using word-boundary regex. - # Used for model formulas (e.g., "A~B") and forceEncode options. - regexEncodeString <- function(x) { - if (!is.character(x) || length(x) == 0) { - return(x) - } - result <- x - for (i in seq_along(result)) { - for (origName in names(lookup)) { - escapedName <- gsub("([.\\\\^$|?*+()\\[\\]\\{\\}-])", "\\\\\\1", origName) - pattern <- paste0("(? 0) { - if (hasMultiTypeVars && !is.null(types) && is.character(types) && length(types) == length(x)) { - # Type-aware encoding: use the parallel types to disambiguate - for (j in idx) { - x[j] <- typeAwareLookup(x[j], types[j]) - } - } else { - # Simple encoding (no ambiguity or no type info) - x[idx] <- unname(lookup[x[idx]]) - } - } - return(x) - } else if (is.list(x)) { - # Special handling for lists with both "model" and "modelOriginal" fields. - # JASP stores pre-encoded column names in "model" (e.g., "JaspColumn_0_Encoded"), - # but our encoding uses different names (e.g., "jaspColumn1"). Since JASP's - # encoding scheme doesn't match ours, we must re-encode from "modelOriginal" - # (which contains the original user-facing variable names) using our lookup. - if ("model" %in% names(x) && "modelOriginal" %in% names(x)) { - x[["model"]] <- regexEncodeString(x[["modelOriginal"]]) - } - - # Special case: x is a list with a "value" element and types is a flat - # character vector (produced by fixOptionsForVariableTypes when additional - # fields like model/modelOriginal are preserved alongside the types/value - # structure). The character types apply to x$value, not the list itself. - if ("value" %in% names(x) && is.character(types)) { - x[["value"]] <- encodeValue(x[["value"]], types) - # Encode remaining elements without type info - for (i in seq_along(x)) { - if (identical(names(x)[i], "value")) next - x[[i]] <- encodeValue(x[[i]]) - } - return(x) - } - - # Recursively process list elements, threading parallel types structure - for (i in seq_along(x)) { - subTypes <- NULL - if (!is.null(types) && is.list(types)) { - # Match by name first, then by position - nm <- names(x)[i] - if (!is.null(nm) && !is.null(names(types)) && nm %in% names(types)) { - subTypes <- types[[nm]] - } else if (i <= length(types)) { - subTypes <- types[[i]] - } - } - x[[i]] <- encodeValue(x[[i]], subTypes) - } - return(x) - } else { - return(x) - } - } - - # Process all options except .meta and .types entries - optionNames <- names(options) - for (nm in optionNames) { - if (nm == ".meta" || grepl("\\.types$", nm)) { - next - } - - if (!is.null(forceEncode) && nm %in% forceEncode) { - options[[nm]] <- regexEncodeString(options[[nm]]) - } else { - # Use the parallel .types entry for type-aware encoding - typesKey <- paste0(nm, ".types") - options[[nm]] <- encodeValue(options[[nm]], options[[typesKey]]) - } - } - - return(options) + valid <- !is.na(columnMapping) & nzchar(columnMapping) & + !is.na(names(columnMapping)) & nzchar(names(columnMapping)) + columnMapping[valid] } +.validateJaspSyntaxDataset <- function(dataset, source, required = TRUE) { + if (is.null(dataset)) + return(NULL) -#' Create Encoded Dataset -#' -#' Creates a new dataset with encoded column names and proper type coercion. -#' -#' @param dataset The original dataset. -#' @param encodingMap Data.frame with columns \code{original}, \code{encoded}, \code{type}. -#' -#' @return A data.frame with encoded column names and proper types. -#' @keywords internal -createEncodedDataset <- function(dataset, encodingMap) { - - # Create new data.frame with encoded columns - encodedDataset <- data.frame(row.names = seq_len(nrow(dataset))) - - for (i in seq_len(nrow(encodingMap))) { - origName <- encodingMap$original[i] - encodedName <- encodingMap$encoded[i] - colType <- encodingMap$type[i] - - if (!origName %in% colnames(dataset)) { - warning("Column '", origName, "' not found in dataset. Skipping.") - next - } - - col <- dataset[[origName]] - - # Apply type coercion - col <- switch(colType, - "nominal" = as.factor(col), - "ordinal" = { - if (is.factor(col)) { - factor(col, levels = levels(col), ordered = TRUE) - } else { - factor(col, ordered = TRUE) - } - }, - "scale" = as.numeric(col), - col # default: keep as-is - ) + if (!is.data.frame(dataset)) { + if (isTRUE(required)) + stop(source, " returned an unexpected dataset object.") - encodedDataset[[encodedName]] <- col + return(NULL) } - return(encodedDataset) + dataset } diff --git a/R/option-state.R b/R/option-state.R new file mode 100644 index 0000000..b3bab59 --- /dev/null +++ b/R/option-state.R @@ -0,0 +1,8 @@ +isPreparedOptions <- function(x) { + isTRUE(attr(x, "jaspTools.preparedOptions", exact = TRUE)) +} + +markPreparedOptions <- function(x) { + attr(x, "jaspTools.preparedOptions") <- TRUE + x +} diff --git a/R/options-parser-qml.R b/R/options-parser-qml.R deleted file mode 100644 index 5b6f3f3..0000000 --- a/R/options-parser-qml.R +++ /dev/null @@ -1,329 +0,0 @@ -readQML <- function(file) { - regularFields <- c( - "IntegerField", - "DoubleField", - "PercentField", - "CIField", - "TextField", - "TextArea", - "CheckBox", - "Slider", - "AssignedVariablesList", - "repeatedMeasuresFactorsList", - "Chi2TestTableView", - "DropDown" - ) # the button group requires additional parsing - - ignoreWhenParsingRegularFields <- c( - "RadioButtonGroup", - "VariablesForm", - "RadioButton", - "ExpanderButton", - "BayesFactorType", - "SubjectivePriors", - "ContrastsList", - "SetSeed", - "LD.LDOptions", - "LD.LDGenerateDisplayData" - ) - - fileSize <- file.info(file)$size - fileContents <- readChar(file, nchars=fileSize) - fileContents <- gsub("//.*?(\\r\\n|\\r|\\n)", "", fileContents) # remove comments - fileContents <- gsub('[[:blank:]]|\\"', "", fileContents) # strip whitespaces - fileContents <- gsub("(\\r\\n|\\r|\\n)", ";", fileContents) # replace newline characters with ; - fileContents <- gsub("^.*?Form;*?\\{", "", fileContents) # remove everything up to the actual form - fileContents <- gsub("(?<={);+|;(?={)|(?<=});+|;(?=})", "", fileContents, perl=TRUE) # remove all ; around {} - fileContents <- gsub("(?<=\\[);+|;(?=\\[)|(?<=\\]);+|;(?=\\])", "", fileContents, perl=TRUE) # remove all ; around [] - - regExpr <- paste0("(", regularFields, "\\{.*?)(?=", paste0(c(regularFields, ignoreWhenParsingRegularFields, "$"), collapse="|"), ")", collapse="|") - qmlElements <- stringr::str_extract_all(fileContents, regExpr)[[1]] - fileContents <- stringr::str_replace_all(fileContents, regExpr, "") # remove everything we can readily use - - regExpr <- "RadioButtonGroup\\{.*?(?=RadioButtonGroup\\{|$)" - qmlElements <- c(qmlElements, stringr::str_extract_all(fileContents, regExpr)[[1]]) - - options <- qmlElementsToOptionsList(qmlElements) - optionsOfStaticElements <- staticElementsToOptions(fileContents) - options <- c(options, optionsOfStaticElements) - return(options) -} - -qmlElementsToOptionsList <- function(qmlElements) { - opts <- list() - for (qmlElement in qmlElements) { - opts <- c(opts, extractData(qmlElement)) - } - return(opts) -} - -staticElementsToOptions <- function(fileContents) { - result <- list() - - result[["plotWidth"]] <- 480 - result[["plotHeight"]] <- 320 - - regMatch <- "BayesFactorType\\{" - if (grepl(regMatch, fileContents)) { - result[["bayesFactorType"]] <- "BF10" - } - - regMatch <- "ContrastsList\\{" - if (grepl(regMatch, fileContents)) { - result[["contrast"]] <- "none" - } - - regMatch <- "SetSeed\\{" - if (grepl(regMatch, fileContents)) { - result[["setSeed"]] <- FALSE - result[["seed"]] <- 1 - } - - regMatch <- "SubjectivePriors\\{" - if (grepl(regMatch, fileContents)) { - subjectivePriors <- list( - priorWidth = 0.707, - informativeCauchyLocation = 0, - informativeCauchyScale = 0.707, - informativeNormalMean = 0, - informativeNormalStd = 0.707, - informativeTLocation = 0, - informativeTScale = 0.707, - informativeTDf = 1, - uniformDienesLowerBound = 0.707, - uniformDienesUpperBound = 0.707, - halfNormalDienesStd = 0.707, - normalDienesMean = 0.707, - normalDienesStd = 0.707, - effectSize = "standardized", - effectSizeStandardized = "default", - defaultStandardizedEffectSize = "cauchy", - informativeStandardizedEffectSize = "cauchy", - dienesEffectSize = "uniform" - ) - result <- c(result, subjectivePriors) - } - - regMatch <- "LD.LDOptions\\{" - if (grepl(regMatch, fileContents)) { - LDoption <- parseLDOption(fileContents) - result <- c(result, LDoption) - } - - regMatch <- "LD.LDGenerateDisplayData\\{" - if (grepl(regMatch, fileContents)) { - LDGenerateDisplayData <- list( - sampleSize = 1, - simulateNow = FALSE, - variable = c(), - summary = TRUE, - moments = FALSE, - momentsUpTo = 2, - histogram = TRUE, - histogramBins = 30, - ecdf = FALSE - ) - result <- c(result, LDGenerateDisplayData) - } - - return(result) -} - -makeExprForOptionParam <- function(param) { - return(paste0("[\\{;]", param, ":(.*?)[;\\}]")) -} - -optionHasParam <- function(option, param) { - expr <- makeExprForOptionParam(param) - return(grepl(expr, option)) -} - -getOptionParamValue <- function(option, param, default = NULL) { - value <- default - if (optionHasParam(option, param)) { - match <- stringr::str_match(option, makeExprForOptionParam(param))[2] - if (tolower(match) == "true") - value <- TRUE - else if (tolower(match) == "false") - value <- FALSE - else if (!is.na(suppressWarnings(as.numeric(match)))) - value <- as.numeric(match) - else - value <- match - } - return(value) -} - -parseLDOption <- function(fileContents) { - LDOption <- stringr::str_extract(fileContents, "LDOptions\\{.*?\\}") - - negativeValues <- getOptionParamValue(LDOption, "negativeValues", default = TRUE) - min <- getOptionParamValue(LDOption, "min", default = ifelse(negativeValues, -Inf, 0)) - max <- getOptionParamValue(LDOption, "max", default = Inf) - - return(list( - min_x = getOptionParamValue(LDOption, "rangeMinX", default = ifelse(min == -Inf, -3, min)), - max_x = getOptionParamValue(LDOption, "rangeMaxX", default = ifelse(max == Inf, 3, max)), - min = getOptionParamValue(LDOption, "intervalMinmaxMin", default = 0), - max = getOptionParamValue(LDOption, "intervalMinmaxMax", default = 1), - lower_max = getOptionParamValue(LDOption, "intervalLowerMax", default = 0), - upper_min = getOptionParamValue(LDOption, "intervalUpperMin", default = 0), - highlightDensity = FALSE, - highlightProbability = FALSE, - highlightType = "minmax" - )) -} - - -extractData <- function(element, ...) { - regMatch <- "^(.*?)\\{.*?[\\};]" - fieldClassTable <- stringr::str_match(element, regMatch) - if (length(fieldClassTable) != 2) { - stop("Could not locate type of the field") - } - fieldClass <- fieldClassTable[, 2] - class(element) <- fieldClass - UseMethod("extractData", element) -} - -#'@export -extractData.IntegerField <- function(element, defaultValue = 0, ...) { - regMatch <- "default.*?:([+-]?([0-9]*[.])?[0-9]+)" - matchTable <- stringr::str_match(element, regMatch) - default <- as.numeric(matchTable[2]) - if (is.na(default)) { - default <- defaultValue - } - extractData.default(element, default) -} - -#'@export -extractData.DoubleField <- function(element, defaultValue = 0, ...) { - extractData.IntegerField(element, defaultValue) -} - -#'@export -extractData.PercentField <- function(element, defaultValue = 50, ...) { - regMatch <- "default.*?:([+-]?([0-9]*[.])?[0-9]+)" - matchTable <- stringr::str_match(element, regMatch) - default <- as.numeric(matchTable[2]) - if (is.na(default)) { - default <- defaultValue - } - default <- default / 100 - extractData.default(element, default) -} - -#'@export -extractData.CIField <- function(element, defaultValue = 95, ...) { - extractData.PercentField(element, defaultValue) -} - -#'@export -extractData.AssignedVariablesList <- function(element, ...) { - regMatch <- "name:(.*?)[;\\}]" - matchTable <- stringr::str_match(element, regMatch) - name <- matchTable[2] - if (is.na(name)) { - name <- "variables" # default behaviour of variablesform.qml - } - - result <- list() - regSingleItem <- "singleVariable:true" - isSingleItem <- grepl(regSingleItem, element) - if (isSingleItem) { - result[[name]] <- "" - } else { - result[[name]] <- list() - } - return(result) -} - -#'@export -extractData.repeatedMeasuresFactorsList <- function(element, ...) { - return(extractData.AssignedVariablesList(element)) -} - -#'@export -extractData.CheckBox <- function(element, ...) { - regMatch <- "checked.*?:(true)" - matchTable <- stringr::str_match(element, regMatch) - if (is.na(matchTable[2])) { - checked <- FALSE - } else { - checked <- TRUE - } - extractData.default(element, checked) -} - -#'@export -extractData.Chi2TestTableView <- function(element, ...) { - extractData.default(element, list()) -} - -#'@export -extractData.Slider <- function(element, ...) { - regMatch <- "value.*?:(\\d+)" - matchTable <- stringr::str_match(element, regMatch) - value <- as.numeric(matchTable[2]) - extractData.default(element, value) -} - -#'@export -extractData.DropDown <- function(element, ...) { - regMatches <- c("indexDefaultValue:(\\d+)", "values:\\[(?!\\{)(.*?)\\]", "values:\\[(.*?)\\]") - matchTable <- stringr::str_match_all(element, regMatches) - - unnamedArray <- matchTable[[2]][2] - if (!is.na(unnamedArray)) { - values <- unlist(strsplit(unnamedArray, ",")) - } else { - namedArray <- matchTable[[3]][2] - regMatchValue <- "value:(.*?)[;\\}]" - matchTableValues <- stringr::str_match_all(namedArray, regMatchValue) - values <- matchTableValues[[1]][, 2] - } - - index <- as.numeric(matchTable[[1]][2]) - if (!is.na(index)) { - index <- index + 1 # zero based qml vs one based R array - } else { - index <- 1 - } - - value <- NA - if (length(values) >= index) { - value <- values[index] - } else { - stop("Index value exceeds array size for element", element) - } - - extractData.default(element, value) -} - -#'@export -extractData.RadioButtonGroup <- function(element, ...) { - regMatch <- "RadioButton\\{[^\\}]*?checked:true" - matchTable <- stringr::str_match(element, regMatch) - regMatchValue <- "value:(.*?)[;\\}]" - matchTableValue <- stringr::str_match(matchTable, regMatchValue) - value <- matchTableValue[2] - extractData.default(element, value) -} - -#'@export -extractData.default <- function(element, value = NA, ...) { - regMatch <- "name:(.*?)[;\\}]" - matchTable <- stringr::str_match(element, regMatch) - name <- matchTable[2] - - result <- NULL - if (!is.na(name)) { - result <- list() - result[[name]] <- "" - if (!identical(value, NA)) { - result[[name]] <- value - } - } - return(result) -} diff --git a/R/options.R b/R/options.R index 6f3e66d..dbd6760 100644 --- a/R/options.R +++ b/R/options.R @@ -3,10 +3,19 @@ #' \code{analysisOptions} provides an easy way to create analysis options that can be supplied to \code{runAnalysis}. #' #' @param source One of three: (1) R function name, (2) path to .jasp file or (3) json string. See the details section for more information. +#' @param modulePath Optional module path, or named list/vector of module paths +#' keyed by module name or analysis name. Used for .jasp replay and for +#' analysis-name defaults when the module checkout should be pinned. #' #' @details #' There are three types of allowed input. 1) The name of the R function of the analysis (case-sensitive); jaspTools will attempt to read the .qml file for that analysis and create a set of default options. -#' 2) the path to .jasp file that has one or more analyses. Or (3) a json string that was sent by the JASP application. This json can be obtained by having JASP log to file (JASP>Preferences>Advanced>Log to file). +#' 2) the path to .jasp file that has one or more analyses. For .jasp files, +#' saved QML-bound options are returned so they can be supplied to +#' \code{runAnalysis()} and replayed once through the native JASP option +#' pipeline. Use \code{analysisRuntimeOptions()} only when you need +#' backend-prepared runtime options for diagnostics. Or (3) a json string that was sent by the +#' JASP application. This json can be obtained by having JASP log to file +#' (JASP>Preferences>Advanced>Log to file). #' The logs can be found by clicking 'Show logs" in the "Logging options". Click on the file "*Engine*.log" that has "Engine::receiveAnalysisMessage:" (usually Engine 1), copy the content between the \{ and \}. #' Be sure to use single quotes (') when supplying this string. #' @@ -54,19 +63,23 @@ #' }') #' #' @export analysisOptions -analysisOptions <- function(source) { +analysisOptions <- function(source, modulePath = NULL) { if (! is.character(source) || length(source) > 1) stop("Expecting a character input of length 1 as source") source <- trimws(source) - # Normalize path separators for cross-platform compatibility + # Normalize path separators for cross-platform compatibility. normalizedSource <- normalizePath(source, winslash = "/", mustWork = FALSE) + isJaspFilePath <- grepl("\\.jasp$", normalizedSource, ignore.case = TRUE) - # First check if it's a .jasp file path (before JSON check, since Windows paths contain ':') - if (grepl("\\.jasp$", normalizedSource, ignore.case = TRUE) && file.exists(normalizedSource)) { - options <- analysisOptionsFromJASPFile(normalizedSource) - } else if (grepl("[{}\":]", source)) { # json string + # First check .jasp file paths before JSON, since Windows paths contain ':'. + if (isJaspFilePath) { + if (!file.exists(normalizedSource)) + stop("File not found: ", normalizedSource) + + options <- analysisOptionsFromJASPFile(normalizedSource, modulePath = modulePath) + } else if (grepl("[{}]", source)) { # json string if (!grepl("^\\{.*\\}$", source)) stop("Your json is invalid, please copy the entire message including the outer braces { } that was send to R in the Qt terminal. @@ -77,62 +90,76 @@ analysisOptions <- function(source) { if (!endsWith(source, ".jasp")) stop("The file you provided exists, but it is not a .jasp file") - options <- analysisOptionsFromJASPFile(source) + options <- analysisOptionsFromJASPFile(source, modulePath = modulePath) + } else if (.looksLikeMissingFilePath(source)) { + stop("File not found: ", normalizedSource) } else { # analysis name - options <- analysisOptionsFromQMLFile(source) + options <- analysisOptionsFromQMLFile(source, modulePath = modulePath) } return(options) } -analysisOptionsFromQMLFile <- function(analysis) { - file <- getQMLFile(analysis) - options <- readQML(file) +analysisOptionsFromQMLFile <- function(analysis, modulePath = NULL) { + if (analysisOptionsShouldUseSubprocess()) { + return(analysisOptionsFromQMLFileSubprocess(analysis, modulePath = modulePath)) + } + + modulePath <- .modulePathForAnalysisName(analysis, modulePath) + options <- jaspSyntax::readDefaultAnalysisOptions( + modulePath = modulePath, + analysisName = analysis, + includeMeta = FALSE, + includeTypeOptions = FALSE + ) attr(options, "analysisName") <- analysis + attr(options, "jaspTools.optionShape") <- "qml" + attr(options, "modulePath") <- normalizePath(modulePath, winslash = "/", mustWork = FALSE) return(options) } -getQMLFile <- function(name) { - modulePath <- getModulePathFromRFunction(name) - if (is.null(modulePath)) - stop("Could not locate the module location for ", name) - - if (isBinaryPackage(modulePath)) { - qmlDir <- file.path(modulePath, "qml") - instDir <- modulePath - } else { # source pkg - qmlDir <- file.path(modulePath, "inst", "qml") - instDir <- file.path(modulePath, "inst") - - } - - possibleQmlFile <- file.path(qmlDir, paste0(name, ".qml")) # it's optional to specify the qml file in Description.qml, you can also just name it RFunc.qml - if (file.exists(possibleQmlFile)) - return(possibleQmlFile) - - descrFile <- file.path(instDir, "Description.qml") - if (!file.exists(descrFile)) - stop("Could not locate Description.qml in ", modulePath) +analysisOptionsShouldUseSubprocess <- function() { + isTRUE(getOption("jaspTools.analysisOptions.subprocess", TRUE)) && + !identical(Sys.getenv("JASPTOOLS_ANALYSIS_OPTIONS_CHILD"), "true") +} - fileSize <- file.info(descrFile)$size - fileContents <- readChar(descrFile, nchars = fileSize) - fileContents <- gsub("[\"']", "", fileContents) - rFuncLocExpr <- paste0("\\{[^\\{\\}]*func:\\s*", name, "[^\\{\\}]*\\}") - if (!grepl(rFuncLocExpr, fileContents)) - stop("Could not locate qml file for R function ", name, " in inst/qml directory and did not find the R function in inst/Description.qml to look for an alternative name for the qml file") +analysisOptionsFromQMLFileSubprocess <- function(analysis, modulePath = NULL) { + payload <- .jaspToolsSubprocessPayload( + extra = list(analysis = analysis, modulePath = modulePath), + env = .jaspToolsSubprocessEnv("JASPTOOLS_ANALYSIS_OPTIONS_CHILD") + ) + + result <- .jaspToolsRunSubprocess( + prefix = "jaspTools-analysisOptions-", + payload = payload, + scriptLines = analysisOptionsSubprocessScript(), + failureMessage = "`analysisOptions()` subprocess failed before returning options", + isError = function(result) inherits(result, "jaspTools.subprocessError") + ) + + .stopIfJaspToolsSubprocessError(result) + result +} - rLocMatch <- stringr::str_match(fileContents, rFuncLocExpr)[1] - qmlLocExpr <- "[a-zA-Z0-9_]+\\.qml" - if (!grepl(qmlLocExpr, rLocMatch)) - stop("Could not locate qml file for R function ", name, " in inst/qml directory and did not find a qml entry in inst/Description.qml that describes an alternative for the qml filename") +analysisOptionsSubprocessScript <- function() { + .jaspToolsSubprocessScript( + resultLines = c( + "result <- tryCatch(", + " jaspTools:::analysisOptionsFromQMLFile(payload$analysis, modulePath = payload$modulePath),", + " error = .jaspToolsSubprocessError", + ")" + ), + saveLines = "saveRDS(result, args[[2L]])" + ) +} - qmlFileName <- stringr::str_match(rLocMatch, qmlLocExpr) - qmlFilePath <- file.path(qmlDir, qmlFileName) - if (!file.exists(qmlFilePath)) - stop("Found a qml filename for the R function ", name, " but this qml file does not appear to exist in inst/qml/") +.looksLikeMissingFilePath <- function(source) { + hasPathSeparator <- grepl("[/\\\\]", source) + hasDrivePrefix <- grepl("^[A-Za-z]:", source) + hasFileExtension <- nzchar(tools::file_ext(source)) - return(qmlFilePath) + hasPathSeparator || hasDrivePrefix || hasFileExtension } analysisOptionsFromJSONString <- function(x) { @@ -144,374 +171,304 @@ analysisOptionsFromJSONString <- function(x) { stop("There is no \"options\" field in your JSON string, cannot create options list") options <- json[["options"]] - if (!is.null(names(options)) && ".meta" %in% names(options)) - options[[".meta"]] <- NULL - if ("name" %in% names(json)) attr(options, "analysisName") <- json[["name"]] return(options) } -analysisOptionsFromJASPFile <- function(file) { - - contents <- archive::archive(file) - fileIndex <- which(contents[["path"]] == "analyses.json") - - if (length(fileIndex) != 1L) - stop("Could not find a file \"analyses.json\" inside the jasp file.") - - fileCon <- archive::archive_read(file, file = fileIndex, mode = "r") - on.exit(close(fileCon)) - contents <- rjson::fromJSON(file = fileCon) - analyses <- contents[["analyses"]] - if (length(analyses) == 0) - stop("No analyses found in the provided file") - - options <- vector("list", length(analyses)) - for (i in seq_along(analyses)) { - analysis <- analyses[[i]] - options[[i]] <- fixOptionsForVariableTypes(analysis[["options"]]) - attr(options[[i]], "analysisName") <- analysis[["name"]] - } - - if (length(options) == 1) - options <- options[[1]] +analysisOptionsFromJASPFile <- function(file, modulePath = NULL) { + records <- .jaspSyntaxReadAnalysisOptionsFromJaspFile( + file, + modulePath = modulePath, + runtime = FALSE, + includeMeta = TRUE, + includeTypeOptions = TRUE, + isolated = TRUE + ) + options <- .optionsFromJaspRecords( + records, + preparedOptions = FALSE, + optionShape = "saved", + modulePath = modulePath + ) + + if (length(options) == 1L) + options <- options[[1L]] return(options) } -fixOptionsForVariableTypes <- function(options) { - - # jasp does this internally before passing the options to R. - # however, when reading the options from a file this hasn't been done yet - - meta <- options[[".meta"]] - - # Check if an option has the types/value structure that needs flattening - needsFlattening <- function(opt) { - is.list(opt) && - !is.null(names(opt)) && - all(c("types", "value") %in% names(opt)) - } - - # Build parallel types structure for complex nested values - buildTypesStructure <- function(types, value, optionKey = NULL) { - # If types is empty or NULL, return as-is - if (length(types) == 0) { - return(list()) - } - - # Simple case: types is a single character and value is atomic - if (is.character(types) && length(types) == 1 && !is.list(value)) { - return(types) - } - - # Simple case: types is character vector matching atomic value vector length - if (is.character(types) && is.character(value) && length(types) == length(value)) { - return(types) - } +#' Obtain backend/runtime options from a JASP file. +#' +#' \code{analysisRuntimeOptions()} reads options from a saved .jasp file, +#' replays them through \code{jaspSyntax} and the native JASP option pipeline, +#' and marks the returned option lists as already prepared. These options are +#' intended for inspection and direct backend diagnostics, not for +#' \code{runAnalysis()}. +#' +#' @param file Path to a .jasp file. +#' @param modulePath Optional module path, or a named list/vector of module +#' paths keyed by module name or analysis name. Passed to +#' \code{jaspSyntax::readAnalysisOptionsFromJaspFile()}. +#' +#' @return A prepared options list. If \code{file} contains multiple analyses, +#' a list of prepared options lists is returned. +#' +#' @export analysisRuntimeOptions +analysisRuntimeOptions <- function(file, modulePath = NULL) { + if (!is.character(file) || length(file) != 1L) + stop("Expecting a character input of length 1 as file") + + file <- normalizePath(trimws(file), winslash = "/", mustWork = FALSE) + if (!file.exists(file)) + stop("File not found: ", file) + if (!grepl("\\.jasp$", file, ignore.case = TRUE)) + stop("File must have a .jasp extension") + + records <- .jaspSyntaxReadAnalysisOptionsFromJaspFile( + file, + modulePath = modulePath, + runtime = TRUE, + includeMeta = FALSE, + includeTypeOptions = TRUE, + isolated = TRUE + ) + options <- .optionsFromJaspRecords( + records, + preparedOptions = TRUE, + optionShape = "runtime", + modulePath = modulePath + ) + + if (length(options) == 1L) + options <- options[[1L]] - # Complex case: value is a list of lists (e.g., for model terms) - # Build a parallel structure: each element in value gets corresponding type - if (is.list(value) && length(types) == length(value)) { - if (!is.null(optionKey)) { - # Each value element is a list with optionKey, mirror structure with types - result <- vector("list", length(value)) - for (i in seq_along(value)) { - if (is.list(value[[i]]) && optionKey %in% names(value[[i]])) { - result[[i]] <- stats::setNames(list(types[[i]]), optionKey) - } else { - result[[i]] <- types[[i]] - } - } - return(result) - } else { - return(types) - } - } + return(options) +} - # Default: return types as-is - return(types) - } +.optionsFromJaspRecords <- function(records, preparedOptions, optionShape, + modulePath = NULL) { + options <- lapply(records, function(record) { + opts <- record[["options"]] - # Fields that are internal JASP metadata and should not be preserved as user-facing options - # when flattening types/value structures - internalFields <- c("types", "value", "optionKey", "columns", "prefixedColumns") + if (!is.null(record[["name"]])) + attr(opts, "analysisName") <- record[["name"]] + if (!is.null(record[["moduleName"]])) + attr(opts, "moduleName") <- record[["moduleName"]] + if (!is.null(record[["moduleVersion"]])) + attr(opts, "moduleVersion") <- record[["moduleVersion"]] + attr(opts, "jaspTools.optionShape") <- optionShape - # Recursively flatten a nested list structure, extracting types into a parallel structure - # Returns a list with $value (the flattened value) and $types (the parallel types structure) - flattenRecursive <- function(obj) { - if (!is.list(obj)) { - return(list(value = obj, types = NULL)) - } + resolvedModulePath <- .modulePathForOptionRecord(record, modulePath) + if (!is.null(resolvedModulePath)) + attr(opts, "modulePath") <- resolvedModulePath - # If this object needs flattening (has types/value structure) - if (needsFlattening(obj)) { - types <- obj[["types"]] - value <- obj[["value"]] - optionKey <- obj[["optionKey"]] + if (preparedOptions) + opts <- markPreparedOptions(opts) - # Build types structure - typesStructure <- buildTypesStructure(types, value, optionKey) + opts + }) - # Check for additional fields that should be preserved (e.g., "model", "modelOriginal") - # These are user-facing fields that exist alongside types/value structure - additionalFields <- setdiff(names(obj), internalFields) + if (!is.null(names(records)) && length(names(records)) == length(options)) + names(options) <- names(records) - # If there are additional fields, preserve them alongside the flattened value - if (length(additionalFields) > 0) { - # Create a new object with the flattened value and preserved additional fields - newObj <- list() - newObj[["value"]] <- value + options +} - for (field in additionalFields) { - # Recursively process each additional field in case it also needs flattening - result <- flattenRecursive(obj[[field]]) - newObj[[field]] <- result$value - } +.modulePathForOptionRecord <- function(record, modulePath = NULL) { + if (is.null(modulePath)) + return(NULL) - return(list(value = newObj, types = typesStructure)) - } + expectedNames <- c(record[["moduleName"]], record[["name"]]) + expectedNames <- expectedNames[!is.na(expectedNames) & nzchar(expectedNames)] - # Recursively process the value in case it contains nested structures - if (is.list(value)) { - result <- flattenRecursive(value) - # If recursive call found more types, we need to merge - if (!is.null(result$types)) { - return(list(value = result$value, types = result$types)) - } - } + .normalizeSingleModulePath( + modulePath, + expectedNames = expectedNames, + context = paste0( + "analysis `", record[["name"]] %||% "", + "` in module `", record[["moduleName"]] %||% "", "`" + ) + ) +} - return(list(value = value, types = typesStructure)) - } +`%||%` <- function(x, y) { + if (is.null(x) || length(x) == 0L || is.na(x[[1L]]) || !nzchar(x[[1L]])) + return(y) - # Not a types/value structure, but may contain nested structures - # Process each element recursively - hasTypes <- FALSE - newObj <- obj - typesObj <- NULL - - nms <- names(obj) - if (!is.null(nms)) { - # Named list - process each named element - typesObj <- list() - for (nm in nms) { - if (nm == ".meta") next - - result <- flattenRecursive(obj[[nm]]) - newObj[[nm]] <- result$value - - if (!is.null(result$types)) { - hasTypes <- TRUE - typesObj[[nm]] <- result$types - } - } - } else if (length(obj) > 0) { - # Unnamed list - process each element by index - typesObj <- vector("list", length(obj)) - for (i in seq_along(obj)) { - result <- flattenRecursive(obj[[i]]) - newObj[[i]] <- result$value - - if (!is.null(result$types)) { - hasTypes <- TRUE - typesObj[[i]] <- result$types - } - } - # Clean up NULL entries if no types found - if (!hasTypes) { - typesObj <- NULL - } - } + as.character(x[[1L]]) +} - if (hasTypes) { - return(list(value = newObj, types = typesObj)) - } else { - return(list(value = newObj, types = NULL)) - } +.normalizeSingleModulePath <- function(modulePath, expectedNames = character(0), + context = "`modulePath`") { + pathNames <- names(modulePath) + + if (.hasUsableNames(modulePath) && length(expectedNames) > 0L) { + matchIndex <- match(expectedNames, pathNames, nomatch = 0L) + matchIndex <- matchIndex[matchIndex > 0L] + if (length(matchIndex) > 0L) + return(.normalizeModulePathValue(modulePath, matchIndex[[1L]])) + + usableNames <- pathNames[!is.na(pathNames) & nzchar(pathNames)] + stop( + "`modulePath` names (", paste(usableNames, collapse = ", "), + ") do not match ", context, ".", + call. = FALSE + ) } - # Find all options that need processing - nms <- names(options) - nms <- nms[nms != ".meta"] - - for (nm in nms) { - opt <- options[[nm]] + if (length(modulePath) != 1L) { + stop( + "`modulePath` must be a single path or a named collection that matches ", + context, ".", + call. = FALSE + ) + } - # Use recursive flattening for all list options - if (is.list(opt)) { - result <- flattenRecursive(opt) - options[[nm]] <- result$value + .normalizeModulePathValue(modulePath, 1L) +} - if (!is.null(result$types)) { - options[[paste0(nm, ".types")]] <- result$types +.normalizeModulePathValue <- function(modulePath, index) { + if (is.list(modulePath)) + modulePath <- modulePath[[index]] + else + modulePath <- modulePath[[index]] - # Update .meta if it exists to include the .types entry - if (!is.null(meta) && nm %in% names(meta)) { - meta[[paste0(nm, ".types")]] <- meta[[nm]] - } - } - } + if (!is.character(modulePath) || length(modulePath) != 1L || + is.na(modulePath) || !nzchar(modulePath)) { + stop("`modulePath` must contain non-empty string paths.", call. = FALSE) } - # Update the meta in options - if (!is.null(meta)) { - options[[".meta"]] <- meta - } - - return(options) - + normalizePath(modulePath, winslash = "/", mustWork = FALSE) } +.hasUsableNames <- function(x) { + nms <- names(x) + !is.null(nms) && any(nzchar(nms)) +} +.modulePathForAnalysisName <- function(analysis, modulePath = NULL) { + if (is.null(modulePath)) + return(getModulePathFromRFunction(analysis)) -parseDescriptionQmlFromAnalysisName <- function(analysisName) { - - modulePath <- getModulePathFromRFunction(analysisName) - if (isBinaryPackage(modulePath)) { - instDir <- modulePath - } else { # source pkg - instDir <- file.path(modulePath, "inst") + pathNames <- names(modulePath) + if (.hasUsableNames(modulePath)) { + matchIndex <- match(analysis, pathNames, nomatch = 0L) + if (matchIndex > 0L) + return(.normalizeModulePathValue(modulePath, matchIndex)) } - pathToDescriptionQml <- file.path(instDir, "Description.qml") - if (!file.exists(pathToDescriptionQml)) { - warning("Could not locate Description.qml in ", modulePath, ". Assuming the module preloads data.") - return(TRUE) + candidatePaths <- .normalizeModulePathCollection(modulePath) + matchesAnalysis <- vapply( + candidatePaths, + .modulePathContainsAnalysis, + logical(1L), + analysis = analysis + ) + + if (sum(matchesAnalysis) == 1L) + return(candidatePaths[matchesAnalysis][[1L]]) + + if (sum(matchesAnalysis) > 1L) { + stop( + "`modulePath` is ambiguous for analysis `", analysis, + "`; more than one supplied module path contains that analysis.", + call. = FALSE + ) } - return(parseDescriptionQmlFromPath(pathToDescriptionQml)) + .normalizeSingleModulePath( + modulePath, + expectedNames = analysis, + context = paste0("analysis `", analysis, "`") + ) } -# some code to test the function below on all Description.qml files in jasp -# dirs <- list.dirs("~/github/jasp/jasp-desktop/Modules", recursive = FALSE) -# qmls <- file.path(dirs, "inst", "Description.qml") -# qmls <- Filter(file.exists, qmls) -# nms <- basename(dirname(dirname(qmls))) -# names(qmls) <- nms -# results <- vector("list", length(nms)) -# names(results) <- nms -# for (nm in nms) { -# cat(nm, "\n") -# results[[nm]] <- jaspTools:::parseDescriptionQmlFromPath(qmls[[nm]]) -# } -parseDescriptionQmlFromPath <- function(pathToDescriptionQml) { - - raw <- trimws(readLines(pathToDescriptionQml)) - raw <- raw[raw != ""] - # drop import statements - raw <- raw[!startsWith(raw, "import")] - # ensure that everything is on a newline - raw <- trimws(unlist(strsplit(raw, ";", fixed = TRUE), use.names = FALSE)) - # remove any whitespace - raw <- gsub("\\s", "", raw) - # transform "Description{}" to c("Description", "{", "}) - raw <- trimws(unlist(strsplit(raw, "(?=\\{)", perl = TRUE), use.names = FALSE)) - raw <- trimws(unlist(strsplit(raw, "(?=\\})", perl = TRUE), use.names = FALSE)) - # "qsTr(\"bla\")" -> "\"bla\"" - raw <- gsub('qsTr\\("(.*)"\\)', "\\1", raw) - - result <- list() - subResults <- NULL - subNames <- character(0L) - depth <- 0L - skipUntilClose <- FALSE - skipCount <- 0L - - groupsToskip <- c("GroupTitle", "Separator", "Timer") - for (i in seq_along(raw)) { - - if (!skipUntilClose) { - - hasColon <- grepl(":", raw[i], fixed = TRUE) - if (!hasColon && grepl("{", raw[i + 1], fixed = TRUE)) { - - if (any(vapply(groupsToskip, function(x) identical(raw[i], x), FUN.VALUE = logical(1L)))) { - skipUntilClose <- TRUE - next - } - - depth <- depth + 1L - subNames[[depth]] <- raw[i] - subResult <- list() - subResults[[depth]] <- list() - - } else if (hasColon) { - - match <- regexec("([^:]+):(.*)", raw[i]) - parts <- regmatches(raw[i], match)[[1]] - key <- parts[2] - value <- parts[3] - # remove quotes at the start and end of the string - value <- gsub("^[\"']|[\"']$", "", value) - - subResults[[depth]][[key]] <- switch( - value, - "false" = FALSE, - "true" = TRUE, - value - ) - - } else if (grepl("}", raw[i], fixed = TRUE)) { - - subName <- subNames[[depth]] - subResult <- subResults[[depth]] - if (!is.null(subResult) && length(subResult) > 0L) { - - # rather than "Analysis", use the name of the R function - if (subName == "Analysis") - subName <- subResult[["func"]] - - result[[subName]] <- subResult - - } - - result[[subName]] <- subResult - depth <- depth - 1L +.normalizeModulePathCollection <- function(modulePath) { + if (is.list(modulePath)) { + paths <- vapply(modulePath, function(path) { + if (!is.character(path) || length(path) != 1L || + is.na(path) || !nzchar(path)) { + stop("`modulePath` must contain non-empty string paths.", call. = FALSE) } - } else if (grepl("{" , raw[i], fixed = TRUE)) { - skipCount <- skipCount + 1L - } else if (grepl("}", raw[i], fixed = TRUE)) { - - skipCount <- skipCount - 1L - if (skipCount == 0) - skipUntilClose <- FALSE - + normalizePath(path, winslash = "/", mustWork = FALSE) + }, character(1L)) + } else { + if (!is.character(modulePath) || any(is.na(modulePath)) || any(!nzchar(modulePath))) { + stop("`modulePath` must contain non-empty string paths.", call. = FALSE) } + + paths <- normalizePath(modulePath, winslash = "/", mustWork = FALSE) } - return(result) + names(paths) <- names(modulePath) + paths +} +.modulePathContainsAnalysis <- function(modulePath, analysis) { + isTRUE(tryCatch({ + jaspSyntax::resolveAnalysisQml(modulePath, analysis) + TRUE + }, error = function(e) FALSE)) || + isTRUE(tryCatch(rFunctionExistsInModule(analysis, modulePath), error = function(e) FALSE)) } -parsePreloadDataFromDescriptionQml <- function(analysisName) { +.jaspSyntaxReadAnalysisOptionsFromJaspFile <- function(file, modulePath = NULL, + runtime = FALSE, + includeMeta = TRUE, + includeTypeOptions = TRUE, + isolated = TRUE) { + if (is.null(modulePath)) { + modulePath <- .jaspSyntaxRuntimeModulePaths() + } - description <- parseDescriptionQmlFromAnalysisName(analysisName) + .jaspSyntaxReadAnalysisOptionsNative( + file = file, + modulePath = modulePath, + runtime = runtime, + includeMeta = includeMeta, + includeTypeOptions = includeTypeOptions, + isolated = isolated + ) +} - # is preloadData globally set to TRUE? - preloadDataGlobalSpecified <- "preloadData" %in% names(description[["Description"]]) - preloadGlobalValue <- preloadDataGlobalSpecified && isTRUE(description[["Description"]][["preloadData"]]) - # is preloadData even set for this specific analysis? - specifiedPreloadDataLocal <- "preloadData" %in% names(description[[analysisName]]) - # is preloadData set to TRUE for this specific analysis? +.jaspSyntaxReadAnalysisOptionsNative <- function(file, modulePath, runtime, + includeMeta, + includeTypeOptions, + isolated) { + jaspSyntax::readAnalysisOptionsFromJaspFile( + jaspFilePath = file, + modulePath = modulePath, + runtime = runtime, + includeMeta = includeMeta, + includeTypeOptions = includeTypeOptions, + isolated = isolated + ) +} - preloadDataAnalysis <- specifiedPreloadDataLocal && isTRUE(description[[analysisName]][["preloadData"]]) - # if preloadData set to TRUE for the analysis, or if set globally to TRUE and not set for the analysis - preloadData <- (specifiedPreloadDataLocal && preloadDataAnalysis) || (!specifiedPreloadDataLocal && preloadDataGlobalSpecified && preloadGlobalValue) +.jaspSyntaxRuntimeModulePaths <- function() { + modulePaths <- tryCatch(getModulePaths(), error = function(e) character(0)) + if (length(modulePaths) == 0L) { + return(NULL) + } - # new default, if not specified set to TRUE - if (!specifiedPreloadDataLocal && !preloadDataGlobalSpecified) - preloadData <- TRUE + .jaspSyntaxNamedModulePaths(modulePaths) +} - # show a warning but if preloadData is not set for the analysis - if (!preloadData) - lifecycle::deprecate_warn( - when = "0.19.2", - what = I(sprintf("The analysis `%s` does not preload data. Please update inst/Description.qml, add `preloadData: true`, and fix any minor issues.", analysisName)) - ) +.jaspSyntaxNamedModulePaths <- function(modulePaths) { + moduleNames <- vapply( + modulePaths, + function(modulePath) tryCatch(getModuleName(modulePath), error = function(e) ""), + character(1L) + ) - return(preloadData) + keep <- nzchar(moduleNames) + if (!any(keep)) { + return(NULL) + } + modulePaths <- normalizePath(modulePaths[keep], winslash = "/", mustWork = FALSE) + stats::setNames(as.list(modulePaths), moduleNames[keep]) } diff --git a/R/pkg-setup.R b/R/pkg-setup.R index 7171c57..50415f4 100644 --- a/R/pkg-setup.R +++ b/R/pkg-setup.R @@ -133,6 +133,9 @@ getSetupCompleteFileName <- function() { } .isSetupComplete <- function() { + if (isTRUE(.pkgenv[["internal"]][["setupCompleteOverride"]])) + return(TRUE) + return(file.exists(getSetupCompleteFileName())) } diff --git a/R/rbridge.R b/R/rbridge.R index 90ce720..7ce15c0 100644 --- a/R/rbridge.R +++ b/R/rbridge.R @@ -1,64 +1,79 @@ -# functions / properties to replace JASP's rcpp functions / properties +# Minimal local replacements for non-dataset JASP Rcpp bridge callbacks. +# +# The active contract is intentionally narrow: jaspTools only provides fallback +# objects that jaspBase::runWrappedAnalysis()/runJaspResults() can request +# through jaspBase:::.fromRCPP() while running outside Desktop. Dataset loading, +# option parsing, option encoding, column encoding/decoding, and computed-column +# mutation belong to jaspSyntax/SyntaxInterface or Desktop itself. +# +# The bridge objects are kept in the jaspTools namespace because +# jaspBase:::.fromRCPP() resolves hidden functions via getAnywhere(). +.rbridgeNativeSymbols <- function() { + c( + ".baseCitation", + ".ppi", + ".requestTempFileNameNative", + ".requestTempRootNameNative", + ".requestStateFileNameNative", + ".imageBackground" + ) +} -# These are not used in combination with getAnywhere() in the code so they cannot be found .insertRbridgeIntoEnv <- function(env) { - env[[".automaticColumnEncDecoding"]] <- FALSE - env[[".encodeColNamesStrict"]] <- function(x) return(x) - env[[".decodeColNamesStrict"]] <- function(x) return(x) - env[[".encodeColNamesLax"]] <- function(x) return(x) - env[[".decodeColNamesLax"]] <- function(x) return(x) - env[[".decodeColTypes"]] <- function(x) return(x) - env[[".encodeColNamesStrict"]] <- function(x) return(x) - - env[[".setColumnDataAsScale"]] <- function(...) return(TRUE) - env[[".setColumnDataAsOrdinal"]] <- function(...) return(TRUE) - env[[".setColumnDataAsNominal"]] <- function(...) return(TRUE) - env[[".setColumnDataAsNominalText"]] <- function(...) return(TRUE) - - env[[".allColumnNamesDataset"]] <- function(...) { - dataset <- .getInternal("dataset") - dataset <- loadCorrectDataset(dataset) - return(colnames(dataset)) + namespace <- asNamespace("jaspTools") + for (symbol in .rbridgeNativeSymbols()) { + assign(symbol, get(symbol, envir = namespace, inherits = FALSE), envir = env) } -} - -# These are used in combination with getAnywhere() and can stay in the jaspTools namespace -.ppi <- 192 - -.baseCitation <- "x" -.readDatasetToEndNative <- function(columns = c(), columns.as.numeric = c(), columns.as.ordinal = c(), - columns.as.factor = c(), all.columns = FALSE) { + invisible(env) +} - dataset <- .getInternal("dataset") - dataset <- loadCorrectDataset(dataset) +.snapshotRbridgeEnv <- function(env, symbols = .rbridgeNativeSymbols()) { + state <- lapply(symbols, function(symbol) { + if (!exists(symbol, envir = env, inherits = FALSE)) + return(list(exists = FALSE, locked = FALSE, value = NULL)) + + list( + exists = TRUE, + locked = bindingIsLocked(symbol, env), + value = get(symbol, envir = env, inherits = FALSE) + ) + }) + names(state) <- symbols + state +} - if (all.columns) { - columns <- colnames(dataset) - columns <- columns[columns != ""] +.restoreRbridgeEnv <- function(env, state) { + if (!is.list(state)) + return(invisible(FALSE)) + + for (symbol in names(state)) { + previous <- state[[symbol]] + currentlyExists <- exists(symbol, envir = env, inherits = FALSE) + currentlyLocked <- currentlyExists && bindingIsLocked(symbol, env) + + if (currentlyLocked) + unlockBinding(symbol, env) + + if (isTRUE(previous$exists)) { + assign(symbol, previous$value, envir = env) + if (isTRUE(previous$locked)) + lockBinding(symbol, env) + } else if (currentlyExists) { + rm(list = symbol, envir = env) + } } - dataset <- jaspBase:::.vdf(dataset, columns, columns.as.numeric, columns.as.ordinal, - columns.as.factor, all.columns, exclude.na.listwise = c()) - return(dataset) + invisible(TRUE) } -.readDataSetHeaderNative <- function(columns = c(), columns.as.numeric = c(), columns.as.ordinal = c(), - columns.as.factor = c(), all.columns = FALSE) { - - dataset <- .readDatasetToEndNative(columns, columns.as.numeric, columns.as.ordinal, - columns.as.factor, all.columns) - dataset <- dataset[0, , drop = FALSE] - - return(dataset) -} +.ppi <- 192 -.readDataSetRequestedNative <- function() { - return(.getInternal("preloadedDataset")) -} +.baseCitation <- "x" .requestTempFileNameNative <- function(...) { root <- getTempOutputLocation("html") + dir.create(file.path(root, "plots"), recursive = TRUE, showWarnings = FALSE) numPlots <- length(list.files(file.path(root, "plots"))) list( root = root, @@ -66,13 +81,34 @@ ) } +.requestTempRootNameNative <- function() { + root <- getTempOutputLocation("html") + dir.create(file.path(root, "plots"), recursive = TRUE, showWarnings = FALSE) + list(root = root, relativePath = "") +} + .requestStateFileNameNative <- function() { - root <- getTempOutputLocation("state") - name <- "state" + stateFile <- .runStateFilePath() + if (!file.exists(stateFile)) + .resetRunStateFile() + list( - root = root, - relativePath = name + root = dirname(stateFile), + relativePath = basename(stateFile) ) } +.runStateFilePath <- function() { + root <- getTempOutputLocation("state") + dir.create(root, recursive = TRUE, showWarnings = FALSE) + file.path(root, "state") +} + +.resetRunStateFile <- function() { + stateFile <- .runStateFilePath() + state <- NULL + save(state, file = stateFile, compress = FALSE) + invisible(stateFile) +} + .imageBackground <- function(...) return("white") diff --git a/R/run.R b/R/run.R index 6cc31c2..96cea83 100644 --- a/R/run.R +++ b/R/run.R @@ -19,9 +19,18 @@ #' \code{analysisOptions}). #' @param view Boolean indicating whether to view the results in a webbrowser. #' @param quiet Boolean indicating whether to suppress messages from the -#' analysis. +#' analysis and native QML bridge. Quiet runs are evaluated in a subprocess so +#' native Desktop logging does not clutter the calling R session. #' @param makeTests Boolean indicating whether to create testthat unit tests and print them to the terminal. -#' @param encodedDataset Boolean indicating whether to assume that the dataset is already encoded. +#' @param modulePath Optional path to the module checkout that should be used +#' for QML resolution and wrapped execution. When omitted, jaspTools first +#' uses a module path attached to \code{options} by \code{analysisOptions()} +#' and then falls back to configured \code{module.dirs}. +#' @details +#' Saved/QML-bound options are replayed through the native QML runtime path. Use +#' \code{analysisOptions()} for options that should be passed to +#' \code{runAnalysis()}; options returned by \code{analysisRuntimeOptions()} are +#' backend-prepared diagnostics and are not accepted by this runner. #' @examples #' #' options <- analysisOptions("BinomialTest") @@ -55,13 +64,22 @@ #' #' #' @export runAnalysis -runAnalysis <- function(name, dataset = NULL, options, view = TRUE, quiet = FALSE, makeTests = FALSE, encodedDataset = FALSE) { +runAnalysis <- function(name, dataset = NULL, options, view = TRUE, quiet = TRUE, + makeTests = FALSE, modulePath = NULL) { if (is.list(options) && is.null(names(options)) && any(names(unlist(lapply(options, attributes))) == "analysisName")) stop("The provided list of options is not named. Did you mean to index in the options list (e.g., options[[1]])?") if (!is.list(options) || is.null(names(options))) stop("The options should be a named list (you can obtain it through `analysisOptions()`") + if (isPreparedOptions(options)) { + stop( + "`runAnalysis()` expects saved/QML-bound options. ", + "`analysisRuntimeOptions()` returns backend-prepared options for inspection only; ", + "use `analysisOptions()` to obtain runnable options." + ) + } + if (missing(name)) { name <- attr(options, "analysisName") if (is.null(name)) @@ -73,26 +91,52 @@ runAnalysis <- function(name, dataset = NULL, options, view = TRUE, quiet = FALS quiet <- TRUE } + if (runAnalysisShouldUseSubprocess(quiet = quiet)) { + return(runAnalysisInSubprocess( + name = name, + dataset = dataset, + options = options, + view = view, + quiet = quiet, + makeTests = makeTests, + modulePath = modulePath + )) + } + + args <- fetchRunArgs(name, options, modulePath = modulePath) + modulePath <- attr(args, "modulePath", exact = TRUE) + runner <- attr(args, "runner", exact = TRUE) + attr(args, "runner") <- NULL + attr(args, "modulePath") <- NULL + oldWd <- getwd() oldLang <- Sys.getenv("LANG") oldLanguage <- Sys.getenv("LANGUAGE") + + rbridgeState <- .snapshotRbridgeEnv(.GlobalEnv) on.exit({ .resetRunTimeInternals() + .restoreRbridgeEnv(.GlobalEnv, rbridgeState) setwd(oldWd) Sys.setenv(LANG = oldLang) Sys.setenv(LANGUAGE = oldLanguage) }, add = TRUE) - initAnalysisRuntime(dataset = dataset, options = options, makeTests = makeTests, encodedDataset = encodedDataset) - args <- fetchRunArgs(name, options) + initAnalysisRuntime( + dataset = dataset, + options = options, + modulePath = modulePath, + analysisName = name, + makeTests = makeTests + ) if (quiet) { sink(tempfile()) on.exit({suppressWarnings(sink(NULL))}, add = TRUE) - returnVal <- suppressWarnings(do.call(jaspBase::runJaspResults, args)) + returnVal <- do.call(runner, args) sink(NULL) } else { - returnVal <- do.call(jaspBase::runJaspResults, args) + returnVal <- do.call(runner, args) } # always TRUE after jaspResults is merged into jaspBase @@ -101,16 +145,13 @@ runAnalysis <- function(name, dataset = NULL, options, view = TRUE, quiet = FALS } else { getJsonResultsFromJaspResultsLegacy() } + storeRawLastResults(jsonResults) transferPlotsFromjaspResults() results <- processJsonResults(jsonResults) - if (insideTestEnvironment()) - .setInternal("lastResults", jsonResults) - - if (view) - view(jsonResults) + viewRunAnalysisResults(results, view) if (makeTests) makeUnitTestsFromResults(results, name, dataset, options) @@ -118,31 +159,294 @@ runAnalysis <- function(name, dataset = NULL, options, view = TRUE, quiet = FALS return(invisible(results)) } -fetchRunArgs <- function(name, options) { +runAnalysisShouldUseSubprocess <- function(quiet, + testEnvironment = insideTestEnvironment()) { + isTRUE(getOption("jaspTools.runAnalysis.subprocess", TRUE)) && + (isTRUE(quiet) || isTRUE(testEnvironment)) && + !identical(Sys.getenv("JASPTOOLS_RUNANALYSIS_CHILD"), "true") +} + +runAnalysisInSubprocess <- function(name, dataset, options, view, quiet, + makeTests, modulePath = NULL) { + payload <- .jaspToolsSubprocessPayload( + extra = list(args = list( + name = name, + dataset = dataset, + options = options, + view = FALSE, + quiet = FALSE, + makeTests = FALSE, + modulePath = modulePath + )), + env = .jaspToolsSubprocessEnv( + "JASPTOOLS_RUNANALYSIS_CHILD", + inherited = c("NOT_CRAN", "LANG", "LANGUAGE") + ) + ) + + subprocessResult <- .jaspToolsRunSubprocess( + prefix = "jaspTools-runAnalysis-", + payload = payload, + scriptLines = runAnalysisSubprocessScript(), + failureMessage = "`runAnalysis()` subprocess failed before returning a result", + launcher = launchRunAnalysisSubprocess, + readResult = function(path) suppressPackageStartupMessages(readRDS(path)), + isError = function(result) { + inherits(.runAnalysisSubprocessResult(result), "jaspTools.subprocessError") + } + ) + if (is.list(subprocessResult) && !is.null(subprocessResult$lastResults)) + .setInternal("lastResults", subprocessResult$lastResults) + + restoreSubprocessHtmlFiles(subprocessResult$htmlFiles) + + result <- .runAnalysisSubprocessResult(subprocessResult) + + replaySubprocessWarnings(subprocessResult$warnings) + + .stopIfJaspToolsSubprocessError(result) + + viewRunAnalysisResults(result, view) + + if (makeTests) + makeUnitTestsFromResults(result, name, dataset, options) + + invisible(result) +} + +.runAnalysisSubprocessResult <- function(subprocessResult) { + if (is.list(subprocessResult) && "result" %in% names(subprocessResult)) + return(subprocessResult$result) + + subprocessResult +} + +launchRunAnalysisSubprocess <- function(scriptPath, inputPath, outputPath, logPath) { + .jaspToolsLaunchSubprocess(scriptPath, inputPath, outputPath, logPath) +} + +viewRunAnalysisResults <- function(results, enabled) { + if (!isTRUE(enabled)) + return(invisible(NULL)) + + get("view", envir = asNamespace("jaspTools"), inherits = FALSE)(results) +} + +runAnalysisSubprocessScript <- function() { + .jaspToolsSubprocessScript( + beforeResultLines = "warnings <- character(0)", + resultLines = c( + "result <- tryCatch(", + " withCallingHandlers(", + " do.call(jaspTools::runAnalysis, payload$args),", + " warning = function(w) {", + " warnings <<- c(warnings, conditionMessage(w))", + " tryInvokeRestart('muffleWarning')", + " }", + " ),", + " error = .jaspToolsSubprocessError", + ")", + "lastResults <- tryCatch(jaspTools:::.getInternal('lastResults'), error = function(e) NULL)", + "htmlFiles <- tryCatch(jaspTools:::collectSubprocessHtmlFiles(), error = function(e) NULL)" + ), + saveLines = "saveRDS(list(result = result, lastResults = lastResults, htmlFiles = htmlFiles, warnings = unique(warnings)), args[[2L]])" + ) +} + +replaySubprocessWarnings <- function(warnings) { + if (!is.character(warnings) || length(warnings) == 0L) + return(invisible(FALSE)) + + for (warningMessage in warnings) + warning(warningMessage, call. = FALSE, immediate. = TRUE) + + invisible(TRUE) +} + +collectSubprocessHtmlFiles <- function(root = getTempOutputLocation("html")) { + if (!dir.exists(root)) + return(list(files = list())) + + paths <- list.files(root, all.files = TRUE, no.. = TRUE, recursive = TRUE, + full.names = TRUE, include.dirs = FALSE) + if (length(paths) == 0L) + return(list(files = list())) + + root <- normalizePath(root, winslash = "/", mustWork = TRUE) + files <- lapply(paths, function(path) { + normalizedPath <- normalizePath(path, winslash = "/", mustWork = TRUE) + relativePath <- substring(normalizedPath, nchar(root) + 2L) + fileSize <- file.info(normalizedPath)$size + list( + path = relativePath, + bytes = readBin(normalizedPath, what = "raw", n = fileSize) + ) + }) + + list(files = files) +} + +restoreSubprocessHtmlFiles <- function(htmlFiles, root = getTempOutputLocation("html")) { + if (!is.list(htmlFiles) || length(htmlFiles$files) == 0L) + return(invisible(FALSE)) + + dir.create(root, recursive = TRUE, showWarnings = FALSE) + for (file in htmlFiles$files) { + if (!is.list(file) || is.null(file$path) || is.null(file$bytes)) + next + + target <- file.path(root, file$path) + dir.create(dirname(target), recursive = TRUE, showWarnings = FALSE) + writeBin(file$bytes, target) + } + + invisible(TRUE) +} + +fetchRunArgs <- function(name, options, modulePath = NULL) { + fetchWrappedRunArgs(name, options, modulePath = modulePath) +} + +fetchWrappedRunArgs <- function(name, options, modulePath = NULL) { + runner <- .jaspBaseRunWrappedAnalysis() + .validateRunWrappedAnalysisContract(runner) + + modulePath <- .resolveRunModulePath(name, options, modulePath = modulePath) + resolved <- .jaspSyntaxResolveAnalysisQml(modulePath, name) + .validateOptionsMatchResolvedAnalysis(options, resolved) + possibleArgs <- list( - name = name, - functionCall = findCorrectFunction(name), - title = "", - requiresInit = TRUE, - options = jsonlite::toJSON(options), - dataKey = "null", - resultsMeta = "null", - stateKey = "null", - preloadData = parsePreloadDataFromDescriptionQml(name) + moduleName = resolved$moduleName, + analysisName = resolved$analysisName, + qmlFileName = resolved$qmlFileName, + qmlFile = resolved$qmlFile, + modulePath = modulePath, + options = options, + version = resolved$version, + preloadData = resolved$preloadData ) - runArgs <- formals(jaspBase::runJaspResults) + runArgs <- formals(runner) argNames <- intersect(names(possibleArgs), names(runArgs)) - return(possibleArgs[argNames]) + args <- possibleArgs[argNames] + attr(args, "runner") <- runner + attr(args, "modulePath") <- modulePath + return(args) +} + +.jaspBaseRunWrappedAnalysis <- function() { + if (!exists("runWrappedAnalysis", envir = asNamespace("jaspBase"), inherits = FALSE)) { + stop( + "Installed jaspBase does not provide `runWrappedAnalysis()`. ", + "Update jaspBase so jaspTools can use the native QML/options runtime path." + ) + } + + get("runWrappedAnalysis", envir = asNamespace("jaspBase"), inherits = FALSE) } -initAnalysisRuntime <- function(dataset, options, makeTests, encodedDataset = FALSE, ...) { +.validateRunWrappedAnalysisContract <- function(runner) { + requiredArgs <- c( + "moduleName", + "analysisName", + "qmlFileName", + "options", + "version", + "preloadData", + "modulePath", + "qmlFile" + ) + missingArgs <- setdiff(requiredArgs, names(formals(runner))) + + if (length(missingArgs) > 0L) { + stop( + "Installed jaspBase::runWrappedAnalysis() does not support source-module ", + "replay arguments: ", paste(missingArgs, collapse = ", "), ". ", + "Install jaspBase >= 0.20.5 from the matching jasp-desktop checkout so ", + "jaspTools can pass resolved QML and module provenance.", + call. = FALSE + ) + } + + invisible(TRUE) +} + +.resolveRunModulePath <- function(name, options, modulePath = NULL) { + if (!is.null(modulePath)) + return(.normalizeRunModulePath(modulePath)) + + optionModulePath <- attr(options, "modulePath", exact = TRUE) + if (!is.null(optionModulePath)) + return(.normalizeRunModulePath(optionModulePath)) + + getModulePathFromRFunction(name) +} + +.normalizeRunModulePath <- function(modulePath) { + if (!is.character(modulePath) || length(modulePath) != 1L || + is.na(modulePath) || !nzchar(modulePath)) { + stop("`modulePath` must be a single non-empty string.", call. = FALSE) + } + + normalizePath(modulePath, winslash = "/", mustWork = FALSE) +} + +.validateOptionsMatchResolvedAnalysis <- function(options, resolved) { + optionAnalysisName <- .scalarOptionAttribute(options, "analysisName") + if (!is.null(optionAnalysisName) && + !identical(optionAnalysisName, as.character(resolved$analysisName))) { + stop( + "`options` are tagged for analysis `", optionAnalysisName, + "`, but `runAnalysis()` is running `", resolved$analysisName, "`." + ) + } + + optionModuleName <- .scalarOptionAttribute(options, "moduleName") + if (!is.null(optionModuleName) && + !identical(optionModuleName, as.character(resolved$moduleName))) { + stop( + "`options` are tagged for module `", optionModuleName, + "`, but `runAnalysis()` resolved module `", resolved$moduleName, "`." + ) + } + + invisible(TRUE) +} + +.scalarOptionAttribute <- function(options, name) { + value <- attr(options, name, exact = TRUE) + if (is.null(value) || length(value) == 0L || is.na(value[[1L]]) || !nzchar(value[[1L]])) + return(NULL) + + as.character(value[[1L]]) +} + +.jaspSyntaxResolveAnalysisQml <- function(modulePath, analysisName) { + if (!exists("resolveAnalysisQml", envir = asNamespace("jaspSyntax"), inherits = FALSE)) { + stop( + "Installed jaspSyntax does not provide `resolveAnalysisQml()`. ", + "Install the jaspSyntax build that exposes the native QML parser API." + ) + } + + jaspSyntax::resolveAnalysisQml(modulePath, analysisName) +} + +initAnalysisRuntime <- function(dataset, options, makeTests, modulePath = NULL, + analysisName = NULL, ...) { # first we reinstall any changed modules in the personal library reinstallChangedModules() # dataset to be found in the analysis when it needs to be read .setInternal("dataset", dataset) - preloadDataset(dataset, options, encodedDataset = encodedDataset) + .resetRunStateFile() + preloadDataset( + dataset, + options, + modulePath = modulePath, + analysisName = analysisName + ) + .insertRbridgeIntoEnv(.GlobalEnv) # prevent the results from being translated (unless the user explicitly wants to) Sys.setenv(LANG = getPkgOption("language")) @@ -215,7 +519,10 @@ processJsonResults <- function(jsonResults) { else stop("Could not process json result from jaspResults") - results[["state"]] <- .getInternal("state") + results <- .jaspSyntaxDecodeAnalysisResults(results) + + results[["state"]] <- .readRunState() + results[["state"]] <- decodeJaspResultState(results[["state"]]) figures <- results$state$figures if (length(figures) > 1 && !is.null(names(figures))) @@ -224,6 +531,98 @@ processJsonResults <- function(jsonResults) { return(results) } +.readRunState <- function() { + fileState <- .readRunStateFile() + if (!is.null(fileState)) + return(fileState) + + .getInternal("state") +} + +.readRunStateFile <- function() { + location <- tryCatch( + .requestStateFileNameNative(), + error = function(e) NULL + ) + if (!is.list(location) || is.null(location$root) || is.null(location$relativePath)) + return(NULL) + + stateFile <- file.path(location$root, location$relativePath) + if (!file.exists(stateFile)) + return(NULL) + + state <- NULL + loaded <- tryCatch( + load(stateFile), + error = function(e) character(0) + ) + if (!"state" %in% loaded) + return(NULL) + + state +} + +decodeJaspResultState <- function(state) { + if (!is.list(state) || is.null(state[["figures"]])) + return(state) + + for (figureName in names(state[["figures"]])) { + figure <- state[["figures"]][[figureName]] + if (is.list(figure) && !is.null(figure[["obj"]])) { + figure[["obj"]] <- decodeJaspPlotObject(figure[["obj"]]) + state[["figures"]][[figureName]] <- figure + } + } + + state +} + +decodeJaspPlotObject <- function(plot) { + tryCatch( + jaspBase:::decodeplot(plot, returnGrob = FALSE), + error = function(e) plot + ) +} + +.jaspSyntaxDecodeAnalysisResults <- function(results) { + requestedDataset <- tryCatch( + .getInternal("preloadedDataset"), + error = function(e) NULL + ) + args <- list(results = results) + if (is.data.frame(requestedDataset) && ncol(requestedDataset) > 0L) + args$requestedDataset <- requestedDataset + + columnMapping <- tryCatch( + .getInternal("preloadedColumnMapping"), + error = function(e) NULL + ) + if (is.character(columnMapping) && length(columnMapping) > 0L && + !is.null(names(columnMapping))) { + args$columnMapping <- columnMapping + } + + decoded <- .jaspSyntaxCall( + "decodeAnalysisResults", + args = args, + required = TRUE, + feature = "native analysis result decoding API", + requiredArgs = "results" + ) + + if (is.null(decoded)) + return(results) + + decoded +} + +storeRawLastResults <- function(jsonResults) { + if (is.character(jsonResults) && length(jsonResults) == 1L) + .setInternal("lastResults", jsonResults) + + invisible(jsonResults) +} + transferPlotsFromjaspResults <- function() { pathPlotsjaspResults <- file.path(tempdir(), "jaspResults", "plots") # as defined in jaspResults pkg pathPlotsjaspTools <- getTempOutputLocation("html") @@ -244,6 +643,10 @@ getJsonResultsFromJaspResultsLegacy <- function() { } .resetRunTimeInternals <- function() { + .jaspSyntaxClearNativeState(required = FALSE) + .resetRunStateFile() .setInternal("state", list()) .setInternal("dataset", "") + .setInternal("preloadedDataset", data.frame()) + .setInternal("preloadedColumnMapping", character(0)) } diff --git a/R/subprocess.R b/R/subprocess.R new file mode 100644 index 0000000..abde4c6 --- /dev/null +++ b/R/subprocess.R @@ -0,0 +1,167 @@ +.jaspToolsSubprocessEnv <- function(childFlag, inherited = character()) { + env <- if (length(inherited) > 0L) + as.list(Sys.getenv(inherited, unset = "")) + else + list() + env[[childFlag]] <- "true" + env +} + +.jaspToolsSubprocessPayload <- function(extra = list(), env = list()) { + payload <- list( + wd = getwd(), + libPaths = .libPaths(), + sourcePath = .jaspToolsSourcePath(), + pkgOptions = .pkgenv[["pkgOptions"]], + rOptions = .jaspToolsSubprocessOptions(), + env = env + ) + + if (length(extra) > 0L) { + payload[names(extra)] <- extra + } + payload +} + +.jaspToolsSubprocessOptions <- function() { + optionNames <- c("jaspLegacyRngKind") + currentOptions <- options() + currentOptions[intersect(optionNames, names(currentOptions))] +} + +.jaspToolsRunSubprocess <- function(prefix, payload, scriptLines, + failureMessage, + launcher = .jaspToolsLaunchSubprocess, + readResult = readRDS, + isError = function(result) FALSE) { + scriptPath <- tempfile(prefix, fileext = ".R") + inputPath <- tempfile(prefix, fileext = ".rds") + outputPath <- tempfile(prefix, fileext = ".rds") + logPath <- tempfile(prefix, fileext = ".log") + on.exit(unlink(c(scriptPath, inputPath, outputPath), force = TRUE), add = TRUE) + + saveRDS(payload, inputPath) + writeLines(scriptLines, scriptPath) + + status <- launcher(scriptPath, inputPath, outputPath, logPath) + if (!file.exists(outputPath)) { + stop( + failureMessage, + if (!is.null(status)) paste0(" (exit status ", status, ")") else "", + ". Log: ", logPath, + .jaspToolsSubprocessLogTail(logPath) + ) + } + + result <- readResult(outputPath) + resultIsError <- isTRUE(isError(result)) + if (!is.null(status) && status != 0L && !resultIsError) { + stop( + failureMessage, + " (exit status ", status, "). Log: ", logPath, + .jaspToolsSubprocessLogTail(logPath), + call. = FALSE + ) + } + + if (!resultIsError) { + unlink(logPath, force = TRUE) + } + result +} + +.jaspToolsLaunchSubprocess <- function(scriptPath, inputPath, outputPath, logPath) { + rscript <- file.path(R.home("bin"), if (.Platform$OS.type == "windows") "Rscript.exe" else "Rscript") + system2( + rscript, + c(normalizePath(scriptPath, winslash = "/", mustWork = TRUE), + normalizePath(inputPath, winslash = "/", mustWork = TRUE), + normalizePath(outputPath, winslash = "/", mustWork = FALSE)), + stdout = logPath, + stderr = logPath + ) +} + +.jaspToolsSubprocessLogTail <- function(logPath, n = 40L) { + if (!file.exists(logPath)) { + return("") + } + + logTail <- paste(utils::tail(readLines(logPath, warn = FALSE), n), collapse = "\n") + if (nzchar(logTail)) paste0("\n", logTail) else "" +} + +.jaspToolsSubprocessScript <- function(resultLines, saveLines, + beforeResultLines = character(0), + statusExpression = "inherits(result, 'jaspTools.subprocessError')") { + c( + "args <- commandArgs(trailingOnly = TRUE)", + "payload <- readRDS(args[[1L]])", + ".libPaths(payload$libPaths)", + "setwd(payload$wd)", + ".jaspToolsSetEnvForChild <- function(env) {", + " if (is.list(env) && length(env) > 0L)", + " do.call(Sys.setenv, env)", + "}", + ".jaspToolsSetEnvForChild(payload$env)", + ".jaspToolsRestoreROptionsForChild <- function(rOptions) {", + " if (is.list(rOptions) && length(rOptions) > 0L)", + " do.call(options, rOptions)", + " invisible(NULL)", + "}", + ".jaspToolsRestoreROptionsForChild(payload$rOptions)", + ".loadJaspToolsForChild <- function(sourcePath) {", + " if (!is.null(sourcePath) && is.character(sourcePath) && length(sourcePath) == 1L &&", + " file.exists(file.path(sourcePath, 'R', 'run.R'))) {", + " if (!requireNamespace('pkgload', quietly = TRUE))", + " stop('pkgload is required to run jaspTools child processes from a source checkout')", + " pkgload::load_all(sourcePath, quiet = TRUE)", + " } else {", + " suppressPackageStartupMessages(library(jaspTools))", + " }", + "}", + ".jaspToolsSubprocessError <- function(e) {", + " structure(list(message = conditionMessage(e)), class = 'jaspTools.subprocessError')", + "}", + ".loadJaspToolsForChild(payload$sourcePath)", + ".jaspToolsRestorePkgOptionsForChild <- function(pkgOptions) {", + " if (!is.list(pkgOptions) || length(pkgOptions) == 0L)", + " return(invisible(NULL))", + " pkgEnv <- get('.pkgenv', envir = asNamespace('jaspTools'), inherits = FALSE)", + " pkgEnv[['internal']][['setupCompleteOverride']] <- TRUE", + " pkgEnv[['pkgOptions']][names(pkgOptions)] <- pkgOptions", + " get('.initOutputDirs', envir = asNamespace('jaspTools'), inherits = FALSE)()", + " invisible(NULL)", + "}", + ".jaspToolsRestorePkgOptionsForChild(payload$pkgOptions)", + beforeResultLines, + resultLines, + saveLines, + paste0("quit(save = 'no', status = if (", statusExpression, ") 2L else 0L)") + ) +} + +.jaspToolsSourcePath <- function() { + namespacePath <- tryCatch( + getNamespaceInfo("jaspTools", "path"), + error = function(e) NULL + ) + + if (!is.character(namespacePath) || length(namespacePath) != 1L) { + return(NULL) + } + + if (!file.exists(file.path(namespacePath, "R", "run.R"))) { + return(NULL) + } + + normalizePath(namespacePath, winslash = "/", mustWork = FALSE) +} + +.stopIfJaspToolsSubprocessError <- function(result) { + if (inherits(result, "jaspTools.subprocessError")) { + stop(result$message, call. = FALSE) + } + + invisible(result) +} diff --git a/R/test-generator.R b/R/test-generator.R index 2c5dd0f..f9a7d19 100644 --- a/R/test-generator.R +++ b/R/test-generator.R @@ -19,11 +19,9 @@ #' with hyphens. If FALSE (default), preserves original spacing and characters in filenames. #' @param overwrite Logical. If TRUE, overwrites existing test files. If FALSE (default), #' skips files that already exist. -#' @param forceEncode Optional character vector of option names that should be forcibly -#' encoded using regular expression replacement. This is useful for options like -#' \code{model} that contain variable names embedded in strings (e.g., formula syntax -#' "A~B") but do not have a parallel \code{.types} entry. These options will have all -#' column names replaced with their encoded equivalents using word-boundary-aware regex. +#' @param forceEncode Compatibility argument retained for older callers. Supplying +#' a non-`NULL` value now aborts because generated tests run directly against +#' the extracted options and dataset without a separate encoding step. #' #' @details #' This function processes JASP example files stored under @@ -38,7 +36,6 @@ #' #' **Prerequisites:** #' - \code{setupJaspTools()} must be run before using this function -#' - Packages 'DBI' and 'RSQLite' are required for extracting data from JASP files #' #' @return Invisibly returns a character vector of created/processed test file paths. #' @@ -63,13 +60,13 @@ #' # Overwrite existing test files (skips verified by default) #' makeTestsFromExamples(overwrite = TRUE) #' -#' # Force encode 'model' option for analyses with embedded variable names -#' makeTestsFromExamples(forceEncode = "model") #' } #' #' @export makeTestsFromExamples makeTestsFromExamples <- function(path, module.dir, source, sanitize = FALSE, overwrite = FALSE, forceEncode = NULL) { + .rejectForceEncodeArgument(forceEncode) + validSources <- c("library", "verified", "other") # Determine module directory @@ -82,22 +79,7 @@ makeTestsFromExamples <- function(path, module.dir, source, sanitize = FALSE, cli::cli_abort("Module directory does not exist: {.path {module.dir}}") } - pkgAnalyses <- NULL - if (isBinaryPackage(module.dir)) { - qmlPath <- file.path(module.dir, "Description.qml") - } else { - qmlPath <- file.path(module.dir, "inst", "Description.qml") - } - - if (file.exists(qmlPath)) { - qmlContent <- parseDescriptionQmlFromPath(qmlPath) - pkgAnalyses <- setdiff(names(qmlContent), "Description") - } else { - cli::cli_abort(c( - "{.file Description.qml} not found at path: {.path {qmlPath}}.", - "i" = "Make sure the module contains {.file inst/Description.qml} (source) or {.file Description.qml} (installed)." - )) - } + pkgAnalyses <- readModuleAnalysisNames(module.dir) # When path is provided, always target "other" and ignore source if (!missing(path)) { @@ -195,6 +177,52 @@ makeTestsFromExamples <- function(path, module.dir, source, sanitize = FALSE, invisible(createdFiles) } +readModuleAnalysisNames <- function(module.dir) { + description <- tryCatch( + .jaspSyntaxReadModuleDescription(module.dir), + error = function(e) { + cli::cli_abort(c( + "Could not read module description through jaspSyntax.", + "i" = conditionMessage(e) + )) + } + ) + + analyses <- description[["analyses"]] + if (!is.list(analyses) || length(analyses) == 0L) { + cli::cli_abort("Module description does not contain any analyses.") + } + + analysisNames <- vapply( + analyses, + function(analysis) { + name <- analysis[["name"]] + if (is.null(name) || length(name) == 0L || is.na(name)) { + return("") + } + as.character(name) + }, + character(1L) + ) + analysisNames <- analysisNames[nzchar(analysisNames)] + + if (length(analysisNames) == 0L) { + cli::cli_abort("Module description analyses do not contain analysis names.") + } + + analysisNames +} + +.jaspSyntaxReadModuleDescription <- function(module.dir) { + if (!exists("readModuleDescription", envir = asNamespace("jaspSyntax"), inherits = FALSE)) { + cli::cli_abort( + "Installed jaspSyntax does not provide {.fn readModuleDescription}. Update jaspSyntax before generating tests." + ) + } + + jaspSyntax::readModuleDescription(module.dir) +} + .printTestGenerationSummary <- function(createdFiles, skippedFiles, copiedFiles, sources) { if (length(createdFiles) == 0 && length(skippedFiles) == 0) { cli::cli_warn("No test files were created.") @@ -288,7 +316,8 @@ makeTestsFromExamples <- function(path, module.dir, source, sanitize = FALSE, #' \code{tests/testthat/jaspfiles/{sourceFolder}/}. #' @param pkgAnalyses Optional character vector of allowed analysis names for this module. #' If provided, analyses not in this list will be skipped. -#' @param forceEncode Optional character vector of option names to force-encode via regex. +#' @param forceEncode Compatibility argument retained for older callers. Supplying +#' a non-`NULL` value now aborts. #' #' @return The path to the created test file (with attr "skipped" if skipped, #' and attr "copiedTo" if copied), or NULL if no tests were generated @@ -298,8 +327,13 @@ makeTestsFromSingleJASPFile <- function(jaspFile, module.dir, sourceFolder, sanitize = FALSE, overwrite = FALSE, copyToJaspfiles = FALSE, pkgAnalyses = NULL, forceEncode = NULL) { - # Extract options from the JASP file - allOptions <- analysisOptions(jaspFile) + .rejectForceEncodeArgument(forceEncode) + + # Extract options from the JASP file through the module currently under test. + allOptions <- analysisOptionsFromJASPFile( + jaspFile, + modulePath = .jaspSyntaxNamedModulePaths(module.dir) + ) # Ensure it's a list of options (even if single analysis) if (!is.null(attr(allOptions, "analysisName"))) { @@ -378,16 +412,11 @@ makeTestsFromSingleJASPFile <- function(jaspFile, module.dir, sourceFolder, cli::cli_inform("Running analysis {i}/{length(allOptions)}: {.val {analysisName}}") - # Encode options and dataset - encoded <- encodeOptionsAndDataset(opts, dataset, forceEncode = forceEncode) - - # Run the analysis to get results + # Run the analysis tryCatch( { set.seed(1) - results <- runAnalysis(analysisName, encoded$dataset, encoded$options, - view = FALSE, quiet = TRUE, encodedDataset = TRUE - ) + results <- runAnalysis(analysisName, dataset, opts, view = FALSE, quiet = TRUE, modulePath = module.dir) # Generate test block with expectations from results testBlock <- generateExampleTestBlock( @@ -396,8 +425,7 @@ makeTestsFromSingleJASPFile <- function(jaspFile, module.dir, sourceFolder, totalAnalyses = length(allOptions), jaspFileName = basename(jaspFile), sourceFolder = sourceFolder, - results = results, - forceEncode = forceEncode + results = results ) testBlocks <- c(testBlocks, list(testBlock)) @@ -410,8 +438,7 @@ makeTestsFromSingleJASPFile <- function(jaspFile, module.dir, sourceFolder, analysisIndex = i, totalAnalyses = length(allOptions), jaspFileName = basename(jaspFile), - sourceFolder = sourceFolder, - forceEncode = forceEncode + sourceFolder = sourceFolder ) testBlocks <<- c(testBlocks, list(testBlock)) } @@ -477,12 +504,15 @@ generateExampleTestFileContent <- function(baseName, sanitizedName, sourceFolder #' @param sourceFolder String indicating the source folder: \code{"library"}, #' \code{"verified"}, or \code{"other"}. #' @param results The analysis results. -#' @param forceEncode Optional character vector of option names to force-encode via regex. +#' @param forceEncode Compatibility argument retained for older callers. Supplying +#' a non-`NULL` value now aborts. #' #' @return Character string with the test_that block. #' @keywords internal generateExampleTestBlock <- function(analysisName, analysisIndex, totalAnalyses, jaspFileName, sourceFolder, results, forceEncode = NULL) { + .rejectForceEncodeArgument(forceEncode) + # Extract tests from results tests <- tryCatch( { @@ -496,42 +526,23 @@ generateExampleTestBlock <- function(analysisName, analysisIndex, totalAnalyses, # Build the test block lines <- character(0) - # Test description - if (totalAnalyses > 1) { - testDesc <- paste0(analysisName, " (analysis ", analysisIndex, ") results match") - } else { - testDesc <- paste0(analysisName, " results match") - } + testDesc <- .generatedExampleTestDescription( + analysisName, + analysisIndex, + totalAnalyses, + suffix = "results match" + ) lines <- c(lines, paste0('test_that("', testDesc, '", {')) lines <- c(lines, "") - # Extract from JASP file in module's jaspfiles folder - lines <- c(lines, " # Load from JASP example file") - lines <- c(lines, paste0(' jaspFile <- testthat::test_path("jaspfiles", "', sourceFolder, '", "', jaspFileName, '")')) - - # Generate appropriate options extraction based on number of analyses - if (totalAnalyses == 1) { - # Single analysis: analysisOptions returns options directly (not in a list) - lines <- c(lines, " opts <- jaspTools::analysisOptions(jaspFile)") - } else { - # Multiple analyses: analysisOptions returns a list - lines <- c(lines, paste0(" opts <- jaspTools::analysisOptions(jaspFile)[[", analysisIndex, "]]")) - } - - lines <- c(lines, " dataset <- jaspTools::extractDatasetFromJASPFile(jaspFile)") - lines <- c(lines, "") - - # Encode and run - include forceEncode if provided - lines <- c(lines, " # Encode and run analysis") - if (!is.null(forceEncode) && length(forceEncode) > 0) { - forceEncodeStr <- paste0('c("', paste(forceEncode, collapse = '", "'), '")') - lines <- c(lines, paste0(" encoded <- jaspTools:::encodeOptionsAndDataset(opts, dataset, forceEncode = ", forceEncodeStr, ")")) - } else { - lines <- c(lines, " encoded <- jaspTools:::encodeOptionsAndDataset(opts, dataset)") - } - lines <- c(lines, " set.seed(1)") - lines <- c(lines, paste0(' results <- jaspTools::runAnalysis("', analysisName, '", encoded$dataset, encoded$options, encodedDataset = TRUE)')) + lines <- c(lines, .generatedExampleReplayLines( + analysisName = analysisName, + analysisIndex = analysisIndex, + totalAnalyses = totalAnalyses, + jaspFileName = jaspFileName, + sourceFolder = sourceFolder + )) lines <- c(lines, "") # Add expectations @@ -558,10 +569,10 @@ generateExampleTestBlock <- function(analysisName, analysisIndex, totalAnalyses, } } } else { - # Fallback: just check no error - lines <- c(lines, " # Basic check - analysis runs without error") - lines <- c(lines, ' expect_false(isTRUE(results[["status"]] == "error"),') - lines <- c(lines, ' info = results[["results"]][["error"]])') + lines <- .appendGeneratedExampleStatusExpectation( + lines, + comment = " # Basic check - analysis runs without error" + ) } lines <- c(lines, "})") @@ -578,65 +589,149 @@ generateExampleTestBlock <- function(analysisName, analysisIndex, totalAnalyses, #' @param jaspFileName Name of the JASP file. #' @param sourceFolder String indicating the source folder: \code{"library"}, #' \code{"verified"}, or \code{"other"}. -#' @param forceEncode Optional character vector of option names to force-encode via regex. +#' @param forceEncode Compatibility argument retained for older callers. Supplying +#' a non-`NULL` value now aborts. #' #' @return Character string with the test_that block. #' @keywords internal generateExampleTestBlockBasic <- function(analysisName, analysisIndex, totalAnalyses, jaspFileName, sourceFolder, forceEncode = NULL) { + .rejectForceEncodeArgument(forceEncode) + lines <- character(0) - # Test description - if (totalAnalyses > 1) { - testDesc <- paste0(analysisName, " (analysis ", analysisIndex, ") runs without error") - } else { - testDesc <- paste0(analysisName, " runs without error") - } + testDesc <- .generatedExampleTestDescription( + analysisName, + analysisIndex, + totalAnalyses, + suffix = "runs without error" + ) lines <- c(lines, paste0('test_that("', testDesc, '", {')) lines <- c(lines, "") - # Extract from JASP file in module's jaspfiles folder - lines <- c(lines, " # Load from JASP example file") - lines <- c(lines, paste0(' jaspFile <- testthat::test_path("jaspfiles", "', sourceFolder, '", "', jaspFileName, '")')) + lines <- c(lines, .generatedExampleReplayLines( + analysisName = analysisName, + analysisIndex = analysisIndex, + totalAnalyses = totalAnalyses, + jaspFileName = jaspFileName, + sourceFolder = sourceFolder + )) + lines <- c(lines, "") - # Generate appropriate options extraction based on number of analyses - if (totalAnalyses == 1) { - # Single analysis: analysisOptions returns options directly (not in a list) - lines <- c(lines, " opts <- jaspTools::analysisOptions(jaspFile)") - } else { - # Multiple analyses: analysisOptions returns a list - lines <- c(lines, paste0(" opts <- jaspTools::analysisOptions(jaspFile)[[", analysisIndex, "]]")) + # Basic expectation + lines <- .appendGeneratedExampleStatusExpectation( + lines, + comment = " # Check analysis runs without error" + ) + + lines <- c(lines, "})") + + return(paste(lines, collapse = "\n")) +} + +.rejectForceEncodeArgument <- function(forceEncode) { + if (is.null(forceEncode)) + return(invisible(FALSE)) + + cli::cli_abort(c( + "{.arg forceEncode} is no longer supported.", + "i" = "Generated tests now replay saved .jasp options and extracted data through jaspSyntax/jaspBase without a jaspTools-side encoding step." + )) +} + +.generatedExampleTestDescription <- function(analysisName, analysisIndex, + totalAnalyses, suffix) { + if (totalAnalyses > 1) { + return(paste0(analysisName, " (analysis ", analysisIndex, ") ", suffix)) } - lines <- c(lines, " dataset <- jaspTools::extractDatasetFromJASPFile(jaspFile)") - lines <- c(lines, "") + paste0(analysisName, " ", suffix) +} - # Encode and run - include forceEncode if provided - lines <- c(lines, " # Encode and run analysis") - if (!is.null(forceEncode) && length(forceEncode) > 0) { - forceEncodeStr <- paste0('c("', paste(forceEncode, collapse = '", "'), '")') - lines <- c(lines, paste0(" encoded <- jaspTools:::encodeOptionsAndDataset(opts, dataset, forceEncode = ", forceEncodeStr, ")")) +.generatedExampleReplayLines <- function(analysisName, analysisIndex, + totalAnalyses, jaspFileName, + sourceFolder) { + optionLine <- if (totalAnalyses == 1) { + " opts <- jaspTools::analysisOptions(jaspFile, modulePath = modulePath)" } else { - lines <- c(lines, " encoded <- jaspTools:::encodeOptionsAndDataset(opts, dataset)") + paste0( + " opts <- jaspTools::analysisOptions(jaspFile, modulePath = modulePath)[[", + analysisIndex, + "]]" + ) } - lines <- c(lines, " set.seed(1)") - lines <- c(lines, paste0(' results <- jaspTools::runAnalysis("', analysisName, '", encoded$dataset, encoded$options, encodedDataset = TRUE)')) - lines <- c(lines, "") - # Basic expectation - lines <- c(lines, " # Check analysis runs without error") - lines <- c(lines, ' expect_false(isTRUE(results[["status"]] == "error"),') - lines <- c(lines, ' info = results[["results"]][["error"]])') + c( + " # Load from JASP example file", + paste0(' jaspFile <- testthat::test_path("jaspfiles", "', sourceFolder, '", "', jaspFileName, '")'), + ' modulePath <- normalizePath(testthat::test_path("..", ".."), winslash = "/", mustWork = TRUE)', + optionLine, + " dataset <- jaspTools::extractDatasetFromJASPFile(jaspFile)", + "", + " # Run analysis", + " set.seed(1)", + paste0(' results <- jaspTools::runAnalysis("', analysisName, '", dataset, opts, modulePath = modulePath)') + ) +} - lines <- c(lines, "})") +.appendGeneratedExampleStatusExpectation <- function(lines, comment) { + c( + lines, + comment, + " jaspTools:::.expectNoGeneratedExampleFailureStatus(results)" + ) +} - return(paste(lines, collapse = "\n")) +.expectNoGeneratedExampleFailureStatus <- function(results) { + testthat::expect_false( + .generatedExampleHasFailureStatus(results), + info = .generatedExampleFailureInfo(results) + ) +} + +.generatedExampleFailureStatuses <- function() { + c("error", "validationError", "fatalError") +} + +.generatedExampleStatus <- function(results) { + status <- if (is.list(results)) results[["status"]] else NULL + if (!is.character(status) || length(status) != 1L || is.na(status)) + return(NA_character_) + + status +} + +.generatedExampleHasFailureStatus <- function(results) { + .generatedExampleStatus(results) %in% .generatedExampleFailureStatuses() +} + +.generatedExampleFailureInfo <- function(results) { + status <- .generatedExampleStatus(results) + errorMessage <- NULL + + if (is.list(results) && is.list(results[["results"]])) { + errorMessage <- results[["results"]][["errorMessage"]] + if (is.null(errorMessage)) + errorMessage <- results[["results"]][["error"]] + } + + lastError <- tryCatch(getErrorMsgFromLastResults(), error = function(e) NULL) + if (is.list(lastError) && !is.null(lastError[["type"]]) && + .generatedExampleHasFailureStatus(results)) { + errorMessage <- lastError[["message"]] + } + + info <- paste0("JASP result status: ", status) + if (!is.null(errorMessage) && length(errorMessage) > 0L) + info <- paste(info, paste(as.character(errorMessage), collapse = "\n"), sep = "\n") + + info } makeUnitTestsFromResults <- function(results, name, dataset, options) { - if (!is.list(results) || is.null(names(results)) || results$status == "error") { + if (!is.list(results) || is.null(names(results)) || .generatedExampleHasFailureStatus(results)) { stop("Can't make unit test from results: not a results list") } diff --git a/R/testthat-helper-tables.R b/R/testthat-helper-tables.R index 8264359..2bc941a 100644 --- a/R/testthat-helper-tables.R +++ b/R/testthat-helper-tables.R @@ -127,7 +127,7 @@ getMismatchesEqualSizeTables <- function(test, ref, nRows, nCols, cellNames) { lookupRow <- refVec[cellRange] for (cell in cellRange) { - indicesMatch <- which(lookupRow %in% testVec[cell]) + indicesMatch <- which(vapply(lookupRow, tableValuesMatch, logical(1L), testVec[cell])) if (length(indicesMatch) > 0) lookupRow <- lookupRow[-min(indicesMatch)] else { @@ -171,7 +171,9 @@ getMissingValuesDiffSizeTables <- function(test, ref, cellNames) { missingValues <- character(0) for (i in seq_along(searchFor)) { - if (!searchFor[i] %in% searchIn) { + matchIndex <- which(vapply(searchIn, tableValuesMatch, logical(1L), searchFor[i])) + + if (length(matchIndex) == 0L) { missingValue <- paste0("`", names(searchFor)[i], "`") col <- attr(searchFor, "cellNames")[i] @@ -180,7 +182,7 @@ getMissingValuesDiffSizeTables <- function(test, ref, cellNames) { missingValues <- c(missingValues, missingValue) } else { - searchIn <- searchIn[-min(which(searchIn %in% searchFor[i]))] + searchIn <- searchIn[-min(matchIndex)] } } @@ -191,8 +193,35 @@ getMissingValuesDiffSizeTables <- function(test, ref, cellNames) { tableListToAnnotatedCharacterVector <- function(tableList, cellNames=NULL) { fullValues <- unlist(tableList) tableVec <- as.character(unlist(lapply(tableList, roundToPrecision))) - names(tableVec) <- fullValues + tableVec <- canonicalizeJaspColumnTokens(tableVec) + names(tableVec) <- canonicalizeJaspColumnTokens(as.character(fullValues)) attr(tableVec, "cellNames") <- cellNames return(tableVec) } + +canonicalizeJaspColumnTokens <- function(x) { + if (!is.character(x) || length(x) == 0L) + return(x) + + tokenPattern <- "(JaspColumn_[[:alnum:]_]+_Encoded|jaspColumn[0-9]+)" + tokens <- unlist(regmatches(x, gregexpr(tokenPattern, x, perl = TRUE)), use.names = FALSE) + tokens <- unique(tokens[nzchar(tokens)]) + + if (length(tokens) == 0L) + return(x) + + replacements <- stats::setNames(paste0(""), tokens) + for (token in tokens) { + x <- gsub(token, replacements[[token]], x, fixed = TRUE) + } + + x +} + +tableValuesMatch <- function(refValue, testValue) { + refValue <- unname(refValue) + testValue <- unname(testValue) + + identical(refValue, testValue) +} diff --git a/R/view.R b/R/view.R index 146571b..5bffbbc 100644 --- a/R/view.R +++ b/R/view.R @@ -7,7 +7,7 @@ #' #' @param results A named R list returned from a JASP analysis, a json #' results string copied from the Qt terminal, or a path to a .jasp file. -#' @return A html page is generated and placed in a temp directory +#' @return Invisibly, the path to the generated HTML file. #' @examples #' #' options <- analysisOptions("BinomialTest") @@ -114,6 +114,7 @@ view <- function(results) { viewer <- utils::browseURL viewer(html) + invisible(html) } makeHtmlFromList <- function(results) { diff --git a/R/zzz.R b/R/zzz.R index 1cce5c0..689ed8b 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,8 +1,10 @@ .pkgenv <- list2env(list( internal = list(jaspToolsPath = "", dataset = "", + preloadedColumnMapping = character(0), state = list(), - modulesMd5Sums = list() + modulesMd5Sums = list(), + setupCompleteOverride = FALSE ), pkgOptions = list(module.dirs = "", reinstall.modules = TRUE, @@ -15,7 +17,6 @@ .onLoad <- function(libname, pkgname) { .setInternal("jaspToolsPath", normalizePath(file.path(libname, "jaspTools"))) - .insertRbridgeIntoEnv(.GlobalEnv) if (.isSetupComplete()) { .initInternalPaths() diff --git a/README.md b/README.md index 6f4b9be..a07e432 100644 --- a/README.md +++ b/README.md @@ -46,6 +46,7 @@ jaspTools will use these to locate R functions, tests, etc. The module(s) that y - `runAnalysis`: run a JASP analysis - `view`: view output of a JASP analysis - `analysisOptions`: create options used by `runAnalysis` +- `analysisRuntimeOptions`: inspect backend/runtime options from a saved `.jasp` file #### Obtaining options There are three general procedures to obtaining the options to run an analysis with in jaspTools. @@ -66,17 +67,33 @@ runAnalysis("BinomialTest", dataset="debug.csv", options=options) ##### Procedure 2 And so the second procedure might be preferred. You can set the options to your liking in JASP and then save the .jasp file (it may contain several analyses). -You can then let jaspTools read the .jasp file to extract the options from. +You can then let jaspTools read the .jasp file to extract the saved options and matching dataset. ###### Example ``` -#fetch all the options from all analyses in a .jasp file -options <- analysisOptions("~/path/to/file.jasp") +jaspFile <- "~/path/to/file.jasp" -#we want to use the options of the first analysis (note that you may omit the analysis name argument) -runAnalysis(dataset="debug.csv", options=options[[1]]) +# fetch the saved options and dataset from the .jasp file +options <- analysisOptions(jaspFile) +dataset <- extractDatasetFromJASPFile(jaspFile) + +# if the file contains multiple analyses, select the one to run +if (is.null(attr(options, "analysisName"))) + options <- options[[1]] + +runAnalysis("Descriptives", dataset = dataset, options = options) ``` +For a single-analysis `.jasp` file, `analysisOptions(jaspFile)` returns the +options list directly. For multiple analyses it returns a list of option lists. +These saved options are meant for `runAnalysis()`, which replays them through +the native QML/runtime path once. + +Use `analysisRuntimeOptions(jaspFile)` only when you need to inspect the +backend-prepared options that the analysis R code receives. Those options are +inspection-only; use `analysisOptions(jaspFile)` for options passed to +`runAnalysis()`. + ##### Procedure 3 The third procedure uses syntax generated by Qt and doesn't require you to save the .jasp file, but instead can be done in real-time. To use this enable "Log to file" in `JASP > Preferences > Advanced > Logging options`. diff --git a/man/addTypedDataSet.Rd b/man/addTypedDataSet.Rd deleted file mode 100644 index 3fe36e6..0000000 --- a/man/addTypedDataSet.Rd +++ /dev/null @@ -1,49 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/dataset.R -\name{addTypedDataSet} -\alias{addTypedDataSet} -\title{Add types for a dataset.} -\usage{ -addTypedDataSet(name, lst) -} -\arguments{ -\item{name}{The path to the dataset on disk.} - -\item{lst}{A list of column names and their types.} -} -\description{ -Add types for a dataset. -} -\details{ -Note that this has already been done for debug.csv and test.csv. -This is an alternative interface to specify types in jaspTools. -The usual way is to specify a key in the options object with the types. -For example, if \code{options[["variables"]] == c("contNormal", "facFive", "contBinom")} -then one could indicate the types by writing -\code{options[["variables.types"]] == c("scale", "ordinal", "nominal")}. -With \code{addTypedDataSet} this becomes: - -\if{html}{\out{
}}\preformatted{addTypedDataSet( - "test.csv", - list( - contNormal = "scale", - facFive = "ordinal", - contBinom = "nominal" - ) -) -}\if{html}{\out{
}} - -the main benefit is that this only needs to be done once, -instead of being repeated for each options object. -} -\examples{ -addTypedDataSet( - "test.csv", - list( - V1 = "scale", - contNormal = "scale", - contGamma = "scale", - contBinom = "nominal" - ) -) -} diff --git a/man/analysisOptions.Rd b/man/analysisOptions.Rd index e433bbd..d4ea1fe 100644 --- a/man/analysisOptions.Rd +++ b/man/analysisOptions.Rd @@ -4,10 +4,14 @@ \alias{analysisOptions} \title{Obtain options to run JASP analyses with.} \usage{ -analysisOptions(source) +analysisOptions(source, modulePath = NULL) } \arguments{ \item{source}{One of three: (1) R function name, (2) path to .jasp file or (3) json string. See the details section for more information.} + +\item{modulePath}{Optional module path, or named list/vector of module paths +keyed by module name or analysis name. Used for .jasp replay and for +analysis-name defaults when the module checkout should be pinned.} } \value{ A list containing options of the analysis. If \code{source} is a .jasp file with multiple analyses, then a list of lists. @@ -20,7 +24,13 @@ left empty. } \details{ There are three types of allowed input. 1) The name of the R function of the analysis (case-sensitive); jaspTools will attempt to read the .qml file for that analysis and create a set of default options. -2) the path to .jasp file that has one or more analyses. Or (3) a json string that was sent by the JASP application. This json can be obtained by having JASP log to file (JASP>Preferences>Advanced>Log to file). +2) the path to .jasp file that has one or more analyses. For .jasp files, +saved QML-bound options are returned so they can be supplied to +\code{runAnalysis()} and replayed once through the native JASP option +pipeline. Use \code{analysisRuntimeOptions()} only when you need +backend-prepared runtime options for diagnostics. Or (3) a json string that was sent by the +JASP application. This json can be obtained by having JASP log to file +(JASP>Preferences>Advanced>Log to file). The logs can be found by clicking 'Show logs" in the "Logging options". Click on the file "\emph{Engine}.log" that has "Engine::receiveAnalysisMessage:" (usually Engine 1), copy the content between the \{ and \}. Be sure to use single quotes (') when supplying this string. } diff --git a/man/analysisRuntimeOptions.Rd b/man/analysisRuntimeOptions.Rd new file mode 100644 index 0000000..e9b7e18 --- /dev/null +++ b/man/analysisRuntimeOptions.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/options.R +\name{analysisRuntimeOptions} +\alias{analysisRuntimeOptions} +\title{Obtain backend/runtime options from a JASP file.} +\usage{ +analysisRuntimeOptions(file, modulePath = NULL) +} +\arguments{ +\item{file}{Path to a .jasp file.} + +\item{modulePath}{Optional module path, or a named list/vector of module +paths keyed by module name or analysis name. Passed to +\code{jaspSyntax::readAnalysisOptionsFromJaspFile()}.} +} +\value{ +A prepared options list. If \code{file} contains multiple analyses, +a list of prepared options lists is returned. +} +\description{ +\code{analysisRuntimeOptions()} reads options from a saved .jasp file, +replays them through \code{jaspSyntax} and the native JASP option pipeline, +and marks the returned option lists as already prepared. These options are +intended for inspection and direct backend diagnostics, not for +\code{runAnalysis()}. +} diff --git a/man/createEncodedDataset.Rd b/man/createEncodedDataset.Rd deleted file mode 100644 index db2fa22..0000000 --- a/man/createEncodedDataset.Rd +++ /dev/null @@ -1,20 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/dataset.R -\name{createEncodedDataset} -\alias{createEncodedDataset} -\title{Create Encoded Dataset} -\usage{ -createEncodedDataset(dataset, encodingMap) -} -\arguments{ -\item{dataset}{The original dataset.} - -\item{encodingMap}{Data.frame with columns \code{original}, \code{encoded}, \code{type}.} -} -\value{ -A data.frame with encoded column names and proper types. -} -\description{ -Creates a new dataset with encoded column names and proper type coercion. -} -\keyword{internal} diff --git a/man/encodeOptionsAndDataset.Rd b/man/encodeOptionsAndDataset.Rd deleted file mode 100644 index 45be9e1..0000000 --- a/man/encodeOptionsAndDataset.Rd +++ /dev/null @@ -1,66 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/dataset.R -\name{encodeOptionsAndDataset} -\alias{encodeOptionsAndDataset} -\title{Encode Options and Dataset for JASP Analysis} -\usage{ -encodeOptionsAndDataset(options, dataset, forceEncode = NULL) -} -\arguments{ -\item{options}{A named list of analysis options, typically from \code{analysisOptions()}.} - -\item{dataset}{A data.frame or the name/path of a dataset to be encoded.} - -\item{forceEncode}{Optional character vector of option names that should be -forcibly encoded using regular expression replacement. This is useful for -options like \code{model} that contain variable names embedded in strings -(e.g., formula syntax "A~B") but do not have a parallel \code{.types} entry. -These options will have all column names replaced with their encoded equivalents -using word-boundary-aware regex matching.} -} -\value{ -A list with three components: -\itemize{ -\item \code{options}: The encoded options with variable names replaced by "jaspColumnN". -\item \code{dataset}: The encoded dataset containing only the relevant columns, -renamed and formatted according to their types. -\item \code{encodingMap}: A data.frame with columns \code{original}, \code{encoded}, -and \code{type} showing the mapping from original variable names to encoded names. -} -} -\description{ -This function processes options with \code{.types} properties and creates an -encoded version of both the options and the dataset. Variables are encoded -to generic names like "jaspColumn1", "jaspColumn2", etc., and the dataset -is filtered and formatted according to the specified types. -} -\details{ -The function performs the following steps: -\enumerate{ -\item Scans all options for those with a parallel \code{.types} entry -(e.g., \code{variables} and \code{variables.types}). -\item Extracts unique variable-type combinations. -\item Creates an encoding map from original names to "jaspColumn1", "jaspColumn2", etc. -\item Replaces all variable references in the options with their encoded names. -\item Subsets and transforms the dataset to contain only the encoded columns, -applying type coercion: -\itemize{ -\item \code{"nominal"}: Converted to factor via \code{as.factor()}. -\item \code{"ordinal"}: Converted to ordered factor. -\item \code{"scale"}: Converted to numeric via \code{as.numeric()}. -} -} -} -\examples{ -\dontrun{ -options <- analysisOptions("BinomialTest") -options$variables <- "contBinom" -options$variables.types <- "nominal" - -result <- encodeOptionsAndDataset(options, "debug.csv") -# result$options$variables is now "jaspColumn1" -# result$dataset has column "jaspColumn1" as a factor -# result$encodingMap shows the mapping -} - -} diff --git a/man/encodeOptionsWithMap.Rd b/man/encodeOptionsWithMap.Rd deleted file mode 100644 index 203f5a8..0000000 --- a/man/encodeOptionsWithMap.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/dataset.R -\name{encodeOptionsWithMap} -\alias{encodeOptionsWithMap} -\title{Encode Options Using Encoding Map} -\usage{ -encodeOptionsWithMap(options, encodingMap, forceEncode = NULL) -} -\arguments{ -\item{options}{The options list.} - -\item{encodingMap}{Data.frame with columns \code{original}, \code{encoded}, \code{type}.} - -\item{forceEncode}{Optional character vector of option names to force-encode via regex.} -} -\value{ -The options list with encoded variable names. -} -\description{ -Replaces variable names in options with their encoded equivalents. -} -\keyword{internal} diff --git a/man/extractDatasetFromJASPFile.Rd b/man/extractDatasetFromJASPFile.Rd index 4a92e1c..f97e8f2 100644 --- a/man/extractDatasetFromJASPFile.Rd +++ b/man/extractDatasetFromJASPFile.Rd @@ -10,33 +10,21 @@ extractDatasetFromJASPFile(jaspFile, dataSetIndex = 1L) \item{jaspFile}{Character string specifying the path to the .jasp file.} \item{dataSetIndex}{Integer specifying which dataset to extract if the JASP -file contains multiple datasets. Default is 1 (the first dataset).} +file contains multiple datasets. Currently only \code{1L} is supported because +that is the index supported by the \code{jaspSyntax} backend.} } \value{ -A data.frame containing the extracted dataset with proper column names, -types, and factor levels. +Either a data.frame containing the extracted dataset or \code{NULL} when +the \code{.jasp} file does not contain tabular data. } \description{ -This function extracts the dataset from a saved JASP file (.jasp) and returns -it as a data.frame. JASP files are zip archives containing an SQLite database -with the data and metadata. +Thin compatibility wrapper around \code{jaspSyntax::readDatasetFromJaspFile()}. } \details{ -The function performs the following steps: -\itemize{ -\item Unpacking the .jasp archive (which is a zip file) -\item Reading the internal.sqlite database -\item Converting Column_N_DBL and Column_N_INT columns to properly named columns -\item Mapping factor levels from the Labels table to create proper R factors -\item Handling both explicitly nominal columns and columns with label mappings -} - -Special values like NA, NaN, and Inf are handled appropriately: -\itemize{ -\item "nan" values in DBL columns are converted to NA -\item "inf" values in DBL columns are converted to Inf -\item -1 values in INT columns typically indicate missing values -} +\code{jaspTools} now relies on \code{jaspSyntax} for reading datasets from saved JASP +files, so the native \code{.jasp} decoding and dataset reconstruction logic lives +in one place. Numeric columns, including \code{Inf} and \code{-Inf}, are returned +directly from the \code{jaspSyntax} backend without additional post-processing. } \examples{ \dontrun{ diff --git a/man/extractPairsFromValueAndType.Rd b/man/extractPairsFromValueAndType.Rd deleted file mode 100644 index 7a77159..0000000 --- a/man/extractPairsFromValueAndType.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/dataset.R -\name{extractPairsFromValueAndType} -\alias{extractPairsFromValueAndType} -\title{Extract Pairs from Value and Type Structures} -\usage{ -extractPairsFromValueAndType(values, types, allColumnNames) -} -\arguments{ -\item{values}{The values (can be character vector, list, or nested structure).} - -\item{types}{The parallel types structure.} - -\item{allColumnNames}{Vector of valid column names.} -} -\value{ -A data.frame with columns \code{variable} and \code{type}. -} -\description{ -Recursively extracts variable-type pairs from potentially nested value and type structures. -} -\keyword{internal} diff --git a/man/extractVariableTypePairs.Rd b/man/extractVariableTypePairs.Rd deleted file mode 100644 index 4454906..0000000 --- a/man/extractVariableTypePairs.Rd +++ /dev/null @@ -1,20 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/dataset.R -\name{extractVariableTypePairs} -\alias{extractVariableTypePairs} -\title{Extract Variable-Type Pairs from Options} -\usage{ -extractVariableTypePairs(options, allColumnNames) -} -\arguments{ -\item{options}{The options list.} - -\item{allColumnNames}{Vector of valid column names in the dataset.} -} -\value{ -A data.frame with columns \code{variable} and \code{type}. -} -\description{ -Internal function that scans options for variable references with associated types. -} -\keyword{internal} diff --git a/man/generateExampleTestBlock.Rd b/man/generateExampleTestBlock.Rd index d44b314..1bce209 100644 --- a/man/generateExampleTestBlock.Rd +++ b/man/generateExampleTestBlock.Rd @@ -28,7 +28,8 @@ generateExampleTestBlock( \item{results}{The analysis results.} -\item{forceEncode}{Optional character vector of option names to force-encode via regex.} +\item{forceEncode}{Compatibility argument retained for older callers. Supplying +a non-\code{NULL} value now aborts.} } \value{ Character string with the test_that block. diff --git a/man/generateExampleTestBlockBasic.Rd b/man/generateExampleTestBlockBasic.Rd index 86a87d7..e838b28 100644 --- a/man/generateExampleTestBlockBasic.Rd +++ b/man/generateExampleTestBlockBasic.Rd @@ -25,7 +25,8 @@ generateExampleTestBlockBasic( \item{sourceFolder}{String indicating the source folder: \code{"library"}, \code{"verified"}, or \code{"other"}.} -\item{forceEncode}{Optional character vector of option names to force-encode via regex.} +\item{forceEncode}{Compatibility argument retained for older callers. Supplying +a non-\code{NULL} value now aborts.} } \value{ Character string with the test_that block. diff --git a/man/makeTestsFromExamples.Rd b/man/makeTestsFromExamples.Rd index 3a2985e..33015bc 100644 --- a/man/makeTestsFromExamples.Rd +++ b/man/makeTestsFromExamples.Rd @@ -36,11 +36,9 @@ with hyphens. If FALSE (default), preserves original spacing and characters in f \item{overwrite}{Logical. If TRUE, overwrites existing test files. If FALSE (default), skips files that already exist.} -\item{forceEncode}{Optional character vector of option names that should be forcibly -encoded using regular expression replacement. This is useful for options like -\code{model} that contain variable names embedded in strings (e.g., formula syntax -"A~B") but do not have a parallel \code{.types} entry. These options will have all -column names replaced with their encoded equivalents using word-boundary-aware regex.} +\item{forceEncode}{Compatibility argument retained for older callers. Supplying +a non-\code{NULL} value now aborts because generated tests run directly against +the extracted options and dataset without a separate encoding step.} } \value{ Invisibly returns a character vector of created/processed test file paths. @@ -62,7 +60,6 @@ blocks within the same test file. \strong{Prerequisites:} \itemize{ \item \code{setupJaspTools()} must be run before using this function -\item Packages 'DBI' and 'RSQLite' are required for extracting data from JASP files } } \examples{ @@ -86,8 +83,6 @@ makeTestsFromExamples(path = "path/to/jasp/files", module.dir = "path/to/module" # Overwrite existing test files (skips verified by default) makeTestsFromExamples(overwrite = TRUE) -# Force encode 'model' option for analyses with embedded variable names -makeTestsFromExamples(forceEncode = "model") } } diff --git a/man/makeTestsFromSingleJASPFile.Rd b/man/makeTestsFromSingleJASPFile.Rd index b689d9d..ea78968 100644 --- a/man/makeTestsFromSingleJASPFile.Rd +++ b/man/makeTestsFromSingleJASPFile.Rd @@ -33,7 +33,8 @@ makeTestsFromSingleJASPFile( \item{pkgAnalyses}{Optional character vector of allowed analysis names for this module. If provided, analyses not in this list will be skipped.} -\item{forceEncode}{Optional character vector of option names to force-encode via regex.} +\item{forceEncode}{Compatibility argument retained for older callers. Supplying +a non-\code{NULL} value now aborts.} } \value{ The path to the created test file (with attr "skipped" if skipped, diff --git a/man/runAnalysis.Rd b/man/runAnalysis.Rd index f6ffa30..033e1ad 100644 --- a/man/runAnalysis.Rd +++ b/man/runAnalysis.Rd @@ -9,9 +9,9 @@ runAnalysis( dataset = NULL, options, view = TRUE, - quiet = FALSE, + quiet = TRUE, makeTests = FALSE, - encodedDataset = FALSE + modulePath = NULL ) } \arguments{ @@ -28,11 +28,15 @@ By default the directory in Resources is checked first, unless called within a t \item{view}{Boolean indicating whether to view the results in a webbrowser.} \item{quiet}{Boolean indicating whether to suppress messages from the -analysis.} +analysis and native QML bridge. Quiet runs are evaluated in a subprocess so +native Desktop logging does not clutter the calling R session.} \item{makeTests}{Boolean indicating whether to create testthat unit tests and print them to the terminal.} -\item{encodedDataset}{Boolean indicating whether to assume that the dataset is already encoded.} +\item{modulePath}{Optional path to the module checkout that should be used +for QML resolution and wrapped execution. When omitted, jaspTools first +uses a module path attached to \code{options} by \code{analysisOptions()} +and then falls back to configured \code{module.dirs}.} } \description{ \code{runAnalysis} makes it possible to execute a JASP analysis in R. Usually this @@ -44,6 +48,12 @@ analysis code between calls is incorporated. The output of the analysis is shown automatically through a call to \code{view} and returned invisibly. } +\details{ +Saved/QML-bound options are replayed through the native QML runtime path. Use +\code{analysisOptions()} for options that should be passed to +\code{runAnalysis()}; options returned by \code{analysisRuntimeOptions()} are +backend-prepared diagnostics and are not accepted by this runner. +} \examples{ options <- analysisOptions("BinomialTest") diff --git a/man/view.Rd b/man/view.Rd index 7b9e211..b79371d 100644 --- a/man/view.Rd +++ b/man/view.Rd @@ -11,7 +11,7 @@ view(results) results string copied from the Qt terminal, or a path to a .jasp file.} } \value{ -A html page is generated and placed in a temp directory +Invisibly, the path to the generated HTML file. } \description{ \code{view} allows you to view output independently of JASP. By default this output diff --git a/tests/testthat/test-analysisOptions.R b/tests/testthat/test-analysisOptions.R index ee72a4d..f3dc350 100644 --- a/tests/testthat/test-analysisOptions.R +++ b/tests/testthat/test-analysisOptions.R @@ -1,100 +1,275 @@ context("analysisOptions") -test_that("analysisOptions flattens simple types/value structures", { - # Test case: split option with empty types and simple value - # Raw structure: $split$types = list(), $split$value = "" - # Expected: $split = "", $split.types = list() +localJaspToolsBinding <- function(name, value) { + namespace <- asNamespace("jaspTools") + oldValue <- get(name, envir = namespace, inherits = FALSE) + wasLocked <- bindingIsLocked(name, namespace) - jaspFile <- file.path(testthat::test_path(), "..", "JASPFiles", "Effectiveness_of_the_BCG_Vaccine_Against_Tuberculosis.jasp") - opts <- jaspTools::analysisOptions(jaspFile)[[2]] + if (wasLocked) + unlockBinding(name, namespace) + assign(name, value, envir = namespace) + if (wasLocked) + lockBinding(name, namespace) + function() { + if (bindingIsLocked(name, namespace)) + unlockBinding(name, namespace) + assign(name, oldValue, envir = namespace) + if (wasLocked) + lockBinding(name, namespace) + } +} - # The split option should be flattened to just the value +localNamespaceBinding <- function(name, value, namespace) { + oldValue <- get(name, envir = namespace, inherits = FALSE) + wasLocked <- bindingIsLocked(name, namespace) - expect_true(is.character(opts$split) || is.null(opts$split$value)) + if (wasLocked) + unlockBinding(name, namespace) + assign(name, value, envir = namespace) + if (wasLocked) + lockBinding(name, namespace) - # If flattened correctly, split should be a character, not a list with types/value + function() { + if (bindingIsLocked(name, namespace)) + unlockBinding(name, namespace) + assign(name, oldValue, envir = namespace) + if (wasLocked) + lockBinding(name, namespace) + } +} +localJaspToolsOptions <- function(values) { + oldValues <- options(values) - if (is.list(opts$split) && !is.null(opts$split$value)) { - fail("split option was not flattened - still has $value structure") + function() { + options(oldValues) + invisible(NULL) } +} + +test_that("analysisOptions preserves JSON options without native replay", { + opts <- jaspTools::analysisOptions('{ + "name": "LoggedAnalysis", + "options": { + ".meta": { + "variables": { + "shouldEncode": true + } + }, + "variables": ["x"] + } + }') + + expect_equal(attr(opts, "analysisName"), "LoggedAnalysis") + expect_true(".meta" %in% names(opts)) + expect_equal(opts$variables, "x") +}) + +test_that("analysisOptions for analysis names requests editable unprepared defaults", { + restoreOption <- localJaspToolsOptions(list(jaspTools.analysisOptions.subprocess = FALSE)) + on.exit(restoreOption(), add = TRUE) + + observed <- NULL + + restoreTools <- localJaspToolsBinding("getModulePathFromRFunction", function(analysis) { + expect_equal(analysis, "FakeAnalysis") + "C:/fake/module" + }) + restoreSyntax <- localNamespaceBinding( + "readDefaultAnalysisOptions", + function(modulePath, analysisName, includeMeta, includeTypeOptions) { + observed <<- list( + modulePath = modulePath, + analysisName = analysisName, + includeMeta = includeMeta, + includeTypeOptions = includeTypeOptions + ) + list(variables = list(), flag = TRUE) + }, + asNamespace("jaspSyntax") + ) + on.exit(restoreTools(), add = TRUE) + on.exit(restoreSyntax(), add = TRUE) + + opts <- jaspTools::analysisOptions("FakeAnalysis") + + expect_equal(observed$modulePath, "C:/fake/module") + expect_equal(observed$analysisName, "FakeAnalysis") + expect_false(observed$includeMeta) + expect_false(observed$includeTypeOptions) + expect_equal(attr(opts, "analysisName"), "FakeAnalysis") + expect_equal(attr(opts, "jaspTools.optionShape"), "qml") + expect_equal(attr(opts, "modulePath"), "C:/fake/module") + expect_false(jaspTools:::isPreparedOptions(opts)) + expect_false(any(grepl("\\.types$", names(opts)))) +}) + +test_that("analysisOptions for analysis names honors explicit modulePath", { + restoreOption <- localJaspToolsOptions(list(jaspTools.analysisOptions.subprocess = FALSE)) + on.exit(restoreOption(), add = TRUE) + + observed <- NULL + + restoreTools <- localJaspToolsBinding("getModulePathFromRFunction", function(analysis) { + stop("ambient module resolution should not be used") + }) + restoreSyntax <- localNamespaceBinding( + "readDefaultAnalysisOptions", + function(modulePath, analysisName, includeMeta, includeTypeOptions) { + observed <<- list(modulePath = modulePath, analysisName = analysisName) + list(flag = TRUE) + }, + asNamespace("jaspSyntax") + ) + on.exit(restoreTools(), add = TRUE) + on.exit(restoreSyntax(), add = TRUE) + + opts <- jaspTools::analysisOptions("FakeAnalysis", modulePath = "C:/explicit/module") - # The .types should be stored separately - expect_true("split.types" %in% names(opts) || identical(opts$split, "")) + expect_equal(observed$modulePath, "C:/explicit/module") + expect_equal(observed$analysisName, "FakeAnalysis") + expect_equal(attr(opts, "modulePath"), "C:/explicit/module") }) -test_that("analysisOptions flattens complex types/value structures with optionKey", -{ - # Test case: effectSizeModelTerms with optionKey and nested lists - # Raw structure: - # $effectSizeModelTerms$optionKey = "components" - - # $effectSizeModelTerms$types = c("scale", "nominal") - # $effectSizeModelTerms$value = list(list(components="ablat"), list(components="alloc")) - # Expected: - # $effectSizeModelTerms = list(list(components="ablat"), list(components="alloc")) - # $effectSizeModelTerms.types = list(list(components="scale"), list(components="nominal")) - - jaspFile <- file.path(testthat::test_path(), "..", "JASPFiles", "Effectiveness_of_the_BCG_Vaccine_Against_Tuberculosis.jasp") - opts <- jaspTools::analysisOptions(jaspFile)[[3]] - - # The effectSizeModelTerms should be flattened to just the value (a list) - expect_true(is.list(opts$effectSizeModelTerms)) - - # It should NOT have the optionKey, types, value structure anymore - expect_false("optionKey" %in% names(opts$effectSizeModelTerms)) - expect_false("types" %in% names(opts$effectSizeModelTerms)) - expect_false("value" %in% names(opts$effectSizeModelTerms)) - - # The first element should have "components" with value "ablat" - expect_equal(opts$effectSizeModelTerms[[1]]$components, "ablat") - expect_equal(opts$effectSizeModelTerms[[2]]$components, "alloc") - - # The .types should be stored separately with parallel structure - expect_true("effectSizeModelTerms.types" %in% names(opts)) - expect_equal(opts$`effectSizeModelTerms.types`[[1]]$components, "scale") - expect_equal(opts$`effectSizeModelTerms.types`[[2]]$components, "nominal") +test_that("analysisOptions for analysis names accepts module-name keyed modulePath", { + restoreOption <- localJaspToolsOptions(list(jaspTools.analysisOptions.subprocess = FALSE)) + on.exit(restoreOption(), add = TRUE) + + observed <- NULL + + restoreTools <- localJaspToolsBinding("getModulePathFromRFunction", function(analysis) { + stop("ambient module resolution should not be used") + }) + restoreResolve <- localNamespaceBinding( + "resolveAnalysisQml", + function(modulePath, analysisName) { + expect_equal(modulePath, "C:/fake/module") + expect_equal(analysisName, "FakeAnalysis") + list() + }, + asNamespace("jaspSyntax") + ) + restoreDefaults <- localNamespaceBinding( + "readDefaultAnalysisOptions", + function(modulePath, analysisName, includeMeta, includeTypeOptions) { + observed <<- list(modulePath = modulePath, analysisName = analysisName) + list(flag = TRUE) + }, + asNamespace("jaspSyntax") + ) + on.exit(restoreTools(), add = TRUE) + on.exit(restoreResolve(), add = TRUE) + on.exit(restoreDefaults(), add = TRUE) + + opts <- jaspTools::analysisOptions( + "FakeAnalysis", + modulePath = list(jaspFake = "C:/fake/module") + ) + + expect_equal(observed$modulePath, "C:/fake/module") + expect_equal(observed$analysisName, "FakeAnalysis") + expect_equal(attr(opts, "modulePath"), "C:/fake/module") }) -test_that("analysisOptions flattens deeply nested types/value structures", { - # Test case: variables[[1]]$coefficientAlpha with nested types/value - # Raw structure: - # $variables[[1]]$coefficientAlpha$types = list() - # $variables[[1]]$coefficientAlpha$value = "" - # Expected: - # $variables[[1]]$coefficientAlpha = "" - # $variables.types[[1]]$coefficientAlpha = list() - - jaspFile <- file.path(testthat::test_path(), "..", "JASPFiles", "Effectiveness_of_the_BCG_Vaccine_Against_Tuberculosis.jasp") - opts <- jaspTools::analysisOptions(jaspFile)[[1]] - - # The coefficientAlpha inside variables[[1]] should be flattened to just the value - expect_true(is.character(opts$variables[[1]]$coefficientAlpha)) - expect_equal(opts$variables[[1]]$coefficientAlpha, "") - - # It should NOT have the types/value structure anymore - expect_false(is.list(opts$variables[[1]]$coefficientAlpha)) - - # The .types should be stored separately with parallel structure - expect_true("variables.types" %in% names(opts)) - expect_true(is.list(opts$`variables.types`[[1]]$coefficientAlpha)) - expect_equal(length(opts$`variables.types`[[1]]$coefficientAlpha), 0) +test_that("analysisOptions subprocess delegates shared child scaffold", { + observed <- NULL + expected <- list(variable = "x") + + restore <- localJaspToolsBinding(".jaspToolsRunSubprocess", function(prefix, payload, scriptLines, + failureMessage, isError, ...) { + observed <<- list( + prefix = prefix, + payload = payload, + scriptLines = scriptLines, + failureMessage = failureMessage, + isError = isError + ) + expected + }) + on.exit(restore(), add = TRUE) + + result <- jaspTools:::analysisOptionsFromQMLFileSubprocess( + "FakeAnalysis", + modulePath = "C:/fake/module" + ) + + expect_identical(result, expected) + expect_equal(observed$prefix, "jaspTools-analysisOptions-") + expect_equal(observed$payload$analysis, "FakeAnalysis") + expect_equal(observed$payload$modulePath, "C:/fake/module") + expect_identical(observed$payload$env$JASPTOOLS_ANALYSIS_OPTIONS_CHILD, "true") + expect_match(observed$failureMessage, "analysisOptions", fixed = TRUE) + expect_false(observed$isError(expected)) + expect_true(any(grepl("pkgload::load_all", observed$scriptLines, fixed = TRUE))) + expect_true(any(grepl(".jaspToolsRestoreROptionsForChild", observed$scriptLines, fixed = TRUE))) + expect_true(any(grepl(".jaspToolsRestorePkgOptionsForChild", observed$scriptLines, fixed = TRUE))) + expect_true(any(grepl(".initOutputDirs", observed$scriptLines, fixed = TRUE))) + expect_true(any(grepl(".jaspToolsSubprocessError", observed$scriptLines, fixed = TRUE))) }) -test_that("analysisOptions extracts options from no-data JASP file", { +test_that("analysisOptions forwards modulePath for .jasp sources", { + jaspFile <- tempfile(fileext = ".jasp") + file.create(jaspFile) + modulePath <- list(jaspFake = "C:/fake/module") + observed <- NULL - jaspFile <- file.path(testthat::test_path(), "..", "JASPFiles", - "no_data_summary_stats.jasp") + restore <- localJaspToolsBinding("analysisOptionsFromJASPFile", function(file, modulePath = NULL) { + observed <<- list(file = file, modulePath = modulePath) + opts <- list(variable = list(value = "x", types = "scale")) + attr(opts, "analysisName") <- "FakeAnalysis" + opts + }) + on.exit(restore(), add = TRUE) - skip_if_not(file.exists(jaspFile), "No-data JASP file not found") + opts <- jaspTools::analysisOptions(jaspFile, modulePath = modulePath) - # Should be able to extract options without error - opts <- jaspTools::analysisOptions(jaspFile) + expect_equal(normalizePath(observed$file, winslash = "/", mustWork = FALSE), + normalizePath(jaspFile, winslash = "/", mustWork = FALSE)) + expect_identical(observed$modulePath, modulePath) + expect_equal(attr(opts, "analysisName"), "FakeAnalysis") +}) + +test_that("analysisOptions treats missing Windows .jasp paths as files, not JSON", { + missingJaspFile <- normalizePath( + file.path(tempdir(), "missing-analysis.jasp"), + winslash = "/", + mustWork = FALSE + ) + + err <- tryCatch(jaspTools::analysisOptions(missingJaspFile), error = function(e) e) + + expect_s3_class(err, "error") + expect_match(conditionMessage(err), "File not found", fixed = TRUE) + expect_false(grepl("json", conditionMessage(err), ignore.case = TRUE)) +}) + +test_that("analysisRuntimeOptions validates .jasp file paths before native dispatch", { + missingJaspFile <- file.path(tempdir(), "missing-runtime.jasp") + expect_error( + jaspTools::analysisRuntimeOptions(missingJaspFile), + "File not found" + ) + + csvFile <- tempfile(fileext = ".csv") + file.create(csvFile) + expect_error( + jaspTools::analysisRuntimeOptions(csvFile), + ".jasp extension", + fixed = TRUE + ) +}) - # Should return a valid options list - expect_true(is.list(opts)) +test_that("analysisOptions treats missing colon-containing non-jasp paths as files", { + missingJsonFile <- normalizePath( + file.path(tempdir(), "missing-options.json"), + winslash = "/", + mustWork = FALSE + ) - # Should have an analysisName attribute - expect_true(!is.null(attr(opts, "analysisName"))) + expect_error( + jaspTools::analysisOptions(missingJsonFile), + "File not found", + fixed = TRUE + ) }) diff --git a/tests/testthat/test-encodeOptionsAndDataset.R b/tests/testthat/test-encodeOptionsAndDataset.R deleted file mode 100644 index 0a1b8c5..0000000 --- a/tests/testthat/test-encodeOptionsAndDataset.R +++ /dev/null @@ -1,605 +0,0 @@ -context("encodeOptionsAndDataset") - -test_that("encodeOptionsAndDataset encodes BCG Vaccine analysis options and dataset", { - - jaspFile <- file.path(testthat::test_path(), "..", "JASPFiles", "Effectiveness_of_the_BCG_Vaccine_Against_Tuberculosis.jasp") - csvFile <- file.path(testthat::test_path(), "..", "JASPFiles", "Effectiveness_of_the_BCG_Vaccine_Against_Tuberculosis.csv") - - skip_if_not(file.exists(jaspFile), "Test JASP file not found") - skip_if_not(file.exists(csvFile), "Expected CSV file not found") - - # Get options from the third analysis (has effectSizeModelTerms with types) - opts <- jaspTools::analysisOptions(jaspFile)[[3]] - - # Load the dataset - dataset <- read.csv(csvFile, stringsAsFactors = FALSE, check.names = FALSE) - - # Encode options and dataset - result <- jaspTools:::encodeOptionsAndDataset(opts, dataset) - - # Check that result has the expected structure - expect_true(is.list(result)) - expect_true(all(c("options", "dataset", "encodingMap") %in% names(result))) - - # Check encoding map structure - expect_true(is.data.frame(result$encodingMap)) - expect_true(all(c("original", "encoded", "type") %in% names(result$encodingMap))) - - # If there are encoded variables, verify encoding - - if (nrow(result$encodingMap) > 0) { - # All encoded names should follow the pattern "jaspColumnN" - expect_true(all(grepl("^jaspColumn\\d+$", result$encodingMap$encoded))) - - # All types should be valid - expect_true(all(result$encodingMap$type %in% c("scale", "ordinal", "nominal"))) - - # Encoded dataset should have the encoded column names - expect_true(all(result$encodingMap$encoded %in% colnames(result$dataset))) - - # Check that encoded options no longer contain original variable names - # that were in the encoding map - originalVars <- result$encodingMap$original - encodedVars <- result$encodingMap$encoded - - # Helper to check if a value contains any original variable names - containsOriginal <- function(x) { - if (is.character(x)) { - any(x %in% originalVars) - } else if (is.list(x)) { - any(vapply(x, containsOriginal, logical(1))) - } else { - FALSE - } - } - - # Helper to check if a value contains encoded variable names - containsEncoded <- function(x) { - if (is.character(x)) { - any(x %in% encodedVars) - } else if (is.list(x)) { - any(vapply(x, containsEncoded, logical(1))) - } else { - FALSE - } - } - - # Check that encoded options contain encoded names instead of original - optNames <- names(result$options) - optNames <- optNames[!grepl("\\.types$", optNames) & optNames != ".meta"] - - for (nm in optNames) { - opt <- result$options[[nm]] - if (containsEncoded(opt)) { - # If it contains encoded names, it should not contain original names - expect_false(containsOriginal(opt), - info = paste("Option", nm, "should not contain original variable names after encoding")) - } - } - } -}) - -test_that("encodeOptionsAndDataset encodes debug-descriptives analysis options and dataset", { - - jaspFile <- file.path(testthat::test_path(), "..", "JASPFiles", "debug-descriptives.jasp") - csvFile <- file.path(testthat::test_path(), "..", "JASPFiles", "debug-descriptives.csv") - - skip_if_not(file.exists(jaspFile), "Test JASP file not found") - skip_if_not(file.exists(csvFile), "Expected CSV file not found") - - # Get options from the first analysis - opts <- jaspTools::analysisOptions(jaspFile) - - # Load the dataset - dataset <- read.csv(csvFile, stringsAsFactors = FALSE, check.names = FALSE) - - # Encode options and dataset - result <- jaspTools:::encodeOptionsAndDataset(opts, dataset) - - # Check that result has the expected structure - expect_true(is.list(result)) - expect_true(all(c("options", "dataset", "encodingMap") %in% names(result))) - - # Check encoding map structure - expect_true(is.data.frame(result$encodingMap)) - expect_true(all(c("original", "encoded", "type") %in% names(result$encodingMap))) - - # If there are encoded variables, verify encoding - if (nrow(result$encodingMap) > 0) { - # All encoded names should follow the pattern "jaspColumnN" - expect_true(all(grepl("^jaspColumn\\d+$", result$encodingMap$encoded))) - - # All types should be valid - expect_true(all(result$encodingMap$type %in% c("scale", "ordinal", "nominal"))) - - # Encoded dataset should have the encoded column names - expect_true(all(result$encodingMap$encoded %in% colnames(result$dataset))) - - # Verify type coercion in dataset - for (i in seq_len(nrow(result$encodingMap))) { - encodedName <- result$encodingMap$encoded[i] - colType <- result$encodingMap$type[i] - col <- result$dataset[[encodedName]] - - if (colType == "nominal") { - expect_true(is.factor(col), - info = paste(encodedName, "should be a factor for nominal type")) - } else if (colType == "ordinal") { - expect_true(is.ordered(col), - info = paste(encodedName, "should be an ordered factor for ordinal type")) - } else if (colType == "scale") { - expect_true(is.numeric(col), - info = paste(encodedName, "should be numeric for scale type")) - } - } - } -}) - -test_that("encodeOptionsAndDataset produces unique variable-type combinations", { - - jaspFile <- file.path(testthat::test_path(), "..", "JASPFiles", "Effectiveness_of_the_BCG_Vaccine_Against_Tuberculosis.jasp") - csvFile <- file.path(testthat::test_path(), "..", "JASPFiles", "Effectiveness_of_the_BCG_Vaccine_Against_Tuberculosis.csv") - - skip_if_not(file.exists(jaspFile), "Test JASP file not found") - skip_if_not(file.exists(csvFile), "Expected CSV file not found") - - opts <- jaspTools::analysisOptions(jaspFile)[[3]] - dataset <- read.csv(csvFile, stringsAsFactors = FALSE, check.names = FALSE) - - result <- jaspTools:::encodeOptionsAndDataset(opts, dataset) - - if (nrow(result$encodingMap) > 0) { - # Check that variable-type combinations are unique - varTypeCombos <- paste(result$encodingMap$original, result$encodingMap$type, sep = "_") - expect_equal(length(varTypeCombos), length(unique(varTypeCombos)), - info = "Each variable-type combination should be unique in the encoding map") - } -}) - -test_that("encodeOptionsAndDataset handles empty types gracefully", { - - # Create a simple options list without .types entries - opts <- list( - someOption = "value", - anotherOption = 42, - `.meta` = list() - ) - - # Create a simple dataset - dataset <- data.frame( - col1 = 1:5, - col2 = letters[1:5] - ) - - # Should warn about no variable-type pairs found - expect_warning( - result <- jaspTools:::encodeOptionsAndDataset(opts, dataset), - "No variable-type pairs found" - ) - - # Should return original options and dataset unchanged - expect_equal(result$options, opts) - expect_equal(result$dataset, dataset) - expect_equal(nrow(result$encodingMap), 0) -}) - -test_that("encodeOptionsAndDataset handles NULL dataset gracefully", { - - # Create a simple options list (typical for summary stats analyses without data) - opts <- list( - n = 100, - mean = 50, - sd = 10, - `.meta` = list() - ) - - # Should not warn or error when dataset is NULL - result <- jaspTools:::encodeOptionsAndDataset(opts, NULL) - - # Should return original options unchanged - expect_equal(result$options, opts) - - # Dataset should remain NULL - expect_null(result$dataset) - - # Encoding map should be empty - expect_equal(nrow(result$encodingMap), 0) - expect_true(is.data.frame(result$encodingMap)) - expect_true(all(c("original", "encoded", "type") %in% names(result$encodingMap))) -}) - -test_that("encodeOptionsAndDataset works with no-data JASP file", { - - jaspFile <- file.path(testthat::test_path(), "..", "JASPFiles", - "no_data_summary_stats.jasp") - - skip_if_not(file.exists(jaspFile), "No-data JASP file not found") - - # Extract options and dataset - opts <- jaspTools::analysisOptions(jaspFile) - dataset <- jaspTools::extractDatasetFromJASPFile(jaspFile) - - # Dataset should be NULL - expect_null(dataset) - - # Encode should work without errors - result <- jaspTools:::encodeOptionsAndDataset(opts, dataset) - - # Result structure should be correct - expect_true(is.list(result)) - expect_true(all(c("options", "dataset", "encodingMap") %in% names(result))) - - # Options should be unchanged (since no dataset columns to encode) - expect_equal(result$options, opts) - - # Dataset should remain NULL - expect_null(result$dataset) - - # Encoding map should be empty - expect_equal(nrow(result$encodingMap), 0) -}) - -test_that("encodeOptionsAndDataset correctly encodes nested option structures", { - - jaspFile <- file.path(testthat::test_path(), "..", "JASPFiles", "Effectiveness_of_the_BCG_Vaccine_Against_Tuberculosis.jasp") - csvFile <- file.path(testthat::test_path(), "..", "JASPFiles", "Effectiveness_of_the_BCG_Vaccine_Against_Tuberculosis.csv") - - skip_if_not(file.exists(jaspFile), "Test JASP file not found") - skip_if_not(file.exists(csvFile), "Expected CSV file not found") - - # Get options with nested structure (effectSizeModelTerms has list of lists) - opts <- jaspTools::analysisOptions(jaspFile)[[3]] - dataset <- read.csv(csvFile, stringsAsFactors = FALSE, check.names = FALSE) - - result <- jaspTools:::encodeOptionsAndDataset(opts, dataset) - - # If effectSizeModelTerms was encoded, check nested structure - if ("effectSizeModelTerms" %in% names(result$options)) { - encodedTerms <- result$options$effectSizeModelTerms - - # Should still be a list - expect_true(is.list(encodedTerms)) - - # If it contains encoded values, they should be jaspColumnN format - extractStrings <- function(x) { - if (is.character(x)) { - return(x) - } else if (is.list(x)) { - return(unlist(lapply(x, extractStrings))) - } else { - return(character(0)) - } - } - - strings <- extractStrings(encodedTerms) - encodedStrings <- strings[grepl("^jaspColumn\\d+$", strings)] - - if (length(encodedStrings) > 0) { - # All encoded strings should be in the encoding map - expect_true(all(encodedStrings %in% result$encodingMap$encoded), - info = "All encoded variable names should be in the encoding map") - } - } -}) - -test_that("encodeOptionsAndDataset with forceEncode replaces column names in model string via regex", { - - jaspFile <- file.path(testthat::test_path(), "..", "JASPFiles", "bainSem.jasp") - - skip_if_not(file.exists(jaspFile), "Test JASP file not found") - - # Get options from the second analysis (has model with column names like peabody, age) - # Note: bainSem.jasp has 3 analyses, we use the second one - opts <- jaspTools:::analysisOptionsFromJASPFile(jaspFile)[[2]] - - # Load the dataset - dataset <- jaspTools::extractDatasetFromJASPFile(jaspFile) - - # The second bainSem analysis has a 'model' option with embedded column names like: - # "A~B > A~peabody = A~age = 0\n..." - # where peabody and age are column names in the dataset - - # First, verify the model option exists and contains column names - expect_true("model" %in% names(opts)) - originalModel <- opts$model - - # Check that the model string contains some column names from the dataset - colNamesInModel <- colnames(dataset)[vapply(colnames(dataset), function(cn) { - grepl(cn, originalModel, fixed = TRUE) - }, logical(1))] - expect_true(length(colNamesInModel) > 0, - info = "Model option should contain column names from dataset") - - # Encode with forceEncode = "model" - result <- jaspTools:::encodeOptionsAndDataset(opts, dataset, forceEncode = "model") - - # Check that the encoding map was created - expect_true(nrow(result$encodingMap) > 0, - info = "Encoding map should have entries") - - # Check that the model option has been force-encoded - encodedModel <- result$options$model - - # The encoded model should not contain original column names that were in the encoding map - originalVars <- result$encodingMap$original - encodedVars <- result$encodingMap$encoded - - # Check that column names in the encoding map have been replaced - # Only check variables that were actually in the original model - for (i in seq_along(originalVars)) { - origVar <- originalVars[i] - encVar <- encodedVars[i] - - # Check if this variable was in the original model - escapedVar <- gsub("([.\\\\^$|?*+()\\[\\]\\{\\}])", "\\\\\\1", origVar) - pattern <- paste0("(?", encodedModel, fixed = TRUE) || grepl("&", encodedModel, fixed = TRUE), - info = "Model should still contain constraint operators") -}) - -test_that("forceEncode only affects specified options", { - - jaspFile <- file.path(testthat::test_path(), "..", "JASPFiles", "bainSem.jasp") - - skip_if_not(file.exists(jaspFile), "Test JASP file not found") - - # Get options from the second analysis - opts <- jaspTools:::analysisOptionsFromJASPFile(jaspFile)[[2]] - dataset <- jaspTools::extractDatasetFromJASPFile(jaspFile) - - # Test that forceEncode only affects the 'model' option, not other options - # The 'syntax' option also references variables but has shouldEncode metadata - - # Encode with forceEncode = "model" - result <- jaspTools:::encodeOptionsAndDataset(opts, dataset, forceEncode = "model") - - # The 'model' option should be force-encoded (column names replaced with jaspColumnN) - encodedModel <- result$options$model - expect_true(grepl("jaspColumn", encodedModel), - info = "Model should contain encoded column names") - - # Verify that other options that should be encoded via the normal mechanism - # (e.g., 'syntax') are not changed by the forceEncode regex path - no_force <- jaspTools:::encodeOptionsAndDataset(opts, dataset) - expect_equal(result$options$syntax$model, no_force$options$syntax$model, - info = "syntax$model should be encoded by the normal mechanism and not be altered by forceEncode") -}) - -test_that("forceEncode handles multiple options", { - - # Create a simple test case with multiple options to force-encode - opts <- list( - formula1 = "A ~ B + C", - formula2 = "D ~ A + B", - regularOpt = c("A", "B"), - `regularOpt.types` = c("scale", "scale"), - `.meta` = list() - ) - - dataset <- data.frame( - A = 1:5, - B = 6:10, - C = 11:15, - D = 16:20, - stringsAsFactors = FALSE - ) - - # Encode with forceEncode for both formula options - result <- jaspTools:::encodeOptionsAndDataset(opts, dataset, forceEncode = c("formula1", "formula2")) - - # Check encoding map was created - expect_true(nrow(result$encodingMap) > 0) - - # Both formula options should have A and B replaced - expect_false(grepl("(? "jaspColumn1B" - opts <- list( - model = "AB ~ A + B", # AB is a single term, A and B are separate - variables = c("A", "B"), - `variables.types` = c("scale", "scale"), - `.meta` = list() - ) - - dataset <- data.frame( - A = 1:5, - B = 6:10, - AB = 11:15, # This column should NOT be matched if not in encoding map - stringsAsFactors = FALSE - ) - - # Only A and B are in the options with types, not AB - result <- jaspTools:::encodeOptionsAndDataset(opts, dataset, forceEncode = "model") - - # The model should have A and B replaced but AB should remain (since AB is not in encoding map) - encodedModel <- result$options$model - - # A and B should be replaced - expect_false(grepl("(?JaspColumn_26_Encoded", p = 0.2) + ) + + ref <- list( + "jaspColumn4", 0.1, + "jaspColumn2jaspColumn3", 0.2 + ) + + expect_silent(jaspTools::expect_equal_tables(table, ref)) +}) + +test_that("legacy jaspColumn placeholders are not arbitrary text wildcards", { + table <- list( + list(effect = "Sleep", p = 0.1), + list(effect = "Chronotype", p = 0.2) + ) + + ref <- list( + "jaspColumn4", 0.1, + "jaspColumn2", 0.2 + ) + + expect_error(jaspTools::expect_equal_tables(table, ref), "not equal") + expect_false(jaspTools:::tableValuesMatch("", "Sleep")) + expect_false(jaspTools:::tableValuesMatch("", "")) + expect_true(jaspTools:::tableValuesMatch("", "")) +}) + +test_that("native and legacy column tokens canonicalize without touching ordinary text", { + x <- c("JaspColumn_18_Encoded", "jaspColumn4", "Sleep") + + expect_equal( + jaspTools:::canonicalizeJaspColumnTokens(x), + c("", "", "Sleep") + ) +}) diff --git a/tests/testthat/test-extractDatasetFromJASPfile.R b/tests/testthat/test-extractDatasetFromJASPfile.R index 29c5c9d..7aeb457 100644 --- a/tests/testthat/test-extractDatasetFromJASPfile.R +++ b/tests/testthat/test-extractDatasetFromJASPfile.R @@ -88,17 +88,14 @@ test_that("extractDatasetFromJASPFile handles binary columns correctly", { test_that("extractDatasetFromJASPFile handles infinity correctly", { jaspFile <- file.path(testthat::test_path(), "..", "JASPFiles", "debug-descriptives.jasp") - csvFile <- file.path(testthat::test_path(), "..", "JASPFiles", "debug-descriptives.csv") skip_if_not(file.exists(jaspFile), "Test JASP file not found") df <- extractDatasetFromJASPFile(jaspFile) - csv <- read.csv(csvFile, stringsAsFactors = FALSE, check.names = FALSE) - # debInf should be character with infinity symbol - expect_type(df[["debInf"]], "character") - expect_equal(unique(df[["debInf"]]), "\u221e", info = "debInf should contain infinity symbol") - expect_equal(df[["debInf"]], csv[["debInf"]], info = "debInf should match CSV") + expect_type(df[["debInf"]], "double") + expect_true(all(is.infinite(df[["debInf"]])), info = "debInf should contain infinite numeric values") + expect_true(all(df[["debInf"]] > 0), info = "debInf should contain positive infinity values") }) test_that("extractDatasetFromJASPFile handles NaN/NA correctly", { diff --git a/tests/testthat/test-generated-example-tests.R b/tests/testthat/test-generated-example-tests.R new file mode 100644 index 0000000..e6db411 --- /dev/null +++ b/tests/testthat/test-generated-example-tests.R @@ -0,0 +1,220 @@ +context("generated example tests") + +localJaspToolsBinding <- function(name, value) { + namespace <- asNamespace("jaspTools") + oldValue <- get(name, envir = namespace, inherits = FALSE) + wasLocked <- bindingIsLocked(name, namespace) + + if (wasLocked) + unlockBinding(name, namespace) + assign(name, value, envir = namespace) + if (wasLocked) + lockBinding(name, namespace) + + function() { + if (bindingIsLocked(name, namespace)) + unlockBinding(name, namespace) + assign(name, oldValue, envir = namespace) + if (wasLocked) + lockBinding(name, namespace) + } +} + +test_that("generated example test blocks use saved options and dataset replay path", { + block <- jaspTools:::generateExampleTestBlock( + analysisName = "SelectionModels", + analysisIndex = 1, + totalAnalyses = 1, + jaspFileName = "example.jasp", + sourceFolder = "library", + results = list(results = list(), state = list()) + ) + + expect_true(grepl('modulePath <- normalizePath(testthat::test_path("..", ".."), winslash = "/", mustWork = TRUE)', block, fixed = TRUE)) + expect_true(grepl("opts <- jaspTools::analysisOptions(jaspFile, modulePath = modulePath)", block, fixed = TRUE)) + expect_true(grepl("dataset <- jaspTools::extractDatasetFromJASPFile(jaspFile)", block, fixed = TRUE)) + expect_true(grepl( + 'results <- jaspTools::runAnalysis\\("SelectionModels", dataset, opts, modulePath = modulePath\\)', + block + )) + expect_true(grepl("jaspTools:::.expectNoGeneratedExampleFailureStatus(results)", block, fixed = TRUE)) + expect_false(grepl("encodeOptionsAndDataset", block, fixed = TRUE)) + expect_false(grepl("encodedDataset", block, fixed = TRUE)) + expect_false(grepl("forceEncode", block, fixed = TRUE)) +}) + +test_that("basic generated example test blocks use saved options and dataset replay path", { + block <- jaspTools:::generateExampleTestBlockBasic( + analysisName = "SelectionModels", + analysisIndex = 1, + totalAnalyses = 1, + jaspFileName = "example.jasp", + sourceFolder = "library" + ) + + expect_true(grepl('modulePath <- normalizePath(testthat::test_path("..", ".."), winslash = "/", mustWork = TRUE)', block, fixed = TRUE)) + expect_true(grepl("opts <- jaspTools::analysisOptions(jaspFile, modulePath = modulePath)", block, fixed = TRUE)) + expect_true(grepl("dataset <- jaspTools::extractDatasetFromJASPFile(jaspFile)", block, fixed = TRUE)) + expect_true(grepl( + 'results <- jaspTools::runAnalysis\\("SelectionModels", dataset, opts, modulePath = modulePath\\)', + block + )) + expect_true(grepl("jaspTools:::.expectNoGeneratedExampleFailureStatus(results)", block, fixed = TRUE)) + expect_false(grepl("encodeOptionsAndDataset", block, fixed = TRUE)) + expect_false(grepl("encodedDataset", block, fixed = TRUE)) + expect_false(grepl("forceEncode", block, fixed = TRUE)) +}) + +test_that("generated fallback status helper catches JASP failure statuses", { + for (status in c("error", "validationError", "fatalError")) { + expect_error( + jaspTools:::.expectNoGeneratedExampleFailureStatus( + list(status = status, results = list(errorMessage = "boom")) + ), + class = "expectation_failure" + ) + } + + expect_silent(jaspTools:::.expectNoGeneratedExampleFailureStatus( + list(status = "complete", results = list()) + )) +}) + +test_that("generated example test blocks index options for multi-analysis files", { + block <- jaspTools:::generateExampleTestBlock( + analysisName = "SelectionModels", + analysisIndex = 2, + totalAnalyses = 3, + jaspFileName = "example.jasp", + sourceFolder = "library", + results = list(results = list(), state = list()) + ) + + expect_true(grepl("opts <- jaspTools::analysisOptions(jaspFile, modulePath = modulePath)[[2]]", block, fixed = TRUE)) + expect_false(grepl("encodeOptionsAndDataset", block, fixed = TRUE)) + expect_false(grepl("encodedDataset", block, fixed = TRUE)) +}) + +test_that("basic generated example test blocks index options for multi-analysis files", { + block <- jaspTools:::generateExampleTestBlockBasic( + analysisName = "SelectionModels", + analysisIndex = 2, + totalAnalyses = 3, + jaspFileName = "example.jasp", + sourceFolder = "library" + ) + + expect_true(grepl("opts <- jaspTools::analysisOptions(jaspFile, modulePath = modulePath)[[2]]", block, fixed = TRUE)) + expect_false(grepl("encodeOptionsAndDataset", block, fixed = TRUE)) + expect_false(grepl("encodedDataset", block, fixed = TRUE)) +}) + +test_that("test generator reads module analyses through jaspSyntax", { + restore <- localJaspToolsBinding( + ".jaspSyntaxReadModuleDescription", + function(modulePath) { + expect_equal(modulePath, "C:/fake/module") + list( + analyses = list( + list(name = "AnalysisOne"), + list(name = "AnalysisTwo") + ) + ) + } + ) + on.exit(restore(), add = TRUE) + + expect_equal( + jaspTools:::readModuleAnalysisNames("C:/fake/module"), + c("AnalysisOne", "AnalysisTwo") + ) +}) + +test_that("makeTestsFromSingleJASPFile runs generation with unprepared saved options", { + moduleDir <- tempfile("jaspModule_") + dir.create(file.path(moduleDir, "tests", "testthat"), recursive = TRUE) + jaspFile <- tempfile(fileext = ".jasp") + file.create(jaspFile) + + observedPrepared <- NULL + + restore <- list( + localJaspToolsBinding("analysisOptionsFromJASPFile", function(file, modulePath) { + opts <- list(variable = list(value = "x", types = "scale"), `.meta` = list()) + attr(opts, "analysisName") <- "SelectionModels" + attr(opts, "jaspTools.optionShape") <- "saved" + opts + }), + localJaspToolsBinding(".jaspSyntaxNamedModulePaths", function(module.dir) { + expect_equal(module.dir, moduleDir) + list(jaspFake = moduleDir) + }), + localJaspToolsBinding("extractDatasetFromJASPFile", function(file) { + expect_equal(file, jaspFile) + data.frame(x = 1:3) + }), + localJaspToolsBinding("runAnalysis", function(name, dataset, opts, view, quiet, ...) { + observedPrepared <<- jaspTools:::isPreparedOptions(opts) + list(results = list(), state = list()) + }), + localJaspToolsBinding("generateExampleTestBlock", function(...) "test_that(\"generated\", {})") + ) + on.exit(lapply(rev(restore), function(restoreBinding) restoreBinding()), add = TRUE) + + created <- jaspTools:::makeTestsFromSingleJASPFile( + jaspFile, + module.dir = moduleDir, + sourceFolder = "other", + overwrite = TRUE, + pkgAnalyses = "SelectionModels" + ) + + expect_false(observedPrepared) + expect_true(file.exists(created)) + expect_true(any(grepl("generated", readLines(created), fixed = TRUE))) +}) + +test_that("forceEncode transition argument fails loudly", { + moduleDir <- tempfile("jaspModule_") + dir.create(file.path(moduleDir, "tests", "testthat"), recursive = TRUE) + jaspFile <- tempfile(fileext = ".jasp") + file.create(jaspFile) + + expect_error( + jaspTools:::makeTestsFromSingleJASPFile( + jaspFile, + module.dir = moduleDir, + sourceFolder = "other", + forceEncode = "model" + ), + "no longer supported", + fixed = TRUE + ) + + expect_error( + jaspTools:::generateExampleTestBlock( + "Analysis", + analysisIndex = 1L, + totalAnalyses = 1L, + jaspFileName = "analysis.jasp", + sourceFolder = "other", + results = list(results = list()), + forceEncode = "model" + ), + "no longer supported", + fixed = TRUE + ) + + expect_error( + jaspTools:::generateExampleTestBlockBasic( + "Analysis", + analysisIndex = 1L, + totalAnalyses = 1L, + jaspFileName = "analysis.jasp", + sourceFolder = "other", + forceEncode = "model" + ), + "no longer supported", + fixed = TRUE + ) +}) diff --git a/tests/testthat/test-jaspSyntax-lifecycle.R b/tests/testthat/test-jaspSyntax-lifecycle.R new file mode 100644 index 0000000..cd1c2b7 --- /dev/null +++ b/tests/testthat/test-jaspSyntax-lifecycle.R @@ -0,0 +1,1057 @@ +context("jaspSyntax lifecycle") + +localJaspToolsBinding <- function(name, value) { + namespace <- asNamespace("jaspTools") + oldValue <- get(name, envir = namespace, inherits = FALSE) + wasLocked <- bindingIsLocked(name, namespace) + + if (wasLocked) + unlockBinding(name, namespace) + assign(name, value, envir = namespace) + if (wasLocked) + lockBinding(name, namespace) + + function() { + if (bindingIsLocked(name, namespace)) + unlockBinding(name, namespace) + assign(name, oldValue, envir = namespace) + if (wasLocked) + lockBinding(name, namespace) + } +} + +localJaspToolsBindings <- function(...) { + replacements <- list(...) + restores <- Map(localJaspToolsBinding, names(replacements), replacements) + + function() { + lapply(rev(restores), function(restoreBinding) restoreBinding()) + invisible(NULL) + } +} + +localJaspToolsOptions <- function(values) { + oldValues <- options(values) + + function() { + options(oldValues) + invisible(NULL) + } +} + +localJaspToolsPkgOptions <- function(values) { + pkgEnv <- get(".pkgenv", envir = asNamespace("jaspTools"), inherits = FALSE) + oldValues <- pkgEnv[["pkgOptions"]][names(values)] + pkgEnv[["pkgOptions"]][names(values)] <- values + + function() { + pkgEnv[["pkgOptions"]][names(oldValues)] <- oldValues + invisible(NULL) + } +} + +fakeRunWrappedAnalysis <- function(moduleName, analysisName, qmlFileName, + options, version, preloadData, + modulePath = NULL, qmlFile = NULL) { + list( + moduleName = moduleName, + analysisName = analysisName, + qmlFileName = qmlFileName, + options = options, + version = version, + preloadData = preloadData, + modulePath = modulePath, + qmlFile = qmlFile + ) +} + +localDescriptivesModuleOptions <- function(modulePath) { + localJaspToolsPkgOptions(list( + "module.dirs" = modulePath, + "reinstall.modules" = FALSE, + "language" = "en", + "data.dirs" = character(0), + "html.dir" = tempdir(), + "view.in.rstudio" = FALSE + )) +} + +disableDescriptivesPlotOptions <- function(options) { + plotFlags <- c( + "boxPlot", + "boxPlotBoxPlot", + "boxPlotColourPalette", + "boxPlotJitter", + "boxPlotOutlierLabel", + "boxPlotViolin", + "correlationPlots", + "densityPlot", + "distributionAndCorrelationPlotDensity", + "distributionAndCorrelationPlotRugMarks", + "distributionPlots", + "dotPlot", + "heatmapDisplayValue", + "heatmapLegend", + "heatmapPlot", + "intervalPlot", + "likertPlot", + "likertPlotAssumeVariablesSameLevel", + "paretoPlot", + "paretoPlotRule", + "paretoPlotTurnXAxisLabels", + "pieChart", + "qqPlot", + "scatterPlot", + "scatterPlotLegend", + "scatterPlotRegressionLine", + "scatterPlotRegressionLineCi", + "stemAndLeaf" + ) + + for (name in intersect(plotFlags, names(options))) { + if (is.logical(options[[name]]) && length(options[[name]]) == 1L) + options[[name]] <- FALSE + } + + options +} + +skip_if_descriptives_qml_has_known_pareto_bug <- function(modulePath) { + qmlFile <- file.path(modulePath, "inst", "qml", "Descriptives.qml") + if (!file.exists(qmlFile)) + return(invisible(FALSE)) + + qml <- readLines(qmlFile, warn = FALSE) + testthat::skip_if( + any(grepl("visible:\\s*paretoAddCountVariable\\.checked", qml)), + "local jaspDescriptives QML has unresolved paretoAddCountVariable visibility binding" + ) +} + +skip_if_no_jaspSyntax_dataset_api <- function() { + namespace <- asNamespace("jaspSyntax") + required <- c( + "loadAnalysisDataset", + "readLoadedDataset", + "readRequestedDataset", + "clearDatasetState" + ) + missing <- required[!vapply(required, exists, logical(1L), envir = namespace, inherits = FALSE)] + testthat::skip_if( + length(missing) > 0L, + paste("jaspSyntax native dataset API is unavailable:", paste(missing, collapse = ", ")) + ) +} + +test_that("analysisOptionsFromJASPFile requests saved jaspSyntax option records for runAnalysis", { + observed <- NULL + + restore <- localJaspToolsBinding( + ".jaspSyntaxReadAnalysisOptionsNative", + function(file, modulePath, runtime, + includeMeta, + includeTypeOptions, + isolated) { + observed <<- list( + file = file, + modulePath = modulePath, + runtime = runtime, + includeMeta = includeMeta, + includeTypeOptions = includeTypeOptions, + isolated = isolated + ) + list( + list(name = "analysisA", options = list(option = 0L, `option.types` = "scale", `.meta` = list())), + list(name = "analysisB", options = list(option = 1L, `option.types` = "nominal", `.meta` = list())) + ) + } + ) + on.exit(restore(), add = TRUE) + + opts <- jaspTools:::analysisOptionsFromJASPFile("dummy.jasp", modulePath = "C:/fake/module") + + expect_equal(observed$file, "dummy.jasp") + expect_equal(observed$modulePath, "C:/fake/module") + expect_false(observed$runtime) + expect_true(observed$includeMeta) + expect_true(observed$includeTypeOptions) + expect_true(observed$isolated) + expect_length(opts, 2) + expect_equal(attr(opts[[1]], "analysisName"), "analysisA") + expect_equal(attr(opts[[2]], "analysisName"), "analysisB") + expect_equal(attr(opts[[1]], "jaspTools.optionShape"), "saved") + expect_equal(attr(opts[[1]], "modulePath"), "C:/fake/module") + expect_equal(attr(opts[[2]], "modulePath"), "C:/fake/module") + expect_false(jaspTools:::isPreparedOptions(opts[[1]])) + expect_equal(opts[[1]]$option, 0L) + expect_equal(opts[[2]]$option, 1L) + expect_true(".meta" %in% names(opts[[1]])) +}) + +test_that("analysisRuntimeOptions requests and marks runtime jaspSyntax option records", { + observed <- NULL + + restore <- localJaspToolsBinding( + ".jaspSyntaxReadAnalysisOptionsNative", + function(file, modulePath, runtime, + includeMeta, + includeTypeOptions, + isolated) { + observed <<- list( + file = file, + modulePath = modulePath, + runtime = runtime, + includeMeta = includeMeta, + includeTypeOptions = includeTypeOptions, + isolated = isolated + ) + list( + list(name = "analysisA", moduleName = "jaspFake", moduleVersion = "1.2.3", + options = list(option = 0L, `option.types` = "scale")), + list(name = "analysisB", moduleName = "jaspFake", moduleVersion = "1.2.3", + options = list(option = 1L, `option.types` = "nominal")) + ) + } + ) + on.exit(restore(), add = TRUE) + + jaspFile <- tempfile(fileext = ".jasp") + file.create(jaspFile) + + opts <- jaspTools::analysisRuntimeOptions(jaspFile, modulePath = "C:/fake/module") + + expect_equal(observed$file, normalizePath(jaspFile, winslash = "/", mustWork = FALSE)) + expect_equal(observed$modulePath, "C:/fake/module") + expect_true(observed$runtime) + expect_false(observed$includeMeta) + expect_true(observed$includeTypeOptions) + expect_true(observed$isolated) + expect_length(opts, 2) + expect_true(jaspTools:::isPreparedOptions(opts[[1]])) + expect_true(jaspTools:::isPreparedOptions(opts[[2]])) + expect_equal(attr(opts[[1]], "analysisName"), "analysisA") + expect_equal(attr(opts[[1]], "moduleName"), "jaspFake") + expect_equal(attr(opts[[1]], "moduleVersion"), "1.2.3") + expect_equal(attr(opts[[1]], "jaspTools.optionShape"), "runtime") + expect_equal(attr(opts[[1]], "modulePath"), "C:/fake/module") + expect_false(".meta" %in% names(opts[[1]])) +}) + +test_that("named modulePath mismatches fail instead of losing provenance", { + records <- list( + list( + name = "analysisA", + moduleName = "jaspFake", + options = list(option = TRUE) + ) + ) + + expect_error( + jaspTools:::.optionsFromJaspRecords( + records, + preparedOptions = FALSE, + optionShape = "saved", + modulePath = list(jaspOther = "C:/other/module") + ), + "do not match", + fixed = TRUE + ) +}) + +test_that(".jaspSyntaxReadAnalysisOptionsFromJaspFile uses configured module paths", { + observed <- NULL + + restore <- list( + localJaspToolsBinding(".jaspSyntaxRuntimeModulePaths", function() list(jaspFake = "C:/fake/module")), + localJaspToolsBinding( + ".jaspSyntaxReadAnalysisOptionsNative", + function(file, modulePath, runtime, + includeMeta, + includeTypeOptions, + isolated) { + observed <<- list( + file = file, + modulePath = modulePath, + runtime = runtime, + includeMeta = includeMeta, + includeTypeOptions = includeTypeOptions, + isolated = isolated + ) + list(list(name = "analysisA", options = structure(list(), analysisName = "analysisA"))) + } + ) + ) + on.exit(lapply(rev(restore), function(restoreBinding) restoreBinding()), add = TRUE) + + records <- jaspTools:::.jaspSyntaxReadAnalysisOptionsFromJaspFile("dummy.jasp") + + expect_length(records, 1) + expect_equal(observed$file, "dummy.jasp") + expect_equal(observed$modulePath, list(jaspFake = "C:/fake/module")) + expect_false(observed$runtime) + expect_true(observed$includeMeta) + expect_true(observed$includeTypeOptions) + expect_true(observed$isolated) +}) + +test_that("prepared option state helper only trusts namespaced attributes", { + opts <- list(option = TRUE) + attr(opts, "preparedOptions") <- TRUE + attr(opts, "syntax") <- TRUE + expect_false(jaspTools:::isPreparedOptions(opts)) + + prepared <- jaspTools:::markPreparedOptions(opts) + expect_true(jaspTools:::isPreparedOptions(prepared)) +}) + +test_that(".jaspSyntaxNamedModulePaths names local module paths for jaspSyntax", { + moduleDir <- tempfile("jaspFakeModule_") + dir.create(moduleDir) + writeLines( + c( + "Package: jaspFake", + "Version: 0.0.1", + "Title: Fake JASP Module", + "Description: Fake module for tests.", + "License: GPL-2" + ), + file.path(moduleDir, "DESCRIPTION") + ) + + paths <- jaspTools:::.jaspSyntaxNamedModulePaths(moduleDir) + + expect_equal(names(paths), "jaspFake") + expect_equal(paths[[1]], normalizePath(moduleDir, winslash = "/", mustWork = FALSE)) +}) + +test_that("preloadDataset delegates raw dataset preparation to jaspSyntax", { + clearDatasetCalls <- 0L + observed <- NULL + requested <- data.frame(left = 1:2) + resultDecodingDataset <- data.frame(left = factor(c("control", "treatment"))) + columnMapping <- c(JaspColumn_1_Encoded = "left") + + restore <- localJaspToolsBindings( + .jaspSyntaxClearDatasetState = function(required) { + expect_true(required) + clearDatasetCalls <<- clearDatasetCalls + 1L + invisible(NULL) + }, + .jaspSyntaxLoadAnalysisDataset = function(dataset, modulePath, analysisName, options) { + observed <<- list( + dataset = dataset, + modulePath = modulePath, + analysisName = analysisName, + options = options + ) + list( + loadedDataset = dataset, + requestedDataset = requested, + resultDecodingDataset = resultDecodingDataset, + columnMapping = columnMapping + ) + } + ) + on.exit(restore(), add = TRUE) + + dataset <- data.frame(left = 1:2, right = c("a", "b"), stringsAsFactors = FALSE) + options <- list(variables = list(value = "left", types = "scale")) + jaspTools:::preloadDataset( + dataset, + options = options, + modulePath = "C:/fake/module", + analysisName = "FakeAnalysis" + ) + + expect_equal(clearDatasetCalls, 1L) + expect_identical(observed$dataset, dataset) + expect_identical(observed$modulePath, "C:/fake/module") + expect_identical(observed$analysisName, "FakeAnalysis") + expect_identical(observed$options, options) + expect_equal(jaspTools:::.getInternal("preloadedDataset"), resultDecodingDataset) + expect_equal(jaspTools:::.getInternal("preloadedColumnMapping"), columnMapping) +}) + +test_that("preloadDataset clears stale native state for null datasets", { + clearDatasetCalls <- 0L + + restore <- localJaspToolsBindings( + .jaspSyntaxClearDatasetState = function(required) { + expect_true(required) + clearDatasetCalls <<- clearDatasetCalls + 1L + invisible(NULL) + } + ) + on.exit(restore(), add = TRUE) + + jaspTools:::preloadDataset(NULL, options = list()) + + expect_equal(clearDatasetCalls, 1L) + expect_equal(jaspTools:::.getInternal("preloadedDataset"), data.frame()) + expect_equal(jaspTools:::.getInternal("preloadedColumnMapping"), character(0)) +}) + +test_that("analysis result decoding delegates to jaspSyntax", { + observed <- NULL + requestedDataset <- data.frame(encoded = factor("a")) + columnMapping <- c(JaspColumn_1_Encoded = "encoded") + oldPreloadedDataset <- tryCatch( + jaspTools:::.getInternal("preloadedDataset"), + error = function(e) NULL + ) + oldPreloadedColumnMapping <- tryCatch( + jaspTools:::.getInternal("preloadedColumnMapping"), + error = function(e) character(0) + ) + jaspTools:::.setInternal("preloadedDataset", requestedDataset) + jaspTools:::.setInternal("preloadedColumnMapping", columnMapping) + on.exit(jaspTools:::.setInternal("preloadedDataset", oldPreloadedDataset), add = TRUE) + on.exit(jaspTools:::.setInternal("preloadedColumnMapping", oldPreloadedColumnMapping), add = TRUE) + + restore <- localJaspToolsBindings( + .jaspSyntaxCall = function(names, args = list(), required = TRUE, + feature = "jaspSyntax bridge API", + requiredArgs = names(args), + requiredArgGroups = list()) { + observed <<- list( + names = names, + args = args, + required = required, + feature = feature, + requiredArgs = requiredArgs, + requiredArgGroups = requiredArgGroups + ) + args$results$decoded <- TRUE + args$results + } + ) + on.exit(restore(), add = TRUE) + + results <- list(status = "complete", table = list(column = "JaspColumn_1_Encoded")) + decoded <- jaspTools:::.jaspSyntaxDecodeAnalysisResults(results) + + expect_true(decoded$decoded) + expect_equal(observed$names, "decodeAnalysisResults") + expect_equal(observed$args$results, results) + expect_identical(observed$args$requestedDataset, requestedDataset) + expect_identical(observed$args$columnMapping, columnMapping) + expect_true(observed$required) + expect_equal(observed$requiredArgs, "results") +}) + +test_that("analysis result decoding delegates plain results to jaspSyntax", { + observed <- NULL + restore <- localJaspToolsBindings( + .jaspSyntaxCall = function(names, args = list(), required = TRUE, + feature = "jaspSyntax bridge API", + requiredArgs = names(args), + requiredArgGroups = list()) { + observed <<- list( + names = names, + args = args, + required = required, + feature = feature, + requiredArgs = requiredArgs, + requiredArgGroups = requiredArgGroups + ) + args$results + } + ) + on.exit(restore(), add = TRUE) + + results <- list(status = "complete", table = list(column = "plain")) + + expect_identical( + jaspTools:::.jaspSyntaxDecodeAnalysisResults(results), + results + ) + expect_equal(observed$names, "decodeAnalysisResults") + expect_equal(observed$args$results, results) + expect_true(observed$required) + expect_equal(observed$requiredArgs, "results") +}) + +test_that("column decoding wrapper calls the current jaspSyntax API", { + observedArgs <- NULL + observedNames <- NULL + restore <- localJaspToolsBinding( + ".jaspSyntaxCall", + function(names, args = list(), required = TRUE, + feature = "jaspSyntax bridge API", + requiredArgs = names(args), + requiredArgGroups = list()) { + observedNames <<- names + observedArgs <<- args + c("decodedA", "decodedB") + } + ) + on.exit(restore(), add = TRUE) + + decoded <- jaspTools:::.jaspSyntaxDecodeColumnNames(c("encodedA", "encodedB"), strict = TRUE) + + expect_equal(decoded, c("decodedA", "decodedB")) + expect_equal(observedNames, "decodeColumnNames") + expect_equal(observedArgs$columnNames, c("encodedA", "encodedB")) + expect_null(observedArgs$x) + expect_true(observedArgs$strict) +}) + +test_that("jaspSyntax bridge wrapper rejects missing required arguments", { + oldLoadAnalysisDataset <- function(dataset) dataset + + expect_error( + jaspTools:::.callWithSupportedArgs( + oldLoadAnalysisDataset, + args = list( + dataset = data.frame(x = 1), + modulePath = "C:/fake/module", + analysisName = "FakeAnalysis", + options = list(variable = "x") + ), + requiredArgs = c("dataset", "modulePath", "analysisName", "options"), + functionName = "jaspSyntax::loadAnalysisDataset()", + feature = "native analysis dataset API" + ), + "modulePath", + fixed = TRUE + ) +}) + +test_that("fetchRunArgs targets jaspBase wrapped native QML path", { + restore <- localJaspToolsBindings( + .jaspBaseRunWrappedAnalysis = function() fakeRunWrappedAnalysis, + getModulePathFromRFunction = function(funName) { + expect_equal(funName, "WrappedAnalysis") + "C:/fake/module" + }, + .jaspSyntaxResolveAnalysisQml = function(modulePath, analysisName) { + expect_equal(modulePath, "C:/fake/module") + expect_equal(analysisName, "WrappedAnalysis") + list( + moduleName = "jaspFake", + analysisName = "WrappedAnalysis", + qmlFileName = "WrappedAnalysis.qml", + qmlFile = "C:/fake/module/inst/qml/WrappedAnalysis.qml", + version = "1.0.0", + preloadData = TRUE + ) + } + ) + on.exit(restore(), add = TRUE) + + opts <- list(flag = TRUE) + args <- jaspTools:::fetchRunArgs("WrappedAnalysis", opts) + + expect_identical(attr(args, "runner"), fakeRunWrappedAnalysis) + expect_equal(attr(args, "modulePath", exact = TRUE), "C:/fake/module") + attr(args, "runner") <- NULL + attr(args, "modulePath") <- NULL + expect_equal(args$moduleName, "jaspFake") + expect_equal(args$analysisName, "WrappedAnalysis") + expect_equal(args$qmlFileName, "WrappedAnalysis.qml") + expect_equal(args$qmlFile, "C:/fake/module/inst/qml/WrappedAnalysis.qml") + expect_equal(args$modulePath, "C:/fake/module") + expect_equal(args$options, opts) + expect_true(args$preloadData) + expect_false("functionCall" %in% names(args)) +}) + +test_that("fetchRunArgs honors modulePath carried by options or explicit calls", { + observedModulePaths <- character(0) + restore <- localJaspToolsBindings( + .jaspBaseRunWrappedAnalysis = function() fakeRunWrappedAnalysis, + getModulePathFromRFunction = function(funName) { + stop("ambient module resolution should not be used") + }, + .jaspSyntaxResolveAnalysisQml = function(modulePath, analysisName) { + observedModulePaths <<- c(observedModulePaths, modulePath) + list( + moduleName = "jaspFake", + analysisName = analysisName, + qmlFileName = paste0(analysisName, ".qml"), + qmlFile = file.path(modulePath, "inst", "qml", paste0(analysisName, ".qml")), + version = "1.0.0", + preloadData = TRUE + ) + } + ) + on.exit(restore(), add = TRUE) + + opts <- list(flag = TRUE) + attr(opts, "modulePath") <- "C:/attr/module" + jaspTools:::fetchRunArgs("WrappedAnalysis", opts) + jaspTools:::fetchRunArgs("WrappedAnalysis", opts, modulePath = "C:/explicit/module") + + expect_equal(observedModulePaths, c("C:/attr/module", "C:/explicit/module")) +}) + +test_that("fetchRunArgs preserves preloadData = FALSE from jaspSyntax for wrapped options", { + restore <- localJaspToolsBindings( + .jaspBaseRunWrappedAnalysis = function() fakeRunWrappedAnalysis, + getModulePathFromRFunction = function(funName) "C:/fake/module", + .jaspSyntaxResolveAnalysisQml = function(modulePath, analysisName) { + list( + moduleName = "jaspFake", + analysisName = analysisName, + qmlFileName = paste0(analysisName, ".qml"), + version = "1.0.0", + preloadData = FALSE + ) + } + ) + on.exit(restore(), add = TRUE) + + args <- jaspTools:::fetchRunArgs("NoDataAnalysis", list(flag = TRUE)) + + expect_identical(attr(args, "runner"), fakeRunWrappedAnalysis) + expect_false(args$preloadData) +}) + +test_that("fetchRunArgs requires jaspBase modulePath and qmlFile provenance support", { + oldRunner <- function(moduleName, analysisName, qmlFileName, options, version, preloadData) NULL + + restore <- localJaspToolsBindings( + .jaspBaseRunWrappedAnalysis = function() oldRunner + ) + on.exit(restore(), add = TRUE) + + expect_error( + jaspTools:::fetchRunArgs("WrappedAnalysis", list(flag = TRUE)), + "modulePath", + fixed = TRUE + ) +}) + +test_that("quiet runAnalysis uses subprocess containment outside testthat", { + restoreOption <- localJaspToolsOptions(list(jaspTools.runAnalysis.subprocess = TRUE)) + on.exit(restoreOption(), add = TRUE) + + expect_true(jaspTools:::runAnalysisShouldUseSubprocess( + quiet = TRUE, + testEnvironment = FALSE + )) + expect_false(jaspTools:::runAnalysisShouldUseSubprocess( + quiet = FALSE, + testEnvironment = FALSE + )) + expect_true(jaspTools:::runAnalysisShouldUseSubprocess( + quiet = FALSE, + testEnvironment = TRUE + )) +}) + +test_that("subprocess html files can be collected and restored", { + sourceRoot <- tempfile("source-html-") + targetRoot <- tempfile("target-html-") + dir.create(file.path(sourceRoot, "plots"), recursive = TRUE) + writeBin(as.raw(c(1, 2, 3, 4)), file.path(sourceRoot, "plots", "plot.png")) + writeLines("", file.path(sourceRoot, "tmp-index.html")) + + files <- jaspTools:::collectSubprocessHtmlFiles(sourceRoot) + restored <- jaspTools:::restoreSubprocessHtmlFiles(files, targetRoot) + + expect_true(restored) + expect_equal( + readBin(file.path(targetRoot, "plots", "plot.png"), what = "raw", n = 4L), + as.raw(c(1, 2, 3, 4)) + ) + expect_true(file.exists(file.path(targetRoot, "tmp-index.html"))) +}) + +test_that("subprocess warnings are replayed in the parent session", { + expect_warning( + jaspTools:::replaySubprocessWarnings("first warning"), + "first warning", + fixed = TRUE + ) +}) + +test_that("subprocess env only carries requested variables", { + env <- jaspTools:::.jaspToolsSubprocessEnv("JASPTOOLS_FAKE_CHILD") + + expect_named(env, "JASPTOOLS_FAKE_CHILD") + expect_identical(env$JASPTOOLS_FAKE_CHILD, "true") +}) + +test_that("subprocess payload carries selected R options", { + restoreOption <- localJaspToolsOptions(list(jaspLegacyRngKind = FALSE)) + on.exit(restoreOption(), add = TRUE) + + payload <- jaspTools:::.jaspToolsSubprocessPayload() + + expect_identical(payload$rOptions$jaspLegacyRngKind, FALSE) +}) + +test_that("subprocess runner captures warnings without child quiet suppression", { + script <- jaspTools:::runAnalysisSubprocessScript() + + expect_true(any(grepl("pkgload::load_all", script, fixed = TRUE))) + expect_true(any(grepl(".jaspToolsRestoreROptionsForChild", script, fixed = TRUE))) + expect_true(any(grepl(".jaspToolsRestorePkgOptionsForChild", script, fixed = TRUE))) + expect_true(any(grepl("setupCompleteOverride", script, fixed = TRUE))) + expect_true(any(grepl(".initOutputDirs", script, fixed = TRUE))) + expect_true(any(grepl(".jaspToolsSubprocessError", script, fixed = TRUE))) + expect_true(any(grepl("withCallingHandlers", script, fixed = TRUE))) + expect_true(any(grepl("warnings <<- c\\(warnings, conditionMessage\\(w\\)\\)", script))) + expect_true(any(grepl("warnings = unique\\(warnings\\)", script))) +}) + +test_that("runAnalysis sends processed results to the viewer", { + rawJson <- '{"status":"complete","results":{"table":{"data":[{"name":"JaspColumn_1_Encoded"}]}}}' + processed <- list( + status = "complete", + results = list(table = list(data = list(list(name = "decoded name")))) + ) + viewed <- NULL + observedOrder <- character() + + restore <- localJaspToolsBindings( + insideTestEnvironment = function() FALSE, + fetchRunArgs = function(name, options, modulePath = NULL) { + observedOrder <<- c(observedOrder, "fetch") + args <- list() + attr(args, "runner") <- function() structure(list(), class = c("jaspResultsR", "R6")) + attr(args, "modulePath") <- modulePath + args + }, + initAnalysisRuntime = function(...) { + observedOrder <<- c(observedOrder, "init") + invisible(NULL) + }, + .resetRunTimeInternals = function() invisible(NULL), + getJsonResultsFromJaspResults = function(results) rawJson, + transferPlotsFromjaspResults = function() invisible(NULL), + processJsonResults = function(jsonResults) { + expect_identical(jsonResults, rawJson) + processed + }, + view = function(results) { + viewed <<- results + invisible("fake.html") + } + ) + on.exit(restore(), add = TRUE) + + result <- jaspTools::runAnalysis( + "FakeAnalysis", + dataset = data.frame(x = 1), + options = list(variable = "x"), + view = TRUE, + quiet = FALSE, + modulePath = "C:/fake/module" + ) + + expect_identical(result, processed) + expect_identical(viewed, processed) + expect_identical(jaspTools:::.getInternal("lastResults"), rawJson) + expect_equal(observedOrder, c("fetch", "init")) +}) + +test_that("subprocess runAnalysis parent views returned processed results", { + rawJson <- '{"status":"complete","results":{"table":{"data":[{"name":"JaspColumn_1_Encoded"}]}}}' + processed <- list( + status = "complete", + results = list(table = list(data = list(list(name = "decoded name")))) + ) + viewed <- NULL + + restore <- localJaspToolsBindings( + launchRunAnalysisSubprocess = function(scriptPath, inputPath, outputPath, logPath) { + payload <- readRDS(inputPath) + expect_false(payload$args$view) + expect_false(payload$args$makeTests) + expect_identical(payload$env$JASPTOOLS_RUNANALYSIS_CHILD, "true") + expect_true(all(c("NOT_CRAN", "LANG", "LANGUAGE") %in% names(payload$env))) + saveRDS( + list( + result = processed, + lastResults = rawJson, + htmlFiles = list(files = list()), + warnings = character(0) + ), + outputPath + ) + 0L + }, + view = function(results) { + viewed <<- results + invisible("fake.html") + } + ) + on.exit(restore(), add = TRUE) + + result <- jaspTools:::runAnalysisInSubprocess( + name = "FakeAnalysis", + dataset = data.frame(x = 1), + options = list(variable = "x"), + view = TRUE, + quiet = TRUE, + makeTests = FALSE + ) + + expect_identical(result, processed) + expect_identical(viewed, processed) + expect_identical(jaspTools:::.getInternal("lastResults"), rawJson) +}) + +test_that("native QML replay accepts saved bound scalar options", { + fixtureModule <- normalizePath( + file.path("C:/JASP-Packages/jaspSyntax/tests/testthat/fixtures/minimalModule"), + winslash = "/", + mustWork = FALSE + ) + testthat::skip_if_not(dir.exists(fixtureModule), "jaspSyntax minimal module fixture is unavailable") + + opts <- jaspSyntax::readAnalysisOptionsFromQml( + fixtureModule, + "MinimalAnalysis", + options = list( + choice = "one", + flag = FALSE, + threshold = 2.5 + ), + fresh = TRUE, + includeMeta = FALSE + ) + + expect_equal(opts$choice, "one") + expect_false(opts$flag) + expect_equal(opts$threshold, 2.5) +}) + +test_that("run argument construction rejects analysis and module metadata mismatch", { + restore <- localJaspToolsBindings( + .jaspBaseRunWrappedAnalysis = function() fakeRunWrappedAnalysis, + getModulePathFromRFunction = function(funName) "C:/fake/module", + .jaspSyntaxResolveAnalysisQml = function(modulePath, analysisName) { + list( + moduleName = "jaspFake", + analysisName = analysisName, + qmlFileName = paste0(analysisName, ".qml"), + version = "1.0.0", + preloadData = TRUE + ) + } + ) + on.exit(restore(), add = TRUE) + + wrongAnalysis <- list(flag = TRUE) + attr(wrongAnalysis, "analysisName") <- "OtherAnalysis" + expect_error( + jaspTools:::fetchRunArgs("PreparedAnalysis", wrongAnalysis), + "tagged for analysis" + ) + + wrongModule <- list(flag = TRUE) + attr(wrongModule, "analysisName") <- "PreparedAnalysis" + attr(wrongModule, "moduleName") <- "jaspOther" + expect_error( + jaspTools:::fetchRunArgs("PreparedAnalysis", wrongModule), + "tagged for module" + ) +}) + +test_that("runAnalysis rejects prepared runtime options", { + restoreOption <- localJaspToolsOptions(list(jaspTools.runAnalysis.subprocess = FALSE)) + on.exit(restoreOption(), add = TRUE) + + observed <- list(initCalled = FALSE, fetchCalled = FALSE) + + restore <- localJaspToolsBindings( + initAnalysisRuntime = function(...) { + observed$initCalled <<- TRUE + invisible(NULL) + }, + fetchRunArgs = function(...) { + observed$fetchCalled <<- TRUE + stop("fetchRunArgs should not be called") + }, + .resetRunTimeInternals = function() invisible(NULL) + ) + on.exit(restore(), add = TRUE) + + opts <- jaspTools:::markPreparedOptions(list(flag = TRUE)) + + expect_error( + jaspTools::runAnalysis("PreparedAnalysis", dataset = data.frame(x = 1), options = opts), + "inspection only", + fixed = TRUE + ) + expect_false(observed$initCalled) + expect_false(observed$fetchCalled) +}) + +test_that("real saved .jasp options replay once through runAnalysis with extracted data", { + testthat::skip_if_not( + identical(Sys.getenv("JASPTOOLS_RUN_REAL_DESCRIPTIVES"), "true"), + "set JASPTOOLS_RUN_REAL_DESCRIPTIVES=true to run local jaspDescriptives subprocess integration tests" + ) + jaspFile <- file.path(testthat::test_path(), "..", "JASPFiles", "debug-descriptives.jasp") + testthat::skip_if_not(file.exists(jaspFile), "debug descriptives .jasp fixture is unavailable") + testthat::skip_if_not_installed("jaspDescriptives") + skip_if_no_jaspSyntax_dataset_api() + + modulePath <- normalizePath("C:/JASP-Packages/jaspDescriptives", winslash = "/", mustWork = FALSE) + testthat::skip_if_not(dir.exists(modulePath), "local jaspDescriptives checkout is unavailable") + skip_if_descriptives_qml_has_known_pareto_bug(modulePath) + + restoreRngOption <- localJaspToolsOptions(list(jaspLegacyRngKind = FALSE)) + on.exit(restoreRngOption(), add = TRUE) + + restorePkgOptions <- localDescriptivesModuleOptions(modulePath) + on.exit(restorePkgOptions(), add = TRUE) + + restore <- localJaspToolsBindings( + getModulePathFromRFunction = function(funName) { + expect_equal(funName, "Descriptives") + modulePath + }, + getModulePaths = function() modulePath, + getPkgOption = function(name) { + switch( + name, + reinstall.modules = FALSE, + language = "en", + data.dirs = character(0), + html.dir = tempdir(), + view.in.rstudio = FALSE, + "" + ) + } + ) + on.exit(restore(), add = TRUE) + + opts <- jaspTools::analysisOptions(jaspFile) + expect_equal(attr(opts, "analysisName"), "Descriptives") + expect_equal(attr(opts, "moduleName"), "jaspDescriptives") + expect_equal(attr(opts, "jaspTools.optionShape"), "saved") + expect_false(jaspTools:::isPreparedOptions(opts)) + expect_true(is.list(opts$variables)) + expect_equal(unlist(opts$variables$value, use.names = FALSE), "contNormal") + expect_equal(unlist(opts$variables$types, use.names = FALSE), "scale") + opts <- disableDescriptivesPlotOptions(opts) + + dataset <- jaspTools::extractDatasetFromJASPFile(jaspFile) + expect_s3_class(dataset, "data.frame") + expect_equal(dim(dataset), c(100L, 31L)) + expect_true("contNormal" %in% names(dataset)) + + results <- jaspTools::runAnalysis("Descriptives", dataset, opts, view = FALSE, quiet = TRUE) + stats <- results$results$stats + firstRow <- stats$data[[1L]] + + expect_equal(results$status, "complete") + expect_equal(stats$status, "complete") + expect_equal(firstRow$Valid, 100L) + expect_equal(firstRow$Missing, 0L) + expect_equal(firstRow$MeanArithmetic, mean(dataset$contNormal), tolerance = 1e-6) + expect_equal(firstRow[["Std. Deviation"]], stats::sd(dataset$contNormal), tolerance = 1e-6) +}) + +test_that("real QML defaults can be edited and replayed through QML once", { + testthat::skip_if_not( + identical(Sys.getenv("JASPTOOLS_RUN_REAL_DESCRIPTIVES"), "true"), + "set JASPTOOLS_RUN_REAL_DESCRIPTIVES=true to run local jaspDescriptives subprocess integration tests" + ) + jaspFile <- file.path(testthat::test_path(), "..", "JASPFiles", "debug-descriptives.jasp") + testthat::skip_if_not(file.exists(jaspFile), "debug descriptives .jasp fixture is unavailable") + testthat::skip_if_not_installed("jaspDescriptives") + skip_if_no_jaspSyntax_dataset_api() + + modulePath <- normalizePath("C:/JASP-Packages/jaspDescriptives", winslash = "/", mustWork = FALSE) + testthat::skip_if_not(dir.exists(modulePath), "local jaspDescriptives checkout is unavailable") + skip_if_descriptives_qml_has_known_pareto_bug(modulePath) + + restoreRngOption <- localJaspToolsOptions(list(jaspLegacyRngKind = FALSE)) + on.exit(restoreRngOption(), add = TRUE) + + restorePkgOptions <- localDescriptivesModuleOptions(modulePath) + on.exit(restorePkgOptions(), add = TRUE) + + restore <- localJaspToolsBindings( + getModulePathFromRFunction = function(funName) { + expect_equal(funName, "Descriptives") + modulePath + }, + getModulePaths = function() modulePath, + getPkgOption = function(name) { + switch( + name, + reinstall.modules = FALSE, + language = "en", + data.dirs = character(0), + html.dir = tempdir(), + view.in.rstudio = FALSE, + "" + ) + } + ) + on.exit(restore(), add = TRUE) + + opts <- jaspTools::analysisOptions("Descriptives") + expect_equal(attr(opts, "jaspTools.optionShape"), "qml") + expect_false(any(grepl("\\.types$", names(opts)))) + opts$variables <- "contNormal" + opts <- disableDescriptivesPlotOptions(opts) + + dataset <- jaspTools::extractDatasetFromJASPFile(jaspFile) + results <- jaspTools::runAnalysis("Descriptives", dataset, opts, view = FALSE, quiet = TRUE) + stats <- results$results$stats + firstRow <- stats$data[[1L]] + + expect_equal(results$status, "complete") + expect_equal(stats$status, "complete") + expect_equal(firstRow$Valid, 100L) + expect_equal(firstRow$MeanArithmetic, mean(dataset$contNormal), tolerance = 1e-6) +}) + +test_that("real runtime .jasp options are inspection-only", { + testthat::skip_if_not( + identical(Sys.getenv("JASPTOOLS_RUN_REAL_DESCRIPTIVES"), "true"), + "set JASPTOOLS_RUN_REAL_DESCRIPTIVES=true to run local jaspDescriptives subprocess integration tests" + ) + jaspFile <- file.path(testthat::test_path(), "..", "JASPFiles", "debug-descriptives.jasp") + testthat::skip_if_not(file.exists(jaspFile), "debug descriptives .jasp fixture is unavailable") + testthat::skip_if_not_installed("jaspDescriptives") + + modulePath <- normalizePath("C:/JASP-Packages/jaspDescriptives", winslash = "/", mustWork = FALSE) + testthat::skip_if_not(dir.exists(modulePath), "local jaspDescriptives checkout is unavailable") + + restorePkgOptions <- localDescriptivesModuleOptions(modulePath) + on.exit(restorePkgOptions(), add = TRUE) + + restore <- localJaspToolsBindings( + getModulePathFromRFunction = function(funName) { + expect_equal(funName, "Descriptives") + modulePath + }, + getModulePaths = function() modulePath, + getPkgOption = function(name) { + switch( + name, + reinstall.modules = FALSE, + language = "en", + data.dirs = character(0), + html.dir = tempdir(), + view.in.rstudio = FALSE, + "" + ) + } + ) + on.exit(restore(), add = TRUE) + + opts <- jaspTools::analysisRuntimeOptions(jaspFile) + expect_equal(attr(opts, "analysisName"), "Descriptives") + expect_equal(attr(opts, "moduleName"), "jaspDescriptives") + expect_true(jaspTools:::isPreparedOptions(opts)) + expect_true("variables.types" %in% names(opts)) + expect_match(unlist(opts$variables, use.names = FALSE)[[1L]], "^JaspColumn_.*_Encoded$") + expect_equal(unlist(opts$`variables.types`, use.names = FALSE), "scale") + + dataset <- jaspTools::extractDatasetFromJASPFile(jaspFile) + expect_error( + jaspTools::runAnalysis("Descriptives", dataset, opts, view = FALSE, quiet = TRUE), + "inspection only", + fixed = TRUE + ) +}) diff --git a/tests/testthat/test-rbridge-shim.R b/tests/testthat/test-rbridge-shim.R new file mode 100644 index 0000000..3daca2f --- /dev/null +++ b/tests/testthat/test-rbridge-shim.R @@ -0,0 +1,218 @@ +context("minimal rbridge shim") + +localJaspToolsBinding <- function(name, value) { + namespace <- asNamespace("jaspTools") + oldValue <- get(name, envir = namespace, inherits = FALSE) + wasLocked <- bindingIsLocked(name, namespace) + + if (wasLocked) + unlockBinding(name, namespace) + assign(name, value, envir = namespace) + if (wasLocked) + lockBinding(name, namespace) + + function() { + if (bindingIsLocked(name, namespace)) + unlockBinding(name, namespace) + assign(name, oldValue, envir = namespace) + if (wasLocked) + lockBinding(name, namespace) + } +} + +localJaspToolsOptions <- function(values) { + oldValues <- options(values) + + function() { + options(oldValues) + invisible(NULL) + } +} + +localGlobalSymbol <- function(name, value) { + hadValue <- exists(name, envir = .GlobalEnv, inherits = FALSE) + oldValue <- if (hadValue) get(name, envir = .GlobalEnv, inherits = FALSE) else NULL + wasLocked <- hadValue && bindingIsLocked(name, .GlobalEnv) + + if (wasLocked) + unlockBinding(name, .GlobalEnv) + assign(name, value, envir = .GlobalEnv) + if (wasLocked) + lockBinding(name, .GlobalEnv) + + function() { + if (exists(name, envir = .GlobalEnv, inherits = FALSE) && + bindingIsLocked(name, .GlobalEnv)) { + unlockBinding(name, .GlobalEnv) + } + + if (hadValue) { + assign(name, oldValue, envir = .GlobalEnv) + if (wasLocked) + lockBinding(name, .GlobalEnv) + } else if (exists(name, envir = .GlobalEnv, inherits = FALSE)) { + rm(list = name, envir = .GlobalEnv) + } + + invisible(NULL) + } +} + +test_that("rbridge hook injects only local runtime callbacks", { + env <- new.env(parent = emptyenv()) + + result <- jaspTools:::.insertRbridgeIntoEnv(env) + + expect_identical(result, env) + expect_setequal(ls(env, all.names = TRUE), jaspTools:::.rbridgeNativeSymbols()) +}) + +test_that("rbridge hook leaves native jaspSyntax dataset callbacks alone", { + env <- new.env(parent = emptyenv()) + nativeRequested <- function() "native" + environment(nativeRequested) <- emptyenv() + env$.readDataSetRequestedNative <- nativeRequested + + jaspTools:::.insertRbridgeIntoEnv(env) + + expect_identical(env$.readDataSetRequestedNative, nativeRequested) + expect_true(identical(environmentName(environment(env$.requestTempFileNameNative)), "jaspTools")) + expect_false(".readDataSetRequestedNative" %in% jaspTools:::.rbridgeNativeSymbols()) +}) + +test_that("state callback initializes the state file expected by jaspBase", { + jaspTools:::.resetRunStateFile() + location <- jaspTools:::.requestStateFileNameNative() + stateFile <- file.path(location$root, location$relativePath) + + expect_true(file.exists(stateFile)) + loadedNames <- load(stateFile) + + expect_identical(loadedNames, "state") + expect_null(state) +}) + +test_that("processed results read standalone jaspBase state from callback file", { + restoreDecode <- localJaspToolsBinding(".jaspSyntaxDecodeAnalysisResults", function(results) results) + on.exit(restoreDecode(), add = TRUE) + on.exit(jaspTools:::.resetRunStateFile(), add = TRUE) + + location <- jaspTools:::.requestStateFileNameNative() + stateFile <- file.path(location$root, location$relativePath) + state <- list(figures = list(), other = list(answer = 42)) + save(state, file = stateFile, compress = FALSE) + + results <- jaspTools:::processJsonResults('{"status":"complete","results":{}}') + + expect_equal(results$state, state) +}) + +test_that("rbridge globals are restored after temporary injection", { + env <- new.env(parent = emptyenv()) + original <- function() "original" + env$.baseCitation <- original + + state <- jaspTools:::.snapshotRbridgeEnv(env) + jaspTools:::.insertRbridgeIntoEnv(env) + expect_identical(env$.baseCitation, jaspTools:::.baseCitation) + + restored <- jaspTools:::.restoreRbridgeEnv(env, state) + + expect_true(restored) + expect_identical(env$.baseCitation, original) + + emptyEnv <- new.env(parent = emptyenv()) + emptyState <- jaspTools:::.snapshotRbridgeEnv(emptyEnv) + jaspTools:::.insertRbridgeIntoEnv(emptyEnv) + jaspTools:::.restoreRbridgeEnv(emptyEnv, emptyState) + + expect_equal(ls(emptyEnv, all.names = TRUE), character(0)) +}) + +test_that("runAnalysis restores rbridge globals when the runner errors", { + restoreOption <- localJaspToolsOptions(list(jaspTools.runAnalysis.subprocess = FALSE)) + originalBaseCitation <- function() "original" + restoreGlobal <- localGlobalSymbol(".baseCitation", originalBaseCitation) + + runner <- function(...) { + stop("runner failed", call. = FALSE) + } + args <- list( + moduleName = "jaspFake", + analysisName = "FakeAnalysis", + qmlFileName = "FakeAnalysis.qml", + qmlFile = "C:/fake/module/inst/qml/FakeAnalysis.qml", + modulePath = "C:/fake/module", + options = list(flag = TRUE), + version = "1.0.0", + preloadData = FALSE + ) + attr(args, "runner") <- runner + attr(args, "modulePath") <- "C:/fake/module" + + restoreFetch <- localJaspToolsBinding("fetchRunArgs", function(...) args) + restoreInit <- localJaspToolsBinding("initAnalysisRuntime", function(...) { + jaspTools:::.insertRbridgeIntoEnv(.GlobalEnv) + }) + restoreReset <- localJaspToolsBinding(".resetRunTimeInternals", function() invisible(NULL)) + + on.exit(restoreOption(), add = TRUE) + on.exit(restoreGlobal(), add = TRUE) + on.exit(restoreFetch(), add = TRUE) + on.exit(restoreInit(), add = TRUE) + on.exit(restoreReset(), add = TRUE) + + expect_error( + jaspTools::runAnalysis( + "FakeAnalysis", + data.frame(), + list(flag = TRUE), + view = FALSE, + modulePath = "C:/fake/module" + ), + "runner failed", + fixed = TRUE + ) + expect_identical(get(".baseCitation", envir = .GlobalEnv), originalBaseCitation) +}) + +test_that("rbridge namespace contract is limited to local runtime objects", { + expected <- c( + ".baseCitation", + ".ppi", + ".requestTempFileNameNative", + ".requestTempRootNameNative", + ".requestStateFileNameNative", + ".imageBackground" + ) + + expect_setequal(jaspTools:::.rbridgeNativeSymbols(), expected) + + removedPlaceholders <- c( + ".automaticColumnEncDecoding", + ".encodeColNamesStrict", + ".decodeColNamesStrict", + ".encodeColNamesLax", + ".decodeColNamesLax", + ".decodeColTypes", + ".setColumnDataAsScale", + ".setColumnDataAsOrdinal", + ".setColumnDataAsNominal", + ".setColumnDataAsNominalText", + ".allColumnNamesDataset", + ".readDatasetToEndNative", + ".readDataSetHeaderNative", + ".readDataSetRequestedNative" + ) + + expect_false(any(removedPlaceholders %in% jaspTools:::.rbridgeNativeSymbols())) + + ns <- asNamespace("jaspTools") + for (symbol in expected) { + expect_true(exists(symbol, envir = ns, inherits = FALSE), info = symbol) + expect_true(length(utils::getAnywhere(symbol)$objs) > 0L, info = symbol) + } + + for (symbol in c(".readDatasetToEndNative", ".readDataSetHeaderNative", ".readDataSetRequestedNative")) + expect_false(exists(symbol, envir = ns, inherits = FALSE), info = symbol) +}) From e46428643974b1e510e8a09cf7e0ca9df8d46719 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Thu, 14 May 2026 15:05:39 +0200 Subject: [PATCH 2/9] Simplify jaspTools bridge subprocess handling --- DESCRIPTION | 1 + R/options.R | 54 +---- R/run.R | 39 +--- R/subprocess.R | 245 ++++++++++++--------- R/testthat-helper-tables.R | 22 +- man/runAnalysis.Rd | 4 +- tests/testthat/test-analysisOptions.R | 45 ---- tests/testthat/test-expect-equal-tables.R | 24 +- tests/testthat/test-jaspSyntax-lifecycle.R | 53 ++--- 9 files changed, 178 insertions(+), 309 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index bf254ac..a6711b0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -12,6 +12,7 @@ License: GNU General Public License Encoding: UTF-8 LazyData: true Imports: + callr, cli, data.table, httr, diff --git a/R/options.R b/R/options.R index dbd6760..a2b84a4 100644 --- a/R/options.R +++ b/R/options.R @@ -101,10 +101,6 @@ analysisOptions <- function(source, modulePath = NULL) { } analysisOptionsFromQMLFile <- function(analysis, modulePath = NULL) { - if (analysisOptionsShouldUseSubprocess()) { - return(analysisOptionsFromQMLFileSubprocess(analysis, modulePath = modulePath)) - } - modulePath <- .modulePathForAnalysisName(analysis, modulePath) options <- jaspSyntax::readDefaultAnalysisOptions( modulePath = modulePath, @@ -119,41 +115,6 @@ analysisOptionsFromQMLFile <- function(analysis, modulePath = NULL) { return(options) } -analysisOptionsShouldUseSubprocess <- function() { - isTRUE(getOption("jaspTools.analysisOptions.subprocess", TRUE)) && - !identical(Sys.getenv("JASPTOOLS_ANALYSIS_OPTIONS_CHILD"), "true") -} - -analysisOptionsFromQMLFileSubprocess <- function(analysis, modulePath = NULL) { - payload <- .jaspToolsSubprocessPayload( - extra = list(analysis = analysis, modulePath = modulePath), - env = .jaspToolsSubprocessEnv("JASPTOOLS_ANALYSIS_OPTIONS_CHILD") - ) - - result <- .jaspToolsRunSubprocess( - prefix = "jaspTools-analysisOptions-", - payload = payload, - scriptLines = analysisOptionsSubprocessScript(), - failureMessage = "`analysisOptions()` subprocess failed before returning options", - isError = function(result) inherits(result, "jaspTools.subprocessError") - ) - - .stopIfJaspToolsSubprocessError(result) - result -} - -analysisOptionsSubprocessScript <- function() { - .jaspToolsSubprocessScript( - resultLines = c( - "result <- tryCatch(", - " jaspTools:::analysisOptionsFromQMLFile(payload$analysis, modulePath = payload$modulePath),", - " error = .jaspToolsSubprocessError", - ")" - ), - saveLines = "saveRDS(result, args[[2L]])" - ) -} - .looksLikeMissingFilePath <- function(source) { hasPathSeparator <- grepl("[/\\\\]", source) hasDrivePrefix <- grepl("^[A-Za-z]:", source) @@ -287,17 +248,18 @@ analysisRuntimeOptions <- function(file, modulePath = NULL) { modulePath, expectedNames = expectedNames, context = paste0( - "analysis `", record[["name"]] %||% "", - "` in module `", record[["moduleName"]] %||% "", "`" + "analysis `", .recordLabel(record, "name"), + "` in module `", .recordLabel(record, "moduleName"), "`" ) ) } -`%||%` <- function(x, y) { - if (is.null(x) || length(x) == 0L || is.na(x[[1L]]) || !nzchar(x[[1L]])) - return(y) +.recordLabel <- function(record, field) { + value <- record[[field]] + if (is.null(value) || length(value) == 0L || is.na(value[[1L]]) || !nzchar(value[[1L]])) + return("") - as.character(x[[1L]]) + as.character(value[[1L]]) } .normalizeSingleModulePath <- function(modulePath, expectedNames = character(0), @@ -308,7 +270,7 @@ analysisRuntimeOptions <- function(file, modulePath = NULL) { matchIndex <- match(expectedNames, pathNames, nomatch = 0L) matchIndex <- matchIndex[matchIndex > 0L] if (length(matchIndex) > 0L) - return(.normalizeModulePathValue(modulePath, matchIndex[[1L]])) + return(.normalizeModulePathValue(modulePath, matchIndex[[1L]])) usableNames <- pathNames[!is.na(pathNames) & nzchar(pathNames)] stop( diff --git a/R/run.R b/R/run.R index 96cea83..2ef07be 100644 --- a/R/run.R +++ b/R/run.R @@ -19,8 +19,8 @@ #' \code{analysisOptions}). #' @param view Boolean indicating whether to view the results in a webbrowser. #' @param quiet Boolean indicating whether to suppress messages from the -#' analysis and native QML bridge. Quiet runs are evaluated in a subprocess so -#' native Desktop logging does not clutter the calling R session. +#' analysis. Quiet runs are evaluated in a subprocess to contain native bridge +#' crashes and Desktop logging. #' @param makeTests Boolean indicating whether to create testthat unit tests and print them to the terminal. #' @param modulePath Optional path to the module checkout that should be used #' for QML resolution and wrapped execution. When omitted, jaspTools first @@ -185,25 +185,21 @@ runAnalysisInSubprocess <- function(name, dataset, options, view, quiet, ) subprocessResult <- .jaspToolsRunSubprocess( - prefix = "jaspTools-runAnalysis-", + task = "runAnalysis", payload = payload, - scriptLines = runAnalysisSubprocessScript(), - failureMessage = "`runAnalysis()` subprocess failed before returning a result", - launcher = launchRunAnalysisSubprocess, - readResult = function(path) suppressPackageStartupMessages(readRDS(path)), + failureMessage = "`runAnalysis()` subprocess failed", isError = function(result) { inherits(.runAnalysisSubprocessResult(result), "jaspTools.subprocessError") } ) + if (is.list(subprocessResult) && !is.null(subprocessResult$lastResults)) .setInternal("lastResults", subprocessResult$lastResults) restoreSubprocessHtmlFiles(subprocessResult$htmlFiles) result <- .runAnalysisSubprocessResult(subprocessResult) - replaySubprocessWarnings(subprocessResult$warnings) - .stopIfJaspToolsSubprocessError(result) viewRunAnalysisResults(result, view) @@ -221,10 +217,6 @@ runAnalysisInSubprocess <- function(name, dataset, options, view, quiet, subprocessResult } -launchRunAnalysisSubprocess <- function(scriptPath, inputPath, outputPath, logPath) { - .jaspToolsLaunchSubprocess(scriptPath, inputPath, outputPath, logPath) -} - viewRunAnalysisResults <- function(results, enabled) { if (!isTRUE(enabled)) return(invisible(NULL)) @@ -232,27 +224,6 @@ viewRunAnalysisResults <- function(results, enabled) { get("view", envir = asNamespace("jaspTools"), inherits = FALSE)(results) } -runAnalysisSubprocessScript <- function() { - .jaspToolsSubprocessScript( - beforeResultLines = "warnings <- character(0)", - resultLines = c( - "result <- tryCatch(", - " withCallingHandlers(", - " do.call(jaspTools::runAnalysis, payload$args),", - " warning = function(w) {", - " warnings <<- c(warnings, conditionMessage(w))", - " tryInvokeRestart('muffleWarning')", - " }", - " ),", - " error = .jaspToolsSubprocessError", - ")", - "lastResults <- tryCatch(jaspTools:::.getInternal('lastResults'), error = function(e) NULL)", - "htmlFiles <- tryCatch(jaspTools:::collectSubprocessHtmlFiles(), error = function(e) NULL)" - ), - saveLines = "saveRDS(list(result = result, lastResults = lastResults, htmlFiles = htmlFiles, warnings = unique(warnings)), args[[2L]])" - ) -} - replaySubprocessWarnings <- function(warnings) { if (!is.character(warnings) || length(warnings) == 0L) return(invisible(FALSE)) diff --git a/R/subprocess.R b/R/subprocess.R index abde4c6..1c21979 100644 --- a/R/subprocess.R +++ b/R/subprocess.R @@ -1,12 +1,3 @@ -.jaspToolsSubprocessEnv <- function(childFlag, inherited = character()) { - env <- if (length(inherited) > 0L) - as.list(Sys.getenv(inherited, unset = "")) - else - list() - env[[childFlag]] <- "true" - env -} - .jaspToolsSubprocessPayload <- function(extra = list(), env = list()) { payload <- list( wd = getwd(), @@ -17,9 +8,9 @@ env = env ) - if (length(extra) > 0L) { + if (length(extra) > 0L) payload[names(extra)] <- extra - } + payload } @@ -29,115 +20,140 @@ currentOptions[intersect(optionNames, names(currentOptions))] } -.jaspToolsRunSubprocess <- function(prefix, payload, scriptLines, - failureMessage, - launcher = .jaspToolsLaunchSubprocess, - readResult = readRDS, - isError = function(result) FALSE) { - scriptPath <- tempfile(prefix, fileext = ".R") - inputPath <- tempfile(prefix, fileext = ".rds") - outputPath <- tempfile(prefix, fileext = ".rds") - logPath <- tempfile(prefix, fileext = ".log") - on.exit(unlink(c(scriptPath, inputPath, outputPath), force = TRUE), add = TRUE) - - saveRDS(payload, inputPath) - writeLines(scriptLines, scriptPath) +.jaspToolsSubprocessEnv <- function(childFlag, inherited = character()) { + env <- if (length(inherited) > 0L) + as.list(Sys.getenv(inherited, unset = "")) + else + list() + env[[childFlag]] <- "true" + env +} - status <- launcher(scriptPath, inputPath, outputPath, logPath) - if (!file.exists(outputPath)) { - stop( - failureMessage, - if (!is.null(status)) paste0(" (exit status ", status, ")") else "", - ". Log: ", logPath, - .jaspToolsSubprocessLogTail(logPath) - ) - } +.jaspToolsRunSubprocess <- function(task, payload, failureMessage, + isError = function(result) FALSE) { + logPath <- tempfile(paste0("jaspTools-", task, "-"), fileext = ".log") + result <- tryCatch( + callr::r( + func = function(task, payload) { + .libPaths(payload$libPaths) + sourcePath <- payload$sourcePath + if (!is.null(sourcePath) && is.character(sourcePath) && length(sourcePath) == 1L && + file.exists(file.path(sourcePath, "R", "run.R"))) { + if (!requireNamespace("pkgload", quietly = TRUE)) + stop("pkgload is required to run jaspTools child processes from a source checkout", call. = FALSE) + + pkgload::load_all(sourcePath, quiet = TRUE) + } else { + suppressPackageStartupMessages(library(jaspTools)) + } + + jaspTools:::.jaspToolsSubprocessMain(task, payload) + }, + args = list(task = task, payload = payload), + libpath = payload$libPaths, + stdout = logPath, + stderr = logPath, + env = .jaspToolsNormalizeSubprocessEnv(payload$env), + cmdargs = c("--slave", "--no-save", "--no-restore"), + error = "error" + ), + error = function(e) { + structure(list(message = conditionMessage(e)), class = "jaspTools.subprocessError") + } + ) - result <- readResult(outputPath) - resultIsError <- isTRUE(isError(result)) - if (!is.null(status) && status != 0L && !resultIsError) { + resultIsError <- isTRUE(isError(result)) || inherits(result, "jaspTools.subprocessError") + if (resultIsError) { stop( failureMessage, - " (exit status ", status, "). Log: ", logPath, + ": ", + .jaspToolsSubprocessErrorMessage(result), + ". Log: ", + logPath, .jaspToolsSubprocessLogTail(logPath), call. = FALSE ) } - if (!resultIsError) { - unlink(logPath, force = TRUE) - } + unlink(logPath, force = TRUE) result } -.jaspToolsLaunchSubprocess <- function(scriptPath, inputPath, outputPath, logPath) { - rscript <- file.path(R.home("bin"), if (.Platform$OS.type == "windows") "Rscript.exe" else "Rscript") - system2( - rscript, - c(normalizePath(scriptPath, winslash = "/", mustWork = TRUE), - normalizePath(inputPath, winslash = "/", mustWork = TRUE), - normalizePath(outputPath, winslash = "/", mustWork = FALSE)), - stdout = logPath, - stderr = logPath +.jaspToolsNormalizeSubprocessEnv <- function(env) { + if (!is.list(env) || length(env) == 0L) + return(character(0)) + + values <- unlist(env, use.names = TRUE) + values[!is.na(names(values)) & nzchar(names(values))] +} + +.jaspToolsSubprocessMain <- function(task, payload) { + .jaspToolsRestoreForSubprocess(payload) + + switch( + task, + runAnalysis = .jaspToolsRunAnalysisSubprocess(payload$args), + stop("Unknown jaspTools subprocess task: ", task, call. = FALSE) ) } -.jaspToolsSubprocessLogTail <- function(logPath, n = 40L) { - if (!file.exists(logPath)) { - return("") +.jaspToolsRestoreForSubprocess <- function(payload) { + .libPaths(payload$libPaths) + setwd(payload$wd) + + if (is.list(payload$env) && length(payload$env) > 0L) + do.call(Sys.setenv, payload$env) + if (is.list(payload$rOptions) && length(payload$rOptions) > 0L) + do.call(options, payload$rOptions) + + .jaspToolsLoadForSubprocess(payload$sourcePath) + .jaspToolsRestorePkgOptionsForSubprocess(payload$pkgOptions) + invisible(NULL) +} + +.jaspToolsLoadForSubprocess <- function(sourcePath) { + if (!is.null(sourcePath) && is.character(sourcePath) && length(sourcePath) == 1L && + file.exists(file.path(sourcePath, "R", "run.R"))) { + if (!requireNamespace("pkgload", quietly = TRUE)) + stop("pkgload is required to run jaspTools child processes from a source checkout", call. = FALSE) + + pkgload::load_all(sourcePath, quiet = TRUE) + } else { + suppressPackageStartupMessages(library(jaspTools)) } +} - logTail <- paste(utils::tail(readLines(logPath, warn = FALSE), n), collapse = "\n") - if (nzchar(logTail)) paste0("\n", logTail) else "" +.jaspToolsRestorePkgOptionsForSubprocess <- function(pkgOptions) { + if (!is.list(pkgOptions) || length(pkgOptions) == 0L) + return(invisible(NULL)) + + pkgEnv <- get(".pkgenv", envir = asNamespace("jaspTools"), inherits = FALSE) + pkgEnv[["internal"]][["setupCompleteOverride"]] <- TRUE + pkgEnv[["pkgOptions"]][names(pkgOptions)] <- pkgOptions + get(".initOutputDirs", envir = asNamespace("jaspTools"), inherits = FALSE)() + invisible(NULL) } -.jaspToolsSubprocessScript <- function(resultLines, saveLines, - beforeResultLines = character(0), - statusExpression = "inherits(result, 'jaspTools.subprocessError')") { - c( - "args <- commandArgs(trailingOnly = TRUE)", - "payload <- readRDS(args[[1L]])", - ".libPaths(payload$libPaths)", - "setwd(payload$wd)", - ".jaspToolsSetEnvForChild <- function(env) {", - " if (is.list(env) && length(env) > 0L)", - " do.call(Sys.setenv, env)", - "}", - ".jaspToolsSetEnvForChild(payload$env)", - ".jaspToolsRestoreROptionsForChild <- function(rOptions) {", - " if (is.list(rOptions) && length(rOptions) > 0L)", - " do.call(options, rOptions)", - " invisible(NULL)", - "}", - ".jaspToolsRestoreROptionsForChild(payload$rOptions)", - ".loadJaspToolsForChild <- function(sourcePath) {", - " if (!is.null(sourcePath) && is.character(sourcePath) && length(sourcePath) == 1L &&", - " file.exists(file.path(sourcePath, 'R', 'run.R'))) {", - " if (!requireNamespace('pkgload', quietly = TRUE))", - " stop('pkgload is required to run jaspTools child processes from a source checkout')", - " pkgload::load_all(sourcePath, quiet = TRUE)", - " } else {", - " suppressPackageStartupMessages(library(jaspTools))", - " }", - "}", - ".jaspToolsSubprocessError <- function(e) {", - " structure(list(message = conditionMessage(e)), class = 'jaspTools.subprocessError')", - "}", - ".loadJaspToolsForChild(payload$sourcePath)", - ".jaspToolsRestorePkgOptionsForChild <- function(pkgOptions) {", - " if (!is.list(pkgOptions) || length(pkgOptions) == 0L)", - " return(invisible(NULL))", - " pkgEnv <- get('.pkgenv', envir = asNamespace('jaspTools'), inherits = FALSE)", - " pkgEnv[['internal']][['setupCompleteOverride']] <- TRUE", - " pkgEnv[['pkgOptions']][names(pkgOptions)] <- pkgOptions", - " get('.initOutputDirs', envir = asNamespace('jaspTools'), inherits = FALSE)()", - " invisible(NULL)", - "}", - ".jaspToolsRestorePkgOptionsForChild(payload$pkgOptions)", - beforeResultLines, - resultLines, - saveLines, - paste0("quit(save = 'no', status = if (", statusExpression, ") 2L else 0L)") +.jaspToolsRunAnalysisSubprocess <- function(args) { + warnings <- character(0) + result <- tryCatch( + withCallingHandlers( + do.call(jaspTools::runAnalysis, args), + warning = function(w) { + warnings <<- c(warnings, conditionMessage(w)) + tryInvokeRestart("muffleWarning") + } + ), + error = function(e) { + structure(list(message = conditionMessage(e)), class = "jaspTools.subprocessError") + } + ) + + list( + result = result, + lastResults = tryCatch(jaspTools:::.getInternal("lastResults"), error = function(e) NULL), + htmlFiles = tryCatch(jaspTools:::collectSubprocessHtmlFiles(), error = function(e) NULL), + warnings = unique(warnings) ) } @@ -147,21 +163,34 @@ error = function(e) NULL ) - if (!is.character(namespacePath) || length(namespacePath) != 1L) { + if (!is.character(namespacePath) || length(namespacePath) != 1L) return(NULL) - } - - if (!file.exists(file.path(namespacePath, "R", "run.R"))) { + if (!file.exists(file.path(namespacePath, "R", "run.R"))) return(NULL) - } normalizePath(namespacePath, winslash = "/", mustWork = FALSE) } +.jaspToolsSubprocessErrorMessage <- function(result) { + if (is.list(result) && !is.null(result$message)) + return(result$message) + if (is.list(result) && inherits(result$result, "jaspTools.subprocessError")) + return(result$result$message) + + "subprocess failed before returning a result" +} + +.jaspToolsSubprocessLogTail <- function(logPath, n = 40L) { + if (!file.exists(logPath)) + return("") + + logTail <- paste(utils::tail(readLines(logPath, warn = FALSE), n), collapse = "\n") + if (nzchar(logTail)) paste0("\n", logTail) else "" +} + .stopIfJaspToolsSubprocessError <- function(result) { - if (inherits(result, "jaspTools.subprocessError")) { + if (inherits(result, "jaspTools.subprocessError")) stop(result$message, call. = FALSE) - } invisible(result) } diff --git a/R/testthat-helper-tables.R b/R/testthat-helper-tables.R index 2bc941a..8046f29 100644 --- a/R/testthat-helper-tables.R +++ b/R/testthat-helper-tables.R @@ -193,32 +193,12 @@ getMissingValuesDiffSizeTables <- function(test, ref, cellNames) { tableListToAnnotatedCharacterVector <- function(tableList, cellNames=NULL) { fullValues <- unlist(tableList) tableVec <- as.character(unlist(lapply(tableList, roundToPrecision))) - tableVec <- canonicalizeJaspColumnTokens(tableVec) - names(tableVec) <- canonicalizeJaspColumnTokens(as.character(fullValues)) + names(tableVec) <- as.character(fullValues) attr(tableVec, "cellNames") <- cellNames return(tableVec) } -canonicalizeJaspColumnTokens <- function(x) { - if (!is.character(x) || length(x) == 0L) - return(x) - - tokenPattern <- "(JaspColumn_[[:alnum:]_]+_Encoded|jaspColumn[0-9]+)" - tokens <- unlist(regmatches(x, gregexpr(tokenPattern, x, perl = TRUE)), use.names = FALSE) - tokens <- unique(tokens[nzchar(tokens)]) - - if (length(tokens) == 0L) - return(x) - - replacements <- stats::setNames(paste0(""), tokens) - for (token in tokens) { - x <- gsub(token, replacements[[token]], x, fixed = TRUE) - } - - x -} - tableValuesMatch <- function(refValue, testValue) { refValue <- unname(refValue) testValue <- unname(testValue) diff --git a/man/runAnalysis.Rd b/man/runAnalysis.Rd index 033e1ad..746f9ee 100644 --- a/man/runAnalysis.Rd +++ b/man/runAnalysis.Rd @@ -28,8 +28,8 @@ By default the directory in Resources is checked first, unless called within a t \item{view}{Boolean indicating whether to view the results in a webbrowser.} \item{quiet}{Boolean indicating whether to suppress messages from the -analysis and native QML bridge. Quiet runs are evaluated in a subprocess so -native Desktop logging does not clutter the calling R session.} +analysis. Quiet runs are evaluated in a subprocess to contain native bridge +crashes and Desktop logging.} \item{makeTests}{Boolean indicating whether to create testthat unit tests and print them to the terminal.} diff --git a/tests/testthat/test-analysisOptions.R b/tests/testthat/test-analysisOptions.R index f3dc350..ad4d2c5 100644 --- a/tests/testthat/test-analysisOptions.R +++ b/tests/testthat/test-analysisOptions.R @@ -67,9 +67,6 @@ test_that("analysisOptions preserves JSON options without native replay", { }) test_that("analysisOptions for analysis names requests editable unprepared defaults", { - restoreOption <- localJaspToolsOptions(list(jaspTools.analysisOptions.subprocess = FALSE)) - on.exit(restoreOption(), add = TRUE) - observed <- NULL restoreTools <- localJaspToolsBinding("getModulePathFromRFunction", function(analysis) { @@ -106,9 +103,6 @@ test_that("analysisOptions for analysis names requests editable unprepared defau }) test_that("analysisOptions for analysis names honors explicit modulePath", { - restoreOption <- localJaspToolsOptions(list(jaspTools.analysisOptions.subprocess = FALSE)) - on.exit(restoreOption(), add = TRUE) - observed <- NULL restoreTools <- localJaspToolsBinding("getModulePathFromRFunction", function(analysis) { @@ -133,9 +127,6 @@ test_that("analysisOptions for analysis names honors explicit modulePath", { }) test_that("analysisOptions for analysis names accepts module-name keyed modulePath", { - restoreOption <- localJaspToolsOptions(list(jaspTools.analysisOptions.subprocess = FALSE)) - on.exit(restoreOption(), add = TRUE) - observed <- NULL restoreTools <- localJaspToolsBinding("getModulePathFromRFunction", function(analysis) { @@ -172,42 +163,6 @@ test_that("analysisOptions for analysis names accepts module-name keyed modulePa expect_equal(attr(opts, "modulePath"), "C:/fake/module") }) -test_that("analysisOptions subprocess delegates shared child scaffold", { - observed <- NULL - expected <- list(variable = "x") - - restore <- localJaspToolsBinding(".jaspToolsRunSubprocess", function(prefix, payload, scriptLines, - failureMessage, isError, ...) { - observed <<- list( - prefix = prefix, - payload = payload, - scriptLines = scriptLines, - failureMessage = failureMessage, - isError = isError - ) - expected - }) - on.exit(restore(), add = TRUE) - - result <- jaspTools:::analysisOptionsFromQMLFileSubprocess( - "FakeAnalysis", - modulePath = "C:/fake/module" - ) - - expect_identical(result, expected) - expect_equal(observed$prefix, "jaspTools-analysisOptions-") - expect_equal(observed$payload$analysis, "FakeAnalysis") - expect_equal(observed$payload$modulePath, "C:/fake/module") - expect_identical(observed$payload$env$JASPTOOLS_ANALYSIS_OPTIONS_CHILD, "true") - expect_match(observed$failureMessage, "analysisOptions", fixed = TRUE) - expect_false(observed$isError(expected)) - expect_true(any(grepl("pkgload::load_all", observed$scriptLines, fixed = TRUE))) - expect_true(any(grepl(".jaspToolsRestoreROptionsForChild", observed$scriptLines, fixed = TRUE))) - expect_true(any(grepl(".jaspToolsRestorePkgOptionsForChild", observed$scriptLines, fixed = TRUE))) - expect_true(any(grepl(".initOutputDirs", observed$scriptLines, fixed = TRUE))) - expect_true(any(grepl(".jaspToolsSubprocessError", observed$scriptLines, fixed = TRUE))) -}) - test_that("analysisOptions forwards modulePath for .jasp sources", { jaspFile <- tempfile(fileext = ".jasp") file.create(jaspFile) diff --git a/tests/testthat/test-expect-equal-tables.R b/tests/testthat/test-expect-equal-tables.R index 563feca..33b9ec8 100644 --- a/tests/testthat/test-expect-equal-tables.R +++ b/tests/testthat/test-expect-equal-tables.R @@ -1,20 +1,20 @@ context("expect_equal_tables") -test_that("expect_equal_tables accepts equivalent native and legacy encoded columns", { +test_that("expect_equal_tables compares table strings literally", { table <- list( - list(effect = "JaspColumn_18_Encoded", p = 0.1), - list(effect = "JaspColumn_5_EncodedJaspColumn_26_Encoded", p = 0.2) + list(effect = "Sleep", p = 0.1), + list(effect = "Chronotype", p = 0.2) ) ref <- list( - "jaspColumn4", 0.1, - "jaspColumn2jaspColumn3", 0.2 + "Sleep", 0.1, + "Chronotype", 0.2 ) expect_silent(jaspTools::expect_equal_tables(table, ref)) }) -test_that("legacy jaspColumn placeholders are not arbitrary text wildcards", { +test_that("expect_equal_tables does not treat encoded names as wildcards", { table <- list( list(effect = "Sleep", p = 0.1), list(effect = "Chronotype", p = 0.2) @@ -26,16 +26,4 @@ test_that("legacy jaspColumn placeholders are not arbitrary text wildcards", { ) expect_error(jaspTools::expect_equal_tables(table, ref), "not equal") - expect_false(jaspTools:::tableValuesMatch("", "Sleep")) - expect_false(jaspTools:::tableValuesMatch("", "")) - expect_true(jaspTools:::tableValuesMatch("", "")) -}) - -test_that("native and legacy column tokens canonicalize without touching ordinary text", { - x <- c("JaspColumn_18_Encoded", "jaspColumn4", "Sleep") - - expect_equal( - jaspTools:::canonicalizeJaspColumnTokens(x), - c("", "", "Sleep") - ) }) diff --git a/tests/testthat/test-jaspSyntax-lifecycle.R b/tests/testthat/test-jaspSyntax-lifecycle.R index cd1c2b7..f8f5cc7 100644 --- a/tests/testthat/test-jaspSyntax-lifecycle.R +++ b/tests/testthat/test-jaspSyntax-lifecycle.R @@ -682,20 +682,6 @@ test_that("subprocess payload carries selected R options", { expect_identical(payload$rOptions$jaspLegacyRngKind, FALSE) }) -test_that("subprocess runner captures warnings without child quiet suppression", { - script <- jaspTools:::runAnalysisSubprocessScript() - - expect_true(any(grepl("pkgload::load_all", script, fixed = TRUE))) - expect_true(any(grepl(".jaspToolsRestoreROptionsForChild", script, fixed = TRUE))) - expect_true(any(grepl(".jaspToolsRestorePkgOptionsForChild", script, fixed = TRUE))) - expect_true(any(grepl("setupCompleteOverride", script, fixed = TRUE))) - expect_true(any(grepl(".initOutputDirs", script, fixed = TRUE))) - expect_true(any(grepl(".jaspToolsSubprocessError", script, fixed = TRUE))) - expect_true(any(grepl("withCallingHandlers", script, fixed = TRUE))) - expect_true(any(grepl("warnings <<- c\\(warnings, conditionMessage\\(w\\)\\)", script))) - expect_true(any(grepl("warnings = unique\\(warnings\\)", script))) -}) - test_that("runAnalysis sends processed results to the viewer", { rawJson <- '{"status":"complete","results":{"table":{"data":[{"name":"JaspColumn_1_Encoded"}]}}}' processed <- list( @@ -754,24 +740,20 @@ test_that("subprocess runAnalysis parent views returned processed results", { results = list(table = list(data = list(list(name = "decoded name")))) ) viewed <- NULL + observedPayload <- NULL restore <- localJaspToolsBindings( - launchRunAnalysisSubprocess = function(scriptPath, inputPath, outputPath, logPath) { - payload <- readRDS(inputPath) - expect_false(payload$args$view) - expect_false(payload$args$makeTests) - expect_identical(payload$env$JASPTOOLS_RUNANALYSIS_CHILD, "true") - expect_true(all(c("NOT_CRAN", "LANG", "LANGUAGE") %in% names(payload$env))) - saveRDS( - list( - result = processed, - lastResults = rawJson, - htmlFiles = list(files = list()), - warnings = character(0) - ), - outputPath + .jaspToolsRunSubprocess = function(task, payload, failureMessage, isError) { + observedPayload <<- payload + expect_equal(task, "runAnalysis") + expect_match(failureMessage, "runAnalysis", fixed = TRUE) + expect_false(isError(list(result = processed))) + list( + result = processed, + lastResults = rawJson, + htmlFiles = list(files = list()), + warnings = character(0) ) - 0L }, view = function(results) { viewed <<- results @@ -789,6 +771,10 @@ test_that("subprocess runAnalysis parent views returned processed results", { makeTests = FALSE ) + expect_false(observedPayload$args$view) + expect_false(observedPayload$args$makeTests) + expect_identical(observedPayload$env$JASPTOOLS_RUNANALYSIS_CHILD, "true") + expect_true(all(c("NOT_CRAN", "LANG", "LANGUAGE") %in% names(observedPayload$env))) expect_identical(result, processed) expect_identical(viewed, processed) expect_identical(jaspTools:::.getInternal("lastResults"), rawJson) @@ -852,9 +838,6 @@ test_that("run argument construction rejects analysis and module metadata mismat }) test_that("runAnalysis rejects prepared runtime options", { - restoreOption <- localJaspToolsOptions(list(jaspTools.runAnalysis.subprocess = FALSE)) - on.exit(restoreOption(), add = TRUE) - observed <- list(initCalled = FALSE, fetchCalled = FALSE) restore <- localJaspToolsBindings( @@ -884,7 +867,7 @@ test_that("runAnalysis rejects prepared runtime options", { test_that("real saved .jasp options replay once through runAnalysis with extracted data", { testthat::skip_if_not( identical(Sys.getenv("JASPTOOLS_RUN_REAL_DESCRIPTIVES"), "true"), - "set JASPTOOLS_RUN_REAL_DESCRIPTIVES=true to run local jaspDescriptives subprocess integration tests" + "set JASPTOOLS_RUN_REAL_DESCRIPTIVES=true to run local jaspDescriptives native integration tests" ) jaspFile <- file.path(testthat::test_path(), "..", "JASPFiles", "debug-descriptives.jasp") testthat::skip_if_not(file.exists(jaspFile), "debug descriptives .jasp fixture is unavailable") @@ -951,7 +934,7 @@ test_that("real saved .jasp options replay once through runAnalysis with extract test_that("real QML defaults can be edited and replayed through QML once", { testthat::skip_if_not( identical(Sys.getenv("JASPTOOLS_RUN_REAL_DESCRIPTIVES"), "true"), - "set JASPTOOLS_RUN_REAL_DESCRIPTIVES=true to run local jaspDescriptives subprocess integration tests" + "set JASPTOOLS_RUN_REAL_DESCRIPTIVES=true to run local jaspDescriptives native integration tests" ) jaspFile <- file.path(testthat::test_path(), "..", "JASPFiles", "debug-descriptives.jasp") testthat::skip_if_not(file.exists(jaspFile), "debug descriptives .jasp fixture is unavailable") @@ -1008,7 +991,7 @@ test_that("real QML defaults can be edited and replayed through QML once", { test_that("real runtime .jasp options are inspection-only", { testthat::skip_if_not( identical(Sys.getenv("JASPTOOLS_RUN_REAL_DESCRIPTIVES"), "true"), - "set JASPTOOLS_RUN_REAL_DESCRIPTIVES=true to run local jaspDescriptives subprocess integration tests" + "set JASPTOOLS_RUN_REAL_DESCRIPTIVES=true to run local jaspDescriptives native integration tests" ) jaspFile <- file.path(testthat::test_path(), "..", "JASPFiles", "debug-descriptives.jasp") testthat::skip_if_not(file.exists(jaspFile), "debug descriptives .jasp fixture is unavailable") From ef194f22a510571252e4be5659bd870c4fb1fc3e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Thu, 14 May 2026 22:40:54 +0200 Subject: [PATCH 3/9] Prune stale bridge compatibility code --- R/dataset.R | 52 ------------------- R/test-generator.R | 26 +++------- README.md | 2 +- man/generateExampleTestBlock.Rd | 6 +-- man/generateExampleTestBlockBasic.Rd | 6 +-- tests/testthat/test-generated-example-tests.R | 22 +------- tests/testthat/test-jaspSyntax-lifecycle.R | 25 --------- 7 files changed, 11 insertions(+), 128 deletions(-) diff --git a/R/dataset.R b/R/dataset.R index 96f84c5..fde4803 100644 --- a/R/dataset.R +++ b/R/dataset.R @@ -40,14 +40,6 @@ extractDatasetFromJASPFile <- function(jaspFile, dataSetIndex = 1L) { jaspSyntax::readDatasetFromJaspFile(jaspFile, dataSetIndex = dataSetIndex) } -.jaspSyntaxHelper <- function(names, required = TRUE, feature = "jaspSyntax bridge API") { - helperName <- .jaspSyntaxHelperName(names, required = required, feature = feature) - if (is.null(helperName)) - return(NULL) - - get(helperName, envir = asNamespace("jaspSyntax"), inherits = FALSE) -} - .jaspSyntaxHelperName <- function(names, required = TRUE, feature = "jaspSyntax bridge API") { namespace <- asNamespace("jaspSyntax") for (name in names) { @@ -132,15 +124,6 @@ extractDatasetFromJASPFile <- function(jaspFile, dataSetIndex = 1L) { invisible(NULL) } -.jaspSyntaxClearQmlForms <- function(required = FALSE) { - .jaspSyntaxCall( - c("clearQmlForms", "clearQmlFormCache"), - required = required, - feature = "native QML lifecycle API" - ) - invisible(NULL) -} - .jaspSyntaxLoadAnalysisDataset <- function(dataset, modulePath = NULL, analysisName = NULL, options = NULL) { @@ -259,41 +242,6 @@ preloadDataset <- function(datasetPathOrObject, options, modulePath = NULL, .validateJaspSyntaxDataset(dataset, "jaspSyntax::readRequestedDataset()", required) } -.jaspSyntaxReadDatasetHeader <- function(required = FALSE) { - dataset <- .jaspSyntaxCall( - "readDatasetHeader", - required = required, - feature = "native dataset header API" - ) - .validateJaspSyntaxDataset(dataset, "jaspSyntax::readDatasetHeader()", required) -} - -.jaspSyntaxDecodeColumnNames <- function(x, strict = FALSE, required = strict) { - if (!is.character(x) || length(x) == 0L) - return(x) - - decoded <- tryCatch( - .jaspSyntaxCall( - "decodeColumnNames", - args = list(columnNames = x, strict = strict), - required = required, - feature = "native column decoding API", - requiredArgs = c("columnNames", if (isTRUE(strict)) "strict" else character(0L)) - ), - error = function(e) { - if (isTRUE(required)) - stop(e) - - x - } - ) - - if (is.null(decoded)) - return(x) - - as.character(decoded) -} - .jaspSyntaxDatasetStateValue <- function(datasetState, name) { if (is.null(datasetState)) return(NULL) diff --git a/R/test-generator.R b/R/test-generator.R index f9a7d19..fd0a45f 100644 --- a/R/test-generator.R +++ b/R/test-generator.R @@ -106,8 +106,7 @@ makeTestsFromExamples <- function(path, module.dir, source, sanitize = FALSE, sanitize = sanitize, overwrite = overwrite, copyToJaspfiles = TRUE, - pkgAnalyses = pkgAnalyses, - forceEncode = forceEncode + pkgAnalyses = pkgAnalyses ) .printTestGenerationSummary(result$created, result$skipped, result$copied, "other") @@ -166,8 +165,7 @@ makeTestsFromExamples <- function(path, module.dir, source, sanitize = FALSE, sanitize = sanitize, overwrite = overwrite, copyToJaspfiles = FALSE, - pkgAnalyses = pkgAnalyses, - forceEncode = forceEncode + pkgAnalyses = pkgAnalyses ) createdFiles <- c(createdFiles, result$created) skippedFiles <- c(skippedFiles, result$skipped) @@ -257,8 +255,7 @@ readModuleAnalysisNames <- function(module.dir) { # collect created/skipped/copied paths, and report per-file progress. # Returns a list with components $created, $skipped, $copied. .processJaspFiles <- function(jaspFiles, module.dir, sourceFolder, sanitize, - overwrite, copyToJaspfiles, pkgAnalyses, - forceEncode) { + overwrite, copyToJaspfiles, pkgAnalyses) { createdFiles <- character(0) skippedFiles <- character(0) copiedFiles <- character(0) @@ -274,8 +271,7 @@ readModuleAnalysisNames <- function(module.dir) { sanitize = sanitize, overwrite = overwrite, copyToJaspfiles = copyToJaspfiles, - pkgAnalyses = pkgAnalyses, - forceEncode = forceEncode + pkgAnalyses = pkgAnalyses ) if (!is.null(result)) { if (!is.null(attr(result, "copiedTo"))) { @@ -504,15 +500,10 @@ generateExampleTestFileContent <- function(baseName, sanitizedName, sourceFolder #' @param sourceFolder String indicating the source folder: \code{"library"}, #' \code{"verified"}, or \code{"other"}. #' @param results The analysis results. -#' @param forceEncode Compatibility argument retained for older callers. Supplying -#' a non-`NULL` value now aborts. -#' #' @return Character string with the test_that block. #' @keywords internal generateExampleTestBlock <- function(analysisName, analysisIndex, totalAnalyses, jaspFileName, - sourceFolder, results, forceEncode = NULL) { - .rejectForceEncodeArgument(forceEncode) - + sourceFolder, results) { # Extract tests from results tests <- tryCatch( { @@ -589,15 +580,10 @@ generateExampleTestBlock <- function(analysisName, analysisIndex, totalAnalyses, #' @param jaspFileName Name of the JASP file. #' @param sourceFolder String indicating the source folder: \code{"library"}, #' \code{"verified"}, or \code{"other"}. -#' @param forceEncode Compatibility argument retained for older callers. Supplying -#' a non-`NULL` value now aborts. -#' #' @return Character string with the test_that block. #' @keywords internal generateExampleTestBlockBasic <- function(analysisName, analysisIndex, totalAnalyses, jaspFileName, - sourceFolder, forceEncode = NULL) { - .rejectForceEncodeArgument(forceEncode) - + sourceFolder) { lines <- character(0) testDesc <- .generatedExampleTestDescription( diff --git a/README.md b/README.md index a07e432..c8b22b7 100644 --- a/README.md +++ b/README.md @@ -157,4 +157,4 @@ To create unit tests you can read [this guide](https://github.com/jasp-stats/jas ## Known limitations: - Click actions in the browser are not supported (e.g., "save as") -- State is ignored +- Browser-only interactions are not replayed diff --git a/man/generateExampleTestBlock.Rd b/man/generateExampleTestBlock.Rd index 1bce209..bd63d50 100644 --- a/man/generateExampleTestBlock.Rd +++ b/man/generateExampleTestBlock.Rd @@ -10,8 +10,7 @@ generateExampleTestBlock( totalAnalyses, jaspFileName, sourceFolder, - results, - forceEncode = NULL + results ) } \arguments{ @@ -27,9 +26,6 @@ generateExampleTestBlock( \code{"verified"}, or \code{"other"}.} \item{results}{The analysis results.} - -\item{forceEncode}{Compatibility argument retained for older callers. Supplying -a non-\code{NULL} value now aborts.} } \value{ Character string with the test_that block. diff --git a/man/generateExampleTestBlockBasic.Rd b/man/generateExampleTestBlockBasic.Rd index e838b28..37599af 100644 --- a/man/generateExampleTestBlockBasic.Rd +++ b/man/generateExampleTestBlockBasic.Rd @@ -9,8 +9,7 @@ generateExampleTestBlockBasic( analysisIndex, totalAnalyses, jaspFileName, - sourceFolder, - forceEncode = NULL + sourceFolder ) } \arguments{ @@ -24,9 +23,6 @@ generateExampleTestBlockBasic( \item{sourceFolder}{String indicating the source folder: \code{"library"}, \code{"verified"}, or \code{"other"}.} - -\item{forceEncode}{Compatibility argument retained for older callers. Supplying -a non-\code{NULL} value now aborts.} } \value{ Character string with the test_that block. diff --git a/tests/testthat/test-generated-example-tests.R b/tests/testthat/test-generated-example-tests.R index e6db411..b3477f3 100644 --- a/tests/testthat/test-generated-example-tests.R +++ b/tests/testthat/test-generated-example-tests.R @@ -192,26 +192,8 @@ test_that("forceEncode transition argument fails loudly", { ) expect_error( - jaspTools:::generateExampleTestBlock( - "Analysis", - analysisIndex = 1L, - totalAnalyses = 1L, - jaspFileName = "analysis.jasp", - sourceFolder = "other", - results = list(results = list()), - forceEncode = "model" - ), - "no longer supported", - fixed = TRUE - ) - - expect_error( - jaspTools:::generateExampleTestBlockBasic( - "Analysis", - analysisIndex = 1L, - totalAnalyses = 1L, - jaspFileName = "analysis.jasp", - sourceFolder = "other", + jaspTools::makeTestsFromExamples( + module.dir = moduleDir, forceEncode = "model" ), "no longer supported", diff --git a/tests/testthat/test-jaspSyntax-lifecycle.R b/tests/testthat/test-jaspSyntax-lifecycle.R index f8f5cc7..d355755 100644 --- a/tests/testthat/test-jaspSyntax-lifecycle.R +++ b/tests/testthat/test-jaspSyntax-lifecycle.R @@ -471,31 +471,6 @@ test_that("analysis result decoding delegates plain results to jaspSyntax", { expect_equal(observed$requiredArgs, "results") }) -test_that("column decoding wrapper calls the current jaspSyntax API", { - observedArgs <- NULL - observedNames <- NULL - restore <- localJaspToolsBinding( - ".jaspSyntaxCall", - function(names, args = list(), required = TRUE, - feature = "jaspSyntax bridge API", - requiredArgs = names(args), - requiredArgGroups = list()) { - observedNames <<- names - observedArgs <<- args - c("decodedA", "decodedB") - } - ) - on.exit(restore(), add = TRUE) - - decoded <- jaspTools:::.jaspSyntaxDecodeColumnNames(c("encodedA", "encodedB"), strict = TRUE) - - expect_equal(decoded, c("decodedA", "decodedB")) - expect_equal(observedNames, "decodeColumnNames") - expect_equal(observedArgs$columnNames, c("encodedA", "encodedB")) - expect_null(observedArgs$x) - expect_true(observedArgs$strict) -}) - test_that("jaspSyntax bridge wrapper rejects missing required arguments", { oldLoadAnalysisDataset <- function(dataset) dataset From 4d3e3feacf01a0958d4ff97c269ad9db8274f602 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Fri, 15 May 2026 07:32:10 +0200 Subject: [PATCH 4/9] Align bridge setup and extraction tests --- .github/copilot-instructions.md | 54 +++++++++---------- R/pkg-setup.R | 16 +++--- R/subprocess.R | 1 - R/zzz.R | 2 +- man/setupJaspTools.Rd | 6 +-- .../test-extractDatasetFromJASPfile.R | 17 +++--- 6 files changed, 48 insertions(+), 48 deletions(-) diff --git a/.github/copilot-instructions.md b/.github/copilot-instructions.md index b14885c..ac97962 100644 --- a/.github/copilot-instructions.md +++ b/.github/copilot-instructions.md @@ -2,7 +2,7 @@ ## Project Overview -jaspTools is an R package that enables JASP developers to preview, debug, and test JASP analyses locally without rebuilding the entire JASP application. It replicates the JASP runtime environment in R, including RCPP bridges, data handling, and state management. +jaspTools is an R package that enables JASP developers to preview, debug, and test JASP analyses locally without rebuilding the entire JASP application. It orchestrates the local JASP runtime in R while delegating native QML, saved `.jasp`, dataset encoding, and result-decoding semantics to `jaspSyntax` and Desktop. ## Architecture @@ -16,10 +16,10 @@ jaspTools uses specialized environments for variable scoping: ### Analysis Execution Flow -1. **Setup**: `setupJaspTools()` fetches dependencies (jaspBase, jaspGraphs, datasets, HTML resources) and validates paths -2. **Options**: `analysisOptions()` parses QML files, JASP files, or JSON to generate option lists +1. **Setup**: `setupJaspTools()` fetches dependencies (jaspBase, jaspSyntax, jaspGraphs, datasets, HTML resources) and validates paths +2. **Options**: `analysisOptions()` reads QML defaults and saved `.jasp` options through `jaspSyntax`; JSON requests are parsed directly 3. **Runtime Init**: `initAnalysisRuntime()` in `R/run.R` sets up dataset, state, and global RCPP masks -4. **Execution**: `runAnalysis()` calls `jaspBase::runJaspResults()` with the analysis function +4. **Execution**: `runAnalysis()` resolves the module QML through `jaspSyntax`, then calls `jaspBase::runWrappedAnalysis()` / `runJaspResults()` 5. **Output**: Results are converted to JSON and optionally displayed via `view()` using JASP's HTML/JS/CSS **Critical**: S3 methods from `common.R` are temporarily exported to `.GlobalEnv` during analysis execution (see `Developers-note.md` "Handling of S3 methods"). @@ -70,28 +70,24 @@ options <- analysisOptions("path/to/analysis.jasp") # Returns list if multiple # For multi-analysis files, access by index: options[[1]], options[[2]], etc. ``` -### Encoding Options and Datasets +### Native Option and Dataset Semantics -For reproducible testing, use `encodeOptionsAndDataset()` to standardize variable names and types: +Do not reimplement option encoding, type coercion, QML parsing, or saved `.jasp` +dataset reconstruction in jaspTools. Those semantics belong to `jaspSyntax` and +Desktop. jaspTools should pass saved options and extracted datasets into the +bridge and let `jaspSyntax` return the runtime-ready dataset, column mapping, +and decoded results. ```r -# Encode options and dataset for reproducible testing -options <- analysisOptions("path/to/file.jasp") +savedOptions <- analysisOptions("path/to/file.jasp") dataset <- extractDatasetFromJASPFile("path/to/file.jasp") -encoded <- encodeOptionsAndDataset(options, dataset) -# encoded$options: Options with variables renamed to jaspColumn1, jaspColumn2, etc. -# encoded$dataset: Dataset with matching column names and proper type coercion -# encoded$encodingMap: Mapping from original names to encoded names - -# Run with encoded data (skip type detection) -runAnalysis("AnalysisName", encoded$dataset, encoded$options, encodedDataset = TRUE) +runAnalysis("AnalysisName", dataset, savedOptions) ``` -The encoding process: -1. Scans options for variables with `.types` metadata (e.g., `variables` and `variables.types`) -2. Creates unique variable-type pairs and maps them to `jaspColumn1`, `jaspColumn2`, etc. -3. Applies type coercion: `"nominal"` → factor, `"ordinal"` → ordered, `"scale"` → numeric +Use `analysisRuntimeOptions()` only for inspecting the backend-prepared option +shape. Do not feed those options back into `runAnalysis()`, because that would +prepare an already-prepared option payload a second time. ### Generating Tests from JASP Example Files @@ -122,9 +118,9 @@ makeTestsFromExamples(sanitize = TRUE) ``` **Source Folders**: JASP example files are stored in `tests/testthat/jaspfiles/{library,verified,other}/`. The `source` argument controls which folders to process: -- `"library"` — JASP files from the analysis library -- `"verified"` — Manually verified/curated test files -- `"other"` — Other/imported JASP files (default target for `path` imports) +- `"library"` - JASP files from the analysis library +- `"verified"` - Manually verified/curated test files +- `"other"` - Other/imported JASP files (default target for `path` imports) **Defaults**: When `overwrite = FALSE` (default), all three sources are processed. When `overwrite = TRUE`, only `"library"` and `"other"` are processed to protect verified tests. @@ -176,11 +172,15 @@ Analysis functions may have `Internal` suffixes. `findCorrectFunction()` searche ### QML Parsing -`readQML()` in `R/options-parser-qml.R` strips comments, whitespace, and newlines, then uses regex to extract QML form elements. Supports `IntegerField`, `CheckBox`, `DropDown`, `RadioButtonGroup`, etc. Static elements like `SetSeed` and `BayesFactorType` inject default options. +jaspTools does not parse QML directly. Use `jaspSyntax::readDefaultAnalysisOptions()`, +`jaspSyntax::readAnalysisOptionsFromJaspFile()`, and +`jaspSyntax::resolveAnalysisQml()` for native option semantics. ### State Management -**State is ignored** in jaspTools (noted in README limitations). State from JASP files is stored in `.internal` but not persisted between runs. Analyses should be stateless or handle missing state gracefully. +jaspTools keeps a standalone state file for `jaspBase` replay and decodes +returned plot state after analysis execution. Browser-only interactions are not +replayed. ## Common Pitfalls @@ -196,17 +196,17 @@ Analysis functions may have `Internal` suffixes. `findCorrectFunction()` searche - **jaspGraphs**: Plotting system for JASP-compatible graphics - **jaspResults**: Legacy state container (now merged into jaspBase) - **vdiffr**: Visual regression testing for plots -- **testthat**: Unit testing framework (requires ≥3.2.2) +- **testthat**: Unit testing framework (requires >=3.2.2) Check versions with `.checkUpdatesJaspCorePkgs()` on package load. ## File Organization -- `R/run.R`: Analysis execution, RCPP mask setup, JSON conversion. Supports `encodedDataset` parameter for pre-encoded data. +- `R/run.R`: Analysis execution, RCPP mask setup, native QML provenance, JSON conversion, state-file replay - `R/test.R`: Testing infrastructure, `testAnalysis()`, `testAll()` - `R/test-agent.R`: Agent-friendly test wrappers, `agentTestAll()`, `agentTestAnalysis()` - `R/options.R`: Option parsing from QML/JASP/JSON. Cross-platform path handling for `.jasp` files. -- `R/dataset.R`: Dataset loading, type conversion, `extractDatasetFromJASPFile()`, `encodeOptionsAndDataset()` +- `R/dataset.R`: Dataset loading orchestration and `jaspSyntax` bridge wrappers - `R/rbridge.R`: RCPP bridge replacements (`.readDatasetToEndNative`, `.requestTempFileNameNative`, etc.) - `R/pkg-setup.R`: Initial setup, dependency fetching - `R/utils.R`: Module path resolution, validation, helper functions diff --git a/R/pkg-setup.R b/R/pkg-setup.R index 50415f4..5569734 100644 --- a/R/pkg-setup.R +++ b/R/pkg-setup.R @@ -1,14 +1,14 @@ #' Setup the jaspTools package. #' #' Ensures that analyses can be run, tested and debugged locally by fetching all of the basic dependencies. -#' This includes fetching the data library and html files and installing jaspBase and jaspGraphs. +#' This includes fetching the data library and html files and installing jaspBase, jaspGraphs and jaspSyntax. #' If no parameters are supplied the function will interactively ask for the location of these dependencies. #' #' @param pathJaspDesktop (optional) Character path to the root of jasp-desktop if present on the system. #' @param installJaspModules (optional) Boolean. Should jaspTools install all the JASP analysis modules as R packages (e.g., jaspAnova, jaspFrequencies)? -#' @param installJaspCorePkgs (optional) Boolean. Should jaspTools install jaspBase, jaspResults and jaspGraphs? +#' @param installJaspCorePkgs (optional) Boolean. Should jaspTools install jaspBase, jaspSyntax, jaspResults and jaspGraphs? #' @param quiet (optional) Boolean. Should the installation of R packages produce output? -#' @param force (optional) Boolean. Should a fresh installation of jaspResults, jaspBase, jaspGraphs and the JASP analysis modules proceed if they are already installed on your system? This is ignored if installJaspCorePkgs = FALSE. +#' @param force (optional) Boolean. Should a fresh installation of jaspResults, jaspBase, jaspSyntax, jaspGraphs and the JASP analysis modules proceed if they are already installed on your system? This is ignored if installJaspCorePkgs = FALSE. #' #' @export setupJaspTools setupJaspTools <- function(pathJaspDesktop = NULL, installJaspModules = FALSE, installJaspCorePkgs = TRUE, quiet = FALSE, force = TRUE) { @@ -44,9 +44,9 @@ setupJaspTools <- function(pathJaspDesktop = NULL, installJaspModules = FALSE, i if (missing(installJaspCorePkgs)) { title <- if (jaspBaseIsLegacyVersion()) { - "- Would you like jaspTools to install jaspResults, jaspBase and jaspGraphs? If you opt no, you must install them yourself." + "- Would you like jaspTools to install jaspResults, jaspBase, jaspSyntax and jaspGraphs? If you opt no, you must install them yourself." } else { - "- Would you like jaspTools to install jaspBase and jaspGraphs? If you opt no, you must install them yourself." + "- Would you like jaspTools to install jaspBase, jaspSyntax and jaspGraphs? If you opt no, you must install them yourself." } wantsInstallJaspCorePkgs <- menu(c("Yes", "No"), title = title) if (wantsInstallJaspCorePkgs == 0) return(message("Setup aborted.")) @@ -75,14 +75,14 @@ setupJaspTools <- function(pathJaspDesktop = NULL, installJaspModules = FALSE, i If this problem persists clone jasp-stats/jasp-desktop manually.") if (on_ci() || on_github_actions()) { - message("Skipping installation of jaspBase and jaspGraphs on CI.\n") + message("Skipping installation of jaspBase, jaspSyntax and jaspGraphs on CI.\n") } else { if (isTRUE(installJaspCorePkgs)) { jaspCorePkgs <- if (jaspBaseIsLegacyVersion()) - c("jaspBase", "jaspGraphs", "jaspResults") + c("jaspBase", "jaspSyntax", "jaspGraphs", "jaspResults") else - c("jaspBase", "jaspGraphs") + c("jaspBase", "jaspSyntax", "jaspGraphs") installJaspPkg(jaspCorePkgs, quiet = quiet, force = force) } diff --git a/R/subprocess.R b/R/subprocess.R index 1c21979..1e4afa2 100644 --- a/R/subprocess.R +++ b/R/subprocess.R @@ -106,7 +106,6 @@ if (is.list(payload$rOptions) && length(payload$rOptions) > 0L) do.call(options, payload$rOptions) - .jaspToolsLoadForSubprocess(payload$sourcePath) .jaspToolsRestorePkgOptionsForSubprocess(payload$pkgOptions) invisible(NULL) } diff --git a/R/zzz.R b/R/zzz.R index 689ed8b..9c7bab6 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -50,7 +50,7 @@ .checkUpdatesJaspCorePkgs <- function() { hasUpdates <- NULL - corePkgs <- c("jaspGraphs", "jaspBase", "jaspTools") + corePkgs <- c("jaspGraphs", "jaspBase", "jaspSyntax", "jaspTools") for (pkg in corePkgs) { suppressWarnings(try(silent = TRUE, { localVer <- packageVersion(pkg) diff --git a/man/setupJaspTools.Rd b/man/setupJaspTools.Rd index e6b92e7..8ccb409 100644 --- a/man/setupJaspTools.Rd +++ b/man/setupJaspTools.Rd @@ -17,14 +17,14 @@ setupJaspTools( \item{installJaspModules}{(optional) Boolean. Should jaspTools install all the JASP analysis modules as R packages (e.g., jaspAnova, jaspFrequencies)?} -\item{installJaspCorePkgs}{(optional) Boolean. Should jaspTools install jaspBase, jaspResults and jaspGraphs?} +\item{installJaspCorePkgs}{(optional) Boolean. Should jaspTools install jaspBase, jaspSyntax, jaspResults and jaspGraphs?} \item{quiet}{(optional) Boolean. Should the installation of R packages produce output?} -\item{force}{(optional) Boolean. Should a fresh installation of jaspResults, jaspBase, jaspGraphs and the JASP analysis modules proceed if they are already installed on your system? This is ignored if installJaspCorePkgs = FALSE.} +\item{force}{(optional) Boolean. Should a fresh installation of jaspResults, jaspBase, jaspSyntax, jaspGraphs and the JASP analysis modules proceed if they are already installed on your system? This is ignored if installJaspCorePkgs = FALSE.} } \description{ Ensures that analyses can be run, tested and debugged locally by fetching all of the basic dependencies. -This includes fetching the data library and html files and installing jaspBase and jaspGraphs. +This includes fetching the data library and html files and installing jaspBase, jaspGraphs and jaspSyntax. If no parameters are supplied the function will interactively ask for the location of these dependencies. } diff --git a/tests/testthat/test-extractDatasetFromJASPfile.R b/tests/testthat/test-extractDatasetFromJASPfile.R index 7aeb457..964e4ff 100644 --- a/tests/testthat/test-extractDatasetFromJASPfile.R +++ b/tests/testthat/test-extractDatasetFromJASPfile.R @@ -73,15 +73,16 @@ test_that("extractDatasetFromJASPFile handles binary columns correctly", { df <- extractDatasetFromJASPFile(jaspFile) csv <- read.csv(csvFile, stringsAsFactors = FALSE, check.names = FALSE) - # Binary columns like contBinom should have correct 0/1 values - expect_equal(sort(unique(na.omit(df[["contBinom"]]))), c(0L, 1L), + # jaspSyntax owns JASP's saved-dataset reconstruction. Binary nominal values + # are returned as labels rather than coerced by jaspTools. + expect_equal(sort(unique(na.omit(df[["contBinom"]]))), c("0", "1"), info = "contBinom should have values 0 and 1") - expect_equal(df[["contBinom"]], csv[["contBinom"]], + expect_equal(df[["contBinom"]], as.character(csv[["contBinom"]]), info = "contBinom values should match CSV") - expect_equal(sort(unique(na.omit(df[["debBinMiss20"]]))), c(0L, 1L), + expect_equal(sort(unique(na.omit(df[["debBinMiss20"]]))), c("0", "1"), info = "debBinMiss20 should have values 0 and 1 (with NAs)") - expect_equal(df[["debBinMiss20"]], csv[["debBinMiss20"]], + expect_equal(df[["debBinMiss20"]], as.character(csv[["debBinMiss20"]]), info = "debBinMiss20 values should match CSV") }) @@ -156,10 +157,10 @@ test_that("extractDatasetFromJASPFile handles ordinal columns correctly", { df <- extractDatasetFromJASPFile(jaspFile) csv <- read.csv(csvFile, stringsAsFactors = FALSE, check.names = FALSE) - # facFive is ordinal with values 1-5 - expect_equal(sort(unique(df[["facFive"]])), 1:5, + # Ordinal labels are returned by jaspSyntax without jaspTools-side coercion. + expect_equal(sort(unique(df[["facFive"]])), as.character(1:5), info = "facFive should have values 1-5") - expect_equal(df[["facFive"]], csv[["facFive"]], + expect_equal(df[["facFive"]], as.character(csv[["facFive"]]), info = "facFive values should match CSV") }) From 039104ed08890860da99b60b1d3af0f7a439b16c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Fri, 15 May 2026 09:22:59 +0200 Subject: [PATCH 5/9] Remove machine-specific bridge test paths --- R/subprocess.R | 12 ------ .../fixtures/minimalModule/DESCRIPTION | 9 +++++ .../testthat/fixtures/minimalModule/NAMESPACE | 1 + .../minimalModule/inst/Description.qml | 18 +++++++++ .../minimalModule/inst/icons/.gitkeep | 1 + .../inst/qml/MinimalAnalysis.qml | 39 +++++++++++++++++++ tests/testthat/test-jaspSyntax-lifecycle.R | 35 +++++++++++++---- 7 files changed, 95 insertions(+), 20 deletions(-) create mode 100644 tests/testthat/fixtures/minimalModule/DESCRIPTION create mode 100644 tests/testthat/fixtures/minimalModule/NAMESPACE create mode 100644 tests/testthat/fixtures/minimalModule/inst/Description.qml create mode 100644 tests/testthat/fixtures/minimalModule/inst/icons/.gitkeep create mode 100644 tests/testthat/fixtures/minimalModule/inst/qml/MinimalAnalysis.qml diff --git a/R/subprocess.R b/R/subprocess.R index 1e4afa2..ee06a17 100644 --- a/R/subprocess.R +++ b/R/subprocess.R @@ -110,18 +110,6 @@ invisible(NULL) } -.jaspToolsLoadForSubprocess <- function(sourcePath) { - if (!is.null(sourcePath) && is.character(sourcePath) && length(sourcePath) == 1L && - file.exists(file.path(sourcePath, "R", "run.R"))) { - if (!requireNamespace("pkgload", quietly = TRUE)) - stop("pkgload is required to run jaspTools child processes from a source checkout", call. = FALSE) - - pkgload::load_all(sourcePath, quiet = TRUE) - } else { - suppressPackageStartupMessages(library(jaspTools)) - } -} - .jaspToolsRestorePkgOptionsForSubprocess <- function(pkgOptions) { if (!is.list(pkgOptions) || length(pkgOptions) == 0L) return(invisible(NULL)) diff --git a/tests/testthat/fixtures/minimalModule/DESCRIPTION b/tests/testthat/fixtures/minimalModule/DESCRIPTION new file mode 100644 index 0000000..96394fe --- /dev/null +++ b/tests/testthat/fixtures/minimalModule/DESCRIPTION @@ -0,0 +1,9 @@ +Package: jaspToolsTestModule +Type: Package +Title: jaspTools Syntax Test Module +Version: 0.1.0 +Author: JASP Team +Maintainer: JASP Team +Description: Minimal module fixture for jaspTools bridge tests. +License: GPL (>= 2) +Encoding: UTF-8 diff --git a/tests/testthat/fixtures/minimalModule/NAMESPACE b/tests/testthat/fixtures/minimalModule/NAMESPACE new file mode 100644 index 0000000..07b25ec --- /dev/null +++ b/tests/testthat/fixtures/minimalModule/NAMESPACE @@ -0,0 +1 @@ +export(MinimalAnalysis) diff --git a/tests/testthat/fixtures/minimalModule/inst/Description.qml b/tests/testthat/fixtures/minimalModule/inst/Description.qml new file mode 100644 index 0000000..cc1d5bc --- /dev/null +++ b/tests/testthat/fixtures/minimalModule/inst/Description.qml @@ -0,0 +1,18 @@ +import QtQuick +import JASP.Module + +Description +{ + title: qsTr("jaspTools Syntax Test Module") + description: qsTr("Minimal module fixture for jaspTools bridge tests.") + preloadData: true + hasWrappers: true + + Analysis + { + title: qsTr("Minimal Analysis") + func: "MinimalAnalysis" + qml: "MinimalAnalysis.qml" + preloadData: false + } +} diff --git a/tests/testthat/fixtures/minimalModule/inst/icons/.gitkeep b/tests/testthat/fixtures/minimalModule/inst/icons/.gitkeep new file mode 100644 index 0000000..8b13789 --- /dev/null +++ b/tests/testthat/fixtures/minimalModule/inst/icons/.gitkeep @@ -0,0 +1 @@ + diff --git a/tests/testthat/fixtures/minimalModule/inst/qml/MinimalAnalysis.qml b/tests/testthat/fixtures/minimalModule/inst/qml/MinimalAnalysis.qml new file mode 100644 index 0000000..b0d5cfc --- /dev/null +++ b/tests/testthat/fixtures/minimalModule/inst/qml/MinimalAnalysis.qml @@ -0,0 +1,39 @@ +import QtQuick +import JASP +import JASP.Controls + +Form +{ + CheckBox + { + name: "flag" + label: qsTr("Flag") + checked: true + } + + DoubleField + { + name: "threshold" + label: qsTr("Threshold") + defaultValue: 1.5 + } + + RadioButtonGroup + { + name: "choice" + title: qsTr("Choice") + + RadioButton + { + value: "one" + label: qsTr("One") + } + + RadioButton + { + value: "two" + label: qsTr("Two") + checked: true + } + } +} diff --git a/tests/testthat/test-jaspSyntax-lifecycle.R b/tests/testthat/test-jaspSyntax-lifecycle.R index d355755..772da5f 100644 --- a/tests/testthat/test-jaspSyntax-lifecycle.R +++ b/tests/testthat/test-jaspSyntax-lifecycle.R @@ -76,6 +76,16 @@ localDescriptivesModuleOptions <- function(modulePath) { )) } +localRealDescriptivesModulePath <- function() { + candidates <- c( + Sys.getenv("JASPTOOLS_REAL_DESCRIPTIVES_MODULE", unset = ""), + file.path(testthat::test_path(), "..", "..", "..", "jaspDescriptives") + ) + candidates <- candidates[nzchar(candidates)] + candidates <- normalizePath(candidates, winslash = "/", mustWork = FALSE) + candidates[dir.exists(candidates)][1L] +} + disableDescriptivesPlotOptions <- function(options) { plotFlags <- c( "boxPlot", @@ -757,11 +767,11 @@ test_that("subprocess runAnalysis parent views returned processed results", { test_that("native QML replay accepts saved bound scalar options", { fixtureModule <- normalizePath( - file.path("C:/JASP-Packages/jaspSyntax/tests/testthat/fixtures/minimalModule"), + file.path(testthat::test_path(), "fixtures", "minimalModule"), winslash = "/", mustWork = FALSE ) - testthat::skip_if_not(dir.exists(fixtureModule), "jaspSyntax minimal module fixture is unavailable") + testthat::skip_if_not(dir.exists(fixtureModule), "minimal module fixture is unavailable") opts <- jaspSyntax::readAnalysisOptionsFromQml( fixtureModule, @@ -849,8 +859,11 @@ test_that("real saved .jasp options replay once through runAnalysis with extract testthat::skip_if_not_installed("jaspDescriptives") skip_if_no_jaspSyntax_dataset_api() - modulePath <- normalizePath("C:/JASP-Packages/jaspDescriptives", winslash = "/", mustWork = FALSE) - testthat::skip_if_not(dir.exists(modulePath), "local jaspDescriptives checkout is unavailable") + modulePath <- localRealDescriptivesModulePath() + testthat::skip_if_not( + !is.na(modulePath), + "set JASPTOOLS_REAL_DESCRIPTIVES_MODULE or keep jaspDescriptives beside jaspTools" + ) skip_if_descriptives_qml_has_known_pareto_bug(modulePath) restoreRngOption <- localJaspToolsOptions(list(jaspLegacyRngKind = FALSE)) @@ -916,8 +929,11 @@ test_that("real QML defaults can be edited and replayed through QML once", { testthat::skip_if_not_installed("jaspDescriptives") skip_if_no_jaspSyntax_dataset_api() - modulePath <- normalizePath("C:/JASP-Packages/jaspDescriptives", winslash = "/", mustWork = FALSE) - testthat::skip_if_not(dir.exists(modulePath), "local jaspDescriptives checkout is unavailable") + modulePath <- localRealDescriptivesModulePath() + testthat::skip_if_not( + !is.na(modulePath), + "set JASPTOOLS_REAL_DESCRIPTIVES_MODULE or keep jaspDescriptives beside jaspTools" + ) skip_if_descriptives_qml_has_known_pareto_bug(modulePath) restoreRngOption <- localJaspToolsOptions(list(jaspLegacyRngKind = FALSE)) @@ -972,8 +988,11 @@ test_that("real runtime .jasp options are inspection-only", { testthat::skip_if_not(file.exists(jaspFile), "debug descriptives .jasp fixture is unavailable") testthat::skip_if_not_installed("jaspDescriptives") - modulePath <- normalizePath("C:/JASP-Packages/jaspDescriptives", winslash = "/", mustWork = FALSE) - testthat::skip_if_not(dir.exists(modulePath), "local jaspDescriptives checkout is unavailable") + modulePath <- localRealDescriptivesModulePath() + testthat::skip_if_not( + !is.na(modulePath), + "set JASPTOOLS_REAL_DESCRIPTIVES_MODULE or keep jaspDescriptives beside jaspTools" + ) restorePkgOptions <- localDescriptivesModuleOptions(modulePath) on.exit(restorePkgOptions(), add = TRUE) From 53dec21c42fe6952906fe69babc7cb3a492e75a7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Tue, 26 May 2026 22:51:28 +0200 Subject: [PATCH 6/9] Delegate result state decoding to jaspBase --- R/run.R | 28 +++++++++------------------- tests/testthat/test-rbridge-shim.R | 22 ++++++++++++++++++++++ 2 files changed, 31 insertions(+), 19 deletions(-) diff --git a/R/run.R b/R/run.R index 2ef07be..e0eb1cf 100644 --- a/R/run.R +++ b/R/run.R @@ -493,7 +493,7 @@ processJsonResults <- function(jsonResults) { results <- .jaspSyntaxDecodeAnalysisResults(results) results[["state"]] <- .readRunState() - results[["state"]] <- decodeJaspResultState(results[["state"]]) + results[["state"]] <- .jaspBaseDecodeJaspResultState(results[["state"]]) figures <- results$state$figures if (length(figures) > 1 && !is.null(names(figures))) @@ -533,26 +533,16 @@ processJsonResults <- function(jsonResults) { state } -decodeJaspResultState <- function(state) { - if (!is.list(state) || is.null(state[["figures"]])) - return(state) - - for (figureName in names(state[["figures"]])) { - figure <- state[["figures"]][[figureName]] - if (is.list(figure) && !is.null(figure[["obj"]])) { - figure[["obj"]] <- decodeJaspPlotObject(figure[["obj"]]) - state[["figures"]][[figureName]] <- figure - } +.jaspBaseDecodeJaspResultState <- function(state) { + if (!exists("decodeJaspResultState", envir = asNamespace("jaspBase"), inherits = FALSE)) { + stop( + "Installed jaspBase does not provide `decodeJaspResultState()`. ", + "Update jaspBase so jaspTools can decode result state through the public jaspBase API.", + call. = FALSE + ) } - state -} - -decodeJaspPlotObject <- function(plot) { - tryCatch( - jaspBase:::decodeplot(plot, returnGrob = FALSE), - error = function(e) plot - ) + jaspBase::decodeJaspResultState(state) } .jaspSyntaxDecodeAnalysisResults <- function(results) { diff --git a/tests/testthat/test-rbridge-shim.R b/tests/testthat/test-rbridge-shim.R index 3daca2f..28f5516 100644 --- a/tests/testthat/test-rbridge-shim.R +++ b/tests/testthat/test-rbridge-shim.R @@ -94,7 +94,9 @@ test_that("state callback initializes the state file expected by jaspBase", { test_that("processed results read standalone jaspBase state from callback file", { restoreDecode <- localJaspToolsBinding(".jaspSyntaxDecodeAnalysisResults", function(results) results) + restoreStateDecode <- localJaspToolsBinding(".jaspBaseDecodeJaspResultState", function(state) state) on.exit(restoreDecode(), add = TRUE) + on.exit(restoreStateDecode(), add = TRUE) on.exit(jaspTools:::.resetRunStateFile(), add = TRUE) location <- jaspTools:::.requestStateFileNameNative() @@ -107,6 +109,26 @@ test_that("processed results read standalone jaspBase state from callback file", expect_equal(results$state, state) }) +test_that("processed results delegate state figure decoding to jaspBase", { + state <- list(figures = list("1.png" = list(obj = "encoded"))) + observed <- NULL + restoreDecode <- localJaspToolsBinding(".jaspSyntaxDecodeAnalysisResults", function(results) results) + restoreReadState <- localJaspToolsBinding(".readRunState", function() state) + restoreStateDecode <- localJaspToolsBinding(".jaspBaseDecodeJaspResultState", function(state) { + observed <<- state + state$decodedByJaspBase <- TRUE + state + }) + on.exit(restoreDecode(), add = TRUE) + on.exit(restoreReadState(), add = TRUE) + on.exit(restoreStateDecode(), add = TRUE) + + results <- jaspTools:::processJsonResults('{"status":"complete","results":{}}') + + expect_identical(observed, state) + expect_true(results$state$decodedByJaspBase) +}) + test_that("rbridge globals are restored after temporary injection", { env <- new.env(parent = emptyenv()) original <- function() "original" From 9dde127b5746dde670d7e8be7369e2ba8f8a997c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Wed, 27 May 2026 09:12:29 +0200 Subject: [PATCH 7/9] Forward quiet flag to wrapped analysis --- R/run.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/run.R b/R/run.R index e0eb1cf..f32ceae 100644 --- a/R/run.R +++ b/R/run.R @@ -108,6 +108,8 @@ runAnalysis <- function(name, dataset = NULL, options, view = TRUE, quiet = TRUE runner <- attr(args, "runner", exact = TRUE) attr(args, "runner") <- NULL attr(args, "modulePath") <- NULL + if ("quiet" %in% names(formals(runner))) + args$quiet <- quiet oldWd <- getwd() oldLang <- Sys.getenv("LANG") From db6ab2009cc1e74c4b46601b73bb87dc78b7f3a4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Wed, 27 May 2026 09:42:46 +0200 Subject: [PATCH 8/9] Add runAnalysis verbosity levels --- R/run.R | 100 ++++++++++++++++++--- R/subprocess.R | 16 ++++ man/runAnalysis.Rd | 15 +++- tests/testthat/test-jaspSyntax-lifecycle.R | 33 +++++++ 4 files changed, 150 insertions(+), 14 deletions(-) diff --git a/R/run.R b/R/run.R index f32ceae..8514340 100644 --- a/R/run.R +++ b/R/run.R @@ -18,9 +18,14 @@ #' @param options List of options to supply to the analysis (see also #' \code{analysisOptions}). #' @param view Boolean indicating whether to view the results in a webbrowser. -#' @param quiet Boolean indicating whether to suppress messages from the -#' analysis. Quiet runs are evaluated in a subprocess to contain native bridge -#' crashes and Desktop logging. +#' @param quiet Boolean indicating whether to run with subprocess containment +#' and suppress raw JASP/native output by default. +#' @param verbose Controls which output streams are replayed. Use \code{"all"} +#' or \code{TRUE} for both analysis and JASP/native output, \code{"analysis"} +#' for R analysis messages and warnings only, \code{"jasp"} for JASP/native +#' output only, and \code{"none"} or \code{FALSE} for no replayed output. When +#' omitted, quiet runs default to \code{"analysis"} and non-quiet runs default +#' to \code{"all"}. #' @param makeTests Boolean indicating whether to create testthat unit tests and print them to the terminal. #' @param modulePath Optional path to the module checkout that should be used #' for QML resolution and wrapped execution. When omitted, jaspTools first @@ -65,7 +70,8 @@ #' #' @export runAnalysis runAnalysis <- function(name, dataset = NULL, options, view = TRUE, quiet = TRUE, - makeTests = FALSE, modulePath = NULL) { + makeTests = FALSE, modulePath = NULL, + verbose = getOption("jaspTools.runAnalysis.verbose", NULL)) { if (is.list(options) && is.null(names(options)) && any(names(unlist(lapply(options, attributes))) == "analysisName")) stop("The provided list of options is not named. Did you mean to index in the options list (e.g., options[[1]])?") @@ -91,6 +97,8 @@ runAnalysis <- function(name, dataset = NULL, options, view = TRUE, quiet = TRUE quiet <- TRUE } + verbose <- normalizeRunAnalysisVerbose(verbose, quiet = quiet) + if (runAnalysisShouldUseSubprocess(quiet = quiet)) { return(runAnalysisInSubprocess( name = name, @@ -99,7 +107,8 @@ runAnalysis <- function(name, dataset = NULL, options, view = TRUE, quiet = TRUE view = view, quiet = quiet, makeTests = makeTests, - modulePath = modulePath + modulePath = modulePath, + verbose = verbose )) } @@ -110,6 +119,8 @@ runAnalysis <- function(name, dataset = NULL, options, view = TRUE, quiet = TRUE attr(args, "modulePath") <- NULL if ("quiet" %in% names(formals(runner))) args$quiet <- quiet + if ("verbose" %in% names(formals(runner))) + args$verbose <- verbose oldWd <- getwd() oldLang <- Sys.getenv("LANG") @@ -132,7 +143,7 @@ runAnalysis <- function(name, dataset = NULL, options, view = TRUE, quiet = TRUE makeTests = makeTests ) - if (quiet) { + if (quiet && !runAnalysisShowsJaspOutput(verbose)) { sink(tempfile()) on.exit({suppressWarnings(sink(NULL))}, add = TRUE) returnVal <- do.call(runner, args) @@ -168,8 +179,47 @@ runAnalysisShouldUseSubprocess <- function(quiet, !identical(Sys.getenv("JASPTOOLS_RUNANALYSIS_CHILD"), "true") } +normalizeRunAnalysisVerbose <- function(verbose = NULL, quiet = NULL) { + if (is.null(verbose) || length(verbose) == 0L) { + if (isFALSE(quiet)) + return("all") + + return("analysis") + } + + verbose <- verbose[[1L]] + if (is.na(verbose)) + stop("`verbose` must be one of 'all', 'analysis', 'jasp', 'none', TRUE, or FALSE.", call. = FALSE) + + if (is.logical(verbose)) + return(if (isTRUE(verbose)) "all" else "none") + + if (is.character(verbose)) { + verbose <- tolower(trimws(verbose)) + if (verbose %in% c("true", "yes", "on", "1")) + return("all") + if (verbose %in% c("false", "no", "off", "0")) + return("none") + if (verbose %in% c("all", "analysis", "jasp", "none")) + return(verbose) + } + + stop("`verbose` must be one of 'all', 'analysis', 'jasp', 'none', TRUE, or FALSE.", call. = FALSE) +} + +runAnalysisShowsAnalysisOutput <- function(verbose) { + verbose %in% c("all", "analysis") +} + +runAnalysisShowsJaspOutput <- function(verbose) { + verbose %in% c("all", "jasp") +} + runAnalysisInSubprocess <- function(name, dataset, options, view, quiet, - makeTests, modulePath = NULL) { + makeTests, modulePath = NULL, + verbose = NULL) { + verbose <- normalizeRunAnalysisVerbose(verbose, quiet = quiet) + payload <- .jaspToolsSubprocessPayload( extra = list(args = list( name = name, @@ -178,7 +228,8 @@ runAnalysisInSubprocess <- function(name, dataset, options, view, quiet, view = FALSE, quiet = FALSE, makeTests = FALSE, - modulePath = modulePath + modulePath = modulePath, + verbose = verbose )), env = .jaspToolsSubprocessEnv( "JASPTOOLS_RUNANALYSIS_CHILD", @@ -201,7 +252,9 @@ runAnalysisInSubprocess <- function(name, dataset, options, view, quiet, restoreSubprocessHtmlFiles(subprocessResult$htmlFiles) result <- .runAnalysisSubprocessResult(subprocessResult) - replaySubprocessWarnings(subprocessResult$warnings) + replaySubprocessOutput(subprocessResult$output, verbose = verbose) + replaySubprocessMessages(subprocessResult$messages, verbose = verbose) + replaySubprocessWarnings(subprocessResult$warnings, verbose = verbose) .stopIfJaspToolsSubprocessError(result) viewRunAnalysisResults(result, view) @@ -226,7 +279,23 @@ viewRunAnalysisResults <- function(results, enabled) { get("view", envir = asNamespace("jaspTools"), inherits = FALSE)(results) } -replaySubprocessWarnings <- function(warnings) { +replaySubprocessMessages <- function(messages, verbose = "analysis") { + if (!runAnalysisShowsAnalysisOutput(verbose)) + return(invisible(FALSE)) + + if (!is.character(messages) || length(messages) == 0L) + return(invisible(FALSE)) + + for (messageText in messages) + message(messageText) + + invisible(TRUE) +} + +replaySubprocessWarnings <- function(warnings, verbose = "analysis") { + if (!runAnalysisShowsAnalysisOutput(verbose)) + return(invisible(FALSE)) + if (!is.character(warnings) || length(warnings) == 0L) return(invisible(FALSE)) @@ -236,6 +305,17 @@ replaySubprocessWarnings <- function(warnings) { invisible(TRUE) } +replaySubprocessOutput <- function(output, verbose = "analysis") { + if (!runAnalysisShowsJaspOutput(verbose)) + return(invisible(FALSE)) + + if (!is.character(output) || length(output) == 0L) + return(invisible(FALSE)) + + writeLines(output) + invisible(TRUE) +} + collectSubprocessHtmlFiles <- function(root = getTempOutputLocation("html")) { if (!dir.exists(root)) return(list(files = list())) diff --git a/R/subprocess.R b/R/subprocess.R index ee06a17..f18b6a5 100644 --- a/R/subprocess.R +++ b/R/subprocess.R @@ -75,6 +75,9 @@ ) } + if (is.list(result) && !inherits(result, "jaspTools.subprocessError")) + result$output <- .jaspToolsSubprocessLog(logPath) + unlink(logPath, force = TRUE) result } @@ -123,9 +126,14 @@ .jaspToolsRunAnalysisSubprocess <- function(args) { warnings <- character(0) + messages <- character(0) result <- tryCatch( withCallingHandlers( do.call(jaspTools::runAnalysis, args), + message = function(m) { + messages <<- c(messages, conditionMessage(m)) + tryInvokeRestart("muffleMessage") + }, warning = function(w) { warnings <<- c(warnings, conditionMessage(w)) tryInvokeRestart("muffleWarning") @@ -140,6 +148,7 @@ result = result, lastResults = tryCatch(jaspTools:::.getInternal("lastResults"), error = function(e) NULL), htmlFiles = tryCatch(jaspTools:::collectSubprocessHtmlFiles(), error = function(e) NULL), + messages = unique(messages), warnings = unique(warnings) ) } @@ -175,6 +184,13 @@ if (nzchar(logTail)) paste0("\n", logTail) else "" } +.jaspToolsSubprocessLog <- function(logPath) { + if (!file.exists(logPath)) + return(character(0)) + + readLines(logPath, warn = FALSE) +} + .stopIfJaspToolsSubprocessError <- function(result) { if (inherits(result, "jaspTools.subprocessError")) stop(result$message, call. = FALSE) diff --git a/man/runAnalysis.Rd b/man/runAnalysis.Rd index 746f9ee..4f81ee2 100644 --- a/man/runAnalysis.Rd +++ b/man/runAnalysis.Rd @@ -11,7 +11,8 @@ runAnalysis( view = TRUE, quiet = TRUE, makeTests = FALSE, - modulePath = NULL + modulePath = NULL, + verbose = getOption("jaspTools.runAnalysis.verbose", NULL) ) } \arguments{ @@ -27,9 +28,8 @@ By default the directory in Resources is checked first, unless called within a t \item{view}{Boolean indicating whether to view the results in a webbrowser.} -\item{quiet}{Boolean indicating whether to suppress messages from the -analysis. Quiet runs are evaluated in a subprocess to contain native bridge -crashes and Desktop logging.} +\item{quiet}{Boolean indicating whether to run with subprocess containment +and suppress raw JASP/native output by default.} \item{makeTests}{Boolean indicating whether to create testthat unit tests and print them to the terminal.} @@ -37,6 +37,13 @@ crashes and Desktop logging.} for QML resolution and wrapped execution. When omitted, jaspTools first uses a module path attached to \code{options} by \code{analysisOptions()} and then falls back to configured \code{module.dirs}.} + +\item{verbose}{Controls which output streams are replayed. Use \code{"all"} +or \code{TRUE} for both analysis and JASP/native output, \code{"analysis"} +for R analysis messages and warnings only, \code{"jasp"} for JASP/native +output only, and \code{"none"} or \code{FALSE} for no replayed output. When +omitted, quiet runs default to \code{"analysis"} and non-quiet runs default +to \code{"all"}.} } \description{ \code{runAnalysis} makes it possible to execute a JASP analysis in R. Usually this diff --git a/tests/testthat/test-jaspSyntax-lifecycle.R b/tests/testthat/test-jaspSyntax-lifecycle.R index 772da5f..6a5943e 100644 --- a/tests/testthat/test-jaspSyntax-lifecycle.R +++ b/tests/testthat/test-jaspSyntax-lifecycle.R @@ -651,6 +651,36 @@ test_that("subprocess warnings are replayed in the parent session", { ) }) +test_that("runAnalysis verbosity separates replayed subprocess streams", { + expect_identical(jaspTools:::normalizeRunAnalysisVerbose(NULL, quiet = TRUE), "analysis") + expect_identical(jaspTools:::normalizeRunAnalysisVerbose(NULL, quiet = FALSE), "all") + expect_identical(jaspTools:::normalizeRunAnalysisVerbose(TRUE), "all") + expect_identical(jaspTools:::normalizeRunAnalysisVerbose(FALSE), "none") + expect_identical(jaspTools:::normalizeRunAnalysisVerbose("jasp"), "jasp") + expect_error( + jaspTools:::normalizeRunAnalysisVerbose("loud"), + "`verbose` must be one of" + ) + + expect_message( + jaspTools:::replaySubprocessMessages("analysis message", verbose = "analysis"), + "analysis message" + ) + expect_silent(jaspTools:::replaySubprocessMessages("analysis message", verbose = "jasp")) + + expect_warning( + jaspTools:::replaySubprocessWarnings("analysis warning", verbose = "analysis"), + "analysis warning" + ) + expect_silent(jaspTools:::replaySubprocessWarnings("analysis warning", verbose = "jasp")) + + expect_output( + jaspTools:::replaySubprocessOutput("Desktop: native output", verbose = "jasp"), + "Desktop: native output" + ) + expect_silent(jaspTools:::replaySubprocessOutput("Desktop: native output", verbose = "analysis")) +}) + test_that("subprocess env only carries requested variables", { env <- jaspTools:::.jaspToolsSubprocessEnv("JASPTOOLS_FAKE_CHILD") @@ -737,6 +767,8 @@ test_that("subprocess runAnalysis parent views returned processed results", { result = processed, lastResults = rawJson, htmlFiles = list(files = list()), + messages = character(0), + output = character(0), warnings = character(0) ) }, @@ -758,6 +790,7 @@ test_that("subprocess runAnalysis parent views returned processed results", { expect_false(observedPayload$args$view) expect_false(observedPayload$args$makeTests) + expect_identical(observedPayload$args$verbose, "analysis") expect_identical(observedPayload$env$JASPTOOLS_RUNANALYSIS_CHILD, "true") expect_true(all(c("NOT_CRAN", "LANG", "LANGUAGE") %in% names(observedPayload$env))) expect_identical(result, processed) From 91a1e449e047e8e80505f376f86b1140036710c9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Thu, 28 May 2026 08:53:06 +0200 Subject: [PATCH 9/9] Honor jaspSyntax verbosity defaults --- R/run.R | 6 +++--- man/runAnalysis.Rd | 4 ++-- tests/testthat/test-jaspSyntax-lifecycle.R | 13 +++++++++++++ 3 files changed, 18 insertions(+), 5 deletions(-) diff --git a/R/run.R b/R/run.R index 8514340..da733b7 100644 --- a/R/run.R +++ b/R/run.R @@ -24,8 +24,8 @@ #' or \code{TRUE} for both analysis and JASP/native output, \code{"analysis"} #' for R analysis messages and warnings only, \code{"jasp"} for JASP/native #' output only, and \code{"none"} or \code{FALSE} for no replayed output. When -#' omitted, quiet runs default to \code{"analysis"} and non-quiet runs default -#' to \code{"all"}. +#' omitted, \code{getOption("jaspSyntax.verbose")} is honored first, then quiet +#' runs default to \code{"analysis"} and non-quiet runs default to \code{"all"}. #' @param makeTests Boolean indicating whether to create testthat unit tests and print them to the terminal. #' @param modulePath Optional path to the module checkout that should be used #' for QML resolution and wrapped execution. When omitted, jaspTools first @@ -71,7 +71,7 @@ #' @export runAnalysis runAnalysis <- function(name, dataset = NULL, options, view = TRUE, quiet = TRUE, makeTests = FALSE, modulePath = NULL, - verbose = getOption("jaspTools.runAnalysis.verbose", NULL)) { + verbose = getOption("jaspTools.runAnalysis.verbose", getOption("jaspSyntax.verbose", NULL))) { if (is.list(options) && is.null(names(options)) && any(names(unlist(lapply(options, attributes))) == "analysisName")) stop("The provided list of options is not named. Did you mean to index in the options list (e.g., options[[1]])?") diff --git a/man/runAnalysis.Rd b/man/runAnalysis.Rd index 4f81ee2..d9743ae 100644 --- a/man/runAnalysis.Rd +++ b/man/runAnalysis.Rd @@ -42,8 +42,8 @@ and then falls back to configured \code{module.dirs}.} or \code{TRUE} for both analysis and JASP/native output, \code{"analysis"} for R analysis messages and warnings only, \code{"jasp"} for JASP/native output only, and \code{"none"} or \code{FALSE} for no replayed output. When -omitted, quiet runs default to \code{"analysis"} and non-quiet runs default -to \code{"all"}.} +omitted, \code{getOption("jaspSyntax.verbose")} is honored first, then quiet +runs default to \code{"analysis"} and non-quiet runs default to \code{"all"}.} } \description{ \code{runAnalysis} makes it possible to execute a JASP analysis in R. Usually this diff --git a/tests/testthat/test-jaspSyntax-lifecycle.R b/tests/testthat/test-jaspSyntax-lifecycle.R index 6a5943e..93ab51e 100644 --- a/tests/testthat/test-jaspSyntax-lifecycle.R +++ b/tests/testthat/test-jaspSyntax-lifecycle.R @@ -681,6 +681,19 @@ test_that("runAnalysis verbosity separates replayed subprocess streams", { expect_silent(jaspTools:::replaySubprocessOutput("Desktop: native output", verbose = "analysis")) }) +test_that("runAnalysis verbosity honors jaspSyntax default option", { + oldOptions <- options( + jaspTools.runAnalysis.verbose = NULL, + jaspSyntax.verbose = "none" + ) + on.exit(do.call(options, oldOptions), add = TRUE) + + expect_identical(eval(formals(jaspTools::runAnalysis)$verbose), "none") + + options(jaspTools.runAnalysis.verbose = "jasp") + expect_identical(eval(formals(jaspTools::runAnalysis)$verbose), "jasp") +}) + test_that("subprocess env only carries requested variables", { env <- jaspTools:::.jaspToolsSubprocessEnv("JASPTOOLS_FAKE_CHILD")