R/tci_algorithms.R

In tci: Target Controlled Infusion (TCI)

# --------------------------------------------------------------------------------------------------------------------------------
# - TCI algorithms ---------------------------------------------------------------------------------------------------------------
# --------------------------------------------------------------------------------------------------------------------------------


#' TCI algorithm for plasma targeting
#'
#' TCI algorithm based on the algorithm described by Jacobs (1990).
#'
#' @param Ct Target plasma concentration
#' @param pkmod PK model
#' @param dtm Duration of the infusion
#' @param maxrt Maximum infusion rate. Defaults to 200 ml/min in reference to the
#' maximum infusion rate of 1200 ml/h permitted by
#' existing TCI pumps (e.g. Anestfusor TCI program).
#' @param ... Arguments passed on to update.pkmod.
#' @return Numeric value
#' @examples
#' # plasma targeting
#' my_mod <- pkmod(pars_pk = c(CL = 10, V1 = 10))
#' tci_plasma(Ct = 2, my_mod)
#' # update CL parameter
#' tci_plasma(Ct = 2, my_mod, pars_pk = c(CL = 15))
#' @export
tci_plasma <- function(Ct, pkmod, dtm = 1/6, maxrt = 1200, ...){

  pkmod <- update(pkmod,...)

  Cp1 <- with(pkmod, pkfn(tm = dtm, kR = 1, pars = pars_pk, init = init))
  Cp2 <- with(pkmod, pkfn(tm = dtm, kR = 2, pars = pars_pk, init = init))

  if(!is.null(dim(Cp1))){
    Cp1 <- Cp1[pkmod$pcmpt,]
    Cp2 <- Cp2[pkmod$pcmpt,]
  }

  m <- Cp2 - Cp1
  b <- Cp1 - m
  inf_rate <- (Ct - b) / m
  if(inf_rate < 0)
    inf_rate <- 0
  if(inf_rate > maxrt)
    inf_rate <- maxrt
  return(unname(inf_rate))
}


#' TCI algorithm for effect-site targeting
#'
#' Function for calculating a TCI infusion schedule corresponding to a set of target concentrations.
#' This function makes use of formulas described by Shafer and Gregg (1992) in "Algorithms to rapidly achieve
#' and maintain stable drug concentrations at the site of drug effect with a computer-controlled infusion pump"
#'
#' @param Ct Numeric vector of target effect-site concentrations.
#' @param pkmod PK model
#' @param dtm Frequency of TCI updates. Default is 1/6 minutes = 10 seconds.
#' @param tmax_search Outer bound on times searched to find a maximum concentration
#' following an infusion of duration dtm. Defaults to 20 minutes. May need to be increased
#' if a drug has a slow elimination rate.
#' @param maxrt Maximum infusion rate of TCI pump. Defaults to 1200.
#' @param grid_len Number of time points used to identify time of maximum concentration.
#' Can be increased for more precision.
#' @param ... List or vector of named values to be passed on to update.pkmod.
#' @return Numeric value
#' @examples
#' # three compartment model with effect site
#' my_mod <- pkmod(pars_pk = c(v1 = 8.995, v2 = 17.297, v3 = 120.963,
#' cl = 1.382, q2 = 0.919, q3 = 0.609, ke0 = 1.289))
#' tci_effect_only(Ct = 2, pkmod = my_mod)
#' # update parameters
#' tci_effect_only(Ct = 2, pkmod = my_mod, pars_pk = c(v1 = 12, cl = 2))
#' @export
tci_effect_only <- function(Ct, pkmod, dtm = 1/6, tmax_search = 10,
                       maxrt = 1200, grid_len = 1200, ...){

  # updates to pkmod
  pkmod <- update(pkmod, ...)

  # check that effect site compartment is specified
  if(is.null(pkmod$ecmpt)) stop("ecmpt must be specified in new_pkmod to use tci_effect")

  # infusions corresponding to unit infusion for duration dtm and a null infusion
  unit_inf <- inf_manual(inf_tms = c(0,dtm,tmax_search), inf_rate = c(1,0,0))
  null_inf <- inf_manual(inf_tms = c(0,tmax_search), inf_rate = c(0,0))

  # predict concentrations with no additional infusions and starting concentrations
  B <- function(tm) predict(pkmod, inf = null_inf, tms = tm)[,pkmod$ecmpt]

  # predict concentrations with unit infusion and no starting concentrations
  E <- function(tm) predict(pkmod, inf = unit_inf, init = rep(0,pkmod$ncmpt), tms = tm)[,pkmod$ecmpt]

  # predict to find the longest time of maximum concentration
  # this will always be shorter when any prior drug has been infused
  grid_tmax <- seq(0,tmax_search,length.out = grid_len)
  con_proj <- E(grid_tmax)
  con_dif <- diff(con_proj)
  while(all(con_dif > 0)){
    tmax_search <- tmax_search*2
    grid_tmax <- seq(0,tmax_search,length.out = grid_len)
    con_proj <- E(grid_tmax)
    con_dif <- diff(con_proj)
  }

  peak_ix <- min(which(diff(con_proj) < 0))

  if(all(pkmod$init == 0)){
    kR <- Ct / con_proj[peak_ix]
  } else{
    tms <- seq(0, grid_tmax[peak_ix]+0.5, length.out = grid_len)
    Bpred <- B(tms)
    Epred <- E(tms)
    peak_ix <- which.max(Epred)
    jpeak1 <- tms[peak_ix]
    jpeak0 <- tms[peak_ix-1]
    iter = 0

    while(jpeak0 != jpeak1){
      if(iter > 100) stop("Effect-site TCI algorithm did not converge.")
      jpeak0 = jpeak1
      I0 = (Ct - Bpred[which(tms == jpeak0)]) / Epred[which(tms == jpeak0)]
      jpeak1 = tms[which.max(Bpred + Epred*I0)]
      iter = iter + 1
    }
    kR = unname((Ct-Bpred[which(tms == jpeak1)]) / Epred[which(tms == jpeak1)])
  }

  if(kR < 0) kR = 0
  if(kR > maxrt) kR = maxrt

  return(unname(kR))
}



