diff --git a/.github/workflows/test-suites.yml b/.github/workflows/test-suites.yml new file mode 100644 index 00000000..eb226281 --- /dev/null +++ b/.github/workflows/test-suites.yml @@ -0,0 +1,167 @@ +# .github/workflows/test-suites.yml +name: Test Suites + +on: + workflow_dispatch: + inputs: + run_cache_only: + description: 'Run and cache dependency installations only' + required: true + default: 'no' + +env: + RSPM: https://packagemanager.posit.co/cran/latest # Enables Linux binaries from Posit + R_KEEP_PKG_SOURCE: yes # Keeps sources for debugging if needed + + +jobs: + install-cache: + runs-on: ubuntu-latest + if: github.event.inputs.run_cache_only == 'yes' || github.event.inputs.run_cache_only == 'no' + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: 'release' + use-public-rspm: true + + - name: Cache R packages + uses: actions/cache@v3 + with: + path: ${{ env.R_LIBS_USER }} + key: ${{ runner.os }}-r-${{ hashFiles('nCompiler/DESCRIPTION', 'ci-extra-packages.txt') }} + restore-keys: ${{ runner.os }}-r- + + - name: Install system dependencies + run: | + sudo apt-get update + sudo apt-get install -y \ + build-essential \ + libcurl4-openssl-dev \ + libssl-dev + + - name: Install R dependencies + run: | + Rscript -e 'install.packages("remotes")' + Rscript -e 'remotes::install_deps("nCompiler", dependencies = TRUE)' + + - name: Install extra packages + run: | + Rscript -e ' + pkgs <- readLines("ci-extra-packages.txt") + new_pkgs <- pkgs[!pkgs %in% installed.packages()[,"Package"]] + if(length(new_pkgs)) install.packages(new_pkgs) + ' + + - name: Install package + run: R CMD INSTALL nCompiler + + # Job 1: nCompile and specific operator tests + test-nCompile: + runs-on: ubuntu-latest + needs: install-cache + if: github.event.inputs.run_cache_only == 'no' + name: nCompile and specific operator tests + + steps: + - uses: actions/checkout@v4 + - uses: r-lib/actions/setup-r@v2 + with: + r-version: 'release' + use-public-rspm: true + + - name: Restore cache + uses: actions/cache@v3 + with: + path: ${{ env.R_LIBS_USER }} + key: ${{ runner.os }}-r-${{ hashFiles('nCompiler/DESCRIPTION', 'ci-extra-packages.txt') }} + restore-keys: ${{ runner.os }}-r- + + - name: Run nCompile and other tests + run: | + testthat::test_dir("tests/testthat/uncompiled_tests", reporter = "progress") + testthat::test_dir("tests/testthat/nCompile_tests", reporter = "progress") + testthat::test_dir("tests/testthat/cpp_tests", reporter = "progress") + testthat::test_dir("tests/testthat/specificOp_tests", reporter = "progress") + shell: Rscript {0} + + # Job 2: nClass, types and serialization tests + test-nClass: + runs-on: ubuntu-latest + needs: install-cache + if: github.event.inputs.run_cache_only == 'no' + name: nClass, types and serialization tests + + steps: + - uses: actions/checkout@v4 + - uses: r-lib/actions/setup-r@v2 + with: + r-version: 'release' + use-public-rspm: true + + - name: Restore cache + uses: actions/cache@v3 + with: + path: ${{ env.R_LIBS_USER }} + key: ${{ runner.os }}-r-${{ hashFiles('nCompiler/DESCRIPTION', 'ci-extra-packages.txt') }} + restore-keys: ${{ runner.os }}-r- + + - name: Run nClass, types and serialization tests + run: | + testthat::test_dir("tests/testthat/nClass_tests", reporter = "progress") + testthat::test_dir("tests/testthat/types_tests", reporter = "progress") + testthat::test_dir("tests/testthat/serialization_tests", reporter = "progress") + shell: Rscript {0} + + # Job 3: Math tests + test-math: + runs-on: ubuntu-latest + needs: install-cache + if: github.event.inputs.run_cache_only == 'no' + name: Math Tests + + steps: + - uses: actions/checkout@v4 + - uses: r-lib/actions/setup-r@v2 + with: + r-version: 'release' + use-public-rspm: true + + - name: Restore cache + uses: actions/cache@v3 + with: + path: ${{ env.R_LIBS_USER }} + key: ${{ runner.os }}-r-${{ hashFiles('nCompiler/DESCRIPTION', 'ci-extra-packages.txt') }} + restore-keys: ${{ runner.os }}-r- + + - name: Run Math tests + run: | + testthat::test_dir("tests/testthat/math_tests", reporter = "progress") + shell: Rscript {0} + + # Job 4: tensorOps + test-tensorOps: + runs-on: ubuntu-latest + needs: install-cache + if: github.event.inputs.run_cache_only == 'no' + name: TensorOps Tests + + steps: + - uses: actions/checkout@v4 + - uses: r-lib/actions/setup-r@v2 + with: + r-version: 'release' + use-public-rspm: true + + - name: Restore cache + uses: actions/cache@v3 + with: + path: ${{ env.R_LIBS_USER }} + key: ${{ runner.os }}-r-${{ hashFiles('nCompiler/DESCRIPTION', 'ci-extra-packages.txt') }} + restore-keys: ${{ runner.os }}-r- + + - name: Run TensorOps tests + run: | + testthat::test_dir("tests/testthat/tensorOps_tests", reporter = "progress") + shell: Rscript {0} diff --git a/archived_tests/tests_to_be_fixed/README.txt b/archived_tests/tests_to_be_fixed/README.txt new file mode 100644 index 00000000..eaeae9ce --- /dev/null +++ b/archived_tests/tests_to_be_fixed/README.txt @@ -0,0 +1 @@ +See README_noscan.txt in ../v1tests. diff --git a/nCompiler/tests/testthat/tests_to_be_fixed/test-TBB-NOTWORKING.R b/archived_tests/tests_to_be_fixed/test-TBB-NOTWORKING.R_noscan similarity index 100% rename from nCompiler/tests/testthat/tests_to_be_fixed/test-TBB-NOTWORKING.R rename to archived_tests/tests_to_be_fixed/test-TBB-NOTWORKING.R_noscan diff --git a/nCompiler/tests/testthat/tests_to_be_fixed/test-nOptim-NOTWORKING.R b/archived_tests/tests_to_be_fixed/test-nOptim-NOTWORKING.R_noscan similarity index 100% rename from nCompiler/tests/testthat/tests_to_be_fixed/test-nOptim-NOTWORKING.R rename to archived_tests/tests_to_be_fixed/test-nOptim-NOTWORKING.R_noscan diff --git a/nCompiler/tests/testthat/tests_to_be_fixed/test-packaging-NOTWORKING.R b/archived_tests/tests_to_be_fixed/test-packaging-NOTWORKING.R_noscan similarity index 100% rename from nCompiler/tests/testthat/tests_to_be_fixed/test-packaging-NOTWORKING.R rename to archived_tests/tests_to_be_fixed/test-packaging-NOTWORKING.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-predefined.R b/archived_tests/tests_to_be_fixed/test-predefined-NOTWORKING.R_noscan similarity index 86% rename from nCompiler/tests/testthat/v1tests/test-predefined.R rename to archived_tests/tests_to_be_fixed/test-predefined-NOTWORKING.R_noscan index d28081c9..034bc3b7 100644 --- a/nCompiler/tests/testthat/v1tests/test-predefined.R +++ b/archived_tests/tests_to_be_fixed/test-predefined-NOTWORKING.R_noscan @@ -9,13 +9,101 @@ # or by including something else in the nCompile that is not predefined and hence # will trigger inclusion of the interface calls. Tests here take the latter approach. # +library(nCompiler) + +foo <- nFunction( + fun=function(x) {return(x+1)}, + argTypes = list(x='numericScalar'), + returnType='numericScalar', + name="myfoofun" +) +cfoo <- nCompile(foo) +cfoo(2) + +foo <- nFunction( + fun=function(x) {return(x+1)}, + argTypes = list(x='numericScalar'), + returnType='numericScalar', + name="myfoofun", + predefined=file.path(tempdir(), 'foo_fun_pre') +) +cfoo <- nCompile(foo, control=list(generate_predefined=TRUE)) +cfoo(2) + +foo <- nFunction( + fun=function(x) {return(x+1)}, + argTypes = list(x='numericScalar'), + returnType='numericScalar', + name="myfoofun", + predefined=file.path(tempdir(), 'foo_fun_pre') +) +cfoo <- nCompile(foo) +cfoo(2) + +foo <- nFunction( + fun=function(x) {return(x+1)}, + argTypes = list(x='numericScalar'), + returnType='numericScalar', + name="myfoofun", + predefined=file.path(tempdir(), 'foo_fun_pre') +) +cfoo <- nCompile(foo, control=list(generate_predefined=TRUE), package = TRUE) +cfoo(2) + +foo <- nFunction( + fun=function(x) {return(x+1)}, + argTypes = list(x='numericScalar'), + returnType='numericScalar', + name="myfoofun", + predefined=file.path(tempdir(), 'foo_fun_pre') +) +cfoo <- nCompile(foo, package=TRUE) +cfoo(2) + +### + +foo <- nClass(Cpublic = list( + bar=nFunction( + fun=function(x){return(x+1)}, + argTypes = list(x='numericScalar'), + returnType = 'numericScalar')), + classname = "my_foo" + ) +# Generate new code. +ctest <- nCompile(foo) +obj <- ctest$new() +obj$bar(2) test_that("test_predefined class works", { # dummy nClass to include in nCompile so that interface calls are included. - foo <- nClass(Cpublic = list(foo=nFunction(fun=function(){}))) + foo <- nClass(Cpublic = list( + bar=nFunction( + fun=function(x){return(x+1)}, + argTypes = list(x='numericScalar'), + returnType = 'numericScalar')), + classname = "foo_test_predefined", + predefined = file.path(tempdir(), "test_predefined_dir") + ) # Generate new code. - ctest <- nCompile(test_predefined, foo, control = list(generate_predefined = TRUE)) + ctest <- nCompile(foo, control = list(generate_predefined = TRUE)) + obj <- ctest$new() + obj$bar(2) + + ctest <- nCompile(foo, control = list(generate_predefined = TRUE), package=TRUE) + obj <- ctest$new() + obj$bar(2) + + # Use existing (predefined) code + ctest <- nCompile(foo, control = list(generate_predefined = FALSE)) + obj <- ctest$new() + obj$bar(2) + + ctest <- nCompile(foo, control = list(generate_predefined = FALSE), package=TRUE) + obj <- ctest$new() + obj$bar(2) + +# Below here is old ctest <- ctest$test_predefined obj <- ctest$new() obj$a <- 1.2 @@ -24,13 +112,14 @@ test_that("test_predefined class works", obj <- test_predefined$new() obj$a <- 1.2 expect_equal(obj$a, 1.2) - + # Use existing (predefined) code - ctest <- nCompile(test_predefined, control = list(generate_predefined = FALSE)) + ctest <- nCompile(foo, control = list(generate_predefined = FALSE)) obj <- ctest$new() - obj$a <- 1.2 + obj$bar(2) + obj$a <- 1.2 expect_equal(obj$a, 1.2) - + # Default to existing (predefined) code # We could add a test to confirm that it is actually the predefined code that is used. ctest <- nCompile(test_predefined) @@ -122,14 +211,14 @@ test_that("test_predefined class works", x$a <- 1.2 x2 <- f1(x) expect_equal(x2$a, 2.2) - - # Call C++ test function that relies on correctly reading the header + + # Call C++ test function that relies on correctly reading the header get_test_predefined <- nFunction( fun = function() { cppLiteral("std::shared_ptr A = make_test_predefined();") cppLiteral("return(A);") }, - returnType = 'test_predefined') + returnType = 'test_predefined') C_gtp <- nCompile(get_test_predefined, test_predefined) x <- C_gtp$get_test_predefined() x$a <- 1.2 @@ -151,13 +240,13 @@ test_that("predefined derivClass class works", obj <- derivClass$new() obj$gradient <- matrix(1:4, nrow = 2) expect_equal(obj$gradient, matrix(1:4, nrow = 2)) - + # Use existing (predefined) code ctest <- nCompile(derivClass, control = list(generate_predefined = FALSE)) obj <- ctest$new() obj$gradient <- matrix(1:4, nrow = 2) expect_equal(obj$gradient, matrix(1:4, nrow = 2)) - + # Default to existing (predefined) code # We could add a test to confirm that it is actually the predefined code that is used. ctest <- nCompile(derivClass) @@ -251,14 +340,14 @@ test_that("predefined derivClass class works", x$gradient <- matrix(1:4, nrow = 2) x2 <- obj$foo(x) expect_equal(x2$gradient, matrix(2:5, nrow = 2)) - - # Call C++ test function that relies on correctly reading the header + + # Call C++ test function that relies on correctly reading the header get_derivClass <- nFunction( fun = function() { cppLiteral("std::shared_ptr A = make_derivClass();") cppLiteral("return(A);") }, - returnType = 'derivClass') + returnType = 'derivClass') C_get <- nCompile(get_derivClass, derivClass) x <- C_get$get_derivClass() x$gradient <- matrix(1:4, nrow = 2) @@ -287,7 +376,7 @@ test_that("predefined EigenDecomp class works", obj <- ctest$new() obj$vectors <- matrix(1:4, nrow = 2) expect_equal(obj$vectors, matrix(1:4, nrow = 2)) - + # Default to existing (predefined) code # We could add a test to confirm that it is actually the predefined code that is used. ctest <- nCompile(EigenDecomp) @@ -379,19 +468,19 @@ test_that("predefined EigenDecomp class works", x$vectors <- matrix(1:4, nrow = 2) x2 <- obj$foo(x) expect_equal(x2$vectors, matrix(2:5, nrow = 2)) - - # Call C++ test function that relies on correctly reading the header + + # Call C++ test function that relies on correctly reading the header get_EigenDecomp <- nFunction( fun = function() { cppLiteral("std::shared_ptr A = make_EigenDecomp();") cppLiteral("return(A);") }, - returnType = 'EigenDecomp') + returnType = 'EigenDecomp') C_get <- nCompile(get_EigenDecomp, EigenDecomp) x <- C_get$get_EigenDecomp() x$vectors <- matrix(1:4, nrow = 2) expect_equal(x$vectors, matrix(1:4, nrow = 2)) - + doEigen <- nFunction( fun = function(x, symmetric, valuesOnly) { eigX <- nEigen(x, symmetric, valuesOnly) @@ -400,7 +489,7 @@ test_that("predefined EigenDecomp class works", argTypes = list(x = 'numericMatrix', symmetric = 'logicalScalar', valuesOnly = 'logicalScalar'), returnType = 'EigenDecomp') comp <- nCompile(doEigen, EigenDecomp) - + # test non-symmetric eigen decomposition x <- matrix(as.numeric(c(2, 4, 1, 3)), nrow = 2) Cres <- comp$doEigen(x, FALSE, FALSE) @@ -411,18 +500,18 @@ test_that("predefined EigenDecomp class works", Cvec = as.numeric(Cres$vectors[,i]) Rvec = as.numeric(Rres$vectors[,i]) expect_true(any( - isTRUE(all.equal(Cvec, Rvec)), + isTRUE(all.equal(Cvec, Rvec)), isTRUE(all.equal(Cvec, -Rvec)) )) } - + # test values only x <- matrix(as.numeric(c(2, 4, 1, 3)), nrow = 2) Cres <- comp$doEigen(x = x, symmetric = FALSE, valuesOnly = TRUE) Rres <- eigen(x, only.values = TRUE) expect_equal(as.numeric(Cres$values), as.numeric(Rres$values)) expect_equal(Cres$vectors, matrix(data = 0, nrow = 0, ncol = 0)) - + # test symmetric eigen decomposition xsym <- x + t(x) Cres <- comp$doEigen(x = xsym, symmetric = TRUE, valuesOnly = FALSE) @@ -433,11 +522,11 @@ test_that("predefined EigenDecomp class works", Cvec = as.numeric(Cres$vectors[,i]) Rvec = as.numeric(Rres$vectors[,i]) expect_true(any( - isTRUE(all.equal(Cvec, Rvec)), + isTRUE(all.equal(Cvec, Rvec)), isTRUE(all.equal(Cvec, -Rvec)) )) } - + # verify nEigen works with tensor expression inputs doEigenOp <- nFunction( fun = function(x, y, z, symmetric, valuesOnly) { @@ -445,9 +534,9 @@ test_that("predefined EigenDecomp class works", return(eigX) }, argTypes = list(x = 'numericMatrix', - y = 'numericMatrix', - z = 'numericMatrix', - symmetric = 'logicalScalar', + y = 'numericMatrix', + z = 'numericMatrix', + symmetric = 'logicalScalar', valuesOnly = 'logicalScalar'), returnType = 'EigenDecomp' ) @@ -462,7 +551,7 @@ test_that("predefined EigenDecomp class works", Cvec = as.numeric(Cres$vectors[,i]) Rvec = as.numeric(Rres$vectors[,i]) expect_true(any( - isTRUE(all.equal(Cvec, Rvec)), + isTRUE(all.equal(Cvec, Rvec)), isTRUE(all.equal(Cvec, -Rvec)) )) } @@ -481,20 +570,20 @@ test_that("predefined SVDDecomp class works", { obj <- SVDDecomp$new() obj$v <- matrix(1:4, nrow = 2) expect_equal(obj$v, matrix(1:4, nrow = 2)) - + # Use existing (predefined) code ctest <- nCompile(SVDDecomp, control = list(generate_predefined = FALSE)) obj <- ctest$new() obj$v <- matrix(1:4, nrow = 2) expect_equal(obj$v, matrix(1:4, nrow = 2)) - + # Default to existing (predefined) code # We could add a test to confirm that it is actually the predefined code that is used. ctest <- nCompile(SVDDecomp) obj <- ctest$new() obj$v <- matrix(1:4, nrow = 2) expect_equal(obj$v, matrix(1:4, nrow = 2)) - + # Use in a class as member data nc1 <- nClass( classname = "nc1", @@ -511,7 +600,7 @@ test_that("predefined SVDDecomp class works", { obj$x <- SVDDecomp$new() obj$x$v <- matrix(1:4, nrow = 2) expect_equal(obj$x$v, matrix(1:4, nrow = 2)) - + # Use in a class as return object nc1 <- nClass( classname = "nc1", @@ -533,7 +622,7 @@ test_that("predefined SVDDecomp class works", { x <- obj$foo() x$v <- matrix(1:4, nrow = 2) expect_equal(x$v, matrix(1:4, nrow = 2)) - + # Use in a class as input object nc1 <- nClass( classname = "nc1", @@ -559,7 +648,7 @@ test_that("predefined SVDDecomp class works", { x$v <- matrix(1:4, nrow = 2) x2 <- obj$foo(x) expect_equal(x2$v, matrix(2:5, nrow = 2)) - + # Use in a function f1 <- nFunction( fun = function(x) { @@ -579,19 +668,19 @@ test_that("predefined SVDDecomp class works", { x$v <- matrix(1:4, nrow = 2) x2 <- obj$foo(x) expect_equal(x2$v, matrix(2:5, nrow = 2)) - - # Call C++ test function that relies on correctly reading the header + + # Call C++ test function that relies on correctly reading the header get_SVDDecomp <- nFunction( fun = function() { cppLiteral("std::shared_ptr A = make_SVDDecomp();") cppLiteral("return(A);") }, - returnType = 'SVDDecomp') + returnType = 'SVDDecomp') C_get <- nCompile(get_SVDDecomp, SVDDecomp) x <- C_get$get_SVDDecomp() x$v <- matrix(1:4, nrow = 2) expect_equal(x$v, matrix(1:4, nrow = 2)) - + # update tests! doSVD <- nFunction( fun = function(x, vectors) { @@ -601,7 +690,7 @@ test_that("predefined SVDDecomp class works", { argTypes = list(x = 'numericMatrix', vectors = 'integer'), returnType = 'SVDDecomp') comp <- nCompile(doSVD, SVDDecomp) - + # test singular value decomposition: values only x <- matrix(as.numeric(c(2, 4, 1, 3, 6, 5)), nrow = 2) Cres <- comp$doSVD(x = x, vectors = 0) @@ -609,7 +698,7 @@ test_that("predefined SVDDecomp class works", { expect_equal(as.numeric(Cres$d), as.numeric(Rres$d)) expect_equal(Cres$u, matrix(0, nrow = 0, ncol = 0)) expect_equal(Cres$v, matrix(0, nrow = 0, ncol = 0)) - + # test singular value decomposition: thin x <- matrix(as.numeric(c(2, 4, 1, 3, 6, 5)), nrow = 2) Cres <- comp$doSVD(x = x, vectors = 1) @@ -621,18 +710,18 @@ test_that("predefined SVDDecomp class works", { Cvec = as.numeric(Cres$u[,i]) Rvec = as.numeric(Rres$u[,i]) expect_true(any( - isTRUE(all.equal(Cvec, Rvec)), + isTRUE(all.equal(Cvec, Rvec)), isTRUE(all.equal(Cvec, -Rvec)) )) # right singular vectors Cvec = as.numeric(Cres$v[,i]) Rvec = as.numeric(Rres$v[,i]) expect_true(any( - isTRUE(all.equal(Cvec, Rvec)), + isTRUE(all.equal(Cvec, Rvec)), isTRUE(all.equal(Cvec, -Rvec)) )) } - + # test singular value decomposition: full x <- matrix(as.numeric(c(2, 4, 1, 3, 6, 5)), nrow = 2) Cres <- comp$doSVD(x = x, vectors = 2) @@ -644,7 +733,7 @@ test_that("predefined SVDDecomp class works", { Cvec = as.numeric(Cres$u[,i]) Rvec = as.numeric(Rres$u[,i]) expect_true(any( - isTRUE(all.equal(Cvec, Rvec)), + isTRUE(all.equal(Cvec, Rvec)), isTRUE(all.equal(Cvec, -Rvec)) )) } @@ -654,11 +743,11 @@ test_that("predefined SVDDecomp class works", { Cvec = as.numeric(Cres$v[,i]) Rvec = as.numeric(Rres$v[,i]) expect_true(any( - isTRUE(all.equal(Cvec, Rvec)), + isTRUE(all.equal(Cvec, Rvec)), isTRUE(all.equal(Cvec, -Rvec)) )) } - + # verify nSvd works with tensor expression inputs doSvdOp <- nFunction( fun = function(x, y, z, vectors) { @@ -666,8 +755,8 @@ test_that("predefined SVDDecomp class works", { return(svdX) }, argTypes = list(x = 'numericMatrix', - y = 'numericMatrix', - z = 'numericMatrix', + y = 'numericMatrix', + z = 'numericMatrix', vectors = 'integer'), returnType = 'SVDDecomp' ) @@ -683,7 +772,7 @@ test_that("predefined SVDDecomp class works", { Cvec = as.numeric(Cres$u[,i]) Rvec = as.numeric(Rres$u[,i]) expect_true(any( - isTRUE(all.equal(Cvec, Rvec)), + isTRUE(all.equal(Cvec, Rvec)), isTRUE(all.equal(Cvec, -Rvec)) )) } @@ -693,9 +782,9 @@ test_that("predefined SVDDecomp class works", { Cvec = as.numeric(Cres$v[,i]) Rvec = as.numeric(Rres$v[,i]) expect_true(any( - isTRUE(all.equal(Cvec, Rvec)), + isTRUE(all.equal(Cvec, Rvec)), isTRUE(all.equal(Cvec, -Rvec)) )) } - + }) diff --git a/nCompiler/tests/testthat/v1tests/AD_utils.R b/archived_tests/v1tests/AD_utils.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/AD_utils.R rename to archived_tests/v1tests/AD_utils.R_noscan diff --git a/archived_tests/v1tests/README_noscan.txt b/archived_tests/v1tests/README_noscan.txt new file mode 100644 index 00000000..9f3ebbc1 --- /dev/null +++ b/archived_tests/v1tests/README_noscan.txt @@ -0,0 +1,11 @@ +These are old tests. +In setting up CI testing using GitHub actions, we used setup-r-dependencies. +This aggressively scans all directories doing static code analysis of .R files +to discover hidden dependencies, for example that may be in testing only. +This causes problems for nCompiler because it does things like dynamically generate +and build packages on the fly, and then check them. So it looks like there are +package dependencies where there aren't. We have worked around this in the +current test suite. However, in retaining these old tests for reference +(eventually they will be removed), we simply renamed the files so they +don't have a .R extension. The new extension is .R_noscan to indicate +they were renamed in order to avoid static code analysis scanning. diff --git a/nCompiler/tests/testthat/v1tests/known_failures.R b/archived_tests/v1tests/known_failures.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/known_failures.R rename to archived_tests/v1tests/known_failures.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/math_utils.R b/archived_tests/v1tests/math_utils.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/math_utils.R rename to archived_tests/v1tests/math_utils.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/serialization_test_in_new_R_session.R b/archived_tests/v1tests/serialization_test_in_new_R_session.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/serialization_test_in_new_R_session.R rename to archived_tests/v1tests/serialization_test_in_new_R_session.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/serialization_test_utils/.gitignore b/archived_tests/v1tests/serialization_test_utils/.gitignore similarity index 100% rename from nCompiler/tests/testthat/v1tests/serialization_test_utils/.gitignore rename to archived_tests/v1tests/serialization_test_utils/.gitignore diff --git a/nCompiler/tests/testthat/v1tests/serialization_test_utils/README.txt b/archived_tests/v1tests/serialization_test_utils/README.txt similarity index 100% rename from nCompiler/tests/testthat/v1tests/serialization_test_utils/README.txt rename to archived_tests/v1tests/serialization_test_utils/README.txt diff --git a/nCompiler/tests/testthat/v1tests/serialization_test_utils/testserial_create_Package.R b/archived_tests/v1tests/serialization_test_utils/testserial_create_Package.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/serialization_test_utils/testserial_create_Package.R rename to archived_tests/v1tests/serialization_test_utils/testserial_create_Package.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/serialization_test_utils/testserial_read_Full.R b/archived_tests/v1tests/serialization_test_utils/testserial_read_Full.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/serialization_test_utils/testserial_read_Full.R rename to archived_tests/v1tests/serialization_test_utils/testserial_read_Full.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/serialization_test_utils/testserial_read_Generic.R b/archived_tests/v1tests/serialization_test_utils/testserial_read_Generic.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/serialization_test_utils/testserial_read_Generic.R rename to archived_tests/v1tests/serialization_test_utils/testserial_read_Generic.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/serialization_test_utils/testserial_read_Multiple.R b/archived_tests/v1tests/serialization_test_utils/testserial_read_Multiple.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/serialization_test_utils/testserial_read_Multiple.R rename to archived_tests/v1tests/serialization_test_utils/testserial_read_Multiple.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/serialization_test_utils/testserial_read_Package.R b/archived_tests/v1tests/serialization_test_utils/testserial_read_Package.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/serialization_test_utils/testserial_read_Package.R rename to archived_tests/v1tests/serialization_test_utils/testserial_read_Package.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/serialization_test_utils/testserial_save_Full.R b/archived_tests/v1tests/serialization_test_utils/testserial_save_Full.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/serialization_test_utils/testserial_save_Full.R rename to archived_tests/v1tests/serialization_test_utils/testserial_save_Full.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/serialization_test_utils/testserial_save_Generic.R b/archived_tests/v1tests/serialization_test_utils/testserial_save_Generic.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/serialization_test_utils/testserial_save_Generic.R rename to archived_tests/v1tests/serialization_test_utils/testserial_save_Generic.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/serialization_test_utils/testserial_save_Multiple.R b/archived_tests/v1tests/serialization_test_utils/testserial_save_Multiple.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/serialization_test_utils/testserial_save_Multiple.R rename to archived_tests/v1tests/serialization_test_utils/testserial_save_Multiple.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/serialization_test_utils/testserial_save_Package.R b/archived_tests/v1tests/serialization_test_utils/testserial_save_Package.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/serialization_test_utils/testserial_save_Package.R rename to archived_tests/v1tests/serialization_test_utils/testserial_save_Package.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/status.txt b/archived_tests/v1tests/status.txt similarity index 100% rename from nCompiler/tests/testthat/v1tests/status.txt rename to archived_tests/v1tests/status.txt diff --git a/nCompiler/tests/testthat/v1tests/test-AD.R b/archived_tests/v1tests/test-AD.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-AD.R rename to archived_tests/v1tests/test-AD.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-ADfun.R b/archived_tests/v1tests/test-ADfun.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-ADfun.R rename to archived_tests/v1tests/test-ADfun.R_noscan diff --git a/nCompiler/tests/testthat/test-NF_CompilerClass.R b/archived_tests/v1tests/test-NF_CompilerClass.R_noscan similarity index 100% rename from nCompiler/tests/testthat/test-NF_CompilerClass.R rename to archived_tests/v1tests/test-NF_CompilerClass.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-NF_derivs.R b/archived_tests/v1tests/test-NF_derivs.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-NF_derivs.R rename to archived_tests/v1tests/test-NF_derivs.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-RcppTypes.R b/archived_tests/v1tests/test-RcppTypes.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-RcppTypes.R rename to archived_tests/v1tests/test-RcppTypes.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-Rcpp_nCompilerPacket.R b/archived_tests/v1tests/test-Rcpp_nCompilerPacket.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-Rcpp_nCompilerPacket.R rename to archived_tests/v1tests/test-Rcpp_nCompilerPacket.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-StridedTensorMap.R b/archived_tests/v1tests/test-StridedTensorMap.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-StridedTensorMap.R rename to archived_tests/v1tests/test-StridedTensorMap.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-TBB.R b/archived_tests/v1tests/test-TBB.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-TBB.R rename to archived_tests/v1tests/test-TBB.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-aliasChecks.R b/archived_tests/v1tests/test-aliasChecks.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-aliasChecks.R rename to archived_tests/v1tests/test-aliasChecks.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-argumentPassing.R b/archived_tests/v1tests/test-argumentPassing.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-argumentPassing.R rename to archived_tests/v1tests/test-argumentPassing.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-as_wrap_Rcpp.R b/archived_tests/v1tests/test-as_wrap_Rcpp.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-as_wrap_Rcpp.R rename to archived_tests/v1tests/test-as_wrap_Rcpp.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-callingBetweenNFs.R b/archived_tests/v1tests/test-callingBetweenNFs.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-callingBetweenNFs.R rename to archived_tests/v1tests/test-callingBetweenNFs.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-compileErrorTrapping.R b/archived_tests/v1tests/test-compileErrorTrapping.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-compileErrorTrapping.R rename to archived_tests/v1tests/test-compileErrorTrapping.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-compilerStage-setToEigen.R b/archived_tests/v1tests/test-compilerStage-setToEigen.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-compilerStage-setToEigen.R rename to archived_tests/v1tests/test-compilerStage-setToEigen.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-compilerStages.R b/archived_tests/v1tests/test-compilerStages.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-compilerStages.R rename to archived_tests/v1tests/test-compilerStages.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-concatenate.R b/archived_tests/v1tests/test-concatenate.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-concatenate.R rename to archived_tests/v1tests/test-concatenate.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-cppLiteral.R b/archived_tests/v1tests/test-cppLiteral.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-cppLiteral.R rename to archived_tests/v1tests/test-cppLiteral.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-cppVariables.R b/archived_tests/v1tests/test-cppVariables.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-cppVariables.R rename to archived_tests/v1tests/test-cppVariables.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-cpp_nClassClass.R b/archived_tests/v1tests/test-cpp_nClassClass.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-cpp_nClassClass.R rename to archived_tests/v1tests/test-cpp_nClassClass.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-cpp_nFunctionClass.R b/archived_tests/v1tests/test-cpp_nFunctionClass.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-cpp_nFunctionClass.R rename to archived_tests/v1tests/test-cpp_nFunctionClass.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-eigenShapeFlex.R b/archived_tests/v1tests/test-eigenShapeFlex.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-eigenShapeFlex.R rename to archived_tests/v1tests/test-eigenShapeFlex.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-header_mgmt.R b/archived_tests/v1tests/test-header_mgmt.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-header_mgmt.R rename to archived_tests/v1tests/test-header_mgmt.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-hellotest.R b/archived_tests/v1tests/test-hellotest.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-hellotest.R rename to archived_tests/v1tests/test-hellotest.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-indexing-cpp.R b/archived_tests/v1tests/test-indexing-cpp.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-indexing-cpp.R rename to archived_tests/v1tests/test-indexing-cpp.R_noscan diff --git a/nCompiler/tests/testthat/test-indexing.R b/archived_tests/v1tests/test-indexing.R_noscan similarity index 100% rename from nCompiler/tests/testthat/test-indexing.R rename to archived_tests/v1tests/test-indexing.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-labelAbstractTypes.R b/archived_tests/v1tests/test-labelAbstractTypes.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-labelAbstractTypes.R rename to archived_tests/v1tests/test-labelAbstractTypes.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-math.R b/archived_tests/v1tests/test-math.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-math.R rename to archived_tests/v1tests/test-math.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-nClass_interface.R b/archived_tests/v1tests/test-nClass_interface.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-nClass_interface.R rename to archived_tests/v1tests/test-nClass_interface.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-nClass_uncompiled.R b/archived_tests/v1tests/test-nClass_uncompiled.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-nClass_uncompiled.R rename to archived_tests/v1tests/test-nClass_uncompiled.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-nCompile.R b/archived_tests/v1tests/test-nCompile.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-nCompile.R rename to archived_tests/v1tests/test-nCompile.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-nCompile_nClass.R b/archived_tests/v1tests/test-nCompile_nClass.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-nCompile_nClass.R rename to archived_tests/v1tests/test-nCompile_nClass.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-nCompile_nFunction.R b/archived_tests/v1tests/test-nCompile_nFunction.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-nCompile_nFunction.R rename to archived_tests/v1tests/test-nCompile_nFunction.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-nFunction_uncompiled.R b/archived_tests/v1tests/test-nFunction_uncompiled.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-nFunction_uncompiled.R rename to archived_tests/v1tests/test-nFunction_uncompiled.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-nOptim.R b/archived_tests/v1tests/test-nOptim.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-nOptim.R rename to archived_tests/v1tests/test-nOptim.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-nParse_nDeparse.R b/archived_tests/v1tests/test-nParse_nDeparse.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-nParse_nDeparse.R rename to archived_tests/v1tests/test-nParse_nDeparse.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-normalizeCalls.R b/archived_tests/v1tests/test-normalizeCalls.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-normalizeCalls.R rename to archived_tests/v1tests/test-normalizeCalls.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-packaging.R b/archived_tests/v1tests/test-packaging.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-packaging.R rename to archived_tests/v1tests/test-packaging.R_noscan diff --git a/nCompiler/tests/testthat/tests_to_be_fixed/test-predefined-NOTWORKING.R b/archived_tests/v1tests/test-predefined.R_noscan similarity index 100% rename from nCompiler/tests/testthat/tests_to_be_fixed/test-predefined-NOTWORKING.R rename to archived_tests/v1tests/test-predefined.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-recycling_rule.R b/archived_tests/v1tests/test-recycling_rule.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-recycling_rule.R rename to archived_tests/v1tests/test-recycling_rule.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-rep.R b/archived_tests/v1tests/test-rep.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-rep.R rename to archived_tests/v1tests/test-rep.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-repClass.R b/archived_tests/v1tests/test-repClass.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-repClass.R rename to archived_tests/v1tests/test-repClass.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-seq.R b/archived_tests/v1tests/test-seq.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-seq.R rename to archived_tests/v1tests/test-seq.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-seqClass.R b/archived_tests/v1tests/test-seqClass.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-seqClass.R rename to archived_tests/v1tests/test-seqClass.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-serialization.R b/archived_tests/v1tests/test-serialization.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-serialization.R rename to archived_tests/v1tests/test-serialization.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-setInputOutputTypes.R b/archived_tests/v1tests/test-setInputOutputTypes.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-setInputOutputTypes.R rename to archived_tests/v1tests/test-setInputOutputTypes.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-setWhich.R b/archived_tests/v1tests/test-setWhich.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-setWhich.R rename to archived_tests/v1tests/test-setWhich.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-substituteMangledArgumentNames.R b/archived_tests/v1tests/test-substituteMangledArgumentNames.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-substituteMangledArgumentNames.R rename to archived_tests/v1tests/test-substituteMangledArgumentNames.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-tensorCreation.R b/archived_tests/v1tests/test-tensorCreation.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-tensorCreation.R rename to archived_tests/v1tests/test-tensorCreation.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-tensorOperations_accessors.R b/archived_tests/v1tests/test-tensorOperations_accessors.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-tensorOperations_accessors.R rename to archived_tests/v1tests/test-tensorOperations_accessors.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-tensorOperations_linear_algebra.R b/archived_tests/v1tests/test-tensorOperations_linear_algebra.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-tensorOperations_linear_algebra.R rename to archived_tests/v1tests/test-tensorOperations_linear_algebra.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-tensorOperations_reshaping.R b/archived_tests/v1tests/test-tensorOperations_reshaping.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-tensorOperations_reshaping.R rename to archived_tests/v1tests/test-tensorOperations_reshaping.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-tensorOperations_sparse.R b/archived_tests/v1tests/test-tensorOperations_sparse.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-tensorOperations_sparse.R rename to archived_tests/v1tests/test-tensorOperations_sparse.R_noscan diff --git a/nCompiler/tests/testthat/test-tensorOperations_sparse_multiplication.R b/archived_tests/v1tests/test-tensorOperations_sparse_multiplication.R_noscan similarity index 100% rename from nCompiler/tests/testthat/test-tensorOperations_sparse_multiplication.R rename to archived_tests/v1tests/test-tensorOperations_sparse_multiplication.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-types-NOTWORKING.R b/archived_tests/v1tests/test-types-NOTWORKING.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-types-NOTWORKING.R rename to archived_tests/v1tests/test-types-NOTWORKING.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/test-which.R b/archived_tests/v1tests/test-which.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-which.R rename to archived_tests/v1tests/test-which.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/testing_operatorLists.R b/archived_tests/v1tests/testing_operatorLists.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/testing_operatorLists.R rename to archived_tests/v1tests/testing_operatorLists.R_noscan diff --git a/nCompiler/tests/testthat/v1tests/testing_utils.R b/archived_tests/v1tests/testing_utils.R_noscan similarity index 100% rename from nCompiler/tests/testthat/v1tests/testing_utils.R rename to archived_tests/v1tests/testing_utils.R_noscan diff --git a/ci-extra-packages.txt b/ci-extra-packages.txt new file mode 100644 index 00000000..7f25f4cb --- /dev/null +++ b/ci-extra-packages.txt @@ -0,0 +1,9 @@ +devtools +gh +nimble +inline +numDeriv +pkgload +withr +rmarkdown +testthat \ No newline at end of file diff --git a/generatePredefinedCpp.R b/generatePredefinedCpp.R index 8042f4c9..f6c0b9e0 100644 --- a/generatePredefinedCpp.R +++ b/generatePredefinedCpp.R @@ -85,7 +85,7 @@ ## This script: ## 1. Reads files in nCompiler/R that have predefined nClass definitions. ## 2. Generates the .cpp and .h content in inst -library(nCompiler) +#library(nCompiler) #set_nOption("use_nCompLocal", TRUE) @@ -116,7 +116,7 @@ library(nCompiler) ## getRcppPacket <- function(parsed, className) { ## env <- new.env() ## eval(parsed, envir = env) -## RcppPacket <- nCompile_nClass(env[[className]], +## RcppPacket <- nCompile_nClass(env[[className]], ## control = list(endStage = 'writeCpp', ## filename = predefined_filebase)) ## RcppPacket @@ -129,14 +129,14 @@ library(nCompiler) ## for(iP in seq_along(parsed)) { ## ##iP <- 1; ## thisParsed <- parsed[[iP]] - + ## if(is.call(thisParsed)) { ## if(deparse(thisParsed[[1]]) == "<-") { ## if(is.call(thisParsed[[3]])) { ## if(deparse(thisParsed[[3]][[1]]) == "nClass") { ## className <- deparse(thisParsed[[2]]) ## predefinedNames <- append(predefinedNames, className) -## predefinedRcppPackets <- c(predefinedRcppPackets, +## predefinedRcppPackets <- c(predefinedRcppPackets, ## list(getRcppPacket(thisParsed, className))) ## } ## } @@ -145,7 +145,7 @@ library(nCompiler) ## } ## } -## sepContents <- function(x, element, label) +## sepContents <- function(x, element, label) ## c("//--------------------------------------", ## "//--------------------------------------", ## paste0("// ", label), @@ -155,18 +155,18 @@ library(nCompiler) ## combinedPacket <- nCompiler:::Rcpp_nCompilerPacket( ## cppContent = c("//GENERATED BY generatedPredefinedCpp.R. DO NOT EDIT BY HAND", -## unlist(mapply(sepContents, -## x = predefinedRcppPackets, +## unlist(mapply(sepContents, +## x = predefinedRcppPackets, ## label = predefinedNames, -## MoreArgs = list(element = "cppContent"), -## SIMPLIFY=FALSE, +## MoreArgs = list(element = "cppContent"), +## SIMPLIFY=FALSE, ## USE.NAMES = FALSE))), ## hContent = c("//GENERATED BY generatedPredefinedCpp.R. DO NOT EDIT BY HAND", -## unlist(mapply(sepContents, -## x = predefinedRcppPackets, +## unlist(mapply(sepContents, +## x = predefinedRcppPackets, ## label = predefinedNames, -## MoreArgs = list(element = "hContent"), -## SIMPLIFY=FALSE, +## MoreArgs = list(element = "hContent"), +## SIMPLIFY=FALSE, ## USE.NAMES = FALSE))), ## filebase = predefined_filebase ## ) diff --git a/nCompiler/NAMESPACE b/nCompiler/NAMESPACE index f1476c09..b4333d84 100644 --- a/nCompiler/NAMESPACE +++ b/nCompiler/NAMESPACE @@ -7,7 +7,6 @@ export(NCinternals) export(NFinternals) export(argType2Cpp) export(build_compiled_nClass) -export(buildPackage) export(cloglog) export(check_Rcpp_for_nCompiler) export(compileNimble) @@ -22,6 +21,7 @@ export(dcat) export(dconstraint) export(ddirch) export(deregisterDistributions) +export(deregisterOpDef) export(dexp_nimble) export(dflat) export(dhalfflat) @@ -46,7 +46,6 @@ export(getType) export(icloglog) export(ilogit) export(iprobit) -export(installLocalDLLpackage) export(isCompiledNCgenerator) export(isDiscrete) export(isNC) @@ -80,6 +79,7 @@ export(nMatrix) export(nArray) export(nOptions) export(nParse) +export(nRep) export(nSerialize) export(nSolve) export(nUnserialize) @@ -99,8 +99,8 @@ export(rcar_normal) export(rcat) export(rconstraint) export(rdirch) -export(read_nClass) export(registerDistributions) +export(registerOpDef) export(rexp_nimble) export(rflat) export(rhalfflat) @@ -114,12 +114,8 @@ export(rmvt_chol) export(rsqrtinvgamma) export(rt_nonstandard) export(rwish_chol) -export(serialize_nComp_object) -export(deserialize_nComp_object) -export(save_nClass) export(set_nOption) export(setup_nClass_environments_from_package) -export(setup_nCompLocal) export(setup_wrt) export(square) export(test_predefined) diff --git a/nCompiler/R/NC.R b/nCompiler/R/NC.R index 8212b217..72c8153c 100644 --- a/nCompiler/R/NC.R +++ b/nCompiler/R/NC.R @@ -174,7 +174,7 @@ nClass <- function(classname, ), list(INHERIT = if(!is.null(inherit)) quote(.inherit_obj) - else quote(nCompiler:::nClassClass)) + else quote(nClassClass)) )) ## 2. in the generator result$.nCompiler <- internals diff --git a/nCompiler/R/NC_Compile.R b/nCompiler/R/NC_Compile.R index 52a687d9..b650ce59 100644 --- a/nCompiler/R/NC_Compile.R +++ b/nCompiler/R/NC_Compile.R @@ -9,7 +9,7 @@ #' @param dir Directory where generated C++ will be written. #' #' @param cacheDir Directory to be used for Rcpp cache. -#' +#' #' @param env Environment to be used for loading results of compilation. #' #' @param control List of control settings for compilation. See... @@ -17,7 +17,7 @@ #' @return Generator of objects of the compiled version of class #' \code{NC}. These will use C++ objects internally for compiled #' data and methods. -#' +#' #' @export nCompile_nClass <- function(NC, dir = file.path(tempdir(), 'nCompiler_generatedCode'), @@ -27,7 +27,7 @@ nCompile_nClass <- function(NC, control = list(), interface = c("full", "generic", "both"), ...) { - ## ... is used for internal arguments that are not necessarily documents or + ## ... is used for internal arguments that are not necessarily documents or ## promised to stay stable. dotArgs <- list(...) @@ -35,7 +35,7 @@ nCompile_nClass <- function(NC, stop(paste0("Argument NC must be an nClass generator.")) ## When called from nCompile, stopAfterRcppPacket will be TRUE. - ## While this could also be done from the control() list, + ## While this could also be done from the control() list, ## we leave that to the user. E.g. That might set endStage even ## earlier. stopAfterRcppPacket <- isTRUE(dotArgs$stopAfterRcppPacket) @@ -46,25 +46,17 @@ nCompile_nClass <- function(NC, control ) is_predefined <- !isFALSE(NCinternals(NC)$predefined) - if(is_predefined && isFALSE(controlFull$generate_predefined)) { - if(!is.character(NCinternals(NC)$predefined)) + if(is_predefined) { + predefined_dir <- NCinternals(NC)$predefined + if(!is.character(predefined_dir)) stop("There is a predefined nClass whose predefined field is not character. It should give the filename base of the predefined nClass.") - predefined_filename <- NCinternals(NC)$predefined regular_filename <- NCinternals(NC)$cpp_classname - if(identical(predefined_filename, regular_filename)) - warning(paste0("There is a predefined class whose predefined_filename and regular_filename are both ", - predefined_filename,". These should be different.")) - cppContent <- readLines( - system.file( - file.path("include", "nCompiler", paste0(predefined_filename,".cpp")), - package = "nCompiler")) - cppDef <- cppManualClass$new( - name = regular_filename, - Hpreamble = paste0("#define PREDEFINED_", regular_filename," ", predefined_filename), - Hincludes = nCompilerIncludeFile(paste0(predefined_filename, ".h")), - cppContent = cppContent, - externalCppDefs = list(R_generic_interface_calls = get_R_interface_cppDef()) - ) + } + if(is_predefined && isFALSE(controlFull$generate_predefined)) { + RcppPacket <- loadRcppPacket(predefined_dir, regular_filename) + cppDef <- cppRcppPacket$new(RcppPacket = RcppPacket) + cppDef$externalCppDefs <- c(cppDef$externalCppDefs, + get_R_interface_cppDef()) #might not be needed, but doesn't hurt to add and we don't have the details on whether it is needed from the loaded RcppPacket. } else { if(is.null(compileInfo)) compileInfo <- NCinternals(NC)$compileInfo ## Make a new compiler object @@ -76,6 +68,14 @@ nCompile_nClass <- function(NC, interfaceCalls = !is_predefined) ## We don't retain NC in NC_Compiler in order to simplify many environments pointing to each other. ## Get the cppDef cppDef <- NC_Compiler$cppDef + if(is_predefined) { + RcppPacket <- cppDefs_2_RcppPacket(cppDef) + saveRcppPacket(RcppPacket, predefined_dir, regular_filename) + # Now add interface calls if necessary for this live compilation, having + # kept them out of the written packet code. + cppDef$buildGenericInterface(interfaceCalls=TRUE, interface=FALSE) + } + ## ## if(isTRUE(get_nOption('serialize'))) ## cppDef$addSerialization(include_DLL_funs = !stopAfterRcppPacket) @@ -91,16 +91,16 @@ nCompile_nClass <- function(NC, # 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) + if(stopAfterRcppPacket) return(NC) - + compiledFuns <- cpp_nCompiler(RcppPacket, dir = dir, cacheDir = cacheDir, @@ -111,23 +111,23 @@ nCompile_nClass <- function(NC, 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, + #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") @@ -135,4 +135,3 @@ nCompile_nClass <- function(NC, ## interface is "both" return(list(full = R6interface[[1]], generic = finalFun[[1]])) } - diff --git a/nCompiler/R/NC_FullCompiledInterface.R b/nCompiler/R/NC_FullCompiledInterface.R index fddfb3f2..e7ced115 100644 --- a/nCompiler/R/NC_FullCompiledInterface.R +++ b/nCompiler/R/NC_FullCompiledInterface.R @@ -203,14 +203,14 @@ build_compiled_nClass <- function(NCgenerator, CppObj <- newCobjFun() } private$CppObj <- CppObj - private$DLLenv <- nCompiler:::get_DLLenv(CppObj) + private$DLLenv <- `:::`("nCompiler", "get_DLLenv")(CppObj) # workaround static code scanning for nCompiler:::get_DLLenv(CppObj) }), RPUBLIC, RFIELDS, CINTERFACE), active = ACTIVEBINDINGS, portable = FALSE, - inherit = nCompiler:::CnClassClass, + inherit = `:::`("nCompiler", "CnClassClass"), # work around static code scanning parent_env = NULL ## when quoted = TRUE, env argument is not used ), env = list( @@ -311,9 +311,9 @@ buildActiveBinding_for_compiled_nClass <- function(NCI, fieldNames) { body(ans) <- substitute( { if(missing(value)) - private$DLLenv$get_value(nCompiler:::getExtptr(private$CppObj), NAME) + private$DLLenv$get_value(`:::`("nCompiler", "getExtptr")(private$CppObj), NAME) else - private$DLLenv$set_value(nCompiler:::getExtptr(private$CppObj), NAME, value) + private$DLLenv$set_value(`:::`("nCompiler", "getExtptr")(private$CppObj), NAME, value) }, list(NAME = name) ) @@ -365,7 +365,7 @@ buildMethod_for_compiled_nClass <- function(fun, name) { 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), + private$DLLenv$call_method(`:::`("nCompiler", "getExtptr")(private$CppObj), NAME, LISTCODE), list(NAME = name, LISTCODE = listcode) ) @@ -423,7 +423,7 @@ build_generic_fn_for_compiled_nClass_method <- function(fun, name) { for(i in seq_along(argNames)) listcode[[i+1]] <- as.name(argNames[i]) body_ans <- substitute( - call_method(nCompiler:::getExtptr(CppObj_), NAME, LISTCODE), + call_method(`:::`("nCompiler", "getExtptr")(CppObj_), NAME, LISTCODE), list(NAME = name, LISTCODE = listcode) ) diff --git a/nCompiler/R/NC_InternalsClass.R b/nCompiler/R/NC_InternalsClass.R index 10ed6243..2a8016af 100644 --- a/nCompiler/R/NC_InternalsClass.R +++ b/nCompiler/R/NC_InternalsClass.R @@ -76,8 +76,8 @@ NC_InternalsClass <- R6::R6Class( stop(paste0('enableDerivs entry ', i, ' is not a method in Cpublic.')) } self$enableDerivs <- enableDerivs - self$predefined <- predefined } + self$predefined <- predefined self$enableSaving <- enableSaving } ) diff --git a/nCompiler/R/NC_Serialize.R b/nCompiler/R/NC_Serialize.R index 392b33bd..6bb85009 100644 --- a/nCompiler/R/NC_Serialize.R +++ b/nCompiler/R/NC_Serialize.R @@ -19,12 +19,12 @@ nSerialize <- function(obj) { # is not serializing them. # Then R's serialize will call the refhook again with the externalptr # which we WILL serialize. - if(isTRUE(nCompiler:::is.loadedObjectEnv(ref_obj))) { + if(isTRUE(is.loadedObjectEnv(ref_obj))) { # First time that we get a loadedObjectEnv, we'll use it for the DLLenv # to get the serialization-related calls to C++. # Future extension: Allow multiple DLLenvs in one nSerialize call. if(is.null(ser_mgr)) { - DLLenv <<- nCompiler:::get_DLLenv(ref_obj) + DLLenv <<- get_DLLenv(ref_obj) new_smgr_fn <- DLLenv$new_serialization_mgr if(!is.function(new_smgr_fn)) stop("nCompiler serialization manager not found.") ser_mgr <<- new_smgr_fn() @@ -60,7 +60,7 @@ nSerialize <- function(obj) { # serialize the serialization_mgr, which will include the pointed-to objects ser_fn <- DLLenv$nComp_serialize_ if(!is.function(ser_fn)) stop("nCompiler serialization function not found") - CPPside <- ser_fn(nCompiler:::getExtptr(ser_mgr)) + CPPside <- ser_fn(getExtptr(ser_mgr)) # 2b. Clear the serialization_mgr of its pointers (underlying objects are still fine) (\() DLLenv$call_method(ser_mgr$extptr, "clear", list()))() } @@ -136,289 +136,3 @@ nUnserialize <- function(obj, pkgName, lib = NULL) { } result } - -################################################################ -### EVERYTHING BELOW HERE IS OLD AND PROBABLY WILL NOT BE USED -### I am leaving it in place during the development moment of adding -### above - -# Internal function used by save_nClass() which calls the provided serialization -# function, then instantiates and returns a new loadedObjectEnv with the -# contents - -get_serialize_fun <- function(obj) { - parent.env(obj)$nComp_serialize_ -} - -get_deserialize_fun <- function(obj) { - parent.env(obj)$nComp_deserialize_ -} - -serialize_nComp_object <- function(obj, serializer) { - if(!is.loadedObjectEnv(obj)) - stop("obj must be a loadedObjectEnv.") - if(is.null(getExtptr(obj))) { - warning("No nComp serialization to be done.") - return(obj) - } else { - if(missing(serializer)) { - serializer <-get_serialize_fun(obj) - if(!is.function(serializer)) - stop("Function for serializing not found not found.") - } - serial_data <- serializer(getExtptr(obj)) - - newObj <- new.serialObjectEnv(serial_data, get_DLLenv(obj)) - return(newObj) - } -} - -# Internal function used by read_nClass() which calls the provided -# deserialization function and applies it to a loadedObjectEnv -deserialize_nComp_object <- function(obj, deserializer) { - if(!is.serialObjectEnv(obj)) - stop("obj must be a serialObjectEnv.") - if(!(class(obj$serial) == "raw")) - stop("serialized content must have class 'raw'") - if(missing(deserializer)) { - deserializer <- get_deserialize_fun(obj) - if(!is.function(deserializer)) - stop("Function for serializing not found not found.") - } - newXptr <- deserializer(obj$serial) - newObj <- new.loadedObjectEnv(newXptr) - parent.env(newObj) <- parent.env(obj) - newObj -} - -#' @name save_nClass -#' @title Save an instance of an nClass object across sessions -#' @description Saves an nClass, including its compiled components, across -#' sessions using the `cereal` serialization library for C++. -#' @param ncObj A compiled instance of an nClass object. Right now this only -#' works for -#' @param ncDef The uncompiled nClass generator used to define ncObj's nClass. -#' Leave NULL and use the argument \code{packageWithDefn} if the nClass is -#' defined in an existing package. -#' @param file The filename to which the serialized object will be written as -#' RDS, probably with extension ".rds" -#' @param packageWithDefn If one exists, the name of the previously defined -#' package that defines the nClass (character string). Leave NULL if no such -#' package exists in which case a small package will be created. If NULL, an -#' ncDef object must be provided. -#' @param classname If no ncDef is provided, a character string giving the class -#' name of the ncObj. If ncDef is provided, can be left NULL. -#' @param dir The directory in which the package directory will be created and -#' source code will be written. Ignored if packageWithDefn is not NULL. -#' @param lib The lib folder where the package will be quietly installed. -#' Ignored if packageWithDefn is not NULL. -#' @export -#' -#' @details -#' -#' There are two parameterizations of this function. If you've defined an nClass -#' and want to save it as an instance, use: -#' -#' \code{ save_nClass(ncObj, file, ncDef) } -#' -#' In this case, a package storing the nClass definition will be created. This -#' allows the nClass info to be restored with the specific instantiated object -#' upon reading. -#' -#' If the nClass is defined in a package, and so will be found even in a new -#' (fresh) session, use: -#' -#' \code{ save_nClass(ncObj, file, packageWithDefn, classname) } -#' -#' @examples -#' set_nOption("serialize", TRUE) -#' -#' # Create a new nClass -#' nc1 <- nClass( -#' classname = "nc1", -#' Cpublic = list( -#' Cv = 'numericScalar', -#' Cx = 'integerScalar', -#' Cfoo = nFunction( -#' fun = function(x) { -#' return(x+1) -#' }, -#' argTypes = list(x = 'numericScalar'), -#' returnType = 'numericScalar') -#' ) -#' ) -#' -#' # Compile the nClass -#' Cnc1 <- nCompile_nClass(nc1, interface = "full") -#' -#' # Instantiate an object of the nClass -#' my_nc1_instance <- Cnc1$new() -#' my_nc1_instance$Cv <- 10 -#' -#' # Save the instance (along with its class definition) -#' save_nClass(my_nc1_instance, file = "example_save.Rds", ncDef = nc1) -#' -save_nClass <- function(ncObj, - file, - ncDef = NULL, - packageWithDefn = NULL, - classname = NULL, - dir = tempdir(), - lib = .libPaths()[1]) { - if (isFALSE(get_nOption("serialize"))) { - set_nOption("serialize", TRUE) - on.exit(set_nOption("serialize", FALSE)) - } - if (missing(lib)) lib <- .libPaths()[1] - if (is.null(packageWithDefn)) { - if (is.null(ncDef)) { - stop("In save_nClass, must provide either 'ncDef' or 'packageWithDefn'.") - } - package.name <- paste0("savePackageClass", - gsub(pattern = "_", "", - Rname2CppName(ncDef$classname))) - createPackage <- TRUE - } else if (is.character(packageWithDefn)) { - package.name <- packageWithDefn - createPackage <- FALSE - } else { - stop("In save_nClass, packageWithDefn must be a character string") - } - - if (is.null(classname)) { - if (is.null(ncDef)) - stop(paste0("In save_nClass, if no 'ncDef' is provided, the class name", - " must be provided", "\n as a character string")) - else classname <- ncDef$classname - } - - ## if (createPackage) { - ## serialize_fn <- get_serialize_fun(ncObj) - ## } else { - ## serialize_fn <- utils::getFromNamespace( - ## "nComp_serialize_" - ## package.name - ## ) - ## } - - if (is.loadedObjectEnv(ncObj)) { - serialized <- serialize_nComp_object(ncObj) - listToSerialize <- list(CppObj = serialized$serialized, - constructedPackage = TRUE, - classname = classname, - package.name = package.name) - saveRDS(listToSerialize, file) - } else if (isNC(ncObj)) { - serialized <- serialize_nComp_object(ncObj$private$CppObj, serialize_fn) - listToSerialize <- list(full = ncObj, - CppObj = serialized$serialized, - constructedPackage = TRUE, - classname = classname, - package.name = package.name) - - saveRDS(listToSerialize, file) - - } else { - stop("Object to save, 'ncObj', must be an instance of an nClass.") - } - - if (createPackage) { - writePackage(ncDef, - package.name = package.name, - dir = dir, - control = list(export = FALSE), - modify = FALSE, - memberData = list(classname = classname)) - buildPackage(package.name = package.name, - dir = dir, lib = lib, load = FALSE) - } - invisible(NULL) -} - - -#' @name read_nClass -#' @title Read an nClass object saved by \code{save_nClass} -#' @description Read an instance of an nClass saved by \code{save_nClass}. -#' The class definition and deserialization tools (using the \code{cereal} -#' library for C++) are loaded from the relevant package, whether it was -#' written or generated automatically from \code{save_nClass}. -#' @param file The (probably .rds) file to which the nClass object was written -#' @param lib The lib folder where the package defining the nClass is found -#' @export -#' -#' @examples -#' set_nOption("serialize", TRUE) -#' -#' # Create a new nClass -#' nc1 <- nClass( -#' classname = "nc1", -#' Cpublic = list( -#' Cv = 'numericScalar', -#' Cx = 'integerScalar', -#' Cfoo = nFunction( -#' fun = function(x) { -#' return(x+1) -#' }, -#' argTypes = list(x = 'numericScalar'), -#' returnType = 'numericScalar') -#' ) -#' ) -#' -#' # Compile the nClass -#' Cnc1 <- nCompile_nClass(nc1, interface = "full") -#' -#' # Instantiate an object of the nClass -#' my_nc1_instance <- Cnc1$new() -#' my_nc1_instance$Cv <- 10 -#' -#' # Save the instance (along with its class definition) -#' save_nClass(my_nc1_instance, file = "example_save.Rds", ncDef = nc1) -#' -#' ### A new session can be started here -#' my_nc1_read <- read_nClass("example_save.Rds") -#' my_nc1_read$Cv -#' my_nc1_read$Cfoo(10) -#' -read_nClass <- function(file, lib = .libPaths()[1]) { - - savedObj <- readRDS(file) - if (!is.list(savedObj) || is.null(savedObj$CppObj)) { - stop("Object in specified RDS file is not a saved nClass.") - } - - if (!is.null(savedObj$full)) { - serialized <- new.loadedObjectEnv(serialized = savedObj$CppObj) - - # library(savedObj$package.name, character.only = TRUE, lib = lib) - # loadEnv <- new.env() - # data(list = "classname", package = savedObj$package.name, envir = loadEnv) - deserialize_fn <- utils::getFromNamespace( - paste0("nComp_deserialize_", Rname2CppName(savedObj$classname)), - savedObj$package.name - ) - deserialized <- deserialize_nComp_object( - serialized, nComp_deserialize_fn = deserialize_fn) - - rtnObjFull <- savedObj$full - rtnObjFull$private$CppObj <- deserialized - - return(rtnObjFull) - - } else { - serialized <- new.loadedObjectEnv(serialized = savedObj$CppObj) - - # library(savedObj$package.name, character.only = TRUE, lib = lib) - # loadEnv <- new.env() - # data(list = "classname", package = savedObj$package.name, envir = loadEnv) - - deserialize_fn <- utils::getFromNamespace( - paste0("nComp_deserialize_", Rname2CppName(savedObj$classname)), - savedObj$package.name - ) - deserialized <- deserialize_nComp_object( - serialized, nComp_deserialize_fn = deserialize_fn) - return(deserialized) - } -} - - diff --git a/nCompiler/R/NC_SimpleInterface.R b/nCompiler/R/NC_SimpleInterface.R index 38587d41..63199cc9 100644 --- a/nCompiler/R/NC_SimpleInterface.R +++ b/nCompiler/R/NC_SimpleInterface.R @@ -6,7 +6,7 @@ method <- function(obj, name) { if(inherits(obj, "CnClass")) obj <- obj$private$CppObj - CnCenv <- nCompiler:::get_CnCenv(obj) + CnCenv <- get_CnCenv(obj) ans <- CnCenv[[name]] environment(ans) <- new.env(parent = environment(ans)) environment(ans)$CppObj_ <- obj @@ -33,8 +33,8 @@ method <- function(obj, name) { value <- function(obj, name) { if(inherits(obj, "CnClass")) obj <- obj$private$CppObj - DLLenv <- nCompiler:::get_DLLenv(obj) - extptr <- nCompiler:::getExtptr(obj) + DLLenv <- get_DLLenv(obj) + extptr <- getExtptr(obj) DLLenv$get_value(extptr, name) ## if(is.null(getExtptr(obj))) @@ -46,8 +46,8 @@ value <- function(obj, name) { `value<-` <- function(obj, name, value) { if(inherits(obj, "CnClass")) obj <- obj$private$CppObj - DLLenv <- nCompiler:::get_DLLenv(obj) - extptr <- nCompiler:::getExtptr(obj) + DLLenv <- get_DLLenv(obj) + extptr <- getExtptr(obj) DLLenv$set_value(extptr, name, value) obj ## if(is.null(getExtptr(obj))) diff --git a/nCompiler/R/NC_Utils.R b/nCompiler/R/NC_Utils.R index 7562d250..793b1396 100644 --- a/nCompiler/R/NC_Utils.R +++ b/nCompiler/R/NC_Utils.R @@ -81,3 +81,26 @@ NCinternals <- function(x) { call. = FALSE) x } + +# Utility function to allow searching up an inheritance +# ladder to find a method. +NC_find_method <- function(NCgenerator, name, inherits=TRUE) { + if(!isNCgenerator(NCgenerator)) + stop("Input must be a nClass generator.") + current_NCgen <- NCgenerator + done <- FALSE + method <- NULL + while(!done) { + if(name %in% NCinternals(current_NCgen)$methodNames) { + method <- current_NCgen$public_methods[[name]] + done <- TRUE + } else { + if(inherits) { + current_NCgen <- current_NCgen$parent_env$.inherit_obj # same as current_NCgen$get_inherit() if there is inheritance, but get_inherit returns the base class at the top + done <- is.null(current_NCgen) + } else + done <- TRUE + } + } + method +} \ No newline at end of file diff --git a/nCompiler/R/NF.R b/nCompiler/R/NF.R index 991f0031..045db877 100644 --- a/nCompiler/R/NF.R +++ b/nCompiler/R/NF.R @@ -85,6 +85,7 @@ nFunction <- function(fun, # returnCallable = TRUE, control = list(), compileInfo = list(), + predefined = FALSE, where = parent.frame(), ... ) { @@ -142,6 +143,7 @@ nFunction <- function(fun, # C_fun = C_fun, control = control, compileInfo = compileInfo, + predefined = predefined, where = where) ## Return a callable function. ## This will be modified: diff --git a/nCompiler/R/NF_Compile.R b/nCompiler/R/NF_Compile.R index 47301e9a..5cdad17d 100644 --- a/nCompiler/R/NF_Compile.R +++ b/nCompiler/R/NF_Compile.R @@ -57,24 +57,40 @@ nCompile_nFunction <- function(NF, if(is.null(compileInfo)) compileInfo <- NFinternals(NF)$compileInfo - NF_Compiler <- NF_CompilerClass$new(f = NF, - useUniqueNameInCpp = - controlFull$useUniqueNameInCode, - compileInfo = compileInfo) - NF_Compiler$createCpp(control = controlFull) - if(NFcompilerMaybeStopAfter(NF_Compiler$stageCompleted, - controlFull)) { - if(get_nOption('verbose')) - message(paste0("Returning after stage ", - NF_Compiler$stageCompleted)) - return(NF_Compiler) + is_predefined <- !isFALSE(NFinternals(NF)$predefined) + if(is_predefined) { + predefined_dir <- NFinternals(NF)$predefined + if(!is.character(predefined_dir)) + stop("There is a predefined nFunction whose predefined field is not character. It should give the filename base of the predefined nFunction.") + regular_filename <- NFinternals(NF)$cpp_code_name } - stageName <- 'makeRcppPacket' - if (logging) logBeforeStage(stageName) - if(NFcompilerMaybeStop(stageName, controlFull)) - return(NF_Compiler) + if(is_predefined && isFALSE(controlFull$generate_predefined)) { + RcppPacket <- loadRcppPacket(predefined_dir, regular_filename) + cppDef <- cppRcppPacket$new(RcppPacket = RcppPacket) + } else { + NF_Compiler <- NF_CompilerClass$new(f = NF, + useUniqueNameInCpp = + controlFull$useUniqueNameInCode, + compileInfo = compileInfo) + NF_Compiler$createCpp(control = controlFull) + if(NFcompilerMaybeStopAfter(NF_Compiler$stageCompleted, + controlFull)) { + if(get_nOption('verbose')) + message(paste0("Returning after stage ", + NF_Compiler$stageCompleted)) + return(NF_Compiler) + } + if(is_predefined) { + RcppPacket <- cppDefs_2_RcppPacket(NF_Compiler$cppDef) + saveRcppPacket(RcppPacket, predefined_dir, regular_filename) + } + stageName <- 'makeRcppPacket' + if (logging) logBeforeStage(stageName) + if(NFcompilerMaybeStop(stageName, controlFull)) + return(NF_Compiler) - cppDef <- NF_Compiler$cppDef + cppDef <- NF_Compiler$cppDef + } if(stopAfterCppDef) return(cppDef) # We might deprecate from here down and make all usages start from nCompile. diff --git a/nCompiler/R/NF_InternalsClass.R b/nCompiler/R/NF_InternalsClass.R index a7ab5f3c..3667b91e 100644 --- a/nCompiler/R/NF_InternalsClass.R +++ b/nCompiler/R/NF_InternalsClass.R @@ -15,7 +15,7 @@ NF_InternalsClass <- R6::R6Class( isMethod = FALSE, uniqueName = character(), cpp_code_name = character(), - template = NULL, + ## template = NULL, replaced with compileInfo$matchDef code = NULL, RcppPacket = NULL, Rwrapper = NULL, @@ -23,6 +23,7 @@ NF_InternalsClass <- R6::R6Class( # needed_nFunctions = list(), ## formerly neededRCfuns ADcontent = NULL, isAD = FALSE, + predefined = FALSE, compileInfo = list(), R_fun = NULL, #used only if compileInfo$C_fun is provided. ## Next two "includes" were only needed for making external calls: @@ -39,6 +40,7 @@ NF_InternalsClass <- R6::R6Class( enableDerivs = FALSE, control = list(), compileInfo = list(), + predefined = FALSE, ## methodNames, ## used only for nf_checkDSLcode ## setupVarNames = NULL, ## Ditto where = parent.frame() @@ -58,6 +60,7 @@ NF_InternalsClass <- R6::R6Class( self$arguments <- as.list(formals(fun_to_use)) self$control <- control self$compileInfo <- compileInfo + self$predefined <- predefined self$compileInfo$C_fun <- NULL # Do not retain this because it ends up in code and arguments self$where <- where if(is.character(refArgs)) { @@ -86,7 +89,7 @@ NF_InternalsClass <- R6::R6Class( if(code[[1]] != '{') self$code <- substitute({CODE}, list(CODE=code)) ## check all code except.nCompiler package nFunctions - ## if(check && "package.nCompiler" %in% search()) + ## if(check && "package.nCompiler" %in% search()) ## nf_checkDSLcode(code, methodNames, setupVarNames) ## Some of this should become unnecessary. ## However, a problem is how regular R default values will be used @@ -94,7 +97,12 @@ NF_InternalsClass <- R6::R6Class( ## Either a named "value" or a ... is in all types. ## not used until much later - self$template <- Rarguments_2_function(arguments, body = quote({})) ## generateTemplate() + if(is.null(self$compileInfo$opDef)) + self$compileInfo$opDef <- list() + if(is.null(self$compileInfo$opDef$matchDef)) { + self$compileInfo$opDef$matchDef <- Rarguments_2_function(arguments, body = quote({})) + } + # self$template <- Rarguments_2_function(arguments, body = quote({})) ## generateTemplate() returnTypeInfo <- nf_extractReturnType(code) returnTypeDecl <- returnTypeInfo$returnType if(is.null(returnTypeDecl)) { @@ -117,10 +125,13 @@ NF_InternalsClass <- R6::R6Class( ## what this one's cpp function name will be: if(!is.null(compileInfo$cpp_code_name)) self$cpp_code_name <- compileInfo$cpp_code_name - else - self$cpp_code_name <- paste(Rname2CppName(name), - nFunctionIDMaker(), - sep = "_") + else { + self$cpp_code_name <- Rname2CppName(name) + if(isFALSE(predefined)) + self$cpp_code_name <- paste(self$cpp_code_name, + nFunctionIDMaker(), + sep = "_") + } ## Unpack enableDerivs into AD self$isAD <- FALSE if(!(isFALSE(enableDerivs) || is.null(enableDerivs))) { @@ -129,7 +140,7 @@ NF_InternalsClass <- R6::R6Class( stop("enableDerivs must be NULL, FALSE, TRUE, or a list.") if(isTRUE(enableDerivs$isAD)) { self$isAD <- TRUE - self$callFromR <- FALSE + self$compileInfo$callFromR <- FALSE } else { self$ADcontent <- list() self$ADcontent$ADfun <- enableDerivs$ADfun diff --git a/nCompiler/R/NF_derivs.R b/nCompiler/R/NF_derivs.R index c057b637..5433a9e8 100644 --- a/nCompiler/R/NF_derivs.R +++ b/nCompiler/R/NF_derivs.R @@ -214,7 +214,7 @@ setup_wrt_internal <- function(wrt, fxnArgs, fxnName, dropArgs = NA) { if (inherits(fxnArgs[[1]], 'symbolBase')) arg_symbols <- fxnArgs else { - arg_symbols <- lapply(fxnArgs, nCompiler:::argType2symbol) + arg_symbols <- lapply(fxnArgs, argType2symbol) } nameCheck <- sapply(wrtMatchArgs, function(i) class(arg_symbols[[i]])) if (any(nameCheck == 'name')) stop('Derivatives of ', fxnName, ' being taken diff --git a/nCompiler/R/Rcpp_nCompiler.R b/nCompiler/R/Rcpp_nCompiler.R index d59bd27a..0370fb68 100644 --- a/nCompiler/R/Rcpp_nCompiler.R +++ b/nCompiler/R/Rcpp_nCompiler.R @@ -27,6 +27,9 @@ Rcpp_nCompilerPacket <- function(...) { ## To be expanded to take a list of cppDefs cppDefs_2_RcppPacket <- function(cppDef, filebase) { + if(inherits(cppDef, 'cppRcppPacket')) + return(cppDef$RcppPacket) + name <- cppDef$name if(missing(filebase)) filebase <- make_cpp_filebase(name) @@ -451,3 +454,203 @@ compileCpp_nCompiler <- function(Rcpp_packet, ## } return(ans) } + +## Functions for saving and loading RcppPackets +## Created with assistance from Copilot using Claude Sonnet 4 + +#' Save an RcppPacket to disk as a set of files +#' +#' @param RcppPacket The RcppPacket object to save +#' @param dir Directory to save the packet files in +#' @param name Base name for the packet files (defaults to filebase from packet) +#' @return Invisibly returns the directory path where files were saved +#' @export +saveRcppPacket <- function(RcppPacket, dir, name = NULL) { + if (is.null(name)) { + name <- RcppPacket$filebase + if (is.null(name)) { + stop("RcppPacket must have a filebase element or name must be provided") + } + } + + # Normalize the directory path for platform independence + dir <- normalizePath(dir, mustWork = FALSE) + + # Create directory if it doesn't exist + dir.create(dir, recursive = TRUE, showWarnings = FALSE) + + # Helper function to write content safely + writePacketElement <- function(content, filename) { + filepath <- normalizePath(file.path(dir, filename), mustWork = FALSE) + if (is.null(content) || length(content) == 0) { + # Create empty file to indicate element exists but is empty + file.create(filepath) + } else if (is.character(content)) { + writeLines(content, filepath) + } else if (is.list(content)) { + # For structured content like cppContent/hContent + if (all(c("opener", "body") %in% names(content))) { + # Write as separate sections + con <- file(filepath, "w") + writeLines("### OPENER ###", con) + if (length(content$opener) > 0) { + writeLines(content$opener, con) + } + writeLines("### BODY ###", con) + if (length(content$body) > 0) { + writeLines(content$body, con) + } + close(con) + } else { + # Other list content - serialize to text + dput(content, file = filepath) + } + } else { + # For other types, use dput + dput(content, file = filepath) + } + } + + # Write each element to its own file + writePacketElement(RcppPacket$preamble, paste0(name, "_preamble.txt")) + writePacketElement(RcppPacket$cppContent, paste0(name, "_cppContent.txt")) + writePacketElement(RcppPacket$hContent, paste0(name, "_hContent.txt")) + writePacketElement(RcppPacket$filebase, paste0(name, "_filebase.txt")) + writePacketElement(RcppPacket$post_cpp_compiler, paste0(name, "_post_cpp_compiler.txt")) + writePacketElement(RcppPacket$copyFiles, paste0(name, "_copyFiles.txt")) + + # Write a manifest file listing what was saved + manifest <- list( + saved_at = Sys.time(), + packet_name = name, + elements = names(RcppPacket), + files = list( + preamble = paste0(name, "_preamble.txt"), + cppContent = paste0(name, "_cppContent.txt"), + hContent = paste0(name, "_hContent.txt"), + filebase = paste0(name, "_filebase.txt"), + post_cpp_compiler = paste0(name, "_post_cpp_compiler.txt"), + copyFiles = paste0(name, "_copyFiles.txt") + ) + ) + + manifest_path <- normalizePath(file.path(dir, paste0(name, "_manifest.txt")), mustWork = FALSE) + dput(manifest, file = manifest_path) + + invisible(normalizePath(dir)) +} + +#' Load an RcppPacket from disk files +#' +#' @param dir Directory containing the packet files +#' @param name Base name of the packet files to load +#' @return An RcppPacket object (list) +#' @export +loadRcppPacket <- function(dir, name) { + # Normalize and check if directory exists + dir <- normalizePath(dir, mustWork = TRUE) + + # Load manifest first to check what files should exist + manifest_file <- normalizePath(file.path(dir, paste0(name, "_manifest.txt")), mustWork = FALSE) + if (file.exists(manifest_file)) { + manifest <- dget(manifest_file) + cat("Loading RcppPacket saved at:", as.character(manifest$saved_at), "\n") + } else { + warning("No manifest file found. Attempting to load standard files.") + manifest <- list(files = list( + preamble = paste0(name, "_preamble.txt"), + cppContent = paste0(name, "_cppContent.txt"), + hContent = paste0(name, "_hContent.txt"), + filebase = paste0(name, "_filebase.txt"), + post_cpp_compiler = paste0(name, "_post_cpp_compiler.txt"), + copyFiles = paste0(name, "_copyFiles.txt") + )) + } + + # Helper function to read content safely + readPacketElement <- function(filename) { + filepath <- normalizePath(file.path(dir, filename), mustWork = FALSE) + if (!file.exists(filepath)) { + return(NULL) + } + + # Check if file is empty + if (file.size(filepath) == 0) { + return(character(0)) + } + + # Try to detect the content type + first_line <- readLines(filepath, n = 1, warn = FALSE) + + if (length(first_line) == 0) { + return(character(0)) + } + + # Check if it's a structured file (cppContent/hContent) + if (first_line == "### OPENER ###") { + lines <- readLines(filepath, warn = FALSE) + opener_start <- which(lines == "### OPENER ###") + body_start <- which(lines == "### BODY ###") + + if (length(opener_start) == 1 && length(body_start) == 1) { + opener_lines <- if (body_start > opener_start + 1) { + lines[(opener_start + 1):(body_start - 1)] + } else { + character(0) + } + + body_lines <- if (length(lines) > body_start) { + lines[(body_start + 1):length(lines)] + } else { + character(0) + } + + return(list(opener = opener_lines, body = body_lines)) + } + } + + # Check if it looks like dput output + if (grepl("^(list|c|character|NULL|[0-9])", first_line)) { + tryCatch({ + return(dget(filepath)) + }, error = function(e) { + # If dget fails, treat as plain text + return(readLines(filepath, warn = FALSE)) + }) + } + + # Default: read as character lines + return(readLines(filepath, warn = FALSE)) + } + + # Load each element + RcppPacket <- Rcpp_nCompilerPacket( + preamble = readPacketElement(manifest$files$preamble), + cppContent = readPacketElement(manifest$files$cppContent), + hContent = readPacketElement(manifest$files$hContent), + filebase = readPacketElement(manifest$files$filebase), + post_cpp_compiler = readPacketElement(manifest$files$post_cpp_compiler), + copyFiles = readPacketElement(manifest$files$copyFiles) + ) + + return(RcppPacket) +} + +#' List available saved RcppPackets in a directory +#' +#' @param dir Directory to search for saved packets +#' @return Character vector of packet names found +#' @export +listRcppPackets <- function(dir) { + # Normalize path, but allow non-existent directories + dir <- normalizePath(dir, mustWork = FALSE) + + if (!dir.exists(dir)) { + return(character(0)) + } + + manifest_files <- list.files(dir, pattern = "_manifest\\.txt$", full.names = FALSE) + packet_names <- sub("_manifest\\.txt$", "", manifest_files) + + return(packet_names) +} diff --git a/nCompiler/R/Rhooks.R b/nCompiler/R/Rhooks.R index 612b7c3e..ddd1e459 100644 --- a/nCompiler/R/Rhooks.R +++ b/nCompiler/R/Rhooks.R @@ -1,6 +1,6 @@ ## for .onLoad .onLoad <- function(...) { - Rcpp::registerPlugin("nCompiler_plugin", nCompiler:::nCompiler_plugin) - Rcpp::registerPlugin("nCompiler_Eigen_plugin", nCompiler:::nCompiler_Eigen_plugin) + Rcpp::registerPlugin("nCompiler_plugin", `:::`("nCompiler", "nCompiler_plugin")) + Rcpp::registerPlugin("nCompiler_Eigen_plugin", `:::`("nCompiler", "nCompiler_Eigen_plugin")) # message("For nCompiler: Run 'setup_nCompLocal()' once per installation and re-start R.") } diff --git a/nCompiler/R/compileNimble.R b/nCompiler/R/compileNimble.R index 936d41a2..02e43e1e 100644 --- a/nCompiler/R/compileNimble.R +++ b/nCompiler/R/compileNimble.R @@ -355,8 +355,8 @@ compileNimble <- function(..., project, dirName = NULL, projectName = '', } names(nComp_units) <- names(units) - nCompiler:::registerOpDef(nimble_nCompiler_opDefs) - on.exit({nCompiler:::deregisterOpDef(ls(nimble_nCompiler_opDefs))}) + registerOpDef(nimble_nCompiler_opDefs) + on.exit({deregisterOpDef(ls(nimble_nCompiler_opDefs))}) ans <- do.call(nCompile, nComp_units) if(sum(nfUnits) > 0) { whichUnits <- which(nfUnits) diff --git a/nCompiler/R/compile_aaa_operatorLists.R b/nCompiler/R/compile_aaa_operatorLists.R index 25ca757f..610d2a8e 100644 --- a/nCompiler/R/compile_aaa_operatorLists.R +++ b/nCompiler/R/compile_aaa_operatorLists.R @@ -14,7 +14,7 @@ returnTypeCodes <- list( returnTypeString2Code <- function(returnTypeString) { if(is.character(returnTypeString)) - do.call('switch', c(list("double"), nCompiler:::returnTypeCodes)) + do.call('switch', c(list("double"), returnTypeCodes)) else returnTypeString } @@ -163,7 +163,7 @@ assignOperatorDef( # c() labelAbstractTypes = list( handler = 'nC', return_nDim = 1, - returnTypeCodes$promote), + returnTypeCode = returnTypeCodes$promote), eigenImpl = list() ) ) @@ -364,21 +364,21 @@ assignOperatorDef( ) ) -nCompiler:::assignOperatorDef( +assignOperatorDef( c('IndexByScalar'), list( cppOutput = list(handler = 'IndexByScalar') ) ) -nCompiler:::assignOperatorDef( +assignOperatorDef( c('IndexByVec'), list( cppOutput = list(handler = 'IndexByVec') ) ) -nCompiler:::assignOperatorDef( +assignOperatorDef( c('IndexBySeqs'), list( cppOutput = list(handler = 'IndexBySeqs') @@ -428,9 +428,9 @@ assignOperatorDef( 'chainedCall', list( labelAbstractTypes = list( + handler = 'ChainedCall'), + cppOutput = list( handler = 'ChainedCall') - ## , cppOutput = list( - ## handler = 'ChainedCall') ) ) @@ -602,7 +602,7 @@ assignOperatorDef( matchDef = function(text, types) {}, compileArgs = c("text","types"), help = 'cppLiteral("x = y;") inserts x = y; directly into the C++ output.', - simpleTransformations = list(handler = "Literal"), + simpleTransformations = list(handler = 'Literal'), labelAbstractTypes = list(handler = 'Literal'), cppOutput = list(handler = 'Literal') ) @@ -1100,6 +1100,7 @@ assignOperatorDef( assignOperatorDef( c('nDiag', 'nDiagonal'), list( + matchDef = function(x, nrow, ncol) {}, labelAbstractTypes = list( handler = 'Diag' ), diff --git a/nCompiler/R/compile_eigenization.R b/nCompiler/R/compile_eigenization.R index 7e7fe6a1..bdc3b19f 100644 --- a/nCompiler/R/compile_eigenization.R +++ b/nCompiler/R/compile_eigenization.R @@ -73,9 +73,10 @@ compile_eigenize <- function(code, return(invisible(NULL)) } - opInfo <- operatorDefEnv[[code$name]] - if(!is.null(opInfo)) { - handlingInfo <- opInfo[["eigenImpl"]] + handlingInfo <- getOperatorDef(code$name, "eigenImpl") + # operatorDefEnv[[code$name]] + # if(!is.null(opInfo)) { + # handlingInfo <- opInfo[["eigenImpl"]] if(!is.null(handlingInfo)) { beforeHandler <- handlingInfo[['beforeHandler']] if(!is.null(beforeHandler)) { @@ -90,7 +91,7 @@ compile_eigenize <- function(code, # return(if(length(setupExprs) == 0) NULL else setupExprs) } } - } + # } iArgs <- seq_along(code$args) useArgs <- eigenizeUseArgs[[code$name]] @@ -104,11 +105,10 @@ compile_eigenize <- function(code, } ## finally, call any special handlers - if(!is.null(opInfo)) { - handlingInfo <- opInfo[["eigenImpl"]] + # if(!is.null(opInfo)) { + # handlingInfo <- opInfo[["eigenImpl"]] if(!is.null(handlingInfo)) { - handler <- handlingInfo[['handler']] - + handler <- handlingInfo[['handler']] if(!is.null(handler)) { setupExprs <- c(setupExprs, eval(call(handler, @@ -120,7 +120,7 @@ compile_eigenize <- function(code, envir = eigenizeEnv)) } } - } + # } } return(if(length(setupExprs) == 0) NULL else setupExprs) } @@ -733,7 +733,7 @@ inEigenizeEnv( } ) -nCompiler:::inEigenizeEnv( +inEigenizeEnv( Bracket_to_StridedTensorMap <- function(code, symTab, auxEnv, workEnv, handlingInfo) { code$name <- paste0('Eigen::MakeStridedTensorMap<', code$type$nDim, '>::make') @@ -786,7 +786,7 @@ nCompiler:::inEigenizeEnv( }) -nCompiler:::inEigenizeEnv( +inEigenizeEnv( MakeIndexByScalarCall <- function(index_slot, index_value, x) { ans <- exprClass$new(isName = FALSE, isCall = TRUE, isAssign = FALSE, name = "IndexByScalar") @@ -797,7 +797,7 @@ nCompiler:::inEigenizeEnv( } ) -nCompiler:::inEigenizeEnv( +inEigenizeEnv( MakeIndexByVecCall <- function(index_slot, index_value, x) { ans <- exprClass$new(isName = FALSE, isCall = TRUE, isAssign = FALSE, name = "IndexByVec") @@ -808,7 +808,7 @@ nCompiler:::inEigenizeEnv( } ) -nCompiler:::inEigenizeEnv( +inEigenizeEnv( MakeIndexBySeqsCall <- function(index_slots, index_value, x) { ans <- exprClass$new(isName = FALSE, isCall = TRUE, isAssign = FALSE, name = "IndexBySeqs") @@ -825,7 +825,7 @@ nCompiler:::inEigenizeEnv( } ) -nCompiler:::inEigenizeEnv( +inEigenizeEnv( Bracket <- function(code, symTab, auxEnv, workEnv, handlingInfo) { if (code$type$nDim == 0) { # Either we're indexing a vector and we keep '[' in the AST, or we're @@ -858,6 +858,34 @@ nCompiler:::inEigenizeEnv( drop <- code$args$drop$name if(!is.logical(drop)) warning("Problem determining whether to drop dimensions.") + + if(isTRUE(nOptions("nimble") || isTRUE(nOptions("dropSingleSizes")))) { + ## Here we imitate nimble's blockIndexInfo to determine + ## scalar indices from ":" or c() (or possibly other?) cases + ## but here what we do is replace the argument right now and + ## then the rest of the logic below should work correctly. + ## Currently in nimble there are three cases: + ## "3:3" Take the first "3" + ## A name with sizeExpr 1, which would be from a lifted c(scalar) + ## here it won't be lifted so it is like ":", take the first arg + ## There are also cases where a name is deparsed or not, and + ## I am not sure which arises when or what I might be missing. + if(drop) { + for(argInd in 2:(length(code$args)-1)) { + if(code$args[[argInd]]$type$nDim > 0 + && !is.null(code$args[[argInd]]$type$knownSize) + && code$args[[argInd]]$type$knownSize == 1) { + if(code$args[[argInd]]$isCall) { + if(code$args[[argInd]]$name %in% c(':', 'nC')) { + singleValueArg <- code$args[[argInd]]$args[[1]]$clone() + setArg(code, argInd, singleValueArg) + } + } + } + } + } + } + for(argInd in 2:(length(code$args)-1)) { ind <- argInd - 1 isBlank <- code$args[[argInd]]$isName & code$args[[argInd]]$name == "" @@ -1043,6 +1071,8 @@ inEigenizeEnv( } } + # This is the only use of Make_Length1_Tensor in the code + # Can we replace it with CreateTensor? if(code$args[[1]]$type$nDim == 0) { insertExprClassLayer(code, 1, "Eigen::Make_Length1_Tensor") } @@ -1267,20 +1297,8 @@ inEigenizeEnv( } # vector input yields arbitrary diagonal matrix else if(xArg$type$nDim == 1) { - nrowValue <- wrapExprClassOperator( - code = exprClass$new(isName = TRUE, isCall = FALSE, isAssign = FALSE, - isLiteral = FALSE, name = xArg$name, - type = xArg$type), - funName = 'length', - type = symbolBasic$new(name = 'nrow', nDim = 0, type = 'integer') - ) - ncolValue <- wrapExprClassOperator( - code = exprClass$new(isName = TRUE, isCall = FALSE, isAssign = FALSE, - isLiteral = FALSE, name = xArg$name, - type = xArg$type), - funName = 'length', - type = symbolBasic$new(name = 'ncol', nDim = 0, type = 'integer') - ) + nrowValue <- nParse(paste0('cppLiteral("MakeSquareDiag__{}")')) + ncolValue <- nParse(paste0('cppLiteral("MakeSquareDiag__{}")')) insertArg(expr = code, ID = 1, value = nrowValue, name = 'nrow') insertArg(expr = code, ID = 1, value = ncolValue, name = 'ncol') argNames <- names(code$args) diff --git a/nCompiler/R/compile_exprClass.R b/nCompiler/R/compile_exprClass.R index b7d4f21a..23ad9dec 100644 --- a/nCompiler/R/compile_exprClass.R +++ b/nCompiler/R/compile_exprClass.R @@ -195,6 +195,16 @@ insertExprClassLayer <- function(code, argID, funName, isName = FALSE, isCall = newExpr } +wrapInExprClass <- function(code, funName, argName=NULL) { + caller <- code$caller + callerArgID <- code$callerArgID + newExpr <- exprClass$new(name=funName, isName=FALSE, isCall=TRUE, isAssign=FALSE) + argID <- if(is.null(argName)) 1 else argName + setArg(newExpr, argID, code, add=TRUE) + setArg(caller, callerArgID, newExpr) + newExpr +} + ## Sometimes we have an expr foo(a, b) and we want to make it g(foo(a, b)) ## We do that by wrapExprClassOperator(code, 'g'), where code is the 'foo' expClass. wrapExprClassOperator <- function(code, funName, isName = FALSE, isCall = TRUE, @@ -484,11 +494,14 @@ anyNonScalar <- function(code) { exprClass_match_call <- function(def, expr) { # This is a version of match.call where def is an R function definition (like for match.call) # or a pairlist, and expr is an exprClass, returned by nParse. + # However, the returned object contains argument (re-)ordering information only. # # The strategy will be to create something like # match.call(function(a , b , c ){}, call("foo", b = 1, 2, 3)) # resulting in foo(a = 2, b = 1, c = 3), - # from which we can see that the expr arguments need to be re-orded by c(2, 1, 3) + # from which we can see that the expr arguments need to be re-orded by c(2, 1, 3). + # The object foo(a = 2, b = 1, c = 3) is returned, so that exprClass_put_args_in_order + # can do the further work needed using the ordering. # We can also see what expected arguments are missing and store that information # for potential later handling. # The sequential values 1, 2, 3 in the artificial call will reveal argument permutations needed. @@ -510,7 +523,8 @@ exprClass_match_call <- function(def, expr) { result } -exprClass_put_args_in_order <- function(def, expr, insertDefaults = TRUE) { +exprClass_put_args_in_order <- function(def, expr, + compileArgs = NULL, insertDefaults = TRUE) { match_res <- exprClass_match_call(def, expr) # there is a function reorderArgs above which appears to have been written # for eigenization of nDiag. @@ -526,6 +540,8 @@ exprClass_put_args_in_order <- function(def, expr, insertDefaults = TRUE) { missing_names <- setdiff(names(formals_def), names(match_res)[-1] ) expr$aux[["provided_as_missing"]] <- missing_names expr$aux[["missing"]] <- missing_names + # match.call DOES NOT insert defaults for missing arguments, + # but we want to do so. if(insertDefaults) { new_missing_names <- character() for(mname in missing_names) { @@ -542,6 +558,22 @@ exprClass_put_args_in_order <- function(def, expr, insertDefaults = TRUE) { } expr$aux[["missing"]] <- new_missing_names } + # separate compile-time arguments. + # This is done AFTER inserting defaults, so that compile-time args can have defaults. + # The nParse-ing of compileTime args was superfluous, so we throw it out in this step. + if(length(compileArgs)>0) { + aux_compileArgs <- list() + iRes <- 1 + for(CA_name in compileArgs) { + if(CA_name %in% names(expr$args)) { + aux_compileArgs[[iRes]] <- expr$args[[CA_name]]$Rexpr + names(aux_compileArgs)[iRes] <- CA_name + iRes <- iRes + 1 + removeArg(expr, CA_name) + } + } + expr$aux[["compileArgs"]] <- aux_compileArgs + } expr } diff --git a/nCompiler/R/compile_generateCpp.R b/nCompiler/R/compile_generateCpp.R index b0683d05..69b22655 100644 --- a/nCompiler/R/compile_generateCpp.R +++ b/nCompiler/R/compile_generateCpp.R @@ -85,11 +85,12 @@ compile_generateCpp <- function(code, ans[[length(code$args) + 2]] <- paste0(indent, '}') return(ans) } - opInfo <- operatorDefEnv[[code$name]] - if(!is.null(opInfo)) { - handlingInfo <- opInfo[["cppOutput"]] - if(!is.null(handlingInfo)) { - handler <- handlingInfo$handler + handler <- getOperatorDef(code$name, "cppOutput", "handler") + # opInfo <- operatorDefEnv[[code$name]] + # if(!is.null(opInfo)) { + # handlingInfo <- opInfo[["cppOutput"]] + # if(!is.null(handlingInfo)) { + # handler <- handlingInfo$handler if(!is.null(handler)) { if (logging) appendToLog(paste('Calling handler', handler, 'for', code$name)) @@ -104,8 +105,8 @@ compile_generateCpp <- function(code, } return(res) } - } - } + # } + # } ## default: not yet updated return(eval(call("AsIs", code, symTab), envir = genCppEnv)) @@ -164,8 +165,10 @@ inGenCppEnv( inGenCppEnv( Generic_nFunction <- function(code, symTab) { - paste0(compile_generateCpp(code$args[[1]], symTab), - '(', paste0(unlist(lapply(code$args[-1], + innerCode <- code$args[['call']] + cpp_code_name <- code$aux$cpp_code_name + paste0(cpp_code_name, + '(', paste0(unlist(lapply(innerCode$args, compile_generateCpp, symTab, asArg = TRUE) ), @@ -181,16 +184,14 @@ inGenCppEnv( ) inGenCppEnv( - chainedCall <- function(code, symTab) { - firstCall <- compile_generateCpp(code$args[[1]], symTab) - paste0(firstCall, - '(', - paste0(unlist(lapply(code$args[-1], - compile_generateCpp, - symTab, - asArg = TRUE) ), - collapse = ', '), ')' - ) + ChainedCall <- function(code, symTab) { + paste0(compile_generateCpp(code$args[[1]], symTab), + '(', paste0(unlist(lapply(code$args[-1], + compile_generateCpp, + symTab, + asArg = TRUE) ), + collapse = ', '), + ')' ) } ) @@ -394,7 +395,7 @@ inGenCppEnv( } ) -nCompiler:::inGenCppEnv( +inGenCppEnv( IndexByScalar <- function(code, symTab) { paste0("ISINGLE_(", compile_generateCpp(code$args[[1]], symTab), ",", @@ -411,7 +412,7 @@ nCompiler:::inGenCppEnv( } ) -nCompiler:::inGenCppEnv( +inGenCppEnv( IndexByVec <- function(code, symTab) { paste0("IVEC_(", compile_generateCpp(code$args[[1]], symTab), ",", @@ -429,21 +430,21 @@ nCompiler:::inGenCppEnv( } ) -nCompiler:::inGenCppEnv( +inGenCppEnv( IndexBySeqs <- function(code, symTab) { midpieces <- list() NumSeqs <- compile_generateCpp(code$args[[1]], symTab) ## piece1 <- paste0("nCompiler::IndexBySeqs<", ## NumSeqs, ## ">().op(nCompiler::IndexBySeqs<",N,">::AllSliceDetails{") - piece1 <- paste0("ISEQS_(", NumSeqs, ", SEQS_(") + piece1 <- paste0("ISEQS_((", NumSeqs, "), SEQS_(") midpieces <- list() iArg <- 2 for(i in 1:((length(code$args)-2)/3)) { - midpieces[[i]] <- paste0("SEQ_(", - compile_generateCpp(code$args[[iArg]], symTab), ",", - MinusOne(compile_generateCpp(code$args[[iArg+1]], symTab)), ",", - MinusOne(compile_generateCpp(code$args[[iArg+2]], symTab)), ")" + midpieces[[i]] <- paste0("SEQ_((", + compile_generateCpp(code$args[[iArg]], symTab), "), (", + MinusOne(compile_generateCpp(code$args[[iArg+1]], symTab)), "), (", + MinusOne(compile_generateCpp(code$args[[iArg+2]], symTab)), "))" ) ## midpieces[[i]] <- paste0("nCompiler::IndexBySeqs<",N,">::SliceDetail{", @@ -456,8 +457,8 @@ nCompiler:::inGenCppEnv( iArg <- iArg + 3 } piece2 <- paste0(unlist(midpieces), collapse=", \n ") - piece3 <- paste0( nCompiler:::compile_generateCpp(code$args[[iArg]], symTab)) - ans <- paste0(piece1, "\n ", piece2, "),\n ", piece3, ")") + piece3 <- paste0( compile_generateCpp(code$args[[iArg]], symTab)) + ans <- paste0(piece1, "\n ", piece2, "),\n (", piece3, "))") ans } ) @@ -470,8 +471,17 @@ inGenCppEnv( inGenCppEnv( Literal <- function(code, symTab) { - paste0(code$aux$compileArgs$text, collapse = "\n") -# code$args[[1]]$name + # For cases that have been in code all the way through compilation, + # the text was removed as a compile-time argument as is in compileArgs$text. + # But there are also cases such as buildSEXPgenerator where cppLiteral is + # parsed but not compile-time args have not been separated (and must be string literals). Therefore we + # look for both situations here and just paste them together. + part1 <- character() + if(length(code$args) > 0) { + part1 <- code$args |> lapply(`[[`,'name') |> unlist() |> paste0(collapse="") + } + part2 <- paste0(code$aux$compileArgs$text, collapse = "\n") + paste0(part1, part2, collapse="") } ) diff --git a/nCompiler/R/compile_labelAbstractTypes.R b/nCompiler/R/compile_labelAbstractTypes.R index 59e0f06f..647dd88a 100644 --- a/nCompiler/R/compile_labelAbstractTypes.R +++ b/nCompiler/R/compile_labelAbstractTypes.R @@ -54,7 +54,8 @@ compile_labelAbstractTypes <- function(code, } # see if code$name is a method of current nClass if(is.null(obj) & isNCgenerator(auxEnv$where)) { - if(code$name %in% names(auxEnv$where$public_methods)) { + found_method <- NC_find_method(auxEnv$where, code$name, inherits = TRUE) + if(!is.null(found_method)) { # code$name is as a reference to the member function as an object labelAbstractTypesEnv$reference_nFunction_or_method_AST( code, auxEnv$where @@ -86,6 +87,8 @@ compile_labelAbstractTypes <- function(code, } if(code$isCall) { + # Note that nFunction or nClass method calls are already (from simpleTransformations) + # embedded in NFCALL_, for which the opDef is then looked up. if(code$name == '{') { ## recurse over lines for(i in seq_along(code$args)) { @@ -97,10 +100,10 @@ compile_labelAbstractTypes <- function(code, return(invisible(NULL)) } - opInfo <- operatorDefEnv[[code$name]] - - if(!is.null(opInfo)) { - handlingInfo <- opInfo[["labelAbstractTypes"]] + handlingInfo <- getOperatorDef(code$name, "labelAbstractTypes") + # opInfo <- operatorDefEnv[[code$name]] + # if(!is.null(opInfo)) { + # handlingInfo <- opInfo[["labelAbstractTypes"]] if(!is.null(handlingInfo)) { handler <- handlingInfo[['handler']] if(!is.null(handler)) { @@ -116,7 +119,7 @@ compile_labelAbstractTypes <- function(code, return(ans) } } - } + # } } nErrorEnv$stateInfo <- character() invisible(NULL) @@ -197,7 +200,7 @@ inLabelAbstractTypesEnv( inserts <- recurse_labelAbstractTypes(code, symTab, auxEnv, handlingInfo) ## TO-DO: Add check that first arg is symbolNF - code$name <- 'NFCALL_' + ## code$name <- 'NFCALL_' if(!inherits(code$args[[1]]$type, "symbolNF")) stop(exprClassProcessingErrorMsg( code, @@ -273,8 +276,7 @@ inLabelAbstractTypesEnv( ## 1. Check if RHS is a method ## 2. Check if RHS is a field innerName <- code$args[[2]]$name - method <- code$args[[1]]$type$NCgenerator$public_methods[[ - innerName]] + method <- NC_find_method(code$args[[1]]$type$NCgenerator, innerName, inherits=TRUE) if(!is.null(method)) { ## Is RHS a method? obj_internals <- NFinternals(method) returnSym <- symbolNF$new( @@ -292,7 +294,7 @@ inLabelAbstractTypesEnv( code$args[[2]]$name <- NFinternals(method)$cpp_code_name obj_internals <- NULL } else { ## Is RHS a field? - symbol <- NCinternals(code$args[[1]]$type$NCgenerator)$symbolTable$getSymbol(innerName) + symbol <- NCinternals(code$args[[1]]$type$NCgenerator)$symbolTable$getSymbol(innerName, inherits=TRUE) if(is.null(symbol)) stop(exprClassProcessingErrorMsg( code, @@ -360,8 +362,7 @@ inLabelAbstractTypesEnv( } # access nFunction - tgt <- NFinternals(obj$public_methods[[code$name]]) - + tgt <- NC_find_method(obj, code$name, inherits=TRUE) if(is.null(tgt)) { stop(exprClassProcessingErrorMsg( code, paste('In reference_nFunction_or_method_AST: the nFunction ', @@ -405,12 +406,24 @@ inLabelAbstractTypesEnv( inLabelAbstractTypesEnv( nFunction_or_method_call <- function(code, symTab, auxEnv, handlingInfo) { - useArgs <- c(FALSE, rep(TRUE, length(code$args)-1)) - inserts <- recurse_labelAbstractTypes(code, symTab, auxEnv, - handlingInfo, useArgs) - obj_internals <- code$args[[1]]$aux$obj_internals - nFunctionName <- code$args[[1]]$aux$nFunctionName - code$args[[1]]$type <- symbolNF$new(name = nFunctionName) + # We have code = NFCALL_(foo(x, y)) + # innerCall if foo(x,y) + # We'll set innerCall$type to symbolNF + # and we'll set code$type to the returnType of foo(x, y) + innerCall <- code$args[['call']] + if(is.null(innerCall)) + stop( + exprClassProcessingErrorMsg( + code, paste('In nFunction_or_method_call: the nFunction (or method) ', + code$name, + ' has NULL content.') + ), call. = FALSE + ) + inserts <- recurse_labelAbstractTypes(innerCall, symTab, auxEnv, + handlingInfo) + obj_internals <- code$aux$obj_internals + nFunctionName <- code$aux$nFunctionName + innerCall$type <- symbolNF$new(name = nFunctionName) returnSym <- obj_internals$returnSym if(is.null(returnSym)) stop( @@ -421,7 +434,25 @@ inLabelAbstractTypesEnv( ), call. = FALSE ) code$type <- returnSym$clone() ## Not sure if a clone is needed, but it seems safer to make one. - invisible(NULL) + inserts + + # useArgs <- c(FALSE, rep(TRUE, length(code$args)-1)) + # inserts <- recurse_labelAbstractTypes(code, symTab, auxEnv, + # handlingInfo, useArgs) + # obj_internals <- code$args[[1]]$aux$obj_internals + # nFunctionName <- code$args[[1]]$aux$nFunctionName + # code$args[[1]]$type <- symbolNF$new(name = nFunctionName) + # returnSym <- obj_internals$returnSym + # if(is.null(returnSym)) + # stop( + # exprClassProcessingErrorMsg( + # code, paste('In nFunction_or_method_call: the nFunction (or method) ', + # code$name, + # ' does not have a valid returnType.') + # ), call. = FALSE + # ) + # code$type <- returnSym$clone() ## Not sure if a clone is needed, but it seems safer to make one. + # invisible(NULL) } ) @@ -465,8 +496,20 @@ inLabelAbstractTypesEnv( nC <- function(code, symTab, auxEnv, handlingInfo) { inserts <- recurse_labelAbstractTypes(code, symTab, auxEnv, handlingInfo) type <- setReturnType(handlingInfo, code$args[[1]]$type$type) + if(length(code$args) > 1) { + for(i in 2:length(code$args)) { + type <- arithmeticOutputType(type, code$args[[i]]$type$type) + } + } nDim <- setReturn_nDim(handlingInfo, code$args[[1]]$type$nDim) code$type <- symbolBasic$new(type = type, nDim = nDim) + # For nimble backward compatibility, set knownSize to 1 + # if it is contains a single scalar + # could put behind if(isTRUE(nOptions("nimble"))) + if(length(code$args)==1 && !is.null(code$args[[1]]$type$nDim) + && code$args[[1]]$type$nDim==0) { + code$type$knownSize <- 1 + } # wrap scalar args to length-1 vectors for implementation compatibility for(arg in code$args) { if(arg$type$nDim == 0) { @@ -808,6 +851,9 @@ inLabelAbstractTypesEnv( fromType <- code$args[[1]]$type$type code_type <- if (fromType == 'logical') 'integer' else fromType code$type <- symbolBasic$new(nDim = 1, type = code_type) + # For backward compatibility cases with nimble: + if(code$args[[1]]$isLiteral && code$args[[2]]$isLiteral) + code$type$knownSize <- code$args[[2]]$name - code$args[[1]]$name + 1 invisible(inserts) } ) @@ -1148,6 +1194,7 @@ inLabelAbstractTypesEnv( inLabelAbstractTypesEnv( Bracket <- function(code, symTab, auxEnv, handlingInfo) { + # To-Do: Mark "drop" as a compile-time arg in the op entry. inserts <- recurse_labelAbstractTypes(code, symTab, auxEnv, handlingInfo) ## drop must be named if provided, so this should work @@ -1161,9 +1208,14 @@ inLabelAbstractTypesEnv( code$args <- NULL ## reset args - brackets_empty <- length(index_args) == 1 && - index_args[[1]]$isName && - index_args[[1]]$name == "" + brackets_empty <- TRUE + for(i in seq_along(index_args)) + if(!(index_args[[i]]$isName && index_args[[i]]$name == "")) + brackets_empty <- FALSE + + # brackets_empty <- length(index_args) == 1 && + # index_args[[1]]$isName && + # index_args[[1]]$name == "" if (brackets_empty) { ## no indexing is happening, so just replace [ with the obj in the AST @@ -1202,6 +1254,10 @@ inLabelAbstractTypesEnv( setArg(code, 1, obj) ## put indexed object back as first arg + # Here we only determine if dropping will occur and for how many + # index dimensions. The actual dropping occurs in the implementation + # during eigenization. + nDrop <- 0 for (i in seq_along(index_args)) { ## ensure that indexing args appear before drop in AST @@ -1223,51 +1279,33 @@ inLabelAbstractTypesEnv( ## ) if (index_args[[i]]$name != '') { - ## ## not a call resulting in non-scalar other than ':' - ## if (is.null(index_args[[i]]$type) || ## missing index nDim info - ## is.null(index_args[[i]]$type$nDim)) ## would this ever happen? - ## stop( - ## exprClassProcessingErrorMsg( - ## code, - ## paste0("In Bracket: '", index_args[[i]]$name, - ## "' has no dimension.") - ## ), call. = FALSE - ## ) - ## ## TODO: allow for scalar logicals? - ## if (index_args[[i]]$type$type == 'logical') ## index logical - ## stop( - ## exprClassProcessingErrorMsg( - ## code, - ## paste0("In Bracket: '", index_args[[i]]$name, - ## "' is a logical which is not allowed when indexing.") - ## ), call. = FALSE - ## ) - ## if (index_args[[i]]$type$nDim > 1) ## bad index nDim - ## stop( - ## exprClassProcessingErrorMsg( - ## code, - ## paste0( - ## "In Bracket: the dimension of '", index_args[[i]]$name, - ## " is ", index_args[[i]]$type$nDim, " but must be 0 or 1." - ## ) - ## ), call. = FALSE - ## ) - ## if (nDim == 0 && index_args[[i]]$type$nDim != 0) ## indexing a scalar with non-scalar - ## stop( - ## exprClassProcessingErrorMsg( - ## code, - ## paste0( - ## "In Bracket: '", obj$name, - ## "' is a scalar but the indexing arg has dimension ", - ## index_args[[i]]$type$nDim, "." - ## ) - ## ), call. = FALSE - ## ) - ## no errors were triggered so increment nDrop if the arg is scalar + # Possible checks to add (from nimble) + # - invalid type result (missing or nDim>1) from recursing on indices above + # - logical index (not allowed in nimble). Possible to-do extension later. + # - indexing a scalar beyond a "[1]" if (index_args[[i]]$type$nDim == 0) nDrop <- nDrop + 1 + else { + ## Backward compatibility with some slightly odd nimble behavior + ## If an index slot contains a literal sequence of length one (e.g. 3:3, but not i:i) + ## or a concatenation of a scalar (e.g. c(3) or c(i)), both of which + ## nimble determines are length 1, it treats it as a drop dimension. + ## In some cases this creates more R-like behavior (R will drop 3:3 or i:i or c(3) or c(i)) + ## but it also creates internal inconsistencies (3:3 different from i:i) + ## and generally sneaky inspection of a vector's length. + ## Hence nCompiler will never drop a vector index, even of obvious length 1 + ## but will do so as tracked by knownSize if nimble compatibility is set. + ## If we discover other cases where nimble drops a dimension + ## we can handle it by making sure the expression resulting in that gets + ## knownSize == 1. + if(isTRUE(nOptions("nimble")) || isTRUE(nOptions("dropSingleSizes"))) { + if(is.numeric(index_args[[i]]$type$knownSize) + && index_args[[i]]$type$knownSize == 1) { + nDrop <- nDrop + 1 + } + } + } } } - drop <- TRUE if (nDim == 0) { # If we're indexing a scalar, any drop arg provided is ignored. @@ -1317,12 +1355,6 @@ inLabelAbstractTypesEnv( inLabelAbstractTypesEnv( Literal <- function(code, symTab, auxEnv, handlingInfo) { - if (length(code$args) > 2) - stop(exprClassProcessingErrorMsg( - code, - 'cppLiteral has argument length > 2.' - ), - call. = FALSE) if(!is.null(code$aux$compileArgs)) { types <- code$aux$compileArgs$types if(!is.null(types)) { @@ -1331,12 +1363,6 @@ inLabelAbstractTypesEnv( for (sym in symbols) symTab$addSymbol(sym) } } - ## if (length(code$args) == 2) { - ## ## Add types that the user specified in their literal C++ code to symTab - ## type_list <- lapply(code$args[[2]]$args, `[[`, 'name') - ## symbols <- argTypeList2symbolTable(type_list)$getSymbols() - ## for (sym in symbols) symTab$addSymbol(sym) - ## } invisible(NULL) } ) @@ -1379,6 +1405,7 @@ inLabelAbstractTypesEnv( ), call. = FALSE) } + # To-do: Warn about element type mismatches and cast later. type_mismatch <- FALSE # if returnType is a scalar, do more checks if(auxEnv$returnSymbol$nDim==0) { diff --git a/nCompiler/R/compile_nParse.R b/nCompiler/R/compile_nParse.R index 9f9c9bc3..d9176370 100644 --- a/nCompiler/R/compile_nParse.R +++ b/nCompiler/R/compile_nParse.R @@ -15,27 +15,29 @@ embedListInRbracket <- function(code) { as.call(c(list(as.name('{')), code)) } -splitCompileTimeArgs <- function(call, template, - compileArgs = character()) { - # call should be R code, e.g. from quote() or parse() - if(!missing(template)) - call <- match.call(template, call) - processedArgs <- list() - for(compileArg in compileArgs) { - processedArg <- NULL - if(!is.null(call[[compileArg]])) { - processedArg <- call[[compileArg]] - } else if(!nCompiler:::is.blank(formals(template)[[compileArg]])) { - processedArg <- formals(template)[[compileArg]] - } - if(!is.null(processedArg)) { - processedArgs[compileArg] <- list(processedArg) - call[compileArg] <- list(NULL) - } - } - list(code = call, - compileArgs = processedArgs) -} +## This has been entirely moved to compile_normalizeCalls +## because then we can use user-defined matchDef (template) and compileArgs. +# splitCompileTimeArgs <- function(call, template, +# compileArgs = character()) { +# # call should be R code, e.g. from quote() or parse() +# if(!missing(template)) +# call <- match.call(template, call) +# processedArgs <- list() +# for(compileArg in compileArgs) { +# processedArg <- NULL +# if(!is.null(call[[compileArg]])) { +# processedArg <- call[[compileArg]] +# } else if(!nCompiler:::is.blank(formals(template)[[compileArg]])) { +# processedArg <- formals(template)[[compileArg]] +# } +# if(!is.null(processedArg)) { +# processedArgs[compileArg] <- list(processedArg) +# call[compileArg] <- list(NULL) +# } +# } +# list(code = call, +# compileArgs = processedArgs) +# } ## build exprClasses from an R parse tree. ## caller and callerArgID are for recursion, not to be used on first entry @@ -56,8 +58,7 @@ splitCompileTimeArgs <- function(call, template, nParse <- function(code, caller = NULL, callerArgID = numeric(), - recursing = FALSE, - opDefEnv = operatorDefEnv) { ## input code is R parse tree + recursing = FALSE) { ## input code is R parse tree if(!recursing) { if(is.character(code)) code <- parse(text = code, @@ -99,20 +100,18 @@ nParse <- function(code, code <- as.call(c(list(as.name('chainedCall')), as.list(code))) } name <- as.character(code[[1]]) - processedCompileArgs <- list() - if(!is.null(opDefEnv)) { - opDef <- opDefEnv[[name]] - if(!is.null(opDef)) { - template <- opDef$matchDef - if(!is.null(template)) { - processedCall <- splitCompileTimeArgs(call=code, - template=template, - compileArgs=opDef$compileArgs) - code <- processedCall$code - processedCompileArgs <- processedCall$compileArgs - } - } - } + # processedCompileArgs <- list() + # opDef <- getOperatorDef(name) + # if(!is.null(opDef)) { + # template <- opDef$matchDef + # if(!is.null(template)) { + # processedCall <- splitCompileTimeArgs(call=code, + # template=template, + # compileArgs=opDef$compileArgs) + # code <- processedCall$code + # processedCompileArgs <- processedCall$compileArgs + # } + # } isAssign <- name %in% c('<-','=','<<-') args <- vector('list', length = length(code)-1) ## build the object @@ -125,8 +124,8 @@ nParse <- function(code, args = args, caller = caller, callerArgID = callerArgID) - if(length(processedCompileArgs)) - ans$aux$compileArgs <- processedCompileArgs + # if(length(processedCompileArgs)) + # ans$aux$compileArgs <- processedCompileArgs ## Ensure that bodies of for, if, while, switch, and run.time are ## in { expressions. ## Doing this here reduces special-case checking in later processing. @@ -173,8 +172,7 @@ nParse <- function(code, ans$args[i-1] <- list(nParse(code[[i]], caller = ans, callerArgID = i-1, - recursing = TRUE, - opDefEnv=opDefEnv)) + recursing = TRUE)) } return(ans) } diff --git a/nCompiler/R/compile_normalizeCalls.R b/nCompiler/R/compile_normalizeCalls.R index 48481725..14576642 100644 --- a/nCompiler/R/compile_normalizeCalls.R +++ b/nCompiler/R/compile_normalizeCalls.R @@ -31,7 +31,7 @@ compile_normalizeCalls <- function(code, if(is.null(opInfo)) { obj <- NULL if(isNCgenerator(auxEnv$where)) {## We are in a class method (by direct call within another class method, no `$` involved) - obj <- auxEnv$where$public_methods[[code$name]] + obj <- NC_find_method(auxEnv$where, code$name, inherits=TRUE) if(!is.null(obj)) { code$aux$obj_internals <- NFinternals(obj) if(isNF(obj)) { @@ -50,7 +50,10 @@ compile_normalizeCalls <- function(code, if(is.null(obj)) { obj <- nGet(code$name, where = auxEnv$where) ## An nFunction will be transformed to - ## have code$name 'NFCALL_'. + ## have code$name 'NFCALL_' during simpleTransformations, + ## but that hasn't happened yet, so we manually use it here. + ## To-do: This could be cleaned up by either making that change here + ## when first detected or making a separate compiler stage just for that. if(!is.null(obj)) { if(isNF(obj)) { code$aux$obj_internals <- NFinternals(obj) @@ -82,7 +85,7 @@ compile_normalizeCalls <- function(code, if(!is.null(opInfo)) { matchDef <- opInfo[["matchDef"]] if(!is.null(matchDef)) { - matched_code <- exprClass_put_args_in_order(matchDef, code) + matched_code <- exprClass_put_args_in_order(matchDef, code, opInfo$compileArgs) code <- replaceArgInCaller(code, matched_code) } handlingInfo <- opInfo[["normalizeCalls"]] @@ -142,20 +145,23 @@ inNormalizeCallsEnv( nFunctionName <- code$name obj_internals <- code$aux$obj_internals code$aux$obj_internals <- NULL - matched_code <- exprClass_put_args_in_order(obj_internals$template, code) + opDef <- obj_internals$compileInfo$opDef + matched_code <- exprClass_put_args_in_order(def=opDef$matchDef, expr=code, compileArgs = opDef$compileArgs) code <- replaceArgInCaller(code, matched_code) ## Note that the string `NFCALL_` matches the operatorDef entry. ## Therefore the change-of-name here will automatically trigger use of ## the 'NFCALL_' operatorDef in later stages. - code$name <- 'NFCALL_' + newExpr <- wrapInExprClass(code, 'NFCALL_', "call") + # code$name <- 'NFCALL_' cpp_code_name <- obj_internals$cpp_code_name - fxnNameExpr <- exprClass$new(name = cpp_code_name, isName = TRUE, - isCall = FALSE, isLiteral = FALSE, isAssign = FALSE) - fxnNameExpr$aux$obj_internals <- obj_internals - fxnNameExpr$aux$nFunctionName <- nFunctionName + # fxnNameExpr <- exprClass$new(name = cpp_code_name, isName = TRUE, + # isCall = FALSE, isLiteral = FALSE, isAssign = FALSE) + newExpr$aux$obj_internals <- obj_internals + # newExpr$aux$nFunctionName <- nFunctionName + newExpr$aux$cpp_code_name <- cpp_code_name ## We may need to add content to this symbol if ## necessary for later processing steps. - insertArg(code, 1, fxnNameExpr, "FUN_") + ## insertArg(code, 1, fxnNameExpr, "FUN_") obj_internals <- NULL invisible(NULL) } diff --git a/nCompiler/R/compile_processAD.R b/nCompiler/R/compile_processAD.R index 73265c4d..dbc78753 100644 --- a/nCompiler/R/compile_processAD.R +++ b/nCompiler/R/compile_processAD.R @@ -52,9 +52,10 @@ compile_processAD <- function(code, return(invisible(NULL)) } - opInfo <- operatorDefEnv[[code$name]] - if(!is.null(opInfo)) { - handlingInfo <- opInfo[["processAD"]] + handlingInfo <- getOperatorDef(code$name, "processAD") + # opInfo <- operatorDefEnv[[code$name]] + # if(!is.null(opInfo)) { + # handlingInfo <- opInfo[["processAD"]] if(!is.null(handlingInfo)) { beforeHandler <- handlingInfo[['beforeHandler']] if(!is.null(beforeHandler)) { @@ -67,7 +68,7 @@ compile_processAD <- function(code, envir = processADEnv) } } - } + # } iArgs <- seq_along(code$args) for(i in iArgs) { @@ -77,8 +78,8 @@ compile_processAD <- function(code, } ## finally, call any special handlers - if(!is.null(opInfo)) { - handlingInfo <- opInfo[["processAD"]] + # if(!is.null(opInfo)) { + # handlingInfo <- opInfo[["processAD"]] if(!is.null(handlingInfo)) { handler <- handlingInfo[['handler']] if(!is.null(handler)) { @@ -91,7 +92,7 @@ compile_processAD <- function(code, envir = processADEnv) } } - } + # } } invisible(NULL) } diff --git a/nCompiler/R/compile_simpleTransformations.R b/nCompiler/R/compile_simpleTransformations.R index 5191a71b..67178014 100644 --- a/nCompiler/R/compile_simpleTransformations.R +++ b/nCompiler/R/compile_simpleTransformations.R @@ -24,9 +24,10 @@ compile_simpleTransformations <- function(code, } } - opInfo <- getOperatorDef(code$name) #operatorDefEnv[[code$name]] - if(!is.null(opInfo)) { - handlingInfo <- opInfo[[opInfoName]] + handlingInfo <- getOperatorDef(code$name, opInfoName) + # opInfo <- getOperatorDef(code$name) #operatorDefEnv[[code$name]] + # if(!is.null(opInfo)) { + # handlingInfo <- opInfo[[opInfoName]] if(!is.null(handlingInfo)) { handler <- handlingInfo[['handler']] if(!is.null(handler)) @@ -37,7 +38,7 @@ compile_simpleTransformations <- function(code, envir = handlerEnv) } } - } + # } } nErrorEnv$stateInfo <- character() invisible(NULL) diff --git a/nCompiler/R/cppDefs_core.R b/nCompiler/R/cppDefs_core.R index eed8d062..dd703c31 100644 --- a/nCompiler/R/cppDefs_core.R +++ b/nCompiler/R/cppDefs_core.R @@ -21,8 +21,8 @@ cppDefinitionClass <- R6::R6Class( CPPpreamble = character(), Hpreamble = character(), CPPusings = character(), - internalCppDefs = list(), - externalCppDefs = list(), + internalCppDefs = list(), # cppDefs unique to this definition, whose pieces are included in this definition's RcppPacket. + externalCppDefs = list(), # cppDefs that may be shared by others, which are checked (and made unique) during nCompile when RcppPackets are generated, and become their own RcppPacket. Hincludes = list(), CPPincludes = list(), compileInfo = list(), # This can be used generically for details about each derived class that are deemed too picayune for a separate member variable @@ -70,6 +70,23 @@ cppDefinitionClass <- R6::R6Class( get_post_cpp_compiler = function() NULL) ) +# cppDefRcppPacket exists for holding an RcppPacket that already exists, +# which happens through a predefined. +# The cppDefRcppPacket acts like a proxy so that it can be part of any list +# of cppDefs during nCompile but then is used only to extract its existing packet. +cppRcppPacket <- R6::R6Class( + 'cppRcppPacket', + portable = FALSE, + inherit = cppDefinitionClass, # This may be used at least for externalCppDefs + public = list( + RcppPacket = list(), + initialize = function(...) { + super$initialize(...) + }, + generate = function() {stop("generate() method does not work for an cppDefRcppPacket. Something is wrong.")} + ) +) + # cppManualClass is the most rudimentary cppDef that can generate content. # It extends cppDefinitionClass with character vectors of hContent and cppContent # and has a generate method. @@ -366,7 +383,7 @@ addGenericInterface_impl <- function(self) { fieldClassNames <- c(fieldClassNames, rep(NCint$cpp_classname, length(new_cpp_fieldNames))) # - current_NCgen <- current_NCgen$parent_env$.inherit_obj + current_NCgen <- current_NCgen$parent_env$.inherit_obj # same as current_NCgen$get_inherit() if there is inheritance, but get_inherit returns the base class at the top done <- is.null(current_NCgen) } if(iOut > 1) { diff --git a/nCompiler/R/cppDefs_nClass.R b/nCompiler/R/cppDefs_nClass.R index c8eccfa0..e1025c36 100644 --- a/nCompiler/R/cppDefs_nClass.R +++ b/nCompiler/R/cppDefs_nClass.R @@ -269,6 +269,22 @@ cpp_nClassClass <- R6::R6Class( addADclassContent = function() { addADclassContent_impl(self) }, + buildGenericInterface = function(interfaceCalls = TRUE, interface = TRUE) { + #interfaceCalls controls whether to include get_values, set_value, call_method + #self$compileInfo$interface controls whether to inherit from base classes for interfacing + #It would be wierd to do the former without the latter, + # so unless/until we get a case where that behavior is needed + # we will prevent it. + # The option interface=FALSE will be called in the case of a predefined, + # when building the predefined, when first we do buildAll(interfaceCalls=FALSE). + # This might build the interface but will not build the calls. + # By then calling buildGenericInterface(TRUE, FALSE), we get the interface + # calls but only if they are needed, but we don't repeat building the interface. + interface_needed <- !identical(self$compileInfo$interface, "none") + interfaceCalls <- interfaceCalls && interface_needed + addGenericInterface(interfaceCalls = interfaceCalls, + interface = interface_needed && interface) + }, buildAll = function(interfaceCalls = TRUE, where = where) { super$buildAll(where) buildDefaultConstructor() @@ -278,15 +294,7 @@ cpp_nClassClass <- R6::R6Class( addADclassContent() if(isTRUE(self$compileInfo$buildCopyFromNimbleFunction)) addCopyFromNimbleFunction(self) - #interfaceCalls controls whether to include get_values, set_value, call_method - #self$compileInfo$interface controls whether to inherit from base classes for interfacing - #It would be wierd to do the former without the latter, - # so unless/until we get a case where that behavior is needed - # we will prevent it. - interface_needed <- !identical(self$compileInfo$interface, "none") - interfaceCalls <- interfaceCalls && interface_needed - addGenericInterface(interfaceCalls = interfaceCalls, - interface = interface_needed) + buildGenericInterface(interfaceCalls = interfaceCalls) } ) ) diff --git a/nCompiler/R/local_DLL.R b/nCompiler/R/local_DLL.R index adac00ca..3c81b6e4 100644 --- a/nCompiler/R/local_DLL.R +++ b/nCompiler/R/local_DLL.R @@ -4,267 +4,267 @@ ## Write uninstallLocalDLL (skeleton below). ## Perhaps re-name some functions below for consistency. -#' Create (but don't install) files for nCompLocal package -#' -#' Write files and compile static library for nCompLocal package, whose purpose is to -#' hold a static library (DLL) that on-the-fly compilation can link to. -#' -#' @param dir Directory in which nCompLocal package files will be generated. -#' -#' @details This function is called internally from \cite{\link{buildLocalDLLpackage}}. -#' See there for explanation of the local DLL. -#' -#' @seealso \cite{\link{buildLocalDLLpackage}}, \cite{\link{installLocalDLLpackage}} -createLocalDLLpackage <- function(dir = '.', - force = TRUE) { - if(!require(pkgKitten, quietly = TRUE)) - stop("Package pkgKitten must be installed") - if(dir.exists(file.path(dir, "nCompLocal"))) { - message(paste0("When trying to create nCompLocal in directory ", dir,", a local directory named nCompLocal already exists.")) - userInput <- readline("Do you want to over-write it (Y or N): ") - if(toupper(userInput) == "Y") - unlink(file.path(dir, "nCompLocal"), recursive = TRUE) - } - showLocalDLLoutput <- isTRUE(get_nOption("showLocalDLLoutput")) - if(!showLocalDLLoutput) { - zz <- file("kitten_output_not_necessary.Rout", open = "wt") - sink(zz) - sink(zz, type = "message") - } - eval( - substitute( - kitten("nCompLocal", - path = DIR, - author = "This little package was generated by nCompiler to build a static library on your machine to link to nComp-generated libraries.", - maintainer = "This package was generated by nCompiler.", - license = "See nCompiler", - email = "not@available.org"), - list(DIR = dir)), - envir = .GlobalEnv) - if(!showLocalDLLoutput) { - sink() - sink(type = "message") - close(zz) - if(file.exists("kitten_output_not_necessary.Rout")) - file.remove("kitten_output_not_necessary.Rout") - } - NAMESPACE_file <- file.path(dir, "nCompLocal", "NAMESPACE") - sink(NAMESPACE_file) # Wipe it clean so it doesn't try to export kitten stuff - sink() - DESCRIPTION_file <- file.path(dir, "nCompLocal", "DESCRIPTION") - DESCRIPTION <- read.dcf(DESCRIPTION_file) - DESCRIPTION[, "Version"] <- "0.1" - DESCRIPTION[, "Title"] <- "Provides a library for static linking to on-the-fly nCompiler C++." - DESCRIPTION[, "Description"] <- "nCompiler generates C++ from R and compiles it. For some purposes, it is useful to link against code that has been compiled on each user's system. Since nCompiler requires a C++ tool chain anyway, which should also be sufficient for installing a package from source, it is expected that each user's system can install this package. You might think that compiled code for linking could be included in the nCompiler package itself, but this is surprisingly difficult and operating-system-dependent." - write.dcf(DESCRIPTION, file = DESCRIPTION_file) - staticLibPath <- file.path(dir, "nCompLocal", "inst", "staticLib") - dir.create(staticLibPath, showWarnings = FALSE, recursive = TRUE) - file.copy(system.file(file.path('nCompLocal_files','loadedObjectEnv.cpp'), - package = 'nCompiler'), - staticLibPath) - currentWarn <- getOption("rcpp.warnNoExports") - options(rcpp.warnNoExports = FALSE) - Rcpp::sourceCpp(file = file.path(staticLibPath, "loadedObjectEnv.cpp"), - showOutput = FALSE) - options(rcpp.warnNoExports = currentWarn) - ## Navigate through Rcpp's cache directory structure: - cacheDir1 <- getOption("rcpp.cache.dir", tempdir()) ## where sourceCpp places files - cacheDir1Files <- list.files(cacheDir1, full.names = TRUE) - ## Determine the most recent directory name with "sourceCpp" in it. - sourceCppDir1 <- cacheDir1Files[ grepl("sourceCpp", cacheDir1Files)] - if (length(sourceCppDir1) > 1) { - cppDir1_mtime <- file.mtime(sourceCppDir1) - sourceCppDir1 <- sourceCppDir1[which.max(cppDir1_mtime)] - } - sourceCppDir1Files <- list.files(sourceCppDir1, full.names = TRUE) - ## Determine the most recent subdirectory with the name "sourcecpp" (lower-case c) in it - sourcecppDir2 <- sourceCppDir1Files[ grepl("sourcecpp", sourceCppDir1Files)] - if (length(sourcecppDir2) > 1) { - cppDir2_mtime <- file.mtime(sourcecppDir2) - sourcecppDir2 <- sourcecppDir2[which.max(cppDir2_mtime)] - } - ## Build static library from the .o files left by Rcpp. - ## This will need to be updated for windows - if(.Platform$OS.type == "windows") - message("Need to update the 'ar' call in createLocalDLLpackage for Windows.") - system2("ar", c("rcs", - file.path(staticLibPath, "libnCompLocal.a"), - file.path(sourcecppDir2, "loadedObjectEnv.o"))) -} +## #' Create (but don't install) files for nCompLocal package +## #' +## #' Write files and compile static library for nCompLocal package, whose purpose is to +## #' hold a static library (DLL) that on-the-fly compilation can link to. +## #' +## #' @param dir Directory in which nCompLocal package files will be generated. +## #' +## #' @details This function is called internally from \cite{\link{buildLocalDLLpackage}}. +## #' See there for explanation of the local DLL. +## #' +## #' @seealso \cite{\link{buildLocalDLLpackage}}, \cite{\link{installLocalDLLpackage}} +## createLocalDLLpackage <- function(dir = '.', +## force = TRUE) { +## if(!require(pkgKitten, quietly = TRUE)) +## stop("Package pkgKitten must be installed") +## if(dir.exists(file.path(dir, "nCompLocal"))) { +## message(paste0("When trying to create nCompLocal in directory ", dir,", a local directory named nCompLocal already exists.")) +## userInput <- readline("Do you want to over-write it (Y or N): ") +## if(toupper(userInput) == "Y") +## unlink(file.path(dir, "nCompLocal"), recursive = TRUE) +## } +## showLocalDLLoutput <- isTRUE(get_nOption("showLocalDLLoutput")) +## if(!showLocalDLLoutput) { +## zz <- file("kitten_output_not_necessary.Rout", open = "wt") +## sink(zz) +## sink(zz, type = "message") +## } +## eval( +## substitute( +## kitten("nCompLocal", +## path = DIR, +## author = "This little package was generated by nCompiler to build a static library on your machine to link to nComp-generated libraries.", +## maintainer = "This package was generated by nCompiler.", +## license = "See nCompiler", +## email = "not@available.org"), +## list(DIR = dir)), +## envir = .GlobalEnv) +## if(!showLocalDLLoutput) { +## sink() +## sink(type = "message") +## close(zz) +## if(file.exists("kitten_output_not_necessary.Rout")) +## file.remove("kitten_output_not_necessary.Rout") +## } +## NAMESPACE_file <- file.path(dir, "nCompLocal", "NAMESPACE") +## sink(NAMESPACE_file) # Wipe it clean so it doesn't try to export kitten stuff +## sink() +## DESCRIPTION_file <- file.path(dir, "nCompLocal", "DESCRIPTION") +## DESCRIPTION <- read.dcf(DESCRIPTION_file) +## DESCRIPTION[, "Version"] <- "0.1" +## DESCRIPTION[, "Title"] <- "Provides a library for static linking to on-the-fly nCompiler C++." +## DESCRIPTION[, "Description"] <- "nCompiler generates C++ from R and compiles it. For some purposes, it is useful to link against code that has been compiled on each user's system. Since nCompiler requires a C++ tool chain anyway, which should also be sufficient for installing a package from source, it is expected that each user's system can install this package. You might think that compiled code for linking could be included in the nCompiler package itself, but this is surprisingly difficult and operating-system-dependent." +## write.dcf(DESCRIPTION, file = DESCRIPTION_file) +## staticLibPath <- file.path(dir, "nCompLocal", "inst", "staticLib") +## dir.create(staticLibPath, showWarnings = FALSE, recursive = TRUE) +## file.copy(system.file(file.path('nCompLocal_files','loadedObjectEnv.cpp'), +## package = 'nCompiler'), +## staticLibPath) +## currentWarn <- getOption("rcpp.warnNoExports") +## options(rcpp.warnNoExports = FALSE) +## Rcpp::sourceCpp(file = file.path(staticLibPath, "loadedObjectEnv.cpp"), +## showOutput = FALSE) +## options(rcpp.warnNoExports = currentWarn) +## ## Navigate through Rcpp's cache directory structure: +## cacheDir1 <- getOption("rcpp.cache.dir", tempdir()) ## where sourceCpp places files +## cacheDir1Files <- list.files(cacheDir1, full.names = TRUE) +## ## Determine the most recent directory name with "sourceCpp" in it. +## sourceCppDir1 <- cacheDir1Files[ grepl("sourceCpp", cacheDir1Files)] +## if (length(sourceCppDir1) > 1) { +## cppDir1_mtime <- file.mtime(sourceCppDir1) +## sourceCppDir1 <- sourceCppDir1[which.max(cppDir1_mtime)] +## } +## sourceCppDir1Files <- list.files(sourceCppDir1, full.names = TRUE) +## ## Determine the most recent subdirectory with the name "sourcecpp" (lower-case c) in it +## sourcecppDir2 <- sourceCppDir1Files[ grepl("sourcecpp", sourceCppDir1Files)] +## if (length(sourcecppDir2) > 1) { +## cppDir2_mtime <- file.mtime(sourcecppDir2) +## sourcecppDir2 <- sourcecppDir2[which.max(cppDir2_mtime)] +## } +## ## Build static library from the .o files left by Rcpp. +## ## This will need to be updated for windows +## if(.Platform$OS.type == "windows") +## message("Need to update the 'ar' call in createLocalDLLpackage for Windows.") +## system2("ar", c("rcs", +## file.path(staticLibPath, "libnCompLocal.a"), +## file.path(sourcecppDir2, "loadedObjectEnv.o"))) +## } -cleanupLocalDLLpackage <- function(dir = '.') { - # Previously we removed the working directory of package creation. - # This causes problems via the non-standard effects of pkgKitten - # via tools it uses like pkgload. A simple solution is to not remove the package source. - # In normal working operation, this will be done in tempdir() so it - # will be cleaned up when R exits. - # - # We leave this currently empty step in the workflow in case we come up - # with valid cleanup steps at some point. - # - # if(dir.exists(dir)) - # unlink(dir, recursive = TRUE) -} +## cleanupLocalDLLpackage <- function(dir = '.') { +## # Previously we removed the working directory of package creation. +## # This causes problems via the non-standard effects of pkgKitten +## # via tools it uses like pkgload. A simple solution is to not remove the package source. +## # In normal working operation, this will be done in tempdir() so it +## # will be cleaned up when R exits. +## # +## # We leave this currently empty step in the workflow in case we come up +## # with valid cleanup steps at some point. +## # +## # if(dir.exists(dir)) +## # unlink(dir, recursive = TRUE) +## } -#' Install nCompLocal package -#' -#' Install the nCompLocal package, whose purpose is to hold a static library for linking from on-the-fly compilations. -#' -#' @param lib location to install package. This defaults to the first element of `.libPaths()`. `lib` matches behavior, -#' and is passed to, the \code{lib} argument of \link{install.packages}. -#' @param source.dir directory where nCompLocal source is located. -#' -#' @details This function is called internally from \cite{\link{buildLocalDLLpackage}}. -#' See there for explanation of the local DLL. -#' -#' @seealso \cite{\link{buildLocalDLLpackage}}, \cite{\link{createLocalDLLpackage}} -installLocalDLLpackage <- function(lib, source.dir = '.') { - if(missing(lib)) lib <- .libPaths()[1] - pkgs <- file.path(source.dir, "nCompLocal") - utils::install.packages(pkgs, # Rstudio / devtools takes over install.packages. use core R version. - lib = lib, - repos = NULL, - type = "source", - quiet = !isTRUE(get_nOption("showLocalDLLoutput"))) -} +## #' Install nCompLocal package +## #' +## #' Install the nCompLocal package, whose purpose is to hold a static library for linking from on-the-fly compilations. +## #' +## #' @param lib location to install package. This defaults to the first element of `.libPaths()`. `lib` matches behavior, +## #' and is passed to, the \code{lib} argument of \link{install.packages}. +## #' @param source.dir directory where nCompLocal source is located. +## #' +## #' @details This function is called internally from \cite{\link{buildLocalDLLpackage}}. +## #' See there for explanation of the local DLL. +## #' +## #' @seealso \cite{\link{buildLocalDLLpackage}}, \cite{\link{createLocalDLLpackage}} +## installLocalDLLpackage <- function(lib, source.dir = '.') { +## if(missing(lib)) lib <- .libPaths()[1] +## pkgs <- file.path(source.dir, "nCompLocal") +## utils::install.packages(pkgs, # Rstudio / devtools takes over install.packages. use core R version. +## lib = lib, +## repos = NULL, +## type = "source", +## quiet = !isTRUE(get_nOption("showLocalDLLoutput"))) +## } -#' Create and install nCompLocal package -#' -#' Create and install nCompLocal package, which contains a static dynamic library (DLL) -#' on each user's machine for nCompiler-generated C++ to link to. -#' -#' @param dir directory where nCompLocal package will be created and possibly installed. The default value -#' can be controlled by setting the.nOption for \code{localDLLdir} (see \link{set_nOption}). -#' In turn, this option be default is NULL, in which case R's session-specific temporary directory (\code{tempdir()}) -#' will be used. If \code{installInR} is \code{FALSE}, then \code{dir} will also be the location of of the installed -#' package. In such a case, the nCompLocal package will be re-created once in every R session that compiled with nCompiler. -#' @param create.dir \code{TRUE} if \code{dir} needs to be created (in which case there will be an error if \code{dir} already exists). -#' @param installInR \code{TRUE} if nCompLocal should be installed as a regular package in R. Generally, this is a -#' good idea, as it means that nCompLocal only needs to be created and installed once per installation. Otherwise -#' these steps may happen once per session, which will be the case if \code{dir} is \code{NULL}. It is also possible -#' to install nCompLocal to a directory provided by \code{get_nOption("localDLLdir")} and leave it there. In that -#' case, nCompiler will automatially find it there in future R sessions. -#' -#' @details See \link{setup_nCompLocal} for the simplest way to install nCompLocal, which is as a standard R -#' package in the standard location. \code{buildLocalDLLpackage} provides more control over where it will be -#' installed and where package source files will be written. -#' -#' @seealso \link{setup_nCompLocal} -#' -#' @export -buildLocalDLLpackage <- function(dir = file.path(tempdir(), get_nOption("localDLLdir")), - create.dir = TRUE, - installInR = FALSE, - cleanup = TRUE) { - if(is.null(dir)) { - dir <- tempdir() - create.dir <- FALSE - } - if(create.dir) { - if(dir.exists(dir)) - stop(paste0("While trying to install nCompLocal, directory ", - dir, - " already exists. remove it and try again.")) - dir.create(dir, showWarnings = FALSE) - } - createLocalDLLpackage(dir = dir) - if(!installInR) { - lib.loc <- file.path(dir, "nCompLocalLibrary") - if(dir.exists(lib.loc)) { - message(paste0("While trying to install nCompLocal, the directory nCompLocalLibrary already exists in ", dir)) - userInput <- readline("Over-write nCompLocalLibrary (Y or N): ") - if(toupper(userInput) == "Y") - unlink("nCompLocalLibrary", recursive = TRUE) - } - dir.create(lib.loc, showWarnings = FALSE, recursive = TRUE) - } else - lib.loc <- .libPaths()[1] - installLocalDLLpackage(lib = lib.loc, source.dir = dir) - if(installInR & cleanup) - cleanupLocalDLLpackage(dir = dir) -} +## #' Create and install nCompLocal package +## #' +## #' Create and install nCompLocal package, which contains a static dynamic library (DLL) +## #' on each user's machine for nCompiler-generated C++ to link to. +## #' +## #' @param dir directory where nCompLocal package will be created and possibly installed. The default value +## #' can be controlled by setting the.nOption for \code{localDLLdir} (see \link{set_nOption}). +## #' In turn, this option be default is NULL, in which case R's session-specific temporary directory (\code{tempdir()}) +## #' will be used. If \code{installInR} is \code{FALSE}, then \code{dir} will also be the location of of the installed +## #' package. In such a case, the nCompLocal package will be re-created once in every R session that compiled with nCompiler. +## #' @param create.dir \code{TRUE} if \code{dir} needs to be created (in which case there will be an error if \code{dir} already exists). +## #' @param installInR \code{TRUE} if nCompLocal should be installed as a regular package in R. Generally, this is a +## #' good idea, as it means that nCompLocal only needs to be created and installed once per installation. Otherwise +## #' these steps may happen once per session, which will be the case if \code{dir} is \code{NULL}. It is also possible +## #' to install nCompLocal to a directory provided by \code{get_nOption("localDLLdir")} and leave it there. In that +## #' case, nCompiler will automatially find it there in future R sessions. +## #' +## #' @details See \link{setup_nCompLocal} for the simplest way to install nCompLocal, which is as a standard R +## #' package in the standard location. \code{buildLocalDLLpackage} provides more control over where it will be +## #' installed and where package source files will be written. +## #' +## #' @seealso \link{setup_nCompLocal} +## #' +## #' @export +## buildLocalDLLpackage <- function(dir = file.path(tempdir(), get_nOption("localDLLdir")), +## create.dir = TRUE, +## installInR = FALSE, +## cleanup = TRUE) { +## if(is.null(dir)) { +## dir <- tempdir() +## create.dir <- FALSE +## } +## if(create.dir) { +## if(dir.exists(dir)) +## stop(paste0("While trying to install nCompLocal, directory ", +## dir, +## " already exists. remove it and try again.")) +## dir.create(dir, showWarnings = FALSE) +## } +## createLocalDLLpackage(dir = dir) +## if(!installInR) { +## lib.loc <- file.path(dir, "nCompLocalLibrary") +## if(dir.exists(lib.loc)) { +## message(paste0("While trying to install nCompLocal, the directory nCompLocalLibrary already exists in ", dir)) +## userInput <- readline("Over-write nCompLocalLibrary (Y or N): ") +## if(toupper(userInput) == "Y") +## unlink("nCompLocalLibrary", recursive = TRUE) +## } +## dir.create(lib.loc, showWarnings = FALSE, recursive = TRUE) +## } else +## lib.loc <- .libPaths()[1] +## installLocalDLLpackage(lib = lib.loc, source.dir = dir) +## if(installInR & cleanup) +## cleanupLocalDLLpackage(dir = dir) +## } -#' Create and install nCompLocal package as a regular R package. -#' -#' Create and install nCompLocal package, which contains a static dynamic library (DLL) -#' on each user's machine for nCompiler-generated C++ to link to. -#' -#' @details nCompiler is faster and simpler if it can link on-the-fly C++ compilation to a static library -#' on each user's machine. That static library is nCompLocal. It is a somewhat unusual R package. It -#' does not contain any R source code. It does not contain the type of compiled shared library that packages -#' with C or C++ source code typically do. Instead it contains a \code{staticLib} directory with a static -#' library. -#' -#' A typical R package would not assume that a user's system has the compiler tools to build a package -#' including C++ source code from source. Since nCompiler requires compiler tools anyway, it is reasonable -#' to assume that dynamically building a package from source will work. -#' -#' This function will install nCompLocal as a regular R package in the default location for packages. -#' For more control over where the package is installed, and where package source files are written, -#' see \link{buildLocalDLLpackage} -#' -#' @seealso \link{buildLocalDLLpackage} -#' -#' @export -setup_nCompLocal <- function() { - # This function builds and installs a package in R's standard location - buildLocalDLLpackage( - dir = file.path(tempdir(), "setup_nCompLocal_files"), - installInR = TRUE) -} +## #' Create and install nCompLocal package as a regular R package. +## #' +## #' Create and install nCompLocal package, which contains a static dynamic library (DLL) +## #' on each user's machine for nCompiler-generated C++ to link to. +## #' +## #' @details nCompiler is faster and simpler if it can link on-the-fly C++ compilation to a static library +## #' on each user's machine. That static library is nCompLocal. It is a somewhat unusual R package. It +## #' does not contain any R source code. It does not contain the type of compiled shared library that packages +## #' with C or C++ source code typically do. Instead it contains a \code{staticLib} directory with a static +## #' library. +## #' +## #' A typical R package would not assume that a user's system has the compiler tools to build a package +## #' including C++ source code from source. Since nCompiler requires compiler tools anyway, it is reasonable +## #' to assume that dynamically building a package from source will work. +## #' +## #' This function will install nCompLocal as a regular R package in the default location for packages. +## #' For more control over where the package is installed, and where package source files are written, +## #' see \link{buildLocalDLLpackage} +## #' +## #' @seealso \link{buildLocalDLLpackage} +## #' +## #' @export +## setup_nCompLocal <- function() { +## # This function builds and installs a package in R's standard location +## buildLocalDLLpackage( +## dir = file.path(tempdir(), "setup_nCompLocal_files"), +## installInR = TRUE) +## } -#' Find and load, or possibly create, nCompLocal package. -#' -#' nCompLocal is a package created and installed on each user's machine, sometimes or each R -#' session. It contains a static library for nCompiler to link to. -#' -#' @param lib optional location where nCompLocal is installed -#' @param buildIfMissing if \code{TRUE}, this function attempt to create nCompLocal if it can't be found. -#' -#' @details This function is called internally every time nCompiler is ready to call the C++ compiler for -#' generated code. -#' -#' @seealso \link{setup_nCompLocal} for how to create and install nCompLocal once for an -#' R installation, so that nCompLocal can be re-used than than re-created in every R session. -requireLocalDLLpackage <- function(lib, buildIfMissing = TRUE) { - ## Check in order: provided lib, regular .libPaths(),nOptions(localDLLdir) - if(isTRUE(get_nOption("localDLL_isLoaded"))) - return(TRUE) - found <- FALSE - if(!missing(lib)) - found <- require("nCompLocal", lib.loc = file.path(lib, "nCompLocalLibrary"), quietly = TRUE) - if(!found) - found <- require("nCompLocal", quietly = TRUE) - if(!found) { - localDLLdir <- file.path(tempdir(), get_nOption("localDLLdir")) - if(!is.null(localDLLdir)) { - if(dir.exists(localDLLdir)) - found <- require("nCompLocal", lib.loc = file.path(localDLLdir, "nCompLocalLibrary"), quietly = TRUE) - } - } - if(found) { - set_nOption("localDLL_isLoaded", TRUE) - return(TRUE) - } - if(buildIfMissing) { - ok <- try({ - message(paste0("Creating nCompLocal package from nCompiler. ", - "This happens once per session if necessary, or ", - "once-per-installation if you run \"setup_nCompLocal()\". ", - " See help(\"setup_nCompLocal\") for more information. ", - "(There may be a spurious warning message, after this ", - "message, saying there is no nCompLocal package.) ")) - buildLocalDLLpackage() - found <- require("nCompLocal", lib.loc = file.path(localDLLdir, "nCompLocalLibrary"), quietly = TRUE) - }) - if(inherits(ok, "try-error") | !found) - stop("There was a problem building the localDLL package.") - TRUE - } else { - FALSE - } -} +## #' Find and load, or possibly create, nCompLocal package. +## #' +## #' nCompLocal is a package created and installed on each user's machine, sometimes or each R +## #' session. It contains a static library for nCompiler to link to. +## #' +## #' @param lib optional location where nCompLocal is installed +## #' @param buildIfMissing if \code{TRUE}, this function attempt to create nCompLocal if it can't be found. +## #' +## #' @details This function is called internally every time nCompiler is ready to call the C++ compiler for +## #' generated code. +## #' +## #' @seealso \link{setup_nCompLocal} for how to create and install nCompLocal once for an +## #' R installation, so that nCompLocal can be re-used than than re-created in every R session. +## requireLocalDLLpackage <- function(lib, buildIfMissing = TRUE) { +## ## Check in order: provided lib, regular .libPaths(),nOptions(localDLLdir) +## if(isTRUE(get_nOption("localDLL_isLoaded"))) +## return(TRUE) +## found <- FALSE +## if(!missing(lib)) +## found <- require("nCompLocal", lib.loc = file.path(lib, "nCompLocalLibrary"), quietly = TRUE) +## if(!found) +## found <- require("nCompLocal", quietly = TRUE) +## if(!found) { +## localDLLdir <- file.path(tempdir(), get_nOption("localDLLdir")) +## if(!is.null(localDLLdir)) { +## if(dir.exists(localDLLdir)) +## found <- require("nCompLocal", lib.loc = file.path(localDLLdir, "nCompLocalLibrary"), quietly = TRUE) +## } +## } +## if(found) { +## set_nOption("localDLL_isLoaded", TRUE) +## return(TRUE) +## } +## if(buildIfMissing) { +## ok <- try({ +## message(paste0("Creating nCompLocal package from nCompiler. ", +## "This happens once per session if necessary, or ", +## "once-per-installation if you run \"setup_nCompLocal()\". ", +## " See help(\"setup_nCompLocal\") for more information. ", +## "(There may be a spurious warning message, after this ", +## "message, saying there is no nCompLocal package.) ")) +## buildLocalDLLpackage() +## found <- require("nCompLocal", lib.loc = file.path(localDLLdir, "nCompLocalLibrary"), quietly = TRUE) +## }) +## if(inherits(ok, "try-error") | !found) +## stop("There was a problem building the localDLL package.") +## TRUE +## } else { +## FALSE +## } +## } # This function is used by the nCompiler_Eigen_plugin for Rcpp. # This plugin is invoked by "// [[Rcpp::plugins(nCompiler_Eigen_plugin)]]" C++ source code that is compiled via Rcpp::sourceCpp. diff --git a/nCompiler/R/nCompile.R b/nCompiler/R/nCompile.R index fbd003f7..9463dcef 100644 --- a/nCompiler/R/nCompile.R +++ b/nCompiler/R/nCompile.R @@ -17,7 +17,7 @@ cppFileLabelFunction <- labelFunctionCreator('nCompiler_units') # compileCpp_nCompiler calls sourceCpp_nCompiler, which calls Rcpp::sourceCpp # compileCpp_nCompiler arranges the results into a named list of the [[Rcpp::export]] functions # This will include the SEXPgenerator C++ functtion named paste0("new_", name) -# +# # nFunction # Each unit that is an nFunction is passed to nCompile_nFunction to create C++ code # The nFunction already has an NFinternals with a name, uniqueName, and cpp_code_name @@ -194,7 +194,7 @@ get_nCompile_types <- function(units) { ans[i] <- if(NFinternals(units[[i]])$compileInfo$callFromR) 'nF' else 'nF_noExport' } else if(isNCgenerator(units[[i]])) ans[i] <- 'nCgen' - else if(isNC(units[[i]])) + else if(isNC(units[[i]])) stop(paste0("The #", i, " object to be compiled is an nClass object.\n", "Only nClass generators (the class definition, not an object of the class) should be compiled."), call.=FALSE) @@ -453,6 +453,7 @@ nCompile <- function(..., } } +#' @export writePackage <- function(..., pkgName, dir = ".", @@ -864,14 +865,14 @@ WP_initializePkg <- function(pkgName, WP_writeCpp <- function(RcppPacket_list, srcDir, codeDir) { for (i in seq_along(RcppPacket_list)) { ## We write the code once for the package's DLL... - nCompiler:::writeCpp_nCompiler(RcppPacket_list[[i]], + writeCpp_nCompiler(RcppPacket_list[[i]], dir = srcDir) ## ... and again for other packages that need to ## compile against this package's source code. ## Otherwise, C++ source code is not present in an installed package. ## Compiling against source code is necessary because of ## heavy use of C++ templates. - nCompiler:::writeCpp_nCompiler(RcppPacket_list[[i]], + writeCpp_nCompiler(RcppPacket_list[[i]], dir = codeDir) } } diff --git a/nCompiler/R/options.R b/nCompiler/R/options.R index 712cd910..46e7a38a 100644 --- a/nCompiler/R/options.R +++ b/nCompiler/R/options.R @@ -1,4 +1,4 @@ -nCompilerUserNamespace <- as.environment(list(sessionSpecificDll = NULL)) +nCompilerUserNamespace <- as.environment(list(sessionSpecificDll = NULL)) # new.env() here fails with: Error in as.environment(pos) : using 'as.environment(NULL)' is defunct when testing package loading during INSTALL updateDefaults <- function(defaults, control) { @@ -39,13 +39,15 @@ updateDefaults <- function(defaults, control) { export = TRUE ), modifyPackageFiles = "no", - localDLL_isLoaded = FALSE, # if TRUE, the localDLL has been loaded. This will be set TRUE after first compilation. - localDLLdir = "nCompLocalLibrary", # directory to be used from the working directory if localDLL needs to be locally built. - showLocalDLLoutput = FALSE, + # localDLL_isLoaded = FALSE, # if TRUE, the localDLL has been loaded. This will be set TRUE after first compilation. + # localDLLdir = "nCompLocalLibrary", # directory to be used from the working directory if localDLL needs to be locally built. + # showLocalDLLoutput = FALSE, error_recover = FALSE, # if TRUE, attempt to recover into a browser() after errors caught by nComp's error trapping, similarly to options(error = recover) - pause_after_writing_files = FALSE, #if TRUE, enter browser() after generated code files have been written but before the C++ compiler has been called. + pause_after_writing_files = FALSE, #if TRUE, enter browser() after generated code files have been written but before the C++ compiler has been called. verbose = FALSE, - sourceCpp_verbose = FALSE + sourceCpp_verbose = FALSE, + nimble = FALSE, ## ensure all backward compatibility + dropSingleSizes = FALSE ## backward compatibility ) ) @@ -53,8 +55,8 @@ updateDefaults <- function(defaults, control) { #' #' Allow the user to set the value of a global _option_ #' that affects the way in which nCompiler operates -#' -#' @param x a character string holding an option name +#' +#' @param x a character string holding an option name #' @param value the new value of the option #' @param listName an optional character string with the name of a list in which to find \code{x} #' @export @@ -75,8 +77,8 @@ set_nOption <- function(x, value, listName = NULL) { #' #' Allow the user to get the value of a global _option_ #' that affects the way in which nCompiler operates -#' -#' @param x a character string holding an option name +#' +#' @param x a character string holding an option name #' @export #' @return The value of the option. get_nOption <- function(x) { @@ -114,5 +116,3 @@ nOptions <- function(...) { if(length(out) == 1) out <- out[[1]] if(invisibleReturn) return(invisible(out)) else return(out) } - - diff --git a/nCompiler/R/packaging.R b/nCompiler/R/packaging.R index dad9ae01..883660a5 100644 --- a/nCompiler/R/packaging.R +++ b/nCompiler/R/packaging.R @@ -15,7 +15,7 @@ #' elements are overwritten, while elements without name conflicts are #' retained. To change the default across multiple calls, use #' `set_nOption("modifyPackageContents" = TRUE)` -#' @param memberData A named list of elements to be stored as exported package +#' @param memberData A named list of elements to be stored as exported package #' data objects. #' @param roxygen A list of roxygen entries corresponding to the objects being #' compiled, indicated either by matching names or (if all objects are @@ -46,493 +46,11 @@ #' and added to the package. This process will overwrite existing compiled #' objects with overlapping names, so can be used to edit and update package #' elements as well as add new elements. -#' +#' #' If an uncompilable nFunction or nClass is passed, \code{writePackage} will #' not error. This will not be caught until the package is built, for example #' with \code{buildPackage}. #' -#' @examples -#' # Initialize an example nFunction -#' foo <- nFunction(name = "foo", -#' fun = function(x = numericScalar()) { -#' ans <- x+1 -#' return(ans) -#' returnType(numericScalar()) -#' } -#' ) -#' # Write a package containing the compiled nFunction "foo" -#' writePackage(foo, -#' dir = tempdir(), -#' pkgName = "fooPackage", -#' control = list(export = TRUE)) -#' # Build and install the package -#' buildPackage("fooPackage", dir = tempdir()) -#' # We can call "foo" from the new namespace -#' fooPackage::foo(10) -#' @seealso For more nCompiler packaging tools, see \code{\link{buildPackage}} -#' and \code{\link{erasePackage}}. For nCompiler roxygen utilities see -#' \code{\link{documentNClass}} and \code{\link{documentNFunction}}. For -#' package initialization tools on which \code{writePackage} depends see -#' \code{\link[Rcpp]{Rcpp.package.skeleton}} and -#' \code{\link[utils]{package.skeleton}}. - - -## writePackage <- function(..., -## pkgName, -## dir = ".", -## control = list(), -## modify = get_nOption("modifyPackageFiles"), -## memberData = list(), -## roxygen = list(), -## nClass_full_interface = TRUE) { - -## modify <- match.arg(modify, c("no", "add", "clear")) -## ## any_modify <- modify %in% c("add", "clear") -## ## if (any_modify && !dir.exists(file.path(dir, pkgName))) { -## ## warning(paste0("No package named '", pkgName, -## ## "' exists in directory '", dir, -## ## "' so one will be created.")) -## ## } - -## require(Rcpp) -## if(grepl("_", pkgName)) -## stop("Package names are not allowed to have underscore characters.") -## objs <- list(...) - -## # Handle the case where the user passes a list rather than using ... -## if (length(objs)==1) { -## if (is.list(objs[[1]])) { -## objs <- objs[[1]] -## } -## } - -## # Handle roxygen input -## if (!is.list(roxygen)) { -## if (is.character(roxygen)) roxygen <- list(roxygen) -## else stop("in writePackage: unknown roxygen type") -## } - -## if (length(roxygen) == 0) { -## roxygenFlag <- "none" -## } else if (sum(nchar(names(roxygen)) > 0) == length(roxygen)) { # Are all rox entries named? -## roxygenFlag <- "names" -## } else if (length(roxygen) == length(objs)) { # Are there as many rox entries as objs? -## roxygenFlag <- "indices" -## } else { # If neither, we don't know what to do about it -## 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.") -## } - -## # Check if control is specified properly. -## # The user has the following options: -## # 1) Provide nothing. Defaults are used for all NF/NC objects. -## # 2) Provide a single unnamed list. This control list will be shared by every object. -## # 3a) Provide 1 or more named lists. These lists are used for the objects whose -## # names they match, while all others get defaults. -## # 3b) Provided 2 or more named lists, one of which is called "default." -## # "default" is used to control all elements. - -## if (!is.list(control)) -## stop("In writePackage, argument 'control' must be a list with controls for all -## or else a list of named lists with controls for each object") -## if (length(control) > 0 && !is.list(control[[1]])) control <- list(control) - -## # shareControl is a boolean flag indicating if all objects will take the same -## # control variable. If so, it'll be stored in the object globalControl for now -## sharedControl <- FALSE -## globalControl <- defaultControl <- get_nOption("packagingOptions") -## if (length(control) == 0) { # We're in option 1. -## sharedControl <- TRUE -## } else if (sum(nchar(names(control)) > 0) < length(control)) { # If any elements are unnamed... -## if (length(control) == 1) { # We're in option 2 -## sharedControl <- TRUE -## globalControl <- updateDefaults(defaultControl, control[[1]]) -## } else { # If no names were provided but control was length >1, that's a problem -## stop(paste("More than one control list detected, but not all were named.", -## "Control lists can only be unnamed if exactly one is provided.")) -## } -## } - -## # Build a fully fleshed out control list. The ith element of totalControl is a -## # controls compilation options for the ith element of objs. -## totalControl <- list() - -## # I retrieve the names of each object. Is there a better way to do this? -## objNames <- unlist(lapply(objs, function(x) { -## if (isNF(x)) return(NFinternals(x)$uniqueName) -## else if (isNCgenerator(x)) return(x$classname) -## else stop(paste("In writePackage: only nFunctions and nClass generators are", -## "allowed. Cannot compile object of class ", class(x)))})) -## if (length(unique(objNames)) < length(objNames)) stop(paste( -## "in writePackage: Duplicate internal object names detected." -## )) - -## # If options 1 or 2 were hit, we can just use the globalControl option set we -## # already built for every element. If neither, we still do this to set up the -## # architecture and think of user specifications as modifying this default -## # structure -## if (sharedControl) { -## for (i in 1:length(objs)) totalControl[[i]] <- globalControl -## } else { # Option 3 - -## if ("default" %in% names(control)) { -## globalControl <- updateDefaults(defaultControl, controls[["default"]]) -## } -## # If no defaults were specified, globalControl is still all defaults -## # for (i in 1:length(objs)) totalControl[[i]] <- globalControl - -## if (length(unique(objNames)) < length(objNames)) { -## stop("In writePackage: multiple objects with the same name were provided.") -## } - -## # Iterate over each specified control list and add it. Throw an error (maybe -## # a warning, but this seems like a big enough problem) if the user provided -## # an unrecognized name. -## for (i in 1:length(control)) { -## if (names(control)[[i]] %in% objNames) { -## totalControl[[which(objNames == names(control)[[i]])]] <- -## updateDefaults(globalControl, control[[i]]) -## } else { -## if (!identical(names(control)[[i]], "default")) { -## stop(paste0('In writePackage: Control specified for object named "', -## names(control)[[i]], -## '"\n\t but no object with that name was provided.')) -## } -## } -## } -## } # Now we have a control object, totalControl, which contains all control -## # options for every element in objs. -## # Used to test if this works: return(totalControl) - -## # if(length(objs) > 1) -## # stop("writePackage only supports one object as a first step of development") - -## pkgDir <- file.path(dir, pkgName) -## Rdir <- file.path(pkgDir, "R") -## srcDir <- file.path(pkgDir, "src") -## instDir <- file.path(pkgDir, "inst") -## codeDir <- file.path(instDir, "include", "nCompGeneratedCode") -## datDir <- file.path(pkgDir, "data") - -## full_interface <- list(); RcppPackets <- list() -## for (i in 1:length(objs)) { -## if(isNF(objs[[i]])) { -## if (!identical(nCompiler:::Rname2CppName(objNames[[i]]), objNames[[i]])) { -## warning(paste0("The nFunction name ", objNames[[i]], " isn't valid for ", -## "C++.\n Using the modified name ", -## Rname2CppName(objNames[[i]]), " instead.")) -## } -## nCompile_nFunction(objs[[i]], -## control = list(endStage = "writeCpp", -## useUniqueNameInCode = TRUE)) -## RcppPackets[[i]] <- NFinternals(objs[[i]])$RcppPacket -## thisRox <- switch(roxygenFlag, -## none = NULL, -## indices = if(length(roxygen) < i) roxygen[[i]] else NULL, -## names = if (objNames[[i]] %in% names(roxygen)) -## roxygen[[ objNames[i] ]] -## else NULL) -## if (!is.null(thisRox)) { -## exportIndex <- which(RcppPackets[[i]]$cppContent == "// [[Rcpp::export]]") -## RcppPackets[[i]]$cppContent <- -## c(RcppPackets[[i]]$cppContent[1:(exportIndex - 1)], -## thisRox$header, -## RcppPackets[[i]]$cppContent[exportIndex:length(RcppPackets[[i]]$cppContent)]) -## } -## } else if (isNCgenerator(objs[[i]])) { -## writtenNC1 <- nCompile_nClass(objs[[i]], -## control = list(endStage = "writeCpp")) -## RcppPackets[[i]] <- NCinternals(objs[[i]])$RcppPacket -## if (isTRUE(nClass_full_interface)) { -## full_interface[[i]] <- build_compiled_nClass(objs[[i]], quoted = TRUE) -## } - -## # I thought maybe I could put methods doc in C++ as follows but I had issues -## # thisRox <- switch(roxygenFlag, -## # none = NULL, -## # indices = if(length(roxygen) < i) roxygen[[i]] else NULL, -## # names = if (objNames[[i]] %in% names(roxygen)) -## # roxygen[[ objNames[i] ]] -## # else NULL) -## # if (!is.null(thisRox)) { -## # # givenNames <- names(objs[[i]]$public_methods) -## # cppCodeNames <- lapply(objs[[i]]$public_methods, -## # function(x) if (isNF(x)) -## # NFinternals(x)$cpp_code_name) -## # for (m in 1:length(thisRox$methods)) { -## # thisFnDefIndex <- grep(paste0(cppCodeNames[names(thisRox$methods)[m]], " ("), -## # RcppPackets[[i]]$cppContent, fixed = TRUE) -## # -## # RcppPackets[[i]]$cppContent <- -## # c(RcppPackets[[i]]$cppContent[1:(thisFnDefIndex - 1)], -## # thisRox$methods[[m]], -## # RcppPackets[[i]]$cppContent[(thisFnDefIndex):length(RcppPackets[[i]]$cppContent)]) -## # } -## # } - -## } else { -## stop(paste("In writePackage: only nFunctions and nClass generators are", -## "allowed. Cannot compile object of class ", class(objs[[i]]))) -## } -## } - -## initializePkg <- FALSE -## if (dir.exists(pkgDir)) { -## if (modify == "no") stop(paste0("Package ", pkgName, " already exists in directory ", dir, -## ". Change 'modify' argument to add to or clear it.")) -## } else initializePkg <- TRUE -## ## The following eval(substitute(...), ...) construction is necessary because -## ## Rcpp.package.skeleton (and also pkgKitten::kitten) has a bug when used -## ## directly as needed here from inside a function. - -## if (initializePkg) { -## nCompiler_placeholder <<- function() NULL -## suppressMessages( -## eval( -## substitute( -## Rcpp.package.skeleton(PN, -## path = DIR, -## # list = "nCompiler_placeholder", -## author = "This package was generated by the nCompiler", -## force = FORCE), -## list(DIR = dir, -## PN = pkgName, -## FORCE = modify == "clear")), -## envir = .GlobalEnv) -## ) -## if(file.exists(file.path(pkgDir, "Read-and-delete-me"))) -## file.remove(file.path(pkgDir, "Read-and-delete-me")) -## dir.create(instDir) -## dir.create(datDir) -## dir.create(codeDir, recursive = TRUE) -## } - -## Rfilepath <- character(length(objs)) - -## # Loop over each object again -## for (i in 1:length(objs)) { - -## ## We write the code once for the package's DLL... -## nCompiler:::writeCpp_nCompiler(RcppPackets[[i]], -## dir = srcDir) -## ## ... and again for other packages that need to -## ## compile against this package's source code. -## ## Otherwise, C++ source code is not present in an installed package. -## ## Compiling against source code is necessary because of -## ## heavy use of C++ templates. -## nCompiler:::writeCpp_nCompiler(RcppPackets[[i]], -## dir = codeDir) -## if (isNCgenerator(objs[[i]]) && isTRUE(nClass_full_interface)) { -## ## Write the nClass full interface to the package's R directory -## generator_name <- objs[[i]]$classname -## Rfile <- paste0(generator_name, '.R') -## Rfilepath[i] <- file.path(Rdir, Rfile) -## con <- file(Rfilepath[i], open = 'w') -## deparsed_full_interface <- deparse(full_interface[[i]]) -## deparsed_full_interface[1] <- paste0( -## generator_name, ' <- ', deparsed_full_interface[1] -## ) -## exportTag <- if (totalControl[[i]]$export) "#' @export\n" else NULL -## # Retrieve roxygen entry -## thisRox <- switch(roxygenFlag, -## none = NULL, -## indices = if(length(roxygen) < i) roxygen[[i]] else NULL, -## names = if (objNames[[i]] %in% names(roxygen)) -## roxygen[[ objNames[i] ]] -## else NULL -## ) - -## if (!is.null(thisRox)) { -## # 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] <- -## gsub(pattern = names(thisRox$methods)[m], -## replacement = paste0( -## "\n", thisRox$methods[m], "\n", names(thisRox$methods)[m] -## ), -## x = deparsed_full_interface[thisDefn], -## fixed = TRUE) -## } -## } - -## deparsed_full_interface <- c( -## '## Generated by nCompiler::writePackage() -> do not edit by hand\n', -## if (is.list(thisRox)) thisRox[["header"]] else thisRox, -## exportTag, -## deparsed_full_interface, -## paste0(generator_name, '$parent_env <- new.env()'), -## paste0(generator_name, '$.newCobjFun <- NULL') -## ) -## writeLines(deparsed_full_interface, con) -## close(con) -## } -## } - -## # Write out data -## if (length(memberData) > 0) { -## datEnv <- as.environment(memberData) -## for (i in 1:length(ls(datEnv))) { -## save(list = ls(datEnv)[i], envir = datEnv, -## file = file.path(datDir, paste0(ls(datEnv)[i], ".RData"))) -## } -## } - -## # Write .onLoad -## nClass_names <- unlist(lapply(objs, function(x) -## if(isNCgenerator(x)) x$classname else NULL -## )) -## if(length(nClass_names)) { -## onLoad_lines <- c(".onLoad <- function(libName, pkgName) {\n", -## paste0(" nCompiler::setup_nClass_environments_from_package(c(", paste0("\"",nClass_names,"\"", collapse = ", "), "))\n"), -## "NULL}\n") -## writeLines(onLoad_lines, con = file.path(Rdir, "zzz.R")) -## } - -## DESCfile <- file.path(pkgDir, "DESCRIPTION") -## NAMEfile <- file.path(pkgDir, "NAMESPACE") -## if (initializePkg) { -## DESCRIPTION <- read.dcf(DESCfile) -## ## TO-DO: Make choice of what to include be smart about what is really needed. -## ## A nFunction might only need: -## ## DESCRIPTION[1, "LinkingTo"] <- paste(DESCRIPTION[1, "LinkingTo"], "RcppEigen", "RcppParallel", "nCompiler", sep = ",") -## ## A nClass might need: -## DESCRIPTION[1, "LinkingTo"] <- paste(DESCRIPTION[1, "LinkingTo"], "RcppEigen", "RcppEigenAD", "RcppParallel", "nCompiler", "Rcereal", sep = ",") -## # DESCRIPTION$Encoding <- "UTF-8" -## ## It is conceivable that nCompLocal will need to be added to this at some point. -## ## If so, it will need to be installed in R's main library, not some local location. -## # DESCRIPTION[1, "Collate"] <- paste(Rfilepath, collapse = ", ") -## write.dcf(DESCRIPTION, DESCfile) - -## NAMESPACE <- c(paste0("useDynLib(", pkgName, ", .registration=TRUE)"), -## "importFrom(Rcpp, evalCpp)", -## "export(nComp_serialize_)", -## "export(nComp_deserialize_)", -## "export(call_method)", -## "export(get_value)", -## "export(set_value)" -## ) -## } else { -## NAMESPACE <- readLines(NAMEfile) -## } - -## for (i in 1:length(objs)) { -## # if (totalControl[[i]]$export && isNCgenerator(objs[[i]])) -## if (totalControl[[i]]$export) { -## if (isNF(objs[[i]]) || nClass_full_interface) { -## NAMESPACE <- c(NAMESPACE, paste0("export(", objNames[i], ")")) -## } -## if (isNCgenerator(objs[[i]])) -## NAMESPACE <- c(NAMESPACE, paste0("export(new_", objNames[i], ")")) -## } -## } -## NAMESPACE <- unique(NAMESPACE) -## writeLines(NAMESPACE, con = NAMEfile) - -## if (!initializePkg) { -## compiledObjs <- list.files(srcDir, pattern = "o$") -## # message("Deleting ", compiledObjs) -## unlink(compiledObjs) -## } -## compileAttributes(pkgdir = pkgDir) - -## invisible(NULL) -## } - -#' @name buildPackage -#' @title Build and install packages written by writePackage -#' @export -#' @param pkgName Character string. The name of the package to be built, -#' corresponding to the argument of the same name in writePackages. -#' @param dir Character string. Path to the parent directory containing the main -#' package directory. By default, the current working directory is used. -#' @param lib Character string, optional. Path to the directory where the -#' package will be installed. See the lib.loc argument in -#' `install.packages()`. -#' @param load Logical, default TRUE. Should the package be attached once -#' installed? -#' -#' @details -#' -#' \code{buildPackage} is a function for adding compiled nFunctions and nClasses -#' to an R package. It handles the building and installation. Optionally -#' buildPackage calls \code{roxygen2::roxygenize} on the home directory of the -#' package. It may not be necessary to use buildPackage if another developer -#' tool is preferred for your package. -#' -#' \code{buildPackage} errors if package installation fails. If an uncompilable -#' nFunction or nClass was written to the package, this will cause -#' \code{buildPackage} to fail, printing the message that install.packages -#' finished with "non-zero exit status." -#' -#' @examples -#' # Initialize an example nFunction -#' foo <- nFunction(name = "foo", -#' fun = function(x = numericScalar()) { -#' ans <- x+1 -#' return(ans) -#' returnType(numericScalar()) -#' }) -#' # Write a package containing the compiled nFunction "foo" -#' writePackage(foo, -#' dir = tempdir(), -#' pkgName = "fooPackage", -#' control = list(export = TRUE)) -#' # Build and install the package -#' buildPackage("fooPackage", dir = tempdir()) -#' # We can call "foo" from the new namespace -#' fooPackage::foo(10) -#' @seealso For other nCompiler packaging tools, see \code{\link{writePackage}} -#' and \code{\link{erasePackage}}. For nCompiler roxygen utilities see -#' \code{\link{documentNClass}} and \code{\link{documentNFunction}}. For -#' roxygen2 tools on which \code{buildPackage} depends see -#' \code{\link[roxygen2]{roxygenize}}. -buildPackage <- function(pkgName, - dir = ".", - lib, - quiet = TRUE, - load = TRUE, - roxygenize = FALSE){ - if(!missing(lib)) { - if(!dir.exists(lib)) - dir.create(lib) - } - - if (roxygenize) roxygen2::roxygenize( - package.dir = file.path(dir, pkgName), - roclets = c("rd") - ) - - if(isTRUE(get_nOption("use_nCompLocal"))) - if(!nCompiler:::requireLocalDLLpackage()) - stop("There was a problem building nCompLocal.") - pkg_libs_entry <- nCompiler:::get_nCompLocal_PKG_LIBS_entry() - staticLibLoc <- system.file('staticLib', package = 'nCompLocal') - Sys.setenv("PKG_CXXFLAGS"="-std=c++11 -Wno-invalid-partial-specialization") - Sys.setenv("PKG_LIBS"=pkg_libs_entry) - ## possible missingness of lib propagates to install.packages - install.packages(file.path(dir, pkgName), - lib = lib, - repos = NULL, - type = "source", - quiet = quiet) - ok <- TRUE - if(load) { - if(missing(lib)) - lib <- NULL - ## require can't take lib.loc as missing. - ## It needs NULL to invoke default behavior. - pos <- match(paste0("package:", pkgName), search()) - if(!is.na(pos)) { - message("detaching and unloading previous version of ", pkgName) - detach(paste0("package:",pkgName), unload=TRUE, character.only=TRUE) - } - ok <- require(pkgName, lib.loc = lib, character.only = TRUE) - } - ok -} #' @name erasePackage #' @title Erase packages generated by `nCompiler`. @@ -565,9 +83,9 @@ buildPackage <- function(pkgName, #' If \code{nCompilerOnly} is \code{TRUE} (the default), the DESCRIPTION file #' will be checked to make sure it looks like one autogenerated by #' \code{writePackage}. -#' +#' #' @examples -#' +#' #' # Initialize an example nFunction #' foo <- nFunction(name = "foo", #' fun = function(x = numericScalar()) { @@ -583,7 +101,7 @@ buildPackage <- function(pkgName, #' # Decide we don't want fooPackage after all and erase it. #' erasePackage("fooPackage", dir = tempdir()) #' dir.exists(file.path(tempdir(), "fooPackage")) # FALSE -#' +#' #' @seealso For other nCompiler packaging tools, see \code{\link{writePackage}} #' and \code{\link{buildPackage}}. For more info on deleting a directory see #' \code{\link[base]{unlink}}. @@ -613,7 +131,7 @@ erasePackage <- function(pkgName, dir = '.', } if (nCompilerOnly && do_erase) { desc <- read.dcf(file.path(pkgDir, "DESCRIPTION")) - # following Writing R extensions notes for DESCRIPTION file, generate or + # following Writing R extensions notes for DESCRIPTION file, generate or # overwrite desc[,"Author"] if desc[,"Authors@R"] is present if("Authors@R" %in% colnames(desc)) { author = utils:::.read_authors_at_R_field(desc[,"Authors@R"]) @@ -750,9 +268,9 @@ erasePackage <- function(pkgName, dir = '.', # TODO: Be more thoughtful about when whitespace is and isn't addressed, # incl. tabs and the like -documentNClass <- function(obj = NULL, name, title, description = NULL, +documentNClass <- function(obj = NULL, name, title, description = NULL, fields = list(), - CMethodsDescriptions = list(), + CMethodsDescriptions = list(), CMethodsParams = list(), otherRoxygen = NULL, headerComment = "#'", @@ -767,77 +285,77 @@ documentNClass <- function(obj = NULL, name, title, description = NULL, stop(paste("in documentNClass: checkAgainstObj is true but no nClass", "object was provided")) } - + if (processWhitespace) { - nameProc <- strwrap(gsub("[[:space:]]+", " ", name), width = 80, - prefix = paste0(headerComment, " "), + nameProc <- strwrap(gsub("[[:space:]]+", " ", name), width = 80, + prefix = paste0(headerComment, " "), initial = paste0(headerComment, " @name ")) - titleProc <- strwrap(gsub("[[:space:]]+", " ", title), width = 80, - prefix = paste0(headerComment, " "), + titleProc <- strwrap(gsub("[[:space:]]+", " ", title), width = 80, + prefix = paste0(headerComment, " "), initial = paste0(headerComment, " @title ")) - descProc <- + descProc <- if (is.null(description)) { NULL - } else strwrap(gsub("[[:space:]]+", " ", description), width = 80, - prefix = paste0(headerComment, " "), + } else strwrap(gsub("[[:space:]]+", " ", description), width = 80, + prefix = paste0(headerComment, " "), initial = paste0(headerComment, " @description ")) - + fieldsProc <- character(length(fields)) if (length(fields) > 0) for (i in 1:length(fields)) { fieldsProc[i] <- strwrap(paste(names(fields)[i], fields[[i]]), width = 80, prefix = paste0(headerComment, " "), initial = paste0(headerComment, " @field ")) } - + } else { - nameProc <- gsub("\n", paste0("\n", headerComment), + nameProc <- gsub("\n", paste0("\n", headerComment), paste0(headerComment, " @name ", name)) - titleProc <- gsub("\n", paste0("\n", headerComment), + titleProc <- gsub("\n", paste0("\n", headerComment), paste0(headerComment, " @title ", title)) - descProc <- gsub("\n", paste0("\n", headerComment), + descProc <- gsub("\n", paste0("\n", headerComment), paste0(headerComment, " @description ", description)) fieldsProc <- character(length(fields)) if (length(fields) > 0) for (i in 1:length(fields)) { - fieldsProc[[i]] <- gsub("\n", paste0("\n", headerComment), - paste(headerComment, "@field", names(fields)[i], + fieldsProc[[i]] <- gsub("\n", paste0("\n", headerComment), + paste(headerComment, "@field", names(fields)[i], fields[[i]])) } } - - header <- paste0(c(nameProc, titleProc, descProc, fieldsProc, otherRoxygen), + + header <- paste0(c(nameProc, titleProc, descProc, fieldsProc, otherRoxygen), collapse = "\n") - - # Handle the methods documentation. + + # Handle the methods documentation. # Methods are allowed to have just description, just params, or both methodsToDocument <- unique(c(names(CMethodsDescriptions), names(CMethodsParams))) - + methodsList <- list() for (i in 1:length(methodsToDocument)) { thisMethod <- methodsToDocument[i] - thisNameProc <- strwrap(gsub("[[:space:]]+", " ", thisMethod), width = 80, - prefix = paste0(methodsComment, " "), + thisNameProc <- strwrap(gsub("[[:space:]]+", " ", thisMethod), width = 80, + prefix = paste0(methodsComment, " "), initial = paste0(methodsComment, " @name ")) - + thisDescStr <- strwrap(gsub("[[:space:]]+", " ", CMethodsDescriptions[[thisMethod]]), - width = 80, prefix = paste0(methodsComment, " "), + width = 80, prefix = paste0(methodsComment, " "), initial = paste0(methodsComment, " @description ")) thisParams <- character(length(CMethodsParams[[thisMethod]])) for (j in 1:length(thisParams)) { - thisParams[j] <- strwrap(gsub("[[:space:]]+", " ", CMethodsParams[[i]][j]), - width = 80, prefix = paste0(methodsComment, " "), - initial = paste0(methodsComment, " @param ", - names(CMethodsParams[[i]])[j], + thisParams[j] <- strwrap(gsub("[[:space:]]+", " ", CMethodsParams[[i]][j]), + width = 80, prefix = paste0(methodsComment, " "), + initial = paste0(methodsComment, " @param ", + names(CMethodsParams[[i]])[j], " ")) } - + methodsList[[ methodsToDocument[i] ]] <- paste( c(thisDescStr, thisParams), collapse = "\n" ) } - + return(list(header = header, methods = methodsList)) } @@ -912,8 +430,8 @@ documentNClass <- function(obj = NULL, name, title, description = NULL, # TODO: Be more thoughtful about when whitespace is and isn't addressed, # incl. tabs and the like -documentNFunction <- function(obj = NULL, name, title, description = NULL, - params = list(), otherRoxygen = NULL, +documentNFunction <- function(obj = NULL, name, title, description = NULL, + params = list(), otherRoxygen = NULL, processWhitespace = TRUE, roxComment = "//'", checkAgainstObj = FALSE){ # Check sanity of inputs @@ -924,47 +442,46 @@ documentNFunction <- function(obj = NULL, name, title, description = NULL, stop(paste("in documentNClass: checkAgainstObj is true but no nFunction", "object was provided")) } - + if (processWhitespace) { - - nameProc <- strwrap(gsub("[[:space:]]+", " ", name), width = 80, - prefix = paste0(roxComment, " "), + + nameProc <- strwrap(gsub("[[:space:]]+", " ", name), width = 80, + prefix = paste0(roxComment, " "), initial = paste0(roxComment, " @name ")) - titleProc <- strwrap(gsub("[[:space:]]+", " ", title), width = 80, - prefix = paste0(roxComment, " "), + titleProc <- strwrap(gsub("[[:space:]]+", " ", title), width = 80, + prefix = paste0(roxComment, " "), initial = paste0(roxComment, " @title ")) - descProc <- + descProc <- if (is.null(description)) { NULL - } else strwrap(gsub("[[:space:]]+", " ", description), width = 80, - prefix = paste0(roxComment, " "), + } else strwrap(gsub("[[:space:]]+", " ", description), width = 80, + prefix = paste0(roxComment, " "), initial = paste0(roxComment, " @description ")) - + paramsProc <- character(length(params)) if (length(params) > 0) for (i in 1:length(params)) { paramsProc[i] <- strwrap(paste(names(params)[i], params[[i]]), width = 80, prefix = paste0(roxComment, " "), initial = paste0(roxComment, " @param ")) } - + } else { - nameProc <- gsub("\n", paste0("\n", roxComment), + nameProc <- gsub("\n", paste0("\n", roxComment), paste0(roxComment, " @name ", name)) - titleProc <- gsub("\n", paste0("\n", roxComment), + titleProc <- gsub("\n", paste0("\n", roxComment), paste0(roxComment, " @title ", title)) - descProc <- gsub("\n", paste0("\n", roxComment), + descProc <- gsub("\n", paste0("\n", roxComment), paste0(roxComment, " @description ", description)) fieldsProc <- character(length(params)) if (length(params) > 0) for (i in 1:length(params)) { - paramsProc[[i]] <- gsub("\n", paste0("\n", roxComment), - paste(roxComment, "@param", + paramsProc[[i]] <- gsub("\n", paste0("\n", roxComment), + paste(roxComment, "@param", names(params)[i], params[[i]])) } } - - header <- paste0(c(nameProc, titleProc, descProc, paramsProc, otherRoxygen), + + header <- paste0(c(nameProc, titleProc, descProc, paramsProc, otherRoxygen), collapse = "\n") - + return(list(header = header)) } - diff --git a/nCompiler/R/symbolTable.R b/nCompiler/R/symbolTable.R index 37bfa3af..fb0f04e4 100644 --- a/nCompiler/R/symbolTable.R +++ b/nCompiler/R/symbolTable.R @@ -31,6 +31,11 @@ symbolBase <- R6::R6Class( ## 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 +## size may end up not being used, but at least in principle it is to define a C++ object of FIXED size. +## knownSize is added for some backward compatibility needs with nimble +## 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 <- R6::R6Class( classname = 'symbolBasic', @@ -39,6 +44,7 @@ symbolBasic <- public = list( nDim = NULL, size = NULL, + knownSize = NULL, isBlockRef = FALSE, initialize = function(..., nDim = 0, diff --git a/nCompiler/inst/include/nCompiler/EigenTensor_extensions/post_Rcpp/tensorFlex.h b/nCompiler/inst/include/nCompiler/EigenTensor_extensions/post_Rcpp/tensorFlex.h index 6595c0ef..66c1ec44 100644 --- a/nCompiler/inst/include/nCompiler/EigenTensor_extensions/post_Rcpp/tensorFlex.h +++ b/nCompiler/inst/include/nCompiler/EigenTensor_extensions/post_Rcpp/tensorFlex.h @@ -339,6 +339,84 @@ struct scalar_cast_ { } }; +// Generic casting system that handles scalars and Eigen objects appropriately +template +TargetType do_flex_cast(const XprType &x, trueScalar) { + // Rcpp::Rcout << "Debug flex_cast: casting trueScalar to " << typeid(TargetType).name() << std::endl; + return static_cast(x); +} + +template +decltype(auto) do_flex_cast(const XprType &x, eigenTensor) { + // Rcpp::Rcout << "Debug flex_cast: casting eigenTensor to " << typeid(TargetType).name() << std::endl; + // Rcpp::Rcout <<" eval = "<) { + // Rcpp::Rcout<<"Using this branch (2)"< result = x.template cast(); + //return result; + return x.template cast().eval(); + } + } else { + // Return lazy expression when eval=false + if constexpr (std::is_same_v) { + // No casting needed, return as-is + return x; + } else { + // Return lazy cast expression + return x.template cast(); + } + } +} + +template +decltype(auto) do_flex_cast(const XprType &x, eigenOp) { + // Rcpp::Rcout << "Debug flex_cast: casting eigenOp to " << typeid(TargetType).name() << std::endl; + if constexpr (eval) { + // Always materialize when eval=true + if constexpr (std::is_same_v::Scalar>) { + // Same type but need to materialize the lazy expression + // Rcpp::Rcout<<"Using this branch"<::NumDimensions> result = x.eval(); + return x.eval(); //result; + } else { + // Different type and need to materialize + //Eigen::Tensor::NumDimensions> result = x.template cast(); + return x.template cast().eval(); //result; + } + } else { + // Return lazy expression when eval=false + if constexpr (std::is_same_v::Scalar>) { + // No casting needed, return lazy expression as-is + return x; + } else { + // Return lazy cast expression + return x.template cast(); + } + } +} + +// +// syntax will be flex_cast(x); +template +struct flex_cast_ { + template + static auto cast(const XprType &x) { + return do_flex_cast(x, typename type_category::type()); + } +}; + +// Convenience function for easier syntax: flex_cast(x) instead of flex_cast_::cast(x) +template +auto flex_cast(const XprType &x) { + return flex_cast_::cast(x); +} + // smartAssignWholeObject handles assignment when the sizes of the LHS // can be changed because the entire object is assigned to. // This is tag dispatched similarly to smartAssignFixedSize diff --git a/nCompiler/inst/include/nCompiler/EigenTensor_extensions/post_Rcpp/tensorOperations.h b/nCompiler/inst/include/nCompiler/EigenTensor_extensions/post_Rcpp/tensorOperations.h index 03e33474..a88a6222 100644 --- a/nCompiler/inst/include/nCompiler/EigenTensor_extensions/post_Rcpp/tensorOperations.h +++ b/nCompiler/inst/include/nCompiler/EigenTensor_extensions/post_Rcpp/tensorOperations.h @@ -829,6 +829,8 @@ Eigen::Tensor nChol(const TensorExpr &x) { return res; } + struct MakeSquareDiag__ {}; // tag to pass for nrow and/or ncol as a "missing" + /** * Generate a rank-2 Eigen::Tensor object (i.e., a matrix) with non-constant * diagonal @@ -853,20 +855,29 @@ Eigen::Tensor nChol(const TensorExpr &x) { > Eigen::Tensor nDiag(Xpr x, Index nrow, Index ncol) { // evaluate input if needed + Eigen::Index nrow_, ncol_; + Eigen::Index size_x = nDimTraits2_size(x); + if constexpr (std::is_same::value) { + nrow_ = ncol_ = size_x; + } else { + nrow_ = nrow; + ncol_ = ncol; + } + auto xEval = eval(x); // initialize output - Eigen::Tensor res(nrow, ncol); + Eigen::Tensor res(nrow_, ncol_); // zero-initialize tensor contents res.setZero(); // figure out how large the main diagonal is - Index nEntries = std::min(nrow, ncol); - if(x.size() != nEntries) { + Eigen::Index nEntries = std::min(nrow_, ncol_); + if(size_x != nEntries) { throw std::range_error( "nCompiler::nDiag - Diagonal entry vector length does not match matrix size" ); } // populate diagonal and return - for(Index i = 0; i < nEntries; ++i) { + for(Eigen::Index i = 0; i < nEntries; ++i) { res(i,i) = xEval(i); } return res; diff --git a/nCompiler/inst/include/nCompiler/EigenTensor_extensions/post_Rcpp/tensorUtils.h b/nCompiler/inst/include/nCompiler/EigenTensor_extensions/post_Rcpp/tensorUtils.h index d99d510c..6950703e 100644 --- a/nCompiler/inst/include/nCompiler/EigenTensor_extensions/post_Rcpp/tensorUtils.h +++ b/nCompiler/inst/include/nCompiler/EigenTensor_extensions/post_Rcpp/tensorUtils.h @@ -81,7 +81,8 @@ namespace Eigen { static const std::size_t NumDimensions = 0; }; - +// This is used in one place, generated code for Rep. +// It could probably be replaced with CreateTensor. template auto Make_Length1_Tensor(const Scalar_ &x) -> Eigen::Tensor { Eigen::Tensor ans(1); @@ -97,16 +98,10 @@ namespace Eigen { typedef Eigen::DSizes DSizes; // for later chained ops such as concatenate, it must be a DSizes. typename XprType::Nested m_expr; typedef decltype(m_expr.reshape(DSizes())) returnType; - //typedef const T constT; - //typedef const decltype(x.reshape(DimArr())) returnType; as_1D_tensor_impl(const XprType &expr) : m_expr(expr) {} returnType go() const { const DSizes newDim( DimArr{{ nDimTraits2_size(m_expr) -// Eigen::internal::array_prod( nDimTraits< typename std::remove_reference::type >::getEvaluator(m_expr).dimensions() ) -// Eigen::TensorRef< -// Eigen::Tensor - // >(x).dimensions().TotalSize() }}); return m_expr.reshape(newDim); } @@ -119,6 +114,24 @@ namespace Eigen { } }; + // Specialization for when input is already a 1D tensor - just return it as-is + template + struct as_1D_tensor_impl> { + typedef typename Eigen::Tensor::Index Index; + typedef const Eigen::Tensor& returnType; + const Eigen::Tensor &m_expr; + as_1D_tensor_impl(const Eigen::Tensor &expr) : m_expr(expr) {} + returnType go() const { + // Rcpp::Rcout<<"as_1D_tensor_impl is doing a no-op"< + returnType go(const S& size) const { + // For 1D tensors, ignore the size parameter and return as-is + return m_expr; + } + }; + // This is to allow creation of c(1, 2, 3) via as_1D_tensor(std::vector{1, 2, 3}); // In the past I have observed that TensorMap's are not fully endowed with all tensor capabilities, // so I am not sure if this will be fully general. If not, we may need to create a new op diff --git a/nCompiler/inst/include/nCompiler/EigenTensor_extensions/post_Rcpp/tensor_cat_op.h b/nCompiler/inst/include/nCompiler/EigenTensor_extensions/post_Rcpp/tensor_cat_op.h index 4da61507..1f8fbc53 100644 --- a/nCompiler/inst/include/nCompiler/EigenTensor_extensions/post_Rcpp/tensor_cat_op.h +++ b/nCompiler/inst/include/nCompiler/EigenTensor_extensions/post_Rcpp/tensor_cat_op.h @@ -3,11 +3,14 @@ #include #include "tensorUtils.h" +#include "tensorFlex.h" -template -auto concat_(const T1 &x1, const T2 &x2) -> decltype(Eigen::as_1D_tensor(x1).concatenate(Eigen::as_1D_tensor(x2),0)) { - return Eigen::as_1D_tensor(x1).concatenate(Eigen::as_1D_tensor(x2),0); -} +// template +// auto concat_(const T1 &x1, const T2 &x2) { +// typedef std::common_type_t::Scalar, typename TypeLike::Scalar> CommonType; +// return flex_cast(Eigen::as_1D_tensor(x1)).concatenate( +// flex_cast(Eigen::as_1D_tensor(x2)), 0); +// } /** * Base template required to avoid redefining partial specializations @@ -15,15 +18,37 @@ auto concat_(const T1 &x1, const T2 &x2) -> decltype(Eigen::as_1D_tensor(x1).con template struct nC_impl; +/** + * Partial specialization for empty case: nC() returns empty 1D tensor + */ +template +struct nC_impl { + static auto run() { + return Eigen::Tensor(0); // Empty 1D tensor + } +}; + +/** + * Partial specialization for singleton case: nC(x) returns x as 1D tensor + */ +template +struct nC_impl { + //typedef Eigen::Tensor ReturnType; + static auto run(const T1 & t1) { + return flex_cast(Eigen::as_1D_tensor(t1)); + } +}; + /** * Partial specialization implementing final concatenate operation recursion */ -template -struct nC_impl { - static auto run(const T1 & t1, const T2 & t2) -> decltype( - Eigen::as_1D_tensor(t1).concatenate(Eigen::as_1D_tensor(t2), 0) - ) { - return Eigen::as_1D_tensor(t1).concatenate(Eigen::as_1D_tensor(t2), 0); +template +struct nC_impl { + //typedef Eigen::Tensor ReturnType; + static auto run(const T1 & t1, const T2 & t2) { + // Rcpp::Rcout<<"going through two-argument implementation"<(Eigen::as_1D_tensor(t1)).eval().concatenate(flex_cast(Eigen::as_1D_tensor(t2)).eval(), 0).eval(); + return flex_cast(Eigen::as_1D_tensor(t1)).concatenate(flex_cast(Eigen::as_1D_tensor(t2)), 0).eval(); } }; @@ -31,40 +56,64 @@ struct nC_impl { /** * Partial specialization implementing concatenate operation recursion */ -template -struct nC_impl { - - /** +template +struct nC_impl { +/** * only used to make decltype well defined. struct nC_impl is not intended * to be instantiated */ const T1 & m_t1; const T2 & m_t2; - /** * Determine return type here to simplify recursive variadic template coding * patterns with auto return types */ typedef decltype( - Eigen::as_1D_tensor(m_t1).concatenate(Eigen::as_1D_tensor(m_t2),0) + flex_cast(Eigen::as_1D_tensor(m_t1)).concatenate(flex_cast(Eigen::as_1D_tensor(m_t2)), 0).eval() ) IntermediateConcat; - - static auto run(const T1 & t1, const T2 & t2, const TT&... tt) -> decltype( - nC_impl::run( - Eigen::as_1D_tensor(t1).concatenate(Eigen::as_1D_tensor(t2), 0), tt...) - ) { - return nC_impl::run( - Eigen::as_1D_tensor(t1).concatenate(Eigen::as_1D_tensor(t2), 0), tt... + + static auto run(const T1 & t1, const T2 & t2, const TT&... tt) { + return nC_impl::run( + flex_cast(Eigen::as_1D_tensor(t1)).concatenate(flex_cast(Eigen::as_1D_tensor(t2)), 0).eval(), + tt... ); } }; + // typedef Eigen::Tensor ReturnType; + // typedef ReturnType IntermediateType; + // static ReturnType run(const T1 & t1, const T2 & t2, const TT&... tt) { + // Rcpp::Rcout<<"going through multiple arguments implementation"<::run( + // ReturnType(flex_cast(Eigen::as_1D_tensor(t1)).concatenate(flex_cast(Eigen::as_1D_tensor(t2)), 0)), + // tt... + // ); + // } + //}; + /** * Convenience wrapper to generate tensor concatenations */ +// Empty case: nC() - default to double +inline auto nC() -> Eigen::Tensor { // inline to avoid duplicate symbol since this is not templated + return nC_impl::run(); +} + template -auto nC(const Args&... args) -> decltype(nC_impl::run(args...)) { - return nC_impl::run(args...); +using nC_common_type_t = std::common_type_t::Scalar...>; + +// Single argument case: nC(x) +template +auto nC(const T1& t1) -> Eigen::Tensor, 1> { + typedef typename TypeLike::Scalar CommonType; + return nC_impl::run(t1); +} + +// Multiple arguments case: nC(x, y, ...) +template +auto nC(const T1& t1, const T2& t2, const Args&... args) -> Eigen::Tensor, 1> { + // Rcpp::Rcout<<"going through multiple arguments cast"<, T1, T2, Args...>::run(t1, t2, args...); } #endif // __TENSOR_CAT_OP_H_ diff --git a/nCompiler/tests/nimble/test-allocations.R b/nCompiler/tests/nimble/test-allocations.R index 0b97a2b2..00fbb265 100644 --- a/nCompiler/tests/nimble/test-allocations.R +++ b/nCompiler/tests/nimble/test-allocations.R @@ -3,7 +3,7 @@ ## tests of numeric, integer, logical, matrix and array library(nimble) -library(nCompiler) +#library(nCompiler) divert_to_nCompiler <- function(fun, replacements) { diversion_env <- list2env(replacements, parent = environment(fun)) @@ -25,9 +25,9 @@ test_coreRfeature_batch <- function( }) } test_coreRfeature_batch_internal <- - divert_to_nCompiler(test_coreRfeature_batch_internal, list(compileNimble = nCompiler:::compileNimble)) + divert_to_nCompiler(test_coreRfeature_batch_internal, list(compileNimble = `:::`("nCompiler", "compileNimble"))) test_coreRfeature_internal <- - divert_to_nCompiler(test_coreRfeature_internal, list(compileNimble = nCompiler:::compileNimble)) + divert_to_nCompiler(test_coreRfeature_internal, list(compileNimble = `:::`("nCompiler", "compileNimble"))) ## Changes stop RwarnLevel <- options('warn')$warn diff --git a/nCompiler/tests/nimble/test-coreR.R b/nCompiler/tests/nimble/test-coreR.R index c391c19a..ebc439b2 100644 --- a/nCompiler/tests/nimble/test-coreR.R +++ b/nCompiler/tests/nimble/test-coreR.R @@ -1,7 +1,8 @@ ## Copied and modified from nimble's test-coreR library(nimble) -library(nCompiler) +#library(nCompiler) +nOptions(nimble=TRUE) divert_to_nCompiler <- function(fun, replacements) { diversion_env <- list2env(replacements, parent = environment(fun)) @@ -13,9 +14,9 @@ source(system.file(file.path('tests', 'testthat', 'test_utils.R'), package = 'ni ## Changes start test_coreRfeature_batch <- function( - input_batch, - info = '', - verbose = nimbleOptions('verbose'), + input_batch, + info = '', + verbose = nimbleOptions('verbose'), dirName = NULL ) { test_that(info, { @@ -23,9 +24,9 @@ test_coreRfeature_batch <- function( }) } test_coreRfeature_batch_internal <- - divert_to_nCompiler(test_coreRfeature_batch_internal, list(compileNimble = nCompiler:::compileNimble)) + divert_to_nCompiler(test_coreRfeature_batch_internal, list(compileNimble = `:::`("nCompiler", "compileNimble"))) test_coreRfeature_internal <- - divert_to_nCompiler(test_coreRfeature_internal, list(compileNimble = nCompiler:::compileNimble)) + divert_to_nCompiler(test_coreRfeature_internal, list(compileNimble = `:::`("nCompiler", "compileNimble"))) ## Changes stop RwarnLevel <- options('warn')$warn @@ -33,8 +34,6 @@ options(warn = 1) nimbleVerboseSetting <- nimbleOptions('verbose') nimbleOptions(verbose = FALSE) -context("Testing of core R functions in NIMBLE code") - ## fix result_type in nimbleEigen.h cTests <- list( @@ -44,22 +43,22 @@ cTests <- list( setArgVals = quote({arg1 <- as.numeric(1:3); arg2 <- as.integer(4:5)}), outputType = quote(double(1))), list(name = "c(double, logical)", expr = quote(out <- c(arg1, arg2)), args = list(arg1 = quote(double(1)), arg2 = quote(logical(1))), setArgVals = quote({arg1 <- as.numeric(1:3); arg2 <- c(TRUE, FALSE, TRUE)}), outputType = quote(double(1))), - - + + list(name = "c(integer, double)", expr = quote(out <- c(arg1, arg2)), args = list(arg1 = quote(integer(1)), arg2 = quote(double(1))), setArgVals = quote({arg1 <- as.integer(1:3); arg2 <- as.numeric(4:5)}), outputType = quote(double(1))), list(name = "c(integer, integer)", expr = quote(out <- c(arg1, arg2)), args = list(arg1 = quote(integer(1)), arg2 = quote(integer(1))), setArgVals = quote({arg1 <- as.integer(1:3); arg2 <- as.integer(4:5)}), outputType = quote(integer(1))), list(name = "c(integer, logical)", expr = quote(out <- c(arg1, arg2)), args = list(arg1 = quote(integer(1)), arg2 = quote(logical(1))), setArgVals = quote({arg1 <- as.integer(1:3); arg2 <- c(TRUE, FALSE, TRUE)}), outputType = quote(integer(1))), - + list(name = "c(logical, double)", expr = quote(out <- c(arg1, arg2)), args = list(arg1 = quote(logical(1)), arg2 = quote(double(1))), setArgVals = quote({arg1 <- c(FALSE, TRUE, FALSE); arg2 <- as.numeric(4:5)}), outputType = quote(double(1))), - - + + list(name = "c(double(2), double)", expr = quote(out <- c(arg1, arg2)), args = list(arg1 = quote(double(2)), arg2 = quote(double(1))), setArgVals = quote({arg1 <- matrix(as.numeric(1:4), nrow = 2); arg2 <- as.numeric(10:11)}), outputType = quote(double(1))), - + list(name = "c(double, double, double)", expr = quote(out <- c(arg1, arg2, arg3)), args = list(arg1 = quote(double(1)), arg2 = quote(double(1)), arg3 = quote(double(1))), setArgVals = quote({arg1 <- as.numeric(1:3); @@ -119,7 +118,7 @@ blockTests <- list( ##6 list(name = "fullxfull block", expr = quote(out <- arg1[, ] + 2), args = list(arg1 = quote(double(2))), setArgVals = quote(arg1 <- matrix(as.numeric(1:25), nrow = 5)), outputType = quote(double(2))), - ## expressions in index ranges (should be lifted) + ## expressions in index ranges (should be lifted) list(name = "3x3 block variable index range", expr = quote({i <- 1; j <- 3; out <- arg1[(j-1):(j+1), 2:4] + 2}), args = list(arg1 = quote(double(2))), setArgVals = quote(arg1 <- matrix(as.numeric(1:25), nrow = 5)), outputType = quote(double(2))), ## dropping a dimension @@ -185,8 +184,8 @@ blockTests <- list( setArgVals = quote(arg1 <- array(as.numeric(1:120), dim = c(4, 5, 6))), outputType = quote(double(2))), list(name = "3x3x1 chained to 2x2 block non-arg", expr = quote({temp <- arg1; out <- temp[2:4, 2:5, 2][2:3, 3:4] + 2}), args = list(arg1 = quote(double(3))), setArgVals = quote(arg1 <- array(as.numeric(1:120), dim = c(4, 5, 6))), outputType = quote(double(2))) - - ## Following is not currently supported: + + ## Following is not currently supported: ## list(name = "5d nimArray map copy", expr = quote({temp <- arg1; out <- temp[2:4, 3:6, 2, 4, 1:3]}), args = list(arg1 = quote(double(5))), ## setArgVals = quote(arg1 <- array(as.numeric(1:(5^5)), dim = c(5, 5, 5, 5, 5))), outputType = quote(double(3))) ## tests to add: @@ -223,7 +222,7 @@ repTests <- list( ##11 list(name = "rep(vector double, first arg)", expr = quote(out <- rep(arg1, each = arg2)), args = list(arg1 = quote(double(1)), arg2 = quote(integer(1))), setArgVals = quote({arg1 <- as.numeric(1:3); arg2 <- as.integer(4:5)}), outputType = quote(double(1)), expectWarnings = list("R eval" = 'Expected warning: vector each', "R run" = "Expected warning: vector each")), - + ## basic cases with x, times and each list(name = "rep(vector double, variable, each = 2)", expr = quote(out <- rep(arg1, times = arg2, each = 2)), args = list(arg1 = quote(double(1)), arg2 = quote(double(0))), setArgVals = quote({arg1 <- as.numeric(1:3); arg2 <- as.numeric(c(4))}), outputType = quote(double(1))), @@ -254,7 +253,7 @@ repTests <- list( setArgVals = quote({arg1 <- as.numeric(1:3); arg2 <- as.numeric(c(7, 8))}), outputType = quote(double(1))), list(name = "rep(vector double, times to ignore, each = first arg, length.out = first arg)", expr = quote(out <- rep(arg1, each = arg3, times = 10, length.out = arg2)), args = list(arg1 = quote(double(1)), arg2 = quote(double(1)), arg3 = quote(double(1))), setArgVals = quote({arg1 <- as.numeric(1:3); arg2 <- as.numeric(c(7, 8)); arg3 <- as.numeric(4:5)}), outputType = quote(double(1)), expectWarnings = list("R eval" = 'Expected warning: vector each', "R run" = "Expected warning: vector each")), - + ## x, times expressions # mods for nCompiler (that weren't needed for nimble): add checkEqual = TRUE to account for floating point errors between R vs Eigen list(name = "rep(vector double expression, expression)", expr = quote(out <- rep(exp(arg1), arg2^2)), args = list(arg1 = quote(double(1)), arg2 = quote(integer())), checkEqual = TRUE, @@ -263,22 +262,22 @@ repTests <- list( # mods for nCompiler (that weren't needed for nimble): add checkEqual = TRUE to account for floating point errors between R vs Eigen list(name = "rep(vector double expression, non-scalar expression)", expr = quote(out <- rep(exp(arg1), sum(arg2^2))), args = list(arg1 = quote(double(1)), arg2 = quote(double(1))), checkEqual = TRUE, setArgVals = quote({arg1 <- as.numeric(1:3); arg2 <- as.numeric(c(2,3))}), outputType = quote(double(1))), - - + + list(name = "rep(matrix, 3)", expr = quote(out <- rep(arg1, 3)), args = list(arg1 = quote(double(2))), setArgVals = quote({arg1 <- matrix(as.numeric(1:9), nrow = 3)}),outputType = quote(double(1))), - - list(name = "rep(vector, vector)", expr = quote(out <- rep(arg1, arg2)), args = list(arg1 = quote(double(1)), arg2 = quote(double(1))), + + list(name = "rep(vector, vector)", expr = quote(out <- rep(arg1, arg2)), args = list(arg1 = quote(double(1)), arg2 = quote(double(1))), setArgVals = quote({arg1 <- as.numeric(1:3); arg2 <- as.numeric(2:4)}), outputType = quote(double(1))), - + list(name = "rep(vector double, 3) in expression", expr = quote(out <- log(rep(arg1, 3))^2 + c(arg1, arg1, arg1)), args = list(arg1 = quote(double(1))), setArgVals = quote({arg1 <- as.numeric(1:3)}), outputType = quote(double(1))) - + ) diagTests <- list( ## could add some where non-scalar inputs are copied in order to get different map behavior - ## + ## ##1 ## diag(scalar) list(name = "diag(scalar)", expr = quote(out <- diag(arg1)), args = list(arg1 = quote(double(0))), @@ -286,7 +285,7 @@ diagTests <- list( list(name = "diag(scalar expression)", expr = quote(out <- diag(arg1 + arg2)), args = list(arg1 = quote(double(0)), arg2 = quote(double(0))), setArgVals = quote({arg1 <- 3; arg2 <- 2}), outputType = quote(double(2))), list(name = "diag(scalar-producing vector expression)", expr = quote(out <- diag(sum(arg1))), args = list(arg1 = quote(double(1))), - setArgVals = quote({arg1 <- as.numeric(1:3);}), outputType = quote(double(2))), + setArgVals = quote({arg1 <- as.numeric(1:3);}), outputType = quote(double(2))), list(name = "diag(scalar) with expr", expr = quote(out <- exp(diag(arg1)) + arg2), args = list(arg1 = quote(double(0)), arg2 = quote(double(2))), setArgVals = quote({arg1 <- 3; arg2 = matrix(1:9, nrow = 3)}), outputType = quote(double(2))), list(name = "diag(0)", expr = quote(out <- diag(arg1)), args = list(arg1 = quote(double(0))), @@ -298,8 +297,8 @@ diagTests <- list( list(name = "diag(vector expression)", expr = quote(out <- diag(arg1 + arg2)), args = list(arg1 = quote(double(1)), arg2 = quote(double(1))), setArgVals = quote({arg1 <- as.numeric(1:3); arg2 <- as.numeric(c(10,20, 30))}), outputType = quote(double(2))), list(name = "diag(vector) with expression", expr = quote(out <- exp(diag(arg1)) + arg2), args = list(arg1 = quote(double(1)), arg2 = quote(double(2))), - setArgVals = quote({arg1 <- as.numeric(1:3); arg2 <- matrix(as.numeric(11:19), nrow = 3)}), outputType = quote(double(2))), - + setArgVals = quote({arg1 <- as.numeric(1:3); arg2 <- matrix(as.numeric(11:19), nrow = 3)}), outputType = quote(double(2))), + ## diag(matrix) list(name = "diag(square matrix)", expr = quote(out <- diag(arg1)), args = list(arg1 = quote(double(2))), setArgVals = quote({arg1 <- matrix(rnorm(25), nrow = 5)}), outputType = quote(double(1))), @@ -308,7 +307,7 @@ diagTests <- list( ## 11 list(name = "diag(non-square matrix)", expr = quote(out <- diag(arg1)), args = list(arg1 = quote(double(2))), setArgVals = quote({arg1 <- matrix(rnorm(12), nrow = 3)}), outputType = quote(double(1))), - + list(name = "diag(square matrix) <-", expr = quote({diag(arg1) <- arg2; out <- arg1}), args = list(arg1 = quote(double(2)), arg2 = quote(double(1))), setArgVals = quote({arg1 <- matrix(rnorm(25), nrow = 5); arg2 <- as.numeric(101:105)}), outputType = quote(double(2))), list(name = "copy, then diag(square matrix) <-", expr = quote({A1 <- arg1; diag(A1) <- arg2; out <- A1}), args = list(arg1 = quote(double(2)), arg2 = quote(double(1))), @@ -321,7 +320,7 @@ diagTests <- list( ## aliasing list(name = "diag(matrix)[3:5] <- diag(matrix[1:3])", expr = quote({diag(arg1)[3:5] <- diag(arg1)[1:3]; out <- arg1}), args = list(arg1 = quote(double(2))), setArgVals = quote({arg1 <- matrix(rnorm(25), nrow = 5)}), outputType = quote(double(2))) - + ) recyclingRuleTests <- list( @@ -383,67 +382,67 @@ rRecyclingRuleTests <- list( args = list(arg1 = quote(double(1))), setArgVals = quote({arg1 <- seq(.1, .4, length = 10)}), outputType = quote(double(1))), - + list(name = "rexp case 1", expr = quote(out <- rexp(5, arg1)), args = list(arg1 = quote(double(1))), setArgVals = quote({arg1 <- seq(.1, .4, length = 10)}), outputType = quote(double(1))), - + list(name = "rnbinom case 1", expr = quote(out <- rnbinom(5, prob = arg1, size = arg2)), args = list(arg1 = quote(double(1)), arg2 = quote(double(1))), setArgVals = quote({arg1 <- seq(.1, .4, length = 10); arg2 <- seq(4, 1, length = 10)}), outputType = quote(double(1)), checkEqual = TRUE), - + list(name = "rpois case 1", expr = quote(out <- rpois(5, arg1)), args = list(arg1 = quote(double(1))), setArgVals = quote({arg1 <- seq(.1, .4, length = 10)}), outputType = quote(double(1)), checkEqual = TRUE), - + list(name = "rchisq case 1", expr = quote(out <- rchisq(5, arg1)), args = list(arg1 = quote(integer(1))), setArgVals = quote({arg1 <- 1:10}), outputType = quote(double(1))), - + list(name = "rbeta case 1", expr = quote(out <- rbeta(5, arg1, arg2)), args = list(arg1 = quote(double(1)), arg2 = quote(double(1))), setArgVals = quote({arg1 <- seq(0.1, 0.4, length = 10); arg2 <- seq(0.9, 0.7, length = 3)}), outputType = quote(double(1))), - + list(name = "rgamma case 1", expr = quote(out <- rgamma(5, arg1, arg2)), args = list(arg1 = quote(double(1)), arg2 = quote(double(1))), setArgVals = quote({arg1 <- seq(0.1, 0.4, length = 10); arg2 <- seq(0.9, 0.7, length = 3)}), outputType = quote(double(1))), - + list(name = "rinvgamma case 1", expr = quote(out <- rinvgamma(5, arg1, arg2)), args = list(arg1 = quote(double(1)), arg2 = quote(double(1))), setArgVals = quote({arg1 <- seq(0.1, 0.4, length = 10); arg2 <- seq(0.9, 0.7, length = 3)}), outputType = quote(double(1))), - + list(name = "rlnorm case 1", expr = quote(out <- rlnorm(5, arg1, arg2)), args = list(arg1 = quote(double(1)), arg2 = quote(double(1))), setArgVals = quote({arg1 <- seq(0.1, 0.4, length = 10); arg2 <- seq(0.9, 0.7, length = 3)}), outputType = quote(double(1))), - + list(name = "rlogis case 1", expr = quote(out <- rlogis(5, arg1, arg2)), args = list(arg1 = quote(double(1)), arg2 = quote(double(1))), setArgVals = quote({arg1 <- seq(0.1, 0.4, length = 10); arg2 <- seq(0.9, 0.7, length = 3)}), outputType = quote(double(1))), - + list(name = "runif case 1", expr = quote(out <- runif(5, arg1, arg2)), args = list(arg1 = quote(double(1)), arg2 = quote(double(1))), setArgVals = quote({arg1 <- seq(0.1, 0.4, length = 10); arg2 <- seq(0.9, 0.7, length = 3)}), outputType = quote(double(1))), - + list(name = "rweibull case 1", expr = quote(out <- rweibull(5, arg1, arg2)), args = list(arg1 = quote(double(1)), arg2 = quote(double(1))), setArgVals = quote({arg1 <- seq(0.1, 0.4, length = 10); arg2 <- seq(0.9, 0.7, length = 3)}), outputType = quote(double(1))), - + list(name = "rt case 1", expr = quote(out <- rt(5, arg1)), args = list(arg1 = quote(integer(1)), arg2 = quote(double(1))), setArgVals = quote({arg1 <- 5:14; arg2 <- seq(0.9, 0.7, length = 3)}), outputType = quote(double(1))) - + ) seqTests <- list( @@ -591,43 +590,43 @@ indexChainTests <- list( arg2 <- c(2, 3, 5); arg3 <- c(4, 6, 7, 8)}), outputType = quote(double(2))), - + list(name = "block chaining 1b", expr = quote(out <- arg1[, arg3][2:3, 2:4]), args = list(arg1 = quote(double(2)), arg2 = quote(integer(1)), arg3 = quote(integer(1))), setArgVals = quote({arg1 <- matrix(as.numeric(1:100), nrow = 10); arg2 <- c(2, 3, 5); arg3 <- c(4, 6, 7, 8)}), outputType = quote(double(2))), - + list(name = "block chaining 1c", expr = quote(out <- arg1[arg2, ][2:3, 2:4]), args = list(arg1 = quote(double(2)), arg2 = quote(integer(1)), arg3 = quote(integer(1))), setArgVals = quote({arg1 <- matrix(as.numeric(1:100), nrow = 10); arg2 <- c(2, 3, 5); arg3 <- c(4, 6, 7, 8)}), outputType = quote(double(2))), - + list(name = "block chaining 1d", expr = quote(out <- arg1[arg2, arg3][, 2:4]), args = list(arg1 = quote(double(2)), arg2 = quote(integer(1)), arg3 = quote(integer(1))), setArgVals = quote({arg1 <- matrix(as.numeric(1:100), nrow = 10); arg2 <- c(2, 3, 5); arg3 <- c(4, 6, 7, 8)}), outputType = quote(double(2))), - + list(name = "block chaining 1e", expr = quote(out <- arg1[arg2, arg3][2:3, ]), args = list(arg1 = quote(double(2)), arg2 = quote(integer(1)), arg3 = quote(integer(1))), setArgVals = quote({arg1 <- matrix(as.numeric(1:100), nrow = 10); arg2 <- c(2, 3, 5); arg3 <- c(4, 6, 7, 8)}), outputType = quote(double(2))), - - + + list(name = "block chaining 2", expr = quote(out <- arg1[2:8, 3:6][arg2, arg3]), args = list(arg1 = quote(double(2)), arg2 = quote(integer(1)), arg3 = quote(integer(1))), setArgVals = quote({arg1 <- matrix(as.numeric(1:100), nrow = 10); arg2 <- c(2, 3, 5); arg3 <- c(2, 4)}), outputType = quote(double(2))), - + list(name = "block chaining 3", expr = quote(out <- arg1[arg2, arg3][arg4, arg5]), args = list(arg1 = quote(double(2)), arg2 = quote(integer(1)), arg3 = quote(integer(1)), arg4 = quote(integer(1)), arg5 = quote(integer(1))), setArgVals = quote({arg1 <- matrix(as.numeric(1:100), nrow = 10); @@ -636,7 +635,7 @@ indexChainTests <- list( arg4 <- c(2, 3); arg5 <- c(1, 4, 5)}), outputType = quote(double(2))), - + list(name = "block chaining 4", expr = quote(out <- arg1[1, arg3][arg5]), args = list(arg1 = quote(double(2)), arg2 = quote(integer(1)), arg3 = quote(integer(1)), arg4 = quote(integer(1)), arg5 = quote(integer(1))), setArgVals = quote({arg1 <- matrix(as.numeric(1:100), nrow = 10); @@ -645,7 +644,7 @@ indexChainTests <- list( arg4 <- c(2, 3); arg5 <- c(1, 4)}), outputType = quote(double(1))), - + list(name = "block chaining 4b", expr = quote(out <- arg1[1, arg3, drop = FALSE][1, arg5]), args = list(arg1 = quote(double(2)), arg2 = quote(integer(1)), arg3 = quote(integer(1)), arg4 = quote(integer(1)), arg5 = quote(integer(1))), setArgVals = quote({arg1 <- matrix(as.numeric(1:100), nrow = 10); @@ -654,8 +653,8 @@ indexChainTests <- list( arg4 <- c(2, 3); arg5 <- c(1, 4)}), outputType = quote(double(1))), - - + + list(name = "block chaining 4c", expr = quote(out <- arg1[arg2, 2][arg5]), args = list(arg1 = quote(double(2)), arg2 = quote(integer(1)), arg3 = quote(integer(1)), arg4 = quote(integer(1)), arg5 = quote(integer(1))), setArgVals = quote({arg1 <- matrix(as.numeric(1:100), nrow = 10); @@ -664,7 +663,7 @@ indexChainTests <- list( arg4 <- c(2, 3); arg5 <- c(1, 4)}), outputType = quote(double(1))), - + list(name = "block chaining assignment 1", expr = quote({out <- matrix(-1, nrow = 10, ncol = 10); out[arg2, arg3][2:3, 2:4] <- arg1[arg2, arg3][2:3, 2:4]}), args = list(arg1 = quote(double(2)), arg2 = quote(integer(1)), arg3 = quote(integer(1))), @@ -672,8 +671,8 @@ indexChainTests <- list( arg2 <- c(2, 3, 5); arg3 <- c(4, 6, 7, 8)}), outputType = quote(double(2))), - - + + list(name = "block chaining assignment 1b", expr = quote({out <- matrix(-1, nrow = 10, ncol = 10); out[, arg3][2:3, 2:4] <- arg1[, arg3][2:3, 2:4]}), args = list(arg1 = quote(double(2)), arg2 = quote(integer(1)), arg3 = quote(integer(1))), @@ -681,7 +680,7 @@ indexChainTests <- list( arg2 <- c(2, 3, 5); arg3 <- c(4, 6, 7, 8)}), outputType = quote(double(2))), - + list(name = "block chaining assignment 1c", expr = quote({out <- matrix(-1, nrow = 10, ncol = 10); out[arg2, ][2:3, 2:4] <- arg1[arg2, ][2:3, 2:4]}), args = list(arg1 = quote(double(2)), arg2 = quote(integer(1)), arg3 = quote(integer(1))), @@ -689,7 +688,7 @@ indexChainTests <- list( arg2 <- c(2, 3, 5); arg3 <- c(4, 6, 7, 8)}), outputType = quote(double(2))), - + list(name = "block chaining assignment 1d", expr = quote({out <- matrix(-1, nrow = 10, ncol = 10); out[arg2, arg3][, 2:4] <- arg1[arg2, arg3][, 2:4]}), args = list(arg1 = quote(double(2)), arg2 = quote(integer(1)), arg3 = quote(integer(1))), @@ -697,7 +696,7 @@ indexChainTests <- list( arg2 <- c(2, 3, 5); arg3 <- c(4, 6, 7, 8)}), outputType = quote(double(2))), - + list(name = "block chaining assignment 1e", expr = quote({out <- matrix(-1, nrow = 10, ncol = 10); out[arg2, arg3][2:3, ] <- arg1[arg2, arg3][2:3, ]}), args = list(arg1 = quote(double(2)), arg2 = quote(integer(1)), arg3 = quote(integer(1))), @@ -705,7 +704,7 @@ indexChainTests <- list( arg2 <- c(2, 3, 5); arg3 <- c(4, 6, 7, 8)}), outputType = quote(double(2))), - + list(name = "block chaining assignment 2", expr = quote({out <- matrix(-1, nrow = 10, ncol = 10); out[2:8, 3:6][arg2, arg3] <- arg1[2:8, 3:6][arg2, arg3]}), args = list(arg1 = quote(double(2)), arg2 = quote(integer(1)), arg3 = quote(integer(1))), @@ -713,7 +712,7 @@ indexChainTests <- list( arg2 <- c(2, 3, 5); arg3 <- c(2, 4)}), outputType = quote(double(2))), - + list(name = "block chaining assignment 3", expr = quote({out <- matrix(-1, nrow = 10, ncol = 10); out[arg2, arg3][arg4, arg5] <- arg1[arg2, arg3][arg4, arg5]}), args = list(arg1 = quote(double(2)), arg2 = quote(integer(1)), arg3 = quote(integer(1)), arg4 = quote(integer(1)), arg5 = quote(integer(1))), @@ -730,55 +729,55 @@ logicalTests <- list( args = list(arg1 = quote(double(1))), setArgVals = quote({arg1 <- seq(1, 8, length = 100)}), outputType = quote(logical(1))), - + list(name = "create boolean vector with expressions", expr = quote(out <- arg1 > 3 & arg1 + 1 < 6), args = list(arg1 = quote(double(1))), setArgVals = quote({arg1 <- seq(1, 8, length = 100)}), outputType = quote(logical(1))), - + list(name = "use boolean vector with expressions", expr = quote({out <- arg1 > 3 & arg1 + 1 < 6; out <- out | arg1 > 7}), args = list(arg1 = quote(double(1))), setArgVals = quote({arg1 <- seq(1, 8, length = 100)}), outputType = quote(logical(1))), - + list(name = "index from boolean vector 1", expr = quote({out <- arg1[arg2 < 5]}), args = list(arg1 = quote(double(1)), arg2 = quote(double(1))), setArgVals = quote({arg1 <- seq(1, 8, length = 100); arg2 <- seq(2, 9, length = 100)}), outputType = quote(double(1))), - + list(name = "index from boolean vector 2 (in expression)", expr = quote({out <- (arg1[arg2 < 5]^2) + 1}), args = list(arg1 = quote(double(1)), arg2 = quote(double(1))), setArgVals = quote({arg1 <- seq(1, 8, length = 100); arg2 <- seq(2, 9, length = 100)}), outputType = quote(double(1))), - + list(name = "index from boolean vector 3 (2D)", expr = quote({out <- arg1[arg2 < 5, arg2 > 4]}), args = list(arg1 = quote(double(2)), arg2 = quote(double(1))), setArgVals = quote({arg1 <- matrix(seq(1, 8, length = 10000), nrow = 100); arg2 <- seq(2, 9, length = 100)}), outputType = quote(double(2))), - + list(name = "index from boolean vector 3 (2D with mixed types)", expr = quote({out <- arg1[arg2 < 5, 30:50]}), args = list(arg1 = quote(double(2)), arg2 = quote(double(1))), setArgVals = quote({arg1 <- matrix(seq(1, 8, length = 10000), nrow = 100); arg2 <- seq(2, 9, length = 100)}), outputType = quote(double(2))), - - + + list(name = "index assignment from boolean vector 1", expr = quote({out <- rep(100, length(arg1)); out[arg2 < 5] <- (arg1[arg2 < 5]^2) + 1}), args = list(arg1 = quote(double(1)), arg2 = quote(double(1))), setArgVals = quote({arg1 <- seq(1, 8, length = 100); arg2 <- seq(2, 9, length = 100)}), outputType = quote(double(1))), - + list(name = "index assignment from boolean vector 2 (2D)", expr = quote({out <- matrix(rep(100, length(arg1)), nrow = dim(arg1)[1]); out[arg2 < 5, arg2 > 4] <- (arg1[arg2 < 5, arg2 > 4]^2) + 1}), args = list(arg1 = quote(double(2)), arg2 = quote(double(1))), setArgVals = quote({arg1 <- matrix(seq(1, 8, length = 10000), nrow = 100); arg2 <- seq(2, 9, length = 100)}), outputType = quote(double(2)), checkEqual = TRUE), ## small numerical differences - + list(name = "index assignment from boolean vector 2 (2D, mixed types)", expr = quote({out <- matrix(rep(100, length(arg1)), nrow = dim(arg1)[1]); out[arg2 < 5, 30:40] <- (arg1[arg2 < 5, 30:40]^2) + 1}), args = list(arg1 = quote(double(2)), arg2 = quote(double(1))), @@ -852,7 +851,7 @@ returnTests <- list( return = quote(return(A + B)), args = list(), setArgVals = quote({}), - outputType = quote(double(1))) + outputType = quote(double(1))) ) ## Regression test for Issue #563 @@ -988,7 +987,7 @@ aliasTests <- list( out <- x}), args = list(arg1 = quote(double(1)), arg2 = quote(double(1))), setArgVals = quote({arg1 <- as.numeric(1:3); arg2 <- as.numeric(4:6)}), - outputType = quote(double(1))), + outputType = quote(double(1))), list(name = "x[2:3] <- x[1:2]", ## Fails due to lack of eval with eigenBlock map expr = quote({ x <- arg1 @@ -1068,10 +1067,10 @@ seqTestsResults <- test_coreRfeature_batch(seqTests, 'seqTests') ## lapply(seqTe nonSeqIndexTestsResults <- test_coreRfeature_batch(nonSeqIndexTests, 'nonSeqIndexTests') ## lapply(nonSeqIndexTests, test_coreRfeature) indexChainTestsResults <- test_coreRfeature_batch(indexChainTests, 'indexChainTests') ## lapply(indexChainTests, test_coreRfeature) logicalTestsResults <- test_coreRfeature_batch(logicalTests, 'logicalTests') ## lapply(logicalTests, test_coreRfeature) -anyNaTestResults <- test_coreRfeature_batch(anyNaTests, 'anyNaTests') +anyNaTestResults <- test_coreRfeature_batch(anyNaTests, 'anyNaTests') returnTestResults <- test_coreRfeature_batch(returnTests, 'returnTests') ## lapply(returnTests, test_coreRfeature) -simpleCopyTestResults <- test_coreRfeature_batch(simpleCopyTests, 'simpleCopyTests') -higherDimBlockTestResults <- test_coreRfeature_batch(higherDimBlockTests, 'higherDimBlockTests') +simpleCopyTestResults <- test_coreRfeature_batch(simpleCopyTests, 'simpleCopyTests') +higherDimBlockTestResults <- test_coreRfeature_batch(higherDimBlockTests, 'higherDimBlockTests') aliasTestResults <- test_coreRfeature_batch(aliasTests, 'aliasTests') ## basic seq_along test @@ -1097,7 +1096,7 @@ test_that('c(a, 1.1) in BUGS works', { a ~ dnorm(0,1) b[1:2] <- c(a, 1.1) }) - + m <- nimbleModel(mc, inits = list(a = 2)) expect_identical(as.numeric(m$b), c(2, 1.1)) m$b <- as.numeric(rep(NA, 2)) @@ -1129,7 +1128,7 @@ test_that('rep(a, 2) in BUGS works', { a ~ dnorm(0,1) b[1:2] <- rep(a, 2) }) - + m <- nimbleModel(mc, inits = list(a = 1.2)) expect_identical(as.numeric(m$b), c(1.2, 1.2)) m$b <- as.numeric(rep(NA, 2)) @@ -1159,7 +1158,7 @@ test_that('rep(1,2) in BUGS works', { test_that('2:3 in BUGS works', { mc <- nimbleCode({ - b[1:2] <- 2:3 + b[1:2] <- 2:3 }) m <- nimbleModel(mc) expect_equal(as.numeric(m$b), 2:3 ) diff --git a/nCompiler/tests/nimble/test-math.R b/nCompiler/tests/nimble/test-math.R index df44c7be..326c18fa 100644 --- a/nCompiler/tests/nimble/test-math.R +++ b/nCompiler/tests/nimble/test-math.R @@ -6,7 +6,7 @@ ## enter each test as a list, with an informative name, NIMBLE expression to evaluate, vector of input dimensions, value of output dimension, and (if NIMBLE expression cannot be directly evaluated in R) the equivalent pure R expression whose result should match the NIMBLE result library(nimble) -library(nCompiler) +#library(nCompiler) divert_to_nCompiler <- function(fun, replacements) { diversion_env <- list2env(replacements, parent = environment(fun)) @@ -18,7 +18,7 @@ source(system.file(file.path('tests', 'testthat', 'test_utils.R'), package = 'ni ## Changes start test_math_internal <- - divert_to_nCompiler(test_math_internal, list(compileNimble = nCompiler:::compileNimble)) + divert_to_nCompiler(test_math_internal, list(compileNimble = `:::`("nCompiler", "compileNimble"))) ## Changes stop #debug(nCompiler:::compileNimble) diff --git a/nCompiler/tests/testthat/cpp/repClass_tests.cpp b/nCompiler/tests/testthat/cpp/repClass_tests.cpp index b3577e0d..eb5ca9ac 100644 --- a/nCompiler/tests/testthat/cpp/repClass_tests.cpp +++ b/nCompiler/tests/testthat/cpp/repClass_tests.cpp @@ -24,3 +24,8 @@ Eigen::Tensor repClass_test4(Eigen::Tensor x, int length_o Eigen::Tensor repClass_test5(Eigen::Tensor x, int times) { return(repTimes(x, times)); } + +// [[Rcpp::export]] +Eigen::Tensor repClass_test6(Eigen::Tensor x) { + return(repTimes(x+x.exp(), 10)); +} diff --git a/nCompiler/tests/testthat/test-ETaccess.R b/nCompiler/tests/testthat/cpp_tests/test-ETaccess.R similarity index 100% rename from nCompiler/tests/testthat/test-ETaccess.R rename to nCompiler/tests/testthat/cpp_tests/test-ETaccess.R diff --git a/nCompiler/tests/testthat/test-StridedTensorMap.R b/nCompiler/tests/testthat/cpp_tests/test-StridedTensorMap.R similarity index 91% rename from nCompiler/tests/testthat/test-StridedTensorMap.R rename to nCompiler/tests/testthat/cpp_tests/test-StridedTensorMap.R index ffc868e7..a354fbb5 100644 --- a/nCompiler/tests/testthat/test-StridedTensorMap.R +++ b/nCompiler/tests/testthat/cpp_tests/test-StridedTensorMap.R @@ -3,7 +3,7 @@ test_that("basic uses of StridedTensorMap work",{ cppfile <- system.file( file.path('tests', 'testthat', 'cpp', 'StridedTensorMap_tests.cpp'), package = 'nCompiler') - test <- nCompiler:::QuietSourceCpp(cppfile) + test <- `:::`("nCompiler", "QuietSourceCpp")(cppfile) x <- array(1:(6*5*4), dim = c(6, 5, 4)) expect_equal(STM1(x), x[, 2:3, ][2, 2, 3]) expect_equal(STM2(x), x[, 2:3, ]) diff --git a/nCompiler/tests/testthat/test-as_wrap_Rcpp.R b/nCompiler/tests/testthat/cpp_tests/test-as_wrap_Rcpp.R similarity index 91% rename from nCompiler/tests/testthat/test-as_wrap_Rcpp.R rename to nCompiler/tests/testthat/cpp_tests/test-as_wrap_Rcpp.R index 358d48f1..ad271174 100644 --- a/nCompiler/tests/testthat/test-as_wrap_Rcpp.R +++ b/nCompiler/tests/testthat/cpp_tests/test-as_wrap_Rcpp.R @@ -4,7 +4,7 @@ library(Rcpp) message("basic as<> and wrap<> tests work but are not thorough and may be deprecated by argument passing tests.") test_that("basic use of as<> and wrap<> work. (Warning about no Rcpp::Export or RCPP_MODULE declarations is expected.)",{ cppfile <- system.file(file.path('tests', 'testthat', 'cpp', 'as_wrap_tests.cpp'), package = 'nCompiler') - test <- expect_warning(nCompiler:::QuietSourceCpp(cppfile)) + test <- expect_warning(`:::`("nCompiler", "QuietSourceCpp")(cppfile)) sofile <- { files <- list.files(test$buildDirectory) files[grepl("sourceCpp", files)][1] diff --git a/nCompiler/tests/testthat/test-indexing-cpp.R b/nCompiler/tests/testthat/cpp_tests/test-indexing-cpp.R similarity index 98% rename from nCompiler/tests/testthat/test-indexing-cpp.R rename to nCompiler/tests/testthat/cpp_tests/test-indexing-cpp.R index 823ff66b..997beb8f 100644 --- a/nCompiler/tests/testthat/test-indexing-cpp.R +++ b/nCompiler/tests/testthat/cpp_tests/test-indexing-cpp.R @@ -8,7 +8,7 @@ test_that("C++ code for indexing and chipping works", { cppfile <- system.file( file.path('tests', 'testthat', 'cpp', 'general_indexing_examples.cpp'), package = 'nCompiler') - nCompiler:::QuietSourceCpp(cppfile) + `:::`("nCompiler", "QuietSourceCpp")(cppfile) # warming up and making sure Rcpp works: # Should print: hello world. first element is 10 diff --git a/nCompiler/tests/testthat/test-repClass-cpp.R b/nCompiler/tests/testthat/cpp_tests/test-repClass-cpp.R similarity index 90% rename from nCompiler/tests/testthat/test-repClass-cpp.R rename to nCompiler/tests/testthat/cpp_tests/test-repClass-cpp.R index e988ccb3..d1ba33ba 100644 --- a/nCompiler/tests/testthat/test-repClass-cpp.R +++ b/nCompiler/tests/testthat/cpp_tests/test-repClass-cpp.R @@ -1,12 +1,13 @@ - library(Rcpp) test_that("basic uses of repClass work", { cppfile <- system.file(file.path('tests', 'testthat', 'cpp', 'repClass_tests.cpp'), package = 'nCompiler') - nCompiler:::QuietSourceCpp(cppfile) + `:::`("nCompiler", "QuietSourceCpp")(cppfile) expect_equivalent(repClass_test1(1:3), rep(1:3, 10)) expect_equivalent(repClass_test2(matrix(1:10, 5), 3), rep(matrix(1:10, 5), 3)) expect_equivalent(repClass_test3(1:3, 12), rep(1:3, length.out = 12)) expect_equivalent(repClass_test3(1:7, 4), rep(1:7, length.out = 4)) expect_equivalent(repClass_test4(array(1:12, c(2,3,2)), 7), rep(array(1:12, c(2,3,2)), length.out=7)) expect_equivalent(repClass_test5(matrix(1:16, 8), 3), rep(matrix(1:16, 8), 3)) + repClass_test6(1:3) + }) diff --git a/nCompiler/tests/testthat/test-seqClass-cpp.R b/nCompiler/tests/testthat/cpp_tests/test-seqClass-cpp.R similarity index 89% rename from nCompiler/tests/testthat/test-seqClass-cpp.R rename to nCompiler/tests/testthat/cpp_tests/test-seqClass-cpp.R index 5ff21bba..12827698 100644 --- a/nCompiler/tests/testthat/test-seqClass-cpp.R +++ b/nCompiler/tests/testthat/cpp_tests/test-seqClass-cpp.R @@ -5,7 +5,7 @@ library(Rcpp) test_that("basic uses of seqClass work",{ cppfile <- system.file(file.path('tests', 'testthat', 'cpp', 'seqClass_tests.cpp'), package = 'nCompiler') - nCompiler:::QuietSourceCpp(cppfile) + `:::`("nCompiler", "QuietSourceCpp")(cppfile) expect_equal(as.numeric(seqClass_test1(0, 10, 1)), 0:10) expect_equal(as.numeric(seqClass_test1(0, 10, 1.1)), seq(0, 10, 1.1)) }) diff --git a/nCompiler/tests/testthat/test-setWhich-cpp.R b/nCompiler/tests/testthat/cpp_tests/test-setWhich-cpp.R similarity index 91% rename from nCompiler/tests/testthat/test-setWhich-cpp.R rename to nCompiler/tests/testthat/cpp_tests/test-setWhich-cpp.R index 6a01e514..3e632951 100644 --- a/nCompiler/tests/testthat/test-setWhich-cpp.R +++ b/nCompiler/tests/testthat/cpp_tests/test-setWhich-cpp.R @@ -3,7 +3,7 @@ library(Rcpp) test_that("basic uses of setWhich work", { cppfile <- system.file(file.path('tests', 'testthat', 'cpp', 'setWhich_tests.cpp'), package = 'nCompiler') - nCompiler:::QuietSourceCpp(cppfile) + `:::`("nCompiler", "QuietSourceCpp")(cppfile) expect_equivalent(setWhich_test1(TRUE), which(TRUE)) expect_equivalent(setWhich_test1(FALSE), which(FALSE)) expect_equivalent(setWhich_test2(c(FALSE, FALSE)), which(c(FALSE, FALSE))) diff --git a/nCompiler/tests/testthat/test-math.R b/nCompiler/tests/testthat/math_tests/test-math.R similarity index 92% rename from nCompiler/tests/testthat/test-math.R rename to nCompiler/tests/testthat/math_tests/test-math.R index dc124f75..5c8fc4dc 100644 --- a/nCompiler/tests/testthat/test-math.R +++ b/nCompiler/tests/testthat/math_tests/test-math.R @@ -27,25 +27,25 @@ for (util_file in utils) source(util_file) ############# ## Overview of approach: -## +## ## We generate a (very) large set of testing pemutations, involving number of dimensions, ## scalar element type, and operators. For example, even for "+", we want ## double + double, integer + double, logical + double, logical + integer, etc. -## +## ## And we want all of those type combinations crossed with ## scalar + scalar, scalar + vector, scalar + matrix. vector + vector, etc. -## +## ## These configurations are contained in the math_test_params nested lists below. ## ## These create an issue of efficiency. To generate each test as a separate nFunction, compile and run it, takes a long time. ## We have two shortcuts: -## (i) We can combined multiple tests as different methods of an nClass. -## This reduces the number of DLLs generated and is much faster. We do this at -## two scales: combine all the tests for one operator into an nClass, or combine *ALL* tests for all -## operators into one very large (many method) nClass. These three choices are controlled by +## (i) We can combined multiple tests as different methods of an nClass. +## This reduces the number of DLLs generated and is much faster. We do this at +## two scales: combine all the tests for one operator into an nClass, or combine *ALL* tests for all +## operators into one very large (many method) nClass. These three choices are controlled by ## FULL_TESTING_GRANULARIY below -## (ii) If we have seen given generated C++ work correctly, and if any changes to our code do not result in -## different generated C++, and if there are no changes to any hard-coded C++, we can test simply +## (ii) If we have seen given generated C++ work correctly, and if any changes to our code do not result in +## different generated C++, and if there are no changes to any hard-coded C++, we can test simply ## whether generated C++ matches known, valid generated C++. We do this by comparing to "gold files" ## that we trust give valid results. This is called "gold file testing" as opposed to "full testing". ## Full testing includes compiling and running everything, comparing uncompiled to compiled results. @@ -109,12 +109,15 @@ math_test_params <- make_math_test_params(get_math_ops()) ## But these tests DO PASS. # Using 1:45 leaves out the pmin and pmax tests, which don't work +message("tests for pmin and pmax do not work and are omitted.") +message("test for %% is omitted.\n See handler tag allScalar=TRUE for backward compatbility with nimble.\n The test suite does not respect this so we get errors.\n Either restrict the test suite in this case or change handling of backward compatibility.") run_test_suite( - math_test_params[1:45], 'math', test_math, FULL_TESTING, + math_test_params[c(1:5,7:45)], 'math', test_math, FULL_TESTING, FULL_TESTING_GRANULARITY, write_gold_file = WRITE_GOLD_FILES, gold_file_dir ) + # FIXED: problem with 5: & -- seems like an Eigen quirk (C++ compile error)? # FIXED: same kind of problem with 14: | # FIXED: problem with 19: any (mismatch b/w R and C answers -- looks like a type issue?) @@ -140,13 +143,13 @@ run_test_suite( # known_compilation_failures <- lapply(math_test_params[[opName]], `[[`, 'compilation_failure') # known_runtime_failures <- lapply(math_test_params[[opName]], `[[`, 'runtime_failure') # cat(paste0("There are ", sum(unlist(known_compilation_failures)), " known compilation failures and ", -# sum(unlist(known_runtime_failures)), " known runtime failures.\n")) +# sum(unlist(known_runtime_failures)), " known runtime failures.\n")) # run_test_suite(math_test_params[opName], 'math', test_math, TRUE, 1, FALSE, NA) # } -# +# # ## Here is code to run a single case, such op 11 in the math_test_params # run_test_suite(list(test = math_test_params[[opName]][11]), 'math', test_math, TRUE, 1, FALSE, NA) -# +# # ## Here is code to run each case within the list for an op, one by one # for(j in seq_along(math_test_params[[opName]])) { # print(j) @@ -169,5 +172,3 @@ run_test_suite( # 2. We defensively gc() after each test to call finalizers while relevant DLL is loaded. # For logical operators, compilation tests come from (scalar, non-scalar) cases - - diff --git a/nCompiler/tests/testthat/test-recyclingRule.R b/nCompiler/tests/testthat/math_tests/test-recyclingRule.R similarity index 100% rename from nCompiler/tests/testthat/test-recyclingRule.R rename to nCompiler/tests/testthat/math_tests/test-recyclingRule.R diff --git a/nCompiler/tests/testthat/test-recycling_rule.R b/nCompiler/tests/testthat/math_tests/test-recycling_rule.R similarity index 100% rename from nCompiler/tests/testthat/test-recycling_rule.R rename to nCompiler/tests/testthat/math_tests/test-recycling_rule.R diff --git a/nCompiler/tests/testthat/math_utils.R b/nCompiler/tests/testthat/math_utils.R index ab39f6eb..ab6d7af8 100644 --- a/nCompiler/tests/testthat/math_utils.R +++ b/nCompiler/tests/testthat/math_utils.R @@ -93,7 +93,7 @@ test_math <- function(base_list, verbose = nOptions('verbose'), ## op: operator name ## make_math_test_params_one_op <- function(op) { - opInfo <- nCompiler:::getOperatorDef(op, 'testing') + opInfo <- `:::`("nCompiler", "getOperatorDef")(op, 'testing') if (is.null(opInfo) || is.null(opInfo[['math_argTypes']])) return(NULL) argTypes <- opInfo[['math_argTypes']] known_failures <- opInfo$known_failures diff --git a/nCompiler/tests/testthat/test-nClass_constructor.R b/nCompiler/tests/testthat/nClass_tests/test-nClass_constructor.R similarity index 99% rename from nCompiler/tests/testthat/test-nClass_constructor.R rename to nCompiler/tests/testthat/nClass_tests/test-nClass_constructor.R index ad9ff2cf..6ad6109b 100644 --- a/nCompiler/tests/testthat/test-nClass_constructor.R +++ b/nCompiler/tests/testthat/nClass_tests/test-nClass_constructor.R @@ -1,4 +1,4 @@ -library(nCompiler) +#library(nCompiler) library(testthat) test_that("nClass constructor works", { diff --git a/nCompiler/tests/testthat/test-nClass_destructor.R b/nCompiler/tests/testthat/nClass_tests/test-nClass_destructor.R similarity index 100% rename from nCompiler/tests/testthat/test-nClass_destructor.R rename to nCompiler/tests/testthat/nClass_tests/test-nClass_destructor.R diff --git a/nCompiler/tests/testthat/test-nClass_inherit.R b/nCompiler/tests/testthat/nClass_tests/test-nClass_inherit.R similarity index 99% rename from nCompiler/tests/testthat/test-nClass_inherit.R rename to nCompiler/tests/testthat/nClass_tests/test-nClass_inherit.R index b8dc81f3..7c93f795 100644 --- a/nCompiler/tests/testthat/test-nClass_inherit.R +++ b/nCompiler/tests/testthat/nClass_tests/test-nClass_inherit.R @@ -1,10 +1,11 @@ - -library(nCompiler) +#library(nCompiler) message("uncompiled nClass Cpublic variables are not initialized well") message("Using inheritance for nClasses with serialization needs fixing.") message("See comments in test-nClass_inherit.R for more notes.") +## See also test-nClass_nested + # With inheritcance, we DO NOT support interfacing to both base class and derived class. # Only the most derived class should have interface = "generic" or "base". # Any class to be used as a base class should have interface = "none". diff --git a/nCompiler/tests/testthat/test-nClass_interface.R b/nCompiler/tests/testthat/nClass_tests/test-nClass_interface.R similarity index 100% rename from nCompiler/tests/testthat/test-nClass_interface.R rename to nCompiler/tests/testthat/nClass_tests/test-nClass_interface.R diff --git a/nCompiler/tests/testthat/nClass_tests/test-nClass_nested.R b/nCompiler/tests/testthat/nClass_tests/test-nClass_nested.R new file mode 100644 index 00000000..799c149b --- /dev/null +++ b/nCompiler/tests/testthat/nClass_tests/test-nClass_nested.R @@ -0,0 +1,102 @@ +# Tests of nClasses holding, passing and use each other. + +#library(nCompiler); library(testthat) +test_that("One nClass holds another and uses it", { + nc_inner <- nClass( + 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', + init = nFunction(function() {my_inner = nc_inner$new()}), + get_inner = nFunction(function() {return(my_inner)}, returnType = 'nc_inner'), + inner_x_p1 = nFunction(function() {return(my_inner$x+1)}, returnType='numericScalar') + ) + ) + comp <- nCompile(nc_inner, nc_outer, package = TRUE) + 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")) + + inner_obj$x <- 10 + expect_equal(obj$get_inner()$x, 10) + expect_equal(obj$inner_x_p1(), 11) + rm(obj, inner_obj) + gc() +}) + +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') + } + ) + ), + 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') + ) + ) + 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")) + + obj$my_A + obj$initA() + obj$my_A + obj$useA() + + 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) + + 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() +}) diff --git a/nCompiler/tests/testthat/test-nClass_uncompiled.R b/nCompiler/tests/testthat/nClass_tests/test-nClass_uncompiled.R similarity index 77% rename from nCompiler/tests/testthat/test-nClass_uncompiled.R rename to nCompiler/tests/testthat/nClass_tests/test-nClass_uncompiled.R index 122cd190..4dd3608a 100644 --- a/nCompiler/tests/testthat/test-nClass_uncompiled.R +++ b/nCompiler/tests/testthat/nClass_tests/test-nClass_uncompiled.R @@ -28,8 +28,8 @@ test_that("nClass basics", expect_equal(nc1$.nCompiler$symbolTable$getSymbol("Cv")$nDim, 0) expect_true(isNC(my.nc1)) expect_true(isNCgenerator(nc1)) - expect_error(inherits(nCompiler:::NCinternals(my.nc1), "NC_InternalsClass")) - expect_true(inherits(nCompiler:::NCinternals(nc1), "NC_InternalsClass")) - expect_equal(nCompiler:::NCinternals(nc1)$methodNames, 'Cfoo') + expect_error(inherits(NCinternals(my.nc1), "NC_InternalsClass")) + expect_true(inherits(NCinternals(nc1), "NC_InternalsClass")) + expect_equal(NCinternals(nc1)$methodNames, 'Cfoo') } ) diff --git a/nCompiler/tests/testthat/test-Rcpp_nCompilerPacket.R b/nCompiler/tests/testthat/nCompile_tests/test-Rcpp_nCompilerPacket.R similarity index 93% rename from nCompiler/tests/testthat/test-Rcpp_nCompilerPacket.R rename to nCompiler/tests/testthat/nCompile_tests/test-Rcpp_nCompilerPacket.R index 5a860baa..c1e1cea3 100644 --- a/nCompiler/tests/testthat/test-Rcpp_nCompilerPacket.R +++ b/nCompiler/tests/testthat/nCompile_tests/test-Rcpp_nCompilerPacket.R @@ -1,7 +1,7 @@ test_that("basics", { - cpp1 <- nCompiler:::Rcpp_nCompilerPacket( + cpp1 <- `:::`("nCompiler", "Rcpp_nCompilerPacket")( filebase = "cpp1", cppContent = list(opener = "", body = paste( diff --git a/nCompiler/tests/testthat/test-argumentPassing.R b/nCompiler/tests/testthat/nCompile_tests/test-argumentPassing.R similarity index 90% rename from nCompiler/tests/testthat/test-argumentPassing.R rename to nCompiler/tests/testthat/nCompile_tests/test-argumentPassing.R index 5fb18556..d6baf772 100644 --- a/nCompiler/tests/testthat/test-argumentPassing.R +++ b/nCompiler/tests/testthat/nCompile_tests/test-argumentPassing.R @@ -5,7 +5,7 @@ # for different kinds of numeric objects library(testthat) -library(nCompiler) +#library(nCompiler) message("More test coverage of argument passing cases is needed. See comments.") # need cases of multiple function call layers @@ -14,6 +14,27 @@ message("doing scalar = vector + scalar does not error out if the vector in leng message("blockRef error trapping can be more involved -- using dims.") message("blockRef cannot cross between scalar types") +# This is a workaround to pkg_name::var. +# This is necessary because on GitHub Actions for testing, we use +# `setup-r-dependencies`. This **aggressively** checks **all** directories +# in the package structure and identifies **all** pkg::var code +# and then attempts to install a package called "pkg". +# Here we are dynamically generating packages, e.g. nc1Package, +# 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) +} + +# Same rationale as above: +load_dynamic_namespace <- function(pkg_name) { + eval(call("loadNamespace", pkg_name)) +} + # compiled and uncompiled 1D by copy # A lot of this is tested elsewhere, so here it is not thorough # and is more of a warm-up test. @@ -83,9 +104,9 @@ test_that("pass 1D by ref and blockRef works and error-traps (compiled & uncompi 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, loadNamespace("testpackage")) - test_foo(testpackage::foo) - test_foo(testpackage::foo) + withr::with_libpaths(lib, 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)", { @@ -139,8 +160,8 @@ test_that("pass 1D by ref and blockRef works and error-traps via nClass method ( 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, loadNamespace("testpackage")) - Cobj <- testpackage::nc1$new() + withr::with_libpaths(lib, load_dynamic_namespace("testpackage")) + Cobj <- access_dynamic_package("testpackage", "nc1")$new() test_foo(Cobj$foo) CppObj <- Cobj$private$CppObj test_foo(method(CppObj, "foo")) @@ -193,7 +214,7 @@ test_that("pass 2D by ref and blockRef works and error-traps (compiled & uncompi 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, loadNamespace("testpackage")) + withr::with_libpaths(lib, load_dynamic_namespace("testpackage")) test_foo(testpackage::foo) test_foo(testpackage::foo) }) @@ -255,7 +276,7 @@ test_that("pass 2D by ref and blockRef works and error-traps via nClass method ( 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, loadNamespace("testpackage")) + withr::with_libpaths(lib, load_dynamic_namespace("testpackage")) Cobj <- testpackage::nc1$new() test_foo(Cobj$foo) CppObj <- Cobj$private$CppObj @@ -309,7 +330,7 @@ test_that("pass 3D by ref and blockRef works and error-traps (compiled & uncompi 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, loadNamespace("testpackage")) + withr::with_libpaths(lib, load_dynamic_namespace("testpackage")) test_foo(testpackage::foo) test_foo(testpackage::foo) }) @@ -372,7 +393,7 @@ test_that("pass 2D by ref and blockRef works and error-traps via nClass method ( 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, loadNamespace("testpackage")) + withr::with_libpaths(lib, load_dynamic_namespace("testpackage")) Cobj <- testpackage::nc1$new() test_foo(Cobj$foo) CppObj <- Cobj$private$CppObj diff --git a/nCompiler/tests/testthat/test-callingBetweenNFs.R b/nCompiler/tests/testthat/nCompile_tests/test-callingBetweenNFs.R similarity index 98% rename from nCompiler/tests/testthat/test-callingBetweenNFs.R rename to nCompiler/tests/testthat/nCompile_tests/test-callingBetweenNFs.R index 7cddc163..c51c7049 100644 --- a/nCompiler/tests/testthat/test-callingBetweenNFs.R +++ b/nCompiler/tests/testthat/nCompile_tests/test-callingBetweenNFs.R @@ -1,7 +1,7 @@ message("callingBetweenNFs tests pass but are quite old and may be deprecated by general nCompile tests.") test_that("One nFunction can call another and be compiled.", - { + { f1 <- nFunction( fun = function(x = double(0), y = double(0)) { @@ -21,12 +21,13 @@ test_that("One nFunction can call another and be compiled.", ## debug(nCompiler:::compile_labelAbstractTypes) # set_nOption("showCompilerOutput", TRUE) test <- nCompile(f2, f1) + expect_equal(test$f1(2, 3), 5) expect_equal(test$f2(2, 3), 5) }) test_that("One nFunction can call another with non-scalar and be compiled.", - { + { f1 <- nFunction( fun = function(x = double(1), y = double(1)) { @@ -48,4 +49,3 @@ test_that("One nFunction can call another with non-scalar and be compiled.", expect_equal(test$f1(1:3, 11:13), ((1:3)+(11:13))) expect_equal(test$f2(1:3, 11:13), ((1:3)+(11:13))) }) - diff --git a/nCompiler/tests/testthat/test-compileErrorTrapping.R b/nCompiler/tests/testthat/nCompile_tests/test-compileErrorTrapping.R similarity index 88% rename from nCompiler/tests/testthat/test-compileErrorTrapping.R rename to nCompiler/tests/testthat/nCompile_tests/test-compileErrorTrapping.R index c35db1e3..a70db33a 100644 --- a/nCompiler/tests/testthat/test-compileErrorTrapping.R +++ b/nCompiler/tests/testthat/nCompile_tests/test-compileErrorTrapping.R @@ -7,7 +7,7 @@ test_that("nCompiler's error handler works", } go <- function() { - nCompiler:::NFtry({ + `:::`("nCompiler", "NFtry")({ doSomething(5) }) } diff --git a/nCompiler/tests/testthat/test-compileNimble.R b/nCompiler/tests/testthat/nCompile_tests/test-compileNimble.R similarity index 79% rename from nCompiler/tests/testthat/test-compileNimble.R rename to nCompiler/tests/testthat/nCompile_tests/test-compileNimble.R index 40d8fff7..04a94ee8 100644 --- a/nCompiler/tests/testthat/test-compileNimble.R +++ b/nCompiler/tests/testthat/nCompile_tests/test-compileNimble.R @@ -3,7 +3,7 @@ ## The real tests will be running nimble's test suite. library(nimble) -library(nCompiler) +#library(nCompiler) library(testthat) test_that("compileNimble bridge works for simple nimbleFunction (RC function)",{ @@ -14,7 +14,7 @@ test_that("compileNimble bridge works for simple nimbleFunction (RC function)",{ returnType(double()) } ) - CRCF1 <- nCompiler:::compileNimble(RCF1) + CRCF1 <- `:::`("nCompiler", "compileNimble")(RCF1) expect_equal(CRCF1(1:3), 6) }) @@ -40,7 +40,11 @@ test_that("registering a user-defined operator definition (opDef) works", { code$name <- 'nArray' NULL } - nCompiler:::registerOpDef( + # This test works by: + # providing a handler to relpace "nimArray" with "nArray" + # and a handler to replace "nimArray2" with "nArray" to + # check on handling multiple cases. + registerOpDef( list(nimArray = list( matchDef = function(value=0, dim=c(1,1), init=TRUE, @@ -48,9 +52,9 @@ test_that("registering a user-defined operator definition (opDef) works", { type="double") {}, # normalizeCalls=list(handler='skip'), simpleTransformations=list(handler = nimArrayHandler)))) - expect_equal(ls(nCompiler:::operatorDefUserEnv), "nimArray") + expect_equal(ls(`:::`("nCompiler", "operatorDefUserEnv")), "nimArray") - nCompiler:::registerOpDef( + registerOpDef( list(nimArray2 = list( matchDef = function(value=0, dim=c(1,1), init=TRUE, @@ -58,7 +62,7 @@ test_that("registering a user-defined operator definition (opDef) works", { type="double") {}, simpleTransformations=list(handler = 'replace', replacement = 'nArray')))) - expect_equal(ls(nCompiler:::operatorDefUserEnv), c("nimArray", "nimArray2")) + expect_equal(ls(`:::`("nCompiler", "operatorDefUserEnv")), c("nimArray", "nimArray2")) nc <- nClass( Cpublic = list( @@ -83,7 +87,7 @@ test_that("registering a user-defined operator definition (opDef) works", { expect_identical(obj$foo2(), c(3, 3)) rm(obj); gc() # - nCompiler:::deregisterOpDef("nimArray") - nCompiler:::deregisterOpDef("nimArray2") - expect_equal(length(ls(nCompiler:::operatorDefUserEnv)), 0) + deregisterOpDef("nimArray") + deregisterOpDef("nimArray2") + expect_equal(length(ls(`:::`("nCompiler", "operatorDefUserEnv"))), 0) }) diff --git a/nCompiler/tests/testthat/test-cppLiteral.R b/nCompiler/tests/testthat/nCompile_tests/test-cppLiteral.R similarity index 100% rename from nCompiler/tests/testthat/test-cppLiteral.R rename to nCompiler/tests/testthat/nCompile_tests/test-cppLiteral.R diff --git a/nCompiler/tests/testthat/test-eigenShapeFlex.R b/nCompiler/tests/testthat/nCompile_tests/test-eigenShapeFlex.R similarity index 100% rename from nCompiler/tests/testthat/test-eigenShapeFlex.R rename to nCompiler/tests/testthat/nCompile_tests/test-eigenShapeFlex.R diff --git a/nCompiler/tests/testthat/v1tests/test-indexing.R b/nCompiler/tests/testthat/nCompile_tests/test-indexing.R similarity index 98% rename from nCompiler/tests/testthat/v1tests/test-indexing.R rename to nCompiler/tests/testthat/nCompile_tests/test-indexing.R index 7f1386fe..102dd2ce 100644 --- a/nCompiler/tests/testthat/v1tests/test-indexing.R +++ b/nCompiler/tests/testthat/nCompile_tests/test-indexing.R @@ -1,5 +1,9 @@ message("test-indexing works but there are disabled tests at the end waiting for better error trapping to test error trapping.") +## Tests to add: +## indexing by numeric vector for higher dimensional objects and for multiple indexing dimensions at once. +## setting option nimble=TRUE or the component options TRUE + test_that("indexing by numeric vector works", { nC <- nClass( Cpublic = list( diff --git a/nCompiler/tests/testthat/test-nCompile.R b/nCompiler/tests/testthat/nCompile_tests/test-nCompile.R similarity index 86% rename from nCompiler/tests/testthat/test-nCompile.R rename to nCompiler/tests/testthat/nCompile_tests/test-nCompile.R index 71298998..54d45a6b 100644 --- a/nCompiler/tests/testthat/test-nCompile.R +++ b/nCompiler/tests/testthat/nCompile_tests/test-nCompile.R @@ -18,6 +18,28 @@ message("add test for control$changeKeywords") # For C, one needs control of the exported R names, perhaps to be called compiledName and defaulting to name. # Return object of nCompile(package = TRUE) needs attention. + +# This is a workaround to pkg_name::var. +# This is necessary because on GitHub Actions for testing, we use +# `setup-r-dependencies`. This **aggressively** checks **all** directories +# in the package structure and identifies **all** pkg::var code +# and then attempts to install a package called "pkg". +# Here we are dynamically generating packages, e.g. nc1Package, +# 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) +} + +# Same rationale as above: +load_dynamic_namespace <- function(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), @@ -40,8 +62,8 @@ test_that("nCompile direct, package, and writePackage work with Eigen::Tensors", 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, loadNamespace("testpackage")) - expect_equal(x1+x2, testpackage::add_vectors(x1, x2)) + withr::with_libpaths(lib, load_dynamic_namespace("testpackage")) + expect_equal(x1+x2, access_dynamic_package("testpackage", "add_vectors")(x1, x2)) # testpackage::add_vectors(x1, x2)) pkgload::unload("testpackage") }) @@ -90,8 +112,8 @@ test_that("nCompile direct, package, and writePackage work with nClass interface 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, loadNamespace("testpackage")) - obj <- testpackage::nc$new() + withr::with_libpaths(lib, 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)) @@ -103,8 +125,8 @@ test_that("nCompile direct, package, and writePackage work with nClass interface 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, loadNamespace("testpackage")) - CppObj <- testpackage::nc() + withr::with_libpaths(lib, 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)) @@ -163,8 +185,8 @@ test_that("nCompile direct, package, and writePackage work with various name man 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, loadNamespace("testpackage")) - expect_equal(testpackage::add.Scalars(2, 3), 5) + withr::with_libpaths(lib, 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) @@ -178,8 +200,8 @@ test_that("nCompile direct, package, and writePackage work with various name man 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, loadNamespace("testpackage")) - expect_equal(testpackage::add.Scalars_name(2, 3), 5) + withr::with_libpaths(lib, 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) @@ -193,8 +215,8 @@ test_that("nCompile direct, package, and writePackage work with various name man 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, loadNamespace("testpackage")) - expect_equal(testpackage::foo1(2, 3), 5) + withr::with_libpaths(lib, 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) @@ -208,8 +230,8 @@ test_that("nCompile direct, package, and writePackage work with various name man 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, loadNamespace("testpackage")) - expect_equal(testpackage::foo2(2, 3), 5) + withr::with_libpaths(lib, load_dynamic_namespace("testpackage")) + expect_equal(access_dynamic_package("testpackage", "foo2")(2, 3), 5) # testpackage::foo2(2, 3), 5) pkgload::unload("testpackage") }) @@ -267,7 +289,7 @@ test_that("nCompile works for nClass with classname and/or exportName and either ) test_obj <- function(obj) { - if(nCompiler:::is.loadedObjectEnv(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)) @@ -309,8 +331,8 @@ test_that("nCompile works for nClass with classname and/or exportName and either 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, loadNamespace("testpackage")) - obj <- testpackage::nc(); test_obj(obj) + withr::with_libpaths(lib, 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") @@ -322,8 +344,8 @@ test_that("nCompile works for nClass with classname and/or exportName and either 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, loadNamespace("testpackage")) - obj <- testpackage::nc$new(); test_obj(obj) + withr::with_libpaths(lib, 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() @@ -360,8 +382,8 @@ test_that("nCompile works for nClass with classname and/or exportName and either 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, loadNamespace("testpackage")) - obj <- testpackage::nc_name(); test_obj(obj) + withr::with_libpaths(lib, 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") @@ -373,8 +395,8 @@ test_that("nCompile works for nClass with classname and/or exportName and either 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, loadNamespace("testpackage")) - obj <- testpackage::nc_name$new(); test_obj(obj) + withr::with_libpaths(lib, 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") @@ -412,8 +434,8 @@ test_that("nCompile works for nClass with classname and/or exportName and either 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, loadNamespace("testpackage")) - obj <- testpackage::exnc1(); test_obj(obj) + withr::with_libpaths(lib, 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") @@ -425,8 +447,8 @@ test_that("nCompile works for nClass with classname and/or exportName and either 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, loadNamespace("testpackage")) - obj <- testpackage::exnc1$new(); test_obj(obj) + withr::with_libpaths(lib, 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") @@ -463,8 +485,8 @@ test_that("nCompile works for nClass with classname and/or exportName and either 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, loadNamespace("testpackage")) - obj <- testpackage::exnc2(); test_obj(obj) + withr::with_libpaths(lib, 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") @@ -476,14 +498,14 @@ test_that("nCompile works for nClass with classname and/or exportName and either 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, loadNamespace("testpackage")) - obj <- testpackage::exnc2$new(); test_obj(obj) + 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") }) 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), @@ -502,7 +524,7 @@ test_that("Compile one nFunction via nCompile, returning a list (and testing ext ) 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), @@ -517,7 +539,7 @@ test_that("Compile one nFunction via nCompile, not returning a list (and testing }) test_that("Compile two nFunctions via nCompile, returning a list.", -{ +{ addScalars <- nFunction( fun = function(x = double(0), y = double(0)) { @@ -541,7 +563,7 @@ test_that("Compile two nFunctions via nCompile, returning a list.", ) test_that("Compile two nFunctions via nCompile provided as a list, returning a list.", -{ +{ addScalars <- nFunction( fun = function(x = double(0), y = double(0)) { @@ -593,13 +615,13 @@ test_that("nCompile naming and interface choices work in various ways", x = 'numericScalar' ) ) - + nc2 <- nClass( Cpublic = list( y = 'numericScalar' ) ) - + nc3 <- nClass( Cpublic = list( z = 'numericScalar' @@ -612,7 +634,7 @@ test_that("nCompile naming and interface choices work in various ways", 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") @@ -650,21 +672,21 @@ test_that("nCompile naming and interface choices work in various ways", expect_true(class(comp$nc1())=="loadedObjectEnv") expect_true(class(comp$nc2())=="loadedObjectEnv") expect_true(class(comp$nc3())=="loadedObjectEnv") - - # Move on to nFunctions + + # 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()) @@ -694,16 +716,16 @@ test_that("nCompile naming and interface choices work in various ways", 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 + 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)) + 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) + 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)) @@ -809,7 +831,7 @@ test_that("manual C++ pieces in nFunction work", { ) }) -library(nCompiler); library(testthat) +#library(nCompiler); library(testthat) test_that("nCompile for nClass with compileInfo$createFromR=FALSE works", { nc_inner <- nClass( classname = "nc_inner", @@ -846,3 +868,38 @@ test_that("nCompile for nClass with compileInfo$createFromR=FALSE works", { ## 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. +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)) +}) diff --git a/nCompiler/tests/testthat/test-nCompile_deps.R b/nCompiler/tests/testthat/nCompile_tests/test-nCompile_deps.R similarity index 99% rename from nCompiler/tests/testthat/test-nCompile_deps.R rename to nCompiler/tests/testthat/nCompile_tests/test-nCompile_deps.R index 90585dcc..24e2f569 100644 --- a/nCompiler/tests/testthat/test-nCompile_deps.R +++ b/nCompiler/tests/testthat/nCompile_tests/test-nCompile_deps.R @@ -29,7 +29,7 @@ # These tests also attempt to cover mixes of needing Eigen or not in one or the other part of # the dependency. -library(nCompiler) +#library(nCompiler) library(testthat) #nOptions(showCompilerOutput=TRUE) #nOptions(showCompilerOutput=FALSE) diff --git a/nCompiler/tests/testthat/test-nList.R b/nCompiler/tests/testthat/nCompile_tests/test-nList.R similarity index 100% rename from nCompiler/tests/testthat/test-nList.R rename to nCompiler/tests/testthat/nCompile_tests/test-nList.R diff --git a/nCompiler/tests/testthat/serialization_test_in_new_R_session.R b/nCompiler/tests/testthat/serialization_test_in_new_R_session.R index 3b36298d..395bb2ff 100644 --- a/nCompiler/tests/testthat/serialization_test_in_new_R_session.R +++ b/nCompiler/tests/testthat/serialization_test_in_new_R_session.R @@ -1,4 +1,4 @@ -library(nCompiler) +#library(nCompiler) library(testthat) args <- R.utils::cmdArgs() if(!is.null(args$pkgName)) diff --git a/nCompiler/tests/testthat/test-serialization.R b/nCompiler/tests/testthat/serialization_tests/test-serialization.R similarity index 85% rename from nCompiler/tests/testthat/test-serialization.R rename to nCompiler/tests/testthat/serialization_tests/test-serialization.R index e49ba07d..0874572c 100644 --- a/nCompiler/tests/testthat/test-serialization.R +++ b/nCompiler/tests/testthat/serialization_tests/test-serialization.R @@ -1,4 +1,4 @@ -library(nCompiler) +#library(nCompiler) library(testthat) message("There will be a problem with serialization and pre-defined nClasses.\n", @@ -19,6 +19,27 @@ message('Need to tetst interactions between serialization and nClass inheritance old_serialize_option <- get_nOption("serialize") set_nOption("serialize", TRUE) +# This is a workaround to pkg_name::var. +# This is necessary because on GitHub Actions for testing, we use +# `setup-r-dependencies`. This **aggressively** checks **all** directories +# in the package structure and identifies **all** pkg::var code +# and then attempts to install a package called "pkg". +# Here we are dynamically generating packages, e.g. nc1Package, +# 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) +} + +# Same rationale as above: +load_dynamic_namespace <- function(pkg_name) { + eval(call("loadNamespace", pkg_name)) +} + in_new_R_session <- function(code, pkgName, lib, @@ -39,7 +60,7 @@ in_new_R_session <- function(code, dir.create(outdir) } } - + codefile <- file.path(outdir, "testing_code_.R") writeLines(deparse(code), con = codefile) @@ -116,14 +137,17 @@ test_that("Basic serialization works (via writePackage, with generic interface, { devtools::install(file.path(tempdir(), "nc1Package"), quiet=TRUE, upgrade = "never", quick=TRUE) - loadNamespace("nc1Package") + # more evasion of setup-r-dependencies used in CI testing. + # Write loadNamespace("nc1Package") indirectly so it + # doesn't think nc1Package is a CRAN package + load_dynamic_namespace("nc1Package") } ) ## serialize and deserialize 1 object # build and test object - obj <- nc1Package::nc1() - expect_true(nCompiler:::is.loadedObjectEnv(obj)) + obj <- access_dynamic_package("nc1Package", "nc1")() + expect_true(`:::`("nCompiler", "is.loadedObjectEnv")(obj)) expect_equal(method(obj, "Cfoo")(1.2), 2.2) value(obj, "C.v") <- 1.23 expect_equal(value(obj, "C.v"), 1.23) @@ -136,7 +160,7 @@ test_that("Basic serialization works (via writePackage, with generic interface, restored_obj <- nUnserialize(serialized_obj) # test the restored objected - expect_true(nCompiler:::is.loadedObjectEnv(restored_obj)) + expect_true(`:::`("nCompiler", "is.loadedObjectEnv")(restored_obj)) expect_equal(method(restored_obj, "Cfoo")(1.2), 2.2) expect_equal(value(restored_obj, "C.v"), 1.23) value(restored_obj, "C.v") <- 2.34 @@ -145,10 +169,10 @@ test_that("Basic serialization works (via writePackage, with generic interface, # done # serialize and deserialize 3 objects - obj2 <- nc1Package::nc1() + obj2 <- access_dynamic_package("nc1Package","nc1")() value(obj2, "C.v") <- -8.5 value(obj2, "C.x") <- -100 - obj3 <- nc1Package::nc1() + obj3 <- access_dynamic_package("nc1Package","nc1")() value(obj3, "C.x") <- 2134 serialized_objlist <- nSerialize(list(obj, obj2, obj3)) restored_objlist <- nUnserialize(serialized_objlist, "nc1Package") # alt mode of providing package @@ -210,7 +234,7 @@ test_that("Basic serialization works (via nCompile(package=TRUE), with generic i ## serialize and deserialize 1 object # build and test object obj <- nc1gen() - expect_true(nCompiler:::is.loadedObjectEnv(obj)) + expect_true(`:::`("nCompiler", "is.loadedObjectEnv")(obj)) expect_equal(method(obj, "Cfoo")(1.2), 2.2) value(obj, "Cv") <- 1.23 expect_equal(value(obj, "Cv"), 1.23) @@ -223,7 +247,7 @@ test_that("Basic serialization works (via nCompile(package=TRUE), with generic i restored_obj <- nUnserialize(serialized_obj) # test the restored objected - expect_true(nCompiler:::is.loadedObjectEnv(restored_obj)) + expect_true(`:::`("nCompiler", "is.loadedObjectEnv")(restored_obj)) expect_equal(method(restored_obj, "Cfoo")(1.2), 2.2) expect_equal(value(restored_obj, "Cv"), 1.23) value(restored_obj, "Cv") <- 2.34 @@ -307,14 +331,17 @@ test_that("Basic serialization works (via writePackage, with full interface, for { devtools::install(file.path(tempdir(), "nc1PackageB"), quiet=TRUE, upgrade = "never", quick=TRUE, force=TRUE) - loadNamespace("nc1PackageB") + # more evasion of setup-r-dependencies used in CI testing. + # Write loadNamespace("nc1PackageB") indirectly so it + # doesn't think nc1PackageB is a CRAN package + load_dynamic_namespace("nc1PackageB") } ) ## serialize and deserialize 1 object # build and test object - obj <- nc1PackageB::nc1$new() - expect_true(nCompiler:::is.loadedObjectEnv(obj$private$CppObj)) + obj <- access_dynamic_package("nc1PackageB", "nc1")$new() #nc1PackageB::nc1$new() + expect_true(`:::`("nCompiler", "is.loadedObjectEnv")(obj$private$CppObj)) expect_equal(obj$Cfoo(1.2), 2.2) obj$Cv <- 1.23 expect_equal(obj$Cv, 1.23) @@ -327,7 +354,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")(restored_obj$private$CppObj)) expect_equal(restored_obj$Cfoo(1.2), 2.2) expect_equal(restored_obj$Cv, 1.23) restored_obj$Cv <- 2.34 @@ -336,10 +363,10 @@ test_that("Basic serialization works (via writePackage, with full interface, for # done # serialize and deserialize 3 objects - obj2 <- nc1PackageB::nc1$new() + obj2 <- access_dynamic_package("nc1PackageB", "nc1")$new() # nc1PackageB::nc1$new() obj2$Cv <- -8.5 obj2$Cx <- -100 - obj3 <- nc1PackageB::nc1$new() + obj3 <- access_dynamic_package("nc1PackageB", "nc1")$new() # nc1PackageB::nc1$new() obj3$Cx <- 2134 serialized_objlist <- nSerialize(list(obj, obj2, obj3)) restored_objlist <- nUnserialize(serialized_objlist, "nc1PackageB") # alt mode of providing package @@ -401,7 +428,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")(obj$private$CppObj)) expect_equal(obj$Cfoo(1.2), 2.2) obj$Cv <- 1.23 expect_equal(obj$Cv, 1.23) @@ -414,7 +441,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")(restored_obj$private$CppObj)) 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/test-rep.R b/nCompiler/tests/testthat/specificOp_tests/test-rep.R similarity index 100% rename from nCompiler/tests/testthat/test-rep.R rename to nCompiler/tests/testthat/specificOp_tests/test-rep.R diff --git a/nCompiler/tests/testthat/test-seq.R b/nCompiler/tests/testthat/specificOp_tests/test-seq.R similarity index 100% rename from nCompiler/tests/testthat/test-seq.R rename to nCompiler/tests/testthat/specificOp_tests/test-seq.R diff --git a/nCompiler/tests/testthat/test-which.R b/nCompiler/tests/testthat/specificOp_tests/test-which.R similarity index 100% rename from nCompiler/tests/testthat/test-which.R rename to nCompiler/tests/testthat/specificOp_tests/test-which.R diff --git a/nCompiler/tests/testthat/test-tensorCreation.R b/nCompiler/tests/testthat/tensorOps_tests/test-tensorCreation.R similarity index 98% rename from nCompiler/tests/testthat/test-tensorCreation.R rename to nCompiler/tests/testthat/tensorOps_tests/test-tensorCreation.R index 9dde08cc..783bc952 100644 --- a/nCompiler/tests/testthat/test-tensorCreation.R +++ b/nCompiler/tests/testthat/tensorOps_tests/test-tensorCreation.R @@ -4,7 +4,7 @@ message("Need to add a test of creating a tensor initialized from a refBlock (St test_that("tensor creation C++ implementation works", { library(Rcpp) cppfile <- system.file(file.path('tests', 'testthat', 'cpp', 'tensorCreation_tests.cpp'), package = 'nCompiler') - test <- nCompiler:::QuietSourceCpp(cppfile) + test <- `:::`("nCompiler", "QuietSourceCpp")(cppfile) expect_equivalent(tensorCreation1(1, 10), rep(1, 10)) expect_equal(tensorCreation2(1:6), matrix(1:6, 2)) expect_equal(tensorCreation3(1:12), array(1:12, c(2, 3, 2))) diff --git a/nCompiler/tests/testthat/test-tensorOperations_accessors.R b/nCompiler/tests/testthat/tensorOps_tests/test-tensorOperations_accessors.R similarity index 93% rename from nCompiler/tests/testthat/test-tensorOperations_accessors.R rename to nCompiler/tests/testthat/tensorOps_tests/test-tensorOperations_accessors.R index 005e6ca8..4aa11511 100644 --- a/nCompiler/tests/testthat/test-tensorOperations_accessors.R +++ b/nCompiler/tests/testthat/tensorOps_tests/test-tensorOperations_accessors.R @@ -1,11 +1,11 @@ -library(nCompiler) +#library(nCompiler) library(testthat) library(Matrix) message("Diag testing (in accessors) might lack the case of diag(matrix)") # -# test the ability to read/write using nCompiler C++ implementations of diag(), +# test the ability to read/write using nCompiler C++ implementations of diag(), # and related accessor functions # cDiagXv cSpDiagXv have errors in eigenization @@ -42,10 +42,10 @@ diag(Xsp)[sample(x = nrow(Xsp), size = .1 * nrow(Xsp))] <- 3 # diag as a creation operator # -# Documenting many of R's behaviors for diag(). There are a few other cases -# where x may be either a scalar or a vector, expanding upon the ideas +# Documenting many of R's behaviors for diag(). There are a few other cases +# where x may be either a scalar or a vector, expanding upon the ideas # documented here. -# +# # FN. ARGS. NROW NCOL DIAG EIGENIZED # # (x, nrow, ncol) nrow ncol x (x, nrow, ncol) @@ -321,22 +321,22 @@ expect_error(cSpDiagXRCv(x = 4, nrow = nr, ncol = nc)) expect_error(cSpDiagXRCv(x = runif(nr), nrow = nr, ncol = nc)) expect_identical(cSpDiagXRC(x = 3, nrow = nr, ncol = nc), as(diag(x = 3, nrow = nr, ncol = nc), 'dgCMatrix')) -expect_identical(cSpDiagXRv(x = xv_nr, nrow = nr), +expect_identical(cSpDiagXRv(x = xv_nr, nrow = nr), as(diag(x = xv_nr, nrow = nr), 'dgCMatrix')) expect_error(cSpDiagXRv(x = xv, nrow = nr)) -expect_identical(cSpDiagXR(x = 3, nrow = nr), +expect_identical(cSpDiagXR(x = 3, nrow = nr), as(diag(x = 3, nrow = nr), 'dgCMatrix')) -expect_identical(cSpDiagXCv(x = 3, ncol = nc), +expect_identical(cSpDiagXCv(x = 3, ncol = nc), as(diag(x = 3, ncol = nc), 'dgCMatrix')) -expect_identical(cSpDiagXC(x = 3, ncol = nc), +expect_identical(cSpDiagXC(x = 3, ncol = nc), as(diag(x = 3, ncol = nc), 'dgCMatrix')) -expect_identical(cSpDiagRC(nrow = nr, ncol = nc), +expect_identical(cSpDiagRC(nrow = nr, ncol = nc), as(diag(nrow = nr, ncol = nc), 'dgCMatrix')) -expect_identical(cSpDiagXv(x = xv), +expect_identical(cSpDiagXv(x = xv), as(diag(x = xv), 'dgCMatrix')) -expect_identical(cSpDiagX(x = 3), +expect_identical(cSpDiagX(x = 3), as(diag(x = 3), 'dgCMatrix')) -expect_identical(cSpDiagR(nrow = nr), +expect_identical(cSpDiagR(nrow = nr), as(diag(nrow = nr), 'dgCMatrix')) @@ -355,22 +355,22 @@ diagAccessor <- function(x) { } nDiagAccessor <- nFunction( - fun = diagAccessor, - argTypes = list(x = 'nMatrix'), + fun = diagAccessor, + argTypes = list(x = 'nMatrix'), returnType = 'numericVector' -) +) nDiagExprAccessor <- nFunction( - fun = diagExprAccessor, - argTypes = list(x = 'nMatrix', y = 'nMatrix'), + fun = diagExprAccessor, + argTypes = list(x = 'nMatrix', y = 'nMatrix'), returnType = 'numericVector' -) +) nDiagAccessorSp <- nFunction( - fun = diagAccessor, - argTypes = list(x = 'nSparseMatrix'), + fun = diagAccessor, + argTypes = list(x = 'nSparseMatrix'), returnType = 'numericVector' -) +) cDiagAccessor <- nCompile(nDiagAccessor) cDiagAccessorSp <- nCompile(nDiagAccessorSp) @@ -401,13 +401,13 @@ diagAssignment <- function(x, y) { } nDiagExprAssignment <- nFunction( - fun = diagExprAssignment, + fun = diagExprAssignment, argTypes = list(x = 'nMatrix', y = 'numericVector', z = 'numericVector'), returnType = 'nMatrix' ) nSpDiagExprAssignment <- nFunction( - fun = diagExprAssignment, + fun = diagExprAssignment, argTypes = list(x = 'nSparseMatrix', y = 'numericVector', z = 'numericVector'), returnType = 'nSparseMatrix' ) @@ -493,14 +493,14 @@ d2Sp <- function(x) { } nD2 <- nFunction( - fun = d2, - argTypes = list(x = 'integer'), + fun = d2, + argTypes = list(x = 'integer'), returnType = 'numericVector' ) nD2Sp <- nFunction( - fun = d2Sp, - argTypes = list(x = 'integer'), + fun = d2Sp, + argTypes = list(x = 'integer'), returnType = 'numericVector' ) @@ -509,4 +509,3 @@ cD2Sp <- nCompile(nD2Sp) expect_equivalent(cD2(x = 5), rep(1,5)) expect_equivalent(cD2Sp(x = 5), rep(1,5)) - diff --git a/nCompiler/tests/testthat/test-tensorOperations_linear_algebra.R b/nCompiler/tests/testthat/tensorOps_tests/test-tensorOperations_linear_algebra.R similarity index 100% rename from nCompiler/tests/testthat/test-tensorOperations_linear_algebra.R rename to nCompiler/tests/testthat/tensorOps_tests/test-tensorOperations_linear_algebra.R diff --git a/nCompiler/tests/testthat/test-tensorOperations_reshaping.R b/nCompiler/tests/testthat/tensorOps_tests/test-tensorOperations_reshaping.R similarity index 100% rename from nCompiler/tests/testthat/test-tensorOperations_reshaping.R rename to nCompiler/tests/testthat/tensorOps_tests/test-tensorOperations_reshaping.R diff --git a/nCompiler/tests/testthat/test-tensorOperations_sparse.R b/nCompiler/tests/testthat/tensorOps_tests/test-tensorOperations_sparse.R similarity index 100% rename from nCompiler/tests/testthat/test-tensorOperations_sparse.R rename to nCompiler/tests/testthat/tensorOps_tests/test-tensorOperations_sparse.R diff --git a/nCompiler/tests/testthat/v1tests/test-tensorOperations_sparse_multiplication.R b/nCompiler/tests/testthat/tensorOps_tests/test-tensorOperations_sparse_multiplication.R similarity index 100% rename from nCompiler/tests/testthat/v1tests/test-tensorOperations_sparse_multiplication.R rename to nCompiler/tests/testthat/tensorOps_tests/test-tensorOperations_sparse_multiplication.R diff --git a/nCompiler/tests/testthat/testing_operatorLists.R b/nCompiler/tests/testthat/testing_operatorLists.R index 25911f21..e2eb158b 100644 --- a/nCompiler/tests/testthat/testing_operatorLists.R +++ b/nCompiler/tests/testthat/testing_operatorLists.R @@ -25,7 +25,7 @@ ################## ## math only -nCompiler:::updateOperatorDef( +`:::`("nCompiler", "updateOperatorDef")( c('min', 'max', 'all', 'any', 'length'), 'testing', val = list( @@ -38,7 +38,7 @@ nCompiler:::updateOperatorDef( ) ) -nCompiler:::updateOperatorDef( +`:::`("nCompiler", "updateOperatorDef")( c('sin', 'cos', 'tan', 'asin', 'acos', 'atan', 'asinh', 'acosh', 'atanh', 'logit', 'ilogit', 'expit', 'probit', 'iprobit', 'phi', 'cloglog', 'icloglog', 'ceiling', 'floor', 'round', 'trunc', 'lgamma', 'loggam', @@ -107,33 +107,32 @@ input_gen_funs_p1inf <- function(arg_size, type) { ) } -nCompiler:::updateOperatorDef( +`:::`("nCompiler", "updateOperatorDef")( c('log1p'), 'testing', 'input_gen_funs', input_gen_funs_m1inf ) -nCompiler:::updateOperatorDef( +`:::`("nCompiler", "updateOperatorDef")( c('log', 'sqrt'), 'testing', 'input_gen_funs', input_gen_funs_zinf ) - -nCompiler:::updateOperatorDef( +`:::`("nCompiler", "updateOperatorDef")( c('cloglog', 'logit', 'probit'), 'testing', 'input_gen_funs', input_gen_funs_zp1 ) -nCompiler:::updateOperatorDef( +`:::`("nCompiler", "updateOperatorDef")( c('asin', 'acos', 'atanh'), 'testing', 'input_gen_funs', input_gen_funs_m1p1 ) -nCompiler:::updateOperatorDef( +`:::`("nCompiler", "updateOperatorDef")( c('acosh'), 'testing', 'input_gen_funs', input_gen_funs_p1inf ) -nCompiler:::updateOperatorDef( +`:::`("nCompiler", "updateOperatorDef")( 'squaredNorm', 'testing', val = list( @@ -145,7 +144,7 @@ nCompiler:::updateOperatorDef( ) ) -nCompiler:::updateOperatorDef( +`:::`("nCompiler", "updateOperatorDef")( c('mean', 'prod', 'squaredNorm', 'sum'), 'testing', 'reductionOp', TRUE ) @@ -175,7 +174,7 @@ binaryOp_argTypes <- c( rhs = c('numericScalar', 'integerScalar', 'logicalScalar')) ) -nCompiler:::updateOperatorDef( +`:::`("nCompiler", "updateOperatorDef")( c('pmin', 'pmax', '==', '!=', '<=', '>=', '<', '>', '&', '|', '+', '/', '*'), 'testing', val = list( @@ -188,7 +187,7 @@ nCompiler:::updateOperatorDef( ## will be used, but for arg2 it will use the custom input generation function ## we provide. ## See make_input() and argType_2_input() in testing_utils.R. -nCompiler:::updateOperatorDef( +`:::`("nCompiler", "updateOperatorDef")( c('/'), 'testing', 'input_gen_funs', list( arg1 = NULL, @@ -204,7 +203,7 @@ nCompiler:::updateOperatorDef( ) ## add AD_argTypes for a few operators -nCompiler:::updateOperatorDef( +`:::`("nCompiler", "updateOperatorDef")( c('+', '/', '*'), 'testing', 'AD_argTypes', list(c('numericScalar', 'numericScalar'), @@ -214,24 +213,24 @@ nCompiler:::updateOperatorDef( ) ## add descriptive and safe names for gold-file names -nCompiler:::updateOperatorDef('+', 'testing', 'alpha_name', 'plus') -nCompiler:::updateOperatorDef('==', 'testing', 'alpha_name', 'eq') -nCompiler:::updateOperatorDef('!=', 'testing', 'alpha_name', 'neq') -nCompiler:::updateOperatorDef('<=', 'testing', 'alpha_name', 'le') -nCompiler:::updateOperatorDef('>=', 'testing', 'alpha_name', 'ge') -nCompiler:::updateOperatorDef('<', 'testing', 'alpha_name', 'lt') -nCompiler:::updateOperatorDef('>', 'testing', 'alpha_name', 'gt') -nCompiler:::updateOperatorDef('&', 'testing', 'alpha_name', 'and') -nCompiler:::updateOperatorDef('|', 'testing', 'alpha_name', 'or') -nCompiler:::updateOperatorDef('/', 'testing', 'alpha_name', 'div') -nCompiler:::updateOperatorDef('*', 'testing', 'alpha_name', 'mult') +`:::`("nCompiler", "updateOperatorDef")('+', 'testing', 'alpha_name', 'plus') +`:::`("nCompiler", "updateOperatorDef")('==', 'testing', 'alpha_name', 'eq') +`:::`("nCompiler", "updateOperatorDef")('!=', 'testing', 'alpha_name', 'neq') +`:::`("nCompiler", "updateOperatorDef")('<=', 'testing', 'alpha_name', 'le') +`:::`("nCompiler", "updateOperatorDef")('>=', 'testing', 'alpha_name', 'ge') +`:::`("nCompiler", "updateOperatorDef")('<', 'testing', 'alpha_name', 'lt') +`:::`("nCompiler", "updateOperatorDef")('>', 'testing', 'alpha_name', 'gt') +`:::`("nCompiler", "updateOperatorDef")('&', 'testing', 'alpha_name', 'and') +`:::`("nCompiler", "updateOperatorDef")('|', 'testing', 'alpha_name', 'or') +`:::`("nCompiler", "updateOperatorDef")('/', 'testing', 'alpha_name', 'div') +`:::`("nCompiler", "updateOperatorDef")('*', 'testing', 'alpha_name', 'mult') ############################# ## unary and binary operators ############################# ## the *_argTypes include both the unary and binary cases -nCompiler:::updateOperatorDef( +`:::`("nCompiler", "updateOperatorDef")( c('-'), 'testing', val = list( @@ -254,7 +253,7 @@ nCompiler:::updateOperatorDef( ## pow (rhs scalar) ################### -nCompiler:::updateOperatorDef( +`:::`("nCompiler", "updateOperatorDef")( '^', 'testing', val = list( @@ -279,7 +278,7 @@ nCompiler:::updateOperatorDef( ## %% (rhs scalar when lhs Eigen::Tensor) ######################################### -nCompiler:::updateOperatorDef( +`:::`("nCompiler", "updateOperatorDef")( '%%', 'testing', val = list( @@ -318,7 +317,7 @@ nCompiler:::updateOperatorDef( ## matrix mult ############## -nCompiler:::updateOperatorDef( +`:::`("nCompiler", "updateOperatorDef")( '%*%', 'testing', val = list(matrixMultOp = TRUE, alpha_name = 'matmul') @@ -328,7 +327,7 @@ nCompiler:::updateOperatorDef( ## distribution functions ######################### -nCompiler:::updateOperatorDef( +`:::`("nCompiler", "updateOperatorDef")( c('dbeta', 'dbinom', 'ddexp', 'dgamma', 'dinvgamma', 'dlnorm', 'dnbinom', 'dnorm', 'dt', 'dt_nonstandard', 'dunif', 'dweibull'), 'testing', diff --git a/nCompiler/tests/testthat/testing_utils.R b/nCompiler/tests/testthat/testing_utils.R index 89bd10c5..cc0acf43 100644 --- a/nCompiler/tests/testthat/testing_utils.R +++ b/nCompiler/tests/testthat/testing_utils.R @@ -72,7 +72,7 @@ add_missing_size <- function(argSymbol, vector_size = 3, matrix_size = c(3, 4), argType_2_input <- function(argType, input_gen_fun = NULL) { argSymbol <- add_missing_size( - nCompiler:::argType2symbol(argType) + `:::`("nCompiler", "argType2symbol")(argType) ) type <- argSymbol$type nDim <- argSymbol$nDim @@ -189,7 +189,7 @@ test_base <- function(param_list, test_name = '', test_fun = NULL, ## are unloaded, giving a crash. ## That is also the reason for the defensive gc() at the end of this function. if(gold_test) - nCompiler:::resetLabelFunctionCreators() + `:::`("nCompiler", "resetLabelFunctionCreators")() nFuns <- lapply(compiles, gen_nFunction) @@ -288,16 +288,16 @@ modifyBatchOnMatch <- get_matching_ops <- function(field, subfield = NULL, test = isTRUE) { ## Returns vector of operator names where the value in a given field (or its ## subfield) returns TRUE when the test function is applied to it. - ops <- ls(nCompiler:::operatorDefEnv) - values <- sapply(ops, nCompiler:::getOperatorDef, field, subfield) + ops <- ls(`:::`("nCompiler", "operatorDefEnv")) + values <- sapply(ops, `:::`("nCompiler", "getOperatorDef"), field, subfield) if (is.null(values)) return(character(0)) names(values)[sapply(values, test)] } get_ops_values <- function(field, subfield = NULL) { ## Return a named (by operator) list of the values found in field/subfield. - ops <- ls(nCompiler:::operatorDefEnv) - values <- sapply(ops, nCompiler:::getOperatorDef, field, subfield, + ops <- ls(`:::`("nCompiler", "operatorDefEnv")) + values <- sapply(ops, `:::`("nCompiler", "getOperatorDef"), field, subfield, simplify = FALSE) non_null <- sapply(values, function(x) !is.null(x)) return(values[non_null]) @@ -311,16 +311,16 @@ get_ops_values <- function(field, subfield = NULL) { ## return_type_string <- function(op, argTypes) { - returnTypeCode <- nCompiler:::getOperatorDef(op, 'labelAbstractTypes', + returnTypeCode <- `:::`("nCompiler", "getOperatorDef")(op, 'labelAbstractTypes', 'returnTypeCode') - recycling_rule_op <- nCompiler:::getOperatorDef(op, 'testing', + recycling_rule_op <- `:::`("nCompiler", "getOperatorDef")(op, 'testing', 'recyclingRuleOp') if (is.null(returnTypeCode)) if (!isTRUE(recycling_rule_op)) return(argTypes[1]) else returnTypeCode <- 1 - scalarTypeString <- nCompiler:::returnTypeCode2String(returnTypeCode) + scalarTypeString <- `:::`("nCompiler", "returnTypeCode2String")(returnTypeCode) ## scalarTypeString <- switch( ## returnTypeCode, @@ -331,13 +331,13 @@ return_type_string <- function(op, argTypes) { args <- lapply( argTypes, function(argType) - nCompiler:::argType2symbol(argType) + `:::`("nCompiler", "argType2symbol")(argType) ) scalarTypeString <- - if (length(argTypes) == 1) nCompiler:::arithmeticOutputType(args[[1]]$type, + if (length(argTypes) == 1) `:::`("nCompiler", "arithmeticOutputType")(args[[1]]$type, returnTypeCode = returnTypeCode) - else if(length(argTypes) == 2) nCompiler:::arithmeticOutputType(args[[1]]$type, args[[2]]$type, + else if(length(argTypes) == 2) `:::`("nCompiler", "arithmeticOutputType")(args[[1]]$type, args[[2]]$type, returnTypeCode = returnTypeCode) else stop( paste0( @@ -350,7 +350,7 @@ return_type_string <- function(op, argTypes) { ## arithmeticOutputType might return 'double' if (scalarTypeString == 'double') scalarTypeString <- 'numeric' - reduction_op <- nCompiler:::getOperatorDef(op, 'testing', 'reductionOp') + reduction_op <- `:::`("nCompiler", "getOperatorDef")(op, 'testing', 'reductionOp') nDim <- if (isTRUE(reduction_op)) 0 else max(sapply(args, `[[`, 'nDim')) @@ -360,7 +360,7 @@ return_type_string <- function(op, argTypes) { call. = FALSE ) - matrix_mult_op <- nCompiler:::getOperatorDef(op, 'testing', 'matrixMultOp') + matrix_mult_op <- `:::`("nCompiler", "getOperatorDef")(op, 'testing', 'matrixMultOp') # if arg sizes weren't provided this will just be NULL sizes <- if (nDim == 0) NULL @@ -481,7 +481,7 @@ test_gold_file <- function(uncompiled, filename = paste0('test_', date()), if (isNF(uncompiled)) { RcppPacket <- NFinternals(uncompiled)$RcppPacket } else if (inherits(uncompiled, 'cpp_nClassClass')) - RcppPacket <- nCompiler:::cppDefs_2_RcppPacket( + RcppPacket <- `:::`("nCompiler", "cppDefs_2_RcppPacket")( uncompiled, filebase = '.' ## filebase won't be used since we provide 'con' to writeCpp_nCompiler ) @@ -489,7 +489,7 @@ test_gold_file <- function(uncompiled, filename = paste0('test_', date()), RcppPacket <- uncompiled if (isTRUE(write_gold_file)) { ## either create or overwrite gold_file con <- file(filepath, open = "w") - nCompiler:::writeCpp_nCompiler( + `:::`("nCompiler", "writeCpp_nCompiler")( RcppPacket, con = con ) close(con) @@ -497,7 +497,7 @@ test_gold_file <- function(uncompiled, filename = paste0('test_', date()), ## read the existing gold file and compare to the current RcppPacket temp_file <- paste0(filepath, 'tmp') con <- file(temp_file, open = "w") - nCompiler:::writeCpp_nCompiler( + `:::`("nCompiler", "writeCpp_nCompiler")( RcppPacket, con = con ) close(con) diff --git a/nCompiler/tests/testthat/test-RcppTypes.R b/nCompiler/tests/testthat/types_tests/test-RcppTypes.R similarity index 99% rename from nCompiler/tests/testthat/test-RcppTypes.R rename to nCompiler/tests/testthat/types_tests/test-RcppTypes.R index 374772e2..07576b8c 100644 --- a/nCompiler/tests/testthat/test-RcppTypes.R +++ b/nCompiler/tests/testthat/types_tests/test-RcppTypes.R @@ -282,8 +282,8 @@ test_that("RcppFunction works", { result1_Correct <- rnorm(10) expect_equal(result1, result1_Correct) - result2 <- nffnC(nCompiler::logit, 0.4) - result2_correct <- nCompiler::logit(0.4) + result2 <- nffnC(logit, 0.4) + result2_correct <- logit(0.4) expect_equal(result2, result2_correct) }) diff --git a/nCompiler/tests/testthat/test-cppVariables.R b/nCompiler/tests/testthat/types_tests/test-cppVariables.R similarity index 84% rename from nCompiler/tests/testthat/test-cppVariables.R rename to nCompiler/tests/testthat/types_tests/test-cppVariables.R index 1673b7ed..f0263c5a 100644 --- a/nCompiler/tests/testthat/test-cppVariables.R +++ b/nCompiler/tests/testthat/types_tests/test-cppVariables.R @@ -2,7 +2,7 @@ message("test-cppVariable has only one case and so needs more coverage.") test_that("cppVariable classes work", { - TR1 <- nCompiler:::cppEigenTensorRef("arg1", + TR1 <- `:::`("nCompiler", "cppEigenTensorRef")("arg1", nDim = 2, 'double') expect_identical( diff --git a/nCompiler/tests/testthat/test-types.R b/nCompiler/tests/testthat/types_tests/test-types.R similarity index 90% rename from nCompiler/tests/testthat/test-types.R rename to nCompiler/tests/testthat/types_tests/test-types.R index df3fdabb..17b8c42c 100644 --- a/nCompiler/tests/testthat/test-types.R +++ b/nCompiler/tests/testthat/types_tests/test-types.R @@ -2,7 +2,7 @@ test_that("numericVector(5)", { ## as if `a = numericVector(5)` declared in function argument a <- quote(numericVector(5)) - aSym <- nCompiler:::argType2symbol(a, + aSym <- `:::`("nCompiler", "argType2symbol")(a, name = "a", origName = "orig_a", isArg = TRUE) @@ -17,7 +17,7 @@ test_that("ref(numericVector(5))", { ## as if `a = ref(numericVector(5))` declared in function-argument a <- quote(ref(numericVector(5))) - aSym <- nCompiler:::argType2symbol(a, + aSym <- `:::`("nCompiler", "argType2symbol")(a, name = "a", origName = "orig_a", isArg = TRUE) @@ -33,7 +33,7 @@ test_that("numericVector(5) isRef=TRUE", ## as if `a = numericVector(5)` declared in function-argument ## and isRef=TRUE used to indicate reference a <- quote(numericVector(5)) - aSym <- nCompiler:::argType2symbol(a, + aSym <- `:::`("nCompiler", "argType2symbol")(a, name = "a", origName = "orig_a", isArg = TRUE, @@ -51,8 +51,8 @@ test_that("ref(numericVector(5) via explicitType)", ## with argType = `ref(numericVector(5))` a <- NULL aExplicit <- quote(ref(numericVector(5))) - - aSym <- nCompiler:::argType2symbol(a, + + aSym <- `:::`("nCompiler", "argType2symbol")(a, name = "a", origName = "orig_a", isArg = TRUE, @@ -70,7 +70,7 @@ test_that("numericVector(5) via explicitType", ## with argType = `numericVector(5)` a <- NULL aExplicit <- quote(numericVector(5)) - aSym <- nCompiler:::argType2symbol(a, + aSym <- `:::`("nCompiler", "argType2symbol")(a, name = "a", origName = "orig_a", isArg = TRUE, @@ -88,7 +88,7 @@ test_that("numericVector(5) isRef = TRUE via explicitType", ## with argType = `numericVector(5)` a <- NULL aExplicit <- quote(numericVector(5)) - aSym <- nCompiler:::argType2symbol(a, + aSym <- `:::`("nCompiler", "argType2symbol")(a, name = "a", origName = "orig_a", isArg = TRUE, @@ -107,7 +107,7 @@ test_that("ref(numericVector(5)) via explicitType with default value to ignore", ## with argType = `ref(numericVector(5))` a <- quote(rnorm(5)) ## ignored aExplicit <- quote(ref(numericVector(5))) - aSym <- nCompiler:::argType2symbol(a, + aSym <- `:::`("nCompiler", "argType2symbol")(a, name = "a", origName = "orig_a", isArg = TRUE, @@ -123,7 +123,7 @@ test_that("infer type from evaluating default", { ## infer type of `a` from default a <- quote(rnorm(5)) - aSym <- nCompiler:::argType2symbol(a, + aSym <- `:::`("nCompiler", "argType2symbol")(a, name = "a", origName = "orig_a", isArg = TRUE @@ -142,7 +142,7 @@ test_that("infer type from evaluating default, with scoping needed", fun1 <- function() { fun2 <- function(n) rnorm(n) a <- quote(fun2(5)) - aSym <- nCompiler:::argType2symbol(a, + aSym <- `:::`("nCompiler", "argType2symbol")(a, name = "a", origName = "orig_a", isArg = TRUE @@ -163,7 +163,7 @@ test_that("Trap error from duplicate setting of isRef. (This should show a warni ## Duplicate setting of ref a <- quote(ref(numericVector(5))) expect_error( - nCompiler:::argType2symbol(a, + `:::`("nCompiler", "argType2symbol")(a, name = "a", origName = "orig_a", isArg = TRUE, @@ -175,7 +175,7 @@ test_that("Trap error from duplicate setting of isRef. (This should show a warni a <- quote(matrix(1:4, nrow = 2, ncol = 2)) aExplicit <- quote(numericVector()) expect_error(suppressWarnings( # this gives a warning and an error, so for testing we suppress the warning - nCompiler:::argType2symbol(a, + `:::`("nCompiler", "argType2symbol")(a, name = "a", origName = "orig_a", isArg = TRUE, @@ -192,7 +192,7 @@ test_that("nMatrix(type = \"integer\")", b <- quote(nMatrix(type = "integer", nrow = 3, ncol = 5)) - bSym <- nCompiler:::argType2symbol(b, + bSym <- `:::`("nCompiler", "argType2symbol")(b, name = "b", origName = "orig_b", isArg = TRUE) @@ -206,7 +206,7 @@ test_that("nMatrix(type = \"integer\")", test_that("list type works", { l <- "RcppList" - lSym <- nCompiler:::argType2symbol(l, name = "l", isArg = TRUE) + lSym <- `:::`("nCompiler", "argType2symbol")(l, name = "l", isArg = TRUE) expect_identical(lSym$name, "l") expect_identical(lSym$type, "Rcpp::List") expect_identical(lSym$isRef, FALSE) @@ -221,7 +221,7 @@ test_that("list arguments handled correctly", bExplicit = quote(nMatrix(type = "integer")) aRef <- TRUE bRef <- FALSE - symTab <- nCompiler:::argTypeList2symbolTable( + symTab <- `:::`("nCompiler", "argTypeList2symbolTable")( argTypeList = list(a = a, b = b), origNames = c("orig_a", "orig_b"), @@ -245,21 +245,21 @@ test_that("list arguments handled correctly", expect_identical(bSym$isArg, FALSE) ## void() (return type default) - vSym <- nCompiler:::argType2symbol(quote(void())) + vSym <- `:::`("nCompiler", "argType2symbol")(quote(void())) expect_identical(vSym$type, "void") expect_identical(vSym$nDim, 0) }) test_that("symbolTBD works", { - nCompiler:::resetLabelFunctionCreators() + `:::`("nCompiler", "resetLabelFunctionCreators")() nc1 <- nClass( Cpublic = list(a = 'numericScalar') ) - sym_nc1 <- nCompiler:::argType2symbol('nc1', 'nc1obj') - symTab <- nCompiler:::symbolTableClass$new() + sym_nc1 <- `:::`("nCompiler", "argType2symbol")('nc1', 'nc1obj') + symTab <- `:::`("nCompiler", "symbolTableClass")$new() symTab$addSymbol(sym_nc1) - nCompiler:::resolveTBDsymbols(symTab) + `:::`("nCompiler", "resolveTBDsymbols")(symTab) expect_equal(symTab$getSymbol("nc1obj")$genCppVar()$generate(), "std::shared_ptr nc1obj") }) diff --git a/nCompiler/tests/testthat/v1tests/test-NF_CompilerClass.R b/nCompiler/tests/testthat/uncompiled_tests/test-NF_CompilerClass.R similarity index 97% rename from nCompiler/tests/testthat/v1tests/test-NF_CompilerClass.R rename to nCompiler/tests/testthat/uncompiled_tests/test-NF_CompilerClass.R index c7ef0912..de512b0c 100644 --- a/nCompiler/tests/testthat/v1tests/test-NF_CompilerClass.R +++ b/nCompiler/tests/testthat/uncompiled_tests/test-NF_CompilerClass.R @@ -8,7 +8,7 @@ test_that("NF_CompilerClass steps", returnType(numericScalar()) } ) - NFC <- nCompiler:::NF_CompilerClass$new(f = foo) + NFC <- `:::`("nCompiler", "NF_CompilerClass")$new(f = foo) expect_equal(NFC$origRcode, quote({ return(a+1) diff --git a/nCompiler/tests/testthat/test-nFunction_uncompiled.R b/nCompiler/tests/testthat/uncompiled_tests/test-nFunction_uncompiled.R similarity index 100% rename from nCompiler/tests/testthat/test-nFunction_uncompiled.R rename to nCompiler/tests/testthat/uncompiled_tests/test-nFunction_uncompiled.R diff --git a/nCompiler/tests/testthat/test-nParse_nDeparse.R b/nCompiler/tests/testthat/uncompiled_tests/test-nParse_nDeparse.R similarity index 100% rename from nCompiler/tests/testthat/test-nParse_nDeparse.R rename to nCompiler/tests/testthat/uncompiled_tests/test-nParse_nDeparse.R