trainingData <-
  trainingData %>% 
  filter(TokenDur > 0, TokenDur < 0.45, FollSegment!="R")

trainingData <-
  trainingData %>% 
  mutate_at(vars(matches("^F1(_[2-8][50]|min|max)$")), ~ . - Initial_F1_50) %>% 
  mutate_at(vars(matches("^F2(_[2-8][50]|min|max)$")), ~ . - Initial_F2_50) %>% 
  mutate_at(vars(matches("^F3(_[2-8][50]|min|max)$")), ~ . - Initial_F3_50) %>% 
  mutate_at(vars(matches("^F4(_[2-8][50]|min|max)$")), ~ . - Initial_F4_50)

trainingData <-
  trainingData %>% 
  group_by(Speaker, Vowel) %>% 
  mutate(TokenDurSD = sd(TokenDur, na.rm=TRUE) %>% replace_na(0),
         TokenDur = if_else(TokenDurSD > 0, scale(TokenDur), 0)) %>% 
  select(-TokenDurSD) %>% 
  ungroup()

##Capture current column ordering
origCols <- trainingData %>% colnames()

##Set up dataframe for imputation: Must contain only the measures to be imputed 
##  and the measures being used to calculate k nearest neighbors.
imputeDF <-
  trainingData %>%
  ##In this data, MatchId serves as a unique identifier for tokens
  select(MatchId, TokenDur:absSlopeF0) %>% 
  select(-contains("F0"), -contains("F4"), -contains("BW4")) %>%
  select_if(~ sum(is.na(.)) < 300) %>% 
  filter(complete.cases(.)) %>% 
  left_join(trainingData %>% 
              select(MatchId, TokenDur:absSlopeF0) %>% 
              select(MatchId, contains("F0"), contains("F4"), contains("BW4")),
            by="MatchId")

##Perform imputation--this takes a while!
imputeDF <- 
  imputeDF %>% 
  select(-MatchId) %>% 
  as.data.frame() %>% 
  knnImputation() %>% 
  cbind(imputeDF %>% select(MatchId))

##Add imputed values back into data frame (MatchId is a unique identifier, so
##  we can use it to match tokens between data frames)
trainingData <-
  trainingData %>% 
  left_join(imputeDF %>% 
              select(MatchId, contains("F0"), contains("F4"), contains("BW4")), 
            by="MatchId") %>% 
  select(-ends_with(".x")) %>% 
  rename_at(vars(ends_with(".y")), str_remove, ".y") %>% 
  select(!!origCols) 

##Clean up
rm(imputeDF)

trainingData <-
  trainingData %>%
  group_by(Speaker, Vowel) %>% 
  mutate_at(vars(matches("^F[01234](_[2-8][50]|min|max)$"), starts_with("intens_"), TokenDur), 
            list(Outlier = ~ . < quantile(., 0.25, na.rm=TRUE) - 1.5*IQR(., na.rm=TRUE) |
                   . > 1.5*IQR(., na.rm=TRUE) + quantile(., 0.75, na.rm=TRUE))) %>% 
  ungroup()

trainingData <-
  trainingData %>% 
  filter_at(vars(TokenDur:absSlopeF0), all_vars(!is.na(.))) %>% 
  droplevels()

if (!dir.exists("Data")) dir.create("Data")
trainingData %>% saveRDS("Data/trainingData.Rds")
trainingData <- readRDS("Data/trainingData.Rds")

Do we even need to mark outliers?

Measurement error is a fact of life when using corpus methods, and of course classifiers will perform better if they have cleaner data. At the same time, not all data is appropriate for outlier-marking. Here are the conditions under which outlier-marking is appropriate:

1. Some measures include measurement error. If your data is spotless, then any outliers are ‘true’ outliers, not just mis-measurements, and your model will be better off for being able to see them.

2. For the measures with some measurement error, the distributions are either unimodal or their bi-/multimodality isn’t due to the classes of interest.

Let’s briefly investigate these conditions. First, do we have evidence of measurement error in our data? Looking at F3 minimum, we appear to have a good distribution, but the extent of it seems questionable (do we really have tokens whose F3 minimum is below 1000 Hz?). Similarly, the intensity at the time of the F3 minimum has some values that seem conspicuously low. When we hand-check these tokens, we find that these measurements are indeed erroneous, meaning there’s evidence for measurement error in our data:

trainingData %>% 
  filter(!is.na(F3min)) %>% 
  mutate(F3min_orig = F3min + Initial_F3_50) %>% 
  ggplot(aes(x=F3min_orig)) +
  geom_histogram(binwidth=50) +
  xlab("F3 minimum (Hz)")

trainingData %>% 
  filter(!is.na(intens_F3min)) %>% 
  ggplot(aes(x=intens_F3min)) +
  geom_histogram(binwidth=1) +
  xlab("Intensity at time of F3 minimum (dB)")

Once we’ve detected measurement error, we have to determine whether these measures are unimodally distributed. Rather than just eyeball the distributions, we’ll conduct Hartigan’s dip tests, which determine whether there is significant evidence for non-unimodality in a distribution (Freeman & Dale, 2013; Hartigan & Hartigan, 1985), using the diptest package (Maechler, 2016). The null hypothesis in these tests is that the distribution is unimodal, so a significant result means that we have evidence that the distribution is bimodal or multimodal. The dip test on the F3 minimum distribution indicates no evidence for non-unimodality, but (perhaps surprisingly) the dip test on the intensity at F3 minimum distribution indicates significant evidence for non-unimodality. In other words, F3 minimum has met the conditions for outlier-marking, but intensity hasn’t.

trainingData$F3min %>% dip.test()

    Hartigans' dip test for unimodality / multimodality

data:  .
D = 0.0010115, p-value = 0.9962
alternative hypothesis: non-unimodal, i.e., at least bimodal

trainingData$intens_F3min %>% dip.test()

    Hartigans' dip test for unimodality / multimodality

data:  .
D = 0.021, p-value < 2.2e-16
alternative hypothesis: non-unimodal, i.e., at least bimodal

The reason for the bimodality condition is that we don’t want to outlier-mark a bimodal distribution that is merely the combinaton of two unimodal distributions that each correspond to one class. If underlying the distribution of some measure are two fairly separate unimodal distributions by class, then outlier-marking is going to eliminate some measurements that are extreme with respect to the pooled distribution but are actually well-behaving measurements for their own class. As a result, if our bimodal distribution isn’t the result of the classes of interest, but instead the result of some other factor external to the classes, then it’s okay to outlier-mark the distribution (although it might be beneficial to normalize for the external factor if that’s possible). To that end, we can look at the by-class distribution of intensity; since we don’t have evidence for different modes for Absent vs. Present, intensity meets the conditions for outlier-marking.

trainingData %>% 
  filter(HowCoded=="Hand") %>% 
  ggplot(aes(x=intens_F3min, fill=Rpresent)) +
  geom_density(alpha=0.5) +
  xlab("Intensity at time of F3 minimum (dB)")

We don’t have any examples of distributions whose bimodality is due to the Absent/Present in the /r/ data, but in the medial /t/ data, the center of gravity at 70% duration is clearly bimodal, and this is clearly due to Voiced tokens having a lower center of gravity than Voiceless tokens.

Now that we’ve determined that we can outlier-mark these measures, what criteria do we use to mark individual measurements as outliers? Two potential rules of thumb are to mark measurements that are more than 2 standard deviations from the mean, or to mark measurements that are more than 1.5 times the interquartile range from the first or third quartiles. The standard deviation-based rule is only appropriate if the data is normal, while the IQR-based rule is more general. In this case, since we had a lot of measures to outlier-mark, some of which are clearly non-normal (e.g., intensity at F3 minimum), we used the more general IQR rule of thumb. We also generated distributions within each speaker and vowel, since a well-behaving measurement in a rare vowel context can easily look like an outlier in the overall data.

Additional resampling

After constructing training and test subsets, train() can perform additional resampling to adjust for class imbalances in the training and test subsets prior to assessing classifier performance. By default, train() performs no additional resampling, but other options are downsampling the majority class to match the size of the minority class, and SMOTE sampling, a hybrid method that combines downsampling the majority class with creating synthetic members of the minority class (Chawla, Bowyer, Hall, & Kegelmeyer, 2002). Given that the data are imbalanced, it’s likely that a model that looks at the data as-is will perform well on the majority class, Absent, but poorly on the minority class, Present. For all the other hyperparameters, we start with default values (method="boot", number=25, num.trees=500, tuneGrid=data.frame(mtry=13, splitrule="gini", min.node.size=1)).

##Define a vector with possible values of our hyperparameter
tuneResamples <- c("none", "down", "smote")

##Register a parallel cluster with 3 cores (the length of our hyperparameter
##  vector)
cl <- makeCluster(tuneResamples %>% length())
registerDoParallel(cl)
##Set a parallel seed for reproducibility
clusterSetRNGStream(cl, 302302) 

##Train the list of forests; the code inside the curly braces will be run in
##  parallel for each value of the vector tuneResamples, outputting a classifier
##  for each setting
fstListResamples <-
  foreach(tuneRsmp = tuneResamples, 
          .packages=c("caret","dplyr")) %dopar% {
            ##Create an extensionless 'dummy file' to signal that the model has
            ##  started running
            file.create(paste("Model Status/Resamples", tuneRsmp, "begun", sep="_"))
            ##Call train()
            mod <- train(Rpresent ~ .,
                         data=trainingData %>% 
                           filter(HowCoded=="Hand") %>% 
                           select(Rpresent, TokenDur:absSlopeF0),
                         method="ranger",
                         importance="impurity",
                         num.trees=500,
                         trControl=trainControl(method="boot", 
                                                number=25,
                                                sampling=if (tuneRsmp=="none") NULL else tuneRsmp,
                                                savePredictions=TRUE,
                                                summaryFunction=cutoffSummary,
                                                returnResamp="all",
                                                classProbs=TRUE),
                         tuneGrid=data.frame(mtry=13, splitrule="gini", min.node.size=1))
            ##Create an extensionless 'dummy file' to signal that the model has
            ##  finished running
            file.create(paste("Model Status/Resamples", tuneRsmp, "completed", sep="_"))
            ##Return the classifier
            return(mod)
          } %>% 
  ##Name each classifier with its hyperparameter setting
  set_names(tuneResamples)