#' Effect-site TCI algorithm with plasma targeting within small range of target
#'
#' Modified effect-site TCI algorithm that switches to plasma-targeting when the
#' plasma concentration is within 20\%
#' of the target and the effect-site concentration is within 0.5\% of the target.
#' The modification decreases computation time and prevents oscillatory behavior
#' in the effect-site concentrations.
#'
#' @param Ct Numeric vector of target effect-site concentrations.
#' @param pkmod PK model
#' @param dtm TCI update frequency. Defaults to 1/6, corresponding to 10-second
#' intervals if model parameters are in terms of minutes.
#' @param cptol Percentage of plasma concentration required to be within to switch
#' to plasma targeting.
#' @param cetol Percentage of effect-site concentration required to be within to switch
#' to plasma targeting.
#' @param ... Arguments passed on to 'tci_plasma' and 'tci_effect_only' functions, including
#' to update.pkmod.
#' @return Numeric value
#' @examples
#' my_mod <- pkmod(pars_pk = c(v1 = 8.995, v2 = 17.297, v3 = 120.963, cl = 1.382,
#' q2 = 0.919, q3 = 0.609, ke0 = 1.289))
#' tci_effect(Ct = 2, pkmod = my_mod)
#' # update parameters
#' tci_effect(Ct = 2, pkmod = my_mod, pars_pk = c(v1 = 12, cl = 2))
#' @export
tci_effect <- function(Ct, pkmod, dtm = 1/6, cptol = 0.2, cetol = 0.05, ...){

  pkmod <- update(pkmod, ...)

  # return zero if concentration exceeds target
  if(Ct <= pkmod$init[pkmod$ecmpt])
    return(0)

  if(Ct>0){
    if(abs((Ct-pkmod$init[pkmod$pcmpt]) / Ct) <= cptol & abs((Ct-pkmod$init[pkmod$ecmpt]) / Ct) <= cetol){
      tci_plasma(Ct = Ct, pkmod = pkmod, dtm = dtm)
    } else{
      tci_effect_only(Ct = Ct, pkmod = pkmod, dtm = dtm)
    }
  } else 0
}


