'start'
'#Copyright (c) 2009, 2010 Sebastien Bihorel'
'#All rights reserved.'
'#'
'#This file is part of scaRabee.'
'#'
'#    scaRabee is free software: you can redistribute it and/or modify'
'#    it under the terms of the GNU General Public License as published by'
'#    the Free Software Foundation, either version 3 of the License, or'
'#    (at your option) any later version.'
'#'
'#    scaRabee is distributed in the hope that it will be useful,'
'#    but WITHOUT ANY WARRANTY; without even the implied warranty of'
'#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the'
'#    GNU General Public License for more details.'
'#'
'#    You should have received a copy of the GNU General Public License'
'#    along with scaRabee.  If not, see <http://www.gnu.org/licenses/>.'
'#'
'@newline@'
'model <- function(x=NULL,dosing=NULL,xdata=NULL,covdata=NULL,issim=0){'
'  #'
'  # AIM: Compute model predictions'
'  #'
'  # INPUT: x       - data frame containing model parameters (model, delays,'
'  #                  variability, initial conditions) for model simulation'
'  #        dosing  - dosing history, a di x 4 matrix is assumed'
'  #        xdata   - independent variable, a 1 x mi matrix is assumed'
'  #        covdata - covariate data, a ti x c matrix is assumed (ti being'
'  #                  the number of covariate measurement time, and c the'
'  #                  number of covariates + 1)'
'  #        issim   - scalar indicator of simulation runs (0/1)'
'  #'
'  # Problem description:'
'@newline@'
'  if (size(dosing,2)!=4)'
'    stop(\'model: dosing does not have a di x 4 dimension\','
'         call.=FALSE)'
'@newline@'
'  # Sort dosing by time'
'  dosing <- dosing[order(dosing[,1]),]'
'@newline@'
'  # Retrieve parameters'
'  parms <- c(get.param.data(x=x,which=\'value\',type=\'P\'),'
'             get.param.data(x=x,which=\'value\',type=\'L\'),'
'             get.param.data(x=x,which=\'value\',type=\'IC\'))'
'  names(parms) <- c(get.param.data(x=x,which=\'names\',type=\'P\'),'
'                    get.param.data(x=x,which=\'names\',type=\'L\'),'
'                    get.param.data(x=x,which=\'names\',type=\'IC\'))'
'@newline@'
'  # Determine integration intervals'
'  tspan      <- create.intervals(xdata=xdata,dosing=dosing)'
'  nintervals <- size(tspan,2)'
'@newline@'
'  # Determine the time points for model evaluation'
'  if (issim < 0.5){'
'    xdata <- xdata'
'  } else {'
'    xdata <- NULL'
'    nint <- ceiling(1001/nintervals)'
'    # Checks that nint is odd; if not, adds 1'
'    if (!nint%%2)'
'      nint <- nint + 1'
'@newline@'
'    # Create vector of time'
'    for (i in 1:nintervals){'
'      xtmp <- seq(tspan[1,i],tspan[2,i],length.out=nint)'
'      if (i==1){'
'        xdata <- c(xdata,xtmp)'
'      } else {'
'        xdata <- c(xdata,xtmp[2:length(xtmp)])'
'      }'
'    }'
'  }'
'@newline@'
'  # Define initial conditions'
'  ic <- init(parms=parms,dosing=dosing)'
'@newline@'
'  # Determine the scaling factors for inputs'
'  scale <- inputscaling(parms=parms,ic=ic)'
'@newline@'
'  # Update initial conditions with bolus dosing if necessary'
'  sol <- ode(y=ic,'
'             times=tspan[,1],'
'             func=odesyst,'
'             parms=parms,'
'             method=\'lsoda\','
'             dosing=dosing,'
'             xdata=xdata,'
'             covdata=covdata,'
'             scale=scale)'
'  ic  <- updateinit(y=sol[sol[,1]==tspan[1,1],],'
'                    t=tspan[1,1],'
'                    dosing=dosing,'
'                    scale=scale)'
'@newline@'
'  # Integration'
'  f <- NULL'
'  for (i in 1:nintervals) {'
'    # Evaluation times'
'    eval.times <- xdata[xdata>=tspan[1,i] & xdata<=tspan[2,i]]'
'    if (is.element(tspan[1,i],eval.times)){'
'      is.mintspan.in.xdata <- TRUE'
'    } else {'
'      is.mintspan.in.xdata <- FALSE'
'      eval.times <- c(tspan[1,i],eval.times)'
'    }'
'    if (is.element(tspan[2,i],eval.times)){'
'      is.maxtspan.in.xdata <- TRUE'
'    } else {'
'      is.maxtspan.in.xdata <- FALSE'
'      eval.times <- c(eval.times,tspan[2,i])'
'    }'
'@newline@'
'    # Evaluate the solution within the intervals and assumes no observation at bolus times'
'    sol <- ode(y=ic,'
'               times=eval.times,'
'               func=odesyst,'
'               parms=parms,'
'               method=\'lsoda\','
'               dosing=dosing,'
'               xdata=xdata,'
'               covdata=covdata,'
'               scale=scale)'
'@newline@'
'    # initialize states for next loop iteration'
'    if (i!=nintervals){'
'      ic <- updateinit(y=sol[sol[,1]==tspan[2,i],],'
'                       t=tspan[1,i+1],'
'                       dosing=dosing,'
'                       scale=scale)'
'    }'
'@newline@'
'    # Filter sol based upon is.mintspan.in.xdata and is.maxtspan.in.xdata'
'    if (!is.mintspan.in.xdata){'
'      sol <- sol[-1,]'
'    } else {'
'      if (!is.null(f)) f <- f[-size(f,1),]'
'    }'
'    if (!is.maxtspan.in.xdata){'
'      ftmp <- sol[-size(sol,1),]'
'    } else {'
'      ftmp <- sol'
'    }'
'@newline@'
'    # Concatenate Ftmp to the previous predictions'
'    if (is.null(f)) {'
'      f <- ftmp'
'    } else {'
'      f <- rbind(f,ftmp)'
'    }'
'  }'
'@newline@'
'  # Define ouput from the system'
'  f <- output(f=transpose(f[,-1]),parms=parms,dosing=dosing,xdata=xdata)'
'@newline@'
'  # Re-attach evaluation times xdata for simulation run only'
'  if (issim > 0.5){'
'    f <- rbind(xdata,f)'
'  }'
'@newline@'
'  return(f)'
'@newline@'
'}'
'@newline@'
'@newline@'
'init <- function(parms=NULL,dosing=NULL){'
'  #'
'  # AIM: Defime the initial conditions of the system'
'  #'
'  # INPUT: parms  - vector of model parameters for model simulation'
'  #        dosing - dosing history, a di x 4 matrix is assumed'
'@newline@'
'  init <- with(as.list(parms),{'
'  #########################################################################'
'  #                        USER CODE STARTS HERE'
'  #########################################################################'
'@newline@'
'  init <- c()'
'@newline@'
'  #########################################################################'
'  #                         USER CODE ENDS HERE'
'  #########################################################################'
'    return(init)}'
'  )'
'@newline@'
'  names(init) <- paste(\'y\',1:length(init),sep=\'\')'
'@newline@'
'  nstate <- size(init,2)'
'@newline@'
'  if (any(is.na(match(dosing[,2],c(1:nstate)))))'
'    stop(paste(\'model: One or more input are assigned to a state that is not \','
'               \'defined in the ODE system.\',sep=\'\'),'
'         call.=FALSE)'
'@newline@'
'  return(init)'
'@newline@'
'}'
'@newline@'
'@newline@'
'inputscaling <- function(parms=NULL,ic=NULL){'
'  #'
'  # AIM: Define a scaling factor for inputs'
'  #'
'  # INPUT: parms - vector of model parameters for model simulation'
'  #        ic    - vector of the n states values of the ode system at the'
'  #                first time of evaluation'
'@newline@'
'  scale <- with(as.list(parms),{'
'  #########################################################################'
'  #                        USER CODE STARTS HERE'
'  #########################################################################'
'@newline@'
'  # scale must be a scalar or have the same dimension as dydt (see below).'
'  # In the latter case, set scale[i] to 0 if there is no input in the ith'
'  # state.'
'@newline@'
'  scale <- c()'
'@newline@'
'  #########################################################################'
'  #                         USER CODE ENDS HERE'
'  #########################################################################'
'    return(scale)}'
'  )'
'@newline@'
'  if (size(scale,1)!=1)'
'    stop(\'inputscaling: scale must be a scalar or a vector.\','
'         call.=FALSE)'
'@newline@'
'  # Expand scale if it is a scalar'
'  if (size(scale,2)==1){'
'    scale <- rep(scale,size(ic,2))'
'    #matrix(1,nrow=1,ncol=size(dydt,1))*scale'
'  } else {'
'    if (size(scale,2)!=size(ic,2))'
'      stop(paste(\'inputscaling: scale must be a scalar or have the same\','
'                 \'dimension as the ODE system.\'),'
'            call.=FALSE)'
'  }'
'@newline@'
'  return(scale)'
'@newline@'
'}'
'@newline@'
'@newline@'
'odesyst <- function(t=NULL,y=NULL,parms=NULL,'
'                    dosing=NULL,xdata=NULL,'
'                    covdata=NULL,scale=NULL){'
'  #'
'  # AIM: Definition of the differential equations functions.'
'  #'
'  # INPUT: t       - evaluated time'
'  #        y       - vector of the n states values of the ode system at the'
'  #                  first time of evaluation'
'  #        parms   - vector of model parameters for model simulation'
'  #        dosing  - dosing history, a di x 4 matrix is assumed'
'  #        xdata   - independent variable, a 1 x mi matrix is assumed'
'  #        covdata - covariate data, a ti x c matrix is assumed (ti being'
'  #                  the number of covariate measurement time, and c the'
'  #                  number of covariates + 1)'
'  #        scale   - vector of n input scale factors'
'@newline@'
'  dydt <- with(as.list(c(parms,y)),{'
'  #########################################################################'
'  #                        USER CODE STARTS HERE'
'  #########################################################################'
'@newline@'
'  # User definition of model parameters'
'@newline@'
'  # ODE System'
'  dydt <- c()'
'@newline@'
'  #########################################################################'
'  #                         USER CODE ENDS HERE'
'  #########################################################################'
'    return(dydt)}'
'  )'
'@newline@'
'  # Get the variable size info and does some comparisons'
'  nstate <- size(dydt,2)'
'@newline@'
'  # Initialize input'
'  input <- rep(0,nstate)'
'@newline@'
'  # Build input'
'  if (any(dosing[,4]>0)){'
'    dose.states <- unique(dosing[dosing[,4]>0,2])'
'    for (i in dose.states){'
'      stdosing <- dosing[dosing[,2]==i,]'
'      input[i] <- approx(x=stdosing[,1],'
'                         y=stdosing[,4],'
'                         xout=t,'
'                         yleft=0,'
'                         yright=stdosing[size(stdosing,1),4],'
'                         ties=\'ordered\')$y'
'    }'
'  }'
'@newline@'
'  # Add the input to the ode system'
'  dydt <- dydt + input/scale'
'@newline@'
'  return(list(dydt))'
'@newline@'
'}'
'@newline@'
'@newline@'
'output <- function(f=NULL,parms=NULL,dosing=NULL,xdata=NULL){'
'  #'
'  # AIM: definition of system output'
'  #'
'  # INPUT: f       - a n x mi matrix of all state predictions at all times'
'  #        parms   - vector of model parameters for model simulation'
'  #        dosing  - dosing history, a di x 4 matrix is assumed'
'  #        xdata   - independent variable, a 1 x mi matrix is assumed'
'@newline@'
'  y <- with(as.list(parms),{'
'  #########################################################################'
'  #                        USER CODE STARTS HERE'
'  #########################################################################'
'@newline@'
'  y <- rbind(f)'
'@newline@'
'  #########################################################################'
'  #                         USER CODE ENDS HERE'
'  #########################################################################'
'    return(y)}'
'  )'
'@newline@'
'  if (size(y,1)==1 & size(y,2)>1)'
'    y <- matrix(y,nrow=1)'
'@newline@'
'  return(y)'
'@newline@'
'}'
'@newline@'
'@newline@'
'updateinit <- function(y=NULL,t=NULL,dosing=NULL,scale=NULL){'
'  #'
'  # AIM: Update the system state amount with potential bolus dosing'
'  #'
'  # INPUT: y       - values of the s states of the ode system at time t, a'
'  #                  (n+1) vector is assumed. The first element is the time'
'  #                  t'
'  #        t       - evaluated time'
'  #        dosing  - dosing history, a di x 4 matrix is assumed'
'  #        scale   - vector of n input scale factors'
'@newline@'
'  # Set init to y'
'  init <- y[-1]'
'@newline@'
'  # Subset dosing for event occuring at time t'
'  bolus <- dosing[dosing[,1]==t,]'
'@newline@'
'  # Update init'
'  if (any(bolus[,3]>0)){'
'    for (i in 1:size(bolus,1)) {'
'      init[bolus[i,2]] <- init[bolus[i,2]] + bolus[i,3]/scale[bolus[i,2]]'
'    }'
'  }'
'@newline@'
'  return(init)'
'@newline@'
'}'
'@newline@'