diff --git a/DESCRIPTION b/DESCRIPTION index 3aa1b307..941132fd 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. @@ -11,6 +11,7 @@ Imports: cli, codetools, compiler, + fs, ggplot2, grDevices, grid, @@ -26,9 +27,11 @@ Imports: ragg, R6, Rcpp (>= 0.12.14), + rlang, rvg, svglite, systemfonts, + vctrs, withr Remotes: jasp-stats/jaspGraphs @@ -38,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/NAMESPACE b/NAMESPACE index 12d68ae5..40acbeba 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -27,7 +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/common.R b/R/common.R index 8db8d7be..7a7f8416 100644 --- a/R/common.R +++ b/R/common.R @@ -30,16 +30,20 @@ loadJaspResults <- function(name) { create_cpp_jaspResults(name, .retrieveState()) } -finishJaspResults <- function(jaspResultsCPP, calledFromAnalysis = TRUE) { +finishJaspResults <- function(jaspResultsCPP, calledFromAnalysis = TRUE, decodeContext = NULL) { jaspResultsCPP$prepareForWriting() + if (is.null(decodeContext) && !isTRUE(calledFromAnalysis)) + decodeContext <- .jaspDecodeContext(source = "stored-result-state") + decodeContext <- .normalizeJaspDecodeContext(decodeContext) 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) { @@ -109,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() @@ -139,7 +149,7 @@ runJaspResults <- function(name, title, dataKey, options, stateKey, functionCall } - finishJaspResults(jaspResultsCPP) + finishJaspResults(jaspResultsCPP, decodeContext = decodeContext) return(jaspResults) } @@ -165,7 +175,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)) @@ -629,6 +639,7 @@ jaspResultsStrings <- function() { ".requestTempFileNameNative", ".requestTempRootNameNative", ".readDatasetToEndNative", + ".readFullDatasetToEnd", ".readDataSetHeaderNative", ".readDataSetRequestedNative", ".requestStateFileNameNative", @@ -659,19 +670,31 @@ jaspResultsStrings <- function() { } -.saveState <- function(state) { +.isNonEmptyString <- function(x) { + rlang::is_string(x) && nzchar(x) +} + +.stateFilePath <- function(location) { + 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 +} + +.saveState <- function(state, decodeContext = NULL) { location <- .fromRCPP(".requestStateFileNameNative") relativePath <- location$relativePath + statePath <- .stateFilePath(location) + fs::dir_create(fs::path_dir(statePath)) - # 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)) - } + state <- .decodeJaspResultState(state, decodeContext = decodeContext) - 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 +706,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*. ) @@ -820,7 +844,11 @@ 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 = TRUE, + decodeContext = .jaspDecodeContext(source = "stored-result-state") + ) location <- .fromRCPP(".requestTempFileNameNative", "png") # create file location string to extract the root location backgroundColor <- .fromRCPP(".imageBackground") @@ -1026,7 +1054,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 @@ -1077,7 +1109,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") @@ -1118,8 +1154,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 @@ -1163,27 +1201,191 @@ storeDataSet <- function(dataset) { jaspSyntax::loadDataSet(dataset) } +.wrappedAnalysisQmlFile <- function(moduleName, qmlFileName, modulePath = NULL, qmlFile = NULL) { + if (.isNonEmptyString(qmlFile)) + return(as.character(fs::path_norm(qmlFile))) + + if (.isNonEmptyString(modulePath)) { + qmlCandidates <- fs::path(modulePath, c("inst/qml", "qml"), qmlFileName) + existingQml <- qmlCandidates[fs::file_exists(qmlCandidates)] + if (length(existingQml) > 0) + return(as.character(fs::path_norm(existingQml[[1]]))) + + return(as.character(fs::path_norm(qmlCandidates[[1]]))) + } + + as.character(fs::path_norm(fs::path(find.package(moduleName), "qml", qmlFileName))) +} + +.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") +} + +.decodeRunWrappedAnalysisConditionMessage <- function(condition, decodeContext = NULL) { + message <- conditionMessage(condition) + if (!is.character(message) || length(message) != 1L || is.na(message) || !nzchar(message)) + return(message) + + decoded <- .decodeJaspText(message, decodeContext = decodeContext) + 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) + showJasp <- .runWrappedAnalysisShowsJasp(verbose) + + if (!showJasp) { + 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") + } + + if (showAnalysis) + return(.runWrappedAnalysisWithDecodedConditions(expr)) + + suppressWarnings(suppressMessages(expr)) +} + #' @export -runWrappedAnalysis <- function(moduleName, analysisName, qmlFileName, options, version, preloadData) { +runWrappedAnalysis <- function(moduleName, analysisName, qmlFileName, options, version, preloadData, modulePath = NULL, qmlFile = NULL, + quiet = getOption("jaspBase.runWrappedAnalysis.quiet", 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. # 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, + # `version` is the generated module wrapper version; this is the runtime contract version. + "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) - # 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) + verbose <- .normalizeRunWrappedAnalysisVerbose(verbose, quiet = quiet) + jaspSyntax::setParameter("verbose", .runWrappedAnalysisShowsJasp(verbose)) - if (options == "") - stop("Error when parsing the options") + 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) - internalAnalysisName <- paste0(moduleName, "::", analysisName, "Internal") + if (options == "") + stop("Error when parsing the options") + + 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(.runWrappedAnalysisWithVerbosity(runWrapped(), verbose = verbose)) } } 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/R/resultDecoding.R b/R/resultDecoding.R new file mode 100644 index 00000000..f254d211 --- /dev/null +++ b/R/resultDecoding.R @@ -0,0 +1,308 @@ +.jaspDecodeContext <- function(columnEncoderContext = NULL, factors = list(), + source = "manual") { + factors <- .normalizeJaspFactorMappings(factors, columnEncoderContext) + + list( + version = 1L, + columnEncoderContext = columnEncoderContext, + factors = factors, + source = source, + warningState = new.env(parent = emptyenv()) + ) +} + +.serializableJaspDecodeContext <- function(decodeContext) { + decodeContext <- .normalizeJaspDecodeContext(decodeContext) + list( + version = decodeContext[["version"]], + columnEncoderContext = decodeContext[["columnEncoderContext"]], + factors = decodeContext[["factors"]], + source = decodeContext[["source"]] + ) +} + +.withJaspDecodeContextDecoder <- function(decodeContext, expr) { + if (is.null(decodeContext)) + return(eval.parent(substitute(expr))) + + decodeContext <- .normalizeJaspDecodeContext(decodeContext) + + oldStrict <- .globalBinding(".decodeColNamesStrict") + oldLax <- .globalBinding(".decodeColNamesLax") + on.exit({ + .restoreGlobalBinding(".decodeColNamesStrict", oldStrict) + .restoreGlobalBinding(".decodeColNamesLax", oldLax) + }, add = TRUE) + + assign(".decodeColNamesStrict", .decodeJaspColumnsStrict(decodeContext), envir = .GlobalEnv) + assign(".decodeColNamesLax", .decodeJaspColumnsLax(decodeContext), 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(decodeContext) { + force(decodeContext) + function(x) { + if (!is.character(x) || length(x) == 0L) + return(x) + + .decodeJaspColumnText(x, decodeContext) + } +} + +.decodeJaspColumnsLax <- function(decodeContext) { + force(decodeContext) + function(x) .decodeJaspColumnText(x, decodeContext) +} + +.currentJaspDecodeContext <- function() { + columnEncoderContext <- NULL + requestedDataset <- NULL + + if (requireNamespace("jaspSyntax", quietly = TRUE)) { + requestedDataset <- tryCatch( + getExportedValue("jaspSyntax", "readRequestedDataset")(decode = FALSE, normalize = FALSE), + error = function(e) NULL + ) + columnEncoderContext <- tryCatch( + getExportedValue("jaspSyntax", "columnEncoderContext")(), + error = function(e) NULL + ) + } + + .jaspDecodeContext( + columnEncoderContext = columnEncoderContext, + factors = .jaspFactorMappingsFromDataset(requestedDataset, columnEncoderContext), + source = "jaspSyntax" + ) +} + +.normalizeJaspDecodeContext <- function(decodeContext = NULL) { + if (is.null(decodeContext)) + return(.currentJaspDecodeContext()) + + decodeContext[["factors"]] <- .normalizeJaspFactorMappings( + decodeContext[["factors"]], + decodeContext[["columnEncoderContext"]] + ) + 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 +} + +.normalizeJaspFactorMappings <- function(factorMappings = NULL, columnEncoderContext = NULL) { + 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, columnEncoderContext) + if (length(valueMap) == 0L) + next + + aliases <- unique(c( + fieldName, + .decodeJaspColumnText(fieldName, columnEncoderContext) + )) + aliases <- aliases[!is.na(aliases) & nzchar(aliases)] + for (alias in aliases) + normalized[[alias]] <- valueMap + } + + normalized +} + +.jaspFactorMappingsFromDataset <- function(requestedDataset, columnEncoderContext = NULL) { + 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, columnEncoderContext) +} + +.jaspEncodedColumnTokenPattern <- function() "(JaspColumn_[[:alnum:]_]+_Encoded|JaspExtraOptions_[[: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, columnEncoderContext = NULL) { + if (!is.character(x) || length(x) == 0L) + return(x) + + if (is.list(columnEncoderContext) && "columnEncoderContext" %in% names(columnEncoderContext)) + columnEncoderContext <- columnEncoderContext[["columnEncoderContext"]] + if (is.null(columnEncoderContext)) + return(x) + + tryCatch( + getExportedValue("jaspSyntax", "decodeColumnText")(x, columnEncoderContext), + error = function(e) { + stop( + "jaspBase result decoding requires a working native jaspSyntax column decoder: ", + conditionMessage(e), + call. = FALSE + ) + } + ) +} + +.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) + )) + 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) + + .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 + } + } + + # `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) + 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) + decoded <- decodeplot(plot, returnGrob = returnGrob, decodeContext = decodeContext) + + if (!isTRUE(returnGrob)) + decoded <- .markJaspDecodedPlotObject(decoded) + + decoded +} + +.decodeJaspRObjectFromCpp <- function(jaspObject, decodeContext = NULL) { + .withJaspDecodeContextDecoder(decodeContext, { + .decodeJaspRObject(jaspObject$toRObject(), decodeContext = decodeContext) + }) +} diff --git a/R/writeImage.R b/R/writeImage.R index 0d6360ad..38858564 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,12 @@ 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 <- 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) @@ -117,16 +122,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 +173,58 @@ 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. - 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 { + 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]])) + 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 } } @@ -219,7 +240,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) { @@ -229,56 +251,118 @@ 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) } } +.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, ...) { +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({ @@ -293,7 +377,7 @@ decodeplot.function <- function(x, ...) { eval(x()) out <- grDevices::recordPlot() - return(decodeplot.recordedplot(out)) + 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 @@ -325,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 978d5547..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 @@ -163,6 +160,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 +303,7 @@ jaspObjR <- R6::R6Class( ), private = list( jaspObject = NULL, + decodeContext = NULL, getJaspObject = function(R6obj) R6obj$.__enclos_env__$private$jaspObject ) ) @@ -307,6 +312,132 @@ 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) +} + +.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, @@ -352,7 +483,7 @@ jaspOutputObjR <- R6::R6Class( for (i in seq_along(x)) private$jaspObject$addCitation(x[i]) }, - toRObject = function() private$jaspObject$toRObject(), + toRObject = function() .decodeJaspRObjectFromCpp(private$jaspObject, decodeContext = self$getDecodeContext()), toHtml = function() private$jaspObject$toHtml() ), active = list( @@ -362,6 +493,134 @@ jaspOutputObjR <- R6::R6Class( ) ) +.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"]], returnGrob = FALSE, decodeContext = decodeContext) + return(.decodeJaspRObjectAttributes(x, decodeContext = decodeContext)) + } + + if (is.character(x)) + return(.decodeJaspText(x, fieldName = fieldName, decodeContext = decodeContext)) + + if (is.factor(x)) { + levels(x) <- .decodeJaspText(levels(x), fieldName = fieldName, decodeContext = decodeContext) + return(x) + } + + if (.isJaspMixedObject(x)) + return(.decodeJaspMixedObject(x, fieldName = fieldName, decodeContext = decodeContext)) + + if (is.data.frame(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)) + } + + # 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)) + 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)) + } + + 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) +} + +.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( + names(attributes(x)), + c("class", "dim", "dimnames", "names", "row.names", "jaspObjectEnvironment") + ) + + for (attribute in attributesToDecode) + attr(x, attribute) <- .decodeJaspRObject(attr(x, attribute), fieldName = attribute, decodeContext = decodeContext) + + x +} + .jaspHtmlPixelizer <- function(maxWidth) { if(is.numeric(maxWidth)) return(paste0(as.character(maxWidth), "px")) return(maxWidth) @@ -487,7 +746,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 ), @@ -498,11 +757,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/inst/po/vi/LC_MESSAGES/R-jaspBase.mo b/inst/po/vi/LC_MESSAGES/R-jaspBase.mo index c04d63f7..80d1faec 100644 Binary files a/inst/po/vi/LC_MESSAGES/R-jaspBase.mo and b/inst/po/vi/LC_MESSAGES/R-jaspBase.mo differ 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..." 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/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/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: 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-result-object-decoding.R b/tests/testthat/test-result-object-decoding.R new file mode 100644 index 00000000..34904622 --- /dev/null +++ b/tests/testthat/test-result-object-decoding.R @@ -0,0 +1,638 @@ +localDecodeContext <- function() { + testthat::skip_if_not_installed("jaspSyntax") + localTestColumnDecoder() + columnEncoderContext <- testColumnEncoderContext() + jaspBase:::.jaspDecodeContext( + 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) + + 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, 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 = decodeContext), + "native decode failure", + fixed = TRUE + ) +}) + +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( + "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), + 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, decodeContext = localDecodeContext()) + + testthat::expect_equal(unname(decoded$labels$x), "group") + 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")), + 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) + 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 = c("1", "2"), + label = "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_0_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_0_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, decodeContext = localDecodeContext()) + + testthat::expect_equal(names(decoded), c("group", "Plot")) + 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, + "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") +}) + +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()) + 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 + + 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("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( + "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("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("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) + ) + + 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(model = list(label = "JaspColumn_2_Encoded")) + ) + + 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, "group") + testthat::expect_identical(decoded$other, state$other) +}) + +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) + + 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", { + 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") +}) diff --git a/tests/testthat/test-runWrappedAnalysis.R b/tests/testthat/test-runWrappedAnalysis.R new file mode 100644 index 00000000..be85555a --- /dev/null +++ b/tests/testthat/test-runWrappedAnalysis.R @@ -0,0 +1,315 @@ +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) + + qmlFile <- jaspBase:::.wrappedAnalysisQmlFile( + moduleName = "jaspBase", + qmlFileName = "Ignored.qml", + qmlFile = explicitFile + ) + + testthat::expect_equal(qmlFile, as.character(fs::path_norm(explicitFile))) +}) + +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, as.character(fs::path_norm(qmlPath))) +}) + +testthat::test_that("wrapped analysis verbosity separates analysis and JASP chatter", { + noisyValue <- function() { + cat("jasp bridge output\n") + message("analysis message") + warning("analysis warning", call. = FALSE) + 42 + } + + testthat::expect_silent( + testthat::expect_equal( + jaspBase:::.runWrappedAnalysisWithVerbosity(noisyValue(), verbose = "none"), + 42 + ) + ) + + testthat::expect_output( + testthat::expect_message( + testthat::expect_warning( + jaspBase:::.runWrappedAnalysisWithVerbosity(noisyValue(), verbose = "analysis"), + "analysis warning" + ), + "analysis message" + ), + 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" + ) +}) + +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", { + testthat::skip_if_not_installed("jaspSyntax") + decodeContext <- jaspBase:::.jaspDecodeContext( + columnEncoderContext = structure( + list(columns = list(list(name = "angle", type = "unknown")), extra = list()), + class = "jaspSyntaxColumnEncoderContext" + ) + ) + restoreContext <- localNamespaceBinding( + ".currentJaspDecodeContext", + function() decodeContext, + asNamespace("jaspBase") + ) + restoreDecoder <- localNamespaceBinding( + "decodeColumnText", + function(text, encoderContext = NULL) { + gsub("JaspColumn_0_Encoded", "angle", text, fixed = TRUE) + }, + asNamespace("jaspSyntax") + ) + on.exit(restoreContext(), add = TRUE) + on.exit(restoreDecoder(), add = TRUE) + + noisyValue <- function() { + message("analysis message: JaspColumn_0_Encoded") + warning("analysis warning: JaspColumn_0_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_0_Encoded", call. = FALSE), + verbose = "analysis" + ), + "analysis error: angle" + ) +}) + +testthat::test_that("wrapped analysis condition decoding propagates native decoder failures", { + testthat::skip_if_not_installed("jaspSyntax") + decodeContext <- jaspBase:::.jaspDecodeContext( + columnEncoderContext = structure( + list(columns = list(list(name = "angle", type = "unknown")), extra = list()), + class = "jaspSyntaxColumnEncoderContext" + ) + ) + restoreContext <- localNamespaceBinding( + ".currentJaspDecodeContext", + function() decodeContext, + asNamespace("jaspBase") + ) + restoreDecoder <- localNamespaceBinding( + "decodeColumnText", + function(text, encoderContext = 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_0_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) + } 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("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) + } 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)) + ) +})