##Stop the parallel cluster
stopCluster(cl)

Clear the model status dummy files:

dir("Model Status", pattern="^Resamples", full.names=TRUE) %>% file.remove()

logical(0)

Create and save a summary object for this tuning step (note that we’ve written fstSummary() to handle a list of classifiers as well as a single classifier):

smryResamples <- fstListResamples %>% fstSummary()
smryResamples %>% saveRDS("Model Status/SmryResamples.Rds")

The resampled performance measures indicate that SMOTE sampling narrowly outperforms no resampling, which outperforms downsampling.

smryResamples$resample %>% 
  group_by(Model) %>% 
  summarise_if(is.numeric, mean, na.rm=TRUE) %>% 
  arrange(desc(AccAUC))

Because we tested each classifier using 25 bootstrap resamples, we can assess performance across a range of possible outcomes. The plot below shows the resampled overall accuracy \(\times\) AUC for each hyperparameter setting. The SMOTE and downsampling models are more variable in their performance than the non-resampled model; this is not surprising given that the process of resampling introduces an additional layer of randomness. Nevertheless, the SMOTE models generally outperform the downsampled and non-resampled models.

smryResamples$resample %>% 
  ggplot(aes(x=Model, y=AccAUC)) +
  geom_violin() +
  xlab("Additional resampling method") +
  ylab("Overall accuracy × AUC")

Even though we’re optimizing our classifiers based on overall accuracy \(\times\) AUC, our summary function allows us to keep an eye on other performance metrics we might care about, like class accuracies. The plot below demonstrates that the choice of additional resampling method makes a considerable impact on class accuracy. As we suspected, the non-resampled model suffers from stratification between high accuracy for Absent and low accuracy for Present; compared to the non-resampled model, the SMOTE model has slightly worse accuracy for Absent, but much better accuracy for Present. This is a tradeoff we’re willing to make, and this tradeoff is reflected in overall accuracy \(\times\) AUC, where the SMOTE model edges out the non-resampled model.

smryResamples$resample %>% 
  gather("Class", "ClassAccuracy", starts_with("ClassAccuracy_")) %>% 
  mutate_at(vars(Class), str_remove, "ClassAccuracy_") %>% 
  ggplot(aes(x=Model, y=ClassAccuracy, fill=Class)) +
  geom_violin() +
  xlab("Additional resampling method") +
  ylab("Class accuracy")

Again, caret automatically saves timing data in the random forest objects it creates, and the summary objects we’ve created store this timing information. Here, SMOTE takes substantially longer to run than no resampling or downsampling, thanks to the fact that it takes the extra step of creating synthetic minority class tokens. The time-saving benefits of parallel processing are also evident from the difference between user (the sum of running time on all cores) and elapsed (the actual time it took to run the models); it took 7 minutes to run the SMOTE model in parallel, but without parallel processing it would have taken nearly 25 minutes!

smryResamples$times

$none
$none$everything
   user  system elapsed 
480.320   1.900  67.386 

$none$final
   user  system elapsed 
 21.484   0.028   1.526 


$down
$down$everything
   user  system elapsed 
277.904   1.572  55.985 

$down$final
   user  system elapsed 
 10.772   0.016   0.879 


$smote
$smote$everything
    user   system  elapsed 
1479.396    4.672  444.371 

$smote$final
   user  system elapsed 
 64.148   0.016  14.972 

It’s also a good idea when you’re running these models to keep an eye on how much memory your forest lists are taking up by sitting in your R workspace. Here we see that our forest list with three different models takes up quite a bit of space. We’re running these forests on a platform where memory’s not a concern, but if it were, we’d certainly want to remove each forest list after extracting whatever summary information we want from the forest list and saving that summary to file.

fstListResamples %>% object.size() %>% format("Mb")

[1] "178.3 Mb"

Training/test subset generation method

The possible subset generation methods are the simple bootstrap estimator, the 0.632 bootstrap estimator, out-of-bag, k-fold cross-validation, repeated k-fold cross-validation, and leave-p-out cross-validation (aka leave-group-out cross-validation). Here, we use caret’s default parameter settings for each of these methods: 25 resamples for bootstrap, out-of-bag, and leave-p-out cross-validation; 10 folds for k-fold cross-validation and repeated k-fold cross-validation; and a training percentage of 75% for leave-p-out cross-validation. We’ll override one caret default, as we’ll use 5 repeats for repeated k-fold cross-validation (caret’s default of 1 repeat makes this method indistinguishable from non-repeated k-fold cross-validation).

Now, we generate our list of forests:

tuneMethods <- c("boot", "boot632", "cv", "repeatedcv", "LGOCV")

cl <- makeCluster(tuneMethods %>% length())
registerDoParallel(cl)
clusterSetRNGStream(cl, 302302)
fstListMethods <-
  foreach(tuneMth = tuneMethods, 
          .packages=c("caret","dplyr")) %dopar% {
            file.create(paste("Model Status/Methods", tuneMth, "begun", sep="_"))
            mod <- train(Rpresent ~ .,
                         data=trainingData %>% 
                           filter(HowCoded=="Hand") %>% 
                           select(Rpresent, TokenDur:absSlopeF0),
                         method="ranger",
                         importance="impurity",
                         num.trees=500,
                         trControl=trainControl(method=tuneMth, 
                                                repeats=if (tuneMth=="repeatedcv") 5 else NA,
                                                sampling="smote",
                                                savePredictions=TRUE,
                                                summaryFunction=cutoffSummary,
                                                returnResamp="all",
                                                classProbs=TRUE),
                         tuneGrid=data.frame(mtry=13, splitrule="gini", min.node.size=1))
            file.create(paste("Model Status/Methods", tuneMth, "completed", sep="_"))
            
            return(mod)
          } %>% 
  set_names(tuneMethods)

stopCluster(cl)

Clear the model status dummy files:

dir("Model Status", pattern="^Methods", full.names=TRUE) %>% file.remove()

logical(0)

Create and save a summary object:

smryMethods <- fstListMethods %>% fstSummary()
smryMethods %>% saveRDS("Model Status/SmryMethods.Rds")

The resampling results give k-fold cross-validation as the best-performing model, although there’s not much difference between methods in terms of performance:

smryMethods$resample %>% 
  group_by(Model) %>% 
  summarise_if(is.numeric, mean, na.rm=TRUE) %>% 
  arrange(desc(AccAUC))

We can also plot the resampled results to get a better sense of the range of performance for each of these methods.

smryMethods$resample %>% 
  ggplot(aes(x=Model, y=AccAUC)) +
  geom_violin()

Training/test subset generation parameters

Now that we’ve selected repeated k-fold cross-validation as our subset generation method, what’s the optimal number of folds and the optimal number of repeats? For folds, We’ll sample a space of options around the default of 10: 4, 6, 8, 10, 12, 14. For repeats, we’ll sample a space of options around 5: 3, 5, 7.

tuneListFoldsReps <- expand.grid(Folds = seq(4, 14, by=2),
                                 Repeats = seq(3, 7, by=2))

tuneListFoldsReps <- tuneListFoldsReps %>% split(tuneListFoldsReps %>% nrow() %>% seq_len())
tuneListFoldsReps <- tuneListFoldsReps %>% set_names(tuneListFoldsReps %>% map(str_c, collapse=" "))

cl <- makeCluster(9)
registerDoParallel(cl)
clusterSetRNGStream(cl, 302302)

fstListFoldsReps <-
  foreach(tuneNmRp = tuneListFoldsReps, 
          .packages=c("caret","dplyr")) %dopar% {
            file.create(paste("Model Status/FoldsReps", paste(tuneNmRp, collapse="&"), "begun", sep="_"))
            mod <- train(Rpresent ~ .,
                         data=trainingData %>% 
                           filter(HowCoded=="Hand") %>% 
                           select(Rpresent, TokenDur:absSlopeF0),
                         method="ranger",
                         importance="impurity",
                         num.trees=500,
                         trControl=trainControl(method="repeatedcv", 
                                                number=tuneNmRp$Folds,
                                                repeats=tuneNmRp$Repeats,
                                                sampling="smote",
                                                savePredictions=TRUE,
                                                summaryFunction=cutoffSummary,
                                                returnResamp="all",
                                                classProbs=TRUE),
                         tuneGrid=data.frame(mtry=13, splitrule="gini", min.node.size=1))
            file.create(paste("Model Status/FoldsReps", paste(tuneNmRp, collapse="&"), "completed", sep="_"))
            return(mod)
          } %>% 
  set_names(names(tuneListFoldsReps))

stopCluster(cl)

Clear the model status dummy files:

dir("Model Status", pattern="^FoldsReps", full.names=TRUE) %>% file.remove()

logical(0)

Create another summary object:

smryFoldsReps <- fstListFoldsReps %>% fstSummary()
smryFoldsReps$resample <- smryFoldsReps$resample %>% 
  separate(Model, c("NumFolds", "Repeats"), sep=" ")
smryFoldsReps %>% saveRDS("Model Status/SmryFoldsReps.Rds")

The resampling results give the model with 12 folds as the best model:

smryFoldsReps$resample %>% 
  group_by(NumFolds, Repeats) %>% 
  summarise_if(is.numeric, mean, na.rm=TRUE) %>% 
  arrange(desc(AccAUC))

ranger parameters (mtry, splitrule, min.node.size)

