Skip to content
Snippets Groups Projects
Commit 3bd85a3a authored by nc71qaxa's avatar nc71qaxa
Browse files

new matching models

parent ff117b7f
Branches
No related tags found
No related merge requests found
......@@ -28,21 +28,21 @@ data <- database_full %>%
ungroup()
data <- data %>%
mutate(Choice_Treat = ifelse( Dummy_Video_2 == 1 | Dummy_Info_nv2 == 1, 1,
ifelse(Dummy_no_info==1 ,0,NA)))
ifelse(Dummy_no_info==1 ,0,NA)))
table(data$Choice_Treat)
logit_choice_treat<-glm(Choice_Treat ~ as.factor(Gender)+Z_Mean_NR+Age_mean + QFIncome +
as.factor(Education), data, family=binomial)
summary(logit_choice_treat)
logit_choice_treat_uni<-glm(Choice_Treat ~ as.factor(Gender)+Z_Mean_NR+Age_mean + QFIncome +
Uni_degree + Kids_Dummy + Engagement_ugs + UGS_visits, data, family=binomial)
Uni_degree + Kids_Dummy + Engagement_ugs + UGS_visits, data, family=binomial)
summary(logit_choice_treat_uni)
......@@ -94,6 +94,7 @@ data <- data %>%
# Split the data into labeled and unlabeled sets
labeled_data <- filter(data, Choice_Treat==1| Choice_Treat==0)
unlabeled_data <- filter(data, is.na(Choice_Treat))
labeled_data_id<-labeled_data
labeled_data<-select(labeled_data,-id)
# Assuming the group information is in the column called 'Group'
labeled_data$Choice_Treat<- as.factor(labeled_data$Choice_Treat)
......@@ -120,10 +121,10 @@ tuneGrid <- expand.grid(
model3 <- train(Choice_Treat ~ .,
data = trainData,
method = "xgbTree",
tuneGrid = tuneGrid,
trControl = trainControl(method = "cv", number = 5))
data = trainData,
method = "xgbTree",
tuneGrid = tuneGrid,
trControl = trainControl(method = "cv", number = 5))
# Get variable importance
......@@ -140,6 +141,10 @@ labeled_data$PredictedGroup <- labeled_predictions
table(labeled_data$Choice_Treat, labeled_data$PredictedGroup)
unlabeled_predictions <- predict(model3, newdata = unlabeled_data)
labeled_data_id$PredictedGroup <- labeled_predictions
data_prediction_labeled<-select(labeled_data_id, c("id", "PredictedGroup"))
saveRDS(data_prediction_labeled, "Data/predictions_labeled.RDS")
unlabeled_data$PredictedGroup <- unlabeled_predictions
data_prediction<-select(unlabeled_data, c("id", "PredictedGroup"))
saveRDS(data_prediction, "Data/predictions.RDS")
......@@ -178,9 +183,4 @@ auc_value <- auc(roc_obj)
best_coords <- coords(roc_obj, "best", best.method="youden")
cut_off <- best_coords$threshold
<<<<<<< HEAD
=======
>>>>>>> refs/remotes/origin/main
cut_off <- best_coords$threshold
\ No newline at end of file
#### Apollo standard script #####
library(apollo) # Load apollo package
data_predictions1 <- readRDS("Data/predictions.RDS")
data_predictions2 <- readRDS("Data/predictions_labeled.RDS")
data_predictions <- bind_rows(data_predictions1, data_predictions2)
database <- left_join(database_full, data_predictions, by="id")
database <- database %>%
filter(!is.na(Treatment_new)) %>%
mutate(Dummy_Treated = case_when(Treatment_new == 1|Treatment_new == 2 ~ 1, TRUE ~ 0),
Dummy_Vol_Treated = case_when(Treatment_new == 5 |Treatment_new == 4 ~ 1, TRUE ~ 0),
Dummy_no_info = case_when(Treatment_new == 3 ~ 1, TRUE~0)) %>%
mutate(Dummy_Treated_Pred = case_when(Dummy_Treated == 1 & PredictedGroup == 1 ~1, TRUE~0),
Dummy_Treated_Not_Pred = case_when(Dummy_Treated == 1 & PredictedGroup == 0 ~1, TRUE~0)) %>%
mutate(Dummy_Control_Not_Pred = case_when(Treatment_new == 6 & PredictedGroup == 0 ~1, TRUE~0),
Dummy_Opt_Treat_Pred = case_when(Treatment_A == "Vol_Treated" & PredictedGroup == 1 ~1, TRUE~0),
Dummy_Opt_Treat_Not_Pred = case_when(Treatment_A == "Vol_Treated" & PredictedGroup == 0 ~1, TRUE~0))
#initialize model
apollo_initialise()
### Set core controls
apollo_control = list(
modelName = "MXL_wtp_Prediction matching all complete",
modelDescr = "MXL wtp space Prediction matching all complete",
indivID ="id",
mixing = TRUE,
HB= FALSE,
nCores = n_cores,
outputDirectory = "Estimation_results/mxl/prediction"
)
##### Define model parameters depending on your attributes and model specification! ####
# set values to 0 for conditional logit model
apollo_beta=c(mu_natural = 15,
mu_walking = -1,
mu_rent = -2,
ASC_sq = 0,
mu_ASC_sq_opt_treated_pred = 0,
mu_ASC_sq_opt_treated_not_pred = 0,
mu_ASC_sq_treat_pred = 0,
mu_ASC_sq_treat_not_pred = 0,
mu_ASC_sq_control_not_pred = 0,
mu_nat_opt_treated_pred = 0,
mu_nat_opt_treated_not_pred = 0,
mu_nat_treat_pred = 0,
mu_nat_treat_not_pred = 0,
mu_nat_control_not_pred = 0,
mu_walking_opt_treated_pred = 0,
mu_walking_opt_treated_not_pred = 0,
mu_walking_treat_pred = 0,
mu_walking_treat_not_pred = 0,
mu_walking_control_not_pred = 0,
mu_rent_opt_treated_pred = 0,
mu_rent_opt_treated_not_pred = 0,
mu_rent_treat_pred = 0,
mu_rent_treat_not_pred = 0,
mu_rent_control_not_pred = 0,
sig_natural = 15,
sig_walking = 2,
sig_rent = 2,
sig_ASC_sq = 2)
### specify parameters that should be kept fixed, here = none
apollo_fixed = c()
### Set parameters for generating draws, use 2000 sobol draws
apollo_draws = list(
interDrawsType = "sobol",
interNDraws = n_draws,
interUnifDraws = c(),
interNormDraws = c("draws_natural", "draws_walking", "draws_rent", "draws_asc"),
intraDrawsType = "halton",
intraNDraws = 0,
intraUnifDraws = c(),
intraNormDraws = c()
)
### Create random parameters, define distribution of the parameters
apollo_randCoeff = function(apollo_beta, apollo_inputs){
randcoeff = list()
randcoeff[["b_mu_natural"]] = mu_natural + sig_natural * draws_natural
randcoeff[["b_mu_walking"]] = mu_walking + sig_walking * draws_walking
randcoeff[["b_mu_rent"]] = -exp(mu_rent + sig_rent * draws_rent)
randcoeff[["b_ASC_sq"]] = ASC_sq + sig_ASC_sq * draws_asc
return(randcoeff)
}
### validate
apollo_inputs = apollo_validateInputs()
apollo_probabilities=function(apollo_beta, apollo_inputs, functionality="estimate"){
### Function initialisation: do not change the following three commands
### Attach inputs and detach after function exit
apollo_attach(apollo_beta, apollo_inputs)
on.exit(apollo_detach(apollo_beta, apollo_inputs))
### Create list of probabilities P
P = list()
#### List of utilities (later integrated in mnl_settings below) ####
# Define utility functions here:
V = list()
V[['alt1']] = -(b_mu_rent + mu_rent_opt_treated_pred * Dummy_Opt_Treat_Pred + mu_rent_opt_treated_not_pred * Dummy_Opt_Treat_Not_Pred + mu_rent_treat_pred * Dummy_Treated_Pred +
mu_rent_treat_not_pred * Dummy_Treated_Not_Pred + mu_rent_control_not_pred * Dummy_Control_Not_Pred)*
(b_mu_natural*Naturalness_1 + b_mu_walking*WalkingDistance_1
+ mu_nat_opt_treated_pred * Dummy_Opt_Treat_Pred * Naturalness_1 + mu_nat_opt_treated_not_pred * Dummy_Opt_Treat_Not_Pred * Naturalness_1
+ mu_nat_treat_pred * Dummy_Treated_Pred * Naturalness_1 + mu_nat_treat_not_pred * Dummy_Treated_Not_Pred * Naturalness_1 + mu_nat_control_not_pred * Dummy_Control_Not_Pred * Naturalness_1
+ mu_walking_opt_treated_pred * Dummy_Opt_Treat_Pred * WalkingDistance_1 + mu_walking_opt_treated_not_pred* Dummy_Opt_Treat_Not_Pred * WalkingDistance_1
+ mu_walking_treat_pred * Dummy_Treated_Pred * WalkingDistance_1 + mu_walking_treat_not_pred * Dummy_Treated_Not_Pred * WalkingDistance_1 + mu_walking_control_not_pred * Dummy_Control_Not_Pred * WalkingDistance_1
- Rent_1)
V[['alt2']] = -(b_mu_rent + mu_rent_opt_treated_pred * Dummy_Opt_Treat_Pred + mu_rent_opt_treated_not_pred * Dummy_Opt_Treat_Not_Pred + mu_rent_treat_pred * Dummy_Treated_Pred +
mu_rent_treat_not_pred * Dummy_Treated_Not_Pred + mu_rent_control_not_pred * Dummy_Control_Not_Pred)*
(b_mu_natural*Naturalness_2 + b_mu_walking*WalkingDistance_2
+ mu_nat_opt_treated_pred * Dummy_Opt_Treat_Pred * Naturalness_2 + mu_nat_opt_treated_not_pred * Dummy_Opt_Treat_Not_Pred * Naturalness_2
+ mu_nat_treat_pred * Dummy_Treated_Pred * Naturalness_2 + mu_nat_treat_not_pred * Dummy_Treated_Not_Pred * Naturalness_2 + mu_nat_control_not_pred * Dummy_Control_Not_Pred * Naturalness_2
+ mu_walking_opt_treated_pred * Dummy_Opt_Treat_Pred * WalkingDistance_2 + mu_walking_opt_treated_not_pred* Dummy_Opt_Treat_Not_Pred * WalkingDistance_2
+ mu_walking_treat_pred * Dummy_Treated_Pred * WalkingDistance_2 + mu_walking_treat_not_pred * Dummy_Treated_Not_Pred * WalkingDistance_2 + mu_walking_control_not_pred * Dummy_Control_Not_Pred * WalkingDistance_2
- Rent_2)
V[['alt3']] = -(b_mu_rent + mu_rent_opt_treated_pred * Dummy_Opt_Treat_Pred + mu_rent_opt_treated_not_pred * Dummy_Opt_Treat_Not_Pred + mu_rent_treat_pred * Dummy_Treated_Pred +
mu_rent_treat_not_pred * Dummy_Treated_Not_Pred + mu_rent_control_not_pred * Dummy_Control_Not_Pred)*
(b_mu_natural*Naturalness_3 + b_mu_walking*WalkingDistance_3
+ mu_nat_opt_treated_pred * Dummy_Opt_Treat_Pred * Naturalness_3 + mu_nat_opt_treated_not_pred * Dummy_Opt_Treat_Not_Pred * Naturalness_3
+ mu_nat_treat_pred * Dummy_Treated_Pred * Naturalness_3 + mu_nat_treat_not_pred * Dummy_Treated_Not_Pred * Naturalness_3 + mu_nat_control_not_pred * Dummy_Control_Not_Pred * Naturalness_3
+ mu_walking_opt_treated_pred * Dummy_Opt_Treat_Pred * WalkingDistance_3 + mu_walking_opt_treated_not_pred* Dummy_Opt_Treat_Not_Pred * WalkingDistance_3
+ mu_walking_treat_pred * Dummy_Treated_Pred * WalkingDistance_3 + mu_walking_treat_not_pred * Dummy_Treated_Not_Pred * WalkingDistance_3 + mu_walking_control_not_pred * Dummy_Control_Not_Pred * WalkingDistance_3
+ b_ASC_sq + mu_ASC_sq_opt_treated_pred * Dummy_Opt_Treat_Pred + mu_ASC_sq_opt_treated_not_pred * Dummy_Opt_Treat_Not_Pred
+ mu_ASC_sq_treat_pred * Dummy_Treated_Pred + mu_ASC_sq_treat_not_pred * Dummy_Treated_Not_Pred + mu_ASC_sq_control_not_pred * Dummy_Control_Not_Pred - Rent_3)
### Define settings for MNL model component
mnl_settings = list(
alternatives = c(alt1=1, alt2=2, alt3=3),
avail = 1, # all alternatives are available in every choice
choiceVar = choice,
V = V#, # tell function to use list vector defined above
)
### Compute probabilities using MNL model
P[['model']] = apollo_mnl(mnl_settings, functionality)
### Take product across observation for same individual
P = apollo_panelProd(P, apollo_inputs, functionality)
### Average across inter-individual draws - nur bei Mixed Logit!
P = apollo_avgInterDraws(P, apollo_inputs, functionality)
### Prepare and return outputs of function
P = apollo_prepareProb(P, apollo_inputs, functionality)
return(P)
}
# ################################################################# #
#### MODEL ESTIMATION ##
# ################################################################# #
# estimate model with bfgs algorithm
mxl_wtp_matching_all_complete = apollo_estimate(apollo_beta, apollo_fixed,
apollo_probabilities, apollo_inputs,
estimate_settings=list(maxIterations=400,
estimationRoutine="bfgs",
hessianRoutine="analytic"))
# ################################################################# #
#### MODEL OUTPUTS ##
# ################################################################# #
apollo_saveOutput(mxl_wtp_matching_all_complete)
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment