Merge pull request #830 from metrumresearchgroup/cran/0.11.1

Release/0.11.1

DESCRIPTION

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

NAMESPACE

@@ -87,8 +87,6 @@ export(data_set)
 export(design)
 export(dmat)
 export(do_mrgsim)
-export(drop.re)
-export(drop_re)
 export(env_eval)
 export(env_get)
 export(env_get_env)
@@ -164,7 +162,6 @@ export(valid_data_set)
 export(valid_data_set.matrix)
 export(valid_idata_set)
 export(wf_sweep)
-export(zero.re)
 export(zero_re)
 exportClasses(ev)
 exportClasses(mrgmod)
@@ -210,7 +207,7 @@ exportMethods(smat)
 exportMethods(stime)
 exportMethods(tail)
 exportMethods(update)
-exportMethods(zero.re)
+exportMethods(zero_re)
 import(methods)
 importFrom(Rcpp,evalCpp)
 importFrom(dplyr,arrange)

NEWS.md

@@ -1,3 +1,16 @@
+# mrgsolve 0.11.1
+
+- `mrgsim()` will now periodically check for user interrupt signal so that 
+  long-running simulations can be stopped using `Esc` and / or `Control-C`; 
+  the check interval can be modified through the `interrupt` argument to 
+  `mrgsim()`, but for most applications, this shouldn't need to be changed 
+  (#823)
+- `mrgsim()` will issue a warning if duplicate columns are found in simulated
+  output and rename duplicates using `make.names()`; thanks @FelicienLL
+  for the report (#827, #828)
+- Users can now turn compartments to `OFF` when they have active infusions 
+  running; this was previously an error (#822)
+
 # mrgsolve 0.11.0
 
 - The absolute paths to nonmem output files (`root.xml` or `root.ext`) are now 

R/class_mrgmod.R

@@ -734,7 +734,7 @@ parin <- function(x) {
     digits=x@digits, tscale=x@tscale,
     mindt=x@mindt, advan=x@advan, 
     ss_n = 500, ss_fixed = FALSE, 
-    ss_cmt = x@ss_cmt
+    ss_cmt = x@ss_cmt, interrupt = -1
   )
 }
 

R/matlist.R

@@ -200,24 +200,37 @@ setMethod("smat", "mrgsims", function(.x,make=FALSE,...) {
   as.matrix(mod(.x)@sigma)
 })
 
-##' Methods for working with matrix-list objects
-##'
-##' @param .x a matlist object
-##' @param x a matlist object
-##' @param .drop if \code{TRUE}, \code{zero_re} will drop \code{omega}
-##' or \code{sigma} or both entirely
-##' @param ... passed along
-##'
-##' @export
-##' @aliases zero.re 
-##' @name matlist
-##' @rdname matlist
-setGeneric("zero.re", function(.x,...) standardGeneric("zero.re"))
 
-##' @export
-##' @rdname matlist
-setMethod("zero.re", "mrgmod", function(.x,...,.drop=FALSE) {
-  if(.drop) return(drop_re(.x,...))
+#' Zero out random effects in a model object
+#' 
+#' Sets all elements of the OMEGA or SIGMA matrix to zero
+#' 
+#' @param .x a model object
+#' @param ... which matrix to zero out; pass `omega` to just zero out `omega`, 
+#' `sigma` to just zero out `sigma`; passing nothing will zero out both
+#' 
+#' @return 
+#' An updated object.
+#' 
+#' @examples
+#' 
+#' mod <- house()
+#' revar(mod)
+#' mod <- zero_re(mod)
+#' revar(mod)
+#'
+#' \dontrun{
+#' mod <- modlib("popex", compile = FALSE)
+#' mod <- zero_re(mod, omega)
+#' revar(mod)
+#' }
+#' @md
+#' @export
+setGeneric("zero_re", function(.x, ...) standardGeneric("zero_re"))
+
+#' @rdname zero_re
+#' @export
+setMethod("zero_re", "mrgmod", function(.x, ...) {
   what <- as.character(eval(substitute(alist(...))))
   if(length(what)==0) what <- c("omega", "sigma")
   if(is.element("omega", what) & !is.null(nrow(omat(.x)))) {
@@ -229,81 +242,59 @@ setMethod("zero.re", "mrgmod", function(.x,...,.drop=FALSE) {
   return(.x)
 })
 
-##' @rdname matlist
-##' @export
-zero_re <- function(...) zero.re(...)
 
-#' Deprecated: drop random effect matrices from model object
-#' 
-#' 
-#' @param .x not used
-#' @param ... not used
-#' 
-#' @details 
-#' Users are no longer allowed to remove random effect matrices from the model 
-#' object.  Use [zero_re] instead to convert the matrix to all zeros.
-#' 
-#' 
-#' @seealso [zero_re]
-#' @md
-#' @export
-drop_re <- function(.x,...) {
-  lifecycle::deprecate_stop("0.10.1", "drop_re()", "zero_re()")
-  # .Deprecated(msg="drop.re and drop_re are deprecated.  Use zero_re instead.")
-  # what <- as.character(eval(substitute(alist(...))))
-  # if(length(what)==0) what <- c("omega", "sigma")
-  # if(is.element("omega", what)) .x@omega <- new("omegalist")
-  # if(is.element("sigma", what)) .x@sigma <- new("sigmalist")
-  # return(.x)
-}
+#' Methods for working with matrix-list objects
+#'
+#' @param .x a matlist object
+#' @param x a matlist object
+#' @param ... passed through to other methods
+#'
+#' @name matlist
+#' @rdname matlist
+NULL
 
-#' @rdname drop_re
+#' @rdname matlist
 #' @export
-drop.re <- function(...) {
-  lifecycle::deprecate_stop("0.10.1", "drop.re()", "zero_re()")
-}
-
-##' @export
-##' @rdname matlist
 setMethod("as.list", "matlist", function(x, ...) x@data)
 
-##' @export
-##' @rdname matlist
-setMethod("as.matrix", "matlist", function(x,...) {
+#' @rdname matlist
+#' @export
+setMethod("as.matrix", "matlist", function(x, ...) {
   if(length(x@data)==0) return(matrix(nrow=0,ncol=0))
-  SUPERMATRIX(x@data,...)
+  SUPERMATRIX(x@data, ...)
 })
 
-##' @export
-##' @rdname matlist
+#' @rdname matlist
+#' @export
 names.matlist <- function(x) {
   names(x@data)  
 }
 
-##' @export
-##' @rdname matlist
+#' @rdname matlist
+#' @export
 length.matlist <- function(x) {
   length(x@data)  
 }
 
-##' @export
-##' @rdname matlist
+#' @rdname matlist
+#' @export
 setMethod("labels", "matlist", function(object,...) {
   object@labels
 })
 
-##' @export
-##' @rdname matlist
+#' @rdname matlist
+#' @export
 setMethod("dim", "matlist", function(x)  lapply(x@data, dim))
 
-##' @export
-##' @rdname matlist
+#' @rdname matlist
+#' @export
 setMethod("nrow", "matlist", function(x) unlist(lapply(x@data, nrow)))
 
-##' @rdname matlist
-##' @param object passed to showmatlist
-##' @export
-##' @keywords internal
+
+#' @param object passed to showmatlist
+#' @rdname matlist
+#' @keywords internal
+#' @export
 setMethod("show", "matlist", function(object) showmatlist(object))
 showmatlist <- function(x,...) {
 

R/mrgsolve.R

@@ -461,6 +461,10 @@ mrgsim_nid <- function(x, nid, events = ev(), ...) {
 #' To silence warnings related to steady state, set `ss_fixed` to `TRUE` and 
 #' set `ss_n` as the maximum number of iterations to try when advancing the 
 #' system for steady state determination.
+#' @param interrupt integer check user interrupt interval; when `interrupt` is a 
+#' positive integer, the simulation will check for the user interrupt signal
+#' every `interrupt` simulation records; pass a negative number to never check
+#' for the user interrupt interval.
 #' 
 #' @md
 #' @rdname mrgsim
@@ -487,6 +491,7 @@ do_mrgsim <- function(x,
                       skip_init_calc = FALSE,
                       ss_n = 500,
                       ss_fixed = FALSE,
+                      interrupt = 256,
                       ...) {
 
   x <- update(x,...,strict=TRUE)
@@ -591,6 +596,7 @@ do_mrgsim <- function(x,
   parin$ss_fixed <- ss_fixed
   parin$ss_n <- ss_n
   parin$request <- Cmti(x)-1L
+  parin$interrupt <- interrupt
 
   if(tad && any(x@capture =="tad")) {
     wstop("tad argument is true and 'tad' found in $CAPTURE") 
@@ -666,9 +672,27 @@ do_mrgsim <- function(x,
     x@capL # already re-named
   )
 
+  if(anyDuplicated.default(cnames)) {
+    dups <- duplicated(cnames)
+    new_names <- make.names(cnames, unique = TRUE)
+    warning("duplicate output columns found; these will be renamed", call.=FALSE)
+    for(dup in which(dups)) {
+      prev <- cnames[dup]
+      updated <- new_names[dup]
+      warning(
+        glue("duplicate renamed: {prev} -> {updated}"),
+        call. = FALSE
+      )
+    }
+    cnames <- new_names
+  }
+
   dimnames(out[["data"]]) <- list(NULL, cnames)
 
-  ans <- as.data.frame(out[["data"]])
+  ans <- as.data.frame.matrix(
+    out[["data"]], 
+    stringsAsFactors = FALSE
+  )
 
   if(do_recover_data || do_recover_idata) {
     if(do_recover_data) {

R/utils.R

@@ -222,7 +222,7 @@ my_str_split <- function(string,pattern,n=3,fixed=FALSE,collapse=pattern) {
 ##' @md
 ##' @export
 expand.idata <- function(...) {
-  ans <- expand.grid(...,stringsAsFactors=FALSE)
+  ans <- expand.grid(...,stringsAsFactors=FALSE, KEEP.OUT.ATTRS = FALSE)
   ans$ID <- seq_len(nrow(ans))
   dplyr::select(ans, "ID", everything())
 }

inst/include/odeproblem.h

@@ -250,6 +250,7 @@ class odeproblem {
   config_func Config; ///< <code>$PREAMBLE</code> function
 
   bool Do_Init_Calc; ///< Flag regulating whether or not initials are taken from <code>$MAIN</code>
+  int interrupt; ///< Check User Interrupt interval (number of simulation records)
 };
 
 

inst/maintenance/unit/test-on-off.R

@@ -52,3 +52,39 @@ test_that("compartment is turned on when F is zero", {
   expect_equal(ans[7:9], c(0,0,0))
   expect_equal(ans[10:27], seq(1,24-t2))
 })
+
+test_that("compartment with active infusion can be turned off", {
+  mod <- house(end = 96)
+  data1 <- c(
+    # start a bunch of infusions into 2nd cmt
+    # then off at time 20
+    # then dose again 
+    ev(amt = 100, rate = 1,  cmt =  2), 
+    ev(amt = 500, rate = 1,  cmt =  2, time = 2),
+    ev(amt = 50,  rate = 1,  cmt =  2, time = 5),
+    ev(amt = 5,   rate = 1,  cmt =  2, time = 10),
+    ev(amt = 0,   evid = 2,  cmt = -2, time = 20),
+    ev(amt = 10,  time = 40, cmt =  2, rate = 10)
+  ) %>% mutate(ID = 1) %>% as.data.frame()
+  data2 <- c(
+    # same thing, just one infusion
+    ev(amt = 100, rate = 1,  cmt =  2), 
+    ev(amt = 0,   evid = 2,  cmt = -2, time = 20), 
+    ev(amt = 10,  time = 40, cmt =  2, rate = 10)
+  ) %>% mutate(ID = 2) %>% as.data.frame()
+  data3 <- c(
+    # same thing, just do the test dose
+    ev(amt = 10,  time = 40, cmt =  2, rate = 10)
+  ) %>% mutate(ID = 3) %>% as.data.frame()
+  data <- bind_rows(data1,data2,data3)
+  out <- mrgsim_df(mod, data, end = 60) 
+  ans <- filter(out, time >= 40)
+  id <- ans$ID
+  ans$ID <- NULL
+  comp <- split(ans, id)
+  for(i in 1:3) {
+    rownames(comp[[i]]) <- NULL  
+  }
+  expect_equal(comp[[1]], comp[[2]])
+  expect_equal(comp[[1]], comp[[3]])
+})