Related
I am attempting to replace a specific value in my list of matrices with each sequential value in a vector called one.to.two.s. This vector comprises a sequence of numbers running from 0.4 to 0.89 with steps of 0.01. From the code below, I would like to replace the value 2 in all matrices in the list by each consecutive value of one.to.two.s: the value 2 in the first matrix is replaced by the first value of one.to.two.s, the value 2 in the second matrix is replaced by the second value of one.to.two.s and so forth.
As an extension, I would like to be able repeat the one.to.two.s sequence if the vector had say length 50 and the list was say length 100. Below, I have a for loop which doesn't work, but I believe this could be handled with lapply somehow.
A <- lapply(1:50, function(x) # construct list of matrices
matrix(c(0, 0, 0, 0,
2, 0, 0, 0,
0, 0, 0, 0,
0, 0, 0, 1), nrow = 4,ncol=4, byrow = TRUE))
Anew <-A
one.to.two.s <- c(seq(from = 0.40, to = 0.89,by=0.01))
for(t in 1:length(Anew)) {
Anew[[t]][2,1] <- one.to.two.s
}
Using an example one.to.two.s which is shorter than length(A), you could use rep with length.out to make it the correct length, and then Map over that vector and A to create Anew
one.to.two.s <- seq(from = 0.4, to = 0.8, by = 0.01)
Anew <- Map(function(A, x) {
A[2, 1] <- x
A
}, A, rep(one.to.two.s, length.out = length(A)))
Created on 2022-01-27 by the reprex package (v2.0.1)
You can try the following for loop if you have longer list than the vector
for(t in 1:length(Anew)) {
Anew[[t]][2,1] <- one.to.two.s[(t-1)%%length(one.to.two.s)+1]
}
I forgot to add [t] to the end of my replacement as well. Also can repeat a vector ahead of time.
for(t in 1:length(Anew)) {
Anew[[t]][2,1] <- one.to.two.s
}
instead becomes
for(t in 1:length(Anew)) {
Anew[[t]][2,1] <- one.to.two.s[t]
}
I believe this is what you are looking for. In this example, the list consists of 105 matrices.
# use replicate() instead of lapply()
B <- 50L
A <- replicate(B*2.1,
matrix(c(0, 0, 0, 0,
2, 0, 0, 0,
0, 0, 0, 0,
0, 0, 0, 1), nrow = 4,ncol=4, byrow = TRUE),
simplify = FALSE)
Anew <- A
one.to.two.s <- seq(from = 0.40, to = 0.89, by = 0.01)
# loop over all elements in Anew
for (t in seq_along(Anew)) {
Anew[[t]][2,1] <- one.to.two.s[
seq_len(length(Anew) + 2L) %% (length(one.to.two.s) + 1L)
][t]
}
# > head(sapply(Anew, '[', 2))
# [1] 0.40 0.41 0.42 0.43 0.44 0.45
# > tail(sapply(Anew, '[', 2))
# [1] 0.89 0.40 0.41 0.42 0.43 0.44
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 am trying to get a data frame from the output of approx(t,y, n=120) below. My intent is for the input values returned to be in increments of 0.25; for instance, 0, 0.25, 0.5, 0.75, ... so I've set n = 120.
However, the data frame I get doesn't return those input values.
t <- c(0, 0.5, 2, 5, 10, 30)
z <- c(1, 0.9869, .9478, 0.8668, .7438, .3945)
data.frame(approx(t, z, n = 120))
I appreciate any assistance in this matter.
There are 121, not 120, points from 0 to 30 inclusive in steps of 0.25
length(seq(0, 30, 0.25))
## [1] 121
so use this:
approx(t, z, n = 121)
Another approach is:
approx(t, z, xout = seq(min(t), max(t), 0.25))
I am trying to write the function in R, but keep getting an error. Within 1 simulation run I generate random values from 2 intevals - in order to generate 2 different output values.
se.m if the input parameter lies within [0, 1]
se.st if the input parameter lies wiothin [1, 5]
(floating point in neglegible)
Then, these randomly generated values are used as input in the following function:
This is the code I have used:
fuchs08 <- function(n){
x.m=se.m=x.st=se.st=NULL
for(i in 1:n){
se.m[i] <- ifelse (runif(n = 1, min = 0, max = 1) < 0.33, 0, 0.12 * (x.m[i]^2) - 0.04 * x.m[i])
se.st[i] <- ifelse (runif(n = 1, min = 1, max = 5) < 3.06, 0.12 * (x.m[i]^2) - 0.04 * x.m[i], 1)
}
return(cbind(se.m, se.st))
}
I dont get any results. I believe the error is in the ifelse statement, but cannot find a solution to it.
> fuchs08(5)
se.m se.st
[1,] 0 NA
[2,] NA 1
[3,] NA 1
[4,] NA NA
[5,] 0 1
The overall idea is add this function to a list of functions called funktionen. Then I run a simulation 100 times. Simulation 1 randomly chooses a function from the list funktionen and executes it. (Function creates two outputs for the aforementioned intevals: se.m and se.st which are combined with the outputs from simulation 2:99) Therefore the function needs to be in the format: function(n) in order to run the random function selection. Here is my code for that part:
funktionen <- list(akbas, bell.glade, borter, fell.hartford, fuchs07, fuchs08)
fxn_list_sample <- sample(1:5, 100, replace=T)
fxn_list_result <- unlist(sapply(fxn_list_sample, function(x) do.call(funktionen[[x]], args=list(n=1))))
results <- as.data.frame(t(fxn_list_result))
colnames(results) <- c("se.m", "se.st")
results <- melt(results)
results$value <-round(results$value, 4)
separate(results, variable, into = c("Parameter", "Intensitaet")) %>%
mutate(Intensitaet = c(3, 2) [(Intensitaet == "m")+1])
Any suggestions how to fix this?
To answer your trouble with ifelse():
ifelse() needs three arguments to make sense (condition, yes, no). it works with only the condition if the condition evaluates to NA, hence the NA's in your results and works with two arguments if the condition evalutates to TRUE, hence the 1 in your resutls. As Konrad says in the comment, the use of ifelse seems redundant. For illustration:
> ifelse(1==1)
Error in ifelse(1 == 1) : argument "yes" is missing, with no default
> ifelse(NA)
[1] NA
> ifelse(1==1, 4)
[1] 4
> ifelse(1!=1, 4)
Error in ifelse(1 != 1, 4) : argument "no" is missing, with no default
> ifelse(1!=1, 4, 10)
[1] 10
Regarding your original problem, I am not sure if I understand you question correctly, but maybe this does what you want:
fuchs08 <- function(x){
ifelse(x<1/3, 0,
ifelse(x<=3.06, 0.12*x^2-0.04*x, 1))
}
fuchs08_with_n_inputs_two_outputcols <- function(n) {
df <- data.frame(input=runif(n, 0, 5))
df$se.m <- ifelse(df$input<1, fuchs08(df$input), NA)
df$se.st <- ifelse(df$input>1 & df$input<5, fuchs08(df$input), NA)
return(df)
}
fuchs08_with_n_inputs_two_outputcols(10)
Edit: replaced n by x to avoid confusion and added a second function after having read your answer (the name is long for the sake of clarity...). It is not the output in your answer but may easily be transformed to that. I think it would be helpfull to give an example of the output you want and which format it should have (data.frame, named vector...?)
I think ifelse & if-and-else are both awkward. You could try something like:
fuchs08<-function(n,min,max) {
x<-runif(n,min,max)
y<-x
y[x<1/3]<-0
y[x>=1/3 & x<=3.06]<-0.12*y[x>=1/3 & x<=3.06]^2-0.04*y[x>=1/3 & x<=3.06]
y[x>3.06]<-1
return(y)
}
(want<-cbind(fuchs08(100,0,1),fuchs08(100,1,5)))
This seems to work. However, not very elegant answer. Feel free to give me tipps to improve it, reduce rebundant elements, etc.
fuchs08 <- function(n) {
x.m=se.m=x.st=se.st=NULL
for(i in 1:n){
print(x.m[i] <- runif(n = 1, min = 0, max = 1))
se.m[i] <- ifelse (runif(n = 1, min = 0, max = 1) < 0.33, 0, 0.12 * x.m[i]^2 - 0.04* x.m[i])
print(x.st[i] <- runif(n = 1, min = 1, max = 5))
se.st[i] <- ifelse (runif(n = 1, min = 1, max = 5) < 3.06, 0.12 * x.st[i]^2 - 0.04* x.st[i], 1)
}
return(cbind(se.m, se.st))
}
fuchs08(10)
The whole code is:
library(reshape2)
library(stringr)
install.packages("dplyr")
install.packages("tidyr")
library(dplyr)
library(tidyr)
install.packages("data.table")
library(data.table)
# AKBAS u.a. (2009)
akbas <- function(n){
x.m=se.m=x.st=se.st=NULL
for(i in 1:n){
print(x.m[i] <- runif(n = 1, min = 0, max = 1))
se.m[i] <- 0.17 * (x.m[i]^2) - 0.03 * x.m[i]
print(x.st[i] <- runif(n = 1, min = 1, max = 5))
se.st[i] <- 0.17 * (x.st[i]^2) - 0.03 * x.st[i]
}
akbasr<-return(cbind(se.m, se.st))
}
# FUCHS u.a.(2007)
fuchs07 <- function(n){
x.m=se.m=x.st=se.st=NULL #solves indexing problem
for(i in 1:n){
print(x.m[i] <- runif(n = 1, min = 0, max = 1))
se.m[i] <- 0.11 * (x.m[i]^2) - 0.02 * x.m[i]
print(x.st[i] <- runif(n = 1, min = 1, max = 5))
se.st[i] <- 0.11 * (x.st[i]^2) - 0.02 * x.st[i]
}
return(cbind(se.m, se.st))
}
# BELL AND GLADE (2004)
bell.glade <- function(n){
x.m=se.m=x.st=se.st=NULL
for(i in 1:n){
se.m[i] <- ifelse (runif(n = 1, min = 0, max = 1) < 1, 0.2, 0.2)
se.st[i] <- ifelse (runif(n = 1, min = 0, max = 1) < 1, 0.5, 0.5)
}
return(cbind(se.m, se.st))
}
# BORTER (1999b,a)
borter <- function(n){
x.m=se.m=x.st=se.st=NULL
for(i in 1:n){
se.m[i] <- ifelse (runif(n = 1, min = 0, max = 1) < 1, 0.1, 0.1)
se.st[i] <- ifelse (runif(n = 1, min = 0, max = 1) < 1, 0.5, 0.5)
}
return(cbind(se.m, se.st))
}
# FELL UND HARTFORD (1997)
fell.hartford <- function(n){
x.m=se.m=x.st=se.st=NULL
for(i in 1:n){
se.m[i] <- ifelse (runif(n = 1, min = 0, max = 1) < 0.25, 0.1, 0.4)
se.st[i] <- ifelse (runif(n = 1, min = 1, max = 5) < 1.5, 0.4, 0.7)
}
return(cbind(se.m, se.st))
}
# FUCH (2008, 2009)
fuchs08 <- function(n) {
x.m=se.m=x.st=se.st=NULL
for(i in 1:n){
print(x.m[i] <- runif(n = 1, min = 0, max = 1))
se.m[i] <- ifelse (runif(n = 1, min = 0, max = 1) < 0.33, 0, 0.12 * x.m[i]^2 - 0.04* x.m[i])
print(x.st[i] <- runif(n = 1, min = 1, max = 5))
se.st[i] <- ifelse (runif(n = 1, min = 1, max = 5) < 3.06, 0.12 * x.st[i]^2 - 0.04* x.st[i], 1)
}
return(cbind(se.m, se.st))
}
funktionen <- list(akbas, bell.glade, borter, fell.hartford, fuchs07, fuchs08)
fxn_list_sample <- sample(1:5, 100, replace=T)
fxn_list_result <- unlist(sapply(fxn_list_sample, function(x) do.call(funktionen[[x]], args=list(n=1))))
results <- as.data.frame(t(fxn_list_result))
colnames(results) <- c("se.m", "se.st")
results <- melt(results)
results$value <-round(results$value, 4)
separate(results, variable, into = c("Parameter", "Intensitaet")) %>%
mutate(Intensitaet = c(3, 2) [(Intensitaet == "m")+1])
write.csv(results, "murgang-test.csv")
Here is my data:
>my.cut <- cut(my.variable, breaks = c(-Inf, -0.5, -0.25, -0.1, 0, 0.02, 0.05, 0.15, 0.3, 0.5, 1, Inf), right = FALSE)
>levels(my.cut)
"[-Inf,-0.5)" "[-0.5,-0.25)" "[-0.25,-0.1)" "[-0.1,0)" "[0,0.02)" "[0.02,0.05)" "[0.05,0.15)" "[0.15,0.3)" "[0.3,0.5)" "[0.5,1)" "[1, Inf)"
Expected result:
>levels(my.cut)
"[-Inf,-0.5)" "[-0.5,-0.25)" "[-0.25,-0.1)" "[-0.1,0)" "0" "(0,0.02)" "[0.02,0.05)" "[0.05,0.15)" "[0.15,0.3)" "[0.3,0.5)" "[0.5,1)" "[1, Inf)"
In the expected result, there is single figure 0 which I only want to choose the my.variable==0, but with the formula of the my.cut, there is no single 0 cause breaks can only be used for interval. So how could I do?
Hope to get your answer soon! Thanks!
You could explicitly put each value into a group. This is more flexible, but also a lot more verbose.
One way of doing this could be to define a bespoke cut function and then apply it to every element of your vector.
my.variable <- rnorm(100)
bespoke_cut <- function(value){
if (value < 0.1) return('[-Inf, 0.1)')
if (value < 0) return('[0.1, 0)')
if (value == 0) return('0')
return('(0, Inf]')
}
my.cut <- sapply(my.variable, bespoke_cut)
my.cut <- factor(my.cut)
I've only done a few of the groupings you wanted, but I think it should be apparent how to add extra groups.
I think the best you can hope for with 'cut' is to specify a really small range for 0, i.e.,
cps = c(-Inf, -0.1, 0-.Machine$double.eps, 0+.Machine$double.eps, 0.02, Inf)
bgroup = cut(c(-10, 10, 0,0), breaks = cps)
cat(deparse(levels(bgroup)), "\n") ## use this to edit the levels more easily
levels(bgroup) = c("(-Inf, -0.1]", "(-0.1,0)", "0", "(0,0.02]", "(0.02, Inf]")
table(bgroup)
Obviously, the display levels are not identical to those used to cut the data, but if you are okay with that window around 0, then the solution is to form the cuts with that value then change the labels.
You could do this : cut, assign 0 where my.variable == 0, refactor.
my.variable <- rnorm(100)
my.variable[sample(1:100,2)] <- 0
my.cut <- cut(my.variable, breaks = c(-Inf, -0.5, -0.25, -0.1, 0, 0.02, 0.05, 0.15, 0.3, 0.5, 1, Inf), right = FALSE)
lvl <- levels(my.cut)
lvlR <- c(lvl[1:4],"0","(0,0.02)",lvl[6:11])
my.cut <- as.character(my.cut)
my.cut[my.variable == 0] <- 0
my.cut <- factor(my.cut,levels=lvlR)
rm(lvl,lvlR)