imap_dfr a function to 3 lists with nested maps? - r

Question

I have this code which works for list [[1]] and list of list [[200]]:
SHAP_Prep_data <- shap.prep(xgb_model = xgb.mod[[1]][[200]],
shap_contrib = shap_values_results[[1]][[200]]$shap_score %>% select(-BIAS0),
X_train = as.matrix(TrainTestData[[1]]$XTrain[[200]])
#top_n = 4
)
I can simply replace out the [[200]] for [[300]], [[400]] etc. and obtain a new data structure (the shap.prep function comes from the shapforxgboost package.
xgb.mod[[1]][[200]] is a single xgboost model
shap_values_results[[1]][[200]]$shap_score %>% select(-BIAS0) is a data frame with the following structure.
> str(shap_values_results[[1]][[200]]$shap_score %>% select(-BIAS0))
'data.frame': 2190 obs. of 29 variables:
$ holiday : num -0.276 -0.347 -0.284 -0.356 -0.197 ...
$ temp : num 0.35 0.25 0.144 0.227 0.16 ...
$ wind : num -0.116 -0.187 -0.25 -0.265 -0.135 ...
$ humidity : num -0.021 0.0125 -0.037 0.016 -0.0196 ...
$ barometer : num -0.0191742 -0.0000462 0.0444956 -0.0148842 -0.0551703 ...
$ weekday : num -0.00421 -0.00937 0.0012 -0.01194 -0.00931 ...
$ weekend : num 0 0 0 0 0 0 0 0 0 0 ...
$ workday_on_holiday : num -0.00949 -0.00949 -0.00885 -0.00949 -0.00885 ...
$ weekend_on_holiday : num 0 0 0 0 0 0 0 0 0 0 ...
$ protocol_active : num 0 0 0 0 0 0 0 0 0 0 ...
$ text_fog : num 0.00714 0.00714 0.00783 0.00783 0.00772 ...
$ text_light_rain : num -0.000364 -0.000364 -0.000364 -0.000364 -0.000364 ...
$ text_mostly_cloudy : num -0.0013 -0.0013 -0.0013 -0.0013 -0.0013 ...
$ text_passing_clouds : num 0.00135 0.00152 0.00363 0.00152 0.00345 ...
$ text_rain : num -0.0000682 -0.0000682 -0.0000682 -0.0000682 -0.0000682 ...
$ text_scattered_clouds: num -0.0941 -0.0832 -0.1497 -0.0813 -0.0965 ...
$ text_sunny : num 0.000635 0.007435 0.009286 0.007435 0.007009 ...
$ month_1 : num 0.045 0.0503 0.062 0.062 0.0484 ...
$ month_2 : num 0.0602 0.0529 0.0526 0.0529 0.1008 ...
$ month_3 : num 0.0467 0.0348 0.0333 0.0348 0.0467 ...
$ month_4 : num -0.03439 -0.03439 -0.00777 -0.03439 -0.00164 ...
$ month_5 : num -0.02191 -0.02191 -0.00836 -0.02026 -0.01533 ...
$ month_6 : num -0.05498 -0.00637 -0.04769 -0.05101 -0.05155 ...
$ month_7 : num -0.1302 -0.1126 -0.0878 -0.0963 -0.1535 ...
$ month_8 : num -0.0418 -0.051 -0.0727 -0.0437 -0.0957 ...
$ month_9 : num 0.164 0.185 0.141 0.193 0.122 ...
$ month_10 : num 0.206 0.251 0.243 0.251 0.211 ...
$ month_11 : num 0.0929 0.0744 0.0302 0.0568 0.0961 ...
$ month_12 : num 0.059 0.0608 0.0806 0.0608 0.0788 ...
Finally as.matrix(TrainTestData[[1]]$XTrain[[200]]) is a dgcMatrix which I convert to a simple matrix using as.matrix() which has structure:
> str(as.matrix(TrainTestData[[1]]$XTrain[[200]]))
num [1:2190, 1:29] 0 0 0 0 0 0 0 0 0 0 ...
- attr(*, "dimnames")=List of 2
..$ : NULL
..$ : chr [1:29] "holiday" "temp" "wind" "humidity" ...
I have 3 pieces of data I would like to apply the shap.prep function to.
The desired output would be to have a list (or list of lists) where the shap.prep function has been applied. The function requires 3 inputs shap.prep(xgb_model = NULL, shap_contrib = NULL, X_train,
top_n = NULL) which is what I am providing.
How can I use imap correctly to pass all three objects to the shap_prep function and obtain lists as my output?
It's difficult for me to give some dput() data since the I am not sure if its possible to dput() a trained XGBoost model.
EDIT:
I am adding the closest thing I can get to a reproducible example.
data(iris)
df <- split(iris, iris$Species) # I just want to create some lists here
library(xgboost)
library(SHAPforxgboost)
dtrainFunction <- function(i){
dt = xgb.DMatrix(data = data.matrix(i[, c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width")]), label = i$Species)
}
dtrain <- map(df, dtrainFunction) # I just apply the dtrainFunction which just puts each list into an xgb.DMatrix
xgb.mod <- map(dtrain, ~xgboost(data = .x, nround = 20)) # Apply the xgboost model to each list
# could not get this part of the code to work but it's not important. I manually put the results into a list below.
# shap_values_function <- function(j){
# map2(
# .x = xgb.mod[[j]],
# .y = df[[j]][, c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width")],
# ~shap.values(xgb_model = .x, X_train = as.matrix(.y))
# )
# }
#
# shap_values_results <- lapply(seq(1:3), shap_values_function)
# Here I manually put the results into a list which are lists of shap.values
shap_values_results <- list(
shap.values(xgb_model = xgb.mod[[1]], X_train = as.matrix(df[[1]][, c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width")])),
shap.values(xgb_model = xgb.mod[[2]], X_train = as.matrix(df[[2]][, c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width")])),
shap.values(xgb_model = xgb.mod[[3]], X_train = as.matrix(df[[3]][, c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width")]))
)
# Something is wrong here which is something to do with shap_contrib and BIAS0
SHAP_Prep_data <- shap.prep(xgb_model = xgb.mod[[1]],
shap_contrib = shap_values_results[[1]]$shap_score[, c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width")],
X_train = as.matrix(df[[1]])
#top_n = 4
)
shap.plot.summary(data_long = SHAP_Prep_data)
My actual code for the SHAP_Prep_data data is slightly different to the one above since I have list of lists.
EDIT 2:
I have tried the following which throws an error:
SHAP_Prep_data <- pmap(
list(
.x = xgb.model[[1]],
.y = shap_values_results[[1]],
.z = TrainTestData[[1]]$XTrain
), ~shap.prep(
xgb_model = .x,
shap_contrib = .y,
X_train = as.matrix(.z))
)
Error in as.matrix(.z) : object '.z' not found
EDIT 3:
When I apply the function on the iris data example:
SHAP_Prep_data <- pmap(
list(
.x = xgb.mod,
.y = shap_values_results,
.z = dtrain
), ~shap.prep(
xgb_model = .x,
shap_contrib = .y,
X_train = as.matrix(.z))
)
Error in as.matrix(.z) : object '.z' not found
EDIT 4:
I want to be able to access the $shap_score data which is created from the shap.values function used earlier (and also remove the column BIAS0 in the data from the following line).
shap_contrib = shap_values_results[[1]][[1300]]$shap_score %>% select(-BIAS0)
So would another map be needed here? or should I extract the shap_score data earlier in the function and remove the BIAS0 column there so that I can just call NEWDATA_shap_score[[1]][[1300]]?

Answer 1

The issue is that
str(as.matrix(df[[1]]))
#chr [1:50, 1:5] "5.1" "4.9" "4.7" "4.6" "5.0" "5.4" "4.6" "5.0" "4.4" "4.9" "5.4" "4.8" "4.8" "4.3" "5.8" "5.7" "5.4" "5.1" "5.7" "5.1" ...
# - attr(*, "dimnames")=List of 2
# ..$ : chr [1:50] "1" "2" "3" "4" ...
# ..$ : chr [1:5] "Sepal.Length" "Sepal.Width" "Petal.Length" "Petal.Width" ...
returns a character matrix as the last column is a character column. Remove the last column and then do the conversion
out <- shap.prep(xgb_model = xgb.mod[[1]],
shap_contrib = shap_values_results[[1]]$shap_score[,
c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width")],
X_train = as.matrix(df[[1]][-5]) ###
#top_n = 4
)
Regarding using this with pmap
out2 <- pmap(list( xgb.model[[1]],
shap_values_results[[1]],
TrainTestData[[1]]$XTrain),
~shap.prep(
xgb_model = ..1,
shap_contrib = ..2$shap_score %>% select(-BIAS0),
X_train = as.matrix(..3)))
If we also want to apply this on the list of lists
pmap(list(xgb.model,
shap_values_results,
TrainTestData), ~
pmap(list(..1, ..2, ..3$xTrain), ~
shap.prep(xgb_model = ..1,
shap_contrib = ..2$shap_score %>% select(-BIAS0),
X_train = as.matrix(..3))))

Answer 2

It's hard to say without a reproducible example, but it sounds like you want pmap rather than imap
a <- list(letters[1:3])
b <- list(letters[4:6])
c <- list(letters[7:9])
purrr::pmap(list(a,b,c), function (x,y,z) paste(x, y, z))
#> [[1]]
#> [1] "a d g" "b e h" "c f i"
Created on 2020-01-08 by the reprex package (v0.3.0)