The problem is to simulate an equation with variables that change. All the variables are fixed, expect for lower case s and treat_date. Here is the error message:
Error in checkFunc(Func2, times, y, rho) : The number of derivatives
returned by func() (202) must equal the length of the initial
conditions vector (2)
I have tried moving things around but I honestly have no idea what I am doing
seasonal_SI <- function (t, y, parameters) {
S <- y[1]
I <- y[2]
with(as.list(parameters), {
julian_date <- t %% 365
v <- ifelse(julian_date >= treat_date &
julian_date < (treat_date + 10) &
treatment, 0.9, v)
beta <- beta0 + s*beta0*sin(2*pi*(julian_date)/365)
dSdt <- b*(1-c*(S+I))*(S+rho*I)-d*S-beta*S*I
dIdt <- beta*S*I-(d+v)*I
res <- c(dSdt, dIdt)
list(res)
})
}
initials <- c(S=99, I=1)
params <- c(b=.5, c=.01, beta0=5e-3, v=.05, rho=.3, treatment=TRUE,
s=as.numeric(seq(from=0, to=1, by=.01)),
treat_date=as.numeric(seq(from=0, to=355, length.out=101)))
t <- 0:1
library("deSolve")
lsoda(y=initials, times=t, parms=params, func=seasonal_SI)
I would like for it to run and return a graph.
I agree with the former comment, that you may consider to use a parameter list. However, you may also consider to use a forcing function or the event mechanism.
You find help pages in deSolve:
?forcings
?events
and a short tutorial here: https://tpetzoldt.github.io/deSolve-forcing/deSolve-forcing.html
Related
I want to use the “fsolve” function solution of nonlinear equations, equations and code is as follows, but I can only use “fsolve”function only to find the solution of a set of nonlinear equations, for example, I have three number in the A and B coefficient（A_coeff and B_coeff）, according to my idea is that each number after formulas to calculate a set of solution, then three, there should be three sets of solution, what can I do to achieve them
A_coeff<-c(177506.9,177639.3,178039.4)
B_coeff<-c(0.0003485474,0.0005155126,0.0004671370)
C_coeff<-5.511464
D_coeff<-23.39138
E_coeff<-5.0866e+17
F_coeff<-0.9732414
library('pracma')
Para_fun <- function(temp1) {
new <- sqrt((4*temp1-1)/3)
return(new)
}
Para_fun2<- function(temp1) {
new2 <- ceiling(temp1/C_coeff)
return(new2)
}
F_try<- function(x){
s_actual <- x[1]
K_actual <- x[2]
n_tube <- x[3]
c( A_coeff/K_actual-s_actual,
(B_coeff+F_coeff/(E_coeff/Para_fun(n_tube)^(2/3))^0.25)^-1-K_actual,
Para_fun2(s_actual)*D_coeff-n_tube)}
x0_xinitial_value<- c(20,2000,20)
X_result<- fsolve(F_try, x0_xinitial_value)
X_result$x
The easiest way to solve your problem is to solve the set of equations for each pair of A_coeff and B_coeff with a loop.
Redefine function F_try as (where I have rewritten the code to make easier to read and less confusing)
F_try<- function(x,k){
s_actual <- x[1]
K_actual <- x[2]
n_tube <- x[3]
y <- numeric(length(x))
y[1] <- A_coeff[k]/K_actual-s_actual
y[2] <- (B_coeff[k]+F_coeff/(E_coeff/Para_fun(n_tube)^(2/3))^0.25)^-1-K_actual
y[3] <- Para_fun2(s_actual)*D_coeff-n_tube
y
}
The argument k is the index of the vector of coefficient A_coeff and B_coeff.
If you try this like so
X_result <- matrix(NA,nrow=3,ncol=3)
xstart <- x0_xinitial_value
for( k in 1:3){
z <- fsolve(F_try, xstart,k=k)
X_result[k,] <- z$x
}
X_result
you will get an error message
Error in if (norm(s, "F") < tol || norm(as.matrix(ynew), "F") < tol) break :
with message
missing value where TRUE/FALSE needed
Calls: fsolve -> broyden
In addition: Warning message:
In sqrt((4 * temp1 - 1)/3) : NaNs produced
Execution halted
It is no immediately clear what is wrong and why the error occurs.
There is another package nleqslv which gives more insight into what is going wrong.
You can use it like this
library(nleqslv)
X_result <- matrix(NA,nrow=3,ncol=3)
xstart <- x0_xinitial_value
for( k in 1:3){
z <- nleqslv(xstart,F_try,k=k)
X_result[k,] <- z$x
}
X_result
Inspecting X_result shows that the third solution is most likely wrong.
Cutting a long story short it appears that for k=3 and the starting values you provided the algorithms cannot find a solution.
A solution is to make the starting value for each k equal to the solution for the previous k. Like so
X_result <- matrix(NA,nrow=3,ncol=3)
xstart <- x0_xinitial_value
for( k in 1:3){
z <- nleqslv(xstart,F_try,k=k)
X_result[k,] <- z$x
xstart <- z$x
}
X_result
resulting in
[,1] [,2] [,3]
[1,] 72.60480 2444.837 327.4793
[2,] 102.59563 1731.451 444.4362
[3,] 94.16426 1890.732 421.0448
It is advisable to check the exit code of nleqslv for each row of this matrix
to make sure that a solution was found.
I have the following optimization function, similar as this one:
R. Run optimization function in data frame:
main <- function(p1, p2, n1, n2, pE) {
# FIND MINIMUM a
func <- function(a) {
Mopt <- (p1-a*pE)/(1-a)
f_n <- (Mopt-p2)^2-Mopt*(1-Mopt)/(n1-1) - p2*(1-p2)/(n2-1)
f_d <- Mopt*(1-p2)+p2*(1-Mopt)
f_v <- f_n/f_d
}
opt <- optimize(func, seq(0, 1,by=0.01), maximum=FALSE)$minimum
}
Here, the arguments of "main" are columns from a data frame. The function returns the minimum value of "a" required to get the minimum f_v value. I would like to add some conditions to the function, or in other words, to force a certain objects to acquire values within a certain range, in order to get the minimum f_v. For instance, Mopt must follow:
0 < Mopt < 1
and (1 - a) must follow:
(1 - a) > 0.
I am not sure how to do this in the context of an optimization.
I think simply add the condition would work. Code might be like this.
func <- function(a) {
a = min(a, 1-1e-7);
Mopt <- max(min((p1-a*pE)/(1-a), 1-1e-7), 1e-7);
#here means a<1 and 0<Mopt<1. 1e-7 ensures the inequality. It can be 1e-6 or 1e-8 depends on the precision you need
f_n <- (Mopt-p2)^2-Mopt*(1-Mopt)/(n1-1) - p2*(1-p2)/(n2-1)
f_d <- Mopt*(1-p2)+p2*(1-Mopt)
f_v <- f_n/f_d
}
opt <- seq(0, 1, 1e-7)[which.min(sapply(seq(0, 1, 1e-7), func))]
Addition:
Code above would return the right $objective but may fail in searching minimum. To search minimum, the function should be.
func <- function(a) {
if ((1-a)<1e-7) return(Inf);
#Ensure the optimization is reached in the range of condition
Mopt <-(p1-a*pE)/(1-a);
if (Mopt<1e-7 || Mopt>(1-1e-7)) return(Inf);
#Ensure the optimization is reached in the range of condition
f_n <- (Mopt-p2)^2-Mopt*(1-Mopt)/(n1-1) - p2*(1-p2)/(n2-1)
f_d <- Mopt*(1-p2)+p2*(1-Mopt)
f_v <- f_n/f_d
}
opt <- seq(0, 1, 1e-7)[which.min(sapply(seq(0, 1, 1e-7), func))]
It is very time consuming but available when you do not need to repeat the computation for many times.
Environments and the like have always confused me incredibly in R. I guess therefore this is more of a reference request, since I've been surfing the site for the last hour in search of an answer to no avail.
I have a simple R function called target defined as follows
target <- function(x,scale,shape){
s <- scale
b <- shape
value <- 0.5*(sin(s*x)^b + x + 1)
return(value)
}
I then define the function AR
AR <- function(n,f,...){
variates <- NULL
for(i in 1:n){
z <- runif(1)
u <- runif(1)
if(u < f(z, scale, shape)/c){
variates[i] <- z
}else{next}
}
variates <- variates[!is.na(variates)]
return(variates)
}
in which the function target is being evaluated. Unfortunately, the call returns the following error
sample <- AR(n = 10000, f = target, shape = 8, scale = 5)
Error in fun(z, scale, shape) : object 'shape' not found
I know this has to do with the function AR not knowing where to look for the objects shape and scale, but I thought that was exactly the job of the ellipsis: allowing me to sort of put argument definition "on hold" until one actually calls the function. Where am I wrong and could anyone give me a lead as to where to look for insight on this specific problem?
You are very close, you just need to make use of your ellipses...
NB: c was not defined in AR so I added it and gave it a value.
NB2: I would refrain from using c and sample in your function as these themselves are functions and could cause some confusion downt he road.
AR <- function(n, f, c, ...){
variates <- NULL
for(i in 1:n){
z <- runif(1)
u <- runif(1)
if(u < f(z, ...)/c){ ##instead of using shape and scale use the ellipses and R will insert any parameters here which were not defined in the function
variates[i] <- z
}else{next}
}
variates <- variates[!is.na(variates)]
return(variates)
}
sample <- AR(n = 10000, f = target, shape = 8, scale = 5, c = 100)
I'm new to R, and I'm trying to code a function which requires it only chooses values in a certain interval, so I have decided to go with k=1 if it lies in [lower, upper] and 0 if it lies elsewhere (where lower and upper have been defined earlier in the function. However, when I try to assign values to the function, it always comes back with this
myfun(10,0.5,0.05)
#Error in k[i] <- function(p) ifelse(p >= lower & p <= upper, 1, 0) :
# incompatible types (from closure to double) in subassignment type fix
I don't really know what this means, I've tried finding an answer, but most pages just say how to fix their particular problem rather than saying what it actually means. Maybe I haven't been looking hard enough, and I apologise if I haven't, but any help would be greatly appreciated. Here is the full function, if it would help:
myfun <- function(a, q, m) {
k <- rep(0,a+1)
bin.prob <- rep(0,a+1)
for (i in 1:(a+1)) {
x <- i-1
qhat <- x/a
z <- qnorm(1-m/2)
upper <- qhat+(z*sqrt(qhat*(1-qhat)*(a^-1)))
lower <- qhat-(z*sqrt(qhat*(1-qhat)*(a^-1)))
k[i] <- function(q) ifelse(q>=lower & q<=upper, 1, 0)
bin.prob[i] <- dbinom(x,a,q)
}
C <- sum(k*bin.prob)
return(C)
}
myfun(10,0.5,0.05)
#Error in k[i] <- function(q) ifelse(q >= lower & q <= upper, 1, 0) :
# incompatible types (from closure to double) in subassignment type fix
NEW PROBLEM
Hey, I'm encountering a new problem when trying to adjust this function when trying to adjust the data set, i.e a becomes a+4 and x becomes x+2
> myfun2 <- function(a,q,m) {
+ fn <- function(a) a+4
+ abar <- fn(a)
+ kadj <- rep(0,abar+1)
+ bin.prob.adj <- rep(0,abar+1)
+ for (j in 1:(abar+1)) {
+ x <- j-1
+ fx <- function(x) x+2
+ xbar <- fx(x)
+ qhatadj <- xbar/abar
+ z <- (1-(m/2))
+ upperadj <- qhatadj+(z*sqrt(qhatadj*(1-qhatadj)*(abar^-1)))
+ loweradj <- qhatadj-(z*sqrt(qhatadj*(1-qhatadj)*(abar^-1)))
+ kadj[j] <- q>=loweradj & q<=upperadj
+ bin.prob.adj[j] <- dbinom(xbar,abar,q)
+ }
+ D <- sum(kadj*bin.prob.adj)
+ return(D)
+ }
> myfun2(10,0.5,0.05)
[1] NA
Warning messages:
1: In sqrt(qhatadj * (1 - qhatadj) * (abar^-1)) : NaNs produced
2: In sqrt(qhatadj * (1 - qhatadj) * (abar^-1)) : NaNs produced
3: In sqrt(qhatadj * (1 - qhatadj) * (abar^-1)) : NaNs produced
4: In sqrt(qhatadj * (1 - qhatadj) * (abar^-1)) : NaNs produced
I've been trying to find an answer as to why this has arised, and have found that the NaNs warning could mean there is a negative square root? However I can't see why that would have arisen. It may be bad coding on my part, or could be something else entirely (I'm new to R). Thanks for any help.
As the error message suggests, the problem starts at the line:
k[i] <- function(q) ifelse(q >= lower & q <= upper, 1, 0)
In the line above you are assigning a function function(q) ifelse(q >= lower & q <= upper, 1, 0) to each element of the vector k, when you really want to be assigning the result of evaluating this function on the scalar q given as an argument to the original function. Note also that the closure function(q) has an environment separate from that of the function in which it is defined. It must be explicitly called with an argument in order for it to evaluate. Hence, when you hit the line:
C <- sum(k * bin.prob)
R tries to multiply the function function(q) itself by bin.prob, throwing an error, when what you want to be doing is multiplying the result of evaluating function(q) for the scalar q defined in the arguments to the original function. In this case, there appears to be no need for you to define function(q) at all. The assignment can be replaced with:
k[i] <- ifelse(q >= lower & q <= upper, 1, 0)
Since R coerces logical vectors to numeric vectors where necessary, treating TRUE as 1 and FALSE as 0, the above assigment can be expressed more succinctly as:
k[i] <- q >= lower & q <= upper
I am trying to run a VaR model on my time series for different alpha values and always come up with the error Error in[<-(tmp, i + seq[1], j, value = 0.09265792) : subscript out of bounds when i try to get my results in a matrix form with different p values. If i solely run the model with one for and a fixed value for p i receive correct results. Why do i get this error, i have not found a solution on this topic in the many threads read! I simulated my time series in order to be reproducible! Thanks
#HS VaR function
VaRhistorical <- function(returns, prob=.05) {
ans <- -quantile(returns, prob)
signif(ans, digits=7)
}
#Parameter specification
ret <- runif(5000,-0.1,0.1)
p <- c(0.05, 0.025)#, 0.01, 0.005, 0.001)
vseq <- -499:0 #VaR estimated from past 500 ret values change to -1999 for window of 2000 observations
#HS VaR Estimation with specified parameters
estperiod <- length(vseq)
VaRhs <- matrix(nrow=length(estperiod:(length(ret)-1)),ncol=length(p),byrow=T)
for (i in estperiod:(length(ret)-1)) {
seq <- vseq + i
for (j in p) {
VaRhs[i+vseq[1],j] <- VaRhistorical(ret[seq],prob=j)
}
}
act <- ret[(length(vseq)+1):length(ret)]
violationratio <- ifelse(act>=(-VaRhs),0,1)
sum(violationratio)
I changed the code as follows:
I removed seq, and vseq as they were not needed. I redefined estperiod to just be the length of the window. The innner loop (the one with j) was removed and replaced with a sapply that calculates the values for all of your p's at once and puts then in the proper row. You should check the math to make sure I have the right part of ret going into the VaRhistorical function for each prediction.
#HS VaR function
VaRhistorical <- function(returns, prob=.05) {
ans <- -quantile(returns, prob)
signif(ans, digits=7)
}
#Parameter specification
ret <- runif(5000,-0.1,0.1)
p <- c(0.05, 0.025)#, 0.01, 0.005, 0.001)
estperiod<-500 #now its the length of the window
VaRhs <- matrix(nrow=length(ret)-estperiod, ncol=length(p))
for (i in 1:nrow(VaRhs) ) {
VaRhs[i,]<- sapply(X=p, FUN=VaRhistorical,returns=ret[i:(estperiod+i-1)] )
}
act <- ret[(estperiod+1):length(ret)]
violationratio <- ifelse(act>=(-VaRhs),0,1)
sum(violationratio)