warn when bad update is attempted from simulation function

metrumresearchgroup · Sep 30, 2019 · 88c76c9 · 88c76c9
1 parent 33eab8f
commit 88c76c9
Show file tree

Hide file tree

Showing 3 changed files with 17 additions and 14 deletions.
diff --git a/R/mrgsolve.R b/R/mrgsolve.R
@@ -188,10 +188,6 @@ mrgsim <-  function(x, data=NULL, idata=NULL, events=NULL, nid=1, ...) {
     events <- x@args$events
   }
 
-  if(nid > 1) {
-    return(mrgsim_nid(x, nid, events, ...))
-  } 
-
   have_data <- !is.null(data)
   have_idata <- !is.null(idata)
   have_events <- !is.null(events)
@@ -201,6 +197,10 @@ mrgsim <-  function(x, data=NULL, idata=NULL, events=NULL, nid=1, ...) {
   x@args$data <- NULL
   x@args$events <- NULL
 
+  if(nid > 1) {
+    return(mrgsim_nid(x, nid, events, ...))
+  } 
+
   if(have_events & !have_data) {
     if(have_idata) {
       return(mrgsim_ei(x, events = events, idata = idata, ...)) 
@@ -280,7 +280,7 @@ mrgsim_e <- function(x, events, idata = NULL, data = NULL, ...) {
   }
   events <- as.data.frame(events, add_ID = 1)
   args <- list(...)
-  x <- do.call(update, c(x,args))
+  # x <- do.call(update, c(x,args))
   args <- combine_list(x@args,args)
   do.call(
     do_mrgsim, 
@@ -295,7 +295,7 @@ mrgsim_d <- function(x, data, idata = NULL, events = NULL, ...) {
     data <- as_data_set(data)  
   }
   args <- list(...)
-  x <- do.call(update, c(x,args))
+  #x <- do.call(update, c(x,args))
   args <- combine_list(x@args,args)
   do.call(
     do_mrgsim, 
@@ -330,7 +330,7 @@ mrgsim_ei <- function(x, events, idata, data = NULL, ...) {
                     idata[,"ID"])
   }
   args <- list(...)
-  x <- do.call(update, c(x,args))
+  #x <- do.call(update, c(x,args))
   args <- combine_list(x@args,args)
   do.call(
     do_mrgsim, 
@@ -347,7 +347,7 @@ mrgsim_di <- function(x, data, idata, events = NULL, ...) {
     idata <- bind_col(idata, "ID", seq_len(nrow(idata)))
   }
   args <- list(...)
-  x <- do.call(update, c(x,args))
+  #x <- do.call(update, c(x,args))
   args <- combine_list(x@args,args)
   do.call(
     do_mrgsim, 
@@ -364,7 +364,7 @@ mrgsim_i <- function(x, idata, data = NULL, events = NULL, ...) {
   }
   data <- matrix(idata[["ID"]], ncol = 1, dimnames = list(NULL, "ID"))
   args <- list(...)
-  x <- do.call(update, c(x,args))
+  #x <- do.call(update, c(x,args))
   args <- combine_list(x@args,args)
   do.call(
     do_mrgsim, 
@@ -377,7 +377,7 @@ mrgsim_i <- function(x, idata, data = NULL, events = NULL, ...) {
 mrgsim_0 <- function(x, idata = NULL, data = NULL, events = NULL, ...) {
   data <- matrix(1, ncol = 1, dimnames = list(NULL, "ID"))
   args <- list(...)
-  x <- do.call(update, c(x,args))
+  #x <- do.call(update, c(x,args))
   args <- combine_list(x@args,args)
   do.call(
     do_mrgsim, 
@@ -470,6 +470,8 @@ do_mrgsim <- function(x,
                       ss_tol = 1E-12,
                       ...) {
 
+  x <- update(x,...,strict=TRUE)
+
   verbose <- x@verbose
 
   if(length(Request) > 0) {
@@ -498,7 +500,7 @@ do_mrgsim <- function(x,
   if(!identical(Cmt(x), x@shlib[["cmt"]])) {
     wstop("the compartment list has changed since the model was compiled.")
   }
-
+  
   ## carry can be tran/data/idata
   # Items to carry out from the data set
   if(length(carry_out) > 0) {

diff --git a/R/update.R b/R/update.R
@@ -105,8 +105,9 @@ setMethod("update", "mrgmod", function(object, ..., merge=TRUE, open=FALSE,
 
   if(strict && anyNA(m)) {
     bad <- a[is.na(m)]
-    wstop("cannot update this item in the model object: ", 
-          paste0(bad,collapse=","))
+    bad <- paste0(bad,collapse=", ")
+    mesg <- paste0("invalid item for model object update: ", bad)
+    warning(mesg, call.=FALSE, immediate.=TRUE)
   }
 
   notna <- !is.na(m)

diff --git a/tests/testthat/test-carry_out.R b/tests/testthat/test-carry_out.R
@@ -43,7 +43,7 @@ out <-
   mod %>% 
   data_set(exTheoph, ID <=2) %>% 
   carry_out(WT,evid,ROW) %>%
-  mrgsim(obsfirst=FALSE,obsonly=TRUE)
+  mrgsim(obsonly=TRUE)
 
 
 out <- mod %>%