Добавить коды причины Шепли ко всем наблюдениям ко всем данным

Question

Вот мой код для получения 5 лучших кодов причин Shaply в наборе данных mtcars.

#install.packages("randomForest"); install.packages("tidyverse"); install.packages(""iml)
library(tidyverse); library(iml); library(randomForest) 

set.seed(42)

mtcars1 <- mtcars %>%  mutate(vs = as.factor(vs),
                              id = row_number())

x <- "vs"
y <- paste0(setdiff(setdiff(names(mtcars1), "vs"), "id"), collapse = "+")

rf = randomForest(as.formula(paste0(x, "~ ", y)), data = mtcars1, ntree = 50)

predictor = Predictor$new(rf, data = mtcars1, y = mtcars1$vs)


shapley = Shapley$new(predictor, x.interest = mtcars1[1,])

shapleyresults <- as_tibble(shapley$results) %>% arrange(desc(phi)) %>% slice(1:5) %>% select(feature.value, phi)

1. Как я могу получить коды причин для всех наблюдений (вместо одного за раз во 2-й последней строке в приведенном выше коде: mtcars [1,])?

2. И, добавить / left_join в результаты shapley, используя id для всего набора данных?

   Набор данных будет в 5 раз длиннее. Должны ли мы использовать purrr здесь, чтобы сделать это?

Answer 1

Я нашел решение.

#install.packages("randomForest"); install.packages("tidyverse"); install.packages("iml")
library(tidyverse); library(iml); library(randomForest) 

set.seed(42)

mtcars1 <- mtcars %>%  mutate(vs = as.factor(vs),
                              id = row_number())

x <- "vs"
y <- paste0(setdiff(setdiff(names(mtcars1), "vs"), "id"), collapse = "+")

rf = randomForest(as.formula(paste0(x, "~ ", y)), data = mtcars1, ntree = 50)

predictor <- Predictor$new(rf, data = mtcars1, y = mtcars1$vs)

shapelyresults <- map_dfr(1:nrow(mtcars), ~(Shapley$new(predictor, x.interest = mtcars1[.x,]) %>% 
                                              .$results %>% 
                                              as_tibble() %>% 
                                              arrange(desc(phi)) %>% 
                                              slice(1:5) %>% 
                                              select(feature.value, phi) %>%
                                              mutate(id = .x)))

final_data <- mtcars1 %>% left_join(shapelyresults, by = "id")