I recently downloaded the deSolve-package to solve ODE-models. I programmed a model according to some example code I found, yet, there seems to be a problem with the handing over of parameters since I get an error massage about unknown parameters.
library(deSolve)
model <- function(t, y, parms) {
dY1 = -(k1 * y[1]) + (k2 * y[6]) - (k13 * y[1] * 400*sin(((2*pi)/period_ca)*t-phase_ca)+600) + (k14 * y[2]) - (k17 * y[1] * 400*sin(((2*pi)/period_dg)*t-phase_dg)+600) + (k18 *y[11]) - (k3*y[1] * AA) + (k4 * y[7])
dY2 = (k13 * y[1] * 400*sin(((2*pi)/period_ca)*t-phase_ca)+600) - (k14 * y[2]) - (k15 * y[2] *400*sin(((2*pi)/period_dg)*t-phase_dg)+600) + (k16 * y[3]) - (k5 * y[2]) + (k6 * y[8]) - (k7 * y[2] * AA) + (k8 * y[9])
dY3 = (k15 * y[2] * 400*sin(((2*pi)/period_dg)*t-phase_dg)+600) - (k16 * y[3]) - (k9 * y[3]) + (k10 * y[10])
dY4 = -(k11 * y[4]) + (k12 * y[5]) + (k19 * y[11] * AA) - (k20 * y[4])
dY5 = (k11 * y[4]) - (k12 * y[5])
dY6 = (k1 * y[1]) - (k2 * y[6])
dY7 = (k3 + y[1] * AA) - (k4 * y[7])
dY8 = (k5 * y[2]) - (k6 * y[8])
dY9 = (k7 * y[2] * AA) - (k8 * y[9])
dY10 = (k9 * y[3]) - (k10 * y[10])
dY11 = (k17 * y[1] * 400*sin(((2*pi)/period_dg)*t-phase_dg)+600) - (k18 * y[11]) - (k19 * y[11] * AA) + (k20 * y[4])
list(c(dY1, dY2, dY3,dY4, dY5, dY6,dY7, dY8, dY9, dY10, dY11))
}
yini <- c(y1 = 1000, y2 = 0, y3 = 0, y4 = 0, y5 = 0, y6 = 20, y7 = 0, y8 = 0, y9 = 0, y10 = 0, y11 = 0)
times <- seq(from = 0, to = 5000, by = 0.1)
parms <- c(AA=11000, k1=1, k2=50, k3=1.2e-7, k4=0.1, k5=1.2705, k6=3.5026, k7=1.2e-6, k8=0.1, k9=1, k10=0.1, k11=2, k12=0.2, k13=0.0006, k14=0.5, k15=7.998e-6,
k16=8.6348, k17=6e-7, k18=0.1, k19=1.8e-5, k20=2, period_ca=100, phase_ca=0, period_dg=100,
phase_dg=0)
out <- ode (times = times, y = yini, func = model, parms = parms)
Here dY1 to dY11 represent differential equations for certain system components. Parms is a vector defining the necessary parameter values, yini defines the initial conditions and times the time scale.
I receive the following error message:
Error in func(time, state, parms, ...) : object 'k1' not found
I am quite new to R and do not understand the origin of the problem (all example code I found was constructed the same way).
You have to look up some examples from the deSolve package. To use your parameters in the function, you need to use the with function:
model <- function(t, y, parms) {
with(as.list(c(y, parms)), {
dY1 = ...
.
.
.
dY11 = ...
list(c(dY1, dY2, dY3,dY4, dY5, dY6,dY7, dY8, dY9, dY10, dY11))
})
}
Nevertheless I got an error, because the integration fails, but this occurs not because the code is wrong. Perhaps this is not the case on your PC.
You can try this code for solving the ODE, which gives some warnings, but integration is successful (on my PC):
out <- ode(times = times, y = yini, func = model, parms = parms, method = "bdf")
Related
I am trying to implement the following formula in R where r0, t, theta0 and alpha are constants. Also, I is a Modified Bessel function of the first kind. My issue, I suppose, is from the Sum term to the end of the formula. I set n = 150 given that the function converges to zero fast so there is no need to go beyond 150. I am using the "Bessel" package.
Formula1
Formula2
Results to reproduce first row = t, second row = Defaultcorr in %
Here is what I have thus far. I can't seem to find my mistake. Defaultcorr should be 0.04 % when t = 1 (according to the image "Results to reproduce").
To obtain this result " m " should be equal to 6.234611709.
V1 = 5
V2 = 5
K1 = 1
K2 = 1
sigma1 = 0.3
sigma2 = 0.3
Z1 = log((V1/K1)/sigma1)
Z2 = log((V2/K2)/sigma2)
t = 1
rho = 0.4
#One firm default -> Firm #1 when lambda = mu
PD_asset1 = 2 * pnorm(-(Z1/sqrt(t)))
PD_asset1
PD_asset2 = 2 * pnorm(-(Z2/sqrt(t)))
PD_asset2
#Results assuming that lambda = mu
#Conditions for alpha, theta0, r0
if (rho < 0) { #alpha
alpha = atan(-(sqrt(1-rho^2)) / rho)
} else {
alpha = pi + atan(-(sqrt(1-rho^2)) / rho)
}
if (rho > 0) { #theta0
theta0 = atan((Z2 * sqrt(1 - rho^2)) / (Z1 - (rho * Z2)))
} else {
theta0 = pi + atan((Z2 * sqrt(1 - rho^2)) / (Z1 - (rho * Z2)))
}
r0 = (Z2 / sin(theta0)) #r0
#Simplified function
h = function(n) {
(sin((n * pi * theta0)/alpha)/n)
}
n = seq(1, 150, 2)
Bessel1 = (besselI(((r0^2)/(4*t)), (0.5*(((n*pi)/alpha) + 1)), FALSE))
Bessel2 = (besselI(((r0^2)/(4*t)), (0.5*(((n*pi)/alpha) - 1)), FALSE))
l = matrix(data = n, ncol = n)
m = apply((h(l)*(Bessel1 + Bessel2)), 2, FUN = sum)
PD_asset1_or_asset2 = 1 - (((2 * r0)/(sqrt(2*pi*t))) * (exp(-(r0^2)/(4*t))) * m)
PD_asset1_or_asset2
Var_asset1 = PD_asset1 * (1 - PD_asset1)
Var_asset1
Var_asset2 = PD_asset2 * (1 - PD_asset2)
Var_asset2
PD_asset1_and_asset2 = PD_asset1 + PD_asset2 - PD_asset1_or_asset2
PD_asset1_and_asset2
Defaultcorr = (PD_asset1_and_asset2 - (PD_asset1 * PD_asset2)) / (sqrt(Var_asset1 * Var_asset2))
Defaultcorr
Any help would be appreciated. Thank you
I'm trying to make a simple neural network with R.
i want to my code to tell me if this iris is versicolor or virginica this to type are not linear separable, in Single layer NN it's simple but in Multi-layer NN i don't know how to update the weight and bias.
this is the code that i made it gives me the same predict of all my data .
I'm using 4 input one hidden layer with 3 node and one output.
data = matrix(
c(iris[1,1:4],
iris[2,1:4],
iris[3,1:4],
iris[4,1:4],
iris[5,1:4],
iris[51,1:4],
iris[52,1:4],
iris[53,1:4],
iris[54,1:4],
iris[55,1:4],
iris[101,1:4],
iris[102,1:4],
iris[103,1:4],
iris[104,1:4],
iris[105,1:4]),
ncol = 4,
byrow = TRUE
)
dataOut <- c(0,0,0,0,0,1,1,1,1,1,0,0,0,0,0) # 1 => versicolor
sigmoid <- function(x){
1/(1+exp(-x))
}
sigmoid_p <- function(x){
sigmoid(x) * (1 - sigmoid(-x))
}
l_rate = 0.01
w1 <- runif(12)
w2 <- runif(3)
b1 <- runif(3)
b2 <- runif(1)
sH <- c(0,0,0)
outH <- c(0,0,0)
for(i in 1:5000){
ri = as.integer(runif(1,1,16))#ri => random number
p <- c(as.double(data[ri,]))
#value of 1st node in hidden layer
sH[1] = p[1]*w1[1] + p[2]*w1[2] + p[3]*w1[3] + p[4]*w1[4] + b1[1]
outH[1] = sigmoid(sH[1])
#value of 2nd node in hidden layer
sH[2] = p[1]*w1[5] + p[2]*w1[6] + p[3]*w1[7] + p[4]*w1[8] + b1[2]
outH[2] = sigmoid(sH[2])
#value of 3th node in hidden layer
sH[3] = p[1]*w1[9] + p[2]*w1[10] + p[3]*w1[11] + p[4]*w1[12] + b1[3]
outH[3] = sigmoid(sH[3])
#value of the output
s = outH[1]*w2[1] + outH[2]*w2[2] + outH[3]*w2[3] + b2
out = sigmoid(s)
error_P = out - dataOut[ri]
out_P = sigmoid_p(s)
w2_p <- c(0,0,0)
w2_p[1] = error_P * out_P * outH[1]
w2_p[2] = error_P * out_P * outH[2]
w2_p[3] = error_P * out_P * outH[3]
w1_p <- c(0,0,0,0,0,0,0,0,0,0,0,0)
w1_p[1] = error_P * out_P * w2[1] * sigmoid_p(sH[1]) * p[1]
w1_p[2] = error_P * out_P * w2[1] * sigmoid_p(sH[1]) * p[2]
w1_p[3] = error_P * out_P * w2[1] * sigmoid_p(sH[1]) * p[3]
w1_p[4] = error_P * out_P * w2[1] * sigmoid_p(sH[1]) * p[4]
w1_p[5] = error_P * out_P * w2[2] * sigmoid_p(sH[2]) * p[1]
w1_p[6] = error_P * out_P * w2[2] * sigmoid_p(sH[2]) * p[2]
w1_p[7] = error_P * out_P * w2[2] * sigmoid_p(sH[2]) * p[3]
w1_p[8] = error_P * out_P * w2[2] * sigmoid_p(sH[2]) * p[4]
w1_p[9] = error_P * out_P * w2[3] * sigmoid_p(sH[3]) * p[1]
w1_p[10] = error_P * out_P * w2[3] * sigmoid_p(sH[3]) * p[2]
w1_p[11] = error_P * out_P * w2[3] * sigmoid_p(sH[3]) * p[3]
w1_p[12] = error_P * out_P * w2[3] * sigmoid_p(sH[3]) * p[4]
for(j in 1: 3){
w2[j] = w2[j] - l_rate * w2_p[j]
}
b2 = b2 - l_rate * error_P * out_P
for(j in 1: 12){
w1[j] = w1[j] - l_rate * w1_p[j]
}
for(j in 1: 3){
b1[j] = b1[j] - l_rate * error_P * sigmoid_p(sH[j])
}
}
for(i in 1:15){
p <- c(as.double(data[i,]))
sH[1] = p[1]*w1[1] + p[2]*w1[2] + p[3]*w1[3] + p[4]*w1[4] + b1[1]
outH[1] = sigmoid(sH[1])
sH[2] = p[1]*w1[5] + p[2]*w1[6] + p[3]*w1[7] + p[4]*w1[8] + b1[2]
outH[2] = sigmoid(sH[2])
sH[3] = p[1]*w1[9] + p[2]*w1[10] + p[3]*w1[11] + p[4]*w1[12] + b1[3]
outH[3] = sigmoid(sH[3])
s = outH[1]*w2[1] + outH[2]*w2[2] + outH[3]*w2[3] + b2
out = sigmoid(s)
if(out < 0.5)
print(c(out,"Not Vericolor"))
else
print(c(out,"Vericolor"))
}
I keep getting the error:
Error in checkFunc(Func2, times, y, rho) :
The number of derivatives returned by func() (175) must equal the length of the initial conditions vector (51)
I am trying to create a model based off of Brigatti et al 2009 (pred-prey model w a spatial component)
x<-c(1:40000)
left_shift = function(x) {
x[c(2:length(x), 1)]
}
right_shift = function(x) {
x[c(length(x), 1:(length(x) - 1))]
}
laplace = function(x) {
return(c(left_shift(x) + right_shift(x) - 2 * x))
}
dxdt <- function(time, state, pars) {
prey = state[1:length(state) / 2]
pred = state[(length(state) / 2 + 1):length(state)]
dprey = pars[5] * laplace(prey) + pars[1] * prey - x[2] * prey * pred
dpred = pars[5] * laplace(pred) + pars[3] * prey * pred - pars[4] * pred
list(c(prey, pred, dprey, dpred))
}
time <- seq(0, 600, by = 1)
pars <- c(alpha=1,
beta = .5,
gamma = .2,
delta = .6,
D = 0.000008 #(0.004*0.004/2), #diffusion coefficient
)
state <- rep(0.1, 51)
out <- as.data.frame(ode(func = dxdt, y = state, parms = pars, times = time))
A few problems. First, missing parentheses.
prey = state[1:length(state) / 2]
should read
prey = state[1:(length(state) / 2)]
Second, your initial conditions are an odd number in length. state should specify the initial conditions for both prey and predator (in that order). So, for each location there should be two values and, consequently, the vector should always be a multiple of two in length.
Thirdly, your function dxdt should return list(c(dprey, dpred)). There is no reason to return the values for the state variables, because the ODE solver will calculate those.
Fix those and this is what you get:
left_shift = function(x) {
x[c(2:length(x), 1)]
}
right_shift = function(x) {
x[c(length(x), 1:(length(x) - 1))]
}
laplace = function(x) {
return(c(left_shift(x) + right_shift(x) - 2 * x))
}
dxdt <- function(time, state, pars) {
prey = state[1:(length(state) / 2)]
pred = state[(length(state) / 2 + 1):length(state)]
dprey = pars[5] * laplace(prey) + pars[1] * prey - x[2] * prey * pred
dpred = pars[5] * laplace(pred) + pars[3] * prey * pred - pars[4] * pred
list(c(dprey, dpred))
}
time <- seq(0, 600, by = 1)
pars <- c(alpha=1,
beta = .5,
gamma = .2,
delta = .6,
D = 0.000008 #(0.004*0.004/2), #diffusion coefficient
)
state <- rep(0.1, 50)
out <- as.data.frame(ode(func = dxdt, y = state, parms = pars, times = time))
I'm trying to plot the results of a For Loop, as follows:
marketPrice = 100
strikePrice = 125
tau = 1
dividendYield = .03
interestRate = .02
sigma = .25
lowerMarketBound = 100
upperMarketBound = 150
stepIncrement = 5
callPrice = NULL
putPrice = NULL
plot(marketPrice, callPrice)
for (marketPrice in seq(from=lowerMarketBound, to=upperMarketBound,
by=stepIncrement)){
d1 = ((log(marketPrice / strikePrice)) + ((interestRate +
(sigma**2/2)) * f_tau)) / (sigma * sqrt(tau))
d2 = d1 - (sigma * sqrt(tau))
print(marketPrice)
callPrice = marketPrice * pnorm(d1) - pnorm(d2) * strikePrice *
exp(1)^(-interestRate * tau)
putPrice = strikePrice * exp(1)^(-interestRate * tau) * pnorm(-d2) -
marketPrice * pnorm(-d1)
print (callPrice)
print (putPrice)
plot(marketPrice, callPrice)
}
The last line of the code calls plot(). I was expecting to see a plot of the marketPrice variable vs. the callPrice variable. Instead, I'm seeing a plot of only the LAST marketPrice and callPrice of the loop (in this case, 150 and 31.46, respectively).
Is there a way to plot all of the results of a For Loop?
You could store the values in a matrix during the loop and plot the whole series at the end.
tau = 1
dividendYield = .03
interestRate = .02
sigma = .25
lowerMarketBound = 100
upperMarketBound = 150
stepIncrement = 5
marketPrice = seq(from=lowerMarketBound, to=upperMarketBound,
by=stepIncrement)
strikePrice = 125
callPrice = rep(0,length(marketPrice))
putPrice = NULL
for (i in 1:length(marketPrice)){
d1 = ((log(marketPrice[i] / strikePrice) + (interestRate + (sigma**2/2)) * tau) / (sigma * sqrt(tau)))
d2 = d1 - (sigma * sqrt(tau))
print(marketPrice[i])
callPrice[i] = marketPrice[i] * pnorm(d1) - pnorm(d2) * strikePrice * exp(1)^(-interestRate * tau)
putPrice = strikePrice * exp(1)^(-interestRate * tau) * pnorm(-d2) - marketPrice[i] * pnorm(-d1)
print (callPrice[i])
print (putPrice)
}
plot(marketPrice, callPrice)
I am trying to fit the model below using rjags but I get a dimension mismatch error. The model runs well in WinBUGS and I can't figure out how to change the code. Thanks in advance for any help.
Data:
dataset <- list(n1 = 462, n2 = 537,
y1 = structure(.Data = c(37, 55, 7, 363), .Dim = c(2, 2)),
y2 = structure(.Data = c(104, 26, 22, 385), .Dim = c(2, 2)),
Q = 2)
Initial values for chains
inits <- list(pi1 = 0.1, pi2 = 0.3, SeMAT = 0.80, SpMAT = 0.90,
SeCMB = 0.90, SpCMB = 0.9995)
Model
model <-
'model {
y1[1:Q, 1:Q] ~ dmulti(p1[1:Q, 1:Q], n1)
y2[1:Q, 1:Q] ~ dmulti(p2[1:Q, 1:Q], n2)
p1[1, 1] <- pi1 * SeMAT * SeCMB + (1 - pi1) * (1 - SpMAT) * (1 - SpCMB)
p1[1, 2] <- pi1 * SeMAT * (1 - SeCMB) + (1 - pi1) * (1 - SpMAT) * SpCMB
p1[2, 1] <- pi1 * (1 - SeMAT) * SeCMB + (1 - pi1) * SpMAT * (1 - SpCMB)
p1[2, 2] <- pi1 * (1 - SeMAT) * (1 - SeCMB) + (1 - pi1) * SpMAT * SpCMB
p2[1, 1] <- pi2 * SeMAT * SeCMB + (1 - pi2) * (1 - SpMAT) * (1 - SpCMB)
p2[1, 2] <- pi2 * SeMAT * (1 - SeCMB) + (1 - pi2) * (1 - SpMAT) * SpCMB
p2[2, 1] <- pi2 * (1 - SeMAT) * SeCMB + (1 - pi2) * SpMAT * (1 - SpCMB)
p2[2, 2] <- pi2 * (1 - SeMAT) * (1 - SeCMB) + (1 - pi2) * SpMAT * SpCMB
SeMAT ~ dbeta(1, 1)
SpMAT ~ dbeta(1, 1)
SeCMB ~ dbeta(1, 1)
SpCMB ~ dbeta(1, 1)
pi1~ dbeta(1, 1)
pi2 ~ dbeta(1, 1)
}'
writeLines(model, 'model.txt')
jags.mod <- jags.model(file = 'model.txt',
data = dataset,
inits = inits,
n.chains = 3)
Error
Error in jags.model(file = "model.txt", data = dataset, inits = inits, :
RUNTIME ERROR:
Cannot insert node into y1[1:2,1:2]. Dimension mismatch
Did you mean to specify a multivariate distribution, not a multinomial one?
The multinomial distribution, dmulti, takes two parameters:n, an integer as you've specified it, and pi a single dimensional vector that sums to one.
Your p1 and p2 are both multi-dimensional, but can't be with that distribution.