#' @useDynLib ModelMetrics
#' @importFrom Rcpp sourceCpp
NULL
#' Test data
#'
#' @name testDF
#' @docType data
NULL
#' @title Multiclass Log Loss
#'
#' @description Calculated the multi-class log loss
#'
#' @param actual A vector of the labels. Can be \code{numeric, character, or factor}
#' @param predicted matrix of predicted values. Can be \code{matrix, data.frame}
#'
#' @export
mlogLoss <- function(actual, predicted){
if(any(class(actual) %in% c('factor', 'character'))){
actual = as.numeric(as.factor(actual))
}
if(any(class(predicted) %in% c('data.frame'))){
predicted = as.matrix(predicted)
}
eps <- 1e-15
predicted = pmax(pmin(predicted, 1 - eps), eps)
mlogLoss_(actual, predicted)
}
#' @title Multiclass Area Under the Curve
#'
#' @description Calculates the area under the curve for a binary classifcation model
#'
#' @param actual A vector of the labels. Can be \code{numeric, character, or factor}
#' @param predicted A data.frame of predicted values. Can be \code{matrix, data.frame}
#'
#'
#' @examples
#' setosa <- glm(I(Species == 'setosa') ~ Sepal.Length, data = iris, family = 'binomial')
#' versicolor <- glm(I(Species == 'versicolor') ~ Sepal.Length, data = iris, family = 'binomial')
#' virginica <- glm(I(Species == 'virginica') ~ Sepal.Length, data = iris, family = 'binomial')
#'
#' Pred <-
#' data.frame(
#' setosa = predict(setosa, type = 'response')
#' ,versicolor = predict(versicolor, type = 'response')
#' ,virginica = predict(virginica, type = 'response')
#' )
#'
#' Predicted = Pred/rowSums(Pred)
#' Actual = iris$Species
#'
#' mauc(Actual, Predicted)
#'
#' @export
mauc <- function(actual, predicted){
actual <- factor(actual)
Data <- data.frame(predicted, actual)
Outcomes <- length(unique(actual))
simpleAUC <- function(x){
# One-vs-all
y1 = levels(Data$actual)[x]
y <- as.numeric(Data[, "actual"] == y1)
prob <- Data[,x]
AUCs <- auc(y, prob)
return(AUCs)
}
AUCs <- sapply(1:Outcomes, simpleAUC)
list(mauc = mean(AUCs), auc = AUCs)
}
#' @title Confusion Matrix
#' @description Create a confusion matrix given a specific cutoff.
#'
#' @param actual A vector of the labels
#' @param predicted A vector of predicted values
#' @param cutoff A cutoff for the predicted values
#' @param use_names If \code{TRUE}, the dimnames of the output matrix will be labelled to indicate
#' which axes show the actual and predicted classes.
#'
#' @examples
#' actual <- c(0, 0, 1)
#' predicted <- c(1, 0, 1)
#'
#' confusionMatrix(actual, predicted)
#'
#' confusionMatrix(actual, predicted, use_names = TRUE)
#'
#' @export
confusionMatrix <- function(actual, predicted, cutoff = .5, use_names = FALSE){
confusionMatrix_(actual, predicted, cutoff, use_names)
}
#' @title Positive Predictive Value
#'
#' @description True Positives / (True Positives + False Positives)
#'
#' @aliases precision
#'
#' @param actual A vector of the labels
#' @param predicted A vector of predicted values
#' @param cutoff A cutoff for the predicted values
#'
#' @examples
#' data(testDF)
#' glmModel <- glm(y ~ ., data = testDF, family="binomial")
#' Preds <- predict(glmModel, type = 'response')
#'
#' ppv(testDF$y, Preds, cutoff = 0)
#' precision(testDF$y, Preds, cutoff = 0)
#'
#' @export
ppv <- function(actual, predicted, cutoff = .5){
ppv_(actual, predicted, cutoff)
}
#' @export
precision <- function(actual, predicted, cutoff = .5){
ppv_(actual, predicted, cutoff)
}
#' @title Negative Predictive Value
#'
#' @description True Negatives / (True Negatives + False Negatives)
#'
#' @param actual A vector of the labels
#' @param predicted A vector of predicted values
#' @param cutoff A cutoff for the predicted values
#'
#' @examples
#' data(testDF)
#' glmModel <- glm(y ~ ., data = testDF, family="binomial")
#' Preds <- predict(glmModel, type = 'response')
#'
#' npv(testDF$y, Preds, cutoff = 0)
#'
#' @export
npv <- function(actual, predicted, cutoff = .5){
npv_(actual, predicted, cutoff)
}
#' @title Recall, Sensitivity, tpr
#'
#' @aliases sensitivity tpr
#'
#' @description True Positives / (True Positives + False Negatives)
#'
#' @param actual A vector of the labels
#' @param predicted A vector of predicted values
#' @param cutoff A cutoff for the predicted values
#'
#' @examples
#' data(testDF)
#' glmModel <- glm(y ~ ., data = testDF, family="binomial")
#' Preds <- predict(glmModel, type = 'response')
#'
#' recall(testDF$y, Preds, cutoff = 0)
#' sensitivity(testDF$y, Preds, cutoff = 0)
#' tpr(testDF$y, Preds, cutoff = 0)
#'
#' @export
recall <- function(actual, predicted, cutoff = .5){
recall_(actual, predicted, cutoff)
}
#' @export
sensitivity <- function(actual, predicted, cutoff = .5){
recall_(actual, predicted, cutoff)
}
#' @export
tpr <- function(actual, predicted, cutoff = .5){
recall_(actual, predicted, cutoff)
}
#' @title Specificity, True negative rate
#'
#' @aliases specificity tnr
#'
#' @description True Negatives / (True Negatives + False Positives)
#'
#' @param actual A vector of the labels
#' @param predicted A vector of predicted values
#' @param cutoff A cutoff for the predicted values
#'
#' @examples
#' data(testDF)
#' glmModel <- glm(y ~ ., data = testDF, family="binomial")
#' Preds <- predict(glmModel, type = 'response')
#'
#' tnr(testDF$y, Preds, cutoff = 0)
#' specificity(testDF$y, Preds, cutoff = 0)
#'
#' @export
tnr <- function(actual, predicted, cutoff = .5){
tnr_(actual, predicted, cutoff)
}
#' @export
specificity <- function(actual, predicted, cutoff = .5){
tnr_(actual, predicted, cutoff)
}
#' @title F1 Score
#' @description Calculates the f1 score
#'
#' @param actual A vector of the labels
#' @param predicted A vector of predicted values
#' @param cutoff A cutoff for the predicted values
#'
#' @export
f1Score <- function(actual, predicted, cutoff = .5){
f1Score_(actual, predicted, cutoff)
}
#' @title F Score
#' @description Calculates the F score and allows different specifications of the beta value (F0.5)
#'
#' @param actual A vector of the labels
#' @param predicted A vector of predicted values
#' @param cutoff A cutoff for the predicted values
#' @param beta the desired beta value (lower increases weight of precision over recall). Defaults to 1
#'
#' @export
fScore <- function(actual, predicted, cutoff = .5, beta = 1){
fScore_(actual, predicted, cutoff, beta)
}
#' @title Matthews Correlation Coefficient
#' @description Calculates the Matthews Correlation Coefficient
#'
#' @param actual A vector of the labels
#' @param predicted A vector of predicted values
#' @param cutoff A cutoff for the predicted values
#'
#' @export
mcc <- function(actual, predicted, cutoff){
mcc_(actual, predicted, cutoff)
}
#' @title kappa statistic
#'
#' @description Calculates kappa statistic. Currently build to handle binary values in \code{actual} vector.
#'
#' @param actual A vector of the labels
#' @param predicted A vector of predicted values
#' @param cutoff A cutoff for the predicted values
#'
#' @export
kappa <- function(actual, predicted, cutoff = .5){
kappa_(actual, predicted, cutoff)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.