Nothing
#' @title Performance measures for regression and classification models
#' @name accuracy
#' @family performance
#'
#' @description \code{\link{cat2meas}} and \code{\link{tab2meas}} calculate the measures for a multiclass classification model.\cr
#' \code{\link{pred2meas}} calculates the measures for a regression model.
#'
#' @details
#' \itemize{
#' \item \code{\link{cat2meas}} compute \eqn{tab=table(yobs,ypred)} and calls \code{\link{tab2meas}} function.
#' \item \code{\link{tab2meas}} function computes the following measures (see \code{measure} argument) for a binary classification model:
#' \itemize{
#' \item \code{accuracy}{ the accuracy classification score}
#' \item \code{recall}, \code{sensitivity,TPrate}{ \eqn{R=TP/(TP+FN)}}
#' \item \code{precision}{ \eqn{P=TP/(TP+FP)}}
#' \item \code{specificity},\code{TNrate}{ \eqn{TN/(TN+FP)}}
#' \item \code{FPrate}{ \eqn{FP/(TN+FP)}}
#' \item \code{FNrate}{ \eqn{FN/(TP+FN)}}
#' \item \code{Fmeasure}{ \eqn{2/(1/R+1/P)}}
#' \item \code{Gmean}{ \eqn{sqrt(R*TN/(TN+FP))}}
#' \item \code{kappa}{ the kappa index}
#' \item \code{cost}{ \eqn{sum(diag(tab)/rowSums(tab)*cost)/sum(cost)}}
#' \item \code{IOU}{ \eqn{TP/(TP+FN+FP)}} mean of Intersection over Union
#' \item \code{IOU4class}{ \eqn{TP/(TP+FN+FP)}} Intersection over Union by level
#' }
#\item \code{\link{tab2meas}} function computes the \code{accuracy}, \code{kappa} and \code{cost} measures for a multiclass vectors-
#' \item \code{\link{pred2meas}} function computes the following measures of error, usign the \code{measure} argument, for observed and predicted vectors:
#' \itemize{
#' \item \code{MSE}{ Mean squared error, \eqn{\frac{\sum{(ypred- yobs)^2}}{n} }{\sum (ypred- yobs)^2 /n }}
#' \item \code{RMSE}{ Root mean squared error \eqn{\sqrt{\frac{\sum{(ypred- yobs)^2}}{n} }}{\sqrt(\sum (ypred- yobs)^2 /n )}}
#' \item \code{MAE}{ Mean Absolute Error, \eqn{\frac{\sum |yobs - ypred|}{n}}{\sum |yobs - ypred| /n}}
#' }
#' }
#'
#' @param yobs A vector of the labels, true class or observed response. Can be \code{numeric}, \code{character}, or \code{factor}.
#' @param ypred A vector of the predicted labels, predicted class or predicted response. Can be \code{numeric, character, or factor}.
#' @param tab Confusion matrix (Contingency table: observed class by rows, predicted class by columns).
#' @param measure Type of measure, see \code{details} section.
#' @param cost Cost value by class (only for input factors).
#' @aliases cat2meas tab2meas pred2meas.
#'
#' @rdname accuracy
#' @export
cat2meas <- function(yobs,ypred,measure="accuracy",cost=rep(1,nlevels(yobs))){
tab<-table(yobs,ypred)
res<-tab2meas(tab,measure=measure,cost=cost)
return(res)
}
#' @rdname accuracy
#' @export
tab2meas <- function(tab, measure="accuracy", cost=rep(1,nrow(tab))){
if (nrow(tab)!=ncol(tab)) stop("nrow(tab)!=ncol(tab)")
nlev <- nrow(tab)
if (nlev==2) {
TP <- tab[2,2]
FN <- tab[2,1]
FP <- tab[1,2]
TN <- tab[1,1]
R <- TP/(TP+FN)
P <- TP/(TP+FP)
nmeas <- length(measure)
meas <- numeric(nmeas)
for (i in seq_len(nmeas)){
meas[i]<-switch(measure[i],
recall=R,
sensitivity=R,
TPrate=R,
specificity=TN/(TN+FP),
TNrate=TN/(TN+FP),
FPrate=FP/(TN+FP),
FNrate=FN/(TP+FN),
precision=P,
NPvalue=TN/(TN+FN),
Fmeasure=2/(1/R+1/P),
F1=2*P*R/(R+P),
F2=5*P*R/(4*R+P),
Gmean=sqrt(R*TN/(TN+FP)),
accuracy=tab2accuracy(tab),
kappa=tab2kappa(tab),
cost=sum(diag(tab)/rowSums(tab)*cost)/sum(cost),
IOU=tab2IOU(tab),
IOU4class=tab2IOU4class(tab)
# cost=1-sum(c(FN,FP)*cost)/sum(table(yobs)*cost)
)
}
names(meas) <- measure
return(meas)
} else {
TP <- diag(tab)
Tobs <- rowSums(tab)
Tpred <- colSums(tab)
R <- TP/Tobs
P <- TP/Tpred
#FN = tab[2,1]
#FP = tab[1,2]
#TN = tab[1,1]
#R = TP/(TP+FN)
#P = TP/(TP+FP)
nmeas <- length(measure)
meas <- numeric(nmeas)
if (nmeas>1) warning("For multiclass problems only the first measure is returned")
#for (i in 1:nmeas){
meas<-switch(measure[1],
recall = R,
sensitivity = R,
TPrate = R,
#specificity=TN/(TN+FP),
#TNrate=TN/(TN+FP),
#FPrate=FP/(TN+FP),
#FNrate=FN/(TP+FN),
precision = P,
#NPvalue=TN/(TN+FN),
Fmeasure = 2/(1/R+1/P),
F1 = 2*P*R/(R+P),
F2 = 5*P*R/(4*R+P),
#Gmean=sqrt(R*TN/(TN+FP)),
cost = sum(diag(tab)/rowSums(tab)*cost)/sum(cost),
accuracy = tab2accuracy(tab),
#waccuracy=tab2waccuracy(tab),
kappa = tab2kappa(tab),
IOU=tab2IOU(tab),
IOU4class=tab2IOU4class(tab)
)
}
#names(meas) = measure
return(meas)
}
cat2alpha <-function(yobs, ypred, weights, coeflearn="Freund"){
ind <- as.numeric(yobs != ypred)
n <- length(yobs)
if (missing(weights)) weights <- rep(1,len=n)
if (sum(weights)!=1) weights <- weights/sum(weights)
err <- mean(weights*ind)
alpha <- log((1-err)/err)
if (coeflearn=="Breiman"){ alpha <- (1/2) * alpha }
if (coeflearn=="Zhu") { alpha <- alpha + log( nlevels(yobs) - 1) }
if (alpha<0) alpha<-0
if(alpha==Inf) alpha<-10
return(list("error"=err,"alpha"=alpha))
}
# @export cat2accuracy
# @format none
cat2accuracy= function(yobs,ypred){
mean(ypred == yobs)
}
# @export cat2waccuracy
# @format none
# cat2waccuracy = function(yobs, ypred) {
# lvls <- levels(yobs)
# accs <- lapply(lvls, function(x) {
# idx <- which(yobs == x)
# return(meas2accuracy( yobs[idx], ypred[idx]))
# })
# acc <- mean(unlist(accs))
# return(acc)
# }
# @export cat2wkappa
# @format none
cat2wkappa = function(yobs,ypred){
cat2meas(yobs=yobs,ypred=ypred,measure="wkappa")
}
# @export cat2kappa
# @format none
cat2kappa = function(yobs,ypred){
cat2meas(yobs=yobs,ypred=ypred,measure="kappa")
}
############################################################
# @export tab2accuracy
# @format none
tab2accuracy = function(tab){
sum(diag(tab))/sum(tab)
}
# @export tab2SAE
tab2SAE = function(tab){
n <- sum(tab)
#nc = nrow(tab)
#diag = diag(tab)
#rowsums = apply(tab, 1, sum)
#colsums = apply(tab, 2, sum)
p <- apply(tab, 1, sum) / n
q <- apply(tab, 2, sum) / n
expAccuracy <- sum(p*q)
accuracy <- sum(diag(tab)) / n
res<-(accuracy - expAccuracy) / (1 - expAccuracy)
res
}
# @export tab2kappa
tab2kappa = function (tab) {
#function (truth, response) {
#conf.mat = table(truth, response)
conf.mat <- tab/sum(tab)
p0 <- sum(diag(conf.mat))
rowsum <- rowSums(conf.mat)
colsum <- colSums(conf.mat)
pe <- sum(rowsum * colsum)/sum(conf.mat)^2
1 - (1 - p0)/(1 - pe)
}
# @export tab2wkappa
tab2wkappa = function (tab) {
lev <- rownames(tab)
conf.mat <- tab/sum(tab)
rowsum <- rowSums(conf.mat)
colsum <- colSums(conf.mat)
expected.mat <- rowsum %*% t(colsum)
class.values <- seq_along(lev) - 1L
weights <- outer(class.values, class.values,
FUN = function(x, y) (x - y)^2)
1 - sum(weights * conf.mat)/sum(weights * expected.mat)
}
# @export cat2IOU
# @format none
cat2IOU4class = function(yobs,ypred){
tab2IOU4class(table(yobs,ypred))
}
# @rdname accuracy
# @export
tab2IOU4class<-function(tab){
nclass<-NROW(tab)
vf<-c(rep(NA,nclass))
for (j in 1:nclass){
TP<-diag(tab)[j]
FP<-sum(tab[j,])-TP
FN<-sum(tab[,j])-TP
iou<-TP/(TP+FP+FN)
vf[j]<-iou
}
return(vf)
}
# @export cat2IOU
# @format none
cat2IOU = function(yobs,ypred){
tab2IOU(table(yobs,ypred))
}
tab2IOU<-function(tab){
nclass<-NROW(tab)
vf2<-c(rep(NA,nclass))
TP<-diag(tab)
for (j in 1:nclass){
FP<-sum(tab[j,])-TP[j]
FN<-sum(tab[,j])-TP[j]
vf2[j]<-(TP[j]+FP+FN)
}
return(sum(TP)/sum(vf2))
}
#' @rdname accuracy
#' @export pred.MSE
pred.MSE = function (yobs, ypred) {
mean((ypred- yobs)^2)
}
# @format none
#' @rdname accuracy
#' @export pred.RMSE
pred.RMSE = function (yobs, ypred) {
sqrt(pred.MSE(yobs, ypred))
}
# @format none
#' @rdname accuracy
#' @export pred.MAE
pred.MAE = function (yobs, ypred) {
mean(abs(yobs - ypred))
}
#' @rdname accuracy
#' @export
pred2meas = function(yobs, ypred, measure="RMSE"){
nmeas <- length(measure)
meas <- numeric(nmeas)
for (i in seq_len(nmeas)){
meas[i]<-switch(measure[i],
RMSE=pred.RMSE(yobs, ypred),
MAE=pred.MAE(yobs, ypred),
MSE = pred.MSE(yobs, ypred)
)
}
names(meas) <- measure
return(meas)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.