Merge pull request #1009 from metrumresearchgroup/release/1.0.5

Release/1.0.5

.Rbuildignore

@@ -1,5 +1,5 @@
 ^run-*\.R$
-^test-*\.R$
+^test-.*\.R$
 ^test\.R$
 Doxygen
 doxyfile

.drone.yml

@@ -3,6 +3,7 @@ kind: pipeline
 type: docker
 name: cran-latest
 
+
 platform:
   os: linux
   arch: amd64

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: mrgsolve
 Title: Simulate from ODE-Based Models
-Version: 1.0.4
+Version: 1.0.5
 Authors@R: 
     c(person(given = "Kyle T", family = "Baron",
              role = c("aut", "cre"),
@@ -35,7 +35,7 @@ URL: https://github.com/metrumresearchgroup/mrgsolve
 BugReports: 
     https://github.com/metrumresearchgroup/mrgsolve/issues
 Depends:
-    R (>= 3.1.2),
+    R (>= 3.5),
     methods
 Imports:
     Rcpp (>= 1.0.7),
@@ -49,11 +49,11 @@ Imports:
 Suggests:
     lattice,
     testthat,
-    xml2 (>= 1.2.0),
+    xml2 (>= 1.3.2),
     rmarkdown,
     yaml,
     knitr, 
-    data.table,
+    data.table (>= 1.14.2),
     pmxTools
 LinkingTo: 
     Rcpp (>= 1.0.7),
@@ -65,7 +65,7 @@ Encoding: UTF-8
 Language: en-US
 LazyLoad: yes
 NeedsCompilation: yes
-RoxygenNote: 7.1.2
+RoxygenNote: 7.2.0
 SystemRequirements: C++11
 Collate: 
     'RcppExports.R'

Makefile

@@ -98,12 +98,11 @@ test-cpp:
 	Rscript -e 'testthat::test_dir("inst/maintenance/unit-cpp")'
 
 clean:
-	rm src/*.o
-	rm src/*.so
-	if [ -d mrgsolve.Rcheck ]; then 
-	  rm -rf mrgsolve.Rcheck
-	fi
-	R CMD REMOVE mrgsolve
+	rm -rf  src/*.o
+	rm -rf src/*.so
+	if [ -d mrgsolve.Rcheck ]; then rm -Rf mrgsolve.Rcheck; fi
+	if [ -d ~/Rlibs/mrgsolve ]; then R CMD REMOVE mrgsolve; fi
+	if [ -d mrgsolve ]; then rm -Rf mrgsolve; fi
 
 datasets:
 	Rscript inst/maintenance/datasets.R

NAMESPACE

@@ -237,6 +237,7 @@ importFrom(dplyr,left_join)
 importFrom(dplyr,mutate)
 importFrom(dplyr,mutate_all)
 importFrom(dplyr,mutate_at)
+importFrom(dplyr,mutate_if)
 importFrom(dplyr,n)
 importFrom(dplyr,pull)
 importFrom(dplyr,rename)

NEWS.md

@@ -1,3 +1,38 @@
+# mrgsolve 1.0.5
+
+- Changed behavior for dosing records where EVID = 4 and SS != 0 
+  to match what is done by NONMEM: the system will be advanced to 
+  steady-state but will not be reset; behavior prior to 1.0.5 
+  release was to advance to steady-state and then reset (#1011).
+
+- Any column in an input data set that has a class attribute will
+  now be dropped in addition to non-numeric columns; this includes
+  columns that are `integer64` which can be present in data frames
+  derived from `data.table::fread()` or other `.csv` readers 
+  (#1008).
+
+- The `$MAIN` and `$TABLE` blocks will no longer get called for 
+  _actual_ dose administration records with lag times; this could 
+  change time after dose calculations or other calculations that 
+  could be happening in those blocks when the _actual_ administration 
+  is taking place (#992). 
+
+- Code to update the parameter list was re-factored to be much more 
+  efficient (#978).
+
+## Bugs Fixed
+
+- Fix bug where apparent dosing events for additional doses with lag
+  times were not getting scheduled (only records for the _actual_ 
+  administration); this doesn't change the simulated output but could
+  change time after dose calculation (#992).
+
+- Fix bug where special `nm-vars` variables were not getting recognized 
+  as valid capture items during dynamic capture (#987).
+
+- Fix bug when updating the parameter list with a data frame that included
+  non-numeric columns that were not parameters (#978). 
+
 # mrgsolve 1.0.4
 
 - Fix bug where `as_data_frame()` was not properly working when leading event

R/Aaaa.R

@@ -21,7 +21,7 @@
 #' @importFrom utils packageVersion assignInMyNamespace read.table
 #' @importFrom stats as.formula setNames rnorm
 #' @importFrom dplyr filter mutate mutate_at mutate_all distinct first
-#' @importFrom dplyr bind_rows arrange summarise summarise_at
+#' @importFrom dplyr bind_rows arrange summarise summarise_at mutate_if
 #' @importFrom dplyr intersect select rename do slice pull
 #' @importFrom dplyr if_else summarise_each is.tbl select
 #' @importFrom dplyr group_by ungroup n left_join

R/RcppExports.R

@@ -1,8 +1,8 @@
 # Generated by using Rcpp::compileAttributes() -> do not edit by hand
 # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
 
-DEVTRAN <- function(parin, inpar, parnames, init, cmtnames, capture, funs, data, idata, OMEGA, SIGMA, envir) {
-    .Call(`_mrgsolve_DEVTRAN`, parin, inpar, parnames, init, cmtnames, capture, funs, data, idata, OMEGA, SIGMA, envir)
+DEVTRAN <- function(parin, funs, data, idata, mod) {
+    .Call(`_mrgsolve_DEVTRAN`, parin, funs, data, idata, mod)
 }
 
 MVGAUSS <- function(OMEGA_, n) {
@@ -17,6 +17,10 @@ SUPERMATRIX <- function(a, keep_names) {
     .Call(`_mrgsolve_SUPERMATRIX`, a, keep_names)
 }
 
+MAKEMATRIX <- function(matlist) {
+    .Call(`_mrgsolve_MAKEMATRIX`, matlist)
+}
+
 get_tokens <- function(code) {
     .Call(`_mrgsolve_get_tokens`, code)
 }
@@ -29,7 +33,7 @@ EXPAND_OBSERVATIONS <- function(data, times, to_copy, next_pos) {
     .Call(`_mrgsolve_EXPAND_OBSERVATIONS`, data, times, to_copy, next_pos)
 }
 
-TOUCH_FUNS <- function(lparam, linit, Neta, Neps, capture, funs, envir) {
-    .Call(`_mrgsolve_TOUCH_FUNS`, lparam, linit, Neta, Neps, capture, funs, envir)
+TOUCH_FUNS <- function(funs, mod) {
+    .Call(`_mrgsolve_TOUCH_FUNS`, funs, mod)
 }
 

R/class_matlist.R

@@ -1,4 +1,4 @@
-# Copyright (C) 2013 - 2019  Metrum Research Group, LLC
+# Copyright (C) 2013 - 2022  Metrum Research Group
 #
 # This file is part of mrgsolve.
 #
@@ -16,22 +16,23 @@
 # along with mrgsolve.  If not, see <http://www.gnu.org/licenses/>.
 
 # this won't get included in coverage since it's copied into the class def
+
 # nocov start
 valid.matlist <- function(object) {
 
   labels <- names(object@data)[names(object@data) != "..."]
 
-  x1 <- all(sapply(object@data, is.matrix))
-  x2 <- all(sapply(object@data, is.numeric))
+  x1 <- all(vapply(object@data, is.matrix, TRUE))
+  x2 <- all(vapply(object@data, is.numeric, TRUE))
 
   x3 <- (!any(duplicated(labels))) | length(labels)==0
 
-  x4 <- all(sapply(object@data, det)>=0)
+  x4 <- all(vapply(object@data, FUN = det, FUN.VALUE = 1.23) >= 0)
 
   x5 <- mapply(object@data, object@labels, FUN=function(x,y) {
     nrow(x) == length(y)
-  }) %>% all
-
+  })
+  x5 <- all(x5)
 
   x <- x1 & x2 & x3 & x4 & x5
 
@@ -47,14 +48,14 @@ valid.matlist <- function(object) {
   }
 
   if(!x4) {
-    y <- which(!sapply(object@data, det) > 0)
+    y <- which(!vapply(object@data, FUN = det, FUN.VALUE = 1.23) >= 0)
     message("Problem with this matrix:")
     print(object@data[y])
     out <- c(out, "Invalid matrix: determinant is less than 0.")
   }
   if(!x5) {
-    n1 <- paste(sapply(object@data,   nrow),collapse=",")
-    n2 <- paste(sapply(object@labels, length),collapse=',')
+    n1 <- paste(vapply(object@data,   nrow, 1L), collapse = ",")
+    n2 <- paste(vapply(object@labels, length, 1L), collapse = ',')
     out <- c(
       out, 
       paste0("Length of labels (", n2, ") does not match the matrix rows (", n1, ").")

R/class_mrgmod.R

@@ -746,14 +746,8 @@ blocks_ <- function(file,what) {
 
 parin <- function(x) {
   list(
-    rtol=x@rtol,atol=x@atol,ss_rtol=x@ss_rtol,ss_atol=x@ss_atol,
-    hmin=as.double(x@hmin), hmax=as.double(x@hmax),
-    maxsteps=x@maxsteps,ixpr=x@ixpr,mxhnil=x@mxhnil,
-    verbose=as.integer(x@verbose),debug=x@debug,
-    digits=x@digits, tscale=x@tscale,
-    mindt=x@mindt, advan=x@advan, 
     ss_n = 500, ss_fixed = FALSE, 
-    ss_cmt = x@ss_cmt, interrupt = -1
+    interrupt = -1
   )
 }
 

R/compile.R

@@ -222,21 +222,10 @@ cleanso <- function(x,where=soloc(x)) {
 ##' 
 ##' @export
 ##' @keywords internal
-touch_funs <- function(x,keep_pointers=TRUE) {
-
+touch_funs <- function(x, keep_pointers = TRUE) {
   funp <- pointers(x)
-
-  param <- as.numeric(param(x))
-  init <- as.numeric(x@init)
-  neta <- sum(nrow(omat(x)))
-  neps <- sum(nrow(smat(x)))
-
-  out <- .Call(`_mrgsolve_TOUCH_FUNS`,param,init,
-               neta,neps,x@capture,funp,
-               x@envir, PACKAGE = "mrgsolve")
-
-  names(out$init) <- names(init)
-
+  out <- .Call(`_mrgsolve_TOUCH_FUNS`, funp, x, PACKAGE = "mrgsolve")
+  names(out$init) <- Cmt(x)
   if(keep_pointers) {
     out[["pointers"]] <- funp
   }

R/events.R

@@ -161,6 +161,7 @@ setMethod("ev", "missing", function(time=0, amt=0, evid=1, cmt=1, ID=numeric(0),
         rownames(data) <- NULL
       } else {
         data <- expand_event_object(data,ID)
+        rownames(data) <- NULL
       }
 
     } else {

R/funset.R

@@ -42,8 +42,8 @@ clean_symbol <- function(x) {
   gsub("[[:punct:]]", "__", x)
 }
 
-funs_create <- function(model,what=c("main", "ode", "table", "config")) {
-  setNames(paste0("_model_", clean_symbol(model), "_",what ,"__"),what)
+funs_create <- function(model, what = c("main", "ode", "table", "config")) {
+  setNames(paste0("_model_", clean_symbol(model), "_", what ,"__"),what)
 }
 
 register_fun <- function(model) {
@@ -67,7 +67,7 @@ which_loaded <- function(x) {
 }
 
 funs_loaded <- function(x,crump=TRUE) {
-  all(which_loaded(x)) & compiled(x)
+  main_loaded(x) && compiled.mrgmod(x)
 }
 
 all_loaded <- function(x) all(which_loaded(x))  
@@ -82,7 +82,7 @@ pointers <- function(x) {
   }
   what <- funs(x)
   ans <- getNativeSymbolInfo(what,PACKAGE=dllname(x))
-  setNames(lapply(ans, "[[","address"),names(what))
+  setNames(lapply(ans, "[[", "address"), names(what))
 }
 
 funset <- function(x) {

R/matrix.R

@@ -33,6 +33,7 @@ decorr <- function(x) {
   return(invisible(.Call(`_mrgsolve_dcorr`, x)))
 }
 
+
 ##' Create a square numeric matrix from the lower-triangular elements
 ##'
 ##' @param x numeric data

R/modspec.R

@@ -767,6 +767,9 @@ get_valid_capture <- function(param, omega, sigma, build, mread.env) {
     build[["cpp_variables"]][["var"]], 
     mread.env[["autov"]]
   )
+  if(isTRUE(mread.env[["using_nm-vars"]])) {
+    ans <- c(ans, build[["nm-vars"]][["match"]][["match"]])  
+  }
   unique(ans)
 }
 

R/mrgindata.R

@@ -40,7 +40,7 @@ cmtname <- function(x) {
 numeric_data_matrix <- function(x, quiet = FALSE) {
   x <- do.call(cbind, numerics_only(x, quiet)) 
   if(ncol(x)==0) stop("invalid data set.", call.=FALSE)
-  return(x)
+  x
 }
 
 ##' Prepare data.frame for input to mrgsim
@@ -52,13 +52,13 @@ numeric_data_matrix <- function(x, quiet = FALSE) {
 ##' columns with \code{\link{as.integer}}
 ##' 
 ##' @export
-numerics_only <- function(x,quiet=FALSE,convert_lgl=FALSE) {
+numerics_only <- function(x, quiet = FALSE, convert_lgl = FALSE) {
   if(convert_lgl) {
     if(any(vapply(x,is.logical,TRUE))) {
-      x <- dplyr::mutate_if(x, is.logical, as.integer)
+      x <- mutate_if(x, is.logical, as.integer)
     }
   }
-  nu <- vapply(x, is.numeric, TRUE)
+  nu <- vapply(x, bare_numeric, TRUE)
   if(!all(nu)) {
     if(!quiet) {
       message(
@@ -81,6 +81,17 @@ convert_character_cmt <- function(data, mod) {
   return(data)
 }
 
+signal_drop <- function(dm, x, to_signal, context) {
+  drop <- setdiff(names(x), dimnames(dm)[[2]])
+  drop <- intersect(drop, to_signal)
+  for(d in drop) {
+    type <- paste0(class(x[[d]]), collapse = ",")
+    msg <- c(context, " dropped column: ", d, " (", type, ")")
+    message(msg)  
+  }
+  invisible(NULL)
+}
+
 ##' Validate and prepare a data sets for simulation
 ##'
 ##' This function is called by mrgsim.  Users may also call this function
@@ -165,11 +176,8 @@ valid_data_set <- function(x, m = NULL, verbose = FALSE, quiet = FALSE) {
   dm <- numeric_data_matrix(x,quiet=TRUE)
 
   if((ncol(dm) != ncol(x)) && !quiet) {
-    drop <- setdiff(names(x), dimnames(dm)[[2]])
-    drop <- intersect(drop, c(Pars(m),GLOBALS$CARRY_TRAN))
-    for(d in drop) {
-      message("[data-set] dropped non-numeric: ", d)  
-    }
+    to_signal <- c(Pars(m), GLOBALS$CARRY_TRAN)
+    signal_drop(dm, x, to_signal, context = "[data-set]")
   }
 
   check_data_set_na(dm,m)
@@ -223,11 +231,8 @@ valid_idata_set <- function(x, m, verbose = FALSE, quiet = FALSE) {
   dm <- numeric_data_matrix(x, quiet = TRUE)
 
   if((ncol(dm) != ncol(x)) && !quiet) {
-    drop <- setdiff(names(x), dimnames(dm)[[2]])
-    drop <- intersect(drop, Pars(m))
-    for(d in drop) {
-      message("[idata-set] dropped non-numeric: ", d)  
-    }
+    to_signal <- Pars(m)
+    signal_drop(dm, x, to_signal, context = "[idata-set]")
   }
 
   check_data_set_na(dm, m)