'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.ori <- xdata'
'    if (tspan[1,1]<xdata[1]){'
'      xdata <- c(tspan[1,1],xdata)'
'      is.dosing.mintime <- TRUE'
'    } else {'
'      is.dosing.mintime <- FALSE'
'    }'
'@newline@'
'  } 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)])'
'      }'
'    }'
'    xdata.ori <- xdata'
'  }'
'@newline@'
'  # Get the initial conditions before any bolus input'
'  ic <- init(parms=parms,dosing=dosing)'
'@newline@'
'  # Get the scaling factors for inputs'
'  scale <- inputscaling(parms=parms,ic=ic)'
'@newline@'
'  # Get the delay parameters'
'  lags <- lags(parms=parms)'
'@newline@'
'  # Get vectors for switch functions'
'  switch.vectors <-  get.switch.vectors(dosing=dosing)'
'@newline@'
'  # Builds parameters list parm.list for integration'
'  parm.list <- list(parms=parms,'
'                    lags=lags,'
'                    dosing=dosing,'
'                    xdata=xdata,'
'                    covdata=covdata,'
'                    scale=scale,'
'                    times=switch.vectors$times,'
'                    signal=switch.vectors$signal,'
'                    ic=ic)'
'@newline@'
'@newline@'
'  # Solve DDE syste (update initial conditions with bolus dosing'
'  # if necessary'
'  sol <- dde(y=updateinit(y=ic,t=xdata[1],dosing=dosing,scale=scale),'
'             times=xdata,'
'             func=ddesyst,'
'             parms=parm.list,'
'             switchfunc=mySwitch,'
'             mapfunc=myMap,'
'             dt=10^(floor(log10(switch.vectors$delta))-2))'
'@newline@'
'  # Define ouput from the system'
'  f <- output(f=transpose(as.matrix(sol[,-1])),parms=parms,dosing=dosing,xdata=xdata)'
'@newline@'
'  # Filter f to extract only time points in xdata.ori'
'  f <- f[,match(xdata.ori,sol[,1])]'
'@newline@'
'  if (size(f,1)==1 & size(f,2)>1)'
'    f <- matrix(f,nrow=1)'
'@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,xdata=xdata){'
'@newline@'
'  init <- with(as.list(parms),{'
'  #########################################################################'
'  #                        USER CODE STARTS HERE'
'  #########################################################################'
'@newline@'
'  init <- c(IC1,'
'            IC2)'
'@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 DDE 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'
'  #########################################################################'
'  # 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,'
'             1)'
'@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 DDE system.\'),'
'            call.=FALSE)'
'  }'
'@newline@'
'  return(scale)'
'@newline@'
'}'
'@newline@'
'@newline@'
'lags <- function(parms=NULL){'
'@newline@'
'  delays <- with(as.list(parms),{'
'  #########################################################################'
'  #                        USER CODE STARTS HERE'
'  #########################################################################'
'  # Delays should be defined as a length of length d'
'@newline@'
'  delays <- c(LAG=LAG)'
'@newline@'
'  #########################################################################'
'  #                         USER CODE ENDS HERE'
'  #########################################################################'
'    return(delays)}'
'  )'
'@newline@'
'  if (is.null(names(delays)))'
'    stop(\'lags: Please provide names for all elements.\','
'         call.=FALSE)'
'@newline@'
'  if (any(names(delays)==\'\'))'
'    stop(\'lags: Please provide names for all elements.\','
'         call.=FALSE)'
'@newline@'
'  if (size(delays,1) > 1)'
'    stop(paste(\'lags: delays should not be defined as a matrix.\','
'               \'Please, correct your model definition file.\'),'
'         call.=FALSE)'
'@newline@'
'  return(delays)'
'@newline@'
'}'
'@newline@'
'@newline@'
'ddesyst <- function(t=NULL,y=NULL,parms=NULL){'
'@newline@'
'  # Evaluates system at past times'
'  lags <- parms$lags'
'  names(lags) <- paste(\'ylag\',names(lags),sep=\'.\')'
'  t0 <- parms$xdata[1]'
'  ic <- parms$ic'
'@newline@'
'  ylag <- lapply(lags,'
'            function(x,...){'
'              if (t-x>=t0) {'
'                pastvalue(t-x)'
'              } else {'
'                ic'
'              }'
'            },'
'            t,t0,ic)'
'  rm(lags,t0,ic)'
'@newline@'
'  dydt <- with(c(as.list(c(y,'
'                           parms$parms,'
'                           parms$lags)),'
'                 ylag),{'
'  #########################################################################'
'  #                        USER CODE STARTS HERE'
'  #########################################################################'
'@newline@'
'  # User definition of model parameters'
'  ke <- CL/V1'
'  k12 <- Q/V1'
'  k21 <- Q/V2'
'@newline@'
'  # DDE System'
'  dydt <- c(-(ke+k12)*y1+k21*y2,'
'            k12*ylag.LAG[1]-k21*y2)'
'@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(parms$dosing[,4]>0)){'
'    dose.states <- unique(parms$dosing[parms$dosing[,4]>0,2])'
'    for (i in dose.states){'
'      stdosing <- parms$dosing[parms$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/parms$scale'
'@newline@'
'  return(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[1,]/V1)'
'@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@'
'get.switch.vectors <- function(dosing=NULL){'
'@newline@'
'  bolus.times <- unique(dosing[dosing[,3]>0,1])'
'  delta <- 0.3*min(bolus.times[-1] - bolus.times[-length(bolus.times)])'
'  return(list(times=sort(c(bolus.times-delta,bolus.times+delta)),'
'              signal=rep(c(1,-1),length(bolus.times)),'
'              delta=delta))'
'@newline@'
'}'
'@newline@'
'@newline@'
'mySwitch <- function(t=NULL,y=NULL,parms=NULL){'
'@newline@'
'  approx(parms$times,'
'         parms$signal,'
'         xout=t,'
'         rule=2)$y'
'@newline@'
'}'
'@newline@'
'@newline@'
'myMap <- function(t=NULL,y=NULL,swID=NULL,parms=NULL) {'
'@newline@'
'  dosing <- parms$dosing'
'@newline@'
'  # Subset dosing for event occuring at time t (or close to)'
'  bolus <- dosing[which.min(abs(dosing[,1]-t)),]'
'@newline@'
'  # Update y'
'  for (i in 1:size(bolus,1)) {'
'    y[bolus[i,2]] <- y[bolus[i,2]] + bolus[i,3]/parms$scale[bolus[i,2]]'
'  }'
'@newline@'
'  return(y)'
'@newline@'
'}'
'@newline@'
'@newline@'
'updateinit <- function(y=NULL,t=NULL,dosing=NULL,scale=NULL){'
'@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)) {'
'      y[bolus[i,2]] <- y[bolus[i,2]] + bolus[i,3]/scale[bolus[i,2]]'
'    }'
'  }'
'@newline@'
'  return(y)'
'@newline@'
'}'