如何在R中求解具有时间相关参数的常微分方程？

Question

I am trying to replicate an existing mathematical model in order to get "control" data for an independent research project. Link to article.

I want to solve a system of five ordinary differential equations in R, using the deSolve package. However, most of the parameters are seasonal; the previous researchers used the 'pchip' function from the pracma package in order to create functions for the parameters:

pchip is a `shape-preserving' piecewise cubic Hermite polynomial approach that apptempts to determine slopes such that function values do not overshoot data values. pchipfun is a wrapper around pchip and returns a function. Both pchip and the function returned by pchipfun are vectorized.

xi and yi must be vectors of the same length greater or equal 3 (for cubic interpolation to be possible), and xi must be sorted. pchip can be applied to points outside [min(xi), max(xi)], but the result does not make much sense outside this interval.

graphed, 'beta' parameter over five years

This is the code I have (just trying to get outputs for one year):

x <- c(0, 1, 2, 3, 4)
ybeta <- c(500, 1500, 500, 0, 500)
yk <- c(8000, 12, 0, 8000, 8000)
yrec <- c(0.25, 0.25, 0.25, 0, 0.25)
yfb <- c(1.5, 1.5, 1.5, 1.5, 1.5)
yno <- c(0, 0, 0, 0.00649, 0)
yni <- c(0, 0, 0, 0.00649, 0)
ypo <- c(0.08511, 0.08511, 0.08511, 0, 0.08511)
ypi <- c(0.16936, 0.16936, 0.16936, 0, 0.16936)
yalpha <- c(0.55, 0.12, 0.24, 0, 0.55)
yW <- 0.1
ydep <- c(0.2061 * yW, 0.2835 * yW, 0.2527 * yW, yW, 0.2061 * yW)
ydec <- c(0.006470, 0.023300, 0.015683, 0, 0.006470)
yup <- c(0.15, 0.15, 0.15, 0.15, 0.15)

xs <- seq(0, 1, len = 365)


nosema <- function(time, state, parameters) {

    with(as.list(c(state, parameters)), {

        H <- Ho + Hi
        Fr <- Fo + Fi
        Z <- H + Fr
        dHo <- pchip(x, ybeta, xs)* (Z^n) / (pchip(x, yk, xs)^n + Z^n) - pchip(x, yrec, xs) * Ho + pchip(x, yfb, xs) * Fr/Z * Fo - pchip(x, yno, xs) * Ho - pchip(x, yalpha, xs) * Ho * E/(sr + E)
        dHi <- -pchip(x, yrec, xs) * Hi + pchip(x, yfb, xs) * Fr/Z * Fi - pchip(x, yni, xs) * Hi + pchip(x, yalpha, xs) * Ho * E/(sr + E)
        dFo <- pchip(x, yrec, xs) * Ho - pchip(x, yfb, xs) * Fr/Z * Fo - pchip(x, ypo, xs) * Fo
        dFi <- pchip(x, yrec, xs) * Hi - pchip(x, yfb, xs) * Fr/Z * Fi - pchip(x, ypi, xs) * Fi
        dE <- pchip(x, ydep, xs) * Hi - pchip(x, ydec, xs) * E - pchip(x, yup, xs) * Ho * E / (sr + E)

        return(list(c(dHo, dHi, dFo, dFi, dE)))
    })
}


init <- c(Ho = 10^4, Hi = 0, Fo = 10000, Fi = 0, E = 0)

parameters <- c(n = 2, 
        sr = 10000)

out <- ode(y = init, times = seq(0, 365, len = 365), func = nosema, parms = parameters)

out <- as.data.frame(out)

out$time <- NULL

head(out)

However, when I run the code above...

The number of derivatives returned by func() (1825) must equal the length of the initial conditions vector (5)

I think I have an inkling of why this isn't working, but I have no clue how to go about fixing it.

Does anyone have any advice on how to proceed?

Answer 1

library(deSolve)
?forcings

see page 72ff at http://desolve.r-forge.r-project.org/user2014/tutorial.pdf