Douăzeci de întrebări și arbori de decizie

Cei mai mulți dintre noi au jucat probabil jocul Twenty Questions. Cel care răspunde alege ceva, iar ceilalți jucători încearcă să ghicească punând întrebări da sau nu. Emisiunea TV „What’s My Line” este un exemplu în acest sens, în care jucătorii încearcă să ghicească ocupația unui concurent.

Spre deosebire de încercările copiilor mei, strategia ar trebui să fie să pun întrebări care să împartă posibilitățile rămase aproximativ în jumătate de fiecare dată.

Acest lucru pare foarte asemănător cu un arbore de decizie de învățare automată, deși cu o distincție interesantă.

Un arbore de decizie trișează. Algoritmul arborelui de decizie cunoaște răspunsul (df$target = 1). Algoritmul încearcă să găsească cea mai bună caracteristică și valoarea împărțită pentru a separa df$target = 1 de df$target = 0 la fiecare nod, dar trebuie să cunoască răspunsul corect pentru a pune cele mai bune întrebări. Acesta este motivul pentru care, dacă jocul este jucat, să zicem cu diferiți președinți ai SUA de mai multe ori, algoritmul poate alege diferite caracteristici și poate împărți valori.

Cu toate acestea, m-am gândit că ar fi distractiv să programez un model de arbore de decizie cu președinții SUA. Am găsit câteva date despre președinți. Am decis că unele variabile aveau prea multe valori (cardinalitate mare – erau multe nume de partide politice în anii 1800), așa că am grupat câteva valori pentru a reduce numărul de valori unice.

Am început inițial cu un număr întreg aleatoriu între 1 și 47 pentru a selecta un președinte, care l-a ales pe președintele Hoover, dar am descoperit că un alt președinte va crea un arbore mai apropiat de întrebările pe care le-aș fi pus dacă aș fi fost un jucător. Așa că l-am ales pe președintele Reagan pentru a obține un copac mai interesant.

(M-am gândit să-l selectez pe președintele Garfield pentru a putea pune întrebarea „Președintelui este creditat cu o dovadă unică a Teoremei lui Pitagora?”, dar am decis că este puțin ciudat, chiar și pentru mine.)

Iată arborele rezultat pentru președintele Reagan:

Iată graficul de importanță variabilă rezultat. Rețineți că variabilele nu sunt în aceeași ordine cu împărțirile arborelui. Înțeleg că importanța variabilei se bazează pe unele dintre îmbunătățirile din toate nodurile în care variabila a fost folosită ca divizor.

Iată codul meu R:

library(dplyr)
library(rpart)
library(rpart.plot)
library(ggplot2)
df <- read.csv("prez.csv", header=TRUE)   
# data file available at github:  
prez.csv
set.seed(123)
# r <- sample(1:nrow(df),1)
r <- 40   # deliberate choice to get longer tree
answer <- df$LastName(r)
print(paste("The target president is:", answer))
df$target <- rep(0, nrow(df))
df$target(r) <- 1

