abichat / evabic Goto Github PK

library(evabic)
library(magrittr)

set.seed(1)
n <- 10000
fake_data <- data.frame(name        = paste("species", 1:n, sep = "_"), 
                        value       = (1:n)/n, 
                        true_status = sample(c(T, F), size = n, replace = T))

## Appel à ebc_tidy_by_threshold pour calculer l'AUC (rapide jusqu'à n = 1000)
tictoc::tic()
run_1 <- ebc_tidy_by_threshold(detection_values = with(fake_data, setNames(value, name)), 
                              true              = with(fake_data, name[true_status]), 
                              all               = with(fake_data, name),
                              measures          = c('TPR', "FPR", "FDR"), 
                              direction         = "<=")
tictoc::toc() ## 49.75 s

## méthode directe sans passer par ebc_tidy
## Prototypée uniquement pour direction = "<" et measures = c('TPR', "FPR", "FDR") mais s'adapte facilement aux autres cas
## Par flemme, j'utilise quelques fonctions de dplyr mais ce n'est pas strictement nécessaire et je ne reprend pas le préprocessing
my_ebc_tidy_by_threshold <- function(detection_values, true, all) {
  N <- length(detection_values)
  N_true <- length(true)
  d <- data.frame(
    ID        = names(detection_values), 
    threshold = detection_values, 
    status    = names(detection_values) %in% true
  ) %>% 
    ## Sort the data to compute TP / FP / FN / TN iteratively
    dplyr::arrange(threshold)  %>% ## desc(threshold) si direction = ">" ou ">!"
    dplyr::mutate(TP  = cumsum(status),          ## Number of TP when using the current threshold, ajouter -1 si direction = "<" au lieu de "<="
                  FP  = 1:N - TP,                ## Number of FP when using the current threshold
                  FN  = N_true - TP,             ## Number of FN when using the current threshold
                  TN  = N - TP - FP - FN,        ## Number of TN when using the current threshold
                  FDR = FP / pmax((FP + TP), 1),
                  TPR = TP / (TP + FN),          ## Recall / sensitivity
                  FPR = FP / (TN + FP)           ## 1 - specificity
    )
  ## Rajouter du code si on demande d'autres mesures
  ## Remove rows corresponding to duplicate scores by keeping only the last one (use rev twice to keep last one instead of first one)
  rows_to_exclude <- d$threshold %>% rev() %>% duplicated() %>% rev()
  d <- d[!rows_to_exclude, ]
  d
}

tictoc::tic()
run_2 <- my_ebc_tidy_by_threshold(detection_values = with(fake_data, setNames(value, name)), 
                                  true              = with(fake_data, name[true_status]), 
                                  all               = with(fake_data, name))
tictoc::toc() # 0.043 s

library(evabic)
ebc_tidy(detected = c(T, T, F), true = c(T, F, T), all = letters[1:3])

function (x, all) 
{
    if (is.logical(x)) {
        if (!is.null(names(x))) {
        return(names(x)[x])
        } else {
        return(all[x]) ## Assumes all and x elements are in the same order but without name information, that's reasonable
       }
    }
    else {
        return(x)
    }
}