#' Apply a TCI algorithm to a `pkmod` object
#'
#' Apply a TCI algorithm to a set of targets and a `pkmod` object to calculate infusion
#' rates.
#' @param pkmod `pkmod` object created by `pkmod()`.
#' @param target_vals A vector of numeric values indicating PK or PD targets for TCI algorithm.
#' @param target_tms A vector of numeric values indicating times at which the TCI algorithm should
#' begin targeting each value.
#' @param type Type of TCI algorithm to be used. Options are plasma- or effect-site
#' targeting.
#' @param dtm TCI update frequency. Defaults to 1/6, corresponding to 10-second
#' intervals if model parameters are in terms of minutes.
#' @param custom_alg Custom TCI algorithm to be used instead of default plasma-
#' or effect-site targeting algorithms. The algorithm should be a function that
#' takes minimum arguments `Ct`, `pkmod`, and `dtm` and returns a single infusion
#' rate. See `tci_plasma` or `tci_effect` for examples and vignette on custom
#' models/algorithms for more details.
#' @param inittm Initial time to start TCI algorithm. Cannot be greater than
#' the minimum value of `target_tms`.
#' @param ignore_pd Logical. Should the PD component of the pkmod object (if present)
#' be ignored. By default, predict.tciinf will assume that 'value' refers to PD
#' targets if a PD model is specified.
#' @param ... Arguments passed to TCI algorithm
#' @examples
#' # 3-compartment model with effect-site
#' my_mod <- pkmod(pars_pk = c(v1 = 8.995, v2 = 17.297, v3 = 120.963, cl = 1.382,
#' q2 = 0.919, q3 = 0.609, ke0 = 1.289))
#' # plasma targeting
#' apply_tci(my_mod, target_vals = c(2,3,4,4), target_tms = c(0,2,3,10), "plasma")
#' # effect-site targeting
#' apply_tci(my_mod, target_vals = c(2,3,4,4), target_tms = c(0,2,3,10), "effect")
#' # incorporate  PD model
#' my_mod_pd <- update(my_mod, pars_pd = c(c50 = 2.8, gamma = 1.47, e0 = 93, emx = 93),
#' pdfn = emax, pdinv = emax_inv)
#' apply_tci(my_mod_pd, target_vals = c(70,60,50,50), target_tms = c(0,2,3,10), "effect")
#' @rdname apply_tci
#' @export
apply_tci <- function(pkmod, target_vals, target_tms, type = c("plasma","effect"), dtm = NULL, custom_alg = NULL, inittm = 0, ignore_pd = FALSE, ...){

  if(length(target_vals) != length(target_tms))
    stop("'target_vals' and 'target_tms' must have the same length")
  if(!inherits(pkmod,"pkmod")) stop("pkmod must have class 'pkmod'")

  type <- match.arg(type)

  if(is.null(custom_alg)){
    tci_alg <- list(tci_plasma, tci_effect)[[which(type == c("plasma","effect"))]]
  } else{
    if(!all(c("Ct","pkmod","dtm") %in% names(formals(custom_alg))))
      stop('pkmod must contain arguments ("Ct","pkmod","dtm").')
    tci_alg <- custom_alg
  }

  if(is.null(dtm)) dtm <- eval(formals(tci_alg)$dtm)

  tms <- target_tms
  if(any(inittm > tms)) stop("inittm cannot be greater than any target times")

  if(!is.null(pkmod$pdfn) & !ignore_pd){
    Ct <- pkmod$pdinv(target_vals, pars = pkmod$pars_pd)
  } else{
    Ct <- target_vals
  }

  # create step function to define targets at any point
  tms <- tms-inittm
  sf <- stepfun(tms, c(0,Ct))
  # updatetms <- seq(0, max(tms), dtm)
  updatetms <- seq(0, max(tms)-dtm, dtm)

  inf <- rep(NA, length(updatetms))
  ini <- matrix(NA, nrow = pkmod$ncmpt, ncol = length(updatetms)+1)
  ini[,1] <- pkmod$init

  # iterate through times
  for(i in 1:length(updatetms)){
    inf[i] <- tci_alg(sf(updatetms[i]), pkmod = pkmod, dtm = dtm, init = ini[,i], ...)
    ini[,i+1] <- pkmod$pkfn(tm = dtm, pars = pkmod$pars_pk, kR = inf[i], init = ini[,i])
  }

  startcon <- matrix(ini[,-ncol(ini)], ncol = nrow(ini), nrow = ncol(ini)-1, byrow = TRUE)
  endcon <- matrix(ini[,-1], ncol = nrow(ini), nrow = ncol(ini)-1, byrow = TRUE)
  dose <- inf_manual(inf_tms = updatetms+inittm, inf_rate = inf, duration = dtm)
  out <- cbind(dose, sf(updatetms), startcon, endcon)
  colnames(out) <- c("begin","end","inf_rate","Ct",paste0("c",1:pkmod$ncmpt, "_start"),
                     paste0("c",1:pkmod$ncmpt, "_end"))

  if(!is.null(pkmod$pdfn) & !ignore_pd){
    pdt <- pkmod$pdfn(out[,"Ct"], pkmod$pars_pd)
    pdresp_start <- pkmod$pdfn(out[,paste0("c",pkmod$ecmpt,"_start")], pkmod$pars_pd)
    pdresp_end <- pkmod$pdfn(out[,paste0("c",pkmod$ecmpt,"_end")], pkmod$pars_pd)

    out <- cbind(out,
                 pdt = pdt,
                 pdresp_start = pdresp_start,
                 pdresp_end = pdresp_end)
  }

  return(out)
}