Define an initial search space for these parameters. A typical value of mtry for classification is the square root of the number of predictors, rounded down to the nearest integer, which in the case of the /r/ data is 13; so we’ll try a few mtry values around 13: 9, 11, 13, 15, 17. splitrule has two values, "gini" and "extratrees", so we’ll try both. Finally, the original randomForest package (Liaw & Wiener, 2002) uses min.node.size defaults of 1 for classification and 5 for regression, so for good measure we’ll try 1, 5, and 10. With respect to the continuous parameters (mtry and min.node.size), the best classifiers in this initial round may indicate values toward the end of the ranges we tuned; if that’s the case, we’ll do another round of tuning these parameters with a better-informed range of values.

tuneList <- expand.grid(mtry=seq(9, 17, by=2), 
                        splitrule=c("gini", "extratrees"), 
                        min.node.size=c(1, 5, 10), 
                        stringsAsFactors=FALSE)
tuneList <- tuneList %>% split(tuneList %>% nrow() %>% seq_len())
tuneList <- tuneList %>% set_names(tuneList %>% map(str_c, collapse=" "))
cl <- makeCluster(10)
registerDoParallel(cl)
clusterSetRNGStream(cl, 302302)
fstListTuneGrid <- 
  foreach(tuneVals = tuneList, 
          .packages=c("caret","dplyr")) %dopar% {
            file.create(paste("Model Status/TuneGrid", 
                              paste(tuneVals, collapse=" "), 
                              "begun", sep="_"))
            mod <- train(Rpresent ~ .,
                         data=trainingData %>% 
                           filter(HowCoded=="Hand") %>% 
                           select(Rpresent, TokenDur:absSlopeF0),
                         method="ranger",
                         importance="impurity",
                         num.trees=500,
                         trControl=trainControl(method="repeatedcv", 
                                                number=12,
                                                repeats=3,
                                                sampling="smote",
                                                savePredictions=TRUE,
                                                summaryFunction=cutoffSummary,
                                                returnResamp="all",
                                                classProbs=TRUE),
                         tuneGrid=tuneVals)
            file.create(paste("Model Status/TuneGrid", 
                              paste(tuneVals, collapse=" "), 
                              "completed", sep="_"))
            return(mod)
          } %>% 
  set_names(names(tuneList))

Clear the model status dummy files:

dir("Model Status", pattern="^TuneGrid", full.names=TRUE) %>% file.remove()

logical(0)

To assess which tuning parameters are the best, we collect some of the most salient characteristics of the model (resampling results, confusion matrix, variable importance, and running time) into a summary object. We’ll also save this summary in its own .Rds file, in case something goes awry and we lose our R session (which is a risk when you’re trying to hold large objects in memory).

smryTuneGrid <- fstListTuneGrid %>% fstSummary()
smryTuneGrid %>% saveRDS("Model Status/SmryTuneGrid.Rds")

The resampled performance measures indicate the best performance with mtry=15, splitrule="gini", and min.node.size=1

smryTuneGrid$resample %>% 
  group_by(mtry, splitrule, min.node.size) %>% 
  summarise_if(is.numeric, mean, na.rm=TRUE) %>% 
  arrange(desc(AccAUC))

Number of trees

Finally, we can adjust the number of trees in our forest. We’ve been using 500 trees, but it seems reasonable to try smaller or larger forests. We’ll try forests of size 250, 500, 750, and 1000; if it seems that our forests’ performance only increases with greater size, we can try larger forests still.

tuneNumTrees <- seq(250, 1000, by=250)

cl <- makeCluster(tuneNumTrees %>% length())
registerDoParallel(cl)
clusterSetRNGStream(cl, 302302)

fstListNumTrees <-
  foreach(tuneNmTr = tuneNumTrees, 
          .packages=c("caret","dplyr")) %dopar% {
            file.create(paste("Model Status/NumTrees", tuneNmTr, "begun", sep="_"))
            mod <- train(Rpresent ~ .,
                         data=trainingData %>% 
                           filter(HowCoded=="Hand") %>% 
                           select(Rpresent, TokenDur:absSlopeF0),
                         method="ranger",
                         importance="impurity",
                         num.trees=tuneNmTr,
                         trControl=trainControl(method="repeatedcv",
                                                number=12,
                                                repeats=3, 
                                                sampling="smote",
                                                savePredictions=TRUE,
                                                summaryFunction=cutoffSummary,
                                                returnResamp="all",
                                                classProbs=TRUE),
                         tuneGrid=data.frame(mtry=13, splitrule="gini", min.node.size=10))
            file.create(paste("Model Status/NumTrees", tuneNmTr, "completed", sep="_"))
            return(mod)
          } %>% 
  set_names(tuneNumTrees)

stopCluster(cl)

Clear the model status dummy files:

dir("Model Status", pattern="^NumTrees", full.names=TRUE) %>% file.remove()

logical(0)

Create and save another summary object:

smryNumTrees <- fstListNumTrees %>% fstSummary()
smryNumTrees %>% saveRDS("Model Status/SmryNumTrees.Rds")

The resampled performance measures are best for the model with 750 trees, so we’ll keep that setting, though we acknowledge that there is no real difference in performance between 250, 500, 750, and 1000 trees (that is, if our model took a very long time to run, we could get away with using just 250 trees).

smryNumTrees$resample %>% 
  group_by(Model) %>% 
  summarise_if(is.numeric, mean, na.rm=TRUE) %>% 
  arrange(desc(AccAUC))

Summary: Hyperparameter tuning

After the tuning process, our classifier has the following hyperparameter settings:

• Additional resampling: SMOTE

• Training/test subset generation method: k-fold cross-validation

• Training/test subset generation parameters: 10 folds

• ranger parameters: mtry=13, splitrule="gini", min.node.size=10

• Number of trees: 750

Let’s train another classifier with these parameter settings to get a snapshot of performance after tuning hyperparameters (since we’re only training one model, we’ll dispatch with the parallel backend):

registerDoSEQ()
set.seed(302302)
fstTuned <- train(Rpresent ~ .,
                  data=trainingData %>%
                    filter(HowCoded=="Hand") %>%
                    select(Rpresent, TokenDur:absSlopeF0),
                  method="ranger",
                  importance="impurity",
                  num.trees=750,
                  trControl=trainControl(method="repeatedcv", 
                                         number=12,
                                         repeats=3,
                                         sampling="smote",
                                         savePredictions=TRUE,
                                         summaryFunction=cutoffSummary,
                                         returnResamp="all",
                                         classProbs=TRUE),
                  tuneGrid=data.frame(mtry=13, splitrule="gini", min.node.size=10))

Create and save a summary object:

smryTuned <- fstTuned %>% fstSummary()
smryTuned %>% saveRDS("Model Status/SmryTuned.Rds")

Here are the performance measures for our tuned classifier:

smryTuned$resample %>% 
  summarise_if(is.numeric, mean, na.rm=TRUE)

Finally, we remove forest objects to avoid overtaxing memory (depending on your system, it might be a good idea to do this after each hyperparameter), except for fstTuned.

rm(fstListMethods, fstListFoldsReps, fstListNumTrees, fstListResamples, fstListTuneGrid)

registerDoSEQ()
set.seed(302302)
fstNoOutlier <- train(Rpresent ~ .,
                      data=trainingData %>% 
                        filter(HowCoded=="Hand") %>% 
                        filter_at(vars(ends_with("_Outlier")), all_vars(!.)) %>%
                        select(Rpresent, TokenDur:absSlopeF0),
                      method="ranger",
                      importance="impurity",
                      num.trees=750,
                      trControl=trainControl(method="repeatedcv", 
                                             number=12,
                                             repeats=3,
                                             sampling="smote",
                                             savePredictions=TRUE,
                                             summaryFunction=cutoffSummary,
                                             returnResamp="all",
                                             classProbs=TRUE),
                      tuneGrid=data.frame(mtry=13, splitrule="gini", min.node.size=10))

fstNoOutlier$resample %>% 
  summarise_if(is.numeric, mean, na.rm=TRUE) %>% 
  select(AccAUC, Accuracy, AUC, everything())

rm(fstNoOutlier)

trainingData %>% 
  mutate(PossOutlier = apply(select(., ends_with("_Outlier")), 1, any)) %$%
  table(HowCoded, PossOutlier)

        PossOutlier
HowCoded FALSE  TRUE
    Auto 17204 15915
    Hand  2978  2642

trainingData %>% 
  select(ends_with("_Outlier")) %>%
  summarise_all(mean) %>% 
  apply(1, mean)

[1] 0.04197241

trainingData %>% 
  mutate(NumOutlier = apply(select(., ends_with("_Outlier")), 1, sum)) %>%
  filter(NumOutlier > 0) %>% 
  ggplot(aes(x=NumOutlier)) +
  geom_histogram(binwidth=1) +
  facet_grid(HowCoded ~ .)

Find ranking of outliers

To lessen the effect of statistical noise, we’ll train 5 models for each step. We’ll use parallel processing as before, but with one additional bit of machinery. Previously, we ensured reproducibility by using parallel::clusterSetRNGStream() to pass the same random seed to each parallel process. If we did the same thing here, we would end up with 5 repetitions of the exact same model running in parallel! Not exactly the best use of parallel processing. As a result, we’ll also pass different vectors of random seeds to the seeds argument of trainControl(), ensuring that train() generates different training and test subsets from one parallel model to the next.

registerDoSEQ()
set.seed(302302)
##For repeated k-fold CV with n repeats, trainControl(seeds) must be a list of
##  (n*k)+1 lists, each containing M integers (M = number of models being 
##  evaluated within each call to train())
seedList <- replicate(5,
                      replicate(37, sample.int(10000, 1), simplify=FALSE),
                      simplify=FALSE)

First, train a list of 5 classifiers on the full data set (i.e., without dropping any outliers):

