I have written following code in R using pomp. Everything works fine except skeleton function.Error is there, unused argument in skel.skel function returns void. I am adding data as an example. Help is solicited and thanks in advance. Error is like this:
C:/Users/admin/AppData/Local/Temp/RtmpmEz0jw/1892/pomp_dfb36bbab4b5ee3a8b4cbc45a0b63e0c.c: In function '__pomp_skelfn':
C:/Users/admin/AppData/Local/Temp/RtmpmEz0jw/1892/pomp_dfb36bbab4b5ee3a8b4cbc45a0b63e0c.c:96:39: warning: 'return' with a value, in function returning void
return(I);
t y1 y2
1 -0.058886245 0.018451378
2 -0.045854389 -0.012812011
3 0 -0.025850852
4 -0.06009386 0.021278254
5 0.053712929 -0.008261274
6 0 0.025270473
7 0.047628037 -0.008357995
8 0.061425641 -0.0146046
9 0 -0.03778035
10 0 -0.004632415
library(magrittr)
library(pomp)
library(ggplot2)
data <- read.csv("C:/Users/admin/Documents/phd/book2.csv", stringsAsFactors = FALSE)
data <- as.data.frame(data)
pomp(
data,times="t", t0=0,
rmeasure=Csnippet("
y1 = rnorm(x1+x2,sigma1);
y2 = rnorm(x2-x1,sigma2);
"),
dmeasure=Csnippet("
lik = dnorm(y1,x1+x2,sigma1,1)+dnorm(y2,x2-x1,sigma2,1);
lik = (give_log) ? lik : exp(lik);
"),
rprocess=discrete.time.sim(
step.fun=Csnippet("
double tx1, tx2;
tx1 = rnorm(a11*x1 + a12*x2,nu1);
tx2 = rnorm(a21*x1 + a22*x2,nu2);
x1 = tx1; x2 = tx2;
"),
delta.t=1),
initializer=Csnippet("
x1 = 0;
x2 = 0;
"),
skeleton = vectorfield(
skel = Csnippet("double I;
I = a11 + a12*x1 + a22 + a21*x2;
return(I);
")
),
toEstimationScale = logtrans <- Csnippet("
Tr1 = log(a11);
TK1 = log(a21);
Tsigma1 = log(sigma1);
"),
fromEstimationScale=exptransexptrans <- Csnippet("
Tr1 = exp(a11);
TK1 = exp(21);
Tsigma1 = exp(sigma1);
"),
statenames=c("x1","x2"),
paramnames=c("a11","a12","a21","a22","sigma1","sigma2","nu1","nu2"),
params=c(a11=0.5,a12=-0.1,a21=0.2,a22=-1,nu1=0.3,nu2=0.1,sigma1=0.1,sigma2=0.3)
) -> parus
Related
I want to optimize my code. I have a lot of repetitions and I'm sure this can be done using a loop.
ciecg <- data.frame(baseline_cardinv_n = sum(d$cardinv_ecg1,na.rm=T),
baseline_total_n = table(d$cardinv_ecg1)[1]+table(d$cardinv_ecg1)[2],
baseline_pct = mean(d$cardinv_ecg1,na.rm=T)*100,
latest_cardinv_n = sum(d$cardinv_ecg2,na.rm=T),
latest_total_n = table(d$cardinv_ecg2)[1]+table(d$cardinv_ecg2)[2],
latest_pct = mean(d$cardinv_ecg2,na.rm=T)*100); rownames(ciecg) <- "ECG only"; ciecg
ciecghol <- data.frame(baseline_cardinv_n = sum(d$cardinv_ecg1_hol1,na.rm=T),
baseline_total_n = table(d$cardinv_ecg1_hol1)[1]+table(d$cardinv_ecg1_hol1)[2],
baseline_pct = mean(d$cardinv_ecg1_hol1,na.rm=T)*100,
latest_cardinv_n = sum(d$cardinv_ecg2_hol2,na.rm=T),
latest_total_n = table(d$cardinv_ecg2_hol2)[1]+table(d$cardinv_ecg2_hol2)[2],
latest_pct = mean(d$cardinv_ecg2_hol2,na.rm=T)*100); rownames(ciecghol) <- "ECG + HOL"; ciecghol
ciecgholec <- data.frame(baseline_cardinv_n = sum(d$cardinv_ecg1_hol1_ec1,na.rm=T),
baseline_total_n = table(d$cardinv_ecg1_hol1_ec1)[1]+table(d$cardinv_ecg1_hol1_ec1)[2],
baseline_pct = mean(d$cardinv_ecg1_hol1_ec1,na.rm=T)*100,
latest_cardinv_n = sum(d$cardinv_ecg2_hol2_ec2,na.rm=T),
latest_total_n = table(d$cardinv_ecg2_hol2_ec2)[1]+table(d$cardinv_ecg2_hol2_ec2)[2],
latest_pct = mean(d$cardinv_ecg2_hol2_ec2,na.rm=T)*100); rownames(ciecgholec) <- "ECG + HOL + TTE"; ciecgholec
round(rbind(ciecg,ciecghol,ciecgholec),1)
If I print the last line in the console I get this:
> round(rbind(ciecg,ciecghol,ciecgholec),1)
baseline_cardinv_n baseline_total_n baseline_pct latest_cardinv_n latest_total_n latest_pct
ECG only 47 194 24.2 83 169 49.1
ECG + HOL 61 183 33.3 59 120 49.2
ECG + HOL + TTE 73 180 40.6 65 113 57.5
I would like to make that same code with a loop to shorten my code. Here is what I have tried (I only tried to make the ciecg to make it simpler for myself):
ci_exam <- data.frame(matrix(nrow = 3,ncol = 0))
exam_1 <- c("cardinv_ecg1","cardinv_hol1","cardinv_ec1")
exam_2 <- c("cardinv_ecg2","cardinv_hol2","cardinv_ec2")
exam_name <- c("ECG only","HOL only","EC only")
for (i in 1:3) {
ci_exam[exam_name[i]] <- c(sum(d$exam_1[i],na.rm=T),
table(d$exam_1[i])[1]+table(d$exam_1[i])[2],
mean(d$exam_1[i],na.rm=T)*100,
sum(d$exam_2[i],na.rm=T),
table(d$exam_2[i])[1]+table(d$exam_2[i])[2],
mean(d$exam_2[i],na.rm=T)*100)
}
But gives me this error
Error in `[<-.data.frame`(`*tmp*`, exam_name[i], value = c(0, NA, NA, :
erstatning har 6 rækker, data har 3
In addition: Warning messages:
1: In mean.default(d$exam_1[i], na.rm = T) :
argument er ikke numerisk eller logisk: returnerer NA
2: In mean.default(d$exam_2[i], na.rm = T) :
argument er ikke numerisk eller logisk: returnerer NA
Tried to make a loop. I was expecting to make the entire dataframe in one loop (all ciecg, ciecghol, ciecgholec combined in one, as shown from the command round(rbind(ciecg,ciecghol,ciecgholec),1))
step 1 ; make your repeated code into a function
do_thing <- function(x,y,z){
this_ <- data.frame(
baseline_cardinv_n = sum(d[[x]], na.rm = T),
baseline_total_n = table(d[[x]])[1] + table(d[[x]])[2],
baseline_pct = mean(d[[x]], na.rm = T) * 100,
latest_cardinv_n = sum(d[[y]], na.rm = T),
latest_total_n = table(d[[y]])[1] + table(d[[y]])[2],
latest_pct = mean(d[[y]], na.rm = T) * 100
) ; rownames(this_) <- z; this_
}
#example of use
ciecg <- do_thing("cardinv_ecg1",
"cardinv_ecg2",
"ECG only")
step 2; iterate over params and using your function
#note to align with your first sets of examples, I had to
params <- data.frame(exam_1 = c("cardinv_ecg1","cardinv_ecg1_hol1","cardinv_ecg1_hol1_ec1"),
exam_2 = c("cardinv_ecg2","cardinv_ecg1_hol1","cardinv_ecg2_hol2_ec2"),
exam_name = c("ECG only", "ECG + HOL","ECG + HOL + TTE"))
library(dplyr)
(results_from_params <- params |> rowwise() |> mutate(res = list(do_thing(x=exam_1,
y=exam_2,
z=exam_name))))
bind_rows(results_from_params$res)
I want to plot a partition of a two-dimensional covariate space constructed by recursive binary splitting. To be more precise, I would like to write a function that replicates the following graph (taken from Elements of Statistical Learning, pag. 306):
Displayed above is a two-dimensional covariate space and a partition obtained by recursive binary splitting the space using axis-aligned splits (what is also called a CART algorithm). What I want to implement is a function that takes the output of the rpart function and generates such plot.
It follows some example code:
## Generating data.
set.seed(1975)
n <- 5000
p <- 2
X <- matrix(sample(seq(0, 1, by = 0.01), n * p, replace = TRUE), ncol = p)
Y <- X[, 1] + 2 * X[, 2] + rnorm(n)
## Building tree.
tree <- rpart(Y ~ ., data = data.frame(Y, X), method = "anova", control = rpart.control(cp = 0, maxdepth = 2))
Navigating SO I found this function:
rpart_splits <- function(fit, digits = getOption("digits")) {
splits <- fit$splits
if (!is.null(splits)) {
ff <- fit$frame
is.leaf <- ff$var == "<leaf>"
n <- nrow(splits)
nn <- ff$ncompete + ff$nsurrogate + !is.leaf
ix <- cumsum(c(1L, nn))
ix_prim <- unlist(mapply(ix, ix + c(ff$ncompete, 0), FUN = seq, SIMPLIFY = F))
type <- rep.int("surrogate", n)
type[ix_prim[ix_prim <= n]] <- "primary"
type[ix[ix <= n]] <- "main"
left <- character(nrow(splits))
side <- splits[, 2L]
for (i in seq_along(left)) {
left[i] <- if (side[i] == -1L)
paste("<", format(signif(splits[i, 4L], digits)))
else if (side[i] == 1L)
paste(">=", format(signif(splits[i, 4L], digits)))
else {
catside <- fit$csplit[splits[i, 4L], 1:side[i]]
paste(c("L", "-", "R")[catside], collapse = "", sep = "")
}
}
cbind(data.frame(var = rownames(splits),
type = type,
node = rep(as.integer(row.names(ff)), times = nn),
ix = rep(seq_len(nrow(ff)), nn),
left = left),
as.data.frame(splits, row.names = F))
}
}
Using this function, I am able to recover all the splitting variables and points:
splits <- rpart_splits(tree)[rpart_splits(tree)$type == "main", ]
splits
# var type node ix left count ncat improve index adj
# 1 X2 main 1 1 < 0.565 5000 -1 0.18110662 0.565 0
# 3 X2 main 2 2 < 0.265 2814 -1 0.06358597 0.265 0
# 6 X1 main 3 5 < 0.645 2186 -1 0.07645851 0.645 0
The column var tells me the splitting variables for each non-terminal node, and the column left tells the associated splitting points. However, I do not know how to use this information to produce my desired plots.
Of course if you have any alternative strategy that do not involve the use of rpart_splits feel free to suggest it.
You could use the (unpublished) parttree package, which you can install from GitHub via:
remotes::install_github("grantmcdermott/parttree")
This allows:
library(parttree)
ggplot() +
geom_parttree(data = tree, aes(fill = path)) +
coord_cartesian(xlim = c(0, 1), ylim = c(0, 1)) +
scale_fill_brewer(palette = "Pastel1", name = "Partitions") +
theme_bw(base_size = 16) +
labs(x = "X2", y = "X1")
Incidentally, this package also contains the function parttree, which returns something very similar to your
rpart_splits function:
parttree(tree)
node Y path xmin xmax ymin ymax
1 4 0.7556079 X2 < 0.565 --> X2 < 0.265 -Inf 0.265 -Inf Inf
2 5 1.3087679 X2 < 0.565 --> X2 >= 0.265 0.265 0.565 -Inf Inf
3 6 1.8681143 X2 >= 0.565 --> X1 < 0.645 0.565 Inf -Inf 0.645
4 7 2.4993361 X2 >= 0.565 --> X1 >= 0.645 0.565 Inf 0.645 Inf
I am trying to run the code below in order to simulate a set of P-values using a generalised linear model
However, I keep getting the error: Lapack routine dgesv: system is exactly singular: U[6,6] = 0
Here is the code I am trying to run:
#which_p_value = "x1"
which_p_value = "groupcategory"
#which_p_value = "x1:groupcategory"
run_anova = FALSE
simulate_mixed_effect = TRUE
mixed_effect_sd = 3.094069
mixed_effect_sd_slope = 3.098661
library(tidyverse)
n_people <- c(2,5,10,15,20)
coef1 <- 1.61
coef2 <- -0.01
#coef3 <- 5
#coef4 <- 0
g1 = 0
g2 = 1
g3 = 2
distances <- c(60,90,135,202.5,303.75,455.625)/100
n_trials <- 35
oneto1000 <- 25
n_track_lengths <- length(distances)
groupcategory = c(rep(g1, n_track_lengths), rep(g2, n_track_lengths),rep(g3,n_track_lengths))
z = c(n_people)
emptydataframeforpowerplots = NULL
coef3s <- c(-5, -4, -3, -2,-1, 0, 1, 2, 3, 4, 5)
coef4s <- c(-1, -0.8, -0.6, -0.4, -0.2, 0, 0.2, 0.4, 0.6, 0.8, 1)
Datarray <- array(dim=c(length(coef3s), length(coef4s),length(n_people)))
coef3_counter =1
for (coef3 in coef3s) {
coef4_counter =1
for (coef4 in coef4s) {
z1_g2 <- coef1 + coef2*distances + coef3*g2 + coef4*g2*distances
z1_g3 <- coef1 + coef2*distances + coef3*g3 + coef4*g3*distances
d = NULL
pr1 = 1/(1+exp(-z1_g2))
pr2 = 1/(1+exp(-z1_g3))
counter=1
for (i in n_people) {
for (j in 1:oneto1000){
df <- c()
for (k in 1:i){
# random effect from drawing a random intercept with sd = x
if (simulate_mixed_effect){
coef1_r = rnorm(1, mean=coef1, sd=mixed_effect_sd)
coef2_r = rnorm(1, mean=coef1, sd=mixed_effect_sd_slope)
} else {
coef1_r = coef1
coef2_r = coef2
}
z_g1 <- coef1_r + coef2*distances + coef3*g1 + coef4*g1*distances
pr = 1/(1+exp(-z_g1))
z1_g2 <- coef1_r + coef2*distances + coef3*g2 + coef4*g2*distances
pr1 = 1/(1+exp(-z1_g2))
if (run_anova) {
df <- rbind(df, data.frame(x1 = c(rep(distances, 3)),
y = c(rbinom(n_track_lengths,n_trials,pr), rbinom(n_track_lengths,n_trials,pr1),rbinom(n_track_lengths,n_trials,pr2)),
groupcategory = groupcategory, id = c(rep(k,18))))
} else { # this is for glmer data organisation
for (m in 1:n_trials) {
df <- rbind(df, data.frame(x1 = c(rep(distances, 3)),
y = c(rbinom(n_track_lengths,1,pr),rbinom(n_track_lengths,1,pr1),rbinom(n_track_lengths,1,pr2)),groupcategory = groupcategory,id = c(rep(k,18))))
}
}
}
if (run_anova) {
#df_aov <- aov(y~x1*groupcategory+Error(id/(x1*groupcategory)),data=df)
#df_aov_sum <- summary(df_aov)
#pvalue <- df_aov_sum[[5]][[1]][which_p_value,"Pr(>F)"]
df_aov <- aov(y~x1*groupcategory+Error(id),data=df)
df_aov_sum <- summary(df_aov)
pvalue <- df_aov_sum[[2]][[1]][which_p_value, "Pr(>F)"]
} else { # glmer
mod_group_glmer <- glmer(y ~ x1 + groupcategory + (1+x1|id), data = df, family = "binomial")
sum <- summary(mod_group_glmer)
pvalue <- sum$coefficients[which_p_value, "Pr(>|z|)"]
}
d = rbind(d,data.frame(pvalue))
}
count <- plyr::ldply(d,function(c) sum(c<=0.05))
Datarray[coef3_counter,coef4_counter,counter] <- count$V1/oneto1000
counter = counter +1
d = NULL
}
coef4_counter = coef4_counter + 1
}
coef3_counter = coef3_counter + 1
}
Below is the script from the debugger:
Lapack routine dgesv: system is exactly singular: U[6,6] = 0
8. stopifnot(length(value <- as.numeric(value)) == 1L)
7. nM$newf(fn(nM$xeval()))
6. (function (fn, par, lower = rep.int(-Inf, n), upper = rep.int(Inf, n), control = list()) { n <- length(par) ...
5. do.call(optfun, arglist)
4. withCallingHandlers(do.call(optfun, arglist), warning = function(w) { curWarnings <<- append(curWarnings, list(w$message)) })
3. optwrap(optimizer, devfun, start, rho$lower, control = control, adj = adj, verbose = verbose, ...)
2. optimizeGlmer(devfun, optimizer = control$optimizer[[2]], restart_edge = control$restart_edge, boundary.tol = control$boundary.tol, control = control$optCtrl, start = start, nAGQ = nAGQ, verbose = verbose, stage = 2, calc.derivs = control$calc.derivs, use.last.params = control$use.last.params)
1. glmer(y ~ x1 + groupcategory + (1 + x1 id), data = df, family = "binomial")
Would anybody be able to give a helping hand as to how I can proceed from here?
I'm moving some code from Matlab to R and I'm facing some difficulties in a particular case of the handle function. This is my Matlab code:
function Application_ChFun
clear;close all;clc;warning('off');
StepsYr = 10;
%% --parameters-- %%
S0 = 1;
r = 0.0;
t0 = 0;
T2 = 5;
gamma = 0.5;
kappa = 0.3;
rho = -0.6;
vBar = 0.05;
v0 = 0.04;
NoOfPaths = 5e4;
NoOfSteps = StepsYr*T2;
%% --Define model-- %%
cf = #(u,T)ChFun(u, T, kappa,vBar,gamma,rho, v0, r);
Vc = #(t,x)MktFun(cf,t,x,log(S0));
% Define bump size
bump_T = 1e-4;
bump_K = #(T)1e-4;
% Define derivatives
dC_dT = #(T,K) (Vc(T + bump_T,K) - Vc(T ,K)) / bump_T;
dC_dK = #(T,K) (Vc(T,K + bump_K(T)) - Vc(T,K - bump_K(T))) / (2 * bump_K(T));
d2C_dK2 = #(T,K) (Vc(T,K + bump_K(T)) + Vc(T,K-bump_K(T)) - 2*Vc(T,K)) / bump_K(T)^2;
t = t0;
S = S0+zeros(NoOfPaths,1);
for i = 1:NoOfSteps
if i==1
t_adj = 1/NoOfSteps;
t = t_adj;
end
% AAA perfectly matches with the R equivalent, but AAB and AAC do not.
AAA = dC_dT(t,S);
AAB = dC_dK(t,S);
AAC = d2C_dK2(t,S);
end
function value = MktFun(cf,T,x,x0)
value = CM_Proxy(cf,T,x,x0);
function value = CM_Proxy(ChF,T,K,x0)
K(K<1e-5)=1e-5;
alpha = 0.75;
c = 3e2;
N_CM = 2^12;
eta = c/N_CM;
b = pi/eta;
u = [0:N_CM-1]*eta;
lambda = 2*pi/(N_CM*eta);
i = complex(0,1);
u_new = u-(alpha+1)*i;
cf = exp(i*u_new*x0).*ChF(u_new,T);
psi = cf./(alpha^2+alpha-u.^2+i*(2*alpha+1)*u);
SimpsonW = 3+(-1).^[1:N_CM]-[1,zeros(1,N_CM-1)];
SimpsonW(N_CM) = 0;
SimpsonW(N_CM-1) = 1;
FFTFun = exp(i*b*u).*psi.*SimpsonW;
payoff = real(eta*fft(FFTFun)/3);
strike = exp(-b:lambda:b-lambda);
payoff_specific = spline(strike,payoff,K);
value = exp(-log(K)*alpha).*payoff_specific/pi;
function cf=ChFun(u, tau, kappa,vBar,gamma,rho, v0, r)
i = complex(0,1);
D_1 = sqrt(((kappa -i*rho*gamma.*u).^2+(u.^2+i*u)*gamma^2));
g = (kappa- i*rho*gamma*u-D_1)./(kappa-i*rho*gamma*u+D_1);
C = (1/gamma^2)*(1-exp(-D_1*tau))./(1-g.*exp(-D_1*tau)).*(kappa-gamma*rho*i*u-D_1);
A = i*u*r*tau + kappa*vBar*tau/gamma^2 * (kappa-gamma*rho*i*u-D_1)-2*kappa*vBar/gamma^2*log((1-g.*exp(-D_1*tau))./(1-g));
cf = exp(A + C * v0);
where MktFun is a standard function. When g=dC_dK(t,S) is called first of all bump_K(T) is evaluated and then Vc(T,K + bump_K(T)) and Vc(T,K-bump_K(T)).
In R I have the following:
Application_ChFun <- function(){
StepsYr = 10
## --parameters-- ##
S0 = 1
r = 0.0
t0 = 0
T2 = 5
gamma = 0.5
kappa = 0.3
rho = -0.6
vBar = 0.05
v0 = 0.04
NoOfPaths = 5e4
NoOfSteps = StepsYr*T2
## --Define model-- ##
cf <- function(u,T) ChFun(u,T,kappa,vBar,gamma,rho, v0, r)
Vc <- function(t,x) MktFun(cf,t,x,log(S0))
# Define bump size
bump_T = 1e-4
bump_K <- function(T) 1e-4
# Define derivatives
dC_dT <- function(T,K) (Vc(T + bump_T,K) - Vc(T ,K)) / bump_T
dC_dK <- function(T,K) (Vc(T,K + bump_K(T)) - Vc(T,K - bump_K(T))) / (2 * bump_K(T))
d2C_dK2 <- function(T,K) (Vc(T,K + bump_K(T)) + Vc(T,K - bump_K(T)) - 2*Vc(T,K)) / bump_K(T)^2
t = t0
S = S0+rep(0,NoOfPaths)
for (i in 1:NoOfSteps){
t_real = t
if (i==1){
t_adj = 1/NoOfSteps;
t = t_adj
}
# AAA perfectly matches with the R's equivalent. But AAB and AAC do not.
AAA = dC_dT(t,S)
AAB = dC_dK(t,S)
AAC = d2C_dK2(t,S)
}
}
MktFun <- function(cf,T,x,x0){
return(CM_Proxy(cf,T,x,x0))
}
CM_Proxy <- function(ChF,T,K,x0){
K[K<1e-5] = 1e-5
alpha = 0.75
c = 3e2
N_CM = 2^12
eta = c/N_CM
b = pi/eta
u = (0:(N_CM-1))*eta
lambda = 2*pi/(N_CM*eta)
i = complex(real = 0, imaginary = 1)
u_new = u - (alpha+1)*i # European call option.
cf = exp(i*u_new*x0)*ChF(u_new,T)
psi = cf/(alpha^2+alpha-u^2+i*(2*alpha+1)*u)
SimpsonW = 3+(-1)^(1:N_CM)-c(1,rep(0,N_CM-1))
SimpsonW[N_CM] = 0
SimpsonW[N_CM-1] = 1
FFTFun = exp(i*b*u)*psi*SimpsonW
payoff = Re(eta*fft(FFTFun)/3)
strike = exp(seq(-b,b-lambda,lambda))
K = as.vector(K)
payoff_specific = stinepack::stinterp(strike,payoff,K)
value = exp(-log(K)*alpha)*payoff_specific$y/pi
return(value)
}
ChFun <- function(u, tau, kappa,vBar,gamma,rho, v0, r){
i = complex(real = 0, imaginary = 1)
D_1 = sqrt(((kappa - i*rho*gamma*u)^2 + (u^2+i*u)*gamma^2))
g = (kappa - i*rho*gamma*u - D_1) / (kappa - i*rho*gamma*u + D_1)
C = (1/gamma^2)*(1-exp(-D_1*tau))/(1-g*exp(-D_1*tau))*(kappa-gamma*rho*i*u-D_1)
A = i*u*r*tau + kappa*vBar*tau/gamma^2 * (kappa-gamma*rho*i*u-D_1) +
-2*kappa*vBar/gamma^2*log((1-g*exp(-D_1*tau))/(1-g))
cf = exp(A + C * v0)
return(cf)
}
The problem is that in this case is that g=dC_dK(t,S) calls directly Vc instead of calling bump_k(T) first. Could someone please suggest a solution?
The evaluation order of functions is not necessarily inside-out (as it appears you are expected) so much as the order as needed. R tries to do things lazily, so if you include an expensive operation that is never actually referenced, it is not realized.
Take this example:
f1 <- function(a) { message("f1"); a + 1; }
f2 <- function(b) { message("f2"); f1(b) + 2; }
f3 <- function(d) { message("f3"); f2(f1(d) + 3) / f2(f1(d) + 4); }
f3(2)
# f3
# f2
# f1
# f1
# f2
# f1
# f1
# [1] 0.9
When f3 is called, the calls to f2 are the next to be evaluated. When f2 is first called (with f1(d)+3), f2 is called with the unevaluated argument. Once f2 tries to use its b, only then is it evaluated and f1 is called.
If I look at the call stack on the first call to f1, then we see:
Browse[2]> where
where 1 at #1: f1(b)
where 2 at #1: f2(f1(d) + 3)
where 3 at #1: f3(2)
showing the order of functions is f3 called first, then f2, then from there f1.
I have the problem in fomulating a model, where at least one variable is to be estimated independently from the classes, so one and the same coefficient for all classes. How could one do this?
I am working with the R package gmnl.
install.packages("gmnl")
library(gmnl)
library(mlogit)
#browseURL("https://cran.r-project.org/web/packages/poLCA/index.html")
## Examples using the Fishing data set from the AER package
data("Electricity", package = "mlogit")
Electr <- mlogit.data(Electricity, id.var = "id", choice = "choice",
varying = 3:26, shape = "wide", sep = "")
Elec.lc <- gmnl(choice ~ pf + cl + loc + wk + tod + seas| 0 | 0 | 0 | 1,
data = Electr,
subset = 1:3000,
model = 'lc',
panel = TRUE,
Q = 2)
summary(Elec.lc)
How would you model one of the variables pf, cl, loc, wk, tod, or seas independently from the class? Thank you!
Thanks to Mauricio Sarrias I can present this work-around, which should solve the problem:
###################################
library("gmnl")
library("mlogit")
# Data
data("Electricity", package = "mlogit")
Electr <- mlogit.data(Electricity, id.var = "id", choice = "choice",
varying = 3:26, shape = "wide", sep = "")
# ASCs
Electr$asc2 <- as.numeric(Electr$alt == 2)
Electr$asc3 <- as.numeric(Electr$alt == 3)
Electr$asc4 <- as.numeric(Electr$alt == 4)
# We estimate a MNL for the initial values of LC-MNL
init_mnl <- gmnl(choice ~ asc2 + asc3 + asc4 + pf + cl| 0,
data = Electr)
summary(init_mnl)
# Work on initial values for LC-MNL
init <- coef(init_mnl)
Q <- 2 # Number of Classes
init.shift <- seq(-0.02, 0.02, length.out = Q)
lc.mean <- c()
for(i in 1:Q){
lc.mean <- c(lc.mean, init + init.shift[i])
}
lc.names <- c()
lc.nalpha <- c()
for (i in 1:Q){
lc.names <- c(lc.names, paste('class', i, names(init), sep = '.'))
}
names(lc.mean) <- lc.names
# Now we fix pf coefficient = 0 in the second class
lc.mean[c("class.2.pf")] <- 0
start_lc <- c(lc.mean, # Var coefficients
0) #Constant for second class
# Estimate LC with price coefficient held fixed at 0 in class 2
lc <- gmnl(choice ~ asc2 + asc3 + asc4 + pf + cl| 0 | 0 | 0 |1,
data = Electr,
model = "lc",
iterlim = 500,
start = start_lc,
fixed = c(rep(FALSE, 8), TRUE, rep(FALSE, 2)), # note that class.2.pf is fixed at 0
print.level = 3,
print.init = TRUE,
Q = 2)
summary(lc)
########################