diff --git a/.github/workflows/test-all.yaml b/.github/workflows/test-all.yaml index a052a5cd..693a901f 100644 --- a/.github/workflows/test-all.yaml +++ b/.github/workflows/test-all.yaml @@ -41,7 +41,7 @@ jobs: run: R -q -e 'sessionInfo()' - name: Install nimbleModel run: R -q -e 'remotes::install_github("https://github.com/perrydv/nimbleModel", subdir="nimbleModel", auth_token=Sys.getenv("GITHUB_TOKEN_NIMBLEMODEL"))' - env: + env: GITHUB_TOKEN_NIMBLEMODEL: ${{ secrets.GH_NM_PAT }} - name: Package Dependencies run: R -q -e 'remotes::install_deps("nCompiler", dependencies=TRUE)' @@ -56,7 +56,7 @@ jobs: library(nCompiler) testthat::test_dir("nCompiler/tests/testthat/uncompiled_tests", reporter = "summary") testthat::test_dir("nCompiler/tests/testthat/nCompile_tests", reporter = "summary") - testthat::test_dir("nCompiler/tests/testthat/cpp_tests", reporter = "summary") + testthat::test_dir("nCompiler/tests/testthat/cpp_tests", reporter = "location") shell: Rscript {0} test-nCompile-features: diff --git a/nCompiler/NAMESPACE b/nCompiler/NAMESPACE index f499d123..4d07a8fa 100644 --- a/nCompiler/NAMESPACE +++ b/nCompiler/NAMESPACE @@ -12,8 +12,12 @@ export(calcInstr_nClass) export(calcInstrList_nClass) export(cloglog) export(check_Rcpp_for_nCompiler) +export(compileInfo) +export(`compileInfo<-`) export(compileNimble) +export(connect_nClass_envs) export(cpp_nCompiler) +export(CpubClass) export(createRef) export(createBlockRef) export(createRefInfoIntoC) @@ -49,6 +53,7 @@ export(getType) export(icloglog) export(ilogit) export(iprobit) +export(isCNC) export(isCompiledNCgenerator) export(isDiscrete) export(isNC) @@ -90,6 +95,7 @@ export(nArray) export(nOptions) export(nParse) export(nRep) +export(nSeq) export(nSerialize) export(nSolve) export(nUnserialize) @@ -130,6 +136,7 @@ export(setup_wrt) export(square) export(test_predefined) export(to_full_interface) +export(to_generic_interface) export(value) export("value<-") export(writeCode) diff --git a/nCompiler/R/NC.R b/nCompiler/R/NC.R index e8f15a67..8ca0c966 100644 --- a/nCompiler/R/NC.R +++ b/nCompiler/R/NC.R @@ -2,15 +2,23 @@ nClassLabelMaker <- labelFunctionCreator('nClass') nClassClass <- R6::R6Class( classname = "nClass", - portable = FALSE + portable = FALSE, + public = list( + initialize = function(...) { + initialize_Cpublic(...) + }, + initialize_Cpublic = function(...) { + private$Cpublic_obj <- private$initialize_Cpublic_obj(...) + } + ) ) -CnClassClass <- R6::R6Class( - classname = "CnClass", - inherit = nClassClass, +CpubClass <- R6::R6Class( + classname = "CpubClass", portable = FALSE ) + #' Create a nClass definition #' #' A nClass is like an R6 class, but it allows some data and @@ -75,6 +83,7 @@ nClass <- function(classname, compileInfo = list(), predefined = FALSE, env = parent.frame()) { + # # supported elements of compileInfo: # exportName: name of the R function to call the # C/C++ function for a new object. Defaults to paste0("new_", classname) @@ -92,6 +101,21 @@ nClass <- function(classname, # 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 # + # packageNames: can be a vector or list of two names, possibly named by "uncompiled" and "compiled", + # and taken in that order if unnamed. + #. These will be the names of the uncompiled and compiled class generators when writing package code, + # either through writePackage or nCompile(..., package=TRUE). If another nClass inherits from this one, + #. the inherit name must be the uncompiled packageNames element if compiling through a package. + #. A good practice will be my_nClass_unc <- nClass(..., packageNames = c("my_nClass_unc", "my_nClass_comp")) + # If these are missing, nCompile can generate names that will work if there is no inheritance by other nClasses, + #. and will often work through nCompiler(..., package=TRUE) if there is inheritance, but will not work + #. if there is inheritance and writePackage is called to help create a new package. The difference in these cases + # is that nCompile() returns a (possibly list of) compiled results in an active R session, but writePackage + #. must create names that will be the names used by the new package. nCompile(nc1, nc2) can return a list with + #. elements nc1 and nc2 that are the compiled versions of nc1 and nc2. But writePackage(nc1, nc2) can't + # safely do that because if it renames the compiled versions to nc1 and nc2, then the uncompiled versions + # must be given some other automated names, which will break `inherits` statements. + # # constructor(s) and destructor: # # constructors should be nFunctions with compileInfo = list(constructor=TRUE) @@ -119,12 +143,14 @@ nClass <- function(classname, interfaceMembers = NULL, depends = list(), inherit = list(), - nClass_inherit = list()), + nClass_inherit = list(), + packageNames = character()), compileInfo ) if(missing(classname)) - classname <- nClassLabelMaker() - + classname <- c(generated = nClassLabelMaker()) + if(is.null(compileInfo$classname)) + compileInfo$classname <- paste0(classname, "_compiled") if('finalize' %in% names(Cpublic)) { if('finalize' %in% names(Rpublic)) stop("If a finalize method is provided in Rpublic, it can't be provided in Cpublic.", @@ -138,7 +164,7 @@ nClass <- function(classname, if('initialize' %in% names(Cpublic)) { if('initialize' %in% names(Rpublic)) stop("If an initialize method is provided in Rpublic, it can't be provided in Cpublic.", - "If you want a C++ constructor that is not an R finalizer, give it a name and set", + "If you want a C++ constructor that is not an R constructor, give it a name and set", "compileInfo$constructor=TRUE.") if(!isTRUE(NFinternals(Cpublic[['initialize']])$compileInfo$constructor)) stop("In nFunction 'initialize', use 'compileInfo = list(constructor=TRUE)'.") @@ -149,7 +175,7 @@ nClass <- function(classname, internals = NC_InternalsClass$new(classname = classname, Cpublic = Cpublic, - isOnlyC = length(Rpublic) == 0, + RpublicNames = names(Rpublic), enableDerivs = enableDerivs, enableSaving = enableSaving, inheritQ = inheritQ, @@ -159,35 +185,180 @@ nClass <- function(classname, env = env) ## We put the internals in 2 places: ## 1. in an environment layer around every instance - new_env <- new.env(parent = env) + # The R6Class inherit argument has weird handling: # "captured as an unevaluated expression which is evaluated in parent_env each time an object is instantiated." # so if provided in the nClass call, we stick it in new_env. # (That is not the only reason for new_env.) # Also note that the inherit arg is for nClass inheritance. The compileInfo$inherit element is for hard-coded C++ inheritance statements. #if(!is.null(inherit)) new_env$.inherit_obj <- inherit - new_env$.NCinternals <- internals + # Uncompiled behavior for Cpublic fields needs to be handled. # Right now a type string like 'numericScalar' just becomes a # default value. - builtIn <- list(isCompiled=function() FALSE) - eval(substitute( - result <- R6::R6Class( - classname = classname, - public = c(Rpublic, Cpublic, builtIn), + if("isCompiled" %in% names(Cpublic)) { + stop("The name 'isCompiled' in Cpublic is reserved for nCompiler internal use.", + call. = FALSE) + } + # Cpublic$initialize may be provided and should check isCompiled() for behavior + # because it will be inherited directly in the compiled Cpublic class. + # + # It should not normally be necessary. + # + Cpub_class_code <- make_uncompiled_Cpub_class_code( + classname = classname, + inheritQ = inheritQ, + Cpublic = NULL # indicates to leave quote(Cpublic) + ) + + main_class_code <- make_nClass_code( + internals = internals, + Cpublic = Cpublic, # Allows to make methods that call the Cpub_object + Rpublic = NULL # indicates to leave quote(Rpublic) + ) + + # Either we must store this or rebuilding it when writing package code. + # To store it, we would need to retain the Rpublic from this function's environment. + # Currently the strategy is to rebuild it. + # internals$main_class_code <- main_class_code + + ## Build the R6 class generator + NCgenerator <- eval(main_class_code) + Cpub_generator <- eval(Cpub_class_code) + connect_nClass_envs(NCgenerator, Cpub_generator, env) + + NCgenerator$parent_env$.NCinternals <- internals + ## Store the internals in two places: + ## 2. in the generator + NCgenerator$.nCompiler <- internals + ## NB: We want to avoid having every object + ## include the generator, to keep saving light. + NCgenerator +} + +make_uncompiled_Cpub_class_code <- function(classname, + inheritQ = NULL, + Cpublic = NULL) { + inherit_provided <- !is.null(inheritQ) + Cpublic_code <- quote(Cpublic) + if(!is.null(Cpublic)) { + parsedcopy <- \(f) {ans <- substitute(\() BODY, list(BODY=body(f))) |> removeSource(); if(!is.null(formals(f))) ans[[2]] <- formals(f); ans} + Cpublic_code_list <- Cpublic |> lapply(\(x) if(is.function(x)) parsedcopy(x) else x) + Cpublic_code <- do.call("call", c("list", + Cpublic_code_list)) + } + substitute( + R6::R6Class( + classname = CLASSNAME, + public = c(CPUBLIC, + list(isCompiled=function() FALSE)), portable = FALSE, inherit = INHERIT, - parent_env = new_env + parent_env = NULL ), - list(INHERIT = + list(CLASSNAME = paste0(classname, "_Cpub_uncompiled"), + CPUBLIC = Cpublic_code, + INHERIT = + if(inherit_provided) substitute((INHERITQ)$parent_env$.Cpub_class, list(INHERITQ = inheritQ)) + else quote(nCompiler::CpubClass)) + ) +} + +make_nClass_code <- function(internals, + Cpublic = NULL, # if nFunctions (called from nClass), create method. If R function (called from WP_writeRinterfaces), use that () + Rpublic = NULL # If NULL (called from nClass), use quote(Rpublic). If provided (from WP_writeRinterfaces), deparse. + ) { + classname <- internals$classname + inheritQ <- internals$inheritQ + fieldNames <- internals$fieldNames + CmethodNames <- internals$methodNames + + inherit_provided <- !is.null(inheritQ) + + activeBindings_code <- fieldNames |> lapply( + function(name) { + substitute( + function(value) { + if(missing(value)) + private$Cpublic_obj$NAME + else + private$Cpublic_obj$NAME <- value + }, + list(NAME = name) + ) |> removeSource()} # otherwise future srcref persists as fourth list element -- confusing! + ) |> structure(names = fieldNames) + activeBindings_list_code <- do.call("call", c("list", activeBindings_code)) + + if(length(CmethodNames)) { + Cmethods_code_list <- mapply(build_Cmethod_code_for_nClass, + fun = Cpublic[CmethodNames], + name = CmethodNames) + } else { + Cmethods_code_list <- list() + } + Cmethods_code <- do.call("call", c("list", + Cmethods_code_list)) + + builtIn_code_list <- list(isCompiled = quote(function() FALSE)) # Will be overridden in compiled version to return TRUE + + Rpublic_code <- quote(Rpublic) + if(!is.null(Rpublic)) { + parsedcopy <- \(f) {ans <- substitute(\() BODY, list(BODY=body(f))) |> removeSource(); if(!is.null(formals(f))) ans[[2]] <- formals(f); ans} + Rpublic_code_list <- Rpublic |> lapply(\(x) if(is.function(x)) parsedcopy(x) else x) + Rpublic_code <- do.call("call", c("list", + Rpublic_code_list)) + } + + substitute( + R6::R6Class( + classname = CLASSNAME, + public = c(RPUBLIC, + CMETHODS, + list(isCompiled = function() FALSE)), + private = list( + Cpublic_obj = NULL, + init_Cpublic_obj_code = quote(.Cpub_class$new(...)), + initialize_Cpublic_obj = function(...) { + private$Cpublic_obj <- eval(private$init_Cpublic_obj_code) + } + ), + active = ACTIVE, + portable = FALSE, + inherit = INHERIT, + parent_env = new.env() # We do this so that the parsed code for writePackage is clean, and we modify the result below. + ), + list(CLASSNAME = classname, + RPUBLIC = Rpublic_code, + CMETHODS = Cmethods_code, + ACTIVE = activeBindings_list_code, + INHERIT = if(inherit_provided) inheritQ - else quote(nClassClass)) - )) - ## 2. in the generator - result$.nCompiler <- internals - ## NB: We want to avoid having every object - ## include the generator, to keep saving light. - result + else quote(nCompiler::nClassClass)) + ) +} + +connect_nClass_envs <- function(NCgen, Cpub_gen, env, .NCgenerator=NULL) { + # The NCgen at this point has been created by R6::R6Class + # with "parent_env = new.env()". + # The Cpub_gen has been created by R6::R6Class + # with "parent_env = NULL" + # env is environment to be treated as the parent env + # of the call to nClass. + # + # The reason to do the below steps here in a separate + # function is to be able to call it from either + # nCompile pathway: package = FALSE or package = TRUE + # as well as from uncompiled nClass. This allows + # the environment arrangements to be done in one place + # for all pathways for consistency. In the package=TRUE + # case, it also allows this step to be done in .onLoad + # so that the objects saved with the class (e.g. R6 class + # generators) are a bit simpler than they would otherwise be. + Cpub_gen$parent_env <- (new_env <- NCgen$parent_env) + parent.env(new_env) <- env + new_env$.Cpub_class <- Cpub_gen + if(!is.null(.NCgenerator)) + new_env$.NCgenerator <- .NCgenerator # It would be (for overall network of environments) not to need this reference } # Provenance of names for an nClass: @@ -197,6 +368,62 @@ nClass <- function(classname, # # NC_InternalsClass does not keep track of the name. # -# In nCompile, the classname is used as the cpp_name - +# In nCompile, the classname is used as the cpp_name. # See nCompile comments for more. + +build_Cmethod_code_for_nClass <- function(fun, name) { + if(is.null(fun)) return(NULL) ## convenient for how this is used from mapply + + if(!isNF(fun)) { + if(is.function(fun)) { # This was called from writePackge with a method from a previously built nClass + return(parse(text = deparse(fun), keep.source = FALSE)[[1]]) + } else { + stop("In nClass, Cpublic method ", name, " is not a function or nFunction.") + } + } + if(!NFinternals(fun)$compileInfo$callFromR) { + ans <- substitute( + function(...) { + stop("method ", NAME, " cannot be called directly from R (because compileInfo$callFromR is FALSE).") + }, + list(NAME = name) + ) |> removeSource() + return(ans) + } + + refArgs <- NFinternals(fun)$refArgs + blockRefArgs <- NFinternals(fun)$blockRefArgs + + if(length(refArgs) + length(blockRefArgs) == 0) { + ans <- substitute(function(...) { + private$Cpublic_obj$NAME(...) + }, + list(NAME = name) + ) |> removeSource() + return(ans) + } + + ## Create Cpublic_obj$method(A = A, B = B) call + ## We need the arguments in place instead of using ... + ## so that we can use passByReference if needed. + formals_fun <- formals(fun) + innerCallDollarPart <- substitute(private$Cpublic_obj$NAME, + list(NAME = name)) + innerArgsList <- names(formals_fun) |> lapply(as.name) |> structure(names = names(formals_fun)) + innerCallTemplate <- as.call(c(list(as.name("CALL__")), + innerArgsList)) + innerCall <- do.call("substitute", + list(expr = innerCallTemplate, + env = list(CALL__ = innerCallDollarPart))) + + ans <- substitute( + function() { + INNERCALL + }, + list(INNERCALL = innerCall) + ) |> removeSource() + if(!is.null(formals_fun)) ans[[2]] <- formals_fun + if(!is.null(ans[[3]])) + ans[[3]] <- passByReference(ans[[3]], refArgs, blockRefArgs) + ans +} diff --git a/nCompiler/R/NC_Compile.R b/nCompiler/R/NC_Compile.R index 102d6089..96c19657 100644 --- a/nCompiler/R/NC_Compile.R +++ b/nCompiler/R/NC_Compile.R @@ -117,50 +117,4 @@ nCompile_nClass <- function(NC, 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 - - if(is.null(filebase)) - filebase <- make_cpp_filebase(cppDef$name) - RcppPacket <- cppDefs_2_RcppPacket(cppDef, - filebase = filebase) - NCinternals(NC)$RcppPacket <- RcppPacket - - if(stopAfterRcppPacket) - return(NC) - - compiledFuns <- cpp_nCompiler(RcppPacket, - dir = dir, - cacheDir = cacheDir, - env = env, - write = !NFcompilerMaybeStop('writeCpp', controlFull), - compile = !NFcompilerMaybeStop('compileCpp', controlFull), - ...) - if(NFcompilerMaybeStop('compileCpp', controlFull)) { - return(compiledFuns) - } - - R6interface <- list(build_compiled_nClass(NC, compiledFuns, env = env)) - names(R6interface) <- cppDef$name # formerly filebase - - interface <- match.arg(interface) - - newDLLenv <- make_DLLenv() - # newCobjFun <- setup_DLLenv(newCobjFun, newDLLenv) - finalFun <- setup_nClass_environments(compiledFuns, - newDLLenv, - #nC_names = NC$classname, - R6interfaces = R6interface) - - if(length(finalFun) != 1) - warning("There may be a problem with number of returned functions in nCompile_nClass.") - # newCobjFun <- wrapNCgenerator_for_DLLenv(newCobjFun, newDLLenv) - - if(interface == "generic") - return(finalFun[[1]]) - if(interface == "full") - return(R6interface[[1]]) - ## interface is "both" - return(list(full = R6interface[[1]], generic = finalFun[[1]])) -} + stop("nCompile_nClass deprecated for stopAfterCppDef=FALSE; use nCompile instead.")} diff --git a/nCompiler/R/NC_CompilerClass.R b/nCompiler/R/NC_CompilerClass.R index 337dc7e3..0cbf30ac 100644 --- a/nCompiler/R/NC_CompilerClass.R +++ b/nCompiler/R/NC_CompilerClass.R @@ -50,7 +50,7 @@ NC_CompilerClass <- R6::R6Class( methodNames <- myNCinternals$methodNames for(m in methodNames) { - thisMethod <- NCgenerator$public_methods[[m]] + thisMethod <- NC_get_Cpub_class(NCgenerator)$public_methods[[m]] thisName <- NULL if(isConstructor(thisMethod)) { #NFinternals(thisMethod)$cpp_code_name <- self$name diff --git a/nCompiler/R/NC_FullCompiledInterface.R b/nCompiler/R/NC_FullCompiledInterface.R index 7dda331b..38f1a481 100644 --- a/nCompiler/R/NC_FullCompiledInterface.R +++ b/nCompiler/R/NC_FullCompiledInterface.R @@ -24,6 +24,7 @@ # ) # # then build_nClassInterface would be like the following: +# To-Do: This example is out of date and should be updated # # FI <- R6::R6Class( # private = list( @@ -50,168 +51,186 @@ # } # ) # ) -# +# #' @export -build_compiled_nClass <- function(NCgenerator, - newCobjFun, - env = NCgenerator$parent_env, - quoted = FALSE) { - # One might wonder if we can have an R6 class created here to - # interface with a compiled C++ class be established with - # a class hierarchy that mirrors that (if any) of the C++ class. - # The answer is no, because only one class in the hierarchy in C++ - # can inherit from genericInterfaceC, so there can be no - # hierarchies of interfaces. - # Some of what is done here has to imitate R6, but it is fairly natural - # so seems reasonable. All inherited methods are pulled down to - # the current class except for those overloaded in the current class. - # All inherited member variables are pulled down, with no - # possibility of the same member variable being distinct at different - # levels of a class hierarchy. - NCI <- NCinternals(NCgenerator) - # Make C interface methods - CmethodNames <- NCI$methodNames - recurse_make_Cmethods <- function(NCgenerator, CmethodNames, - derivedNames = character()) { - interfaceMethods <- mapply(buildMethod_for_compiled_nClass, - NCgenerator$public_methods[CmethodNames], - CmethodNames) - inherit_obj <- NCgenerator$get_inherit() - if(isNCgenerator(inherit_obj)) { - derivedNames <- c(derivedNames, CmethodNames) - baseNCgen <- inherit_obj - baseCmethodNames <- NCinternals(baseNCgen)$methodNames - baseCmethodNames <- setdiff(baseCmethodNames, derivedNames) - # Note: baseCmethodNames could be empty but we still need to - # recurse in case there are more classes in the hierarchy. - baseInterfaceMethods <- recurse_make_Cmethods(baseNCgen, - baseCmethodNames, - derivedNames) - interfaceMethods <- c(interfaceMethods, baseInterfaceMethods) +build_compiled_nClasses <- function(units, + unitTypes, + interfaces, + exportNames, + returnNames, + newCobjFuns = NULL, + package = FALSE, + packageNames = list()) { + numUnits <- length(units) + ans <- vector("list", numUnits) + inherit_indices <- vector("list", numUnits) + for(i in seq_along(units)) { + if(unitTypes[i]=="nCgen") { + if(isTRUE(interfaces[[i]]%in%c("full", "generic"))) { +# Find inheritance + NCgenerator <- units[[i]] + inherit_NCgen <- NCgenerator$get_inherit() + match <- rep(FALSE, numUnits) + inherit_returnName <- NULL + inherit_indices[[i]] <- integer() + if(identical(inherit_NCgen, nCompiler::nClassClass)) + inherit_NCgen <- NULL + else { + for(j in seq_along(units)) { + if(identical(units[[j]], inherit_NCgen)) match[j] <- TRUE + } + if(sum(match)>1) + stop("When building compiled interface for ", exportNames[i], ", there were multiple matches for inherited nClass generator.") + inherit_indices[[i]] <- which(match) + inherit_returnName <- if(!package) "NOT_USED" + else packageNames[[inherit_indices[[i]] ]]["compiled"] + } + + ans[[i]] <- try(build_compiled_nClass(NCgenerator = units[[i]], + newCobjFun = if(is.null(newCobjFuns)) NULL else newCobjFuns[[i]], + inherit_NCgen = inherit_NCgen, + inherit_returnName = inherit_returnName, + package = package)) + if(inherits(ans[[i]], "try-error")) { + warning(paste0("There was a problem building a full nClass interface for ", exportNames[i], ".")) + ans[[i]] <- NULL + } + } } - interfaceMethods } - CinterfaceMethods <- recurse_make_Cmethods(NCgenerator, CmethodNames) - # Make R interface methods - RmethodNames <- setdiff(names(NCgenerator$public_methods), - c(CmethodNames, 'clone')) - recurse_make_Rmethods <- function(NCgenerator, RmethodNames, - derivedNames = character()) { - interfaceMethods <- NCgenerator$public_methods[RmethodNames] - inherit_obj <- NCgenerator$get_inherit() - if(isNCgenerator(inherit_obj)) { - derivedNames <- c(derivedNames, RmethodNames) - baseNCgen <- inherit_obj - baseCmethodNames <- NCinternals(baseNCgen)$methodNames - baseRmethodNames <- setdiff(names(baseNCgen$public_methods), - c(baseCmethodNames, 'clone')) - baseRmethodNames <- setdiff(baseRmethodNames, derivedNames) - baseInterfaceMethods <- recurse_make_Rmethods(baseNCgen, - baseRmethodNames, - derivedNames) - interfaceMethods <- c(interfaceMethods, baseInterfaceMethods) - } - interfaceMethods + + if(package) return(ans) + + for(i in seq_along(units)) { + if(length(inherit_indices[[i]])==0) next + Cpub_class <- ans[[i]]$parent_env$.Cpub_class + Cpub_class$parent_env$.Cpub_base_class <- ans[[inherit_indices[[i]] ]]$parent_env$.Cpub_class } - RinterfaceMethods <- recurse_make_Rmethods(NCgenerator, RmethodNames) - - # CinterfaceMethods <- mapply(buildMethod_for_compiled_nClass, -# NCgenerator$public_methods[CmethodNames], -# CmethodNames) - ## enableDerivs <- unlist(NCinternals(NCgenerator)$enableDerivs) - ## if (length(enableDerivs > 0)) { - ## ## add *_derivs_ method for methods in enableDerivs - ## derivsMethods <- mapply(buildMethod_derivs_for_compiled_nClass, - ## NCgenerator$public_methods[enableDerivs], - ## enableDerivs) - ## names(derivsMethods) <- paste0(enableDerivs, '_derivs_') - ## CinterfaceMethods <- c(CinterfaceMethods, derivsMethods) - ## } - ## CfieldNames <- NCI$fieldNames - ## RfieldNames <- setdiff(names(NCgenerator$public_fields), - ## CfieldNames) - ## activeBindingResults <- buildActiveBinding_for_compiled_nClass(NCI) - ## activeBindings <- activeBindingResults$activeBindings - ## internal_fields <- activeBindingResults$newFields - ## activeBindings <- lapply(CfieldNames, - ## buildActiveBinding_for_compiled_nClass, - ## NCI$symbolTable) - #names(activeBindings) = CfieldNames - - recurse_make_activeBindings <- function(NCgenerator, CfieldNames, - derivedNames = character()) { - NCint <- NCinternals(NCgenerator) - activeBindingResults <- - buildActiveBinding_for_compiled_nClass(NCint, CfieldNames) - inherit_obj <- NCgenerator$get_inherit() - if(isNCgenerator(inherit_obj)) { - derivedNames <- c(derivedNames, CfieldNames) - baseNCgen <- inherit_obj - baseCfieldNames <- NCinternals(baseNCgen)$fieldNames - baseCfieldNames <- setdiff(baseCfieldNames, derivedNames) - baseActiveBindingResults <- - recurse_make_activeBindings(baseNCgen, - baseCfieldNames, - derivedNames) - activeBindingResults$activeBindings <- - c(activeBindingResults$activeBindings, baseActiveBindingResults$activeBindings) - activeBindingResults$internal_fields <- - c(activeBindingResults$internal_fields, baseActiveBindingResults$internal_fields) + ans +} + +#' @export +build_compiled_nClass <- function(NCgenerator, + newCobjFun, + inherit_NCgen = NULL, + inherit_returnName = NULL, + package = FALSE) { + + + compiled_Cpub_class_code <- make_compiled_Cpub_class_code( + NCgenerator = NCgenerator, + inheritName = inherit_returnName, + package = package, + newCobjFun = newCobjFun + ) + + CnCgenerator_code <- make_compiled_nClass_code(NCgenerator) + + if(package) return(list(CncGen_code = CnCgenerator_code, + Cpub_comp_code = compiled_Cpub_class_code)) + + CnCgenerator <- eval(CnCgenerator_code) + Cpub_comp_generator <- eval(compiled_Cpub_class_code) + env <- NCgenerator$parent_env + connect_nClass_envs(CnCgenerator, Cpub_comp_generator, env, .NCgenerator = NCgenerator) + + # Note there is a circular relationship with + # new_env$.Cpub_class$parent_env == new_env + # I don't think it's a problem + + if(!missing(newCobjFun) && !is.null(newCobjFun)) { + # Similar to .internals in nClass, + # we put newCobjFun in two places: + # 1. In the generator + # 2. In the environment that every object will have as its parent.env + if (is.list(newCobjFun)) { + Cpub_comp_generator$.newCobjFun <- newCobjFun[[1]] + CnCgenerator$parent_env$.newCobjFun <- newCobjFun[[1]] + } else { + Cpub_comp_generator$.newCobjFun <- newCobjFun + CnCgenerator$parent_env$.newCobjFun <- newCobjFun } - activeBindingResults + } else { + Cpub_comp_generator$.newCobjFun <- NULL + CnCgenerator$parent_env$.newCobjFun <- NULL } - CfieldNames <- NCI$fieldNames - activeBindingResults <- recurse_make_activeBindings(NCgenerator, CfieldNames) - activeBindings <- activeBindingResults$activeBindings - internal_fields <- activeBindingResults$newFields + CnCgenerator +} - recurse_make_Rfields <- function(NCgenerator, RfieldNames, - derivedNames = character()) { - interfaceFields <- NCgenerator$public_fields[RfieldNames] - inherit_obj <- NCgenerator$get_inherit() - if(isNCgenerator(inherit_obj)) { - derivedNames <- c(derivedNames, RfieldNames) - baseNCgen <- inherit_obj - baseCfieldNames <- NCinternals(baseNCgen)$fieldNames - baseRfieldNames <- setdiff(names(baseNCgen$public_fields), - c(baseCfieldNames, 'clone')) - baseRfieldNames <- setdiff(baseRfieldNames, derivedNames) - baseInterfaceFields <- recurse_make_Rfields(baseNCgen, - baseRfieldNames, - derivedNames) - interfaceFields <- c(interfaceFields, baseInterfaceFields) +# buildActiveBinding_for_compiled_nClass <- function(NCI, fieldNames) { + #fieldNames <- NCI$fieldNames +# symTab <- NCI$symbolTable +# activeBindings <- list() +# newFields <- list() +# for(name in fieldNames) { +# ans <- function(value) {} +# sym <- symTab$getSymbol(name) +# if(is.null(sym)) { +# warning(paste0("Could not find a way to build active binding for field ", name, ".")) +# return(ans) +# } +# body(ans) <- substitute( +# { +# if(missing(value)) +# private$DLLenv$get_value(`:::`("nCompiler", "getExtptr")(private$CppObj), NAME) +# else +# private$DLLenv$set_value(`:::`("nCompiler", "getExtptr")(private$CppObj), NAME, value) +# }, +# list(NAME = name) +# ) +# activeBindings[[name]] <- ans +# } +# list(activeBindings = activeBindings, +# newFields = newFields) +# } + +make_compiled_nClass_code <- function(NCgenerator) { + classname <- NCinternals(NCgenerator)$compileInfo$classname + substitute( + R6::R6Class( + classname = CLASSNAME, + public =list(isCompiled = \() TRUE, + initializeCpp = \(CppObj) private$Cpublic_obj$initializeCpp(CppObj) + ), + portable = FALSE, + inherit = INHERIT, + parent_env = new.env() + ), + env = list( + CLASSNAME = classname, + INHERIT = quote(.NCgenerator) + ) + ) +} + +make_compiled_Cpub_class_code <- function(NCgenerator, + inheritName = NULL, + package = FALSE, + newCobjFun = NULL + ) { + classname <- NCgenerator$classname + Cpub_classname <- paste0(classname, "_Cpub_compiled") + + NCI <- NCinternals(NCgenerator) + # Make C interface methods + + CfieldNames <- NCI$fieldNames + symTab <- NCI$symbolTable + for(name in CfieldNames) { + sym <- symTab$getSymbol(name) + if(is.null(sym)) { + warning(paste0("Could not find a way to build active binding for field ", name, ".")) + CfieldNames <- setdiff(CfieldNames, name) } - interfaceFields } - RfieldNames <- setdiff(names(NCgenerator$public_fields), - CfieldNames) - RinterfaceFields <- recurse_make_Rfields(NCgenerator, RfieldNames) - - - classname <- paste0(NCgenerator$classname, '_compiled') - - if("isCompiled" %in% names(RinterfaceMethods)) - RinterfaceMethods[["isCompiled"]] <- function() TRUE - - ## How the initialize scheme works: - ## If a user has not provided an Rpublic method called initialize, - ## then we insert a default initialize, which takes CppObj and calls initializeCpp(CppObj), - ## which builds a new Cpp object in the usual case that CppObj is missing or - ## inserts it as the private$CppObj if provided. - ## If a user has provided an Rpublic method called initialize, - ## then if compileInfo$omit_automatic_Cpp_construction is not TRUE, - ## we modify the body of that initialize to call initializeCpp() at the start. - ##. In that case, there is no option to pass in a CppObj; the C++ object is always constructed. - ## If a user wants to write an initialize AND allow the use of an existing CppObj, - ## they must set compileInfo=list(omit_automatic_Cpp_construction=TRUE) - ##. AND write the call to initializeCpp(CppObj) themselves, which should normally check - ## if the object is compiled: `if(isCompiled()) initializeCpp(CppObj)`. - - if("initializeCpp" %in% names(RinterfaceMethods)) - stop("Rpublic method name 'initializeCpp' is reserved for nCompiler use.") - - RinterfaceMethods[["initializeCpp"]] <- substitute( + CmethodNames <- NCI$methodNames + Cmethods <- NC_get_Cpub_class(NCgenerator)$public_methods[CmethodNames] + omit_automatic_Cpp_construction <- isTRUE(NCI$compileInfo$omit_automatic_Cpp_construction) + + Rmethods_code_list <- list() + + Rmethods_code_list[["initializeCpp"]] <- substitute( function(CppObj) { if(missing(CppObj)) { newCobjFun <- NEWCOBJFUN @@ -223,140 +242,123 @@ build_compiled_nClass <- function(NCgenerator, private$DLLenv <- `:::`("nCompiler", "get_DLLenv")(CppObj) # workaround static code scanning for nCompiler:::get_DLLenv(CppObj) }, list( - NEWCOBJFUN = if(quoted) as.name(newCobjFun) + NEWCOBJFUN = if(package) as.name(newCobjFun) else quote(parent.env(parent.env(self))$.newCobjFun) ) ) - omit_automatic_Cpp_construction <- isTRUE(NCI$compileInfo$omit_automatic_Cpp_construction) - if("initialize" %in% names(RinterfaceMethods)) { + + Rmethods_code_list[["isCompiled"]] <- quote(\() TRUE) + + initialize_fun <- NC_get_Cpub_class(NCgenerator)$public_methods[["initialize"]] + if(is.null(initialize_fun)) { if(!omit_automatic_Cpp_construction) { - body(RinterfaceMethods[["initialize"]]) <- - substitute({initializeCpp(); OLDBODY}, list(OLDBODY = body(RinterfaceMethods[["initialize"]]))) + # The ... argument to initialize is important because it will be called + # with ... from the outer R6generator, which might have other arguments embedded in the ... + Rmethods_code_list[["initialize"]] <- quote( + function(CppObj, ...) {self$initializeCpp(CppObj)} + ) } } else { - if(!omit_automatic_Cpp_construction) - RinterfaceMethods[["initialize"]] <- function(CppObj) {initializeCpp(CppObj)} + parsedcopy <- \(f) {ans <- substitute(\() BODY, list(BODY=body(f))) |> removeSource(); if(!is.null(formals(f))) ans[[2]] <- formals(f); ans} + new_init_code <- substitute( + {if(is.null(private$CppObj)) self$initializeCpp() # when this is inherited, the derived class should have populated private$CppObj + OLDBODY}, + list(OLDBODY = body(initialize_fun)) + ) |> removeSource() + if(!is.null(formals(initialize_fun))) new_init_code[[2]] <- formals(initialize_fun) + Rmethods_code_list[["initialize"]] <- new_init_code } - ans <- substitute( - expr = R6::R6Class( + + Rmethods_code <- do.call("call", c("list", + Rmethods_code_list)) + + activeBindings_code_list <- list() + for(name in CfieldNames) { + ABcode <- substitute( + \(value) { + if(missing(value)) + private$DLLenv$get_value(`:::`("nCompiler", "getExtptr")(private$CppObj), NAME) + else + private$DLLenv$set_value(`:::`("nCompiler", "getExtptr")(private$CppObj), NAME, value) + }, + list(NAME = name) + ) |> removeSource() + activeBindings_code_list[[name]] <- ABcode + } + activeBindings_code <- do.call("call", c("list", + activeBindings_code_list)) + + + CinterfaceMethods_code_list <- mapply(make_method_code_for_compiled_nClass, + Cmethods, + CmethodNames) + CinterfaceMethods_code <- do.call("call", c("list", + CinterfaceMethods_code_list)) + + Cpub_inherit_arg <- if(package) { + if(is.null(inheritName)) quote(nCompiler::CpubClass) + else substitute(IRN$parent_env$.Cpub_class, list(IRN=as.name(inheritName)))#as.name(paste0(inheritName, "_compiled")))) + } else { + if(is.null(inheritName)) quote(nCompiler::CpubClass) + else quote(.Cpub_base_class) + } + + Cpub_comp_code <- substitute( + R6::R6Class( classname = CLASSNAME, private = list( CppObj = NULL, DLLenv = NULL ), public = c( - RPUBLIC, - RFIELDS, + RMETHODS, CINTERFACE), active = ACTIVEBINDINGS, portable = FALSE, - inherit = `:::`("nCompiler", "CnClassClass"), # work around static code scanning + inherit = INHERIT, # Default. May be updated at next pass, parent_env = NULL ## when quoted = TRUE, env argument is not used ), env = list( - CLASSNAME = classname, - RPUBLIC = parse(text = deparse( - RinterfaceMethods #NCgenerator$public_methods[RmethodNames] - ), keep.source = FALSE)[[1]], - RFIELDS = parse(text = deparse( -# c(NCgenerator$public_fields[RfieldNames], internal_fields) - c(RinterfaceFields, internal_fields) - ), keep.source = FALSE)[[1]], - CINTERFACE = parse(text = deparse( - CinterfaceMethods - ), keep.source = FALSE)[[1]], - ACTIVEBINDINGS = parse(text = deparse(activeBindings))[[1]] + CLASSNAME = Cpub_classname, + RMETHODS = Rmethods_code, + CINTERFACE = CinterfaceMethods_code, + ACTIVEBINDINGS = activeBindings_code, + INHERIT = Cpub_inherit_arg ) ) - - if (quoted) return(ans) - - ans <- eval(ans) - ## ans$public_methods$initialize <- function(CppObj) { - ## if(missing(CppObj)) { - ## newCobjFun <- parent.env(parent.env(self))$.newCobjFun - ## if(is.null(newCobjFun)) - ## stop("Cannot create a nClass full interface object without a newCobjFun or a CppObj argument.") - ## CppObj <- newCobjFun() - ## } - ## private$CppObj <- CppObj - ## private$DLLenv <- nCompiler:::get_DLLenv(CppObj) - ## } - - new_env <- new.env(parent = env) - ans$parent_env <- new_env - - if(!missing(newCobjFun)) { - # Similar to .internals in nClass, - # we put newCobjFun in two places: - # 1. In the generator - # 2. In the environment that every object will have as its parent.env - if (is.list(newCobjFun)) { - ans$.newCobjFun <- newCobjFun[[1]] - new_env$.newCobjFun <- newCobjFun[[1]] - } else { - ans$.newCobjFun <- newCobjFun - new_env$.newCobjFun <- newCobjFun - } - } else { - ans$.newCobjFun <- NULL - new_env$.newCobjFun <- NULL - } - ans } -buildActiveBinding_for_compiled_nClass <- function(NCI, fieldNames) { - #fieldNames <- NCI$fieldNames - symTab <- NCI$symbolTable - activeBindings <- list() - newFields <- list() - for(name in fieldNames) { - ans <- function(value) {} - sym <- symTab$getSymbol(name) - if(is.null(sym)) { - warning(paste0("Could not find a way to build active binding for field ", name, ".")) - return(ans) - } - - ## if(inherits(sym, "symbolTBD")) { # This is a putative nClass type - ## internal_name <- paste0(name, "_internal") - ## body(ans) <- substitute( - ## { - ## if(missing(value)) - ## private$DLLenv$get_value(nCompiler:::getExtptr(private$CppObj), NAME) - ## else { - ## if(!isCNC(value)) { - ## if(nCompiler:::is.loadedObjectEnv(value)) { - ## value <- nCompiler:::to_full_interface(value) - ## } else if(isNC(value)) - ## stop("Assigning an uncompiled nClass object to a Cpublic field, where a compiled object is needed.") - ## else - ## stop("Assigning an invalid object to a Cpublic nClass field") - ## } - ## self$INTERNAL_NAME <- value - ## private$DLLenv$set_value(nCompiler:::getExtptr(private$CppObj), NAME, value$private$CppObj) - ## } - ## }, - ## list(NAME = name, INTERNAL_NAME = as.name(internal_name)) - ## ) - ## activeBindings[[name]] <- ans - ## newFields[internal_name] <- list(NULL) - ## next - ## } - - body(ans) <- substitute( - { - if(missing(value)) - private$DLLenv$get_value(`:::`("nCompiler", "getExtptr")(private$CppObj), NAME) - else - private$DLLenv$set_value(`:::`("nCompiler", "getExtptr")(private$CppObj), NAME, value) - }, - list(NAME = name) +make_method_code_for_compiled_nClass <- function(fun, name) { + if(is.null(fun)) return(NULL) ## convenient for how this is used from mapply + if(!NFinternals(fun)$compileInfo$callFromR) { + ans <- substitute( + function(...) { + stop("method ", NAME, " cannot be called directly from R.") + }, + list(NAME = name) ) - activeBindings[[name]] <- ans + return(ans) } - list(activeBindings = activeBindings, - newFields = newFields) + argNames <- names(formals(fun)) + + parsedcopy <- \(f) {ans <- substitute(\() BODY, list(BODY=body(f))) |> removeSource(); if(!is.null(formals(f))) ans[[2]] <- formals(f); ans} + listcode <- quote(list()) + for(i in seq_along(argNames)) + listcode[[i+1]] <- as.name(argNames[i]) + body_ans <- substitute( + private$DLLenv$call_method(`:::`("nCompiler", "getExtptr")(private$CppObj), NAME, LISTCODE), + list(NAME = name, + LISTCODE = listcode) + ) + refArgs <- NFinternals(fun)$refArgs + blockRefArgs <- NFinternals(fun)$blockRefArgs + body_ans <- passByReferenceIntoC(body_ans, refArgs, blockRefArgs) + ans <- substitute( + \() BODY, + list(BODY = body_ans) + ) |> removeSource() + if(!is.null(formals(fun))) ans[[2]] <- formals(fun) + ans } buildMethod_for_compiled_nClass <- function(fun, name) { @@ -376,7 +378,7 @@ buildMethod_for_compiled_nClass <- function(fun, name) { environment(ans) <- new.env() ## The internet says that R6 methods are assigned their environments ## during a call to methodGenerator$new(). We put a new.env() - ## here anyway as insurance against the possibility of quirky + ## here anyway as insurance against the possibility of quirky ## environment problems. ## ## We used to make the third argument like list(arg1, arg2, arg3) @@ -408,13 +410,10 @@ buildMethod_for_compiled_nClass <- function(fun, name) { refArgs <- NFinternals(fun)$refArgs blockRefArgs <- NFinternals(fun)$blockRefArgs body(ans) <- passByReferenceIntoC(body_ans, refArgs, blockRefArgs) - ## body(ans) <- substitute( - ## private$DLLenv$call_method(nCompiler:::getExtptr(private$CppObj), NAME, environment()), - ## list(NAME = name) - ## ) ans } +# This builds functions that are placed in the DLLenv to call C functions exported from that DLL build_generic_fns_for_compiled_nClass <- function(NCgenerator) { NCI <- NCinternals(NCgenerator) # Make C interface methods @@ -422,7 +421,7 @@ build_generic_fns_for_compiled_nClass <- function(NCgenerator) { recurse_make_Cmethods <- function(NCgenerator, CmethodNames, derivedNames = character()) { interfaceFns <- mapply(build_generic_fn_for_compiled_nClass_method, - NCgenerator$public_methods[CmethodNames], + NC_get_Cpub_class(NCgenerator)$public_methods[CmethodNames], CmethodNames) inherit_obj <- NCgenerator$get_inherit() if(isNCgenerator(inherit_obj)) { @@ -472,29 +471,6 @@ build_generic_fn_for_compiled_nClass_method <- function(fun, name) { refArgs <- NFinternals(fun)$refArgs blockRefArgs <- NFinternals(fun)$blockRefArgs body(ans) <- passByReferenceIntoC(body_ans, refArgs, blockRefArgs) - ## body(ans) <- substitute( - ## private$DLLenv$call_method(nCompiler:::getExtptr(private$CppObj), NAME, environment()), - ## list(NAME = name) - ## ) ans } - -## buildMethod_derivs_for_compiled_nClass <- function(fun, name) { -## if(is.null(fun)) return(NULL) ## convenient for how this is used from mapply -## ans <- fun -## ## add the 'order' and 'wrt' args to the function's formals -## formals(ans) <- c(formals(ans), list(order = c(0, 1, 2), wrt = NULL)) -## argNames <- names(formals(ans)) -## environment(ans) <- new.env() -## listcode <- quote(list()) -## for(i in seq_along(argNames)) -## listcode[[i+1]] <- as.name(argNames[i]) -## body(ans) <- substitute({ -## obj_env <- private$DLLenv$call_method( -## nCompiler:::getExtptr(private$CppObj), NAME, LISTCODE -## ) -## C_nC_derivClass$new(obj_env) -## }, list(NAME = paste0(name, '_derivs_'), LISTCODE = listcode)) -## ans -## } diff --git a/nCompiler/R/NC_InternalsClass.R b/nCompiler/R/NC_InternalsClass.R index f9001904..748a2084 100644 --- a/nCompiler/R/NC_InternalsClass.R +++ b/nCompiler/R/NC_InternalsClass.R @@ -32,9 +32,12 @@ NC_InternalsClass <- R6::R6Class( virtualMethodNames_self = character(), # will be used when checking inherited method validity, only for locally implemented methods virtualMethodNames = character(), check_inherit_done = FALSE, + #Cpub_class_code = NULL, + #main_class_code = NULL, + RpublicNames = character(), initialize = function(classname, Cpublic, - isOnlyC = FALSE, + RpublicNames = character(), enableDerivs = NULL, enableSaving = get_nOption("enableSaving"), inheritQ = NULL, @@ -46,7 +49,8 @@ NC_InternalsClass <- R6::R6Class( self$compileInfo <- compileInfo self$classname <- classname self$cpp_classname <- Rname2CppName(classname) - self$isOnlyC = isOnlyC + self$RpublicNames <- RpublicNames + self$isOnlyC = length(RpublicNames) == 0 numEntries <- length(Cpublic) if(numEntries) { isMethod <- rep(FALSE, numEntries) @@ -64,14 +68,22 @@ NC_InternalsClass <- R6::R6Class( call. = FALSE) } } + has_Cpublic_init <- "initialize" %in% names(Cpublic) self$virtualMethodNames <- names(Cpublic)[isVirtual] self$symbolTable <- argTypeList2symbolTable(Cpublic[!isMethod], evalEnv = env) self$cppSymbolNames <- Rname2CppName(symbolTable$getSymbolNames()) self$methodNames <- names(Cpublic)[isMethod] + if(has_Cpublic_init) { + if("initialize" %in% self$methodNames) { + stop("The name 'initialize' in Cpublic can only be used for an R function to provide any special initialization handling (usually not needed).", + call. = FALSE) + } + } self$allMethodNames_self <- methodNames self$virtualMethodNames_self <- names(Cpublic)[isVirtual] self$allMethodNames <- methodNames self$fieldNames <- names(Cpublic)[!isMethod] + if(has_Cpublic_init) self$fieldNames <- setdiff(self$fieldNames, "initialize") self$allFieldNames_self <- fieldNames self$allFieldNames <- fieldNames self$orig_methodName_to_cpp_code_name <- structure(vector("list", length=length(methodNames)), @@ -92,6 +104,19 @@ NC_InternalsClass <- R6::R6Class( } self$enableDerivs <- enableDerivs } + classname_provided <- !identical(names(classname), "generated") + packageNames <- c(uncompiled = "", compiled = "") + if(!is.null(self$compileInfo$packageNames)) packageNames <- self$compileInfo$packageNames + if(is.list(packageNames)) packageNames <- unlist(packageNames) + if(is.null(names(packageNames))) + names(packageNames) <- c("uncompiled", "compiled")[seq_along(packageNames)] + if(is.na(packageNames["compiled"])) packageNames["compiled"] <- "" + if(is.na(packageNames["uncompiled"])) packageNames["uncompiled"] <- "" + packageNames <- packageNames[c("uncompiled", "compiled")] + if(classname_provided && packageNames["uncompiled"] == "") + packageNames["uncompiled"] <- classname + self$compileInfo$packageNames <- packageNames + self$predefined <- predefined self$enableSaving <- enableSaving }, diff --git a/nCompiler/R/NC_LoadedObjectEnv.R b/nCompiler/R/NC_LoadedObjectEnv.R index c11ae62b..cdad8a07 100644 --- a/nCompiler/R/NC_LoadedObjectEnv.R +++ b/nCompiler/R/NC_LoadedObjectEnv.R @@ -27,6 +27,8 @@ new.loadedObjectEnv <- function(extptr = NULL, parentEnv = NULL) { #' @export to_full_interface <- function(LOE) { # parentEnv <- parent.env(LOE) + if(!is.loadedObjectEnv(LOE)) + stop("LOE should be a loadedObjectEnv") CnCenv <- get_CnCenv(LOE) if(exists('.R6interface', CnCenv)) { fullAns <- CnCenv$.R6interface$new(LOE) @@ -35,6 +37,13 @@ to_full_interface <- function(LOE) { LOE # default to non-full } +#'@export +to_generic_interface <- function(obj) { + if(!isCNC(obj)) + stop("obj should be a compiled nClass object") + obj$private$Cpublic_obj$private$CppObj +} + #' @export new.loadedObjectEnv_full <- function(extptr = NULL, parentEnv = NULL) { # This will be true if called from an nFunction (or nClass method) returning an object @@ -112,7 +121,7 @@ get_CnCenv <- function(obj) { setup_nClass_environments <- function(compiledFuns, newDLLenv, exportNames = character(), - R6interfaces, + NCgenerators, methodFns, interfaceTypes, returnList = FALSE) { @@ -122,7 +131,7 @@ setup_nClass_environments <- function(compiledFuns, compiledFuns <- setup_CnClass_env(compiledFuns, newDLLenv, exportNames[i], - R6interfaces[[i]], + NCgenerators[[i]], methodFns[[i]], interfaceTypes[i]) } @@ -135,7 +144,7 @@ setup_nClass_environments <- function(compiledFuns, setup_nClass_environments_from_package <- function(nClass_exportNames, interfaceTypes, createFromR, - R6interfaces, + CnCgenerators, methodFns, pkgName) { # nClass_names will really be exportNames @@ -170,11 +179,11 @@ setup_nClass_environments_from_package <- function(nClass_exportNames, } for(fn in reqdFuns) get_fn(fn, TRUE) for(fn in optFuns) get_fn(fn, FALSE) - # TO-DO: Case when R6interfaces are set up + # TO-DO: Case when CnCgenerators are set up setup_nClass_environments(compiledFuns, DLLenv, exportNames = nClass_exportNames, - R6interfaces, + CnCgenerators, methodFns, interfaceTypes, returnList = TRUE) diff --git a/nCompiler/R/NC_SimpleInterface.R b/nCompiler/R/NC_SimpleInterface.R index 39ee93f6..06430e70 100644 --- a/nCompiler/R/NC_SimpleInterface.R +++ b/nCompiler/R/NC_SimpleInterface.R @@ -4,8 +4,11 @@ #' @export method <- function(obj, name) { - if(inherits(obj, "CnClass")) - obj <- obj$private$CppObj + if(inherits(obj, "nClass")) + if(obj$isCompiled()) + obj <- obj$private$Cpublic_obj$private$CppObj # obj$private$CppObj + else + stop("method() can only be used on compiled nClass objects.") CnCenv <- get_CnCenv(obj) ans <- CnCenv[[name]] environment(ans) <- new.env(parent = environment(ans)) @@ -31,27 +34,25 @@ method <- function(obj, name) { #' @export value <- function(obj, name) { - if(inherits(obj, "CnClass")) - obj <- obj$private$CppObj + if(inherits(obj, "nClass")) + if(obj$isCompiled()) + obj <- obj$private$Cpublic_obj$private$CppObj # obj$private$CppObj + else + stop("value() can only be used on compiled nClass objects.") DLLenv <- get_DLLenv(obj) extptr <- getExtptr(obj) DLLenv$get_value(extptr, name) - - ## if(is.null(getExtptr(obj))) - ## stop("obj does not point to a C++ object.") - ## nCompiler:::get_value(getExtptr(obj), name) } #' @export `value<-` <- function(obj, name = NULL, value) { - if(inherits(obj, "CnClass")) - obj <- obj$private$CppObj + if(inherits(obj, "nClass")) + if(obj$isCompiled()) + obj <- obj$private$Cpublic_obj$private$CppObj # obj$private$CppObj + else + stop("value<-() can only be used on compiled nClass objects.") DLLenv <- get_DLLenv(obj) extptr <- getExtptr(obj) DLLenv$set_value(extptr, name, value) obj - ## if(is.null(getExtptr(obj))) - ## stop("obj does not point to a C++ object.") - ## nCompiler:::set_value(getExtptr(obj), name, value) - ## obj } diff --git a/nCompiler/R/NC_Utils.R b/nCompiler/R/NC_Utils.R index cd45d975..3e073740 100644 --- a/nCompiler/R/NC_Utils.R +++ b/nCompiler/R/NC_Utils.R @@ -10,8 +10,22 @@ isNC <- function(x) inherits(x, 'nClass') #' @export -isCNC <- function(x) inherits(x, 'CnClass') +isCNC <- function(x) inherits(x, 'nClass') && isTRUE(x$isCompiled()) +#' @export +compileInfo <- function(NC) { + if(!isNCgenerator(NC)) + stop("NC must be a nClass generator (returned from nClass).") + NCinternals(NC)$compileInfo +} + +#' @export +`compileInfo<-` <- function(NC, value) { + if(!isNCgenerator(NC)) + stop("NC must be a nClass generator (returned from nClass).") + NCinternals(NC)$compileInfo <- value + NC +} #' Determine if an object is a nClass generator #' @@ -40,7 +54,7 @@ isNCgenerator <- function(x) { #' @export isCompiledNCgenerator <- function(x) { if(inherits(x, "R6ClassGenerator")) - exists(".newCobjFun", x) + exists(".newCobjFun", x$parent_env) else FALSE } @@ -92,7 +106,7 @@ NC_find_method <- function(NCgenerator, name, inherits=TRUE) { method <- NULL while(!done) { if(name %in% NCinternals(current_NCgen)$methodNames) { - method <- current_NCgen$public_methods[[name]] + method <- NC_get_Cpub_class(current_NCgen)$public_methods[[name]] done <- TRUE } else { if(inherits) { @@ -156,7 +170,7 @@ NC_check_inheritance <- function(NCgenerator) { next } # At this point the current level has the method and it is inherited - localMethod <- NCgenerator$public_methods[[mN]] + localMethod <- NC_get_Cpub_class(NCgenerator)$public_methods[[mN]] inheritMethod <- NC_find_method(inheritNCgenerator, mN) if(is.null(inheritMethod)) stop("Problem finding inherited method ", mN, " in NC_check_inheritance.", call. = FALSE) @@ -193,4 +207,10 @@ NC_check_inheritance <- function(NCgenerator) { } NCint$check_inherit_done <- TRUE c(new_virtualMethodNames, inherit_virtualMethodNames) -} \ No newline at end of file +} + +NC_get_Cpub_class <- function(NCgenerator) { + if(!isNCgenerator(NCgenerator)) + stop("Input to NC_get_Cpub_class must be a nClass generator.") + NCgenerator$parent_env$.Cpub_class +} diff --git a/nCompiler/R/NF_PassByReference.R b/nCompiler/R/NF_PassByReference.R index 56011498..5b1cec0b 100644 --- a/nCompiler/R/NF_PassByReference.R +++ b/nCompiler/R/NF_PassByReference.R @@ -4,17 +4,36 @@ passByReference <- function(fun, refArgs = character(), blockRefArgs = character()) { + # The format from an NFinternals object is a named list of TRUE/FALSE values, + # so convert that to a character vector of names for the TRUE ones. + if(is.list(refArgs)) + refArgs <- names(refArgs)[ unlist(lapply(refArgs, isTRUE)) ] + + if(is.list(blockRefArgs)) + blockRefArgs <- names(blockRefArgs)[ unlist(lapply(blockRefArgs, isTRUE)) ] + + if(is.null(refArgs)) refArgs <- character() + if(is.null(blockRefArgs)) blockRefArgs <- character() + + if((length(refArgs)==0) & length(blockRefArgs)==0) + return(fun) + + # fun can be a function or the body of a function. passedAsFunction <- is.function(fun) code <- if(passedAsFunction) body(fun) else fun + # Helper to create a substitution list from argument names + # e.g. ("x", "_suffix") -> list(x = as.name("x_suffix")) args_2_subList <- function(args, suffix) args |> lapply(function(x) as.name(paste0(x, suffix))) |> structure(names = args) + # Helper to create lines of code for active bindings + # e.g. nCompiler::createRef("x_suffix", x) # either createRef or createBlockRef subList_2_lines <- function(subList, fun_name) { lines <- list() @@ -29,12 +48,17 @@ passByReference <- function(fun, lines } + # From "x", create lines like + # nCompiler::createRef("x_Ref__", x) subList <- args_2_subList(refArgs, "_Ref__") refArg_activeBinding_lines <- subList_2_lines(subList, "createRef") + # From "y", create lines like + # nCompiler::createBlockRef("y_BlockRef__", y) blockSubList <- args_2_subList(blockRefArgs, "_BlockRef__") blockRefArg_activeBinding_lines <- subList_2_lines(blockSubList, "createBlockRef") + # In the original code, replace x with x_Ref__, y with y_BlockRef__, etc. code <- eval( substitute( @@ -44,6 +68,7 @@ passByReference <- function(fun, ) ) + # Wrap in braces if not already if(code[[1]] != '{') code <- substitute({CODE}, list(CODE=code)) @@ -90,8 +115,7 @@ createRef <- function(innerName, createBlockRef <- function(innerName, outerCode, env, - innerEnv, - dummyName = 'DUMMY_FOR_CREATE_BLOCK_REF_') { + innerEnv) { # There is potential for more elaborate error-trapping. # E.g. we could determine the sizes (or net length) of outerCode (assignment target) # and check that v matches it. @@ -105,9 +129,8 @@ createBlockRef <- function(innerName, stop("A block reference argument must be passed as a variable name, e.g. `x`, or an indexed block of a variable, e.g. `x[1:4, 2:3]` or `x[1:4, ]`.") } outerLen <- eval(substitute(length(OC), list(OC = outerCode)), envir=env) - outer_dummy_assign_code <- substitute(L <- R, - list(L = outerCode, - R = as.name(dummyName))) + assignment_code <- substitute(L <- NULL, + list(L = outerCode)) binding <- function(v) if(missing(v)) @@ -115,9 +138,9 @@ createBlockRef <- function(innerName, else { if(outerLen != length(v)) stop("blockRef assignment must match in length.") - assign(dummyName, v, env) - on.exit(rm(list = dummyName, envir = env)) - eval(outer_dummy_assign_code, env) + assignment_code[[3]] <<- v + eval(assignment_code, env) + assignment_code[[3]] <<- NULL v } makeActiveBinding(innerName, binding, innerEnv) diff --git a/nCompiler/R/NF_derivs.R b/nCompiler/R/NF_derivs.R index 5433a9e8..9470fb0e 100644 --- a/nCompiler/R/NF_derivs.R +++ b/nCompiler/R/NF_derivs.R @@ -129,7 +129,7 @@ setup_wrt <- function(nFxn = NA, dropArgs = NA, wrt = NULL, NC = NULL) { fxn <- eval(fxnCall, envir = parent.frame()) fxnName <- fxnCall[[3]] if (!is.character(fxnName)) fxnName <- deparse(fxnName) - nf <- NC$public_methods[[fxnName]] + nf <- NC_get_Cpub_class(NC)$public_methods[[fxnName]] fxnArgs <- NFinternals(nf)$argSymTab$symbols } else if (is.call(fxnCall) && fxnCall[[1]] == 'method') { @@ -154,7 +154,7 @@ setup_wrt <- function(nFxn = NA, dropArgs = NA, wrt = NULL, NC = NULL) { fxnName <- fxnCall[[3]] - nf <- NC$public_methods[[fxnName]] + nf <- NC_get_Cpub_class(NC)$public_methods[[fxnName]] if (is.null(nf)) stop(paste0( "The 'NC' argument provided to 'setup_wrt' has no public method named ", @@ -575,7 +575,7 @@ nDerivs_full <- function(fxnCall = NULL, order = c(0, 1, 2), dropArgs = NA, fxnName <- fxnCall[[1]][[3]] if (is.symbol(fxnName)) fxnName <- deparse(fxnName) - nf <- NC$public_methods[[fxnName]] + nf <- NC_get_Cpub_class(NC)$public_methods[[fxnName]] fxnArgs <- NFinternals(nf)$argSymTab$symbols fxnCall[[1]] <- derivFxnCall fxnCall$order <- order @@ -603,7 +603,7 @@ nDerivs_generic <- function(fxnCall = NULL, order = c(0, 1, 2), dropArgs = NA, "The 'NC' argument to 'nDerivs' must be an nClass generator (returned", "from a call to 'nClass').")) - nf <- NC$public_methods[[fxnName]] + nf <- NC_get_Cpub_class(NC)$public_methods[[fxnName]] if (is.null(nf)) stop(paste0( "The 'NC' argument provided to 'nDerivs' has no public method named ", diff --git a/nCompiler/R/Rcpp_nCompiler.R b/nCompiler/R/Rcpp_nCompiler.R index 78b7ed54..761f6058 100644 --- a/nCompiler/R/Rcpp_nCompiler.R +++ b/nCompiler/R/Rcpp_nCompiler.R @@ -10,7 +10,7 @@ ## When calling nCompile with package=TRUE, or calling writePackage ## cppDefsList --> RcppPacket_list --> WP_writeCpp --> writeCpp_nCompiler (for each RcppPacket in the list) -## Rcpp_nCompilerPacket represents information needed from cppDefs in.nCompiler +## Rcpp_nCompilerPacket represents information needed from cppDefs in nCompiler ## to generate Rcpp-ready content. ## At the moment it is just a list, but we establish the abstraction ## because we suspect it will need to do more work in the future. @@ -22,8 +22,8 @@ Rcpp_nCompilerPacket <- function(...) { list(...) } -## Interface between.nCompiler's cppDef representation of code and -##.nCompiler's packet of content for Rcpp +## Interface between nCompiler's cppDef representation of code and +## nCompiler's packet of content for Rcpp ## To be expanded to take a list of cppDefs cppDefs_2_RcppPacket <- function(cppDef, filebase) { diff --git a/nCompiler/R/Rexecution.R b/nCompiler/R/Rexecution.R index f52c71e7..efe5d875 100644 --- a/nCompiler/R/Rexecution.R +++ b/nCompiler/R/Rexecution.R @@ -14,6 +14,18 @@ parallel_for <- function(index, range, body, ...) { #' @export parallel_reduce <- function(f, x, init, ...) { + if(is.character(f)) { # Not clear how to convert to char ... + operatorDef <- operatorDefEnv[[f]] + if(!is.null(operatorDef) && is.null(operatorDef$reduction)) + stop("`", f, "` is not a valid reduction function/operator") + } + if(missing(init)) { + if(!is.character(f) || is.null(operatorDef) || is.null(operatorDef$reduction)) + stop("`init` argument is missing and no default value provided for reduction function/operator") + init <- operatorDef$reduction + } + if(identical(f, "pairmin")) f <- "pmin" + if(identical(f, "pairmax")) f <- "pmax" Reduce(f, x, init) } @@ -337,6 +349,36 @@ nRep <- function(x, ...) { base::rep(x, ...) } +#' Sequence Generation +#' +#' In a \code{nFunction}, \code{nSeq} is (mostly) equivalent to \code{base::seq} +#' +#' @details This function is similar to R's \code{\link{seq}} function, but +#' can be used in a nFunction and compiled using \code{nCompile}. +#' +#' @param from the starting value of the sequence. +#' +#' @param to the ending value of the sequence. +#' +#' @param by increment of the sequence +#' +#' @param length.out desired length of the sequence +#' +#' @details +#' +#' \code{nSeq} behaves like R's \code{\link{seq}} function with +#' support for \code{from}, \code{to}, \code{by}, and \code{length.out} +#' arguments. The \code{along.with} argument is not supported. +#' There are no nCompiler versions of \code{seq.int}, \code{seq_along} or \code{seq_len}. + +#' @export +#' +nSeq <- function(...) { + base::seq(...) +} + + + #' Converts a dense matrix or vector to a sparse matrix or vector #' #' @importFrom Matrix Matrix as @@ -416,4 +458,4 @@ nVar <- function(x) { #' @export nSd <- function(x) { sd(x) -} \ No newline at end of file +} diff --git a/nCompiler/R/all_utils.R b/nCompiler/R/all_utils.R index 66c59d0a..d212e01b 100644 --- a/nCompiler/R/all_utils.R +++ b/nCompiler/R/all_utils.R @@ -141,10 +141,10 @@ pasteSemicolon <- function(x, indent = '') { call. = FALSE) } -#' Write unlisted code generated from.nCompiler cpp definitions. +#' Write unlisted code generated from nCompiler cpp definitions. #' #' This is not intended to be called directly but is useful for -#' debugging.nCompiler's C++ output. +#' debugging nCompiler's C++ output. #' #' @param x A (potentially nested) list of C++ code in character #' strings. diff --git a/nCompiler/R/compile_aaa_operatorLists.R b/nCompiler/R/compile_aaa_operatorLists.R index 0cac8c90..d187bb19 100644 --- a/nCompiler/R/compile_aaa_operatorLists.R +++ b/nCompiler/R/compile_aaa_operatorLists.R @@ -12,6 +12,8 @@ returnTypeCodes <- list( promoteToDoubleOrAD = 6L, promoteNoLogical = 7L) +liftedBlockOperatorsArg <- c("parallel_for" = 3, "parallel_reduce" = 1) # These are used for flagging when methods in lifted code block will need to have their object reference them explicitly via `obj__.`. The values are the argID where the method needs to occur. + returnTypeString2Code <- function(returnTypeString) { if(is.character(returnTypeString)) do.call('switch', c(list("double"), returnTypeCodes)) @@ -140,6 +142,16 @@ assignOperatorDef( ) ) +assignOperatorDef( + 'nClass_method_in_lifted', # This is used for local method calls in the body of lifted code blocks (currently `parallel_{for,reduce}`). + list( + labelAbstractTypes = list( + handler = 'nFunction_or_method_call'), + cppOutput = list( + handler = 'nClass_method_in_lifted') + ) +) + assignOperatorDef( 'custom_default', list( @@ -228,6 +240,10 @@ updateOperatorDef( c('nMatrix', 'nArray'), 'labelAbstractTypes', 'returnTypeCode', returnTypeCodes$promote ) +updateOperatorDef( + 'nMatrix', + 'matchDef', val = function(value = 0, nrow = NA, ncol = NA, init = TRUE, fillZeros = TRUE, recycle = TRUE, type = 'double') {} +) assignOperatorDef( 'type_is', @@ -273,6 +289,7 @@ assignOperatorDef( assignOperatorDef( c('parallel_for'), list( + matchDef = function(index, range, body, copyVars, shareVars) {}, labelAbstractTypes = list( handler = 'ParallelFor'), finalTransformations = list( @@ -282,7 +299,8 @@ assignOperatorDef( assignOperatorDef( c('parallel_reduce'), - list( + list( + matchDef = function(operator, object, init) {}, labelAbstractTypes = list( handler = 'ParallelReduce'), finalTransformations = list( @@ -473,9 +491,11 @@ assignOperatorDef( ) ), cppOutput = list( - handler = 'BinaryOrUnary') + handler = 'BinaryOrUnary'), + reduction = 0 ) ) +updateOperatorDef('-', 'reduction', val = NULL) assignOperatorDef( c('inprod'), @@ -522,11 +542,13 @@ assignOperatorDef( labelAbstractTypes = list( handler = 'BinaryCwise', returnTypeCode = returnTypeCodes$promoteNoLogical), - cppOutput = list() + cppOutput = list(), + reduction = Inf ) ) updateOperatorDef('pairmax', 'cppOutput', 'cppString', 'std::max') updateOperatorDef('pairmin', 'cppOutput', 'cppString', 'std::min') +updateOperatorDef('pairmax', 'reduction', val = -Inf) assignOperatorDef( c('pmin', 'pmax'), @@ -902,7 +924,8 @@ assignOperatorDef( ) ), cppOutput = list( - handler = 'MidOperator') + handler = 'MidOperator'), + reduction = 1 ) ) diff --git a/nCompiler/R/compile_eigenization.R b/nCompiler/R/compile_eigenization.R index adf981f7..75f72372 100644 --- a/nCompiler/R/compile_eigenization.R +++ b/nCompiler/R/compile_eigenization.R @@ -5,7 +5,8 @@ eigenizeUseArgs <- c( list( setWhich = c(FALSE, TRUE), - setRepVectorTimes = c(FALSE, TRUE, TRUE) + setRepVectorTimes = c(FALSE, TRUE, TRUE), + parallel_reduce = c(FALSE, TRUE, TRUE) )) eigenizeEnv <- new.env() diff --git a/nCompiler/R/compile_exprClass.R b/nCompiler/R/compile_exprClass.R index f8bb37c5..adf8d412 100644 --- a/nCompiler/R/compile_exprClass.R +++ b/nCompiler/R/compile_exprClass.R @@ -218,6 +218,7 @@ wrapExprClassOperator <- function(code, funName, isName = FALSE, isCall = TRUE, newExpr } + insertIndexingBracket <- function(code, argID, index) { insertExprClassLayer(code, argID, 'index[') setArg(code$args[[argID]], 2, index) diff --git a/nCompiler/R/compile_finalTransformations.R b/nCompiler/R/compile_finalTransformations.R index a82da612..33991bce 100644 --- a/nCompiler/R/compile_finalTransformations.R +++ b/nCompiler/R/compile_finalTransformations.R @@ -28,19 +28,7 @@ inFinalTransformationsEnv( inFinalTransformationsEnv( ParallelExpr <- function(parallel_expr_name, loop_body_name, auxEnv_field, code, symTab, auxEnv, info) { - copyVars <- eval(nDeparse(code$args[[4]], toR = TRUE), - envir = auxEnv$where) - shareVars <- eval(nDeparse(code$args[[5]], toR = TRUE), - envir = auxEnv$where) - ## Look for a mangled argument name in nameSubList. - ## It is unfortunate to have to do this here instead of earlier - ## when other names are replaced, but here the names are given - ## as character objects (potentially from R evaluation). - copyVars <- replace_nameSubList(copyVars, auxEnv$nameSubList) - shareVars <- replace_nameSubList(shareVars, auxEnv$nameSubList) - - code$args[[4]] <- copyVars ## This is no longer an exprClass - code$args[[5]] <- shareVars ## Ditto + allVars <- unlist(code$args[4:length(code$args)]) auxEnv[[auxEnv_field]] <- c(auxEnv[[auxEnv_field]], code) ## parallel_for(blocked_range(0, n), parallel_loop_body(x)); ## blocked_range_expr will be blocked_range(start, end + 1) @@ -62,11 +50,10 @@ inFinalTransformationsEnv( isName = FALSE, isLiteral = FALSE, isAssign = FALSE) setArg(parallel_expr, 1, blocked_range_expr) - ## loop_body_expr will be parallel_loop_body(var1, var2, etc.) + ## loop_body_expr will be parallel_loop_body_(var1, var2, etc.) loop_body_expr <- exprClass$new(name = loop_body_name, isCall = TRUE, isName = FALSE, isLiteral = FALSE, isAssign = FALSE) - allVars <- c(copyVars, shareVars) for(iv in seq_along(allVars)) { ## Look for a mangled argument name in nameSubList. ## It is unfortunate to have to do this here instead of earlier @@ -77,6 +64,8 @@ inFinalTransformationsEnv( exprClass$new(name = thisVar, isCall = FALSE, isName = TRUE, isLiteral = FALSE, isAssign = FALSE)) } + if(length(code$aux$localMethods)) + setArg(loop_body_expr, iv+1, nParse('cppLiteral("*this")')) setArg(parallel_expr, 2, loop_body_expr) setArg(code$caller, code$callerArgID, parallel_expr) NULL @@ -85,7 +74,64 @@ inFinalTransformationsEnv( inFinalTransformationsEnv( ParallelFor <- function(code, symTab, auxEnv, info) { - ParallelExpr('parallel_for', 'parallel_loop_body', 'parallelContent', code, + ## TODO: not sure if we will do more work on arg matching such that + ## code$args[[4]] and code$args[[5]] will always exist and correspond to `copyVars` and `shareVars` + ## respectively for `parallel_for`. But if so, we might rework/simplify this. + ## Check for "" is because it seems valid to do: `parallel_for(i,1:5,{},}` or `parallel_for(i,1:5,{},,}`. + if(!'copyVars' %in% names(code$args) || nDeparse(code$args[['copyVars']]) == "") { + copyVars <- NULL + } else copyVars <- eval(nDeparse(code$args[['copyVars']], toR = TRUE), + envir = auxEnv$where) + if(!'shareVars' %in% names(code$args) || nDeparse(code$args[['shareVars']]) == "") { + shareVars <- NULL + } else shareVars <- eval(nDeparse(code$args[['shareVars']], toR = TRUE), + envir = auxEnv$where) + if(any(shareVars %in% copyVars)) + stop(exprClassProcessingErrorMsg( + code, + paste('In finalTransformations handler ParallelExpr:', + 'arguments `shareVars` and `copyVars` to `parallel_for`', + 'both contain the same variable')), call. = FALSE) + ## Look for a mangled argument name in nameSubList. + ## It is unfortunate to have to do this here instead of earlier + ## when other names are replaced, but here the names are given + ## as character objects (potentially from R evaluation). + copyVars <- replace_nameSubList(copyVars, auxEnv$nameSubList) + shareVars <- replace_nameSubList(shareVars, auxEnv$nameSubList) + + ## Add default vars: + ## Any argument, class member variable, nFunction local variable by default is shared. + ## Any local variable in the loop body by default is copied. + vars <- all.vars(code$args[[3]]$Rexpr) + vars2 <- vars[vars != nDeparse(code$args[[1]])] # Omit index variable. + inST <- vars2 %in% c(symTab$getSymbolNames(), symTab$parentST$getSymbolNames()) + defaultCopyVars <- code$aux$localVars # Local vars in for loop body. + defaultCopyVars <- defaultCopyVars[!defaultCopyVars %in% shareVars] + defaultShareVars <- vars2[inST] # All other vars. + defaultShareVars <- defaultShareVars[!defaultShareVars %in% code$aux$localVars] + defaultShareVars <- defaultShareVars[!defaultShareVars %in% copyVars] + + ## Find nClass objects (if methods are used; members would have been found above). + nms <- all.names(code$args[[3]]$Rexpr) + nms <- nms[!nms %in% vars] + objects <- nms[nms %in% c(symTab$getSymbolNames(), symTab$parentST$getSymbolNames())] + ## Make sure the items are actually nClass objects. + if(length(objects)) + objects <- objects[sapply(objects, + function(x) !is.null(symTab$getSymbol(x)$NCgenerator) || !is.null(parentST$getSymbol(x)$NCgenerator))] + + shareVars <- unique(c(shareVars, defaultShareVars, objects)) + copyVars <- unique(c(copyVars, defaultCopyVars)) + + ## NULL cannot hold a position in `code$args`. + if(is.null(copyVars)) copyVars <- character(0) + if(is.null(shareVars)) shareVars <- character(0) + + code$args[[4]] <- copyVars ## This is no longer an exprClass + code$args[[5]] <- shareVars ## Ditto + names(code$args)[4:5] <- c('copyVars','shareVars') + + ParallelExpr('parallel_for', code$aux$bodyName, 'parallelContent', code, symTab, auxEnv, info) } ) @@ -128,13 +174,17 @@ inFinalTransformationsEnv( setArg(colon, 1, exprClass$new(name = 1, isLiteral = TRUE, isCall = FALSE, isName = FALSE, isAssign = FALSE)) size_expr <- setArg( - colon, 2, nParse(paste0('cppLiteral("', vector_arg$name, '.size();")'))) + colon, 2, nParse(paste0('cppLiteral("', vector_arg$name, '.size()")'))) ## make the vector an argument of the reduce op and index it reduce_op <- code$args[[3]] - setArg(reduce_op, 1, copyExprClass(vector_arg)) - insertIndexingBracket(reduce_op, 1, copyExprClass(index_arg)) + inc <- 0 + if(reduce_op$name == 'chainedCall') + inc <- 1 + + setArg(reduce_op, 1+inc, copyExprClass(vector_arg)) + insertIndexingBracket(reduce_op, 1+inc, copyExprClass(index_arg)) ## the other arg to the reduce op is a local aggregation var called 'val__' - val <- setArg(reduce_op, 2, exprClass$new(name = 'val__', isName = TRUE, + val <- setArg(reduce_op, 2+inc, exprClass$new(name = 'val__', isName = TRUE, isCall = FALSE, isLiteral = FALSE, isAssign = FALSE)) @@ -162,40 +212,100 @@ inFinalTransformationsEnv( symTab$addSymbol(value_type) } - ## The class name is hard-wired expecting only a single case of parallel - ## reduce content. - ## TO-DO: generalize the name with unique identifier. + instName <- sub("_body", "_inst__", code$aux$bodyName) + + inputVar <- eval(nDeparse(code$args[[4]], toR = TRUE), + envir = auxEnv$where) + outputVar <- eval(nDeparse(code$args[[5]], toR = TRUE), + envir = auxEnv$where) + ## Look for a mangled argument name in nameSubList. + ## It is unfortunate to have to do this here instead of earlier + ## when other names are replaced, but here the names are given + ## as character objects (potentially from R evaluation). + inputVar <- replace_nameSubList(inputVar, auxEnv$nameSubList) + + nms <- all.vars(code$Rexpr) + object <- nms[nms %in% c(symTab$getSymbolNames(), symTab$parentST$getSymbolNames()) & + !nms %in% inputVar] + if(length(object) > 1) + stop(exprClassProcessingErrorMsg( + code$Rexpr, + paste('In finalTransformations handler ParallelReduce:', + 'Unexpectedly found multiple objects in parallel_reduce reduction function')), + call. = FALSE) + ## Make sure the items are actually nClass objects. + if(length(object) && is.null(symTab$getSymbol(object)$NCgenerator) && + !is.null(parentST$getSymbol(object)$NCgenerator)) + object <- character(0) + + ## TODO: consider reworking how we handle these items as it doesn't map cleanly onto the + ## `args`, which was really set up for `parallel_for`. + code$args[[4]] <- inputVar ## This is no longer an exprClass + code$args[[5]] <- outputVar ## Ditto + code$args[[6]] <- object + ParallelExpr('parallel_reduce', - 'parallel_reduce_body parallel_reduce_inst__', + paste(code$aux$bodyName, instName, collapse = ' '), 'parallelReduceContent', code, symTab, auxEnv, info) - - if (isTRUE(code$caller$isAssign)) { - assign_argID <- code$caller$callerArgID - parallel_reduce_expr <- removeArg(code$caller, 2) - ## the instantiation of the parallel_reduce_body object will happen - ## before the call to parallel_reduce - instance_expr <- removeArg(parallel_reduce_expr, 2) - ## the second argument should be the initial value provided by the user - setArg(instance_expr, 2, init_arg) - ## TODO: this doesn't have the effect I hoped for... is there a way to - ## add type annotation to a call (such as object instantiation)? - instance_expr$type <- symbolBase$new(name = 'parallel_reduce_body', - type = 'parallel_reduce_body') - ## the parallel_reduce_body instance name is the second arg to the - ## parallel_reduce call (note that this isn't an exprClass) - setArg(parallel_reduce_expr, 2, - exprClass$new(name = 'parallel_reduce_inst__', isName = TRUE, - isCall = FALSE, isLiteral = FALSE, isAssign = FALSE)) - ## move the parallel_reduce_body instantiation to before the assignment - insertArg(code$caller$caller, assign_argID, instance_expr) - ## put the parallel_reduce call between the parallel_reduce_body - ## instantiation and the assign - insertArg(code$caller$caller, assign_argID + 1, parallel_reduce_expr) - ## now the RHS of the assign is the aggregation value after the - ## parallel_reduce - setArg(code$caller, 2, - nParse(paste0('cppLiteral("parallel_reduce_inst__.value__;")'))) + + outerCall <- code$caller + level <- 1 + while(!isTRUE(outerCall$isAssign) && !outerCall$name == "return" && !outerCall$name == "{") { + outerCall <- outerCall$caller # Find correct level to insert the reduction code. + level <- level + 1 + if(level > 100) ## Not sure what situation could lead to this. + stop(exprClassProcessingErrorMsg( + code$Rexpr, + paste('In finalTransformations handler ParallelReduce:', + 'Unexpected levels of nesting in use of parallel_reduce')), + call. = FALSE) } + if(outerCall$name == "{") # No assignment or return. Handle these gracefully but no known use cases. + if(outerCall$args[[1]]$name == 'parallel_reduce') { # A lone `parallel_reduce()` + ## Add layer so that parallel_reduce call is within a call so can be handled + ## as other cases are handled. + code$caller <- wrapInExprClass(code$caller, "{") + setCaller(code, code$caller$args[[1]], 1) + } else outerCall <- outerCall$args[[1]] # A case like `3 + parallel_reduce()` + + code$aux$init <- init_arg + assign_argID <- outerCall$callerArgID # Always 1, presumably. + + ## Check for `tbb::blocked_range` handles cases such as `parallel_reduce() + parallel_reduce()`, + ## distinguishing which one is currently being processed. + reduce_argID <- which(sapply(code$caller$args, function(x) + x$name == "parallel_reduce" && x$args[[1]]$name == "tbb::blocked_range")) + + if(length(reduce_argID) != 1) + stop(exprClassProcessingErrorMsg( + code$Rexpr, + paste('In finalTransformations handler ParallelReduce:', + 'Unable to process code - missing or too many uses of parallel_reduce')), + call. = FALSE) + parallel_reduce_expr <- removeArg(code$caller, reduce_argID) + ## the instantiation of the parallel_reduce_body object will happen + ## before the call to parallel_reduce + instance_expr <- removeArg(parallel_reduce_expr, 2) + ## the second argument should be the initial value provided by the user + setArg(instance_expr, 2, init_arg) + ## TODO: this doesn't have the effect I hoped for... is there a way to + ## add type annotation to a call (such as object instantiation)? + instance_expr$type <- symbolBase$new(name = code$aux$bodyName, + type = 'parallel_reduce_body') + ## the parallel_reduce_body instance name is the second arg to the + ## parallel_reduce call (note that this isn't an exprClass) + setArg(parallel_reduce_expr, 2, + exprClass$new(name = instName, isName = TRUE, + isCall = FALSE, isLiteral = FALSE, isAssign = FALSE)) + ## move the parallel_reduce_body instantiation to before the assignment + insertArg(outerCall$caller, assign_argID, instance_expr) + ## put the parallel_reduce call between the parallel_reduce_body + ## instantiation and the assign + insertArg(outerCall$caller, assign_argID + 1, parallel_reduce_expr) + ## now the RHS of the assign is the aggregation value after the + ## parallel_reduce + insertArg(code$caller, reduce_argID, + nParse(paste0('cppLiteral("', instName, '.value__")'))) NULL } ) diff --git a/nCompiler/R/compile_generateCpp.R b/nCompiler/R/compile_generateCpp.R index ce0a932e..bf0cba4c 100644 --- a/nCompiler/R/compile_generateCpp.R +++ b/nCompiler/R/compile_generateCpp.R @@ -190,6 +190,20 @@ inGenCppEnv( } ) +inGenCppEnv( + nClass_method_in_lifted <- function(code, symTab) { + cpp_code_name <- code$aux$cachedOpInfo$obj_internals$cpp_code_name + paste0(selfNameInLiftedBlock, ".", cpp_code_name, + '(', paste0(unlist(lapply(code$args, + compile_generateCpp, + symTab, + asArg = TRUE) ), + collapse = ', '), + ')' ) + } +) + + inGenCppEnv( nClass_constructor <- function(code, symTab) { paste0("nClass_builder<" , code$type$name ,">()") @@ -209,7 +223,7 @@ inGenCppEnv( ) inGenCppEnv( - MidOperator <- function(code, symTab) { + MidOperator <- function(code, symTab) { if(length(code$args) != 2) stop('Error: expecting 2 arguments for operator ',code$name) if(is.null(code$caller)) useParens <- FALSE else { @@ -349,7 +363,7 @@ inGenCppEnv( ) inGenCppEnv( - ## Member(A, x) -> A.x + ## PtrMember(A, x) -> A->x PtrMember <- function(code, symTab) { Member(code, symTab, connector = '->') } diff --git a/nCompiler/R/compile_labelAbstractTypes.R b/nCompiler/R/compile_labelAbstractTypes.R index dd7e7ddb..ac2ea0ac 100644 --- a/nCompiler/R/compile_labelAbstractTypes.R +++ b/nCompiler/R/compile_labelAbstractTypes.R @@ -540,7 +540,7 @@ inLabelAbstractTypesEnv( ) inLabelAbstractTypesEnv( - InitData <- function(code, symTab, auxEnv, handlingInfo) { + InitData <- function(code, symTab, auxEnv, handlingInfo) { ## TODO: handle 'init' arg ## defaults: ## n{Numeric|Integer|Logical}(length = 0, value = 0, init = TRUE) @@ -654,6 +654,10 @@ inLabelAbstractTypesEnv( if(!symTab$symbolExists(LHS$name, TRUE)) { newSym <- RHStype$clone() newSym$isArg <- FALSE + # Assignment from a reference (could be a refArg) or a blockRef (blockRefArg) should be a plain type + newSym$isRef <- FALSE + if(!is.null(newSym$isBlockRef)) + newSym$isBlockRef <- FALSE newSym$name <- LHS$name symTab$addSymbol(newSym) LHS$type <- newSym @@ -729,11 +733,12 @@ inLabelAbstractTypesEnv( inLabelAbstractTypesEnv( ParallelFor <- function(code, symTab, auxEnv, handlingInfo) { - if(length(code$args) != 5) + if(length(code$args) < 3 || !identical(names(code$args)[1:3], + c('index','range','body'))) stop(exprClassProcessingErrorMsg( code, paste('In labelAbstractTypes handler ParallelFor:', - 'expected 5 arguments to a parallel_for-loop')), call. = FALSE) + 'expected arguments `index`, `range`, and `body` to a parallel_for-loop')), call. = FALSE) ## first handle type of the indexing variable if(!inherits(code$args[[2]], 'exprClass')) stop( @@ -753,22 +758,62 @@ inLabelAbstractTypesEnv( if (!symTab$symbolExists(code$args[[1]]$name, inherits = TRUE)) if (TRUE) symTab$addSymbol(code$args[[1]]$type) - - ## Now the 3rd arg, the body of the loop, can be processed + + ## Now the 3rd arg, the body of the loop, can be processed. + ## For now, we will handle local vars in body as `copyVars` that are vars + ## in the encompassing method, but consider setting up local symbol table for + ## the loop body with the loop body C++ function declaring its own variables. + symbolsNoBody <- symTab$getSymbolNames() inserts <- c(inserts, compile_labelAbstractTypes(code$args[[3]], symTab, auxEnv)) ## I think there shouldn't be any inserts returned since the body should be a bracket expression. + symbols <- symTab$getSymbolNames() + code$aux$localVars <- symbols[!symbols %in% symbolsNoBody] + + ## We have already found the local method calls and set the `opInfo$case` to be 'nClass_method_in_lifted', + ## such that C++ calls to the method will be handled by cppOutput handler. + ## The following checks for such methods in a different way (so perhaps worry an inconsistency could arise). + ## Perhaps there is a better way to get this information. + ## This information is used later to ensure that the self object is passed into the lifted TBB code. + ## Currently we don't use the actual identified `localMethods` values, just whether there are any. + nms <- all.names(code$args[[3]]$Rexpr) + code$aux$localMethods <- nms[nms %in% c(names(auxEnv$where$public_methods), names(auxEnv$where$private_methods))] + code$aux$class <- auxEnv$where$classname + + code$aux$bodyName <- parallelForBodyLabelMaker() + return(if (length(inserts) == 0) invisible(NULL) else inserts) } ) inLabelAbstractTypesEnv( ParallelReduce <- function(code, symTab, auxEnv, handlingInfo) { - if (length(code$args) != 3) + if(is.null(symTab$parentST)) # TODO: this seems kludgey and perhaps should be done at a different processing stage. + stop(exprClassProcessingErrorMsg( + code, + paste0('In labelAbstractTypes handler ParallelReduce: ', + 'parallel_reduce must be used in a method of an nClass, not in a stand-alone nFunction.')), + call. = FALSE) + operatorDef <- operatorDefEnv[[code$args[[1]]$name]] + if (code$args[[1]]$name != '$' && !is.null(operatorDef) && is.null(operatorDef$reduction)) # Check for validity only for our operators. + # TODO: perhaps this should just be a warning. + stop(exprClassProcessingErrorMsg( + code, + paste0('In labelAbstractTypes handler ParallelReduce: ', + 'function/operator `', code$args[[1]]$name, '` is not a valid reduction function/operator.')), + call. = FALSE) + if(length(code$args) == 2 && !is.null(operatorDef$reduction)) + setArg(code, 3, nParse(operatorDef$reduction)) + if (length(code$args) != 3) stop(exprClassProcessingErrorMsg( code, paste('In labelAbstractTypes handler ParallelReduce:', 'expected 3 arguments but got', length(code$args))), call. = FALSE) + if(code$args[[1]]$isName) { ## Handle reduction function as function not char. + code$args[[1]]$isName <- FALSE + code$args[[1]]$isLiteral <- TRUE + code$args[[1]]$Rexpr <- deparse(code$args[[1]]$Rexpr) + } ## process the initial value inserts <- compile_labelAbstractTypes(code$args[[3]], symTab, auxEnv) if (code$args[[3]]$type$nDim != 0) @@ -778,12 +823,14 @@ inLabelAbstractTypesEnv( 'initial value for parallel_reduce should be scalar but got', ' nDim = ', code$args[[3]]$type$nDim)), call. = FALSE) - if (isFALSE(code$args[[3]]$isLiteral)) - stop(exprClassProcessingErrorMsg( - code, - paste('In labelAbstractTypes handler ParallelReduce:', - 'initial value for parallel_reduce must be a literal')), - call. = FALSE) + if (isFALSE(code$args[[3]]$isLiteral)) { + if(!(code$args[[3]]$name == "-" && isTRUE(code$args[[3]]$args[[1]]$isLiteral))) # Handle negative init. + stop(exprClassProcessingErrorMsg( + code, + paste('In labelAbstractTypes handler ParallelReduce:', + 'initial value for parallel_reduce must be a literal value, not a variable or expression')), + call. = FALSE) + } ## process the reduce operator if (isTRUE(code$args[[1]]$isLiteral)) { if (!is.character(code$args[[1]]$name)) @@ -796,12 +843,35 @@ inLabelAbstractTypesEnv( code$args[[1]]$isLiteral <- FALSE code$args[[1]]$isCall <- TRUE } - ## give reduce operator the same return type as the initial value + if(code$args[[1]]$name == "$") { + if(code$args[[1]]$args[[1]]$name == "$") + stop(exprClassProcessingErrorMsg( + code, + paste('In labelAbstractTypes handler ParallelReduce:', + 'too many levels of class hierarchy in reduction operator', + deparse(code$args[[1]]$Rexpr))), + call. = FALSE) + code$args[[1]] <- wrapInExprClass(code$args[[1]], 'chainedCall') + inserts <- c(inserts, compile_labelAbstractTypes(code$args[[1]], symTab, auxEnv)) + } + + ## give reduce operator the same return type as the input vector. ## TODO: Maybe symbolNF is the right type for the reduction op. code$args[[1]]$type <- symbolBasic$new(name = code$args[[1]]$name, - nDim = 0, type = code$args[[3]]$type$type) + nDim = 0, type = code$args[[2]]$type$type) ## finish by processing the vector arg + ## TODO: we want to handle if vector is an expression (including obj$x), + ## presumably by lifting. + if(!code$args[[2]]$isName) + stop(exprClassProcessingErrorMsg( + code, + paste('In labelAbstractTypes handler ParallelReduce:', + 'vector argument for parallel_reduce must be a variable, but found an expression `', + deparse(code$args[[2]]$Rexpr), + '`. Please create a temporary variable to use as the second argument.')), + call. = FALSE) + inserts <- c(inserts, compile_labelAbstractTypes(code$args[[2]], symTab, auxEnv)) if (code$args[[2]]$type$nDim != 1) stop(exprClassProcessingErrorMsg( @@ -811,7 +881,21 @@ inLabelAbstractTypesEnv( code$args[[2]]$type$nDim)), call. = FALSE) code$type <- symbolBasic$new(name = code$name, nDim = 0, - type = code$args[[3]]$type$type) + type = code$args[[2]]$type$type) + + ## We have already found the local method calls and set the `opInfo$case` to be 'nClass_method_in_lifted', + ## such that C++ calls to the method will be handled by cppOutput handler. + ## The following checks for such methods in a different way (so perhaps worry an inconsistency could arise). + ## Perhaps there is a better way to get this information. + ## This information is used later to ensure that the self object is passed into the lifted TBB code. + ## Currently we don't use the actual identified `localMethods` values, just whether there are any. + nm <- code$args[[1]]$Rexpr + if(is.character(nm) && nm %in% c(names(auxEnv$where$public_methods), names(auxEnv$where$private_methods))) + code$aux$localMethods <- nm else code$aux$localMethods <- character(0) + code$aux$class <- auxEnv$where$classname + + code$aux$bodyName <- parallelReduceBodyLabelMaker() + return(if (length(inserts) == 0) invisible(NULL) else inserts) } ) diff --git a/nCompiler/R/compile_nParse.R b/nCompiler/R/compile_nParse.R index d9176370..7732e81c 100644 --- a/nCompiler/R/compile_nParse.R +++ b/nCompiler/R/compile_nParse.R @@ -41,10 +41,10 @@ embedListInRbracket <- function(code) { ## build exprClasses from an R parse tree. ## caller and callerArgID are for recursion, not to be used on first entry -#' Create.nCompiler parse tree from R code. +#' Create nCompiler parse tree from R code. #' #' Create nCompiler parse tree, an annotated bidirectional syntax tree -#' used by the.nCompiler compiler, from R code. +#' used by the nCompiler compiler, from R code. #' #' @param code R code object such as returned by \code{quote()} or #' \code{call()}. @@ -228,7 +228,7 @@ brackOperatorsForDeparse <- list('[' = c('[',']'), #' Convert a nCompiler parse tree, specifically an \code{exprClass} #' object, to an R parse tree or text. #' -#' @param code An \code{exprClass} object, representing a.nCompiler parse +#' @param code An \code{exprClass} object, representing a nCompiler parse #' tree. #' @param indent Amount of indentation in text output if \code{toR} is #' \code{FALSE} diff --git a/nCompiler/R/compile_normalizeCalls.R b/nCompiler/R/compile_normalizeCalls.R index ddb99426..2f2bb8c2 100644 --- a/nCompiler/R/compile_normalizeCalls.R +++ b/nCompiler/R/compile_normalizeCalls.R @@ -1,3 +1,9 @@ +## Special cases placed here by analogy with `eigenizeUseArgs`, +## but perhaps should be in handler list. +normalizeCallsFunctionArgs <- list( + parallel_reduce = 1 +) + normalizeCallsEnv <- new.env() normalizeCallsEnv$.debug <- FALSE @@ -50,7 +56,10 @@ compile_normalizeCalls <- function(code, # What gets cached in the aux of the exprClass for the call: # cachedOpInfo = list(opDef, name, obj_internals, case) # We defer: uniqueName, cpp_code_name - cachedOpInfo <- update_cachedOpInfo(code, auxEnv$where) + fxnArg <- normalizeCallsFunctionArgs[[code$name]] + if(!is.null(fxnArg)) { # Handle arguments that are functions (`parallel_reduce`). + cachedOpInfo <- update_cachedOpInfo(code$args[[fxnArg]], auxEnv$where) + } else cachedOpInfo <- update_cachedOpInfo(code, auxEnv$where) if(cachedOpInfo$case == "nFunction") { uniqueName <- cachedOpInfo$obj_internals$uniqueName2 if(length(uniqueName)==0) @@ -65,17 +74,20 @@ compile_normalizeCalls <- function(code, ## but we do not as a way to avoid having many references to R6 objects ## in a blind attempt to facilitate garbage collection based on past experience. ## Instead, we provide what is needed to look up the nFunction again later. - auxEnv$needed_nFunctions[[uniqueName]] <- list(code$name, auxEnv$where) + if(is.null(fxnArg)) nm <- code$name else nm <- code$args[[fxnArg]]$name + auxEnv$needed_nFunctions[[uniqueName]] <- list(nm, auxEnv$where) } } - opDef <- cachedOpInfo$opDef - matchDef <- opDef[["matchDef"]] - if(is.null(matchDef)) - matchDef <- cachedOpInfo$obj_internals$default_matchDef - if(!is.null(matchDef)) { - exprClass_put_args_in_order(matchDef, code, opDef$compileArgs) - # code <- replaceArgInCaller(code, matched_code) + if(is.null(fxnArg)) { + opDef <- cachedOpInfo$opDef + matchDef <- opDef[["matchDef"]] + if(is.null(matchDef)) + matchDef <- cachedOpInfo$obj_internals$default_matchDef + if(!is.null(matchDef)) { + exprClass_put_args_in_order(matchDef, code, opDef$compileArgs) + # code <- replaceArgInCaller(code, matched_code) + } } normalizeCallsEnv$recurse_normalizeCalls(code, symTab, auxEnv, handlingInfo) } @@ -133,7 +145,9 @@ update_cachedOpInfo <- function(code, where, allowFail=FALSE) { obj <- NC_find_method(where, code$name, inherits=TRUE) if(!is.null(obj)) { if(isNF(obj)) { - cachedOpInfo$case <- "nClass method" # possibly disambiguate method from keyword + if(!checkForLiftedBody(code)) { # Current lifted body cases are `parallel_{for,reduce}`. + cachedOpInfo$case <- "nClass method" # possibly disambiguate method from keyword + } else cachedOpInfo$case <- "nClass method in lifted" # a method call in a code block that will be lifted out of the class def and will need to reference the method via the local object } else { stop(exprClassProcessingErrorMsg(code, paste0('method ', code$name, 'is being called, but it is not a nFunction.')), @@ -184,6 +198,10 @@ update_cachedOpInfo <- function(code, where, allowFail=FALSE) { if(cachedOpInfo$case == "nFunction" || cachedOpInfo$case == "nClass method") { opDef <- getOperatorDef("nFunction_default") } + if(cachedOpInfo$case == "nClass method in lifted") { + opDef <- getOperatorDef("nClass_method_in_lifted") + } + } } if(is.null(opDef)) { @@ -243,3 +261,14 @@ update_cachedOpInfo <- function(code, where, allowFail=FALSE) { # NULL # } # ) + +checkForLiftedBody <- function(code) { + while(!is.null(code$caller)) { # Caller needs to be in specific set of operators and method in particular argument. + if(code$caller$isCall && code$caller$name %in% names(liftedBlockOperatorsArg)) + if(code$callerArgID %in% liftedBlockOperatorsArg[[code$caller$name]]) + return(TRUE) else return(FALSE) + return(checkForLiftedBody(code$caller)) + } + return(FALSE) +} + diff --git a/nCompiler/R/cppDefs_ADutils.R b/nCompiler/R/cppDefs_ADutils.R index 6c41006f..11a1d5c7 100644 --- a/nCompiler/R/cppDefs_ADutils.R +++ b/nCompiler/R/cppDefs_ADutils.R @@ -64,7 +64,7 @@ symbolTable2templateTypeSymbolTable <- function(symTab, makeTypeTemplateFunction = function(newName, self) { newCppFunDef <- cpp_nFunctionClass$new(name = newName, static = TRUE) - ## use typedefs to change.nCompiler's general typedefs for Eigen locally + ## use typedefs to change nCompiler's general typedefs for Eigen locally typeDefs <- symbolTableClass$new() ## Need to add here replacement of Eigen types with Eigen > newCppFunDef$name <- newName @@ -135,7 +135,7 @@ makeADtapingFunction <- function(newFunName = 'callForADtaping', ansSym$name <- 'ANS_' localVars$addSymbol(ansSym) symNames <- localVars$getSymbolNames() - ## set up a set of index variables for copying code, up to six to be arbitrary (allowing up to 6-dimensional.nCompiler objects to be handled) + ## set up a set of index variables for copying code, up to six to be arbitrary (allowing up to 6-dimensional nCompiler objects to be handled) indexVarNames <- paste0(letters[9:14],'_') ## set any sizes, which must be known .nCompilerSymTab <- targetFunDef$NF_Compiler$symbolTable ##targetFunDef$RCfunProc$compileInfo$newLocalSymTab @@ -171,7 +171,7 @@ makeADtapingFunction <- function(newFunName = 'callForADtaping', ## call CppAD::Independent(ADindependentVars) ## This starts CppADs taping system - CppADindependentCode <- quote(`CppAD::Independent`(ADindependentVars)) #.nCompiler:::RparseTree2ExprClasses(quote(`CppAD::Independent`(ADindependentVars))) + CppADindependentCode <- quote(`CppAD::Independent`(ADindependentVars)) # nCompiler:::RparseTree2ExprClasses(quote(`CppAD::Independent`(ADindependentVars))) ## make copying blocks into independent vars ## This looks like e.g. @@ -296,7 +296,7 @@ makeADtapingFunction <- function(newFunName = 'callForADtaping', returnCall <- cppLiteral("return(RETURN_TAPE_);") - ## Finally put together all the code, parse it into the.nCompiler exprClass system, + ## Finally put together all the code, parse it into the nCompiler exprClass system, ## and add it to the result (CFT) allRcode <- do.call('call', c(list('{'), diff --git a/nCompiler/R/cppDefs_TBB.R b/nCompiler/R/cppDefs_TBB.R index 7ec9d27c..c334275b 100644 --- a/nCompiler/R/cppDefs_TBB.R +++ b/nCompiler/R/cppDefs_TBB.R @@ -1,6 +1,10 @@ -# not working ## cppDefs for parallel loop bodies for TBB +selfNameInLiftedBlock <- "obj__" + +parallelForBodyLabelMaker <- labelFunctionCreator('parallel_loop_body') +parallelReduceBodyLabelMaker <- labelFunctionCreator('parallel_reduce_body') + cppParallelBodyClass <- R6::R6Class( 'cppParallelBodyClass', inherit = cppClassClass, @@ -10,13 +14,15 @@ cppParallelBodyClass <- R6::R6Class( loop_var, symbolTable, copyVars = character(), - noncopyVars = character()) { + noncopyVars = character(), + aux = list()) { cppParallelBodyClass_init_impl(self, loop_body = loop_body, loop_var = loop_var, symbolTable = symbolTable, copyVars = copyVars, - noncopyVars = noncopyVars) + noncopyVars = noncopyVars, + aux = aux) }, generate = function(declaration = FALSE, ...) { ## This version of generate creates a fully inlined version @@ -47,13 +53,12 @@ cppParallelBodyClass <- R6::R6Class( ) cppParallelBodyClass_init_impl <- function(cppDef, - name = "parallel_loop_body", - orig_loop_code = orig_loop_code, - loop_body = orig_loop_code$args[[3]], - loop_var = orig_loop_code$args[[1]], + loop_body, + loop_var, symbolTable, copyVars, - noncopyVars) { + noncopyVars, + aux) { ## 1. Create symbolTable for copyVars + noncopyVars ## 2. Create operator() ## 3. Create constructor @@ -99,6 +104,11 @@ cppParallelBodyClass_init_impl <- function(cppDef, sym$ref <- TRUE newSymTab$addSymbol(sym) } + if(length(aux$localMethods)) + newSymTab$addSymbol(cppVarFullClass$new(name = selfNameInLiftedBlock, + baseType = aux$class, + ref = TRUE)) + ## Create operator() generalForExpr <- exprClass$new(name = 'GeneralFor', isCall = TRUE, isName = FALSE, isAssign = FALSE, isLiteral = FALSE) @@ -134,7 +144,7 @@ cppParallelBodyClass_init_impl <- function(cppDef, list(X = as.name(thisSymName), X_ = as.name(thisArgName)))) } - constructor <- cppFunctionClass$new(name = name, + constructor <- cppFunctionClass$new(name = aux$bodyName, args = ctorArgSymTab, code = cppCodeBlockClass$new( code = nParse(quote({})), @@ -142,7 +152,7 @@ cppParallelBodyClass_init_impl <- function(cppDef, ), initializerList = initializerList, returnType = cppBlank()) - cppDef$name <- name + cppDef$name <- aux$bodyName cppDef$memberCppDefs <- list(`operator()` = `operator()`, constructor = constructor) cppDef$symbolTable <- newSymTab @@ -158,13 +168,15 @@ cppParallelReduceBodyClass <- R6::R6Class( loop_var, symbolTable, copyVars = character(), - noncopyVars = character()) { + noncopyVars = character(), + aux = list()) { cppParallelReduceBodyClass_init_impl(self, loop_body = loop_body, loop_var = loop_var, symbolTable = symbolTable, copyVars = copyVars, - noncopyVars = noncopyVars) + noncopyVars = noncopyVars, + aux = aux) }, generate = function(declaration = FALSE, ...) { ## This version of generate creates a fully inlined version @@ -197,13 +209,12 @@ cppParallelReduceBodyClass <- R6::R6Class( ) cppParallelReduceBodyClass_init_impl <- function(cppDef, - name = "parallel_reduce_body", - orig_loop_code = orig_loop_code, - loop_body = orig_loop_code$args[[3]], - loop_var = orig_loop_code$args[[1]], + loop_body, + loop_var, symbolTable, copyVars, - noncopyVars) { + noncopyVars, + aux) { ## 1. call cppParallelBodyClass_init_impl which creates GeneralFor ## 2. make some minor alterations to the body of `operator()` ## 3. Create split constructor @@ -211,10 +222,10 @@ cppParallelReduceBodyClass_init_impl <- function(cppDef, ## need to save this here because cppParallelBodyClass_init_impl will change ## loop_body's caller - orig_caller <- loop_body$caller + orig_caller <- copyExprClass(loop_body$caller) - cppParallelBodyClass_init_impl(cppDef, name, orig_loop_code, loop_body, - loop_var, symbolTable, copyVars, noncopyVars) + cppParallelBodyClass_init_impl(cppDef, loop_body, loop_var, + symbolTable, copyVars, noncopyVars, aux) ## get the local aggregation var copy variable val_expr <- copyExprClass(loop_body$args[[1]]) @@ -242,13 +253,9 @@ cppParallelReduceBodyClass_init_impl <- function(cppDef, cppVarClass$new(name = val_expr$name, baseType = val_expr$type$type)) ## remove 'const' from the `operator()` declaration cppDef$memberCppDefs[['operator()']]$const <- FALSE - - ## get the reduce op's identity element which is guaranteed to be a literal - ## by the labelAbstractTypes ParallelReduce handler - init_arg <- copyExprClass(orig_caller$caller$caller$args[[1]]$args[[2]]) - + split_ctor_symTab <- symbolTableClass$new() - split_ctor_symTab$addSymbol(cppVarClass$new(name = 'parent', baseType = name, + split_ctor_symTab$addSymbol(cppVarClass$new(name = 'parent', baseType = aux$bodyName, ref = TRUE)) split_ctor_symTab$addSymbol(cppVarClass$new(name = 'tbb::split')) ## Get the name of the vector we're working with, which together with the @@ -256,13 +263,24 @@ cppParallelReduceBodyClass_init_impl <- function(cppDef, vector_name <- orig_caller$args[[4]] ## should be a string initializerList <- list() initializerList[[1]] <- nParse( - substitute(X(X_), list(X = as.name(value_name), - X_ = as.name(init_arg$name)))) + substitute(X(X_), list(X = as.name(value_name)))) + ## Need to directly parse the init value to handle various numeric cases, e.g., `Inf`. + setArg(initializerList[[1]], 1, orig_caller$aux$init) initializerList[[2]] <- nParse( substitute(X(X_), list(X = as.name(vector_name), X_ = as.name(paste0('parent.', vector_name))))) + if(length(aux$localMethods)) + initializerList[[3]] <- nParse( + substitute(X(X_), list(X = selfNameInLiftedBlock, + X_ = as.name(paste0('parent.', selfNameInLiftedBlock))))) + if(length(orig_caller$args) == 6 && length(orig_caller$args[[6]])) # This is the object if using an object method as the operator. + initializerList[[3]] <- nParse( + substitute(X(X_), list(X = orig_caller$args[[6]], + X_ = as.name(paste0('parent.', orig_caller$args[[6]]))))) + - split_constructor <- cppFunctionClass$new(name = name, + + split_constructor <- cppFunctionClass$new(name = aux$bodyName, args = split_ctor_symTab, code = cppCodeBlockClass$new( code = nParse(quote({})), @@ -274,18 +292,28 @@ cppParallelReduceBodyClass_init_impl <- function(cppDef, ## join_symTab is the symbolTable for the arguments to join join_symTab <- symbolTableClass$new() join_symTab$addSymbol(cppVarFullClass$new(name = 'target', - baseType = name, + baseType = aux$bodyName, ref = TRUE, const = TRUE)) + ## make the reduce code - reduce_op <- exprClass$new(name = loop_body$args[[2]]$name, isCall = TRUE, - isName = FALSE, isAssign = FALSE, + ## `aux` needed so that user-defined reduction functions will be replaced with `cpp_code_name`. + if(loop_body$args[[2]]$name == 'chainedCall') { + reduce_op <- copyExprClass(loop_body$args[[2]]) + inc <- 1 + } else { + reduce_op <- exprClass$new(name = loop_body$args[[2]]$name, aux = loop_body$args[[2]]$aux, + isCall = TRUE, isName = FALSE, isAssign = FALSE, isLiteral = FALSE) - setArg(reduce_op, 1, copyExprClass(value_expr)) - setArg(reduce_op, 2, nParse(paste0('cppLiteral("target.', value_name, ';")'))) + inc <- 0 + } + setArg(reduce_op, 1+inc, copyExprClass(value_expr)) + setArg(reduce_op, 2+inc, nParse(paste0('cppLiteral("target.', value_name, '")'))) join_code <- newAssignmentExpression() setArg(join_code, 1, copyExprClass(value_expr)) setArg(join_code, 2, reduce_op) + ## Put code in {} so handled by full processing later, in particular adding ending `;`. + join_code <- newBracketExpr(list(join_code)) ## create the join cppFunctionClass definition join_body <- cppCodeBlockClass$new(code = join_code, ## TODO: any symbols ever needed? @@ -301,3 +329,5 @@ cppParallelReduceBodyClass_init_impl <- function(cppDef, join = join)) invisible(NULL) } + + diff --git a/nCompiler/R/cppDefs_core.R b/nCompiler/R/cppDefs_core.R index 44197c07..c203eea6 100644 --- a/nCompiler/R/cppDefs_core.R +++ b/nCompiler/R/cppDefs_core.R @@ -348,7 +348,7 @@ addGenericInterface_impl <- function(self) { for(mName in methodNames) { if(mName %in% outputMethodNames) next if(useIM && !(mName %in% interfaceMembers)) next - NFint <- NFinternals(current_NCgen$public_methods[[mName]]) + NFint <- NFinternals(NC_get_Cpub_class(current_NCgen)$public_methods[[mName]]) NFcompInfo <- NFint$compileInfo if(!useIM && !isTRUE(NFcompInfo$callFromR)) next if(isTRUE(NFcompInfo$destructor)) next diff --git a/nCompiler/R/cppDefs_nClass.R b/nCompiler/R/cppDefs_nClass.R index 84929f01..60c987c8 100644 --- a/nCompiler/R/cppDefs_nClass.R +++ b/nCompiler/R/cppDefs_nClass.R @@ -11,13 +11,13 @@ nClassBaseClass_init_impl <- function(cppDef) { cppDef$Hpreamble <- pluginIncludes cppDef$Hpreamble <- c(cppDef$Hpreamble, "#define NCOMPILER_USES_EIGEN", - "// #define NCOMPILER_USES_TBB", + "#define NCOMPILER_USES_TBB", "#define NCOMPILER_USES_NLIST", "#define USES_NCOMPILER") cppDef$CPPpreamble <- pluginIncludes cppDef$CPPpreamble <- c(cppDef$CPPpreamble, "#define NCOMPILER_USES_EIGEN", - "// #define NCOMPILER_USES_TBB", + "#define NCOMPILER_USES_TBB", "#define NCOMPILER_USES_NLIST", "#define USES_NCOMPILER") @@ -222,7 +222,7 @@ cpp_nClassClass <- R6::R6Class( buildParallelClassDefs() }, buildFunctionDefs = function() { - message("To-do: Care needed to filter interfaced methods by exportMembers names.") + # message("To-do: Care needed to filter interfaced methods by exportMembers names.") for(i in seq_along(Compiler$NFcompilers)) { RCname <- names(Compiler$NFcompilers)[i] thisNFcomp <- Compiler$NFcompilers[[RCname]] @@ -236,16 +236,15 @@ cpp_nClassClass <- R6::R6Class( buildParallelClassDefs = function() { for(i in seq_along(Compiler$NFcompilers)) { parallelContent <- Compiler$NFcompilers[[i]]$auxEnv$parallelContent - if(!is.null(parallelContent)) { - for(j in seq_along(parallelContent)) { - cppDef_TBB <- cppParallelBodyClass$new(loop_body = parallelContent[[j]]$args[[3]], + if(length(parallelContent)) { + for(j in seq_along(parallelContent)) { + cppDef_TBB <- cppParallelBodyClass$new(loop_body = parallelContent[[j]]$args[[3]], loop_var = parallelContent[[j]]$args[[1]], symbolTable = memberCppDefs[[i]]$code$symbolTable, copyVars = parallelContent[[j]]$args[[4]], - noncopyVars = parallelContent[[j]]$args[[5]]) - ## The name is hard-wired expecting only a single case of parallel content. - ## TO-DO: generalize the name with unique identifier. - self$memberCppDefs[["parallel_loop_body"]] <<- cppDef_TBB + noncopyVars = parallelContent[[j]]$args[[5]], + aux = parallelContent[[j]]$aux) + self$memberCppDefs[[parallelContent[[j]]$aux$bodyName]] <<- cppDef_TBB } } parallelReduceContent <- Compiler$NFcompilers[[i]]$auxEnv$parallelReduceContent @@ -260,12 +259,11 @@ cpp_nClassClass <- R6::R6Class( loop_var = parallelReduceContent[[j]]$args[[1]], symbolTable = memberCppDefs[[i]]$code$symbolTable, copyVars = list(), - noncopyVars = list(parallelReduceContent[[j]]$args[[4]], - parallelReduceContent[[j]]$args[[5]]) - ) - ## The name is hard-wired expecting only a single case of parallel content. - ## TO-DO: generalize the name with unique identifier. - self$memberCppDefs[["parallel_reduce_body"]] <<- cppDef_TBB + noncopyVars = as.list(c(parallelReduceContent[[j]]$args[[4]], + parallelReduceContent[[j]]$args[[5]], + parallelReduceContent[[j]]$args[[6]])), + aux = parallelReduceContent[[j]]$aux) + self$memberCppDefs[[parallelReduceContent[[j]]$aux$bodyName]] <<- cppDef_TBB } } } diff --git a/nCompiler/R/cppDefs_nFunction.R b/nCompiler/R/cppDefs_nFunction.R index 7220c625..6bd56703 100644 --- a/nCompiler/R/cppDefs_nFunction.R +++ b/nCompiler/R/cppDefs_nFunction.R @@ -8,7 +8,7 @@ cpp_nFunctionClass_init_impl <- function(cppDef) { cppDef$Hpreamble <- pluginIncludes cppDef$Hpreamble <- c(cppDef$Hpreamble, "#define NCOMPILER_USES_EIGEN", - "// #define NCOMPILER_USES_TBB", + "#define NCOMPILER_USES_TBB", "#define NCOMPILER_USES_NLIST", "#define USES_NCOMPILER") ## handler nList in labelAbstractTypes does record in auxEnv if an @@ -19,7 +19,7 @@ cpp_nFunctionClass_init_impl <- function(cppDef) { cppDef$CPPpreamble <- pluginIncludes cppDef$CPPpreamble <- c(cppDef$CPPpreamble, "#define NCOMPILER_USES_EIGEN", - "// #define NCOMPILER_USES_TBB", + "#define NCOMPILER_USES_TBB", "#define NCOMPILER_USES_NLIST", "#define USES_NCOMPILER") cppDef$Hincludes <- c(cppDef$Hincludes)#, @@ -75,7 +75,7 @@ cpp_nFunctionClass <- R6::R6Class( SEXPwrapperCname = character(), NF_Compiler = NULL, initialize = function(...) { - ## conflicting protocols:.nCompiler inserts #include later + ## conflicting protocols: nCompiler inserts #include later ## inline/Rcpp plugins do not, so we strip them out here ## so that they can be inserted later. cpp_nFunctionClass_init_impl(self) diff --git a/nCompiler/R/nCompile.R b/nCompiler/R/nCompile.R index ac85b41e..cf4d3d54 100644 --- a/nCompiler/R/nCompile.R +++ b/nCompiler/R/nCompile.R @@ -31,10 +31,50 @@ cppFileLabelFunction <- labelFunctionCreator('nCompiler_units') # The cppDef$name is same as name (and NFinternals$cpp_code_name). # - That becomes the name in C++ code. # - In nCompile, the cpp_name for that unitResult is the cpp_code_name +# +# Addendum: +# exportNames are names exported from sourceCpp, i.e.from Rcpp::export labeling. +#. returnNames are the names returned to the user from nCompile. +# +# compiled generator names when going through writePackage: +# This is a subtle issue. +#. If a user has written an nClass with an inherit argument for another nClass, +#. we *must* preserve the name of the base class so that it will be found by +#. the derived class by the name used when programming them. Since we don't know +#. where or when inheritance might be done, that means we should preserve all original names. +# +#. However, from the input to nCompile or writePackage, we don't know those names. +# We only know the intended *returnNames*. In some cases (and when parsed from unnamed inputs), +# those may match the original generator object name. +# +# There is also a different need for writePackage called directly vs nCompile with package=TRUE. +# +#. For nCompile with package=TRUE, the user should give returnName matching generator name +#. (or let that happen by not providing a name). Then the uncompiled generator in the +# written package code will have the correct name for inheritance, and the same name +#. can be used for the list element of the compiled generator returned to the user. +#. (If there is no nClass inheritance, the user can safely change the returnName.) +# +# However, for writePackage called directly, that scheme will not work. We *must* +#. preserve the original uncompiled generator name (for any inherts) and we must have a distinct +#. object name for the compiled generator. +# To do that we use compileInfo$classname. A default value of which (if needed) is +# created by the original NC by appending "_compiled". +# +# In internal code, the uncompiled generator name will be uncomp_gen_name +#. and the compiled generator name will be comp_gen_name. +# +# Although the compiled_name is strictly only necessary for writePackage called directly, +# we will support and use it also for nCompile with package=TRUE so that that can be used +# for development and testing with the expectation that it mirrors what writePackage does. +# +# There are somewhat corresponding issues of the `classname` arguments (aka tags) +# that are appended on the `class` attribute. For an nClass "nc", we will make +# a base class with `classname="nc"`; the compiled class will get this by `inherits` +# and also `classname="nc_compiled"`. S3 dispatch like `print.nc` will catch both compiled +# and uncompiled. One can also use the isCompiled() method. #' @export - - get_nCompile_types <- function(units) { ans <- character(length(units)) for(i in seq_along(units)) { @@ -113,22 +153,31 @@ nCompile_prepare_units <- function(..., # package = FALSE, # returnList = FALSE ) { - #(1) Put together inputs from ... + #(1) Put together inputs from ... # cat("starting nCompile\n") + # dotsDeparses is used to get default names for unnamed inputs. dotsDeparses <- unlist(lapply( substitute(list(...))[-1], deparse )) + # origList can have several kinds of elements: + # nc = nc_generator + # nf = nFunction + # not_used = list(nc1 = nc1, nf1 = nf2, etc) (in which case the name of the list isn't used) + origList <- list(...) if(is.null(names(origList))) names(origList) <- rep('', length(origList)) boolNoName <- names(origList)=='' origIsList <- unlist(lapply(origList, is.list)) + dotsDeparses[origIsList] <- '' + names(origList)[boolNoName & !origIsList] <- "NO_NAME_PROVIDED" 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.") + if(is.null(names(origList[[i]]))) + names(origList[[i]]) <- rep('', length(origList[[i]])) } - dotsDeparses[origIsList] <- '' - names(origList)[boolNoName] <- dotsDeparses[boolNoName] # This puts default names from deparsing ... entries into list + dotsDeparse_boolNoName_before_c <- dotsDeparses[boolNoName & !origIsList] # This puts default names from deparsing ... entries into list # for `nCompile(A = foo, foo2))`, names(units) will be c("A", "foo2") units <- do.call('c', origList) + boolNoName <- names(units)=='NO_NAME_PROVIDED' | names(units)=='' + names(units)[names(units)=='NO_NAME_PROVIDED'] <- dotsDeparse_boolNoName_before_c inputNamesInfo <- list(names = names(units), boolNameProvided = !boolNoName) @@ -164,6 +213,8 @@ nCompile_prepare_units <- function(..., # We defer processing of nClass inheritance until compile time to allow nClass # to be called with inherit = some_nClass before some_nClass is defined. + # Note that each step must be done for all units before the next step is done + # for all units. for(i in seq_along(units)) { if(unitTypes[i] == "nCgen") NCinternals(units[[i]])$connect_inherit() @@ -176,7 +227,69 @@ nCompile_prepare_units <- function(..., if(unitTypes[i] == "nCgen") NC_check_inheritance(units[[i]]) } - # set up exportNames and returnNames + # set up exportNames, returnNames, and packageNames + # exportNames: These appear in C++ as [[Rcpp::export(exportName = )]]. + # Thus they give the name of the R function that will call the C++ version of the nFunction or nClass generator function. + # returnNames: These are the names used in the list returned from nCompile. + # packageNames: Each element is a vector of two names. The first is the + # uncompiled generator name in pacakge code. The second is the + # compiled generator name in package code. + # If there is inheritance, the uncompiled generator name should be the one + # used for inheritance by derived classes. + # + # Note that we have retained information from the inputs (... or list) on + # (i) whether a name was affirmatively provided (name = unit) and + #. (ii) what a default name from deparsing the ... would be. + #. with the possibility that the default name is "" if the input was from an unnamed list element. + # + # The naming decisions are as follows: + # exportName defaults to compileInfo$exportName, if provided. + # returnName defaults to name from inputs, if affirmatively provided. + # packageNames defaults to compileInfo$packageNames, if provided, + # normalized as first element "uncompiled", second element "compiled". + # (Note: compileInfo$packageNames$uncompiled will have already defaulted to classname + # if classname was provided in the call to nClass.) + # [nFunction case:] packageNames$compiled next defaults to exportName. + # returnName next defaults to packageNames$compiled, if provided (or just set in nFunction case) + # returnName next defaults to default name from inputs (deparsed from ...), if available. + # exportName next defaults to returnName, if provided. + # returnName next defaults to exportName, if provided. + # [nClass case:] exportName and returnName next default to the classname + # [nFunction case:] exportName defaults to NFinternals -> cpp_code_name; + # returnName defaults to name in NFinternals -> name + # [next four steps will only matter in nClass case, + #. because packageNames$compiled is now set for nFunction case] + # If neither part of packageNames is provided, + #. packageNames$compiled defaults to returnName. + # If we have only packageNames$compiled (provided, or defaulting to returnName) + #. packageNames$uncompiled next defaults to the deparsed ... name, if available, otherwise returnName, if distinct, + #. otherwise paste0(packageNames$compiled, "_uncompiled") + #. THIS DEFAULT is natural for simple cases but COULD BREAK inherits arguments. + #. Hence we may want to error-trap on this later. + # If only packageNames$uncompiled is provided: + # packageNames$compiled next defaults to returnName + # If packageNames$compiled and packageNames$uncompiled match (even possibly by faulty user input) + #. append "_compiled" to packageNames$compiled + # This may be then hard to find if unexpected by the user, but they need to give better input. + # + # [nClass case:] If exportName matches either packageNames element: + #. if interface=="full", exportName gets "_new" appended. + # Otherwise the conflicting name gets "_compiled" or "_uncompiled" appended + # + # Examples: + # (1) if no compileInfo$exportName or compileInfo$packageNames is provided, + # then exportName and returnName will both be the name from the input list (or deparsed name), + # and exportName will get "_new" appended if interface=="full". + # + # (2) if compileInfo$packageNames is provided and the input is an unnamed list, + # + # For nFunctions: + # Most of the naming decisions are the same as for nClasses. + # Key difference: the exportName and packageNames$compiled are redunant. + #. Whatever is exported from Rcpp is directly the function in R to call that C++ function. + # Hence the separate steps above + # + # DEPRECATED COMMENTS TO REMOVE WHEN CLEANING UP # exportNames will be from names(units) if named in the call or there is no exportName in the NF or NC compileInfo # Otherwise (i.e. no name provided in call and there is an exportName in the object def), use the exportName in the object def (compileInfo) # @@ -185,49 +298,114 @@ nCompile_prepare_units <- function(..., # returned name for the nClass generator. # e.g. for nc1, exportName will be new_nc1 but returnName will be nc1. returnNames <- exportNames <- vector("character", length(units)) + packageNames <- vector("list", length(units)) compileInfos <- structure(vector("list", length(units)), names = names(units)) for(i in seq_along(units)) { - add_new_prefix <- FALSE if(unitTypes[i] == "nF" || unitTypes[i] == "nF_noExport") { compileInfo <- NFinternals(units[[i]])$compileInfo + case <- "NF" } else { compileInfo <- NCinternals(units[[i]])$compileInfo + case <- "NC" if(interfaces[[i]] == "") 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_prefix <- TRUE } - # If a name was provided directly in the ... list - # OR if no exportName was provided in the nClass call's compileInfo, - # then use the name from the ... list (inferred or provided). - # Otherwise use the exportName from the nClass call's compileInfo. - if(isTRUE(inputNamesInfo$boolNameProvided[i]) || - is.null(compileInfo$exportName)) - exportNames[i] <- inputNamesInfo$names[i] - else - exportNames[i] <- compileInfo$exportName - 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_prefix) # this could happen by setting just above or by choice of provided compileInfo$exportName - exportNames[i] <- paste0("new_", exportNames[i]) + + if(!is.null(compileInfo$exportName)) exportNames[i] <- compileInfo$exportName + if(isTRUE(inputNamesInfo$boolNameProvided[i])) returnNames[i] <- inputNamesInfo$names[i] + if(!is.null(compileInfo$packageNames)) packageNames[[i]] <- compileInfo$packageNames + if(is.null(packageNames[[i]])) packageNames[[i]] <- c(uncompiled = "", compiled = "") + # Note other packageNames normalization is done in NC_InternalsClass$initialize + # and if a classname was provided, the packageNames$uncompiled defaults to that classname + # We do some normalization here because a user could have modified the compileInfo$packageNames + # manually and left one or other element empty. + if(is.na(packageNames[[i]]["compiled"])) packageNames[[i]]["compiled"] <- "" + if(is.na(packageNames[[i]]["uncompiled"])) packageNames[[i]]["uncompiled"] <- "" + packageNames[[i]] <- packageNames[[i]][c("uncompiled", "compiled")] + + if(case == "NF") + if(packageNames[[i]]["compiled"] == "" && exportNames[i] != "") + packageNames[[i]]["compiled"] <- exportNames[i] + + # Further "it just works" handling of packageNames can be provided. + # For now it should have named elements "uncompiled" and "compiled". + if(returnNames[i] == "") + if(packageNames[[i]]["compiled"] != "") + returnNames[i] <- packageNames[[i]]["compiled"] + if(returnNames[i] == "") + if(inputNamesInfo$names[i] != "") + returnNames[i] <- inputNamesInfo$names[i] + if(exportNames[i] == "") exportNames[i] <- returnNames[i] + if(returnNames[i] == "") returnNames[i] <- exportNames[i] + if(returnNames[i] == "" && exportNames[i] == "") + if(case == "NC") + returnNames[i] <- exportNames[i] <- NCinternals(units[[i]])$classname + else if(case == "NF") { + exportNames[i] <- NFinternals(units[[i]])$cpp_code_name + returnNames[i] <- NFinternals(units[[i]])$name + } + + if(case == "NC") { + # First three of these steps should never be relevant for an nFunction anyway, + # but it is clearer to but them within this if + # neither part of packageNames provided + if(packageNames[[i]]["compiled"] == "" && packageNames[[i]]["uncompiled"] == "") + packageNames[[i]]["compiled"] <- returnNames[i] + # packageNames$compiled only (provided or just set to default returnName) + if(packageNames[[i]]["uncompiled"] == "" && packageNames[[i]]["compiled"] != "") { + if(inputNamesInfo$names[i] != "") packageNames[[i]]["uncompiled"] <- inputNamesInfo$names[i] + else packageNames[[i]]["uncompiled"] <- returnNames[i] + # if packageNames now match, disambiguate by changing uncompiled name + if(packageNames[[i]]["uncompiled"] == packageNames[[i]]["compiled"]) + packageNames[[i]]["uncompiled"] <- paste0(packageNames[[i]]["compiled"], "_uncompiled") + # Any class inheriting from this class will likely not find it if we are in this + # case of default handling. The user must provide packageNames to fix this. + } + # packageNames$uncompiled only provided) + if(packageNames[[i]]["compiled"] == "" && packageNames[[i]]["uncompiled"] != "") { + packageNames[[i]]["compiled"] <- returnNames[i] + } + + if(packageNames[[i]]["compiled"] == packageNames[[i]]["uncompiled"]) + packageNames[[i]]["compiled"] <- paste0(packageNames[[i]]["uncompiled"], "_compiled") + + if(exportNames[i] %in% packageNames[[i]]) { + if(interfaces[i] == "full") { + exportNames[i] <- paste0(exportNames[i], "_new") + } else { + if(exportNames[i] == packageNames[[i]]["compiled"]) + packageNames[[i]]["compiled"] <- paste0(packageNames[[i]]["compiled"], "_compiled") + else if(exportNames[i] == packageNames[[i]]["uncompiled"]) + packageNames[[i]]["uncompiled"] <- paste0(packageNames[[i]]["uncompiled"], "_uncompiled") + ## DANGER! With interface != "full", the exportName gets dominance because that will be the + ## generator function for generic C++ objects. This means the uncompiled name must be changed + ##. if it clashes, and this means any inherits or usage of the name will fail. + ## Error-trapping this cleanly can't be done (easily) right here because its a question of whether this is + ##. used anywhere by other code being compiled. + } + } + } + + if(names(units)[i] == "") names(units)[i] <- returnNames[i] # In some cases this is the first addition of an exportName to a compileInfo compileInfo$exportName <- exportNames[i] compileInfo$interface <- interfaces[[i]] + compileInfo$packageNames <- packageNames[[i]] compileInfos[[i]] <- compileInfo } -list(units = units, + list(units = units, unitTypes = unitTypes, interfaces = interfaces, compileInfos = compileInfos, exportNames = exportNames, - returnNames = returnNames) + returnNames = returnNames, + packageNames = packageNames) } - #' @export nCompile <- function(..., dir = file.path(tempdir(), 'nCompiler_generatedCode'), @@ -253,8 +431,9 @@ nCompile <- function(..., 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 + new_exportNames <- unit_info$exportNames # names for Rcpp::export[[exportName = fnName]] + new_returnNames <- unit_info$returnNames # names for returning to user from nCompile + new_packageNames <- unit_info$packageNames # if package = TRUE, call package steps either with units or original ... (above) # after packing up control list (e.g. from interfaces) @@ -267,6 +446,7 @@ nCompile <- function(..., compileInfos <- list() exportNames <- character() returnNames <- character() + packageNames <- list() cppDefs <- list() cpp_names <- character() auto_included <- rep(FALSE, length(new_units)) @@ -285,6 +465,7 @@ nCompile <- function(..., compileInfos <- c(compileInfos, new_compileInfos) exportNames <- c(exportNames, new_exportNames) returnNames <- c(returnNames, new_returnNames) + packageNames <- c(packageNames, new_packageNames) cppDefs <- c(cppDefs, new_cppDefs) cpp_names <- c(cpp_names, new_cpp_names) @@ -324,6 +505,7 @@ nCompile <- function(..., new_compileInfos <- new_unit_info$compileInfos new_exportNames <- new_unit_info$exportNames new_returnNames <- new_unit_info$returnNames + new_packageNames <- new_unit_info$packageNames auto_included <- c(auto_included, rep(TRUE, length(new_units))) new_compileInfos <- new_compileInfos |> lapply(\(x) {x$auto_included <- TRUE; x}) } else { @@ -352,7 +534,8 @@ nCompile <- function(..., createFromR = createFromR, cppDefs = cppDefs, exportNames = exportNames, - returnNames = returnNames + returnNames = returnNames, + packageNames = packageNames ) } @@ -385,6 +568,8 @@ nCompile <- function(..., memberData = list(), roxygen = list() ) + if(isTRUE(get_nOption('pause_after_writing_files'))) + browser() lib <- file.path(tempdir(), "templib") if(!dir.exists(lib)) dir.create(lib, recursive=TRUE) pkgDir <- file.path(dir, temppkgname) @@ -398,8 +583,18 @@ nCompile <- function(..., withr::with_libpaths(lib, action="prefix", code = loadNamespace(temppkgname)) }) + pkgNames <- returnNames + pc <- controlFull$prepared_content + for(i in seq_along(pc$units)) { + if(pc$unitTypes[[i]] == "nCgen") { + if(pc$interfaces[[i]] == "full") + pkgNames[i] <- pc$packageNames[[i]][["compiled"]] + else + pkgNames[i] <- pc$exportNames[i] + } + } pkgEnv <- getNamespace(temppkgname) - ans_ <- lapply(returnNames, function(x) { + ans_ <- lapply(pkgNames, function(x) { if(exists(x, envir = pkgEnv, inherits=FALSE)) #might not exist for interface="none" get(x, envir = pkgEnv, inherits=FALSE) else NULL @@ -462,13 +657,13 @@ writePackage <- function(..., if(modify == "clear") { # Always initialize initializePkg <- TRUE } else { - if (dir.exists(pkgDir)) { - if (modify == "no") stop(paste0("Package ", pkgName, " already exists in directory ", dir, - ". Change 'modify' argument 'add' (to add to it) or 'clear' ", - " (to erase it before writing). Use erasePackage to erase it as a separate step.")) - } else { - initializePkg <- TRUE # Initialize is modify != "clear" but no package exists yet - } + if (dir.exists(pkgDir)) { + if (modify == "no") stop(paste0("Package ", pkgName, " already exists in directory ", dir, + ". Change 'modify' argument 'add' (to add to it) or 'clear' ", + " (to erase it before writing). Use erasePackage to erase it as a separate step.")) + } else { + initializePkg <- TRUE # Initialize is modify != "clear" but no package exists yet + } } if(grepl("_", pkgName)) stop("Package names are not allowed to have underscore characters.") @@ -505,6 +700,7 @@ writePackage <- function(..., cppDefs <- content$cppDefs exportNames <- content$exportNames returnNames <- content$returnNames + packageNames <- content$packageNames # Handle roxygen input if (!is.list(roxygen)) { if (is.character(roxygen)) roxygen <- list(roxygen) @@ -520,7 +716,6 @@ writePackage <- function(..., stop("If fewer roxygen entries are provided than objects, they must be named", " in the input list to indicate the objects to which they correspond.") } - message("set up thorough control and unitControls handling. include $export field") # pkgDir <- file.path(dir, pkgName) Rdir <- file.path(pkgDir, "R") srcDir <- file.path(pkgDir, "src") @@ -531,7 +726,8 @@ writePackage <- function(..., # cat("starting writePackage writing steps\n") WP_check_unit_types(units, unitTypes) cppDefs <- WP_add_roxygen_fxns_to_cppDefs(cppDefs, units, unitTypes, roxygen, roxygenFlag) - full_interfaces <- WP_build_full_interfaces(units, unitTypes, interfaces, exportNames) + CnCgenerator_codes <- WP_build_CnCgenerators(units, unitTypes, interfaces, exportNames, + returnNames, packageNames) methodFns <- WP_build_methodFns(units, unitTypes, interfaces) # if (initializePkg) @@ -545,10 +741,11 @@ writePackage <- function(..., ## Rcpp's Rcpp::interfaces attribute for C++ that provides some automated inst/include ## generation of R interface functions. WP_writeCpp(RcppPacket_list, srcDir, codeDir) - WP_writeRinterfaces(units, unitTypes, interfaces, returnNames, - Rdir, full_interfaces, methodFns, roxygen, roxygenFlag) + WP_writeRinterfaces(units, unitTypes, interfaces, returnNames, packageNames, + Rdir, CnCgenerator_codes, methodFns, roxygen, roxygenFlag) WP_writeMemberData(memberData, datDir) - WP_write_dotOnLoad(exportNames, returnNames, unitTypes, interfaces, createFromR, Rdir) + WP_write_dotOnLoad(units, unitTypes, interfaces, exportNames, returnNames, packageNames, + createFromR, Rdir) WP_write_DESCRIPTION_NAMESPACE(units, unitTypes, interfaces, createFromR, returnNames, initializePkg, pkgDir, pkgName) ## if (!initializePkg) { @@ -642,63 +839,53 @@ nCompile_finish_nonpackage <- function(units, env = resultEnv, packetList = TRUE, returnList = TRUE) - # unit_is_nClass <- unitTypes=="nCgen" - # num_nClasses <- sum(unit_is_nClass) if(!(length(units)==length(compileInfos))) stop("Problem while post-processing nCompile results.") - R6interfaces <- vector(mode="list", length = length(units) ) # will remain null for nFunctions methodFns <- vector(mode="list", length = length(units) ) # ditto + createFromR_funs <- vector(mode="list", length = length(units) ) exportNames <- unlist(lapply(compileInfos, function(x) x$exportName)) expect_nC_interface <- rep(FALSE, length(units)) expect_createFromR <- rep(FALSE, length(units)) interfaceTypes <- compileInfos |> lapply(\(x) if(is.null(x$interface)) NA else x$interface ) |> unlist() # can replace some code below using this - # if(num_nClasses > 0) { - for(i in seq_along(units)) { - iRes <- which( exportNames[i] == names(compiledFuns)) - ## 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 - } + for(i in seq_along(units)) { + iRes <- which( exportNames[i] == names(compiledFuns)) + if(unitTypes[i] == "nCgen") { #unit_is_nClass[i]) { + expect_nC_interface[i] <- isTRUE(interfaceTypes[i] %in% c("full", "generic")) + expect_createFromR[i] <- !isFALSE(compileInfos[[i]]$createFromR) && + expect_nC_interface[i] ## Currently one can't create objects without interface support + 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_funs[[i]] <- compiledFuns[[iRes]] + 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) + } } - # } - names(R6interfaces) <- returnNames -# names(R6interfaces) <- exportNames # used for next step, then set to returnNames + } + CnCgenerators <- build_compiled_nClasses(units, + unitTypes, + interfaceTypes, + exportNames, + returnNames, + createFromR_funs, + package=FALSE) + names(CnCgenerators) <- returnNames if(any(unitTypes == "nCgen")) { newDLLenv <- make_DLLenv() @@ -707,7 +894,7 @@ nCompile_finish_nonpackage <- function(units, compiledFuns <- setup_nClass_environments(compiledFuns, newDLLenv, exportNames = exportNames[expect_nC_interface], - R6interfaces = R6interfaces[expect_nC_interface], + NCgenerators = CnCgenerators[expect_nC_interface], methodFns = methodFns[expect_nC_interface], interfaceTypes = interfaceTypes[expect_nC_interface], returnList = TRUE) @@ -719,7 +906,7 @@ 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)) @@ -755,7 +942,7 @@ nCompile_finish_nonpackage <- function(units, interfaceType <- "full" if(interfaceType == "full") { if(expect_createFromR[i]) - ans[[i]] <- R6interfaces[[returnNames[i] ]] + ans[[i]] <- CnCgenerators[[returnNames[i] ]] } else if(interfaceType == "generic") { if(expect_createFromR[i]) ans[[i]] <- compiledFuns[[iRes]] @@ -821,18 +1008,17 @@ WP_add_roxygen_fxns_to_cppDefs <- function(cppDefs, cppDefs } -WP_build_full_interfaces <- function(units, unitTypes, interfaces, exportNames) { - full_interfaces <- vector("list", length = length(units)) - for(i in seq_along(units)) { - if(unitTypes[i]=="nCgen") { - if(isTRUE(interfaces[[i]]%in%c("full", "generic"))) { - full_interfaces[[i]] <- build_compiled_nClass(NCgenerator = units[[i]], - newCobjFun = exportNames[i], - quoted = TRUE) - } - } - } - full_interfaces +WP_build_CnCgenerators <- function(units, unitTypes, interfaces, exportNames, + returnNames, packageNames) { + CnCgenerator_codes <- build_compiled_nClasses(units = units, + unitTypes = unitTypes, + interfaces = interfaces, + exportNames = exportNames, + returnNames = returnNames, + newCobjFuns = exportNames, + package=TRUE, + packageNames = packageNames) + CnCgenerator_codes } WP_build_methodFns <- function(units, unitTypes, interfaces) { @@ -895,27 +1081,55 @@ WP_writeCpp <- function(RcppPacket_list, srcDir, codeDir) { } } -WP_writeRinterfaces <- function(units, unitTypes, interfaces, returnNames, - Rdir, full_interfaces, methodFns, roxygen, roxygenFlag) { +WP_writeRinterfaces <- function(units, unitTypes, interfaces, returnNames, packageNames, + Rdir, CnCgenerator_codes, methodFns, roxygen, roxygenFlag) { Rfilepath <- vector("character", length(units)) for (i in seq_along(units)) { if ((unitTypes[i]=='nCgen') && isTRUE(interfaces[[i]]!="none")) { ## Write the nClass full interface to the package's R directory - if(interfaces[[i]] == "full") - generator_name <- returnNames[i] # note this may differ from the name in input list - else - generator_name <- paste0(".", returnNames[i], "_R6interface") + generator_name <- packageNames[[i]]["uncompiled"] # must be unchanged in case inherited + NCI <- NCinternals(units[[i]]) + compiled_generator_name <- packageNames[[i]]["compiled"] + # if(interfaces[[i]] == "full") + # generator_name <- returnNames[i] # note this may differ from the name in input list + # else + # generator_name <- paste0(".", returnNames[i], "_CnCgenerator") Rfile <- paste0(returnNames[i], '.R') Rfilepath[i] <- file.path(Rdir, Rfile) con <- file(Rfilepath[i], open = 'w') - if(is.null(full_interfaces[[i]])) { # likely a problem, but we'll try to proceed + on.exit(close(con)) + if(is.null(CnCgenerator_codes[[i]])) { # likely a problem, but we'll try to proceed warning("In writePackage: R6 interface code for ", returnNames[i], " missing.") - deparsed_full_interface <- "NULL" + deparsed_CnCgenerator <- "NULL" } else { - deparsed_full_interface <- deparse(full_interfaces[[i]]) - deparsed_full_interface[1] <- paste0( - generator_name, ' <- ', deparsed_full_interface[1] + deparsed_CnCgenerator <- CnCgenerator_codes[[i]]$CncGen_code |> deparse() + deparsed_CnCgenerator[1] <- paste0( + compiled_generator_name, ' <- ', deparsed_CnCgenerator[1] ) + deparsed_Cpub_comp <- CnCgenerator_codes[[i]]$Cpub_comp_code |> deparse() + deparsed_Cpub_comp[1] <- paste0( + compiled_generator_name, '_CpubGen <- ', deparsed_Cpub_comp[1] + ) + + inherit_obj <- units[[i]] # NCgenerator from which the CncGen_code will inherit + NCI_inherit <- NCinternals(inherit_obj) + + # deparsed_main_class <- NCI_inherit$main_class_code |> deparse() + RpublicMethodNames <- NCI_inherit$RpublicNames[ + NCI_inherit$RpublicNames %in% names(units[[i]]$public_methods)] + RpublicFieldNames <- NCI_inherit$RpublicNames[ + NCI_inherit$RpublicNames %in% names(units[[i]]$public_fields)] + #N.B: Cpublic fields are build from NCI_inherit$fieldNames. + deparsed_main_class <- make_nClass_code( + internals = NCI_inherit, + Cpublic = units[[i]]$public_methods[NCI_inherit$methodNames], + Rpublic = c(units[[i]]$public_methods[RpublicMethodNames], + units[[i]]$public_fields[RpublicFieldNames]) + ) |> deparse() + deparsed_main_class[1] <- paste0( + generator_name, ' <- ', deparsed_main_class[1] + ) + exportTag <- "#' @export\n" #if (totalControl[[i]]$export) "#' @export\n" else NULL # Retrieve roxygen entry thisRox <- switch(roxygenFlag, @@ -927,27 +1141,29 @@ WP_writeRinterfaces <- function(units, unitTypes, interfaces, returnNames, # Find the spot where each documented method is defined for (m in 1:length(thisRox$methods)) { thisDefn <- grep(paste0(names(thisRox$methods)[m], " = function("), - deparsed_full_interface, fixed = TRUE) - targetStr <- deparsed_full_interface[thisDefn] - deparsed_full_interface[thisDefn] <- + deparsed_CnCgenerator, fixed = TRUE) + targetStr <- deparsed_CnCgenerator[thisDefn] + deparsed_CnCgenerator[thisDefn] <- gsub(pattern = names(thisRox$methods)[m], replacement = paste0( "\n", thisRox$methods[m], "\n", names(thisRox$methods)[m] ), - x = deparsed_full_interface[thisDefn], + x = deparsed_CnCgenerator[thisDefn], fixed = TRUE) } } - deparsed_full_interface <- c( + all_class_output <- c( '## Generated by nCompiler::writePackage() -> do not edit by hand\n', + deparsed_main_class, + deparsed_Cpub_comp, if (is.list(thisRox)) thisRox[["header"]] else thisRox, exportTag, - deparsed_full_interface, - paste0(generator_name, '$parent_env <- new.env()'), - paste0(generator_name, '$.newCobjFun <- NULL') + deparsed_CnCgenerator ) + # .onLoad should call + # connect_nClass(envs, , , ) } - writeLines(deparsed_full_interface, con) + writeLines(all_class_output, con) ## methodFns_name <- paste0(".", returnNames[i], "_methodFns") deparsed_methodFns <- deparse(methodFns[[i]]) @@ -955,6 +1171,7 @@ WP_writeRinterfaces <- function(units, unitTypes, interfaces, returnNames, methodFns_name, ' <- ', deparsed_methodFns[1] ) writeLines(deparsed_methodFns, con) + on.exit() close(con) } } @@ -972,32 +1189,58 @@ WP_writeMemberData <- function(memberData, datDir) { } } -WP_write_dotOnLoad <- function(exportNames, returnNames, unitTypes, interfaces, createFromR, Rdir) { +WP_write_dotOnLoad <- function(units, unitTypes, interfaces, exportNames, returnNames, packageNames, + createFromR, Rdir) { expect_nC_interface <- unitTypes == "nCgen" & interfaces %in% c("full", "generic") if(!any(expect_nC_interface)) return() exportNames <- exportNames[expect_nC_interface] returnNames <- returnNames[expect_nC_interface] interfaces <- interfaces[expect_nC_interface] createFromR <- createFromR[expect_nC_interface] + packageNames <- packageNames[expect_nC_interface] # nClass_names <- unlist(lapply(objs, function(x) # if(isNCgenerator(x)) x$classname else NULL # )) - R6interfaceNames <- ifelse(interfaces == "full", - returnNames, - ifelse(interfaces == "generic", - paste0(".",returnNames,"_R6interface"), - NA)) - R6interfaceNames <- R6interfaceNames[!is.na(R6interfaceNames)] + # Get these differently than expect_nC_interface because + # we need these even if interface=="none" (but not if createFromR is FALSE), so + # we check if there is a valid compiled generator name. + CnCgeneratorNames <- packageNames |> lapply(\(x) x["compiled"]) + keep <- (!is.na(CnCgeneratorNames)) & (!CnCgeneratorNames == "") + #units |> lapply(function(x) + # if(isNCgenerator(x)) NCinternals(x)$compileInfo$classname else NULL) |> unlist() + # CnCgeneratorNames <- ifelse(interfaces == "full", + # returnNames, + # ifelse(interfaces == "generic", + # paste0(".",returnNames,"_CnCgenerator"), + # NA)) + + CnCgeneratorNames <- CnCgeneratorNames[keep] + Cpub_generator_names <- paste0(CnCgeneratorNames, '_CpubGen') + # Cpub_generator_names <- ifelse(interfaces == "full", + # paste0(returnNames, '_CpubGen'), + # ifelse(interfaces == "generic", + # paste0(".", returnNames, "_CnCgenerator_CpubGen"), + # NA)) methodFnsNames <- paste0(".", returnNames, "_methodFns") paste0cq <- function(names) { paste0("c(", paste0("\"",names,"\"", collapse = ", "), ")") } - onLoad_lines <- c(".onLoad <- function(libName, pkgName) {\n", + .NCgenerator_names <- packageNames |> lapply(\(x) x["uncompiled"]) + .NCgenerator_names <- .NCgenerator_names[keep] + # .NCgenerator_names <- ifelse(interfaces == "full", + # paste0(returnNames, "_uncompiled"), + # ifelse(interfaces == "generic", + # paste0(".", returnNames, "_CnCgenerator_uncompiled"), + # NA)) + onLoad_lines <- c(".onLoad <- function(libname, pkgname) {\n", + paste0("nCompiler::connect_nClass_envs(", CnCgeneratorNames, ",", Cpub_generator_names, + ", env = asNamespace(pkgname), .NCgenerator = ", .NCgenerator_names, ")") |> + paste(collapse = "\n"), #replace parent.frame() with the package env? paste0(" nCompiler::setup_nClass_environments_from_package(\n", " nClass_exportNames = ", paste0cq(exportNames), ",\n", " interfaceTypes = ", paste0cq(interfaces), ",\n", " createFromR = c(", paste0(createFromR, collapse=","), "),\n", - " R6interfaces = list(", paste0(R6interfaceNames, collapse=","), "),\n", + " CnCgenerators = list(", paste0(CnCgeneratorNames, collapse=","), "),\n", " methodFns = list(", paste0(methodFnsNames, collapse=","), "))\n"), "NULL}\n") writeLines(onLoad_lines, con = file.path(Rdir, "zzz.R")) @@ -1041,24 +1284,6 @@ WP_write_DESCRIPTION_NAMESPACE <- function(units, unitTypes, interfaces, createF needed <- !(new_exports %in% NAMESPACE) NAMESPACE <- c(NAMESPACE, new_exports[needed]) } - ## for (i in seq_along(units)) { - ## # if (totalControl[[i]]$export && isNCgenerator(objs[[i]])) - ## # if (totalControl[[i]]$export) { - ## if(FALSE) { - ## if (unitTypes[i]=="nF" || - ## (!(unitTypes[i]=="nF_noExport") && isTRUE(interfaces[[i]]=="full"))) { - ## # (nClass_full_interface && !(unitTypes[i]=="nF_noExport"))) { - ## # The second condition in this if is klugey and needs - ## # to be cleaned up with nClass_full_interface becomes a vector - ## # NAMESPACE <- c(NAMESPACE, paste0("export(", objNames[i], ")")) - ## NAMESPACE <- c(NAMESPACE, paste0("export(", units[[i]]$name, ")")) - ## } - ## if(unitTypes[i] == "nCgen") { - ## # NAMESPACE <- c(NAMESPACE, paste0("export(new_", objNames[i], ")")) - ## NAMESPACE <- c(NAMESPACE, paste0("export(new_", units[[i]]$classname, ")")) - ## } - ## } - ## } NAMESPACE <- unique(NAMESPACE) # double checking writeLines(NAMESPACE, con = NAMEfile) } diff --git a/nCompiler/R/nimbleModels.R b/nCompiler/R/nimbleModels.R index 173b879b..df39883a 100644 --- a/nCompiler/R/nimbleModels.R +++ b/nCompiler/R/nimbleModels.R @@ -24,7 +24,8 @@ nodeInstr_nClass <- nClass( file.path("nodeInstr_nC")), compileInfo=list(interface="full", createFromR = TRUE, - exportName = "nodeInstr_nClass" + exportName = "nodeInstr_nClass_new", + packageNames = c(uncompiled = "nodeInstr_nClass", compiled="nodeInstr_nClass_C") ) ) @@ -38,7 +39,7 @@ calcInstr_nClass <- nClass( file.path("calcInstr_nC")), compileInfo=list(interface="full", createFromR = TRUE, - # The Hincludes should be picked up automatically but I think it's not + # The Hincludes should be picked up automatically but I think it's not # because it is in the nList type and that is not being scanned for needed nClasses. # These do need to be in "" not <>, for case of nCompile(...., package=TRUE) Hincludes = '"nodeInstr_nClass_c_.h"', @@ -46,7 +47,8 @@ calcInstr_nClass <- nClass( # 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"), - exportName = "calcInstr_nClass" + exportName = "calcInstr_nClass_new", + packageNames = c(uncompiled="calcInstr_nClass", compiled="calcInstr_nClass_C") ) ) @@ -60,7 +62,8 @@ calcInstrList_nClass <- nClass( compileInfo=list(interface="full", createFromR = TRUE, Hincludes = '"calcInstr_nClass_c_.h"', - exportName = "calcInstrList_nClass", + exportName = "calcInstrList_nClass_new", + packageNames = c(uncompiled = "calcInstrList_nClass", compiled = "calcInstrList_nClass_C"), needed_units = list("calcInstr_nClass") ) ) @@ -85,7 +88,9 @@ nodeFxnBase_nClass <- nClass( file.path("nodeFxnBase_nC")), compileInfo=list(interface="full", createFromR = FALSE, - exportName = "nodeFxnBase_nClass") + exportName = "nodeFxnBase_nClass_new", + packageNames = c(uncompiled="nodeFxnBase_nClass", compiled="nodeFxnBase_nClass_C") + ) ) # nCompile(nodeFxnBase_nClass, control=list(generate_predefined=TRUE)) @@ -118,7 +123,7 @@ modelBase_nClass <- nClass( cppLiteral('Rprintf("modelBase_nClass calculate (should not see this)\\n");'); return(0)}, virtual=TRUE ) - ) + ) ), # See comment above about needing to ensure a virtual destructor predefined = quote(system.file(file.path("include","nCompiler", "predef"), package="nCompiler") |> file.path("modelBase_nC")), @@ -126,7 +131,8 @@ modelBase_nClass <- nClass( createFromR = FALSE, Hincludes = c('"nodeFxnBase_nClass_c_.h"', '"calcInstrList_nClass_c_.h"'), # do we need "" too? needed_units = list("nodeFxnBase_nClass","calcInstrList_nClass"), #do we need nodeFxnBase_nClass here too? - exportName = "modelBase_nClass" + exportName = "modelBase_nClass_new", + packageNames = c(uncompiled="modelBase_nClass", compiled="modelBase_nClass_C") ) ) @@ -147,7 +153,7 @@ nm_addModelDollarSign <- function(expr, exceptionNames = character(0)) { if(expr[[1]] == '$'){ expr[2] <- lapply(expr[2], function(listElement) nm_addModelDollarSign(listElement, exceptionNames)) return(expr) - } + } if(expr[[1]] == 'returnType') return(expr) if(length(expr) > 1) { @@ -189,8 +195,12 @@ make_node_nClass <- function(varInfo = list(), CpublicVars <- names(symbolList) |> lapply(\(x) eval(substitute(quote(T(symbolList$NAME)), list(NAME=as.name(x))))) names(CpublicVars) <- names(symbolList) + # This is a kluge to have a model field in the Cpublic_obj, + # needed for uncompiled purposes, and for compiled purposes + # we instead use references to model variables. So + # the declared type here is arbitrary. initFun <- function(){} - + if(numVars > 0) { ctorArgNames <- paste0(names(symbolList), '_') # List used when generating C++ constructor code to allow direct initializers, necessary for references. @@ -206,8 +216,10 @@ make_node_nClass <- function(varInfo = list(), # Rpublic method to set the model pointer/reference. setModel <- function(model) { - if(!isCompiled()) + if(!isCompiled()) { self$model <- model + #private$Cpublic_obj$model <- model + } else warning("setModel called on compiled object; no action taken") } @@ -232,9 +244,10 @@ make_node_nClass <- function(varInfo = list(), ) ) |> structure(names = classname), CpublicVars, + list(model = "RcppList"), methods ), - RPUBLIC = list(model = NULL, + RPUBLIC = list(#model = NULL, setModel = setModel), CLASSNAME = classname, BASECLASS = baseclass @@ -350,6 +363,7 @@ makeModel_nClass <- function(varInfo, # It is not very easy to set debug onto the initialize function, so # here is a magic flag. if(isTRUE(.GlobalEnv$.debugModelInit)) browser() + super$initialize() if(isCompiled()) self$setup_node_mgmt_from_names(self$nodeObjNames) if(!isCompiled()) { @@ -358,7 +372,7 @@ makeModel_nClass <- function(varInfo, self[[nodeObj]]$setModel(self) } } - + # First expand any provided or default sizes # To-Do possibly merge the argument sizes and defaultSizes by element. if(missing(sizes)) sizes <- self$defaultSizes @@ -372,7 +386,7 @@ makeModel_nClass <- function(varInfo, baseclass <- paste0("modelClass_<", classname, ">") # CpublicNodeFuns has elements like "node_1 = quote(nodeFxn_1())" # We provide it in Cpublic to declare C++ member variables with types. - # We also place the list itself in the class so that we can look up for uncompiled execution + # We also place the list itself in the class so that we can look up for uncompiled execution # the objects that need to be created in initialize. # If we someday make type declarations and initializations more automatic, we can avoid this duplication. ans <- substitute( @@ -390,9 +404,9 @@ makeModel_nClass <- function(varInfo, ), list(OPDEFS = opDefs, # A list of individual elements - RPUBLIC = list(initialize=initialize, + RPUBLIC = list(initialize=initialize, nodeObjNames = nodeObjNames, - nodeObjName_2_nodeIndex = nodeObjName_2_nodeIndex, + nodeObjName_2_nodeIndex = nodeObjName_2_nodeIndex, defaultSizes = sizes, defaultInits = inits, CpublicNodeFuns = CpublicNodeFuns), @@ -446,12 +460,12 @@ make_stoch_sim_line <- function(LHSrep, RHSrep) { if(is.null(sim_code)) stop("Could not find simulation ('r') function for ", BUGSdistName) RHSrep[[1]] <- sim_code # scoot all named arguments right 1 position - if(length(RHSrep) > 1) { + if(length(RHSrep) > 1) { for(i in (length(RHSrep)+1):3) { RHSrep[i] <- RHSrep[i-1] names(RHSrep)[i] <- names(RHSrep)[i-1] - } - } + } + } RHSrep[[2]] <- 1 names(RHSrep)[2] <- '' sim_line <- substitute( @@ -542,7 +556,7 @@ make_node_methods_from_declInfo <- function(declInfo) { make_node_method_nFxn("sim_one", NULL), calc_one = (function(idx) {DETERMCALC; return(invisible(0))}) |> make_node_method_nFxn("calc_one"), - calcDiff_one = (function(idx) {calc_one(idx);return(invisible(0))}) |> + calcDiff_one = (function(idx) {calc_one(idx);return(invisible(0))}) |> make_node_method_nFxn("calcDiff_one"), getLogProb_one = (function(idx) {return(0)}) |> make_node_method_nFxn("getLogProb_one") @@ -559,7 +573,7 @@ make_node_methods_from_declInfo <- function(declInfo) { make_node_method_nFxn("sim_one", NULL), calc_one = (function(idx) { STOCHCALC; return(invisible(LOGPROB)) }) |> make_node_method_nFxn("calc_one"), - calcDiff_one = (function(idx) {STOCHCALC_DIFF; LocalAns_ <- LocalNewLogProb_ - LOGPROB; + calcDiff_one = (function(idx) {STOCHCALC_DIFF; LocalAns_ <- LocalNewLogProb_ - LOGPROB; LOGPROB <- LocalNewLogProb_; return(invisible(LocalAns_))}) |> make_node_method_nFxn("calcDiff_one"), getLogProb_one = (function(idx) { return(LOGPROB) }) |> diff --git a/nCompiler/R/options.R b/nCompiler/R/options.R index 8f3cbefc..22661e9c 100644 --- a/nCompiler/R/options.R +++ b/nCompiler/R/options.R @@ -97,7 +97,7 @@ nOptions <- function(...) { invisibleReturn <- FALSE args <- list(...) if (!length(args)) { - # Get all.nCompiler options. + # Get all nCompiler options. return(as.list(.nOptions)) } if (length(args) == 1 && is.null(names(args)) && is.list(args[[1]])) { @@ -105,10 +105,10 @@ nOptions <- function(...) { args <- args[[1]] } if (is.null(names(args))) { - # Get some.nCompiler options. + # Get some nCompiler options. args <- unlist(args) } else { - # Set some.nCompiler options. + # Set some nCompiler options. for(i in seq_along(args)) { set_nOption(names(args)[[i]], args[[i]]) } diff --git a/nCompiler/R/typeDeclarations.R b/nCompiler/R/typeDeclarations.R index 6bec7b98..603ac6d4 100644 --- a/nCompiler/R/typeDeclarations.R +++ b/nCompiler/R/typeDeclarations.R @@ -287,7 +287,7 @@ typeDeclarationList <- list( nDim <- length(nDim(x)) if(!(nDim >= 0 & nDim <= 6)) - stop(paste0("Invalid number of dimensions used to declare a.nCompiler ", + stop(paste0("Invalid number of dimensions used to declare a nCompiler ", "argument. Dimensions from 0-6 are allowed."), call. = FALSE) nType(scalarType, nDim) @@ -333,14 +333,17 @@ argType2symbol <- function(argType, explicitType else argType + + if(missing(typeToUse)) + stop("Argument `", origName, "` does not have its type specified.") ## This could be restricted to inherits(typeToUse, "symbolBase") ## but "R6" allows an even wider range of flexibility. - if(inherits(typeToUse, "R6")) { - ans <- typeToUse$clone(deep=TRUE) - ans$name <- name - return(ans) - } + if(inherits(typeToUse, "R6")) { + ans <- typeToUse$clone(deep=TRUE) + ans$name <- name + return(ans) + } inputAsCharacter <- FALSE if(is.character(typeToUse)) { diff --git a/nCompiler/inst/include/.DS_Store b/nCompiler/inst/include/.DS_Store new file mode 100644 index 00000000..d96ea5ae Binary files /dev/null and b/nCompiler/inst/include/.DS_Store differ diff --git a/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/ET_SEXP_converter.h b/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/ET_SEXP_converter.h index 66729bd1..de7fa542 100644 --- a/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/ET_SEXP_converter.h +++ b/nCompiler/inst/include/nCompiler/ET_Rcpp_ext/post_Rcpp/ET_SEXP_converter.h @@ -7,6 +7,7 @@ #include "SEXP_2_EigenTensor.h" #include "SEXP_indices_2_IndexArray.h" #include +#include #define PRINTF Rprintf @@ -18,16 +19,19 @@ class nCompiler_Eigen_SEXP_converter { typedef typename EigenTensorType::Index Index; typedef typename Eigen::array IndexArray; nCompiler_Eigen_SEXP_converter(SEXP Sx) : - Sinput(Sx), + Rinput(Sx), indexArray(SEXP_indices_2_IndexArray(Sx)) { } operator EigenTensorType() { EigenTensorType xCopy; - xCopy = SEXP_2_EigenTensor::template copy(Sinput, indexArray); + SEXP Sinput = static_cast(Rinput); + xCopy = SEXP_2_EigenTensor + ::template copy( + Sinput, indexArray); return xCopy; // compiler should use copy elision } private: - SEXP Sinput; + Rcpp::RObject Rinput; IndexArray indexArray; }; @@ -45,115 +49,57 @@ class nCompiler_EigenRef_SEXP_converter { if(!(RxList_.isUsable())) Rcpp::stop("Problem: List was not provided for a ref arg.\n"); Rcpp::List RxList(RxList_); - // I could not get the following uses of Nullable to work. - // Rcpp::Nullable SobjName_(SxList[0]); // compiler error: ambiguous - // // Sx should contain a list with first element a symbol and second element an environment - SEXP SobjName = Rcpp::as(RxList[0]); - if(TYPEOF(SobjName) != SYMSXP) { - if(TYPEOF(SobjName) == LANGSXP) - Rcpp::stop("A reference argument should be a variable name, not an expression."); - else - Rcpp::stop("A reference argument should be a variable name."); + RobjExpr = static_cast(RxList[0]); + SEXP SobjExpr = static_cast(RobjExpr); + if(TYPEOF(SobjExpr) != SYMSXP && TYPEOF(SobjExpr) != LANGSXP) { + Rcpp::stop("A reference argument should be a name or expression."); } - objStr = Rcpp::String(PRINTNAME(SobjName)).get_cstring(); - // Rcpp::Nullable Senv_(SxList[1]); // ditto - // if(Senv_.isNull()) - // Rcpp::stop("Problem: Environment as second list element is missing for a ref arg.\n"); - // Senv = Senv_; - Renv = RxList[1]; - // Since Nullable did not work in this context, error-trapping might need - // simpler use of SEXPs until everything is checked. + Renv = static_cast(RxList[1]); } operator EigenTensorRefType() { - // Rcpp::CharacterVector SobjName = SxList[0]; - // Rcpp::Environment Renv(SxList[1]); -// Rprintf("Doing the implicit type conversion operator\n"); - SEXP Sobj = PROTECT(Renv.get(objStr)); // equiv to Renv[ <1st arg> ] + Rcpp::RObject Robj = Rf_eval(RobjExpr, Renv); + SEXP Sobj = static_cast(Robj); if(Sobj == R_NilValue) { Rcpp::stop("Problem: Could not obtain object for a ref arg.\n"); } IndexArray indexArray( SEXP_indices_2_IndexArray(Sobj) ); - xCopy = SEXP_2_EigenTensor::template copy(Sobj, indexArray); - UNPROTECT(1); + xCopy = SEXP_2_EigenTensor:: + template copy( + Sobj, indexArray); return xCopy; // compiler should use copy elision } ~nCompiler_EigenRef_SEXP_converter() { // Rprintf("goodbye to a tensor ref\n"); - SEXP Sputback = PROTECT(Rcpp::wrap(xCopy)); - Renv.assign(objStr, Sputback); - UNPROTECT(1); - // One idea was to update the Sinput object upon destruction, - // but that is not how SEXP objects work. If we assign it to - // newly allocated data, this is not seen by the calling function. - // std::cout< RxList_; - std::string objStr; + Rcpp::RObject RobjExpr; Rcpp::Environment Renv; IndexArray indexArray; EigenTensorType xCopy; }; -static SEXP Sexpr_2_data(SEXP Sexpr, SEXP Senv) { - // Input should be a name (`A`) or a bracket expression (`[`(A, ), parsed from A[]. - // add checks and flexibility for integer vs double - // - // If it is bracketed expression, Sexpr is pairlist: - // ( `[`, (`A`, ( index1, (index 2, etc. ) ) ) ) - // where CAR pulls out the first and CDR the rest at each step and - // CADR( ) is CAR(CAR( ) ), etc. - - SEXP Ssym; - if(Rf_isSymbol(Sexpr)) { // argument is a name without indexing brackets - Ssym = Sexpr; - } else { - if( Rf_isLanguage(Sexpr) ) { - // It is unclear if PROTECT needs to be used for results or CAR, CADR, etc. I don't think so. - SEXP Sop = CAR(Sexpr); // should be `[` of A[ ] - // If these get turned into error throws, check on PROTECT/UNPROTECT balance, - // or use Rcpp::Shield. - if(Sop != R_BracketSymbol) { - Rcpp::stop("Problem: Argument to refBlock should be a name or indexing expression."); - } - Ssym = CADR(Sexpr); - if(!Rf_isSymbol(Ssym)) { - Rcpp::stop("Problem: Argument to refBlock has first arg that is not a symbol."); - } - } else { - Rcpp::stop("Problem: Argument to refBlock should be a name or language object."); +// We use Rcpp::RObject because we could have a symbol (name) or expression (language). +static Rcpp::RObject Rexpr_2_RvarExpr(Rcpp::RObject Rexpr) { + if(Rcpp::is(Rexpr)) return Rexpr; + if( Rcpp::is(Rexpr) ) { + Rcpp::Language lang(Rexpr); + if (lang[0] == Symbol("[")) { + return static_cast(lang[1]); } + return Rexpr; } - SEXP Robj = PROTECT(Rf_findVarInFrame(Senv, Ssym)); // This does not search up environments - // SEXP Robj = PROTECT(Rf_findVar(Ssym, Senv)); // This does. - // For now the reference behavior only works in the immediate calling environment. - // Passing by reference is already dangerous, so the user should be careful, - // and objects of the same name in higher environments should not be modified. - if(Rf_isNull(Robj)) { - Rcpp::stop("Problem: Variable in refBlock argument not found."); - } - UNPROTECT(1); - return Robj; -} - -static SEXP STMinput_2_expr(SEXP Sx) { - // add checks - return VECTOR_ELT(Sx, 0); -} - -static SEXP STMinput_2_env(SEXP Sx) { - // add checks - return VECTOR_ELT(Sx, 1); + Rcpp::stop("A refBlock argument should be an expression (with or without \"[]\")."); } // From nimble static int SEXP_2_int(SEXP Sn, int i, int offset ) { if(!(Rf_isNumeric(Sn) || Rf_isLogical(Sn))) PRINTF("Error: SEXP_2_int called for SEXP that is not numeric or logical\n"); - if(LENGTH(Sn) <= i) PRINTF("Error: SEXP_2_int called for element %i% >= length of %i.\n", i, LENGTH(Sn)); + if(LENGTH(Sn) <= i) PRINTF("Error: SEXP_2_int called for element %i >= length of %i.\n", i, LENGTH(Sn)); if(Rf_isInteger(Sn) || Rf_isLogical(Sn)) { if(Rf_isInteger(Sn)) return(INTEGER(Sn)[i] + offset); @@ -183,8 +129,9 @@ static int SEXP_eval_to_single_int(SEXP Sx, SEXP Senv) { } template -std::vector SEXP_2_indexBlockArray(SEXP Sexpr, - SEXP Senv, +std::vector Rinputs_2_indexBlockArray(Rcpp::RObject Rdata, + Rcpp::RObject Rexpr, + Rcpp::Environment Renv, InputArray &sizeArray) { // This will be called after Sexpr_2_data, so much of the checking // of Sexpr as a valid input will already be done. @@ -192,28 +139,33 @@ std::vector SEXP_2_indexBlockArray(SEXP Sexpr, // sizeArray is used if there are no indexing brackets. // It is also used to check that entries in indexing brackets // are within bounds. - SEXP R_ColonSymbol = Rf_install(":"); // Why isn't this with the others in Rinternals.h - + int nDim = sizeArray.size(); std::vector indexBlockArray(nDim); - SEXP SnextIndex, Sind, Sop, Sargs; - bool useSizeArray = Rf_isSymbol(Sexpr); - if(!useSizeArray) { - SnextIndex = PROTECT(CDDR(Sexpr)); // See explanation above of CAR, CADR, etc. + Rcpp::Language lang; + bool isIndexed = false; + if(Rcpp::is(Rexpr) ) { + lang = Rcpp::Language(Rexpr); + isIndexed = (lang[0] == Symbol("[")); + } + if(isIndexed) { + if( (lang.size() - 2) != nDim ) { + Rcpp::stop("Number of indices in refBlock does not match number of dimensions of object."); + } } + Rcpp::Language RcurrentIndex; for(int i = 0; i < nDim; ++i) { - // std::cout<<"i = "< SEXP_2_indexBlockArray(SEXP Sexpr, PRINTF("Problem: Last index in a range is too large. Using size of object instead.\n"); last = sizeArray[i] - 1; } - // PRINTF("first last\n"); indexBlockArray[i] = b__(first, last); - UNPROTECT(3); } else { // index entry is a number, a variable, or a blank. - bool isBlank(false); - if(Rf_isSymbol(Sind)) { - isBlank = PRINTNAME(Sind) == R_BlankString; + bool isBlank = false; + if(Rcpp::is(RcurrentIndex)) { + isBlank = Rcpp::Symbol(RcurrentIndex) == R_MissingArg; } if(isBlank) { - // PRINTF("blank\n"); + //PRINTF("blank\n"); indexBlockArray[i] = b__(0, sizeArray[i]-1); } else { - indexBlockArray[i] = b__( SEXP_eval_to_single_int(Sind, Senv) ); - std::cout<<"Got singleton "<< SEXP_eval_to_single_int(Sind, Senv)< { } return REAL(Sin); } + static bool matches_type(SEXP Sin) { + return Rf_isReal(Sin); + } + static const SEXPTYPE Rtype = REALSXP; }; template<> @@ -278,6 +227,10 @@ struct Rdataptr { } return INTEGER(Sin); } + static bool matches_type(SEXP Sin) { + return Rf_isInteger(Sin); + } + static const SEXPTYPE Rtype = INTSXP; }; template<> @@ -291,8 +244,101 @@ struct Rdataptr { } return INTEGER(Sin);// R bools are integers } + static bool matches_type(SEXP Sin) { + return Rf_isLogical(Sin); + } + static const SEXPTYPE Rtype = LGLSXP; + +}; + +template +Eigen::Tensor +castedSTMcopy( fromT * from, + const std::vector &indexArray, + const std::vector &indexBlockArray, + std::true_type same_types) { + Eigen::StridedTensorMap > xMap(from, indexArray, indexBlockArray); + Eigen::Tensor to = xMap; + return to; +} + +template +Eigen::Tensor +castedSTMcopy( fromT * from, + const std::vector &indexArray, + const std::vector &indexBlockArray, + std::false_type different_types) { + Eigen::StridedTensorMap > xMap(from, indexArray, indexBlockArray); + Eigen::Tensor to = xMap.template cast(); + return to; +} + +template /* Scalar is the target scalar. The input scalar is determined by TYPEOF(SINPUT). */ +struct Rexpr_2_EigenTensor { + typedef Eigen::Tensor EigenTensorType; + typedef typename EigenTensorType::Index Index; + //typedef typename Eigen::array IndexArray; + + static EigenTensorType copy(Rcpp::RObject &Rdata, + Rcpp::RObject &Rexpr, + Rcpp::Environment &Renv) { + SEXP Sdata = static_cast(Rdata); + std::vector indexArray( + SEXP_indices_2_IndexArray_general >( + static_cast(Rdata))); + std::vector indexBlockArray( + Rinputs_2_indexBlockArray( + Rdata, Rexpr, Renv, indexArray)); + EigenTensorType xCopy; + typedef typename std::is_same::type i_match_type; + typedef typename std::is_same::type d_match_type; + switch( TYPEOF(Sdata) ) { + case REALSXP: + // std::cout<<"copying from REAL\n"; + xCopy = + castedSTMcopy(REAL(Sdata), + indexArray, + indexBlockArray, + d_match_type() + ); + break; + case INTSXP: + // std::cout<<"copying from INTEGER\n"; + xCopy = + castedSTMcopy(INTEGER(Sdata), + indexArray, + indexBlockArray, + i_match_type() + ); + break; + case LGLSXP: + // std::cout<<"copying from LOGICAL\n"; + // R represents logicals as int + xCopy = + castedSTMcopy(INTEGER(Sdata), + indexArray, + indexBlockArray, + i_match_type() + ); + break; + default: + std::cout<<"Bad type\n"< class nCompiler_StridedTensorMap_SEXP_converter { public: @@ -301,32 +347,49 @@ class nCompiler_StridedTensorMap_SEXP_converter { typedef Eigen::Tensor& EigenTensorRefType; typedef typename EigenTensorType::Index Index; - typedef typename Eigen::array IndexArray; - nCompiler_StridedTensorMap_SEXP_converter(SEXP Sx) : - Sinput(Sx), - Senv(STMinput_2_env(Sx)), - Sexpr(STMinput_2_expr(Sx)), - Sdata(Sexpr_2_data(Sexpr, Senv)), - indexArray(SEXP_indices_2_IndexArray_general >(Sdata)), - indexBlockArray(SEXP_2_indexBlockArray(Sexpr, Senv, indexArray)), - xMap(Rdataptr::PTR(Sdata), indexArray, indexBlockArray ) - { - // std::cout<<"hello to a StridedTensorMap"< IndexArray; + + static Rcpp::List check_input_Sx(Rcpp::Nullable RxList_) { + if(!(RxList_.isUsable())) + Rcpp::stop("Problem: List was not provided for a refBlock arg.\n"); + Rcpp::List Rlist(RxList_); + if(Rlist.size() != 2) + Rcpp::stop("Problem: refBlock arg list should have two elements: expression and environment.\n"); + return Rlist; } + + nCompiler_StridedTensorMap_SEXP_converter(SEXP Sx) : + Rlist(check_input_Sx(Sx)), + Renv(Rlist[1]), + Rexpr(Rlist[0]), + RobjExpr(Rexpr_2_RvarExpr(Rexpr)), + Rdata(Rf_eval(RobjExpr, Renv)), + xCopy(Rexpr_2_EigenTensor + ::copy(Rdata, Rexpr, Renv)), + xMap(Eigen::MakeStridedTensorMap::make(xCopy)) + { + // Rcpp::Language call("print", Rexpr); + // Rf_eval(call, Renv); + // std::cout<<"hello to a StridedTensorMap"<::make(ans, indexBlockArray); // std::cout<<"handling my StridedTensorMap for function input"< indexArray; - std::vector indexBlockArray; + Rcpp::List Rlist; + Rcpp::Environment Renv; + Rcpp::RObject Rexpr; + Rcpp::RObject RobjExpr; + Rcpp::RObject Rdata; + EigenTensorType xCopy; StridedTensorMapType xMap; }; diff --git a/nCompiler/inst/include/nCompiler/ET_ext/StridedTensorMap.h b/nCompiler/inst/include/nCompiler/ET_ext/StridedTensorMap.h index d2d8ce21..13816eb7 100644 --- a/nCompiler/inst/include/nCompiler/ET_ext/StridedTensorMap.h +++ b/nCompiler/inst/include/nCompiler/ET_ext/StridedTensorMap.h @@ -122,7 +122,25 @@ namespace Eigen { }; // See Eigen::TensorMap for alternative constructor ideas that have been removed. - // Constructor added for StridedTensorMap + // Constructors added for StridedTensorMap + + template + EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE StridedTensorMap(InputType &inputTensor) // default to mapping the full tensor + : m_data(inputTensor.data()) + { + createSubTensorInfo(inputTensor.dimensions(), + m_dimensions, // sizes + m_strides, + m_startIndices, + m_stopIndices); +#ifdef DEBUG_STRIDED_TENSOR_MAP + std::cout<<"sizes\t"; for(size_t i = 0; i < NumIndices; ++i) std::cout< EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE StridedTensorMap(InputType &inputTensor, const Eigen::array &ss) @@ -162,8 +180,6 @@ namespace Eigen { EIGEN_STRONG_INLINE Index dimension(Index n) const { return m_dimensions[n]; } EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE Index stride(Index n) const { return m_strides[n]; } // Added for StridedTensorMap - EIGEN_DEVICE_FUNC - EIGEN_STRONG_INLINE Index offset() const { return m_offset; } // Added for StridedTensorMap EIGEN_DEVICE_FUNC EIGEN_STRONG_INLINE const Dimensions& dimensions() const { return m_dimensions; } @@ -205,7 +221,7 @@ namespace Eigen { EIGEN_STRONG_INLINE const Scalar& operator()(Index index) const { eigen_internal_assert(index >= 0 && index < size()); - return m_data[m_offset + m_strides[0] * index]; // Modified for StridedTensorMap. + return m_data[m_startIndices[0] + m_strides[0] * index]; // Modified for StridedTensorMap. } #if USE_VARIADIC_TEMPLATES_IN_STRIDED_TENSOR_MAP //EIGEN_HAS_VARIADIC_TEMPLATES @@ -233,7 +249,6 @@ namespace Eigen { return m_data[index]; } else { const Index index = m_startIndices[0] + i0*m_strides[0] + m_dimensions[0]*( (i1*m_strides[1] + m_startIndices[1])); // Modified for StridedTensorMap - m_offset + m_strides[0] * (i0 + i1 * m_strides[1]); // Modified for StridedTensorMap return m_data[index]; } } @@ -313,7 +328,7 @@ namespace Eigen { EIGEN_STRONG_INLINE Scalar& operator()(Index index) { eigen_internal_assert(index >= 0 && index < size()); - return m_data[m_offset + m_strides[0] * index]; // Modified for StridedTensorMap. + return m_data[m_startIndices[0] + m_strides[0] * index]; // Modified for StridedTensorMap. } #if USE_VARIADIC_TEMPLATES_IN_STRIDED_TENSOR_MAP //EIGEN_HAS_VARIADIC_TEMPLATES @@ -342,7 +357,6 @@ namespace Eigen { return m_data[index]; } else { const Index index = m_startIndices[0] + i0*m_strides[0] + m_dimensions[0]*( (i1*m_strides[1] + m_startIndices[1])); // Modified for StridedTensorMap - m_offset + m_strides[0] * (i0 + i1 * m_strides[1]); // Modified for StridedTensorMap return m_data[index]; } } @@ -418,7 +432,6 @@ namespace Eigen { Dimensions m_strides; // Added for StridedTensorMap. Could this be a simple array? Dimensions m_startIndices; // ditto Dimensions m_stopIndices; // ditto - Index m_offset; }; // TensorEvaluator cases are modified from TensorSlidingSlicingOp @@ -618,15 +631,19 @@ typename MakeIndexBlocksTypes::type MakeIndexBlocks(P ...p) { // or MakeStridedTensorMap<2>::make(myEigenTensor, Eigen::array({s(1, 2), s(), s(3)})) template struct MakeStridedTensorMap { - template + template struct MakeOutputType { typedef typename EigenInputType::Scalar Scalar; typedef Tensor EigenOutputType; typedef StridedTensorMap< EigenOutputType > type; }; template - static typename MakeOutputType::type make(EigenInputType &x, const IndexBlocksType &indexBlockArray) { - return typename MakeOutputType::type(x, indexBlockArray); + static typename MakeOutputType::type make(EigenInputType &x, const IndexBlocksType &indexBlockArray) { + return typename MakeOutputType::type(x, indexBlockArray); + } + template + static typename MakeOutputType::type make(EigenInputType &x) { + return typename MakeOutputType::type(x); } }; diff --git a/nCompiler/inst/include/nCompiler/ET_ext/StridedTensorMapInfo.h b/nCompiler/inst/include/nCompiler/ET_ext/StridedTensorMapInfo.h index ba652e1a..10e48d46 100644 --- a/nCompiler/inst/include/nCompiler/ET_ext/StridedTensorMapInfo.h +++ b/nCompiler/inst/include/nCompiler/ET_ext/StridedTensorMapInfo.h @@ -10,7 +10,7 @@ // output_strides gives strides necessary to move in each dimension of the output. // These strides are not cumulatively multiplied. Each stride is the number of steps to take in its // dimension for a change in index. The native values would be (1, 1, 1), not (1, dim[0], dim[0] * dim[1]), e.g. -// We can think of the output_strides as "inner strides" nad the output_sizes as "outer strides". +// We can think of the output_strides as "inner strides" and the output_sizes as "outer strides". // To move in the 0th dim, move by output_strides[0] * 1 (1 for outer strides). // To move in the 1st dim, move by output_strides[1] * output_sizes[0] // To move in the 2nd dim, move by output_strides[2] * output_sizes[0] * output_sizes[1]; @@ -101,6 +101,16 @@ void createSubTensorInfo(const Eigen::array &ss, createSubTensorInfoGeneral< Eigen::array, Eigen::array, output_nDim, ScalarType>(ss, input_sizes, output_sizes, output_strides, output_startIndices, output_stopIndices); } +template +void createSubTensorInfo(const Eigen::array &input_sizes, + Eigen::array &output_sizes, + Eigen::array &output_strides, + Eigen::array &output_startIndices, + Eigen::array &output_stopIndices) { + Eigen::array ss {}; // all empty blocks, resulting in full tensor + createSubTensorInfoGeneral< Eigen::array, Eigen::array, output_nDim, ScalarType>(ss, input_sizes, output_sizes, output_strides, output_startIndices, output_stopIndices); +} + template void showSubTensorInfo(const Eigen::array &ss, const Eigen::array &input_sizes) { diff --git a/nCompiler/inst/include/nCompiler/ET_ext/post_Rcpp/tensorOperations.h b/nCompiler/inst/include/nCompiler/ET_ext/post_Rcpp/tensorOperations.h index a88a6222..e4607f03 100644 --- a/nCompiler/inst/include/nCompiler/ET_ext/post_Rcpp/tensorOperations.h +++ b/nCompiler/inst/include/nCompiler/ET_ext/post_Rcpp/tensorOperations.h @@ -85,8 +85,8 @@ namespace nCompiler { template struct nEval_ { template - static EigenType go(const T& op) { - EigenType ans = op; // Materialize the result of op. + static std::remove_reference_t go(const T& op) { + std::remove_reference_t ans = op; // Materialize the result of op. return ans; } }; diff --git a/nCompiler/inst/include/nCompiler/nC_inter/post_Rcpp/generic_class_interface_Rcpp_steps.h b/nCompiler/inst/include/nCompiler/nC_inter/post_Rcpp/generic_class_interface_Rcpp_steps.h index ec0983b2..33edf6ea 100644 --- a/nCompiler/inst/include/nCompiler/nC_inter/post_Rcpp/generic_class_interface_Rcpp_steps.h +++ b/nCompiler/inst/include/nCompiler/nC_inter/post_Rcpp/generic_class_interface_Rcpp_steps.h @@ -53,51 +53,32 @@ class genericInterfaceC : virtual public genericInterfaceBaseC { // argument passing by defining new Rcpp::traits::input_parameter specializations. // As a result, it is simpler here to create a new P object via this pathway. if constexpr(P_is_shared_ptr) { - bool use_set_all_values(true); - if(Rcpp::is(Svalue)) { - // use_set_all_values is definitively true. - } else { - // Unfortunately the checking for either extptr - // or private$CppObj will be done again if we use the Exporter - // when use_set_all_values=false. - // But at the moment there is not a great way to avoid that. - // This checking could possibly be pulled out to a small utility - // used also by the Exporter< shared_ptr > specialization. - if(Rcpp::is(Svalue)) { - Rcpp::Environment Senv(Svalue); - if(Senv.exists("extptr")) { - use_set_all_values = false; // it is a loadedObjectEnv - } else { - Nullable private_env = Senv["private"]; - if(private_env.isNotNull()) { - if(Rcpp::Environment(private_env).exists("CppObj")) { - use_set_all_values = false; // It is an R6 nClass-interface object. - } - } - } - } + Rcpp::RObject Rextptr = get_extptr_from_SEXP(Svalue); + SEXP Sextptr = Rextptr; + if(Sextptr != R_NilValue) { + // Use the regular Exporter pathway for non-shared_ptr types + dynamic_cast(intBasePtr)->*ptr = P(typename Rcpp::traits::input_parameter

::type(Sextptr)); + return; } - if(use_set_all_values) { - // Rprintf("trying to use set all values\n"); - auto casted_T = dynamic_cast(intBasePtr); - auto& ptr2 = casted_T->*ptr; - if(ptr2 != nullptr) { - // Rprintf("its not null\n"); - ptr2->set_all_values(Svalue); + // If Svalue is not an external pointer, try to set values from list or environment + // Rprintf("trying to use set all values\n"); + auto casted_T = dynamic_cast(intBasePtr); + auto& ptr2 = casted_T->*ptr; + if(ptr2 != nullptr) { + // Rprintf("its not null\n"); + ptr2->set_all_values(Svalue); + } else { + if constexpr(std::is_default_constructible_v) { + casted_T->*ptr = std::make_shared(); + // auto& ptr3 = casted_T->*ptr; + (casted_T->*ptr)->set_all_values(Svalue); } else { - if constexpr(std::is_default_constructible_v) { - casted_T->*ptr = std::make_shared(); - // auto& ptr3 = casted_T->*ptr; - (casted_T->*ptr)->set_all_values(Svalue); - } else { - Rcpp::stop("Trying to set values of an uninitialized compiled nClass (with no default constructor!) from a list or environment."); - } + Rcpp::stop("Trying to set values of an uninitialized compiled nClass (with no default constructor!) from a list or environment."); } - return; } + } else { + dynamic_cast(intBasePtr)->*ptr = P(typename Rcpp::traits::input_parameter

::type(Svalue)); } - // Use the regular Exporter pathway for non-shared_ptr types - dynamic_cast(intBasePtr)->*ptr = P(typename Rcpp::traits::input_parameter

::type(Svalue)); } std::unique_ptr ETaccess(genericInterfaceBaseC *intBasePtr) { std::unique_ptr ans( new ETaccessor

( dynamic_cast(intBasePtr)->*ptr ) ); diff --git a/nCompiler/inst/include/nCompiler/nC_inter_Rcpp_ext/post_Rcpp/shared_ptr_as_wrap.h b/nCompiler/inst/include/nCompiler/nC_inter_Rcpp_ext/post_Rcpp/shared_ptr_as_wrap.h index 8c30a7f4..772f6a1c 100644 --- a/nCompiler/inst/include/nCompiler/nC_inter_Rcpp_ext/post_Rcpp/shared_ptr_as_wrap.h +++ b/nCompiler/inst/include/nCompiler/nC_inter_Rcpp_ext/post_Rcpp/shared_ptr_as_wrap.h @@ -6,6 +6,7 @@ #include // #include "loadedObjectEnv.h" + // For an input of type T (e.g. shared_ptr< some_nClass_ >), // Rcpp creates code like this: // void test_input_(std::shared_ptr obj); @@ -37,27 +38,15 @@ namespace Rcpp { std::shared_ptr sp_, spnew_; Exporter(SEXP Sx) { - Rcpp::Environment Sx_env(Sx); // Sx is an environment, so initialize an Rcpp:Environment from it. - SEXP Xptr = PROTECT(Sx_env["extptr"]); // Get the extptr element of it. - bool ok(false); - if(Xptr != R_NilValue) { - ok = true; - } else { - UNPROTECT(1); - Nullable private_env = Sx_env["private"]; - if(private_env.isNotNull()) { - Nullable CppObj = Rcpp::Environment(private_env)["CppObj"]; - if(CppObj.isNotNull()) { - Xptr = PROTECT(Rcpp::Environment(CppObj)["extptr"]); - if(Xptr != R_NilValue) { - ok=true;}}} - } - if(!ok) {stop("An argument that should be an nClass object is not valid.");} - std::shared_ptr spbase = static_cast(R_ExternalPtrAddr(Xptr))->get_interfaceBase_shared_ptr(); + Rcpp::RObject Rx = Sx; // to protect it + Rcpp::RObject Rextptr = get_extptr_from_SEXP(Sx); + SEXP Sextptr = Rextptr; + if(Sextptr == R_NilValue) {stop("An argument that should be an nClass object is not valid.");} + std::shared_ptr spbase = + static_cast(R_ExternalPtrAddr(Sextptr))->get_interfaceBase_shared_ptr(); if constexpr (T_is_polymorphic) { spnew_ = std::dynamic_pointer_cast(spbase); if(!spnew_) { - UNPROTECT(1); stop("Invalid nClass assignment: check that the assigned object is of the expected class (or derived from it)."); } sp_ = spnew_; @@ -65,7 +54,6 @@ namespace Rcpp { sp_ = std::static_pointer_cast(spbase); } // sp_ = dynamic_cast* >(static_cast(R_ExternalPtrAddr(Xptr)))->sp(); - UNPROTECT(1); } inline std::shared_ptr< T > get(){ return sp_; diff --git a/nCompiler/inst/include/nCompiler/omnibus_fxns.h b/nCompiler/inst/include/nCompiler/omnibus_fxns.h index 506ee6be..51d5b5f9 100644 --- a/nCompiler/inst/include/nCompiler/omnibus_fxns.h +++ b/nCompiler/inst/include/nCompiler/omnibus_fxns.h @@ -4,4 +4,59 @@ #include #include +inline Rcpp::Nullable get_env_from_env(const Rcpp::Environment& env, const std::string& name) { + Rcpp::RObject maybe_env = env[name]; + if(Rcpp::is(maybe_env)) { + return static_cast(maybe_env); + } + return R_NilValue; +} + +inline SEXP get_extptr_from_env(const Rcpp::Environment& env, const std::string& name) { + Rcpp::RObject maybe_extptr = env[name]; + SEXP Smaybe_extptr = static_cast(maybe_extptr); + if(TYPEOF(Smaybe_extptr) == EXTPTRSXP) { + return Smaybe_extptr; + } + return R_NilValue; +} + +// This is used from two places. +// First is the shared_ptr<> Exporter in shared_ptr_as_wrap. +// Second is the genericInterfaceC::accessor_class::set function +// In the second case, sometimes we will be calling the Exporter below. +// In that case, the underlying extptr will have already been extracted +// and when the Exporter call this function, it will return the extptr directly +// after the first clause. +inline SEXP get_extptr_from_SEXP(SEXP Svalue) { + if(TYPEOF(Svalue) == EXTPTRSXP) { + return Svalue; + } + SEXP Sres = R_NilValue; // constructed as NULL + if(Rcpp::is(Svalue)) { + Rcpp::Environment Senv(Svalue); + Sres = get_extptr_from_env(Senv, "extptr"); + if(Sres != R_NilValue) { + return Sres; + } + Rcpp::Nullable private_env = get_env_from_env(Senv, "private"); + if(private_env.isNotNull()) { + Rcpp::Nullable CpublicObj_env = get_env_from_env(Rcpp::Environment(private_env), "Cpublic_obj"); + if(CpublicObj_env.isNotNull()) { + Rcpp::Nullable private2_env = get_env_from_env(Rcpp::Environment(CpublicObj_env), "private"); + if(private2_env.isNotNull()) { + Rcpp::Nullable LOE_env = get_env_from_env(Rcpp::Environment(private2_env), "CppObj"); + if(LOE_env.isNotNull()) { + Sres = get_extptr_from_env(Rcpp::Environment(LOE_env), "extptr"); + if(Sres != R_NilValue) { + return Sres; + } + } + } + } + } + } + return Sres; // will be NULL +} + #endif diff --git a/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC/calcInstrList_nClass_cppContent.cpp b/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC/calcInstrList_nClass_cppContent.cpp index c7309d21..20bc4cf0 100644 --- a/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC/calcInstrList_nClass_cppContent.cpp +++ b/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC/calcInstrList_nClass_cppContent.cpp @@ -17,19 +17,19 @@ using namespace Rcpp; RESET_EIGEN_ERRORS } -// [[Rcpp::export(name = "new_calcInstrList_nClass")]] +// [[Rcpp::export(name = "calcInstrList_nClass_new")]] SEXP new_calcInstrList_nClass ( ) { RESET_EIGEN_ERRORS return CREATE_NEW_NCOMP_OBJECT(calcInstrList_nClass);; } -// [[Rcpp::export(name = "set_CnClass_env_new_calcInstrList_nClass")]] +// [[Rcpp::export(name = "set_CnClass_env_calcInstrList_nClass_new")]] void set_CnClass_env_calcInstrList_nClass ( SEXP env ) { RESET_EIGEN_ERRORS SET_CNCLASS_ENV(calcInstrList_nClass, env);; } -// [[Rcpp::export(name = "get_CnClass_env_new_calcInstrList_nClass")]] +// [[Rcpp::export(name = "get_CnClass_env_calcInstrList_nClass_new")]] Rcpp::Environment get_CnClass_env_calcInstrList_nClass ( ) { RESET_EIGEN_ERRORS return GET_CNCLASS_ENV(calcInstrList_nClass);; diff --git a/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC/calcInstrList_nClass_manifest.txt b/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC/calcInstrList_nClass_manifest.txt index 386bb12f..c9d48e0f 100644 --- a/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC/calcInstrList_nClass_manifest.txt +++ b/nCompiler/inst/include/nCompiler/predef/calcInstrList_nC/calcInstrList_nClass_manifest.txt @@ -1,4 +1,4 @@ -list(saved_at = structure(1765437409.8481, class = c("POSIXct", +list(saved_at = structure(1772141341.98022, class = c("POSIXct", "POSIXt")), packet_name = "calcInstrList_nClass", elements = c("preamble", "cppContent", "hContent", "filebase", "post_cpp_compiler", "copyFiles" ), files = list(preamble = "calcInstrList_nClass_preamble.cpp", diff --git a/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_cppContent.cpp b/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_cppContent.cpp index b94c8e71..5c98d3d4 100644 --- a/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_cppContent.cpp +++ b/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_cppContent.cpp @@ -17,19 +17,19 @@ using namespace Rcpp; RESET_EIGEN_ERRORS } -// [[Rcpp::export(name = "new_calcInstr_nClass")]] +// [[Rcpp::export(name = "calcInstr_nClass_new")]] SEXP new_calcInstr_nClass ( ) { RESET_EIGEN_ERRORS return CREATE_NEW_NCOMP_OBJECT(calcInstr_nClass);; } -// [[Rcpp::export(name = "set_CnClass_env_new_calcInstr_nClass")]] +// [[Rcpp::export(name = "set_CnClass_env_calcInstr_nClass_new")]] void set_CnClass_env_calcInstr_nClass ( SEXP env ) { RESET_EIGEN_ERRORS SET_CNCLASS_ENV(calcInstr_nClass, env);; } -// [[Rcpp::export(name = "get_CnClass_env_new_calcInstr_nClass")]] +// [[Rcpp::export(name = "get_CnClass_env_calcInstr_nClass_new")]] Rcpp::Environment get_CnClass_env_calcInstr_nClass ( ) { RESET_EIGEN_ERRORS return GET_CNCLASS_ENV(calcInstr_nClass);; diff --git a/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_manifest.txt b/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_manifest.txt index 7301701f..2badd3ed 100644 --- a/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_manifest.txt +++ b/nCompiler/inst/include/nCompiler/predef/calcInstr_nC/calcInstr_nClass_manifest.txt @@ -1,4 +1,4 @@ -list(saved_at = structure(1765437403.89444, class = c("POSIXct", +list(saved_at = structure(1772141071.19335, class = c("POSIXct", "POSIXt")), packet_name = "calcInstr_nClass", elements = c("preamble", "cppContent", "hContent", "filebase", "post_cpp_compiler", "copyFiles" ), files = list(preamble = "calcInstr_nClass_preamble.cpp", cppContent = "calcInstr_nClass_cppContent.cpp", diff --git a/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_cppContent.cpp b/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_cppContent.cpp index 2e00bd80..57648c3d 100644 --- a/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_cppContent.cpp +++ b/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_cppContent.cpp @@ -26,13 +26,13 @@ return(0.0); RESET_EIGEN_ERRORS } -// [[Rcpp::export(name = "set_CnClass_env_new_modelBase_nClass")]] +// [[Rcpp::export(name = "set_CnClass_env_modelBase_nClass_new")]] void set_CnClass_env_modelBase_nClass ( SEXP env ) { RESET_EIGEN_ERRORS SET_CNCLASS_ENV(modelBase_nClass, env);; } -// [[Rcpp::export(name = "get_CnClass_env_new_modelBase_nClass")]] +// [[Rcpp::export(name = "get_CnClass_env_modelBase_nClass_new")]] Rcpp::Environment get_CnClass_env_modelBase_nClass ( ) { RESET_EIGEN_ERRORS return GET_CNCLASS_ENV(modelBase_nClass);; diff --git a/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_manifest.txt b/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_manifest.txt index 11652f46..272fb957 100644 --- a/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_manifest.txt +++ b/nCompiler/inst/include/nCompiler/predef/modelBase_nC/modelBase_nClass_manifest.txt @@ -1,4 +1,4 @@ -list(saved_at = structure(1765437502.8499, class = c("POSIXct", +list(saved_at = structure(1772143550.30016, class = c("POSIXct", "POSIXt")), packet_name = "modelBase_nClass", elements = c("preamble", "cppContent", "hContent", "filebase", "post_cpp_compiler", "copyFiles" ), files = list(preamble = "modelBase_nClass_preamble.cpp", cppContent = "modelBase_nClass_cppContent.cpp", diff --git a/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_cppContent.cpp b/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_cppContent.cpp index 27e2bae7..a0f994db 100644 --- a/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_cppContent.cpp +++ b/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_cppContent.cpp @@ -25,13 +25,13 @@ return(0.0); RESET_EIGEN_ERRORS } -// [[Rcpp::export(name = "set_CnClass_env_new_nodeFxnBase_nClass")]] +// [[Rcpp::export(name = "set_CnClass_env_nodeFxnBase_nClass_new")]] void set_CnClass_env_nodeFxnBase_nClass ( SEXP env ) { RESET_EIGEN_ERRORS SET_CNCLASS_ENV(nodeFxnBase_nClass, env);; } -// [[Rcpp::export(name = "get_CnClass_env_new_nodeFxnBase_nClass")]] +// [[Rcpp::export(name = "get_CnClass_env_nodeFxnBase_nClass_new")]] Rcpp::Environment get_CnClass_env_nodeFxnBase_nClass ( ) { RESET_EIGEN_ERRORS return GET_CNCLASS_ENV(nodeFxnBase_nClass);; diff --git a/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_manifest.txt b/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_manifest.txt index bc74c3a8..3f858b64 100644 --- a/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_manifest.txt +++ b/nCompiler/inst/include/nCompiler/predef/nodeFxnBase_nC/nodeFxnBase_nClass_manifest.txt @@ -1,4 +1,4 @@ -list(saved_at = structure(1765437416.01603, class = c("POSIXct", +list(saved_at = structure(1772141354.19454, class = c("POSIXct", "POSIXt")), packet_name = "nodeFxnBase_nClass", elements = c("preamble", "cppContent", "hContent", "filebase", "post_cpp_compiler", "copyFiles" ), files = list(preamble = "nodeFxnBase_nClass_preamble.cpp", diff --git a/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_cppContent.cpp b/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_cppContent.cpp index 1d323700..d372f7f8 100644 --- a/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_cppContent.cpp +++ b/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_cppContent.cpp @@ -17,19 +17,19 @@ using namespace Rcpp; RESET_EIGEN_ERRORS } -// [[Rcpp::export(name = "new_nodeInstr_nClass")]] +// [[Rcpp::export(name = "nodeInstr_nClass_new")]] SEXP new_nodeInstr_nClass ( ) { RESET_EIGEN_ERRORS return CREATE_NEW_NCOMP_OBJECT(nodeInstr_nClass);; } -// [[Rcpp::export(name = "set_CnClass_env_new_nodeInstr_nClass")]] +// [[Rcpp::export(name = "set_CnClass_env_nodeInstr_nClass_new")]] void set_CnClass_env_nodeInstr_nClass ( SEXP env ) { RESET_EIGEN_ERRORS SET_CNCLASS_ENV(nodeInstr_nClass, env);; } -// [[Rcpp::export(name = "get_CnClass_env_new_nodeInstr_nClass")]] +// [[Rcpp::export(name = "get_CnClass_env_nodeInstr_nClass_new")]] Rcpp::Environment get_CnClass_env_nodeInstr_nClass ( ) { RESET_EIGEN_ERRORS return GET_CNCLASS_ENV(nodeInstr_nClass);; diff --git a/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_manifest.txt b/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_manifest.txt index 3feecfbc..98b1addd 100644 --- a/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_manifest.txt +++ b/nCompiler/inst/include/nCompiler/predef/nodeInstr_nC/nodeInstr_nClass_manifest.txt @@ -1,4 +1,4 @@ -list(saved_at = structure(1765437397.73714, class = c("POSIXct", +list(saved_at = structure(1772140976.23266, class = c("POSIXct", "POSIXt")), packet_name = "nodeInstr_nClass", elements = c("preamble", "cppContent", "hContent", "filebase", "post_cpp_compiler", "copyFiles" ), files = list(preamble = "nodeInstr_nClass_preamble.cpp", cppContent = "nodeInstr_nClass_cppContent.cpp", diff --git a/nCompiler/tests/testthat/nClass_tests/test-nClass_constructor.R b/nCompiler/tests/testthat/nClass_tests/test-nClass_constructor.R index 7fb67d0e..0dd9fd73 100644 --- a/nCompiler/tests/testthat/nClass_tests/test-nClass_constructor.R +++ b/nCompiler/tests/testthat/nClass_tests/test-nClass_constructor.R @@ -73,12 +73,16 @@ test_that("nClass replacing default constructor works", { # gc() }) -test_that("manual initialize works and Cpp ctor call is inserted", { +test_that("manual initialize works and Cpp ctor call is made", { + # Requirement is that users include "super$initialize()". + # That seems reasonable. + # Manual alternative is below. nc <- nClass( classname = "methods_test", Rpublic = list( Ra = 0, initialize = function() { + super$initialize() print("calling initialize") self$Ra <- 1 }, @@ -121,14 +125,19 @@ test_that("manual initialize works and Cpp ctor call is inserted", { }) -test_that("manual initialize with hand-coded C++ initialization works", { +test_that("manual initialize with hand-coded Cpublic initialization works", { + # two distinct steps on display here: + # 1. manual alternative to calling super$initialize() is initialize_Cpublic() + # 2. If the auto_include of C++ constructor is turned off, it can be constructed manually + # at whatever step of initialize one wants. nc <- nClass( classname = "methods_test", Rpublic = list( Ra = 0, initialize = function() { print("calling initialize") - if(isCompiled()) initializeCpp() + initialize_Cpublic() # step 1, for uncompiled or compiled + if(isCompiled()) initializeCpp() # step 2, only for compiled self$Ra <- 1 }, get_Ra = function() { @@ -154,6 +163,7 @@ test_that("manual initialize with hand-coded C++ initialization works", { obj <- nc$new() expect_equal(obj$Ra, 1) expect_equal(obj$get_Ra(), 1) + expect_equal(obj$Ca, "numericScalar") expect_true(isFALSE(obj$isCompiled())) #obj$Ca #obj$get_Ca() @@ -179,6 +189,7 @@ test_that("manual initialize OMITTED with hand-coded C++ initialization compiles Ra = 0, initialize = function() { print("calling initialize") + super$initialize() # if(isCompiled()) initializeCpp() # OMITTED! self$Ra <- 1 }, @@ -205,6 +216,7 @@ test_that("manual initialize OMITTED with hand-coded C++ initialization compiles obj <- nc$new() expect_equal(obj$Ra, 1) expect_equal(obj$get_Ra(), 1) + expect_equal(obj$Ca, "numericScalar") expect_true(isFALSE(obj$isCompiled())) #obj$Ca #obj$get_Ca() diff --git a/nCompiler/tests/testthat/nClass_tests/test-nClass_inherit.R b/nCompiler/tests/testthat/nClass_tests/test-nClass_inherit.R index acc55532..2f33de9d 100644 --- a/nCompiler/tests/testthat/nClass_tests/test-nClass_inherit.R +++ b/nCompiler/tests/testthat/nClass_tests/test-nClass_inherit.R @@ -174,6 +174,7 @@ test_that("nClass hierarchy traps inherited field duplicate names", { ) }) +message("add a test that inheriting from interface = 'none' results in not being able to use base class fields and methods") test_that("nClass hierarchies work as expected (including uncompiled vs compiled discrepancies)", { @@ -185,6 +186,10 @@ test_that("nClass hierarchies work as expected (including uncompiled vs compiled oldOpt2 <- nOptions("allow_inherited_field_duplicates") nOptions(allow_method_overloading = TRUE) nOptions(allow_inherited_field_duplicates = TRUE) + # The tests below worked in an early version. + # Then some changes were made around inheritance handling. + # Now we need these options to keep these tests functioning. + # To-Do: Update these tests to be more deliberate about these options. on.exit({ nOptions(allow_method_overloading = oldOpt1) nOptions(allow_inherited_field_duplicates = oldOpt2) @@ -249,7 +254,8 @@ test_that("nClass hierarchies work as expected (including uncompiled vs compiled return(wA); returnType('numericScalar') }) ), - compileInfo = list(interface = "none", createFromR = FALSE) + compileInfo = list(interface = "generic", createFromR = FALSE, + packageNames=c(compiled="ncA_comp")) ) ncB <- nClass( @@ -374,13 +380,13 @@ test_that("inheriting-only classes in 3-level hierarchy works", { return(v + 2*x); returnType('numericScalar'); }) ), - compileInfo = list(interface = "none",createFromR=FALSE) + compileInfo = list(interface = "generic",createFromR=FALSE) ) ncMid <- nClass( inherit = ncBase, classname = "ncMid", - compileInfo = list(interface = "none",createFromR=FALSE), + compileInfo = list(interface = "generic",createFromR=FALSE), Cpublic = list(x2 = 'numericScalar') ) @@ -405,7 +411,7 @@ test_that("inheriting-only classes in 3-level hierarchy works", { 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(method(to_generic_interface(Cobj), "add_x")(15), 25) expect_equal(Cobj$add_2x_virt(15), 35) Cobj2 <- comp$ncUseBase$new() diff --git a/nCompiler/tests/testthat/nClass_tests/test-nClass_nested.R b/nCompiler/tests/testthat/nClass_tests/test-nClass_nested.R index 799c149b..2f650df4 100644 --- a/nCompiler/tests/testthat/nClass_tests/test-nClass_nested.R +++ b/nCompiler/tests/testthat/nClass_tests/test-nClass_nested.R @@ -24,7 +24,9 @@ test_that("One nClass holds another and uses it", { expect_true(is.null(inner_obj)) obj$init() inner_obj <- obj$my_inner - expect_true(inherits(inner_obj, "CnClass")) + expect_true(obj$isCompiled()) + expect_true(inherits(inner_obj, "nClass")) + expect_true(inner_obj$isCompiled()) inner_obj$x <- 10 expect_equal(obj$get_inner()$x, 10) @@ -34,69 +36,82 @@ test_that("One nClass holds another and uses it", { }) test_that("One nClass holds another by a base class and uses it", { - - ncA <- nClass( - Cpublic = list( - classname = "ncA", - v.A = 'numericVector', - wA = 'numericScalar', - add.wA = nFunction( - function(x.1 = 'numericVector') { - return(wA + x.1); returnType('numericVector') - } + make_defs <- function() { + ncA <- nClass( + classname = "ncAclass", + Cpublic = list( + v.A = 'numericVector', + wA = 'numericScalar', + add.wA = nFunction( + function(x.1 = 'numericVector') { + return(wA + x.1); returnType('numericVector') + } + ) + ), + compileInfo = list(interface="generic", createFromR=FALSE, + packageNames = c(uncompiled="ncA", compiled="ncAcomp")) + ) + nc_inner <- nClass( + inherit = ncA, + classname = "nc_inner", + Cpublic = list( + x = 'numericScalar', + get_x = nFunction(function() {return(x)}, returnType = 'numericScalar') ) - ), - compileInfo = list(interface="none", createFromR=FALSE) - ) - nc_inner <- nClass( - inherit = ncA, - classname = "nc_inner", - Cpublic = list( - x = 'numericScalar', - get_x = nFunction(function() {return(x)}, returnType = 'numericScalar') ) - ) - nc_outer <- nClass( - classname = "nc_outer", - Cpublic = list( - my_inner = 'nc_inner', - my_A = 'ncA', - init = nFunction(function() {my_inner = nc_inner$new()}), - initA = nFunction(function() {my_A = nc_inner$new() }), - useA = nFunction(function() {my_A$wA <- 10; return(my_A$wA + 3)}, returnType='numericScalar'), - get_inner = nFunction(function() {return(my_inner)}, returnType = 'nc_inner'), - inner_x_p1 = nFunction(function() {return(my_inner$x+1)}, returnType='numericScalar'), - inner_add_wA_p2 = nFunction(function(v='numericVector') {return(my_inner$add.wA(v)+2)}, returnType='numericVector'), - inner_wA_p3 = nFunction(function() {return(my_inner$wA + 3)}, returnType='numericScalar') + nc_outer <- nClass( + classname = "nc_outer", + Cpublic = list( + my_inner = 'nc_inner', + my_A = 'ncA', + init = nFunction(function() {my_inner = nc_inner$new()}), + initA = nFunction(function() {my_A = nc_inner$new() }), + useA = nFunction(function() {my_A$wA <- 10; return(my_A$wA + 3)}, returnType='numericScalar'), + get_inner = nFunction(function() {return(my_inner)}, returnType = 'nc_inner'), + inner_x_p1 = nFunction(function() {return(my_inner$x+1)}, returnType='numericScalar'), + inner_add_wA_p2 = nFunction(function(v='numericVector') {return(my_inner$add.wA(v)+2)}, returnType='numericVector'), + inner_wA_p3 = nFunction(function() {return(my_inner$wA + 3)}, returnType='numericScalar') + ) ) - ) - message("clean up this test for both compilation paths") - comp <- nCompile(nc_inner, nc_outer, ncA, package = TRUE) - comp <- nCompile(nc_inner, nc_outer, ncA, package = FALSE) - obj <- comp$nc_outer$new() - inner_obj <- obj$my_inner - expect_true(is.null(inner_obj)) - obj$init() - inner_obj <- obj$my_inner - expect_true(inherits(inner_obj, "CnClass")) + list(ncA = ncA, + nc_inner = nc_inner, + nc_outer = nc_outer) + } + defs <- make_defs() + for(package in c(TRUE, FALSE)) { + # A different returnName must be provided for ncA because that + # will be its default exportName and for interface != "full" that + # takes priority and results in renaming the uncompiled class name + # and that breaks inherits + comp <- with(defs, nCompile(nc_inner, nc_outer, ncAc = ncA, package = package)) + comp <- with(defs, nCompile(nc_inner, nc_outer, package = package)) + obj <- comp$nc_outer$new() + inner_obj <- obj$my_inner + expect_true(is.null(inner_obj)) + obj$init() + inner_obj <- obj$my_inner + expect_true(inner_obj$isCompiled()) + expect_true(inherits(inner_obj, "nClass")) - obj$my_A - obj$initA() - obj$my_A - obj$useA() + obj$my_A + obj$initA() + # since my_A is of type ncA, which has interface="none", we get back only a raw externalptr, + expect_true(inherits(obj$my_A, "loadedObjectEnv")) + obj$useA() - inner_obj$x <- 10 - expect_equal(obj$get_inner()$x, 10) - expect_equal(obj$inner_x_p1(), 11) + inner_obj$x <- 10 + expect_equal(obj$get_inner()$x, 10) + expect_equal(obj$inner_x_p1(), 11) - inner_obj$wA <- 20 - inner_obj$v.A <- 1:3 - expect_equal(obj$get_inner()$v.A, 1:3) - expect_equal(inner_obj$add.wA(1:3), 1:3 + 20) + inner_obj$wA <- 20 + inner_obj$v.A <- 1:3 + expect_equal(obj$get_inner()$v.A, 1:3) + expect_equal(inner_obj$add.wA(1:3), 1:3 + 20) - expect_equal(obj$inner_add_wA_p2(1:3), 1:3 + 20 + 2) - expect_equal(obj$inner_wA_p3(), 20 + 3) + expect_equal(obj$inner_add_wA_p2(1:3), 1:3 + 20 + 2) + expect_equal(obj$inner_wA_p3(), 20 + 3) - rm(obj, inner_obj) - gc() + rm(obj, inner_obj) + gc() + } }) diff --git a/nCompiler/tests/testthat/nClass_tests/test-nClass_uncompiled.R b/nCompiler/tests/testthat/nClass_tests/test-nClass_uncompiled.R index 7670ad61..88d375f9 100644 --- a/nCompiler/tests/testthat/nClass_tests/test-nClass_uncompiled.R +++ b/nCompiler/tests/testthat/nClass_tests/test-nClass_uncompiled.R @@ -2,6 +2,7 @@ test_that("nClass basics", { + nc1 <- nClass( Rpublic = list( Rv = NULL, @@ -14,30 +15,81 @@ test_that("nClass basics", return(x+1) }, argTypes = list(x = 'numericScalar'), + returnType = 'numericScalar'), + Cbreak = nFunction( + fun = function(x) { + return(Rfoo(x)) # should give an error + }, + argTypes = list(x = 'numericScalar'), returnType = 'numericScalar') ) ) + expect_true(isNCgenerator(nc1)) + expect_false(isCompiledNCgenerator(nc1)) + my.nc1 <- nc1$new() + expect_true(isNC(my.nc1)) + expect_false(isCNC(my.nc1)) - my_nc1 <- nc1$new() - - expect_true(inherits(my_nc1, "nClass")) - expect_true(inherits(my_nc1, "R6")) - expect_true(inherits(my_nc1$Cfoo, 'nFunction')) - expect_equal(my_nc1$Cfoo(2), 3) + expect_true(inherits(my.nc1, "nClass")) + expect_true(inherits(my.nc1, "R6")) + expect_true(inherits(my.nc1$private$Cpublic_obj$Cfoo, 'nFunction')) + expect_true(inherits(my.nc1$Cfoo, 'function')) + expect_equal(my.nc1$Cfoo(2), 3) + expect_equal(my.nc1$Rfoo(2), 3) expect_true(inherits(nc1$.nCompiler$symbolTable, "symbolTableClass")) expect_equal(nc1$.nCompiler$symbolTable$getSymbol("Cv")$nDim, 0) expect_true(isNC(my_nc1)) expect_true(isNCgenerator(nc1)) expect_error(inherits(NCinternals(my_nc1), "NC_InternalsClass")) expect_true(inherits(NCinternals(nc1), "NC_InternalsClass")) - expect_equal(NCinternals(nc1)$methodNames, 'Cfoo') - - ## Check that `$clone` works. - values <- rnorm(3) - my_nc1$Rv <- values - expect_silent(my_nc1_clone <- my_nc1$clone()) - expect_identical(my_nc1$Rv, my_nc1_clone$Rv) - my_nc1$Rv[2] <- 3 - expect_identical(values[2], my_nc1_clone$Rv[2]) + expect_equal(NCinternals(nc1)$methodNames, c('Cfoo','Cbreak')) } ) + +test_that("nClass inheritance basics", { + nc1 <- nClass( + classname = "surprise", + Rpublic = list( + Rv = NULL, + Rfoo = function(x) x+1 + ), + Cpublic = list( + Cv = 'numericScalar', + Cfoo = nFunction( + fun = function(x) { + return(x+1) + }, + argTypes = list(x = 'numericScalar'), + returnType = 'numericScalar') + ) + ) + + nc2 <- nClass( + inherit = nc1, + Rpublic = list( + Rfoo2 = function(x) Rfoo(x) + ), + Cpublic = list( + Cv2 = 'numericVector', + Cfoo2 = nFunction( + fun = function(x) { + return(Cfoo(x)) + }, + argTypes = list(x = 'numericScalar'), + returnType = 'numericScalar') + ) + ) + + my.nc2 <- nc2$new() + expect_equal(my.nc2$Rfoo(1), 2) + expect_equal(my.nc2$Rfoo2(1), 2) + expect_equal(my.nc2$Cfoo(1), 2) + expect_equal(my.nc2$Cfoo2(1), 2) + my.nc2$Cv <- 5 + expect_equal(my.nc2$Cv, 5) + my.nc2$Cv2 <- 6 + expect_equal(my.nc2$Cv2, 6) + + expect_true(inherits(my.nc2, "surprise")) + expect_true(inherits(nc1$new(), "surprise")) +}) diff --git a/nCompiler/tests/testthat/nCompile_tests/test-argumentPassing.R b/nCompiler/tests/testthat/nCompile_tests/test-argumentPassing.R index ab06c901..bc1ab49f 100644 --- a/nCompiler/tests/testthat/nCompile_tests/test-argumentPassing.R +++ b/nCompiler/tests/testthat/nCompile_tests/test-argumentPassing.R @@ -60,6 +60,7 @@ test_that("pass 1D by copy works (compiled & uncompiled)", { #################### ## 1D tests +# Shows bug of modifying a lazy copy by blockRef # compiled and uncompiled 1D by ref test_that("pass 1D by ref and blockRef works and error-traps (compiled & uncompiled) in nFunction", { message("This test has many trapped errors.") @@ -77,7 +78,9 @@ test_that("pass 1D by ref and blockRef works and error-traps (compiled & uncompi test_foo <- function(fn) { x <- as.numeric(1:3) xRef <- as.numeric(11:13) + xRef2 <- xRef xBlockRef <- as.numeric(21:23) + xBlockRef2 <- xBlockRef expect_error(fn(x, 11:13, xBlockRef)) # Can't pass literal to ref expect_error(fn(x, xRef, 11:13)) # Can't pass literal to blockRef expect_error(fn(x, xRef[1:3], blockRef)) # Can't pass block to ref @@ -85,6 +88,8 @@ test_that("pass 1D by ref and blockRef works and error-traps (compiled & uncompi expect_equal(y, x[1:2] + 10 + 100) expect_equal(xRef, x[1:2] + 10) expect_equal(xBlockRef, c(21, 1:2 + 10 + 1000)) + expect_equal(xRef2, 11:13) # copies should be unmodified + expect_equal(xBlockRef2, 21:23) } cfoo <- nCompile(foo) test_foo(foo) @@ -106,14 +111,18 @@ test_that("pass 1D by ref and blockRef works and error-traps (compiled & uncompi dir.create(lib, showWarnings=FALSE) withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), upgrade = "never", quick=TRUE, quiet=TRUE)) - withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) - test_foo(access_dynamic_package("testpackage", "foo")) - test_foo(access_dynamic_package("testpackage", "foo")) + withr::with_libpaths(lib, action = "prefix", code = { + load_dynamic_namespace("testpackage") + test_foo(access_dynamic_package("testpackage", "foo")) + test_foo(access_dynamic_package("testpackage", "foo")) + }) }) - test_that("pass 1D by ref and blockRef works and error-traps via nClass method (compiled & uncompiled)", { message("This test has four trapped errors.") + + #debug(nCompiler:::make_nClass_code) + #undebug(nCompiler:::build_Cmethod_code_for_nClass) nc1 <- nClass( Cpublic = list( foo = nFunction( @@ -127,6 +136,7 @@ test_that("pass 1D by ref and blockRef works and error-traps via nClass method ( blockRefArgs = 'xBlockRef', returnType = 'numericVector' ))) + test_foo <- function(fn) { x <- as.numeric(1:3) xRef <- as.numeric(11:13) @@ -146,29 +156,31 @@ test_that("pass 1D by ref and blockRef works and error-traps via nClass method ( Cnc1 <- nCompile(nc1, package = FALSE) Cobj <- Cnc1$new() test_foo(Cobj$foo) - CppObj <- Cobj$private$CppObj + CppObj <- to_generic_interface(Cobj) test_foo(method(CppObj, "foo")) rm(Cobj, CppObj); gc() # Compiled via package Cnc1 <- nCompile(nc1, package = TRUE) Cobj <- Cnc1$new() test_foo(Cobj$foo) - CppObj <- Cobj$private$CppObj + CppObj <- to_generic_interface(Cobj) test_foo(method(CppObj, "foo")) rm(Cobj, CppObj); gc() # Compiled via package via writePackage - dir <- file.path(tempdir(), "test_nComp_testpackage_argPassing") - test <- writePackage(nc1, pkgName = "testpackage", dir = dir, modify="clear") - lib <- file.path(tempdir(), "test_nComp_lib_argPassing") + dir <- file.path(tempdir(), "test_nComp_testpackage_argPassingb") + test <- writePackage(nc1, pkgName = "testpackageb", dir = dir, modify="clear") + lib <- file.path(tempdir(), "test_nComp_lib_argPassingb") dir.create(lib, showWarnings=FALSE) - withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), + withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackageb"), upgrade = "never", quick=TRUE, quiet=TRUE)) - withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) - Cobj <- access_dynamic_package("testpackage", "nc1")$new() - test_foo(Cobj$foo) - CppObj <- Cobj$private$CppObj - test_foo(method(CppObj, "foo")) - rm(Cobj, CppObj); gc() + withr::with_libpaths(lib, action = "prefix", code = { + load_dynamic_namespace("testpackageb") + Cobj <- access_dynamic_package("testpackageb", "nc1")$new() + test_foo(Cobj$foo) + CppObj <- to_generic_interface(Cobj) + test_foo(method(CppObj, "foo")) + rm(Cobj, CppObj); gc() + }) }) #################### @@ -211,15 +223,17 @@ test_that("pass 2D by ref and blockRef works and error-traps (compiled & uncompi test_foo(cfoo) test_foo(cfoo) - dir <- file.path(tempdir(), "test_nComp_testpackage_argPassing") - test <- writePackage(foo, pkgName = "testpackage", dir = dir, modify="clear") - lib <- file.path(tempdir(), "test_nComp_lib_argPassing") + dir <- file.path(tempdir(), "test_nComp_testpackage_argPassing2") + test <- writePackage(foo, pkgName = "testpackage2", dir = dir, modify="clear") + lib <- file.path(tempdir(), "test_nComp_lib_argPassing2") dir.create(lib, showWarnings=FALSE) - withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), + withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage2"), upgrade = "never", quick=TRUE, quiet=TRUE)) - withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) - test_foo(testpackage::foo) - test_foo(testpackage::foo) + withr::with_libpaths(lib, action = "prefix", code = { + load_dynamic_namespace("testpackage2") + test_foo(testpackage2::foo) + test_foo(testpackage2::foo) + }) }) test_that("pass 2D by ref and blockRef works and error-traps via nClass method (compiled & uncompiled)", { @@ -260,7 +274,7 @@ test_that("pass 2D by ref and blockRef works and error-traps via nClass method ( Cnc1 <- nCompile(nc1, package = FALSE) Cobj <- Cnc1$new() test_foo(Cobj$foo) - CppObj <- Cobj$private$CppObj + CppObj <- to_generic_interface(Cobj) test_foo(method(CppObj, "foo")) rm(Cobj, CppObj); gc() @@ -268,23 +282,25 @@ test_that("pass 2D by ref and blockRef works and error-traps via nClass method ( Cnc1 <- nCompile(nc1, package = TRUE) Cobj <- Cnc1$new() test_foo(Cobj$foo) - CppObj <- Cobj$private$CppObj + CppObj <- to_generic_interface(Cobj) test_foo(method(CppObj, "foo")) rm(Cobj, CppObj); gc() # Compiled via package via writePackage - dir <- file.path(tempdir(), "test_nComp_testpackage_argPassing") - test <- writePackage(nc1, pkgName = "testpackage", dir = dir, modify="clear") - lib <- file.path(tempdir(), "test_nComp_lib_argPassing") + dir <- file.path(tempdir(), "test_nComp_testpackage_argPassing2b") + test <- writePackage(nc1, pkgName = "testpackage2b", dir = dir, modify="clear") + lib <- file.path(tempdir(), "test_nComp_lib_argPassing2b") dir.create(lib, showWarnings=FALSE) - withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), + withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage2b"), upgrade = "never", quick=TRUE, quiet=TRUE)) - withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) - Cobj <- testpackage::nc1$new() - test_foo(Cobj$foo) - CppObj <- Cobj$private$CppObj - test_foo(method(CppObj, "foo")) - rm(Cobj, CppObj); gc() + withr::with_libpaths(lib, action = "prefix", code = { + load_dynamic_namespace("testpackage2b") + Cobj <- testpackage2b::nc1$new() + test_foo(Cobj$foo) + CppObj <- to_generic_interface(Cobj) + test_foo(method(CppObj, "foo")) + rm(Cobj, CppObj); gc() + }) }) ##################### @@ -327,15 +343,17 @@ test_that("pass 3D by ref and blockRef works and error-traps (compiled & uncompi test_foo(cfoo) test_foo(cfoo) - dir <- file.path(tempdir(), "test_nComp_testpackage_argPassing") - test <- writePackage(foo, pkgName = "testpackage", dir = dir, modify="clear") - lib <- file.path(tempdir(), "test_nComp_lib_argPassing") + dir <- file.path(tempdir(), "test_nComp_testpackage_argPassing3") + test <- writePackage(foo, pkgName = "testpackage3", dir = dir, modify="clear") + lib <- file.path(tempdir(), "test_nComp_lib_argPassing3") dir.create(lib, showWarnings=FALSE) - withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), + withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage3"), upgrade = "never", quick=TRUE, quiet=TRUE)) - withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) - test_foo(testpackage::foo) - test_foo(testpackage::foo) + withr::with_libpaths(lib, action = "prefix", code = { + load_dynamic_namespace("testpackage3") + test_foo(testpackage3::foo) + test_foo(testpackage3::foo) + }) }) test_that("pass 2D by ref and blockRef works and error-traps via nClass method (compiled & uncompiled)", { @@ -377,7 +395,7 @@ test_that("pass 2D by ref and blockRef works and error-traps via nClass method ( Cnc1 <- nCompile(nc1, package = FALSE) Cobj <- Cnc1$new() test_foo(Cobj$foo) - CppObj <- Cobj$private$CppObj + CppObj <- to_generic_interface(Cobj) test_foo(method(CppObj, "foo")) rm(Cobj, CppObj); gc() @@ -385,25 +403,281 @@ test_that("pass 2D by ref and blockRef works and error-traps via nClass method ( Cnc1 <- nCompile(nc1, package = TRUE) Cobj <- Cnc1$new() test_foo(Cobj$foo) - CppObj <- Cobj$private$CppObj + CppObj <- to_generic_interface(Cobj) test_foo(method(CppObj, "foo")) rm(Cobj, CppObj); gc() # Compiled via package via writePackage - dir <- file.path(tempdir(), "test_nComp_testpackage_argPassing") - test <- writePackage(nc1, pkgName = "testpackage", dir = dir, modify="clear") - lib <- file.path(tempdir(), "test_nComp_lib_argPassing") + dir <- file.path(tempdir(), "test_nComp_testpackage_argPassing3b") + test <- writePackage(nc1, pkgName = "testpackage3b", dir = dir, modify="clear") + lib <- file.path(tempdir(), "test_nComp_lib_argPassing3b") dir.create(lib, showWarnings=FALSE) - withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), + withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage3b"), upgrade = "never", quick=TRUE, quiet=TRUE)) - withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) - Cobj <- testpackage::nc1$new() - test_foo(Cobj$foo) - CppObj <- Cobj$private$CppObj - test_foo(method(CppObj, "foo")) - rm(Cobj, CppObj); gc() + withr::with_libpaths(lib, action = "prefix", code = { + load_dynamic_namespace("testpackage3b") + Cobj <- testpackage3b::nc1$new() + test_foo(Cobj$foo) + CppObj <- to_generic_interface(Cobj) + test_foo(method(CppObj, "foo")) + rm(Cobj, CppObj); gc() + }) +}) + +## Tests added while re-designing these schemes as part of redesigning nClasses +## Jan 2026 + +test_that("nested pass by ref works", { + foo1 <- nFunction( + fun=function(x=double(1)) { + x <- x+1 + }, + refArgs = "x" + ) + foo2 <- nFunction( + fun=function(x=double(1)) { + foo1(x) + }, + refArgs = "x" + ) + foo3 <- nFunction( + fun=function(x=double(1)) { + x <- x + 1 + foo1(x) + }, + refArgs = "x" + ) + x <- as.numeric(1:2) + foo1(x) + expect_equal(x, 2:3) + x <- as.numeric(1:2) + foo2(x) + expect_equal(x, 2:3) + x <- as.numeric(1:2) + foo3(x) + expect_equal(x, 3:4) + + C <- nCompile(foo1, foo2, foo3) + x <- as.numeric(1:2) + C$foo1(x) + expect_equal(x, 2:3) + x <- as.numeric(1:2) + C$foo2(x) + expect_equal(x, 2:3) + x <- as.numeric(1:2) + C$foo3(x) + expect_equal(x, 3:4) + + # Nest from R to C++ + foo4 <- nFunction( + fun=function(x=double(1)) { + C$foo3(x) + }, + refArgs = "x" + ) + x <- as.numeric(1:2) + foo4(x) + expect_equal(x, 3:4) +}) + +## FIXED when nested from R to C++ with brackets in use. +test_that("nested pass by blockRef case 1 works", { + foo1 <- nFunction( + fun=function(x=double(1)) { + x <- x+1 + }, + blockRefArgs = "x" + ) + foo2 <- nFunction( + fun=function(x=double(1)) { + foo1(x) + }, + blockRefArgs = "x" + ) + foo3 <- nFunction( + fun=function(x=double(1)) { + x <- x + 1 + foo1(x) + }, + blockRefArgs = "x" + ) + x <- as.numeric(1:2) + foo1(x) + expect_equal(x, 2:3) + x <- as.numeric(1:2) + foo2(x) + expect_equal(x, 2:3) + x <- as.numeric(1:2) + foo3(x) + expect_equal(x, 3:4) + + Cfoo1 <- nCompile(foo1) + + C <- nCompile(foo1, foo2, foo3) + x <- as.numeric(1:2) + C$foo1(x[1:2]) + expect_equal(x, 2:3) + x <- as.numeric(1:2) + C$foo2(x[1:2]) + expect_equal(x, 2:3) + x <- as.numeric(1:2) + C$foo3(x[1:2]) + expect_equal(x, 3:4) + + # Nest from R to C++ + foo4 <- nFunction( + fun=function(x=double(1)) { + C$foo3(x) + }, + blockRefArgs = "x" + ) + x <- as.numeric(1:2) + foo4(x[1:2]) + expect_equal(x, 3:4) ## FIXED +}) + +# FAIL with the same argument pass by refArg to C++ +# This will NEVER (in any forseeable way) be made to work +# in the case from R to C++ +test_that("pass by ref with same ref in multiple args works except R->C++", { + foo1 <- nFunction( + fun=function(x=double(1), y=double(1)) { + z <- x + x <- x+1 + y <- z+2 + # foo1(v, v) should set v = v+2 + }, + refArgs = c("x", "y") + ) + v <- as.numeric(1:2) + foo1(v, v) + expect_equal(v, 3:4) + + foo2 <- nFunction( + fun=function(x=double(1), y=double(1)) { + z <- x + y <- z+2 + x <- x+1 + # foo1(v, v) should set v = v + 2 + }, + refArgs = c("x", "y") + ) + v <- as.numeric(1:2) + foo2(v, v) + expect_equal(v, (1:2)+3) + + C <- nCompile(foo1, foo2) + + v <- as.numeric(1:2) + C$foo1(v, v) + expect_false(identical(v, 3:4)) # FAIL + + v <- as.numeric(1:2) + C$foo2(v, v) + expect_false(identical(v, (1:2)+3)) # FAIL + + # Nest from R to C++ + }) +# This will NEVER be made to work in the case from R to C++ +test_that("pass by blockRef with same ref in multiple args works except R->C++", { + foo1 <- nFunction( + fun=function(x=double(1), y=double(1)) { + z <- x + x <- x+1 + y <- z+2 + # foo1(v, v) should set v = v+2 + }, + blockRefArgs = c("x", "y") + ) + v <- as.numeric(1:3) + foo1(v[2:3], v[2:3]) + expect_equal(v, c(1, (2:3) + 2)) + + foo2 <- nFunction( + fun=function(x=double(1), y=double(1)) { + z <- x + y <- z+2 + x <- x+1 + # foo1(v, v) should set v = v + 2 + }, + blockRefArgs = c("x", "y") + ) + v <- as.numeric(1:3) + foo2(v[2:3], v[2:3]) + expect_equal(v, c(1, (2:3) + 3)) + + C <- nCompile(foo1, foo2) + + v <- as.numeric(1:3) + C$foo1(v[2:3], v[2:3]) + expect_false(identical(v, c(1, (2:3) + 2))) # FAIL + + v <- as.numeric(1:3) + C$foo2(v[2:3], v[2:3]) + expect_false(identical(v, c(1, (2:3) + 3))) +}) + +message("Uncomment an argumentPassing test when nested STM / ISEQS_ issues are fixed") + +## This fails to compile due to ISEQS_ issues +## test_that("nested pass by blockRef works", { +## foo1 <- nFunction( +## fun=function(x=double(1)) { +## x <- x+1 +## }, +## blockRefArgs = "x" +## ) +## foo2 <- nFunction( +## fun=function(x=double(1)) { +## foo1(x[1:2]) +## }, +## blockRefArgs = "x" +## ) +## foo3 <- nFunction( +## fun=function(x=double(1)) { +## x <- x + 1 +## foo1(x[1:2]) +## }, +## blockRefArgs = "x" +## ) +## x <- as.numeric(1:2) +## foo1(x) +## expect_equal(x, 2:3) +## x <- as.numeric(1:2) +## foo2(x) +## expect_equal(x, 2:3) +## x <- as.numeric(1:2) +## foo3(x) +## expect_equal(x, 3:4) + +## C <- nCompile(foo1, foo2, foo3) +## x <- as.numeric(1:2) +## C$foo1(x) +## expect_equal(x, 2:3) +## x <- as.numeric(1:2) +## foo2(x) +## expect_equal(x, 2:3) +## x <- as.numeric(1:2) +## foo3(x) +## expect_equal(x, 3:4) + +## foo4 <- nFunction( +## fun=function(x=double(1)) { +## C$foo3(x) +## }, +## blockRefArgs = "x" +## ) +## x <- as.numeric(1:2) +## foo4(x) +## expect_equal(x, 3:4) + +## }) + + + + ## It seems like this test should give an error because we are assigning ## from a vector to a scalar and the vector is not length 1. ## This seems to occur from flex_(y) assignment. diff --git a/nCompiler/tests/testthat/nCompile_tests/test-nCompile.R b/nCompiler/tests/testthat/nCompile_tests/test-nCompile.R index 38f2945b..8c3749dc 100644 --- a/nCompiler/tests/testthat/nCompile_tests/test-nCompile.R +++ b/nCompiler/tests/testthat/nCompile_tests/test-nCompile.R @@ -28,877 +28,926 @@ message("add test for control$changeKeywords") # and then checking that they work. So we use access_dynamic_package, # which internally uses get(), to avoid the `::` syntax. access_dynamic_package <- function(pkg_name, var) { - if (!isNamespaceLoaded(pkg_name)) { - stop(paste("Dynamic package", pkg_name, "is not loaded")) - } - ns <- asNamespace(pkg_name) - get(var, envir = ns, inherits = FALSE) + if (!isNamespaceLoaded(pkg_name)) { + stop(paste("Dynamic package", pkg_name, "is not loaded")) + } + ns <- asNamespace(pkg_name) + get(var, envir = ns, inherits = FALSE) } -# Same rationale as above: + # Same rationale as above: load_dynamic_namespace <- function(pkg_name) { - eval(call("loadNamespace", pkg_name)) + eval(call("loadNamespace", pkg_name)) } test_that("nCompile direct, package, and writePackage work with Eigen::Tensors", { - add_vectors <- nFunction( - fun = function(x = double(1), - y = double(1)) { - returnType(double(1)) - ans <- x + y - return(ans) - } - ) - x1 <- 1:3 - x2 <- 11:13 - expect_equal(x1 + x2, add_vectors(x1, x2)) - c1 <- nCompile(add_vectors) - expect_equal(x1 + x2, c1(x1, x2)) - c2 <- nCompile(add_vectors, package = TRUE) - expect_equal(x1 + x2, c2(x1, x2)) - dir <- file.path(tempdir(), "test_nComp_testpackage") - test <- writePackage(add_vectors, pkgName = "testpackage", dir = dir, modify="clear") - lib <- file.path(tempdir(), "test_nComp_lib") - dir.create(lib, showWarnings=FALSE) - withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), - upgrade = "never", quick=TRUE, quiet=TRUE)) - withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) - expect_equal(x1+x2, access_dynamic_package("testpackage", "add_vectors")(x1, x2)) # testpackage::add_vectors(x1, x2)) - pkgload::unload("testpackage") -}) - -test_that("nCompile direct, package, and writePackage work with nClass interfaces", { - nc <- nClass( - Cpublic = list( - add_vectors = nFunction( + add_vectors <- nFunction( fun = function(x = double(1), y = double(1)) { - returnType(double(1)) - ans <- x + y - return(ans) + returnType(double(1)) + ans <- x + y + return(ans) } - ) ) - ) - x1 <- 1:3 - x2 <- 11:13 - nc1 <- nc$new() - expect_equal(x1 + x2, nc1$add_vectors(x1, x2)) - c1 <- nCompile(nc) - obj <- c1$new() - expect_equal(x1 + x2, obj$add_vectors(x1, x2)) - CppObj <- obj$private$CppObj - expect_equal(x1 + x2, method(CppObj, 'add_vectors')(x1, x2)) - rm(CppObj, obj); gc(); - - c2 <- nCompile(nc, package = TRUE) - obj <- c2$new() - expect_equal(x1 + x2, obj$add_vectors(x1, x2)) - CppObj <- obj$private$CppObj - expect_equal(x1 + x2, method(CppObj, 'add_vectors')(x1, x2)) - rm(CppObj, obj); gc(); - - c3 <- nCompile(nc, package = TRUE, interfaces = "generic") - CppObj <- c3() - expect_equal(x1 + x2, method(CppObj, 'add_vectors')(x1, x2)) - obj <- to_full_interface(CppObj) - expect_equal(x1 + x2, obj$add_vectors(x1, x2)) - rm(CppObj, obj); gc(); - - dir <- file.path(tempdir(), "test_nComp_testpackage") - test <- writePackage(nc, pkgName = "testpackage", dir = dir, modify="clear") - lib <- file.path(tempdir(), "test_nComp_lib") - dir.create(lib, showWarnings=FALSE) - withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), - upgrade = "never", quick=TRUE, quiet=TRUE)) - withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) - obj <- access_dynamic_package("testpackage", "nc")$new() #testpackage::nc$new() - expect_equal(x1 + x2, obj$add_vectors(x1, x2)) - CppObj <- obj$private$CppObj - expect_equal(x1 + x2, method(CppObj, 'add_vectors')(x1, x2)) - rm(CppObj, obj); gc(); pkgload::unload("testpackage") - - dir <- file.path(tempdir(), "test_nComp_testpackage") - test <- writePackage(nc, pkgName = "testpackage", interfaces = "generic", dir = dir, modify="clear") - lib <- file.path(tempdir(), "test_nComp_lib") - dir.create(lib, showWarnings=FALSE) - withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), - upgrade = "never", quick=TRUE, quiet=TRUE)) - withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) - CppObj <- access_dynamic_package("testpackage", "nc")() # testpackage::nc() - expect_equal(x1 + x2, method(CppObj, 'add_vectors')(x1, x2)) - obj <- to_full_interface(CppObj) - expect_equal(x1 + x2, obj$add_vectors(x1, x2)) - rm(CppObj, obj); gc(); pkgload::unload("testpackage") + x1 <- 1:3 + x2 <- 11:13 + expect_equal(x1 + x2, add_vectors(x1, x2)) + c1 <- nCompile(add_vectors) + expect_equal(x1 + x2, c1(x1, x2)) + c2 <- nCompile(add_vectors, package = TRUE) + expect_equal(x1 + x2, c2(x1, x2)) + dir <- file.path(tempdir(), "test_nComp_testpackage") + test <- writePackage(add_vectors, pkgName = "testpackage", dir = dir, modify="clear") + lib <- file.path(tempdir(), "test_nComp_lib") + dir.create(lib, showWarnings=FALSE) + withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), + upgrade = "never", quick=TRUE, quiet=TRUE)) + withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) + expect_equal(x1+x2, access_dynamic_package("testpackage", "add_vectors")(x1, x2)) # testpackage::add_vectors(x1, x2)) + pkgload::unload("testpackage") +}) + +test_that("nCompile direct, package, and writePackage work with nClass interfaces", { + nc <- nClass( + Cpublic = list( + add_vectors = nFunction( + fun = function(x = double(1), + y = double(1)) { + returnType(double(1)) + ans <- x + y + return(ans) + } + ) + ) + ) + x1 <- 1:3 + x2 <- 11:13 + nc1 <- nc$new() + expect_equal(x1 + x2, nc1$add_vectors(x1, x2)) + expect_false(nc1$isCompiled()) + expect_false(nc1$private$Cpublic_obj$isCompiled()) + #debug(nCompiler:::build_compiled_nClasses) + #debug(nCompiler:::nCompile_finish_nonpackage) + #debug(nCompiler:::build_compiled_nClass) + c1 <- nCompile(nc) + obj <- c1$new() + expect_true(obj$isCompiled()) + expect_true(obj$private$Cpublic_obj$isCompiled()) + expect_equal(x1 + x2, obj$add_vectors(x1, x2)) + CppObj <- to_generic_interface(obj)# to_generic_interface(obj) + expect_equal(x1 + x2, method(CppObj, 'add_vectors')(x1, x2)) + expect_equal(x1 + x2, method(obj, 'add_vectors')(x1, x2)) + rm(CppObj, obj); gc(); + + #debug(nCompiler:::WP_writeRinterfaces) + #debug(nCompiler:::build_compiled_nClasses) + #debug(nCompiler:::build_compiled_nClass) + #debug(nCompiler:::WP_write_dotOnLoad) +# debug(nCompiler:::nCompile) + + c2 <- nCompile(nc, package = TRUE) + obj <- c2$new() + expect_true(obj$isCompiled()) + expect_true(obj$private$Cpublic_obj$isCompiled()) + expect_equal(x1 + x2, obj$add_vectors(x1, x2)) + CppObj <- to_generic_interface(obj) + expect_equal(x1 + x2, method(CppObj, 'add_vectors')(x1, x2)) + expect_equal(x1 + x2, method(obj, "add_vectors")(x1, x2)) + rm(CppObj, obj); gc(); + + c3 <- nCompile(nc, package = TRUE, interfaces = "generic") + CppObj <- c3() + expect_equal(x1 + x2, method(CppObj, 'add_vectors')(x1, x2)) + obj <- to_full_interface(CppObj) + expect_true(obj$isCompiled()) + expect_true(obj$private$Cpublic_obj$isCompiled()) + expect_equal(x1 + x2, obj$add_vectors(x1, x2)) + expect_equal(CppObj, to_generic_interface(obj)) + rm(CppObj, obj); gc(); + + dir <- file.path(tempdir(), "test_nComp_testpackage") + compileInfo(nc)$packageNames <- c(compiled = "ncc") + test <- writePackage(nc, pkgName = "testpackage", dir = dir, modify="clear") + lib <- file.path(tempdir(), "test_nComp_lib") + dir.create(lib, showWarnings=FALSE) + withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), + upgrade = "never", quick=TRUE, quiet=TRUE)) + withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) + obj <- access_dynamic_package("testpackage", "ncc")$new() #testpackage::nc$new() + expect_equal(x1 + x2, obj$add_vectors(x1, x2)) + CppObj <- to_generic_interface(obj) + expect_equal(x1 + x2, method(CppObj, 'add_vectors')(x1, x2)) + rm(CppObj, obj); gc(); pkgload::unload("testpackage") + + dir <- file.path(tempdir(), "test_nComp_testpackage") + test <- writePackage(nc, pkgName = "testpackage", interfaces = "generic", dir = dir, modify="clear") + lib <- file.path(tempdir(), "test_nComp_lib") + dir.create(lib, showWarnings=FALSE) + withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), + upgrade = "never", quick=TRUE, quiet=TRUE)) + withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) + CppObj <- access_dynamic_package("testpackage", "ncc")() # testpackage::nc() + expect_equal(x1 + x2, method(CppObj, 'add_vectors')(x1, x2)) + obj <- to_full_interface(CppObj) + expect_equal(x1 + x2, obj$add_vectors(x1, x2)) + rm(CppObj, obj); gc(); pkgload::unload("testpackage") }) test_that("nCompile direct, package, and writePackage work with various name management", { - add.Scalars_name <- nFunction( - name = 'Cadd.scalars', - fun = function(x = double(0), - y = double(0)) { - returnType(double(0)) - ans <- x + y - return(ans) - } - ) - - add.Scalars_name_eName <- nFunction( - name = 'Cadd.scalars', - compileInfo = list(exportName = "foo2"), - fun = function(x = double(0), - y = double(0)) { - returnType(double(0)) - ans <- x + y - return(ans) - } - ) - - add.Scalars <- nFunction( - fun = function(x = double(0), - y = double(0)) { - returnType(double(0)) - ans <- x + y - return(ans) - } - ) - - add.Scalars_eName <- nFunction( - compileInfo = list(exportName = "foo1"), - fun = function(x = double(0), - y = double(0)) { - returnType(double(0)) - ans <- x + y - return(ans) - } - ) - - test <- nCompile(add.Scalars, package = FALSE, returnList = TRUE) - expect_equal(test$add.Scalars(2, 3), 5) - test <- nCompile(add.Scalars, package = TRUE, returnList = TRUE) - expect_equal(test$add.Scalars(2, 3), 5) - dir <- file.path(tempdir(), "test_nComp_testpackage") - dir.create(dir, showWarnings=FALSE) - test <- writePackage(add.Scalars, pkgName = "testpackage", dir = dir, modify="clear") - lib <- file.path(tempdir(), "test_nComp_lib") - dir.create(lib, showWarnings=FALSE) - withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), - upgrade = "never", quick=TRUE, quiet=TRUE)) - withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) - expect_equal(access_dynamic_package("testpackage", "add.Scalars")(2, 3), 5) #testpackage::add.Scalars(2, 3), 5) - pkgload::unload("testpackage") - - test <- nCompile(add.Scalars_name, package = FALSE, returnList = TRUE) - expect_equal(test$add.Scalars_name(2, 3), 5) - test <- nCompile(add.Scalars_name, package = TRUE, returnList = TRUE) - expect_equal(test$add.Scalars_name(2, 3), 5) - dir <- file.path(tempdir(), "test_nComp_testpackage") - dir.create(dir, showWarnings=FALSE) - test <- writePackage(add.Scalars_name, pkgName = "testpackage", dir = dir, modify="clear") - lib <- file.path(tempdir(), "test_nComp_lib") - dir.create(lib, showWarnings=FALSE) - withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), - upgrade = "never", quick=TRUE, quiet=TRUE)) - withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) - expect_equal(access_dynamic_package("testpackage", "add.Scalars_name")(2, 3), 5) #testpackage::add.Scalars_name(2, 3), 5) - pkgload::unload("testpackage") - - test <- nCompile(add.Scalars_eName, package = FALSE, returnList = TRUE) - expect_equal(test$foo1(2, 3), 5) - test <- nCompile(add.Scalars_eName, package = TRUE, returnList = TRUE) - expect_equal(test$foo1(2, 3), 5) - dir <- file.path(tempdir(), "test_nComp_testpackage") - dir.create(dir, showWarnings=FALSE) - test <- writePackage(add.Scalars_eName, pkgName = "testpackage", dir = dir, modify="clear") - lib <- file.path(tempdir(), "test_nComp_lib") - dir.create(lib, showWarnings=FALSE) - withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), - upgrade = "never", quick=TRUE, quiet=TRUE)) - withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) - expect_equal(access_dynamic_package("testpackage", "foo1")(2, 3), 5) #testpackage::foo1(2, 3), 5) - pkgload::unload("testpackage") - - test <- nCompile(add.Scalars_name_eName, package = FALSE, returnList = TRUE) - expect_equal(test$foo2(2, 3), 5) - test <- nCompile(add.Scalars_name_eName, package = TRUE, returnList = TRUE) - expect_equal(test$foo2(2, 3), 5) - dir <- file.path(tempdir(), "test_nComp_testpackage") - dir.create(dir, showWarnings=FALSE) - test <- writePackage(add.Scalars_name_eName, pkgName = "testpackage", dir = dir, modify="clear") - lib <- file.path(tempdir(), "test_nComp_lib") - dir.create(lib, showWarnings=FALSE) - withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), - upgrade = "never", quick=TRUE, quiet=TRUE)) - withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) - expect_equal(access_dynamic_package("testpackage", "foo2")(2, 3), 5) # testpackage::foo2(2, 3), 5) - pkgload::unload("testpackage") + add.Scalars_name <- nFunction( + name = 'Cadd.scalars', + fun = function(x = double(0), + y = double(0)) { + returnType(double(0)) + ans <- x + y + return(ans) + } + ) + + add.Scalars_name_eName <- nFunction( + name = 'Cadd.scalars', + compileInfo = list(exportName = "foo2"), + fun = function(x = double(0), + y = double(0)) { + returnType(double(0)) + ans <- x + y + return(ans) + } + ) + + add.Scalars <- nFunction( + fun = function(x = double(0), + y = double(0)) { + returnType(double(0)) + ans <- x + y + return(ans) + } + ) + + add.Scalars_eName <- nFunction( + compileInfo = list(exportName = "foo1"), + fun = function(x = double(0), + y = double(0)) { + returnType(double(0)) + ans <- x + y + return(ans) + } + ) + + # simplest case: no explicit version of naming + test <- nCompile(add.Scalars, package = FALSE, returnList = TRUE) + expect_equal(test$add.Scalars(2, 3), 5) + test <- nCompile(add.Scalars, package = TRUE, returnList = TRUE) + expect_equal(test$add.Scalars(2, 3), 5) + dir <- file.path(tempdir(), "test_nComp_testpackage") + dir.create(dir, showWarnings=FALSE) + test <- writePackage(add.Scalars, pkgName = "testpackage", dir = dir, modify="clear") + lib <- file.path(tempdir(), "test_nComp_lib") + dir.create(lib, showWarnings=FALSE) + withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), + upgrade = "never", quick=TRUE, quiet=TRUE)) + withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) + expect_equal(access_dynamic_package("testpackage", "add.Scalars")(2, 3), 5) #testpackage::add.Scalars(2, 3), 5) + pkgload::unload("testpackage") + + # next case: the nFunction has a name argument, but that should correctly not be used + test <- nCompile(add.Scalars_name, package = FALSE, returnList = TRUE) + expect_equal(test$add.Scalars_name(2, 3), 5) + test <- nCompile(add.Scalars_name, package = TRUE, returnList = TRUE) + expect_equal(test$add.Scalars_name(2, 3), 5) + dir <- file.path(tempdir(), "test_nComp_testpackage") + dir.create(dir, showWarnings=FALSE) + test <- writePackage(add.Scalars_name, pkgName = "testpackage", dir = dir, modify="clear") + lib <- file.path(tempdir(), "test_nComp_lib") + dir.create(lib, showWarnings=FALSE) + withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), + upgrade = "never", quick=TRUE, quiet=TRUE)) + withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) + expect_equal(access_dynamic_package("testpackage", "add.Scalars_name")(2, 3), 5) #testpackage::add.Scalars_name(2, 3), 5) + pkgload::unload("testpackage") + + # next case: an exportName is provided + test <- nCompile(add.Scalars_eName, package = FALSE, returnList = TRUE) + expect_equal(test$foo1(2, 3), 5) + test <- nCompile(add.Scalars_eName, package = TRUE, returnList = TRUE) + expect_equal(test$foo1(2, 3), 5) + dir <- file.path(tempdir(), "test_nComp_testpackage") + dir.create(dir, showWarnings=FALSE) + test <- writePackage(add.Scalars_eName, pkgName = "testpackage", dir = dir, modify="clear") + lib <- file.path(tempdir(), "test_nComp_lib") + dir.create(lib, showWarnings=FALSE) + withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), + upgrade = "never", quick=TRUE, quiet=TRUE)) + withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) + expect_equal(access_dynamic_package("testpackage", "foo1")(2, 3), 5) #testpackage::foo1(2, 3), 5) + pkgload::unload("testpackage") + + # next case: an exportName and a name argument are provided. The exportName should get used. + test <- nCompile(add.Scalars_name_eName, package = FALSE, returnList = TRUE) + expect_equal(test$foo2(2, 3), 5) + test <- nCompile(add.Scalars_name_eName, package = TRUE, returnList = TRUE) + expect_equal(test$foo2(2, 3), 5) + dir <- file.path(tempdir(), "test_nComp_testpackage") + dir.create(dir, showWarnings=FALSE) + test <- writePackage(add.Scalars_name_eName, pkgName = "testpackage", dir = dir, modify="clear") + lib <- file.path(tempdir(), "test_nComp_lib") + dir.create(lib, showWarnings=FALSE) + withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), + upgrade = "never", quick=TRUE, quiet=TRUE)) + withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) + expect_equal(access_dynamic_package("testpackage", "foo2")(2, 3), 5) # testpackage::foo2(2, 3), 5) + pkgload::unload("testpackage") }) test_that("nCompile works for nClass with classname and/or exportName and either interface", { - nc_name <- nClass( - classname = "nc.1", - Cpublic = list( - v.1 = 'numericVector', - go.1 = nFunction( - fun = function(c = 'numericScalar') { - return(c * v.1) - }, - returnType = 'numericVector' - ) + nc_name <- nClass( + classname = "nc.1", + Cpublic = list( + v.1 = 'numericVector', + go.1 = nFunction( + fun = function(c = 'numericScalar') { + return(c * v.1) + }, + returnType = 'numericVector' + ) + ) ) - ) - - nc <- nClass( - Cpublic = list( - v.1 = 'numericVector', - go.1 = nFunction( - fun = function(c = 'numericScalar') { - return(c * v.1) - }, - returnType = 'numericVector' - ) + + nc <- nClass( + Cpublic = list( + v.1 = 'numericVector', + go.1 = nFunction( + fun = function(c = 'numericScalar') { + return(c * v.1) + }, + returnType = 'numericVector' + ) + ) ) - ) - - nc_name_eName <- nClass( - classname = "nc.1", - compileInfo = list(exportName = "exnc2"), - Cpublic = list( - v.1 = 'numericVector', - go.1 = nFunction( - fun = function(c = 'numericScalar') { - return(c * v.1) - }, - returnType = 'numericVector' - ) + + nc_name_eName <- nClass( + classname = "nc.1", + compileInfo = list(exportName = "exnc2"), + Cpublic = list( + v.1 = 'numericVector', + go.1 = nFunction( + fun = function(c = 'numericScalar') { + return(c * v.1) + }, + returnType = 'numericVector' + ) + ) ) - ) - - nc_eName <- nClass( - compileInfo = list(exportName = "exnc1"), - Cpublic = list( - v.1 = 'numericVector', - go.1 = nFunction( - fun = function(c = 'numericScalar') { - return(c * v.1) - }, - returnType = 'numericVector' - ) + + nc_eName <- nClass( + compileInfo = list(exportName = "exnc1"), + Cpublic = list( + v.1 = 'numericVector', + go.1 = nFunction( + fun = function(c = 'numericScalar') { + return(c * v.1) + }, + returnType = 'numericVector' + ) + ) ) - ) - - test_obj <- function(obj) { - if(`:::`("nCompiler", "is.loadedObjectEnv")(obj)) { - value(obj, "v.1") <- 1:3 - expect_equal(value(obj, "v.1"), 1:3) - expect_identical(method(obj, "go.1")(10), 10 * (1:3)) - } else { - obj$v.1 <- 1:3 - expect_equal(obj$v.1, 1:3) - expect_identical(obj$go.1(10), 10 * (1:3)) + + test_obj <- function(obj) { + if(`:::`("nCompiler", "is.loadedObjectEnv")(obj)) { + value(obj, "v.1") <- 1:3 + expect_equal(value(obj, "v.1"), 1:3) + expect_identical(method(obj, "go.1")(10), 10 * (1:3)) + } else { + obj$v.1 <- 1:3 + expect_equal(obj$v.1, 1:3) + expect_identical(obj$go.1(10), 10 * (1:3)) + } } - } ###### plain version of nc - ## generic & direct - test <- nCompile(nc, package=FALSE, interfaces = "generic", returnList = TRUE) - obj <- test$nc(); test_obj(obj) - objf <- to_full_interface(obj); test_obj(objf) - rm(obj, objf); gc() - ## full & direct - test <- nCompile(nc, package=FALSE, interfaces = "full", returnList = TRUE) - obj <- test$nc$new(); test_obj(obj) - objC <- obj$private$CppObj; test_obj(objC) - rm(obj, objC); gc() - - ## generic & package - test <- nCompile(nc, package=TRUE, interfaces = "generic", returnList = TRUE) - obj <- test$nc(); test_obj(obj) - objf <- to_full_interface(obj); test_obj(objf) - rm(obj, objf); gc() - ## full & package - test <- nCompile(nc, package=TRUE, interfaces = "full", returnList = TRUE) - obj <- test$nc$new(); test_obj(obj) - objC <- obj$private$CppObj; test_obj(objC) - rm(obj, objC); gc() - - ## generic & writePackage - dir <- file.path(tempdir(), "test_nComp_testpackage2") - dir.create(dir, showWarnings=FALSE) - test <- writePackage(nc, interfaces = "generic", pkgName = "testpackage", dir = dir, modify="clear") - lib <- file.path(tempdir(), "test_nComp_lib2") - dir.create(lib, showWarnings=FALSE) - withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), - upgrade = "never", quick=TRUE, quiet=TRUE)) - withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) - obj <- access_dynamic_package("testpackage", "nc")(); test_obj(obj) - objf <- to_full_interface(obj); test_obj(objf) - rm(obj, objf); gc(); pkgload::unload("testpackage") - - ## full & writePackage - dir <- file.path(tempdir(), "test_nComp_testpackage2") - dir.create(dir, showWarnings=FALSE) - test <- writePackage(nc, pkgName = "testpackage", dir = dir, modify="clear") - lib <- file.path(tempdir(), "test_nComp_lib2") - dir.create(lib, showWarnings=FALSE) - withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), - upgrade = "never", quick=TRUE, quiet=TRUE)) - withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) - obj <- access_dynamic_package("testpackage", "nc")$new(); test_obj(obj) - objC <- obj$private$CppObj; test_obj(objC) - rm(obj, objC); gc() + ## generic & direct + test <- nCompile(nc, package=FALSE, interfaces = "generic", returnList = TRUE) + obj <- test$nc(); test_obj(obj) + objf <- to_full_interface(obj); test_obj(objf) + rm(obj, objf); gc() + ## full & direct + test <- nCompile(nc, package=FALSE, interfaces = "full", returnList = TRUE) + obj <- test$nc$new(); test_obj(obj) + objC <- to_generic_interface(obj); test_obj(objC) + rm(obj, objC); gc() + + ## generic & package + test <- nCompile(nc, package=TRUE, interfaces = "generic", returnList = TRUE) + obj <- test$nc(); test_obj(obj) + objf <- to_full_interface(obj); test_obj(objf) + rm(obj, objf); gc() + ## full & package + test <- nCompile(nc, package=TRUE, interfaces = "full", returnList = TRUE) + obj <- test$nc$new(); test_obj(obj) + objC <- to_generic_interface(obj); test_obj(objC) + rm(obj, objC); gc() + + ## generic & writePackage + dir <- file.path(tempdir(), "test_nComp_testpackage2") + dir.create(dir, showWarnings=FALSE) + test <- writePackage(nc, interfaces = "generic", pkgName = "testpackage", dir = dir, modify="clear") + lib <- file.path(tempdir(), "test_nComp_lib2") + dir.create(lib, showWarnings=FALSE) + withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), + upgrade = "never", quick=TRUE, quiet=TRUE)) + withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) + obj <- access_dynamic_package("testpackage", "nc")(); test_obj(obj) + objf <- to_full_interface(obj); test_obj(objf) + rm(obj, objf); gc(); pkgload::unload("testpackage") + + ## full & writePackage + dir <- file.path(tempdir(), "test_nComp_testpackage2") + dir.create(dir, showWarnings=FALSE) + test <- writePackage(nc, pkgName = "testpackage", dir = dir, modify="clear") + lib <- file.path(tempdir(), "test_nComp_lib2") + dir.create(lib, showWarnings=FALSE) + withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), + upgrade = "never", quick=TRUE, quiet=TRUE)) + withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) + obj <- access_dynamic_package("testpackage", "nc")$new(); test_obj(obj) + objC <- to_generic_interface(obj); test_obj(objC) + rm(obj, objC); gc() ###### name version of nc - ## generic & direct - test <- nCompile(nc_name, package=FALSE, interfaces = "generic", returnList = TRUE) - obj <- test$nc_name(); test_obj(obj) - objf <- to_full_interface(obj); test_obj(objf) - rm(obj, objf); gc() - - ## full & direct - test <- nCompile(nc_name, package=FALSE, interfaces = "full", returnList = TRUE) - obj <- test$nc_name$new(); test_obj(obj) - objC <- obj$private$CppObj; test_obj(objC) - rm(obj, objC); gc() - - ## generic & package - test <- nCompile(nc_name, package=TRUE, interfaces = "generic", returnList = TRUE) - obj <- test$nc_name(); test_obj(obj) - objf <- to_full_interface(obj); test_obj(objf) - rm(obj, objf); gc() - - ## full & package - test <- nCompile(nc_name, package=TRUE, interfaces = "full", returnList = TRUE) - obj <- test$nc_name$new(); test_obj(obj) - objC <- obj$private$CppObj; test_obj(objC) - rm(obj, objC); gc() - - ## generic & writePackage - dir <- file.path(tempdir(), "test_nComp_testpackage2") - dir.create(dir, showWarnings=FALSE) - test <- writePackage(nc_name, interfaces = "generic", pkgName = "testpackage", dir = dir, modify="clear") - lib <- file.path(tempdir(), "test_nComp_lib2") - dir.create(lib, showWarnings=FALSE) - withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), - upgrade = "never", quick=TRUE, quiet=TRUE)) - withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) - obj <- access_dynamic_package("testpackage", "nc_name")(); test_obj(obj) - objf <- to_full_interface(obj); test_obj(objf) - rm(obj, objf); gc(); pkgload::unload("testpackage") - - ## full & writePackage - dir <- file.path(tempdir(), "test_nComp_testpackage2") - dir.create(dir, showWarnings=FALSE) - test <- writePackage(nc_name, pkgName = "testpackage", dir = dir, modify="clear") - lib <- file.path(tempdir(), "test_nComp_lib2") - dir.create(lib, showWarnings=FALSE) - withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), - upgrade = "never", quick=TRUE, quiet=TRUE)) - withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) - obj <- access_dynamic_package("testpackage", "nc_name")$new(); test_obj(obj) - objC <- obj$private$CppObj; test_obj(objC) - rm(obj, objC); gc(); pkgload::unload("testpackage") + ## generic & direct + test <- nCompile(nc_name, package=FALSE, interfaces = "generic", returnList = TRUE) + obj <- test$nc_name(); test_obj(obj) + objf <- to_full_interface(obj); test_obj(objf) + rm(obj, objf); gc() + + ## full & direct + test <- nCompile(nc_name, package=FALSE, interfaces = "full", returnList = TRUE) + obj <- test$nc_name$new(); test_obj(obj) + objC <- to_generic_interface(obj); test_obj(objC) + rm(obj, objC); gc() + + ## generic & package + test <- nCompile(nc_name, package=TRUE, interfaces = "generic", returnList = TRUE) + obj <- test$nc_name(); test_obj(obj) + objf <- to_full_interface(obj); test_obj(objf) + rm(obj, objf); gc() + + ## full & package + test <- nCompile(nc_name, package=TRUE, interfaces = "full", returnList = TRUE) + obj <- test$nc_name$new(); test_obj(obj) + objC <- to_generic_interface(obj); test_obj(objC) + rm(obj, objC); gc() + + ## generic & writePackage + dir <- file.path(tempdir(), "test_nComp_testpackage2") + dir.create(dir, showWarnings=FALSE) + test <- writePackage(nc_name, interfaces = "generic", pkgName = "testpackage", dir = dir, modify="clear") + lib <- file.path(tempdir(), "test_nComp_lib2") + dir.create(lib, showWarnings=FALSE) + withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), + upgrade = "never", quick=TRUE, quiet=TRUE)) + withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) + obj <- access_dynamic_package("testpackage", "nc_name")(); test_obj(obj) + objf <- to_full_interface(obj); test_obj(objf) + rm(obj, objf); gc(); pkgload::unload("testpackage") + + ## full & writePackage + dir <- file.path(tempdir(), "test_nComp_testpackage2") + dir.create(dir, showWarnings=FALSE) + test <- writePackage(nc_name, pkgName = "testpackage", dir = dir, modify="clear") + lib <- file.path(tempdir(), "test_nComp_lib2") + dir.create(lib, showWarnings=FALSE) + withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), + upgrade = "never", quick=TRUE, quiet=TRUE)) + withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) + obj <- access_dynamic_package("testpackage", "nc_name")$new(); test_obj(obj) + objC <- to_generic_interface(obj); test_obj(objC) + rm(obj, objC); gc(); pkgload::unload("testpackage") ###### eName version of nc - ## generic & direct - test <- nCompile(nc_eName, package=FALSE, interfaces = "generic", returnList = TRUE) ## we got a full interface! - obj <- test$exnc1(); test_obj(obj) - objf <- to_full_interface(obj); test_obj(objf) - rm(obj, objf); gc() - - ## full & direct - test <- nCompile(nc_eName, package=FALSE, interfaces = "full", returnList = TRUE) - obj <- test$exnc1$new(); test_obj(obj) - objC <- obj$private$CppObj; test_obj(objC) - rm(obj, objC); gc() - - ## generic & package - test <- nCompile(nc_eName, package=TRUE, interfaces = "generic", returnList = TRUE) - obj <- test$exnc1(); test_obj(obj) - objf <- to_full_interface(obj); test_obj(objf) - rm(obj, objf); gc() - - ## full & package - test <- nCompile(nc_eName, package=TRUE, interfaces = "full", returnList = TRUE) - obj <- test$exnc1$new(); test_obj(obj) - objC <- obj$private$CppObj; test_obj(objC) - rm(obj, objC); gc() - - ## generic & writePackage - dir <- file.path(tempdir(), "test_nComp_testpackage2") - dir.create(dir, showWarnings=FALSE) - test <- writePackage(nc_eName, interfaces = "generic", pkgName = "testpackage", dir = dir, modify="clear") - lib <- file.path(tempdir(), "test_nComp_lib2") - dir.create(lib, showWarnings=FALSE) - withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), - upgrade = "never", quick=TRUE, quiet=TRUE)) - withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) - obj <- access_dynamic_package("testpackage", "exnc1")(); test_obj(obj) - objf <- to_full_interface(obj); test_obj(objf) - rm(obj, objf); gc(); pkgload::unload("testpackage") - - ## full & writePackage - dir <- file.path(tempdir(), "test_nComp_testpackage2") - dir.create(dir, showWarnings=FALSE) - test <- writePackage(nc_eName, pkgName = "testpackage", dir = dir, modify="clear") - lib <- file.path(tempdir(), "test_nComp_lib2") - dir.create(lib, showWarnings=FALSE) - withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), - upgrade = "never", quick=TRUE, quiet=TRUE)) - withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) - obj <- access_dynamic_package("testpackage", "exnc1")$new(); test_obj(obj) - objC <- obj$private$CppObj; test_obj(objC) - rm(obj, objC); gc(); pkgload::unload("testpackage") + ## generic & direct + test <- nCompile(nc_eName, package=FALSE, interfaces = "generic", returnList = TRUE) ## we got a full interface! + # This was previously a test expecting to see the exportName + # exnc1, but after changing how names work, that would have + # to use packageNames instead of exportName + # obj <- test$exnc1(); test_obj(obj) + obj <- test$nc_eName(); test_obj(obj) + objf <- to_full_interface(obj); test_obj(objf) + rm(obj, objf); gc() + + ## full & direct + test <- nCompile(nc_eName, package=FALSE, interfaces = "full", returnList = TRUE) + # See comment on previous test + # obj <- test$exnc1$new(); test_obj(obj) + obj <- test$nc_eName$new(); test_obj(obj) + objC <- to_generic_interface(obj); test_obj(objC) + rm(obj, objC); gc() + + ## generic & package + test <- nCompile(nc_eName, package=TRUE, interfaces = "generic", returnList = TRUE) + # See comment on previous two tests + # obj <- test$exnc1(); test_obj(obj) + obj <- test$nc_eName(); test_obj(obj) + objf <- to_full_interface(obj); test_obj(objf) + rm(obj, objf); gc() + + ## full & package + test <- nCompile(nc_eName, package=TRUE, interfaces = "full", returnList = TRUE) + # See comment on previous three tests + # obj <- test$exnc1$new(); test_obj(obj) + obj <- test$nc_eName$new(); test_obj(obj) + objC <- to_generic_interface(obj); test_obj(objC) + rm(obj, objC); gc() + + ## generic & writePackage + dir <- file.path(tempdir(), "test_nComp_testpackage2") + dir.create(dir, showWarnings=FALSE) + test <- writePackage(nc_eName, interfaces = "generic", pkgName = "testpackage", dir = dir, modify="clear") + lib <- file.path(tempdir(), "test_nComp_lib2") + dir.create(lib, showWarnings=FALSE) + withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), + upgrade = "never", quick=TRUE, quiet=TRUE)) + withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) + # Here we really do get the exportName. + # Note that the full interface generator nc_eName is *also* now available. + obj <- access_dynamic_package("testpackage", "exnc1")(); test_obj(obj) + objf <- to_full_interface(obj); test_obj(objf) + rm(obj, objf); gc(); pkgload::unload("testpackage") + + ## full & writePackage + ## This is really not different than above and should probably be re-done. + dir <- file.path(tempdir(), "test_nComp_testpackage2") + dir.create(dir, showWarnings=FALSE) + test <- writePackage(nc_eName, pkgName = "testpackage", dir = dir, modify="clear") + lib <- file.path(tempdir(), "test_nComp_lib2") + dir.create(lib, showWarnings=FALSE) + withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), + upgrade = "never", quick=TRUE, quiet=TRUE)) + withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) + # obj <- access_dynamic_package("testpackage", "exnc1")$new(); test_obj(obj) + obj <- access_dynamic_package("testpackage", "nc_eName")$new(); test_obj(obj) + objC <- to_generic_interface(obj); test_obj(objC) + rm(obj, objC); gc(); pkgload::unload("testpackage") ###### name and eName version of nc - ## generic & direct - test <- nCompile(nc_name_eName, package=FALSE, interfaces = "generic", returnList = TRUE) ## we got a full interface! - obj <- test$exnc2(); test_obj(obj) - objf <- to_full_interface(obj); test_obj(objf) - rm(obj, objf); gc() - - ## full & direct - test <- nCompile(nc_name_eName, package=FALSE, interfaces = "full", returnList = TRUE) - obj <- test$exnc2$new(); test_obj(obj) - objC <- obj$private$CppObj; test_obj(objC) - rm(obj, objC); gc() - - ## generic & package - test <- nCompile(nc_name_eName, package=TRUE, interfaces = "generic", returnList = TRUE) - obj <- test$exnc2(); test_obj(obj) - objf <- to_full_interface(obj); test_obj(objf) - rm(obj, objf); gc() - - ## full & package - test <- nCompile(nc_name_eName, package=TRUE, interfaces = "full", returnList = TRUE) - obj <- test$exnc2$new(); test_obj(obj) - objC <- obj$private$CppObj; test_obj(objC) - rm(obj, objC); gc() - - ## generic & writePackage - dir <- file.path(tempdir(), "test_nComp_testpackage2") - dir.create(dir, showWarnings=FALSE) - test <- writePackage(nc_name_eName, interfaces = "generic", pkgName = "testpackage", dir = dir, modify="clear") - lib <- file.path(tempdir(), "test_nComp_lib2") - dir.create(lib, showWarnings=FALSE) - withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), - upgrade = "never", quick=TRUE, quiet=TRUE)) - withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) - obj <- access_dynamic_package("testpackage", "exnc2")(); test_obj(obj) - objf <- to_full_interface(obj); test_obj(objf) - rm(obj, objf); gc(); pkgload::unload("testpackage") - - ## full & writePackage - dir <- file.path(tempdir(), "test_nComp_testpackage2") - dir.create(dir, showWarnings=FALSE) - test <- writePackage(nc_name_eName, pkgName = "testpackage", dir = dir, modify="clear") - lib <- file.path(tempdir(), "test_nComp_lib2") - dir.create(lib, showWarnings=FALSE) - withr::with_libpaths(lib, devtools::install(file.path(dir, "testpackage"), - upgrade = "never", quick=TRUE, quiet=TRUE)) - withr::with_libpaths(lib, load_dynamic_namespace("testpackage")) - obj <- access_dynamic_package("testpackage", "exnc2")$new(); test_obj(obj) - objC <- obj$private$CppObj; test_obj(objC) - rm(obj, objC); gc(); pkgload::unload("testpackage") + ## generic & direct + test <- nCompile(nc_name_eName, package=FALSE, interfaces = "generic", returnList = TRUE) ## we got a full interface! + # See above comments + # obj <- test$exnc2(); test_obj(obj) + obj <- test$nc_name_eName(); test_obj(obj) + objf <- to_full_interface(obj); test_obj(objf) + rm(obj, objf); gc() + + ## full & direct + test <- nCompile(nc_name_eName, package=FALSE, interfaces = "full", returnList = TRUE) + # See above comments + # obj <- test$exnc2$new(); test_obj(obj) + obj <- test$nc_name_eName$new(); test_obj(obj) + objC <- to_generic_interface(obj); test_obj(objC) + rm(obj, objC); gc() + + ## generic & package + test <- nCompile(nc_name_eName, package=TRUE, interfaces = "generic", returnList = TRUE) + # See above comments + # obj <- test$exnc2(); test_obj(obj) + obj <- test$nc_name_eName(); test_obj(obj) + objf <- to_full_interface(obj); test_obj(objf) + rm(obj, objf); gc() + + ## full & package + test <- nCompile(nc_name_eName, package=TRUE, interfaces = "full", returnList = TRUE) + # See above comments + # obj <- test$exnc2$new(); test_obj(obj) + obj <- test$nc_name_eName$new(); test_obj(obj) + objC <- to_generic_interface(obj); test_obj(objC) + rm(obj, objC); gc() + + ## generic & writePackage + dir <- file.path(tempdir(), "test_nComp_testpackage2") + dir.create(dir, showWarnings=FALSE) + test <- writePackage(nc_name_eName, interfaces = "generic", pkgName = "testpackage", dir = dir, modify="clear") + lib <- file.path(tempdir(), "test_nComp_lib2") + dir.create(lib, showWarnings=FALSE) + withr::with_libpaths(lib, action = "prefix", code = devtools::install(file.path(dir, "testpackage"), + upgrade = "never", quick=TRUE, quiet=TRUE)) + withr::with_libpaths(lib, action = "prefix", code = load_dynamic_namespace("testpackage")) + obj <- access_dynamic_package("testpackage", "exnc2")(); test_obj(obj) + objf <- to_full_interface(obj); test_obj(objf) + rm(obj, objf); gc(); pkgload::unload("testpackage") + + ## full & writePackage + dir <- file.path(tempdir(), "test_nComp_testpackage2") + dir.create(dir, showWarnings=FALSE) + test <- writePackage(nc_name_eName, pkgName = "testpackage", dir = dir, modify="clear") + lib <- file.path(tempdir(), "test_nComp_lib2") + dir.create(lib, showWarnings=FALSE) + withr::with_libpaths(lib, devtools::install(file.path(dir, "testpackage"), + upgrade = "never", quick=TRUE, quiet=TRUE)) + withr::with_libpaths(lib, load_dynamic_namespace("testpackage")) + # obj <- access_dynamic_package("testpackage", "exnc2")$new(); test_obj(obj) + obj <- access_dynamic_package("testpackage", "nc_name_eName")$new(); test_obj(obj) + objC <- to_generic_interface(obj); test_obj(objC) + rm(obj, objC); gc(); pkgload::unload("testpackage") }) test_that("Compile one nFunction via nCompile, returning a list (and testing external R name invalid for C++).", { - add.Scalars <- nFunction( - name = 'Cadd.scalars', - fun = function(x = double(0), - y = double(0)) { - returnType(double(0)) - ans <- x + y - return(ans) - } - ) - test <- nCompile(add.Scalars, package = FALSE, returnList = TRUE) - #test <- nCompile2(add.Scalars, returnList = TRUE) - expect_equal(test$add.Scalars(2, 3), 5) - test <- nCompile(add.Scalars, package = TRUE, returnList = TRUE) - expect_equal(test$add.Scalars(2, 3), 5) + add.Scalars <- nFunction( + name = 'Cadd.scalars', + fun = function(x = double(0), + y = double(0)) { + returnType(double(0)) + ans <- x + y + return(ans) + } + ) + test <- nCompile(add.Scalars, package = FALSE, returnList = TRUE) + #test <- nCompile2(add.Scalars, returnList = TRUE) + expect_equal(test$add.Scalars(2, 3), 5) + test <- nCompile(add.Scalars, package = TRUE, returnList = TRUE) + expect_equal(test$add.Scalars(2, 3), 5) } ) test_that("Compile one nFunction via nCompile, not returning a list (and testing internal name invalid for C++).", { - addScalars <- nFunction( - name = "add.Scalars", - fun = function(x = double(0), - y = double(0)) { - returnType(double(0)) - ans <- x + y - return(ans) - } - ) - test <- nCompile(addScalars, returnList = FALSE) - expect_equal(test(2, 3), 5) + addScalars <- nFunction( + name = "add.Scalars", + fun = function(x = double(0), + y = double(0)) { + returnType(double(0)) + ans <- x + y + return(ans) + } + ) + test <- nCompile(addScalars, returnList = FALSE) + expect_equal(test(2, 3), 5) }) test_that("Compile two nFunctions via nCompile, returning a list.", { - addScalars <- nFunction( - fun = function(x = double(0), - y = double(0)) { - returnType(double(0)) - ans <- x + y - return(ans) - } - ) - multScalars <- nFunction( - fun = function(x = double(0), - y = double(0)) { - returnType(double(0)) - ans <- x * y - return(ans) - } - ) - test <- nCompile(addScalars, multScalars) - expect_equal(test$addScalars(2, 3), 5) - expect_equal(test$multScalars(2, 3), 6) + addScalars <- nFunction( + fun = function(x = double(0), + y = double(0)) { + returnType(double(0)) + ans <- x + y + return(ans) + } + ) + multScalars <- nFunction( + fun = function(x = double(0), + y = double(0)) { + returnType(double(0)) + ans <- x * y + return(ans) + } + ) + test <- nCompile(addScalars, multScalars) + expect_equal(test$addScalars(2, 3), 5) + expect_equal(test$multScalars(2, 3), 6) } ) test_that("Compile two nFunctions via nCompile provided as a list, returning a list.", { - addScalars <- nFunction( - fun = function(x = double(0), - y = double(0)) { - returnType(double(0)) - ans <- x + y - return(ans) - } - ) - multScalars <- nFunction( - fun = function(x = double(0), - y = double(0)) { - returnType(double(0)) - ans <- x * y - return(ans) - } - ) - test <- nCompile(list(f1 = addScalars, f2 = multScalars)) - expect_equal(test$f1(2, 3), 5) - expect_equal(test$f2(2, 3), 6) + addScalars <- nFunction( + fun = function(x = double(0), + y = double(0)) { + returnType(double(0)) + ans <- x + y + return(ans) + } + ) + multScalars <- nFunction( + fun = function(x = double(0), + y = double(0)) { + returnType(double(0)) + ans <- x * y + return(ans) + } + ) + test <- nCompile(list(f1 = addScalars, f2 = multScalars)) + expect_equal(test$f1(2, 3), 5) + expect_equal(test$f2(2, 3), 6) }) test_that("Compile one nClass via nCompile provided as a list, returning not as list (and checking R to C++ conversions of class, method, and member names).", { - # Some other variants are in the "...various ways..." test below - nc <- nClass( - classname = "nc.1", - Cpublic = list( - v.1 = 'numericVector', - go.1 = nFunction( - fun = function(c = 'numericScalar') { - return(c * v.1) - }, - returnType = 'numericVector' - ) + # Some other variants are in the "...various ways..." test below + nc <- nClass( + classname = "nc.1", + Cpublic = list( + v.1 = 'numericVector', + go.1 = nFunction( + fun = function(c = 'numericScalar') { + return(c * v.1) + }, + returnType = 'numericVector' + ) + ) ) - ) - Cnc <- nCompile(list(nc = nc)) -# Cnc <- nCompile2(list(nc = nc)) - Cnc1 <- Cnc$new() - Cnc1$v.1 <- 1:3 - expect_equal(Cnc1$go.1(2), 2*(1:3)) + Cnc <- nCompile(list(nc = nc)) + # Cnc <- nCompile2(list(nc = nc)) + Cnc1 <- Cnc$new() + Cnc1$v.1 <- 1:3 + expect_equal(Cnc1$go.1(2), 2*(1:3)) }) test_that("nCompile naming and interface choices work in various ways", { - nc1 <- nClass( - classname = "nc1_", - Cpublic = list( - x = 'numericScalar' + nc1 <- nClass( + classname = "nc1_", + Cpublic = list( + x = 'numericScalar' + ) ) - ) - nc2 <- nClass( - Cpublic = list( - y = 'numericScalar' + nc2 <- nClass( + Cpublic = list( + y = 'numericScalar' + ) ) - ) - nc3 <- nClass( - Cpublic = list( - z = 'numericScalar' + nc3 <- nClass( + Cpublic = list( + z = 'numericScalar' + ) ) - ) - - # Basic use - #nOptions(showCompilerOutput = TRUE) - comp <- nCompile(nc1, nc2) - expect_identical(names(comp), c("nc1", "nc2")) - expect_true(inherits(comp$nc1$new(), "nClass")) - expect_true(inherits(comp$nc2$new(), "nClass")) - - # One named element in the ..., and generic interface for ALL - comp <- nCompile(nc1x = nc1, nc2, - interfaces = "generic") - expect_identical(names(comp), c("nc1x", "nc2")) - expect_true(class(comp$nc1())=="loadedObjectEnv") - expect_true(class(comp$nc2())=="loadedObjectEnv") - - # One named element in the ..., and different interface choices - comp <- nCompile(nc1x = nc1, nc2, - interfaces = c(nc1x = "full", nc2 = "generic")) - expect_identical(names(comp), c("nc1x", "nc2")) - expect_true(inherits(comp$nc1x$new(), "CnClass")) - expect_true(class(comp$nc2())=="loadedObjectEnv") - - # Call with singleton does not return a list - comp <- nCompile(nc1) - expect_true(inherits(comp$new(), "CnClass")) - - # Option to return a list with a singleton - comp <- nCompile(nc1, returnList = TRUE) - expect_true(inherits(comp$nc1$new(), "CnClass")) - - # Provide compilation units as a named list - comp <- nCompile(list(nc1 = nc1, nc2 = nc2), interfaces = "generic") - expect_identical(names(comp), c("nc1", "nc2")) - expect_true(class(comp$nc1())=="loadedObjectEnv") - expect_true(class(comp$nc2())=="loadedObjectEnv") - - # Error if a list is not completely named - expect_error(comp <- nCompile(list(nc1 = nc1, nc2))) ## expect error due to only partial naming in list - - # Mix of named list and individual unit, both in ... - comp <- nCompile(list(nc1 = nc1, nc3 = nc3), nc2, interfaces = "generic") - expect_identical(names(comp), c("nc1", "nc3", "nc2")) - expect_true(class(comp$nc1())=="loadedObjectEnv") - expect_true(class(comp$nc2())=="loadedObjectEnv") - expect_true(class(comp$nc3())=="loadedObjectEnv") - - # Move on to nFunctions - nfA <- nFunction( - name = "nfA_", - fun = function() { - return(2) - returnType('integerScalar') - }) - - nfB <- nFunction( - fun = function() { - return(nfA()) - returnType('integerScalar') - }) - - nfC <- nFunction( - fun = function() { - return(nfB()) - returnType('integerScalar') - }) - - # Basic use - #debug(nCompile) - comp <- nCompile(nfB, nfA) - expect_identical(names(comp), c("nfB", "nfA")) - expect_true(is.function(comp$nfB)) - expect_true(is.function(comp$nfA)) - expect_equal(comp$nfB(), 2) - # Singleton - comp <- nCompile(nfA) - expect_true(is.function(comp)) - - # Singleton returned as list - comp <- nCompile(nfA, returnList = TRUE) - expect_identical(names(comp), c("nfA")) - expect_true(is.function(comp$nfA)) - - # One item named, the other not, in ... - comp <- nCompile(f2 = nfB, nfA) - expect_identical(names(comp), c("f2", "nfA")) - expect_true(is.function(comp$f2)) - expect_true(is.function(comp$nfA)) - - # Error from incompletely named list - expect_error(comp <- nCompile(list(f2 = nfB, nfA))) # expected error due to incompletely named list - - # Fully named list - comp <- nCompile(list(f2 = nfB, f1 = nfA)) - expect_identical(names(comp), c("f2", "f1")) - expect_true(is.function(comp$f2)) - expect_true(is.function(comp$f1)) - - # Mix of list and individual item, both in ... - comp <- nCompile(list(f2 = nfB, f3 = nfC), nfA) - expect_identical(names(comp), c("f2", "f3", "nfA")) - expect_true(is.function(comp$f2)) - expect_true(is.function(comp$f3)) - expect_true(is.function(comp$nfA)) - - # Mix of nFunction and nClass - comp <- nCompile(nfA, nc1) - expect_identical(names(comp), c("nfA", "nc1")) - expect_true(is.function(comp$nfA)) - expect_true(inherits(comp$nc1$new(), "nClass")) + + # Basic use + #nOptions(showCompilerOutput = TRUE) + comp <- nCompile(nc1, nc2) + expect_identical(names(comp), c("nc1", "nc2")) + expect_true(inherits(comp$nc1$new(), "nClass")) + expect_true(inherits(comp$nc2$new(), "nClass")) + + # One named element in the ..., and generic interface for ALL + comp <- nCompile(nc1x = nc1, nc2, + interfaces = "generic") + expect_identical(names(comp), c("nc1x", "nc2")) + expect_true(class(comp$nc1())=="loadedObjectEnv") + expect_true(class(comp$nc2())=="loadedObjectEnv") + + # One named element in the ..., and different interface choices + comp <- nCompile(nc1x = nc1, nc2, + interfaces = c(nc1x = "full", nc2 = "generic")) + expect_identical(names(comp), c("nc1x", "nc2")) + expect_true(inherits(comp$nc1x$new(), "nClass")) + expect_true(comp$nc1x$new()$isCompiled()) + expect_true(class(comp$nc2())=="loadedObjectEnv") + + # Call with singleton does not return a list + comp <- nCompile(nc1) + expect_true(comp$new()$isCompiled()) + expect_true(inherits(comp$new(), "nClass")) + # Option to return a list with a singleton + comp <- nCompile(nc1, returnList = TRUE) + expect_true(comp$nc1$new()$isCompiled()) + expect_true(inherits(comp$nc1$new(), "nClass")) + # Provide compilation units as a named list + comp <- nCompile(list(nc1 = nc1, nc2 = nc2), interfaces = "generic") + expect_identical(names(comp), c("nc1", "nc2")) + expect_true(class(comp$nc1())=="loadedObjectEnv") + expect_true(class(comp$nc2())=="loadedObjectEnv") + + # Error if a list is not completely named + expect_error(comp <- nCompile(list(nc1 = nc1, nc2))) ## expect error due to only partial naming in list + + # Mix of named list and individual unit, both in ... + comp <- nCompile(list(nc1 = nc1, nc3 = nc3), nc2, interfaces = "generic") + expect_identical(names(comp), c("nc1", "nc3", "nc2")) + expect_true(class(comp$nc1())=="loadedObjectEnv") + expect_true(class(comp$nc2())=="loadedObjectEnv") + expect_true(class(comp$nc3())=="loadedObjectEnv") + + # Move on to nFunctions + nfA <- nFunction( + name = "nfA_", + fun = function() { + return(2) + returnType('integerScalar') + }) + + nfB <- nFunction( + fun = function() { + return(nfA()) + returnType('integerScalar') + }) + + nfC <- nFunction( + fun = function() { + return(nfB()) + returnType('integerScalar') + }) + + # Basic use + #debug(nCompile) + comp <- nCompile(nfB, nfA) + expect_identical(names(comp), c("nfB", "nfA")) + expect_true(is.function(comp$nfB)) + expect_true(is.function(comp$nfA)) + expect_equal(comp$nfB(), 2) + # Singleton + comp <- nCompile(nfA) + expect_true(is.function(comp)) + + # Singleton returned as list + comp <- nCompile(nfA, returnList = TRUE) + expect_identical(names(comp), c("nfA")) + expect_true(is.function(comp$nfA)) + + # One item named, the other not, in ... + comp <- nCompile(f2 = nfB, nfA) + expect_identical(names(comp), c("f2", "nfA")) + expect_true(is.function(comp$f2)) + expect_true(is.function(comp$nfA)) + + # Error from incompletely named list + expect_error(comp <- nCompile(list(f2 = nfB, nfA))) # expected error due to incompletely named list + + # Fully named list + comp <- nCompile(list(f2 = nfB, f1 = nfA)) + expect_identical(names(comp), c("f2", "f1")) + expect_true(is.function(comp$f2)) + expect_true(is.function(comp$f1)) + + # Mix of list and individual item, both in ... + comp <- nCompile(list(f2 = nfB, f3 = nfC), nfA) + expect_identical(names(comp), c("f2", "f3", "nfA")) + expect_true(is.function(comp$f2)) + expect_true(is.function(comp$f3)) + expect_true(is.function(comp$nfA)) + + # Mix of nFunction and nClass + comp <- nCompile(nfA, nc1) + expect_identical(names(comp), c("nfA", "nc1")) + expect_true(is.function(comp$nfA)) + expect_true(inherits(comp$nc1$new(), "nClass")) }) test_that("copyFiles field of compileInfo works", { - td <- tempdir() - workdir <- file.path(td, "nCompiler_copyFiles_test") - dir.create(workdir, showWarnings = FALSE) - fromFile <- file.path(workdir, "fromFile.txt") - random_string <- basename(tempfile()) - writeLines(random_string, con=fromFile) - foo <- nFunction( - function(){}, - compileInfo = list(copyFiles = fromFile) - ) - outdir <- file.path(workdir, "generated_code") - Cfoo <- nCompile(foo, - dir = outdir) - expect_true(file.exists(file.path(outdir, "fromFile.txt"))) - expect_identical(readLines(file.path(outdir, "fromFile.txt"),n=1), random_string) + td <- tempdir() + workdir <- file.path(td, "nCompiler_copyFiles_test") + dir.create(workdir, showWarnings = FALSE) + fromFile <- file.path(workdir, "fromFile.txt") + random_string <- basename(tempfile()) + writeLines(random_string, con=fromFile) + foo <- nFunction( + function(){}, + compileInfo = list(copyFiles = fromFile) + ) + outdir <- file.path(workdir, "generated_code") + Cfoo <- nCompile(foo, + dir = outdir) + expect_true(file.exists(file.path(outdir, "fromFile.txt"))) + expect_identical(readLines(file.path(outdir, "fromFile.txt"),n=1), random_string) }) test_that("manual C++ pieces in nFunction work", { - foo <- nFunction( - name = "foo", - function(x = numericScalar()) { # manually to become vector - nCpp("return x[0];") - returnType('numericVector') # manually to become scalar - }, - compileInfo = list( - prototype = "double foo(Eigen::Tensor y)", - deftype = "double foo(Eigen::Tensor x)" + foo <- nFunction( + name = "foo", + function(x = numericScalar()) { # manually to become vector + nCpp("return x[0];") + returnType('numericVector') # manually to become scalar + }, + compileInfo = list( + prototype = "double foo(Eigen::Tensor y)", + deftype = "double foo(Eigen::Tensor x)" + ) ) - ) - cppDefs <- nCompile(foo, control = list(return_cppDefs = TRUE)) - decl <- capture.output( writeCode(cppDefs[[1]]$generate(declaration=TRUE))) - def <- capture.output( writeCode(cppDefs[[1]]$generate(declaration=FALSE))) - expect_true(grepl("^double foo\\(Eigen::Tensor y\\);$", decl)) - expect_true(grepl("^double foo\\(Eigen::Tensor x\\)", def[2])) - # cfoo <- nCompile(foo) # these should work but we're avoiding full compilation for speed - # expect_identical(cfoo(1:3), 1) - - foo <- nFunction( - name = "foo", - function(x = integerVector()) { # replace with numericVector - nCpp("return x[0];") - returnType('integerScalar') # replace with numericScalar - }, - compileInfo = list( - name = "myfoo", - cpp_code_name = "myfoo2", # not used because name over-rides it - scopes = c("s1", "s2"), - qualifiers = c("const -> double"), - args = "(Eigen::Tensor x, double y)", - returnType = "double" + cppDefs <- nCompile(foo, control = list(return_cppDefs = TRUE)) + decl <- capture.output( writeCode(cppDefs[[1]]$generate(declaration=TRUE))) + def <- capture.output( writeCode(cppDefs[[1]]$generate(declaration=FALSE))) + expect_true(grepl("^double foo\\(Eigen::Tensor y\\);$", decl)) + expect_true(grepl("^double foo\\(Eigen::Tensor x\\)", def[2])) + # cfoo <- nCompile(foo) # these should work but we're avoiding full compilation for speed + # expect_identical(cfoo(1:3), 1) + + foo <- nFunction( + name = "foo", + function(x = integerVector()) { # replace with numericVector + nCpp("return x[0];") + returnType('integerScalar') # replace with numericScalar + }, + compileInfo = list( + name = "myfoo", + cpp_code_name = "myfoo2", # not used because name over-rides it + scopes = c("s1", "s2"), + qualifiers = c("const -> double"), + args = "(Eigen::Tensor x, double y)", + returnType = "double" + ) ) - ) - cppDefs <- nCompile(foo, control = list(return_cppDefs = TRUE)) - decl <- capture.output( writeCode(cppDefs[[1]]$generate(declaration=TRUE))) - def <- capture.output( writeCode(cppDefs[[1]]$generate(declaration=FALSE))) - expect_true(grepl("double s1::s2::myfoo \\(Eigen::Tensor x, double y\\) const -> double", decl)) - expect_true(grepl("double s1::s2::myfoo \\(Eigen::Tensor x, double y\\) const -> double", def[2])) - ## - foo <- nFunction( - name = "foo", - function() { # replace with numericVector - nCpp("return x[0];") - }, - compileInfo = list( - cpp_code_name = "myfoo2", - args = "(Eigen::Tensor x)", - returnType = "double", - template = "template", - callFromR = FALSE + cppDefs <- nCompile(foo, control = list(return_cppDefs = TRUE)) + decl <- capture.output( writeCode(cppDefs[[1]]$generate(declaration=TRUE))) + def <- capture.output( writeCode(cppDefs[[1]]$generate(declaration=FALSE))) + expect_true(grepl("double s1::s2::myfoo \\(Eigen::Tensor x, double y\\) const -> double", decl)) + expect_true(grepl("double s1::s2::myfoo \\(Eigen::Tensor x, double y\\) const -> double", def[2])) + ## + foo <- nFunction( + name = "foo", + function() { # replace with numericVector + nCpp("return x[0];") + }, + compileInfo = list( + cpp_code_name = "myfoo2", + args = "(Eigen::Tensor x)", + returnType = "double", + template = "template", + callFromR = FALSE + ) ) - ) - cppDefs <- nCompile(foo, control = list(return_cppDefs = TRUE)) - decl <- capture.output( writeCode(cppDefs[[1]]$generate(declaration=TRUE))) - def <- capture.output( writeCode(cppDefs[[1]]$generate(declaration=FALSE))) - expect_true(grepl("template", decl[1])) - expect_true(grepl("double myfoo2 \\(Eigen::Tensor x\\)", decl[2])) - expect_true(grepl("template", def[1])) - expect_true(grepl("double myfoo2 \\(Eigen::Tensor x\\)", def[2])) - ## - foo <- nFunction( - name = "foo", - function() { }, - compileInfo = list( - cpp_code_name = "myfoo2", - args = "(Eigen::Tensor x)", - returnType = "double", - template = "template", - callFromR = FALSE + cppDefs <- nCompile(foo, control = list(return_cppDefs = TRUE)) + decl <- capture.output( writeCode(cppDefs[[1]]$generate(declaration=TRUE))) + def <- capture.output( writeCode(cppDefs[[1]]$generate(declaration=FALSE))) + expect_true(grepl("template", decl[1])) + expect_true(grepl("double myfoo2 \\(Eigen::Tensor x\\)", decl[2])) + expect_true(grepl("template", def[1])) + expect_true(grepl("double myfoo2 \\(Eigen::Tensor x\\)", def[2])) + ## + foo <- nFunction( + name = "foo", + function() { }, + compileInfo = list( + cpp_code_name = "myfoo2", + args = "(Eigen::Tensor x)", + returnType = "double", + template = "template", + callFromR = FALSE + ) ) - ) }) -#library(nCompiler); library(testthat) + #library(nCompiler); library(testthat) test_that("nCompile for nClass with compileInfo$createFromR=FALSE works", { - nc_inner <- nClass( - classname = "nc_inner", - Cpublic = list( - x = 'numericScalar', - get_x = nFunction(function() {return(x)}, returnType = 'numericScalar') - ), - compileInfo = list(interface = "generic", createFromR = FALSE) - ) - nc_outer <- nClass( - classname = "nc_outer", - Cpublic = list( - my_inner = 'nc_inner', - init = nFunction(function() {my_inner = nc_inner$new()}), - get_inner = nFunction(function() {return(my_inner)}, returnType = 'nc_inner') + nc_inner <- nClass( + classname = "nc_inner", + Cpublic = list( + x = 'numericScalar', + get_x = nFunction(function() {return(x)}, returnType = 'numericScalar') + ), + compileInfo = list(interface = "generic", createFromR = FALSE) + ) + nc_outer <- nClass( + classname = "nc_outer", + Cpublic = list( + my_inner = 'nc_inner', + init = nFunction(function() {my_inner = nc_inner$new()}), + get_inner = nFunction(function() {return(my_inner)}, returnType = 'nc_inner') + ) ) - ) - # nOptions(showCompilerOutput=TRUE) - #comp <- nCompile(nc_inner, nc_outer) - #debug(nCompiler:::nCompile) - #debug(nCompiler:::writePackage) - #debug(nCompiler:::setup_nClass_environments) - #debug(nCompiler:::setup_nClass_environments_from_package) - comp <- nCompile(nc_inner, nc_outer, package = TRUE) - expect_error(comp$nc_inner_new()) - obj <- comp$nc_outer$new() - inner_obj <- obj$my_inner - expect_true(is.null(inner_obj)) - obj$init() - inner_obj <- obj$my_inner - inner_obj2 <- obj$my_inner - inner_obj <- obj$get_inner() + # nOptions(showCompilerOutput=TRUE) + #comp <- nCompile(nc_inner, nc_outer) + #debug(nCompiler:::nCompile) + #debug(nCompiler:::writePackage) + #debug(nCompiler:::setup_nClass_environments) + #debug(nCompiler:::setup_nClass_environments_from_package) + comp <- nCompile(nc_inner, nc_outer, package = TRUE) + expect_error(comp$nc_inner_new()) + obj <- comp$nc_outer$new() + inner_obj <- obj$my_inner + expect_true(is.null(inner_obj)) + obj$init() + inner_obj <- obj$my_inner + inner_obj2 <- obj$my_inner + inner_obj <- obj$get_inner() }) ## 1. createFromR = FALSE does not have environments set up etc. ## 2. createFromR = TRUE (status quo) does not access an inner obj via interface correctly -# This test could perhaps be removed or superceded by others in the future. + # This test could perhaps be removed or superceded by others in the future. test_that("argument name mangling and argument ordering work together", { - foo <- nFunction( - fun = function(x, log) { - return(dnorm(x,0,1,log=log)) - }, - argTypes=list(quote(double(0)), quote(double(0))), - returnType = quote(double(0)) - ) - - bar1 <- nFunction( - fun = function(x, log) { - return(foo(x, log)) - }, - argType = list('numericScalar','numericScalar'), - returnType = quote('numericScalar') - ) - - comp1 <- nCompile(foo, bar1) - expect_equal(bar1(1.2,TRUE), dnorm(1.2,0,1,TRUE)) - expect_equal(comp1$bar1(1.2,TRUE), dnorm(1.2,0,1,TRUE)) - - bar2 <- nFunction( - fun = function(x, log) { - return(foo(log=log, x)) - }, - argType = list('numericScalar','numericScalar'), - returnType = quote('numericScalar') - ) - - comp2 <- nCompile(foo, bar2) - expect_equal(bar2(1.2,TRUE), dnorm(1.2,0,1,TRUE)) - expect_equal(comp2$bar2(1.2,TRUE), dnorm(1.2,0,1,TRUE)) + foo <- nFunction( + fun = function(x, log) { + return(dnorm(x,0,1,log=log)) + }, + argTypes=list(quote(double(0)), quote(double(0))), + returnType = quote(double(0)) + ) + + bar1 <- nFunction( + fun = function(x, log) { + return(foo(x, log)) + }, + argType = list('numericScalar','numericScalar'), + returnType = quote('numericScalar') + ) + + comp1 <- nCompile(foo, bar1) + expect_equal(bar1(1.2,TRUE), dnorm(1.2,0,1,TRUE)) + expect_equal(comp1$bar1(1.2,TRUE), dnorm(1.2,0,1,TRUE)) + + bar2 <- nFunction( + fun = function(x, log) { + return(foo(log=log, x)) + }, + argType = list('numericScalar','numericScalar'), + returnType = quote('numericScalar') + ) + + comp2 <- nCompile(foo, bar2) + expect_equal(bar2(1.2,TRUE), dnorm(1.2,0,1,TRUE)) + expect_equal(comp2$bar2(1.2,TRUE), dnorm(1.2,0,1,TRUE)) }) 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 e6fc0635..3d32bf03 100644 --- a/nCompiler/tests/testthat/nCompile_tests/test-nCompile_auto_include.R +++ b/nCompiler/tests/testthat/nCompile_tests/test-nCompile_auto_include.R @@ -6,7 +6,7 @@ # 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", { +test_that("nFunction auto-including nFunction works and can be controlled (1)", { opt <- nOptions("compilerOptions")$nCompile_include_units on.exit(set_nOption("nCompile_include_units", opt, "compilerOptions")) set_nOption("nCompile_include_units", TRUE, "compilerOptions") @@ -36,7 +36,7 @@ test_that("nFunction auto-including nFunction works and can be controlled", { }) -test_that("nClass auto-including nFunction works and can be controlled", { +test_that("nClass auto-including nFunction works and can be controlled (2) ", { opt <- nOptions("compilerOptions")$nCompile_include_units on.exit(set_nOption("nCompile_include_units", opt, "compilerOptions")) set_nOption("nCompile_include_units", TRUE, "compilerOptions") @@ -300,13 +300,13 @@ test_that("auto-including from inherited nClass works and can be controlled", { return(v + 2*x); returnType('numericScalar'); }) ), - compileInfo = list(interface = "none",createFromR=FALSE) + compileInfo = list(interface = "generic",createFromR=FALSE) ) ncMid <- nClass( inherit = ncBase, classname = "ncMid", - compileInfo = list(interface = "none",createFromR=FALSE), + compileInfo = list(interface = "generic",createFromR=FALSE), Cpublic = list(x2 = 'numericScalar') ) @@ -331,7 +331,7 @@ test_that("auto-including from inherited nClass works and can be controlled", { 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(method(to_generic_interface(Cobj), "add_x")(15), 25) expect_equal(Cobj$add_2x_virt(15), 35) Cobj2 <- comp$ncUseBase$new() expect_true(is.null(Cobj2$myBase)) @@ -343,7 +343,7 @@ test_that("auto-including from inherited nClass works and can be controlled", { 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(method(to_generic_interface(Cobj), "add_x")(15), 25) expect_equal(Cobj$add_2x_virt(15), 35) Cobj2 <- comp$ncUseBase$new() expect_true(is.null(Cobj2$myBase)) @@ -412,70 +412,93 @@ test_that("One predefined nFunction can use another via auto-include", unlink(NFinternals(bar)$predefined, recursive=TRUE) }) +message("with package=TRUE for class used in code, one might need manual packageNames AND exportName.") +message("to use a predefined in a package, the exportName must be specified.") + 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()) - } + for(package in c(TRUE, FALSE)) { + make_defs <- function() { + foo_base <- nClass( + classname = "test_predefined_nC_foo_base", + Cpublic = list( + give_one = nFunction( + function() { + return(1.0); returnType(double()) + } + ) ) + , compileInfo = list(interface='generic', createFromR = FALSE, + packageNames=c(uncompiled="foo_base"), + # , compileInfo = list(interface='full', createFromR = FALSE, + # exportName="fooBase") + exportName="foo_base_export") # must be distinct + , predefined=file.path(tempdir(), "test_predefined_nC_foo_base_dir") ) - , 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))} + 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_export", # required for the predefined to be used by another unit not during generation + packageNames=c(uncompiled="foo")) ) - , 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')} + 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") ) - , predefined=file.path(tempdir(), "test_predefined_nC_use_foo") - , compileInfo=list(needed_units = "foo", - exportName = "use_foo") - ) + list(foo_base=foo_base, foo = foo, use_foo = use_foo) + } + my_defs <- make_defs() 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_no_error(comp <- with(my_defs, + nCompile(use_foo, foo, foo_base, + dir=dir, + control=list(generate_predefined=TRUE), + package=package, returnList=TRUE)) + ) + expect_no_error(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) + comp <- with(my_defs, + nCompile(foo, foo_base, use_foo, 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)) + loading_output <- capture_output(comp2 <- with(my_defs, + 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) + with(my_defs, { + 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/predefined_tests/test-predefined.R b/nCompiler/tests/testthat/predefined_tests/test-predefined.R index df921525..fe92cdfd 100644 --- a/nCompiler/tests/testthat/predefined_tests/test-predefined.R +++ b/nCompiler/tests/testthat/predefined_tests/test-predefined.R @@ -220,59 +220,70 @@ test_that("generating and compiling a predefined nClass works through packaging" }) cat("type declaration in code of returnType(foo()) needs fixing\n") +cat("inheriting from an nClass with interface='none' will not work via package=TRUE") +cat("If only packageNames$uncompiled is given, but not exportName or packageNames$compiled, then packageNames$uncompiled will not be respected. Fix.") test_that("One predefined nClass can use another, separately and by inheritance", { 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()) - } + make_defs <- function() { + foo_base <- nClass( + classname = "test_predefined_nC_foo_base", + Cpublic = list( + give_one = nFunction( + function() { + return(1.0); returnType(double()) + } + ) ) + , compileInfo = list(interface='generic', createFromR = FALSE, + packageNames=c(uncompiled="foo_base", compiled = "foo_base_c")), + , predefined=file.path(tempdir(), "test_predefined_nC_foo_base_dir") ) - , 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))} + 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") ) - , predefined=file.path(tempdir(), "test_predefined_nC_foo_dir") - ) - use_foo <- nClass( - classname = "test_predefined_nC_usefoo", - Cpublic = list( - make_foo = nFunction( - function() {return(foo$new()); returnType('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") ) - , predefined=file.path(tempdir(), "test_predefined_nC_use_foo") - ) - + list(foo_base = foo_base, + foo = foo, + use_foo = use_foo) + } + defs <- make_defs() dir <- file.path(tempdir(), "use_predefined_nC_testdir2") - comp <- nCompile(foo, foo_base, use_foo, dir=dir, control=list(generate_predefined=TRUE),package=package) + comp <- with(defs, + nCompile(foo, foo_base, use_foo, dir=dir, control=list(generate_predefined=TRUE),package=package)) 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(foo, foo_base, use_foo, dir=dir2,package=package)) + loading_output <- capture_output( + comp2 <- with(defs, + nCompile(foo, foo_base, use_foo, dir=dir2,package=package))) 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) + with(defs, unlink(NCinternals(foo)$predefined, recursive=TRUE)) + with(defs, unlink(NCinternals(foo_base)$predefined, recursive=TRUE)) + with(defs, unlink(NCinternals(use_foo)$predefined, recursive=TRUE)) } }) diff --git a/nCompiler/tests/testthat/serialization_tests/test-serialization.R b/nCompiler/tests/testthat/serialization_tests/test-serialization.R index bd185d4b..307b6ff5 100644 --- a/nCompiler/tests/testthat/serialization_tests/test-serialization.R +++ b/nCompiler/tests/testthat/serialization_tests/test-serialization.R @@ -337,7 +337,7 @@ test_that("Basic serialization works (via writePackage, with full interface, for ## serialize and deserialize 1 object # build and test object obj <- access_dynamic_package("nc1PackageB", "nc1")$new() #nc1PackageB::nc1$new() - expect_true(`:::`("nCompiler", "is.loadedObjectEnv")(obj$private$CppObj)) + expect_true(`:::`("nCompiler", "is.loadedObjectEnv")(to_generic_interface(obj))) expect_equal(obj$Cfoo(1.2), 2.2) obj$Cv <- 1.23 expect_equal(obj$Cv, 1.23) @@ -350,7 +350,7 @@ test_that("Basic serialization works (via writePackage, with full interface, for restored_obj <- nUnserialize(serialized_obj) # test the restored objected - expect_true(`:::`("nCompiler", "is.loadedObjectEnv")(restored_obj$private$CppObj)) + expect_true(`:::`("nCompiler", "is.loadedObjectEnv")(to_generic_interface(restored_obj))) expect_equal(restored_obj$Cfoo(1.2), 2.2) expect_equal(restored_obj$Cv, 1.23) restored_obj$Cv <- 2.34 @@ -424,7 +424,7 @@ test_that("Basic serialization works (via nCompile(package=TRUE), with full inte ## serialize and deserialize 1 object # build and test object obj <- nc1gen$new() - expect_true(`:::`("nCompiler", "is.loadedObjectEnv")(obj$private$CppObj)) + expect_true(`:::`("nCompiler", "is.loadedObjectEnv")(to_generic_interface(obj))) expect_equal(obj$Cfoo(1.2), 2.2) obj$Cv <- 1.23 expect_equal(obj$Cv, 1.23) @@ -437,7 +437,7 @@ test_that("Basic serialization works (via nCompile(package=TRUE), with full inte restored_obj <- nUnserialize(serialized_obj) # test the restored objected - expect_true(`:::`("nCompiler", "is.loadedObjectEnv")(restored_obj$private$CppObj)) + expect_true(`:::`("nCompiler", "is.loadedObjectEnv")(to_generic_interface(restored_obj))) expect_equal(restored_obj$Cfoo(1.2), 2.2) expect_equal(restored_obj$Cv, 1.23) restored_obj$Cv <- 2.34 diff --git a/nCompiler/tests/testthat/specificOp_tests/test-indexing.R b/nCompiler/tests/testthat/specificOp_tests/test-indexing.R index 5ece4b1b..4503569a 100644 --- a/nCompiler/tests/testthat/specificOp_tests/test-indexing.R +++ b/nCompiler/tests/testthat/specificOp_tests/test-indexing.R @@ -17,12 +17,13 @@ test_that("indexing by numeric vector works", { ) #cobj <- nCompile_nClass(nC)$new() cobj <- nCompile(nC)$new() + robj <- nC$new() x <- matrix(1:20, nrow = 4) iv <- c(2,3,2,1,5) method_names <- ls(nC$public_methods) for (test_i in method_names[startsWith(method_names, "test")]) { outC <- cobj[[test_i]](x, iv) - outR <- nC$public_methods[[test_i]](x, iv) + outR <- robj[[test_i]](x, iv) if (is.array(outC) && length(attributes(outC)$dim) == 1) attributes(outC)$dim <- NULL expect_equal(outC, outR) @@ -90,11 +91,12 @@ test_that("drop arg variations give correct results, 3D input", { ) # cobj <- nCompile_nClass(nC)$new() cobj <- nCompile(nC)$new() + robj <- nC$new() x <- array(1:105, c(3, 5, 7)) method_names <- ls(nC$public_methods) for (test_i in method_names[startsWith(method_names, "test")]) { outC <- cobj[[test_i]](x) - outR <- nC$public_methods[[test_i]](x) + outR <- robj[[test_i]](x) if (is.array(outC) && length(attributes(outC)$dim) == 1) attributes(outC)$dim <- NULL expect_equal(outC, outR) @@ -141,11 +143,12 @@ test_that("indexing arg variations give correct results, 3D input", { ) #cobj <- nCompile_nClass(nC)$new() cobj <- nCompile(nC)$new() + robj <- nC$new() x <- array(1:105, c(3, 5, 7)) method_names <- ls(nC$public_methods) for (test_i in method_names[startsWith(method_names, "test")]) { outC <- cobj[[test_i]](x) - outR <- nC$public_methods[[test_i]](x) + outR <- robj[[test_i]](x) if (is.array(outC) && length(attributes(outC)$dim) == 1) attributes(outC)$dim <- NULL expect_equal(outC, outR) @@ -173,13 +176,13 @@ test_that("assignment involving indexing give correct results, 3D input", { ) ) ) - # cobj <- nCompile_nClass(nC)$new() cobj <- nCompile(nC)$new() + robj <- nC$new() x <- array(1:105, c(3, 5, 7)) method_names <- ls(nC$public_methods) for (test_i in method_names[startsWith(method_names, "test")]) { outC <- cobj[[test_i]](x) - outR <- nC$public_methods[[test_i]](x) + outR <- robj[[test_i]](x) if (is.array(outC) && length(attributes(outC)$dim) == 1) attributes(outC)$dim <- NULL expect_equal(outC, outR) @@ -206,13 +209,13 @@ test_that("expressions involving indexing give correct results, 3D input", { ) ) ) - #cobj <- nCompile_nClass(nC)$new() cobj <- nCompile(nC)$new() + robj <- nCompile(nC)$new() x <- array(1:105, c(3, 8, 7)) method_names <- ls(nC$public_methods) for (test_i in method_names[startsWith(method_names, "test")]) { outC <- cobj[[test_i]](x) - outR <- nC$public_methods[[test_i]](x) + outR <- robj[[test_i]](x) if (is.array(outC) && length(attributes(outC)$dim) == 1) attributes(outC)$dim <- NULL expect_equal(outC, outR) @@ -231,13 +234,13 @@ test_that("scalar input gives correct results", { ) ) ) - # cobj <- nCompile_nClass(nC)$new() cobj <- nCompile(nC)$new() + robj <- nC$new() x <- 3 method_names <- ls(nC$public_methods) for (test_i in method_names[startsWith(method_names, "test")]) { expect_equal( - nC$public_methods[[test_i]](x), ## R + robj[[test_i]](x), ## R cobj[[test_i]](x) ## C++ ) } @@ -262,13 +265,13 @@ test_that("vector input gives correct results", { ) ) ) - # cobj <- nCompile_nClass(nC)$new() cobj <- nCompile(nC)$new() + robj <- nC$new() x <- 1:11 method_names <- ls(nC$public_methods) for (test_i in method_names[startsWith(method_names, "test")]) { outC <- cobj[[test_i]](x) - outR <- nC$public_methods[[test_i]](x) + outR <- robj[[test_i]](x) if (is.array(outC) && length(attributes(outC)$dim) == 1) attributes(outC)$dim <- NULL expect_equal(outC, outR) @@ -301,13 +304,13 @@ test_that("matrix input gives correct results", { ) ) ) - # cobj <- nCompile_nClass(nC)$new() cobj <- nCompile(nC)$new() + robj <- nC$new() x <- matrix(1:21, c(7, 3)) method_names <- ls(nC$public_methods) for (test_i in method_names[startsWith(method_names, "test")]) { outC <- cobj[[test_i]](x) - outR <- nC$public_methods[[test_i]](x) + outR <- robj[[test_i]](x) if (is.array(outC) && length(attributes(outC)$dim) == 1) attributes(outC)$dim <- NULL expect_equal(outC, outR) @@ -340,13 +343,13 @@ test_that("3-dimensional input array gives correct results", { ) ) ) - # cobj <- nCompile_nClass(nC)$new() cobj <- nCompile(nC)$new() + robj <- nC$new() x <- array(1:84, c(3, 4, 7)) method_names <- ls(nC$public_methods) for (test_i in method_names[startsWith(method_names, "test")]) { outC <- cobj[[test_i]](x) - outR <- nC$public_methods[[test_i]](x) + outR <- robj[[test_i]](x) if (is.array(outC) && length(attributes(outC)$dim) == 1) attributes(outC)$dim <- NULL expect_equal(outC, outR) @@ -393,13 +396,13 @@ test_that("4-dimensional input array gives correct results", { ) ) ) - #cobj <- nCompile_nClass(nC)$new() cobj <- nCompile(nC)$new() + robj <- nC$new() x <- array(1:924, c(3, 7, 4, 11)) method_names <- ls(nC$public_methods) for (test_i in method_names[startsWith(method_names, "test")]) { outC <- cobj[[test_i]](x) - outR <- nC$public_methods[[test_i]](x) + outR <- robj[[test_i]](x) if (is.array(outC) && length(attributes(outC)$dim) == 1) attributes(outC)$dim <- NULL expect_equal(outC, outR) @@ -418,13 +421,13 @@ test_that("5-dimensional input array gives correct results", { ) ) ) - # cobj <- nCompile_nClass(nC)$new() cobj <- nCompile(nC)$new() + robj <- nC$new() x <- array(1:2310, c(2, 3, 7, 5, 11)) method_names <- ls(nC$public_methods) for (test_i in method_names[startsWith(method_names, "test")]) { outC <- cobj[[test_i]](x) - outR <- nC$public_methods[[test_i]](x) + outR <- robj[[test_i]](x) if (is.array(outC) && length(attributes(outC)$dim) == 1) attributes(outC)$dim <- NULL expect_equal(outC, outR) diff --git a/nCompiler/tests/testthat/specificOp_tests/test-seq.R b/nCompiler/tests/testthat/specificOp_tests/test-seq.R index 913be283..d34010d9 100644 --- a/nCompiler/tests/testthat/specificOp_tests/test-seq.R +++ b/nCompiler/tests/testthat/specificOp_tests/test-seq.R @@ -404,6 +404,126 @@ test_that("Basic seq usage works", { ## The two most useful debug spots: ## debug(nCompiler:::labelAbstractTypesEnv$Seq) ## debug(nCompiler:::eigenizeEnv$Seq) + + nc_obj <- nc$new() + expect_equivalent(nc_obj$seq_empty(), 1 + exp(1)) + expect_equivalent(nc_obj$seq_td(7), 1+exp(seq(to = 2*7))) + expect_identical(nc_obj$seq_ti(7), seq(to = 7L)) + expect_equivalent(nc_obj$seq_fd(5), 1 + exp(1:10)) + expect_identical(nc_obj$seq_fi(7), seq(from = 7L)) + expect_equivalent(nc_obj$seq_fd(-5), 1 + exp(seq(from = 2*(-5)))) + + expect_equivalent(nc_obj$seq_fdv(5:10), 1 + exp(1:3)) + expect_identical(nc_obj$seq_fiv(5:10), seq(5L:10L)) + + expect_equivalent(nc_obj$seq_fd_td(7, 20), seq(7, 20)) + expect_equivalent(nc_obj$seq_fd_td(7.1, 20.2), seq(7.1, 20.2)) + expect_equivalent(nc_obj$seq_fd_td(7.1, 20.2), seq(7.1, 20.2)) + expect_equivalent(nc_obj$seq_fd_td(-1, -5), seq(-1, -5)) + expect_equivalent(nc_obj$seq_fd_td(-1, -1), seq(-1, -1)) + + expect_identical(nc_obj$seq_fi_td(1, 5.2), seq(from=1L, 5.2)) + expect_identical(nc_obj$seq_fi_ti(1, 5), seq(from=1L, 5L)) + expect_identical(nc_obj$seq_fd_ti(1.1, 5), seq(from=1.1, 5L)) + + expect_equivalent(nc_obj$seq_ld(4), 1:4) + expect_equivalent(nc_obj$seq_ld(4.1), 1:5) + expect_equivalent(nc_obj$seq_ld(0), integer()) + expect_equivalent(nc_obj$seq_ld(.1), 1) + + expect_equivalent(nc_obj$seq_fd_td_bd(0, 1, .1), seq(0, 1, .1)) + expect_equivalent(nc_obj$seq_fd_td_bd(1, -1, -.1), seq(1, -1, -.1)) + expect_equivalent(nc_obj$seq_fd_td_bd(1.1, -1.3, -.1), seq(1.1, -1.3, -.1)) + expect_equivalent(nc_obj$seq_fd_td_bd(1, 10, 1), seq(1, 10, 1)) + expect_error(nc_obj$seq_fd_td_bd(1, 10, -1)) # Correctly generates error + expect_equivalent(nc_obj$seq_fd_td_bd(1, 1, 1), seq(1, 1, 1)) + expect_equivalent(nc_obj$seq_fd_td_bd(1, 1, .1), seq(1, 1, .1)) + expect_equivalent(nc_obj$seq_fd_td_bd(1, 1, 0), seq(1, 1, 0)) + + expect_identical(nc_obj$seq_fi_ti_bi(1, 10, 2), seq(1, 10, 2)) + + expect_equivalent(nc_obj$seq_bd(1), seq(by = 1)) + expect_equivalent(nc_obj$seq_bd(0), seq(by = 0)) + expect_equivalent(nc_obj$seq_bd(0.5), seq(by = 0.5)) + expect_equivalent(nc_obj$seq_bd(-.5), seq(by = -0.5)) + + expect_equivalent(nc_obj$seq_fd_bd(1, 1), seq(from = 1, by = 1)) + expect_equivalent(nc_obj$seq_fd_bd(0, .1), seq(from = 0, by = .1)) + expect_equivalent(nc_obj$seq_fd_bd(2, -.1), seq(from = 2, by = -.1)) + expect_error(nc_obj$seq_fd_bd(2, 0)) # Correctly gives error msg + expect_equivalent(nc_obj$seq_fd_bd(1.5, -.1), seq(from = 1.5, by = -.1)) + expect_equivalent(nc_obj$seq_fd_bd(1,0), seq(from = 1, by = 0)) + expect_equivalent(nc_obj$seq_fd_bd(2, -.4), seq(from = 2, by = -.4)) + expect_equivalent(nc_obj$seq_fd_bd(2, -4), seq(from = 2, by = -4)) + + expect_identical(nc_obj$seq_fi_bi(2, -4), seq(from = 2L, by = -4L)) + expect_identical(nc_obj$seq_fi_bd(2, -4), seq(from = 2L, by = -4)) + + expect_equivalent(nc_obj$seq_fd_ld(1.5, 10), seq(from = 1.5, length.out = 10)) + expect_equivalent(nc_obj$seq_fd_ld(1.5, 0), seq(from = 1.5, length.out = 0)) + expect_equivalent(nc_obj$seq_fd_ld(1.5, 1.1), seq(from = 1.5, length.out = 1.1)) + expect_equivalent(nc_obj$seq_fd_ld(2, 10), seq(from = 2, length.out = 10)) + expect_equivalent(nc_obj$seq_fd_ld(-1, 0), seq(from = -1, length.out = 0)) + expect_equivalent(nc_obj$seq_fd_ld(-2, 1.1), seq(from = -2, length.out = 1.1)) + + expect_identical(nc_obj$seq_fi_ld(2, 10), seq(from = 2L, length.out = 10)) + expect_equivalent(nc_obj$seq_fi_ld(-1, 0), seq(from = -1L, length.out = 0)) # R returns integer based on length.out value; we can't do that. + expect_identical(nc_obj$seq_fi_ld(-2, 1.1), seq(from = -2L, length.out = 1.1)) + + expect_equivalent(nc_obj$seq_td_ld(1.5, 10), seq(to = 1.5, length.out = 10)) + expect_equivalent(nc_obj$seq_td_ld(1, 10), seq(to = 1, length.out = 10)) + expect_equivalent(nc_obj$seq_td_ld(5, 1), seq(to = 5, length.out = 1)) + expect_equivalent(nc_obj$seq_td_ld(5, 0), seq(to = 5, length.out = 0)) + expect_error(nc_obj$seq_td_ld(5, -1)) # Correctly gives error msg + expect_identical(nc_obj$seq_ti_ld(5, 3), seq(to = 5, length.out = 3)) + expect_identical(nc_obj$seq_td_li(5, 3), seq(to = 5, length.out = 3L)) + expect_identical(nc_obj$seq_ti_li(5, 3), seq(to = 5, length.out = 3L)) + + expect_equivalent(nc_obj$seq_td_bd(3, 1), seq(to = 3, by = 1)) + expect_equivalent(nc_obj$seq_td_bd(3, .1), seq(to = 3, by = .1)) + expect_error(nc_obj$seq_td_bd(3, -.1)) # Correctly gives error msg + expect_error(nc_obj$seq_td_bd(-1.5, .1)) # Correctly gives error msg + expect_equivalent(nc_obj$seq_td_bd(-1.5, -.1), seq(to = -1.5, by = -.1)) + expect_error(nc_obj$seq_td_bd(-1.5, 0)) # Correctly gives error msg + expect_identical(nc_obj$seq_ti_bd(3L, 1), seq(to = 3L, by = 1)) + expect_identical(nc_obj$seq_td_bi(3, 1L), seq(to = 3, by = 1L)) + expect_identical(nc_obj$seq_ti_bi(3L, 1L), seq(to = 3L, by = 1L)) + + expect_equivalent(nc_obj$seq_bd_ld(3, 5), seq(by = 3, length.out = 5)) + expect_equivalent(nc_obj$seq_bd_ld(3, 1), seq(by = 3, length.out = 1)) + expect_equivalent(nc_obj$seq_bd_ld(3, 0), seq(by = 3, length.out = 0)) + expect_equivalent(nc_obj$seq_bd_ld(-3, 5), seq(by = -3, length.out = 5)) + expect_equivalent(nc_obj$seq_bd_ld(-3, 1), seq(by = -3, length.out = 1)) + expect_equivalent(nc_obj$seq_bd_ld(-3, 0), seq(by = -3, length.out = 0)) + expect_error(nc_obj$seq_bd_ld(-3, -1)) # Correctly gives error msg + expect_identical(nc_obj$seq_bi_ld(3L, 5), seq(by = 3L, length.out = 5)) + expect_identical(nc_obj$seq_bd_li(3, 5L), seq(by = 3, length.out = 5L)) + expect_identical(nc_obj$seq_bi_li(3L, 5L), seq(by = 3L, length.out = 5L)) + + expect_equivalent(nc_obj$seq_fd_td_ld(10, -1, 12), seq(10, -1, length.out = 12 )) + expect_equivalent(nc_obj$seq_fd_td_ld(-4, 8, 5.6), seq(-4, 8, length.out = 5.6 )) + + expect_identical(nc_obj$seq_fi_td_ld(10L, -1, 12), seq(10L, -1, length.out = 12 )) + expect_identical(nc_obj$seq_fd_ti_ld(10, -1L, 12), seq(10, -1L, length.out = 12 )) + expect_identical(nc_obj$seq_fi_ti_ld(10L, -1L, 12), seq(10L, -1L, length.out = 12 )) + + expect_equivalent(nc_obj$seq_fd_bd_ld(10, -.4, 12), seq(10, by=-.4, length.out = 12 )) + expect_equivalent(nc_obj$seq_fd_bd_ld(10, -.4, 1), seq(10, by=-.4, length.out = 1 )) + expect_equivalent(nc_obj$seq_fd_bd_ld(10, -.4, 0), seq(10, by=-.4, length.out = 0 )) + + expect_equivalent(nc_obj$seq_fi_bd_ld(10L, -.4, 12), seq(10L, by=-.4, length.out = 12 )) + expect_equivalent(nc_obj$seq_fd_bi_ld(10, -6L, 12), seq(10, by= -6L, length.out = 12 )) + expect_equivalent(nc_obj$seq_fi_bi_ld(10L, -6L, 12), seq(10L, by=-6L, length.out = 12 )) + + expect_equivalent(nc_obj$seq_td_bd_ld(10, -.4, 5), seq(to = 10, by=-.4, length.out = 5 )) + expect_equivalent(nc_obj$seq_td_bd_ld(10, -.4, 1), seq(to = 10, by=-.4, length.out = 1 )) + expect_equivalent(nc_obj$seq_td_bd_ld(10, -.4, 1.1), seq(to = 10, by=-.4, length.out = 1.1 )) + expect_equivalent(nc_obj$seq_td_bd_ld(10, -.4, 0), seq(to = 10, by=-.4, length.out = 0 )) + + expect_equivalent(nc_obj$seq_ti_bd_ld(10L, -.4, 5), seq(to = 10L, by=-.4, length.out = 5 )) + expect_equivalent(nc_obj$seq_td_bi_ld(10, -2L, 5), seq(to = 10, by=-2L, length.out = 5 )) + expect_equivalent(nc_obj$seq_ti_bi_ld(10L, -2L, 5), seq(to = 10L, by=-2L, length.out = 5 )) + ncc <- nCompile(nc) nc_obj <- ncc$new() diff --git a/nCompiler/tests/testthat/tbb_tests/test-parallel_reduce.R b/nCompiler/tests/testthat/tbb_tests/test-parallel_reduce.R new file mode 100644 index 00000000..75b00198 --- /dev/null +++ b/nCompiler/tests/testthat/tbb_tests/test-parallel_reduce.R @@ -0,0 +1,279 @@ +test_that("basic usage of parallel_reduce", { + nc <- nClass( + Cpublic = list( + go = nFunction( + fun = function(x = 'numericVector') { + y <- parallel_reduce('+', x) + return(y) + }, + returnType = 'numericScalar' + ) + ) + ) + Cnc <- nCompile(nc) + obj <- nc$new() + Cobj <- Cnc$new() + expect_identical(obj$go(101:110), as.numeric(sum(101:110))) + expect_identical(Cobj$go(101:110), as.numeric(sum(101:110))) + + nc <- nClass( + Cpublic = list( + go = nFunction( + fun = function(x = 'numericVector') { + y <- parallel_reduce('+', x, 5) + return(y) + }, + returnType = 'numericScalar' + ) + ) + ) + Cnc <- nCompile(nc) + obj <- nc$new() + Cobj <- Cnc$new() + expect_identical(obj$go(101:110), as.numeric(5+sum(101:110))) + expect_identical(Cobj$go(101:110), as.numeric(5+sum(101:110))) + + ## Negative values required some additional processing, so test that case explicitly. + nc <- nClass( + Cpublic = list( + go = nFunction( + fun = function(x = 'numericVector') { + y <- parallel_reduce('+', x, -5) + return(y) + }, + returnType = 'numericScalar' + ) + ) + ) + Cnc <- nCompile(nc) + obj <- nc$new() + Cobj <- Cnc$new() + expect_identical(obj$go(101:110), as.numeric(sum(101:110)-5)) + expect_identical(Cobj$go(101:110), as.numeric(sum(101:110)-5)) + + nc <- nClass( + Cpublic = list( + go = nFunction( + fun = function(x = 'numericVector') { + y <- parallel_reduce('pairmin', x) + return(y) + }, + returnType = 'numericScalar' + ) + ) + ) + Cnc <- nCompile(nc) + obj <- nc$new() + Cobj <- Cnc$new() + x <- c(3.7, 2.5, 4.9, 3.1) + expect_identical(obj$go(x), 2.5) + expect_identical(Cobj$go(x), 2.5) + + ## Operator as function (user-defined), not char. + mypairmin <- nFunction( + fun = function(x = 'numericScalar', y = 'numericScalar') { + return(pmin(x,y)) + }, returnType = 'numericScalar' + ) + + nc <- nClass( + Cpublic = list( + go = nFunction( + fun = function(x = 'numericVector') { + y <- parallel_reduce(mypairmin, x, Inf) + return(y) + }, + returnType = 'numericScalar' + ) + ) + ) + Cnc <- nCompile(nc, mypairmin)[[1]] + obj <- nc$new() + Cobj <- Cnc$new() + x <- c(3.7, 2.5, 4.9, 3.1) + expect_identical(obj$go(x), 2.5) + expect_identical(Cobj$go(x), 2.5) + +}) + +test_that("error trapping for parallel_reduce", { + nc <- nClass( + Cpublic = list( + go = nFunction( + fun = function(x = 'numericVector') { + y <- parallel_reduce('-', x) + return(y) + }, + returnType = 'numericScalar' + ) + ) + ) + ## The error message is not silent. + expect_error(Cnc <- nCompile(nc), "is not a valid reduction") ## Compile-time error. + obj <- nc$new() + expect_error(obj$go(1:5), "not a valid reduction") ## Run-time error. + + ## No init for user-defined reduction function. + mypairmin <- nFunction( + fun = function(x = 'numericScalar', y = 'numericScalar') { + return(pmin(x,y)) + }, returnType = 'numericScalar' + ) + + nc <- nClass( + Cpublic = list( + go = nFunction( + fun = function(x = 'numericVector') { + y <- parallel_reduce(mypairmin, x) + return(y) + }, + returnType = 'numericScalar' + ) + ) + ) + expect_error(Cnc <- nCompile(nc, mypairmin)[[1]], "expected 3 arguments") + obj <- nc$new() + expect_error(obj$go(1:5), "no default value provided") + + + nc <- nClass( + Cpublic = list( + go = nFunction( + fun = function(x = 'numericVector', start = 'numericScalar') { + y <- parallel_reduce('pairmin', x, start) + return(y) + }, + returnType = 'numericScalar' + ) + ) + ) + expect_error(Cnc <- nCompile(nc), "must be a literal") + + go = nFunction( + fun = function(x = 'numericVector') { + y <- parallel_reduce('+', x) + return(y) + }, + returnType = 'numericScalar' + ) + expect_error(Cgo <- nCompile(go), "must be used in a method of an nClass") + +}) + +## Could add check for user-defined reduction function with defined default init via operatorDef. + +test_that("user-defined reduction functions", { + ## User-defined nFunction + reduction_fun <- nFunction( + fun = function(x = 'numericScalar', y = 'numericScalar') { + ans <- x + y + return(ans) + }, + returnType = 'numericScalar' + ) + + + nc <- nClass( + Cpublic = list( + go = nFunction( + fun = function(x = 'numericVector') { + y <- parallel_reduce('reduction_fun', x, 0) + return(y) + }, + returnType = 'numericScalar' + ) + ) + ) + Cnc <- nCompile(nc, reduction_fun)[[1]] + obj <- nc$new() + Cobj <- Cnc$new() + expect_identical(obj$go(101:110), as.numeric(sum(101:110))) + expect_identical(Cobj$go(101:110), as.numeric(sum(101:110))) + + ## See issue 133. + nc <- nClass( + Cpublic = list( + reduction_fun = nFunction( + fun = function(x = 'numericScalar', y = 'numericScalar') { + ans <- x + y + return(ans) + }, + returnType = 'numericScalar' + ), + parallel_fun = nFunction( + fun = function(x = 'numericVector') { + y <- parallel_reduce(reduction_fun, x, 0) + return(y) + }, + returnType = 'numericScalar' + ) + ) + ) + ## This particular error doesn't fit well with testthat for some reason. + ## expect_error(Cnc <- nCompile(nc)) + + nc0 <- nClass( + Cpublic = list( + reduction_fun = nFunction( + fun = function(x = 'numericScalar', y = 'numericScalar') { + ans <- x + y + return(ans) + }, + returnType = 'numericScalar' + ) + )) + + nc <- nClass( + Cpublic = list( + parallel_fun = nFunction( + fun = function(x = 'numericVector', obj = 'nc0') { + y <- parallel_reduce(obj$reduction_fun, x, 0) + return(y) + }, + returnType = 'numericScalar' + ) + ) + ) + expect_error(result <- nCompile(nc, nc0), "not a valid reduction") + +}) + + +test_that("reduction cases that don't work", { + nc <- nClass( + Cpublic = list( + go = nFunction( + fun = function(x = 'numericVector', y = 'numericVector') { + z <- parallel_reduce('+', x+y) + return(z) + }, + returnType = 'numericScalar' + ) + ) + ) + expect_error(Cnc <- nCompile(nc)) + obj <- nc$new() + obj$go(1:5, 6:10) + expect_identical(obj$go(1:5, 6:10) , as.numeric(55)) + + nc <- nClass( + Cpublic = list( + go = nFunction( + fun = function(x = 'integerVector') { + z <- parallel_reduce('pairmin', x) + return(z) + }, + returnType = 'integerScalar' + ) + ) + ) + expect_error(Cnc <- nCompile(nc)) ## Lots of C++ compiler output. + +}) + + +## test parallel_reduce(o$adder) with o either passed as arg or as member data and from nc1 class; check it works in R too + +## error trapping for o$foo$foo as reducer + +## o$foo as reducer, o2$x as vector diff --git a/nCompiler/tests/testthat/tensorOps_tests/test-tensorCreation.R b/nCompiler/tests/testthat/tensorOps_tests/test-tensorCreation.R index 1a3a662b..0b53d36e 100644 --- a/nCompiler/tests/testthat/tensorOps_tests/test-tensorCreation.R +++ b/nCompiler/tests/testthat/tensorOps_tests/test-tensorCreation.R @@ -47,12 +47,13 @@ test_that("data initialization working: nNumeric, nInteger, nLogical", { ) ncc <- nCompile(nc) nc_obj <- ncc$new() - expect_equivalent(nc_obj$nf1(), nc$public_methods$nf1()) + Robj <- nc$new() + expect_equivalent(nc_obj$nf1(), Robj$nf1()) expect_equivalent( nc_obj$nf2(1:4, 3:6, c(TRUE, TRUE, FALSE, TRUE)), - nc$public_methods$nf2(1:4, 3:6, c(TRUE, TRUE, FALSE, TRUE)) + Robj$nf2(1:4, 3:6, c(TRUE, TRUE, FALSE, TRUE)) ) - expect_equivalent(nc_obj$nf3(), nc$public_methods$nf3()) + expect_equivalent(nc_obj$nf3(), Robj$nf3()) }) test_that("data initialization working: nMatrix", { @@ -85,9 +86,10 @@ test_that("data initialization working: nMatrix", { ) ncc <- nCompile(nc) nc_obj <- ncc$new() - expect_equivalent(nc_obj$nf1(), nc$public_methods$nf1()) - expect_equivalent(nc_obj$nf2(), nc$public_methods$nf2()) - expect_equivalent(nc_obj$nf3(1:14), nc$public_methods$nf3(1:14)) + Robj <- nc$new() + expect_equivalent(nc_obj$nf1(), Robj$nf1()) + expect_equivalent(nc_obj$nf2(), Robj$nf2()) + expect_equivalent(nc_obj$nf3(1:14), Robj$nf3(1:14)) }) cat("A SET OF FAILING tensorCreation TESTS IS COMMENTED OUT.")