cl <- makeCluster(5)
registerDoParallel(cl)
clusterSetRNGStream(cl, 302302)

fstListDropOut0 <- foreach(seed = seedList, 
                           .packages=c("caret","dplyr")) %dopar% {
                             train(Rpresent ~ .,
                                   data=trainingData %>% 
                                     filter(HowCoded=="Hand") %>% 
                                     select(Rpresent, TokenDur:absSlopeF0),
                                   method="ranger",
                                   importance="impurity",
                                   num.trees=750,
                                   trControl=trainControl(method="repeatedcv", 
                                                          number=12,
                                                          repeats=3,
                                                          sampling="smote",
                                                          seeds=seed,
                                                          savePredictions=TRUE,
                                                          summaryFunction=cutoffSummary,
                                                          returnResamp="all",
                                                          classProbs=TRUE),
                                   tuneGrid=data.frame(mtry=13, splitrule="gini", min.node.size=10))
                           }

stopCluster(cl)

Extract and save a summary:

smryDropOut0 <- fstListDropOut0 %>% fstSummary()
smryDropOut0 %>% saveRDS("Model Status/SmryDropOut0.Rds")

For each forest in this list, we can assess the effect of each outlier on performance by comparing the proportions of outliers for different measures in each fold and each fold’s performance. We pull each token’s fold assignment from the pred element of each forest and add it to each token’s outlier data:

fstListDropOut0[[1]] %>% 
  extract2("pred") %>% 
  arrange(rowIndex) %>% 
  select(Resample) %>% 
  cbind(trainingData %>% filter(HowCoded=="Hand") %>% select(ends_with("_Outlier")))

From this data, we can find the proportion of outliers for each measure in each fold (within each repetition):

fstListDropOut0[[1]] %>% 
  extract2("pred") %>% 
  arrange(rowIndex) %>% 
  select(Resample) %>% 
  cbind(trainingData %>% filter(HowCoded=="Hand") %>% select(ends_with("_Outlier"))) %>% 
  group_by(Resample) %>% 
  summarise_all(mean)

We then take performance data from the resample element of the forest and join it to the outlier data:

fstListDropOut0[[1]] %>% 
  extract2("resample") %>% 
  select(AccAUC, Resample)

fstListDropOut0[[1]] %>% 
  extract2("pred") %>% 
  arrange(rowIndex) %>% 
  select(Resample) %>% 
  cbind(trainingData %>% filter(HowCoded=="Hand") %>% select(ends_with("_Outlier"))) %>% 
  group_by(Resample) %>% 
  summarise_all(mean) %>% 
  left_join(fstListDropOut0[[1]] %>% 
              extract2("resample") %>% 
              select(AccAUC, Resample),
            by="Resample")

After we put this data together for all 5 classifiers in the list, we pass the resulting dataframe to cor() to get correlations, and we pull out just the correlations we care about: the correlations between AccAUC and the proportions of outliers. Finally, we store the data in a dataframe and, to save memory, remove the forest list from our R environment. The following function puts all these calculations together:

##Find the outliers that most hurt classifier performance by calculating the
##  correlation between folds' test performance and proportion of outliers
##This code works for repeated k-fold cross-validation, but it'll need to be
##  tweaked for different methods of generating training/test subsets.
outlierCors <- function(fstList, data=trainingData, dropped=NULL) {
  ##Get fold info (performance and proportion of outliers) for each forest; if
  ##  outliers have already been dropped, don't include them in the calculation
  if (is.null(dropped) | length(dropped)==0) {
    foldInfo <- function(fst, data, dropped) {
      data %>% 
        filter(HowCoded=="Hand") %>% 
        cbind(fst$pred %>% arrange(rowIndex) %>% select(Resample)) %>%
        group_by(Resample) %>%
        summarise_at(vars(ends_with("_Outlier")), mean, na.rm=TRUE) %>%
        left_join(fst$resample %>% select(AccAUC, Resample), by="Resample")
    } 
  } else {
    foldInfo <- function(fst, data, dropped) {
      data %>% 
        filter(HowCoded=="Hand") %>% 
        filter_at(vars(dropped), all_vars(!.)) %>% 
        cbind(fst$pred %>% arrange(rowIndex) %>% select(Resample)) %>%
        group_by(Resample) %>%
        summarise_at(vars(ends_with("_Outlier")), mean, na.rm=TRUE) %>%
        select(-dropped) %>% 
        left_join(fst$resample %>% select(AccAUC, Resample), by="Resample")
    }
  }
  
  ##Get fold info for all forests and put them together into a dataframe
  ret <-
    fstList %>% 
    map_dfr(foldInfo, data=data, dropped=dropped) %>%
    select(-Resample) %>%
    select(AccAUC, everything()) %>%
    ##Get correlations between AccAUC and outlier proportions
    cor() %>%
    ##Reduce correlation matrix to a vector
    extract(1, -1) %>%
    sort() %>%
    tibble(Measure = names(.), TestCor = .)
  
  ret
}

Running this function on our forest list with no outliers dropped, we find an initial ranking of outliers with F3_80 as the outlier that most hurts classifier performance. We’ll try removing F3_80 outliers first.

(negOutliers <- fstListDropOut0 %>% outlierCors(dropped=NULL))

rm(fstListDropOut0)

Drop outliers in one measure at a time

Start by initializing a character vector (empty, for now) where we’ll store measures that we decide to drop:

dropped <- character(0L)

Now train another list of 5 classifiers, this time dropping tokens with outliers in the measure with the biggest negative impact on performance, F3_80:

tryDrop <- negOutliers$Measure[1]

cl <- makeCluster(5)
registerDoParallel(cl)
clusterSetRNGStream(cl, 302302)

fstListDropOut1_1 <- foreach(seed = seedList, 
                             .packages=c("caret","dplyr")) %dopar% {
                               train(Rpresent ~ .,
                                     data=trainingData %>% 
                                       filter_at(vars(c(dropped, tryDrop)), all_vars(!.)) %>%
                                       filter(HowCoded=="Hand") %>% 
                                       select(Rpresent, TokenDur:absSlopeF0),
                                     method="ranger",
                                     importance="impurity",
                                     num.trees=750,
                                     trControl=trainControl(method="repeatedcv", 
                                                            number=12,
                                                            repeats=3,
                                                            sampling="smote",
                                                            seeds=seed,
                                                            savePredictions=TRUE,
                                                            summaryFunction=cutoffSummary,
                                                            returnResamp="all",
                                                            classProbs=TRUE),
                                     tuneGrid=data.frame(mtry=13, splitrule="gini", min.node.size=10))
                             }

stopCluster(cl)

Create and save a summary object:

smryDropOut1_1 <- fstListDropOut1_1 %>% fstSummary()
smryDropOut1_1 %>% saveRDS("Model Status/SmryDropOut1_1.Rds")

Now we can compare the overall accuracy \(\times\) AUC for the 10 classifiers that drop no outliers vs. the overall accuracy \(\times\) AUC for the 10 classifiers that drop tokens with F3_80 outliers. The latter model well outperforms the former, indicating that the performance gain from dropping F3_80 outliers is worth the loss in data.

list(smryDropOut0, smryDropOut1_1) %>% 
  set_names(c("None", dropped, tryDrop) %>% str_remove("_Outlier")) %>%
  imap_dfr(~ .x %>% 
             extract2("resample") %>% 
             separate(Resample, c("Fold","Rep"), "\\.") %>% 
             group_by(Model, Rep) %>% 
             summarise_at(vars(AccAUC), mean, na.rm=TRUE) %>%
             mutate(Dropped = .y)) %>% 
  mutate_at(vars(Dropped), factor, levels=c("None", dropped, tryDrop) %>% str_remove("_Outlier")) %>% 
  ggplot(aes(x=AccAUC, group=Dropped, fill=Dropped)) +
  geom_density(alpha=0.5)

Now, we’ll proceed to drop outliers for one measure at a time and compare classifier performance after each step using Wilcoxon rank-sum tests (rather than its parametric counterpart, an independent samples t-test). The distributions of classifier performance fail to satisfy the assumption of normality that is necessary to use an independent samples t-test, so instead we compare performance using a Wilcoxon rank-sum test. We’ll drop outliers until we get three consecutive results showing that classifier performance fails to significantly improve at \(\alpha\) = .05. In this case, we find a highly significant increase in classifier performance, which justifies dropping tokens with outlying F3_80 measurements.

list(smryDropOut0, smryDropOut1_1) %>% 
  set_names(c("None", dropped, tryDrop) %>% str_remove("_Outlier")) %>%
  imap_dfr(~ .x %>% 
             extract2("resample") %>% 
             separate(Resample, c("Fold","Rep"), "\\.") %>% 
             group_by(Model, Rep) %>% 
             summarise_at(vars(AccAUC), mean, na.rm=TRUE) %>% 
             mutate(Dropped = .y)) %>% 
  mutate_at(vars(Dropped), factor, levels=c("None", dropped, tryDrop) %>% str_remove("_Outlier")) %>% 
  wilcox.test(AccAUC ~ Dropped, ., alternative="less", exact=TRUE)

    Wilcoxon rank sum test

data:  AccAUC by Dropped
W = 19, p-value = 1.327e-05
alternative hypothesis: true location shift is less than 0

So we add F3_80 to our established set of dropped outliers, meaning we drop about 3% of tokens:

dropped <- c(dropped, tryDrop)
tibble(Dropped = "None", 
       Auto = trainingData %>% filter(HowCoded=="Auto") %>% nrow(),
       Hand = trainingData %>% filter(HowCoded=="Hand") %>% nrow()) %>% 
  rbind(
    cbind(Dropped = dropped,
          map_dfr(dropped %>% seq_along(),
                  ~ trainingData %>%
                    filter_at(vars(dropped[1:.x]), all_vars(!.)) %>%
                    count(HowCoded) %>%
                    spread(HowCoded, n)
          )
    )
  ) %>%
  mutate_at(vars(Auto, Hand), list(PctTossed = ~ (.[1] - .) / .[1]))

