Export several functions per roxygen2 warning

[kylebaron]

✖ utils.R:592: S3 method `is.numeric.data.frame` needs @export or @exportS3method tag.
✖ print.R:31: S3 method `print.mrgmod` needs @export or @exportS3method tag.
✖ class_mrgmod.R:707: S3 method `unloadso.mrgmod` needs @export or @exportS3method tag.

I don't think print.mrgmod() was doing any dispatch; mod is an S4 object and there's a show method for that which just calls print.mrgmod(). I simply renamed that function.

The other 2 functions I just exported; they are for internal use.

EDIT:
Based on @kyleam review, decided to nuke is.numeric.data.frame(); too dangerous. Made a pass through all the code and changed is.numeric.data.frame (or similar pattern) to numeric_columns().

Note that there are places in the code where we rely on the names that come back from that function.

[kyleam]

I'm worried about exposing an is.numeric method for a non-mrgsolve object, especially something as core as data.frame. This could lead to surprising breakage in scripts that have loaded mrgsolve.

d <- data.frame(
  foo = 1:3,
  bar = 3:5
)

sloop::s3_dispatch(is.numeric(d))
#>    is.numeric.data.frame
#>    is.numeric.default
#> => is.numeric (internal)
is.numeric(d)
#> [1] FALSE

loadNamespace("mrgsolve")
#> <environment: namespace:mrgsolve>

sloop::s3_dispatch(is.numeric(d))
#> => is.numeric.data.frame
#>    is.numeric.default
#>  * is.numeric (internal)
is.numeric(d)
#>  foo  bar
#> TRUE TRUE

In the long run, I think it'd be better to rename (or delete) is.numeric.data.frame and audit is.numeric call sites in mrgsolve for those that need to be adjusted.

call sites

is.numeric

