Merge pull request #74 from t-kalinowski/fix/covr-switch-fallthrough

Fix covr switch fallthrough; add r2size tests

Author: t-kalinowski

.github/workflows/test-coverage.yaml

@@ -0,0 +1,62 @@
+# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples
+# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
+on:
+  push:
+    branches: [main, master]
+  pull_request:
+
+name: test-coverage.yaml
+
+permissions: read-all
+
+jobs:
+  test-coverage:
+    runs-on: ubuntu-latest
+    env:
+      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+
+    steps:
+      - uses: actions/checkout@v4
+
+      - uses: r-lib/actions/setup-r@v2
+        with:
+          use-public-rspm: true
+
+      - uses: r-lib/actions/setup-r-dependencies@v2
+        with:
+          extra-packages: any::covr, any::xml2
+          needs: coverage
+
+      - name: Test coverage
+        run: |
+          cov <- covr::package_coverage(
+            quiet = FALSE,
+            clean = FALSE,
+            install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package")
+          )
+          print(cov)
+          covr::to_cobertura(cov)
+        shell: Rscript {0}
+
+      - uses: codecov/codecov-action@v5
+        with:
+          # Fail if error if not on PR, or if on PR and token is given
+          fail_ci_if_error: ${{ github.event_name != 'pull_request' || secrets.CODECOV_TOKEN }}
+          files: ./cobertura.xml
+          plugins: noop
+          disable_search: true
+          token: ${{ secrets.CODECOV_TOKEN }}
+
+      - name: Show testthat output
+        if: always()
+        run: |
+          ## --------------------------------------------------------------------
+          find '${{ runner.temp }}/package' -name 'testthat.Rout*' -exec cat '{}' \; || true
+        shell: bash
+
+      - name: Upload test results
+        if: failure()
+        uses: actions/upload-artifact@v4
+        with:
+          name: coverage-test-failures
+          path: ${{ runner.temp }}/package

R/sizes.R

@@ -141,74 +141,71 @@ r2size <- function(r, scope) {
         r2size(var@r, scope)
       },
       language = {
-        as.character(r[[1]]) |>
-          switch(
-            `+` = ,
-            `-` = ,
-            `/` = ,
-            `*` = ,
-            `^` = ,
-            `%/%` = ,
-            `%%` = {
-              args <- as.list(r)[-1]
-              args <- lapply(args, r2size, scope)
-              if (anyNA(rapply(args, as.list))) {
-                return(NA_integer_)
-              }
-              cl <- as.call(c(r[[1]], args))
-              if (all(map_lgl(args, is.atomic))) {
-                cl <- eval(cl, baseenv())
-              }
-              cl
-            },
-            length = {
-              var <- get0(as.character(r[[2L]]), scope)
-              if (!inherits(var, Variable)) {
-                stop("could not resolve size: ", deparse1(r))
-              }
-              if (var@rank == 1) {
-                return(var@dims[[1L]])
-              }
-              len <- reduce(var@dims, \(d1, d2) call("*", d1, d2))
-              r2size(len, scope)
-            },
-            `[` = {
-              # [ only works when paired with dim()
-              if (!is_call(r[[2L]], quote(dim))) {
-                return(NA_integer_)
-              }
-              var <- get0(as.character(r[[2L]][[2L]]), scope)
-              if (!inherits(var, Variable)) {
-                stop("could not resolve size: ", deparse1(r))
-              }
-              axis <- r[[3]]
-              if (!is_wholenumber(axis)) {
-                return(NA_integer_)
-              }
-              if (axis > var@rank) {
-                stop("insufficient rank of variable in ", deparse1(r))
-              }
-              var@dims[[axis]]
-            },
-            # dim = {
-            #
-            # },
-            nrow = {
-              var <- get0(as.character(r[[2L]]), scope)
-              if (!inherits(var, Variable)) {
-                stop("could not resolve size: ", deparse1(r))
-              }
-              var@dims[[1]]
-            },
-            ncol = {
-              var <- get0(as.character(r[[2L]]), scope)
-              if (!inherits(var, Variable)) {
-                stop("could not resolve size: ", deparse1(r))
-              }
-              var@dims[[2]]
-            },
-            NA_integer_
-          )
+        op <- as.character(r[[1]])
+
+        if (op %in% c("+", "-", "/", "*", "^", "%/%", "%%")) {
+          args <- as.list(r)[-1]
+          args <- lapply(args, r2size, scope)
+          if (anyNA(rapply(args, as.list))) {
+            return(NA_integer_)
+          }
+          cl <- as.call(c(r[[1]], args))
+          if (all(map_lgl(args, is.atomic))) {
+            cl <- eval(cl, baseenv())
+          }
+          return(cl)
+        }
+
+        switch(
+          op,
+          length = {
+            var <- get0(as.character(r[[2L]]), scope)
+            if (!inherits(var, Variable)) {
+              stop("could not resolve size: ", deparse1(r))
+            }
+            if (var@rank == 1) {
+              return(var@dims[[1L]])
+            }
+            len <- reduce(var@dims, \(d1, d2) call("*", d1, d2))
+            r2size(len, scope)
+          },
+          `[` = {
+            # [ only works when paired with dim()
+            if (!is_call(r[[2L]], quote(dim))) {
+              return(NA_integer_)
+            }
+            var <- get0(as.character(r[[2L]][[2L]]), scope)
+            if (!inherits(var, Variable)) {
+              stop("could not resolve size: ", deparse1(r))
+            }
+            axis <- r[[3]]
+            if (!is_wholenumber(axis)) {
+              return(NA_integer_)
+            }
+            if (axis > var@rank) {
+              stop("insufficient rank of variable in ", deparse1(r))
+            }
+            var@dims[[axis]]
+          },
+          # dim = {
+          #
+          # },
+          nrow = {
+            var <- get0(as.character(r[[2L]]), scope)
+            if (!inherits(var, Variable)) {
+              stop("could not resolve size: ", deparse1(r))
+            }
+            var@dims[[1]]
+          },
+          ncol = {
+            var <- get0(as.character(r[[2L]]), scope)
+            if (!inherits(var, Variable)) {
+              stop("could not resolve size: ", deparse1(r))
+            }
+            var@dims[[2]]
+          },
+          NA_integer_
+        )
       },
       NA_integer_
     )