We re-rank measures based on the results of this list of classifiers:

(negOutliers <- fstListDropOut1_1 %>% outlierCors(dropped=dropped))

And we continue the procedure by training another list of 5 classifiers, this time on data that drops tokens with outliers in F3_80 and intens_F3max:

rm(fstListDropOut1_1)

tryDrop <- negOutliers$Measure[1]

cl <- makeCluster(5)
registerDoParallel(cl)
clusterSetRNGStream(cl, 302302)

fstListDropOut2_1 <- foreach(seed = seedList, 
                             .packages=c("caret","dplyr")) %dopar% {
                               train(Rpresent ~ .,
                                     data=trainingData %>% 
                                       filter_at(vars(c(dropped, tryDrop)), all_vars(!.)) %>% 
                                       filter(HowCoded=="Hand") %>% 
                                       select(Rpresent, TokenDur:absSlopeF0),
                                     method="ranger",
                                     importance="impurity",
                                     num.trees=750,
                                     trControl=trainControl(method="repeatedcv", 
                                                            number=12,
                                                            repeats=3,
                                                            sampling="smote",
                                                            seeds=seed,
                                                            savePredictions=TRUE,
                                                            summaryFunction=cutoffSummary,
                                                            returnResamp="all",
                                                            classProbs=TRUE),
                                     tuneGrid=data.frame(mtry=13, splitrule="gini", min.node.size=10))
                             }

stopCluster(cl)

Create and save a summary object:

smryDropOut2_1 <- fstListDropOut2_1 %>% fstSummary()
smryDropOut2_1 %>% saveRDS("Model Status/SmryDropOut2_1.Rds")

The plot of performance suggests little performance gain from dropping intens_F3max outliers, compared to our established set of dropped outliers.

list(smryDropOut0, smryDropOut1_1, smryDropOut2_1) %>%
  set_names(c("None", dropped, tryDrop) %>% str_remove("_Outlier")) %>%
  imap_dfr(~ .x %>% 
             extract2("resample") %>% 
             separate(Resample, c("Fold","Rep"), "\\.") %>% 
             group_by(Model, Rep) %>% 
             summarise_at(vars(AccAUC), mean, na.rm=TRUE) %>% 
             mutate(Dropped = .y)) %>% 
  mutate_at(vars(Dropped), factor, levels=c("None", dropped, tryDrop) %>% str_remove("_Outlier")) %>% 
  ggplot(aes(x=AccAUC, group=Dropped, fill=Dropped)) +
  geom_density(alpha=0.5)

A Wilcoxon rank-sum test fails to indicate a significant performance gain from dropping intens_F3max outliers, compared to our established set of dropped outliers.

list(smryDropOut1_1, smryDropOut2_1) %>%
  set_names(c(dropped[length(dropped)], tryDrop) %>% str_remove("_Outlier")) %>%
  imap_dfr(~ .x %>% 
             extract2("resample") %>% 
             separate(Resample, c("Fold","Rep"), "\\.") %>% 
             group_by(Model, Rep) %>% 
             summarise_at(vars(AccAUC), mean, na.rm=TRUE) %>% 
             mutate(Dropped = .y)) %>% 
  mutate_at(vars(Dropped), factor, 
            levels=c(dropped[length(dropped)], tryDrop) %>% str_remove("_Outlier")) %>% 
  wilcox.test(AccAUC ~ Dropped, ., alternative="less", exact=TRUE)

    Wilcoxon rank sum test

data:  AccAUC by Dropped
W = 96, p-value = 0.2562
alternative hypothesis: true location shift is less than 0

So we move on to the next measure in the ranking, F2_35, training a list of classifiers on data that drops outliers in F2_35 in addition to our established set of dropped outliers.

rm(fstListDropOut2_1)

tryDrop <- negOutliers$Measure[2]

cl <- makeCluster(5)
registerDoParallel(cl)
clusterSetRNGStream(cl, 302302)

fstListDropOut2_2 <- foreach(seed = seedList, 
                             .packages=c("caret","dplyr")) %dopar% {
                               train(Rpresent ~ .,
                                     data=trainingData %>% 
                                       filter_at(vars(c(dropped, tryDrop)), all_vars(!.)) %>% 
                                       filter(HowCoded=="Hand") %>% 
                                       select(Rpresent, TokenDur:absSlopeF0),
                                     method="ranger",
                                     importance="impurity",
                                     num.trees=750,
                                     trControl=trainControl(method="repeatedcv", 
                                                            number=12,
                                                            repeats=3,
                                                            sampling="smote",
                                                            seeds=seed,
                                                            savePredictions=TRUE,
                                                            summaryFunction=cutoffSummary,
                                                            returnResamp="all",
                                                            classProbs=TRUE),
                                     tuneGrid=data.frame(mtry=13, splitrule="gini", min.node.size=10))
                             }

stopCluster(cl)

Create and save a summary object:

smryDropOut2_2 <- fstListDropOut2_2 %>% fstSummary()
smryDropOut2_2 %>% saveRDS("Model Status/SmryDropOut2_2.Rds")

The plot of performance suggests further performance gain from dropping F2_35 outliers, compared to our established set of dropped outliers.

list(smryDropOut0, smryDropOut1_1, smryDropOut2_2) %>%
  set_names(c("None", dropped, tryDrop) %>% str_remove("_Outlier")) %>%
  imap_dfr(~ .x %>% 
             extract2("resample") %>% 
             separate(Resample, c("Fold","Rep"), "\\.") %>% 
             group_by(Model, Rep) %>% 
             summarise_at(vars(AccAUC), mean, na.rm=TRUE) %>% 
             mutate(Dropped = .y)) %>% 
  mutate_at(vars(Dropped), factor, levels=c("None", dropped, tryDrop) %>% str_remove("_Outlier")) %>% 
  ggplot(aes(x=AccAUC, group=Dropped, fill=Dropped)) +
  geom_density(alpha=0.5)

A Wilcoxon rank-sum test indicates a significant performance gain from dropping F2_35 outliers, compared to our established set of dropped outliers.

list(smryDropOut1_1, smryDropOut2_2) %>%
  set_names(c(dropped[length(dropped)], tryDrop) %>% str_remove("_Outlier")) %>%
  imap_dfr(~ .x %>% 
             extract2("resample") %>% 
             separate(Resample, c("Fold","Rep"), "\\.") %>% 
             group_by(Model, Rep) %>% 
             summarise_at(vars(AccAUC), mean, na.rm=TRUE) %>% 
             mutate(Dropped = .y)) %>% 
  mutate_at(vars(Dropped), factor, 
            levels=c(dropped[length(dropped)], tryDrop) %>% str_remove("_Outlier")) %>% 
  wilcox.test(AccAUC ~ Dropped, ., alternative="less", exact=TRUE)

    Wilcoxon rank sum test

data:  AccAUC by Dropped
W = 14, p-value = 3.275e-06
alternative hypothesis: true location shift is less than 0

So we add F2_35 to our established set of dropped outliers, meaning we drop about 8% of tokens:

dropped <- c(dropped, tryDrop)
tibble(Dropped = "None", 
       Auto = trainingData %>% filter(HowCoded=="Auto") %>% nrow(),
       Hand = trainingData %>% filter(HowCoded=="Hand") %>% nrow()) %>% 
  rbind(
    cbind(Dropped = dropped,
          map_dfr(dropped %>% seq_along(),
                  ~ trainingData %>%
                    filter_at(vars(dropped[1:.x]), all_vars(!.)) %>%
                    count(HowCoded) %>%
                    spread(HowCoded, n)
          )
    )
  ) %>%
  mutate_at(vars(Auto, Hand), list(PctTossed = ~ (.[1] - .) / .[1]))

We re-rank measures based on the results of this list of classifiers:

(negOutliers <- fstListDropOut2_2 %>% outlierCors(dropped=dropped))

And we continue the procedure by training another list of 5 classifiers, this time on data that drops tokens with outliers in intens_F3min, in addition to our established set of dropped outliers:

rm(fstListDropOut2_2)

tryDrop <- negOutliers$Measure[1]

cl <- makeCluster(5)
registerDoParallel(cl)
clusterSetRNGStream(cl, 302302)

fstListDropOut3_1 <- foreach(seed = seedList, 
                             .packages=c("caret","dplyr")) %dopar% {
                               train(Rpresent ~ .,
                                     data=trainingData %>% 
                                       filter_at(vars(c(dropped, tryDrop)), all_vars(!.)) %>% 
                                       filter(HowCoded=="Hand") %>% 
                                       select(Rpresent, TokenDur:absSlopeF0),
                                     method="ranger",
                                     importance="impurity",
                                     num.trees=750,
                                     trControl=trainControl(method="repeatedcv", 
                                                            number=12,
                                                            repeats=3,
                                                            sampling="smote",
                                                            seeds=seed,
                                                            savePredictions=TRUE,
                                                            summaryFunction=cutoffSummary,
                                                            returnResamp="all",
                                                            classProbs=TRUE),
                                     tuneGrid=data.frame(mtry=13, splitrule="gini", min.node.size=10))
                             }

stopCluster(cl)

Create and save a summary object:

smryDropOut3_1 <- fstListDropOut3_1 %>% fstSummary()
smryDropOut3_1 %>% saveRDS("Model Status/SmryDropOut3_1.Rds")

The plot of performance suggests further performance gain from dropping intens_F3min outliers, compared to our established set of dropped outliers.

