comparison sampling/simulations.R @ 0:205974c9568c tip

Initial commit. Predictions not included for lack of space.

+filter_set <- function(set, ref_set){
+    
+  excerpts <- set %>%
+    inner_join(get_excerpts_artists(), by = c("ex_id"))
+  
+  artists <- get_artists(ref_set$ex_id, unique_artists = T)
+  
+  ex_ids <- excerpts %>% 
+    group_by(ex_id) %>% 
+    filter(any(artist_id %in% artists)) %>% 
+    select(ex_id) %>%
+    unique() %>%
+    unlist()
+    
+  excerpts %>% filter(! ex_id %in% ex_ids) %>% select(-artist_id)
+  
+}
+
+check_filt <- function(set, minimum = 10){
+  
+  if(plyr::empty(set) | is.null(set)){
+    classes <- get_class_names()
+    res <- logical(nrow(classes))
+    names(res) <- classes$class
+    return(res)
+  }
+    
+  table(
+    get_classes(set$ex_id, unique_classes = F, use_names = T)) >= minimum
+  
+}
+
+select_samples <- function(min_per_class = 10, selection_type = 'rand_surv',
+                           max_draws = 1e6){
+  
+  if (selection_type == 'rand_surv' | 
+      selection_type == 'class_surv' |
+      selection_type == 'art_class_surv'){
+    survival_selection(min_per_class, selection_type, max_draws)
+  }
+  
+}
+
+#
+.update_set <- function(original_set, class_set){
+  
+  class <- get_classes(class_set$ex_id,
+                       unique_classes = T)[1]
+  classes <- get_classes(original_set$ex_id,
+                         unique_classes = F)
+  
+  new_set <- original_set[classes != class, ]
+  
+  rbind(new_set, class_set) %>% arrange(ex_id)
+  
+}
+
+#
+.update_sets <- function(original_sets, class_sets){
+  
+  original_sets$train <- .update_set(original_sets$train, class_sets$train)
+  original_sets$test <- .update_set(original_sets$test, class_sets$test)
+  original_sets$filt <- .update_set(original_sets$filt, class_sets$filt)
+  original_sets
+
+}
+
+# 
+
+.get_sets <- function(class = NULL, hold_out_ex_ids = NULL){
+  
+  if(is.null(class)) N <- 1000
+  else N <- 100
+  
+  sets <- get_bs_samples(N, 
+                         num_iter = 1, stratified = T,
+                         keep_prop = F, classes = class,
+                         hold_out_ex_ids = hold_out_ex_ids)
+  sets$filt <- filter_set(sets$test, sets$train)
+  
+  return(sets)
+  
+}
+
+.get_class_sets <- function(class = NULL, 
+                            selection_type = 'class_surv',
+                            min_per_class = 0){
+  
+  if(selection_type == 'class_surv') .get_sets(class = class)
+  else if(selection_type == 'art_class_surv'){
+    
+    ex_art <- 
+      get_excerpts_classes(class = class) %>% 
+      inner_join(get_excerpts_artists(), by = c('ex_id'))
+    
+    artists_dist <- table(ex_art$artist_id)
+    
+    total_excerpts <- length(unique(ex_art$ex_id))
+    num_excerpts <- 0
+    hold_out_artists <- numeric(0)
+    
+    while (num_excerpts < min_per_class) {
+      new_artist <- sample(unique(ex_art$artist_id), 1)
+      if (!any(new_artist %in% hold_out_artists)) {
+        hold_out_artists <- c(hold_out_artists, new_artist)
+        num_excerpts <- num_excerpts + 
+          as.numeric(artists_dist[which(names(artists_dist) == new_artist)])
+      }
+      
+    }
+    
+    hold_out_ex_ids <- unique(ex_art$ex_id)[
+      which(ex_art$artist_id %in% hold_out_artists)]
+    
+    return(.get_sets(class, hold_out_ex_ids))
+    
+  }
+  
+}
+
+.fail_selection <- function(num_draws){
+  
+  list(sets = NULL, success = F, draws = num_draws)
+  
+}
+
+survival_selection <- function(min_per_class = 10,
+                               selection_type = 'rand_surv',
+                               max_draws = 1e6){
+  
+  # 1.- Draw initial sets
+  sets <- .get_sets()
+  num_draws <- nrow(sets$train)
+  
+  # 2.- Check if initial test set meets requirements
+  checked <- check_filt(sets$filt, minimum = min_per_class)
+  
+  if(!all(checked)){
+    
+    # 3.1.- Random Survival: Complete redraw
+    if(selection_type == 'rand_surv')
+      while(!all(checked)){
+        if(num_draws > max_draws) return(.fail_selection(num_draws))
+        sets <- .get_sets()
+        num_draws <- num_draws + 1000
+        checked <- check_filt(sets$filt, minimum = min_per_class)
+      }
+    # 3.2.- Class Survival: Redraw only problematic classes
+    # 3.3.- Artist-informed Class Survival
+    else if(selection_type == 'class_surv' | 
+            selection_type == 'art_class_surv'){
+      
+      for(fail_class in names(checked[!checked])){
+        print(paste0("Redrawing class: ", fail_class))
+        if(num_draws > max_draws) return(.fail_selection(num_draws))
+        class_checked <- F
+        while (!class_checked) {
+          print(paste0("  Attempting: ", fail_class))
+          class_sets <- .get_class_sets(class = fail_class,
+                                        selection_type = selection_type,
+                                        min_per_class = min_per_class)
+          num_draws <- num_draws + 100
+          class_checked <- nrow(class_sets$filt) >= min_per_class
+        }
+        sets <- .update_sets(sets, class_sets)
+      }
+    }
+  }
+    
+  return(list(sets = sets, success = T, draws = num_draws))
+
+}
+
+
+# 
+draw_samples <- function(num_iters = 40,
+                         min_per_class = 10,
+                         selection_type = "art_class_surv"){
+  
+  sets <- list(train = data.frame(),
+               test = data.frame(),
+               filt = data.frame())
+  sim_results <- data.frame(
+    success = logical(0), num_draws = numeric(0))
+  i <- 1
+  while(i <= num_iters){
+    
+    print("Starting new attempt")
+    
+    res <- survival_selection(
+      min_per_class = min_per_class,
+      selection_type = selection_type
+    )
+    
+    print(
+      paste0(
+        "Finishing new attempt: ",
+        ifelse(res$success, "Success ", "Failure "),
+        "after ", res$draws, " draws"))
+    print("")
+    
+    sim_results <- rbind(sim_results,
+                         list(success = res$success,
+                              num_draws = res$draws))
+    
+    if(res$success){
+      sets$train <- rbind(sets$train,
+                          res$sets$train %>% mutate(iter = i))
+      sets$test <- rbind(sets$test,
+                          res$sets$test %>% mutate(iter = i))
+      sets$filt <- rbind(sets$filt,
+                          res$sets$filt %>% mutate(iter = i))
+      i <- i + 1
+    }
+    
+  }  
+    
+  return(list(sets = sets, sim_results = sim_results))
+    
+}