Merge pull request #974 from metrumresearchgroup/release/1.0.4

Release/1.0.4

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: mrgsolve
 Title: Simulate from ODE-Based Models
-Version: 1.0.3
+Version: 1.0.4
 Authors@R: 
     c(person(given = "Kyle T", family = "Baron",
              role = c("aut", "cre"),

Makefile

@@ -94,6 +94,9 @@ test1:
 test2:
 	Rscript -e 'testthat::test_dir("inst/maintenance/unit")'
 
+test-cpp: 
+	Rscript -e 'testthat::test_dir("inst/maintenance/unit-cpp")'
+
 clean:
 	rm src/*.o
 	rm src/*.so

NAMESPACE

@@ -40,6 +40,8 @@ S3method(handle_spec_block,specTHETA)
 S3method(handle_spec_block,specTRANSIT)
 S3method(handle_spec_block,specVCMT)
 S3method(handle_spec_block,specYAML)
+S3method(lctran,data.frame)
+S3method(lctran,ev)
 S3method(length,matlist)
 S3method(loadso,mrgmod)
 S3method(merge,list)
@@ -61,6 +63,8 @@ S3method(summarise,each)
 S3method(summarise,mrgsims)
 S3method(summary,mrgmod)
 S3method(summary,mrgsims)
+S3method(uctran,data.frame)
+S3method(uctran,ev)
 S3method(within,mrgmod)
 export("%>%")
 export("%then%")
@@ -105,7 +109,9 @@ export(ev_repeat)
 export(ev_rx)
 export(ev_seq)
 export(evd)
+export(evd_expand)
 export(expand.ev)
+export(expand.evd)
 export(expand.idata)
 export(expand_observations)
 export(file_show)

NEWS.md

@@ -1,3 +1,24 @@
+# mrgsolve 1.0.4
+
+- Fix bug where `as_data_frame()` was not properly working when leading event
+  object was `evd` type (#948, #955).
+
+- Add `uctran()` to convert nmtran data names to upper case (#955). 
+
+- Both `lctran()` and `uctran()` are generic and work on `data.frame` or 
+  event (`ev`) objects (#949, #955). 
+
+- Fix bug where data records with `EVID = 3` were getting shifted in time by
+  `ALAG` (#964, #969).
+
+- Small negative eigenvalues from `OMEGA` or `SIGMA` are set to zero in 
+  multivariate normal simulation of `ETA` and `EPS`, following the pattern
+  seen in `MASS::mvrnorm()` (#956, #957).
+
+- Fixed bug where template parameters (`T`) were getting modified when `nm-vars`
+  plugin was used in conjunction with `mrgx` plugin (#965, #968).
+
+
 # mrgsolve 1.0.3
 
 - Removed `assert()` statement in LSODA code found by CRAN check (#943).

R/class_evd.R

@@ -13,8 +13,8 @@
 #' Note that `evd` isn't a separate class; it is just an `ev` object with 
 #' a specific `case` attribute. See examples which illustrate the difference.
 #' 
-#' @param x An mrgmod object.
-#' @param ... Arguments passed to [ev()].
+#' @param x an mrgmod object.
+#' @param ... arguments passed to [ev()].
 #' 
 #' @examples
 #' a <- evd(amt = 100)
@@ -51,8 +51,7 @@ setMethod("evd", "ev", function(x, ...) {
   set_ev_case(x, 1L)
 })
 
-
-#' @param x An event object.
+#' @param x an event object.
 #' @rdname evd
 #' @export
 as.evd <- function(x) {

R/data_set.R

@@ -167,12 +167,13 @@ setMethod("data_set", c("mrgmod", "missing"), function(x, object, ...) {
 #' If both lower and upper case versions of the name are present in the data 
 #' frame, no changes will be made. 
 #' 
-#' @param data A data set with nmtran-like format.
-#' @param warn If `TRUE`, a warning will be issued when there are both upper
+#' @param data a data set with nmtran-like format.
+#' @param warn if `TRUE`, a warning will be issued when there are both upper
 #' and lower case versions of any nmtran-like column in the data frame.
+#' @param ... for potential future use.
 #' 
 #' @return 
-#' A data frame with possibly renamed columns.
+#' A data frame or event object with possibly renamed columns.
 #' 
 #' @examples
 #' data <- data.frame(TIME = 0, AMT = 5, II = 24, addl = 2, WT = 80)
@@ -181,6 +182,9 @@ setMethod("data_set", c("mrgmod", "missing"), function(x, object, ...) {
 #' data <- data.frame(TIME = 0, AMT = 5, II = 24, addl = 2, wt = 80)
 #' uctran(data)
 #' 
+#' ev <- evd(amt = 100, evid = 3)
+#' uctran(ev)
+#' 
 #' # warning
 #' data <- data.frame(TIME = 1, time = 2, CMT = 5)
 #' lctran(data)
@@ -190,10 +194,10 @@ setMethod("data_set", c("mrgmod", "missing"), function(x, object, ...) {
 #' 
 #' @md
 #' @export
-lctran <- function(data, warn = TRUE) {
-  if(!is.data.frame(data)) {
-    stop("`data` must be a data.frame.") 
-  }
+lctran <- function(data, ...) UseMethod("lctran")
+#' @rdname lctran
+#' @export
+lctran.data.frame <- function(data, warn = TRUE, ...) {
   n <- names(data)
   infrom <- n %in% GLOBALS$TRAN_UPPER
   haslower <- tolower(n) %in% n
@@ -207,13 +211,17 @@ lctran <- function(data, warn = TRUE) {
   }
   data
 }
-
 #' @rdname lctran
 #' @export
-uctran <- function(data, warn = TRUE) {
-  if(!is.data.frame(data)) {
-    stop("`data` must be a data.frame.") 
-  }
+lctran.ev <- function(data, ...) {
+  as.ev(data)
+}
+#' @rdname lctran
+#' @export
+uctran <- function(data, ...) UseMethod("uctran")
+#' @rdname lctran
+#' @export
+uctran.data.frame <- function(data, warn = TRUE, ...) {
   n <- names(data)
   infrom <- n %in% GLOBALS$TRAN_LOWER
   hasupper <- toupper(n) %in% n
@@ -227,6 +235,11 @@ uctran <- function(data, warn = TRUE) {
   }
   data
 }
+#' @rdname lctran
+#' @export
+uctran.ev <- function(data, ...) {
+  as.evd(data)
+}
 
 data_hooks <- function(data, object, envir, param = list(), ...) {
   param <- as.list(param)
@@ -295,7 +308,7 @@ setGeneric("as_data_set", function(x,...) standardGeneric("as_data_set"))
 setMethod("as_data_set", "ev", function(x, ...) {
   other_ev <- list(...)
   if(length(other_ev)==0) {
-    return(check_ev(x)) 
+    return(ev_to_ds(x)) 
   }
   do.call(collect_ev, c(list(x), other_ev))
 })

R/events.R

@@ -262,6 +262,7 @@ setMethod("as.ev", "data.frame",  df_to_ev)
 #' @rdname as.ev
 #' @export
 setMethod("as.ev", "ev", function(x, ...) {
+  x@case <- 0L
   x
 })
 

R/utils.R

@@ -200,59 +200,73 @@ my_str_split <- function(string,pattern,n=3,fixed=FALSE,collapse=pattern) {
   lapply(m,collapsen,collapse=collapse,n=n)
 }
 
-##' Create template data sets for simulation
-##'
-##' @param ... passed to [expand.grid]
-##' 
-##' @details
-##' An ID column is added as `seq(nrow(ans))` if not supplied by the user.  
-##' For `expand.ev`, defaults also added include `cmt = 1`, 
-##' `time = 0`, `evid = 1`.  If `total` is included, 
-##' then `addl` is derived as `total` - 1. If `tinf` is included, then 
-##' an infusion rate is derived for row where `tinf` is greater than 
-##' zero.
-##'
-##' @examples
-##' idata <- expand.idata(CL = c(1,2,3), VC = c(10,20,30))
-##'
-##' doses <- expand.ev(amt = c(300,100), ii = c(12,24), cmt = 1)
-##' 
-##' infusion <- expand.ev(amt = 100, tinf = 2)
-##' 
-##' @md
-##' @export
+#' Create template data sets for simulation
+#' 
+#' These functions expand all combinations of arguments using 
+#' [expand.grid()]. The result always has only one row for one individual.
+#' Use [expand.evd()] or [evd_expand()] to convert nmtran names (e.g. AMT
+#' or CMT) to upper case (see [uctran()]).
+#'
+#' @param ... passed to [expand.grid()]
+#' 
+#' @details
+#' An ID column is added as `seq(nrow(ans))` if not supplied by the user. For 
+#' `expand.ev`, defaults also added include `cmt = 1`, `time = 0`, `evid = 1`.  
+#' If `total` is included, then `addl` is derived as `total` - 1. If `tinf` is 
+#' included, then an infusion rate is derived for row where `tinf` is greater 
+#' than zero.
+#'
+#' @examples
+#' idata <- expand.idata(CL = c(1,2,3), VC = c(10,20,30))
+#'
+#' doses <- expand.ev(amt = c(300,100), ii = c(12,24), cmt = 1)
+#' 
+#' infusion <- expand.ev(amt = 100, tinf = 2)
+#' 
+#' @md
+#' @export
 expand.idata <- function(...) {
-  ans <- expand.grid(...,stringsAsFactors=FALSE, KEEP.OUT.ATTRS = FALSE)
-  ans$ID <- seq_len(nrow(ans))
-  dplyr::select(ans, "ID", everything())
+  ans <- expand.grid(..., stringsAsFactors = FALSE, KEEP.OUT.ATTRS = FALSE)
+  ans$ID <- seq(nrow(ans))
+  ans[, unique(c("ID", names(ans))), drop = FALSE]
 }
 
 #' @export
 #' @rdname expand.idata
 expand.ev <- function(...) {
-  ans <- expand.grid(...,stringsAsFactors=FALSE)
-  ans[["ID"]] <- seq_len(nrow(ans))
+  ans <- expand.grid(..., stringsAsFactors = FALSE)
+  ans[["ID"]] <- seq(nrow(ans))
   if(!has_name("evid", ans)) ans[["evid"]] <- 1
   if(!has_name("cmt", ans)) ans[["cmt"]] <- 1
   if(!has_name("time", ans)) ans[["time"]] <- 0
   if(!has_name("amt", ans)) ans[["amt"]] <- 0
   finalize_ev(ans)
 }
 
+#' @rdname expand.idata
 #' @export
+expand.evd <- function(...) {
+  uctran(expand.ev(...))  
+}
+
 #' @rdname expand.idata
+#' @export
 ev_expand <- expand.ev
 
+#' @export
+#' @rdname expand.idata
+evd_expand <- expand.evd
+
 #' Expand an event data frame across multiple ID
 #' 
 #' @noRd
-expand_event_object <- function(event,ID) {
+expand_event_object <- function(event, ID) {
   event <- as.data.frame(event)
   out_names <- unique(c("ID", names(event)))
-  ind <- rep(seq(nrow(event)), times=length(ID))
-  big <- dplyr::slice(event, ind)
-  big[["ID"]] <- rep(ID, each=nrow(event))
-  big[,out_names]
+  ind <- rep(seq(nrow(event)), times = length(ID))
+  big <- event[ind, , drop = FALSE]
+  big[["ID"]] <- rep(ID, each = nrow(event))
+  big[, out_names, drop = FALSE]
 } 
 
 tolist <- function(x,concat=TRUE,envir=list()) {

inst/WORDLIST

@@ -145,3 +145,4 @@ QD
 KA
 pkgdown
 Rcpp
+df

inst/maintenance/unit-cpp/test-cpp.R

@@ -0,0 +1,26 @@
+
+library(testthat)
+library(mrgsolve)
+library(dplyr)
+
+Sys.setenv(R_TESTS="")
+options("mrgsolve_mread_quiet"=TRUE)
+
+context("test-cpp")
+
+code <- '
+[ plugin ] nm-vars, mrgx, Rcpp
+
+[ cmt ] @number 1
+
+[ des ]  
+DADT(1) = -0.1 * A(1);
+'
+
+test_that("build a model with mrgx and nm-vars", {
+  expect_is(
+    mcode("test-cpp-mrgx-nm-vars", code, quiet = TRUE), 
+    "mrgmod"
+  )
+})
+

inst/maintenance/unit/test-z-alag-f.R

@@ -155,3 +155,14 @@ test_that("ALAG is set from data", {
 
 })
 
+test_that("ALAG does not change records with EVID 3 [SLV-TEST-0007]", {
+  data1 <- c(
+    ev(amt = 100), 
+    ev(amt = 0, evid = 3, time = 8), 
+    ev(amt = 100, time = 12)
+  )
+  data2 <- mutate(data1, ALAG1 = c(0, 5, 0))
+  out1 <- mrgsim(mod, data1, end = 24)
+  out2 <- mrgsim(mod, data2, end = 24)
+  expect_equal(out1@data, out2@data)
+})

inst/mrgx/mrgx.h

@@ -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.
 //
@@ -128,8 +128,8 @@ double rlognorm(const double mean, const double sd, const double lower,
  * @param self the model data object
  * @return an object from the model environment
  */
-template<typename T>
-T get(const std::string name, const databox& self) {
+template<typename _T___>
+_T___ get(const std::string name, const databox& self) {
   Rcpp::Environment env = get_envir(self);
   return env[name];
 }
@@ -147,8 +147,8 @@ T get(const std::string name, const databox& self) {
  * @param name name of the R object to get
  * @return an object from the global environment
  */
-template<typename T>
-T get(const std::string name) {
+template<typename _T___>
+_T___ get(const std::string name) {
   Rcpp::Environment env = Rcpp::Environment::global_env();
   return env[name];
 } 
@@ -180,10 +180,10 @@ T get(const std::string name) {
  * @param name name of the object to get
  * @return an object from the package namespace
  */
-template<typename T>
-T get(const std::string package, const std::string name) {
+template<typename _T___>
+_T___ get(const std::string package, const std::string name) {
   Rcpp::Environment env = Rcpp::Environment::namespace_env(package);
-  T ans = env[name];
+  _T___ ans = env[name];
   return ans;
 }
 
@@ -194,8 +194,8 @@ T get(const std::string package, const std::string name) {
  * @param filename the name of the RDS file to read
  * @return an object saved in the RDS file
  */
-template<typename T>
-T readRDS(const std::string filename) {
+template<typename _T___>
+_T___ readRDS(const std::string filename) {
   Rcpp::Function readRDS = get<Rcpp::Function>("base", "readRDS");
   return readRDS(filename);
 }