list(smryDropOut0, smryDropOut1_1, smryDropOut2_2, smryDropOut3_1) %>%
  set_names(c("None", dropped, tryDrop) %>% str_remove("_Outlier")) %>%
  imap_dfr(~ .x %>% 
             extract2("resample") %>% 
             separate(Resample, c("Fold","Rep"), "\\.") %>% 
             group_by(Model, Rep) %>% 
             summarise_at(vars(AccAUC), mean, na.rm=TRUE) %>% 
             mutate(Dropped = .y)) %>% 
  mutate_at(vars(Dropped), factor, levels=c("None", dropped, tryDrop) %>% str_remove("_Outlier")) %>% 
  ggplot(aes(x=AccAUC, group=Dropped, fill=Dropped)) +
  geom_density(alpha=0.5)

A Wilcoxon rank-sum test indicates a significant performance gain from dropping intens_F3min outliers, compared to our established set of dropped outliers.

list(smryDropOut2_2, smryDropOut3_1) %>%
  set_names(c(dropped[length(dropped)], tryDrop) %>% str_remove("_Outlier")) %>%
  imap_dfr(~ .x %>% 
             extract2("resample") %>% 
             separate(Resample, c("Fold","Rep"), "\\.") %>% 
             group_by(Model, Rep) %>% 
             summarise_at(vars(AccAUC), mean, na.rm=TRUE) %>% 
             mutate(Dropped = .y)) %>% 
  mutate_at(vars(Dropped), factor, 
            levels=c(dropped[length(dropped)], tryDrop) %>% str_remove("_Outlier")) %>% 
  wilcox.test(AccAUC ~ Dropped, ., alternative="less", exact=TRUE)

    Wilcoxon rank sum test

data:  AccAUC by Dropped
W = 29, p-value = 0.0001322
alternative hypothesis: true location shift is less than 0

So we add intens_F3min to our established set of dropped outliers, meaning we drop about 9.5% of tokens:

dropped <- c(dropped, tryDrop)
tibble(Dropped = "None", 
       Auto = trainingData %>% filter(HowCoded=="Auto") %>% nrow(),
       Hand = trainingData %>% filter(HowCoded=="Hand") %>% nrow()) %>% 
  rbind(
    cbind(Dropped = dropped,
          map_dfr(dropped %>% seq_along(),
                  ~ trainingData %>%
                    filter_at(vars(dropped[1:.x]), all_vars(!.)) %>%
                    count(HowCoded) %>%
                    spread(HowCoded, n)
          )
    )
  ) %>%
  mutate_at(vars(Auto, Hand), list(PctTossed = ~ (.[1] - .) / .[1]))

We re-rank measures based on the results of this list of classifiers:

(negOutliers <- fstListDropOut3_1 %>% outlierCors(dropped=dropped))

And we continue the procedure by training another list of 5 classifiers, this time on data that drops tokens with outliers in F1_70, in addition to our established set of dropped outliers:

rm(fstListDropOut3_1)

tryDrop <- negOutliers$Measure[1]

cl <- makeCluster(5)
registerDoParallel(cl)
clusterSetRNGStream(cl, 302302)

fstListDropOut4_1 <- foreach(seed = seedList, 
                             .packages=c("caret","dplyr")) %dopar% {
                               train(Rpresent ~ .,
                                     data=trainingData %>% 
                                       filter_at(vars(c(dropped, tryDrop)), all_vars(!.)) %>% 
                                       filter(HowCoded=="Hand") %>% 
                                       select(Rpresent, TokenDur:absSlopeF0),
                                     method="ranger",
                                     importance="impurity",
                                     num.trees=750,
                                     trControl=trainControl(method="repeatedcv", 
                                                            number=12,
                                                            repeats=3,
                                                            sampling="smote",
                                                            seeds=seed,
                                                            savePredictions=TRUE,
                                                            summaryFunction=cutoffSummary,
                                                            returnResamp="all",
                                                            classProbs=TRUE),
                                     tuneGrid=data.frame(mtry=13, splitrule="gini", min.node.size=10))
                             }

stopCluster(cl)

Create and save a summary object:

smryDropOut4_1 <- fstListDropOut4_1 %>% fstSummary()
smryDropOut4_1 %>% saveRDS("Model Status/SmryDropOut4_1.Rds")

The plot of performance suggests further performance gain from dropping F1_70 outliers, compared to our established set of dropped outliers.

list(smryDropOut0, smryDropOut1_1, smryDropOut2_2, smryDropOut3_1, 
     smryDropOut4_1) %>%
  set_names(c("None", dropped, tryDrop) %>% str_remove("_Outlier")) %>%
  imap_dfr(~ .x %>% 
             extract2("resample") %>% 
             separate(Resample, c("Fold","Rep"), "\\.") %>% 
             group_by(Model, Rep) %>% 
             summarise_at(vars(AccAUC), mean, na.rm=TRUE) %>% 
             mutate(Dropped = .y)) %>% 
  mutate_at(vars(Dropped), factor, levels=c("None", dropped, tryDrop) %>% str_remove("_Outlier")) %>% 
  ggplot(aes(x=AccAUC, group=Dropped, fill=Dropped)) +
  geom_density(alpha=0.5)

A Wilcoxon rank-sum test fails to indicate a significant performance gain from dropping intens_F3max outliers, compared to our established set of dropped outliers.

list(smryDropOut3_1, smryDropOut4_1) %>%
  set_names(c(dropped[length(dropped)], tryDrop) %>% str_remove("_Outlier")) %>%
  imap_dfr(~ .x %>% 
             extract2("resample") %>% 
             separate(Resample, c("Fold","Rep"), "\\.") %>% 
             group_by(Model, Rep) %>% 
             summarise_at(vars(AccAUC), mean, na.rm=TRUE) %>% 
             mutate(Dropped = .y)) %>% 
  mutate_at(vars(Dropped), factor, 
            levels=c(dropped[length(dropped)], tryDrop) %>% str_remove("_Outlier")) %>% 
  wilcox.test(AccAUC ~ Dropped, ., alternative="less", exact=TRUE)

    Wilcoxon rank sum test

data:  AccAUC by Dropped
W = 28, p-value = 0.0001075
alternative hypothesis: true location shift is less than 0

So we add F1_70 to our established set of dropped outliers, meaning we drop about 13% of tokens:

dropped <- c(dropped, tryDrop)
tibble(Dropped = "None", 
       Auto = trainingData %>% filter(HowCoded=="Auto") %>% nrow(),
       Hand = trainingData %>% filter(HowCoded=="Hand") %>% nrow()) %>% 
  rbind(
    cbind(Dropped = dropped,
          map_dfr(dropped %>% seq_along(),
                  ~ trainingData %>%
                    filter_at(vars(dropped[1:.x]), all_vars(!.)) %>%
                    count(HowCoded) %>%
                    spread(HowCoded, n)
          )
    )
  ) %>%
  mutate_at(vars(Auto, Hand), list(PctTossed = ~ (.[1] - .) / .[1]))

We re-rank measures based on the results of this list of classifiers:

(negOutliers <- fstListDropOut4_1 %>% outlierCors(dropped=dropped))

And we continue the procedure by training another list of 5 classifiers, this time on data that drops tokens with outliers in F1_50, in addition to our established set of dropped outliers:

rm(fstListDropOut4_1)

tryDrop <- negOutliers$Measure[1]

cl <- makeCluster(5)
registerDoParallel(cl)
clusterSetRNGStream(cl, 302302)

fstListDropOut5_1 <- foreach(seed = seedList, 
                             .packages=c("caret","dplyr")) %dopar% {
                               train(Rpresent ~ .,
                                     data=trainingData %>% 
                                       filter_at(vars(c(dropped, tryDrop)), all_vars(!.)) %>% 
                                       filter(HowCoded=="Hand") %>% 
                                       select(Rpresent, TokenDur:absSlopeF0),
                                     method="ranger",
                                     importance="impurity",
                                     num.trees=750,
                                     trControl=trainControl(method="repeatedcv", 
                                                            number=12,
                                                            repeats=3,
                                                            sampling="smote",
                                                            seeds=seed,
                                                            savePredictions=TRUE,
                                                            summaryFunction=cutoffSummary,
                                                            returnResamp="all",
                                                            classProbs=TRUE),
                                     tuneGrid=data.frame(mtry=13, splitrule="gini", min.node.size=10))
                             }

stopCluster(cl)

Create and save a summary object:

smryDropOut5_1 <- fstListDropOut5_1 %>% fstSummary()
smryDropOut5_1 %>% saveRDS("Model Status/SmryDropOut5_1.Rds")

The plot of performance suggests some further performance gain from dropping F1_50 outliers, compared to our established set of dropped outliers.

list(smryDropOut0, smryDropOut1_1, smryDropOut2_2, smryDropOut3_1, 
     smryDropOut4_1, smryDropOut5_1) %>%
  set_names(c("None", dropped, tryDrop) %>% str_remove("_Outlier")) %>%
  imap_dfr(~ .x %>% 
             extract2("resample") %>% 
             separate(Resample, c("Fold","Rep"), "\\.") %>% 
             group_by(Model, Rep) %>% 
             summarise_at(vars(AccAUC), mean, na.rm=TRUE) %>% 
             mutate(Dropped = .y)) %>% 
  mutate_at(vars(Dropped), factor, levels=c("None", dropped, tryDrop) %>% str_remove("_Outlier")) %>% 
  ggplot(aes(x=AccAUC, group=Dropped, fill=Dropped)) +
  geom_density(alpha=0.5)

A Wilcoxon rank-sum test indicates a significant performance gain from dropping F1_50 outliers, compared to our established set of dropped outliers.

