Related
I am trying to estimate a state-space model to obtain the potential output (y_p) from data on output (y) and the unemployment rate (u) using R. The model is already programmed in EViews and I simply want to reproduce its results. The model is described by the following eqations (with time indizes):
signal equations:
(i) y_t = y_p_t + eps_y_t
(ii) u_t = beta_0 + beta_1(y_t-y_p_t) + eps_u_t
state equations:
(iii) y_p_t = y_p_(t-1) + g_(t-1)
(iv) g_t = g_(t-1) + eps_g_t
I have tried different packages. But there are different problems: Either there are no intercepts allowed (dlm package) or there is no smoother function (FKF package). So I do have two questions, either of them answered would solve my problem. The first (Questions 1a and 1b) relates to the specification of an appropriate state-space model in the dlm-package; the second (Question 2) relates to a smoothing function that could be used with the FKF package.
Question 1a. In the dlm-package no intercepts are allowed. So I put beta_0 and the output gap (gap_t = y_t-y_p_t) into the state vector using the JGG-matrix to reference to the y_t-data and tried to estimate beta_1 subsequently via maximum likelihood. However, I didn't obtain reasonable results.
# States: x(1) y_pot, x(2) growth, x(3) y_gap, x(4) beta_0
# Signal: y(1) y, y(2) u
beta_1 <- -0.2
beta_0 <- 0.03
# Measurement
FF <- matrix(c(1, 0, 0, 0,
0, beta_1, 0, 1), 2, 4)
# Transition
GG <- matrix(c(1, 0, -1, 0,
1, 1, -1, 0,
0, 0, 1, 0,
0, 0, 0, beta_0), 4, 4)
JGG <- matrix(c(0, 0, 0, 0,
0, 0, 0, 0,
0, 0, 1, 0,
0, 0, 0, 0), 4, 4)
# Covariance Transition
W <- diag(1e-2, 4)
# Covariance Measurement
V <- matrix(c(1e-2, 0,
0, 1e-2), 2, 2)
m0 <- c(11.4, 0.04, 0, 0.03)
C0 <- diag(1, 4) # 1e-7
C0[3,3] <- 0.1
C0[4,4] <- 0.1
# Now bring them into the dlm-object
myMod <- dlm(FF = FF,
GG = GG,
JGG = JGG,
X = dataMLE,
W = W,
V = V,
m0 = m0,
C0 = C0)
buildFun <- function(theta) {
V(myMod)[1,1] <- lambda_ss*exp(theta[1])
V(myMod)[2,2] <- exp(theta[2])
W(myMod)[2,2] <- exp(theta[1])
FF(myMod)[2,3] <- theta[3]
return(myMod)
}
myMod.mle <- dlmMLE(y = dataMLE, parm = c(-10, -10, -.2),
build = buildFun,
lower = c(rep(-1e6, 3)),
upper = c(rep(1e6, 3)),
control = list(trace = 1, REPORT = 5, maxit = 1000))
Question 1b. I've also tried to use the state vector x(1) y_pot, x(2) growth, x(3) beta_1, x(4) beta_0, and to use JFF to get the y_t-data for the output-gap-calculation... but this approach was not sucessfull either.
Question 1: Do you know of a way in which this rather simple model could be implemented within the dlm-package? The problems are the incercepts on the one hand and on the other the interaction of the beta_1-estimation with the ouput-gap, which consists itself of one state-variable and one external signal.
A more promising approach seemed to be to use the FKF-package. However, no smoother function is provided within this package.
Question 2: Is there a way to obtain the smoothed output instead of the Kalman-filtered output usind the FKF-package?
I deepely appreciate any help on this problem!
Thank you a lot!
Samuel
I want to minimize function
f <- function(u){
return(-(1+u[1]+u[2]+u[3]+u[4]))
}
with gradient grad
And I have constraints:
1) u[1]+u[2]+u[3]+u[4] = 1
2) 0<=u[1]<=1, 0<=u[2]<=1, 0<=u[3]<=1, 0<=u[4]<=1
How to make it correctly? I can make it only for 2 constraint
optim(par=c(0,0,0,0), fn=f,lower=c(0, 0, 0, 0), upper=c(1, 1, 1, 1),method="L-BFGS-B")
But 1 constraint is not true in this case
Maybe you can try fmincon from package pracma like below
pracma::fmincon(c(0,0,0,0),
f,
gr = grad,
Aeq = cbind(1,1,1,1),
beq = 1,
lb = c(0,0,0,0),
ub = c(1,1,1,1))
I'm using the nloptr package and everything works well. But I need a way to define the objective function and the constraints in a faster way. I can't write all the settings by hand each time.
For example, I want to solve this problem:
library(nloptr)
eval_f <- function(x){
return(x[4]^2+x[7]^2+x[9]^2)
}
x0 = c(1,1,1,1,0.5,0,0.5,1,0)
hin <- function(x){
h <- numeric(6)
h[1] = x[1]+x[4]-x[2]-x[5]-0.01
h[2] = x[1]+x[4]-x[3]-x[6]-0.01
h[3] = x[2]+x[5]-x[3]-x[6]-0.01
h[4] = x[2]+x[8]-x[1]-x[7]-0.01
h[5] = x[2]+x[8]-x[3]-x[9]-0.01
h[6] = x[1]+x[7]-x[3]-x[9]-0.01
return(h)
}
heq <- function(x){
h <- numeric(1)
h[1] <- x[1]+x[2]+x[3]-3
return(h)
}
res <- slsqp(x0=x0,fn=eval_f,hin = hin,heq = heq)
Everything works.
But I want to define the objective function in a faster way. Can I pass another argument (the indices) to the function in an automatic way? For example:
eval_f <- function(x,indices){
return(x[indices]^2)
}
I tried but I have an error.
The ... argument to slsqp allows you to pass arbitrary arguments through to the objective function. So define a new objective function that takes indices as an argument:
eval_f2 <- function(x,indices){
return(sum(x[indices]^2))
}
... and include indices=c(4,7,9) (to match your previous objective function's definition):
res2 <- slsqp(x0=x0,fn=eval_f2, hin = hin,heq = heq, indices=c(4,7,9))
Check the solution:
all.equal(res$par,res2$par) ## TRUE
factories
More generally, you can define a factory - a function that returns a function. This works because functions have associated environments in which variables (such as the indices) can be stored. This will work even in cases where the top-level function doesn't allow arbitrary arguments to be passed through (and may e.g. be important if you want to use different sets of indices for your objective and constraint functions ...)
eval_factory <- function(indices) {
fun <- function(x) {
return(sum(x[indices]^2))
}
return(fun)
}
res3 <- slsqp(x0=x0, fn=eval_factory(indices=c(4,7,9)),
hin = hin,heq = heq)
all.equal(res$par,res3$par) ## TRUE
factory for hin
hin_factory <- function(A,b) {
fun <- function(x) {
return((A %*% x) + b)
}
return(fun)
}
A0 <- matrix(c(1, -1, 0, 1,-1, 0, 0, 0, 0,
1, 0, -1, 1, 0, -1, 0, 0, 0,
0, 1, -1, 0, 1, -1, 0, 0, 0,
-1, 1, 0, 0, 0, 0,-1, 1, 0,
0, 1, -1, 0, 0, 0, 0, 1, -1,
1, 0, -1, 0, 0, 0, 1, 0, -1),
byrow=TRUE,ncol=9)
all.equal(c(hin_factory(A0,-0.01)(x0)),hin(x0))
res4 <- slsqp(x0=x0, fn=eval_factory(indices=c(4,7,9)),
hin = hin_factory(A0,b=-0.01), heq = heq)
all.equal(res$par, res4$par)
I have the code below where I have a loop above which is fed with a single value X:
n = 25
X = 1
p = 0.2 #probability
P = matrix( c(p, 1-p, 0, 0, 0, 0,
p, 0, 1-p, 0, 0, 0,
p, 0, 0, 1-p, 0, 0,
0, p, 0, 0, 1-p, 0,
0, 0, p, 0, 0, 1-p,
0, 0, 0, p, 0, 1-p),
ncol=6, nrow=6, byrow = TRUE) #transition matrix
for(i in 1:n){
Y = runif(1) #uniform sample
k = P[X[i], ] #calculate k values
k = cumsum(k)
if(Y <= k[1]){ #update the chain
X[i+1] = 1}
else if(Y <= k[2]){
X[i+1] = 2}
else if (Y <= k[3]){
X[i+1] = 3}
else if (Y<=k[4]){
X[i+1] = 4}
else if (Y<=k[5]){
X[i+1] = 5}
else {X[i+1]=6}
}
plot(1:n, X[1:i], type = 's')
I'm wondering that can I set my X be multi data like X = c(1,3,4), such that I can run all three values for X in only one line of code without having to resimulate by changing the value for X? The three graphs should be produced as a result.
First of all, you will want to put your code inside a function, if you aim to re-use that code. Secondly, in the code you posted, you plot the graph in the graphic device, which will be lost after you plot something else, so you might wanna save it as a PDF or PNG or something like that:
xtoplot <- function(X, n = 25, p = 0.2, transit = P){
for(i in 1:n){
Y <- runif(1) # uniform sample
k <- P[X[i], ] # calculate k values
k <- cumsum(k)
if(Y <= k[1]){ # update the chain
X[i+1] <- 1}
else if(Y <= k[2]){
X[i+1] <- 2}
else if(Y <= k[3]){
X[i+1] <- 3}
else if(Y <= k[4]){
X[i+1] <- 4}
else if(Y <= k[5]){
X[i+1] <- 5}
else{
X[i+1] <- 6}
}
pltname <- paste0("plot_", X, ".pdf") # The document name of the plot
pdf(pltname) # Tell R to prepare to export something to PDF
plot(1:n, X[1:i], type = 's') # The plot to be exported
dev.off()
}
Now that the function is in place, you can use a member of the "apply()-family" to run the function for multiple input values for X like this:
lapply(c(1,3,4), xtoplot)
In your working directory, you will find three PDFs called plot_1.pdf, plot_3.pdf and plot_4.pdf with the graphs you were looking for.
I want to plot a polyhedron, which is described by the following inequalities:
3*x+5*y+9*z<=500
4*x+5*z<=350
2*y+3*z<=150
x,y,z>=0
It is a linear program. The objective function is:
4*x+3*y+6*z
The polyhedron is the feasible region for this program.
I am able to plot the inequalities as planes, which should describe the polyhedron
(Note that this is my first try with rgl, so the code is kinda messy. if you want to improve it, please feel free to do so):
# setup
x <- seq(0,9,length=20)*seq(0,9,length=20)
y <- x
t <- x
f1 <- function(x,y){y=70-0.8*x}
z1 <- outer(x,y,f1)
f2 <- function(x,y){500/9-x/3-(5*y)/9}
z2 <- outer(x,y,f2)
f3 <- function(x,y){t=50-(2*y)/3}
z3 <- outer(x,y,f3)
# plot planes with rgl
uM = matrix(c(0.72428817, 0.03278469, -0.68134511, 0,
-0.6786808, 0.0555667, -0.7267077, 0,
0.01567543, 0.99948466, 0.05903265, 0,
0, 0, 0, 1),
4, 4)
library(rgl)
open3d(userMatrix = uM, windowRect = c(0, 0, 400, 400))
rgl.pop("lights")
light3d(diffuse='white',theta=0,phi=20)
light3d(diffuse="gray10", specular="gray25")
rgl.light(theta = 0, phi = 0, viewpoint.rel = TRUE, ambient = "#FFFFFF",
diffuse = "#FFFFFF", specular = "#FFFFFF", x=30, y=30, z=40)
rgl.light(theta = 0, phi = 0, viewpoint.rel = TRUE, ambient = "#FFFFFF",
diffuse = "#FFFFFF", specular = "#FFFFFF", x=0, y=0, z=0)
bg3d("white")
material3d(col="white")
persp3d(x,y,z3,
xlim=c(0,100), ylim=c(0,100), zlim=c(0,100),
xlab='x', ylab='y', zlab='z',
col='lightblue',
ltheta=100, shade=0, ticktype = "simple")
surface3d(x, y, z2, col='orange', alpha=1)
surface3d(t, y, z1, col='pink', alpha=1, smooth=TRUE)
Now I want to plot the region that is described by the planes with
x,y,z>=0.
But I don't know how to do it. I tried to do it like this:
x <- seq(0,9,length=20)*seq(0,9,length=20)
y <- x
z <- x
f4 <- function(x,y,t){
cond1 <- 3*x+5*y+9*z<=500
cond2 <- 4*x+5*z<=350
cond3 <- 2*y+3*z<=150
ifelse(cond1, 3*x+5*y+9*z,
ifelse(cond2, 4*x+5*z,
ifelse(cond3, 2*y+3*z,0)))
}
f4(x,y,z)
z4 <- outer(x,y,z,f4) # ERROR
But this is the point where I'm stuck. outer() is defined only for 2 variables, but I have three. How can I move on from here?
You can compute the vertices of the polyhedron by intersecting the planes 3 at a time
(some of the intersections are outside the polyhedron, because of other inequalities:
you have to check those as well).
Once you have the vertices, you can try to connect them.
To identify which are on the boundary, you can take the middle of the segment,
and check if any inequality is satisfied as an equality.
# Write the inequalities as: planes %*% c(x,y,z,1) <= 0
planes <- matrix( c(
3, 5, 9, -500,
4, 0, 5, -350,
0, 2, 3, -150,
-1, 0, 0, 0,
0, -1, 0, 0,
0, 0, -1, 0
), nc = 4, byrow = TRUE )
# Compute the vertices
n <- nrow(planes)
vertices <- NULL
for( i in 1:n )
for( j in 1:n)
for( k in 1:n )
if( i < j && j < k ) try( {
# Intersection of the planes i, j, k
vertex <- solve(planes[c(i,j,k),-4], -planes[c(i,j,k),4] )
# Check that it is indeed in the polyhedron
if( all( planes %*% c(vertex,1) <= 1e-6 ) ) {
print(vertex)
vertices <- rbind( vertices, vertex )
}
} )
# For each pair of points, check if the segment is on the boundary, and draw it
library(rgl)
open3d()
m <- nrow(vertices)
for( i in 1:m )
for( j in 1:m )
if( i < j ) {
# Middle of the segment
p <- .5 * vertices[i,] + .5 * vertices[j,]
# Check if it is at the intersection of two planes
if( sum( abs( planes %*% c(p,1) ) < 1e-6 ) >= 2 )
segments3d(vertices[c(i,j),])
}