Permalink
Browse files

Add tableControl

  • Loading branch information...
mattfidler committed Aug 22, 2018
1 parent eabdf7c commit ff29217efb4a8dca1063934c5c3c2d379cced426
Showing with 203 additions and 73 deletions.
  1. +1 −3 NAMESPACE
  2. +0 −1 R/foceiFit.R
  3. +48 −33 R/nlmixr.R
  4. +59 −1 R/npde.R
  5. +3 −1 man/addCwres.Rd
  6. +20 −1 man/addNpde.Rd
  7. +7 −16 man/nlmixr.Rd
  8. +5 −5 man/nlmixr_fit.Rd
  9. +59 −11 src/resid.cpp
  10. +1 −1 vignettes/running_nlmixr.Rmd
View
@@ -24,9 +24,6 @@ S3method(nlme,nlmixr.ui.focei.fit)
S3method(nlme,nlmixr.ui.nlme)
S3method(nlme,nlmixrUI)
S3method(nlmixr,"function")
S3method(nlmixr,nlmixr.ui.focei.fit)
S3method(nlmixr,nlmixr.ui.nlme)
S3method(nlmixr,nlmixr.ui.saem)
S3method(nlmixr,nlmixrUI)
S3method(nlmixrData,character)
S3method(nlmixrData,default)
@@ -162,6 +159,7 @@ export(rxSolve)
export(saem)
export(saem.fit)
export(saemControl)
export(tableControl)
export(traceplot)
export(varComb)
export(varConstPower)
View
@@ -35,7 +35,6 @@ is.latex <- function() {
##'
##' @param maxstepsOde Maximum number of steps for ODE solver.
##'
##'
##' @param printInner Integer representing when the inner step is
##' printed. By default this is 0 or do not print. 1 is print
##' every function evaluation, 5 is print every 5 evaluations.
View
@@ -101,13 +101,14 @@ armaVersion <- function(){
##' @return Either a nlmixr model or a nlmixr fit object
##' @author Matthew L. Fidler, Rik Schoemaker
##' @export
nlmixr <- function(object, data, est="nlme", control=list(), calc.resid=TRUE, ...){
nlmixr <- function(object, data, est="nlme", control=list(),
table=tableControl(), ...){
UseMethod("nlmixr")
}
##' @rdname nlmixr
##' @export
nlmixr.function <- function(object, data, est="nlme", control=list(), calc.resid=TRUE, ...){
nlmixr.function <- function(object, data, est="nlme", control=list(), table=tableControl(), ...){
uif <- nlmixrUI(object);
class(uif) <- "list";
uif$nmodel$model.name <- deparse(substitute(object))
@@ -117,7 +118,7 @@ nlmixr.function <- function(object, data, est="nlme", control=list(), calc.resid
} else {
uif$nmodel$data.name <- deparse(substitute(data))
class(uif) <- "nlmixrUI"
nlmixr_fit(uif, data, est, control=control, calc.resid=calc.resid, ...);
nlmixr_fit(uif, data, est, control=control, table=table, ...);
}
}
@@ -135,28 +136,6 @@ nlmixr.nlmixrUI <- function(object, data, est="nlme", control=list(), ...){
}
}
##' @rdname nlmixr
##' @export
nlmixr.nlmixr.ui.nlme <- function(object, data, est="nlme", ...){
env <- attr(object, ".focei.env")
uif <- env$uif.new;
if (missing(data) && missing(est)){
return(uif)
} else {
if (missing(data)){
data <- getData(object);
}
nlmixr_fit(uif, data, est, ...);
}
}
##' @rdname nlmixr
##' @export
nlmixr.nlmixr.ui.focei.fit <- nlmixr.nlmixr.ui.nlme
##' @rdname nlmixr
##' @export
nlmixr.nlmixr.ui.saem <- nlmixr.nlmixr.ui.nlme
##' Convert/Format the data appropriately for nlmixr
##'
##' @param data is the name of the data to convert. Can be a csv file
@@ -243,19 +222,22 @@ nlmixrData.default <- function(data){
##' EVIDs.
##' @param est Estimation method
##' @param control Estimation control options. They could be
##' \code{\link[nlme]{nlmeControl}}, \code{\link{saemControl}}
##' \code{\link[nlme]{nlmeControl}}, \code{\link{saemControl}} or
##' \code{\link{foceiControl}}
##' @param ... Parameters passed to estimation method.
##' @param sum.prod Take the RxODE model and use more precise
##' products/sums. Increases solving accuracy and solving time.
##' @param calc.resid Translate the model to FOCEi and then run
##' the tables and objective function so that different estimation
##' methodologies are comparable through OBJF.
##' @param table A list controlling the table options (i.e. CWRES,
##' NPDE etc). See \code{\link{tableControl}}.
##' @return nlmixr fit object
##' @author Matthew L. Fidler
##' @export
nlmixr_fit <- function(uif, data, est="nlme", control=list(), ...,
sum.prod=FALSE, calc.resid=TRUE){
sum.prod=FALSE, table=tableControl()){
start.time <- Sys.time();
if (!is(table, "tableControl")){
table <- do.call(tableControl, table);
}
dat <- nlmixrData(data);
up.covs <- toupper(uif$all.covs);
up.names <- toupper(names(dat))
@@ -282,6 +264,30 @@ nlmixr_fit <- function(uif, data, est="nlme", control=list(), ...,
return(x);
}
}
.addNpde <- function(x){
.doIt <- table$npde;
if (is.null(.doIt)){
if (est == "saem"){
.doIt <- table$saemNPDE
} else if (est == "focei"){
.doIt <- table$foceiNPDE
} else if (est == "nlme"){
.doIt <- table$nlmeNPDE
}
}
if (!.doIt) return (x);
.ret <- try(addNpde(x,nsim=table$nsim, ties=table$ties, seed=table$seed, updateObject=FALSE), silent=TRUE);
if (inherits(.ret, "try-error")) return(x);
return(.ret);
}
calc.resid <- table$cwres;
if (is.null(calc.resid)){
if (est == "saem"){
calc.resid <- table$saemCWRES
} else if (est == "nlme"){
calc.resid <- table$nlmeCWRES
}
}
if (est == "saem"){
pt <- proc.time()
args <- as.list(match.call(expand.dots=TRUE))[-1]
@@ -353,7 +359,7 @@ nlmixr_fit <- function(uif, data, est="nlme", control=list(), ...,
if (inherits(.ret, "try-error")){
return(fit)
}
.env <- .ret$env
.ret <- .addNpde(.ret);
assign("startTime", start.time, .env);
assign("est", est, .env);
assign("stopTime", Sys.time(), .env);
@@ -368,6 +374,7 @@ nlmixr_fit <- function(uif, data, est="nlme", control=list(), ...,
if (inherits(.ret, "try-error")){
return(fit)
}
.ret <- .addNpde(.ret);
.env <- .ret$env
assign("startTime", start.time, .env);
assign("est", est, .env);
@@ -376,6 +383,7 @@ nlmixr_fit <- function(uif, data, est="nlme", control=list(), ...,
}
}
.ret <- fix.dat(.ret);
.ret <- .addNpde(.ret);
.env <- .ret$env
assign("startTime", start.time, .env);
assign("est", est, .env);
@@ -388,13 +396,15 @@ nlmixr_fit <- function(uif, data, est="nlme", control=list(), ...,
if (inherits(.ret, "try-error")){
return(fit)
}
.ret <- .addNpde(.ret);
.env <- .ret$env
assign("startTime", start.time, .env);
assign("est", est, .env);
assign("stopTime", Sys.time(), .env);
return(.ret);
}
.ret <- fix.dat(.ret);
.ret <- .addNpde(.ret);
.env <- .ret$env
assign("startTime", start.time, .env);
assign("est", est, .env);
@@ -477,6 +487,7 @@ nlmixr_fit <- function(uif, data, est="nlme", control=list(), ...,
if (inherits(.ret, "try-error")){
return(fit);
}
.ret <- .addNpde(.ret);
.env <- .ret$env
assign("startTime", start.time, .env);
assign("est", est, .env);
@@ -492,6 +503,7 @@ nlmixr_fit <- function(uif, data, est="nlme", control=list(), ...,
if (inherits(.ret, "try-error")){
return(fit);
}
.ret <- .addNpde(.ret);
.env <- .ret$env
assign("startTime", start.time, .env);
assign("est", est, .env);
@@ -500,6 +512,7 @@ nlmixr_fit <- function(uif, data, est="nlme", control=list(), ...,
}
}
.ret <- fix.dat(.ret);
.ret <- .addNpde(.ret);
.env <- .ret$env
assign("startTime", start.time, .env);
assign("est", est, .env);
@@ -513,12 +526,14 @@ nlmixr_fit <- function(uif, data, est="nlme", control=list(), ...,
return(fit);
}
.env <- .ret$env
.ret <- .addNpde(.ret);
assign("startTime", start.time, .env);
assign("est", est, .env);
assign("stopTime", Sys.time(), .env);
return(.ret)
}
.ret <- fix.dat(.ret);
.ret <- .addNpde(.ret);
.env <- .ret$env
assign("startTime", start.time, .env);
assign("est", est, .env);
@@ -543,6 +558,7 @@ nlmixr_fit <- function(uif, data, est="nlme", control=list(), ...,
control=control,
env=env,
...)
fit <- .addNpde(fit);
assign("start.time", start.time, env);
assign("est", est, env);
assign("stop.time", Sys.time(), env);
@@ -685,8 +701,7 @@ addCwres <- function(fit, updateObject=TRUE){
.saem <- fit$saem
.cls <- class(fit);
if (!is.null(.saem)){
.newFit <- as.focei.saemFit(.saem, .uif, data=getData(fit), calcResid = TRUE,
obf=fit$objDf["SAEMg","OBJF"]);
.newFit <- as.focei.saemFit(.saem, .uif, data=getData(fit), calcResid = TRUE, obf=fit$objDf["SAEMg","OBJF"]);
.df <- .newFit[, c("WRES", "CRES", "CWRES", "CPRED")];
.new <- cbind(fit, .df);
}
View
@@ -40,7 +40,7 @@ addNpde <- function(object, nsim=300, ties=TRUE, seed=1009, updateObject=TRUE, .
class(.new) <- .cls;
if (updateObject){
.parent <- parent.frame(2);
.bound <- do.call("c", lapply(ls(.parent), function(.cur){
.bound <- do.call("c", lapply(ls(.parent, all=TRUE), function(.cur){
if (.cur == .objName && identical(.parent[[.cur]], object)){
return(.cur)
}
@@ -50,3 +50,61 @@ addNpde <- function(object, nsim=300, ties=TRUE, seed=1009, updateObject=TRUE, .
}
return(.new)
}
##' Output table/data.frame options
##'
##' @param npde When TRUE, request npde regardless of the algorithm used.
##'
##' @param cwres When TRUE, request CWRES and FOCEi likelihood
##' regardless of the algorithm used.
##'
##' @param saemNPDE When TRUE and estimating with SAEM, adds NPDE
##' metrics to fit including EPRED, ERES, and NPDE. (default
##' TRUE);
##'
##' @param saemCWRES When TRUE and estimating with SAEM, adds CWRES
##' metrics to the fit including CPRED, CRES and CWRES. It also
##' evaluates the function with the FOCEi objective function to
##' allow comparison between estimation methods. (default FALSE)
##'
##' @param nlmeNPDE When TRUE and estimating with nlme, adds NPDE
##' metrics to fit including EPRED, ERES, and NPDE. (default
##' TRUE);
##'
##' @param nlmeCWRES When TRUE and estimating with nlme, adds CWRES
##' metrics to the fit including CPRED, CRES and CWRES. It also
##' evaluates the function with the FOCEi objective function to
##' allow comparison between estimation methods. (default FALSE)
##'
##' @param foceiNPDE When TRUE and estimating with FOCEi, adds NPDE
##' metrics to fit including EPRED, ERES, and NPDE. (default
##' TRUE);
##'
##' @inheritParams addNpde
##'
##' @details
##'
##' If you ever want to add CWRES/FOCEi objective function you can use the \code{\link{addCwres}}
##'
##' If you ever want to add NPDE/EPRED columns you can use the \code{\link{addNpde}}
##'
##' @return A list of table options for nlmixr
##' @author Matthew L. Fidler
##' @export
tableControl <- function(npde=NULL,
cwres=NULL,
saemNPDE=TRUE,
saemCWRES=FALSE,
nlmeNPDE=TRUE,
nlmeCWRES=FALSE,
foceiNPDE=TRUE,
nsim=300, ties=TRUE, seed=1009){
.ret <- list(npde=npde, cwres=cwres,
saemNPDE=saemNPDE,
saemCWRES=saemCWRES,
nlmeNPDE=nlmeNPDE,
nlmeCWRES=nlmeCWRES,
foceiNPDE=foceiNPDE,
nsim=nsim, ties=ties, seed=seed)
class(.ret) <- "tableControl";
return(.ret)
}
View

Some generated files are not rendered by default. Learn more.

Oops, something went wrong.
View

Some generated files are not rendered by default. Learn more.

Oops, something went wrong.
View

Some generated files are not rendered by default. Learn more.

Oops, something went wrong.
Oops, something went wrong.

0 comments on commit ff29217

Please sign in to comment.