list(smryDropOut4_1, smryDropOut5_1) %>%
  set_names(c(dropped[length(dropped)], tryDrop) %>% str_remove("_Outlier")) %>%
  imap_dfr(~ .x %>% 
             extract2("resample") %>% 
             separate(Resample, c("Fold","Rep"), "\\.") %>% 
             group_by(Model, Rep) %>% 
             summarise_at(vars(AccAUC), mean, na.rm=TRUE) %>% 
             mutate(Dropped = .y)) %>% 
  mutate_at(vars(Dropped), factor, 
            levels=c(dropped[length(dropped)], tryDrop) %>% str_remove("_Outlier")) %>% 
  wilcox.test(AccAUC ~ Dropped, ., alternative="less", exact=TRUE)

    Wilcoxon rank sum test

data:  AccAUC by Dropped
W = 53, p-value = 0.0064
alternative hypothesis: true location shift is less than 0

So we add F1_50 to our established set of dropped outliers, meaning we drop about 15% of tokens:

dropped <- c(dropped, tryDrop)
tibble(Dropped = "None", 
       Auto = trainingData %>% filter(HowCoded=="Auto") %>% nrow(),
       Hand = trainingData %>% filter(HowCoded=="Hand") %>% nrow()) %>% 
  rbind(
    cbind(Dropped = dropped,
          map_dfr(dropped %>% seq_along(),
                  ~ trainingData %>%
                    filter_at(vars(dropped[1:.x]), all_vars(!.)) %>%
                    count(HowCoded) %>%
                    spread(HowCoded, n)
          )
    )
  ) %>%
  mutate_at(vars(Auto, Hand), list(PctTossed = ~ (.[1] - .) / .[1]))

We re-rank measures based on the results of this list of classifiers:

(negOutliers <- fstListDropOut5_1 %>% outlierCors(dropped=dropped))

And we continue the procedure by training another list of 5 classifiers, this time on data that drops tokens with outliers in F3min, in addition to our established set of dropped outliers:

rm(fstListDropOut5_1)

tryDrop <- negOutliers$Measure[1]

cl <- makeCluster(5)
registerDoParallel(cl)
clusterSetRNGStream(cl, 302302)

fstListDropOut6_1 <- foreach(seed = seedList, 
                             .packages=c("caret","dplyr")) %dopar% {
                               train(Rpresent ~ .,
                                     data=trainingData %>% 
                                       filter_at(vars(c(dropped, tryDrop)), all_vars(!.)) %>% 
                                       filter(HowCoded=="Hand") %>% 
                                       select(Rpresent, TokenDur:absSlopeF0),
                                     method="ranger",
                                     importance="impurity",
                                     num.trees=750,
                                     trControl=trainControl(method="repeatedcv", 
                                                            number=12,
                                                            repeats=3,
                                                            sampling="smote",
                                                            seeds=seed,
                                                            savePredictions=TRUE,
                                                            summaryFunction=cutoffSummary,
                                                            returnResamp="all",
                                                            classProbs=TRUE),
                                     tuneGrid=data.frame(mtry=13, splitrule="gini", min.node.size=10))
                             }

stopCluster(cl)

Create and save a summary object:

smryDropOut6_1 <- fstListDropOut6_1 %>% fstSummary()
smryDropOut6_1 %>% saveRDS("Model Status/SmryDropOut6_1.Rds")

The plot of performance suggests some further performance gain from dropping F3min outliers, compared to our established set of dropped outliers.

list(smryDropOut0, smryDropOut1_1, smryDropOut2_2, smryDropOut3_1, 
     smryDropOut4_1, smryDropOut5_1, smryDropOut6_1) %>%
  set_names(c("None", dropped, tryDrop) %>% str_remove("_Outlier")) %>%
  imap_dfr(~ .x %>% 
             extract2("resample") %>% 
             separate(Resample, c("Fold","Rep"), "\\.") %>% 
             group_by(Model, Rep) %>% 
             summarise_at(vars(AccAUC), mean, na.rm=TRUE) %>% 
             mutate(Dropped = .y)) %>% 
  mutate_at(vars(Dropped), factor, levels=c("None", dropped, tryDrop) %>% str_remove("_Outlier")) %>% 
  ggplot(aes(x=AccAUC, group=Dropped, fill=Dropped)) +
  geom_density(alpha=0.5)

A Wilcoxon rank-sum test indicates a significant performance gain from dropping F3min outliers, compared to our established set of dropped outliers.

list(smryDropOut5_1, smryDropOut6_1) %>%
  set_names(c(dropped[length(dropped)], tryDrop) %>% str_remove("_Outlier")) %>%
  imap_dfr(~ .x %>% 
             extract2("resample") %>% 
             separate(Resample, c("Fold","Rep"), "\\.") %>% 
             group_by(Model, Rep) %>% 
             summarise_at(vars(AccAUC), mean, na.rm=TRUE) %>% 
             mutate(Dropped = .y)) %>% 
  mutate_at(vars(Dropped), factor, 
            levels=c(dropped[length(dropped)], tryDrop) %>% str_remove("_Outlier")) %>% 
  wilcox.test(AccAUC ~ Dropped, ., alternative="less", exact=TRUE)

    Wilcoxon rank sum test

data:  AccAUC by Dropped
W = 31, p-value = 0.000197
alternative hypothesis: true location shift is less than 0

So we add F3min to our established set of dropped outliers, meaning we drop about 17% of tokens:

dropped <- c(dropped, tryDrop)
tibble(Dropped = "None", 
       Auto = trainingData %>% filter(HowCoded=="Auto") %>% nrow(),
       Hand = trainingData %>% filter(HowCoded=="Hand") %>% nrow()) %>% 
  rbind(
    cbind(Dropped = dropped,
          map_dfr(dropped %>% seq_along(),
                  ~ trainingData %>%
                    filter_at(vars(dropped[1:.x]), all_vars(!.)) %>%
                    count(HowCoded) %>%
                    spread(HowCoded, n)
          )
    )
  ) %>%
  mutate_at(vars(Auto, Hand), list(PctTossed = ~ (.[1] - .) / .[1]))

We re-rank measures based on the results of this list of classifiers:

(negOutliers <- fstListDropOut6_1 %>% outlierCors(dropped=dropped))

And we continue the procedure by training another list of 5 classifiers, this time on data that drops tokens with outliers in F4_40, in addition to our established set of dropped outliers:

rm(fstListDropOut6_1)

tryDrop <- negOutliers$Measure[1]

cl <- makeCluster(5)
registerDoParallel(cl)
clusterSetRNGStream(cl, 302302)

fstListDropOut7_1 <- foreach(seed = seedList, 
                             .packages=c("caret","dplyr")) %dopar% {
                               train(Rpresent ~ .,
                                     data=trainingData %>% 
                                       filter_at(vars(c(dropped, tryDrop)), all_vars(!.)) %>% 
                                       filter(HowCoded=="Hand") %>% 
                                       select(Rpresent, TokenDur:absSlopeF0),
                                     method="ranger",
                                     importance="impurity",
                                     num.trees=750,
                                     trControl=trainControl(method="repeatedcv", 
                                                            number=12,
                                                            repeats=3,
                                                            sampling="smote",
                                                            seeds=seed,
                                                            savePredictions=TRUE,
                                                            summaryFunction=cutoffSummary,
                                                            returnResamp="all",
                                                            classProbs=TRUE),
                                     tuneGrid=data.frame(mtry=13, splitrule="gini", min.node.size=10))
                             }

stopCluster(cl)

Create and save a summary object:

smryDropOut7_1 <- fstListDropOut7_1 %>% fstSummary()
smryDropOut7_1 %>% saveRDS("Model Status/SmryDropOut7_1.Rds")

The plot of performance suggests little performance gain from dropping F4_40 outliers, compared to our established set of dropped outliers.

list(smryDropOut0, smryDropOut1_1, smryDropOut2_2, smryDropOut3_1, 
     smryDropOut4_1, smryDropOut5_1, smryDropOut6_1, smryDropOut7_1) %>%
  set_names(c("None", dropped, tryDrop) %>% str_remove("_Outlier")) %>%
  imap_dfr(~ .x %>% 
             extract2("resample") %>% 
             separate(Resample, c("Fold","Rep"), "\\.") %>% 
             group_by(Model, Rep) %>% 
             summarise_at(vars(AccAUC), mean, na.rm=TRUE) %>% 
             mutate(Dropped = .y)) %>% 
  mutate_at(vars(Dropped), factor, levels=c("None", dropped, tryDrop) %>% str_remove("_Outlier")) %>% 
  ggplot(aes(x=AccAUC, group=Dropped, fill=Dropped)) +
  geom_density(alpha=0.5)

A Wilcoxon rank-sum test fails to indicate a significant performance gain from dropping F4_40 outliers, compared to our established set of dropped outliers.

list(smryDropOut6_1, smryDropOut7_1) %>%
  set_names(c(dropped[length(dropped)], tryDrop) %>% str_remove("_Outlier")) %>%
  imap_dfr(~ .x %>% 
             extract2("resample") %>% 
             separate(Resample, c("Fold","Rep"), "\\.") %>% 
             group_by(Model, Rep) %>% 
             summarise_at(vars(AccAUC), mean, na.rm=TRUE) %>% 
             mutate(Dropped = .y)) %>% 
  mutate_at(vars(Dropped), factor, 
            levels=c(dropped[length(dropped)], tryDrop) %>% str_remove("_Outlier")) %>% 
  wilcox.test(AccAUC ~ Dropped, ., alternative="less", exact=TRUE)

    Wilcoxon rank sum test

data:  AccAUC by Dropped
W = 119, p-value = 0.6126
alternative hypothesis: true location shift is less than 0

So we move on to the next measure in the ranking, F4_50, training a list of classifiers on data that drops outliers in F4_50 in addition to our established set of dropped outliers.

rm(fstListDropOut7_1)

tryDrop <- negOutliers$Measure[2]

cl <- makeCluster(5)
registerDoParallel(cl)
clusterSetRNGStream(cl, 302302)