$ git grep -Fn is.numeric
R/class_matlist.R:26:  x2 <- all(vapply(object@data, is.numeric, TRUE))
R/data_set.R:425:    nu <- sapply(idata, is.numeric)
R/env.R:32:  if(is.numeric(seed)) set.seed(seed)
R/events.R:127:  if(is.numeric(tinf) && length(tinf) > 0) l[["tinf"]] <- tinf
R/events.R:128:  if(is.numeric(until) && length(until) > 0) l[["until"]] <- until
R/events.R:159:    if(!is.numeric(ID)) {
R/events.R:164:      if(any(!is.numeric(data))) {
R/events.R:623:    # TODO: refactor once is.numeric is handled
R/events.R:624:    spacer <- is.atomic(evs[[i]]) && is.numeric(evs[[i]]) && length(evs[[i]])==1
R/events.R:694:  if(is.numeric(ID)) {
R/handle_spec_block.R:333:  if(is.numeric(number)) {
R/matlist.R:477:  if(!is.numeric(range)) {
R/modspec.R:78:    resolves_int <- is.numeric(etan) && all.equal(etan, round(etan))
R/mrgindata.R:279:  if(is.numeric(x)) {
R/mrgsolve.R:266:  if(is.numeric(nid) && !have_idata && !have_data) {
R/mrgsolve.R:584:      drop <- names(which(!is.numeric(join_data)))
R/mrgsolve.R:594:      drop <- names(which(!is.numeric(join_idata)))
R/mrgsolve.R:769:      if(!all(sapply(out[["data"]], is.numeric))) {
R/nmxml.R:133:  if(!is.numeric(index)) {
R/nmxml.R:402:  if(!is.numeric(index)) wstop("index did not resolve to a numeric value")
R/utils.R:434:single.number <- function(x) length(x)==1 & is.numeric(x)
R/utils.R:435:bare_numeric <- function(x) is.numeric(x) && !is.object(x)
R/utils.R:592:is.numeric.data.frame <- function(x) vapply(x,is.numeric,TRUE)
tests/testthat/test-data_set.R:138:  expect_true(all(mrgsolve:::is.numeric.data.frame(df)))
tests/testthat/test-data_set.R:142:  expect_true(all(mrgsolve:::is.numeric.data.frame(df)))

single.number (calls is.numeric)

$ git grep -Fn single.number
R/class_numericlist.R:22:  x1 <- all(sapply(object@data,single.number))
R/update.R:337:  non_nu <- !vapply(.y, FUN = single.number, TRUE)
R/utils.R:434:single.number <- function(x) length(x)==1 & is.numeric(x)

bare_numeric (calls is.numeric)

$ git grep -Fn bare_numeric
R/mrgindata.R:61:  nu <- vapply(x, bare_numeric, TRUE)
R/utils.R:435:bare_numeric <- function(x) is.numeric(x) && !is.object(x)

[kylebaron]

You're right. Thanks for pulling all of this out.

I put a comment below to triage all of the call sites. This pattern is so man places, I decided to keep a function to do this (numeric_columnsI()) and subbed that in where ever I found the pattern (I believe).

[kyleam]

I put a comment below to triage all of the call sites.

Thanks, that annotated list was very helpful.

[kylebaron]

$ git grep -Fn is.numeric

# Leave as is; looking at a list of matrices; previous line checks that all object@data are matrices
R/class_matlist.R:26:  x2 <- all(vapply(object@data, is.numeric, TRUE))

# Switch to the new function
R/data_set.R:425:    nu <- sapply(idata, is.numeric)

# Not a data frame
R/env.R:32:  if(is.numeric(seed)) set.seed(seed)

# Not a data frame
R/events.R:127:  if(is.numeric(tinf) && length(tinf) > 0) l[["tinf"]] <- tinf
R/events.R:128:  if(is.numeric(until) && length(until) > 0) l[["until"]] <- until
R/events.R:159:    if(!is.numeric(ID)) {

# Substitute
R/events.R:164:      if(any(!is.numeric(data))) {

# Not a data frame; only looking at atomic values per the first condition
R/events.R:623:    # TODO: refactor once is.numeric is handled
R/events.R:624:    spacer <- is.atomic(evs[[i]]) && is.numeric(evs[[i]]) && length(evs[[i]])==1

# Not a data frame
R/events.R:694:  if(is.numeric(ID)) {
R/handle_spec_block.R:333:  if(is.numeric(number)) {

# Not a data frame
R/matlist.R:477:  if(!is.numeric(range)) {

# Not a data frame
R/modspec.R:78:    resolves_int <- is.numeric(etan) && all.equal(etan, round(etan))

# This method is handling matrices (x)
R/mrgindata.R:279:  if(is.numeric(x)) {

# Not a data frame
R/mrgsolve.R:266:  if(is.numeric(nid) && !have_idata && !have_data) {

# Needs changing
R/mrgsolve.R:584:      drop <- names(which(!is.numeric(join_data)))
R/mrgsolve.R:594:      drop <- names(which(!is.numeric(join_idata)))

# Switch to new function; we _could_ get non-numeric data here from recover
R/mrgsolve.R:769:      if(!all(sapply(out[["data"]], is.numeric))) {

# Not data frames
R/nmxml.R:133:  if(!is.numeric(index)) {
R/nmxml.R:402:  if(!is.numeric(index)) wstop("index did not resolve to a numeric value")

# Not applied to data frame
R/utils.R:434:single.number <- function(x) length(x)==1 & is.numeric(x)

class_numericlist.R:  x1 <- all(sapply(object@data,single.number))
class_numericlist.R:    out <- c(out, "all parameters must be single numbers")
update.R:  non_nu <- !vapply(.y, FUN = single.number, TRUE)
utils.R:single.number <- function(x) length(x)==1 & is.numeric(x)

R/utils.R:435:bare_numeric <- function(x) is.numeric(x) && !is.object(x)

➜  git/m4solve/R (roxygen-exports)  grep bare_numeric *.R
mrgindata.R:  nu <- vapply(x, bare_numeric, TRUE)
utils.R:bare_numeric <- function(x) is.numeric(x) && !is.object(x)


# The function itself; delete
R/utils.R:592:is.numeric.data.frame <- function(x) vapply(x,is.numeric,TRUE)

# Change to the new function
tests/testthat/test-data_set.R:138:  expect_true(all(mrgsolve:::is.numeric.data.frame(df)))
tests/testthat/test-data_set.R:142:  expect_true(all(mrgsolve:::is.numeric.data.frame(df)))

Result

diff --git a/NAMESPACE b/NAMESPACE
index cc4aab0e..64b41012 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -41,7 +41,6 @@ S3method(handle_spec_block,specTHETA)
 S3method(handle_spec_block,specTRANSIT)
 S3method(handle_spec_block,specVCMT)
 S3method(handle_spec_block,specYAML)
-S3method(is.numeric,data.frame)
 S3method(lctran,data.frame)
 S3method(lctran,ev)
 S3method(length,matlist)
diff --git a/R/data_set.R b/R/data_set.R
index bd4db6e8..631c67f7 100644
--- a/R/data_set.R
+++ b/R/data_set.R
@@ -422,7 +422,7 @@ ev_assign <- function(l, idata, evgroup, join = FALSE) {
   x[["ID"]] <- ID
   
   if(join) {
-    nu <- sapply(idata, is.numeric)
+    nu <- numeric_columns(idata)
     x <- left_join(x,idata[,nu,drop=FALSE],by="ID") 
   }
   return(x)
diff --git a/R/events.R b/R/events.R
index 4109411a..585126a6 100644
--- a/R/events.R
+++ b/R/events.R
@@ -161,7 +161,7 @@ setMethod("ev", "missing", function(time=0, amt=0, evid=1, cmt=1, ID=numeric(0),
     }
     
     if(replicate) {
-      if(any(!is.numeric(data))) {
+      if(any(!numeric_columns(data))) {
         data <- as.list(data)
         data <- lapply(data, unique)
         data <- do.call("expand.grid", 
diff --git a/R/mrgsolve.R b/R/mrgsolve.R
index 290415d4..913f3e34 100644
--- a/R/mrgsolve.R
+++ b/R/mrgsolve.R
@@ -581,7 +581,7 @@ do_mrgsim <- function(x,
       join_data$.data_row. <- seq_len(nrow(data))
       data$.data_row. <- join_data$.data_row.
       carry.recover <- ".data_row."
-      drop <- names(which(!is.numeric(join_data)))
+      drop <- names(which(!numeric_columns(join_data)))
       # Will be dropped with error later when validating data
       drop <- drop[!drop %in% c(Pars(x), GLOBALS$CARRY_TRAN)]
       data <- data[,setdiff(names(data),drop),drop=FALSE]
@@ -591,7 +591,7 @@ do_mrgsim <- function(x,
     do_recover_idata <- length(recover_idata) > 0
     if(do_recover_idata) {
       join_idata <- idata[,unique(c("ID", recover_idata)),drop=FALSE]
-      drop <- names(which(!is.numeric(join_idata)))
+      drop <- names(which(!numeric_columns(join_idata)))
       # Will be dropped with error later when validating data
       drop <- drop[!drop %in% Pars(x)]
       idata <- idata[,setdiff(names(idata),drop),drop=FALSE]
@@ -766,7 +766,7 @@ do_mrgsim <- function(x,
       return(out[["data"]])  
     }
     if(output=="matrix") {
-      if(!all(sapply(out[["data"]], is.numeric))) {
+      if(!all(numeric_columns(out[["data"]]))) {
         stop("can't return matrix because non-numeric data was found.", call.=FALSE)  
       }
       return(data.matrix(out[["data"]]))
diff --git a/R/utils.R b/R/utils.R
index 73176216..26042b2c 100644
--- a/R/utils.R
+++ b/R/utils.R
@@ -588,9 +588,7 @@ make_matrix_labels <- function(mat,lab,diag=TRUE) {
 
 
 # nocov start
-# TODO: give up on this
-#' @export
-is.numeric.data.frame <- function(x) vapply(x,is.numeric,TRUE)
+numeric_columns <- function(x) vapply(x, is.numeric, TRUE)
 
 mapvalues <- function (x, from, to, warn_missing = FALSE) { 
   if (length(from) != length(to)) {
diff --git a/tests/testthat/test-data_set.R b/tests/testthat/test-data_set.R
index 01138244..cff86e13 100644
--- a/tests/testthat/test-data_set.R
+++ b/tests/testthat/test-data_set.R
@@ -135,11 +135,11 @@ test_that("numerics_only", {
   )
   df <- numerics_only(data, convert_lgl=TRUE)
   expect_equal(names(df), c("ID", "INT", "BOOL"))
-  expect_true(all(mrgsolve:::is.numeric.data.frame(df)))
+  expect_true(all(mrgsolve:::numeric_columns(df)))
   expect_message(numerics_only(data))
   df <- numerics_only(data,convert_lgl = FALSE)
   expect_equal(names(df), c("ID", "INT"))
-  expect_true(all(mrgsolve:::is.numeric.data.frame(df)))
+  expect_true(all(mrgsolve:::numeric_columns(df)))
   expect_silent(numerics_only(data,quiet=TRUE))
 })

[kyleam]

LGTM

As an added check of the is.numeric changes, I applied the following patch on top of the tip commit (0d59c55) and ran the tests.

diff --git a/R/utils.R b/R/utils.R
index 26042b2c..a2b65d15 100644
--- a/R/utils.R
+++ b/R/utils.R
@@ -590,6 +590,8 @@ make_matrix_labels <- function(mat,lab,diag=TRUE) {
 # nocov start
 numeric_columns <- function(x) vapply(x, is.numeric, TRUE)
 
+is.numeric.data.frame <- function(x) stop("hit is.numeric.data.frame")
+
 mapvalues <- function (x, from, to, warn_missing = FALSE) { 
   if (length(from) != length(to)) {
     stop("`from` and `to` vectors are not the same length.")

If the triage missed a site but it's covered by the tests, this should flag it. Tests were all green.

[kylebaron]

Awesome; thanks, @kyleam .