# Feature engineering:
df <- df %>%
  # A. Categorical Reduction
  mutate(
    Party = case_when(
        Party %in% c("Democratic") ~ "Democratic", 
        Party %in% c("Republican") ~ "Republican", 
        TRUE ~ "Other"),
    Occupation = case_when(
        Occupation %in% c("Businessman", "Lawyer") ~ Occupation, 
        TRUE ~ "Other"),
    State = case_when(
        State %in% c("New York") ~ "NY", 
        State %in% c("Ohio") ~ "OH", 
        State %in% c("Virginia") ~ "VA", 
        State %in% c("Massachusetts") ~ "MA", 
        State %in% c("Texas") ~ "TX", TRUE ~ "Other"),
    Religion = case_when(
        Religion %in% c("Episcopalian", "Presbyterian", "Unitarian", "Baptist", "Methodist") ~ "Main_Prot", 
        TRUE ~ "Other"),
    
    # B. Year/Century Binning using cut()
    DOB = cut(DOB, breaks = c(-Inf, 1800, 1900, 2000, Inf), 
        labels = c("18th century", "19th century", "20th century", "21st century"), right = FALSE),
    DOD = cut(DOD, breaks = c(-Inf, 1800, 1900, 2000, Inf), 
        labels = c("18th century", "19th century", "20th century", "21st century"), right = FALSE),
    Began = cut(Began, breaks = c(-Inf, 1800, 1900, 2000, Inf), 
        labels = c("18th century", "19th century", "20th century", "21st century"), right = FALSE),
    Ended = cut(Ended, breaks = c(-Inf, 1800, 1900, 2000, Inf), 
        labels = c("18th century", "19th century", "20th century", "21st century"), right = FALSE)
  ) %>%

  # C. Convert all new/existing binary/categorical variables to factor
  mutate_at(vars(Party, State, Occupation, Religion, Assassinated, Military, Terms_GT_1, Pres_During_War, Was_Veep, DOB, DOD, Began, Ended), as.factor)


# selected variables 
formula <- as.formula(target ~ Began + State + Party + Occupation + Pres_During_War)
# Using aggressive control settings to force a maximal, unpruned tree
prez_tree <- rpart(formula, data = df, method = "class",
                   control = rpart.control(cp = 0.001, minsplit = 2, minbucket = 1))
rpart.plot(prez_tree, type = 4, extra = 101, main = "President Twenty Questions")

# check Reagan
df %>% filter(Began == "20th century" & 
              !State %in% c("MA", "NY", "OH", "TX") &
              Party == "Republican" &
              !Occupation %in% c( "Businessman", "Lawyer"))

variable_importance <- prez_tree$variable.importance
importance_df <- data.frame(
  Variable = names(variable_importance),
  Importance = variable_importance
)

importance_df <- importance_df(order(importance_df$Importance, decreasing = TRUE), )

common_theme <- theme(
        legend.position="NULL",
        plot.title = element_text(size=15, face="bold"),
        plot.subtitle = element_text(size=12.5, face="bold"),
        axis.title = element_text(size=15, face="bold"),
        axis.text = element_text(size=15, face="bold"),
        legend.title = element_text(size=15, face="bold"),
        legend.text = element_text(size=15, face="bold"))


ggplot(importance_df, aes(x = factor(Variable, levels = rev(Variable)), y = Importance)) +
  geom_col(aes(fill = Variable)) + 
  coord_flip() +
  labs(title = "20 Questions Variable Importance",
       x = "Variable",
       y = "Mean Decrease Gini") +
  common_theme

# loop through all presidents to see different first split vars
library(purrr)

### 1. Define the Analysis Function ###
# The function is modified to return a data frame row for clarity
get_first_split_row <- function(df, r) {
  # Temporarily set the target for the current president
  df$target <- 0
  df$target(r) <- 1
  tree <- rpart(formula, data = df, method = "class",
                control = rpart.control(cp = 0.001, minsplit = 2, minbucket = 1))
  frame <- tree$frame
  
  # Determine the result
  if (nrow(frame) > 1) {
    first_split_var <- as.character(frame$var(1))
  } else {
    first_split_var <- "No split"
  }
  
  # Return a single-row data frame
  return(data.frame(
    President = df$LastName(r),
    First_Split_Variable = first_split_var
  ))
}

### 2. Run the Analysis and Combine Results ###
# Create a list of row indices to iterate over
indices_to_run <- 1:nrow(df)

# Use map_dfr to apply the function to every index and combine the results 
# into a single data frame (dfr = data frame row bind)
first_split_results_df <- map_dfr(indices_to_run, ~ get_first_split_row(df, .x))

### 3. Display the Table and Original Analysis ###
# Display the resulting table:
print(first_split_results_df)

print(table(first_split_results_df$First_Split_Variable))
  
  

Sfârşit