#' Extract best model predictions
#'
#' Extracts best predictions from each resample from cv data
#' @param model The model to extract predictions from
#' @keywords model
#' @import data.table
#' @export
#'
ExtractBestPreds <- function(model){
best.pred.key <- data.table::data.table(model$bestTune, key = names(model$bestTune)) # save this
all.preds <- data.table::data.table(model$pred, key = names(model$bestTune))
best.pred <- all.preds[best.pred.key, ] # save this, and reorder?
data.table::setorderv(best.pred, c("rowIndex", "Resample"))
return(best.pred)}
#' Extract probabilities from class estimation predictions
#'
#' Extracts the probability that instances will be less than the target value
#' @param model The model to extract probabilities from
#' @keywords model
#' @export
ExtractDownProbs <- function(model){
down.probs <- model$DOWN
return(down.probs)}
#' Extract model performance
#'
#' Extracts all performance data from best model
#' @param model The model to extract performance from
#' @keywords model
#' @import data.table
#' @export
ExtractPerformance <- function(model){
best.pred.key <- data.table::data.table(model$bestTune, key = names(model$bestTune))
results.table <- data.table::data.table(model$results, key = names(model$bestTune))
results.table <- results.table[best.pred.key, ] # save this
return(results.table)}
#' Extract model kappa
#'
#' Extracts kappa from best model performance
#' @param model The model to extract kappa from
#' @keywords model
#' @export
ExtractKappa <- function(model){
Kappa <- model$Kappa
return(Kappa)}
#' Extract model accuracy
#'
#' Extracts accuracy from best model performance
#' @param model The model to extract accuracy from
#' @keywords model
#'@export
ExtractAccuracy <- function(model){
Accuracy <- model$Accuracy
return(Accuracy)}
#' Extract model accuracy standard deviation
#'
#' Extracts accuracy standard deviation of resamples from best model performance
#' @param model The model to extract accuracy SD from
#' @keywords model
#' @export
ExtractAccuracySD <- function(model){
AccuracySD <- model$AccuracySD
return(AccuracySD)}
#' Extract model kappa standard deviation
#'
#' Extracts kappa standard deviation of resamples from best model performance
#' @param model The model to extract kappa SD from
#' @keywords model
#' @export
ExtractKappaSD <- function(model){
KappaSD <- model$KappaSD
return(KappaSD)}
#' Calculate HDI
#'
#' Takes vector of pdf sample points and corresponding target variable values to
#' calculate the HDI at desired confidence level
#' @param sample.points Vector of target variable values corresponding to pdf
#' @param epdf Vector of epdf sample point values
#' @param cred Confidence level
#' @keywords model
#' @export
CalcHDI <- function(sample.points, epdf, cred = 0.90){
# check lengths
if(length(sample.points) != length(epdf)){
cat("Sample point and PDF vectors are of unequal lengths\n")
# if length is off by one, do interpolation automatically
if(length(sample.points)-1 == length(epdf)){
cat("Calculating sample points interpolation vector...\n\n")
sample.points <- (sample.points[1:length(sample.points)-1]
+ sample.points[2:length(sample.points)])/2
}
}
prob.mass <- epdf/sum(epdf)
sorted.mass <- sort(prob.mass, decreasing = TRUE)
HDI.height.id <- min(which(cumsum(sorted.mass) >= cred))
HDI.height <- sorted.mass[HDI.height.id]
HDI.mass <- sum(prob.mass[prob.mass >= HDI.height])
HDI.ids <- which(prob.mass >= HDI.height)
x0 <- sample.points[min(HDI.ids)]
x1 <- sample.points[max(HDI.ids)]
out <- list(interval = c(x0, x1))
return(out)
}
#' Check model list object
#'
#' Ensures model.list object contains all `train` objects
#' @param model.list List of model objects from TrainLEs function
#' @keywords model
#' @export
CheckModelList <- function(model.list){
if(is.list(model.list) != TRUE){
stop('The model.list object is not a list')
}
n.train <- sum((sapply(model.list, function(x)
class(x) == 'train')))
if(n.train != length(model.list)){
stop('The model.list object contains objects that are not models')
}
}
#' Check list lengths
#'
#' Ensures two objects are the same length
#' @param model.list List of model objects from TrainLEs function
#' @param y.vals Vector of y values being passed
#' @keywords model
#' @export
CheckLengths <- function(model.list, y.vals){
if(length(model.list) != length(y.vals)){
stop('Objects are of unequal lengths- check model list and y-values')
}
}
# function to calculate variable importance- TODO: validate VARIMP capability of base learner
# ExtractVarImp <- function(model){
# importance <- varImp(model)$importance$Overall
# return(importance)}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.