A differential equation might be defined as
sys <- function(t, y, p, u) {
dy <- numeric(2)
u <- u(t)
dy[1] = p$a*(1 + p$b*(y[2] - 1)/(p$c + y[2] - 1) - u*y[1])
dy[2] = u*y[1] - y[2]
list(dy)
}
Let's furthermore assume that the steady states (equilibria) are known. Now, is there a way to calculate the Jacobian matrix of the right hand side of with respect to x?
I know that I could define
f <- function(y){
c(
p$a*(1 + p$b*(y[2] - 1)/(p$c + y[2] - 1) - u*y[1]),
u*y[1] - y[2]
)
}
and calculate the Jacobian with
Jx <- jacobian(f, c(1,1))
wherein jacobian comes from the pracma package. But isn't there an easier way without that intermediate step? It might also help if one could call f within sys, e.g.
sys <- function(t, y, p, u) {
dy <- numeric(2)
u <- u(t)
dy[1] = f(y)[1]
dy[2] = f(y)[2]
list(dy)
}
And lastly, might there also be a way to calculate the Jacobian w.r.t. to u?
Thanks a lot!
There is a solution with the R package rootSolve.
For this, your function definition has to be a little bit different, but (in my opinion) more convenient. I don't know your exact parameters p or your function u, so I made a minimal example:
library(rootSolve)
sys <- function(t, y, parms) {
with(as.list(c(y,parms)),{
dy = a*(1 + b*(z - 1)/(c + z - 1) - 1*y)
dz = 1*y - z
return(list(c(dy, dz)))
})
}
parms <- list(a = 1, b = 1, c= 2)
rootSolve::jacobian.full(y = c(y = 1, z = 1), func = sys, parms = parms)
In the function jacobian.fully() you can use your steady state results, I just picked random results. The definition of sys uses the standard definition for ODEs in the package deSolve, an excellent package for solving ODEs.
The result is a normal Jacobian matrix.
So with this definition you can run solving algorithms for your equations, e.g.
library(deSolve)
ode <- deSolve::ode(y = c(y = 1, z = 0),
times = seq(1,100),
func = sys,
parms = parms)
plot(ode)
I hope this helps you a little bit!
Regards,
J_F
Related
library(deSolve)
require(deSolve)
delta_conc <- function(time, current_state, params) {
with(as.list(c(current_state, params)),{
dX <- Y
dY <- X - X^3 - 0.25*Y + A * sin(t)
return(list(c(dX, dY)))
})
}
params <- c(
A <- 0.2645
)
initial_state <- c(
X <- 0.9,
Y <- 0.4
)
times <- 1:10
model <- ode(initial_state, times, delta_conc, params)
summary(model)
matplot(model, type="l",lty=1, main="Enzyme model", xlab="Time")
I get this error message when I try to run it:
Error in checkFunc(Func2, times, y, rho) :
The number of derivatives returned by func() (21) must equal the length of the initial conditions vector (2)
When I exclude the 'sin(t)' part it works, so the problem is with that part, but I'm very much a beginner so I have no idea how to approach this problem
You should consistently use einer t or time for the actual time step. In your case t is not defined as variable, so tis interpreted as transpose-function.
The following should work:
require(deSolve)
delta_conc <- function(time, current_state, params) {
with(as.list(c(current_state, params)),{
dX <- Y
dY <- X - X^3 - 0.25*Y + A * sin(time)
return(list(c(dX, dY)))
})
}
params <- c(
A = 0.2645
)
initial_state <- c(
X = 0.9,
Y = 0.4
)
times <- 1:10
model <- ode(initial_state, times, delta_conc, params)
summary(model)
matplot.0D(model, type="l",lty=1, main="Enzyme model", xlab="Time")
In addition, the code had also some other issues:
use either require or library and not both
use = within c(). It is parameter matching and not assignment
Two additional suggestions:
you can use the deSolve-built in plot function matplot.0D
I would recommend to use times <- seq(0, 10, length.out = 100) instead of 1:10. This way the plot will get smooth. Starting time with 1 (or another value) may be ok, but is often more convenient to start time with zero.
I'm attempting to solve a set of equations related to biological processes. One equation (of about 5) is for a pharmacokinetic (PK) curve of the form C = Co(exp(k1*t)-exp(k2*t). The need is to simultaneously solve the derivative of this equation along with some enzyme binding equations and initial results where not as expected. After troubleshooting, realized that the PK derivative doesn't numerically integrate by itself, if k is negative using the desolve ode function. I've attempted every method (lsode, lsoda, etc) in the ode function, with no success. I've tried adjusting rtol, it doesn't resolve.
Is there an alternative to the deSolve ode function I should investigate? Or another way to get at this problem?
Below is the code with a simplified equation to demonstrate the problem.
When k is negative, the integrated solution does not match the analytical result.
When k is positive, results are as expected.
First Image, result with k=0.2: Analytical and Integrated results match when k is positive
Second Image, result with k=-0.2: Integrated result does not match analytical when k is negative
library(deSolve)
abi <- function(t, state, parameters) {
with(as.list(c(state, parameters)), {
dI <- k*exp(k*t)
list(c(dI))
})
}
k <- c(-0.2)
times <- seq(0, 24, by = 1)
I_analytical <- exp(k*times)
parameters <- c(k)
state <- c(I = 0)
out <- ode(y = state, times = times, func = abi, parms = parameters)
plot(out)
points(I_analytical ~ times)
It was pointed out that the initial condition easily resolves the above example, which is very helpful. Here is the equation I can't accurately integrate, I've tried a few different initial conditions without real success.
library(deSolve)
## Chaos in the atmosphere
CYP <- function(t, state, parameters) {
with(as.list(c(state, parameters)), {
#dE <- ksyn - (kdeg * E) + (k2 * EI) - (k1 * E * I)
#dEI <- (k1 * E * I) - (k2 * EI) + (k4 * EIstar) - (k3 * EI)
#dEIstar <- (k3 * EI) - (k4 * EIstar)
#dOcc <- dEI + dEIstar
dI <- a*tau1*exp(tau1*t) + b*tau2*exp(tau2*t) + c*tau3*exp(tau3*t)
#list(c(dE, dEI, dEIstar, dOcc, dI))
list(c(dI))
})
}
ifit <- c(-0.956144311,0.82619445,0.024520276,-0.913499862,-0.407478829,-0.037174745)
a = ifit[1]
b = ifit[2]
c = ifit[3]
tau1 = ifit[4]
tau2 = ifit[5]
tau3 = ifit[6]
parameters <- c(ksyn = 0.82, kdeg = 0.02, k1 = 2808, k2 = 370.66, k3 = 2.12, k4 = 0.017, a, b, c, tau1, tau2, tau3)
#state <- c(E = 41, EI = 0, EIstar = 0, Occupancy = 0, I = 0.0)
state <- c(I=-0.01)
times <- seq(0, 24, by = .1)
out <- ode(y = state, times = times, func = CYP, parms = parameters)
I_analytical <- a*exp(tau1*times) + b*exp(tau2*times) + c*exp(tau3*times)
plot(out)
points(I_analytical ~ times)
Target curve and the ode solution line.
The initial value should be
state <- c(I= a + b + c)
#state <- c(I = 1)
The first script contains several issues. The most important two are that (1) the model function (abi) must contain the derivative, not an integrated function, while (2) the analytically integrated model missed I_0 that results from the integration constant.
Let's assume a first order decay model
dI/dt = k I
then analytical integration yields
I_t = I_0 exp(kt)
The code is then:
library(deSolve)
abi <- function(t, state, parameters) {
with(as.list(c(state, parameters)), {
# dI <- k*exp(k*t) # original
dI <- k * I # corrected, should be the dervivative
list(c(dI))
})
}
k <- -0.2 # simplified, c() was not necessary
times <- seq(0, 24, by = 1)
# correction: set I0 to a value > zero
I0 <- 10
# I_analytical <- exp(k*times) # original
I_analytical <- I0 * exp(k*times) # corrected, multiplied with I0
#state <- c(I = 0) # original
state <- c(I = I0) # corrected
parameters <- c(k = k)
out <- ode(y = state, times = times, func = abi, parms = parameters)
plot(out)
points(I_analytical ~ times)
This code can be further simplified if you want.
I have an equation as below;
dN/dt = N(t)G(t)
G(t) is given by the equation: dG/dt = a * G
How do I solve this in R, using ode function from deSolve package?
As dario already mentioned, the question lacks some details. Nevertheless, let's try an answer. If we assume that a < 0, the model looks like the ode formulation of Gompertz growth:
dN/dt = N * G
dG/dt = a * G
This can then be solved as:
library(deSolve)
model <- function(t, y, p) {
with(as.list(c(y, p)), {
dN <- N * G
dG <- a * G
list(c(dN, dG))
})
}
y <- c(N = 1, G = 1)
parms <- c(a = -0.1)
times <- seq(0, 100)
out <- ode(y, times, model, parms)
plot(out)
I'm trying to write the density of a mixture Gaussian distribution to an arbitrary power, b, in R. Currently, I have two methods that works, but I prefer if I could avoid a for loop.
dnorm_mix_tempered_unnorm <- function(x, w, m, s, b) {
value <- 0
for (i in 1:length(w)) {value <- value + w[i]*dnorm(x, mean = m[i], sd = s[i])}
value <- value^(b)
return(value)
}
Alternatively, I can vectorise this to avoid the for loop:
dnorm_mix_tempered_unnorm <- function(x, w, m, s, b) {
return(sum(w*dnorm(x, mean = m, sd = s))^b)
}
Both of these give the same result, but the second is more efficient since it is vectorised. But I need to next normalise this so that the density integrates to 1, I do this by using:
dnorm_mix_tempered <- function(x, weights, means, sds, beta) {
norm_constant <- integrate(function(x) dnorm_mix_tempered_unnorm(x, w = weights,
m = means, s = sds, b = 1/beta), lower = -Inf,
upper = Inf)$value
value <- dnorm_mix_tempered_unnorm(x, w = weights, m = means, s = sds, b = 1/beta)
/ norm_constant
return(value)
}
If I define dnorm_mix_tempered_unnorm with for loops, this works with no problem, and I can use curve() to plot the density. But if I define dnorm_mix_tempered_unnorm by using vectorisation, then I get the following error:
Error in integrate(function(x) dnorm_mix_tempered_unnorm(x, w = weights, :
evaluation of function gave a result of wrong length
Does anyone know what is going on when I am vectorising instead and trying to integrate?
Thanks in advance,
R.
A possible option is
dnorm_mix_tempered_unnorm <- function(x, w, m, s, b) {
return(rowSums(mapply(dnorm, mean = m, sd = m, MoreArgs = list(x = x)))^b)
}
But I think it is quite similar to your first proposal.
I am using the example from here, where the original post had an objective function returning a list, with first element equal to the value of the objective function and the second element the gradient:
logisticRegressionCost <- function(theta, X, y) {
J = 0;
theta = as.matrix(theta);
X = as.matrix(X);
y = as.matrix(y);
rows = dim(theta)[2];
cols = dim(theta)[1];
grad = matrix(0, rows, cols);
predicted = sigmoid(X %*% theta);
J = (-y) * log(predicted) - (1 - y) * log(1 - predicted);
J = sum(J) / dim(y)[1];
grad = t(predicted - y);
grad = grad %*% X;
grad = grad / dim(y)[1];
return(list(fn = J, gr = t(grad)));
}
The suggested solution to use optim is to split this into two separate functions that serve as wrappers, e.g.:
fn <- function(...){
logisticRegressionCost(...)$fn
}
gr <- function(...){
logisticRegressionCost(...)$gr
}
and thus optim can be called like optim(fn = fn, gr = gr, ...).
However, this is unsatisfactory as computation of the gradient generally relies on shared computations with the objective function. In this case, the line:
predicted = sigmoid(X %*% theta);
will definitely be duplicated.
Is there a way to use optim so that shared computations between the objective function and gradient are efficient performed?