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 1af62743..102d6089 100644 --- a/nCompiler/R/NC_Compile.R +++ b/nCompiler/R/NC_Compile.R @@ -46,6 +46,10 @@ nCompile_nClass <- function(NC, control ) is_predefined <- !isFALSE(NCinternals(NC)$predefined) + 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. @@ -62,14 +66,18 @@ 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 + regular_filename <- NCinternals(NC)$cpp_classname + 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) 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, @@ -80,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 @@ -89,6 +97,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 +113,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..337dc7e3 100644 --- a/nCompiler/R/NC_CompilerClass.R +++ b/nCompiler/R/NC_CompilerClass.R @@ -115,6 +115,107 @@ NC_CompilerClass <- R6::R6Class( NCgenerator) setupMethodSymbolTables() } + }, + 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() + 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(), + 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) { + # 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. + # 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(isNF(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) { + # 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]]$NCgenerator + } + } + # 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/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 75e83006..60c80f68 100644 --- a/nCompiler/R/NF_Compile.R +++ b/nCompiler/R/NF_Compile.R @@ -58,6 +58,10 @@ 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(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. @@ -75,6 +79,9 @@ 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 <- 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) @@ -92,12 +99,14 @@ 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 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 +115,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..e2a8c93d 100644 --- a/nCompiler/R/NF_CompilerClass.R +++ b/nCompiler/R/NF_CompilerClass.R @@ -139,10 +139,32 @@ NF_CompilerClass <- R6::R6Class( doKeywords, .nCompilerProject, initialTypeInferenceOnly) + }, + gather_needed_units = function() { + compileInfo_needed_units <- nCompile_process_manual_needed_units(self$NFinternals) + list( + 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() { + nCompile_gather_needed_nClasses(cppDef, self$symbolTable, self) + }, + gather_needed_nFunctions = function() { + nCompile_gather_needed_nFunctions(cppDef, self) } ) ) +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..95ec03ba 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)) @@ -205,38 +51,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 +97,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))) @@ -309,7 +162,7 @@ nCompile <- 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") @@ -335,7 +188,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 +197,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 +211,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 +219,132 @@ 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() + 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) + 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() + 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 + # input list because that's what nCompiler_prepare_units and nCompile_createCppDefsInfo uses. + new_units <- c(new_needed_nClasses, new_needed_nFunctions) + ## 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 { + 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 + 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\").", + "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 +362,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 +379,7 @@ nCompile <- function(..., temppkgname <- basename(tempfile("TEMPPKG", "")) writePackage(pkgName = temppkgname, dir = dir, - control = control, + control = controlFull, unitControls = unitControls, modify = "clear", memberData = list(), @@ -446,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") @@ -475,7 +439,8 @@ nCompile <- function(..., cacheDir = cacheDir, env = env, returnList = returnList, - compileInfos = compileInfos)) + compileInfos = compileInfos, + auto_included = auto_included)) } } @@ -665,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, @@ -691,42 +658,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) + } + } ##} } # } @@ -735,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], @@ -750,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") { @@ -766,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]] @@ -788,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]] @@ -1029,7 +1016,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" 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 c5cbb15d..18e4ad05 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( + 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, rebuildCppDef = FALSE, 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..e6fc0635 --- /dev/null +++ b/nCompiler/tests/testthat/nCompile_tests/test-nCompile_auto_include.R @@ -0,0 +1,481 @@ +# 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$nf2(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, + exportName="fooBase") + , 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", + exportName = "foo") + ) + + 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", + exportName = "use_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) + + # 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() + 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