--- title: "2.2. Model sculpting and interpretation - bike" date: last-modified editor_options: chunk_output_type: inline --- # Note `model_type` specified below:- 3_model_sculpt_bike.R# Setup and load ```{r} #| output: FALSE #| message: FALSE library (dplyr)library (stringr)source (here:: here ("R/0_setup.R" ))theme_set (theme_bw (base_size = 12 ))<- theme (text = element_text (size = 16 ),legend.position = "inside" ,legend.position.inside = c (0.85 , 0.2 ), legend.background = element_rect (colour = "black" ), legend.title = element_blank ()<- theme (text = element_text (size = 16 ))# Function to check if the model is trained <- function (model_type) {<- file.path (storage_folder, sname (paste0 (model_type, "-fit_final.rds" )))if (file.exists (model_path)) {load_results (sname (paste0 (model_type, "-fit_final.rds" )))else {stop (paste0 ("Model " , model_type, " is not trained for compas, `" ,"` does not exist. " ,"Please train it first with: " ,"`Rscript R/2_train_models.R " , model_type, " compas FALSE`" ))``` ```{r} # set dataset (any with discrete response) <- "bike" # set model_type = "xgb_bayes" # model_type = "xgb" # set nr of features for a polished model <- 7 # util function for storage <- function (x, prefix = dataset) {paste0 (prefix, "-" , x)# load dataset <- define_data (dataset)# load xgb <- load_model_if_trained (model_type)# xgb_fo <- load_model_if_trained("xgb_1_order_bayes") <- load_model_if_trained ("xgb_1_order" )# get product marginals <- sample_marginals (dd$ data$ train[dd$ covariates$ all], n = 1e4 , seed = 1234 )``` # xgb model ## Sculpting ### Main models ```{r} # load sculpted models <- load_results (paste0 (dataset, "-" , model_type, "-sculpt_rough_pm.rds" ))<- load_results (paste0 (dataset, "-" , model_type, "-sculpt_detailed_pm.rds" ))<- load_results (paste0 (dataset, "-" , model_type, "-sculpt_polished_pm.rds" ))``` ### Other sculpting models ```{r} #| output: FALSE # get rough model - on train <- sculpt_rough ($ data$ train[dd$ covariates$ all],seed = 1234 ,model_predict_fun = function (x) {predict (xgb, new_data = x)$ .preddata_as_marginals = TRUE # First order model <- sculpt_rough (seed = 1234 ,model_predict_fun = function (x) {predict (xgb_fo, new_data = x)$ .pred``` ## ICE plots ```{r} <- scale_color_manual (values = c ("ICE Profiles" = "gray60" , "Rough model (with SE)" = "blue" ),labels = c ("ICE Profiles" , "Rough model" ),name = "" <- g_ice (rs_pm, centered = F, show_PDP = F, facet_spec = facet_specification (ncol = 3 ))<- g_ice (rs_pm, centered = T, show_PDP = T, facet_spec = facet_specification (ncol = 3 ))``` ### Rough ```{r} $ continuous + theme_facets``` ```{r} $ discrete``` ### Rough: centered ```{r} #| message: FALSE #| fig-width: 8 #| fig-height: 6 $ continuous + scale_col_update + theme_facets``` ```{r} #| message: FALSE #| fig-width: 8 #| fig-height: 6 $ discrete + scale_col_update + theme_facets``` ### Rough vs direct 1st order ```{r} #| fig-width: 8 #| fig-height: 6 #| fig-show: hold # comparison plot <- g_comparison (sculptures = list (rs_pm, rs_pm_xgb_fo),descriptions = c ("Rough Model" , "Direct Additive XGB" ), facet_spec = facet_specification (ncol = 3 )$ continuous + theme_facets$ discrete``` ### Detailed vs rough ```{r} #| fig-width: 8 #| fig-height: 6 #| fig-show: hold # compare detailed and rough <- g_comparison (sculptures = list (rs_pm, ds_pm),descriptions = c ("Rough Model" , "Detailed Model" ), facet_spec = facet_specification (ncol = 3 )$ continuous + theme_facets$ discrete + theme_facets``` ### Polished vs rough ```{r} #| fig-width: 8 #| fig-height: 6 #| fig-show: hold # compare detailed and rough <- g_comparison (sculptures = list (rs_pm, ps_pm),descriptions = c ("Rough Model" , "Polished Model" ), facet_spec = facet_specification (ncol = 3 )$ continuous + theme_facets$ discrete + theme_facets``` ## Data density ```{r} #| fig-width: 10 #| fig-height: 8 #| fig-show: hold <- g_density_ice_plot_list (ps_pm,$ data$ train,var_names = dd$ covariates$ all,var_labels = dd$ covariates$ labels,task = dd$ task)<- intersect (dd$ covariates$ continuous, names (ps_pm))<- intersect (dd$ covariates$ discrete, names (ps_pm)):: wrap_plots (g_density_plots[cov_cont_ps], ncol = 2 ) :: wrap_plots (g_density_plots[cov_disc_ps], ncol = 2 ) ``` ## Additivity evaluation ```{r} <- predict (xgb, new_data = pm)$ .pred<- predict (xgb, new_data = dd$ data$ train)$ .pred<- predict (rs_pm, pm)<- predict (rs_train, dd$ data$ train)g_additivity (sp = list (p3, p4),lp = list (p1, p2),descriptions = c ("Product Marginals" , "Train Set" )+ labs (x = "Rough Model Predictions" , y = "Strong Learner Predictions" ) + ``` ## Variable importance ### pm ```{r} #| fig-width: 9 #| fig-height: 6 <- g_var_imp (rs_pm, show_pdp_plot = FALSE , textsize = 16 , var_imp_type = "ice" )plot (vi_pm)``` ### train ```{r} #| fig-width: 9 #| fig-height: 6 <- g_var_imp (rs_train, show_pdp_plot = FALSE , textsize = 16 , var_imp_type = "ice" )plot (vi_train)``` ## Calibration ```{r} <- tibble (obs = dd$ data$ holdout[[dd$ response]],xgb = predict (xgb, new_data = dd$ data$ holdout)$ .pred,rm = predict (rs_pm, newdata = dd$ data$ holdout),pm = predict (ps_pm, newdata = dd$ data$ holdout),dir = predict (xgb_fo, new_data = dd$ data$ holdout)$ .pred%>% pivot_longer (cols = - obs,names_to = "Model" ,values_to = "pred" %>% mutate (Model = c ("xgb" = "XGBoost" , "rm" = "Rough Model" ,"pm" = "Polished Model" , "dir" = "Direct Additive XGBoost" Model = factor (levels = c ("XGBoost" , "Rough Model" , "Polished Model" , "Direct Additive XGBoost" <- ggplot (preds_sculptures) + geom_smooth (aes (x = pred, y = obs, colour = Model), se = F, method = "gam" , formula = y~ x) + geom_abline (linetype = "dashed" ) + labs (x = "Prediction" , y = "Truth" ) + theme_bw () + theme (text = element_text (size = 18 ))``` # Compare with linear models ## Load and sculpt ```{r} #| warning: FALSE #| <- load_model_if_trained ("lm_elastic" )<- load_model_if_trained ("lm_lasso" )<- load_model_if_trained ("lm_ridge" )<- define_model (type = "lm" , data_info = dd)<- fit (dm_linm$ workflow, data = dd$ data$ train)<- fit_resamples (dm_linm$ workflow, dd$ cv)``` ```{r} #| warning: FALSE # sculptures on pm from different models <- sculpt_rough (seed = 1234 ,model_predict_fun = function (x) {predict (elastic, new_data = x)$ .pred<- sculpt_rough (seed = 1234 ,model_predict_fun = function (x) {predict (lasso, new_data = x)$ .pred<- sculpt_rough (seed = 1234 ,model_predict_fun = function (x) {predict (ridge, new_data = x)$ .pred<- sculpt_rough (seed = 1234 ,model_predict_fun = function (x) {predict (linm, new_data = x)$ .pred``` ## ICE ```{r} #| fig-width: 8 #| fig-height: 6 #| fig-show: hold #| <- g_comparison (sculptures = list (rs_pm_elastic, rs_pm_lasso, rs_pm_ridge, rs_pm_linm, ps_pm),descriptions = c ("Elastic Net" , "Lasso" , "Ridge" , "Logistic Regression" , "Polished" ),facet_spec = facet_specification (ncol = 3 )$ continuous + theme_facets$ discrete + theme_facets``` ## Calibration ```{r} <- tibble (obs = dd$ data$ holdout[[dd$ response]],xgbPol = predict (ps_pm, newdata = dd$ data$ holdout),linm = predict (rs_pm_linm, newdata = dd$ data$ holdout),elastic = predict (rs_pm_elastic, newdata = dd$ data$ holdout),lasso = predict (rs_pm_lasso, newdata = dd$ data$ holdout),ridge = predict (rs_pm_ridge, newdata = dd$ data$ holdout)%>% pivot_longer (cols = - obs,names_to = "Model" ,values_to = "pred" %>% mutate (Model = c ("xgbPol" = "Polished" , "linm" = "Logistic" , "elastic" = "Elastic Net" , "lasso" = "Lasso" , "ridge" = "Ridge" # calibration plot on holdout based on pm sculptures of different linear models <- ggplot (preds_models) + geom_smooth (aes (x = pred, y = obs, colour = Model), se = F, method = "gam" , formula = y~ x) + geom_abline (linetype = "dashed" ) + labs (x = "Prediction" , y = "Truth" ) + theme_bw () + theme (text = element_text (size = 18 ))``` # Session info ```{r} :: session_info ()``` 