fstListDropOut7_2 <- foreach(seed = seedList, 
                             .packages=c("caret","dplyr")) %dopar% {
                               train(Rpresent ~ .,
                                     data=trainingData %>% 
                                       filter_at(vars(c(dropped, tryDrop)), all_vars(!.)) %>% 
                                       filter(HowCoded=="Hand") %>% 
                                       select(Rpresent, TokenDur:absSlopeF0),
                                     method="ranger",
                                     importance="impurity",
                                     num.trees=750,
                                     trControl=trainControl(method="repeatedcv", 
                                                            number=12,
                                                            repeats=3,
                                                            sampling="smote",
                                                            seeds=seed,
                                                            savePredictions=TRUE,
                                                            summaryFunction=cutoffSummary,
                                                            returnResamp="all",
                                                            classProbs=TRUE),
                                     tuneGrid=data.frame(mtry=13, splitrule="gini", min.node.size=10))
                             }

stopCluster(cl)

Create and save a summary object:

smryDropOut7_2 <- fstListDropOut7_2 %>% fstSummary()
smryDropOut7_2 %>% saveRDS("Model Status/SmryDropOut7_2.Rds")

The plot of performance suggests little performance gain from dropping F4_50 outliers, compared to our established set of dropped outliers.

list(smryDropOut0, smryDropOut1_1, smryDropOut2_2, smryDropOut3_1, 
     smryDropOut4_1, smryDropOut5_1, smryDropOut6_1, smryDropOut7_2) %>%
  set_names(c("None", dropped, tryDrop) %>% str_remove("_Outlier")) %>%
  imap_dfr(~ .x %>% 
             extract2("resample") %>% 
             separate(Resample, c("Fold","Rep"), "\\.") %>% 
             group_by(Model, Rep) %>% 
             summarise_at(vars(AccAUC), mean, na.rm=TRUE) %>% 
             mutate(Dropped = .y)) %>% 
  mutate_at(vars(Dropped), factor, levels=c("None", dropped, tryDrop) %>% str_remove("_Outlier")) %>% 
  ggplot(aes(x=AccAUC, group=Dropped, fill=Dropped)) +
  geom_density(alpha=0.5)

A Wilcoxon rank-sum test fails to indicate a significant performance gain from dropping F4_50 outliers, compared to our established set of dropped outliers.

list(smryDropOut6_1, smryDropOut7_2) %>%
  set_names(c(dropped[length(dropped)], tryDrop) %>% str_remove("_Outlier")) %>%
  imap_dfr(~ .x %>% 
             extract2("resample") %>% 
             separate(Resample, c("Fold","Rep"), "\\.") %>% 
             group_by(Model, Rep) %>% 
             summarise_at(vars(AccAUC), mean, na.rm=TRUE) %>% 
             mutate(Dropped = .y)) %>% 
  mutate_at(vars(Dropped), factor, 
            levels=c(dropped[length(dropped)], tryDrop) %>% str_remove("_Outlier")) %>% 
  wilcox.test(AccAUC ~ Dropped, ., alternative="less", exact=TRUE)

    Wilcoxon rank sum test

data:  AccAUC by Dropped
W = 138, p-value = 0.8573
alternative hypothesis: true location shift is less than 0

So we move on to the next measure in the ranking, F1_60, training a list of classifiers on data that drops outliers in F1_60 in addition to our established set of dropped outliers. Since that’s been two consecutive nonsignificant results, we’ll stop this process if the next result is also nonsignificant.

rm(fstListDropOut7_2)

tryDrop <- negOutliers$Measure[3]

cl <- makeCluster(5)
registerDoParallel(cl)
clusterSetRNGStream(cl, 302302)

fstListDropOut7_3 <- foreach(seed = seedList, 
                             .packages=c("caret","dplyr")) %dopar% {
                               train(Rpresent ~ .,
                                     data=trainingData %>% 
                                       filter_at(vars(c(dropped, tryDrop)), all_vars(!.)) %>% 
                                       filter(HowCoded=="Hand") %>% 
                                       select(Rpresent, TokenDur:absSlopeF0),
                                     method="ranger",
                                     importance="impurity",
                                     num.trees=750,
                                     trControl=trainControl(method="repeatedcv", 
                                                            number=12,
                                                            repeats=3,
                                                            sampling="smote",
                                                            seeds=seed,
                                                            savePredictions=TRUE,
                                                            summaryFunction=cutoffSummary,
                                                            returnResamp="all",
                                                            classProbs=TRUE),
                                     tuneGrid=data.frame(mtry=13, splitrule="gini", min.node.size=10))
                             }

stopCluster(cl)

Create and save a summary object:

smryDropOut7_3 <- fstListDropOut7_3 %>% fstSummary()
smryDropOut7_3 %>% saveRDS("Model Status/SmryDropOut7_3.Rds")

The plot of performance suggests little performance gain from dropping F1_60 outliers, compared to our established set of dropped outliers.

list(smryDropOut0, smryDropOut1_1, smryDropOut2_2, smryDropOut3_1, 
     smryDropOut4_1, smryDropOut5_1, smryDropOut6_1, smryDropOut7_3) %>%
  set_names(c("None", dropped, tryDrop) %>% str_remove("_Outlier")) %>%
  imap_dfr(~ .x %>% 
             extract2("resample") %>% 
             separate(Resample, c("Fold","Rep"), "\\.") %>% 
             group_by(Model, Rep) %>% 
             summarise_at(vars(AccAUC), mean, na.rm=TRUE) %>% 
             mutate(Dropped = .y)) %>% 
  mutate_at(vars(Dropped), factor, levels=c("None", dropped, tryDrop) %>% str_remove("_Outlier")) %>% 
  ggplot(aes(x=AccAUC, group=Dropped, fill=Dropped)) +
  geom_density(alpha=0.5)

A Wilcoxon rank-sum test fails to indicate a significant performance gain from dropping F1_60 outliers, compared to our established set of dropped outliers.

list(smryDropOut6_1, smryDropOut7_3) %>%
  set_names(c(dropped[length(dropped)], tryDrop) %>% str_remove("_Outlier")) %>%
  imap_dfr(~ .x %>% 
             extract2("resample") %>% 
             separate(Resample, c("Fold","Rep"), "\\.") %>% 
             group_by(Model, Rep) %>% 
             summarise_at(vars(AccAUC), mean, na.rm=TRUE) %>% 
             mutate(Dropped = .y)) %>% 
  mutate_at(vars(Dropped), factor, 
            levels=c(dropped[length(dropped)], tryDrop) %>% str_remove("_Outlier")) %>% 
  wilcox.test(AccAUC ~ Dropped, ., alternative="less", exact=TRUE)

    Wilcoxon rank sum test

data:  AccAUC by Dropped
W = 74, p-value = 0.05799
alternative hypothesis: true location shift is less than 0

Since that’s been three consecutive nonsignificant results, we stop our outlier-dropping process there.

rm(fstListDropOut7_3)

Summary: Outlier dropping

We’ve dropped outliers in six measures for which outliers significantly hurt classifier performance: F3_80, F2_35, intens_F3min, F1_70, F1_50, and F3min. We determined which outliers to drop not in terms of variable importance—most of these measures did not rank particularly high in variable importance—but in terms of which measures’ outliers were most negatively correlated with classifier performance.

dropped %>% 
  str_remove("_Outlier") %>% 
  set_names(., .) %>% 
  map_int(~ smryTuned$varImp %>% sort(decreasing=TRUE) %>% names() %>% equals(.x) %>% which())

       F3_80        F2_35 intens_F3min        F1_70        F1_50 
          39          114           13           50           58 
       F3min 
          18 

Dropping these outliers comes at the price of about 1/6 of all auto-coded and hand-coded tokens.

tibble(Dropped = "None", 
       Auto = trainingData %>% filter(HowCoded=="Auto") %>% nrow(),
       Hand = trainingData %>% filter(HowCoded=="Hand") %>% nrow()) %>% 
  rbind(
    cbind(Dropped = dropped,
          map_dfr(dropped %>% seq_along(),
                  ~ trainingData %>%
                    filter_at(vars(dropped[1:.x]), all_vars(!.)) %>%
                    count(HowCoded) %>%
                    spread(HowCoded, n)
          )
    )
  ) %>%
  mutate_at(vars(Auto, Hand), list(PctTossed = ~ (.[1] - .) / .[1]))

The loss of these tokens pays off in an incremental increase in the performance of our classifier.

list(smryDropOut0, smryDropOut1_1, smryDropOut2_2, smryDropOut3_1, 
     smryDropOut4_1, smryDropOut5_1, smryDropOut6_1) %>%
  set_names(c("None", dropped) %>% str_remove("_Outlier")) %>%
  imap_dfr(~ .x %>% 
             extract2("resample") %>% 
             separate(Resample, c("Fold","Rep"), "\\.") %>% 
             group_by(Model, Rep) %>% 
             summarise_at(vars(AccAUC), mean, na.rm=TRUE) %>% 
             mutate(Dropped = .y)) %>% 
  mutate_at(vars(Dropped), factor, levels=c("None", dropped) %>% str_remove("_Outlier")) %>% 
  ggplot(aes(x=AccAUC, group=Dropped, fill=Dropped)) +
  geom_density(alpha=0.5)

list(smryDropOut0, smryDropOut1_1, smryDropOut2_2, smryDropOut3_1, 
     smryDropOut4_1, smryDropOut5_1, smryDropOut6_1) %>%
  set_names(c("None", dropped) %>% str_remove("_Outlier")) %>%
  imap_dfr(~ .x %>% 
             extract2("resample") %>% 
             mutate(Dropped = .y)) %>% 
  mutate_at(vars(Dropped), factor, levels=c("None", dropped) %>% str_remove("_Outlier")) %>% 
  select(-Model) %>% 
  group_by(Dropped) %>% 
  summarise_if(is.numeric, mean, na.rm=TRUE)