kylebaron
commented
1 month ago
$ 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))
})
I don't think
print.mrgmod()was doing any dispatch;modis anS4object and there's ashowmethod for that which just callsprint.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 changedis.numeric.data.frame(or similar pattern) tonumeric_columns().Note that there are places in the code where we rely on the names that come back from that function.