From 94e24b0f7129f6f64e178a39eeb08ff643566115 Mon Sep 17 00:00:00 2001 From: perrydv Date: Mon, 8 Dec 2025 12:46:07 +0100 Subject: [PATCH 1/7] nCompile automated inclusion (optionally) of needed units --- nCompiler/R/NC_Compile.R | 13 +- nCompiler/R/NC_CompilerClass.R | 37 +++++ nCompiler/R/NF_Compile.R | 11 +- nCompiler/R/NF_CompilerClass.R | 19 +++ nCompiler/R/cppDefs_nFunction.R | 2 +- nCompiler/R/nCompile.R | 243 ++++++++++++++++++++++---------- nCompiler/R/options.R | 2 + 7 files changed, 247 insertions(+), 80 deletions(-) diff --git a/nCompiler/R/NC_Compile.R b/nCompiler/R/NC_Compile.R index 1af62743..f0f29297 100644 --- a/nCompiler/R/NC_Compile.R +++ b/nCompiler/R/NC_Compile.R @@ -46,6 +46,8 @@ nCompile_nClass <- function(NC, control ) is_predefined <- !isFALSE(NCinternals(NC)$predefined) + gather_needed_units <- isTRUE(controlFull$always_include_units) + needed_units <- list() if(is_predefined) { predefined_dir <- NCinternals(NC)$predefined # predefined can be character, quoted expression, or function. @@ -63,6 +65,7 @@ nCompile_nClass <- function(NC, "It should give the directory path of the predefined nClass. ", "The classname argument to nClass gives the base for filenames in that directory.") regular_filename <- NCinternals(NC)$cpp_classname + if(gather_needed_units) needed_units <- NCinternals(NC)$compileInfo$needed_units } if(is_predefined && isFALSE(controlFull$generate_predefined)) { RcppPacket <- loadRcppPacket(predefined_dir, regular_filename) @@ -89,6 +92,10 @@ nCompile_nClass <- function(NC, # Now add interface calls if necessary for this live compilation, having # kept them out of the written packet code. cppDef$buildGenericInterface(interfaceCalls=TRUE, interface=FALSE) + # To do: check that there aren't any detected needed units that are not in the compileInfo$needed_units + # because for a predefined, needed units must be provided manually by compileInfo. + } else { + if(gather_needed_units) needed_units <- NC_Compiler$gather_needed_units() } ## @@ -101,8 +108,10 @@ nCompile_nClass <- function(NC, return(NC_Compiler) } - if(stopAfterCppDef) return(cppDef) - + if(stopAfterCppDef) { + if(gather_needed_units) return(list(cppDef = cppDef, needed_units = needed_units)) + else return(cppDef) + } # We might deprecate from here onward. # Then nCompile_nClass would only be called via nCompile filebase <- controlFull$filename diff --git a/nCompiler/R/NC_CompilerClass.R b/nCompiler/R/NC_CompilerClass.R index b491f6c0..3ec8199f 100644 --- a/nCompiler/R/NC_CompilerClass.R +++ b/nCompiler/R/NC_CompilerClass.R @@ -115,6 +115,43 @@ NC_CompilerClass <- R6::R6Class( NCgenerator) setupMethodSymbolTables() } + }, + gather_needed_units = function() { + needed_nClasses1 <- nCompile_gather_needed_nClasses(cppDef, self$symbolTable) + needed_nClasses2 <- lapply(NFcompilers, + \(x) x$gather_needed_nClasses()) |> + unlist(recursive = FALSE) |> unique() + needed_nFunctions <- lapply(NFcompilers, + \(x) x$gather_needed_nFunctions()) |> + unlist(recursive = FALSE) |> unique() + list( + needed_nClasses = unique(c(needed_nClasses1, needed_nClasses2)), + needed_nFunctions = needed_nFunctions + ) } ) ) + +nCompile_gather_needed_nClasses <- function(cppDef, + symTab, + NF_Compiler = NULL) { + # Collect nClass generators needed by this symbol table + new_needed <- list() + for(i in seq_along(symTab$symbols)) { + if(inherits(symTab$symbols[[i]], "symbolNC")) { + new_needed[[length(new_needed) + 1]] <- + symTab$symbols[[i]]$nClassGenerator + } + } + # For an nFunction, collection nClass generators identified + # from processing the code. + if(!is.null(NF_Compiler)) { + auxEnv_needed_nClasses <- NF_Compiler$auxEnv$needed_nClasses + if(length(auxEnv_needed_nClasses)) { + bool_NCgen <- lapply(auxEnv_needed_nClasses, isNCgenerator) |> unlist() + new_needed <- c(new_needed, + auxEnv_needed_nClasses[bool_NCgen]) + } + } + unique(new_needed) +} \ No newline at end of file diff --git a/nCompiler/R/NF_Compile.R b/nCompiler/R/NF_Compile.R index 75e83006..27f7c807 100644 --- a/nCompiler/R/NF_Compile.R +++ b/nCompiler/R/NF_Compile.R @@ -58,6 +58,8 @@ nCompile_nFunction <- function(NF, if(is.null(compileInfo)) compileInfo <- NFinternals(NF)$compileInfo is_predefined <- !isFALSE(NFinternals(NF)$predefined) + gather_needed_units <- isTRUE(controlFull$always_include_units) + needed_units <- list() if(is_predefined) { predefined_dir <- NFinternals(NF)$predefined # predefined can be character, quoted expression, or function. @@ -75,6 +77,7 @@ nCompile_nFunction <- function(NF, "It should give the directory path of the predefined nFunction. ", "The name argument to nFunction gives the base for filenames in that directory.") regular_filename <- NFinternals(NF)$cpp_code_name + if(gather_needed_units) needed_units <- NFinternals(NF)$compileInfo$needed_units } if(is_predefined && isFALSE(controlFull$generate_predefined)) { RcppPacket <- loadRcppPacket(predefined_dir, regular_filename) @@ -98,6 +101,8 @@ nCompile_nFunction <- function(NF, predefined_gen_dir <- predefined_dir RcppPacket <- cppDefs_2_RcppPacket(NF_Compiler$cppDef) saveRcppPacket(RcppPacket, predefined_dir, regular_filename) + } else { + if(gather_needed_units) needed_units <- NF_Compiler$gather_needed_units() } stageName <- 'makeRcppPacket' if (logging) logBeforeStage(stageName) @@ -106,8 +111,10 @@ nCompile_nFunction <- function(NF, cppDef <- NF_Compiler$cppDef } - if(stopAfterCppDef) return(cppDef) - + if(stopAfterCppDef) { + if(gather_needed_units) return(list(needed_units = needed_units, cppDef = cppDef)) + else return(cppDef) + } # We might deprecate from here down and make all usages start from nCompile. stop("Entering deprecated portion of nCompile_nFunction. Check what is going on.") diff --git a/nCompiler/R/NF_CompilerClass.R b/nCompiler/R/NF_CompilerClass.R index 9cd89dc7..0ea89933 100644 --- a/nCompiler/R/NF_CompilerClass.R +++ b/nCompiler/R/NF_CompilerClass.R @@ -139,10 +139,29 @@ NF_CompilerClass <- R6::R6Class( doKeywords, .nCompilerProject, initialTypeInferenceOnly) + }, + gather_needed_units = function() { + list( + needed_nClasses = self$gather_needed_nClasses(), + needed_nFunctions = self$gather_needed_nFunctions() + ) + }, + gather_needed_nClasses = function() { + nCompile_gather_needed_nClasses(cppDef, self$symbolTable, self) + }, + gather_needed_nFunctions = function() { + nCompile_gather_needed_nFunctions(cppDef, self$symbolTable) } ) ) +nCompile_gather_needed_nFunctions <- function(cppDef, + NF_Compiler) { + lapply(NF_Compiler$auxEnv$needed_nFunctions, + function(x) + nGet(x[[1]], where = x[[2]])) |> unique() +} + processNFstages <- function(NFcompiler, control = list(), sourceObj = NULL, diff --git a/nCompiler/R/cppDefs_nFunction.R b/nCompiler/R/cppDefs_nFunction.R index 80517f63..7220c625 100644 --- a/nCompiler/R/cppDefs_nFunction.R +++ b/nCompiler/R/cppDefs_nFunction.R @@ -199,7 +199,7 @@ cpp_include_needed_nClasses <- function(cppDef, } } new_Hincludes <- unique(new_Hincludes) - cppDef$Hincludes <- c(cppDef$Hincludes, new_Hincludes) + cppDef$Hincludes <- unique(c(cppDef$Hincludes, new_Hincludes)) invisible(NULL) } diff --git a/nCompiler/R/nCompile.R b/nCompiler/R/nCompile.R index be071fa7..574fc5cd 100644 --- a/nCompiler/R/nCompile.R +++ b/nCompiler/R/nCompile.R @@ -205,38 +205,42 @@ get_nCompile_types <- function(units) { ans } -createCppDefsInfo <- function(units, +nCompile_createCppDefsInfo <- function(units, unitTypes, control, compileInfos) { if(is.null(names(units))) names(units) <- rep('', length(units)) if(length(units) == 0) stop('No objects for compilation provided') unitResults <- vector("list", length(units)) - ## names(units) should be fully populated and unique. TO-DO: check. cpp_names <- character(length(units)) - # RcppPacket_list <- vector(length = length(units), mode = "list") + needed_nClasses <- vector("list", length(units)) + needed_nFunctions <- vector("list", length(units)) for(i in seq_along(units)) { compileInfo <- compileInfos[[i]] if(unitTypes[i] == "nF" || unitTypes[i] == "nF_noExport") { - unitResults[[i]] <- nCompile_nFunction(units[[i]], - stopAfterCppDef = TRUE, - env = env, - compileInfo = compileInfo, - control = control) + oneResult <- nCompile_nFunction(units[[i]], + stopAfterCppDef = TRUE, + env = env, + compileInfo = compileInfo, + control = control) cpp_names[i] <- NFinternals(units[[i]])$cpp_code_name -# RcppPacket_list[[i]] <- NFinternals(unitResults[[i]])$RcppPacket } else if(unitTypes[i] == "nCgen") { - unitResults[[i]] <- nCompile_nClass(units[[i]], - stopAfterCppDef = TRUE, - env = env, - compileInfo = compileInfo, - control = control) + oneResult <- nCompile_nClass(units[[i]], + stopAfterCppDef = TRUE, + env = env, + compileInfo = compileInfo, + control = control) cpp_names[i] <- NCinternals(units[[i]])$cpp_classname - # RcppPacket_list[[i]] <- NCinternals(unitResults[[i]])$RcppPacket } + if(!is.list(oneResult)) stop("nCompile_nFunction or nCompile_nClass did not return a list for ", cpp_names[i]) + unitResults[[i]] <- oneResult$cppDef + needed_nClasses[[i]] <- oneResult$needed_units$needed_nClasses + needed_nFunctions[[i]] <- oneResult$needed_units$needed_nFunctions } list(cppDefs = unitResults, - cpp_names = cpp_names) + cpp_names = cpp_names, + needed_nClasses = needed_nClasses, + needed_nFunctions = needed_nFunctions) } cppDefsList_2_RcppPacketList <- function(cppDefs) { @@ -247,21 +251,24 @@ cppDefsList_2_RcppPacketList <- function(cppDefs) { RcppPacket_list } -# refactor to integrate with writePackage -# -#' @export -nCompile <- function(..., - dir = file.path(tempdir(), 'nCompiler_generatedCode'), - cacheDir = file.path(tempdir(), 'nCompiler_RcppCache'), - env = parent.frame(), - control = list(), - unitControls = list(), - interfaces = list(), - package = FALSE, - returnList = FALSE) { ## return a list even if there is only one unit being compiled. - #(1) Put together inputs from ... +# prepare information for compilation units: +#. names, interface type, unit types, inherits. +# previously this was done inside nCompile, but +# now we separate it so we can recurse on units +# that need other units that then need prepared +# information +nCompile_prepare_units <- function(..., + # dir = file.path(tempdir(), 'nCompiler_generatedCode'), + # cacheDir = file.path(tempdir(), 'nCompiler_RcppCache'), + # env = parent.frame(), + # control = list(), + # unitControls = list(), + interfaces = list()#, + # package = FALSE, + # returnList = FALSE + ) { + #(1) Put together inputs from ... # cat("starting nCompile\n") - dotsDeparses <- unlist(lapply( substitute(list(...))[-1], deparse )) origList <- list(...) if(is.null(names(origList))) @@ -335,7 +342,7 @@ nCompile <- function(..., compileInfos <- structure(vector("list", length(units)), names = names(units)) for(i in seq_along(units)) { - add_new_ <- FALSE + add_new_prefix <- FALSE if(unitTypes[i] == "nF" || unitTypes[i] == "nF_noExport") { compileInfo <- NFinternals(units[[i]])$compileInfo } else { @@ -344,7 +351,7 @@ nCompile <- function(..., interfaces[[i]] <- compileInfo$interface if(!(interfaces[[i]] %in% c("full", "generic", "none"))) stop("Could not determine a valid interface value ('full', 'generic', or 'none') for ", names(units)[i]) - if(interfaces[[i]]=="full") add_new_ <- TRUE + if(interfaces[[i]]=="full") add_new_prefix <- TRUE } # If a name was provided directly in the ... list # OR if no exportName was provided in the nClass call's compileInfo, @@ -358,7 +365,7 @@ nCompile <- function(..., returnNames[i] <- exportNames[i] # If a full interface will be returned, make the exportName # distinct from the returnName by prefixing with "new_" - if(add_new_) # this could happen by setting just above or by choice of provided compileInfo$exportName + if(add_new_prefix) # this could happen by setting just above or by choice of provided compileInfo$exportName exportNames[i] <- paste0("new_", exportNames[i]) # In some cases this is the first addition of an exportName to a compileInfo @@ -366,26 +373,112 @@ nCompile <- function(..., compileInfo$interface <- interfaces[[i]] compileInfos[[i]] <- compileInfo } +list(units = units, + unitTypes = unitTypes, + interfaces = interfaces, + compileInfos = compileInfos, + exportNames = exportNames, + returnNames = returnNames) +} + + +#' @export +nCompile <- function(..., + dir = file.path(tempdir(), 'nCompiler_generatedCode'), + cacheDir = file.path(tempdir(), 'nCompiler_RcppCache'), + env = parent.frame(), + control = list(), + unitControls = list(), + interfaces = list(), + package = FALSE, + returnList = FALSE) { ## return a list even if there is only one unit being compiled. + #(1) Put together inputs from ... + # cat("starting nCompile\n") + + controlFull <- updateDefaults( + get_nOption('compilerOptions'), + control + ) + controlFull$always_include_units <- TRUE # Do this even if auto_include_units is FALSE, so we can error-trap + + unit_info <- nCompile_prepare_units(..., + interfaces = interfaces) + new_units <- unit_info$units + new_unitTypes <- unit_info$unitTypes + new_interfaces <- unit_info$interfaces + new_compileInfos <- unit_info$compileInfos + new_exportNames <- unit_info$exportNames + new_returnNames <- unit_info$returnNames # if package = TRUE, call package steps either with units or original ... (above) # after packing up control list (e.g. from interfaces) - # (2) Create cppDefs # cat("making cppDefs\n") - cppDefs_info <- createCppDefsInfo(units, unitTypes, control, compileInfos) - cppDefs <- cppDefs_info$cppDefs - if(isTRUE(control$return_cppDefs)) return(cppDefs) - cpp_names <- cppDefs_info$cpp_names + done_finding_units <- FALSE + units <- list() + unitTypes <- character() + interfaces <- list() + compileInfos <- list() + exportNames <- character() + returnNames <- character() + cppDefs <- list() + cpp_names <- character() + + while(!done_finding_units) { + cppDefs_info <- nCompile_createCppDefsInfo(new_units, new_unitTypes, controlFull, new_compileInfos) + new_cppDefs <- cppDefs_info$cppDefs + new_cpp_names <- cppDefs_info$cpp_names + + units <- c(units, new_units) + unitTypes <- c(unitTypes, new_unitTypes) + interfaces <- c(interfaces, new_interfaces) + compileInfos <- c(compileInfos, new_compileInfos) + exportNames <- c(exportNames, new_exportNames) + returnNames <- c(returnNames, new_returnNames) + cppDefs <- c(cppDefs, new_cppDefs) + cpp_names <- c(cpp_names, new_cpp_names) + + new_needed_nClasses <- do.call("c", cppDefs_info$needed_nClasses) |> unique() + new_needed_nFunctions <- do.call("c", cppDefs_info$needed_nFunctions) |> unique() + setNames(new_needed_nClasses, new_needed_nClasses |> lapply(\(x) x$classname)) + setNames(new_needed_nFunctions, new_needed_nFunctions |> lapply(\(x) NFinternals(x)$uniqueName)) + # A bit of design irony: At this point, the needed units are + # nicely organized into nClasses and nFunctions, + # but we are going to mix them together as if they were an arbitrary + # input list because that's what nCompiler_prepare_units and nCompile_createCppDefsInfo uses. + new_units <- c(new_needed_nClasses, new_needed_nFunctions) + new_units <- setdiff(new_units, units) + if(length(new_units) == 0) { + done_finding_units <- TRUE + } else { + if(isTRUE(controlFull$nCompile_include_units)) { + # rely on any included unit having compileInfo$interface set. + new_unit_info <- nCompile_prepare_units(new_units) + new_units <- new_unit_info$units + new_unitTypes <- new_unit_info$unitTypes + new_interfaces <- new_unit_info$interfaces + new_compileInfos <- new_unit_info$compileInfos + new_exportNames <- new_unit_info$exportNames + new_returnNames <- new_unit_info$returnNames + } else { + stop("During compilation, additional units (nClasses or nFunctions) were needed but were not provided in the nCompile call. ", + "To have nCompile automatically include such units, include control(nCompile_include_units=TRUE) or (to change the setting for all calls) do set_nOption(\"nCompile_include_units\", TRUE, \"compilerOptions\").", + "The missing units are:\n", paste(names(new_units), collapse = "\n")) + } + } + } + + if(isTRUE(controlFull$return_cppDefs)) return(cppDefs) # writePackage inserts roxygen here # (3) Create RcppPacket_list # called from writePackage or not - from_writePackage <- control$.writePackage + from_writePackage <- controlFull$.writePackage if(!is.null(from_writePackage) || package) { createFromR <- compileInfos |> lapply(\(x) !isFALSE(x$createFromR)) |> unlist() - control$prepared_content <- list( + controlFull$prepared_content <- list( units = units, unitTypes = unitTypes, cpp_names = cpp_names, @@ -403,7 +496,7 @@ nCompile <- function(..., return( writePackage(pkgName = from_writePackage$pkgName, dir = dir, - control = control, + control = controlFull, unitControls = unitControls, modify = from_writePackage$modify, memberData = from_writePackage$memberData, @@ -420,7 +513,7 @@ nCompile <- function(..., temppkgname <- basename(tempfile("TEMPPKG", "")) writePackage(pkgName = temppkgname, dir = dir, - control = control, + control = controlFull, unitControls = unitControls, modify = "clear", memberData = list(), @@ -691,42 +784,42 @@ nCompile_finish_nonpackage <- function(units, ## if(length(iRes) != 1) { ## warning(paste0("Post-processing in nCompile: Name matching of results had a problem for ", exportNames[i], ".")) ## } else { - if(unitTypes[i] == "nCgen") { #unit_is_nClass[i]) { - expect_nC_interface[i] <- isTRUE(compileInfos[[i]]$interface %in% c("full", "generic")) - expect_createFromR[i] <- !isFALSE(compileInfos[[i]]$createFromR) && - expect_nC_interface[i] ## Currently one can't create objects without interface support - #nClass_name <- names(units)[i] - if(expect_nC_interface[i]) { - createFromR_fun <- NULL - if((length(iRes) != 1) && expect_createFromR[i]) { - warning(paste0("Post-processing in nCompile: Name matching of results had a problem for nClass ", exportNames[i], ".")) - } else { - if(expect_createFromR[i]) createFromR_fun <- compiledFuns[[iRes]] - R6interfaces[[i]] <- try(build_compiled_nClass(units[[i]], - createFromR_fun, - env = resultEnv)) - if(inherits(R6interfaces[[i]], "try-error")) { - warning(paste0("There was a problem building a full nClass interface for ", exportNames[i], ".")) - R6interfaces[[i]] <- NULL - } - methodFns[[i]] <- try(build_generic_fns_for_compiled_nClass(units[[i]])) - if(inherits(methodFns[[i]], "try-error")) { - warning(paste0("There was a problem building functions for generic nClass interface for ", exportNames[i], ".")) - methodFns[[i]] <- NULL - } + if(unitTypes[i] == "nCgen") { #unit_is_nClass[i]) { + expect_nC_interface[i] <- isTRUE(compileInfos[[i]]$interface %in% c("full", "generic")) + expect_createFromR[i] <- !isFALSE(compileInfos[[i]]$createFromR) && + expect_nC_interface[i] ## Currently one can't create objects without interface support + #nClass_name <- names(units)[i] + if(expect_nC_interface[i]) { + createFromR_fun <- NULL + if((length(iRes) != 1) && expect_createFromR[i]) { + warning(paste0("Post-processing in nCompile: Name matching of results had a problem for nClass ", exportNames[i], ".")) + } else { + if(expect_createFromR[i]) createFromR_fun <- compiledFuns[[iRes]] + R6interfaces[[i]] <- try(build_compiled_nClass(units[[i]], + createFromR_fun, + env = resultEnv)) + if(inherits(R6interfaces[[i]], "try-error")) { + warning(paste0("There was a problem building a full nClass interface for ", exportNames[i], ".")) + R6interfaces[[i]] <- NULL + } + methodFns[[i]] <- try(build_generic_fns_for_compiled_nClass(units[[i]])) + if(inherits(methodFns[[i]], "try-error")) { + warning(paste0("There was a problem building functions for generic nClass interface for ", exportNames[i], ".")) + methodFns[[i]] <- NULL } - } - } else if(unitTypes[i]=="nF") { - if(length(iRes) != 1) { - warning(paste0("Post-processing in nCompile: Name matching of results had a problem for nFunction ", exportNames[i], ".")) - } else { - refArgs <- cppDefs[[i]]$NF_Compiler$NFinternals$refArgs # alt: NFinternals(units[[i]])$refArgs - blockRefArgs <- cppDefs[[i]]$NF_Compiler$NFinternals$blockRefArgs # ditto - compiledFuns[[iRes]] <- passByReferenceIntoC(compiledFuns[[iRes]], - refArgs = refArgs, - blockRefArgs = blockRefArgs) } } + } else if(unitTypes[i]=="nF") { + if(length(iRes) != 1) { + warning(paste0("Post-processing in nCompile: Name matching of results had a problem for nFunction ", exportNames[i], ".")) + } else { + refArgs <- cppDefs[[i]]$NF_Compiler$NFinternals$refArgs # alt: NFinternals(units[[i]])$refArgs + blockRefArgs <- cppDefs[[i]]$NF_Compiler$NFinternals$blockRefArgs # ditto + compiledFuns[[iRes]] <- passByReferenceIntoC(compiledFuns[[iRes]], + refArgs = refArgs, + blockRefArgs = blockRefArgs) + } + } ##} } # } diff --git a/nCompiler/R/options.R b/nCompiler/R/options.R index c5cbb15d..039f86f3 100644 --- a/nCompiler/R/options.R +++ b/nCompiler/R/options.R @@ -18,6 +18,8 @@ updateDefaults <- function(defaults, control) { allow_method_overloading = FALSE, allow_inherited_field_duplicates = FALSE, compilerOptions = list( + nCompiler_include_units = TRUE, # Checked by nCompile, which sets always_include_units to match + always_include_units = FALSE, # Checked by NC_Compiler and NF_Compile. use_nCompiler_error_handling = TRUE, rebuild = FALSE, rebuildCppDef = FALSE, From 99fc4d425b3428ee761eda6574fa298b397428e9 Mon Sep 17 00:00:00 2001 From: perrydv Date: Mon, 8 Dec 2025 17:47:52 +0100 Subject: [PATCH 2/7] Clean up empty cases of new_needed_nFunctions --- nCompiler/R/nCompile.R | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/nCompiler/R/nCompile.R b/nCompiler/R/nCompile.R index 574fc5cd..2b5bf9aa 100644 --- a/nCompiler/R/nCompile.R +++ b/nCompiler/R/nCompile.R @@ -217,6 +217,7 @@ nCompile_createCppDefsInfo <- function(units, needed_nFunctions <- vector("list", length(units)) for(i in seq_along(units)) { compileInfo <- compileInfos[[i]] + needed_nFunctions[[i]] <- list() if(unitTypes[i] == "nF" || unitTypes[i] == "nF_noExport") { oneResult <- nCompile_nFunction(units[[i]], stopAfterCppDef = TRUE, @@ -224,6 +225,7 @@ nCompile_createCppDefsInfo <- function(units, compileInfo = compileInfo, control = control) cpp_names[i] <- NFinternals(units[[i]])$cpp_code_name + needed_nFunctions[[i]] <- oneResult$needed_units$needed_nFunctions } else if(unitTypes[i] == "nCgen") { oneResult <- nCompile_nClass(units[[i]], stopAfterCppDef = TRUE, @@ -235,7 +237,6 @@ nCompile_createCppDefsInfo <- function(units, if(!is.list(oneResult)) stop("nCompile_nFunction or nCompile_nClass did not return a list for ", cpp_names[i]) unitResults[[i]] <- oneResult$cppDef needed_nClasses[[i]] <- oneResult$needed_units$needed_nClasses - needed_nFunctions[[i]] <- oneResult$needed_units$needed_nFunctions } list(cppDefs = unitResults, cpp_names = cpp_names, @@ -253,7 +254,7 @@ cppDefsList_2_RcppPacketList <- function(cppDefs) { # prepare information for compilation units: #. names, interface type, unit types, inherits. -# previously this was done inside nCompile, but +# previously this was done inside nCompile, but # now we separate it so we can recurse on units # that need other units that then need prepared # information @@ -316,7 +317,7 @@ nCompile_prepare_units <- function(..., unitTypes <- get_nCompile_types(units) - # We defer processing of nClass inheritance until compile time to allow nClass + # We defer processing of nClass inheritance until compile time to allow nClass # to be called with inherit = some_nClass before some_nClass is defined. for(i in seq_along(units)) { if(unitTypes[i] == "nCgen") @@ -402,7 +403,7 @@ nCompile <- function(..., controlFull$always_include_units <- TRUE # Do this even if auto_include_units is FALSE, so we can error-trap unit_info <- nCompile_prepare_units(..., - interfaces = interfaces) + interfaces = interfaces) new_units <- unit_info$units new_unitTypes <- unit_info$unitTypes new_interfaces <- unit_info$interfaces @@ -425,6 +426,7 @@ nCompile <- function(..., cpp_names <- character() while(!done_finding_units) { + browser() cppDefs_info <- nCompile_createCppDefsInfo(new_units, new_unitTypes, controlFull, new_compileInfos) new_cppDefs <- cppDefs_info$cppDefs new_cpp_names <- cppDefs_info$cpp_names @@ -1122,7 +1124,7 @@ WP_write_DESCRIPTION_NAMESPACE <- function(units, unitTypes, interfaces, createF DESCRIPTION[1, "LinkingTo"] <- paste(DESCRIPTION[1, "LinkingTo"], "nCompiler", "RcppEigen", #"RcppEigenAD", "RcppParallel", "Rcereal", sep = ",") - # On Linux RcppParallel might need to be in both LinkingTo and Imports. + # On Linux RcppParallel might need to be in both LinkingTo and Imports. # Having it in Imports allows the symbols to be found when the on-the-fly package is loaded. # DESCRIPTION[1, "Imports"] <- paste(DESCRIPTION[1, "Imports"], "RcppParallel", sep = ",") # DESCRIPTION$Encoding <- "UTF-8" From d8da3598df2737f11074b03205e59523ca99d55a Mon Sep 17 00:00:00 2001 From: perrydv Date: Mon, 8 Dec 2025 17:52:21 +0100 Subject: [PATCH 3/7] remove browser() --- nCompiler/R/nCompile.R | 1 - 1 file changed, 1 deletion(-) diff --git a/nCompiler/R/nCompile.R b/nCompiler/R/nCompile.R index 2b5bf9aa..9de777c2 100644 --- a/nCompiler/R/nCompile.R +++ b/nCompiler/R/nCompile.R @@ -426,7 +426,6 @@ nCompile <- function(..., cpp_names <- character() while(!done_finding_units) { - browser() cppDefs_info <- nCompile_createCppDefsInfo(new_units, new_unitTypes, controlFull, new_compileInfos) new_cppDefs <- cppDefs_info$cppDefs new_cpp_names <- cppDefs_info$cpp_names From 47e6508922f9d85900e449641e78fb80dfdb5459 Mon Sep 17 00:00:00 2001 From: perrydv Date: Mon, 8 Dec 2025 18:26:36 +0100 Subject: [PATCH 4/7] fix nFunctions method gather_neeeded_nFunctions --- nCompiler/R/NC_CompilerClass.R | 4 ++-- nCompiler/R/NF_CompilerClass.R | 2 +- nCompiler/R/nCompile.R | 7 +++---- 3 files changed, 6 insertions(+), 7 deletions(-) diff --git a/nCompiler/R/NC_CompilerClass.R b/nCompiler/R/NC_CompilerClass.R index 3ec8199f..ac490a4b 100644 --- a/nCompiler/R/NC_CompilerClass.R +++ b/nCompiler/R/NC_CompilerClass.R @@ -125,8 +125,8 @@ NC_CompilerClass <- R6::R6Class( \(x) x$gather_needed_nFunctions()) |> unlist(recursive = FALSE) |> unique() list( - needed_nClasses = unique(c(needed_nClasses1, needed_nClasses2)), - needed_nFunctions = needed_nFunctions + needed_nClasses = unique(c(needed_nClasses1, needed_nClasses2 %||% list())), + needed_nFunctions = needed_nFunctions %||% list() ) } ) diff --git a/nCompiler/R/NF_CompilerClass.R b/nCompiler/R/NF_CompilerClass.R index 0ea89933..5e17be34 100644 --- a/nCompiler/R/NF_CompilerClass.R +++ b/nCompiler/R/NF_CompilerClass.R @@ -150,7 +150,7 @@ NF_CompilerClass <- R6::R6Class( nCompile_gather_needed_nClasses(cppDef, self$symbolTable, self) }, gather_needed_nFunctions = function() { - nCompile_gather_needed_nFunctions(cppDef, self$symbolTable) + nCompile_gather_needed_nFunctions(cppDef, self) } ) ) diff --git a/nCompiler/R/nCompile.R b/nCompiler/R/nCompile.R index 9de777c2..9e9f72c1 100644 --- a/nCompiler/R/nCompile.R +++ b/nCompiler/R/nCompile.R @@ -217,7 +217,6 @@ nCompile_createCppDefsInfo <- function(units, needed_nFunctions <- vector("list", length(units)) for(i in seq_along(units)) { compileInfo <- compileInfos[[i]] - needed_nFunctions[[i]] <- list() if(unitTypes[i] == "nF" || unitTypes[i] == "nF_noExport") { oneResult <- nCompile_nFunction(units[[i]], stopAfterCppDef = TRUE, @@ -225,7 +224,6 @@ nCompile_createCppDefsInfo <- function(units, compileInfo = compileInfo, control = control) cpp_names[i] <- NFinternals(units[[i]])$cpp_code_name - needed_nFunctions[[i]] <- oneResult$needed_units$needed_nFunctions } else if(unitTypes[i] == "nCgen") { oneResult <- nCompile_nClass(units[[i]], stopAfterCppDef = TRUE, @@ -237,6 +235,7 @@ nCompile_createCppDefsInfo <- function(units, if(!is.list(oneResult)) stop("nCompile_nFunction or nCompile_nClass did not return a list for ", cpp_names[i]) unitResults[[i]] <- oneResult$cppDef needed_nClasses[[i]] <- oneResult$needed_units$needed_nClasses + needed_nFunctions[[i]] <- oneResult$needed_units$needed_nFunctions } list(cppDefs = unitResults, cpp_names = cpp_names, @@ -441,8 +440,8 @@ nCompile <- function(..., new_needed_nClasses <- do.call("c", cppDefs_info$needed_nClasses) |> unique() new_needed_nFunctions <- do.call("c", cppDefs_info$needed_nFunctions) |> unique() - setNames(new_needed_nClasses, new_needed_nClasses |> lapply(\(x) x$classname)) - setNames(new_needed_nFunctions, new_needed_nFunctions |> lapply(\(x) NFinternals(x)$uniqueName)) + names(new_needed_nClasses) <- new_needed_nClasses |> lapply(\(x) x$classname) + names(new_needed_nFunctions) <- new_needed_nFunctions |> lapply(\(x) NFinternals(x)$uniqueName) # A bit of design irony: At this point, the needed units are # nicely organized into nClasses and nFunctions, # but we are going to mix them together as if they were an arbitrary From 8dd1c0e1273d9896d9f405b50cb7313be823ebb3 Mon Sep 17 00:00:00 2001 From: perrydv Date: Tue, 9 Dec 2025 11:36:25 +0100 Subject: [PATCH 5/7] clean up and finish gathering of needed units --- nCompiler/R/NC.R | 1 + nCompiler/R/NC_Compile.R | 11 ++- nCompiler/R/NC_CompilerClass.R | 66 ++++++++++++- nCompiler/R/NC_InternalsClass.R | 4 +- nCompiler/R/NF_Compile.R | 6 +- nCompiler/R/NF_CompilerClass.R | 7 +- nCompiler/R/nCompile.R | 170 +++----------------------------- nCompiler/R/nimbleModels.R | 6 +- nCompiler/R/options.R | 2 +- 9 files changed, 103 insertions(+), 170 deletions(-) diff --git a/nCompiler/R/NC.R b/nCompiler/R/NC.R index 79838630..e8f15a67 100644 --- a/nCompiler/R/NC.R +++ b/nCompiler/R/NC.R @@ -90,6 +90,7 @@ nClass <- function(classname, # All inheritance provided by compileInfo$inherit should include any # accessor specifier, typically "public", e.g. "public some_class". # Similarly, template arguments (include CRTP) should be in the text explicitly. + # needed_units: list of needed nClasses and nFunctions to include, by name or object # # constructor(s) and destructor: # diff --git a/nCompiler/R/NC_Compile.R b/nCompiler/R/NC_Compile.R index f0f29297..d8ba148e 100644 --- a/nCompiler/R/NC_Compile.R +++ b/nCompiler/R/NC_Compile.R @@ -47,7 +47,8 @@ nCompile_nClass <- function(NC, ) is_predefined <- !isFALSE(NCinternals(NC)$predefined) gather_needed_units <- isTRUE(controlFull$always_include_units) - needed_units <- list() + needed_units <- list(needed_nClasses = list(), + needed_nFunctions = list()) if(is_predefined) { predefined_dir <- NCinternals(NC)$predefined # predefined can be character, quoted expression, or function. @@ -64,15 +65,17 @@ nCompile_nClass <- function(NC, stop("There is a predefined nClass whose predefined field is not (and does not evaluate to) character. ", "It should give the directory path of the predefined nClass. ", "The classname argument to nClass gives the base for filenames in that directory.") - regular_filename <- NCinternals(NC)$cpp_classname - if(gather_needed_units) needed_units <- NCinternals(NC)$compileInfo$needed_units + regular_filename <- NCinternals(NC)$cpp_classname + if(gather_needed_units) + needed_units <- nCompile_process_manual_needed_units(NCinternals(NC), + NC$parent_env, isNC = TRUE) } if(is_predefined && isFALSE(controlFull$generate_predefined)) { RcppPacket <- loadRcppPacket(predefined_dir, regular_filename) cppDef <- cppRcppPacket$new(RcppPacket = RcppPacket) cppDef$externalCppDefs <- c(cppDef$externalCppDefs, get_R_interface_cppDef()) #might not be needed, but doesn't hurt to add and we don't have the details on whether it is needed from the loaded RcppPacket. - } else { + } else { if(is.null(compileInfo)) compileInfo <- NCinternals(NC)$compileInfo ## Make a new compiler object NC_Compiler <- NC_CompilerClass$new(NC, diff --git a/nCompiler/R/NC_CompilerClass.R b/nCompiler/R/NC_CompilerClass.R index ac490a4b..870eb99a 100644 --- a/nCompiler/R/NC_CompilerClass.R +++ b/nCompiler/R/NC_CompilerClass.R @@ -117,21 +117,81 @@ NC_CompilerClass <- R6::R6Class( } }, gather_needed_units = function() { + # This gathers from member variables and methods. + # It DOES NOT include an inherit nClass, because we could only access + # the inheritNCinternals, but we need the generator object. + # Hence this is collected from nCompile_nClass. + # list() |> unlist() returns NULL so we have to catch that and give list() instead. + # list() |> unique() retruns list(), what we want. needed_nClasses1 <- nCompile_gather_needed_nClasses(cppDef, self$symbolTable) needed_nClasses2 <- lapply(NFcompilers, \(x) x$gather_needed_nClasses()) |> unlist(recursive = FALSE) |> unique() needed_nFunctions <- lapply(NFcompilers, \(x) x$gather_needed_nFunctions()) |> - unlist(recursive = FALSE) |> unique() + unlist(recursive = FALSE) |> unique() + compileInfo_needed_units <- nCompile_process_manual_needed_units( + NCinternals(self$NCgenerator), + self$NCgenerator$parent_env, isNC = TRUE) list( - needed_nClasses = unique(c(needed_nClasses1, needed_nClasses2 %||% list())), - needed_nFunctions = needed_nFunctions %||% list() + needed_nClasses = unique(c(needed_nClasses1, needed_nClasses2 %||% list(), + compileInfo_needed_units$needed_nClasses)), + needed_nFunctions = unique(c(needed_nFunctions %||% list(), + compileInfo_needed_units$needed_nFunctions)) ) } ) ) +nCompile_process_manual_needed_units <- function(internals, + where = internals$where, # NFinternals case + isNC = FALSE) { + # A little awkwardness on the input arguments + # It would be nice to pass either just the internals (NCinternals(NC) or NFinternals(NF)) + # OR just the NC or NF object. + # But neither case is consistent between nClass and nFunction. + # We would need the nClass generator to get the where (parent_env), and the NCinternals doesn't have that. + # Conversely, we could pass the objects, but the NF_CompilerClass (a calling point) does not have the NF object. + # Therefore, we make this harder to read and pass both internals and where and indicate which case we're in with isNC. + # The defaults are for the case of NF, where internals is NFinternals(NF). + name <- if(isNC) internals$classname else internals$uniqueName + + needed_units <- internals$compileInfo$needed_units + results_nClasses <- list() + results_nFunctions <- list() + for(i in seq_along(needed_units)) { + if(is.character(needed_units[[i]])) { + obj <- nGet(needed_units[[i]], where) + if(is.null(obj)) + stop(paste0("In processing compileInfo$needed_units for ", name, ", could not find object named '", + needed_units[[i]], "' in the environment of the source unit.")) + } else { + obj <- needed_units[[i]] + } + if(isNCgenerator(obj)) { + results_nClasses[[length(results_nClasses) + 1]] <- obj + } else if(isNFunction(obj)) { + results_nFunctions[[length(results_nFunctions) + 1]] <- obj + } else { + stop(paste0("In processing compileInfo$needed_units for ", name, ", object '", + needed_units[[i]], "' is neither an nClass generator nor an nFunction.")) + } + } + + if(isNC) { + # Get inherited nClass as a needed unit + if(!is.null(internals$inheritQ)) { + inherit_obj <- eval(internals$inheritQ, envir = internals$env) # see connect_inherit + if(!isNCgenerator(inherit_obj)) + stop("An inherit argument that was provided to nClass does not evaluate to an nClass generator.") + results_nClasses[[length(results_nClasses) + 1]] <- inherit_obj + } + } + + list(needed_nClasses = results_nClasses, + needed_nFunctions = results_nFunctions) +} + nCompile_gather_needed_nClasses <- function(cppDef, symTab, NF_Compiler = NULL) { diff --git a/nCompiler/R/NC_InternalsClass.R b/nCompiler/R/NC_InternalsClass.R index f5e64371..f9001904 100644 --- a/nCompiler/R/NC_InternalsClass.R +++ b/nCompiler/R/NC_InternalsClass.R @@ -27,7 +27,7 @@ NC_InternalsClass <- R6::R6Class( predefined = FALSE, # directory for reading and (default) writing predefined nClass saved RcppPacket. Writing location can be over-ridden by compileInfo$predefined_output_dir inheritNCinternals = NULL, env = NULL, - inheritQ = NULL, + inheritQ = NULL, # quoted inherit expression, to defer access to the inherited nClass generator itself. process_inherit_done = FALSE, virtualMethodNames_self = character(), # will be used when checking inherited method validity, only for locally implemented methods virtualMethodNames = character(), @@ -101,7 +101,7 @@ NC_InternalsClass <- R6::R6Class( if(!is.null(self$inheritQ)) { inherit_obj <- eval(self$inheritQ, envir = self$env) #inheritQ can be an expression but it must always return the same generator object if(!isNCgenerator(inherit_obj)) - stop("An inherit argument that was provided to nClass is not nClass generator.") + stop("An inherit argument that was provided to nClass does not evaluate to an nClass generator.") self$inheritNCinternals <- NCinternals(inherit_obj) message("add check that base class has interface 'none'") if(!self$inherit_base_provided) { diff --git a/nCompiler/R/NF_Compile.R b/nCompiler/R/NF_Compile.R index 27f7c807..e95ea2cc 100644 --- a/nCompiler/R/NF_Compile.R +++ b/nCompiler/R/NF_Compile.R @@ -59,7 +59,8 @@ nCompile_nFunction <- function(NF, is_predefined <- !isFALSE(NFinternals(NF)$predefined) gather_needed_units <- isTRUE(controlFull$always_include_units) - needed_units <- list() + needed_units <- list(needed_nClasses = list(), + needed_nFunctions = list()) if(is_predefined) { predefined_dir <- NFinternals(NF)$predefined # predefined can be character, quoted expression, or function. @@ -77,7 +78,8 @@ nCompile_nFunction <- function(NF, "It should give the directory path of the predefined nFunction. ", "The name argument to nFunction gives the base for filenames in that directory.") regular_filename <- NFinternals(NF)$cpp_code_name - if(gather_needed_units) needed_units <- NFinternals(NF)$compileInfo$needed_units + if(gather_needed_units) + needed_units <- nCompile_process_manual_needed_units(NFinternals(NF)) } if(is_predefined && isFALSE(controlFull$generate_predefined)) { RcppPacket <- loadRcppPacket(predefined_dir, regular_filename) diff --git a/nCompiler/R/NF_CompilerClass.R b/nCompiler/R/NF_CompilerClass.R index 5e17be34..e2a8c93d 100644 --- a/nCompiler/R/NF_CompilerClass.R +++ b/nCompiler/R/NF_CompilerClass.R @@ -141,9 +141,12 @@ NF_CompilerClass <- R6::R6Class( initialTypeInferenceOnly) }, gather_needed_units = function() { + compileInfo_needed_units <- nCompile_process_manual_needed_units(self$NFinternals) list( - needed_nClasses = self$gather_needed_nClasses(), - needed_nFunctions = self$gather_needed_nFunctions() + needed_nClasses = c(self$gather_needed_nClasses(), + compileInfo_needed_units$needed_nClasses), + needed_nFunctions = c(self$gather_needed_nFunctions(), + compileInfo_needed_units$needed_nFunctions) ) }, gather_needed_nClasses = function() { diff --git a/nCompiler/R/nCompile.R b/nCompiler/R/nCompile.R index 9e9f72c1..1dcfd458 100644 --- a/nCompiler/R/nCompile.R +++ b/nCompiler/R/nCompile.R @@ -33,161 +33,7 @@ cppFileLabelFunction <- labelFunctionCreator('nCompiler_units') # - In nCompile, the cpp_name for that unitResult is the cpp_code_name #' @export -# This was original but is replaced below by a version that integrates with packing as inherent workflow -## nCompile1 <- function(..., -## dir = file.path(tempdir(), 'nCompiler_generatedCode'), -## cacheDir = file.path(tempdir(), 'nCompiler_RcppCache'), -## env = parent.frame(), -## control = list(), -## interfaces = "full", -## returnList = FALSE) { ## return a list even if there is only one unit being compiled. -## dotsDeparses <- unlist(lapply( substitute(list(...))[-1], deparse )) -## origList <- list(...) -## if(is.null(names(origList))) -## names(origList) <- rep('', length(origList)) -## boolNoName <- names(origList)=='' -## origIsList <- unlist(lapply(origList, is.list)) -## for(i in which(origIsList)) { -## if(is.null(names(origList[[i]])) || any(names(origList[[i]])=="")) -## stop("If you provide a list of compilation units, all list elements must be named.") -## } -## dotsDeparses[origIsList] <- '' -## names(origList)[boolNoName] <- dotsDeparses[boolNoName] # This puts default names from deparsing ... entries into list -## units <- do.call('c', origList) -## # Unpack interfaces argument from various formats. -## # Remember interface is only needed for nClass compilation units -## if(!is.list(interfaces)) { -## if(is.character(interfaces)) { -## if(length(interfaces) == 1) { -## interfaces <- rep(interfaces, length(units)) -## names(interfaces) <- names(units) # nFunction units will just be ignored -## } -## } -## interfaces <- as.list(interfaces) -## } - -## unitTypes <- get_nCompile_types(units) -## if(is.null(names(units))) names(units) <- rep('', length(units)) -## if(length(units) == 0) stop('No objects for compilation provided') -## unitResults <- list() -## ## names(units) should be fully populated and unique. TO-DO: check. -## cpp_names <- character(length(units)) -## # RcppPacket_list <- vector(length = length(units), mode = "list") -## for(i in seq_along(units)) { -## if(unitTypes[i] == "nF") { -## unitResults[[i]] <- nCompile_nFunction(units[[i]], -## stopAfterCppDef = TRUE, -## env = env, -## control = control) -## cpp_names[i] <- NFinternals(units[[i]])$cpp_code_name -## # RcppPacket_list[[i]] <- NFinternals(unitResults[[i]])$RcppPacket -## } else if(unitTypes[i] == "nCgen") { -## unitResults[[i]] <- nCompile_nClass(units[[i]], -## stopAfterCppDef = TRUE, -## env = env, -## control = control) -## cpp_names[i] <- NCinternals(units[[i]])$cpp_classname -## # RcppPacket_list[[i]] <- NCinternals(unitResults[[i]])$RcppPacket -## } -## } - -## allCppDefs <- c(unitResults, -## do.call("c", lapply(unitResults, function(x) x$getExternalDefs()))) -## allCppDefs <- allCppDefs[!duplicated(allCppDefs)] # preserves names. unique(allCppDefs) does not. -## RcppPacket_list <- lapply(allCppDefs, cppDefs_2_RcppPacket) - -## ## Write the results jointly, with one .cpp file and multiple .h files. -## ## This fits Rcpp::sourceCpp's requirements. -## cppfile <- paste0(cppFileLabelFunction(),".cpp") ## "nCompiler_multiple_units.cpp" -## resultEnv <- new.env() -## compiledFuns <- cpp_nCompiler(RcppPacket_list, -## cppfile = cppfile, -## dir = dir, -## cacheDir = cacheDir, -## env = resultEnv, -## packetList = TRUE, -## returnList = TRUE) - -## # Build full interfaces for everything, even if generic is requested in the return object. -## unit_is_nClass <- unitTypes=="nCgen" -## num_nClasses <- sum(unit_is_nClass) -## R6interfaces <- vector(mode="list", length = length(units) ) # will remain null for nFunctions -## if(num_nClasses > 0) { -## for(i in seq_along(units)) { -## if(unit_is_nClass[i]) { -## nClass_name <- names(units)[i] -## iRes <- which( paste0("new_", cpp_names[i]) == names(compiledFuns)) -## if(length(iRes) != 1) { -## warning(paste0("Building R6 inteface classes: Name matching of results had a problem for ", nClass_name, ".")) -## } else { -## R6interfaces[[i]] <- try(build_compiled_nClass(units[[i]], -## compiledFuns[[iRes]], -## env = resultEnv)) -## if(inherits(R6interfaces[[i]], "try-error")) { -## warning(paste0("There was a problem building a full nClass interface. for ", nClass_name, ".")) -## R6interfaces[[i]] <- NULL -## } -## } -## } -## } -## } -## names(R6interfaces) <- cpp_names - -## if(any(unitTypes == "nCgen")) { -## newDLLenv <- make_DLLenv() -## compiledFuns <- setup_nClass_environments(compiledFuns, -## newDLLenv, -## nC_names = cpp_names[unitTypes=="nCgen"], -## R6interfaces = R6interfaces, -## returnList = TRUE) -## } - -## ## Next we re-order results using input names, -## ## in case the ordering in the C++ code or in Rcpp's handling -## ## does not match order of units. -## ## cpp_names should be 1-to-1 with names(ans) -## ## We want to return with names(ans) changed to -## ## names(units), in the order corresponding to cpp_names. -## ans <- vector(mode="list", length = length(units)) -## ans_names <- character(length = length(units)) -## for(i in seq_along(units)) { -## if(unitTypes[i] == "nF") { -## iRes <- which(cpp_names[i] == names(compiledFuns)) # iRes is index in compiledFuns of the i-th unit -## } else if(unitTypes[i] == "nCgen") { -## iRes <- which( paste0("new_", cpp_names[i]) == names(compiledFuns)) -## } else { -## iRes <- integer() -## } -## if(length(iRes) != 1) { -## warning(paste0("Collecting results: Name matching of results had a problem for ", names(units)[i], ".\n", -## " Returning list of compiled results with internal C++ names.")) -## return(compiledFuns) -## } -## ans_names[i] <- names(units)[i] - -## if(unitTypes[i] == "nF") { -## ans[[i]] <- compiledFuns[[iRes]] -## } else if(unitTypes[i] == "nCgen") { -## interfaceType <- interfaces[[ ans_names[i] ]] -## if(is.null(interfaceType)) -## interfaceType <- "full" -## if(interfaceType == "full") -## ans[[i]] <- R6interfaces[[cpp_names[i] ]] -## else -## ans[[i]] <- compiledFuns[[iRes]] -## } -## } -## names(ans) <- ans_names - -## if(is.list(ans)) { # ans should always be a list but this handles if it isn't -## if(!returnList) { -## if(length(ans) == 1) ans[[1]] -## else ans -## } else ans -## } else if(returnList) list(ans) -## else ans -## } get_nCompile_types <- function(units) { ans <- character(length(units)) @@ -447,7 +293,21 @@ nCompile <- function(..., # but we are going to mix them together as if they were an arbitrary # input list because that's what nCompiler_prepare_units and nCompile_createCppDefsInfo uses. new_units <- c(new_needed_nClasses, new_needed_nFunctions) - new_units <- setdiff(new_units, units) + ## We need to make our own version of setdiff as it won't work on these types. + ## For now we rely on identical(). If this gets clunky or inefficient, + ## we can refine, but that would then need looking at types of each comparison + ## to decide how to do the comparison. + keep_new_unit <- rep(TRUE, length(new_units)) + for(i in seq_along(new_units)) { + this_new_unit <- new_units[[i]] + for(j in seq_along(units)) { + if(identical(this_new_unit, units[[j]])) { + keep_new_unit[i] <- FALSE + break + } + } + } + new_units <- new_units[keep_new_unit] if(length(new_units) == 0) { done_finding_units <- TRUE } else { diff --git a/nCompiler/R/nimbleModels.R b/nCompiler/R/nimbleModels.R index efee3c2a..d1f1e609 100644 --- a/nCompiler/R/nimbleModels.R +++ b/nCompiler/R/nimbleModels.R @@ -38,7 +38,11 @@ calcInstr_nClass <- nClass( file.path("calcInstr_nClass")), compileInfo=list(interface="full", createFromR = TRUE, - Hincludes = "" + Hincludes = "", + # In the format here, needed_units is a list with either objects (nFunction or nClass (generators), + # or names. If names, we will use scoping to look them up and decide what they are. + # The list can mix objects and names of nClasses and nFunctions. + needed_units = list("nodeInstr_nClass") #predefined_output_dir = "calcInstr_nClass" ) ) diff --git a/nCompiler/R/options.R b/nCompiler/R/options.R index 039f86f3..18e4ad05 100644 --- a/nCompiler/R/options.R +++ b/nCompiler/R/options.R @@ -18,7 +18,7 @@ updateDefaults <- function(defaults, control) { allow_method_overloading = FALSE, allow_inherited_field_duplicates = FALSE, compilerOptions = list( - nCompiler_include_units = TRUE, # Checked by nCompile, which sets always_include_units to match + nCompile_include_units = TRUE, # Checked by nCompile, which sets always_include_units to match always_include_units = FALSE, # Checked by NC_Compiler and NF_Compile. use_nCompiler_error_handling = TRUE, rebuild = FALSE, From 6311c37cc8123b8cef6e30f15863bcf547dca76c Mon Sep 17 00:00:00 2001 From: perrydv Date: Tue, 9 Dec 2025 18:25:32 +0100 Subject: [PATCH 6/7] added test-nCompile_auto_include and fixed issues along the way --- nCompiler/R/NC_Compile.R | 4 +- nCompiler/R/NC_CompilerClass.R | 10 +- nCompiler/R/NF_Compile.R | 4 +- nCompiler/R/nCompile.R | 40 +- .../nClass_tests/test-nClass_inherit.R | 20 +- .../test-nCompile_auto_include.R | 475 ++++++++++++++++++ .../test-eigenShapeFlex.R | 0 .../test-indexing.R | 0 8 files changed, 529 insertions(+), 24 deletions(-) create mode 100644 nCompiler/tests/testthat/nCompile_tests/test-nCompile_auto_include.R rename nCompiler/tests/testthat/{nCompile_tests => specificOp_tests}/test-eigenShapeFlex.R (100%) rename nCompiler/tests/testthat/{nCompile_tests => specificOp_tests}/test-indexing.R (100%) diff --git a/nCompiler/R/NC_Compile.R b/nCompiler/R/NC_Compile.R index d8ba148e..102d6089 100644 --- a/nCompiler/R/NC_Compile.R +++ b/nCompiler/R/NC_Compile.R @@ -49,6 +49,7 @@ nCompile_nClass <- function(NC, gather_needed_units <- isTRUE(controlFull$always_include_units) needed_units <- list(needed_nClasses = list(), needed_nFunctions = list()) + allow_write_predefined <- FALSE if(is_predefined) { predefined_dir <- NCinternals(NC)$predefined # predefined can be character, quoted expression, or function. @@ -69,6 +70,7 @@ nCompile_nClass <- function(NC, if(gather_needed_units) needed_units <- nCompile_process_manual_needed_units(NCinternals(NC), NC$parent_env, isNC = TRUE) + allow_write_predefined <- !isTRUE(compileInfo$auto_included) } if(is_predefined && isFALSE(controlFull$generate_predefined)) { RcppPacket <- loadRcppPacket(predefined_dir, regular_filename) @@ -86,7 +88,7 @@ nCompile_nClass <- function(NC, interfaceCalls = !is_predefined) ## We don't retain NC in NC_Compiler in order to simplify many environments pointing to each other. ## Get the cppDef cppDef <- NC_Compiler$cppDef - if(is_predefined) { + if(is_predefined && allow_write_predefined) { predefined_gen_dir <- NCinternals(NC)$compileInfo$predefined_output_dir if(is.null(predefined_gen_dir)) predefined_gen_dir <- predefined_dir diff --git a/nCompiler/R/NC_CompilerClass.R b/nCompiler/R/NC_CompilerClass.R index 870eb99a..337dc7e3 100644 --- a/nCompiler/R/NC_CompilerClass.R +++ b/nCompiler/R/NC_CompilerClass.R @@ -146,7 +146,11 @@ NC_CompilerClass <- R6::R6Class( nCompile_process_manual_needed_units <- function(internals, where = internals$where, # NFinternals case isNC = FALSE) { - # A little awkwardness on the input arguments + # This function collects two forms of "manual" needed units (nClasses and nFunctions): + # those provided via compileInfo$needed_units and also (in the case of nClass) + # an inherited nClass. + # + # A little awkwardness on the input arguments: # It would be nice to pass either just the internals (NCinternals(NC) or NFinternals(NF)) # OR just the NC or NF object. # But neither case is consistent between nClass and nFunction. @@ -170,7 +174,7 @@ nCompile_process_manual_needed_units <- function(internals, } if(isNCgenerator(obj)) { results_nClasses[[length(results_nClasses) + 1]] <- obj - } else if(isNFunction(obj)) { + } else if(isNF(obj)) { results_nFunctions[[length(results_nFunctions) + 1]] <- obj } else { stop(paste0("In processing compileInfo$needed_units for ", name, ", object '", @@ -200,7 +204,7 @@ nCompile_gather_needed_nClasses <- function(cppDef, for(i in seq_along(symTab$symbols)) { if(inherits(symTab$symbols[[i]], "symbolNC")) { new_needed[[length(new_needed) + 1]] <- - symTab$symbols[[i]]$nClassGenerator + symTab$symbols[[i]]$NCgenerator } } # For an nFunction, collection nClass generators identified diff --git a/nCompiler/R/NF_Compile.R b/nCompiler/R/NF_Compile.R index e95ea2cc..60c80f68 100644 --- a/nCompiler/R/NF_Compile.R +++ b/nCompiler/R/NF_Compile.R @@ -61,6 +61,7 @@ nCompile_nFunction <- function(NF, gather_needed_units <- isTRUE(controlFull$always_include_units) needed_units <- list(needed_nClasses = list(), needed_nFunctions = list()) + allow_write_predefined <- FALSE if(is_predefined) { predefined_dir <- NFinternals(NF)$predefined # predefined can be character, quoted expression, or function. @@ -80,6 +81,7 @@ nCompile_nFunction <- function(NF, regular_filename <- NFinternals(NF)$cpp_code_name if(gather_needed_units) needed_units <- nCompile_process_manual_needed_units(NFinternals(NF)) + allow_write_predefined <- !isTRUE(compileInfo$auto_included) } if(is_predefined && isFALSE(controlFull$generate_predefined)) { RcppPacket <- loadRcppPacket(predefined_dir, regular_filename) @@ -97,7 +99,7 @@ nCompile_nFunction <- function(NF, NF_Compiler$stageCompleted)) return(NF_Compiler) } - if(is_predefined) { + if(is_predefined && allow_write_predefined) { predefined_gen_dir <- NFinternals(NF)$compileInfo$predefined_output_dir if(is.null(predefined_gen_dir)) predefined_gen_dir <- predefined_dir diff --git a/nCompiler/R/nCompile.R b/nCompiler/R/nCompile.R index 1dcfd458..95ec03ba 100644 --- a/nCompiler/R/nCompile.R +++ b/nCompiler/R/nCompile.R @@ -269,6 +269,10 @@ nCompile <- function(..., returnNames <- character() cppDefs <- list() cpp_names <- character() + auto_included <- rep(FALSE, length(new_units)) + # the compileInfos$auto_included field is used in nCompile_nFunction and nCompile_nClass + # to decide whether it is allowed to generate predefined code. For auto_included units, NO. + new_compileInfos <- new_compileInfos |> lapply(\(x) {x$auto_included <- FALSE; x}) while(!done_finding_units) { cppDefs_info <- nCompile_createCppDefsInfo(new_units, new_unitTypes, controlFull, new_compileInfos) @@ -320,6 +324,8 @@ nCompile <- function(..., new_compileInfos <- new_unit_info$compileInfos new_exportNames <- new_unit_info$exportNames new_returnNames <- new_unit_info$returnNames + auto_included <- c(auto_included, rep(TRUE, length(new_units))) + new_compileInfos <- new_compileInfos |> lapply(\(x) {x$auto_included <- TRUE; x}) } else { stop("During compilation, additional units (nClasses or nFunctions) were needed but were not provided in the nCompile call. ", "To have nCompile automatically include such units, include control(nCompile_include_units=TRUE) or (to change the setting for all calls) do set_nOption(\"nCompile_include_units\", TRUE, \"compilerOptions\").", @@ -399,6 +405,11 @@ nCompile <- function(..., else NULL }) names(ans_) <- returnNames + # Remove any auto_included entries. + # See comment below in nCompile_finish_package about this step. + if(any(auto_included)) { + ans_ <- ans_[!auto_included] + } ans_ }) # cat("done trying devtools::install\n") @@ -428,7 +439,8 @@ nCompile <- function(..., cacheDir = cacheDir, env = env, returnList = returnList, - compileInfos = compileInfos)) + compileInfos = compileInfos, + auto_included = auto_included)) } } @@ -618,7 +630,9 @@ nCompile_finish_nonpackage <- function(units, cacheDir, env, returnList, - compileInfos) { + compileInfos, + auto_included = rep(FALSE, length(units)) + ) { cppfile <- paste0(cppFileLabelFunction(),".cpp") ## "nCompiler_multiple_units.cpp" resultEnv <- new.env() compiledFuns <- cpp_nCompiler(RcppPacket_list, @@ -688,6 +702,8 @@ nCompile_finish_nonpackage <- function(units, if(any(unitTypes == "nCgen")) { newDLLenv <- make_DLLenv() + # The next call does NOT rely on alignment of compiledFuns and the other inputs. + # The other inputs are used to pick out and move subsets of compiledFuns. compiledFuns <- setup_nClass_environments(compiledFuns, newDLLenv, exportNames = exportNames[expect_nC_interface], @@ -703,9 +719,12 @@ nCompile_finish_nonpackage <- function(units, ## cpp_names should be 1-to-1 with names(ans), with the exception of nF's that are not exported to R via RcppExport ## We want to return with names(ans) changed to ## names(units), in the order corresponding to cpp_names, but skipping non-exported nF's. + ## + ## At the last step, we also exclude returning auto_included entries, and we must track that through any reordering unit_is_nF_noExport <- unitTypes=="nF_noExport" ans <- vector(mode="list", length = length(units)) ans_names <- character(length = length(units)) + ans_auto_included <- logical(length = length(units)) for(i in seq_along(units)) { iRes <- -1 # will not get used. in cases where it is not replaced next, it is not used. if(unitTypes[i] == "nF") { @@ -719,7 +738,14 @@ nCompile_finish_nonpackage <- function(units, " Returning list of compiled results with internal C++ names.")) return(compiledFuns) } - ans_names[i] <- returnNames[i]# names(units)[i] + ## In the case of nCgen and !expect_createFromR[i], ans[[i]] will remain NULL + ## and below ans[[i]] will remain NULL, which is correct. + ## The next two lines are a bit silly in that we are simply copying two vectors + ## element by element. What they demonstrate is that the ans list is being returned + ## in the same order as input, even if that requires rearrangement from compiledFuns. + ## When returning an R6interface, that is being picked out by name. + ans_names[i] <- returnNames[i] + ans_auto_included[i] <- auto_included[i] if(unitTypes[i] == "nF") { ans[[i]] <- compiledFuns[[iRes]] @@ -741,6 +767,14 @@ nCompile_finish_nonpackage <- function(units, } names(ans) <- ans_names + # Remove results that were auto_included. + # Arguably this could be done earlier and save work. + # It is done here for two reasons: being added to the code later, + # and potential cleanness in being able to turn it off or modify later. + if(any(ans_auto_included)) { + ans <- ans[!ans_auto_included] + } + if(is.list(ans)) { # ans should always be a list but this handles if it isn't if(!returnList) { if(length(ans) == 1) ans[[1]] diff --git a/nCompiler/tests/testthat/nClass_tests/test-nClass_inherit.R b/nCompiler/tests/testthat/nClass_tests/test-nClass_inherit.R index d8c83782..acc55532 100644 --- a/nCompiler/tests/testthat/nClass_tests/test-nClass_inherit.R +++ b/nCompiler/tests/testthat/nClass_tests/test-nClass_inherit.R @@ -13,8 +13,8 @@ message("See comments in test-nClass_inherit.R for more notes.") # We use the inheritance semantics of R6 classes to set the default rules for # nClasses. # -# For fields: If two R6 classes have fields of the same name, they seem to -#. become one field. Therefore we disallow this in nClasses in order to +# For fields: If two R6 classes have fields of the same name, they seem to +#. become one field. Therefore we disallow this in nClasses in order to # avoid generating C++ classes that actually have two distinct members #. of the same name and then getting different compiled vs. uncompiled behavior. # This is checked in NC_check_inheritance. @@ -27,7 +27,7 @@ message("See comments in test-nClass_inherit.R for more notes.") # fine and a base class method can be accessed by super$foo(). #. However, R6 has no notion of virtual vs. non-virtual inheritance, no #. notion of signatures (argument and return types) being required to match -#. for virtual inheritance, and no notion of base class pointers. In effect, +#. for virtual inheritance, and no notion of base class pointers. In effect, # R6 objects are just passed as objects and a method call will always use # the most derived version. To match that, we require nClass inherited methods #. of the same name to have exactly matching argument names, types, and return type. @@ -51,7 +51,7 @@ message("See comments in test-nClass_inherit.R for more notes.") # We now keep it that way as `inheritQ` (for "quoted") # This allows an nClass call to inherit from a method that isn't defined yet. -# We do not currently support "super$" in compilation, so there is no +# We do not currently support "super$" in compilation, so there is no # way to call a base class method (yet). test_that("nClass hierarchy traps lack of virtual declaration", { @@ -362,18 +362,6 @@ test_that("nClass hierarchies work as expected (including uncompiled vs compiled # cat("With inheritance, we may now be able to interface at multiple levels, but it is untested.\n") test_that("inheriting-only classes in 3-level hierarchy works", { - # This was written before all the error-trapping above. - # I am going to disable the error-trapping. I think this is good - # because now we also test the more general compilation, but - # I may not be thinking about cases we're missing. - oldOpt1 <- nOptions("allow_method_overloading") - oldOpt2 <- nOptions("allow_inherited_field_duplicates") - nOptions(allow_method_overloading = TRUE) - nOptions(allow_inherited_field_duplicates = TRUE) - on.exit({ - nOptions(allow_method_overloading = oldOpt1) - nOptions(allow_inherited_field_duplicates = oldOpt2) - }) ncBase <- nClass( classname = "ncBase", Cpublic = list( diff --git a/nCompiler/tests/testthat/nCompile_tests/test-nCompile_auto_include.R b/nCompiler/tests/testthat/nCompile_tests/test-nCompile_auto_include.R new file mode 100644 index 00000000..77475ae7 --- /dev/null +++ b/nCompiler/tests/testthat/nCompile_tests/test-nCompile_auto_include.R @@ -0,0 +1,475 @@ +# Tests of nCompile's ability to automatically include needed units (nClasses and nFunctions) + +# library(testthat) +# library(nCompiler) + +# Rather than running all of the below tests in both non-package and +# package modes of compilation, I will alternate. + +test_that("nFunction auto-including nFunction works and can be controlled", { + opt <- nOptions("compilerOptions")$nCompile_include_units + on.exit(set_nOption("nCompile_include_units", opt, "compilerOptions")) + set_nOption("nCompile_include_units", TRUE, "compilerOptions") + + fn1 <- nFunction( + function(x=double()) {return(x+1); returnType(double())} + ) + nf2 <- nFunction( + function(x=double()) {return(fn1(x)); returnType(double())} + ) + comp <- nCompile(fn1, nf2) + expect_equal(comp$fn2(1), 2) + + comp <- nCompile(nf2) + expect_true(is.function(comp)) + expect_equal(comp(1), 2) + + expect_error( + nCompile(nf2, control=list(nCompile_include_units=FALSE)) + ) + + set_nOption("nCompile_include_units", FALSE, "compilerOptions") + expect_error( + nCompile(nf2) + ) + set_nOption("nCompile_include_units", TRUE, "compilerOptions") + +}) + +test_that("nClass auto-including nFunction works and can be controlled", { + opt <- nOptions("compilerOptions")$nCompile_include_units + on.exit(set_nOption("nCompile_include_units", opt, "compilerOptions")) + set_nOption("nCompile_include_units", TRUE, "compilerOptions") + + fn1 <- nFunction( + function(x=double()) {return(x+1); returnType(double())} + ) + nc2 <- nClass( + Cpublic = list( + fn2 = nFunction( + function(x=double()) {return(fn1(x)); returnType(double())} + ) + ) + ) + comp <- nCompile(fn1, nc2, package = TRUE) + obj <- comp$nc2$new() + expect_equal(obj$fn2(1), 2) + rm(obj); gc() + + comp <- nCompile(nc2) + expect_true(inherits(comp, "R6ClassGenerator")) + obj <- comp$new() + expect_equal(obj$fn2(1), 2) + rm(obj); gc() + + expect_error( + nCompile(nc2, package=TRUE, control=list(nCompile_include_units=FALSE)) + ) + + set_nOption("nCompile_include_units", FALSE, "compilerOptions") + expect_error( + nCompile(nc2, package=TRUE) + ) + set_nOption("nCompile_include_units", TRUE, "compilerOptions") +}) + +test_that("nClass auto-including nClass works and can be controlled", { + opt <- nOptions("compilerOptions")$nCompile_include_units + on.exit(set_nOption("nCompile_include_units", opt, "compilerOptions")) + set_nOption("nCompile_include_units", TRUE, "compilerOptions") + + nc1 <- nClass( + Cpublic = list( + fn1 = nFunction( + function(x=double()) {return(x+1); returnType(double())} + ) + ) + ) + nc2 <- nClass( + Cpublic = list( + mync1 = "nc1", + fn2 = nFunction( + function(x=double()) { + mync1 <- nc1$new() + return(mync1$fn1(x)); returnType(double())} + ) + ) + ) + comp <- nCompile(nc2, nc1) + obj <- comp$nc2$new() + expect_equal(obj$fn2(1), 2) + rm(obj); gc() + + comp <- nCompile(nc2) + expect_true(inherits(comp, "R6ClassGenerator")) + obj <- comp$new() + expect_equal(obj$fn2(1), 2) + rm(obj); gc() + + expect_error( + nCompile(nc2, control=list(nCompile_include_units=FALSE)) + ) + + set_nOption("nCompile_include_units", FALSE, "compilerOptions") + expect_error( + nCompile(nc2) + ) + set_nOption("nCompile_include_units", TRUE, "compilerOptions") +}) + +# The next test is a very minor tweak and could perhaps be reduced in the future +test_that("nClass auto-including nClass works (non-member) and can be controlled", { + opt <- nOptions("compilerOptions")$nCompile_include_units + on.exit(set_nOption("nCompile_include_units", opt, "compilerOptions")) + set_nOption("nCompile_include_units", TRUE, "compilerOptions") + + nc1 <- nClass( + Cpublic = list( + fn1 = nFunction( + function(x=double()) {return(x+1); returnType(double())} + ) + ) + ) + nc2 <- nClass( + Cpublic = list( + #mync1 = "nc1", + fn2 = nFunction( + function(x=double()) { + mync1 <- nc1$new() # local object only + return(mync1$fn1(x)); returnType(double())} + ) + ) + ) + comp <- nCompile(nc2, nc1, package=TRUE) + obj <- comp$nc2$new() + expect_equal(obj$fn2(1), 2) + rm(obj); gc() + + comp <- nCompile(nc2, package=TRUE) + expect_true(inherits(comp, "R6ClassGenerator")) + obj <- comp$new() + expect_equal(obj$fn2(1), 2) + rm(obj); gc() + + expect_error( + nCompile(nc2, package=TRUE, control=list(nCompile_include_units=FALSE)) + ) + + set_nOption("nCompile_include_units", FALSE, "compilerOptions") + expect_error( + nCompile(nc2, package=TRUE) + ) + set_nOption("nCompile_include_units", TRUE, "compilerOptions") +}) + + +# The next test is a very minor tweak and could perhaps be reduced in the future +test_that("nClass auto-including nClass works (member only) and can be controlled", { + opt <- nOptions("compilerOptions")$nCompile_include_units + on.exit(set_nOption("nCompile_include_units", opt, "compilerOptions")) + set_nOption("nCompile_include_units", TRUE, "compilerOptions") + + nc1 <- nClass( + Cpublic = list( + fn1 = nFunction( + function(x=double()) {return(x+1); returnType(double())} + ) + ) + ) + nc2 <- nClass( + Cpublic = list( + mync1 = "nc1", # not used, needs still to be seed as needed + fn2 = nFunction( + function(x=double()) { + return(x+1); returnType(double())} + ) + ) + ) + comp <- nCompile(nc2, nc1) + obj <- comp$nc2$new() + expect_equal(obj$fn2(1), 2) + rm(obj); gc() + + comp <- nCompile(nc2) + expect_true(inherits(comp, "R6ClassGenerator")) + obj <- comp$new() + expect_equal(obj$fn2(1), 2) + rm(obj); gc() + + expect_error( + nCompile(nc2, control=list(nCompile_include_units=FALSE)) + ) + + set_nOption("nCompile_include_units", FALSE, "compilerOptions") + expect_error( + nCompile(nc2) + ) + set_nOption("nCompile_include_units", TRUE, "compilerOptions") +}) + +# The next test is a very minor tweak and could perhaps be reduced in the future +test_that("nClass auto-including nClass works (member only, in parent_env) and can be controlled", { + opt <- nOptions("compilerOptions")$nCompile_include_units + on.exit(set_nOption("nCompile_include_units", opt, "compilerOptions")) + set_nOption("nCompile_include_units", TRUE, "compilerOptions") + + nc1 <- nClass( + Cpublic = list( + fn1 = nFunction( + function(x=double()) {return(x+1); returnType(double())} + ) + ) + ) + nc2 <- nClass( + Cpublic = list( + mync1 = "nc1", # not used, needs still to be seed as needed + fn2 = nFunction( + function(x=double()) { + return(x+1); returnType(double())} + ) + ) + ) + nc2$parent_env$nc1 <- nc1 + rm(nc1) + comp <- nCompile(nc2, returnList=TRUE) + obj <- comp$nc2$new() + expect_equal(obj$fn2(1), 2) + rm(obj); gc() + + expect_error( + nCompile(nc2, control=list(nCompile_include_units=FALSE)) + ) + + set_nOption("nCompile_include_units", FALSE, "compilerOptions") + expect_error( + nCompile(nc2) + ) + set_nOption("nCompile_include_units", TRUE, "compilerOptions") +}) + +test_that("nFunction auto-including nClass works (non-member) and can be controlled", { + opt <- nOptions("compilerOptions")$nCompile_include_units + on.exit(set_nOption("nCompile_include_units", opt, "compilerOptions")) + set_nOption("nCompile_include_units", TRUE, "compilerOptions") + + nc1 <- nClass( + Cpublic = list( + fn1 = nFunction( + function(x=double()) {return(x+1); returnType(double())} + ) + ) + ) + fn2 <- nFunction( + function(x=double()) { + mync1 <- nc1$new() # local object only + return(mync1$fn1(x)); returnType(double())} + ) + comp <- nCompile(fn2, nc1, package=TRUE) + expect_equal(fn2(1), 2) + + comp <- nCompile(fn2, package=TRUE) + expect_true(is.function(comp)) + expect_equal(fn2(1), 2) + + expect_error( + nCompile(fn2, package=TRUE, control=list(nCompile_include_units=FALSE)) + ) + + set_nOption("nCompile_include_units", FALSE, "compilerOptions") + expect_error( + nCompile(fn2, package=TRUE) + ) + set_nOption("nCompile_include_units", TRUE, "compilerOptions") +}) + +test_that("auto-including from inherited nClass works and can be controlled", { + # Adapted from test-nClass_inherit + opt <- nOptions("compilerOptions")$nCompile_include_units + on.exit(set_nOption("nCompile_include_units", opt, "compilerOptions")) + set_nOption("nCompile_include_units", TRUE, "compilerOptions") + + ncBase <- nClass( + classname = "ncBase", + Cpublic = list( + x = 'numericScalar', + add_x = nFunction(function(v = 'numericScalar') { + return(v + x); returnType('numericScalar'); + }, + name = "add_x"), + add_2x_virt = nFunction(function(v = 'numericScalar') { + return(v + 2*x); returnType('numericScalar'); + }) + ), + compileInfo = list(interface = "none",createFromR=FALSE) + ) + + ncMid <- nClass( + inherit = ncBase, + classname = "ncMid", + compileInfo = list(interface = "none",createFromR=FALSE), + Cpublic = list(x2 = 'numericScalar') + ) + + ncDer <- nClass( + inherit = ncMid, + Cpublic = list(x3 = 'numericScalar') + ) + + ncUseBase <- nClass( + classname = "ncUseBase", + Cpublic = list( + myBase = 'ncBase', + call_add_x = nFunction( + fun = function(v = 'numericScalar') { + return(myBase$add_x(v)); returnType('numericScalar') + } + ) + ) + ) + + comp <- nCompile(ncUseBase, ncBase, ncMid, ncDer) + Cobj <- comp$ncDer$new() + Cobj$x <- 10 + expect_equal(Cobj$add_x(15), 25) + expect_equal(method(Cobj$private$CppObj, "add_x")(15), 25) + expect_equal(Cobj$add_2x_virt(15), 35) + Cobj2 <- comp$ncUseBase$new() + expect_true(is.null(Cobj2$myBase)) + Cobj2$myBase <- Cobj + expect_equal(Cobj2$call_add_x(15), 25) + rm(Cobj, Cobj2); gc() + + comp <- nCompile(ncUseBase, ncDer, returnList=TRUE) + Cobj <- comp$ncDer$new() + Cobj$x <- 10 + expect_equal(Cobj$add_x(15), 25) + expect_equal(method(Cobj$private$CppObj, "add_x")(15), 25) + expect_equal(Cobj$add_2x_virt(15), 35) + Cobj2 <- comp$ncUseBase$new() + expect_true(is.null(Cobj2$myBase)) + Cobj2$myBase <- Cobj + expect_equal(Cobj2$call_add_x(15), 25) + rm(Cobj, Cobj2); gc() + + expect_error( + nCompile(ncUseBase, ncDer, control=list(nCompile_include_units=FALSE)) + ) + + set_nOption("nCompile_include_units", FALSE, "compilerOptions") + expect_error( + nCompile(ncUseBase, ncDer) + ) + set_nOption("nCompile_include_units", TRUE, "compilerOptions") +}) + +# modified from test-predefined +test_that("One predefined nFunction can use another via auto-include", +{ + opt <- nOptions("compilerOptions")$nCompile_include_units + on.exit(set_nOption("nCompile_include_units", opt, "compilerOptions")) + set_nOption("nCompile_include_units", TRUE, "compilerOptions") + + ## It is recommended to provide an exportName. + ## Otherwise, the built-in export name will be set + ## when the predefined is generated, and that will + ## not necessarily match when it is auto-included + ## include the name happens to match the export name + ## given when calling nCompile (ie. the name of the ... entry) + foo <- nFunction( + name = "test_predefined_foo_nF", + function(x=double(1)) {return(x+1); returnType(double(1))}, + predefined=file.path(tempdir(), "test_predefined_foo_dir"), + compileInfo = list(exportName = "foo_export") + ) + bar <- nFunction( + name = "test_predefined_bar_nF", + function(x=double(1)) {return(foo(x+1)); returnType(double(1))}, + predefined=file.path(tempdir(), "test_predefined_bar_dir"), + compileInfo=list(needed_units="foo") + ) + dir <- file.path(tempdir(), "use_predefined_testdir") + comp <- nCompile(bar, dir=dir, control=list(generate_predefined=TRUE), returnList=TRUE) + expect_true(dir.exists(NFinternals(bar)$predefined)) + # auto-included unit does NOT get predefined files written. + # It must be manually included in the nCompile call to write files. + expect_false(dir.exists(NFinternals(foo)$predefined)) + expect_equal(comp$bar(1:3), 3:5) + # now write the next one + comp <- nCompile(foo, dir=dir, control=list(generate_predefined=TRUE), returnList=TRUE) + expect_true(dir.exists(NFinternals(foo)$predefined)) + expect_true(names(comp)=="foo_export") + expect_equal(comp$foo_export(1), 2) + dir2 <- file.path(tempdir(), "use_predefined_testdir2") + + loading_output <- capture_output(comp2 <- nCompile(bar, dir=dir2, returnList=TRUE)) + + text_matches <- gregexpr("Loading RcppPacket", loading_output)[[1]] + expect_true(length(text_matches)==2) + expect_equal(comp2$bar(1:3), 3:5) + unlink(dir, recursive = TRUE) + unlink(dir2, recursive = TRUE) + unlink(NFinternals(foo)$predefined, recursive=TRUE) + unlink(NFinternals(bar)$predefined, recursive=TRUE) +}) + +test_that("One predefined nClass can use another, separately and by inheritance, via auto-include", +{ + opt <- nOptions("compilerOptions")$nCompile_include_units + on.exit(set_nOption("nCompile_include_units", opt, "compilerOptions")) + set_nOption("nCompile_include_units", TRUE, "compilerOptions") + + for(package in c(FALSE, TRUE)) { + foo_base <- nClass( + classname = "test_predefined_nC_foo_base", + Cpublic = list( + give_one = nFunction( + function() { + return(1.0); returnType(double()) + } + ) + ) + , compileInfo = list(interface='none', createFromR = FALSE) + , predefined=file.path(tempdir(), "test_predefined_nC_foo_base_dir") + ) + + foo <- nClass( + classname = "test_predefined_nC_foo", + inherit = foo_base, + Cpublic = list( + bar = nFunction( + function(x=double(1)) {return(x+1); returnType(double(1))} + ) + ) + , predefined=file.path(tempdir(), "test_predefined_nC_foo_dir") + , compileInfo=list(needed_units = "foo_base") + ) + + use_foo <- nClass( + classname = "test_predefined_nC_usefoo", + Cpublic = list( + make_foo = nFunction( + function() {return(foo$new()); returnType('foo')} + ) + ) + , predefined=file.path(tempdir(), "test_predefined_nC_use_foo") + , compileInfo=list(needed_units = "foo") + ) + + dir <- file.path(tempdir(), "use_predefined_nC_testdir2") + + comp <- nCompile(use_foo, dir=dir, control=list(generate_predefined=TRUE), package=package, returnList=TRUE) + obj <- comp$use_foo$new() + expect_equal(obj$make_foo()$bar(1:3), 2:4) + dir2 <- file.path(tempdir(), "use_predefined_nC_testdir2") + loading_output <- capture_output(comp2 <- nCompile(use_foo, dir=dir2,package=package, returnList=TRUE)) + obj2 <- comp2$use_foo$new() + expect_true(grepl("^Loading RcppPacket", loading_output)) + expect_equal(obj2$make_foo()$bar(1:3), 2:4) + rm(obj, obj2); gc() + unlink(dir, recursive = TRUE) + unlink(dir2, recursive = TRUE) + unlink(NCinternals(foo)$predefined, recursive=TRUE) + unlink(NCinternals(foo_base)$predefined, recursive=TRUE) + unlink(NCinternals(use_foo)$predefined, recursive=TRUE) + } +}) diff --git a/nCompiler/tests/testthat/nCompile_tests/test-eigenShapeFlex.R b/nCompiler/tests/testthat/specificOp_tests/test-eigenShapeFlex.R similarity index 100% rename from nCompiler/tests/testthat/nCompile_tests/test-eigenShapeFlex.R rename to nCompiler/tests/testthat/specificOp_tests/test-eigenShapeFlex.R diff --git a/nCompiler/tests/testthat/nCompile_tests/test-indexing.R b/nCompiler/tests/testthat/specificOp_tests/test-indexing.R similarity index 100% rename from nCompiler/tests/testthat/nCompile_tests/test-indexing.R rename to nCompiler/tests/testthat/specificOp_tests/test-indexing.R From 79ccf9a97cb6ce290c0596cc70f34b20f7c8e04f Mon Sep 17 00:00:00 2001 From: perrydv Date: Tue, 9 Dec 2025 19:12:56 +0100 Subject: [PATCH 7/7] fix new test-nCompile_auto_include --- .../nCompile_tests/test-nCompile_auto_include.R | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/nCompiler/tests/testthat/nCompile_tests/test-nCompile_auto_include.R b/nCompiler/tests/testthat/nCompile_tests/test-nCompile_auto_include.R index 77475ae7..e6fc0635 100644 --- a/nCompiler/tests/testthat/nCompile_tests/test-nCompile_auto_include.R +++ b/nCompiler/tests/testthat/nCompile_tests/test-nCompile_auto_include.R @@ -18,7 +18,7 @@ test_that("nFunction auto-including nFunction works and can be controlled", { function(x=double()) {return(fn1(x)); returnType(double())} ) comp <- nCompile(fn1, nf2) - expect_equal(comp$fn2(1), 2) + expect_equal(comp$nf2(1), 2) comp <- nCompile(nf2) expect_true(is.function(comp)) @@ -428,7 +428,8 @@ test_that("One predefined nClass can use another, separately and by inheritance, } ) ) - , compileInfo = list(interface='none', createFromR = FALSE) + , compileInfo = list(interface='none', createFromR = FALSE, + exportName="fooBase") , predefined=file.path(tempdir(), "test_predefined_nC_foo_base_dir") ) @@ -441,7 +442,8 @@ test_that("One predefined nClass can use another, separately and by inheritance, ) ) , predefined=file.path(tempdir(), "test_predefined_nC_foo_dir") - , compileInfo=list(needed_units = "foo_base") + , compileInfo=list(needed_units = "foo_base", + exportName = "foo") ) use_foo <- nClass( @@ -452,7 +454,8 @@ test_that("One predefined nClass can use another, separately and by inheritance, ) ) , predefined=file.path(tempdir(), "test_predefined_nC_use_foo") - , compileInfo=list(needed_units = "foo") + , compileInfo=list(needed_units = "foo", + exportName = "use_foo") ) dir <- file.path(tempdir(), "use_predefined_nC_testdir2") @@ -460,6 +463,9 @@ test_that("One predefined nClass can use another, separately and by inheritance, comp <- nCompile(use_foo, dir=dir, control=list(generate_predefined=TRUE), package=package, returnList=TRUE) obj <- comp$use_foo$new() expect_equal(obj$make_foo()$bar(1:3), 2:4) + + # now write the next one + comp <- nCompile(foo, foo_base, dir=dir, control=list(generate_predefined=TRUE), returnList=TRUE) dir2 <- file.path(tempdir(), "use_predefined_nC_testdir2") loading_output <- capture_output(comp2 <- nCompile(use_foo, dir=dir2,package=package, returnList=TRUE)) obj2 <- comp2$use_foo$new()