From 6d6834d608b55c8721f548277b767b4f2649973e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Thu, 14 May 2026 13:56:04 +0200 Subject: [PATCH 01/22] Support source-module wrapped analysis replay --- DESCRIPTION | 2 +- R/common.R | 60 +++++++++--- R/commonerrorcheck.R | 3 + src/jaspResults.cpp | 9 ++ tests/testthat/test-commonerrorcheck.R | 8 ++ tests/testthat/test-runWrappedAnalysis.R | 118 +++++++++++++++++++++++ 6 files changed, 186 insertions(+), 14 deletions(-) create mode 100644 tests/testthat/test-commonerrorcheck.R create mode 100644 tests/testthat/test-runWrappedAnalysis.R diff --git a/DESCRIPTION b/DESCRIPTION index 3aa1b307..4cb73125 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: jaspBase Type: Package Title: JASP Base -Version: 0.20.4 +Version: 0.20.5 Author: JASP Team Maintainer: Bruno Boutin Description: Package contains the JASP Bayesian and Frequentist analyses. diff --git a/R/common.R b/R/common.R index 8db8d7be..608bebe3 100644 --- a/R/common.R +++ b/R/common.R @@ -629,6 +629,7 @@ jaspResultsStrings <- function() { ".requestTempFileNameNative", ".requestTempRootNameNative", ".readDatasetToEndNative", + ".readFullDatasetToEnd", ".readDataSetHeaderNative", ".readDataSetRequestedNative", ".requestStateFileNameNative", @@ -659,19 +660,20 @@ jaspResultsStrings <- function() { } +.stateFilePath <- function(location) { + if (is.list(location) && !is.null(location$root) && !is.null(location$relativePath)) + return(file.path(location$root, location$relativePath)) + + location$relativePath +} + .saveState <- function(state) { location <- .fromRCPP(".requestStateFileNameNative") relativePath <- location$relativePath + statePath <- .stateFilePath(location) + dir.create(dirname(statePath), recursive = TRUE, showWarnings = FALSE) - # when run through jaspTools do not save the state, but store it internally - if ("jaspTools" %in% loadedNamespaces()) { - # fool renv so it does not try to install jaspTools - .setInternal <- utils::getFromNamespace(".setInternal", asNamespace("jaspTools")) - .setInternal("state", state) - return(list(relativePath = relativePath)) - } - - try(suppressWarnings(base::save(state, file=relativePath, compress=FALSE)), silent = FALSE) + try(suppressWarnings(base::save(state, file=statePath, compress=FALSE)), silent = FALSE) return(list(relativePath = relativePath)) } @@ -683,9 +685,10 @@ jaspResultsStrings <- function() { if (base::exists(".requestStateFileNameNative")) { location <- .fromRCPP(".requestStateFileNameNative") + statePath <- .stateFilePath(location) base::tryCatch( - base::load(location$relativePath), + base::load(statePath), error=function(e) e #,warning=function(w) w #Commented out because if there *is* a warning, which there of course shouldnt be, the state wont be loaded *at all*. ) @@ -1163,18 +1166,49 @@ storeDataSet <- function(dataset) { jaspSyntax::loadDataSet(dataset) } +.wrappedAnalysisQmlFile <- function(moduleName, qmlFileName, modulePath = NULL, qmlFile = NULL) { + isNonEmptyString <- function(x) is.character(x) && length(x) == 1 && !is.na(x) && nzchar(x) + + if (isNonEmptyString(qmlFile)) + return(normalizePath(qmlFile, winslash = "/", mustWork = FALSE)) + + if (isNonEmptyString(modulePath)) { + qmlCandidates <- file.path(modulePath, c("inst/qml", "qml"), qmlFileName) + existingQml <- qmlCandidates[file.exists(qmlCandidates)] + if (length(existingQml) > 0) + return(normalizePath(existingQml[[1]], winslash = "/", mustWork = FALSE)) + + return(normalizePath(qmlCandidates[[1]], winslash = "/", mustWork = FALSE)) + } + + normalizePath(file.path(find.package(moduleName), "qml", qmlFileName), winslash = "/", mustWork = FALSE) +} + #' @export -runWrappedAnalysis <- function(moduleName, analysisName, qmlFileName, options, version, preloadData) { +runWrappedAnalysis <- function(moduleName, analysisName, qmlFileName, options, version, preloadData, modulePath = NULL, qmlFile = NULL) { if (jaspResultsCalledFromJasp()) { # In this case, it is JASP Desktop that called the wrapper. This was done to parse the R code, and to get the arguments # in a structured way. In this way the Desktop can then set the options to the QML controls of the form, and this will run the analysis. # So here, just give back the parsed options. - return(toJSON(list("options" = options, "module" = moduleName, "analysis" = analysisName, "version" = version))) + response <- list( + "options" = options, + "module" = moduleName, + "analysis" = analysisName, + "version" = version, + "qmlFileName" = qmlFileName, + "jaspBaseVersion" = as.character(utils::packageVersion("jaspBase")), + "source" = "jaspBase::runWrappedAnalysis" + ) + if (!is.null(modulePath)) + response[["modulePath"]] <- modulePath + if (!is.null(qmlFile)) + response[["qmlFile"]] <- qmlFile + return(toJSON(response)) } else { # The wrapper is called inside an R environment (R Studio probably). # The options must be parsed and checked by the QML form, and then the real analysis can be called. - qmlFile <- file.path(find.package(moduleName), "qml", qmlFileName) + qmlFile <- .wrappedAnalysisQmlFile(moduleName, qmlFileName, modulePath, qmlFile) # Load the qml form, and set the right options (formula should be parsed and all logics set in QML should be checked), and run the analysis options <- jaspSyntax::loadQmlAndParseOptions(moduleName, analysisName, qmlFile, as.character(toJSON(options)), version, preloadData) diff --git a/R/commonerrorcheck.R b/R/commonerrorcheck.R index 5eb7f65b..8ad88ae6 100644 --- a/R/commonerrorcheck.R +++ b/R/commonerrorcheck.R @@ -432,6 +432,9 @@ validValues <- x[is.finite(x)] variance <- -1 # Prevents the function from returning NA's if (length(validValues) > 1) { + if (is.factor(validValues)) { + validValues <- as.numeric(validValues) + } variance <- stats::var(validValues) } return(variance) diff --git a/src/jaspResults.cpp b/src/jaspResults.cpp index 5f3e7199..284f487b 100644 --- a/src/jaspResults.cpp +++ b/src/jaspResults.cpp @@ -131,12 +131,18 @@ std::string jaspResults::getStatus() void jaspResults::prepareForWriting() { + if(_writeSealRoot + _writeSealRelative == "") + return; + //Remove the seal if it is there or not doesnt matter BREMOVE((_writeSealRoot + _writeSealRelative).c_str()); } void jaspResults::finishWriting() { + if(_writeSealRoot + _writeSealRelative == "") + return; + //Let us write a small file that tells us writing stuff went well ( https://github.com/jasp-stats/INTERNAL-jasp/issues/884 ) bofstream sealMe((_writeSealRoot + _writeSealRelative).c_str(), std::ios_base::trunc); @@ -279,6 +285,9 @@ void jaspResults::send(std::string otherMsg) jaspPrint("send was called!"); #endif + if(!_insideJASP) + return; + if(_ipccSendFunc != nullptr) (*_ipccSendFunc)(otherMsg == "" ? constructResultJson() : otherMsg.c_str()); } diff --git a/tests/testthat/test-commonerrorcheck.R b/tests/testthat/test-commonerrorcheck.R new file mode 100644 index 00000000..1194a669 --- /dev/null +++ b/tests/testthat/test-commonerrorcheck.R @@ -0,0 +1,8 @@ +testthat::test_that("variance checks handle factor variables", { + dataset <- data.frame(x = factor(c("a", "b", "a"))) + + result <- jaspBase:::.checkVariance(dataset, target = "x", equalTo = 0) + + testthat::expect_false(result$error) + testthat::expect_null(result$errorVars) +}) diff --git a/tests/testthat/test-runWrappedAnalysis.R b/tests/testthat/test-runWrappedAnalysis.R new file mode 100644 index 00000000..8cc07abb --- /dev/null +++ b/tests/testthat/test-runWrappedAnalysis.R @@ -0,0 +1,118 @@ +testthat::test_that("wrapped analysis QML paths prefer explicit files", { + explicitFile <- tempfile(fileext = ".qml") + writeLines("import QtQuick", explicitFile) + + qmlFile <- jaspBase:::.wrappedAnalysisQmlFile( + moduleName = "jaspBase", + qmlFileName = "Ignored.qml", + qmlFile = explicitFile + ) + + testthat::expect_equal(qmlFile, normalizePath(explicitFile, winslash = "/", mustWork = FALSE)) +}) + +testthat::test_that("wrapped analysis QML paths resolve checkout module paths", { + modulePath <- tempfile("module") + qmlDir <- file.path(modulePath, "inst", "qml") + dir.create(qmlDir, recursive = TRUE) + qmlPath <- file.path(qmlDir, "Analysis.qml") + writeLines("import QtQuick", qmlPath) + + qmlFile <- jaspBase:::.wrappedAnalysisQmlFile( + moduleName = "jaspBase", + qmlFileName = "Analysis.qml", + modulePath = modulePath + ) + + testthat::expect_equal(qmlFile, normalizePath(qmlPath, winslash = "/", mustWork = FALSE)) +}) + +testthat::test_that("standalone bridge can read the full dataset callback", { + oldCallback <- if (exists(".readFullDatasetToEnd", envir = .GlobalEnv, inherits = FALSE)) { + get(".readFullDatasetToEnd", envir = .GlobalEnv, inherits = FALSE) + } else { + NULL + } + hadCallback <- exists(".readFullDatasetToEnd", envir = .GlobalEnv, inherits = FALSE) + on.exit({ + if (hadCallback) { + assign(".readFullDatasetToEnd", oldCallback, envir = .GlobalEnv) + } else if (exists(".readFullDatasetToEnd", envir = .GlobalEnv, inherits = FALSE)) { + rm(".readFullDatasetToEnd", envir = .GlobalEnv) + } + }, add = TRUE) + + assign( + ".readFullDatasetToEnd", + function() data.frame(x = 1, check.names = FALSE), + envir = .GlobalEnv + ) + + testthat::expect_equal( + jaspBase:::.fromRCPP(".readFullDatasetToEnd"), + data.frame(x = 1, check.names = FALSE) + ) +}) + +testthat::test_that("standalone state saving uses the callback file contract", { + oldCallback <- if (exists(".requestStateFileNameNative", envir = .GlobalEnv, inherits = FALSE)) { + get(".requestStateFileNameNative", envir = .GlobalEnv, inherits = FALSE) + } else { + NULL + } + hadCallback <- exists(".requestStateFileNameNative", envir = .GlobalEnv, inherits = FALSE) + on.exit({ + if (hadCallback) { + assign(".requestStateFileNameNative", oldCallback, envir = .GlobalEnv) + } else if (exists(".requestStateFileNameNative", envir = .GlobalEnv, inherits = FALSE)) { + rm(".requestStateFileNameNative", envir = .GlobalEnv) + } + }, add = TRUE) + + stateFile <- tempfile("jasp-state-") + assign( + ".requestStateFileNameNative", + function() list(root = dirname(stateFile), relativePath = basename(stateFile)), + envir = .GlobalEnv + ) + + savedState <- list(figures = list(), other = list(answer = 42)) + result <- jaspBase:::.saveState(savedState) + loaded <- load(stateFile) + + testthat::expect_equal(result$relativePath, basename(stateFile)) + testthat::expect_identical(loaded, "state") + testthat::expect_equal(state, savedState) +}) + +testthat::test_that("standalone state retrieval uses the callback root", { + oldCallback <- if (exists(".requestStateFileNameNative", envir = .GlobalEnv, inherits = FALSE)) { + get(".requestStateFileNameNative", envir = .GlobalEnv, inherits = FALSE) + } else { + NULL + } + hadCallback <- exists(".requestStateFileNameNative", envir = .GlobalEnv, inherits = FALSE) + on.exit({ + if (hadCallback) { + assign(".requestStateFileNameNative", oldCallback, envir = .GlobalEnv) + } else if (exists(".requestStateFileNameNative", envir = .GlobalEnv, inherits = FALSE)) { + rm(".requestStateFileNameNative", envir = .GlobalEnv) + } + }, add = TRUE) + + stateFile <- tempfile("jasp-state-") + assign( + ".requestStateFileNameNative", + function() list(root = dirname(stateFile), relativePath = basename(stateFile)), + envir = .GlobalEnv + ) + + state <- list(figures = list(), other = list(answer = 42)) + save(state, file = stateFile, compress = FALSE) + rm(state) + + testthat::expect_equal( + jaspBase:::.retrieveState(), + list(figures = list(), other = list(answer = 42)) + ) +}) From f51c8d7aadf45367c444545b79c360ef14dddc69 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Thu, 14 May 2026 16:00:06 +0200 Subject: [PATCH 02/22] Clarify wrapped analysis bridge helpers --- DESCRIPTION | 2 ++ R/common.R | 34 +++++++++++++++--------- tests/testthat/test-runWrappedAnalysis.R | 11 ++++++++ 3 files changed, 34 insertions(+), 13 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 4cb73125..8138032e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -11,6 +11,7 @@ Imports: cli, codetools, compiler, + fs, ggplot2, grDevices, grid, @@ -26,6 +27,7 @@ Imports: ragg, R6, Rcpp (>= 0.12.14), + rlang, rvg, svglite, systemfonts, diff --git a/R/common.R b/R/common.R index 608bebe3..cadd1859 100644 --- a/R/common.R +++ b/R/common.R @@ -660,9 +660,18 @@ jaspResultsStrings <- function() { } +.isNonEmptyString <- function(x) { + rlang::is_string(x) && nzchar(x) +} + .stateFilePath <- function(location) { - if (is.list(location) && !is.null(location$root) && !is.null(location$relativePath)) - return(file.path(location$root, location$relativePath)) + if (!rlang::is_list(location) || !.isNonEmptyString(location$relativePath)) + stop("State file callback must return a list with a non-empty `relativePath`.", call. = FALSE) + + # Desktop/native callbacks return `root` plus `relativePath`; standalone callbacks + # may only have a relative path, which is then interpreted from the current wd. + if (.isNonEmptyString(location$root)) + return(as.character(fs::path(location$root, location$relativePath))) location$relativePath } @@ -671,7 +680,7 @@ jaspResultsStrings <- function() { location <- .fromRCPP(".requestStateFileNameNative") relativePath <- location$relativePath statePath <- .stateFilePath(location) - dir.create(dirname(statePath), recursive = TRUE, showWarnings = FALSE) + fs::dir_create(fs::path_dir(statePath)) try(suppressWarnings(base::save(state, file=statePath, compress=FALSE)), silent = FALSE) @@ -1167,21 +1176,19 @@ storeDataSet <- function(dataset) { } .wrappedAnalysisQmlFile <- function(moduleName, qmlFileName, modulePath = NULL, qmlFile = NULL) { - isNonEmptyString <- function(x) is.character(x) && length(x) == 1 && !is.na(x) && nzchar(x) - - if (isNonEmptyString(qmlFile)) - return(normalizePath(qmlFile, winslash = "/", mustWork = FALSE)) + if (.isNonEmptyString(qmlFile)) + return(as.character(fs::path_norm(qmlFile))) - if (isNonEmptyString(modulePath)) { - qmlCandidates <- file.path(modulePath, c("inst/qml", "qml"), qmlFileName) - existingQml <- qmlCandidates[file.exists(qmlCandidates)] + if (.isNonEmptyString(modulePath)) { + qmlCandidates <- fs::path(modulePath, c("inst/qml", "qml"), qmlFileName) + existingQml <- qmlCandidates[fs::file_exists(qmlCandidates)] if (length(existingQml) > 0) - return(normalizePath(existingQml[[1]], winslash = "/", mustWork = FALSE)) + return(as.character(fs::path_norm(existingQml[[1]]))) - return(normalizePath(qmlCandidates[[1]], winslash = "/", mustWork = FALSE)) + return(as.character(fs::path_norm(qmlCandidates[[1]]))) } - normalizePath(file.path(find.package(moduleName), "qml", qmlFileName), winslash = "/", mustWork = FALSE) + as.character(fs::path_norm(fs::path(find.package(moduleName), "qml", qmlFileName))) } #' @export @@ -1196,6 +1203,7 @@ runWrappedAnalysis <- function(moduleName, analysisName, qmlFileName, options, v "analysis" = analysisName, "version" = version, "qmlFileName" = qmlFileName, + # `version` is the generated module wrapper version; this is the runtime contract version. "jaspBaseVersion" = as.character(utils::packageVersion("jaspBase")), "source" = "jaspBase::runWrappedAnalysis" ) diff --git a/tests/testthat/test-runWrappedAnalysis.R b/tests/testthat/test-runWrappedAnalysis.R index 8cc07abb..37a98258 100644 --- a/tests/testthat/test-runWrappedAnalysis.R +++ b/tests/testthat/test-runWrappedAnalysis.R @@ -85,6 +85,17 @@ testthat::test_that("standalone state saving uses the callback file contract", { testthat::expect_equal(state, savedState) }) +testthat::test_that("state file locations reject unsupported callback shapes", { + testthat::expect_error( + jaspBase:::.stateFilePath(list(root = tempdir())), + "non-empty `relativePath`" + ) + testthat::expect_error( + jaspBase:::.stateFilePath(tempfile()), + "non-empty `relativePath`" + ) +}) + testthat::test_that("standalone state retrieval uses the callback root", { oldCallback <- if (exists(".requestStateFileNameNative", envir = .GlobalEnv, inherits = FALSE)) { get(".requestStateFileNameNative", envir = .GlobalEnv, inherits = FALSE) From fc70f1a4f8687ad226886a57d73239475b124f65 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Fri, 15 May 2026 09:24:53 +0200 Subject: [PATCH 03/22] Use portable QML path expectations in tests --- tests/testthat/test-runWrappedAnalysis.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-runWrappedAnalysis.R b/tests/testthat/test-runWrappedAnalysis.R index 37a98258..af80cc23 100644 --- a/tests/testthat/test-runWrappedAnalysis.R +++ b/tests/testthat/test-runWrappedAnalysis.R @@ -8,7 +8,7 @@ testthat::test_that("wrapped analysis QML paths prefer explicit files", { qmlFile = explicitFile ) - testthat::expect_equal(qmlFile, normalizePath(explicitFile, winslash = "/", mustWork = FALSE)) + testthat::expect_equal(qmlFile, as.character(fs::path_norm(explicitFile))) }) testthat::test_that("wrapped analysis QML paths resolve checkout module paths", { @@ -24,7 +24,7 @@ testthat::test_that("wrapped analysis QML paths resolve checkout module paths", modulePath = modulePath ) - testthat::expect_equal(qmlFile, normalizePath(qmlPath, winslash = "/", mustWork = FALSE)) + testthat::expect_equal(qmlFile, as.character(fs::path_norm(qmlPath))) }) testthat::test_that("standalone bridge can read the full dataset callback", { From c2b96dd9507adba38eecc53e65f4449b386dcf9b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Tue, 26 May 2026 18:07:18 +0200 Subject: [PATCH 04/22] Decode R-facing result objects --- R/writeImage.R | 17 +-- R/zzzWrappers.R | 53 +++++++++- tests/testthat/test-result-object-decoding.R | 104 +++++++++++++++++++ 3 files changed, 165 insertions(+), 9 deletions(-) create mode 100644 tests/testthat/test-result-object-decoding.R diff --git a/R/writeImage.R b/R/writeImage.R index 0d6360ad..4651de4b 100755 --- a/R/writeImage.R +++ b/R/writeImage.R @@ -181,13 +181,13 @@ decodeplot.gg <- function(x, returnGrob = TRUE, ...) { # TODO: do not return a grid object! # we can do this by automatically replacing the scales and geoms, although this is quite a lot of work. # alternatively, those edge cases will need to be handled by the developer. - if (packageVersion("ggplot2") < "4.0.0") { - labels <- x$labels # x[["labels"]] needs to be subsetted by `$`, not `[[`, as patchwork objects would fail if subsetting with `[[` - for (i in seq_along(labels)) - if (!is.null(labels[[i]])) - labels[[i]] <- decodeColNames(labels[[i]]) - x$labels <- labels - } else { + labels <- x$labels # x[["labels"]] needs to be subsetted by `$`, not `[[`, as patchwork objects would fail if subsetting with `[[` + for (i in seq_along(labels)) + if (!is.null(labels[[i]])) + labels[[i]] <- decodeColNames(labels[[i]]) + x$labels <- labels + + if (packageVersion("ggplot2") >= "4.0.0") { currentGuides <- x@guides .makeDecodedGuide <- function(axisName, positional = TRUE) { @@ -219,7 +219,8 @@ decodeplot.gg <- function(x, returnGrob = TRUE, ...) { y = .makeDecodedGuide("y", positional = TRUE), colour = .makeDecodedGuide("colour", positional = FALSE), fill = .makeDecodedGuide("fill", positional = FALSE), - shape = .makeDecodedGuide("shape", positional = FALSE) + shape = .makeDecodedGuide("shape", positional = FALSE), + linetype = .makeDecodedGuide("linetype", positional = FALSE) ) } if (returnGrob) { diff --git a/R/zzzWrappers.R b/R/zzzWrappers.R index 978d5547..94cc0cbc 100755 --- a/R/zzzWrappers.R +++ b/R/zzzWrappers.R @@ -352,7 +352,7 @@ jaspOutputObjR <- R6::R6Class( for (i in seq_along(x)) private$jaspObject$addCitation(x[i]) }, - toRObject = function() private$jaspObject$toRObject(), + toRObject = function() .decodeJaspRObject(private$jaspObject$toRObject()), toHtml = function() private$jaspObject$toHtml() ), active = list( @@ -362,6 +362,57 @@ jaspOutputObjR <- R6::R6Class( ) ) +.decodeJaspRObject <- function(x) { + if (is.null(x)) + return(x) + + if (inherits(x, "jaspPlotWrapper")) { + if (!is.null(x[["plotObject"]])) { + x[["plotObject"]] <- tryCatch( + decodeplot(x[["plotObject"]], returnGrob = FALSE), + error = function(e) x[["plotObject"]] + ) + } + return(.decodeJaspRObjectAttributes(x)) + } + + if (is.character(x)) + return(decodeColNames(x)) + + if (is.factor(x)) { + levels(x) <- decodeColNames(levels(x)) + return(x) + } + + if (is.data.frame(x)) { + for (name in names(x)) + x[[name]] <- .decodeJaspRObject(x[[name]]) + names(x) <- decodeColNames(names(x)) + return(.decodeJaspRObjectAttributes(x)) + } + + if (is.list(x)) { + for (i in seq_along(x)) + x[[i]] <- .decodeJaspRObject(x[[i]]) + names(x) <- decodeColNames(names(x)) + return(.decodeJaspRObjectAttributes(x)) + } + + .decodeJaspRObjectAttributes(x) +} + +.decodeJaspRObjectAttributes <- function(x) { + attributesToDecode <- setdiff( + names(attributes(x)), + c("class", "dim", "dimnames", "names", "row.names", "jaspObjectEnvironment") + ) + + for (attribute in attributesToDecode) + attr(x, attribute) <- .decodeJaspRObject(attr(x, attribute)) + + x +} + .jaspHtmlPixelizer <- function(maxWidth) { if(is.numeric(maxWidth)) return(paste0(as.character(maxWidth), "px")) return(maxWidth) diff --git a/tests/testthat/test-result-object-decoding.R b/tests/testthat/test-result-object-decoding.R new file mode 100644 index 00000000..a3ac6008 --- /dev/null +++ b/tests/testthat/test-result-object-decoding.R @@ -0,0 +1,104 @@ +localDecoder <- function(mapping) { + oldDecoder <- if (exists(".decodeColNamesLax", envir = .GlobalEnv, inherits = FALSE)) { + get(".decodeColNamesLax", envir = .GlobalEnv, inherits = FALSE) + } else { + NULL + } + hadDecoder <- exists(".decodeColNamesLax", envir = .GlobalEnv, inherits = FALSE) + + assign( + ".decodeColNamesLax", + function(x) { + for (encoded in names(mapping)) + x <- gsub(encoded, unname(mapping[[encoded]]), x, fixed = TRUE) + x + }, + envir = .GlobalEnv + ) + + function() { + if (hadDecoder) { + assign(".decodeColNamesLax", oldDecoder, envir = .GlobalEnv) + } else if (exists(".decodeColNamesLax", envir = .GlobalEnv, inherits = FALSE)) { + rm(".decodeColNamesLax", envir = .GlobalEnv) + } + } +} + +testthat::test_that("decodeplot.gg returns decoded labels for R-facing plots", { + restoreDecoder <- localDecoder(c( + JaspColumn_1_Encoded = "group", + JaspColumn_2_Encoded = "score" + )) + on.exit(restoreDecoder(), add = TRUE) + + plot <- ggplot2::ggplot( + data.frame(x = 1, y = 2), + ggplot2::aes(x = x, y = y) + ) + + ggplot2::geom_point() + + ggplot2::labs( + x = "JaspColumn_1_Encoded", + y = "JaspColumn_2_Encoded" + ) + + decoded <- jaspBase:::decodeplot(plot, returnGrob = FALSE) + + testthat::expect_equal(unname(decoded$labels$x), "group") + testthat::expect_equal(unname(decoded$labels$y), "score") +}) + +testthat::test_that("toRObject result copies decode tables, footnotes, and plots", { + restoreDecoder <- localDecoder(c( + JaspColumn_1_Encoded = "group", + JaspColumn_2_Encoded = "score", + JaspColumn_3_Encoded = "cluster" + )) + on.exit(restoreDecoder(), add = TRUE) + + table <- data.frame( + JaspColumn_1_Encoded = "JaspColumn_2_Encoded", + check.names = FALSE + ) + class(table) <- c("jaspTableWrapper", "jaspWrapper", class(table)) + attr(table, "title") <- "JaspColumn_1_Encoded table" + attr(table, "footnotes") <- list(list( + text = "The following variable is 'JaspColumn_3_Encoded'.", + symbol = "Note." + )) + + plot <- ggplot2::ggplot( + data.frame(x = 1, y = 2), + ggplot2::aes(x = x, y = y) + ) + + ggplot2::geom_point() + + ggplot2::labs( + x = "JaspColumn_1_Encoded", + y = "JaspColumn_2_Encoded" + ) + plotWrapper <- list(plotObject = plot) + class(plotWrapper) <- c("jaspPlotWrapper", "jaspWrapper") + attr(plotWrapper, "title") <- "JaspColumn_3_Encoded plot" + + result <- list( + JaspColumn_1_Encoded = table, + Plot = plotWrapper + ) + class(result) <- c("jaspContainerWrapper", "jaspWrapper") + attr(result, "title") <- "JaspColumn_1_Encoded results" + + decoded <- jaspBase:::.decodeJaspRObject(result) + + testthat::expect_equal(names(decoded), c("group", "Plot")) + testthat::expect_equal(names(decoded$group), "group") + testthat::expect_equal(decoded$group$group, "score") + testthat::expect_equal(attr(decoded$group, "title"), "group table") + testthat::expect_equal( + attr(decoded$group, "footnotes")[[1L]]$text, + "The following variable is 'cluster'." + ) + testthat::expect_equal(attr(decoded$Plot, "title"), "cluster plot") + testthat::expect_equal(unname(decoded$Plot$plotObject$labels$x), "group") + testthat::expect_equal(unname(decoded$Plot$plotObject$labels$y), "score") + testthat::expect_equal(attr(decoded, "title"), "group results") +}) From 8c4f861a4974701ec6e1aaa5f6b5c32f5334e812 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Tue, 26 May 2026 22:51:25 +0200 Subject: [PATCH 05/22] Expose result state decoding --- NAMESPACE | 1 + R/writeImage.R | 33 ++++++++++++++++++++ R/zzzWrappers.R | 8 ++--- man/decodeJaspResultState.Rd | 20 ++++++++++++ tests/testthat/test-result-object-decoding.R | 32 +++++++++++++++++++ 5 files changed, 88 insertions(+), 6 deletions(-) create mode 100644 man/decodeJaspResultState.Rd diff --git a/NAMESPACE b/NAMESPACE index 12d68ae5..0219bd86 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -85,6 +85,7 @@ export(createJaspTable) export(createMixedColumn) export(createMixedRow) export(decodeColNames) +export(decodeJaspResultState) export(decodeName) export(encodeColNames) export(excludeNaListwise) diff --git a/R/writeImage.R b/R/writeImage.R index 4651de4b..3fe45234 100755 --- a/R/writeImage.R +++ b/R/writeImage.R @@ -297,6 +297,39 @@ decodeplot.function <- function(x, ...) { return(decodeplot.recordedplot(out)) } +#' Decode JASP Result State +#' +#' Decodes display-only plot objects stored in a JASP result state. This is +#' intended for R-facing result payloads that need the same decoded figure +#' objects as rendered JASP output, without changing backend/runtime state. +#' +#' @param state A JASP result state list, typically containing a `figures` +#' element. +#' +#' @return `state`, with decodable figure objects decoded. +#' @export +decodeJaspResultState <- function(state) { + if (!is.list(state) || is.null(state[["figures"]])) + return(state) + + for (figureIndex in seq_along(state[["figures"]])) { + figure <- state[["figures"]][[figureIndex]] + if (is.list(figure) && !is.null(figure[["obj"]])) { + figure[["obj"]] <- .decodeJaspPlotObject(figure[["obj"]]) + state[["figures"]][[figureIndex]] <- figure + } + } + + state +} + +.decodeJaspPlotObject <- function(plot) { + tryCatch( + decodeplot(plot, returnGrob = FALSE), + error = function(e) plot + ) +} + # Some functions that act as a bridge between R and JASP. If JASP isn't running then all columnNames are expected to not be encoded # Two convenience functions to encode/decode jasp column names. A custom encoder/decoder function may be supplied, otherwise a default is used. diff --git a/R/zzzWrappers.R b/R/zzzWrappers.R index 94cc0cbc..066f2e43 100755 --- a/R/zzzWrappers.R +++ b/R/zzzWrappers.R @@ -367,12 +367,8 @@ jaspOutputObjR <- R6::R6Class( return(x) if (inherits(x, "jaspPlotWrapper")) { - if (!is.null(x[["plotObject"]])) { - x[["plotObject"]] <- tryCatch( - decodeplot(x[["plotObject"]], returnGrob = FALSE), - error = function(e) x[["plotObject"]] - ) - } + if (!is.null(x[["plotObject"]])) + x[["plotObject"]] <- .decodeJaspPlotObject(x[["plotObject"]]) return(.decodeJaspRObjectAttributes(x)) } diff --git a/man/decodeJaspResultState.Rd b/man/decodeJaspResultState.Rd new file mode 100644 index 00000000..19120407 --- /dev/null +++ b/man/decodeJaspResultState.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/writeImage.R +\name{decodeJaspResultState} +\alias{decodeJaspResultState} +\title{Decode JASP Result State} +\usage{ +decodeJaspResultState(state) +} +\arguments{ +\item{state}{A JASP result state list, typically containing a \code{figures} +element.} +} +\value{ +\code{state}, with decodable figure objects decoded. +} +\description{ +Decodes display-only plot objects stored in a JASP result state. This is +intended for R-facing result payloads that need the same decoded figure +objects as rendered JASP output, without changing backend/runtime state. +} diff --git a/tests/testthat/test-result-object-decoding.R b/tests/testthat/test-result-object-decoding.R index a3ac6008..175d1f2a 100644 --- a/tests/testthat/test-result-object-decoding.R +++ b/tests/testthat/test-result-object-decoding.R @@ -102,3 +102,35 @@ testthat::test_that("toRObject result copies decode tables, footnotes, and plots testthat::expect_equal(unname(decoded$Plot$plotObject$labels$y), "score") testthat::expect_equal(attr(decoded, "title"), "group results") }) + +testthat::test_that("decodeJaspResultState decodes stored figure objects", { + restoreDecoder <- localDecoder(c( + JaspColumn_1_Encoded = "group", + JaspColumn_2_Encoded = "score" + )) + on.exit(restoreDecoder(), add = TRUE) + + plot <- ggplot2::ggplot( + data.frame(x = 1, y = 2), + ggplot2::aes(x = x, y = y) + ) + + ggplot2::geom_point() + + ggplot2::labs( + x = "JaspColumn_1_Encoded", + y = "JaspColumn_2_Encoded" + ) + state <- list( + figures = list( + "1.png" = list(obj = plot), + "2.png" = list(other = "JaspColumn_1_Encoded") + ), + other = list(label = "JaspColumn_2_Encoded") + ) + + decoded <- jaspBase::decodeJaspResultState(state) + + testthat::expect_equal(unname(decoded$figures[["1.png"]]$obj$labels$x), "group") + testthat::expect_equal(unname(decoded$figures[["1.png"]]$obj$labels$y), "score") + testthat::expect_identical(decoded$figures[["2.png"]]$other, "JaspColumn_1_Encoded") + testthat::expect_identical(decoded$other$label, "JaspColumn_2_Encoded") +}) From 507936ca5f714a8d946a428244f120bb4fdb28bd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Wed, 27 May 2026 09:12:03 +0200 Subject: [PATCH 06/22] Quiet direct wrapped analysis output --- R/common.R | 44 ++++++++++++++++++------ tests/testthat/test-runWrappedAnalysis.R | 27 +++++++++++++++ 2 files changed, 61 insertions(+), 10 deletions(-) diff --git a/R/common.R b/R/common.R index cadd1859..9b11abdf 100644 --- a/R/common.R +++ b/R/common.R @@ -1191,8 +1191,28 @@ storeDataSet <- function(dataset) { as.character(fs::path_norm(fs::path(find.package(moduleName), "qml", qmlFileName))) } +.runWrappedAnalysisQuietly <- function(expr, quiet) { + if (isTRUE(quiet)) { + outputFile <- tempfile("jaspBase-runWrappedAnalysis-") + outputConnection <- file(outputFile, open = "wt") + outputSink <- sink.number(type = "output") + on.exit({ + while (sink.number(type = "output") > outputSink) + sink(type = "output") + close(outputConnection) + unlink(outputFile) + }, add = TRUE) + + sink(outputConnection, type = "output") + return(suppressWarnings(suppressMessages(expr))) + } + + expr +} + #' @export -runWrappedAnalysis <- function(moduleName, analysisName, qmlFileName, options, version, preloadData, modulePath = NULL, qmlFile = NULL) { +runWrappedAnalysis <- function(moduleName, analysisName, qmlFileName, options, version, preloadData, modulePath = NULL, qmlFile = NULL, + quiet = getOption("jaspBase.runWrappedAnalysis.quiet", TRUE)) { if (jaspResultsCalledFromJasp()) { # In this case, it is JASP Desktop that called the wrapper. This was done to parse the R code, and to get the arguments # in a structured way. In this way the Desktop can then set the options to the QML controls of the form, and this will run the analysis. @@ -1214,18 +1234,22 @@ runWrappedAnalysis <- function(moduleName, analysisName, qmlFileName, options, v return(toJSON(response)) } else { - # The wrapper is called inside an R environment (R Studio probably). - # The options must be parsed and checked by the QML form, and then the real analysis can be called. - qmlFile <- .wrappedAnalysisQmlFile(moduleName, qmlFileName, modulePath, qmlFile) - # Load the qml form, and set the right options (formula should be parsed and all logics set in QML should be checked), and run the analysis - options <- jaspSyntax::loadQmlAndParseOptions(moduleName, analysisName, qmlFile, as.character(toJSON(options)), version, preloadData) + runWrapped <- function() { + # The wrapper is called inside an R environment (R Studio probably). + # The options must be parsed and checked by the QML form, and then the real analysis can be called. + qmlFile <- .wrappedAnalysisQmlFile(moduleName, qmlFileName, modulePath, qmlFile) + # Load the qml form, and set the right options (formula should be parsed and all logics set in QML should be checked), and run the analysis + options <- jaspSyntax::loadQmlAndParseOptions(moduleName, analysisName, qmlFile, as.character(toJSON(options)), version, preloadData) + + if (options == "") + stop("Error when parsing the options") - if (options == "") - stop("Error when parsing the options") + internalAnalysisName <- paste0(moduleName, "::", analysisName, "Internal") - internalAnalysisName <- paste0(moduleName, "::", analysisName, "Internal") + return(runJaspResults(name=internalAnalysisName, title=analysisName, dataKey="{}", options=options, stateKey="{}", functionCall=internalAnalysisName, preloadData=preloadData)) + } - return(runJaspResults(name=internalAnalysisName, title=analysisName, dataKey="{}", options=options, stateKey="{}", functionCall=internalAnalysisName, preloadData=preloadData)) + return(.runWrappedAnalysisQuietly(runWrapped(), quiet = quiet)) } } diff --git a/tests/testthat/test-runWrappedAnalysis.R b/tests/testthat/test-runWrappedAnalysis.R index af80cc23..7bb8f55f 100644 --- a/tests/testthat/test-runWrappedAnalysis.R +++ b/tests/testthat/test-runWrappedAnalysis.R @@ -27,6 +27,33 @@ testthat::test_that("wrapped analysis QML paths resolve checkout module paths", testthat::expect_equal(qmlFile, as.character(fs::path_norm(qmlPath))) }) +testthat::test_that("wrapped analysis quiet mode suppresses raw R chatter", { + noisyValue <- function() { + cat("raw module output\n") + message("raw module message") + warning("raw module warning", call. = FALSE) + 42 + } + + testthat::expect_silent( + testthat::expect_equal( + jaspBase:::.runWrappedAnalysisQuietly(noisyValue(), quiet = TRUE), + 42 + ) + ) + + testthat::expect_output( + testthat::expect_message( + testthat::expect_warning( + jaspBase:::.runWrappedAnalysisQuietly(noisyValue(), quiet = FALSE), + "raw module warning" + ), + "raw module message" + ), + "raw module output" + ) +}) + testthat::test_that("standalone bridge can read the full dataset callback", { oldCallback <- if (exists(".readFullDatasetToEnd", envir = .GlobalEnv, inherits = FALSE)) { get(".readFullDatasetToEnd", envir = .GlobalEnv, inherits = FALSE) From 8ff17b10c99cfd53e5b960d5b2162baf4fce1e14 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Wed, 27 May 2026 09:42:38 +0200 Subject: [PATCH 07/22] Add wrapped analysis verbosity levels --- R/common.R | 58 +++++++++++++++++++++--- tests/testthat/test-runWrappedAnalysis.R | 57 +++++++++++++++++++---- 2 files changed, 100 insertions(+), 15 deletions(-) diff --git a/R/common.R b/R/common.R index 9b11abdf..8db3f8d8 100644 --- a/R/common.R +++ b/R/common.R @@ -1191,8 +1191,48 @@ storeDataSet <- function(dataset) { as.character(fs::path_norm(fs::path(find.package(moduleName), "qml", qmlFileName))) } -.runWrappedAnalysisQuietly <- function(expr, quiet) { - if (isTRUE(quiet)) { +.normalizeRunWrappedAnalysisVerbose <- 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) +} + +.runWrappedAnalysisShowsAnalysis <- function(verbose) { + verbose %in% c("all", "analysis") +} + +.runWrappedAnalysisShowsJasp <- function(verbose) { + verbose %in% c("all", "jasp") +} + +.runWrappedAnalysisWithVerbosity <- function(expr, verbose = "analysis") { + verbose <- .normalizeRunWrappedAnalysisVerbose(verbose) + showAnalysis <- .runWrappedAnalysisShowsAnalysis(verbose) + showJasp <- .runWrappedAnalysisShowsJasp(verbose) + + if (!showJasp) { outputFile <- tempfile("jaspBase-runWrappedAnalysis-") outputConnection <- file(outputFile, open = "wt") outputSink <- sink.number(type = "output") @@ -1204,15 +1244,18 @@ storeDataSet <- function(dataset) { }, add = TRUE) sink(outputConnection, type = "output") - return(suppressWarnings(suppressMessages(expr))) } - expr + if (showAnalysis) + return(expr) + + suppressWarnings(suppressMessages(expr)) } #' @export runWrappedAnalysis <- function(moduleName, analysisName, qmlFileName, options, version, preloadData, modulePath = NULL, qmlFile = NULL, - quiet = getOption("jaspBase.runWrappedAnalysis.quiet", TRUE)) { + quiet = getOption("jaspBase.runWrappedAnalysis.quiet", NULL), + verbose = getOption("jaspBase.runWrappedAnalysis.verbose", NULL)) { if (jaspResultsCalledFromJasp()) { # In this case, it is JASP Desktop that called the wrapper. This was done to parse the R code, and to get the arguments # in a structured way. In this way the Desktop can then set the options to the QML controls of the form, and this will run the analysis. @@ -1234,6 +1277,9 @@ runWrappedAnalysis <- function(moduleName, analysisName, qmlFileName, options, v return(toJSON(response)) } else { + verbose <- .normalizeRunWrappedAnalysisVerbose(verbose, quiet = quiet) + jaspSyntax::setParameter("verbose", .runWrappedAnalysisShowsJasp(verbose)) + runWrapped <- function() { # The wrapper is called inside an R environment (R Studio probably). # The options must be parsed and checked by the QML form, and then the real analysis can be called. @@ -1249,7 +1295,7 @@ runWrappedAnalysis <- function(moduleName, analysisName, qmlFileName, options, v return(runJaspResults(name=internalAnalysisName, title=analysisName, dataKey="{}", options=options, stateKey="{}", functionCall=internalAnalysisName, preloadData=preloadData)) } - return(.runWrappedAnalysisQuietly(runWrapped(), quiet = quiet)) + return(.runWrappedAnalysisWithVerbosity(runWrapped(), verbose = verbose)) } } diff --git a/tests/testthat/test-runWrappedAnalysis.R b/tests/testthat/test-runWrappedAnalysis.R index 7bb8f55f..af6f78ab 100644 --- a/tests/testthat/test-runWrappedAnalysis.R +++ b/tests/testthat/test-runWrappedAnalysis.R @@ -27,17 +27,17 @@ testthat::test_that("wrapped analysis QML paths resolve checkout module paths", testthat::expect_equal(qmlFile, as.character(fs::path_norm(qmlPath))) }) -testthat::test_that("wrapped analysis quiet mode suppresses raw R chatter", { +testthat::test_that("wrapped analysis verbosity separates analysis and JASP chatter", { noisyValue <- function() { - cat("raw module output\n") - message("raw module message") - warning("raw module warning", call. = FALSE) + cat("jasp bridge output\n") + message("analysis message") + warning("analysis warning", call. = FALSE) 42 } testthat::expect_silent( testthat::expect_equal( - jaspBase:::.runWrappedAnalysisQuietly(noisyValue(), quiet = TRUE), + jaspBase:::.runWrappedAnalysisWithVerbosity(noisyValue(), verbose = "none"), 42 ) ) @@ -45,12 +45,51 @@ testthat::test_that("wrapped analysis quiet mode suppresses raw R chatter", { testthat::expect_output( testthat::expect_message( testthat::expect_warning( - jaspBase:::.runWrappedAnalysisQuietly(noisyValue(), quiet = FALSE), - "raw module warning" + jaspBase:::.runWrappedAnalysisWithVerbosity(noisyValue(), verbose = "analysis"), + "analysis warning" ), - "raw module message" + "analysis message" ), - "raw module output" + NA + ) + + testthat::expect_output( + testthat::expect_warning( + testthat::expect_message( + testthat::expect_equal( + jaspBase:::.runWrappedAnalysisWithVerbosity(noisyValue(), verbose = "jasp"), + 42 + ), + NA + ), + NA + ), + "jasp bridge output" + ) + + testthat::expect_output( + testthat::expect_message( + testthat::expect_warning( + jaspBase:::.runWrappedAnalysisWithVerbosity(noisyValue(), verbose = "all"), + "analysis warning" + ), + "analysis message" + ), + "jasp bridge output" + ) +}) + +testthat::test_that("wrapped analysis verbosity normalizes legacy quiet options", { + testthat::expect_equal(jaspBase:::.normalizeRunWrappedAnalysisVerbose(NULL), "analysis") + testthat::expect_equal(jaspBase:::.normalizeRunWrappedAnalysisVerbose(NULL, quiet = TRUE), "analysis") + testthat::expect_equal(jaspBase:::.normalizeRunWrappedAnalysisVerbose(NULL, quiet = FALSE), "all") + testthat::expect_equal(jaspBase:::.normalizeRunWrappedAnalysisVerbose(TRUE), "all") + testthat::expect_equal(jaspBase:::.normalizeRunWrappedAnalysisVerbose(FALSE), "none") + testthat::expect_equal(jaspBase:::.normalizeRunWrappedAnalysisVerbose("jasp"), "jasp") + testthat::expect_equal(jaspBase:::.normalizeRunWrappedAnalysisVerbose("off"), "none") + testthat::expect_error( + jaspBase:::.normalizeRunWrappedAnalysisVerbose("loud"), + "`verbose` must be one of" ) }) From 972e5376cbceeb0d827ff16dfe28bda961ff8159 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Wed, 27 May 2026 09:58:50 +0200 Subject: [PATCH 08/22] Decode wrapped analysis conditions --- R/common.R | 69 +++++++++++++++++++++++- tests/testthat/test-runWrappedAnalysis.R | 47 ++++++++++++++++ 2 files changed, 115 insertions(+), 1 deletion(-) diff --git a/R/common.R b/R/common.R index 8db3f8d8..0cec03e3 100644 --- a/R/common.R +++ b/R/common.R @@ -1227,6 +1227,73 @@ storeDataSet <- function(dataset) { verbose %in% c("all", "jasp") } +.decodeRunWrappedAnalysisConditionMessage <- function(condition) { + message <- conditionMessage(condition) + if (!is.character(message) || length(message) != 1L || is.na(message) || !nzchar(message)) + return(message) + + decoded <- tryCatch( + decodeColNames(message, strict = FALSE), + error = function(e) message + ) + if (!is.character(decoded) || length(decoded) != 1L || is.na(decoded)) + return(message) + + decoded +} + +.decodeRunWrappedAnalysisCondition <- function(condition) { + decodedMessage <- .decodeRunWrappedAnalysisConditionMessage(condition) + if (identical(decodedMessage, conditionMessage(condition))) + return(condition) + + if (is.list(condition) && "message" %in% names(condition)) { + condition[["message"]] <- decodedMessage + return(condition) + } + + simpleError(decodedMessage, call = conditionCall(condition)) +} + +.runWrappedAnalysisWithDecodedConditions <- function(expr) { + replayingCondition <- FALSE + + tryCatch( + withCallingHandlers( + expr, + message = function(messageCondition) { + if (isTRUE(replayingCondition)) + return() + + decodedMessage <- .decodeRunWrappedAnalysisConditionMessage(messageCondition) + if (identical(decodedMessage, conditionMessage(messageCondition))) + return() + + replayingCondition <<- TRUE + on.exit(replayingCondition <<- FALSE, add = TRUE) + message(decodedMessage, appendLF = !grepl("\n$", decodedMessage)) + tryInvokeRestart("muffleMessage") + }, + warning = function(warningCondition) { + if (isTRUE(replayingCondition)) + return() + + decodedMessage <- .decodeRunWrappedAnalysisConditionMessage(warningCondition) + if (identical(decodedMessage, conditionMessage(warningCondition))) + return() + + replayingCondition <<- TRUE + on.exit(replayingCondition <<- FALSE, add = TRUE) + warning(decodedMessage, call. = FALSE) + tryInvokeRestart("muffleWarning") + } + ), + error = function(errorCondition) { + stop(.decodeRunWrappedAnalysisCondition(errorCondition)) + } + ) +} + .runWrappedAnalysisWithVerbosity <- function(expr, verbose = "analysis") { verbose <- .normalizeRunWrappedAnalysisVerbose(verbose) showAnalysis <- .runWrappedAnalysisShowsAnalysis(verbose) @@ -1247,7 +1314,7 @@ storeDataSet <- function(dataset) { } if (showAnalysis) - return(expr) + return(.runWrappedAnalysisWithDecodedConditions(expr)) suppressWarnings(suppressMessages(expr)) } diff --git a/tests/testthat/test-runWrappedAnalysis.R b/tests/testthat/test-runWrappedAnalysis.R index af6f78ab..6192a09f 100644 --- a/tests/testthat/test-runWrappedAnalysis.R +++ b/tests/testthat/test-runWrappedAnalysis.R @@ -93,6 +93,53 @@ testthat::test_that("wrapped analysis verbosity normalizes legacy quiet options" ) }) +testthat::test_that("wrapped analysis verbosity decodes analysis conditions", { + oldDecoder <- if (exists(".decodeColNamesLax", envir = .GlobalEnv, inherits = FALSE)) { + get(".decodeColNamesLax", envir = .GlobalEnv, inherits = FALSE) + } else { + NULL + } + hadDecoder <- exists(".decodeColNamesLax", envir = .GlobalEnv, inherits = FALSE) + on.exit({ + if (hadDecoder) { + assign(".decodeColNamesLax", oldDecoder, envir = .GlobalEnv) + } else if (exists(".decodeColNamesLax", envir = .GlobalEnv, inherits = FALSE)) { + rm(".decodeColNamesLax", envir = .GlobalEnv) + } + }, add = TRUE) + + assign( + ".decodeColNamesLax", + function(x) gsub("JaspColumn_3_Encoded", "angle", x, fixed = TRUE), + envir = .GlobalEnv + ) + + noisyValue <- function() { + message("analysis message: JaspColumn_3_Encoded") + warning("analysis warning: JaspColumn_3_Encoded", call. = FALSE) + 42 + } + + testthat::expect_output( + testthat::expect_message( + testthat::expect_warning( + jaspBase:::.runWrappedAnalysisWithVerbosity(noisyValue(), verbose = "analysis"), + "analysis warning: angle" + ), + "analysis message: angle" + ), + NA + ) + + testthat::expect_error( + jaspBase:::.runWrappedAnalysisWithVerbosity( + stop("analysis error: JaspColumn_3_Encoded", call. = FALSE), + verbose = "analysis" + ), + "analysis error: angle" + ) +}) + testthat::test_that("standalone bridge can read the full dataset callback", { oldCallback <- if (exists(".readFullDatasetToEnd", envir = .GlobalEnv, inherits = FALSE)) { get(".readFullDatasetToEnd", envir = .GlobalEnv, inherits = FALSE) From 745b5ddd2ddfb75773cbbc21a3158c11f847ca33 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Thu, 28 May 2026 08:52:58 +0200 Subject: [PATCH 09/22] Honor jaspSyntax verbosity defaults --- R/common.R | 2 +- tests/testthat/test-runWrappedAnalysis.R | 19 +++++++++++++++++++ 2 files changed, 20 insertions(+), 1 deletion(-) diff --git a/R/common.R b/R/common.R index 0cec03e3..cce4618e 100644 --- a/R/common.R +++ b/R/common.R @@ -1322,7 +1322,7 @@ storeDataSet <- function(dataset) { #' @export runWrappedAnalysis <- function(moduleName, analysisName, qmlFileName, options, version, preloadData, modulePath = NULL, qmlFile = NULL, quiet = getOption("jaspBase.runWrappedAnalysis.quiet", NULL), - verbose = getOption("jaspBase.runWrappedAnalysis.verbose", NULL)) { + verbose = getOption("jaspBase.runWrappedAnalysis.verbose", getOption("jaspSyntax.verbose", NULL))) { if (jaspResultsCalledFromJasp()) { # In this case, it is JASP Desktop that called the wrapper. This was done to parse the R code, and to get the arguments # in a structured way. In this way the Desktop can then set the options to the QML controls of the form, and this will run the analysis. diff --git a/tests/testthat/test-runWrappedAnalysis.R b/tests/testthat/test-runWrappedAnalysis.R index 6192a09f..e535f241 100644 --- a/tests/testthat/test-runWrappedAnalysis.R +++ b/tests/testthat/test-runWrappedAnalysis.R @@ -93,6 +93,25 @@ testthat::test_that("wrapped analysis verbosity normalizes legacy quiet options" ) }) +testthat::test_that("wrapped analysis verbosity honors jaspSyntax default option", { + oldOptions <- options( + jaspBase.runWrappedAnalysis.verbose = NULL, + jaspSyntax.verbose = "none" + ) + on.exit(do.call(options, oldOptions), add = TRUE) + + testthat::expect_identical( + eval(formals(jaspBase::runWrappedAnalysis)$verbose), + "none" + ) + + options(jaspBase.runWrappedAnalysis.verbose = "jasp") + testthat::expect_identical( + eval(formals(jaspBase::runWrappedAnalysis)$verbose), + "jasp" + ) +}) + testthat::test_that("wrapped analysis verbosity decodes analysis conditions", { oldDecoder <- if (exists(".decodeColNamesLax", envir = .GlobalEnv, inherits = FALSE)) { get(".decodeColNamesLax", envir = .GlobalEnv, inherits = FALSE) From b96880c6678dbf0a8732aa3c2276d0e11615f774 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Thu, 28 May 2026 09:05:39 +0200 Subject: [PATCH 10/22] Print output wrappers as R objects --- NAMESPACE | 1 + R/zzzWrappers.R | 6 ++++++ tests/testthat/test-result-object-decoding.R | 20 ++++++++++++++++++++ 3 files changed, 27 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 0219bd86..ef2fe128 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -28,6 +28,7 @@ S3method(ifElse,integer) S3method(ifElse,numeric) S3method(ifElse,ordered) S3method(print,jaspObjR) +S3method(print,jaspOutputObjR) S3method(replaceNA,character) S3method(replaceNA,factor) S3method(replaceNA,numeric) diff --git a/R/zzzWrappers.R b/R/zzzWrappers.R index 066f2e43..86cc634a 100755 --- a/R/zzzWrappers.R +++ b/R/zzzWrappers.R @@ -307,6 +307,12 @@ jaspObjR <- R6::R6Class( print.jaspObjR <- function(x, ...) # TODO: print actual information depending on object type x$print() +#' @export +print.jaspOutputObjR <- function(x, ...) { + print(x$toRObject(), ...) + invisible(x) +} + jaspStateR <- R6::R6Class( classname = "jaspStateR", inherit = jaspObjR, diff --git a/tests/testthat/test-result-object-decoding.R b/tests/testthat/test-result-object-decoding.R index 175d1f2a..cb2b20d6 100644 --- a/tests/testthat/test-result-object-decoding.R +++ b/tests/testthat/test-result-object-decoding.R @@ -103,6 +103,26 @@ testthat::test_that("toRObject result copies decode tables, footnotes, and plots testthat::expect_equal(attr(decoded, "title"), "group results") }) +testthat::test_that("printing output wrappers shows the R-facing object", { + richResult <- list( + toRObject = function() list( + "ANOVA Summary" = data.frame( + effect = "angle", + stat = 21.89, + check.names = FALSE + ) + ), + print = function() stop("native wrapper print should not be used", domain = NA) + ) + class(richResult) <- c("jaspOutputObjR", "jaspObjR") + + printed <- capture.output(returned <- print(richResult)) + + testthat::expect_identical(returned, richResult) + testthat::expect_true(any(grepl("ANOVA Summary", printed, fixed = TRUE))) + testthat::expect_true(any(grepl("angle", printed, fixed = TRUE))) +}) + testthat::test_that("decodeJaspResultState decodes stored figure objects", { restoreDecoder <- localDecoder(c( JaspColumn_1_Encoded = "group", From 3aa96219bfaea49039b615cea701b9ec014bb096 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Thu, 28 May 2026 09:20:08 +0200 Subject: [PATCH 11/22] Pretty-print R-facing result wrappers --- NAMESPACE | 3 + R/zzzWrappers.R | 120 ++++++++++++++++++ tests/testthat/test-result-object-decoding.R | 127 +++++++++++++++++++ 3 files changed, 250 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index ef2fe128..700fe27f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -27,8 +27,11 @@ S3method(ifElse,factor) S3method(ifElse,integer) S3method(ifElse,numeric) S3method(ifElse,ordered) +S3method(print,jaspContainerWrapper) S3method(print,jaspObjR) S3method(print,jaspOutputObjR) +S3method(print,jaspPlotWrapper) +S3method(print,jaspTableWrapper) S3method(replaceNA,character) S3method(replaceNA,factor) S3method(replaceNA,numeric) diff --git a/R/zzzWrappers.R b/R/zzzWrappers.R index 86cc634a..d00b9a67 100755 --- a/R/zzzWrappers.R +++ b/R/zzzWrappers.R @@ -313,6 +313,126 @@ print.jaspOutputObjR <- function(x, ...) { invisible(x) } +.jaspWrapperTitle <- function(x) { + title <- attr(x, "title", exact = TRUE) + if (is.null(title) || !is.character(title) || length(title) == 0L) + return(NULL) + title[[1L]] +} + +.jaspWrapperHasTitle <- function(x) { + title <- .jaspWrapperTitle(x) + !is.null(title) && nzchar(title) +} + +.jaspWrapperPrintTitle <- function(x) { + title <- .jaspWrapperTitle(x) + if (!is.null(title) && nzchar(title)) + cat(title, "\n", sep = "") +} + +.jaspWrapperFormatName <- function(name) { + if (is.null(name) || !is.character(name) || length(name) == 0L || is.na(name[[1L]]) || !nzchar(name[[1L]])) + return("[[1]]") + + name <- name[[1L]] + if (make.names(name) == name) + return(name) + + paste0("`", gsub("`", "\\\\`", name, fixed = TRUE), "`") +} + +.jaspWrapperChildPath <- function(path, name, index = 1L) { + formattedName <- .jaspWrapperFormatName(name) + if (identical(formattedName, "[[1]]")) + return(paste0(path, "[[", index, "]]")) + + paste0(path, "$", formattedName) +} + +.jaspWrapperPlainDataFrame <- function(x) { + class(x) <- setdiff(class(x), c("jaspTableWrapper", "jaspWrapper")) + x +} + +.jaspWrapperHasPrintPath <- function(x) { + inherits(x, c("jaspContainerWrapper", "jaspTableWrapper", "jaspPlotWrapper")) +} + +.jaspWrapperStripHtml <- function(x) { + if (is.null(x) || !is.character(x) || length(x) == 0L) + return("") + + gsub("<[^>]+>", "", x[[1L]]) +} + +.jaspWrapperPrintFootnotes <- function(x) { + footnotes <- attr(x, "footnotes", exact = TRUE) + if (is.null(footnotes) || length(footnotes) == 0L) + return(invisible(NULL)) + + cat("\nFootnotes:\n") + for (footnote in footnotes) { + if (!is.list(footnote) || is.null(footnote[["text"]])) + next + + symbol <- .jaspWrapperStripHtml(footnote[["symbol"]]) + prefix <- if (nzchar(symbol)) paste0(symbol, " ") else "" + cat("- ", prefix, footnote[["text"]][[1L]], "\n", sep = "") + } + + invisible(NULL) +} + +#' @export +print.jaspContainerWrapper <- function(x, ..., path = "x") { + .jaspWrapperPrintTitle(x) + + childNames <- names(x) + for (i in seq_along(x)) { + if (i > 1L || .jaspWrapperHasTitle(x)) + cat("\n") + + childName <- if (!is.null(childNames) && length(childNames) >= i) childNames[[i]] else "" + childPath <- .jaspWrapperChildPath(path, childName, i) + if (.jaspWrapperHasPrintPath(x[[i]])) { + print(x[[i]], ..., path = childPath) + } else { + if (nzchar(childName)) + cat(childName, "\n", sep = "") + print(x[[i]], ...) + } + } + + invisible(x) +} + +#' @export +print.jaspTableWrapper <- function(x, ..., path = "x") { + .jaspWrapperPrintTitle(x) + cat("\n\n", sep = "") + print(.jaspWrapperPlainDataFrame(x), ...) + .jaspWrapperPrintFootnotes(x) + invisible(x) +} + +#' @export +print.jaspPlotWrapper <- function(x, ..., path = NULL, display = NULL) { + directPrint <- is.null(path) + if (is.null(display)) + display <- directPrint + if (directPrint) + path <- "x" + + .jaspWrapperPrintTitle(x) + cat("\n", sep = "") + + if (isTRUE(display) && !is.null(x[["plotObject"]])) + print(x[["plotObject"]], ...) + + invisible(x) +} + jaspStateR <- R6::R6Class( classname = "jaspStateR", inherit = jaspObjR, diff --git a/tests/testthat/test-result-object-decoding.R b/tests/testthat/test-result-object-decoding.R index cb2b20d6..2b27a830 100644 --- a/tests/testthat/test-result-object-decoding.R +++ b/tests/testthat/test-result-object-decoding.R @@ -123,6 +123,133 @@ testthat::test_that("printing output wrappers shows the R-facing object", { testthat::expect_true(any(grepl("angle", printed, fixed = TRUE))) }) +testthat::test_that("R-facing wrapper print methods are registered", { + testthat::expect_false(is.null(getS3method("print", "jaspContainerWrapper", optional = TRUE))) + testthat::expect_false(is.null(getS3method("print", "jaspTableWrapper", optional = TRUE))) + testthat::expect_false(is.null(getS3method("print", "jaspPlotWrapper", optional = TRUE))) +}) + +testthat::test_that("printing result wrappers keeps tables readable and plots compact", { + table <- data.frame( + effect = "angle", + stat = 21.89, + check.names = FALSE + ) + class(table) <- c("jaspTableWrapper", "jaspWrapper", class(table)) + attr(table, "title") <- "ANOVA Summary" + attr(table, "footnotes") <- list( + list( + text = "Model terms tested with Satterthwaite method.", + symbol = "Note." + ) + ) + attr(table, "jaspObjectEnvironment") <- new.env(parent = emptyenv()) + + plotWrapper <- list(plotObject = NULL) + class(plotWrapper) <- c("jaspPlotWrapper", "jaspWrapper") + attr(plotWrapper, "title") <- "Plot" + attr(plotWrapper, "jaspObjectEnvironment") <- new.env(parent = emptyenv()) + + result <- list( + "ANOVA Summary" = table, + Plot = plotWrapper + ) + class(result) <- c("jaspContainerWrapper", "jaspWrapper") + attr(result, "title") <- "MixedModelsLMM" + before <- result + + printed <- capture.output(returned <- print(result)) + + testthat::expect_identical(returned, result) + testthat::expect_identical(result, before) + testthat::expect_true(any(grepl("MixedModelsLMM", printed, fixed = TRUE))) + testthat::expect_true(any(grepl("ANOVA Summary", printed, fixed = TRUE))) + testthat::expect_true(any(grepl( + "", + printed, + fixed = TRUE + ))) + testthat::expect_true(any(grepl("angle", printed, fixed = TRUE))) + testthat::expect_true(any(grepl("Footnotes:", printed, fixed = TRUE))) + testthat::expect_true(any(grepl("Note. Model terms tested", printed, fixed = TRUE))) + testthat::expect_true(any(grepl( + "", + printed, + fixed = TRUE + ))) + testthat::expect_false(any(printed == "$plotObject")) + testthat::expect_false(any(grepl("jaspObjectEnvironment", printed, fixed = TRUE))) +}) + +testthat::test_that("table wrapper printing forwards data-frame options", { + table <- data.frame( + effect = "angle", + stat = 21.89, + check.names = FALSE + ) + class(table) <- c("jaspTableWrapper", "jaspWrapper", class(table)) + attr(table, "title") <- "ANOVA Summary" + attr(table, "footnotes") <- list() + + printed <- capture.output(returned <- print(table, row.names = FALSE)) + + testthat::expect_identical(returned, table) + testthat::expect_true(any(grepl( + "", + printed, + fixed = TRUE + ))) + testthat::expect_true(any(grepl("angle", printed, fixed = TRUE))) + testthat::expect_false(any(grepl("Footnotes:", printed, fixed = TRUE))) + testthat::expect_false(any(grepl("^1\\s+angle", printed))) +}) + +testthat::test_that("plot wrapper printing separates placeholders from rendering", { + plotWrapper <- list(plotObject = "dummy plot printed") + class(plotWrapper) <- c("jaspPlotWrapper", "jaspWrapper") + attr(plotWrapper, "title") <- "Plot" + + suppressed <- capture.output(returned <- print(plotWrapper, display = FALSE)) + + testthat::expect_identical(returned, plotWrapper) + testthat::expect_true(any(grepl( + "", + suppressed, + fixed = TRUE + ))) + testthat::expect_false(any(grepl("dummy plot printed", suppressed, fixed = TRUE))) + + rendered <- capture.output(print(plotWrapper)) + testthat::expect_true(any(grepl("dummy plot printed", rendered, fixed = TRUE))) +}) + +testthat::test_that("container wrapper printing formats nested paths and protects non-JASP children", { + plotWrapper <- list(plotObject = NULL) + class(plotWrapper) <- c("jaspPlotWrapper", "jaspWrapper") + attr(plotWrapper, "title") <- "Plot" + + section <- list(Plot = plotWrapper) + class(section) <- c("jaspContainerWrapper", "jaspWrapper") + attr(section, "title") <- "Section" + + result <- list( + Section = section, + Other = "plain child" + ) + class(result) <- c("jaspContainerWrapper", "jaspWrapper") + attr(result, "title") <- "MixedModelsLMM" + + printed <- capture.output(returned <- print(result)) + + testthat::expect_identical(returned, result) + testthat::expect_true(any(grepl( + "", + printed, + fixed = TRUE + ))) + testthat::expect_true(any(grepl("plain child", printed, fixed = TRUE))) +}) + testthat::test_that("decodeJaspResultState decodes stored figure objects", { restoreDecoder <- localDecoder(c( JaspColumn_1_Encoded = "group", From 310db3988e7ed8e87d25297955588ef8024b3127 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Fri, 29 May 2026 15:17:29 +0200 Subject: [PATCH 12/22] Eagerly materialize decoded result state --- NAMESPACE | 1 - R/common.R | 14 +- R/resultDecoding.R | 265 +++++++++++++++++++ R/writeImage.R | 119 ++++----- R/zzzWrappers.R | 57 ++-- man/decodeJaspResultState.Rd | 20 -- src/jaspPlot.cpp | 6 +- tests/testthat/test-result-object-decoding.R | 143 ++++++++-- 8 files changed, 487 insertions(+), 138 deletions(-) create mode 100644 R/resultDecoding.R delete mode 100644 man/decodeJaspResultState.Rd diff --git a/NAMESPACE b/NAMESPACE index 700fe27f..40acbeba 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -89,7 +89,6 @@ export(createJaspTable) export(createMixedColumn) export(createMixedRow) export(decodeColNames) -export(decodeJaspResultState) export(decodeName) export(encodeColNames) export(excludeNaListwise) diff --git a/R/common.R b/R/common.R index cce4618e..2d6bc925 100644 --- a/R/common.R +++ b/R/common.R @@ -33,13 +33,15 @@ loadJaspResults <- function(name) { finishJaspResults <- function(jaspResultsCPP, calledFromAnalysis = TRUE) { jaspResultsCPP$prepareForWriting() + decodeContext <- .currentJaspDecodeContext() newState <- list( figures = jaspResultsCPP$getPlotObjectsForState(), other = jaspResultsCPP$getOtherObjectsForState() ) + newState <- .decodeJaspResultState(newState, decodeContext = decodeContext) - jaspResultsCPP$relativePathKeep <- .saveState(newState)$relativePath + jaspResultsCPP$relativePathKeep <- .saveState(newState, decodeContext = decodeContext)$relativePath returnThis <- NULL if (calledFromAnalysis) { @@ -676,12 +678,14 @@ jaspResultsStrings <- function() { location$relativePath } -.saveState <- function(state) { +.saveState <- function(state, decodeContext = NULL) { location <- .fromRCPP(".requestStateFileNameNative") relativePath <- location$relativePath statePath <- .stateFilePath(location) fs::dir_create(fs::path_dir(statePath)) + state <- .decodeJaspResultState(state, decodeContext = decodeContext) + try(suppressWarnings(base::save(state, file=statePath, compress=FALSE)), silent = FALSE) return(list(relativePath = relativePath)) @@ -832,7 +836,7 @@ saveImage <- function(plotName, format, height, width) state <- .retrieveState() # Retrieve plot object from state plt <- state[["figures"]][[plotName]][["obj"]] - plt <- decodeplot(plt); + plt <- .decodeJaspPlotObject(plt, returnGrob = FALSE); location <- .fromRCPP(".requestTempFileNameNative", "png") # create file location string to extract the root location backgroundColor <- .fromRCPP(".imageBackground") @@ -1227,13 +1231,13 @@ storeDataSet <- function(dataset) { verbose %in% c("all", "jasp") } -.decodeRunWrappedAnalysisConditionMessage <- function(condition) { +.decodeRunWrappedAnalysisConditionMessage <- function(condition, decodeContext = NULL) { message <- conditionMessage(condition) if (!is.character(message) || length(message) != 1L || is.na(message) || !nzchar(message)) return(message) decoded <- tryCatch( - decodeColNames(message, strict = FALSE), + .decodeJaspText(message, decodeContext = decodeContext), error = function(e) message ) if (!is.character(decoded) || length(decoded) != 1L || is.na(decoded)) diff --git a/R/resultDecoding.R b/R/resultDecoding.R new file mode 100644 index 00000000..c1e4b600 --- /dev/null +++ b/R/resultDecoding.R @@ -0,0 +1,265 @@ +.jaspDecodeContext <- function(columns = character(), factors = list(), source = "manual") { + columns <- .normalizeJaspColumnMapping(columns) + factors <- .normalizeJaspFactorMappings(factors, columns) + + list( + version = 1L, + columns = columns, + factors = factors, + source = source, + warningState = new.env(parent = emptyenv()) + ) +} + +.serializableJaspDecodeContext <- function(decodeContext) { + decodeContext <- .normalizeJaspDecodeContext(decodeContext) + list( + version = decodeContext[["version"]], + columns = decodeContext[["columns"]], + factors = decodeContext[["factors"]], + source = decodeContext[["source"]] + ) +} + +.currentJaspDecodeContext <- function() { + columnMapping <- character() + requestedDataset <- NULL + + if (requireNamespace("jaspSyntax", quietly = TRUE)) { + columnMapping <- tryCatch( + getExportedValue("jaspSyntax", "columnMapping")(strict = FALSE), + error = function(e) character() + ) + requestedDataset <- tryCatch( + getExportedValue("jaspSyntax", "readRequestedDataset")(decode = FALSE, normalize = FALSE), + error = function(e) NULL + ) + } + + .jaspDecodeContext( + columns = columnMapping, + factors = .jaspFactorMappingsFromDataset(requestedDataset, columnMapping), + source = "jaspSyntax" + ) +} + +.normalizeJaspDecodeContext <- function(decodeContext = NULL) { + if (is.null(decodeContext)) + return(.currentJaspDecodeContext()) + + decodeContext[["columns"]] <- .normalizeJaspColumnMapping(decodeContext[["columns"]]) + decodeContext[["factors"]] <- .normalizeJaspFactorMappings(decodeContext[["factors"]], decodeContext[["columns"]]) + if (is.null(decodeContext[["version"]])) + decodeContext[["version"]] <- 1L + if (is.null(decodeContext[["source"]])) + decodeContext[["source"]] <- "unknown" + if (!is.environment(decodeContext[["warningState"]])) + decodeContext[["warningState"]] <- new.env(parent = emptyenv()) + + decodeContext +} + +.normalizeJaspColumnMapping <- function(columnMapping = NULL) { + if (is.null(columnMapping) || length(columnMapping) == 0L) + return(stats::setNames(character(), character())) + if (!is.character(columnMapping) || is.null(names(columnMapping))) + return(stats::setNames(character(), character())) + + valid <- !is.na(columnMapping) & nzchar(columnMapping) & + !is.na(names(columnMapping)) & nzchar(names(columnMapping)) + columnMapping[valid] +} + +.normalizeJaspFactorMappings <- function(factorMappings = NULL, columnMapping = character()) { + if (is.null(factorMappings) || length(factorMappings) == 0L) + return(list()) + + normalized <- list() + for (fieldName in names(factorMappings)) { + if (!.isNonEmptyString(fieldName)) + next + + valueMap <- factorMappings[[fieldName]] + if (is.list(valueMap) && !is.null(valueMap[["levels"]])) + valueMap <- valueMap[["levels"]] + if (!is.character(valueMap) || is.null(names(valueMap))) + next + + valid <- !is.na(valueMap) & !is.na(names(valueMap)) & nzchar(names(valueMap)) + valueMap <- valueMap[valid] + valueMap <- .decodeJaspColumnText(valueMap, columnMapping) + if (length(valueMap) == 0L) + next + + aliases <- unique(c( + fieldName, + .decodeJaspColumnText(fieldName, columnMapping), + names(columnMapping)[!is.na(columnMapping) & columnMapping == fieldName] + )) + aliases <- aliases[!is.na(aliases) & nzchar(aliases)] + for (alias in aliases) + normalized[[alias]] <- valueMap + } + + normalized +} + +.jaspFactorMappingsFromDataset <- function(requestedDataset, columnMapping = character()) { + if (!is.data.frame(requestedDataset)) + return(list()) + + factorMappings <- list() + for (columnName in names(requestedDataset)) { + column <- requestedDataset[[columnName]] + if (!is.factor(column)) + next + + factorMappings[[columnName]] <- stats::setNames( + as.character(levels(column)), + as.character(seq_along(levels(column))) + ) + } + + .normalizeJaspFactorMappings(factorMappings, columnMapping) +} + +.jaspEncodedColumnTokenPattern <- function() "(JaspColumn_[[:alnum:]_]+_Encoded|jaspColumn[0-9]+)" + +.containsJaspEncodedTokens <- function(x) { + if (!is.character(x) || length(x) == 0L) + return(FALSE) + any(grepl(.jaspEncodedColumnTokenPattern(), x, perl = TRUE), na.rm = TRUE) +} + +.decodeJaspColumnText <- function(x, columnMapping = character()) { + if (!is.character(x) || length(x) == 0L || length(columnMapping) == 0L) + return(x) + + for (encoded in names(columnMapping)) + x <- gsub(encoded, unname(columnMapping[[encoded]]), x, fixed = TRUE) + + x +} + +.decodeJaspFactorValues <- function(x, fieldName = NULL, decodeContext) { + if (is.null(fieldName) || length(fieldName) != 1L || is.na(fieldName) || !nzchar(fieldName)) + return(x) + + candidateFields <- unique(c( + fieldName, + .decodeJaspColumnText(fieldName, decodeContext[["columns"]]) + )) + candidateFields <- candidateFields[!is.na(candidateFields) & nzchar(candidateFields)] + + valueMap <- NULL + for (candidateField in candidateFields) { + valueMap <- decodeContext[["factors"]][[candidateField]] + if (!is.null(valueMap)) + break + } + if (is.null(valueMap)) + return(x) + + keys <- as.character(x) + matched <- !is.na(keys) & keys %in% names(valueMap) + if (!any(matched)) + return(x) + + out <- as.character(x) + out[matched] <- unname(valueMap[keys[matched]]) + out +} + +.warnIfMissingJaspDecodeContext <- function(x, decodeContext) { + if (!.containsJaspEncodedTokens(x)) + return(invisible(NULL)) + if (isTRUE(decodeContext[["warningState"]][["missingContext"]])) + return(invisible(NULL)) + + decodeContext[["warningState"]][["missingContext"]] <- TRUE + warning( + "JASP result output still contains encoded column tokens, but no analysis decode context was available. ", + "This should only happen for legacy or externally constructed state.", + call. = FALSE + ) + invisible(NULL) +} + +.decodeJaspText <- function(x, decodeContext = NULL, fieldName = NULL) { + if (!is.character(x) || length(x) == 0L) + return(x) + + decodeContext <- .normalizeJaspDecodeContext(decodeContext) + x <- .decodeJaspFactorValues(x, fieldName = fieldName, decodeContext = decodeContext) + x <- .decodeJaspColumnText(x, decodeContext[["columns"]]) + + if (length(decodeContext[["columns"]]) == 0L) { + fallback <- tryCatch( + decodeColNames(x, strict = FALSE), + error = function(e) x + ) + if (is.character(fallback) && length(fallback) == length(x)) + x <- fallback + } + + .warnIfMissingJaspDecodeContext(x, decodeContext) + x +} + +.isJaspDecodedPlotObject <- function(x) { + isTRUE(attr(x, "jaspDecodedResultObject", exact = TRUE)) +} + +.markJaspDecodedPlotObject <- function(x) { + attr(x, "jaspDecodedResultObject") <- TRUE + x +} + +.decodeJaspResultState <- function(state, decodeContext = NULL) { + decodeContext <- .normalizeJaspDecodeContext(decodeContext) + if (!is.list(state) || is.null(state[["figures"]])) + return(.decodeJaspRObject(state, decodeContext = decodeContext)) + + for (figureIndex in seq_along(state[["figures"]])) { + figure <- state[["figures"]][[figureIndex]] + if (is.list(figure)) { + if (!is.null(figure[["obj"]])) + figure[["obj"]] <- .decodeJaspPlotObject(figure[["obj"]], returnGrob = FALSE, decodeContext = decodeContext) + otherFields <- setdiff(names(figure), "obj") + for (field in otherFields) + figure[[field]] <- .decodeJaspRObject(figure[[field]], fieldName = field, decodeContext = decodeContext) + names(figure) <- .decodeJaspText(names(figure), decodeContext = decodeContext) + state[["figures"]][[figureIndex]] <- figure + } + } + + if (!is.null(state[["other"]])) + state[["other"]] <- .decodeJaspRObject(state[["other"]], decodeContext = decodeContext) + + otherFields <- setdiff(names(state), c("figures", "other")) + for (field in otherFields) + state[[field]] <- .decodeJaspRObject(state[[field]], fieldName = field, decodeContext = decodeContext) + + names(state) <- .decodeJaspText(names(state), decodeContext = decodeContext) + state +} + +.decodeJaspPlotObject <- function(plot, returnGrob = FALSE, decodeContext = NULL) { + if (!isTRUE(returnGrob) && .isJaspDecodedPlotObject(plot)) + return(plot) + + decodeContext <- .normalizeJaspDecodeContext(decodeContext) + decodeFailed <- FALSE + decoded <- tryCatch( + decodeplot(plot, returnGrob = returnGrob, decodeContext = decodeContext), + error = function(e) { + decodeFailed <<- TRUE + plot + } + ) + + if (!isTRUE(returnGrob) && !isTRUE(decodeFailed)) + decoded <- .markJaspDecodedPlotObject(decoded) + + decoded +} diff --git a/R/writeImage.R b/R/writeImage.R index 3fe45234..9319d890 100755 --- a/R/writeImage.R +++ b/R/writeImage.R @@ -27,7 +27,7 @@ openGrDevice <- function(...) { } writeImageJaspResults <- function(plot, width = 320, height = 320, obj = TRUE, relativePathpng = NULL, relativePathJson = NULL, ppi = 300, backgroundColor = "white", - location = getImageLocation(), oldPlotInfo = list()) { + location = getImageLocation(), oldPlotInfo = list(), decodeContext = .currentJaspDecodeContext()) { # Set values from JASP'S Rcpp when available if (exists(".fromRCPP")) { location <- .fromRCPP(".requestTempFileNameNative", "png") @@ -79,7 +79,8 @@ writeImageJaspResults <- function(plot, width = 320, height = 320, obj = TRUE, r width <- width * (ppi / 96) height <- height * (ppi / 96) - plot2draw <- decodeplot(plot) + plotObject <- .decodeJaspPlotObject(plot, returnGrob = FALSE, decodeContext = decodeContext) + plot2draw <- plotObject openGrDevice(file = relativePathpng, width = width, height = height, res = 72 * (ppi / 96), background = backgroundColor)#, dpi = ppi) on.exit(grDevices::dev.off(), add = TRUE) @@ -117,16 +118,16 @@ writeImageJaspResults <- function(plot, width = 320, height = 320, obj = TRUE, r image[["png"]] <- relativePathpng if (obj) { - image[["obj"]] <- plot2draw + image[["obj"]] <- plotObject } - image[["editOptions"]] <- jaspGraphs::plotEditingOptions(plot, asJSON = TRUE) + image[["editOptions"]] <- jaspGraphs::plotEditingOptions(plotObject, asJSON = TRUE) - image[["interactive"]] <- ggplot2::is.ggplot(plot) || inherits(plot, "jaspMatrixPlot") + image[["interactive"]] <- ggplot2::is.ggplot(plotObject) || inherits(plotObject, "jaspMatrixPlot") if (image[["interactive"]] ) tryCatch( { - jsonOrTryError <- jaspGraphs::convertGgplotToPlotly(plot) + jsonOrTryError <- jaspGraphs::convertGgplotToPlotly(plotObject) if (exists(".fromRCPP")) { if (isTryError(jsonOrTryError)) { @@ -168,42 +169,46 @@ decodeplot <- function(x, ...) { # S3 methods must be registered (done by @export) so that jaspGraphs can call jaspBase:::decodeplot #' @export -decodeplot.jaspGraphsPlot <- function(x, ...) { +decodeplot.jaspGraphsPlot <- function(x, ..., decodeContext = NULL) { + decodeContext <- .normalizeJaspDecodeContext(decodeContext) for (i in seq_along(x$subplots)) - x$subplots[[i]] <- decodeplot(x$subplots[[i]], returnGrob = FALSE) + x$subplots[[i]] <- decodeplot(x$subplots[[i]], returnGrob = FALSE, decodeContext = decodeContext) return(x) } #' @export -decodeplot.gg <- function(x, returnGrob = TRUE, ...) { +decodeplot.gg <- function(x, returnGrob = TRUE, ..., decodeContext = NULL) { + decodeContext <- .normalizeJaspDecodeContext(decodeContext) # TODO: do not return a grid object! # we can do this by automatically replacing the scales and geoms, although this is quite a lot of work. # alternatively, those edge cases will need to be handled by the developer. labels <- x$labels # x[["labels"]] needs to be subsetted by `$`, not `[[`, as patchwork objects would fail if subsetting with `[[` for (i in seq_along(labels)) if (!is.null(labels[[i]])) - labels[[i]] <- decodeColNames(labels[[i]]) + labels[[i]] <- .decodeJaspText(labels[[i]], decodeContext = decodeContext) x$labels <- labels if (packageVersion("ggplot2") >= "4.0.0") { currentGuides <- x@guides + guideDecodeContext <- .serializableJaspDecodeContext(decodeContext) + decodeGuideTitle <- function(title) .decodeJaspText(title, decodeContext = guideDecodeContext) .makeDecodedGuide <- function(axisName, positional = TRUE) { existing <- currentGuides$guides[[axisName]] if (is.character(existing)) { - newTitle <- decodeColNames + newTitle <- decodeGuideTitle } else { title <- existing$params$title newTitle <- if (is.null(title) || ggplot2::is_waiver(title)) { - decodeColNames + decodeGuideTitle } else if (is.character(title)) { - decodeColNames(title) + decodeGuideTitle(title) } else if (is.function(title)) { - function(t) decodeColNames(title(t)) + function(t) decodeGuideTitle(title(t)) } else { - decodeColNames + decodeGuideTitle } } @@ -230,56 +235,71 @@ decodeplot.gg <- function(x, returnGrob = TRUE, ...) { if (file.exists(f)) file.remove(f) }) - return(decodeplot.gTree(ggplot2::ggplotGrob(x))) + return(decodeplot.gTree(ggplot2::ggplotGrob(x), decodeContext = decodeContext)) } else { return(x) } } #' @export -decodeplot.patchwork <- function(x, ...) { +decodeplot.patchwork <- function(x, ..., decodeContext = NULL) { + decodeContext <- .normalizeJaspDecodeContext(decodeContext) # the last plot in a patchwork is the "active" plot # and is essentially a ggplot (with some extras), # so we can decode it as such - x <- decodeplot.gg(x, returnGrob = FALSE) + x <- decodeplot.gg(x, returnGrob = FALSE, decodeContext = decodeContext) # but it also contains annotations, which need to be decoded in addition to the standard gg stuff - x$patches$annotation$title <- decodeColNames(x$patches$annotation$title ) - x$patches$annotation$subtitle <- decodeColNames(x$patches$annotation$subtitle) - x$patches$annotation$caption <- decodeColNames(x$patches$annotation$caption ) + x$patches$annotation$title <- .decodeJaspText(x$patches$annotation$title, decodeContext = decodeContext) + x$patches$annotation$subtitle <- .decodeJaspText(x$patches$annotation$subtitle, decodeContext = decodeContext) + x$patches$annotation$caption <- .decodeJaspText(x$patches$annotation$caption, decodeContext = decodeContext) # each subplot can be either a patchwork or a ggplot object - x$patches$plots <- lapply(x$patches$plots, decodeplot, returnGrob = FALSE) + x$patches$plots <- lapply(x$patches$plots, decodeplot, returnGrob = FALSE, decodeContext = decodeContext) return(x) } #' @export -decodeplot.recordedplot <- function(x, ...) { - decodeplot.gTree(grid::grid.grabExpr(gridGraphics::grid.echo(x))) +decodeplot.recordedplot <- function(x, ..., decodeContext = NULL) { + decodeplot.gTree(grid::grid.grabExpr(gridGraphics::grid.echo(x)), decodeContext = decodeContext) } #' @export -decodeplot.gtable <- function(x, ...) rapply(x, f = decodeColNames, classes = "character", how = "replace") +decodeplot.gtable <- function(x, ..., decodeContext = NULL) { + decodeContext <- .normalizeJaspDecodeContext(decodeContext) + rapply(x, f = function(text) .decodeJaspText(text, decodeContext = decodeContext), classes = "character", how = "replace") +} #' @export -decodeplot.grob <- function(x, ...) rapply(x, f = decodeColNames, classes = "character", how = "replace") +decodeplot.grob <- function(x, ..., decodeContext = NULL) { + decodeContext <- .normalizeJaspDecodeContext(decodeContext) + rapply(x, f = function(text) .decodeJaspText(text, decodeContext = decodeContext), classes = "character", how = "replace") +} #' @export -decodeplot.gTree <- function(x, ...) rapply(x, f = decodeColNames, classes = "character", how = "replace") +decodeplot.gTree <- function(x, ..., decodeContext = NULL) { + decodeContext <- .normalizeJaspDecodeContext(decodeContext) + rapply(x, f = function(text) .decodeJaspText(text, decodeContext = decodeContext), classes = "character", how = "replace") +} #' @export -decodeplot.gDesc <- function(x, ...) rapply(x, f = decodeColNames, classes = "character", how = "replace") +decodeplot.gDesc <- function(x, ..., decodeContext = NULL) { + decodeContext <- .normalizeJaspDecodeContext(decodeContext) + rapply(x, f = function(text) .decodeJaspText(text, decodeContext = decodeContext), classes = "character", how = "replace") +} #' @export -decodeplot.qgraph <- function(x, ...) { +decodeplot.qgraph <- function(x, ..., decodeContext = NULL) { + decodeContext <- .normalizeJaspDecodeContext(decodeContext) labels <- x[["graphAttributes"]][["Nodes"]][["labels"]] names <- x[["graphAttributes"]][["Nodes"]][["names"]] - labels <- decodeColNames(labels) - names <- decodeColNames(names) + labels <- .decodeJaspText(labels, decodeContext = decodeContext) + names <- .decodeJaspText(names, decodeContext = decodeContext) x[["graphAttributes"]][["Nodes"]][["labels"]] <- labels x[["graphAttributes"]][["Nodes"]][["names"]] <- names return(x) } #' @export -decodeplot.function <- function(x, ...) { +decodeplot.function <- function(x, ..., decodeContext = NULL) { + decodeContext <- .normalizeJaspDecodeContext(decodeContext) f <- tempfile() on.exit({ @@ -294,40 +314,7 @@ decodeplot.function <- function(x, ...) { eval(x()) out <- grDevices::recordPlot() - return(decodeplot.recordedplot(out)) -} - -#' Decode JASP Result State -#' -#' Decodes display-only plot objects stored in a JASP result state. This is -#' intended for R-facing result payloads that need the same decoded figure -#' objects as rendered JASP output, without changing backend/runtime state. -#' -#' @param state A JASP result state list, typically containing a `figures` -#' element. -#' -#' @return `state`, with decodable figure objects decoded. -#' @export -decodeJaspResultState <- function(state) { - if (!is.list(state) || is.null(state[["figures"]])) - return(state) - - for (figureIndex in seq_along(state[["figures"]])) { - figure <- state[["figures"]][[figureIndex]] - if (is.list(figure) && !is.null(figure[["obj"]])) { - figure[["obj"]] <- .decodeJaspPlotObject(figure[["obj"]]) - state[["figures"]][[figureIndex]] <- figure - } - } - - state -} - -.decodeJaspPlotObject <- function(plot) { - tryCatch( - decodeplot(plot, returnGrob = FALSE), - error = function(e) plot - ) + return(decodeplot.recordedplot(out, decodeContext = decodeContext)) } # Some functions that act as a bridge between R and JASP. If JASP isn't running then all columnNames are expected to not be encoded diff --git a/R/zzzWrappers.R b/R/zzzWrappers.R index d00b9a67..0fc95afa 100755 --- a/R/zzzWrappers.R +++ b/R/zzzWrappers.R @@ -478,7 +478,7 @@ jaspOutputObjR <- R6::R6Class( for (i in seq_along(x)) private$jaspObject$addCitation(x[i]) }, - toRObject = function() .decodeJaspRObject(private$jaspObject$toRObject()), + toRObject = function() .decodeJaspRObject(private$jaspObject$toRObject(), decodeContext = .currentJaspDecodeContext()), toHtml = function() private$jaspObject$toHtml() ), active = list( @@ -488,49 +488,74 @@ jaspOutputObjR <- R6::R6Class( ) ) -.decodeJaspRObject <- function(x) { +.decodeJaspRObject <- function(x, fieldName = NULL, decodeContext = NULL) { + decodeContext <- .normalizeJaspDecodeContext(decodeContext) + if (is.null(x)) return(x) if (inherits(x, "jaspPlotWrapper")) { if (!is.null(x[["plotObject"]])) - x[["plotObject"]] <- .decodeJaspPlotObject(x[["plotObject"]]) - return(.decodeJaspRObjectAttributes(x)) + x[["plotObject"]] <- .decodeJaspPlotObject(x[["plotObject"]], returnGrob = FALSE, decodeContext = decodeContext) + return(.decodeJaspRObjectAttributes(x, decodeContext = decodeContext)) } if (is.character(x)) - return(decodeColNames(x)) + return(.decodeJaspText(x, fieldName = fieldName, decodeContext = decodeContext)) if (is.factor(x)) { - levels(x) <- decodeColNames(levels(x)) + levels(x) <- .decodeJaspText(levels(x), fieldName = fieldName, decodeContext = decodeContext) return(x) } if (is.data.frame(x)) { - for (name in names(x)) - x[[name]] <- .decodeJaspRObject(x[[name]]) - names(x) <- decodeColNames(names(x)) - return(.decodeJaspRObjectAttributes(x)) + oldNames <- names(x) + for (name in oldNames) + x[[name]] <- .decodeJaspRObject(x[[name]], fieldName = name, decodeContext = decodeContext) + names(x) <- .decodeJaspText(oldNames, decodeContext = decodeContext) + rowNames <- row.names(x) + if (is.character(rowNames)) + row.names(x) <- .decodeJaspText(rowNames, decodeContext = decodeContext) + return(.decodeJaspRObjectAttributes(x, decodeContext = decodeContext)) } if (is.list(x)) { + oldNames <- names(x) for (i in seq_along(x)) - x[[i]] <- .decodeJaspRObject(x[[i]]) - names(x) <- decodeColNames(names(x)) - return(.decodeJaspRObjectAttributes(x)) + x[[i]] <- .decodeJaspRObject( + x[[i]], + fieldName = if (!is.null(oldNames) && length(oldNames) >= i) oldNames[[i]] else NULL, + decodeContext = decodeContext + ) + names(x) <- .decodeJaspText(oldNames, decodeContext = decodeContext) + return(.decodeJaspRObjectAttributes(x, decodeContext = decodeContext)) } - .decodeJaspRObjectAttributes(x) + decodedFactorValues <- .decodeJaspFactorValues(x, fieldName = fieldName, decodeContext = decodeContext) + if (!identical(decodedFactorValues, x)) + return(decodedFactorValues) + + dimNames <- dimnames(x) + if (!is.null(dimNames)) { + dimnames(x) <- lapply(dimNames, .decodeJaspText, decodeContext = decodeContext) + } + + objectNames <- names(x) + if (!is.null(objectNames)) + names(x) <- .decodeJaspText(objectNames, decodeContext = decodeContext) + + .decodeJaspRObjectAttributes(x, decodeContext = decodeContext) } -.decodeJaspRObjectAttributes <- function(x) { +.decodeJaspRObjectAttributes <- function(x, decodeContext = NULL) { + decodeContext <- .normalizeJaspDecodeContext(decodeContext) attributesToDecode <- setdiff( names(attributes(x)), c("class", "dim", "dimnames", "names", "row.names", "jaspObjectEnvironment") ) for (attribute in attributesToDecode) - attr(x, attribute) <- .decodeJaspRObject(attr(x, attribute)) + attr(x, attribute) <- .decodeJaspRObject(attr(x, attribute), fieldName = attribute, decodeContext = decodeContext) x } diff --git a/man/decodeJaspResultState.Rd b/man/decodeJaspResultState.Rd deleted file mode 100644 index 19120407..00000000 --- a/man/decodeJaspResultState.Rd +++ /dev/null @@ -1,20 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/writeImage.R -\name{decodeJaspResultState} -\alias{decodeJaspResultState} -\title{Decode JASP Result State} -\usage{ -decodeJaspResultState(state) -} -\arguments{ -\item{state}{A JASP result state list, typically containing a \code{figures} -element.} -} -\value{ -\code{state}, with decodable figure objects decoded. -} -\description{ -Decodes display-only plot objects stored in a JASP result state. This is -intended for R-facing result payloads that need the same decoded figure -objects as rendered JASP output, without changing backend/runtime state. -} diff --git a/src/jaspPlot.cpp b/src/jaspPlot.cpp index f36d19a4..e0b45ca3 100644 --- a/src/jaspPlot.cpp +++ b/src/jaspPlot.cpp @@ -107,8 +107,10 @@ void jaspPlot::renderPlot() writeResult = tryToWriteImage(Rcpp::_["width"] = _width, Rcpp::_["height"] = _height, Rcpp::_["plot"] = obj, Rcpp::_["oldPlotInfo"] = oldPlotInfo, Rcpp::_["relativePathpng"] = R_NilValue); } - // we need to overwrite plot functions with their recordedplot result - if(Rcpp::is(obj) && writeResult.containsElementNamed("obj")) + // Keep the state object in sync with the rendered object. R returns an + // editable decoded object for ggplot-like plots and a materialized object + // for function/base plots. + if(writeResult.containsElementNamed("obj")) plotInfo["obj"] = writeResult["obj"]; if(writeResult.containsElementNamed("png")) diff --git a/tests/testthat/test-result-object-decoding.R b/tests/testthat/test-result-object-decoding.R index 2b27a830..c960dfe7 100644 --- a/tests/testthat/test-result-object-decoding.R +++ b/tests/testthat/test-result-object-decoding.R @@ -25,13 +25,20 @@ localDecoder <- function(mapping) { } } -testthat::test_that("decodeplot.gg returns decoded labels for R-facing plots", { - restoreDecoder <- localDecoder(c( - JaspColumn_1_Encoded = "group", - JaspColumn_2_Encoded = "score" - )) - on.exit(restoreDecoder(), add = TRUE) +localDecodeContext <- function() { + jaspBase:::.jaspDecodeContext( + columns = c( + JaspColumn_1_Encoded = "group", + JaspColumn_2_Encoded = "score", + JaspColumn_3_Encoded = "cluster" + ), + factors = list( + JaspColumn_1_Encoded = c("1" = "control", "2" = "treatment") + ) + ) +} +testthat::test_that("decodeplot.gg returns decoded labels for R-facing plots", { plot <- ggplot2::ggplot( data.frame(x = 1, y = 2), ggplot2::aes(x = x, y = y) @@ -42,22 +49,64 @@ testthat::test_that("decodeplot.gg returns decoded labels for R-facing plots", { y = "JaspColumn_2_Encoded" ) - decoded <- jaspBase:::decodeplot(plot, returnGrob = FALSE) + decoded <- jaspBase:::decodeplot(plot, returnGrob = FALSE, decodeContext = localDecodeContext()) testthat::expect_equal(unname(decoded$labels$x), "group") testthat::expect_equal(unname(decoded$labels$y), "score") }) -testthat::test_that("toRObject result copies decode tables, footnotes, and plots", { - restoreDecoder <- localDecoder(c( - JaspColumn_1_Encoded = "group", - JaspColumn_2_Encoded = "score", - JaspColumn_3_Encoded = "cluster" - )) - on.exit(restoreDecoder(), add = TRUE) +testthat::test_that("writeImage uses decoded editable objects for state and interactive conversion", { + ns <- asNamespace("jaspGraphs") + original <- get("convertGgplotToPlotly", envir = ns) + captured <- new.env(parent = emptyenv()) + unlockBinding("convertGgplotToPlotly", ns) + assign("convertGgplotToPlotly", function(plot, ...) { + captured$x <- unname(plot$labels$x) + "{}" + }, envir = ns) + lockBinding("convertGgplotToPlotly", ns) + on.exit({ + unlockBinding("convertGgplotToPlotly", ns) + assign("convertGgplotToPlotly", original, envir = ns) + lockBinding("convertGgplotToPlotly", ns) + }, add = TRUE) + + oldTempFile <- if (exists(".requestTempFileNameNative", envir = .GlobalEnv, inherits = FALSE)) get(".requestTempFileNameNative", envir = .GlobalEnv) else NULL + oldBackground <- if (exists(".imageBackground", envir = .GlobalEnv, inherits = FALSE)) get(".imageBackground", envir = .GlobalEnv) else NULL + oldPpi <- if (exists(".ppi", envir = .GlobalEnv, inherits = FALSE)) get(".ppi", envir = .GlobalEnv) else NULL + hadTempFile <- exists(".requestTempFileNameNative", envir = .GlobalEnv, inherits = FALSE) + hadBackground <- exists(".imageBackground", envir = .GlobalEnv, inherits = FALSE) + hadPpi <- exists(".ppi", envir = .GlobalEnv, inherits = FALSE) + on.exit({ + if (hadTempFile) assign(".requestTempFileNameNative", oldTempFile, envir = .GlobalEnv) else if (exists(".requestTempFileNameNative", envir = .GlobalEnv, inherits = FALSE)) rm(".requestTempFileNameNative", envir = .GlobalEnv) + if (hadBackground) assign(".imageBackground", oldBackground, envir = .GlobalEnv) else if (exists(".imageBackground", envir = .GlobalEnv, inherits = FALSE)) rm(".imageBackground", envir = .GlobalEnv) + if (hadPpi) assign(".ppi", oldPpi, envir = .GlobalEnv) else if (exists(".ppi", envir = .GlobalEnv, inherits = FALSE)) rm(".ppi", envir = .GlobalEnv) + }, add = TRUE) + assign(".requestTempFileNameNative", function(extension) list(root = tempdir(), relativePath = paste0("decoded-write-image.", extension)), envir = .GlobalEnv) + assign(".imageBackground", "white", envir = .GlobalEnv) + assign(".ppi", 300, envir = .GlobalEnv) + + plot <- ggplot2::ggplot( + data.frame(x = 1, y = 2), + ggplot2::aes(x = x, y = y) + ) + + ggplot2::geom_point() + + ggplot2::labs(x = "JaspColumn_1_Encoded") + + image <- jaspBase:::writeImageJaspResults( + plot, + location = list(root = tempdir(), relativePath = "decoded-write-image.png"), + decodeContext = localDecodeContext() + ) + + testthat::expect_equal(unname(image$obj$labels$x), "group") + testthat::expect_equal(captured$x, "group") +}) +testthat::test_that("toRObject result copies decode tables, footnotes, and plots", { table <- data.frame( - JaspColumn_1_Encoded = "JaspColumn_2_Encoded", + JaspColumn_1_Encoded = c("1", "2"), + label = "JaspColumn_2_Encoded", check.names = FALSE ) class(table) <- c("jaspTableWrapper", "jaspWrapper", class(table)) @@ -87,11 +136,12 @@ testthat::test_that("toRObject result copies decode tables, footnotes, and plots class(result) <- c("jaspContainerWrapper", "jaspWrapper") attr(result, "title") <- "JaspColumn_1_Encoded results" - decoded <- jaspBase:::.decodeJaspRObject(result) + decoded <- jaspBase:::.decodeJaspRObject(result, decodeContext = localDecodeContext()) testthat::expect_equal(names(decoded), c("group", "Plot")) - testthat::expect_equal(names(decoded$group), "group") - testthat::expect_equal(decoded$group$group, "score") + testthat::expect_equal(names(decoded$group), c("group", "label")) + testthat::expect_equal(decoded$group$group, c("control", "treatment")) + testthat::expect_equal(decoded$group$label, c("score", "score")) testthat::expect_equal(attr(decoded$group, "title"), "group table") testthat::expect_equal( attr(decoded$group, "footnotes")[[1L]]$text, @@ -250,13 +300,7 @@ testthat::test_that("container wrapper printing formats nested paths and protect testthat::expect_true(any(grepl("plain child", printed, fixed = TRUE))) }) -testthat::test_that("decodeJaspResultState decodes stored figure objects", { - restoreDecoder <- localDecoder(c( - JaspColumn_1_Encoded = "group", - JaspColumn_2_Encoded = "score" - )) - on.exit(restoreDecoder(), add = TRUE) - +testthat::test_that("result state decoding eagerly decodes figures and other state", { plot <- ggplot2::ggplot( data.frame(x = 1, y = 2), ggplot2::aes(x = x, y = y) @@ -274,10 +318,53 @@ testthat::test_that("decodeJaspResultState decodes stored figure objects", { other = list(label = "JaspColumn_2_Encoded") ) - decoded <- jaspBase::decodeJaspResultState(state) + decoded <- jaspBase:::.decodeJaspResultState(state, decodeContext = localDecodeContext()) testthat::expect_equal(unname(decoded$figures[["1.png"]]$obj$labels$x), "group") testthat::expect_equal(unname(decoded$figures[["1.png"]]$obj$labels$y), "score") - testthat::expect_identical(decoded$figures[["2.png"]]$other, "JaspColumn_1_Encoded") - testthat::expect_identical(decoded$other$label, "JaspColumn_2_Encoded") + testthat::expect_identical(decoded$figures[["2.png"]]$other, "group") + testthat::expect_identical(decoded$other$label, "score") +}) + +testthat::test_that("result state decoding is internal", { + testthat::expect_false("decodeJaspResultState" %in% getNamespaceExports("jaspBase")) +}) + +testthat::test_that("decoded result objects persist without a live decoder", { + plot <- ggplot2::ggplot( + data.frame(x = 1, y = 2), + ggplot2::aes(x = x, y = y) + ) + + ggplot2::geom_point() + + ggplot2::labs(x = "JaspColumn_1_Encoded") + + result <- list( + table = data.frame(JaspColumn_1_Encoded = c("1", "2"), check.names = FALSE), + plot = list(plotObject = plot) + ) + class(result$plot) <- c("jaspPlotWrapper", "jaspWrapper") + + decoded <- jaspBase:::.decodeJaspRObject(result, decodeContext = localDecodeContext()) + path <- tempfile(fileext = ".rds") + saveRDS(decoded, path) + + restoreDecoder <- localDecoder(c(JaspColumn_1_Encoded = "wrong dataset name")) + on.exit(restoreDecoder(), add = TRUE) + + restored <- readRDS(path) + testthat::expect_equal(restored$table$group, c("control", "treatment")) + testthat::expect_equal(unname(restored$plot$plotObject$labels$x), "group") +}) + +testthat::test_that("missing decode context warns for encoded legacy state", { + restoreDecoder <- localDecoder(stats::setNames(character(), character())) + on.exit(restoreDecoder(), add = TRUE) + + state <- list(other = list(label = "JaspColumn_1_Encoded")) + + testthat::expect_warning( + decoded <- jaspBase:::.decodeJaspResultState(state, decodeContext = jaspBase:::.jaspDecodeContext()), + "no analysis decode context" + ) + testthat::expect_identical(decoded$other$label, "JaspColumn_1_Encoded") }) From 17d2533b1e108c9cbde0a34e43eb567f52a104a7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Fri, 29 May 2026 15:41:53 +0200 Subject: [PATCH 13/22] Preserve decode context across result materialization --- R/common.R | 34 +++++++-- R/resultDecoding.R | 79 ++++++++++++++++++-- R/zzzWrappers.R | 19 ++++- tests/testthat/test-result-object-decoding.R | 31 +++++++- 4 files changed, 144 insertions(+), 19 deletions(-) diff --git a/R/common.R b/R/common.R index 2d6bc925..b0aff30f 100644 --- a/R/common.R +++ b/R/common.R @@ -30,10 +30,12 @@ loadJaspResults <- function(name) { create_cpp_jaspResults(name, .retrieveState()) } -finishJaspResults <- function(jaspResultsCPP, calledFromAnalysis = TRUE) { +finishJaspResults <- function(jaspResultsCPP, calledFromAnalysis = TRUE, decodeContext = NULL) { jaspResultsCPP$prepareForWriting() - decodeContext <- .currentJaspDecodeContext() + if (is.null(decodeContext) && !isTRUE(calledFromAnalysis)) + decodeContext <- .jaspDecodeContext(source = "stored-result-state") + decodeContext <- .normalizeJaspDecodeContext(decodeContext) newState <- list( figures = jaspResultsCPP$getPlotObjectsForState(), @@ -84,6 +86,8 @@ runJaspResults <- function(name, title, dataKey, options, stateKey, functionCall jaspResultsCPP <- loadJaspResults(name) jaspResultsCPP$title <- title jaspResults <- jaspResultsR$new(jaspResultsCPP) + decodeContext <- .currentJaspDecodeContext() + jaspResults$setDecodeContext(decodeContext) jaspResultsCPP$setOptions(options) @@ -141,7 +145,7 @@ runJaspResults <- function(name, title, dataKey, options, stateKey, functionCall } - finishJaspResults(jaspResultsCPP) + finishJaspResults(jaspResultsCPP, decodeContext = decodeContext) return(jaspResults) } @@ -167,7 +171,7 @@ runJaspResults <- function(name, title, dataKey, options, stateKey, functionCall return(paste0("{ \"status\" : \"", errorStatus, "\", \"results\" : { \"title\" : \"error\", \"error\" : 1, \"errorMessage\" : \"", errorMessage, "\" } }", sep="")) } else { - returnThis <- finishJaspResults(jaspResultsCPP) + returnThis <- finishJaspResults(jaspResultsCPP, decodeContext = decodeContext) json <- try({ toJSON(returnThis) }) if (isTryError(json)) @@ -836,7 +840,11 @@ saveImage <- function(plotName, format, height, width) state <- .retrieveState() # Retrieve plot object from state plt <- state[["figures"]][[plotName]][["obj"]] - plt <- .decodeJaspPlotObject(plt, returnGrob = FALSE); + plt <- .decodeJaspPlotObject( + plt, + returnGrob = FALSE, + decodeContext = .jaspDecodeContext(source = "stored-result-state") + ) location <- .fromRCPP(".requestTempFileNameNative", "png") # create file location string to extract the root location backgroundColor <- .fromRCPP(".imageBackground") @@ -1042,7 +1050,11 @@ rewriteImages <- function(name, ppi, imageBackground) { jaspPlotCPP$editing <- TRUE - plot <- jaspPlotCPP$plotObject + plot <- .decodeJaspPlotObject( + jaspPlotCPP$plotObject, + returnGrob = FALSE, + decodeContext = .jaspDecodeContext(source = "stored-result-state") + ) # here we can modify general things for all plots (theme, font, etc.). # ppi and imageBackground are automatically updated in writeImageJaspResults through .Rcpp magic @@ -1093,7 +1105,11 @@ editImage <- function(name, optionsJson) { jaspPlotCPP$editing <- TRUE on.exit({jaspPlotCPP$editing <- FALSE}) # this should not persist! - plot <- jaspPlotCPP$plotObject + plot <- .decodeJaspPlotObject( + jaspPlotCPP$plotObject, + returnGrob = FALSE, + decodeContext = .jaspDecodeContext(source = "stored-result-state") + ) if (is.null(plot)) stop("no plot object found") @@ -1134,8 +1150,10 @@ editImage <- function(name, optionsJson) { newPlot <- jaspGraphs::plotEditing(newPlot, newOpts) # plot editing did nothing or was canceled - if (!identical(plot, newPlot)) + if (!identical(plot, newPlot)) { jaspPlotCPP$plotObject <- newPlot + plot <- newPlot + } } interactiveJsonData <- jaspPlotCPP$interactiveJsonData diff --git a/R/resultDecoding.R b/R/resultDecoding.R index c1e4b600..df1a91d1 100644 --- a/R/resultDecoding.R +++ b/R/resultDecoding.R @@ -1,4 +1,4 @@ -.jaspDecodeContext <- function(columns = character(), factors = list(), source = "manual") { +.jaspDecodeContext <- function(columns = character(), factors = list(), source = "manual", allowLiveFallback = FALSE) { columns <- .normalizeJaspColumnMapping(columns) factors <- .normalizeJaspFactorMappings(factors, columns) @@ -7,6 +7,7 @@ columns = columns, factors = factors, source = source, + allowLiveFallback = isTRUE(allowLiveFallback), warningState = new.env(parent = emptyenv()) ) } @@ -17,11 +18,67 @@ version = decodeContext[["version"]], columns = decodeContext[["columns"]], factors = decodeContext[["factors"]], - source = decodeContext[["source"]] + source = decodeContext[["source"]], + allowLiveFallback = isTRUE(decodeContext[["allowLiveFallback"]]) ) } -.currentJaspDecodeContext <- function() { +.withJaspDecodeContextDecoder <- function(decodeContext, expr) { + if (is.null(decodeContext)) + return(eval.parent(substitute(expr))) + + decodeContext <- .normalizeJaspDecodeContext(decodeContext) + columns <- decodeContext[["columns"]] + + oldStrict <- .globalBinding(".decodeColNamesStrict") + oldLax <- .globalBinding(".decodeColNamesLax") + on.exit({ + .restoreGlobalBinding(".decodeColNamesStrict", oldStrict) + .restoreGlobalBinding(".decodeColNamesLax", oldLax) + }, add = TRUE) + + assign(".decodeColNamesStrict", .decodeJaspColumnsStrict(columns), envir = .GlobalEnv) + assign(".decodeColNamesLax", .decodeJaspColumnsLax(columns), envir = .GlobalEnv) + + eval.parent(substitute(expr)) +} + +.globalBinding <- function(name) { + exists <- exists(name, envir = .GlobalEnv, inherits = FALSE) + list( + exists = exists, + value = if (exists) get(name, envir = .GlobalEnv, inherits = FALSE) else NULL + ) +} + +.restoreGlobalBinding <- function(name, binding) { + if (isTRUE(binding[["exists"]])) { + assign(name, binding[["value"]], envir = .GlobalEnv) + } else if (exists(name, envir = .GlobalEnv, inherits = FALSE)) { + rm(list = name, envir = .GlobalEnv) + } + invisible(NULL) +} + +.decodeJaspColumnsStrict <- function(columnMapping) { + force(columnMapping) + function(x) { + if (!is.character(x) || length(x) == 0L || length(columnMapping) == 0L) + return(x) + + out <- x + matched <- !is.na(out) & out %in% names(columnMapping) + out[matched] <- unname(columnMapping[out[matched]]) + out + } +} + +.decodeJaspColumnsLax <- function(columnMapping) { + force(columnMapping) + function(x) .decodeJaspColumnText(x, columnMapping) +} + +.currentJaspDecodeContext <- function(allowLiveFallback = FALSE) { columnMapping <- character() requestedDataset <- NULL @@ -39,13 +96,14 @@ .jaspDecodeContext( columns = columnMapping, factors = .jaspFactorMappingsFromDataset(requestedDataset, columnMapping), - source = "jaspSyntax" + source = "jaspSyntax", + allowLiveFallback = allowLiveFallback ) } -.normalizeJaspDecodeContext <- function(decodeContext = NULL) { +.normalizeJaspDecodeContext <- function(decodeContext = NULL, allowLiveFallback = is.null(decodeContext)) { if (is.null(decodeContext)) - return(.currentJaspDecodeContext()) + return(.currentJaspDecodeContext(allowLiveFallback = allowLiveFallback)) decodeContext[["columns"]] <- .normalizeJaspColumnMapping(decodeContext[["columns"]]) decodeContext[["factors"]] <- .normalizeJaspFactorMappings(decodeContext[["factors"]], decodeContext[["columns"]]) @@ -53,6 +111,7 @@ decodeContext[["version"]] <- 1L if (is.null(decodeContext[["source"]])) decodeContext[["source"]] <- "unknown" + decodeContext[["allowLiveFallback"]] <- isTRUE(decodeContext[["allowLiveFallback"]]) if (!is.environment(decodeContext[["warningState"]])) decodeContext[["warningState"]] <- new.env(parent = emptyenv()) @@ -193,7 +252,7 @@ x <- .decodeJaspFactorValues(x, fieldName = fieldName, decodeContext = decodeContext) x <- .decodeJaspColumnText(x, decodeContext[["columns"]]) - if (length(decodeContext[["columns"]]) == 0L) { + if (isTRUE(decodeContext[["allowLiveFallback"]]) && length(decodeContext[["columns"]]) == 0L) { fallback <- tryCatch( decodeColNames(x, strict = FALSE), error = function(e) x @@ -263,3 +322,9 @@ decoded } + +.decodeJaspRObjectFromCpp <- function(jaspObject, decodeContext = NULL) { + .withJaspDecodeContextDecoder(decodeContext, { + .decodeJaspRObject(jaspObject$toRObject(), decodeContext = decodeContext) + }) +} diff --git a/R/zzzWrappers.R b/R/zzzWrappers.R index 0fc95afa..b2f14bc0 100755 --- a/R/zzzWrappers.R +++ b/R/zzzWrappers.R @@ -163,6 +163,13 @@ jaspObjR <- R6::R6Class( public = list( initialize = function() stop("You should not create a new jaspObject!", domain = NA), print = function() private$jaspObject$print(), + setDecodeContext = function(decodeContext = NULL) { + private$decodeContext <- if (is.null(decodeContext)) NULL else .serializableJaspDecodeContext(decodeContext) + invisible(self) + }, + getDecodeContext = function() { + private$decodeContext + }, dependOn = function(options=NULL, optionsFromObject=NULL, optionContainsValue=NULL, nestedOptions = NULL, nestedOptionsContainsValue = NULL) { if (is.jaspDeps(options)) { @@ -299,6 +306,7 @@ jaspObjR <- R6::R6Class( ), private = list( jaspObject = NULL, + decodeContext = NULL, getJaspObject = function(R6obj) R6obj$.__enclos_env__$private$jaspObject ) ) @@ -478,7 +486,7 @@ jaspOutputObjR <- R6::R6Class( for (i in seq_along(x)) private$jaspObject$addCitation(x[i]) }, - toRObject = function() .decodeJaspRObject(private$jaspObject$toRObject(), decodeContext = .currentJaspDecodeContext()), + toRObject = function() .decodeJaspRObjectFromCpp(private$jaspObject, decodeContext = self$getDecodeContext()), toHtml = function() private$jaspObject$toHtml() ), active = list( @@ -685,7 +693,7 @@ jaspContainerR <- R6::R6Class( children = list(), jaspObject = NULL, jaspCppToR6 = function(cppObj) { - return(switch( + r6Obj <- switch( class(cppObj), "Rcpp_jaspPlot" = jaspPlotR$new( jaspObject = cppObj ), "Rcpp_jaspTable" = jaspTableR$new( jaspObject = cppObj ), @@ -696,11 +704,16 @@ jaspContainerR <- R6::R6Class( "Rcpp_jaspQmlSource" = jaspQmlSourceR$new(jaspObject = cppObj ), "Rcpp_jaspReport" = jaspReportR$new( jaspObject = cppObj ), stop(sprintf("Invalid call to jaspCppToR6. Expected jaspResults object but got %s", class(cppObj)), domain = NA) - )) + ) + if (is.JaspResultsObj(r6Obj)) + r6Obj$setDecodeContext(private$decodeContext) + r6Obj }, #These two functions should be the exact same as those for jaspResults setField = function(field, value) { field <- decodeName(field) + if (is.JaspResultsObj(value)) + value$setDecodeContext(private$decodeContext) private$jaspObject[[field]] <- private$getJaspObject(value); private$children[[field]] <- value; }, diff --git a/tests/testthat/test-result-object-decoding.R b/tests/testthat/test-result-object-decoding.R index c960dfe7..ecb4f9f0 100644 --- a/tests/testthat/test-result-object-decoding.R +++ b/tests/testthat/test-result-object-decoding.R @@ -153,6 +153,35 @@ testthat::test_that("toRObject result copies decode tables, footnotes, and plots testthat::expect_equal(attr(decoded, "title"), "group results") }) +testthat::test_that("R6 result wrappers keep their analysis decode context", { + jaspResults <- jaspBase:::jaspResultsR$new(jaspBase:::create_cpp_jaspResults("Context test", NULL)) + jaspResults$setDecodeContext(localDecodeContext()) + on.exit({ + jaspBase:::destroyAllAllocatedObjects() + jaspBase:::destroyAllAllocatedRObjects() + }, add = TRUE) + + table <- jaspBase::createJaspTable( + title = "JaspColumn_1_Encoded table", + data = data.frame(JaspColumn_1_Encoded = c("1", "2"), check.names = FALSE) + ) + jaspResults[["JaspColumn_1_Encoded"]] <- table + + restoreDecoder <- localDecoder(c(JaspColumn_1_Encoded = "wrong dataset name")) + on.exit(restoreDecoder(), add = TRUE) + + decoded <- jaspResults$toRObject() + child <- jaspResults[["JaspColumn_1_Encoded"]] + decodedTable <- decoded[[1L]] + + testthat::expect_equal(names(decoded), "group table") + testthat::expect_equal(names(decodedTable), "group") + testthat::expect_equal(decodedTable$group, c("control", "treatment")) + testthat::expect_equal(attr(decodedTable, "title"), "group table") + testthat::expect_false(any(grepl("wrong dataset name", capture.output(str(decoded)), fixed = TRUE))) + testthat::expect_equal(child$getDecodeContext()[["columns"]], localDecodeContext()[["columns"]]) +}) + testthat::test_that("printing output wrappers shows the R-facing object", { richResult <- list( toRObject = function() list( @@ -357,7 +386,7 @@ testthat::test_that("decoded result objects persist without a live decoder", { }) testthat::test_that("missing decode context warns for encoded legacy state", { - restoreDecoder <- localDecoder(stats::setNames(character(), character())) + restoreDecoder <- localDecoder(c(JaspColumn_1_Encoded = "wrong dataset name")) on.exit(restoreDecoder(), add = TRUE) state <- list(other = list(label = "JaspColumn_1_Encoded")) From 1b90919b9c976d39289f58dcbc3b94e08c0513ad Mon Sep 17 00:00:00 2001 From: "Weblate (bot)" Date: Sat, 16 May 2026 06:42:10 +0200 Subject: [PATCH 14/22] Translated using Weblate (Vietnamese) (#203) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Currently translated at 100.0% (26 of 26 strings) Translation: JASP/jaspBase Translate-URL: https://hosted.weblate.org/projects/jasp/jaspbase/vi/ Co-authored-by: Thành Khôi Lê --- po/R-vi.po | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/po/R-vi.po b/po/R-vi.po index 4b6ac6c4..a51be874 100644 --- a/po/R-vi.po +++ b/po/R-vi.po @@ -2,8 +2,8 @@ msgid "" msgstr "" "Project-Id-Version: jaspBase 0.19.2\n" "POT-Creation-Date: 2026-04-11 04:23\n" -"PO-Revision-Date: 2026-01-20 08:01+0000\n" -"Last-Translator: Tran Thien Truong \n" +"PO-Revision-Date: 2026-05-13 12:45+0000\n" +"Last-Translator: Thành Khôi Lê \n" "Language-Team: Vietnamese \n" "Language: vi\n" @@ -11,7 +11,7 @@ msgstr "" "Content-Type: text/plain; charset=UTF-8\n" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=1; plural=0;\n" -"X-Generator: Weblate 5.16-dev\n" +"X-Generator: Weblate 2026.5.dev0\n" msgid "Note." msgstr "Ghi chú." @@ -129,4 +129,4 @@ msgid "The following error occured while converting a ggplot to plotly: %s" msgstr "Lỗi sau đây xảy ra trong khi chuyển đổi ggplot thành plotly: %s" msgid "No interactive plot generated..." -msgstr "" +msgstr "Chưa có điểm tương tác nào được kích hoạt..." From 3eef8348a33c6228f20bb0b2f4650a98f210ccbd Mon Sep 17 00:00:00 2001 From: github-actions Date: Sat, 16 May 2026 04:42:52 +0000 Subject: [PATCH 15/22] updated translation files --- inst/po/vi/LC_MESSAGES/R-jaspBase.mo | Bin 4987 -> 5097 bytes 1 file changed, 0 insertions(+), 0 deletions(-) diff --git a/inst/po/vi/LC_MESSAGES/R-jaspBase.mo b/inst/po/vi/LC_MESSAGES/R-jaspBase.mo index c04d63f7aebb197d29c3f24e20723583aa68c106..80d1faec2c3aa9e62171ce87f4826d694c276dd2 100644 GIT binary patch delta 775 zcmXZaOK1~O6oBEACbg#3T4P&Vt$2O3#YbbCG=dTrQe8+DaUo(Cnvf2ikanijp@Ii~L1)lOIA{h)kVGGiLD=PGS<5@CN?G;P-{F$Oz8h1zg2eJP{GOj2H15zCne9 z^?JXeoaZK3n8IFku?MSo6TjnL%&Zd`!n=43-(xp6G>AOLK74{c9>mOgk*|0kgF+^v zA{}@O@6g;V#-zyRO(GUAk{EpW8NS4CxEmjC5V?e}{@c1yWFOC0@H#$47dsi#E?mGJ zxQuCB!$Y`#lgI%a!3TH`kFdYAwTKMkSv-!jxCcMuM+|KinZr*Q6nHfzvVyO%4d=En zPFzG9)7=K^3{D3F&_TocD7PXt>u^^?E$1ji2S+CCAv7*DtN#vjmzQm zkm;ARD(6+yyP15gdV4}Se%UWsW6JSLIc0hCHgEiLt@=Et3f@A_RHj{9Dmg(3)#kU6 EztqxyC;$Ke delta 655 zcmXZZ&uh|g9LMq3)Genq%hI`iTKR)kPHjJ^Scj4#*=2$d^xL7VRycCjVLy<-(+<0Q zC)j1zQI`;}gZ_kWbqPZ{tU!p)MfCKeZ}@y4-_Q5^<@lOcNoObpgFIiTiir> zuz(TV#0_j<2;)Oi3bS|}>lnt*SjWHk7HbEjOBi=b-|zu;6PO*A0+_)nMJ=J1{V$hP zR7JA6dp~}O4PJb}bC^3QJ;G|=?|6az%|p@}zCa6q;8|R!O{Z`N{?t#})|Qvy>d4KqRECMZ;#A;0x| z;6#QjOfVO5fT&VbWCjl=n5F5>Xn#M}w+qRb(`mDqp#sf^Hov{OJ(zO1lCjH)VB*TP zMAB*x2hNmo#bEa7vjW%BtL5TiaJFnL^CF*Lv3#z7&gqHdOe|k`-8}97WN(gpK05vb D2J%ko From 8827c315e65751e69568c7f786b16e62c9f3723b Mon Sep 17 00:00:00 2001 From: boutinb Date: Fri, 29 May 2026 15:57:47 +0200 Subject: [PATCH 16/22] Fix mixed column type --- src/jaspTable.cpp | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/jaspTable.cpp b/src/jaspTable.cpp index 3f0ee9fb..0bdd60a8 100644 --- a/src/jaspTable.cpp +++ b/src/jaspTable.cpp @@ -1429,6 +1429,9 @@ jaspTableColumnType jaspTable::deriveColumnType(int col) const { case Json::nullValue: workingType = cell.type(); + if (workingType == Json::objectValue && + cell.isMember("value") && cell.isMember("type") && cell.isMember("format")) + return jaspTableColumnType::mixed; break; case Json::stringValue: From 0a64ba4e4e9651b246d88b938c3b1fbb2003a60a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Fri, 29 May 2026 16:45:23 +0200 Subject: [PATCH 17/22] Constrain result decoding to JASP-owned surfaces --- DESCRIPTION | 1 + R/common.R | 8 ++- R/resultDecoding.R | 25 +++++-- R/zzzWrappers.R | 56 +++++++++++++++ tests/testthat/test-result-object-decoding.R | 74 +++++++++++++++++++- 5 files changed, 153 insertions(+), 11 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 8138032e..b3eed2d5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -31,6 +31,7 @@ Imports: rvg, svglite, systemfonts, + vctrs, withr Remotes: jasp-stats/jaspGraphs diff --git a/R/common.R b/R/common.R index b0aff30f..c60bca12 100644 --- a/R/common.R +++ b/R/common.R @@ -86,8 +86,6 @@ runJaspResults <- function(name, title, dataKey, options, stateKey, functionCall jaspResultsCPP <- loadJaspResults(name) jaspResultsCPP$title <- title jaspResults <- jaspResultsR$new(jaspResultsCPP) - decodeContext <- .currentJaspDecodeContext() - jaspResults$setDecodeContext(decodeContext) jaspResultsCPP$setOptions(options) @@ -115,6 +113,12 @@ runJaspResults <- function(name, title, dataKey, options, stateKey, functionCall if(preloadData) dataset <- .fromRCPP(".readDataSetRequestedNative") + # Capture the analysis decode context after dataset preload: that is when the + # bridge exposes the encoded requested-dataset names needed to materialize + # R-facing results with original column and factor labels. + decodeContext <- .currentJaspDecodeContext() + jaspResults$setDecodeContext(decodeContext) + # ensure an analysis always starts with a clean hashtable of computed jasp Objects emptyRecomputed() diff --git a/R/resultDecoding.R b/R/resultDecoding.R index df1a91d1..f6280701 100644 --- a/R/resultDecoding.R +++ b/R/resultDecoding.R @@ -83,14 +83,26 @@ requestedDataset <- NULL if (requireNamespace("jaspSyntax", quietly = TRUE)) { - columnMapping <- tryCatch( - getExportedValue("jaspSyntax", "columnMapping")(strict = FALSE), - error = function(e) character() - ) requestedDataset <- tryCatch( getExportedValue("jaspSyntax", "readRequestedDataset")(decode = FALSE, normalize = FALSE), error = function(e) NULL ) + defaultMapping <- tryCatch( + getExportedValue("jaspSyntax", "columnMapping")(strict = FALSE), + error = function(e) character() + ) + requestedMapping <- character() + requestedNames <- if (is.data.frame(requestedDataset)) names(requestedDataset) else character() + if (length(requestedNames) > 0L && .containsJaspEncodedTokens(requestedNames)) { + requestedMapping <- tryCatch( + getExportedValue("jaspSyntax", "columnMapping")(requestedNames, strict = FALSE), + error = function(e) character() + ) + } + columnMapping <- c( + requestedMapping, + defaultMapping[setdiff(names(defaultMapping), names(requestedMapping))] + ) } .jaspDecodeContext( @@ -292,8 +304,9 @@ } } - if (!is.null(state[["other"]])) - state[["other"]] <- .decodeJaspRObject(state[["other"]], decodeContext = decodeContext) + # `other` contains jaspState payloads: arbitrary analysis-owned R objects + # restored into the next run. Keep those objects opaque. Display/replay state + # that JASP owns lives under `figures` and is decoded above. otherFields <- setdiff(names(state), c("figures", "other")) for (field in otherFields) diff --git a/R/zzzWrappers.R b/R/zzzWrappers.R index b2f14bc0..ef92e82f 100755 --- a/R/zzzWrappers.R +++ b/R/zzzWrappers.R @@ -516,6 +516,9 @@ jaspOutputObjR <- R6::R6Class( return(x) } + if (.isJaspMixedObject(x)) + return(.decodeJaspMixedObject(x, fieldName = fieldName, decodeContext = decodeContext)) + if (is.data.frame(x)) { oldNames <- names(x) for (name in oldNames) @@ -527,6 +530,17 @@ jaspOutputObjR <- R6::R6Class( return(.decodeJaspRObjectAttributes(x, decodeContext = decodeContext)) } + # Decode only JASP-owned result wrappers and plain R result payloads here. + # Model objects from analysis packages can be S3/S4 lists internally; rewriting + # their slots, attributes, or names mutates package-owned state and can break + # invariants such as lme4 response objects. In particular, external packages + # may use class names that overlap with JASP display helpers. + if (isS4(x) || is.call(x) || is.name(x)) + return(x) + + if (is.object(x) && !inherits(x, "jaspWrapper")) + return(x) + if (is.list(x)) { oldNames <- names(x) for (i in seq_along(x)) @@ -555,6 +569,48 @@ jaspOutputObjR <- R6::R6Class( .decodeJaspRObjectAttributes(x, decodeContext = decodeContext) } +.isJaspMixedObject <- function(x) { + if (!inherits(x, "mixed")) + return(FALSE) + + if (inherits(x, "vctrs_vctr")) + return(!is.null(attr(x, "column", exact = TRUE))) + + is.list(x) && all(c("value", "type", "format") %in% names(x)) +} + +.decodeJaspMixedObject <- function(x, fieldName = NULL, decodeContext = NULL) { + if (!inherits(x, "vctrs_vctr")) { + oldNames <- names(x) + for (i in seq_along(x)) + x[[i]] <- .decodeJaspRObject( + x[[i]], + fieldName = if (!is.null(oldNames) && length(oldNames) >= i && identical(oldNames[[i]], "value")) fieldName else NULL, + decodeContext = decodeContext + ) + return(x) + } + + data <- vctrs::vec_data(x) + for (i in seq_along(data)) { + cell <- data[[i]] + if (is.list(cell) && !is.null(cell[["value"]])) { + cell[["value"]] <- .decodeJaspRObject( + cell[["value"]], + fieldName = fieldName, + decodeContext = decodeContext + ) + data[[i]] <- cell + } + } + + result <- vctrs::new_vctr(data, column = attr(x, "column", exact = TRUE), class = "mixed") + objectNames <- names(x) + if (!is.null(objectNames)) + names(result) <- .decodeJaspText(objectNames, decodeContext = decodeContext) + result +} + .decodeJaspRObjectAttributes <- function(x, decodeContext = NULL) { decodeContext <- .normalizeJaspDecodeContext(decodeContext) attributesToDecode <- setdiff( diff --git a/tests/testthat/test-result-object-decoding.R b/tests/testthat/test-result-object-decoding.R index ecb4f9f0..103a63ce 100644 --- a/tests/testthat/test-result-object-decoding.R +++ b/tests/testthat/test-result-object-decoding.R @@ -153,6 +153,52 @@ testthat::test_that("toRObject result copies decode tables, footnotes, and plots testthat::expect_equal(attr(decoded, "title"), "group results") }) +testthat::test_that("decoder handles JASP-owned mixed table cells without broad object mutation", { + table <- data.frame( + JaspColumn_1_Encoded = jaspBase::createMixedColumn( + values = list("JaspColumn_2_Encoded", 12L), + types = c("string", "integer") + ), + check.names = FALSE + ) + + decoded <- jaspBase:::.decodeJaspRObject(table, decodeContext = localDecodeContext()) + decodedCells <- vctrs::vec_data(decoded$group) + + testthat::expect_s3_class(decoded$group, "mixed") + testthat::expect_identical(decodedCells[[1L]][["value"]], "score") + testthat::expect_identical(decodedCells[[2L]][["value"]], 12L) +}) + +testthat::test_that("decoder handles legacy scalar mixed table cells", { + cell <- structure( + list(value = "JaspColumn_2_Encoded", type = "string", format = NULL), + class = "mixed" + ) + + decoded <- jaspBase:::.decodeJaspRObject(cell, fieldName = "JaspColumn_1_Encoded", decodeContext = localDecodeContext()) + + testthat::expect_s3_class(decoded, "mixed") + testthat::expect_identical(decoded$value, "score") + testthat::expect_identical(decoded$type, "string") +}) + +testthat::test_that("decoder leaves foreign mixed model objects intact", { + object <- structure( + list( + anova_table = data.frame(JaspColumn_1_Encoded = "JaspColumn_2_Encoded", check.names = FALSE), + full_model = structure(list(JaspColumn_3_Encoded = "JaspColumn_1_Encoded"), class = "opaqueModel") + ), + class = "mixed", + type = "3", + method = "S" + ) + + decoded <- jaspBase:::.decodeJaspRObject(object, decodeContext = localDecodeContext()) + + testthat::expect_identical(decoded, object) +}) + testthat::test_that("R6 result wrappers keep their analysis decode context", { jaspResults <- jaspBase:::jaspResultsR$new(jaspBase:::create_cpp_jaspResults("Context test", NULL)) jaspResults$setDecodeContext(localDecodeContext()) @@ -182,6 +228,28 @@ testthat::test_that("R6 result wrappers keep their analysis decode context", { testthat::expect_equal(child$getDecodeContext()[["columns"]], localDecodeContext()[["columns"]]) }) +testthat::test_that("decoder leaves opaque S4 internals intact", { + className <- paste0("OpaqueDecodeState", sample.int(.Machine$integer.max, 1L)) + methods::setClass(className, slots = c(label = "character"), where = environment()) + object <- methods::new(className, label = "JaspColumn_1_Encoded") + + decoded <- jaspBase:::.decodeJaspRObject(object, decodeContext = localDecodeContext()) + + testthat::expect_s4_class(decoded, className) + testthat::expect_identical(methods::slot(decoded, "label"), "JaspColumn_1_Encoded") +}) + +testthat::test_that("decoder leaves opaque classed objects intact", { + object <- structure( + list(JaspColumn_1_Encoded = "JaspColumn_2_Encoded"), + class = "opaqueModelState" + ) + + decoded <- jaspBase:::.decodeJaspRObject(object, decodeContext = localDecodeContext()) + + testthat::expect_identical(decoded, object) +}) + testthat::test_that("printing output wrappers shows the R-facing object", { richResult <- list( toRObject = function() list( @@ -329,7 +397,7 @@ testthat::test_that("container wrapper printing formats nested paths and protect testthat::expect_true(any(grepl("plain child", printed, fixed = TRUE))) }) -testthat::test_that("result state decoding eagerly decodes figures and other state", { +testthat::test_that("result state decoding eagerly decodes figures and preserves analysis state", { plot <- ggplot2::ggplot( data.frame(x = 1, y = 2), ggplot2::aes(x = x, y = y) @@ -344,7 +412,7 @@ testthat::test_that("result state decoding eagerly decodes figures and other sta "1.png" = list(obj = plot), "2.png" = list(other = "JaspColumn_1_Encoded") ), - other = list(label = "JaspColumn_2_Encoded") + other = list(model = list(label = "JaspColumn_2_Encoded")) ) decoded <- jaspBase:::.decodeJaspResultState(state, decodeContext = localDecodeContext()) @@ -352,7 +420,7 @@ testthat::test_that("result state decoding eagerly decodes figures and other sta testthat::expect_equal(unname(decoded$figures[["1.png"]]$obj$labels$x), "group") testthat::expect_equal(unname(decoded$figures[["1.png"]]$obj$labels$y), "score") testthat::expect_identical(decoded$figures[["2.png"]]$other, "group") - testthat::expect_identical(decoded$other$label, "score") + testthat::expect_identical(decoded$other, state$other) }) testthat::test_that("result state decoding is internal", { From 7be9ac375ed4e854f93d9105f586496a2d0e69ff Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Mon, 1 Jun 2026 10:48:47 +0200 Subject: [PATCH 18/22] Use captured SyntaxInterface decoder context Carry the native column decoder snapshot through jaspBase result materialization so tables, plots, wrappers, and stored state decode against the analysis dataset rather than live global state. Keep fallback decoding shallow when jaspSyntax is unavailable and avoid double-rendering function/base plots when writing images. --- R/common.R | 2 +- R/resultDecoding.R | 74 +++++++++++++++----- R/writeImage.R | 65 ++++++++++++++++- tests/testthat/test-result-object-decoding.R | 27 +++++++ 4 files changed, 147 insertions(+), 21 deletions(-) diff --git a/R/common.R b/R/common.R index c60bca12..fe907454 100644 --- a/R/common.R +++ b/R/common.R @@ -846,7 +846,7 @@ saveImage <- function(plotName, format, height, width) plt <- .decodeJaspPlotObject( plt, - returnGrob = FALSE, + returnGrob = TRUE, decodeContext = .jaspDecodeContext(source = "stored-result-state") ) diff --git a/R/resultDecoding.R b/R/resultDecoding.R index f6280701..65c14ae1 100644 --- a/R/resultDecoding.R +++ b/R/resultDecoding.R @@ -1,10 +1,12 @@ -.jaspDecodeContext <- function(columns = character(), factors = list(), source = "manual", allowLiveFallback = FALSE) { +.jaspDecodeContext <- function(columns = character(), factors = list(), columnDecoder = NULL, + source = "manual", allowLiveFallback = FALSE) { columns <- .normalizeJaspColumnMapping(columns) factors <- .normalizeJaspFactorMappings(factors, columns) list( version = 1L, columns = columns, + columnDecoder = columnDecoder, factors = factors, source = source, allowLiveFallback = isTRUE(allowLiveFallback), @@ -17,6 +19,7 @@ list( version = decodeContext[["version"]], columns = decodeContext[["columns"]], + columnDecoder = decodeContext[["columnDecoder"]], factors = decodeContext[["factors"]], source = decodeContext[["source"]], allowLiveFallback = isTRUE(decodeContext[["allowLiveFallback"]]) @@ -28,7 +31,6 @@ return(eval.parent(substitute(expr))) decodeContext <- .normalizeJaspDecodeContext(decodeContext) - columns <- decodeContext[["columns"]] oldStrict <- .globalBinding(".decodeColNamesStrict") oldLax <- .globalBinding(".decodeColNamesLax") @@ -37,8 +39,8 @@ .restoreGlobalBinding(".decodeColNamesLax", oldLax) }, add = TRUE) - assign(".decodeColNamesStrict", .decodeJaspColumnsStrict(columns), envir = .GlobalEnv) - assign(".decodeColNamesLax", .decodeJaspColumnsLax(columns), envir = .GlobalEnv) + assign(".decodeColNamesStrict", .decodeJaspColumnsStrict(decodeContext), envir = .GlobalEnv) + assign(".decodeColNamesLax", .decodeJaspColumnsLax(decodeContext), envir = .GlobalEnv) eval.parent(substitute(expr)) } @@ -60,26 +62,24 @@ invisible(NULL) } -.decodeJaspColumnsStrict <- function(columnMapping) { - force(columnMapping) +.decodeJaspColumnsStrict <- function(decodeContext) { + force(decodeContext) function(x) { - if (!is.character(x) || length(x) == 0L || length(columnMapping) == 0L) + if (!is.character(x) || length(x) == 0L) return(x) - out <- x - matched <- !is.na(out) & out %in% names(columnMapping) - out[matched] <- unname(columnMapping[out[matched]]) - out + .decodeJaspColumnText(x, decodeContext) } } -.decodeJaspColumnsLax <- function(columnMapping) { - force(columnMapping) - function(x) .decodeJaspColumnText(x, columnMapping) +.decodeJaspColumnsLax <- function(decodeContext) { + force(decodeContext) + function(x) .decodeJaspColumnText(x, decodeContext) } .currentJaspDecodeContext <- function(allowLiveFallback = FALSE) { columnMapping <- character() + columnDecoder <- NULL requestedDataset <- NULL if (requireNamespace("jaspSyntax", quietly = TRUE)) { @@ -87,6 +87,10 @@ getExportedValue("jaspSyntax", "readRequestedDataset")(decode = FALSE, normalize = FALSE), error = function(e) NULL ) + columnDecoder <- tryCatch( + getExportedValue("jaspSyntax", "columnDecoderSnapshot")(), + error = function(e) NULL + ) defaultMapping <- tryCatch( getExportedValue("jaspSyntax", "columnMapping")(strict = FALSE), error = function(e) character() @@ -107,6 +111,7 @@ .jaspDecodeContext( columns = columnMapping, + columnDecoder = columnDecoder, factors = .jaspFactorMappingsFromDataset(requestedDataset, columnMapping), source = "jaspSyntax", allowLiveFallback = allowLiveFallback @@ -202,23 +207,54 @@ any(grepl(.jaspEncodedColumnTokenPattern(), x, perl = TRUE), na.rm = TRUE) } -.decodeJaspColumnText <- function(x, columnMapping = character()) { +.decodeJaspColumnTextWithMapping <- function(x, columnMapping = character()) { + columnMapping <- .normalizeJaspColumnMapping(columnMapping) if (!is.character(x) || length(x) == 0L || length(columnMapping) == 0L) return(x) - for (encoded in names(columnMapping)) - x <- gsub(encoded, unname(columnMapping[[encoded]]), x, fixed = TRUE) + tokens <- names(columnMapping) + tokens <- tokens[order(nchar(tokens), decreasing = TRUE)] + for (token in tokens) + x <- gsub(token, unname(columnMapping[[token]]), x, fixed = TRUE) x } +.decodeJaspColumnText <- function(x, columnMapping = character()) { + if (!is.character(x) || length(x) == 0L) + return(x) + + decoderSnapshot <- NULL + if (is.list(columnMapping) && (!is.null(columnMapping[["columns"]]) || !is.null(columnMapping[["columnDecoder"]]))) { + decoderSnapshot <- columnMapping[["columnDecoder"]] + columnMapping <- columnMapping[["columns"]] + if (length(columnMapping) == 0L && length(decoderSnapshot[["columns"]]) > 0L) + columnMapping <- decoderSnapshot[["columns"]] + if (is.null(decoderSnapshot) && length(columnMapping) > 0L) + decoderSnapshot <- columnMapping + } else if (length(columnMapping) > 0L) { + decoderSnapshot <- columnMapping + } + + decoded <- tryCatch( + getExportedValue("jaspSyntax", "decodeColumnText")(x, decoderSnapshot), + error = function(e) .decodeJaspColumnTextWithMapping(x, columnMapping) + ) + if (is.character(decoded) && length(decoded) == length(x)) { + names(decoded) <- names(x) + decoded + } else { + x + } +} + .decodeJaspFactorValues <- function(x, fieldName = NULL, decodeContext) { if (is.null(fieldName) || length(fieldName) != 1L || is.na(fieldName) || !nzchar(fieldName)) return(x) candidateFields <- unique(c( fieldName, - .decodeJaspColumnText(fieldName, decodeContext[["columns"]]) + .decodeJaspColumnText(fieldName, decodeContext) )) candidateFields <- candidateFields[!is.na(candidateFields) & nzchar(candidateFields)] @@ -262,7 +298,7 @@ decodeContext <- .normalizeJaspDecodeContext(decodeContext) x <- .decodeJaspFactorValues(x, fieldName = fieldName, decodeContext = decodeContext) - x <- .decodeJaspColumnText(x, decodeContext[["columns"]]) + x <- .decodeJaspColumnText(x, decodeContext) if (isTRUE(decodeContext[["allowLiveFallback"]]) && length(decodeContext[["columns"]]) == 0L) { fallback <- tryCatch( diff --git a/R/writeImage.R b/R/writeImage.R index 9319d890..67674e97 100755 --- a/R/writeImage.R +++ b/R/writeImage.R @@ -80,7 +80,11 @@ writeImageJaspResults <- function(plot, width = 320, height = 320, obj = TRUE, r height <- height * (ppi / 96) plotObject <- .decodeJaspPlotObject(plot, returnGrob = FALSE, decodeContext = decodeContext) - plot2draw <- plotObject + plot2draw <- if (ggplot2::is.ggplot(plot)) { + .decodeJaspPlotObject(plot, returnGrob = TRUE, decodeContext = decodeContext) + } else { + plotObject + } openGrDevice(file = relativePathpng, width = width, height = height, res = 72 * (ppi / 96), background = backgroundColor)#, dpi = ppi) on.exit(grDevices::dev.off(), add = TRUE) @@ -184,6 +188,18 @@ decodeplot.gg <- function(x, returnGrob = TRUE, ..., decodeContext = NULL) { # TODO: do not return a grid object! # we can do this by automatically replacing the scales and geoms, although this is quite a lot of work. # alternatively, those edge cases will need to be handled by the developer. + x$data <- .decodeGgplotData(x$data, decodeContext = decodeContext) + x$mapping <- .decodeGgplotMapping(x$mapping, decodeContext = decodeContext) + + for (i in seq_along(x$layers)) { + x$layers[[i]]$data <- .decodeGgplotData(x$layers[[i]]$data, decodeContext = decodeContext) + x$layers[[i]]$mapping <- .decodeGgplotMapping(x$layers[[i]]$mapping, decodeContext = decodeContext) + } + + x$facet$params$facets <- .decodeGgplotMapping(x$facet$params$facets, decodeContext = decodeContext) + x$facet$params$rows <- .decodeGgplotMapping(x$facet$params$rows, decodeContext = decodeContext) + x$facet$params$cols <- .decodeGgplotMapping(x$facet$params$cols, decodeContext = decodeContext) + labels <- x$labels # x[["labels"]] needs to be subsetted by `$`, not `[[`, as patchwork objects would fail if subsetting with `[[` for (i in seq_along(labels)) if (!is.null(labels[[i]])) @@ -241,6 +257,53 @@ decodeplot.gg <- function(x, returnGrob = TRUE, ..., decodeContext = NULL) { } } +.decodeGgplotData <- function(data, decodeContext = NULL) { + if (is.data.frame(data)) + .decodeJaspRObject(data, decodeContext = decodeContext) + else + data +} + +.decodeGgplotMapping <- function(mapping, decodeContext = NULL) { + if (is.null(mapping) || length(mapping) == 0L) + return(mapping) + + oldNames <- names(mapping) + for (i in seq_along(mapping)) + mapping[[i]] <- .decodeGgplotExpression(mapping[[i]], decodeContext = decodeContext) + if (!is.null(oldNames)) + names(mapping) <- .decodeJaspText(oldNames, decodeContext = decodeContext) + + mapping +} + +.decodeGgplotExpression <- function(x, decodeContext = NULL) { + if (rlang::is_quosure(x)) { + return(rlang::new_quosure( + .decodeGgplotExpression(rlang::quo_get_expr(x), decodeContext = decodeContext), + rlang::quo_get_env(x) + )) + } + + if (is.name(x)) { + decodedName <- .decodeJaspText(as.character(x), decodeContext = decodeContext) + if (identical(decodedName, as.character(x))) + x + else + rlang::sym(decodedName) + } else if (is.call(x)) { + callParts <- as.list(x) + if (length(callParts) > 1L) + for (i in seq.int(2L, length(callParts))) + callParts[[i]] <- .decodeGgplotExpression(callParts[[i]], decodeContext = decodeContext) + as.call(callParts) + } else if (is.character(x)) { + .decodeJaspText(x, decodeContext = decodeContext) + } else { + x + } +} + #' @export decodeplot.patchwork <- function(x, ..., decodeContext = NULL) { decodeContext <- .normalizeJaspDecodeContext(decodeContext) diff --git a/tests/testthat/test-result-object-decoding.R b/tests/testthat/test-result-object-decoding.R index 103a63ce..54fa6031 100644 --- a/tests/testthat/test-result-object-decoding.R +++ b/tests/testthat/test-result-object-decoding.R @@ -55,6 +55,33 @@ testthat::test_that("decodeplot.gg returns decoded labels for R-facing plots", { testthat::expect_equal(unname(decoded$labels$y), "score") }) +testthat::test_that("decodeplot.gg decodes plot-owned data, mappings, and metadata", { + plotData <- data.frame( + JaspColumn_1_Encoded = factor(c("1", "2")), + JaspColumn_2_Encoded = c(3, 4), + check.names = FALSE + ) + attr(plotData, "pri.vars") <- "JaspColumn_1_Encoded" + attr(plotData, "x") <- "JaspColumn_1_Encoded" + attr(plotData, "dv") <- "JaspColumn_2_Encoded" + + plot <- ggplot2::ggplot( + plotData, + ggplot2::aes(x = JaspColumn_1_Encoded, y = JaspColumn_2_Encoded) + ) + + ggplot2::geom_point() + + decoded <- jaspBase:::decodeplot(plot, returnGrob = FALSE, decodeContext = localDecodeContext()) + + testthat::expect_named(decoded$data, c("group", "score")) + testthat::expect_equal(levels(decoded$data$group), c("control", "treatment")) + testthat::expect_identical(attr(decoded$data, "pri.vars"), "group") + testthat::expect_identical(attr(decoded$data, "x"), "group") + testthat::expect_identical(attr(decoded$data, "dv"), "score") + testthat::expect_identical(as.character(rlang::quo_get_expr(decoded$mapping$x)), "group") + testthat::expect_identical(as.character(rlang::quo_get_expr(decoded$mapping$y)), "score") +}) + testthat::test_that("writeImage uses decoded editable objects for state and interactive conversion", { ns <- asNamespace("jaspGraphs") original <- get("convertGgplotToPlotly", envir = ns) From 3189fcc550ddbd37004f41eea1fe770284739b33 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Tue, 2 Jun 2026 17:02:58 +0200 Subject: [PATCH 19/22] Remove R-side column decode fallbacks --- R/common.R | 5 +- R/resultDecoding.R | 50 +++------ R/writeImage.R | 17 +++- R/zzzWrappers.R | 11 +- tests/testthat/test-result-object-decoding.R | 101 ++++++++++++------- tests/testthat/test-runWrappedAnalysis.R | 84 +++++++++++---- 6 files changed, 167 insertions(+), 101 deletions(-) diff --git a/R/common.R b/R/common.R index fe907454..7a7f8416 100644 --- a/R/common.R +++ b/R/common.R @@ -1258,10 +1258,7 @@ storeDataSet <- function(dataset) { if (!is.character(message) || length(message) != 1L || is.na(message) || !nzchar(message)) return(message) - decoded <- tryCatch( - .decodeJaspText(message, decodeContext = decodeContext), - error = function(e) message - ) + decoded <- .decodeJaspText(message, decodeContext = decodeContext) if (!is.character(decoded) || length(decoded) != 1L || is.na(decoded)) return(message) diff --git a/R/resultDecoding.R b/R/resultDecoding.R index 65c14ae1..00e101a7 100644 --- a/R/resultDecoding.R +++ b/R/resultDecoding.R @@ -1,5 +1,5 @@ .jaspDecodeContext <- function(columns = character(), factors = list(), columnDecoder = NULL, - source = "manual", allowLiveFallback = FALSE) { + source = "manual") { columns <- .normalizeJaspColumnMapping(columns) factors <- .normalizeJaspFactorMappings(factors, columns) @@ -9,7 +9,6 @@ columnDecoder = columnDecoder, factors = factors, source = source, - allowLiveFallback = isTRUE(allowLiveFallback), warningState = new.env(parent = emptyenv()) ) } @@ -21,8 +20,7 @@ columns = decodeContext[["columns"]], columnDecoder = decodeContext[["columnDecoder"]], factors = decodeContext[["factors"]], - source = decodeContext[["source"]], - allowLiveFallback = isTRUE(decodeContext[["allowLiveFallback"]]) + source = decodeContext[["source"]] ) } @@ -77,7 +75,7 @@ function(x) .decodeJaspColumnText(x, decodeContext) } -.currentJaspDecodeContext <- function(allowLiveFallback = FALSE) { +.currentJaspDecodeContext <- function() { columnMapping <- character() columnDecoder <- NULL requestedDataset <- NULL @@ -113,14 +111,13 @@ columns = columnMapping, columnDecoder = columnDecoder, factors = .jaspFactorMappingsFromDataset(requestedDataset, columnMapping), - source = "jaspSyntax", - allowLiveFallback = allowLiveFallback + source = "jaspSyntax" ) } -.normalizeJaspDecodeContext <- function(decodeContext = NULL, allowLiveFallback = is.null(decodeContext)) { +.normalizeJaspDecodeContext <- function(decodeContext = NULL) { if (is.null(decodeContext)) - return(.currentJaspDecodeContext(allowLiveFallback = allowLiveFallback)) + return(.currentJaspDecodeContext()) decodeContext[["columns"]] <- .normalizeJaspColumnMapping(decodeContext[["columns"]]) decodeContext[["factors"]] <- .normalizeJaspFactorMappings(decodeContext[["factors"]], decodeContext[["columns"]]) @@ -128,7 +125,6 @@ decodeContext[["version"]] <- 1L if (is.null(decodeContext[["source"]])) decodeContext[["source"]] <- "unknown" - decodeContext[["allowLiveFallback"]] <- isTRUE(decodeContext[["allowLiveFallback"]]) if (!is.environment(decodeContext[["warningState"]])) decodeContext[["warningState"]] <- new.env(parent = emptyenv()) @@ -207,22 +203,11 @@ any(grepl(.jaspEncodedColumnTokenPattern(), x, perl = TRUE), na.rm = TRUE) } -.decodeJaspColumnTextWithMapping <- function(x, columnMapping = character()) { - columnMapping <- .normalizeJaspColumnMapping(columnMapping) - if (!is.character(x) || length(x) == 0L || length(columnMapping) == 0L) - return(x) - - tokens <- names(columnMapping) - tokens <- tokens[order(nchar(tokens), decreasing = TRUE)] - for (token in tokens) - x <- gsub(token, unname(columnMapping[[token]]), x, fixed = TRUE) - - x -} - .decodeJaspColumnText <- function(x, columnMapping = character()) { if (!is.character(x) || length(x) == 0L) return(x) + if (!.containsJaspEncodedTokens(x)) + return(x) decoderSnapshot <- NULL if (is.list(columnMapping) && (!is.null(columnMapping[["columns"]]) || !is.null(columnMapping[["columnDecoder"]]))) { @@ -238,13 +223,19 @@ decoded <- tryCatch( getExportedValue("jaspSyntax", "decodeColumnText")(x, decoderSnapshot), - error = function(e) .decodeJaspColumnTextWithMapping(x, columnMapping) + error = function(e) { + stop( + "jaspBase result decoding requires a working native jaspSyntax column decoder: ", + conditionMessage(e), + call. = FALSE + ) + } ) if (is.character(decoded) && length(decoded) == length(x)) { names(decoded) <- names(x) decoded } else { - x + stop("Native jaspSyntax column decoder returned an invalid result.", call. = FALSE) } } @@ -300,15 +291,6 @@ x <- .decodeJaspFactorValues(x, fieldName = fieldName, decodeContext = decodeContext) x <- .decodeJaspColumnText(x, decodeContext) - if (isTRUE(decodeContext[["allowLiveFallback"]]) && length(decodeContext[["columns"]]) == 0L) { - fallback <- tryCatch( - decodeColNames(x, strict = FALSE), - error = function(e) x - ) - if (is.character(fallback) && length(fallback) == length(x)) - x <- fallback - } - .warnIfMissingJaspDecodeContext(x, decodeContext) x } diff --git a/R/writeImage.R b/R/writeImage.R index 67674e97..38858564 100755 --- a/R/writeImage.R +++ b/R/writeImage.R @@ -409,8 +409,21 @@ decodeColNames <- function(x, strict = FALSE, fun = NULL, ...) { fun <- .findFun(defaults[[type]][[method]]) - if (!is.function(fun)) - return(function(inIsOut){return(inIsOut)}) # Instead of complaining we just give it a dummy function + if (!is.function(fun)) { + if (type == "decode") { + return(function(inIsOut) { + if (.containsJaspEncodedTokens(inIsOut)) { + stop( + "No JASP column decoder is available for encoded column names.", + call. = FALSE + ) + } + inIsOut + }) + } + + return(function(inIsOut){return(inIsOut)}) # Outside JASP, raw names do not need encoding. + } return(fun) } diff --git a/R/zzzWrappers.R b/R/zzzWrappers.R index ef92e82f..93267a8f 100755 --- a/R/zzzWrappers.R +++ b/R/zzzWrappers.R @@ -46,13 +46,10 @@ progressbarTick <- function() { # we need to decode all the names for jaspObjects before going to CPP to avoid some problems. This because otherwise some jaspPlots (and others) might contain encoded columnnames. Which breaks plot-resizing-persistence #' @export decodeName <- function(name) { - if(jaspBase::jaspResultsCalledFromJasp()) { - tryCatch( - suppressWarnings(return(.getDefaultEnDeCoderFun("decode", FALSE)(name))), - error = function(e) { return(name) } - ) - - } else return(name) + if(jaspBase::jaspResultsCalledFromJasp()) + return(suppressWarnings(.getDefaultEnDeCoderFun("decode", FALSE)(name))) + + name } #' @export diff --git a/tests/testthat/test-result-object-decoding.R b/tests/testthat/test-result-object-decoding.R index 54fa6031..de9cff8b 100644 --- a/tests/testthat/test-result-object-decoding.R +++ b/tests/testthat/test-result-object-decoding.R @@ -1,31 +1,5 @@ -localDecoder <- function(mapping) { - oldDecoder <- if (exists(".decodeColNamesLax", envir = .GlobalEnv, inherits = FALSE)) { - get(".decodeColNamesLax", envir = .GlobalEnv, inherits = FALSE) - } else { - NULL - } - hadDecoder <- exists(".decodeColNamesLax", envir = .GlobalEnv, inherits = FALSE) - - assign( - ".decodeColNamesLax", - function(x) { - for (encoded in names(mapping)) - x <- gsub(encoded, unname(mapping[[encoded]]), x, fixed = TRUE) - x - }, - envir = .GlobalEnv - ) - - function() { - if (hadDecoder) { - assign(".decodeColNamesLax", oldDecoder, envir = .GlobalEnv) - } else if (exists(".decodeColNamesLax", envir = .GlobalEnv, inherits = FALSE)) { - rm(".decodeColNamesLax", envir = .GlobalEnv) - } - } -} - localDecodeContext <- function() { + testthat::skip_if_not_installed("jaspSyntax") jaspBase:::.jaspDecodeContext( columns = c( JaspColumn_1_Encoded = "group", @@ -38,6 +12,70 @@ localDecodeContext <- function() { ) } +localNamespaceBinding <- function(name, value, namespace) { + 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) + } +} + +localGlobalAbsent <- function(name) { + hadValue <- exists(name, envir = .GlobalEnv, inherits = FALSE) + oldValue <- if (hadValue) get(name, envir = .GlobalEnv, inherits = FALSE) else NULL + + if (hadValue) + rm(list = name, envir = .GlobalEnv) + + function() { + if (hadValue) + assign(name, oldValue, envir = .GlobalEnv) + } +} + +testthat::test_that("decodeColNames fails for encoded names when no decoder is installed", { + restoreStrict <- localGlobalAbsent(".decodeColNamesStrict") + restoreLax <- localGlobalAbsent(".decodeColNamesLax") + on.exit(restoreStrict(), add = TRUE) + on.exit(restoreLax(), add = TRUE) + + testthat::expect_identical(jaspBase::decodeColNames("plain name"), "plain name") + testthat::expect_error( + jaspBase::decodeColNames("JaspColumn_1_Encoded"), + "No JASP column decoder is available", + fixed = TRUE + ) +}) + +testthat::test_that("result decoding does not use R mapping replacement when native decoding fails", { + testthat::skip_if_not_installed("jaspSyntax") + restoreDecoder <- localNamespaceBinding( + "decodeColumnText", + function(text, decoderSnapshot = NULL) { + stop("native decode failure", call. = FALSE) + }, + asNamespace("jaspSyntax") + ) + on.exit(restoreDecoder(), add = TRUE) + + testthat::expect_error( + jaspBase:::.decodeJaspText("JaspColumn_1_Encoded", decodeContext = localDecodeContext()), + "native decode failure", + fixed = TRUE + ) +}) + testthat::test_that("decodeplot.gg returns decoded labels for R-facing plots", { plot <- ggplot2::ggplot( data.frame(x = 1, y = 2), @@ -240,9 +278,6 @@ testthat::test_that("R6 result wrappers keep their analysis decode context", { ) jaspResults[["JaspColumn_1_Encoded"]] <- table - restoreDecoder <- localDecoder(c(JaspColumn_1_Encoded = "wrong dataset name")) - on.exit(restoreDecoder(), add = TRUE) - decoded <- jaspResults$toRObject() child <- jaspResults[["JaspColumn_1_Encoded"]] decodedTable <- decoded[[1L]] @@ -472,18 +507,12 @@ testthat::test_that("decoded result objects persist without a live decoder", { path <- tempfile(fileext = ".rds") saveRDS(decoded, path) - restoreDecoder <- localDecoder(c(JaspColumn_1_Encoded = "wrong dataset name")) - on.exit(restoreDecoder(), add = TRUE) - restored <- readRDS(path) testthat::expect_equal(restored$table$group, c("control", "treatment")) testthat::expect_equal(unname(restored$plot$plotObject$labels$x), "group") }) testthat::test_that("missing decode context warns for encoded legacy state", { - restoreDecoder <- localDecoder(c(JaspColumn_1_Encoded = "wrong dataset name")) - on.exit(restoreDecoder(), add = TRUE) - state <- list(other = list(label = "JaspColumn_1_Encoded")) testthat::expect_warning( diff --git a/tests/testthat/test-runWrappedAnalysis.R b/tests/testthat/test-runWrappedAnalysis.R index e535f241..bf99995a 100644 --- a/tests/testthat/test-runWrappedAnalysis.R +++ b/tests/testthat/test-runWrappedAnalysis.R @@ -1,3 +1,22 @@ +localNamespaceBinding <- function(name, value, namespace) { + 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) + } +} + testthat::test_that("wrapped analysis QML paths prefer explicit files", { explicitFile <- tempfile(fileext = ".qml") writeLines("import QtQuick", explicitFile) @@ -113,25 +132,24 @@ testthat::test_that("wrapped analysis verbosity honors jaspSyntax default option }) testthat::test_that("wrapped analysis verbosity decodes analysis conditions", { - oldDecoder <- if (exists(".decodeColNamesLax", envir = .GlobalEnv, inherits = FALSE)) { - get(".decodeColNamesLax", envir = .GlobalEnv, inherits = FALSE) - } else { - NULL - } - hadDecoder <- exists(".decodeColNamesLax", envir = .GlobalEnv, inherits = FALSE) - on.exit({ - if (hadDecoder) { - assign(".decodeColNamesLax", oldDecoder, envir = .GlobalEnv) - } else if (exists(".decodeColNamesLax", envir = .GlobalEnv, inherits = FALSE)) { - rm(".decodeColNamesLax", envir = .GlobalEnv) - } - }, add = TRUE) - - assign( - ".decodeColNamesLax", - function(x) gsub("JaspColumn_3_Encoded", "angle", x, fixed = TRUE), - envir = .GlobalEnv + testthat::skip_if_not_installed("jaspSyntax") + decodeContext <- jaspBase:::.jaspDecodeContext( + columns = c(JaspColumn_3_Encoded = "angle") + ) + restoreContext <- localNamespaceBinding( + ".currentJaspDecodeContext", + function() decodeContext, + asNamespace("jaspBase") ) + restoreDecoder <- localNamespaceBinding( + "decodeColumnText", + function(text, decoderSnapshot = NULL) { + gsub("JaspColumn_3_Encoded", "angle", text, fixed = TRUE) + }, + asNamespace("jaspSyntax") + ) + on.exit(restoreContext(), add = TRUE) + on.exit(restoreDecoder(), add = TRUE) noisyValue <- function() { message("analysis message: JaspColumn_3_Encoded") @@ -159,6 +177,36 @@ testthat::test_that("wrapped analysis verbosity decodes analysis conditions", { ) }) +testthat::test_that("wrapped analysis condition decoding propagates native decoder failures", { + testthat::skip_if_not_installed("jaspSyntax") + decodeContext <- jaspBase:::.jaspDecodeContext( + columns = c(JaspColumn_3_Encoded = "angle") + ) + restoreContext <- localNamespaceBinding( + ".currentJaspDecodeContext", + function() decodeContext, + asNamespace("jaspBase") + ) + restoreDecoder <- localNamespaceBinding( + "decodeColumnText", + function(text, decoderSnapshot = NULL) { + stop("native decode failure", call. = FALSE) + }, + asNamespace("jaspSyntax") + ) + on.exit(restoreContext(), add = TRUE) + on.exit(restoreDecoder(), add = TRUE) + + testthat::expect_error( + jaspBase:::.runWrappedAnalysisWithVerbosity( + stop("analysis error: JaspColumn_3_Encoded", call. = FALSE), + verbose = "analysis" + ), + "native decode failure", + fixed = TRUE + ) +}) + testthat::test_that("standalone bridge can read the full dataset callback", { oldCallback <- if (exists(".readFullDatasetToEnd", envir = .GlobalEnv, inherits = FALSE)) { get(".readFullDatasetToEnd", envir = .GlobalEnv, inherits = FALSE) From 967e59397ea19e1c80a2bdbf14531bb87d0d99f7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Wed, 3 Jun 2026 15:13:00 +0200 Subject: [PATCH 20/22] Use native encoder context for result decoding --- R/resultDecoding.R | 86 ++++++-------------- tests/testthat/test-result-object-decoding.R | 55 +++++++++++-- tests/testthat/test-runWrappedAnalysis.R | 24 ++++-- 3 files changed, 84 insertions(+), 81 deletions(-) diff --git a/R/resultDecoding.R b/R/resultDecoding.R index 00e101a7..24742145 100644 --- a/R/resultDecoding.R +++ b/R/resultDecoding.R @@ -1,12 +1,10 @@ -.jaspDecodeContext <- function(columns = character(), factors = list(), columnDecoder = NULL, +.jaspDecodeContext <- function(columnEncoderContext = NULL, factors = list(), source = "manual") { - columns <- .normalizeJaspColumnMapping(columns) - factors <- .normalizeJaspFactorMappings(factors, columns) + factors <- .normalizeJaspFactorMappings(factors, columnEncoderContext) list( version = 1L, - columns = columns, - columnDecoder = columnDecoder, + columnEncoderContext = columnEncoderContext, factors = factors, source = source, warningState = new.env(parent = emptyenv()) @@ -17,8 +15,7 @@ decodeContext <- .normalizeJaspDecodeContext(decodeContext) list( version = decodeContext[["version"]], - columns = decodeContext[["columns"]], - columnDecoder = decodeContext[["columnDecoder"]], + columnEncoderContext = decodeContext[["columnEncoderContext"]], factors = decodeContext[["factors"]], source = decodeContext[["source"]] ) @@ -76,8 +73,7 @@ } .currentJaspDecodeContext <- function() { - columnMapping <- character() - columnDecoder <- NULL + columnEncoderContext <- NULL requestedDataset <- NULL if (requireNamespace("jaspSyntax", quietly = TRUE)) { @@ -85,32 +81,15 @@ getExportedValue("jaspSyntax", "readRequestedDataset")(decode = FALSE, normalize = FALSE), error = function(e) NULL ) - columnDecoder <- tryCatch( - getExportedValue("jaspSyntax", "columnDecoderSnapshot")(), + columnEncoderContext <- tryCatch( + getExportedValue("jaspSyntax", "columnEncoderContext")(), error = function(e) NULL ) - defaultMapping <- tryCatch( - getExportedValue("jaspSyntax", "columnMapping")(strict = FALSE), - error = function(e) character() - ) - requestedMapping <- character() - requestedNames <- if (is.data.frame(requestedDataset)) names(requestedDataset) else character() - if (length(requestedNames) > 0L && .containsJaspEncodedTokens(requestedNames)) { - requestedMapping <- tryCatch( - getExportedValue("jaspSyntax", "columnMapping")(requestedNames, strict = FALSE), - error = function(e) character() - ) - } - columnMapping <- c( - requestedMapping, - defaultMapping[setdiff(names(defaultMapping), names(requestedMapping))] - ) } .jaspDecodeContext( - columns = columnMapping, - columnDecoder = columnDecoder, - factors = .jaspFactorMappingsFromDataset(requestedDataset, columnMapping), + columnEncoderContext = columnEncoderContext, + factors = .jaspFactorMappingsFromDataset(requestedDataset, columnEncoderContext), source = "jaspSyntax" ) } @@ -119,8 +98,10 @@ if (is.null(decodeContext)) return(.currentJaspDecodeContext()) - decodeContext[["columns"]] <- .normalizeJaspColumnMapping(decodeContext[["columns"]]) - decodeContext[["factors"]] <- .normalizeJaspFactorMappings(decodeContext[["factors"]], decodeContext[["columns"]]) + decodeContext[["factors"]] <- .normalizeJaspFactorMappings( + decodeContext[["factors"]], + decodeContext[["columnEncoderContext"]] + ) if (is.null(decodeContext[["version"]])) decodeContext[["version"]] <- 1L if (is.null(decodeContext[["source"]])) @@ -131,18 +112,7 @@ decodeContext } -.normalizeJaspColumnMapping <- function(columnMapping = NULL) { - if (is.null(columnMapping) || length(columnMapping) == 0L) - return(stats::setNames(character(), character())) - if (!is.character(columnMapping) || is.null(names(columnMapping))) - return(stats::setNames(character(), character())) - - valid <- !is.na(columnMapping) & nzchar(columnMapping) & - !is.na(names(columnMapping)) & nzchar(names(columnMapping)) - columnMapping[valid] -} - -.normalizeJaspFactorMappings <- function(factorMappings = NULL, columnMapping = character()) { +.normalizeJaspFactorMappings <- function(factorMappings = NULL, columnEncoderContext = NULL) { if (is.null(factorMappings) || length(factorMappings) == 0L) return(list()) @@ -159,14 +129,13 @@ valid <- !is.na(valueMap) & !is.na(names(valueMap)) & nzchar(names(valueMap)) valueMap <- valueMap[valid] - valueMap <- .decodeJaspColumnText(valueMap, columnMapping) + valueMap <- .decodeJaspColumnText(valueMap, columnEncoderContext) if (length(valueMap) == 0L) next aliases <- unique(c( fieldName, - .decodeJaspColumnText(fieldName, columnMapping), - names(columnMapping)[!is.na(columnMapping) & columnMapping == fieldName] + .decodeJaspColumnText(fieldName, columnEncoderContext) )) aliases <- aliases[!is.na(aliases) & nzchar(aliases)] for (alias in aliases) @@ -176,7 +145,7 @@ normalized } -.jaspFactorMappingsFromDataset <- function(requestedDataset, columnMapping = character()) { +.jaspFactorMappingsFromDataset <- function(requestedDataset, columnEncoderContext = NULL) { if (!is.data.frame(requestedDataset)) return(list()) @@ -192,10 +161,10 @@ ) } - .normalizeJaspFactorMappings(factorMappings, columnMapping) + .normalizeJaspFactorMappings(factorMappings, columnEncoderContext) } -.jaspEncodedColumnTokenPattern <- function() "(JaspColumn_[[:alnum:]_]+_Encoded|jaspColumn[0-9]+)" +.jaspEncodedColumnTokenPattern <- function() "(JaspColumn_[[:alnum:]_]+_Encoded|JaspExtraOptions_[[:alnum:]_]+_Encoded|jaspColumn[0-9]+)" .containsJaspEncodedTokens <- function(x) { if (!is.character(x) || length(x) == 0L) @@ -203,26 +172,17 @@ any(grepl(.jaspEncodedColumnTokenPattern(), x, perl = TRUE), na.rm = TRUE) } -.decodeJaspColumnText <- function(x, columnMapping = character()) { +.decodeJaspColumnText <- function(x, columnEncoderContext = NULL) { if (!is.character(x) || length(x) == 0L) return(x) if (!.containsJaspEncodedTokens(x)) return(x) - decoderSnapshot <- NULL - if (is.list(columnMapping) && (!is.null(columnMapping[["columns"]]) || !is.null(columnMapping[["columnDecoder"]]))) { - decoderSnapshot <- columnMapping[["columnDecoder"]] - columnMapping <- columnMapping[["columns"]] - if (length(columnMapping) == 0L && length(decoderSnapshot[["columns"]]) > 0L) - columnMapping <- decoderSnapshot[["columns"]] - if (is.null(decoderSnapshot) && length(columnMapping) > 0L) - decoderSnapshot <- columnMapping - } else if (length(columnMapping) > 0L) { - decoderSnapshot <- columnMapping - } + if (is.list(columnEncoderContext) && "columnEncoderContext" %in% names(columnEncoderContext)) + columnEncoderContext <- columnEncoderContext[["columnEncoderContext"]] decoded <- tryCatch( - getExportedValue("jaspSyntax", "decodeColumnText")(x, decoderSnapshot), + getExportedValue("jaspSyntax", "decodeColumnText")(x, columnEncoderContext), error = function(e) { stop( "jaspBase result decoding requires a working native jaspSyntax column decoder: ", diff --git a/tests/testthat/test-result-object-decoding.R b/tests/testthat/test-result-object-decoding.R index de9cff8b..a541fa7c 100644 --- a/tests/testthat/test-result-object-decoding.R +++ b/tests/testthat/test-result-object-decoding.R @@ -1,17 +1,51 @@ localDecodeContext <- function() { testthat::skip_if_not_installed("jaspSyntax") + localTestColumnDecoder() + columnEncoderContext <- testColumnEncoderContext() jaspBase:::.jaspDecodeContext( - columns = c( - JaspColumn_1_Encoded = "group", - JaspColumn_2_Encoded = "score", - JaspColumn_3_Encoded = "cluster" - ), + columnEncoderContext = columnEncoderContext, factors = list( JaspColumn_1_Encoded = c("1" = "control", "2" = "treatment") ) ) } +testColumnEncoderContext <- function() { + structure( + list( + version = 1L, + columns = list( + list(name = "cluster", type = "unknown"), + list(name = "group", type = "unknown"), + list(name = "score", type = "unknown") + ), + extra = list() + ), + class = "jaspSyntaxColumnEncoderContext" + ) +} + +localTestColumnDecoder <- local({ + function() { + restore <- localNamespaceBinding( + "decodeColumnText", + function(text, encoderContext = NULL) { + if (is.null(encoderContext)) + return(text) + + out <- text + out <- gsub("JaspColumn_0_Encoded", "cluster", out, fixed = TRUE) + out <- gsub("JaspColumn_1_Encoded", "group", out, fixed = TRUE) + out <- gsub("JaspColumn_2_Encoded", "score", out, fixed = TRUE) + out + }, + asNamespace("jaspSyntax") + ) + withr::defer(restore(), testthat::teardown_env()) + invisible(NULL) + } +}) + localNamespaceBinding <- function(name, value, namespace) { oldValue <- get(name, envir = namespace, inherits = FALSE) wasLocked <- bindingIsLocked(name, namespace) @@ -62,15 +96,18 @@ testthat::test_that("result decoding does not use R mapping replacement when nat testthat::skip_if_not_installed("jaspSyntax") restoreDecoder <- localNamespaceBinding( "decodeColumnText", - function(text, decoderSnapshot = NULL) { + function(text, encoderContext = NULL) { stop("native decode failure", call. = FALSE) }, asNamespace("jaspSyntax") ) on.exit(restoreDecoder(), add = TRUE) + decodeContext <- jaspBase:::.jaspDecodeContext( + columnEncoderContext = testColumnEncoderContext() + ) testthat::expect_error( - jaspBase:::.decodeJaspText("JaspColumn_1_Encoded", decodeContext = localDecodeContext()), + jaspBase:::.decodeJaspText("JaspColumn_1_Encoded", decodeContext = decodeContext), "native decode failure", fixed = TRUE ) @@ -177,7 +214,7 @@ testthat::test_that("toRObject result copies decode tables, footnotes, and plots class(table) <- c("jaspTableWrapper", "jaspWrapper", class(table)) attr(table, "title") <- "JaspColumn_1_Encoded table" attr(table, "footnotes") <- list(list( - text = "The following variable is 'JaspColumn_3_Encoded'.", + text = "The following variable is 'JaspColumn_0_Encoded'.", symbol = "Note." )) @@ -192,7 +229,7 @@ testthat::test_that("toRObject result copies decode tables, footnotes, and plots ) plotWrapper <- list(plotObject = plot) class(plotWrapper) <- c("jaspPlotWrapper", "jaspWrapper") - attr(plotWrapper, "title") <- "JaspColumn_3_Encoded plot" + attr(plotWrapper, "title") <- "JaspColumn_0_Encoded plot" result <- list( JaspColumn_1_Encoded = table, diff --git a/tests/testthat/test-runWrappedAnalysis.R b/tests/testthat/test-runWrappedAnalysis.R index bf99995a..be85555a 100644 --- a/tests/testthat/test-runWrappedAnalysis.R +++ b/tests/testthat/test-runWrappedAnalysis.R @@ -134,7 +134,10 @@ testthat::test_that("wrapped analysis verbosity honors jaspSyntax default option testthat::test_that("wrapped analysis verbosity decodes analysis conditions", { testthat::skip_if_not_installed("jaspSyntax") decodeContext <- jaspBase:::.jaspDecodeContext( - columns = c(JaspColumn_3_Encoded = "angle") + columnEncoderContext = structure( + list(columns = list(list(name = "angle", type = "unknown")), extra = list()), + class = "jaspSyntaxColumnEncoderContext" + ) ) restoreContext <- localNamespaceBinding( ".currentJaspDecodeContext", @@ -143,8 +146,8 @@ testthat::test_that("wrapped analysis verbosity decodes analysis conditions", { ) restoreDecoder <- localNamespaceBinding( "decodeColumnText", - function(text, decoderSnapshot = NULL) { - gsub("JaspColumn_3_Encoded", "angle", text, fixed = TRUE) + function(text, encoderContext = NULL) { + gsub("JaspColumn_0_Encoded", "angle", text, fixed = TRUE) }, asNamespace("jaspSyntax") ) @@ -152,8 +155,8 @@ testthat::test_that("wrapped analysis verbosity decodes analysis conditions", { on.exit(restoreDecoder(), add = TRUE) noisyValue <- function() { - message("analysis message: JaspColumn_3_Encoded") - warning("analysis warning: JaspColumn_3_Encoded", call. = FALSE) + message("analysis message: JaspColumn_0_Encoded") + warning("analysis warning: JaspColumn_0_Encoded", call. = FALSE) 42 } @@ -170,7 +173,7 @@ testthat::test_that("wrapped analysis verbosity decodes analysis conditions", { testthat::expect_error( jaspBase:::.runWrappedAnalysisWithVerbosity( - stop("analysis error: JaspColumn_3_Encoded", call. = FALSE), + stop("analysis error: JaspColumn_0_Encoded", call. = FALSE), verbose = "analysis" ), "analysis error: angle" @@ -180,7 +183,10 @@ testthat::test_that("wrapped analysis verbosity decodes analysis conditions", { testthat::test_that("wrapped analysis condition decoding propagates native decoder failures", { testthat::skip_if_not_installed("jaspSyntax") decodeContext <- jaspBase:::.jaspDecodeContext( - columns = c(JaspColumn_3_Encoded = "angle") + columnEncoderContext = structure( + list(columns = list(list(name = "angle", type = "unknown")), extra = list()), + class = "jaspSyntaxColumnEncoderContext" + ) ) restoreContext <- localNamespaceBinding( ".currentJaspDecodeContext", @@ -189,7 +195,7 @@ testthat::test_that("wrapped analysis condition decoding propagates native decod ) restoreDecoder <- localNamespaceBinding( "decodeColumnText", - function(text, decoderSnapshot = NULL) { + function(text, encoderContext = NULL) { stop("native decode failure", call. = FALSE) }, asNamespace("jaspSyntax") @@ -199,7 +205,7 @@ testthat::test_that("wrapped analysis condition decoding propagates native decod testthat::expect_error( jaspBase:::.runWrappedAnalysisWithVerbosity( - stop("analysis error: JaspColumn_3_Encoded", call. = FALSE), + stop("analysis error: JaspColumn_0_Encoded", call. = FALSE), verbose = "analysis" ), "native decode failure", From 322fc31ec6bbfc0504963055cc889aa88741bb11 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Thu, 4 Jun 2026 15:05:18 +0200 Subject: [PATCH 21/22] Tighten result decode context handling --- DESCRIPTION | 3 +- R/resultDecoding.R | 13 ++--- tests/testthat/test-result-object-decoding.R | 52 ++++++++++++++++++++ 3 files changed, 58 insertions(+), 10 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index b3eed2d5..941132fd 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -41,6 +41,7 @@ Encoding: UTF-8 LinkingTo: Rcpp RcppModules: jaspResults NeedsCompilation: yes -Suggests: +Suggests: + jaspSyntax (>= 1.3.3), testthat (>= 3.0.0) Config/testthat/edition: 3 diff --git a/R/resultDecoding.R b/R/resultDecoding.R index 24742145..41455537 100644 --- a/R/resultDecoding.R +++ b/R/resultDecoding.R @@ -180,6 +180,8 @@ if (is.list(columnEncoderContext) && "columnEncoderContext" %in% names(columnEncoderContext)) columnEncoderContext <- columnEncoderContext[["columnEncoderContext"]] + if (is.null(columnEncoderContext)) + return(x) decoded <- tryCatch( getExportedValue("jaspSyntax", "decodeColumnText")(x, columnEncoderContext), @@ -299,16 +301,9 @@ return(plot) decodeContext <- .normalizeJaspDecodeContext(decodeContext) - decodeFailed <- FALSE - decoded <- tryCatch( - decodeplot(plot, returnGrob = returnGrob, decodeContext = decodeContext), - error = function(e) { - decodeFailed <<- TRUE - plot - } - ) + decoded <- decodeplot(plot, returnGrob = returnGrob, decodeContext = decodeContext) - if (!isTRUE(returnGrob) && !isTRUE(decodeFailed)) + if (!isTRUE(returnGrob)) decoded <- .markJaspDecodedPlotObject(decoded) decoded diff --git a/tests/testthat/test-result-object-decoding.R b/tests/testthat/test-result-object-decoding.R index a541fa7c..3ed79ba8 100644 --- a/tests/testthat/test-result-object-decoding.R +++ b/tests/testthat/test-result-object-decoding.R @@ -113,6 +113,29 @@ testthat::test_that("result decoding does not use R mapping replacement when nat ) }) +testthat::test_that("missing decode context does not borrow live native decoder state", { + testthat::skip_if_not_installed("jaspSyntax") + restoreDecoder <- localNamespaceBinding( + "decodeColumnText", + function(text, encoderContext = NULL) { + if (is.null(encoderContext)) + return(rep("wrong dataset name", length(text))) + + text + }, + asNamespace("jaspSyntax") + ) + on.exit(restoreDecoder(), add = TRUE) + + state <- list(other = list(label = "JaspColumn_1_Encoded")) + + testthat::expect_warning( + decoded <- jaspBase:::.decodeJaspResultState(state, decodeContext = jaspBase:::.jaspDecodeContext()), + "no analysis decode context" + ) + testthat::expect_identical(decoded$other$label, "JaspColumn_1_Encoded") +}) + testthat::test_that("decodeplot.gg returns decoded labels for R-facing plots", { plot <- ggplot2::ggplot( data.frame(x = 1, y = 2), @@ -130,6 +153,35 @@ testthat::test_that("decodeplot.gg returns decoded labels for R-facing plots", { testthat::expect_equal(unname(decoded$labels$y), "score") }) +testthat::test_that("plot decoding propagates native decoder failures", { + testthat::skip_if_not_installed("jaspSyntax") + restoreDecoder <- localNamespaceBinding( + "decodeColumnText", + function(text, encoderContext = NULL) { + stop("native decode failure", call. = FALSE) + }, + asNamespace("jaspSyntax") + ) + on.exit(restoreDecoder(), add = TRUE) + + plot <- ggplot2::ggplot( + data.frame(x = 1, y = 2), + ggplot2::aes(x = x, y = y) + ) + + ggplot2::geom_point() + + ggplot2::labs(x = "JaspColumn_1_Encoded") + + testthat::expect_error( + jaspBase:::.decodeJaspPlotObject( + plot, + returnGrob = FALSE, + decodeContext = jaspBase:::.jaspDecodeContext(columnEncoderContext = testColumnEncoderContext()) + ), + "native decode failure", + fixed = TRUE + ) +}) + testthat::test_that("decodeplot.gg decodes plot-owned data, mappings, and metadata", { plotData <- data.frame( JaspColumn_1_Encoded = factor(c("1", "2")), From 1b414bf39e6bb1bfce4dac115bb336bae36a1d4f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Franti=C5=A1ek=20Barto=C5=A1?= Date: Tue, 16 Jun 2026 15:39:34 +0200 Subject: [PATCH 22/22] Delegate result text decoding directly --- R/resultDecoding.R | 10 +------- tests/testthat/test-result-object-decoding.R | 26 ++++++++++++++++++++ 2 files changed, 27 insertions(+), 9 deletions(-) diff --git a/R/resultDecoding.R b/R/resultDecoding.R index 41455537..f254d211 100644 --- a/R/resultDecoding.R +++ b/R/resultDecoding.R @@ -175,15 +175,13 @@ .decodeJaspColumnText <- function(x, columnEncoderContext = NULL) { if (!is.character(x) || length(x) == 0L) return(x) - if (!.containsJaspEncodedTokens(x)) - return(x) if (is.list(columnEncoderContext) && "columnEncoderContext" %in% names(columnEncoderContext)) columnEncoderContext <- columnEncoderContext[["columnEncoderContext"]] if (is.null(columnEncoderContext)) return(x) - decoded <- tryCatch( + tryCatch( getExportedValue("jaspSyntax", "decodeColumnText")(x, columnEncoderContext), error = function(e) { stop( @@ -193,12 +191,6 @@ ) } ) - if (is.character(decoded) && length(decoded) == length(x)) { - names(decoded) <- names(x) - decoded - } else { - stop("Native jaspSyntax column decoder returned an invalid result.", call. = FALSE) - } } .decodeJaspFactorValues <- function(x, fieldName = NULL, decodeContext) { diff --git a/tests/testthat/test-result-object-decoding.R b/tests/testthat/test-result-object-decoding.R index 3ed79ba8..34904622 100644 --- a/tests/testthat/test-result-object-decoding.R +++ b/tests/testthat/test-result-object-decoding.R @@ -113,6 +113,32 @@ testthat::test_that("result decoding does not use R mapping replacement when nat ) }) +testthat::test_that("result decoding delegates plain text to the native decoder", { + testthat::skip_if_not_installed("jaspSyntax") + seen <- new.env(parent = emptyenv()) + restoreDecoder <- localNamespaceBinding( + "decodeColumnText", + function(text, encoderContext = NULL) { + seen$text <- text + seen$encoderContext <- encoderContext + paste0(text, " decoded") + }, + asNamespace("jaspSyntax") + ) + on.exit(restoreDecoder(), add = TRUE) + + decodeContext <- jaspBase:::.jaspDecodeContext( + columnEncoderContext = testColumnEncoderContext() + ) + + testthat::expect_identical( + jaspBase:::.decodeJaspText("plain name", decodeContext = decodeContext), + "plain name decoded" + ) + testthat::expect_identical(seen$text, "plain name") + testthat::expect_identical(seen$encoderContext, testColumnEncoderContext()) +}) + testthat::test_that("missing decode context does not borrow live native decoder state", { testthat::skip_if_not_installed("jaspSyntax") restoreDecoder <- localNamespaceBinding(