#' Target-controlled infusion
#'
#' Apply a TCI algorithm to a set of targets and a `pkmod` or `poppkmod` object to calculate infusion
#' rates.
#' @param pkmod `pkmod` object created by `pkmod()` or a `poppkmod` object created by `poppkmod()`.
#' @param target_vals A vector of numeric values indicating PK or PD targets for TCI algorithm.
#' @param target_tms A vector of numeric values indicating times at which the TCI algorithm should
#' begin targeting each value.
#' @param type Type of TCI algorithm to be used. Options are plasma- or effect-site
#' targeting.
#' @param dtm TCI update frequency. Defaults to 1/6, corresponding to 10-second
#' intervals if model parameters are in terms of minutes.
#' @param custom_alg Custom TCI algorithm to be used instead of default plasma-
#' or effect-site targeting algorithms. The algorithm should be a function that
#' takes minimum arguments `Ct`, `pkmod`, and `dtm` and returns a single infusion
#' rate. See `tci_plasma` or `tci_effect` for examples and vignette on custom
#' models/algorithms for more details.
#' @param inittm Initial time to start TCI algorithm. Cannot be greater than
#' the minimum value of `target_tms`.
#' @param ignore_pd Logical. Should the PD component of the pkmod object (if present)
#' be ignored. By default, predict.tciinf will assume that 'value' refers to PD
#' targets if a PD model is specified.
#' @param ... Arguments passed to TCI algorithm
#' @examples
#' # 3-compartment model with effect-site
#' my_mod <- pkmod(pars_pk = c(v1 = 8.995, v2 = 17.297, v3 = 120.963, cl = 1.382,
#' q2 = 0.919, q3 = 0.609, ke0 = 1.289))
#' # plasma targeting
#' inf_tci(my_mod, target_vals = c(2,3,4,4), target_tms = c(0,2,3,10), "plasma")
#' # effect-site targeting
#' inf_tci(my_mod, target_vals = c(2,3,4,4), target_tms = c(0,2,3,10), "effect")
#' # poppkmod object
#' data <- data.frame(ID = 1:5, AGE = seq(20,60,by=10), TBW = seq(60,80,by=5),
#' HGT = seq(150,190,by=10), MALE = c(TRUE,TRUE,FALSE,FALSE,FALSE))
#' elvd_mod <- poppkmod(data, drug = "ppf", model = "eleveld")
#' inf_tci(elvd_mod, target_vals = c(2,3,4,4), target_tms = c(0,2,3,10), "effect")
#' @export
inf_tci <- function(pkmod, target_vals, target_tms, type = c("plasma","effect"), dtm = NULL, custom_alg = NULL, inittm = 0, ignore_pd = FALSE, ...){

  if(!(inherits(pkmod,"pkmod")|inherits(pkmod, "poppkmod")))
    stop("pkmod must have class 'pkmod' or 'poppkmod'")
  if(inherits(pkmod,"pkmod")){
    apply_tci(pkmod, target_vals, target_tms, type = match.arg(type), dtm = dtm, custom_alg = custom_alg, inittm = inittm, ignore_pd = ignore_pd, ...)
  } else{
    infs <- lapply(pkmod$pkmods, apply_tci, target_vals = target_vals, target_tms=target_tms, type = match.arg(type), dtm = dtm, custom_alg = custom_alg, inittm = inittm, ignore_pd = ignore_pd, ...)
    cbind(id=rep(pkmod$ids, each = nrow(infs[[1]])),do.call("rbind", infs))
  }
}


