Multivariate ordered probit model
Posted: 09 Aug 2025, 20:51
Hello Prof. Hess,
I am trying to estimate a multivariate ordered profit model with three ordered dependent variables - "mail", "collection", and "return". I have set up the problem. I am able to estimate the model and the results (although not final) are reasonable. Please let me know if it is correct.
Further, I also wanted to introduce certain latent variables (named "soc" and "int") into my model. Please take a look at that as well:
Thanks.
Furqan
I am trying to estimate a multivariate ordered profit model with three ordered dependent variables - "mail", "collection", and "return". I have set up the problem. I am able to estimate the model and the results (although not final) are reasonable. Please let me know if it is correct.
Code: Select all
### Initialise
rm(list = ls())
library(apollo)
### Load data
database <- read.csv(file.choose())
apollo_initialise()
apollo_control = list(
modelName ="OP_test",
nCores = 8,
indivID ="S.No.",
mixing=TRUE)
### Set up starting values for parameters to estimate
apollo_beta <- c(
beta_age_mail = 0,
beta_age_collection = 0,
beta_age_return = 0,
beta_gender_mail = 0,
beta_gender_collection = 0,
beta_gender_return = 0,
# break points for ordered variables
tau_mail_1 = -2,
tau_mail_2 = -1,
tau_mail_3 = 1,
tau_mail_4 = 2,
tau_collection_1 = -2,
tau_collection_2 = -1,
tau_collection_3 = 1,
tau_collection_4 = 2,
tau_return_1 = -2,
tau_return_2 = -1,
tau_return_3 = 1,
tau_return_4 = 2,
# Components of choleski decomposition
Ch11 = 1, Ch12 = 0, Ch13 = 0,
Ch22 = 1, Ch23 = 0, Ch33 = 1)
# Fixed parameters, to force identification.
apollo_fixed <- c("tau_mail_1", "tau_collection_1", "tau_return_1")
# Set up the form of the maximum simulated likelihood
apollo_draws <- list(
interDrawsType = "halton",
interNDraws = 500,
interNormDraws = c("eta_mail", "eta_collection", "eta_return")
)
# Set up random coefficients definitions
apollo_randCoeff <- function(apollo_beta, apollo_inputs) {
randcoef <- list()
## To introduce correlations across utilties
randcoef[['ec1']] <- eta_mail*Ch11 + eta_collection*Ch12 + eta_return*Ch13
randcoef[['ec2']] <- eta_collection*Ch22 + eta_return*Ch23
randcoef[['ec3']] <- eta_return*Ch33
return(randcoef)
}
### Group and validate input
apollo_inputs <- apollo_validateInputs()
### Set up the probabilities for the choices.
apollo_probabilities <- function(apollo_beta,
apollo_inputs,
functionality ="estimate") {
### Attach inputs and detach after function exit
apollo_attach (apollo_beta, apollo_inputs)
on.exit(apollo_detach(apollo_beta, apollo_inputs))
### Create list for probabilities
P <- list()
### Likelihood of choosing future
op_settings_mail <- list(outcomeOrdered = mailOrd,
V = beta_age_mail*age + beta_gender_mail*gender + ec1,
tau = c(tau_mail_1, tau_mail_2, tau_mail_3, tau_mail_4),
coding = 1:5)
op_settings_collection <- list(outcomeOrdered = collectionOrd,
V = beta_age_collection*age + beta_gender_collection*gender + ec2,
tau = c(tau_collection_1, tau_collection_2, tau_collection_3, tau_collection_4),
coding = 1:5)
op_settings_return <- list(outcomeOrdered = returnOrd,
V = beta_age_return*age + beta_gender_return*gender + ec3,
tau = c(tau_return_1, tau_return_2, tau_return_3, tau_return_4),
coding = 1:5)
P[['mail']] <- apollo_op(op_settings_mail, functionality)
P[['collection']] <- apollo_op(op_settings_collection, functionality)
P[['return']] <- apollo_op(op_settings_return, functionality)
#
### Likelihood of the whole model
P <- apollo_combineModels(P, apollo_inputs, functionality)
### Take product across observation for same individual
# P <- apollo_panelProd(P, apollo_inputs, functionality)
### Average across inter-individual draws
P <- apollo_avgInterDraws(P, apollo_inputs, functionality)
### Prepare and return outputs of function
P <- apollo_prepareProb(P, apollo_inputs, functionality)
return(P)
}
L <- apollo_probabilities(apollo_beta, apollo_inputs)
model = apollo_estimate(apollo_beta, apollo_fixed,
apollo_probabilities, apollo_inputs,
estimate_settings=list(writeIter=FALSE))
apollo_modelOutput(model)
Code: Select all
### Initialise
rm(list = ls())
library(apollo)
### Load data
database <- read.csv(file.choose())
apollo_initialise()
apollo_control = list(
modelName ="OP_With_Latent_Variables_test",
nCores = 8,
indivID ="S.No.",
mixing=TRUE)
### Set up starting values for parameters to estimate
apollo_beta <- c(
beta_age_mail = 0,
beta_age_collection = 0,
beta_age_return = 0,
beta_gender_mail = 0,
beta_gender_collection = 0,
beta_gender_return = 0,
## Latent Variables
gamma_age_soc = 0,
gamma_gender_soc = 0,
gamma_age_int = 0,
gamma_gender_int = 0,
lambda_soc = 0,
sigma_eta_soc =-1,
zeta_soc_1 = 1,
zeta_soc_2 = 1,
zeta_soc_3 = 1,
tau_soc_1_1 = 0,
tau_soc_1_2 = 1,
tau_soc_1_3 = 3,
tau_soc_1_4 = 6,
tau_soc_2_1 = 0,
tau_soc_2_2 = 1,
tau_soc_2_3 = 3,
tau_soc_2_4 = 6,
tau_soc_3_1 = 0,
tau_soc_3_2 = 1,
tau_soc_3_3 = 3,
tau_soc_3_4 = 6,
lambda_int = 0,
sigma_eta_int =-1,
zeta_int_1 = 1,
zeta_int_2 = 1,
zeta_int_3 = 1,
tau_int_1_1 = 0,
tau_int_1_2 = 1,
tau_int_1_3 = 3,
tau_int_1_4 = 6,
tau_int_2_1 = 0,
tau_int_2_2 = 1,
tau_int_2_3 = 3,
tau_int_2_4 = 6,
tau_int_3_1 = 0,
tau_int_3_2 = 1,
tau_int_3_3 = 3,
tau_int_3_4 = 6,
# break points for ordered variables
tau_mail_1 = -2,
tau_mail_2 = -1,
tau_mail_3 = 1,
tau_mail_4 = 2,
tau_collection_1 = -2,
tau_collection_2 = -1,
tau_collection_3 = 1,
tau_collection_4 = 2,
tau_return_1 = -2,
tau_return_2 = -1,
tau_return_3 = 1,
tau_return_4 = 2,
# gamma_mail_0 = 0,
# gamma_collection_0 = 0,
# gamma_return_0 = 0,
# Components of choleski decomposition
Ch11 = 1, Ch12 = 0, Ch13 = 0,
Ch22 = 1, Ch23 = 0, Ch33 = 1)
# Fixed parameters, to force identification.
apollo_fixed <- c("tau_mail_1", "tau_collection_1", "tau_return_1", "zeta_soc_1", "zeta_int_1")
# Set up the form of the maximum simulated likelihood
apollo_draws <- list(
interDrawsType = "halton",
interNDraws = 500,
interNormDraws = c("eta_mail", "eta_collection", "eta_return", "eta_soc", "eta_int")
)
# Set up random coefficients definitions
apollo_randCoeff <- function(apollo_beta, apollo_inputs) {
randcoef <- list()
randcoef[['ec1']] <- eta_mail*Ch11 + eta_collection*Ch12 + eta_return*Ch13
randcoef[['ec2']] <- eta_collection*Ch22 + eta_return*Ch23
randcoef[['ec3']] <- eta_return*Ch33
randcoef[["LV_soc"]] <- gamma_age_soc*age + gamma_gender_soc*gender + sigma_eta_soc*eta_soc
randcoef[["LV_int"]] <- gamma_age_int*age + gamma_gender_int*gender + sigma_eta_int*eta_int
return(randcoef)
}
### Group and validate input
apollo_inputs <- apollo_validateInputs()
### Set up the probabilities for the choices.
apollo_probabilities <- function(apollo_beta,
apollo_inputs,
functionality ="estimate") {
### Attach inputs and detach after function exit
apollo_attach (apollo_beta, apollo_inputs)
on.exit(apollo_detach(apollo_beta, apollo_inputs))
### Create list for probabilities
P <- list()
### Likelihood of indicators
ol_settings1 = list(outcomeOrdered = soc1,
V = zeta_soc_1*LV_soc,
tau = list(tau_soc_1_1, tau_soc_1_2, tau_soc_1_3, tau_soc_1_4),
componentName = "indic_soc_1")
ol_settings2 = list(outcomeOrdered = soc2,
V = zeta_soc_2*LV_soc,
tau = list(tau_soc_2_1, tau_soc_2_2, tau_soc_2_3, tau_soc_2_4),
componentName = "indic_soc_2")
ol_settings3 = list(outcomeOrdered = soc3,
V = zeta_soc_3*LV_soc,
tau = list(tau_soc_3_1, tau_soc_3_2, tau_soc_3_3, tau_soc_3_4),
componentName = "indic_soc_3")
ol_settings4 = list(outcomeOrdered = int1,
V = zeta_int_1*LV_int,
tau = list(tau_int_1_1, tau_int_1_2, tau_int_1_3, tau_int_1_4),
componentName = "indic_int_1")
ol_settings5 = list(outcomeOrdered = int2,
V = zeta_int_2*LV_int,
tau = list(tau_int_2_1, tau_int_2_2, tau_int_2_3, tau_int_2_4),
componentName = "indic_int_2")
ol_settings6 = list(outcomeOrdered = int3,
V = zeta_int_3*LV_int,
tau = list(tau_int_3_1, tau_int_3_2, tau_int_3_3, tau_int_3_4),
componentName = "indic_int_3")
P[["indic_soc_1"]] = apollo_ol(ol_settings1, functionality)
P[["indic_soc_2"]] = apollo_ol(ol_settings2, functionality)
P[["indic_soc_3"]] = apollo_ol(ol_settings3, functionality)
P[["indic_int_1"]] = apollo_ol(ol_settings4, functionality)
P[["indic_int_2"]] = apollo_ol(ol_settings5, functionality)
P[["indic_int_3"]] = apollo_ol(ol_settings6, functionality)
### Likelihood of choosing future
op_settings_mail <- list(outcomeOrdered = mailOrd,
V = beta_age_mail*age + beta_gender_mail*gender + lambda_soc*LV_soc + lambda_int*LV_int + ec1,
tau = c(tau_mail_1, tau_mail_2, tau_mail_3, tau_mail_4),
coding = 1:5)
op_settings_collection <- list(outcomeOrdered = collectionOrd,
V = beta_age_collection*age + beta_gender_collection*gender + lambda_soc*LV_soc + lambda_int*LV_int + ec2,
tau = c(tau_collection_1, tau_collection_2, tau_collection_3, tau_collection_4),
coding = 1:5)
op_settings_return <- list(outcomeOrdered = returnOrd,
V = beta_age_return*age + beta_gender_return*gender + lambda_soc*LV_soc + lambda_int*LV_int + ec3,
tau = c(tau_return_1, tau_return_2, tau_return_3, tau_return_4),
coding = 1:5)
P[['mail']] <- apollo_op(op_settings_mail, functionality)
P[['collection']] <- apollo_op(op_settings_collection, functionality)
P[['return']] <- apollo_op(op_settings_return, functionality)
#
### Likelihood of the whole model
P <- apollo_combineModels(P, apollo_inputs, functionality)
### Take product across observation for same individual
# P <- apollo_panelProd(P, apollo_inputs, functionality)
### Average across inter-individual draws
P <- apollo_avgInterDraws(P, apollo_inputs, functionality)
### Prepare and return outputs of function
P <- apollo_prepareProb(P, apollo_inputs, functionality)
return(P)
}
L <- apollo_probabilities(apollo_beta, apollo_inputs)
model = apollo_estimate(apollo_beta, apollo_fixed,
apollo_probabilities, apollo_inputs,
estimate_settings=list(writeIter=FALSE))
apollo_modelOutput(model)
Furqan