...
 
Commits (2)
#' Class and Prediction Objects
#'
#'
#' A virtual class for \code{bincap} and \code{multcap}.
#'
#'
#'
#'
#' @name cap-class
#' @docType class
#' @section Objects from the Class: A virtual Class: No objects may be created
......@@ -12,22 +12,23 @@
#' @export
#' @keywords internal
#' @keywords classes
setClass(Class = "cap"
, representation = representation(
response = "factor"
, "VIRTUAL"
)
, prototype = prototype(response = factor())
, validity = function(object){
}
)
setClass(
Class = "cap",
representation = representation(
response = "factor",
"VIRTUAL"
),
prototype = prototype(response = factor()),
validity = function(object) {
}
)
#' Binary Class and Prediction Objects
#'
#'
#' S4 class for a binary class response and corresponding (predicted)
#' probabilities.
#'
#'
#'
#'
#' @name bincap-class
#' @docType class
#' @note No defaults are set. Especially, you have to explicitly initialize
......@@ -47,35 +48,41 @@ setClass(Class = "cap"
#' @keywords classes
#' @export
#' @examples
#'
#'
#' showClass("bincap")
#'
setClass(Class = "bincap"
, contains = "cap"
, representation = representation(
predicted = "numeric"
, true = "character"
)
, prototype = prototype(predicted = numeric(), true = character() )
, validity = function(object){
if(length(object@response) != length(object@predicted))
return("response and predicted must have the same number of observations.")
if(any(object@predicted < 0, na.rm = TRUE) || any(object@predicted > 1, na.rm = TRUE))
return("probabilities should be in [0,1].")
if(length(object@true) > 1)
return("give a single character for the 'true'/'presence' class.")
if(length(levels(object@response)) > 2)
return("response has to be a binary class factor.")
}
)
setClass(
Class = "bincap",
contains = "cap",
representation = representation(
predicted = "numeric",
true = "character"
),
prototype = prototype(predicted = numeric(), true = character()),
validity = function(object) {
if (length(object@response) != length(object@predicted)) {
return(paste("response and predicted must have",
"the same number of observations."))
}
if (any(object@predicted < 0, na.rm = TRUE) || any(object@predicted > 1,
na.rm = TRUE)) {
return("probabilities should be in [0,1].")
}
if (length(object@true) > 1) {
return("give a single character for the 'true'/'presence' class.")
}
if (length(levels(object@response)) > 2) {
return("response has to be a binary class factor.")
}
}
)
#' Multiple Class and Prediction Objects
#'
#'
#' S4 class for a multiple class response and corresponding (predicted)
#' probabilities.
#'
#'
#'
#'
#' @name multcap-class
#' @docType class
#' @section Objects from the Class: Objects can be created by calls of the form
......@@ -87,50 +94,59 @@ setClass(Class = "bincap"
#' @keywords classes
#' @export
#' @examples
#'
#'
#' showClass("multcap")
#'
setClass(Class = "multcap"
, contains = "cap"
, representation = representation(
predicted = "matrix"
)
, prototype = prototype(predicted = matrix(nrow = 0, ncol = 0))
, validity = function(object){
p <- object@predicted
r <- object@response
if(! isTRUE(all.equal(sort(as.character(unique(r))), sort(levels(r)))))
warning(paste("found extraneous factor level(s) '"
, paste(setdiff(levels(r),as.character(unique(r))), collapse=', ')
,"' of response.\n"
, "You may want to work around this by 'response <- factor(response)'."
, sep = ''))
if(! all(levels(r) %in% dimnames(p)[[2]]))
warning(paste("found factor level(s) '"
, paste(setdiff(levels(r), dimnames(p)[[2]]), collapse=', ')
,"' of response unmatched by predicted."
, sep = ''))
if(! all(unique(r) %in% dimnames(p)[[2]], na.rm = TRUE))
return(paste("found value(s) '"
, setdiff(as.character(unique(r)), dimnames(p)[[2]])
, "' of response unmatched by predicted.\n"
, "You may want to add column(s) filled with NA to predicted."
, sep = '')
)
if(! all(dimnames(p)[[2]] %in% levels(r)))
return(paste("found column(s) '"
, paste(setdiff(dimnames(p)[[2]], levels(r)), collapse=', ')
,"' of predicted unmatched by levels(response)."
, sep = '')
)
if(length(r) != nrow(p))
return("response and predicted must have the same number of observations.")
if(any(p < 0, na.rm = TRUE) || any(p > 1, na.rm = TRUE))
return("probabilities should be in [0,1].")
if(! isTRUE(all.equal(rep(1,nrow(p)) ,as.numeric(rowSums(p, na.rm = TRUE)))))
return("row sums of predicted must be 1.")
}
)
setClass(
Class = "multcap",
contains = "cap",
representation = representation(
predicted = "matrix"
),
prototype = prototype(predicted = matrix(nrow = 0, ncol = 0)),
validity = function(object) {
p <- object@predicted
r <- object@response
if (!isTRUE(all.equal(sort(as.character(unique(r))), sort(levels(r))))) {
warning(paste("found extraneous factor level(s) '",
paste(setdiff(levels(r), as.character(unique(r))), collapse = ", "),
"' of response.\n",
"You may want to work around this by 'response <- factor(response)'.",
sep = ""
))
}
if (!all(levels(r) %in% dimnames(p)[[2]])) {
warning(paste("found factor level(s) '",
paste(setdiff(levels(r), dimnames(p)[[2]]), collapse = ", "),
"' of response unmatched by predicted.",
sep = ""
))
}
if (!all(unique(r) %in% dimnames(p)[[2]], na.rm = TRUE)) {
return(paste("found value(s) '",
setdiff(as.character(unique(r)), dimnames(p)[[2]]),
"' of response unmatched by predicted.\n",
"You may want to add column(s) filled with NA to predicted.",
sep = ""
))
}
if (!all(dimnames(p)[[2]] %in% levels(r))) {
return(paste("found column(s) '",
paste(setdiff(dimnames(p)[[2]], levels(r)), collapse = ", "),
"' of predicted unmatched by levels(response).",
sep = ""
))
}
if (length(r) != nrow(p)) {
return(paste("response and predicted must have",
"the same number of observations."))
}
if (any(p < 0, na.rm = TRUE) || any(p > 1, na.rm = TRUE)) {
return("probabilities should be in [0,1].")
}
if (!isTRUE(all.equal(rep(1, nrow(p)),
as.numeric(rowSums(p, na.rm = TRUE))))) {
return("row sums of predicted must be 1.")
}
}
)
#' A Constructor for Objects of Class \code{bincap}
#'
#'
#' \code{bincap(\dots)} is an alias to \code{new("bincap", \dots)}.
#'
#'
#' There is no casting or conversion of data. \code{bincap(\dots)} is just an
#' alias to \code{new("bincap", \dots)}.
#'
#'
#' @param response Object of class \code{factor}.
#' @param predicted Object of class \code{numeric}.
#' @param true Object of class \code{character}.
......@@ -12,55 +12,55 @@
#' @seealso \code{\link[=bincap-class]{class?HandTill2001::bincap}}
#' @keywords ui-constructor
#' @examples
#'
#'
#' library(HandTill2001)
#' data(ht01.twoclass)
#' str(ht01.twoclass$observed)
#' message("note that ht01.twoclass$observed is not a factor; we have to convert it.")
#' bincap(
#' response = as.factor(ht01.twoclass$observed)
#' , predicted = ht01.twoclass$predicted
#' , true = c("1")
#' )
#'
#'
#' @export
bincap <- function (response, predicted, true = "1") {
new <- methods::new(Class = "bincap", response = response,
predicted = predicted, true = true)
return(new)
#' response = as.factor(ht01.twoclass$observed),
#' predicted = ht01.twoclass$predicted,
#' true = c("1")
#' )
#' @export
bincap <- function(response, predicted, true = "1") {
new <- methods::new(
Class = "bincap", response = response,
predicted = predicted, true = true
)
return(new)
}
#' A Constructor for Objects of Class \code{multcap}
#'
#'
#' \code{multcap(\dots)} is an alias to \code{new("multcap", \dots)}.
#'
#'
#' There is no casting or conversion of data. \code{multcap(\dots)} is just
#' an alias to \code{new("multcap", \dots)}.
#'
#'
#' @param response Object of class \code{factor}.
#' @param predicted Object of class \code{matrix}.
#' @return An object of class \code{multcap}.
#' @seealso \code{\link[=multcap-class]{class?HandTill2001::multcap}}
#' @keywords ui-constructor
#' @examples
#'
#'
#' library(HandTill2001)
#' data(ht01.multipleclass)
#' str(ht01.multipleclass$observed)
#' message("note that ht01.multipleclass$observed is a factor; we do not have to convert it.")
#' multcap(
#' response = ht01.multipleclass$observed
#' , predicted = as.matrix(ht01.multipleclass[, levels(ht01.multipleclass$observed)])
#' )
#'
#'
#' @export
multcap <- function (response, predicted) {
new <- methods::new(Class = "multcap", response = response,
predicted = predicted)
return(new)
#' response = ht01.multipleclass$observed,
#' predicted = as.matrix(ht01.multipleclass[, levels(ht01.multipleclass$observed)])
#' )
#' @export
multcap <- function(response, predicted) {
new <- methods::new(
Class = "multcap", response = response,
predicted = predicted
)
return(new)
}
setGeneric(name = "auc",
def = function(object){standardGeneric("auc")})
setGeneric(
name = "auc",
def = function(object) {
standardGeneric("auc")
}
)
#' Multiple Class Area under ROC Curve
#'
#'
#' A very lean package implementing merely \eqn{M} given by \cite{Hand and Till
#' (2001)}, Eq. (7).
#'
#'
#' \eqn{M} given by \cite{Hand and Till (2001)} defines a multiple class
#' version of the area under curve of the receiver operating characteristic.
#'
#'
#' @name HandTill2001-package
#' @aliases HandTill2001-package HandTill2001
#' @docType package
......@@ -20,14 +20,13 @@
#' \href{http://dx.doi.org/10.1023/A:1010920819831}{10.1023/A:1010920819831}}.
#' @keywords AUC ROC
#' @examples
#'
#'
#' library(HandTill2001)
#' data(ht01.multipleclass)
#' auc(
#' auc(
#' multcap(
#' response = ht01.multipleclass$observed
#' , predicted = as.matrix(ht01.multipleclass[, levels(ht01.multipleclass$observed)])
#' )
#' )
#'
#' response = ht01.multipleclass$observed,
#' predicted = as.matrix(ht01.multipleclass[, levels(ht01.multipleclass$observed)])
#' )
#' )
NULL
#' Methods for Function \code{auc} in Package \pkg{HandTill2001}
#'
#' Calculate area under curve of the receiver operating characteristic for
#'
#' Calculate area under curve of the receiver operating characteristic for
#' two or more prediction classes.
#'
#'
#' Depending on whether \code{object} is of class \code{bincap} or of class
#' \code{multcap}, a binary class or multiple class AUC is calculated.
#'
#'
#' @param object An object of \code{class} \emph{bincap} or \emph{multcap}.
#' @name auc-methods
#' @aliases auc-methods auc auc,bincap-method auc,multcap-method
#' @docType methods
#' @return An object of class \code{"numeric"}.
#' @section Methods: \describe{
#'
#'
#' \item{signature(object = "bincap")}{ calculates the AUC statistic
#' for a binary class response following \cite{Hand and Till (2001)}, Eq. (3). }
#'
#'
#' \item{signature(object = "multcap")}{ calculates the AUC statistic
#' for a multiple class response following \cite{Hand and Till (2001)}, Eq.
#' (7). } }
......@@ -32,33 +32,37 @@
#' data(ht01.twoclass, package = "HandTill2001")
#' message(" == AUC for a binary class response")
#' message(" == == HandTill2001 result:")
#' HandTill2001::auc(HandTill2001::bincap(response = as.factor(ht01.twoclass[["observed"]]),
#' predicted = ht01.twoclass[["predicted"]],
#' true = "1"))
#' HandTill2001::auc(HandTill2001::bincap(
#' response = as.factor(ht01.twoclass[["observed"]]),
#' predicted = ht01.twoclass[["predicted"]],
#' true = "1"
#' ))
#' \dontrun{
#' message(" == == ROCR result:")
#' ROCR::performance(ROCR::prediction(labels = ht01.twoclass[["observed"]] ,
#' predictions = ht01.twoclass[["predicted"]]),
#' measure = "auc")@y.values
#' message(" == == ROCR result:")
#' ROCR::performance(ROCR::prediction(
#' labels = ht01.twoclass[["observed"]],
#' predictions = ht01.twoclass[["predicted"]]
#' ),
#' measure = "auc"
#' )@y.values
#' }
setMethod(f = "auc"
, signature(object = "bincap")
, function(object){
n0 <- sum((object@response
== object@true) * 1 )
n1 <- sum((object@response
!= object@true) * 1 )
s0 <- sum(rank(object@predicted
, ties.method = "average"
, na.last = TRUE)
* (object@response
== object@true)
)
return(
(s0 - n0 * (n0 + 1) / 2) / ( n0 * n1 )
)
}
)
setMethod(
f = "auc",
signature(object = "bincap"),
function(object) {
n0 <- sum(as.numeric(object@response == object@true))
n1 <- sum(as.numeric(object@response != object@true))
s0 <- sum(rank(object@predicted,
ties.method = "average",
na.last = TRUE
)
* (object@response
== object@true))
return(
(s0 - n0 * (n0 + 1) / 2) / (n0 * n1)
)
}
)
#' @rdname auc-methods
#' @export
......@@ -66,40 +70,41 @@ setMethod(f = "auc"
#' data(ht01.multipleclass, package = "HandTill2001")
#' message(" == AUC for a multiple class response")
#' predicted <- as.matrix(ht01.multipleclass[, levels(ht01.multipleclass[["observed"]])])
#' HandTill2001::auc(HandTill2001::multcap(response = ht01.multipleclass[["observed"]],
#' predicted = predicted))
setMethod(f = "auc"
, signature(object = "multcap")
, function(object){
return(mean(
utils::combn(levels(object@response), 2,
function(levels
, response
, predicted){
df <- as.data.frame(predicted) ## factor and matrix -> need data.frame
df[["obs"]] <- response
dfs <- subset(df, get("obs") %in% levels)
t <- levels[1]
aij <- auc(methods::new("bincap"
, response = factor(dfs[,"obs"]) ## to drop non-ocurring levels
, predicted = dfs[,t]
, true = t)
)
t <- levels[2]
aji <- auc(methods::new("bincap"
, response = factor(dfs[,"obs"]) ## to drop non-ocurring levels
, predicted = dfs[,t]
, true = t)
)
Aij <- mean(c(aij,aji))
return(Aij)
}
, response = object@response
, predicted = object@predicted
), na.rm = TRUE
)
)
}
)
#' HandTill2001::auc(HandTill2001::multcap(
#' response = ht01.multipleclass[["observed"]],
#' predicted = predicted
#' ))
setMethod(
f = "auc",
signature(object = "multcap"),
function(object) {
return(mean(
utils::combn(levels(object@response), 2,
function(levels,
response,
predicted) {
df <- as.data.frame(predicted) # factor and matrix -> need data frame
df[["obs"]] <- response
dfs <- subset(df, get("obs") %in% levels)
t <- levels[1]
aij <- auc(methods::new("bincap",
response = factor(dfs[, "obs"]) # to drop non-ocurring levels
, predicted = dfs[, t],
true = t
))
t <- levels[2]
aji <- auc(methods::new("bincap",
response = factor(dfs[, "obs"]) # to drop non-ocurring levels
, predicted = dfs[, t],
true = t
))
Aij <- mean(c(aij, aji))
return(Aij)
},
response = object@response,
predicted = object@predicted
),
na.rm = TRUE
))
}
)
#' Example Data for Multiple Classes
#'
#'
#' Multiple class data and probability predictions thereof.
#'
#'
#' Multiple class data ('observed': \code{MASS::fgl$type}) and probability
#' predictions (\code{predict(fgl.rp4)}, cf. Venables and Ripley (2002), p. 264
#' and \sQuote{Source}) from \code{rpart::rpart}.
#'
#'
#' @name ht01.multipleclass
#' @docType data
#' @format A data frame with 214 observations on the following 7 variables.
#' \describe{
#' \item{observed}{a factor with levels
#' \code{Con} \code{Head} \code{Tabl} \code{Veh}
#' \describe{
#' \item{observed}{a factor with levels
#' \code{Con} \code{Head} \code{Tabl} \code{Veh}
#' \code{WinF} \code{WinNF}}
#' \item{WinF}{a numeric vector}
#' \item{WinF}{a numeric vector}
#' \item{WinNF}{a numeric vector}
#' \item{Veh}{a numeric vector}
#' \item{Veh}{a numeric vector}
#' \item{Con}{a numeric vector}
#' \item{Tabl}{a numeric vector}
#' \item{Tabl}{a numeric vector}
#' \item{Head}{a numeric vector}
#' }
#' @references Venables, W. N and Ripley, B. D. (2002), \emph{Modern Applied
......@@ -30,22 +30,21 @@
#' "ht01.multipleclass.txt") }
#' @keywords datasets
#' @examples
#'
#'
#' library(HandTill2001)
#' data(ht01.multipleclass)
#' str(ht01.multipleclass)
#'
NULL
#' Example Data for Binary Classes
#'
#'
#' Binary class data and probability predictions thereof.
#'
#'
#' Binary class data ('observed': \code{MASS::birthwt$low}) and probability
#' predictions
#' (\code{predict(birthwt.step2, type = "response")}, cf. Venables and Ripley
#' (2002), pp. 195f and \sQuote{Source}) from \code{stats::glm}.
#'
#'
#' @name ht01.twoclass
#' @docType data
#' @format A data frame with 189 observations on the following 2 variables.
......@@ -65,9 +64,8 @@ NULL
#' "response")) write.table(ht01.twoclass, file = "ht01.twoclass.txt") }
#' @keywords datasets
#' @examples
#'
#'
#' library(HandTill2001)
#' data(ht01.twoclass)
#' str(ht01.twoclass)
#'
NULL
......@@ -12,10 +12,14 @@
#' condition of class c("error", "HandTill2001", "condition").
#' @keywords internal
#' @examples
#' tryCatch(HandTill2001:::throw("Hello error!"), HandTill2001 = function(e) return(e))
#' tryCatch(HandTill2001:::throw("Hello error!"), HandTill2001 = function(e) {
#' return(e)
#' })
throw <- function(message_string, system_call = sys.call(-1), ...) {
condition <- structure(class = c("error", "HandTill2001", "condition"),
list(message = message_string, call = system_call),
...)
stop(condition)
condition <- structure(
class = c("error", "HandTill2001", "condition"),
list(message = message_string, call = system_call),
...
)
stop(condition)
}
library(HandTill2001)
data(ht01.twoclass)
data(ht01.multipleclass)
data(ht01.twoclass, package = "HandTill2001")
data(ht01.multipleclass, package = "HandTill2001")
message("AUC for a two class response")
auc(bincap(
response = as.factor(ht01.twoclass$observed)
, predicted = ht01.twoclass$predicted
, true = "1"
)
)
HandTill2001::auc(HandTill2001::bincap(
response = as.factor(ht01.twoclass$observed),
predicted = ht01.twoclass$predicted,
true = "1"
))
message("AUC for a multiple class response")
auc(multcap(
response = ht01.multipleclass$observed
, predicted = as.matrix(ht01.multipleclass[, levels(ht01.multipleclass$observed)])
)
)
HandTill2001::auc(HandTill2001::multcap(
response = ht01.multipleclass$observed,
predicted = as.matrix(ht01.multipleclass[,
levels(ht01.multipleclass$observed)])
))
Loading HandTill2001
<error in cleanr::check_package(".", check_return = FALSE): . /home/qwer/git/cyclops/fvafrcu/HandTill2001/R/AllClasses.R: line 62 counts 81 characters.
/home/qwer/git/cyclops/fvafrcu/HandTill2001/R/AllClasses.R: line 63 counts 90 characters.
/home/qwer/git/cyclops/fvafrcu/HandTill2001/R/AllClasses.R: line 128 counts 81 characters.
/home/qwer/git/cyclops/fvafrcu/HandTill2001/R/AllClasses.R: line 131 counts 81 characters.
. /home/qwer/git/cyclops/fvafrcu/HandTill2001/R/AllConstructors.R: line 19 counts 86 characters.
<error in cleanr::check_package(".", check_return = FALSE): . /home/qwer/git/cyclops/fvafrcu/HandTill2001/R/AllConstructors.R: line 19 counts 86 characters.
/home/qwer/git/cyclops/fvafrcu/HandTill2001/R/AllConstructors.R: line 54 counts 94 characters.
/home/qwer/git/cyclops/fvafrcu/HandTill2001/R/AllConstructors.R: line 57 counts 89 characters.
. /home/qwer/git/cyclops/fvafrcu/HandTill2001/R/auc-methods.R: line 35 counts 93 characters.
/home/qwer/git/cyclops/fvafrcu/HandTill2001/R/auc-methods.R: line 36 counts 84 characters.
/home/qwer/git/cyclops/fvafrcu/HandTill2001/R/auc-methods.R: line 40 counts 81 characters.
/home/qwer/git/cyclops/fvafrcu/HandTill2001/R/auc-methods.R: line 41 counts 87 characters.
/home/qwer/git/cyclops/fvafrcu/HandTill2001/R/auc-methods.R: line 68 counts 89 characters.
/home/qwer/git/cyclops/fvafrcu/HandTill2001/R/auc-methods.R: line 69 counts 88 characters.
/home/qwer/git/cyclops/fvafrcu/HandTill2001/R/auc-methods.R: line 79 counts 102 characters.
/home/qwer/git/cyclops/fvafrcu/HandTill2001/R/auc-methods.R: line 84 counts 111 characters.
/home/qwer/git/cyclops/fvafrcu/HandTill2001/R/auc-methods.R: line 90 counts 112 characters.
/home/qwer/git/cyclops/fvafrcu/HandTill2001/R/AllConstructors.R: line 57 counts 85 characters.
. /home/qwer/git/cyclops/fvafrcu/HandTill2001/R/auc-methods.R: line 72 counts 89 characters.
. /home/qwer/git/cyclops/fvafrcu/HandTill2001/R/HandTill2001-package.R: line 13 counts 82 characters.
/home/qwer/git/cyclops/fvafrcu/HandTill2001/R/HandTill2001-package.R: line 29 counts 89 characters.
. /home/qwer/git/cyclops/fvafrcu/HandTill2001/R/throw.R: line 15 counts 87 characters.>
/home/qwer/git/cyclops/fvafrcu/HandTill2001/R/HandTill2001-package.R: line 29 counts 87 characters.>
Warning messages:
1: In getPackageName(where) :
Created a package name, ‘2019-12-18 15:05:25’, when none found
Created a package name, ‘2019-12-18 17:04:07’, when none found
2: In getPackageName(where) :
Created a package name, ‘2019-12-18 15:05:25’, when none found
Created a package name, ‘2019-12-18 17:04:07’, when none found
checking for file ‘/tmp/Rtmp9aAsun/remotes6d4928a2e08b/HandTill2001/DESCRIPTION’ ... ✔ checking for file ‘/tmp/Rtmp9aAsun/remotes6d4928a2e08b/HandTill2001/DESCRIPTION’
checking for file ‘/tmp/RtmpDlflnc/remotes7952ee86b5b/HandTill2001/DESCRIPTION’ ... ✔ checking for file ‘/tmp/RtmpDlflnc/remotes7952ee86b5b/HandTill2001/DESCRIPTION’
─ preparing ‘HandTill2001’:
checking DESCRIPTION meta-information ... ✔ checking DESCRIPTION meta-information
✔ checking DESCRIPTION meta-information
✔ checking vignette meta-information
─ checking for LF line-endings in source and make files and shell scripts
─ checking for empty or unneeded directories
......@@ -42,4 +42,5 @@
** testing if installed package keeps a record of temporary installation path
* DONE (HandTill2001)
Adding ‘HandTill2001_0.2-12.9000_R_x86_64-pc-linux-gnu.tar.gz’ to the cache
[1] TRUE
......
......@@ -7,7 +7,7 @@
─ building ‘HandTill2001_0.2-12.9000.tar.gz’
Running /home/qwer/svn/R/r-devel/build/bin/R CMD INSTALL \
/tmp/RtmpEJaDgo/HandTill2001_0.2-12.9000.tar.gz --install-tests
/tmp/RtmpADlXqZ/HandTill2001_0.2-12.9000.tar.gz --install-tests
* installing to library ‘/home/qwer/svn/R/r-devel/build/library’
* installing *source* package ‘HandTill2001’ ...
** using staged installation
......@@ -34,7 +34,7 @@
─ building ‘HandTill2001_0.2-12.9000.tar.gz’
Running /usr/lib/R/bin/R CMD INSTALL \
/tmp/RtmpvOPHT5/HandTill2001_0.2-12.9000.tar.gz --install-tests
/tmp/RtmpMR9QEy/HandTill2001_0.2-12.9000.tar.gz --install-tests
* installing to library ‘/home/qwer/R/x86_64-pc-linux-gnu-library/3.3’
* installing *source* package ‘HandTill2001’ ...
** R
......
This diff is collapsed.
......@@ -21,9 +21,15 @@ Type 'q()' to quit R.
Writing NAMESPACE
Loading HandTill2001
Writing NAMESPACE
Writing cap-class.Rd
Writing bincap-class.Rd
Writing multcap-class.Rd
Writing bincap.Rd
Writing multcap.Rd
Writing HandTill2001-package.Rd
Writing auc-methods.Rd
Writing ht01.multipleclass.Rd
Writing ht01.twoclass.Rd
Writing throw.Rd
Warning message:
roxygen2 requires Encoding: UTF-8
>
......
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
"http://www.w3.org/TR/html4/transitional.dtd">
<html><head><title>RUNIT TEST PROTOCOL--Wed Dec 18 15:08:28 2019</title>
<html><head><title>RUNIT TEST PROTOCOL--Wed Dec 18 17:05:47 2019</title>
</head>
<body><h1 TRUE>RUNIT TEST PROTOCOL--Wed Dec 18 15:08:28 2019</h1>
<body><h1 TRUE>RUNIT TEST PROTOCOL--Wed Dec 18 17:05:47 2019</h1>
<p>Number of test functions: 1</p>
<p>Number of errors: 0</p>
<p>Number of failures: 0</p>
......
RUNIT TEST PROTOCOL -- Wed Dec 18 15:08:28 2019
RUNIT TEST PROTOCOL -- Wed Dec 18 17:05:47 2019
***********************************************
Number of test functions: 1
Number of errors: 0
......
DESCRIPTION does not contain 'Language' field. Defaulting to 'en-US'.
WORD FOUND IN
bincap auc-methods.Rd:16
DOI auc-methods.Rd:63
HandTill2001-package.Rd:32
DOI auc-methods.Rd:70
HandTill2001-package.Rd:31
description:2
Eq auc-methods.Rd:33,36
HandTill2001-package.Rd:10
description:1
eval consensus_auc.Rnw:23
fgl consensus_auc.Rnw:17,23,32
Generalisation auc-methods.Rd:61
HandTill2001-package.Rd:30
eval consensus_auc.Rnw:25
fgl consensus_auc.Rnw:17,25,26,35
Generalisation auc-methods.Rd:68
HandTill2001-package.Rd:29
gitlab README.md:67
README.Rmd:39
HandTill throw.Rd:19,22
......@@ -19,18 +19,18 @@ HandTill throw.Rd:19,22
README.Rmd:21,39
modelling consensus_auc.Rnw:18
multcap auc-methods.Rd:16
multinom consensus_auc.Rnw:46
nnet consensus_auc.Rnw:18,46
pre consensus_auc.Rnw:76,99
pROC HandTill2001-package.Rd:39
rpart consensus_auc.Rnw:18,32
multinom consensus_auc.Rnw:49
nnet consensus_auc.Rnw:18,49
pre consensus_auc.Rnw:79,102
pROC HandTill2001-package.Rd:38
rpart consensus_auc.Rnw:18,35
RStudio README.md:8,9
README.Rmd:8,9
Springer ht01.multipleclass.Rd:44
ht01.twoclass.Rd:40
th ht01.multipleclass.Rd:44
ht01.twoclass.Rd:40
Venables ht01.multipleclass.Rd:32,43
ht01.twoclass.Rd:28,39
Springer ht01.multipleclass.Rd:43
ht01.twoclass.Rd:39
th ht01.multipleclass.Rd:43
ht01.twoclass.Rd:39
Venables ht01.multipleclass.Rd:32,42
ht01.twoclass.Rd:28,38
Warning message:
spell check failed
......@@ -19,4 +19,4 @@ output file: ./inst/doc/consensus_auc.Rnw
Warning message:
In remind_sweave(if (in.file) input, sweave_lines) :
It seems you are using the Sweave-specific syntax in line(s) 8, 9, 10, 20, 24, 33, 47, 53, 63, 78, 86, 100, 114, 122, 128, 133; you may need Sweave2knitr("/home/qwer/git/cyclops/fvafrcu/HandTill2001/vignettes/consensus_auc.Rnw") to convert it to knitr
It seems you are using the Sweave-specific syntax in line(s) 8, 9, 10, 20, 27, 36, 50, 56, 66, 81, 89, 103, 117, 125, 131, 136; you may need Sweave2knitr("/home/qwer/git/cyclops/fvafrcu/HandTill2001/vignettes/consensus_auc.Rnw") to convert it to knitr
......
......@@ -17,13 +17,12 @@ version of the area under curve of the receiver operating characteristic.
library(HandTill2001)
data(ht01.multipleclass)
auc(
auc(
multcap(
response = ht01.multipleclass$observed
, predicted = as.matrix(ht01.multipleclass[, levels(ht01.multipleclass$observed)])
)
)
response = ht01.multipleclass$observed,
predicted = as.matrix(ht01.multipleclass[, levels(ht01.multipleclass$observed)])
)
)
}
\references{
\cite{David J. Hand and Robert J. Till (2001). A Simple
......
......@@ -19,7 +19,7 @@
An object of class \code{"numeric"}.
}
\description{
Calculate area under curve of the receiver operating characteristic for
Calculate area under curve of the receiver operating characteristic for
two or more prediction classes.
}
\details{
......@@ -41,20 +41,27 @@ for a multiple class response following \cite{Hand and Till (2001)}, Eq.
data(ht01.twoclass, package = "HandTill2001")
message(" == AUC for a binary class response")
message(" == == HandTill2001 result:")
HandTill2001::auc(HandTill2001::bincap(response = as.factor(ht01.twoclass[["observed"]]),
predicted = ht01.twoclass[["predicted"]],
true = "1"))
HandTill2001::auc(HandTill2001::bincap(
response = as.factor(ht01.twoclass[["observed"]]),
predicted = ht01.twoclass[["predicted"]],
true = "1"
))
\dontrun{
message(" == == ROCR result:")
ROCR::performance(ROCR::prediction(labels = ht01.twoclass[["observed"]] ,
predictions = ht01.twoclass[["predicted"]]),
measure = "auc")@y.values
message(" == == ROCR result:")
ROCR::performance(ROCR::prediction(
labels = ht01.twoclass[["observed"]],
predictions = ht01.twoclass[["predicted"]]
),
measure = "auc"
)@y.values
}
data(ht01.multipleclass, package = "HandTill2001")
message(" == AUC for a multiple class response")
predicted <- as.matrix(ht01.multipleclass[, levels(ht01.multipleclass[["observed"]])])
HandTill2001::auc(HandTill2001::multcap(response = ht01.multipleclass[["observed"]],
predicted = predicted))
HandTill2001::auc(HandTill2001::multcap(
response = ht01.multipleclass[["observed"]],
predicted = predicted
))
}
\references{
\cite{David J. Hand and Robert J. Till (2001). A Simple
......
......@@ -27,7 +27,6 @@ that \code{response} is \code{true}.
\examples{
showClass("bincap")
}
\seealso{
\code{\link[=cap-class]{class?HandTill2001::cap}} ,
......
......@@ -30,12 +30,10 @@ data(ht01.twoclass)
str(ht01.twoclass$observed)
message("note that ht01.twoclass$observed is not a factor; we have to convert it.")
bincap(
response = as.factor(ht01.twoclass$observed)
, predicted = ht01.twoclass$predicted
, true = c("1")
)
response = as.factor(ht01.twoclass$observed),
predicted = ht01.twoclass$predicted,
true = c("1")
)
}
\seealso{
\code{\link[=bincap-class]{class?HandTill2001::bincap}}
......
......@@ -5,15 +5,15 @@
\alias{ht01.multipleclass}
\title{Example Data for Multiple Classes}
\format{A data frame with 214 observations on the following 7 variables.
\describe{
\item{observed}{a factor with levels
\code{Con} \code{Head} \code{Tabl} \code{Veh}
\describe{
\item{observed}{a factor with levels
\code{Con} \code{Head} \code{Tabl} \code{Veh}
\code{WinF} \code{WinNF}}
\item{WinF}{a numeric vector}
\item{WinF}{a numeric vector}
\item{WinNF}{a numeric vector}
\item{Veh}{a numeric vector}
\item{Veh}{a numeric vector}
\item{Con}{a numeric vector}
\item{Tabl}{a numeric vector}
\item{Tabl}{a numeric vector}
\item{Head}{a numeric vector}
}}
\source{
......@@ -37,7 +37,6 @@ and \sQuote{Source}) from \code{rpart::rpart}.
library(HandTill2001)
data(ht01.multipleclass)
str(ht01.multipleclass)
}
\references{
Venables, W. N and Ripley, B. D. (2002), \emph{Modern Applied
......
......@@ -33,7 +33,6 @@ predictions
library(HandTill2001)
data(ht01.twoclass)
str(ht01.twoclass)
}
\references{
Venables, W. N and Ripley, B. D. (2002), \emph{Modern Applied
......
......@@ -17,7 +17,6 @@ and the predicted probabilities for each of the \code{levels(response)}.
\examples{
showClass("multcap")
}
\seealso{
\code{\link[=cap-class]{class?HandTill2001::cap}} ,
......
......@@ -28,11 +28,9 @@ data(ht01.multipleclass)
str(ht01.multipleclass$observed)
message("note that ht01.multipleclass$observed is a factor; we do not have to convert it.")
multcap(
response = ht01.multipleclass$observed
, predicted = as.matrix(ht01.multipleclass[, levels(ht01.multipleclass$observed)])
)
response = ht01.multipleclass$observed,
predicted = as.matrix(ht01.multipleclass[, levels(ht01.multipleclass$observed)])
)
}
\seealso{
\code{\link[=multcap-class]{class?HandTill2001::multcap}}
......
......@@ -25,6 +25,8 @@ Throws a condition of class c("error", "HandTill2001", "condition").
We use this condition as an error dedicated to \pkg{ HandTill2001.}
}
\examples{
tryCatch(HandTill2001:::throw("Hello error!"), HandTill2001 = function(e) return(e))
tryCatch(HandTill2001:::throw("Hello error!"), HandTill2001 = function(e) {
return(e)
})
}
\keyword{internal}
......@@ -3,115 +3,117 @@ assertError <- function(expr) {
d.expr <- deparse(substitute(expr))
t.res <- tryCatch(expr, error = function(e) e)
print(t.res)
if(!inherits(t.res, "error"))
if (!inherits(t.res, "error")) {
stop(d.expr, "\n\t did not give an error", call. = FALSE)
}
invisible(t.res)
}
assertWarning <- function(expr) {
d.expr <- deparse(substitute(expr))
t.res <- tryCatch(expr, warning = function(w)w)
if(!inherits(t.res, "warning"))
stop(d.expr, "\n\t did not give a warning", call. = FALSE)
invisible(t.res)
d.expr <- deparse(substitute(expr))
t.res <- tryCatch(expr, warning = function(w) w)
if (!inherits(t.res, "warning")) {
stop(d.expr, "\n\t did not give a warning", call. = FALSE)
}
invisible(t.res)
}
library(HandTill2001)
library("HandTill2001")
data(ht01.twoclass)
new("bincap"
, response = as.factor(ht01.twoclass$observed)
, predicted = ht01.twoclass$predicted
)
new("bincap",
response = as.factor(ht01.twoclass$observed),
predicted = ht01.twoclass$predicted
)
assertError(
new("bincap"
, response = ht01.twoclass$observed
, predicted = ht01.twoclass$predicted
)
new("bincap",
response = ht01.twoclass$observed,
predicted = ht01.twoclass$predicted
)
)
assertError(
new("bincap"
, response = as.factor(ht01.twoclass$observed)
, predicted = as.data.frame(ht01.twoclass$predicted)
)
new("bincap",
response = as.factor(ht01.twoclass$observed),
predicted = as.data.frame(ht01.twoclass$predicted)
)
)
assertError(
new("bincap"
, true = 1
)
new("bincap",
true = 1
)
)
data(ht01.multipleclass)
new("multcap"
, response = ht01.multipleclass$observed
, predicted = as.matrix(ht01.multipleclass[, levels(ht01.multipleclass$observed)])
)
new("multcap",
response = ht01.multipleclass$observed,
predicted = as.matrix(ht01.multipleclass[, levels(ht01.multipleclass$observed)])
)
assertError(
new("multcap"
, response = as.numeric(ht01.multipleclass$observed)
, predicted = as.matrix(ht01.multipleclass[, levels(ht01.multipleclass$observed)])
)
new("multcap",
response = as.numeric(ht01.multipleclass$observed),
predicted = as.matrix(ht01.multipleclass[, levels(ht01.multipleclass$observed)])
)
)
assertError(
new("multcap"
, response = ht01.multipleclass$observed
, predicted = ht01.multipleclass[, levels(ht01.multipleclass$observed)]
)
new("multcap",
response = ht01.multipleclass$observed,
predicted = ht01.multipleclass[, levels(ht01.multipleclass$observed)]
)
)
assertError(
new("multcap"
, true = 1
)
new("multcap",
true = 1
)
)
###########################################################
po <- ht01.multipleclass[, levels(ht01.multipleclass$observed)]
ro <- ht01.multipleclass$observed
######## get a subset
i <- c(1,73,157,170,182,186)
p <- po[i,]
i <- c(1, 73, 157, 170, 182, 186)
p <- po[i, ]
r <- ro[i]
multcap(
response = r
, predicted = as.matrix(p)
)
response = r,
predicted = as.matrix(p)
)
## r extraneous levels
r <- ro[i]
p <- po[i,]
p <- po[i, ]
levels(r) <- c(levels(r), "foo", "bar")
assertWarning(
multcap(
response = r
, predicted = as.matrix(p)
)
response = r,
predicted = as.matrix(p)
)
)
## r levels unmatched by p
r <- ro[i]
p <- po[i,]
p <- po[i, ]
levels(r) <- c(levels(r), "foo", "bar")
assertWarning(
multcap(
response = r
, predicted = as.matrix(p)
)
response = r,
predicted = as.matrix(p)
)
)
## r values unmatched by p
r <- ro[i]
p <- po[i,1:5]
p <- po[i, 1:5]
assertError(
multcap(
response = r
, predicted = as.matrix(p)
)
response = r,
predicted = as.matrix(p)
)
)
## p columns unmatched by levels(r)
r <- ro[i]
p <- po[i,]
p <- po[i, ]
p$foo <- NA
assertError(
multcap(
response = r
, predicted = as.matrix(p)
)
response = r,
predicted = as.matrix(p)
)
)
#!/usr/bin/Rscript --vanilla
is_failure <- function(result) {
res <- RUnit::getErrors(result)
names(res) <- tolower(names(res)) # soothe lintr
sum_of_exceptions <- res[["nerr"]] + res[["nfail"]]
fail <- as.logical(sum_of_exceptions)
return(fail)
res <- RUnit::getErrors(result)
names(res) <- tolower(names(res)) # soothe lintr
sum_of_exceptions <- res[["nerr"]] + res[["nfail"]]
fail <- as.logical(sum_of_exceptions)
return(fail)
}
if (interactive()) {
pkgload::load_all(path = ".") # needed to use pkgload's shim version of
# base's system.file
unit_dir <- system.file("inst", "runit_tests", package = "HandTill2001")
pkgload::load_all(path = ".") # needed to use pkgload's shim version of
# base's system.file
unit_dir <- system.file("inst", "runit_tests", package = "HandTill2001")
} else {
require("HandTill2001", quietly = TRUE, character.only = TRUE) ||
pkgload::load_all(path = ".") # needed to use pkgload's shim version of
r_call <- commandArgs(trailingOnly = FALSE)
if (any(grepl("--file", r_call))) {
unit_dir <- file.path("inst", "runit_tests")
} else {
unit_dir <- system.file("runit_tests", package = "HandTill2001")
}
require("HandTill2001", quietly = TRUE, character.only = TRUE) ||
pkgload::load_all(path = ".") # needed to use pkgload's shim version of
r_call <- commandArgs(trailingOnly = FALSE)
if (any(grepl("--file", r_call))) {
unit_dir <- file.path("inst", "runit_tests")
} else {
unit_dir <- system.file("runit_tests", package = "HandTill2001")
}
}
if (! dir.exists(unit_dir)) {
stop("Can not find RUnit test directory ", unit_dir,
". Try to (re)install the package first.")
if (!dir.exists(unit_dir)) {
stop(
"Can not find RUnit test directory ", unit_dir,
". Try to (re)install the package first."
)
}
package_suite <- RUnit::defineTestSuite("HandTill2001_unit_test",
dirs = unit_dir,
testFileRegexp = "^.*\\.[rR]",
testFuncRegexp = "^test_+")
dirs = unit_dir,
testFileRegexp = "^.*\\.[rR]",
testFuncRegexp = "^test_+"
)
test_result <- RUnit::runTestSuite(package_suite)
root <- tryCatch(rprojroot::find_root(rprojroot::is_r_package),
error = function(e) return(NULL))
if (! is.null(root)) {
log_dir <- file.path(root, "log")
dir.create(log_dir, showWarnings = FALSE)
file_name <- file.path(log_dir, "runit.log")
html_file <- file.path(log_dir, "runit.html")
RUnit::printHTMLProtocol(test_result, fileName = html_file)
if (interactive()) {
browseURL(paste0("file:", html_file))
}
error = function(e) {
return(NULL)
}
)
if (!is.null(root)) {
log_dir <- file.path(root, "log")
dir.create(log_dir, showWarnings = FALSE)
file_name <- file.path(log_dir, "runit.log")
html_file <- file.path(log_dir, "runit.html")
RUnit::printHTMLProtocol(test_result, fileName = html_file)
if (interactive()) {
browseURL(paste0("file:", html_file))
}
} else {
file_name <- ""
file_name <- ""
}
RUnit::printTextProtocol(test_result, showDetails = TRUE, fileName = file_name)
if (is_failure(test_result)) {
RUnit::printTextProtocol(test_result, showDetails = TRUE)
stop("RUnit failed.")
RUnit::printTextProtocol(test_result, showDetails = TRUE)
stop("RUnit failed.")
}
library(testthat)
library(HandTill2001)
library("HandTill2001")
test_check("HandTill2001")
testthat::context("Testing HandTill2001:::throw()")
testthat::test_that("throw the HandTill2001 exception", {
error_message <- "hello, testthat"
string <- "hello, testthat"
testthat::expect_error(HandTill2001:::throw(string),
error_message)
}
)
error_message <- "hello, testthat"
string <- "hello, testthat"
testthat::expect_error(
HandTill2001:::throw(string),
error_message
)
})
......@@ -20,55 +20,58 @@ We will follow the modelling process shown in \cite[Figure 1]{marmion2009} restr
<<echo=false,print=false>>=
options(useFancyQuotes="UTF-8")
@
After loading the data, we create random indices for training and evaluation sets (since the training and evaluation sets are complements with respect to the data set, two indices are redundant, but \rcode{fgl[ind.eval, ]} might be easier to read than \rcode{fgl[!ind.train, ]}).
After loading the data, we create random indices for training and evaluation
sets (since the training and evaluation sets are complements with respect to the
data set, two indices are redundant, but \rcode{fgl[ind\_eval, ]} might be
easier to read than \rcode{fgl[!ind\_train, ]}).
<<echo=true>>=
library(MASS)
data(fgl)
set.seed(100)
ind.train <- sample(nrow(fgl), size = floor(nrow(fgl) * 0.7),
ind_train <- sample(nrow(fgl), size = floor(nrow(fgl) * 0.7),
replace = FALSE)
ind.eval <- setdiff(seq(1:nrow(fgl)), ind.train)
ind_eval <- setdiff(seq(1:nrow(fgl)), ind_train)
@
Choosing \rcode{fgl\$type} as response and all other variables as predictors, we calibrate a classification tree using \rcode{rpart::rpart} (cf. \cite[p. 264]{MASS}):
<<echo=true>>=
library(rpart)
set.seed(123)
fgl.rpart <- rpart(type ~ ., data = fgl[ind.train, TRUE],
fgl_rpart <- rpart(type ~ ., data = fgl[ind_train, TRUE],
parms = list(split = "information"))
newcp <- max(fgl.rpart$cptable[,"CP"] *
as.numeric(fgl.rpart$cptable[TRUE ,"xerror"] <
sum(fgl.rpart$cptable[dim(fgl.rpart$cptable)[1],
newcp <- max(fgl_rpart$cptable[,"CP"] *
as.numeric(fgl_rpart$cptable[TRUE ,"xerror"] <
sum(fgl_rpart$cptable[dim(fgl_rpart$cptable)[1],
c("xerror","xstd")]))
) + 1e-13
fgl.rpart.pruned <- prune(fgl.rpart, cp = newcp)
fgl_rpart_pruned <- prune(fgl_rpart, cp = newcp)
@
and a multinomial log-linear model using \rcode{nnet::multinom}:
<<echo=true>>=
library(nnet)
fgl.multinom <- multinom(type ~ ., data = fgl[ind.train, TRUE],
fgl_multinom <- multinom(type ~ ., data = fgl[ind_train, TRUE],
trace = FALSE)
@
We can now assess the model accuracy using either a confusion matrix of the classified predictions
<<echo=true>>=
library(mda)
confusion(predict(fgl.rpart.pruned, newdata = fgl[ind.eval, TRUE],
confusion(predict(fgl_rpart_pruned, newdata = fgl[ind_eval, TRUE],
type = "class"),
fgl[ind.eval, "type"])
confusion(predict(fgl.multinom, newdata = fgl[ind.eval, TRUE],
fgl[ind_eval, "type"])
confusion(predict(fgl_multinom, newdata = fgl[ind_eval, TRUE],
type = "class"),
fgl[ind.eval, "type"])
fgl[ind_eval, "type"])
@
or a multiple class version of AUC using the raw predictions:
<<echo=true>>=
library(HandTill2001)
auc(multcap(response = fgl[ind.eval, "type"],
predicted = predict(fgl.rpart.pruned,
newdata = fgl[ind.eval, TRUE])))
auc(multcap(response = fgl[ind_eval, "type"],
predicted = predict(fgl_rpart_pruned,
newdata = fgl[ind_eval, TRUE])))
auc(multcap(response = fgl[ind.eval, "type"],
predicted = predict(fgl.multinom,
newdata = fgl[ind.eval, TRUE],
auc(multcap(response = fgl[ind_eval, "type"],
predicted = predict(fgl_multinom,
newdata = fgl[ind_eval, TRUE],
type = "probs")))
@
To enhance predictive performance, we decide to use both models to build a
......@@ -77,45 +80,45 @@ Furthermore, we want to use the 'weighted average' consensus method given by \ci
So we split the training set into two complementary subsets: 'inner training' and 'inner evaluation'.
<<echo=true>>=
set.seed(100)
ind.inner.train <- sample(ind.train,
size = floor(length(ind.train) * 0.7),
ind_inner_train <- sample(ind_train,
size = floor(length(ind_train) * 0.7),
replace = FALSE)
ind.inner.eval <- setdiff(ind.train, ind.inner.train)
ind_inner_eval <- setdiff(ind_train, ind_inner_train)
@
We then refit our two models to the 'inner training' data:
<<echo=true>>=
wa.fgl.multinom <- multinom(fgl.multinom, data = fgl[ind.inner.train, ],
wa_fgl_multinom <- multinom(fgl_multinom, data = fgl[ind_inner_train, ],
trace = FALSE)
wa.fgl.rpart <- rpart(type ~ ., data = fgl[ind.inner.train, ],
wa_fgl_rpart <- rpart(type ~ ., data = fgl[ind_inner_train, ],
parms = list(split = "information")
)
newcp <- max(wa.fgl.rpart$cptable[,"CP"] *
as.numeric(wa.fgl.rpart$cptable[TRUE ,"xerror"] <
sum(wa.fgl.rpart$cptable[dim(wa.fgl.rpart$cptable)[1],
newcp <- max(wa_fgl_rpart$cptable[,"CP"] *
as.numeric(wa_fgl_rpart$cptable[TRUE ,"xerror"] <
sum(wa_fgl_rpart$cptable[dim(wa_fgl_rpart$cptable)[1],
c("xerror","xstd")]))
) + 1e-13
wa.fgl.rpart.pruned <- prune(wa.fgl.rpart, cp = newcp)
wa_fgl_rpart_pruned <- prune(wa_fgl_rpart, cp = newcp)
@
and calculate pre-evaluation AUC (which we save in a \rcode{list}) using the 'inner evaluation' data and the refitted models:
<<echo=true>>=
li <- list()
li$rpart$auc <- auc(multcap(response = fgl[ind.inner.eval, "type"],
predicted = predict(wa.fgl.rpart.pruned,
newdata = fgl[ind.inner.eval,
li$rpart$auc <- auc(multcap(response = fgl[ind_inner_eval, "type"],
predicted = predict(wa_fgl_rpart_pruned,
newdata = fgl[ind_inner_eval,
TRUE]
)))
li$mllm$auc <- auc(multcap(response = fgl[ind.inner.eval, "type"],
predicted = predict(wa.fgl.multinom,
newdata = fgl[ind.inner.eval,
li$mllm$auc <- auc(multcap(response = fgl[ind_inner_eval, "type"],
predicted = predict(wa_fgl_multinom,
newdata = fgl[ind_inner_eval,
TRUE],
type = "probs")))
@
We add the predictions using the models (the 'original' or 'Single' ones, not the refitted) for the evaluation set
<<echo=true>>=
li$rpart$predictions <- predict(fgl.rpart.pruned,
newdata = fgl[ind.eval, TRUE])
li$mllm$predictions <- predict(fgl.multinom,
newdata = fgl[ind.eval, TRUE],
li$rpart$predictions <- predict(fgl_rpart_pruned,
newdata = fgl[ind_eval, TRUE])
li$mllm$predictions <- predict(fgl_multinom,
newdata = fgl[ind_eval, TRUE],
type = "probs")
@
and obtain the consensus predictions as (\cite[Eqn 1]{marmion2009})
......@@ -126,15 +129,15 @@ predicted <- Reduce('+', lapply(li, function(x)
@
which perform (slightly) better than the predictions using the 'single models':
<<echo=true>>=
auc(multcap(response = fgl[ind.eval, "type"],
auc(multcap(response = fgl[ind_eval, "type"],
predicted = predicted))
@
To classify the predicted probabilities, we choose the class with highest predicted probability (which.max gives the \_first\_ maximum):
<<echo=true>>=
classes.predicted <-
classes_predicted <-
factor(x = apply(predicted, 1, function(x)
dimnames(predicted)[[2]][which.max(x)]),
levels = levels(fgl[ind.eval, "type"])
levels = levels(fgl[ind_eval, "type"])
)
@
......