#'  infusion schedule
#'
#' Returns a data frame describing a set of infusions to be administered. Output
#' can be used as argument "inf" in predict_pkmod.
#'
#' @param inf_tms Vector of time to begin infusions. If duration is NULL, times
#' expected to include both infusion start and infusion end times.
#' @param inf_rate Vector of infusion rates. Must lave length equal to either
#' length(inf_tms) or 1. If length(inf_rate)=1, the same infusion rate will be
#' administered at each time. Either inf_rate or target must be specified, but not both.
#' @param duration Optional duration of infusions.
#' @return Matrix of infusion rates, start and end times.
#' @importFrom utils tail
#' @examples
#' # specify start and end times, as well as infusion rates (including 0).
#' inf_manual(inf_tms = c(0,0.5,4,4.5,10), inf_rate = c(100,0,80,0,0))
#' # specify start times, single infusion rate and single duration
#' inf_manual(inf_tms = c(0,4), inf_rate = 100, duration = 0.5)
#' # multiple infusion rates, single duration
#' inf_manual(inf_tms = c(0,4), inf_rate = c(100,80), duration = 0.5)
#' # multiple sequential infusion rates
#' inf_manual(inf_tms = seq(0,1,1/6), inf_rate = 100, duration = 1/6)
#' # single infusion rate, multiple durations
#' inf_manual(inf_tms = c(0,4), inf_rate = 100, duration = c(0.5,1))
#' # multiple infusion rates, multiple durations
#' inf_manual(inf_tms = c(0,4), inf_rate = c(100,80), duration = c(0.5,1))
#' @export
inf_manual <- function(inf_tms, inf_rate, duration = NULL)
{

  if(!is.null(duration) & !(length(duration) %in% c(1, length(inf_tms))))
    stop("duration length must be equal to 1 or length of time vector")
  if(!(length(inf_rate) %in% c(1, length(inf_tms))))
    stop("inf_rate length must be equal to 1 or length of time vector")
  if(!(length(inf_rate) %in% c(1, length(inf_tms))) & tail(inf_rate,1)!=0 & !is.null(duration))
    stop("Final value of inf_rate must be zero or duration must be non-null")
  if(!is.null(duration)){
    endtms <- inf_tms + duration
    alltms <- union(round(inf_tms,5), round(endtms,5))
    ord <- order(alltms)
    if(length(inf_rate) == 1) inf_rate <- c(rep(inf_rate,length(inf_tms)), rep(0,length(endtms)))
    out <- as.matrix(cbind(
      begin = alltms[ord][-length(alltms)],
      end = alltms[ord][-1],
      inf_rate = inf_rate[ord][-length(alltms)]))
    out[is.na(out[,"inf_rate"]),"inf_rate"] <- 0
  } else{
    out <- as.matrix(cbind(begin = inf_tms[-length(inf_tms)],
                           end = inf_tms[-1],
                           inf_rate = inf_rate[-length(inf_rate)]))
  }
  return(out)
}