I tried to estimate State-space models with latent variables in r, but I failed.
I tried to do it in rstan package.
Does someone know how to do it better?
Let's say we have two observable variables: gdp and inflation.
We also know there are three unobservable variables: potential grow, potential gdp, output gap.
We want to estimate unobservable variables and two coefficient (a1 and a2).
Our model:
State Equations:
grow[t] = grow[t-1] + e
potential[t] = potential[t-1] + grow[t] + e
gap[t] = a1*gap[t-1] + e
Measurement Equations:
gdp[t] = potential[t] + gap[t]
inflation[t] = inflation[t-1] + a2*gap[t] + e
Here I generated data:
a1 <- 0.7
a2 <- 0.3
grow <- c()
potential <- c()
gap <- c()
gdp <- c()
inflation <- c()
grow[1] <- 2
potential[1] <- 10
gap[1] <- 0
gdp[1] <- potential[1] + gap[1]/100
inflation[1] <- 2
for (i in 2:100) {
grow[i] <- grow[i-1] + rnorm(1, 0, 0.1)
potential[i] <- potential[i-1] + grow[i]/100 + rnorm(1, 0, 0.1)
gap[i] <- a1*gap[i-1] + rnorm(1,0,0.1)
gdp[i] <- potential[i] + gap[i]/100
inflation[i] <- inflation[i-1] + a2*gap[i] + rnorm(1,0,0.1)
}
And here is my rstan code:
data {
int T; // number of obs
int P; //number of variables
matrix[T,P] Y; //dataset of generated series
}
parameters {
#Coefficients
vector[1] alfa1; //ar gap
vector[1] alfa2; //phillips curve
#State Variables (unobserved economic variables)
vector[T] gap; // output gap
vector[T] potential; // potential output
vector[T] grow; // growth of potential output
#Innovations
real<lower = 0> sigma_pot; // The scale of innovations to potential output
real<lower = 0> sigma_grow; // The scale of innovations to growth in potential output
real<lower = 0> sigma_gap; // The scale of innovations to output gap
real<lower = 0> sigma_inf; // The scale of innovations to phillips curve
}
model {
// priors
//Innovations
sigma_pot ~ cauchy(0.2,3);
sigma_grow ~ cauchy(0.3,3);
sigma_gap ~ cauchy(0.9,5);
sigma_inf ~ cauchy(2,5);
//coefficients
alfa1 ~ normal(0,1);
alfa2 ~ normal(0,1);
//Initialize State Equations
potential[1] ~ normal(0,1);
grow[1] ~ normal(0,1);
gap[1] ~ normal(0,1);
// State Equations
for(t in 2:T) {
grow[t] ~ normal(grow[t-1], sigma_grow);
potential[t] ~ normal(potential[t-1] + grow[t], sigma_pot);
gap[t] ~ normal( alfa1*gap[t-1], sigma_gap);
}
// Measurement Equations
for(t in 1:T) {
Y[t,1] = potential[t] + gap[t];
Y[t,2] ~ normal(Y[t-1,2] + alfa1*gap[t],sigma_inf);
}
}
Here I tried model
mvf_model <- stan(file = "newstan.stan" ,
data = list(T = nrow(data),
P = ncol(data),
Y = data),
chains = 4)
And here is the error I've got
Cannot assign to variable outside of declaration block; left-hand-side variable origin=data
Illegal statement beginning with non-void expression parsed as
Y[[t, 1]]
Not a legal assignment, sampling, or function statement. Note that
* Assignment statements only allow variables (with optional indexes) on the left;
* Sampling statements allow arbitrary value-denoting expressions on the left.
* Functions used as statements must be declared to have void returns
error in 'model16a4a72378d_newstan' at line 27, column 3
-------------------------------------------------
25: transformed parameters {
26: for(t in 1:T) {
27: Y[t,1] = potential[t] + gap[t];
^
28: }
-------------------------------------------------
PARSER EXPECTED: "}"
Error in stanc(file = file, model_code = model_code, model_name = model_name, :
failed to parse Stan model 'newstan' due to the above error.
Related
I simulated data in SAS where I have 861 poplar trees. These trees are correlated with correlation matrix K. The varcov is assumed known and equal to sigmaGK +sigmaEI. sigmaG is set at 3.5 and sigmaE at 2.5. There is 1 predictor beta set at 2.5, and an intercept set at 1. the sascode is as follows:
proc iml;
use work.dataK; /* open the data set */
read all var _ALL_ into K;
close work.dataK;
use work.snps; /* open the data set */
read all var _ALL_ into GT;
close work.snps;
snp2 = GT[,2];
n=861;
sigma2_g = 3.4;
sigma2_e = 2.5;
beta = {1, 2.5};
print(beta);
G = sigma2_g*K ;
R = sigma2_e*I(n);
varcov = G + R ;
print(varcov);
treeID = colvec(1:n);
X = J(n,1,1)||GT[,2] ; /*col vector of 1 for intercept*/
call randseed(1234);
create simdata2 var {"treeID" "trait1" "snp2"};
zero = j(1, n, 0); /* the zero vector */
eps = RandNormal(1, zero, varcov); /* eps ~ MVN(0,varcov) */
trait1 = X*beta + eps`; /* fixed effects, correlated errors */
append;
close;
quit;
and is analyzed with:
Proc mixed data = input METHOD=REML noprofile covtest itdetails ;
class treeID ;
model x = snp&snp /s ddfm=KR vciry outpm=out chisq;
random treeID / type=lin(1) ldata=kin ;
parms/ lowerb= 0 0;
run;
This yields the expected results
However, when I simulate this in R:
sigma2_g <- 3.4
sigma2_e <- 2.5
beta1 <- 2.7
I <- diag(nrow = nrow(X_snps_additive), ncol = nrow(X_snps_additive))
Intercept <- matrix(nrow = nrow(X_snps_additive), ncol = 1, data = 1)
G <- sigma2_g * K
R <- sigma2_e * I
var_cov <- G + R
SNP1 <- X_snps_additive[, colnames(X_snps_additive)=="SNP_SNP_IGA_1_21572990"]
lin1 <- as.matrix(SNP1) %*% beta1
zeros <- replicate(n = dim(K)[1], expr = 0)
library(mvtnorm)
error = mvtnorm::rmvnorm(n = 1, mean = zeros, sigma = var_cov, method="chol")
error = as.vector(error)
trait <- as.vector(lin1 + Intercept + error)
Followed by an analysis in SAS, then the estimate for sigmaG is off.
I am trying to code a custom Probit function in Stan to improve my understanding of the Stan language and likelihoods. So far I've written the logarithm of the normal pdf but am receiving an error message that I've found to be unintelligible when I am trying to write the likelihood. What am I doing wrong?
Stan model
functions {
real normal_lpdf(real mu, real sigma) {
return -log(2 * pi()) / 2 - log(sigma)
- square(mu) / (2 * sigma^2);
}
real myprobit_lpdf(int y | real mu, real sigma) {
return normal_lpdf(mu, sigma)^y * (1 - normal_lpdf(mu, sigma))^(1-y);
}
}
data {
int N;
int y[N];
}
parameters {
real mu;
real<lower = 0> sigma;
}
model {
for (n in 1:N) {
target += myprobit_lpdf(y[n] | mu, sigma);
}
}
Error
PARSER EXPECTED:
Error in stanc(model_code = paste(program, collapse = "\n"), model_name = model_cppname, :
failed to parse Stan model 'Probit_lpdf' due to the above error.
R code to simulate data
## DESCRIPTION
# testing a Probit model
## DATA
N <- 2000
sigma <- 1
mu <- 0.3
u <- rnorm(N, 0, 2)
y.star <- rnorm(N, mu, sigma)
y <- ifelse(y.star > 0,1, 0)
data = list(
N = N,
y = y
)
## MODEL
out.stan <- stan("Probit_lpdf.stan",data = data, chains = 2, iter = 1000 )
The full error message is
SYNTAX ERROR, MESSAGE(S) FROM PARSER:
Probabilty functions with suffixes _lpdf, _lpmf, _lcdf, and _lccdf,
require a vertical bar (|) between the first two arguments.
error in 'model2a7252aef8cf_probit' at line 7, column 27
-------------------------------------------------
5: }
6: real myprobit_lpdf(real y, real mu, real sigma) {
7: return normal_lpdf(mu, sigma)^y * (1 - normal_lpdf(mu, sigma))^(1-y);
^
8: }
-------------------------------------------------
which is telling you that the normal_lpdf function excepts three inputs and a vertical bar separating the first from the second.
It is also not a good idea to give your function the same name as a function that is already in the Stan language, such as normal_lpdf.
But the functions you have written do not implement the log-likelihood of a probit model anyway. First, the standard deviation of the errors is not identified by the data, so you do not need sigma. Then, the correct expressions would be something like
real Phi_mu = Phi(mu);
real log_Phi_mu = log(Phi_mu);
real log1m_Phi_mu = log1m(Phi_mu);
for (n in 1:N)
target += y[n] == 1 ? log_Phi_mu : log1m_Phi_mu;
although that is just a slow way of doing
target += bernoulli_lpmf(y | Phi(mu));
I am using the brms package to build a multilevel model with a gaussian process on the predictor, x. The model looks like this: make_stancode(y ~ gp(x, cov = "exp_quad", by= groups) + (1| groups), data = dat) so a gp on the x predictor and a multilevel group variable. In my case I have 5 groups. I've been looking at the code for that (below) and I'm trying to figure out the meanings and dimensions of some of the parameters.
I see that M_1 is the number of groups
My questions are:
What is the meaning of N_1, is it the same as the number of observations , N? It is used here: vector[N_1] z_1[M_1]; // unscaled group-level effects
For Kgp_1 and Mgp_1 ( int Kgp_1; and int Mgp_1;), if I have 5 groups are both Kgp_1 and Mgp_1 equal to 5? If so, why are two variables used?
// generated with brms 1.10.0
functions {
/* compute a latent Gaussian process
* Args:
* x: array of continuous predictor values
* sdgp: marginal SD parameter
* lscale: length-scale parameter
* zgp: vector of independent standard normal variables
* Returns:
* a vector to be added to the linear predictor
*/
vector gp(vector[] x, real sdgp, real lscale, vector zgp) {
matrix[size(x), size(x)] cov;
cov = cov_exp_quad(x, sdgp, lscale);
for (n in 1:size(x)) {
// deal with numerical non-positive-definiteness
cov[n, n] = cov[n, n] + 1e-12;
}
return cholesky_decompose(cov) * zgp;
}
}
data {
int<lower=1> N; // total number of observations
vector[N] Y; // response variable
int<lower=1> Kgp_1;
int<lower=1> Mgp_1;
vector[Mgp_1] Xgp_1[N];
int<lower=1> Igp_1[Kgp_1];
int<lower=1> Jgp_1_1[Igp_1[1]];
int<lower=1> Jgp_1_2[Igp_1[2]];
int<lower=1> Jgp_1_3[Igp_1[3]];
int<lower=1> Jgp_1_4[Igp_1[4]];
int<lower=1> Jgp_1_5[Igp_1[5]];
// data for group-level effects of ID 1
int<lower=1> J_1[N];
int<lower=1> N_1;
int<lower=1> M_1;
vector[N] Z_1_1;
int prior_only; // should the likelihood be ignored?
}
transformed data {
}
parameters {
real temp_Intercept; // temporary intercept
// GP hyperparameters
vector<lower=0>[Kgp_1] sdgp_1;
vector<lower=0>[Kgp_1] lscale_1;
vector[N] zgp_1;
real<lower=0> sigma; // residual SD
vector<lower=0>[M_1] sd_1; // group-level standard deviations
vector[N_1] z_1[M_1]; // unscaled group-level effects
}
transformed parameters {
// group-level effects
vector[N_1] r_1_1 = sd_1[1] * (z_1[1]);
}
model {
vector[N] mu = rep_vector(0, N) + temp_Intercept;
mu[Jgp_1_1] = mu[Jgp_1_1] + gp(Xgp_1[Jgp_1_1], sdgp_1[1], lscale_1[1], zgp_1[Jgp_1_1]);
mu[Jgp_1_2] = mu[Jgp_1_2] + gp(Xgp_1[Jgp_1_2], sdgp_1[2], lscale_1[2], zgp_1[Jgp_1_2]);
mu[Jgp_1_3] = mu[Jgp_1_3] + gp(Xgp_1[Jgp_1_3], sdgp_1[3], lscale_1[3], zgp_1[Jgp_1_3]);
mu[Jgp_1_4] = mu[Jgp_1_4] + gp(Xgp_1[Jgp_1_4], sdgp_1[4], lscale_1[4], zgp_1[Jgp_1_4]);
mu[Jgp_1_5] = mu[Jgp_1_5] + gp(Xgp_1[Jgp_1_5], sdgp_1[5], lscale_1[5], zgp_1[Jgp_1_5]);
for (n in 1:N) {
mu[n] = mu[n] + (r_1_1[J_1[n]]) * Z_1_1[n];
}
// priors including all constants
target += student_t_lpdf(sdgp_1 | 3, 0, 10)
- 1 * student_t_lccdf(0 | 3, 0, 10);
target += normal_lpdf(lscale_1 | 0, 0.5)
- 1 * normal_lccdf(0 | 0, 0.5);
target += normal_lpdf(zgp_1 | 0, 1);
target += student_t_lpdf(sigma | 3, 0, 10)
- 1 * student_t_lccdf(0 | 3, 0, 10);
target += student_t_lpdf(sd_1 | 3, 0, 10)
- 1 * student_t_lccdf(0 | 3, 0, 10);
target += normal_lpdf(z_1[1] | 0, 1);
// likelihood including all constants
if (!prior_only) {
target += normal_lpdf(Y | mu, sigma);
}
}
generated quantities {
// actual population-level intercept
real b_Intercept = temp_Intercept;
}
If you use make_standata(...) on the same formula, you can see the data that would be passed onto Stan. From here, you can piece together what some of the variables do. If I use the lme4::sleepstudy dataset as a proxy for your data, I get:
library(brms)
dat <- lme4::sleepstudy
dat$groups <- dat$Subject
dat$y <- dat$Reaction
dat$x <- dat$Days
s_data <- make_standata(
y ~ gp(x, cov = "exp_quad", by= groups) + (1| groups), data = dat)
s_data$N_1
#> 18
For N_1, I get 18 which is the number of levels in groups in this dataset.
For Kgp_1 and Mgp_1 ( int Kgp_1; and int Mgp_1;), if I have 5 groups are both Kgp_1 and Mgp_1 equal to 5? If so, why are two variables used?
s_data$Mgp_1
#> 1
s_data$Kgp_1
#> 18
It looks like Kgp_1 is again the number of groups. I am not sure what Mgp_1 does besides set the length of the vector vector[Mgp_1] Xgp_1[N];
I'm trying to modeling a prey-prey-predator system using differential equations based on the LV model. For the sake of the precision, i need to use the runge-kutta4 method.
But given the equations, some of the populations become quickly negative.
So I tried to use the events/root system of ODE but it seems that rk4 and rootfun are not compatibles...
eventFunc <- function(t, y, p){
if (y["N1"] < 0) { y["N1"] = 0 }
if (y["N2"] < 0) { y["N2"] = 0 }
if (y["P"] < 0) { y["P"] = 0 }
return(y)
}
rootFunction <- function(t, y, p){
if (y["P"] < 0) {y["P"] = 0}
if (y["N1"] < 0) {y["N1"] = 0}
if (y["N2"] < 0) {y["N2"] = 0}
return(y)
}
out <- ode(func=Model_T2.2,
method="rk4",
y=state,
parms=parameters,
times=times,
events = list(func = eventFunc,
root = TRUE),
rootfun = rootFunction
)
This code give me the followin error :
Error in checkevents(events, times, Ynames, dllname) :
either 'events$time' should be given and contain the times of the events, if 'events$func' is specified and no root function or your solver does not support root functions
Is there any solution to use rk4 and forbid the functions to go under 0?
Thanks in advance.
For those who might ask, here is what works :
if(!require(ggplot2)) {
install.packages("ggplot2"); require(ggplot2)}
if(!require(deSolve)) {
install.packages("deSolve"); require(deSolve)}
Model_T2.2 <- function(t, state, par){
with(as.list(c(state, par)), {
response1 <- (a1 * N1)/(1+(a1*h1*N1)+(a2*h2*N2))
response2 <- (a2 * N2)/(1+(a1*h1*N1)+(a2*h2*N2))
dN1 = r1*N1 * (1 - ((N1 + A12 * N2)/K1)) - response1 * P
dN2 = r2*N2 * (1 - ((N1 + A21 * N2)/K2)) - response2 * P
dP = ((E1 * response1) + (E2 * response2)) * P - Mp
return(list(c(dN1, dN2, dP)))
})
}
parameters<-c(
r1=1.42, r2=0.9,
A12=0.6, A21=0.5,
K1=50, K2=50,
a1=0.77, a2=0.77,
b1 = 1, b2=1,
h1=1.04, h2=1.04,
o1=0, o2=0,
Mp=0.22,
E1=0.36, E2=0.36
)
## inital states
state<-c(
P=10,
N1=30,
N2=30
)
times <- seq(0, 30, by=0.5)
out <- ode(func=Model_T2.2,
method="rk4",
y=state,
parms=parameters,
times=times,
events = list(func = eventFunc,
root = TRUE),
rootfun = rootFunction
)
md <- melt(as.data.frame(out), id.vars=1, measure.vars = c("N1", "N2", "P"))
pl <- ggplot(md, aes(x=time, y=value, colour=variable))
pl <- pl + geom_line() + geom_point() + scale_color_discrete(name="Population")
pl
And the result in a graph :
Evolution of prey1, prey2 and predator populations
As you can see, the population of predators become negative which is clearly impossible in the real world.
Edit : missing variables, sorry about that.
This is a problem you will have with all explicit solvers like rk4. Reducing the time step will help, up to a point. Better use a solver with an implicit method, lsoda seems universally available in one form or another.
Another way to explicitly force positive values is to parametrize them as exponentials. Set N1=exp(U1), N2=exp(U2) then the ODE function code translates to (as dN = exp(U)*dU = N*dU)
N1 <- exp(U1)
N2 <- exp(U2)
response1 <- (a1)/(1+(a1*h1*N1)+(a2*h2*N2))
response2 <- (a2)/(1+(a1*h1*N1)+(a2*h2*N2))
dU1 = r1 * (1 - ((N1 + A12 * N2)/K1)) - response1 * P
dU2 = r2 * (1 - ((N1 + A21 * N2)/K2)) - response2 * P
dP = ((E1 * response1*N1) + (E2 * response2*N2)) * P - Mp
For the output you have then of course to reconstruct N1, N2 from the solutions U1, U2.
Thanks to J_F, I am now able to run my L-V model.
The radau (not randau as you mentionned) function indeed accept root function and events ans implicitly implements the runge-kutta method.
Thanks again, hope this will help someone in the future.
I'm trying to replicate the Excel Solver in R- which is basically a constraint optimization problem
I'm trying to minimize the cost per action which is total spend/ total actions which equals to the below function with a few constraints.
CPA function:
(a+b+c+d)/((consta+(Baln(a)))+ (constb+(Bbln(b)))+(constc+(Bcln(c)))+(constd+(Bdln(d)))
where the unknown variables are a,b,c,d and const* stands for constant from a regressions and B* stand for coefficient from a regression (so they are values that I have).
Here is the simplified filled in function that I'm trying to minimize:
(a+b+c+d)/ (((69.31*ln(a))+(14.885*ln(b))+(21.089*ln(c))+(9.934*ln(d))-(852.93))
Constraints:
a+b+c+d>=0
a+b+c+d<=130000(total spend)
a<=119000 (maxa)
a>=272.56(mina)
b<=11000(maxb)
b>=2.04(minb)
c<=2900(maxc)
c>=408.16(minc)
d<=136800(maxd)
d>=55.02(mind)
I'm doing this using the constraints optimization function. My code is below:
g<-function(a,b,c,d) { (a+b+c+d)/((consta+(Balog(a)))+ (constb+(Bblog(b)))+ (constc+(Bclog(c)))+ (constd+(Bdlog(d)))) }
gb<-function(a) g(a[1], a[2], a[3],a[4])
A<-matrix(c(1,0,0,0,-1,0,0,0,0,1,0,0,0,-1,0,0,0,0,1,0,0,0,-1,0,0,0,0,1,0,0,0,-1,-1,-1,-1,-1,1,1,1,1),4,10)
B<- c(mina, -maxa, minb, -maxb, minc, -maxc, mind, -maxd,-totalspend, 0)
constrOptim(c(273,6,409,56),g,gb,A,B)
When I run the optimization function, it states that something is wrong with my arguments (Error in ui %*% theta : non-conformable arguments). I think it is the gradient of the function that is coded wrong but I'm not sure. Any help is appreciated.
You can consider the following approach
library(DEoptim)
fn_Opt <- function(param)
{
a <- param[1]
b <- param[2]
c <- param[3]
d <- param[4]
bool_Cond <- a + b + c + d <= 130000
if(bool_Cond == FALSE)
{
return(10 ^ 30)
}else
{
val <- (a + b + c + d) / (((69.31 * log(a)) + (14.885 * log(b)) + (21.089 * log(c)) + (9.934 * log(d)) - (852.93)))
return(val)
}
}
obj_DEoptim <- DEoptim(fn = fn_Opt, lower = c(272.56, 2.04, 408.16, 55.02),
upper = c(119000, 11000, 2900, 136800),
control = list(itermax = 10000))