From ab7d6c119294d8f2341e51921a5dcab3f44c266e Mon Sep 17 00:00:00 2001 From: perrydv Date: Mon, 8 Jun 2026 16:54:36 -0700 Subject: [PATCH] split a string basic type away from symbolBase --- nCompiler/R/compile_labelAbstractTypes.R | 2 +- nCompiler/R/symbolTable.R | 101 +++++++++++++----- nCompiler/R/typeDeclarations.R | 4 +- .../testthat/types_tests/test-RcppTypes.R | 58 +++++----- .../tests/testthat/types_tests/test-types.R | 14 ++- 5 files changed, 121 insertions(+), 58 deletions(-) diff --git a/nCompiler/R/compile_labelAbstractTypes.R b/nCompiler/R/compile_labelAbstractTypes.R index 0bd156d7..9a721e87 100644 --- a/nCompiler/R/compile_labelAbstractTypes.R +++ b/nCompiler/R/compile_labelAbstractTypes.R @@ -1471,7 +1471,7 @@ inLabelAbstractTypesEnv( if(auxEnv$returnSymbol$nDim==0) { # if the return is a literal, check for a case like return(2) with return type "double" if(code$args[[1]]$isLiteral) { - # What other cases are there here? + # Are there additional cases to warn on for literals other than returning an integer to a double? # returning anything to a logical is ok type_mismatch <- FALSE if(auxEnv$returnSymbol$type == "integer" && code$type$type == "double") diff --git a/nCompiler/R/symbolTable.R b/nCompiler/R/symbolTable.R index 11bd69fa..7691f878 100644 --- a/nCompiler/R/symbolTable.R +++ b/nCompiler/R/symbolTable.R @@ -35,6 +35,23 @@ symbolBase <- R6::R6Class( ) ) +symbolVoid <- R6::R6Class( + classname = 'symbolVoid', + inherit = symbolBase, + portable = TRUE, + public = list( + initialize = function(...) { + super$initialize(type = 'void', ...) + }, + shortPrint = function()"void", + uniqueID = function() "void", + print = function() "void", + genCppVar = function() { + cppVoid() + } + ) +) + ## nDim and size are redundant for convenience with one exception: ## nDim = 0 must have size = 1 and means it is a true scalar -- NOT sure this is correct anymore... ## nDim = 1 with size = 1 means it is a 1D vector that happens to be length 1 @@ -43,9 +60,9 @@ symbolBase <- R6::R6Class( ## In cases such as x[3:3, 2:4] or x[c(3), 2:4], nimble's system for ## symbolic sizeExprs determines that 3:3 or c(3) have sizeExpr "1" ## and then the bracket processing will drop the index (if drop=TRUE) -symbolBasic <- +symbolScalarOrTensor <- R6::R6Class( - classname = 'symbolBasic', + classname = 'symbolScalarOrTensor', inherit = symbolBase, portable = TRUE, public = list( @@ -66,14 +83,8 @@ symbolBasic <- self$isConst <- isConst self }, - shortPrint = function() { - paste0(switch(self$type, - double = 'D', - integer = 'I', - logical = 'L', - AD = 'AD', - 'Other'), - self$nDim) + shortPrint = function(prefix = '') { + paste0(prefix, self$nDim) }, uniqueID = function(...) { self$shortPrint() @@ -91,20 +102,9 @@ symbolBasic <- ) } }, - genCppVar = function() { + genCppVar = function(cType = NULL) { + if(is.null(cType)) stop("should not be calling symbolScalarOrTensor$genCppVar without a cType") isArg <- self$isArg - type <- self$type - if(type == 'void') return(cppVoid()) - else if(type == 'integer') cType <- 'int' - else if(type == 'double') cType <- 'double' - else if(type == 'logical') cType <- 'bool' - else if(type == 'AD') cType <- 'CppAD::AD' - else if(type == 'string') cType <- 'std::string' - else warning(paste("in genCppVar method for", - self$name, - "in symbolBasic class,", - "type", type,"unrecognized\n"), - FALSE) if(self$nDim == 0) { if(identical(self$name, "pi")) return(cppVarFullClass$new(baseType = cType, @@ -144,6 +144,58 @@ symbolBasic <- ) ) +symbolBasic <- R6::R6Class( + classname = "symbolBasic", + inherit = symbolScalarOrTensor, + portable = TRUE, + public = list( + initialize = function(...) { + super$initialize(...) + }, + shortPrint = function() { + prefix <- switch(self$type, + double = 'D', + integer = 'I', + logical = 'L', + AD = 'AD', + 'Other') + super$shortPrint(prefix = prefix) + }, + genCppVar = function() { + cType <- NULL + type <- self$type + if(type == 'integer') cType <- 'int' + else if(type == 'double') cType <- 'double' + else if(type == 'logical') cType <- 'bool' + else if(type == 'AD') cType <- 'CppAD::AD' + else warning(paste("in genCppVar method for", + self$name, + "in symbolBasic class,", + "type", type,"unrecognized\n"), + FALSE) + super$genCppVar(cType = cType) + } + + ) +) + +symbolBasicString <- R6::R6Class( + classname = "symbolBasicString", + inherit = symbolScalarOrTensor, + portable = TRUE, + public = list( + initialize = function(...) { + super$initialize(..., type = "string") + }, + shortPrint = function() { + super$shortPrint(prefix = 'S') + }, + genCppVar = function() { + super$genCppVar(cType = 'std::string') + } + ) +) + symbolBlank <- R6::R6Class( classname = "symbolBlank", inherit = symbolBase, @@ -666,8 +718,7 @@ symbolSparse <- R6::R6Class( genCppVar = function() { isArg <- self$isArg type <- self$type - if(type == 'void') return(cppVoid()) - else if(type == 'integer') cType <- 'int' + if(type == 'integer') cType <- 'int' else if(type == 'double') cType <- 'double' else if(type == 'logical') cType <- 'bool' else if(type == 'AD') cType <- 'CppAD::AD' diff --git a/nCompiler/R/typeDeclarations.R b/nCompiler/R/typeDeclarations.R index c7a759f2..1d2dc53a 100644 --- a/nCompiler/R/typeDeclarations.R +++ b/nCompiler/R/typeDeclarations.R @@ -306,10 +306,10 @@ typeDeclarationList <- list( nTypeBasic("logical", nDim, ...) }, void = function(...) { - nTypeBasic("void", 0, ...) + symbolVoid$new(...) }, string = function(...) { - nTypeBasic("string", 0, ...) + symbolBasicString$new(nDim = 0, ...) }, ## SEXP = function(...) { diff --git a/nCompiler/tests/testthat/types_tests/test-RcppTypes.R b/nCompiler/tests/testthat/types_tests/test-RcppTypes.R index 07576b8c..f29ae9f5 100644 --- a/nCompiler/tests/testthat/types_tests/test-RcppTypes.R +++ b/nCompiler/tests/testthat/types_tests/test-RcppTypes.R @@ -256,11 +256,11 @@ test_that("RcppS4 works in nFunctions", { } ) nfs4C <- nCompile(nfs4) - + # Taken from ?setClass track <- setClass("track", slots = c(x="numeric", y="numeric")) t1 <- track(x = 1:10, y = 1:10 + rnorm(10)) - + expect_true(nfs4C(t1)) }) @@ -281,7 +281,7 @@ test_that("RcppFunction works", { set.seed(505) result1_Correct <- rnorm(10) expect_equal(result1, result1_Correct) - + result2 <- nffnC(logit, 0.4) result2_correct <- logit(0.4) expect_equal(result2, result2_correct) @@ -413,9 +413,9 @@ test_that("RcppNumericVector works in nClasses", { classname = "test_RcppNumericVector", Cpublic = list( x = "RcppNumericVector", - set_x = nFunction(fun = function(new_x = "RcppNumericVector") { + set_x = nFunction(fun = function(new_x = "RcppNumericVector") { x <- new_x - return(0) + return(0) }, returnType = "integerScalar" ) ) @@ -436,9 +436,9 @@ test_that("RcppNumericMatrix works in nClasses", { classname = "test_RcppNumericMatrix", Cpublic = list( x = "RcppNumericMatrix", - set_x = nFunction(fun = function(new_x = "RcppNumericMatrix") { + set_x = nFunction(fun = function(new_x = "RcppNumericMatrix") { x <- new_x - return(0) + return(0) }, returnType = "integerScalar" ) ) @@ -459,9 +459,9 @@ test_that("RcppIntegerVector works in nClasses", { classname = "test_RcppIntegerVector", Cpublic = list( x = "RcppIntegerVector", - set_x = nFunction(fun = function(new_x = "RcppIntegerVector") { + set_x = nFunction(fun = function(new_x = "RcppIntegerVector") { x <- new_x - return(0) + return(0) }, returnType = "integerScalar" ) ) @@ -482,9 +482,9 @@ test_that("RcppIntegerMatrix works in nClasses", { classname = "test_RcppIntegerMatrix", Cpublic = list( x = "RcppIntegerMatrix", - set_x = nFunction(fun = function(new_x = "RcppIntegerMatrix") { + set_x = nFunction(fun = function(new_x = "RcppIntegerMatrix") { x <- new_x - return(0) + return(0) }, returnType = "integerScalar" ) ) @@ -505,9 +505,9 @@ test_that("RcppCharacterVector works in nClasses", { classname = "test_RcppCharacterVector", Cpublic = list( x = "RcppCharacterVector", - set_x = nFunction(fun = function(new_x = "RcppCharacterVector") { + set_x = nFunction(fun = function(new_x = "RcppCharacterVector") { x <- new_x - return(0) + return(0) }, returnType = "integerScalar" ) ) @@ -528,9 +528,9 @@ test_that("RcppCharacterMatrix works in nClasses", { classname = "test_RcppCharacterMatrix", Cpublic = list( x = "RcppCharacterMatrix", - set_x = nFunction(fun = function(new_x = "RcppCharacterMatrix") { + set_x = nFunction(fun = function(new_x = "RcppCharacterMatrix") { x <- new_x - return(0) + return(0) }, returnType = "integerScalar" ) ) @@ -551,9 +551,9 @@ test_that("RcppComplexVector works in nClasses", { classname = "test_RcppComplexVector", Cpublic = list( x = "RcppComplexVector", - set_x = nFunction(fun = function(new_x = "RcppComplexVector") { + set_x = nFunction(fun = function(new_x = "RcppComplexVector") { x <- new_x - return(0) + return(0) }, returnType = "integerScalar" ) ) @@ -574,9 +574,9 @@ test_that("RcppComplexMatrix works in nClasses", { classname = "test_RcppComplexMatrix", Cpublic = list( x = "RcppComplexMatrix", - set_x = nFunction(fun = function(new_x = "RcppComplexMatrix") { + set_x = nFunction(fun = function(new_x = "RcppComplexMatrix") { x <- new_x - return(0) + return(0) }, returnType = "integerScalar" ) ) @@ -597,9 +597,9 @@ test_that("RcppLogicalVector works in nClasses", { classname = "test_RcppLogicalVector", Cpublic = list( x = "RcppLogicalVector", - set_x = nFunction(fun = function(new_x = "RcppLogicalVector") { + set_x = nFunction(fun = function(new_x = "RcppLogicalVector") { x <- new_x - return(0) + return(0) }, returnType = "integerScalar" ) ) @@ -620,9 +620,9 @@ test_that("RcppLogicalMatrix works in nClasses", { classname = "test_RcppLogicalMatrix", Cpublic = list( x = "RcppLogicalMatrix", - set_x = nFunction(fun = function(new_x = "RcppLogicalMatrix") { + set_x = nFunction(fun = function(new_x = "RcppLogicalMatrix") { x <- new_x - return(0) + return(0) }, returnType = "integerScalar" ) ) @@ -668,26 +668,26 @@ test_that("RcppLogicalMatrix works in nClasses", { # classname = "test_RcppDatetimeVector", # Cpublic = list( # x = "RcppDatetimeVector", -# set_x = nFunction(fun = function(new_x = "RcppDatetimeVector") { +# set_x = nFunction(fun = function(new_x = "RcppDatetimeVector") { # x <- new_x -# return(0) +# return(0) # }, returnType = "integerScalar" # ) # ) # ) # ncC <- nCompile(nc) # my_nc <- ncC$new() -# test_x1 <- as.POSIXct(c(1593166562, 1593066562, 1592166562, 159316562), +# test_x1 <- as.POSIXct(c(1593166562, 1593066562, 1592166562, 159316562), # origin = as.Date("1950-01-01")) # my_nc$set_x(test_x1) # expect_equal(my_nc$x, test_x1) -# test_x2 <- as.POSIXct(c(1493166562, 1593066562, 2592166562, 159316562), +# test_x2 <- as.POSIXct(c(1493166562, 1593066562, 2592166562, 159316562), # origin = as.Date("1950-01-01")) # my_nc$x <- test_x2 # expect_equal(my_nc$x, test_x2) # }) -# -# +# +# test_that("RcppDataFrame works in nClasses", { nc <- nClass( classname = "test_RcppDataFrame", diff --git a/nCompiler/tests/testthat/types_tests/test-types.R b/nCompiler/tests/testthat/types_tests/test-types.R index 2c9c70ec..4c684ec0 100644 --- a/nCompiler/tests/testthat/types_tests/test-types.R +++ b/nCompiler/tests/testthat/types_tests/test-types.R @@ -462,6 +462,7 @@ test_that("Trap error from duplicate setting of isRef. (This should show a warni ## Error-trapping: ## Duplicate setting of ref a <- quote(ref(numericVector(5))) + cat("expecting an error:\n") expect_error( `:::`("nCompiler", "type2symbol")(O(!!a), name = "a", @@ -474,6 +475,7 @@ test_that("Trap error from duplicate setting of isRef. (This should show a warni ## Type incompatible with default a <- quote(matrix(1:4, nrow = 2, ncol = 2)) aExplicit <- nType(numericVector()) + cat("expecting an error:\n") expect_error(suppressWarnings( # this gives a warning and an error, so for testing we suppress the warning `:::`("nCompiler", "type2symbol")(O(!!a), name = "a", @@ -547,7 +549,7 @@ test_that("list arguments handled correctly", ## void() (return type default) vSym <- `:::`("nCompiler", "type2symbol")(quote(void())) expect_identical(vSym$type, "void") - expect_identical(vSym$nDim, 0) +# expect_identical(vSym$nDim, 0) }) test_that("symbolTBD works", @@ -634,3 +636,13 @@ test_that("types as objects work with an nClass", { obj$nf(1:3) expect_identical(obj$nf(1:3), 2:4) }) + +test_that("string type works in nFunctions", { + foo <- nFunction( + fun=function(mystr = 'string'){ + return(mystr) + }, returnType = 'string' + ) + cfoo <- nCompile(foo) + expect_identical(cfoo("hw"),"hw") +})