Metric simulations

1 Setup

suppressPackageStartupMessages(library(tidyverse))
suppressPackageStartupMessages(library(tidymodels)) # for the recipes package, along with the rest of tidymodels
tidymodels_prefer()

2 Precision / Recall / F1 for multiclass

n_permutations <- 1000
n_samples_per_class <- 2
n_classes <- 160
truth <- rep(seq(1, n_classes), n_samples_per_class)
truth_fac <- as.factor(truth)

metrics_random <-
  map_df(1:n_permutations,
         function(i) {
           estimate <- sample(truth)
           
           estimate_fac <- as.factor(estimate)
           
           tibble(
             recall =  recall_vec(
               truth = truth_fac,
               estimate = estimate_fac,
               event_level = "second"
             ),
             
             precision =  precision_vec(
               truth = truth_fac,
               estimate = estimate_fac,
               event_level = "second"
             ),
             
             f_meas =  f_meas_vec(
               truth = truth_fac,
               estimate = estimate_fac,
               event_level = "second"
             )
             
           )
         })

metrics_random %>%
  pivot_longer(everything(), names_to = "metric") %>%
  ggplot(aes(value)) +
  geom_histogram(bins = 30) +
  facet_wrap(~ metric) +
  theme_bw()

metrics_random %>%
  pivot_longer(everything(), names_to = "metric") %>%
  ggplot(aes(metric, value)) +
  geom_boxplot() +
  theme_bw()

metrics_random %>%
  summarize(across(everything(),
                   list(mean = mean, sd = sd))) %>%
  pivot_longer(everything())

3 Average Precision for two-class

n_permutations <- 1000
n_samples <- 100
n_samples_class_min <- 3
n_samples_class_max <- 30

metrics_random <-
  map_df(n_samples_class_min:n_samples_class_max,
         
         function(n_samples_class) {
           truth <-
             c(rep(TRUE, n_samples_class),
               rep(FALSE, n_samples - n_samples_class))
           
           truth_fac <- as.factor(truth)
           
           map_df(1:n_permutations,
                  function(i) {
                    estimate <- runif(length(truth))
                    
                    threshold <-
                      sort(estimate,
                           partial = n_samples - n_samples_class + 1)[n_samples - n_samples_class + 1]
                    
                    estimate_fac <- estimate >= threshold
                    
                    stopifnot(sum(estimate_fac) == n_samples_class)
                    
                    estimate_fac <- as.factor(estimate_fac)
                    
                    tibble(
                      average_precision =  average_precision_vec(
                        truth = truth_fac,
                        estimate = estimate,
                        event_level = "second"
                      ),
                      precision_at_r =  precision_vec(
                        truth = truth_fac,
                        estimate = estimate_fac,
                        event_level = "second"
                      ),
                      
                    )
                  }) %>%
             mutate(n_samples_class = n_samples_class)
         })

metrics_random %>%
  pivot_longer(-n_samples_class, names_to = "metric") %>%
  ggplot(aes(as.factor(n_samples_class), value)) +
  geom_boxplot() +
  facet_wrap(~ metric) +
  theme_bw()

metrics_random %>%
  group_by(n_samples_class) %>%
  summarize(across(everything(),
                   list(mean = mean, sd = sd)))