R/zzz.R

@@ -29,7 +29,9 @@
 # }
 
 .onLoad <- function(...) {
-  S7::methods_register()
-  asNamespace("dotty")$dotify()
+  suppressWarnings({
+    S7::methods_register()
+    asNamespace("dotty")$dotify()
+  })
   # on_load_register_.AtNames.default()
 }

README.Rmd

@@ -25,6 +25,7 @@ knitr::opts_chunk$set(
 <!-- badges: start -->
 
 [![R-CMD-check](https://github.com/t-kalinowski/quickr/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/t-kalinowski/quickr/actions/workflows/R-CMD-check.yaml)
+[![Codecov test coverage](https://codecov.io/gh/t-kalinowski/quickr/graph/badge.svg)](https://app.codecov.io/gh/t-kalinowski/quickr)
 <!-- badges: end -->
 
 The goal of quickr is to make your R code run quicker.

tests/testthat/test-classes.R

@@ -0,0 +1,76 @@
+# Unit tests for internal S7 helpers/classes
+
+test_that("prop helpers implement coercion, validation and set-once behavior", {
+  Test <- S7::new_class(
+    name = "Test",
+    properties = list(
+      s = quickr:::prop_string(
+        default = NULL,
+        allow_null = TRUE,
+        coerce = TRUE,
+        set_once = TRUE
+      ),
+      n = quickr:::prop_wholenumber(
+        default = 1,
+        allow_null = TRUE,
+        coerce = TRUE
+      ),
+      e = quickr:::prop_enum(
+        values = c("alpha", "beta"),
+        nullable = TRUE,
+        exact = FALSE
+      )
+    )
+  )
+
+  obj <- Test()
+
+  obj@s <- 123
+  expect_identical(obj@s, "123")
+  expect_error(obj@s <- "again", "can only be set once")
+
+  obj@n <- 2
+  expect_identical(obj@n, 2L)
+  expect_error(obj@n <- 2.5, "must be a whole number")
+
+  obj@e <- "alp"
+  expect_identical(obj@e, "alpha")
+  obj@e <- "gamma"
+  expect_error(S7::validate(obj), "must be either")
+})
+
+test_that("Variable dims setter accepts common forms", {
+  v <- quickr:::Variable(name = "x", mode = "integer", dims = c(2, NA))
+  expect_identical(v@dims, list(2L, NA_integer_))
+  expect_identical(v@rank, 2L)
+
+  v2 <- quickr:::Variable(name = quote(foo), mode = "double", dims = quote(n))
+  expect_identical(v2@name, "foo")
+  expect_true(is.symbol(v2@dims[[1L]]))
+
+  v3 <- quickr:::Variable(name = "y", mode = "double", dims = quote(n + 1L))
+  expect_true(is.call(v3@dims[[1L]]))
+
+  expect_error(
+    quickr:::Variable(name = "bad", mode = "integer", dims = list("x")),
+    "@dims must be a list"
+  )
+})
+
+test_that("Variable validator rejects non-logical logical_as_int", {
+  expect_error(
+    quickr:::Variable(mode = "integer", logical_as_int = TRUE),
+    "logical_as_int"
+  )
+})
+
+test_that("Fortran validates length and prints non-null properties", {
+  expect_error(quickr:::Fortran(c("a", "b")), "length 1")
+
+  v <- quickr:::Variable(name = "x", mode = "integer", dims = 1L)
+  f <- quickr:::Fortran("x", value = v, r = quote(x))
+
+  out <- capture.output(print(f))
+  expect_true(any(grepl("@value:", out, fixed = TRUE)))
+  expect_true(any(grepl("@r:", out, fixed = TRUE)))
+})

tests/testthat/test-compile-package.R

@@ -0,0 +1,37 @@
+# Unit tests for compile-package helpers
+
+test_that("dump_collected writes src stubs for collected quick functions", {
+  temp <- withr::local_tempdir()
+  withr::local_dir(temp)
+
+  writeLines("useDynLib(pkg, .registration = TRUE)", "NAMESPACE")
+  dir.create("src")
+
+  closure_env <- new.env(parent = asNamespace("quickr"))
+  fn <- evalq(
+    function(x) {
+      declare(type(x = double(1)))
+      x + 1
+    },
+    closure_env
+  )
+
+  quick_closure <- quickr:::create_quick_closure("fn", fn)
+
+  quickr:::collector$activate("test")
+  quickr:::collector$add(
+    name = "fn",
+    closure = fn,
+    quick_closure = quick_closure
+  )
+
+  testthat::capture_output({
+    result <- suppressMessages(withVisible(quickr:::dump_collected()))
+  })
+  expect_false(result$visible)
+
+  expect_true(file.exists("src/quickr_entrypoints.c"))
+  expect_true(file.exists("src/quickr_sub_routines.f90"))
+  expect_true(file.info("src/quickr_entrypoints.c")$size > 0)
+  expect_true(file.info("src/quickr_sub_routines.f90")$size > 0)
+})