'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){'
'@newline@'
'  if (size(dosing,2)!=4)'
'    stop(\'model: dosing does not have a di x 4 dimesion\','
'         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){'
'@newline@'
'  init <- with(as.list(parms),{'
'  #########################################################################'
'  #                        USER CODE STARTS HERE'
'  #########################################################################'
'@newline@'
'  init <- c(0,'
'            0)'
'@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){'
'@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(1,'
'             2)'
'@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){'
'@newline@'
'  dydt <- with(as.list(c(parms,y)),{'
'  #########################################################################'
'  #                        USER CODE STARTS HERE'
'  #########################################################################'
'@newline@'
'  # User definition of model parameters'
'@newline@'
'  # ODE System'
'  dydt <- c(0,'
'            0)'
'@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){'
'@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)'
'    '
'  return(y)'
'@newline@'
'}'
'@newline@'
'@newline@'
'updateinit <- function(y=NULL,t=NULL,dosing=NULL,scale=NULL){'
'@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@'
'}'