Commit 4adab759 authored by Jakob Wirbel's avatar Jakob Wirbel
Browse files

changes from the internal structure of the mlr3 package.

parent 297bae13
......@@ -5,59 +5,69 @@
#' @title Evaluate prediction results
#'
#' @description This function takes the correct labels and predictions for all
#' samples and evaluates the results using the \itemize{
#' \item Area Under the Receiver Operating Characteristic (ROC)
#' Curve (AU-ROC)
#' \item and the Precision-Recall Curve (PR)}
#' as metric. Predictions can be supplied either for a single case or as
#' matrix after resampling of the dataset.
#'
#' Prediction results are usually produced with the function
#' \link{make.predictions}.
#' @description This function compares the predictions (from
#' [make.predictions]) and true labels for all samples and evaluates
#' the results.
#'
#' @param siamcat object of class \link{siamcat-class}
#'
#' @param verbose integer, control output: \code{0} for no output at all,
#' \code{1} for only information about progress and success, \code{2} for
#' normal level of information and \code{3} for full debug information,
#' defaults to \code{1}
#' @param verbose integer, control output: \code{0} for no output at all,
#' \code{1} for only information about progress and success, \code{2} for
#' normal level of information and \code{3} for full debug information,
#' defaults to \code{1}
#'
#' @keywords SIAMCAT evaluate.predictions
#'
#' @details This functions calculates several metrices for the predictions in
#' the \code{pred_matrix}-slot of the \link{siamcat-class}-object.
#' The Area Under the Receiver Operating Characteristic (ROC)
#' Curve (AU-ROC) and the Precision-Recall Curve will be evaluated and
#' the results will be saved in the \code{eval_data}-slot of the
#' supplied \link{siamcat-class}-object. The \code{eval_data}-slot
#' contains a list with several entries: \itemize{
#' \item \code{$roc} - average ROC-curve across repeats or a
#' single ROC-curve on complete dataset (see \link[pROC]{roc});
#' \item \code{$auroc} - AUC value for the average ROC-curve;
#' \item \code{$prc} - list containing the positive predictive value
#' (precision) and true positive rate (recall) values used
#' to plot the mean PR curve;
#' \item \code{$auprc} - AUC value for the mean PR curve;
#' \item \code{$ev} - list containing for different decision thresholds
#' the number of false positives, false negatives, true
#' negatives, and true positives.}
#' For the case of repeated cross-validation, the function will
#' additonally return \itemize{
#' \item \code{$roc.all} - list of roc objects (see \link[pROC]{roc})
#' for every repeat;
#' \item \code{$auroc.all} - vector of AUC values for the ROC curves
#' for every repeat;
#' \item \code{$prc.all} - list of PR curves for every repeat;
#' \item \code{$auprc.all} - vector of AUC values for the PR curves
#' for every repeat;
#' \item \code{$ev.all} - list of \code{ev} lists (see above)
#' for every repeat.}
#' @section Binary classification problems:
#' This function calculates several metrics for the predictions in
#' the \code{pred_matrix}-slot of the \link{siamcat-class}-object.
#' The Area Under the Receiver Operating Characteristic (ROC) Curve (AU-ROC)
#' and the Precision-Recall Curve will be evaluated and the results will be
#' saved in the \code{eval_data}-slot of the supplied \link{siamcat-class}-
#' object. The \code{eval_data}-slot contains a list with several entries:
#' \itemize{
#' \item \code{$roc} - average ROC-curve across repeats or a single ROC-curve
#' on complete dataset (see \link[pROC]{roc});
#' \item \code{$auroc} - AUC value for the average ROC-curve;
#' \item \code{$prc} - list containing the positive predictive value
#' (precision) and true positive rate (recall) values used to plot the mean
#' PR curve;
#' \item \code{$auprc} - AUC value for the mean PR curve;
#' \item \code{$ev} - list containing for different decision thresholds the
#' number of false positives, false negatives, true negatives, and true
#' positives.}
#' For the case of repeated cross-validation, the function will additionally
#' return \itemize{
#' \item \code{$roc.all} - list of roc objects (see \link[pROC]{roc})
#' for every repeat;
#' \item \code{$auroc.all} - vector of AUC values for the ROC curves
#' for every repeat;
#' \item \code{$prc.all} - list of PR curves for every repeat;
#' \item \code{$auprc.all} - vector of AUC values for the PR curves
#' for every repeat;
#' \item \code{$ev.all} - list of \code{ev} lists (see above)
#' for every repeat.}
#'
#' @section Regression problems:
#' This function calculates several metrics for the evaluation of predictions
#' and will store the results in the \code{eval_data}-slot of the supplied
#' \link{siamcat-class} objects. The \code{eval_data}-slot will contain:
#' \itemize{
#' \item \code{r2} - the mean R squared value across repeats or a single
#' R-squared value on the complete dataset;
#' \item \code{mae} - them mean absolute error of the predictions;
#' \item \code{mse} - the mean squared error of the predictions.}
#' For the case of repeated cross-validation, the function will additionally
#' compute all three of these measures for the individual cross-validation
#' repeats and will store the results in the \code{eval_data} slot as
#' \code{r2.all}, \code{mae.all}, and \code{mse.all}.
#'
#' @export
#'
#' @return object of class \link{siamcat-class} with the
#' slot \code{eval_data} filled
#' @encoding UTF-8
#'
#' @return object of class \link{siamcat-class} with the slot
#' \code{eval_data} filled
#'
#' @examples
#' data(siamcat_example)
......@@ -68,17 +78,89 @@ evaluate.predictions <- function(siamcat, verbose = 1) {
message("+ starting evaluate.predictions")
s.time <- proc.time()[3]
# check that predictions are present
if (is.null(pred_matrix(siamcat, verbose=0))){
stop('SIAMCAT object does not contain predictions. Exiting\n')
}
label <- label(siamcat)
if (label$type == 'TEST'){
stop('SIAMCAT can not evaluate the predictions on a TEST',
' label. Exiting...')
}
# check that predictions are present
if (is.null(pred_matrix(siamcat, verbose=0))){
stop('SIAMCAT object does not contain predictions. Exiting\n')
if (label$type == 'BINARY'){
r.object <- eval.binary(siamcat, s.time, verbose)
} else if (label$type == 'CONTINUOUS'){
r.object <- eval.regr(siamcat, s.time, verbose)
}
return(r.object)
}
#' @keywords internal
eval.regr <- function(siamcat, s.time, verbose=0){
label <- label(siamcat)
m <- match(names(label$label), rownames(pred_matrix(siamcat)))
pred <- pred_matrix(siamcat)[m, , drop = FALSE]
stopifnot(all(names(label$label) == rownames(pred)))
if (ncol(pred) > 1){
if (verbose > 2)
message("+ evaluating multiple predictions")
# mean predictions
pred.mean <- rowMeans(pred)
ess <- sum((label$label - mean(label$label))^2)
rss <- sum((abs(pred.mean) - label$label)^2)
r2.mean <- 1 - rss/ess
mae.mean <- mean(abs(pred.mean - label$label))
mse.mean <- mean((abs(pred.mean - label$label))^2)
# each repetition individually
r2.all <- list()
mae.all <- list()
mse.all <- list()
for (i in seq_len(ncol(pred))){
rss <- sum((abs(pred[,i]) - label$label)^2)
r2.all[[i]] <- 1 - rss/ess
mae.all[[i]] <- mean(abs(pred[,i] - label$label))
mse.all[[i]] <- mean((abs(pred[,i] - label$label))^2)
}
eval_data(siamcat) <- list(
r2 = r2.mean, r2.all = r2.all,
mae = mae.mean, mae.all = mae.all,
mse = mse.mean, mse.all = mse.all)
} else {
if (verbose > 2)
message("+ evaluating single prediction")
rss <- sum((abs(pred[,1]) - label$label)^2)
ess <- sum((label$label - mean(label$label))^2)
r2 <- 1 - rss/ess
mae <- mean(abs(pred[,1] - label$label))
mse <- mean((abs(pred[,1] - label$label))^2)
eval_data(siamcat) <- list(r2=r2, mae=mae, mse=mse)
}
e.time <- proc.time()[3]
if (verbose > 1)
message(paste(
"+ finished evaluate.predictions in",
formatC(e.time - s.time, digits = 3),
"s"
))
if (verbose == 1)
message("Evaluated predictions successfully.")
return(siamcat)
}
#' @keywords internal
eval.binary <- function(siamcat, s.time, verbose=0){
label <- label(siamcat)
summ.stat = "mean" # TODO make this a possible parameter?
# TODO compare header to label make sure that label and prediction are in
# the same order
......@@ -96,30 +178,21 @@ evaluate.predictions <- function(siamcat, verbose = 1) {
roc.all = list()
auroc.all = vector("numeric", ncol(pred))
for (c in seq_len(ncol(pred))) {
roc.all[[c]] = roc(
response = label$label,
predictor = pred[, c],
direction = '<',
levels = label$info,
ci = FALSE
)
roc.all[[c]] = roc(response = label$label, predictor = pred[, c],
direction = '<', levels = label$info, ci = FALSE)
auroc.all[c] = roc.all[[c]]$auc
}
l.vec = rep(label$label, ncol(pred))
} else {
l.vec = label$label
}
# average data for plotting one mean prediction curve
roc.mean = roc(
response = label$label,
predictor = apply(pred, 1, summ.stat),
#ci = TRUE,
#of = "se",
sp = seq(0, 1, 0.05),
direction = '<',
levels = label$info
)
roc.mean = roc(response = label$label,
predictor = apply(pred, 1, summ.stat),
#ci = TRUE, #of = "se",
sp = seq(0, 1, 0.05), direction = '<', levels = label$info)
auroc = roc.mean$auc
# ##########################################################################
......@@ -133,22 +206,19 @@ evaluate.predictions <- function(siamcat, verbose = 1) {
ev.all <- list()
for (c in seq_len(ncol(pred))) {
ev.all[[c]] = evaluate.classifier(pred[, c], label$label, label,
verbose = verbose)
verbose = verbose)
prc.all[[c]] = evaluate.get.pr(ev.all[[c]], verbose = verbose)
auprc.all[c] = evaluate.calc.aupr(ev.all[[c]], verbose = verbose)
}
ev = evaluate.classifier(
apply(pred, 1, summ.stat),
label$label, label)
ev = evaluate.classifier(apply(pred, 1, summ.stat), label$label, label)
} else {
ev = evaluate.classifier(as.vector(pred), label$label, label,
verbose = verbose)
verbose = verbose)
}
prc = evaluate.get.pr(ev, verbose = verbose)
auprc <- c(evaluate.calc.aupr(ev, verbose = verbose))
if (ncol(pred) > 1) {
if (verbose > 2)
message("+ evaluating multiple predictions")
......
......@@ -6,258 +6,267 @@
#' @title Make predictions on a test set
#'
#' @description This function takes a \link{siamcat-class}-object containing
#' a model trained by \link{train.model} and performs predictions on
#' a given test-set.
#' a model trained by \link{train.model} and performs predictions on
#' a given test-set.
#'
#' @usage make.predictions(siamcat, siamcat.holdout = NULL,
#' normalize.holdout = TRUE, verbose = 1)
#' @usage make.predictions(siamcat, siamcat.holdout = NULL,
#' normalize.holdout = TRUE, verbose = 1)
#'
#' @param siamcat object of class \link{siamcat-class}
#'
#' @param siamcat.holdout optional, object of class \link{siamcat-class} on
#' which to make predictions, defaults to \code{NULL}
#' @param siamcat.holdout optional, object of class \link{siamcat-class} on
#' which to make predictions, defaults to \code{NULL}
#'
#' @param normalize.holdout boolean, should the holdout features be normalized
#' with a frozen normalization (see \link{normalize.features}) using the
#' normalization parameters in \code{siamcat}?, defaults to \code{TRUE}
#' with a frozen normalization (see \link{normalize.features}) using the
#' normalization parameters in \code{siamcat}?, defaults to \code{TRUE}
#'
#' @param verbose integer, control output: \code{0} for no output at all,
#' \code{1} for only information about progress and success, \code{2} for
#' normal level of information and \code{3} for full debug information,
#' defaults to \code{1}
#' \code{1} for only information about progress and success, \code{2} for
#' normal level of information and \code{3} for full debug information,
#' defaults to \code{1}
#'
#' @export
#'
#' @encoding UTF-8
#'
#' @keywords SIAMCAT make.predictions
#'
#' @return object of class \link{siamcat-class} with the slot \code{pred_matrix}
#' filled
#' @return object of class \link{siamcat-class} with the slot
#' \code{pred_matrix} filled
#'
#' @details This functions uses the model in the \code{model_list}-slot of the
#' \code{siamcat} object to make predictions on a given test set. The
#' test set can either consist of the test instances in the cross-
#' validation, saved in the \code{data_split}-slot of the same
#' \code{siamcat} object, or a completely external feature set, given in
#' the form of another \code{siamcat} object (\code{siamcat.holdout}).
#' \code{siamcat} object to make predictions on a given test set. The test set
#' can either consist of the test instances in the cross-validation, saved in
#' the \code{data_split}-slot of the same \code{siamcat} object, or a
#' completely external feature set, given in the form of another
#' \code{siamcat} object (\code{siamcat.holdout}).
#'
#' @examples
#' data(siamcat_example)
#'
#' # Simple example
#' siamcat_example <- train.model(siamcat_example, method='lasso')
#' siamcat.pred <- make.predictions(siamcat_example)
#'
#' # Predictions on a holdout-set
#' \donttest{pred.mat <- make.predictions(siamcat.trained, siamcat.holdout,
#' normalize.holdout=TRUE)}
make.predictions <- function(siamcat,
siamcat.holdout = NULL,
normalize.holdout = TRUE,
verbose = 1) {
make.predictions <- function(siamcat, siamcat.holdout = NULL,
normalize.holdout = TRUE, verbose = 1) {
s.time <- proc.time()[3]
# models
if (is.null(models(siamcat, verbose=0))){
stop('SIAMCAT does not seem to contain any models. Exiting...')
}
# if holdout is NULL, make predictions on data in siamcat
if (is.null(siamcat.holdout)) {
if (verbose > 1)
message("+ starting make.predictions on siamcat object")
r.object <- make.interal.predictions(siamcat, verbose)
} else {
r.object <- make.external.predictions(
siamcat.trained = siamcat, siamcat.external = siamcat.holdout,
normalize.holdout, verbose)
}
pred <- pred_matrix(r.object)
# print correlation matrix
if (verbose > 1)
message(paste("Total number of predictions made:", length(pred)))
correlation <- cor(pred, method = "spearman")
if (verbose > 1)
message("Correlation between predictions from repeated CV:")
if (verbose > 1)
message(paste("\tMin: ", min(correlation), "\n\tMedian: ",
median(correlation), "\n\tMean: ", mean(correlation)))
# label
label <- label(siamcat)
if (label$type == 'TEST'){
stop('SIAMCAT can not predict on a reference object with a',
' TEST label. Exiting...')
}
# data.split
if (is.null(data_split(siamcat, verbose=0))){
stop('SIAMCAT needs a data split for predictions! Exiting...')
}
data.split <- data_split(siamcat)
# models
if (is.null(models(siamcat, verbose=0))){
stop('SIAMCAT does not seem to contain any models. Exiting...')
}
models <- models(siamcat)
# features
feature.type <- feature_type(siamcat)
if (feature.type == 'original'){
feat <- get.orig_feat.matrix(siamcat)
} else if (feature.type == 'filtered'){
feat <- get.filt_feat.matrix(siamcat)
} else if (feature.type == 'normalized'){
feat <- get.norm_feat.matrix(siamcat)
}
rownames(feat) <- make.names(rownames(feat))
feat <- t(feat)
# print out time
e.time <- proc.time()[3]
if (verbose > 1)
message(paste(
"+ finished make.predictions in",
formatC(e.time - s.time, digits = 3),
"s"
))
if (verbose == 1)
message("Made predictions successfully.")
label.fac <-
factor(label$label,
levels = sort(label$info))
return(r.object)
}
num.folds <- data.split$num.folds
num.resample <- data.split$num.resample
pred <- matrix(NA, ncol = num.resample, nrow = length(label.fac),
dimnames = list(names(label.fac), paste0("CV_rep",
seq_len(num.resample))))
i = 1
if (verbose == 1 || verbose == 2)
pb <- progress_bar$new(total = num.folds * num.resample)
for (f in seq_len(num.folds)) {
for (r in seq_len(num.resample)) {
test.label <- label.fac[data.split$test.folds[[r]][[f]]]
data <-
as.data.frame(feat[data.split$test.folds[[r]][[f]], ,
drop=FALSE])
#' @keywords internal
make.interal.predictions <- function(siamcat, verbose){
if (verbose > 1)
message("+ starting make.predictions on siamcat object")
# assert stuff
stopifnot(nrow(data) == length(test.label))
stopifnot(all(rownames(data) == names(test.label)))
data.split <- data_split(siamcat)
models <- models(siamcat)
label <- label(siamcat)
# features
feature.type <- feature_type(siamcat)
if (feature.type == 'original'){
feat <- get.orig_feat.matrix(siamcat)
} else if (feature.type == 'filtered'){
feat <- get.filt_feat.matrix(siamcat)
} else if (feature.type == 'normalized'){
feat <- get.norm_feat.matrix(siamcat)
}
rownames(feat) <- make.names(rownames(feat))
feat <- t(feat)
model <- models[[i]]
if (label$type == 'BINARY'){
label.fac <-
factor(label$label,
levels = sort(label$info))
} else if (label$type == "CONTINUOUS"){
label.fac <- label$label
}
stopifnot(!any(rownames(model$task$env$data) %in%
rownames(data)))
num.folds <- data.split$num.folds
num.resample <- data.split$num.resample
# subselect features for each model
# needs to be added due to feature selection
data <- data[,model$features]
pred <- matrix(NA, ncol = num.resample, nrow = length(label.fac),
dimnames = list(names(label.fac),
paste0("CV_rep", seq_len(num.resample))))
i = 1
if (verbose == 1 || verbose == 2)
pb <- progress_bar$new(total = num.folds * num.resample)
for (f in seq_len(num.folds)) {
for (r in seq_len(num.resample)) {
test.label <- label.fac[data.split$test.folds[[r]][[f]]]
data <-
as.data.frame(feat[data.split$test.folds[[r]][[f]], ,
drop=FALSE])
data$label <- test.label
# assert stuff
stopifnot(nrow(data) == length(test.label))
stopifnot(all(rownames(data) == names(test.label)))
if (verbose > 2)
message(paste0("Applying ", model_type(siamcat),
" on cv_fold", f, "_rep", r, " (", i, " of ",
num.resample * num.folds, ")..."))
model <- models[[i]]
# subselect features for each model
# needs to be added due to feature selection
data <- data[,names(model$features)]
task <-
makeClassifTask(data = data, target = "label",
fixup.data='quiet', check.data=FALSE)
pdata <- predict(model, task = task)
data$label <- test.label
p <- pdata$data[, 4]
names(p) <- rownames(pdata$data)
pred[names(p), r] <- p
i <- i + 1
if (verbose == 1 || verbose == 2)
pb$tick()
if (verbose > 2)
message(paste0("Applying ", model_type(siamcat),
" on cv_fold", f, "_rep", r, " (", i, " of ",
num.resample * num.folds, ")..."))
if (label$type == 'BINARY'){
test.task <- TaskClassif$new(id='classif', backend=data,
target='label')
pdata <- model$model$predict(task=test.task)
p <- pdata$data$prob[,2]
names(p) <- rownames(data)
} else if (label$type == 'CONTINUOUS'){
test.task <- TaskRegr$new(id='regr', backend=data,
target='label')
pdata <- model$model$predict(task=test.task)
p <- pdata$data$response
names(p) <- rownames(data)
}
pred[names(p), r] <- p
i <- i + 1
if (verbose == 1 || verbose == 2)
pb$tick()
}
stopifnot(!any(is.na(pred)))
pred_matrix(siamcat) <- pred
r.object <- siamcat
} else {
if (verbose > 1)
message("+ starting make.predictions on external dataset")
}
stopifnot(!any(is.na(pred)))
pred_matrix(siamcat) <- pred
return(siamcat)
}
# check reference set
if (is.null(data_split(siamcat, verbose=0))){
stop('Reference SIAMCAT object should contain a data split.',
' Exiting...')
}
data.split <- data_split(siamcat)
if (is.null(models(siamcat, verbose=0))){
stop('Reference SIAMCAT object should contains models. Exiting...')
}
models <- models(siamcat)
#' @keywords internal
make.external.predictions <- function(siamcat.trained, siamcat.external,
normalize, verbose){
if (verbose > 1)
message("+ starting make.predictions on external dataset")
feature.type <- feature_type(siamcat)
models <- models(siamcat.trained)
label <- label(siamcat.trained)
feature.type <- feature_type(siamcat.trained)
if (feature.type == 'normalized'){
if (feature.type == 'normalized'){
if (normalize.holdout) {
if (verbose > 1)
message("+ Performing frozen normalization on holdout set")
siamcat.holdout <- normalize.features(siamcat.holdout,
norm.param = norm_params(siamcat), feature.type='original',
verbose = verbose)
} else {
warning("WARNING: holdout set is not being normalized!")
if (is.null(norm_feat(siamcat.holdout, verbose=0))){
stop('Holdout set has not been normalized yet!')
}
}
feat.test <- get.norm_feat.matrix(siamcat.holdout)
} else if (feature.type == 'filtered') {
if (is.null(filt_feat(siamcat.holdout, verbose=0))){
stop('Holdout set has not been filtered yet!')
if (normalize) {
if (verbose > 1)
message("+ Performing frozen normalization on holdout set")
siamcat.external <- normalize.features(
siamcat.external, norm.param = norm_params(siamcat.trained),
feature.type='original', verbose = verbose)
} else {
warning("WARNING: holdout set is not being normalized!")
if (is.null(norm_feat(siamcat.external, verbose=0))){
stop('Holdout set has not been normalized yet!')
}
feat.test <- get.filt_feat.matrix(siamcat.holdout)
} else if (feature.type == 'original'){
feat.test <-