Force idata_set to be data.frame; explicit #100

rdev/NAMESPACE

@@ -159,7 +159,6 @@ exportMethods(loadso)
 exportMethods(mod)
 exportMethods(model)
 exportMethods(moving)
-exportMethods(mrgsim)
 exportMethods(names)
 exportMethods(neq)
 exportMethods(nrow)

rdev/R/idata_set.R

@@ -15,7 +15,7 @@ setMethod("idata_set",c("mrgmod", "data.frame"), function(x,data,subset=TRUE,sel
   if(!missing(subset)) data <- filter_(data,.dots=lazy(subset))
   if(!missing(select)) data <- select_(data,.dots=lazy(select))
   if(nrow(data) ==0) stop("Zero rows in idata after filtering.", call.=FALSE)
-  x@args <- merge(x@args,list(idata=data), strict=FALSE)
+  x@args <- merge(x@args,list(idata=as.data.frame(data)), strict=FALSE)
   return(x)
 })
 ##' @export

rdev/R/mrgsolve.R

@@ -107,11 +107,6 @@ validate_idata <- function(idata) {
 ##' \item{\code{carry.out} can be used to insert data columns into the output data set.  This is partially dependent on the
 ##' nature of the data brought into the problem.}
 ##' }
-setGeneric("mrgsim", function(x,...) standardGeneric("mrgsim"))
-
-
-##' @rdname mrgsim
-##' @export
 ##' @param data NMTRAN-like data set
 ##' @param idata a matrix or data frame of model parameters, one parameter per row
 ##' @section Additional arguments:
@@ -172,10 +167,10 @@ setGeneric("mrgsim", function(x,...) standardGeneric("mrgsim"))
 ##'
 
 
-setMethod("mrgsim", "mrgmod", function(x,
-                                       data=NULL,
-                                       idata=NULL,
-                                       nid = 1,...) {
+mrgsim <-  function(x,
+                    data=NULL,
+                    idata=NULL,
+                    nid = 1,...) {
 
   if(missing(data)) data <- x@args$data; x@args$data <- NULL
   if(missing(idata)) idata <- x@args$idata; x@args$idata <- NULL
@@ -186,7 +181,7 @@ setMethod("mrgsim", "mrgmod", function(x,
     x <- do.call("update",c(x,args))
   }
 
-
+  
   ## Neither data nor idata passed in, but nid > 1
   ## Build a simple idata set to use
   if(is.null(data) & is.null(idata) & nid > 1) {
@@ -239,7 +234,8 @@ setMethod("mrgsim", "mrgmod", function(x,
                   idata[,"ID"])
   } else {
     ## No data, no events:
-    data <- matrix(idata[,"ID"], ncol=1, 
+    data <- matrix(idata[,"ID"], 
+                   ncol=1, 
                    dimnames=list(NULL, c("ID")))
   }
 
@@ -251,13 +247,8 @@ setMethod("mrgsim", "mrgmod", function(x,
 
   return(out)
 
-})
+}
 
-##' @export
-##' @rdname mrgsim
-setMethod("mrgsim", "mrgsims", function(x,...) {
-  mrgsim(mod(x),...)
-})
 
 tran_mrgsim <- function(x,
                         data,

rdev/tests/testthat/test-initials.R

@@ -0,0 +1,67 @@
+library(mrgsolve)
+library(testthat)
+library(mrgsolve)
+library(dplyr)
+
+Sys.setenv(R_TESTS="")
+
+code1 <- '
+$SET request="A,B,C", end=2, delta=1
+$CMT A B C
+$PARAM a = 0, b = 0, c = 0, IFLAG = 0
+
+$MAIN
+if(IFLAG > 0) {
+  A_0 = a;
+  B_0 = b;
+  C_0 = c;
+}
+
+' 
+
+mod <- mcode("test-init", code1, warn=FALSE)
+
+context("test-initials")
+
+
+test_that("Set initials via init", {
+  out <- mod %>% init(A=1, B=2, C=3) %>% mrgsim %>% filter(time==0)
+  expect_equal(out$A,1)
+  expect_equal(out$B,2)
+  expect_equal(out$C,3)
+
+})
+
+
+test_that("Set initials via $MAIN", {
+
+  out <- mod %>% param(a=1, b=2, c=3) %>% mrgsim %>% filter(time==0)
+  expect_equal(out$A,0)
+  expect_equal(out$B,0)
+  expect_equal(out$C,0)
+
+  out <- mod %>% param(a=11, b=22, c=33,IFLAG=1) %>% mrgsim %>% filter(time==0)
+  expect_equal(out$A,11)
+  expect_equal(out$B,22)
+  expect_equal(out$C,33)
+
+  out <- mod %>% param(a=11, b=22, c=33, IFLAG=1) %>% 
+    ev(amt=100,cmt=2) %>%
+    mrgsim %>% filter(time==0)
+
+  expect_equal(out$A,c(11,11))
+  expect_equal(out$B,c(22,122))
+  expect_equal(out$C,c(33,33))
+
+})
+
+
+test_that("Set initials via idata", {
+  id <- dplyr::data_frame(ID=1:3, C_0 = c(99,88,88))
+  out <- mod %>% idata_set(id) %>% mrgsim %>% filter(time==0)
+})
+
+
+
+
+

rdev/tests/testthat/test-update.R

@@ -0,0 +1,66 @@
+library(mrgsolve)
+library(testthat)
+library(mrgsolve)
+library(dplyr)
+
+Sys.setenv(R_TESTS="")
+
+code1 <- '
+$SET request=""
+$CMT CM
+$PARAM A = 0, B = 0, C = 0
+$CAPTURE A B C
+' 
+
+mod1 <- mcode("code1", code1, warn=FALSE)
+
+context("test-update")
+
+
+test_that("Update parameter - via param", {
+  expect_equal(param(param(mod1,B = 2))$B,2)
+  expect_equal(as.list(param(param(mod1,A=11,C=22))),list(A=11,B=0,C=22))
+
+  out <- mod1 %>% mrgsim(end=8)
+  expect_true(all(c(out$A==0,out$B==0,out$C==0)))
+
+  out <- mod1 %>% param(A=3, B=2, C=1) %>% mrgsim
+  expect_true(all(c(out$A==3,out$B==2,out$C==1)))
+})
+
+
+
+test_that("Update parameter - via idata", {
+  idata <- expand.idata(ID=1, A=c(4,5,6),B=c(7,8,9),C=c(11,12,13,14))  
+  out <- mod1 %>% idata_set(idata) %>% mrgsim %>% as.tbl %>% distinct(ID,A,B,C)
+  expect_equal(unlist(out),unlist(idata))
+  expect_identical(param(param(mod1,B = 2))$B,2)
+})
+
+
+test_that("Update parameter - via data, not-time-varying", {
+  data <- expand.ev(ID=1, A=c(4,5,6),B=c(7,8,9),C=c(11,12,13,14),amt=2)
+  out <- mod1 %>% data_set(data) %>% carry_out(amt,evid,cmt,time) %>%
+    mrgsim() %>% as.tbl %>% filter(evid==1) %>% mutate(CM=NULL)
+  expect_equal(unlist(out),unlist(data[,names(out)]))
+
+})
+
+test_that("Update parameter - via data, time-varying", {
+  ## data with time-varying covariate
+  data <- 
+    bind_rows(
+      data_frame(ID=1, time=seq(0,10,1), A = 2*time, B = 1.1*time),
+      data_frame(ID=2, time=seq(0,15,1), A = 22*time, B = 11.1*time)
+    ) %>% mutate(evid=ifelse(time==1,1,0),cmt=1)
+
+  out <- mod1 %>% data_set(data)  %>% mrgsim()
+
+  expect_true(all(c(data$A==out$A,data$B==out$B)))
+
+})
+
+
+
+
+