I am trying to implement this Euler Method procedure but I am unable to get the required graphs.
solve_logistic <- function(N0, r = 1, delta_t = 0.01, times = 1000) {
N <- rep(N0, times)
dN <- function(N) r * N * (1 - N)
for (i in seq(2, times)) {
# Euler
N[i] <- N[i-1] + delta_t * dN(N[i-1])
# Improved Euler
# k <- N[i-1] + delta_t * dN(N[i-1])
# N[i] <- N[i-1] + 1 /2 * delta_t * (dN(N[i-1]) + dN(k))
# Runge-Kutta 4th order
# k1 <- dN(N[i-1]) * delta_t
# k2 <- dN(N[i-1] + k1/2) * delta_t
# k3 <- dN(N[i-1] + k2/2) * delta_t
# k4 <- dN(N[i-1] + k3) * delta_t
#
# N[i] <- N[i-1] + 1/6 * (k1 + 2*k2 + 2*k3 + k4)
}
N
}
This is the graph I want to make:
And you can also view the original source which I am following for this graph
Your interest for epedimiological model is a good thing.
To obtain a similar graph as you show, you need to code first the analytical solution of N(t) which is given on the reference web site.
logistic <- function(N0, r, t){
return(1 / (1 + ((1-N0)/N0) * exp(- r * t)))
}
Moreover you should be careful with absisse informations.
r <- 1
t <- 1:1000
N0 <- 0.03
delta_t <- 0.01
plot(t * delta_t, logistic(N0 = N0, r = r, t = t * delta_t), type = "l",
ylim = c(0, 1),
ylab = "N(t)",
xlab = "times")
lines(t * delta_t, solve_logistic(N0 = N0, times = max(t)),
col = "red", lty = 2)
It gives you part of the graphic, now you are able to compute error of the method and test with another delta.
The Euler method is a numerical method for EDO resolution based on Taylor expansion like gradient descent algorithm
.
solve_logistic <- function(N0, r = 1, delta_t = 0.01, times = 1000) {
N <- rep(N0, times)
dN <- function(N) r * N * (1 - N)
for (i in seq(2, times)) {
# Euler (you follow the deepest slope with a small step delta)
N[i] <- N[i-1] + delta_t * dN(N[i-1])
}
N
}
Related
I am working on a paper that requires me to find the MLE of Gumbel’s type I
bivariate exponential distribution. I have proved the likelihood and log-likelihood functions likelihood and log-likelihood but I am struggling to implement it in r to perform optimization with Optim function. My code generates NA values.
Below are my codes.
# likelihood function of x
likelihood.x = function(params, data) {
lambda1 = params[1]
lambda2 = params[2]
theta = params[3]
A = (1 - theta) * (lambda1 * lambda2)
B = theta * (lambda1 ^ 2) * lambda2 * data$X1
C = theta * lambda1 * (lambda2 ^ 2) * data$X2
D = (theta ^ 2) * (lambda1 ^ 2) * (lambda2 ^ 2) * data$X1 * data$X2
E = (lambda1 * data$X1) + (lambda2 * data$X2) + (theta * lambda1 * lambda2 * data$X1 * data$X2)
f = sum(log(A + B + C + D)) - sum(E)
return(exp(f))
}
# Log-likelihood function of x
log.likelihood.x = function(params, data){
lambda1 = params[1]
lambda2 = params[2]
theta = params[3]
A = (1 - theta) * (lambda1 * lambda2)
B = theta * (lambda1 ^ 2) * lambda2 * data$X1
C = theta * lambda1 * (lambda2 ^ 2) * data$X2
D = (theta ^ 2) * (lambda1 ^ 2) * (lambda2 ^ 2) * data$X1 * data$X2
E = (lambda1 * data$X1) + (lambda2 * data$X2) + (theta * lambda1 * lambda2 * data$X1 * data$X2)
f = sum(log(A + B + C + D)) - sum(E)
return(-f)
}
Here's the function for generating the data
# Simulating data
rGBVE = function(n, lambda1, lambda2, theta) {
x1 = rexp(n, lambda1)
lambda12 = lambda1 * lambda2
pprod = lambda12 * theta
C = exp(lambda1 * x1)
A = (lambda12 - pprod + pprod * lambda1 * x1) / C
B = (pprod * lambda2 + pprod ^ 2 * x1) / C
D = lambda2 + pprod * x1
wExp = A / D
wGamma = B / D ^ 2
data.frame(x1, x2 = rgamma(n, (runif(n) > wExp / (wExp + wGamma)) + 1, D))
}
data = rGBVE(n=100, lambda1 = 1.2, lambda2 = 1.4, theta = 0.5)
colnames(data) = c("X1", "X2")
My goal is to find MLE for lambda1, lambda2 and theta using Optim() in r.
Kindly assist me to implement my likelihood and log-likelihood function in r.
Thank you.
Your concern appears to be about the warning message
In log(A+B+C+D): NaNs produced
Such warnings are usually harmless — it just means that the optimization algorithm tried a set of parameters somewhere along the way that violated the condition A+B+C+D ≥ 0. Since these are reasonably complex expressions it would take a little bit of effort to figure out how one might constrain the parameters (or reparameterize the function, e.g. fitting some of the parameters on the log scale) to avoid the warning, but taking a guess that keeping the parameters non-negative will help, we can try using the L-BFGS-B algorithm (which is the only algorithm available in optim() that allows multidimensional bounded optimization).
r1 <- optim(par = c(1,2,1),
fn = log.likelihood.x,
dat = data)
r2 <- optim(par = c(1,2,1),
fn = log.likelihood.x,
lower = rep(0,3),
method = "L-BFGS-B",
dat = data)
The second does not generate warnings, and the results are close (if not identical):
all.equal(r1$par, r2$par)
## "Mean relative difference: 0.0001451953"
You might want to use bbmle, which has some additional features for likelihood modeling:
library(bbmle)
fwrap <- function(x) log.likelihood.x(x, dat = data)
parnames(fwrap) <- c("lambda1", "lambda2", "theta")
m1 <- mle2(fwrap, start = c(lambda1 = 1, lambda2 = 2, theta = 1), vecpar = TRUE,
method = "L-BFGS-B", lower = c(0, 0, -0.5))
pp <- profile(m1)
plot(pp)
confint(pp)
confint(m1, method = "quad")
I need help generating an AR(2) model in R and I am new to the software.
I have the following AR(2) process:
y[t] = phi_1 * y[t-1] + phi_2 * y[t-2] + e[t] where e[t] ~ N(0,2)
How can I generate a series of y[t]?
Thanks for the help, much appreciated!
You could do:
set.seed(123)
n <- 200
phi_1 <- 0.9
phi_2 <- 0.7
e <- rnorm(n, 0, 2)
y <- vector("numeric", n)
y[1:2] <- c(0, 1)
for (t in 3:n) {
y[t] <- phi_1 * y[t - 1] + phi_2 * y[t - 2] + e[t]
}
plot(seq(n), y, type = "l")
I am trying to manually optimise a negative binomial regression model using the optim package in R trying to predict a count variable y using a matrix of factors X using the following code:
# generating some fake data
n <- 1000
X <- matrix(NA, ncol = 5, nrow = n)
X[,1] <- 1
X[,2] <- sample(size = n, x = c(0,1), replace = TRUE)
X[,3] <- sample(size = n, x = c(0,1), replace = TRUE)
X[,4] <- sample(size = n, x = c(0,1), replace = TRUE)
X[,5] <- sample(size = n, x = c(0,1), replace = TRUE)
beta0 <- 3
beta1 <- -2
beta2 <- -2
beta3 <- -4
beta4 <- -0.9
k <- 0.9
## draws from negative binomial distribution
mu <- exp(beta0 + beta1 * X[,2] + beta2 * X[,3] + beta3 * X[,4] + beta4 * X[,5])
theta <- mu + mu ^2 / k
# dependent variable
y <- rnegbin(n, mu = mu, theta = theta)
# function to be optimised
negbin_ll <- function(y, X, theta){
beta <- theta[1:ncol(X)]
alpha <- theta[ncol(X) + 1]
logll <- y * log(alpha) + y *( beta %*% t(X) ) - (y + (1 / alpha ) ) * log( 1 + alpha * exp(beta %*% t(X))) + lgamma(y + (1 / alpha)) - lgamma ( y + 1) - lgamma ( 1 / alpha)
logll <- sum( logll )
return(logll)
}
stval <- rep(0, ncol(X) + 1)
res <-
optim(
stval,
negbin_ll,
y = y,
X = X,
control = list(fnscale = -1),
hessian = TRUE,
method = "BFGS"
)
The code should produce point estimates from the optimisation process, but instead fails when executing the optim-function with the error in optim(stval, negbin_ll, y = y, X = X, control = list(fnscale = -1), : initial value in 'vmmin' is not finite.
I already tried to change log(gamma(...)) to lgamma(...) in the likelihood function and tried many other ways, but I fail to get estimates.
Changing the start values of optim also does not help.
Do you have any idea if there is any particularity to the likelihood function that leads to values being treated in any odd fashion?
Help would be much appreciated.
optim tries several points to get to the minimum, in your case it hits some non-positive values in the arguments inside the logs. One way is to discard the values that return any non-positive inside the problematic functions by returning a negative (in your case) large number, like -lenght(series)*10^6. Remade the log-likelihood function, like this it kinda works:
negbin_ll <- function(y, X, theta){
beta <- theta[1:ncol(X)]
alpha <- theta[ncol(X) + 1]
if(any(alpha<=0)) return(-length(y)*10^6)
if(any(1 + alpha * exp(beta %*% t(X))<=0)) return(-length(y)*10^6)
logll <- y * log(alpha) + y *( beta %*% t(X) ) - (y + (1 / alpha ) ) * log( 1 + alpha * exp(beta %*% t(X))) + lgamma(y + (1 / alpha)) - lgamma ( y + 1) - lgamma ( 1 / alpha)
logll <- sum( logll )
return(logll)
}
I'm trying to build covariance matrix from a scratch (cov() function). My task is not to use any package. Hence I created my functions:
meanf <- function(x){
sum(x) / length(x)
}
sampleCov <- function(x,y){
stopifnot(identical(length(x), length(y)))
sum((x - meanf(x)) * (y - meanf(y))) / (length(x) - 1)
}
> sampleCov(winequality_red$quality, winequality_red$alcohol)
[1] 0.409789
Unfortunately, I'm stuck here. All loops I tried to apply are missing any point. Of course it's possible to just copy the sampleCov function and make it for every possible combination but that's not my point.
If I understand you correctly then I believe you want to recreate a covariate output like the one returned by cov function.
OPs given function:
meanf <- function(x){
sum(x) / length(x)
}
sampleCov <- function(x,y){
stopifnot(identical(length(x), length(y)))
sum((x - meanf(x)) * (y - meanf(y))) / (length(x) - 1)
}
You can try this way, I have taken mtcars data here:
Covariate Function:
vars <- names(mtcars)
egrid <- expand.grid(vars, vars)
egrid <- data.frame(sapply(egrid, as.character),stringsAsFactors = F)
egrid <- egrid[order(egrid$Var1, egrid$Var2),]
mat <- vector("list", nrow(egrid))
for(i in 1:nrow(egrid)){
mat[[i]] <- sampleCov(mtcars[,egrid[i,"Var1"]], mtcars[,egrid[i,"Var2"]])
}
finaldat <- cbind(egrid, cov = do.call('rbind', mat))
finaldat_list <- split(finaldat, finaldat$Var1)
mat_form <- do.call('cbind', finaldat_list)
cov_values <- mat_form[,grepl("\\.cov",names(mat_form))]
col_values <- mat_form[,paste0(egrid$Var1[1],".Var2")]
final_matrix_cov <- cbind(col_values, cov_values)
Sample Output:
> final_matrix_cov
col_values am.cov carb.cov cyl.cov disp.cov
9 mpg 1.80393145 -5.36310484 -9.1723790 -633.09721
20 cyl -0.46572581 1.52016129 3.1895161 199.66028
31 disp -36.56401210 79.06875000 199.6602823 15360.79983
42 hp -8.32056452 83.03629032 101.9314516 6721.15867
You need the matrix multiplication %*%.
sampleCov <- function(x,y){
stopifnot(identical(length(x), length(y)))
sum((x - mean(x)) %*% (y - mean(y))) / (length(x) - 1)
}
> sampleCov(rnorm(10000),rnorm(10000))
[1] 0.01808466
This is probably a little more than you need, but it should answer your question, and I think it is a nice illustration of the practical application of covariances, correlations, etc.
# load the data
link <- "https://raw.githubusercontent.com/DavZim/Efficient_Frontier/master/data/mult_assets.csv"
df <- data.table(read.csv(link))
# calculate the necessary values:
# I) expected returns for the two assets
er_x <- mean(df$x)
er_y <- mean(df$y)
# II) risk (standard deviation) as a risk measure
sd_x <- sd(df$x)
sd_y <- sd(df$y)
# III) covariance
cov_xy <- cov(df$x, df$y)
# create 1000 portfolio weights (omegas)
x_weights <- seq(from = 0, to = 1, length.out = 1000)
# create a data.table that contains the weights for the two assets
two_assets <- data.table(wx = x_weights,
wy = 1 - x_weights)
# calculate the expected returns and standard deviations for the 1000 possible portfolios
two_assets[, ':=' (er_p = wx * er_x + wy * er_y,
sd_p = sqrt(wx^2 * sd_x^2 +
wy^2 * sd_y^2 +
2 * wx * (1 - wx) * cov_xy))]
two_assets
# lastly plot the values
ggplot() +
geom_point(data = two_assets, aes(x = sd_p, y = er_p, color = wx)) +
geom_point(data = data.table(sd = c(sd_x, sd_y), mean = c(er_x, er_y)),
aes(x = sd, y = mean), color = "red", size = 3, shape = 18) +
# Miscellaneous Formatting
theme_bw() + ggtitle("Possible Portfolios with Two Risky Assets") +
xlab("Volatility") + ylab("Expected Returns") +
scale_y_continuous(label = percent, limits = c(0, max(two_assets$er_p) * 1.2)) +
scale_x_continuous(label = percent, limits = c(0, max(two_assets$sd_p) * 1.2)) +
scale_color_continuous(name = expression(omega[x]), labels = percent)
See the link below for all details.
https://datashenanigan.wordpress.com/2016/05/24/a-gentle-introduction-to-finance-using-r-efficient-frontier-and-capm-part-1/
I'm just playing around with the image of circles under the complex map exp(z).
I couldn't find a built in R function to generate the points on a circle of given radius so I wrote one myself (integrating the equations of motion numerically):
# Integration points:
N <- 10000
e <- 0.001
dt <- seq(0, e*(N-1), by=e)
Rp = pi # radius of point circle
Rv = pi # radius of vector circle
# Initial conditions:
px <- c(Rp)
py <- c(0)
vx <- c(0)
vy <- c(Rv)
Rp <- c()
Rv <- c()
ax <- c()
ay <- c()
for (i in(2:N)) {
Rp[i-1] <- sqrt(px[i-1]^2 + py[i-1]^2)
Rv[i-1] <- sqrt(vx[i-1]^2 + vy[i-1]^2)
ax[i-1] <- -(Rv[i-1]^2/Rp[i-1]^2)*px[i-1] # acceleration toowards
ay[i-1] <- -(Rv[i-1]^2/Rp[i-1]^2)*py[i-1] # center of circle
px[i] <- px[i-1] + e*vx[i-1] # dp_x = epsilon * v_x
py[i] <- py[i-1] + e*vy[i-1] # dp_y = epsilon * v_y
vx[i] <- vx[i-1] + e*ax[i-1] # dv_x = epsilon * a_x
vy[i] <- vy[i-1] + e*ay[i-1] # dv_y = epslon * a_y
}
complex(real=px,imaginary=py)
This seems like a lot of work just to get a circle, and the program is slow. Is there a built in R function to do this for me?
par(mfrow=c(1,2))
plot(cbind(px,py))
plot(exp(zs))
Thanks!
Parameterize on angle:
circle_xy = function(n, r, close_loop = FALSE) {
theta = seq(0, 2 * pi, length.out = n + 1)
if(!close_loop) theta = theta[-(n + 1)]
cbind(x = r * cos(theta), y = r * sin(theta))
}
Gives x-y coords for n evenly spaced points on a circle of radius r. If close_loop = TRUE, the first point is repeated at the end. Takes about 0.2 seconds to generate 1MM points on my laptop.
And there is plot.formula function that would take that to an instantiation:
plot( y ~ x, data = xy<- circle_xy(100,1), type="l")