ODE，多根和事件，R

Question

I like to solve a system of coupled differential equations which involve multiple thresholds. Going through the R information this leads me to using ODE in combination with the root function and the event function.

Going through various examples, ie temperature model, page 14 http://cran.r-project.org/web/packages/diffEq/vignettes/ODEinR.pdf -- code pasted below --, I am able to let my model act on one threshold, ie finding the root/ reaching the threshold for one variable triggers an event.

library(deSolve)
yini <- c(temp = 18, heating_on=1)

temp <- function(t,y, parms) {
  dy1 <- ifelse(y[2] == 1, 1.0, -0.5)
  dy2 <- 0
 list(c(dy1, dy2))
}

rootfunc <- function(t,y,parms) c(y[1]-18, y[1]-20)

eventfunc <- function(t,y,parms) {
  y[1] <- y[1]
  y[2] <- ! y[2]  
 return(y)
}

times <- seq(from=0, to=20, by=0.1)
out <- lsode(times=times, y=yini, func = temp, parms = NULL, 
         rootfun = rootfunc, events = list(func=eventfunc, root = TRUE))
plot(out, lwd=2)
attributes(out)$troot

The example shows also that different roots can trigger the same event function (y[1] – 18 and y[1]-20 both trigger eventfunc). My question is, however, is it also possible to have different roots trigger different event functions? Said differently, depending on which root is found, a different eventfunc is triggered? Or alternatively, within the same eventfunct, can it do different actions depending on which root is found.

To keep it simple I first wanted to see if this can work using the same example, for instance by naming the roots and by working with an if statement? At the moment that doesn't work. Does anyone have experience with this? If you look at attributes(out) it seems like ODE does keep a record of which root is encountered $indroot (but that's after evaluation.) Thank you in advance.

# library(deSolve)
yini <- c(temp = 18, heating_on=1)

temp <- function(t,y, parms) {
  dy1 <- ifelse(y[2] == 1, 1.0, -0.5)
  dy2 <- 0
 list(c(dy1, dy2))
}

rootfunc <- function(t,y,parms) {
  yroot <- vector(len = 2)
  yroot[1] <- y[1]-18 
  yroot[2] <- y[1]-20
 return(yroot)
}

eventfunc <- function(t,y, parms) {
  y[1] <- y[1]
  ifelse(yroot[2]==2, y[2] <- y[2], y[2] <- !y[2])
 return(y)
}

times <- seq(from=0, to=20,by=0.1)
out <- lsode(times=times, y=yini, func = temp, parms = NULL, 
         rootfun = rootfunc, events = list(func=eventfunc, root = TRUE))
plot(out, lwd=2)
attributes(out)$troot 

Answer 1

The state y of the system is available in both, the root function and the event function, so it can be used as a condition which event to trigger.

For more complex cases it is of course also possible to dispatch the events from a main event function to different functions for the details, the same is also possible for checking the root condition.

Thanks to @Bakaburg for spotting this interesting unanswered question.

Here a solution that also simplifies some programming construcs:

library(deSolve)
yini <- c(temp = 18, heating_on = 1)

temp <- function(t,y, parms) {
  dy1 <- ifelse(y[2] == 1, 1.0, -0.5)
  dy2 <- 0
  list(c(dy1, dy2))
}

rootfunc <- function(t, y, parms) {
  yroot <- c(y[1] - 18, y[1] - 20)
  return(yroot)
}

eventfunc <- function(t, y, parms) {
  yroot <- c(y[1] - 18, y[1] - 20)
  whichroot <- which(abs(yroot) < 1e-6) # specify tolerance
  y[2] <- if(whichroot == 2) 0 else 1
  return(y)
}

times <- seq(from=0, to=20,by=0.1)
out <- lsode(times=times, y=yini, func = temp, parms = NULL, 
             rootfun = rootfunc, events = list(func=eventfunc, root = TRUE))
plot(out, lwd=2)

Answer 2

I approached a similar problem by using a global variable set in the root or directly in the main function (useful if you trigger it based on overcoming a threshold in a particular direction.

The global flag then changes the behaviour of the event function.

Not very elegant but it works.

In your case the code would become:

trigger <- FALSE

rootfunc <- function(t,y,parms) {
  yroot <- vector(len = 2)
  yroot[1] <- y[1]-18 
  yroot[2] <- y[1]-20

  if (yroot[2] == 0) trigger <- TRUE

  return(yroot)
}

eventfunc <- function(t,y, parms) {
  y[1] <- y[1]
  if (trigger) y[2] <- y[2] else y[2] <- !y[2]
  return(y)
}