diff --git a/.dockerfile/2.0.0-beta/dockerfile b/.dockerfile/2.0.0-beta/dockerfile
new file mode 100644
index 0000000000000000000000000000000000000000..c58676d004658cf0620697ea90104cc899805bc0
--- /dev/null
+++ b/.dockerfile/2.0.0-beta/dockerfile
@@ -0,0 +1,15 @@
+FROM r-base:4.3.1
+
+
+RUN apt-get -y update && \
+ apt-get -y install cmake libxml2-dev libcurl4-gnutls-dev
+
+COPY HTRfit_v2.0.0-beta.tar.gz /HTRfit_v2.0.0-beta.tar.gz
+
+RUN R -e "install.packages(c('car', 'parallel', 'data.table', 'ggplot2', 'gridExtra', 'glmmTMB', 'magrittr', 'MASS', 'reshape2', 'rlang', 'stats', 'utils', 'BiocManager'))"
+
+RUN R -e "BiocManager::install('S4Vectors', update = FALSE)"
+
+RUN R -e "BiocManager::install('DESeq2', update = FALSE)"
+
+RUN R -e "install.packages('/HTRfit_v2.0.0-beta.tar.gz', repos = NULL, type='source')"
diff --git a/DESCRIPTION b/DESCRIPTION
index 39a3fdc6ba8882b5df5d996125028e61b498c8ec..991f17829b8e4d8bc3b5a5461e179c86b66ff1cb 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,6 +1,6 @@
Package: HTRfit
Title: HTRfit
-Version: 1.0.2
+Version: 0.0.0.9000
Authors@R:
person("First", "Last", , "first.last@example.com", role = c("aut", "cre"),
comment = c(ORCID = "YOUR-ORCID-ID"))
@@ -15,7 +15,6 @@ Imports:
magrittr,
MASS,
parallel,
- plotROC,
reshape2,
rlang,
S4Vectors,
diff --git a/NAMESPACE b/NAMESPACE
index 6b45d02d6500eb66090777e854c3640c520bd303..8463ec664ed394337f3100fa56d0eebc5b3901c5 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -1,11 +1,19 @@
# Generated by roxygen2: do not edit by hand
export("%>%")
+export(AUC)
+export(Area_Under_Curve)
+export(ConfusionDF)
+export(ConfusionMatrix)
+export(PRAUC)
+export(accuracy)
export(addBasalExpression)
export(add_interaction)
export(already_init_variable)
export(anovaParallel)
export(averageByGroup)
+export(build_gg_pr_curve)
+export(build_gg_roc_curve)
export(build_missingColumn_with_na)
export(calculate_actualMixed)
export(calculate_actual_interactionX2_values)
@@ -15,14 +23,21 @@ export(clean_variable_name)
export(compareInferenceToExpected)
export(computeActualInteractionFixEff)
export(compute_covariation)
+export(compute_metrics_summary)
+export(compute_pr_auc)
+export(compute_pr_curve)
+export(compute_roc_auc)
+export(compute_roc_curve)
+export(compute_rsquare)
export(convert2Factor)
export(correlation_matrix_2df)
export(countMatrix_2longDtf)
export(counts_plot)
-export(dispersion_plot)
+export(diagnostic_plot)
export(drop_randfx)
export(endsWithDigit)
-export(evaluateDispersion)
+export(eval_identityTerm)
+export(evaluation_report)
export(exportReportFile)
export(extract_ddsDispersion)
export(extract_fixed_effect)
@@ -80,11 +95,22 @@ export(getSettingsTable)
export(getStandardDeviationInCorrelation)
export(getTidyGlmmTMB)
export(getValidDispersion)
+export(get_eval_data)
+export(get_eval_data_from_dds)
+export(get_eval_data_from_ltmb)
+export(get_eval_metrics)
export(get_inference_dds)
+export(get_label_y_position)
+export(get_ml_metrics_obj)
+export(get_performances_metrics_obj)
+export(get_pr_curve)
+export(get_pr_object)
+export(get_roc_curve)
+export(get_roc_object)
+export(get_rsquare_2plot)
export(glance_tmb)
export(group_logQij_per_genes_and_labels)
export(handleAnovaError)
-export(identity_plot)
export(inferenceToExpected_withFixedEff)
export(inferenceToExpected_withMixedEff)
export(init_variable)
@@ -100,13 +126,18 @@ export(join_dtf)
export(launchFit)
export(launchUpdate)
export(medianRatioNormalization)
-export(metrics_plot)
export(mock_rnaseq)
export(parallel_fit)
export(parallel_update)
+export(performance)
+export(precision)
+export(prediction)
export(prepareData2computeInteraction)
export(prepareData2fit)
export(prepare_dataParallel)
+export(rbind_evaldata_tmb_dds)
+export(rbind_model_params_and_dispersion)
+export(recall)
export(removeDigitsAtEnd)
export(removeDuplicatedWord)
export(renameColumns)
@@ -114,11 +145,11 @@ export(reorderColumns)
export(replicateByGroup)
export(replicateMatrix)
export(replicateRows)
-export(roc_plot)
export(samplingFromMvrnorm)
export(scaleCountsTable)
+export(sensitivity)
export(set_correlation)
-export(simulationReport)
+export(specificity)
export(subsetByTermLabel)
export(subsetFixEffectInferred)
export(subsetGenes)
@@ -129,6 +160,8 @@ export(updateParallel)
export(wald_test)
export(wrap_dds)
export(wrapper_var_cor)
+exportClasses(performance)
+exportClasses(prediction)
importFrom(MASS,mvrnorm)
importFrom(car,Anova)
importFrom(data.table,data.table)
@@ -136,45 +169,51 @@ importFrom(data.table,setDT)
importFrom(data.table,setorderv)
importFrom(data.table,tstrsplit)
importFrom(ggplot2,aes)
+importFrom(ggplot2,coord_fixed)
importFrom(ggplot2,element_blank)
importFrom(ggplot2,facet_wrap)
importFrom(ggplot2,geom_abline)
importFrom(ggplot2,geom_density)
importFrom(ggplot2,geom_histogram)
+importFrom(ggplot2,geom_path)
importFrom(ggplot2,geom_point)
+importFrom(ggplot2,geom_text)
importFrom(ggplot2,ggplot)
importFrom(ggplot2,ggsave)
importFrom(ggplot2,ggtitle)
importFrom(ggplot2,scale_color_manual)
importFrom(ggplot2,scale_x_log10)
-importFrom(ggplot2,scale_y_log10)
importFrom(ggplot2,sym)
importFrom(ggplot2,theme)
importFrom(ggplot2,theme_bw)
importFrom(ggplot2,unit)
-importFrom(ggplot2,xlab)
-importFrom(ggplot2,ylab)
+importFrom(ggplot2,xlim)
+importFrom(ggplot2,ylim)
importFrom(gridExtra,arrangeGrob)
importFrom(gridExtra,grid.arrange)
importFrom(gridExtra,tableGrob)
importFrom(gridExtra,ttheme_minimal)
importFrom(magrittr,"%>%")
-importFrom(plotROC,geom_roc)
importFrom(reshape2,dcast)
importFrom(reshape2,melt)
importFrom(rlang,":=")
importFrom(rlang,.data)
+importFrom(rlang,new_environment)
importFrom(stats,anova)
+importFrom(stats,approxfun)
importFrom(stats,as.formula)
importFrom(stats,cor)
importFrom(stats,drop.terms)
+importFrom(stats,integrate)
importFrom(stats,median)
importFrom(stats,model.matrix)
+importFrom(stats,na.omit)
importFrom(stats,p.adjust)
importFrom(stats,pnorm)
importFrom(stats,rnbinom)
importFrom(stats,sd)
importFrom(stats,setNames)
+importFrom(stats,splinefun)
importFrom(stats,terms)
importFrom(stats,update)
importFrom(utils,tail)
diff --git a/R/evaluate_dispersion.R b/R/evaluate_dispersion.R
index f0492716a9d82268c69ceafac21688d30fa00195..0b30f99ba036a100f9c7678ebe27d36525acf5e3 100644
--- a/R/evaluate_dispersion.R
+++ b/R/evaluate_dispersion.R
@@ -1,31 +1,6 @@
# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
-#' Evaluate Dispersion Comparison
-#'
-#' Compares dispersion values between two data frames containing dispersion information.
-#'
-#' @param TMB_dispersion_df A data frame containing dispersion values from TMB.
-#' @param DESEQ_dispersion_df A data frame containing dispersion values from DESeq2.
-#' @param color2use vector of color use for points coloration
-#'
-#' @return A list containing a dispersion plot and a data frame with dispersion comparison.
-#' @importFrom ggplot2 scale_color_manual
-#' @export
-#'
-#' @examples
-#' \dontrun{
-#' disp_comparison <- evaluateDispersion(TMB_dispersion_df, DESEQ_dispersion_df, "red")
-#' plot_dispersion <- disp_comparison$disp_plot
-#' comparison_df <- disp_comparison$data
-#' }
-evaluateDispersion <- function(TMB_dispersion_df, DESEQ_dispersion_df, color2use) {
- disp_comparison_dtf <- rbind(TMB_dispersion_df, DESEQ_dispersion_df)
- disp_plot <- dispersion_plot(disp_comparison_dtf, col = "from", pch = "from") + ggplot2::scale_color_manual(values = color2use)
- return(list(disp_plot = disp_plot, data = disp_comparison_dtf))
-}
-
-
#' Get Dispersion Comparison
#'
#' Compares inferred dispersion values with actual dispersion values.
@@ -42,10 +17,12 @@ evaluateDispersion <- function(TMB_dispersion_df, DESEQ_dispersion_df, color2use
#' dispersion_comparison <- getDispersionComparison(inferred_disp, actual_disp)
#' }
getDispersionComparison <- function(inferred_dispersion, actual_dispersion) {
- actual_disp <- data.frame(actual_dispersion = actual_dispersion)
- actual_disp$geneID <- rownames(actual_disp)
+ actual_disp <- data.frame(actual = actual_dispersion)
+ actual_disp$ID <- rownames(actual_disp)
rownames(actual_disp) <- NULL
- disp_comparison <- join_dtf(actual_disp, inferred_dispersion, "geneID", "geneID")
+ disp_comparison <- join_dtf(actual_disp, inferred_dispersion, c("ID"), c("ID"))
+ disp_comparison$term <- 'dispersion'
+ disp_comparison$description <- 'dispersion'
return(disp_comparison)
}
@@ -65,8 +42,8 @@ getDispersionComparison <- function(inferred_dispersion, actual_dispersion) {
#' dispersion_df <- extract_ddsDispersion(deseq2_object)
#' }
extract_ddsDispersion <- function(dds_wrapped) {
- inferred_dispersion <- data.frame(inferred_dispersion = dds_wrapped$dispersion)
- inferred_dispersion$geneID <- rownames(inferred_dispersion)
+ inferred_dispersion <- data.frame(estimate = dds_wrapped$dispersion)
+ inferred_dispersion$ID <- rownames(inferred_dispersion)
rownames(inferred_dispersion) <- NULL
return(inferred_dispersion)
}
@@ -88,45 +65,10 @@ extract_ddsDispersion <- function(dds_wrapped) {
#' }
extract_tmbDispersion <- function(list_tmb) {
glanceRes <- glance_tmb(list_tmb)
- inferred_dispersion <- data.frame(inferred_dispersion = glanceRes$dispersion)
- inferred_dispersion$geneID <- rownames(glanceRes)
+ inferred_dispersion <- data.frame(estimate = glanceRes$dispersion)
+ inferred_dispersion$ID <- rownames(glanceRes)
rownames(inferred_dispersion) <- NULL
return(inferred_dispersion)
}
-
-#' Dispersion Evaluation Plot
-#'
-#' Creates a scatter plot to evaluate the dispersion values between actual and inferred dispersions.
-#'
-#' @param eval_dispersion A data frame containing actual and inferred dispersion values.
-#' @param ... Additional arguments to be passed to the ggplot2::aes function.
-#' @importFrom ggplot2 ggplot geom_point aes geom_abline theme_bw ggtitle scale_x_log10 scale_y_log10
-#' @importFrom rlang .data
-#' @return A ggplot2 scatter plot.
-#'
-#' @export
-#'
-#' @examples
-#' \dontrun{
-#' disp_plot <- dispersion_plot(disp_comparison_dtf, col = "from")
-#' print(disp_plot)
-#' }
-dispersion_plot <- function(eval_dispersion, ...) {
-
- args <- lapply(list(...), function(x) if (!is.null(x)) ggplot2::sym(x))
-
- p <- ggplot2::ggplot(eval_dispersion) +
- ggplot2::geom_point(ggplot2::aes(x = .data$actual_dispersion, y = .data$inferred_dispersion, !!!args), size = 3, alpha = 0.6) +
- ggplot2::geom_abline(intercept = 0, slope = 1, lty = 3, col = 'red', linewidth = 1) +
- ggplot2::theme_bw() +
- ggplot2::ggtitle("Dispersion evaluation") +
- ggplot2::scale_x_log10() +
- ggplot2::scale_y_log10()
-
- return(p)
-}
-
-
-
diff --git a/R/evaluation_identity.R b/R/evaluation_identity.R
new file mode 100644
index 0000000000000000000000000000000000000000..adf7e9b91574a7e95a967af69976bc6f4d87923a
--- /dev/null
+++ b/R/evaluation_identity.R
@@ -0,0 +1,101 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+
+
+
+#' Compute R-squared values for linear regression on grouped data
+#'
+#' This function takes a data frame, performs linear regression on specified grouping variables,
+#' and computes R-squared values for each group.
+#'
+#' @param data A data frame containing the variables 'actual' and 'estimate' for regression.
+#' @param grouping_by A character vector specifying the grouping variables for regression.
+#' @return A data frame with columns 'from', 'term', and 'R2' representing the grouping variables
+#' and the corresponding R-squared values.
+#' @export
+#' @examples
+#' data <- data.frame(from = c("A", "A", "A", "A"),
+#' term = c("X", "Y", "X", "Y"),
+#' actual = c(1, 2, 3, 4),
+#' estimate = c(1.5, 2.5, 3.5, 4.5))
+#' compute_rsquare(data, grouping_by = c("from", "term"))
+#'
+#' @importFrom data.table data.table
+compute_rsquare <- function(data, grouping_by = c("from", "description") ){
+ ## -- convert to data.table
+ dat <- data.table::data.table(data)
+ ## -- calculate the regression coefficient r^2
+ r_square_df <- as.data.frame(
+ dat[ , summary(lm(actual~estimate))$r.squared,
+ by = grouping_by ]
+ )
+ names(r_square_df)[names(r_square_df) == "V1"] <- "R2"
+ return(r_square_df)
+}
+
+
+#' Gets R-squared values for plotting.
+#'
+#' This function takes a data frame with R-squared values,
+#' computes position coordinates, and prepares data for plotting.
+#' @param data_rsquare Data frame with R-squared values.
+#' @return A data frame with additional columns for labeling in the plot.
+#' @export
+#' @examples
+#' data_rsquare <- data.frame(from = c("A", "B", "C"), description = c("Desc1", "Desc2", "Desc3"), R2 = c(0.9, 0.8, 0.7))
+#' result <- get_rsquare_2plot(data_rsquare)
+get_rsquare_2plot <- function(data_rsquare){
+ data_rsquare$pos_x <- -Inf
+ data_rsquare$pos_y <- Inf
+ data_rsquare$label_italic <- sprintf("italic(R^2) == %.2f", round(data_rsquare$R2, 3))
+ data_rsquare$label_vjust <- as.numeric(factor(data_rsquare$from))
+ return(data_rsquare)
+}
+
+
+
+#' Generate an identity term plot and get metrics associated
+#'
+#' This function generates an identity plot for comparing actual values with estimates
+#'
+#' @param data_identity A data frame containing comparison results with "actual" and "estimate" columns.
+#' @param palette_color dict-like palette default: palette_color = c(DESeq2 = "#500472", HTRfit ="#79cbb8")
+#' @param ... additional parameters to pass geom_point aes
+#' @return A ggplot2 identity plot and R2 metric associated
+#'
+#' @importFrom ggplot2 sym aes geom_point geom_abline facet_wrap theme_bw ggtitle scale_color_manual geom_text
+#' @importFrom rlang .data new_environment
+#' @export
+#' @examples
+#' comparison_data <- data.frame(
+#' actual = c(1, 2, 3, 4, 5),
+#' estimate = c(0.9, 2.2, 2.8, 4.1, 5.2),
+#' description = rep("Category A", 5),
+#' term = rep("Category A", 5),
+#' from = c("A", "B", "B", "A", "B"))
+#' eval_identityTerm(comparison_data)
+eval_identityTerm <- function(data_identity, palette_color = c(DESeq2 = "#500472", HTRfit ="#79cbb8"), ...){
+
+ data_rsquare <- compute_rsquare(data_identity)
+ data_rsquare2plot <- get_rsquare_2plot(data_rsquare)
+
+ p <- ggplot2::ggplot(data_identity, mapping = ggplot2::aes(x = .data$actual, y = .data$estimate, col = from, ...) )+
+ ggplot2::geom_point(alpha = 0.6, size = 2) +
+ ggplot2::geom_abline(intercept = 0, slope = 1, lty = 3, col = 'red', linewidth = 1) +
+ ggplot2::facet_wrap(~description, scales = "free") +
+ ggplot2::theme_bw() +
+ ggplot2::geom_text(data = data_rsquare2plot,
+ mapping = ggplot2::aes(x = pos_x, y = pos_y, label = label_italic, col = from, vjust = label_vjust),
+ parse = TRUE, hjust = -0.3 ) +
+ ggplot2::ggtitle("Identity plot") +
+ ggplot2::scale_color_manual(values = palette_color )
+
+ p$plot_env <- rlang::new_environment()
+
+ obj_idTerm <- list(R2 = data_rsquare, p = p )
+
+ return(obj_idTerm)
+}
+
+
diff --git a/R/fake-section-title.R b/R/fake-section-title.R
new file mode 100644
index 0000000000000000000000000000000000000000..3b93160efebdb8c53a336b4ff105f8aba4c1b075
--- /dev/null
+++ b/R/fake-section-title.R
@@ -0,0 +1,919 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+#' @name prediction-class
+#' @aliases prediction-class
+#'
+#' @title Class \code{prediction}
+#'
+#' @description
+#' Object to encapsulate numerical predictions together with the
+#' corresponding true class labels, optionally collecting predictions and
+#' labels for several cross-validation or bootstrapping runs.
+#'
+#' @section Objects from the Class:
+#' Objects can be created by using the \code{prediction} function.
+#'
+#' @note
+#' Every \code{prediction} object contains information about the 2x2
+#' contingency table consisting of tp,tn,fp, and fn, along with the
+#' marginal sums n.pos,n.neg,n.pos.pred,n.neg.pred, because these form
+#' the basis for many derived performance measures.
+#'
+#' @slot predictions A list, in which each element is a vector of predictions
+#' (the list has length > 1 for x-validation data.
+#' @slot labels Analogously, a list in which each element is a vector of true
+#' class labels.
+#' @slot cutoffs A list in which each element is a vector of all necessary
+#' cutoffs. Each cutoff vector consists of the predicted scores (duplicates
+#' removed), in descending order.
+#' @slot fp A list in which each element is a vector of the number (not the
+#' rate!) of false positives induced by the cutoffs given in the corresponding
+#' 'cutoffs' list entry.
+#' @slot tp As fp, but for true positives.
+#' @slot tn As fp, but for true negatives.
+#' @slot fn As fp, but for false negatives.
+#' @slot n.pos A list in which each element contains the number of positive
+#' samples in the given x-validation run.
+#' @slot n.neg As n.pos, but for negative samples.
+#' @slot n.pos.pred A list in which each element is a vector of the number of
+#' samples predicted as positive at the cutoffs given in the corresponding
+#' 'cutoffs' entry.
+#' @slot n.neg.pred As n.pos.pred, but for negatively predicted samples.
+#'
+#'
+#' @author
+#' Tobias Sing \email{tobias.sing@gmail.com}, Oliver Sander
+#' \email{osander@gmail.com}
+#'
+#' @seealso
+#' \code{\link{prediction}},
+#' \code{\link{performance}},
+#' \code{\link{performance-class}},
+#' \code{\link{plot.performance}}
+#'
+#' @export
+setClass("prediction",
+ representation(predictions = "list",
+ labels = "list",
+ cutoffs = "list",
+ fp = "list",
+ tp = "list",
+ tn = "list",
+ fn = "list",
+ n.pos = "list",
+ n.neg = "list",
+ n.pos.pred = "list",
+ n.neg.pred = "list"))
+
+setMethod("show","prediction",
+ function(object){
+ cat("A ", class(object), " instance\n", sep = "")
+ if(length(object@predictions) > 1L){
+ cat(" with ", length(object@predictions)," cross ",
+ "validation runs ", sep = "")
+ if(length(unique(vapply(object@predictions,length,integer(1))))){
+ cat("(equal lengths)", sep = "")
+ } else {
+ cat("(different lengths)", sep = "")
+ }
+ } else {
+ cat(" with ", length(object@predictions[[1L]]),
+ " data points", sep = "")
+ }
+ })
+
+#' @name performance-class
+#' @aliases performance-class
+#'
+#' @title Class \code{performance}
+#'
+#' @description
+#' Object to capture the result of a performance evaluation, optionally
+#' collecting evaluations from several cross-validation or bootstrapping runs.
+#'
+#' @section Objects from the Class:
+#' Objects can be created by using the \code{performance} function.
+#'
+#' @details
+#' A \code{performance} object can capture information from four
+#' different evaluation scenarios:
+#' \itemize{
+#' \item The behaviour of a cutoff-dependent performance measure across
+#' the range of all cutoffs (e.g. \code{performance( predObj, 'acc' )} ). Here,
+#' \code{x.values} contains the cutoffs, \code{y.values} the
+#' corresponding values of the performance measure, and
+#' \code{alpha.values} is empty.\cr
+#' \item The trade-off between two performance measures across the
+#' range of all cutoffs (e.g. \code{performance( predObj,
+#' 'tpr', 'fpr' )} ). In this case, the cutoffs are stored in
+#' \code{alpha.values}, while \code{x.values} and \code{y.values}
+#' contain the corresponding values of the two performance measures.\cr
+#' \item A performance measure that comes along with an obligatory
+#' second axis (e.g. \code{performance( predObj, 'ecost' )} ). Here, the measure values are
+#' stored in \code{y.values}, while the corresponding values of the
+#' obligatory axis are stored in \code{x.values}, and \code{alpha.values}
+#' is empty.\cr
+#' \item A performance measure whose value is just a scalar
+#' (e.g. \code{performance( predObj, 'auc' )} ). The value is then stored in
+#' \code{y.values}, while \code{x.values} and \code{alpha.values} are
+#' empty.
+#' }
+#'
+#' @slot x.name Performance measure used for the x axis.
+#' @slot y.name Performance measure used for the y axis.
+#' @slot alpha.name Name of the unit that is used to create the parametrized
+#' curve. Currently, curves can only be parametrized by cutoff, so
+#' \code{alpha.name} is either \code{none} or \code{cutoff}.
+#' @slot x.values A list in which each entry contains the x values of the curve
+#' of this particular cross-validation run. \code{x.values[[i]]},
+#' \code{y.values[[i]]}, and \code{alpha.values[[i]]} correspond to each
+#' other.
+#' @slot y.values A list in which each entry contains the y values of the curve
+#' of this particular cross-validation run.
+#' @slot alpha.values A list in which each entry contains the cutoff values of
+#' the curve of this particular cross-validation run.
+#'
+#' @references
+#' A detailed list of references can be found on the ROCR homepage at
+#' \url{http://rocr.bioinf.mpi-sb.mpg.de}.
+#'
+#' @author
+#' Tobias Sing \email{tobias.sing@gmail.com}, Oliver Sander
+#' \email{osander@gmail.com}
+#'
+#' @seealso
+#' \code{\link{prediction}}
+#' \code{\link{performance}},
+#' \code{\link{prediction-class}},
+#' \code{\link{plot.performance}}
+#'
+#' @export
+setClass("performance",
+ representation(x.name = "character",
+ y.name = "character",
+ alpha.name = "character",
+ x.values = "list",
+ y.values = "list",
+ alpha.values = "list" ))
+
+setMethod("show","performance",
+ function(object){
+ cat("A ", class(object), " instance\n", sep = "")
+ if(length(object@y.values[[1L]]) > 1L){
+ cat(" '", object@x.name, "' vs. '", object@y.name,
+ "' (alpha: '",object@alpha.name,"')\n", sep = "")
+ } else {
+ cat(" '", object@y.name, "'\n", sep = "")
+ }
+ if(length(object@y.values) > 1L){
+ cat(" for ", length(object@y.values)," cross ",
+ "validation runs ", sep = "")
+ } else {
+ if(length(object@y.values[[1L]]) > 1L){
+ cat(" with ", length(object@y.values[[1L]])," data points",
+ sep = "")
+ }
+ }
+ })
+
+
+
+#' @name prediction
+#'
+#' @title Function to create prediction objects
+#'
+#' @description
+#' Every classifier evaluation using ROCR starts with creating a
+#' \code{prediction} object. This function is used to transform the input data
+#' (which can be in vector, matrix, data frame, or list form) into a
+#' standardized format.
+#'
+#' @details
+#' \code{predictions} and \code{labels} can simply be vectors of the same
+#' length. However, in the case of cross-validation data, different
+#' cross-validation runs can be provided as the *columns* of a matrix or
+#' data frame, or as the entries of a list. In the case of a matrix or
+#' data frame, all cross-validation runs must have the same length, whereas
+#' in the case of a list, the lengths can vary across the cross-validation
+#' runs. Internally, as described in section 'Value', all of these input
+#' formats are converted to list representation.
+#'
+#' Since scoring classifiers give relative tendencies towards a negative
+#' (low scores) or positive (high scores) class, it has to be declared
+#' which class label denotes the negative, and which the positive class.
+#' Ideally, labels should be supplied as ordered factor(s), the lower
+#' level corresponding to the negative class, the upper level to the
+#' positive class. If the labels are factors (unordered), numeric,
+#' logical or characters, ordering of the labels is inferred from
+#' R's built-in \code{<} relation (e.g. 0 < 1, -1 < 1, 'a' < 'b',
+#' FALSE < TRUE). Use \code{label.ordering} to override this default
+#' ordering. Please note that the ordering can be locale-dependent
+#' e.g. for character labels '-1' and '1'.
+#'
+#' Currently, ROCR supports only binary classification (extensions toward
+#' multiclass classification are scheduled for the next release,
+#' however). If there are more than two distinct label symbols, execution
+#' stops with an error message. If all predictions use the same two
+#' symbols that are used for the labels, categorical predictions are
+#' assumed. If there are more than two predicted values, but all numeric,
+#' continuous predictions are assumed (i.e. a scoring
+#' classifier). Otherwise, if more than two symbols occur in the
+#' predictions, and not all of them are numeric, execution stops with an
+#' error message.
+#'
+#' @param predictions A vector, matrix, list, or data frame containing the
+#' predictions.
+#' @param labels A vector, matrix, list, or data frame containing the true class
+#' labels. Must have the same dimensions as \code{predictions}.
+#' @param label.ordering The default ordering (cf.details) of the classes can
+#' be changed by supplying a vector containing the negative and the positive
+#' class label.
+#'
+#' @return An S4 object of class \code{prediction}.
+#'
+#' @author
+#' Tobias Sing \email{tobias.sing@gmail.com}, Oliver Sander
+#' \email{osander@gmail.com}
+#' @export
+prediction <- function(predictions, labels, label.ordering=NULL) {
+
+ ## bring 'predictions' and 'labels' into list format,
+ ## each list entry representing one x-validation run
+
+ ## convert predictions into canonical list format
+ if (is.data.frame(predictions)) {
+ names(predictions) <- c()
+ predictions <- as.list(predictions)
+ } else if (is.matrix(predictions)) {
+ predictions <- as.list(data.frame(predictions))
+ names(predictions) <- c()
+ } else if (is.vector(predictions) && !is.list(predictions)) {
+ predictions <- list(predictions)
+ } else if (!is.list(predictions)) {
+ stop("Format of predictions is invalid. It couldn't be coerced to a list.",
+ call. = FALSE)
+ }
+
+ ## convert labels into canonical list format
+ if (is.data.frame(labels)) {
+ names(labels) <- c()
+ labels <- as.list( labels)
+ } else if (is.matrix(labels)) {
+ labels <- as.list( data.frame( labels))
+ names(labels) <- c()
+ } else if ((is.vector(labels) ||
+ is.ordered(labels) ||
+ is.factor(labels)) &&
+ !is.list(labels)) {
+ labels <- list( labels)
+ } else if (!is.list(labels)) {
+ stop("Format of labels is invalid. It couldn't be coerced to a list.",
+ call. = FALSE)
+ }
+
+
+ if(any(vapply(predictions,anyNA, logical(1)))){
+ warnings("'predictions' contains NA. These missing predictions will be removed from evaluation")
+ nonNA_pred <- !is.na(predictions)
+ predictions <- predictions[nonNA_pred]
+ labels <- labels[nonNA_pred]
+ }
+
+
+ ## Length consistency checks
+ if (length(predictions) != length(labels))
+ stop(paste("Number of cross-validation runs must be equal",
+ "for predictions and labels."))
+ if (! all(sapply(predictions, length) == sapply(labels, length)))
+ stop(paste("Number of predictions in each run must be equal",
+ "to the number of labels for each run."))
+
+ ## only keep prediction/label pairs that are finite numbers
+ for (i in 1:length(predictions)) {
+ finite.bool <- is.finite( predictions[[i]] )
+ predictions[[i]] <- predictions[[i]][ finite.bool ]
+ labels[[i]] <- labels[[i]][ finite.bool ]
+ }
+
+ ## abort if 'labels' format is inconsistent across
+ ## different cross-validation runs
+ label.format="" ## one of 'normal','factor','ordered'
+ if (all(sapply( labels, is.factor)) &&
+ !any(sapply(labels, is.ordered))) {
+ label.format <- "factor"
+ } else if (all(sapply( labels, is.ordered))) {
+ label.format <- "ordered"
+ } else if (all(sapply( labels, is.character)) ||
+ all(sapply( labels, is.numeric)) ||
+ all(sapply( labels, is.logical))) {
+ label.format <- "normal"
+ } else {
+ stop(paste("Inconsistent label data type across different",
+ "cross-validation runs."))
+ }
+
+ ## abort if levels are not consistent across different
+ ## cross-validation runs
+ if (! all(sapply(labels, levels)==levels(labels[[1]])) ) {
+ stop(paste("Inconsistent factor levels across different",
+ "cross-validation runs."))
+ }
+
+ ## convert 'labels' into ordered factors, aborting if the number
+ ## of classes is not equal to 2.
+ levels <- c()
+ if ( label.format == "ordered" ) {
+ if (!is.null(label.ordering)) {
+ stop(paste("'labels' is already ordered. No additional",
+ "'label.ordering' must be supplied."))
+ } else {
+ levels <- levels(labels[[1]])
+ }
+ } else {
+ if ( is.null( label.ordering )) {
+ if ( label.format == "factor" ) levels <- sort(levels(labels[[1]]))
+ else levels <- sort( unique( unlist( labels)))
+ } else {
+ ## if (!setequal( levels, label.ordering)) {
+ if (!setequal( unique(unlist(labels)), label.ordering )) {
+ stop("Label ordering does not match class labels.")
+ }
+ levels <- label.ordering
+ }
+ for (i in 1:length(labels)) {
+ if (is.factor(labels))
+ labels[[i]] <- ordered(as.character(labels[[i]]),
+ levels=levels)
+ else labels[[i]] <- ordered( labels[[i]], levels=levels)
+ }
+
+ }
+
+ if (length(levels) != 2) {
+ message <- paste("Number of classes is not equal to 2.\n",
+ "HTRfit currently supports only evaluation of ",
+ "binary classification tasks.",sep="")
+ stop(message)
+ }
+
+ ## determine whether predictions are continuous or categorical
+ ## (in the latter case stop
+ if (!is.numeric( unlist( predictions ))) {
+ stop("Currently, only continuous predictions are supported by HTRfit")
+ }
+
+ ## compute cutoff/fp/tp data
+
+ cutoffs <- list()
+ fp <- list()
+ tp <- list()
+ fn <- list()
+ tn <- list()
+ n.pos <- list()
+ n.neg <- list()
+ n.pos.pred <- list()
+ n.neg.pred <- list()
+ for (i in 1:length(predictions)) {
+ n.pos <- c( n.pos, sum( labels[[i]] == levels[2] ))
+ n.neg <- c( n.neg, sum( labels[[i]] == levels[1] ))
+ ans <- .compute.unnormalized.roc.curve( predictions[[i]], labels[[i]] )
+ cutoffs <- c( cutoffs, list( ans$cutoffs ))
+ fp <- c( fp, list( ans$fp ))
+ tp <- c( tp, list( ans$tp ))
+ fn <- c( fn, list( n.pos[[i]] - tp[[i]] ))
+ tn <- c( tn, list( n.neg[[i]] - fp[[i]] ))
+ n.pos.pred <- c(n.pos.pred, list(tp[[i]] + fp[[i]]) )
+ n.neg.pred <- c(n.neg.pred, list(tn[[i]] + fn[[i]]) )
+ }
+
+
+ return( new("prediction", predictions=predictions,
+ labels=labels,
+ cutoffs=cutoffs,
+ fp=fp,
+ tp=tp,
+ fn=fn,
+ tn=tn,
+ n.pos=n.pos,
+ n.neg=n.neg,
+ n.pos.pred=n.pos.pred,
+ n.neg.pred=n.neg.pred))
+}
+
+## fast fp/tp computation based on cumulative summing
+.compute.unnormalized.roc.curve <- function( predictions, labels ) {
+ ## determine the labels that are used for the pos. resp. neg. class :
+ pos.label <- levels(labels)[2]
+ neg.label <- levels(labels)[1]
+
+ pred.order <- order(predictions, decreasing=TRUE)
+ predictions.sorted <- predictions[pred.order]
+ tp <- cumsum(labels[pred.order]==pos.label)
+ fp <- cumsum(labels[pred.order]==neg.label)
+
+ ## remove fp & tp for duplicated predictions
+ ## as duplicated keeps the first occurrence, but we want the last, two
+ ## rev are used.
+ ## Highest cutoff (Infinity) corresponds to tp=0, fp=0
+ dups <- rev(duplicated(rev(predictions.sorted)))
+ tp <- c(0, tp[!dups])
+ fp <- c(0, fp[!dups])
+ cutoffs <- c(Inf, predictions.sorted[!dups])
+
+ return(list( cutoffs=cutoffs, fp=fp, tp=tp ))
+}
+
+#' @name performance
+#'
+#' @title Function to create performance objects
+#'
+#' @description
+#' All kinds of predictor evaluations are performed using this function.
+#'
+#' @details
+#' Here is the list of available performance measures. Let Y and
+#' \eqn{\hat{Y}}{Yhat} be random variables representing the class and the prediction for
+#' a randomly drawn sample, respectively. We denote by
+#' \eqn{\oplus}{+} and \eqn{\ominus}{-} the positive and
+#' negative class, respectively. Further, we use the following
+#' abbreviations for empirical quantities: P (\# positive
+#' samples), N (\# negative samples), TP (\# true positives), TN (\# true
+#' negatives), FP (\# false positives), FN (\# false negatives).
+#' \describe{
+#' \item{\code{acc}:}{accuracy. \eqn{P(\hat{Y}=Y)}{P(Yhat = Y)}. Estimated
+#' as: \eqn{\frac{TP+TN}{P+N}}{(TP+TN)/(P+N)}.}
+#' \item{\code{err}:}{Error rate. \eqn{P(\hat{Y}\ne Y)}{P(Yhat !=
+#' Y)}. Estimated as: \eqn{\frac{FP+FN}{P+N}}{(FP+FN)/(P+N)}.}
+#' \item{\code{fpr}:}{False positive rate. \eqn{P(\hat{Y}=\oplus | Y =
+#' \ominus)}{P(Yhat = + | Y = -)}. Estimated as:
+#' \eqn{\frac{FP}{N}}{FP/N}.}
+#' \item{\code{fall}:}{Fallout. Same as \code{fpr}.}
+#' \item{\code{tpr}:}{True positive
+#' rate. \eqn{P(\hat{Y}=\oplus|Y=\oplus)}{P(Yhat = + | Y = +)}. Estimated
+#' as: \eqn{\frac{TP}{P}}{TP/P}.}
+#' \item{\code{rec}:}{recall. Same as \code{tpr}.}
+#' \item{\code{sens}:}{sensitivity. Same as \code{tpr}.}
+#' \item{\code{fnr}:}{False negative
+#' rate. \eqn{P(\hat{Y}=\ominus|Y=\oplus)}{P(Yhat = - | Y =
+#' +)}. Estimated as: \eqn{\frac{FN}{P}}{FN/P}.}
+#' \item{\code{miss}:}{Miss. Same as \code{fnr}.}
+#' \item{\code{tnr}:}{True negative rate. \eqn{P(\hat{Y} =
+#' \ominus|Y=\ominus)}{P(Yhat = - | Y = -)}.}
+#' \item{\code{spec}:}{specificity. Same as \code{tnr}.}
+#' \item{\code{ppv}:}{Positive predictive
+#' value. \eqn{P(Y=\oplus|\hat{Y}=\oplus)}{P(Y = + | Yhat =
+#' +)}. Estimated as: \eqn{\frac{TP}{TP+FP}}{TP/(TP+FP)}.}
+#' \item{\code{prec}:}{precision. Same as \code{ppv}.}
+#' \item{\code{npv}:}{Negative predictive
+#' value. \eqn{P(Y=\ominus|\hat{Y}=\ominus)}{P(Y = - | Yhat =
+#' -)}. Estimated as: \eqn{\frac{TN}{TN+FN}}{TN/(TN+FN)}.}
+#' \item{\code{pcfall}:}{Prediction-conditioned
+#' fallout. \eqn{P(Y=\ominus|\hat{Y}=\oplus)}{P(Y = - | Yhat =
+#' +)}. Estimated as: \eqn{\frac{FP}{TP+FP}}{FP/(TP+FP)}.}
+#' \item{\code{pcmiss}:}{Prediction-conditioned
+#' miss. \eqn{P(Y=\oplus|\hat{Y}=\ominus)}{P(Y = + | Yhat =
+#' -)}. Estimated as: \eqn{\frac{FN}{TN+FN}}{FN/(TN+FN)}.}
+#' \item{\code{rpp}:}{Rate of positive predictions. \eqn{P( \hat{Y} =
+#' \oplus)}{P(Yhat = +)}. Estimated as: (TP+FP)/(TP+FP+TN+FN).}
+#' \item{\code{rnp}:}{Rate of negative predictions. \eqn{P( \hat{Y} =
+#' \ominus)}{P(Yhat = -)}. Estimated as: (TN+FN)/(TP+FP+TN+FN).}
+#' \item{\code{phi}:}{Phi correlation coefficient. \eqn{\frac{TP \cdot
+#' TN - FP \cdot FN}{\sqrt{ (TP+FN) \cdot (TN+FP) \cdot (TP+FP)
+#' \cdot (TN+FN)}}}{(TP*TN -
+#' FP*FN)/(sqrt((TP+FN)*(TN+FP)*(TP+FP)*(TN+FN)))}. Yields a
+#' number between -1 and 1, with 1 indicating a perfect
+#' prediction, 0 indicating a random prediction. Values below 0
+#' indicate a worse than random prediction.}
+#' \item{\code{mat}:}{Matthews correlation coefficient. Same as \code{phi}.}
+#' \item{\code{mi}:}{Mutual information. \eqn{I(\hat{Y},Y) := H(Y) -
+#' H(Y|\hat{Y})}{I(Yhat, Y) := H(Y) - H(Y | Yhat)}, where H is the
+#' (conditional) entropy. Entropies are estimated naively (no bias
+#' correction).}
+#' \item{\code{chisq}:}{Chi square test statistic. \code{?chisq.test}
+#' for details. Note that R might raise a warning if the sample size
+#' is too small.}
+#' \item{\code{odds}:}{Odds ratio. \eqn{\frac{TP \cdot TN}{FN \cdot
+#' FP}}{(TP*TN)/(FN*FP)}. Note that odds ratio produces
+#' Inf or NA values for all cutoffs corresponding to FN=0 or
+#' FP=0. This can substantially decrease the plotted cutoff region.}
+#' \item{\code{lift}:}{Lift
+#' value. \eqn{\frac{P(\hat{Y}=\oplus|Y=\oplus)}{P(\hat{Y}=\oplus)}}{P(Yhat = + |
+#' Y = +)/P(Yhat = +)}.}
+#' \item{\code{f}:}{precision-recall F measure (van Rijsbergen, 1979). Weighted
+#' harmonic mean of precision (P) and recall (R). \eqn{F =
+#' \frac{1}{\alpha \frac{1}{P} + (1-\alpha)\frac{1}{R}}}{F = 1/
+#' (alpha*1/P + (1-alpha)*1/R)}. If
+#' \eqn{\alpha=\frac{1}{2}}{alpha=1/2}, the mean is balanced. A
+#' frequent equivalent formulation is
+#' \eqn{F = \frac{(\beta^2+1) \cdot P \cdot R}{R + \beta^2 \cdot
+#' P}}{F = (beta^2+1) * P * R / (R + beta^2 * P)}. In this formulation, the
+#' mean is balanced if \eqn{\beta=1}{beta=1}. Currently, ROCR only accepts
+#' the alpha version as input (e.g. \eqn{\alpha=0.5}{alpha=0.5}). If no
+#' value for alpha is given, the mean will be balanced by default.}
+#' \item{\code{rch}:}{ROC convex hull. A ROC (=\code{tpr} vs \code{fpr}) curve
+#' with concavities (which represent suboptimal choices of cutoff) removed
+#' (Fawcett 2001). Since the result is already a parametric performance
+#' curve, it cannot be used in combination with other measures.}
+#' \item{\code{auc}:}{Area under the ROC curve. This is equal to the value of the
+#' Wilcoxon-Mann-Whitney test statistic and also the probability that the
+#' classifier will score are randomly drawn positive sample higher than a
+#' randomly drawn negative sample. Since the output of
+#' \code{auc} is cutoff-independent, this
+#' measure cannot be combined with other measures into a parametric
+#' curve. The partial area under the ROC curve up to a given false
+#' positive rate can be calculated by passing the optional parameter
+#' \code{fpr.stop=0.5} (or any other value between 0 and 1) to
+#' \code{performance}.}
+#' \item{\code{aucpr}:}{Area under the precision/recall curve. Since the output
+#' of \code{aucpr} is cutoff-independent, this measure cannot be combined
+#' with other measures into a parametric curve.}
+#' \item{\code{prbe}:}{precision-recall break-even point. The cutoff(s) where
+#' precision and recall are equal. At this point, positive and negative
+#' predictions are made at the same rate as their prevalence in the
+#' data. Since the output of
+#' \code{prbe} is just a cutoff-independent scalar, this
+#' measure cannot be combined with other measures into a parametric curve.}
+#' \item{\code{cal}:}{Calibration error. The calibration error is the
+#' absolute difference between predicted confidence and actual reliability. This
+#' error is estimated at all cutoffs by sliding a window across the
+#' range of possible cutoffs. The default window size of 100 can be
+#' adjusted by passing the optional parameter \code{window.size=200}
+#' to \code{performance}. E.g., if for several
+#' positive samples the output of the classifier is around 0.75, you might
+#' expect from a well-calibrated classifier that the fraction of them
+#' which is correctly predicted as positive is also around 0.75. In a
+#' well-calibrated classifier, the probabilistic confidence estimates
+#' are realistic. Only for use with
+#' probabilistic output (i.e. scores between 0 and 1).}
+#' \item{\code{mxe}:}{Mean cross-entropy. Only for use with
+#' probabilistic output. \eqn{MXE :=-\frac{1}{P+N}( \sum_{y_i=\oplus}
+#' ln(\hat{y}_i) + \sum_{y_i=\ominus} ln(1-\hat{y}_i))}{MXE := - 1/(P+N) \sum_{y_i=+}
+#' ln(yhat_i) + \sum_{y_i=-} ln(1-yhat_i)}. Since the output of
+#' \code{mxe} is just a cutoff-independent scalar, this
+#' measure cannot be combined with other measures into a parametric curve.}
+#' \item{\code{rmse}:}{Root-mean-squared error. Only for use with
+#' numerical class labels. \eqn{RMSE:=\sqrt{\frac{1}{P+N}\sum_i (y_i
+#' - \hat{y}_i)^2}}{RMSE := sqrt(1/(P+N) \sum_i (y_i -
+#' yhat_i)^2)}. Since the output of
+#' \code{rmse} is just a cutoff-independent scalar, this
+#' measure cannot be combined with other measures into a parametric curve.}
+#' \item{\code{sar}:}{Score combinining performance measures of different
+#' characteristics, in the attempt of creating a more "robust"
+#' measure (cf. Caruana R., ROCAI2004):
+#' SAR = 1/3 * ( accuracy + Area under the ROC curve + Root
+#' mean-squared error ).}
+#' \item{\code{ecost}:}{Expected cost. For details on cost curves,
+#' cf. Drummond&Holte 2000,2004. \code{ecost} has an obligatory x
+#' axis, the so-called 'probability-cost function'; thus it cannot be
+#' combined with other measures. While using \code{ecost} one is
+#' interested in the lower envelope of a set of lines, it might be
+#' instructive to plot the whole set of lines in addition to the lower
+#' envelope. An example is given in \code{demo(ROCR)}.}
+#' \item{\code{cost}:}{Cost of a classifier when
+#' class-conditional misclassification costs are explicitly given.
+#' Accepts the optional parameters \code{cost.fp} and
+#' \code{cost.fn}, by which the costs for false positives and
+#' negatives can be adjusted, respectively. By default, both are set
+#' to 1.}
+#' }
+#'
+#' @note
+#' Here is how to call \code{performance()} to create some standard
+#' evaluation plots:
+#' \describe{
+#' \item{ROC curves:}{measure="tpr", x.measure="fpr".}
+#' \item{precision/recall graphs:}{measure="prec", x.measure="rec".}
+#' \item{sensitivity/specificity plots:}{measure="sens", x.measure="spec".}
+#' \item{Lift charts:}{measure="lift", x.measure="rpp".}
+#' }
+#'
+#' @param prediction.obj An object of class \code{prediction}.
+#' @param measure Performance measure to use for the evaluation. A complete list
+#' of the performance measures that are available for \code{measure} and
+#' \code{x.measure} is given in the 'Details' section.
+#' @param x.measure A second performance measure. If different from the default,
+#' a two-dimensional curve, with \code{x.measure} taken to be the unit in
+#' direction of the x axis, and \code{measure} to be the unit in direction of
+#' the y axis, is created. This curve is parametrized with the cutoff.
+#' @param ... Optional arguments (specific to individual performance measures).
+#'
+#' @return An S4 object of class \code{performance}.
+#'
+#' @author
+#' Tobias Sing \email{tobias.sing@gmail.com}, Oliver Sander
+#' \email{osander@gmail.com}
+#'
+#' @export
+performance <- function(prediction.obj,
+ measure,
+ x.measure="cutoff",
+ ...) {
+
+ ## define the needed environments
+ envir.list <- .define.environments()
+ long.unit.names <- envir.list$long.unit.names
+ function.names <- envir.list$function.names
+ obligatory.x.axis <- envir.list$obligatory.x.axis
+ optional.arguments <- envir.list$optional.arguments
+ default.values <- envir.list$default.values
+
+ ## abort in case of misuse
+ if (class(prediction.obj) != 'prediction' ||
+ !exists(measure, where=long.unit.names, inherits=FALSE) ||
+ !exists(x.measure, where=long.unit.names, inherits=FALSE)) {
+ stop(paste("Wrong argument types: First argument must be of type",
+ "'prediction'; second and optional third argument must",
+ "be available performance measures!"))
+ }
+
+ ## abort, if attempt is made to use a measure that has an obligatory
+ ## x.axis as the x.measure (cannot be combined)
+ if (exists( x.measure, where=obligatory.x.axis, inherits=FALSE )) {
+ message <- paste("The performance measure",
+ x.measure,
+ "can only be used as 'measure', because it has",
+ "the following obligatory 'x.measure':\n",
+ get( x.measure, envir=obligatory.x.axis))
+ stop(message)
+ }
+
+ ## if measure is a performance measure with obligatory x.axis, then
+ ## enforce this axis:
+ if (exists( measure, where=obligatory.x.axis, inherits=FALSE )) {
+ x.measure <- get( measure, envir=obligatory.x.axis )
+ }
+
+ if (x.measure == "cutoff" ||
+ exists( measure, where=obligatory.x.axis, inherits=FALSE )) {
+
+ ## fetch from '...' any optional arguments for the performance
+ ## measure at hand that are given, otherwise fill up the default values
+ optional.args <- list(...)
+ argnames <- c()
+ if ( exists( measure, where=optional.arguments, inherits=FALSE )) {
+ argnames <- get( measure, envir=optional.arguments )
+ default.arglist <- list()
+ for (i in 1:length(argnames)) {
+ default.arglist <- c(default.arglist,
+ get(paste(measure,":",argnames[i],sep=""),
+ envir=default.values, inherits=FALSE))
+ }
+ names(default.arglist) <- argnames
+
+ for (i in 1:length(argnames)) {
+ templist <- list(optional.args,
+ default.arglist[[i]])
+ names(templist) <- c('arglist', argnames[i])
+
+ optional.args <- do.call('.farg', templist)
+ }
+ }
+ optional.args <- .select.args( optional.args, argnames )
+
+ ## determine function name
+ function.name <- get( measure, envir=function.names )
+
+ ## for each x-validation run, compute the requested performance measure
+ x.values <- list()
+ y.values <- list()
+ for (i in 1:length( prediction.obj@predictions )) {
+ argumentlist <- .sarg(optional.args,
+ predictions= prediction.obj@predictions[[i]],
+ labels= prediction.obj@labels[[i]],
+ cutoffs= prediction.obj@cutoffs[[i]],
+ fp= prediction.obj@fp[[i]],
+ tp= prediction.obj@tp[[i]],
+ fn= prediction.obj@fn[[i]],
+ tn= prediction.obj@tn[[i]],
+ n.pos= prediction.obj@n.pos[[i]],
+ n.neg= prediction.obj@n.neg[[i]],
+ n.pos.pred= prediction.obj@n.pos.pred[[i]],
+ n.neg.pred= prediction.obj@n.neg.pred[[i]])
+
+ ans <- do.call( function.name, argumentlist )
+
+ if (!is.null(ans[[1]])) x.values <- c( x.values, list( ans[[1]] ))
+ y.values <- c( y.values, list( ans[[2]] ))
+ }
+
+ if (! (length(x.values)==0 || length(x.values)==length(y.values)) ) {
+ stop("Consistency error.")
+ }
+
+ ## create a new performance object
+ return( new("performance",
+ x.name = get( x.measure, envir=long.unit.names ),
+ y.name = get( measure, envir=long.unit.names ),
+ alpha.name = "none",
+ x.values = x.values,
+ y.values = y.values,
+ alpha.values = list() ))
+ } else {
+ perf.obj.1 <- performance( prediction.obj, measure=x.measure, ... )
+ perf.obj.2 <- performance( prediction.obj, measure=measure, ... )
+ return( .combine.performance.objects( perf.obj.1, perf.obj.2 ) )
+ }
+}
+
+#' @importFrom stats approxfun
+.combine.performance.objects <- function( p.obj.1, p.obj.2 ) {
+ ## some checks for misusage (in any way, this function is
+ ## only for internal use)
+ if ( p.obj.1@x.name != p.obj.2@x.name ) {
+ stop("Error: Objects need to have identical x axis.")
+ }
+ if ( p.obj.1@alpha.name != "none" || p.obj.2@alpha.name != "none") {
+ stop("Error: At least one of the two objects has already been merged.")
+ }
+ if (length(p.obj.1@x.values) != length(p.obj.2@x.values)) {
+ stop(paste("Only performance objects with identical number of",
+ "cross-validation runs can be combined."))
+ }
+
+ x.values <- list()
+ x.name <- p.obj.1@y.name
+ y.values <- list()
+ y.name <- p.obj.2@y.name
+ alpha.values <- list()
+ alpha.name <- p.obj.1@x.name
+
+ for (i in 1:length( p.obj.1@x.values )) {
+ x.values.1 <- p.obj.1@x.values[[i]]
+ y.values.1 <- p.obj.1@y.values[[i]]
+ x.values.2 <- p.obj.2@x.values[[i]]
+ y.values.2 <- p.obj.2@y.values[[i]]
+
+ ## cutoffs of combined object = merged cutoffs of simple objects
+ cutoffs <- sort( unique( c(x.values.1, x.values.2)), decreasing=TRUE )
+
+ ## calculate y.values at cutoffs using step function
+ y.values.int.1 <- stats::approxfun(x.values.1, y.values.1,
+ method="constant",f=1,rule=2)(cutoffs)
+ y.values.int.2 <- stats::approxfun(x.values.2, y.values.2,
+ method="constant",f=1,rule=2)(cutoffs)
+
+ ## 'approxfun' ignores NA and NaN
+ objs <- list( y.values.int.1, y.values.int.2)
+ objs.x <- list( x.values.1, x.values.2 )
+ na.cutoffs.1.bool <- is.na( y.values.1) & !is.nan( y.values.1 )
+ nan.cutoffs.1.bool <- is.nan( y.values.1)
+ na.cutoffs.2.bool <- is.na( y.values.2) & !is.nan( y.values.2 )
+ nan.cutoffs.2.bool <- is.nan( y.values.2)
+ bools <- list(na.cutoffs.1.bool, nan.cutoffs.1.bool,
+ na.cutoffs.2.bool, nan.cutoffs.2.bool)
+ values <- c(NA,NaN,NA,NaN)
+
+ for (j in 1:4) {
+ for (k in which(bools[[j]])) {
+ interval.max <- objs.x[[ ceiling(j/2) ]][k]
+ interval.min <- -Inf
+ if (k < length(objs.x[[ ceiling(j/2) ]])) {
+ interval.min <- objs.x[[ ceiling(j/2) ]][k+1]
+ }
+ objs[[ ceiling(j/2) ]][cutoffs <= interval.max &
+ cutoffs > interval.min ] <- values[j]
+ }
+ }
+
+ alpha.values <- c(alpha.values, list(cutoffs))
+ x.values <- c(x.values, list(objs[[1]]))
+ y.values <- c(y.values, list(objs[[2]]))
+ }
+
+ return( new("performance",
+ x.name=x.name, y.name=y.name,
+ alpha.name=alpha.name, x.values=x.values,
+ y.values=y.values, alpha.values=alpha.values))
+}
+
+.define.environments <- function() {
+ ## There are five environments: long.unit.names, function.names,
+ ## obligatory.x.axis, optional.arguments, default.values
+
+ ## Define long names corresponding to the measure abbreviations.
+ long.unit.names <- new.env()
+ assign("none","None", envir=long.unit.names)
+ assign("cutoff", "Cutoff", envir=long.unit.names)
+ assign("acc", "accuracy", envir=long.unit.names)
+ assign("err", "Error Rate", envir=long.unit.names)
+ assign("fpr", "False positive rate", envir=long.unit.names)
+ assign("tpr", "True positive rate", envir=long.unit.names)
+ assign("rec", "recall", envir=long.unit.names)
+ assign("sens", "sensitivity", envir=long.unit.names)
+ assign("fnr", "False negative rate", envir=long.unit.names)
+ assign("tnr", "True negative rate", envir=long.unit.names)
+ assign("spec", "specificity", envir=long.unit.names)
+ assign("ppv", "Positive predictive value", envir=long.unit.names)
+ assign("prec", "precision", envir=long.unit.names)
+ assign("npv", "Negative predictive value", envir=long.unit.names)
+ assign("fall", "Fallout", envir=long.unit.names)
+ assign("miss", "Miss", envir=long.unit.names)
+ assign("pcfall", "Prediction-conditioned fallout", envir=long.unit.names)
+ assign("pcmiss", "Prediction-conditioned miss", envir=long.unit.names)
+ assign("rpp", "Rate of positive predictions", envir=long.unit.names)
+ assign("rnp", "Rate of negative predictions", envir=long.unit.names)
+ assign("auc","Area under the ROC curve", envir=long.unit.names)
+ assign("aucpr","Area under the precision/recall curve", envir=long.unit.names)
+ assign("cal", "Calibration error", envir=long.unit.names)
+ assign("mwp", "Median window position", envir=long.unit.names)
+ assign("prbe","precision/recall break-even point", envir=long.unit.names)
+ assign("rch", "ROC convex hull", envir=long.unit.names)
+ assign("mxe", "Mean cross-entropy", envir=long.unit.names)
+ assign("rmse","Root-mean-square error", envir=long.unit.names)
+ assign("phi", "Phi correlation coefficient", envir=long.unit.names)
+ assign("mat","Matthews correlation coefficient", envir=long.unit.names)
+ assign("mi", "Mutual information", envir=long.unit.names)
+ assign("chisq", "Chi-square test statistic", envir=long.unit.names)
+ assign("odds","Odds ratio", envir=long.unit.names)
+ assign("lift", "Lift value", envir=long.unit.names)
+ assign("f","precision-recall F measure", envir=long.unit.names)
+ assign("sar", "SAR", envir=long.unit.names)
+ assign("ecost", "Expected cost", envir=long.unit.names)
+ assign("cost", "Explicit cost", envir=long.unit.names)
+
+ ## Define function names corresponding to the measure abbreviations.
+ function.names <- new.env()
+ assign("acc", ".performance.accuracy", envir=function.names)
+ assign("err", ".performance.error.rate", envir=function.names)
+ assign("fpr", ".performance.false.positive.rate", envir=function.names)
+ assign("tpr", ".performance.true.positive.rate", envir=function.names)
+ assign("rec", ".performance.true.positive.rate", envir=function.names)
+ assign("sens", ".performance.true.positive.rate", envir=function.names)
+ assign("fnr", ".performance.false.negative.rate", envir=function.names)
+ assign("tnr", ".performance.true.negative.rate", envir=function.names)
+ assign("spec", ".performance.true.negative.rate", envir=function.names)
+ assign("ppv", ".performance.positive.predictive.value",
+ envir=function.names)
+ assign("prec", ".performance.positive.predictive.value",
+ envir=function.names)
+ assign("npv", ".performance.negative.predictive.value",
+ envir=function.names)
+ assign("fall", ".performance.false.positive.rate", envir=function.names)
+ assign("miss", ".performance.false.negative.rate", envir=function.names)
+ assign("pcfall", ".performance.prediction.conditioned.fallout",
+ envir=function.names)
+ assign("pcmiss", ".performance.prediction.conditioned.miss",
+ envir=function.names)
+ assign("rpp", ".performance.rate.of.positive.predictions",
+ envir=function.names)
+ assign("rnp", ".performance.rate.of.negative.predictions",
+ envir=function.names)
+ assign("auc", ".performance.auc", envir=function.names)
+ assign("aucpr", ".performance.aucpr", envir=function.names)
+ assign("cal", ".performance.calibration.error", envir=function.names)
+ assign("prbe", ".performance.precision.recall.break.even.point",
+ envir=function.names)
+ assign("rch", ".performance.rocconvexhull", envir=function.names)
+ assign("mxe", ".performance.mean.cross.entropy", envir=function.names)
+ assign("rmse", ".performance.root.mean.squared.error",
+ envir=function.names)
+ assign("phi", ".performance.phi", envir=function.names)
+ assign("mat", ".performance.phi", envir=function.names)
+ assign("mi", ".performance.mutual.information", envir=function.names)
+ assign("chisq", ".performance.chisq", envir=function.names)
+ assign("odds", ".performance.odds.ratio", envir=function.names)
+ assign("lift", ".performance.lift", envir=function.names)
+ assign("f", ".performance.f", envir=function.names)
+ assign("sar", ".performance.sar", envir=function.names)
+ assign("ecost", ".performance.expected.cost", envir=function.names)
+ assign("cost", ".performance.cost", envir=function.names)
+
+ ## If a measure comes along with an obligatory x axis (including "none"),
+ ## list it here.
+ obligatory.x.axis <- new.env()
+ assign("mxe", "none", envir=obligatory.x.axis)
+ assign("rmse", "none", envir=obligatory.x.axis)
+ assign("prbe", "none", envir=obligatory.x.axis)
+ assign("auc", "none", envir=obligatory.x.axis)
+ assign("aucpr", "none", envir=obligatory.x.axis)
+ assign("rch","none", envir=obligatory.x.axis)
+ ## ecost requires probability cost function as x axis, which is handled
+ ## implicitly, not as an explicit performance measure.
+ assign("ecost","none", envir=obligatory.x.axis)
+
+ ## If a measure has optional arguments, list the names of the
+ ## arguments here.
+ optional.arguments <- new.env()
+ assign("cal", "window.size", envir=optional.arguments)
+ assign("f", "alpha", envir=optional.arguments)
+ assign("cost", c("cost.fp", "cost.fn"), envir=optional.arguments)
+ assign("auc", "fpr.stop", envir=optional.arguments)
+
+ ## If a measure has additional arguments, list the default values
+ ## for them here. Naming convention: e.g. "cal" has an optional
+ ## argument "window.size" the key to use here is "cal:window.size"
+ ## (colon as separator)
+ default.values <- new.env()
+ assign("cal:window.size", 100, envir=default.values)
+ assign("f:alpha", 0.5, envir=default.values)
+ assign("cost:cost.fp", 1, envir=default.values)
+ assign("cost:cost.fn", 1, envir=default.values)
+ assign("auc:fpr.stop", 1, envir=default.values)
+
+ list(long.unit.names=long.unit.names, function.names=function.names,
+ obligatory.x.axis=obligatory.x.axis,
+ optional.arguments=optional.arguments,
+ default.values=default.values)
+}
+
diff --git a/R/fitmodel.R b/R/fitmodel.R
index 74e1f5105beed8abfb771fee91582557bb81c01c..2f26e1ca4df7cb4b79097b5ef3ddefa733864bf1 100644
--- a/R/fitmodel.R
+++ b/R/fitmodel.R
@@ -136,7 +136,9 @@ is_fullrank <- function(metadata, formula) {
#' fitModel("mtcars" , formula = mpg ~ cyl + disp, data = mtcars)
fitModel <- function(group , formula, data, ...) {
# Fit the model using glm.nb from the GLmmTMB package
- model <- glmmTMB::glmmTMB(formula, ..., data = data )
+ model <- glmmTMB::glmmTMB(formula, ..., data = data )
+
+ ## -- save additional info
model$frame <- data
model$groupId <- group
## family in ... => avoid error in future update
@@ -146,6 +148,7 @@ fitModel <- function(group , formula, data, ...) {
## control in ... => avoid error in future update
controlArgs <- additional_args[['control']]
if (!is.null(controlArgs)) model$call$control <- controlArgs
+
return(model)
}
@@ -215,8 +218,9 @@ launchFit <- function(data, group_by, formula, ...) {
#' @param formula Formula specifying the model formula
#' @param data Data frame containing the data
#' @param n.cores The number of CPU cores to use for parallel processing.
-#' If set to NULL (default), the number of available CPU cores will be automatically detected.
+#' If set to NULL (default), the number of available CPU (minus 1) cores will be automatically detected.
#' @param log_file File to write log (default : Rtmpdir/htrfit.log)
+#' @param cl_type cluster type (defautl "PSOCK"). "FORK" is recommanded for linux.
#' @param ... Additional arguments to be passed to the glmmTMB::glmmTMB function
#' @return List of fitted model objects or NULL for any errors
#' @export
@@ -225,20 +229,25 @@ launchFit <- function(data, group_by, formula, ...) {
#' formula = Sepal.Length ~ Sepal.Width + Petal.Length,
#' data = iris, n.cores = 1 )
parallel_fit <- function(groups, group_by, formula, data, n.cores = NULL,
- log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"), ...) {
+ log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"),
+ cl_type = "PSOCK", ...) {
- if (is.null(n.cores)) n.cores <- parallel::detectCores()
+ if (is.null(n.cores)) n.cores <- max(1, parallel::detectCores(logical = FALSE) - 1)
+
+ message(paste("CPU(s) number :", n.cores, sep = " "))
+ message(paste("Cluster type :", cl_type, sep = " "))
+
## get data for parallelization
l_data2parallel <- prepare_dataParallel(groups, group_by, data)
- clust <- parallel::makeCluster(n.cores, outfile = log_file)
+ clust <- parallel::makeCluster(n.cores, outfile = log_file , type= cl_type )
parallel::clusterExport(clust, c("fitModel"), envir=environment())
results_fit <- parallel::parLapply(clust, X = l_data2parallel,
fun = launchFit,
group_by = group_by, formula = formula, ...)
- parallel::stopCluster(clust)
+ parallel::stopCluster(clust) ; invisible(gc(reset = T, verbose = F, full = T));
#closeAllConnections()
return(results_fit)
}
@@ -252,13 +261,15 @@ parallel_fit <- function(groups, group_by, formula, data, n.cores = NULL,
#' @param n.cores The number of CPU cores to use for parallel processing.
#' If set to NULL (default), the number of available CPU cores will be automatically detected.
#' @param log_file File path to save the log messages (default : Rtmpdir/htrfit.log)
+#' @param cl_type cluster type (defautl "PSOCK"). "FORK" is recommanded for linux.
#' @param ... Additional arguments to be passed to the glmmTMB::glmmTMB function
#' @return List of fitted model objects or NULL for any errors
#' @export
#' @examples
#' fitModelParallel(formula = Sepal.Length ~ Sepal.Width + Petal.Length,
#' data = iris, group_by = "Species", n.cores = 1)
-fitModelParallel <- function(formula, data, group_by, n.cores = NULL, log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"), ...) {
+fitModelParallel <- function(formula, data, group_by, n.cores = NULL, cl_type = "PSOCK" ,
+ log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"), ...) {
## Some verification
isValidInput2fit(data, formula)
@@ -270,7 +281,7 @@ fitModelParallel <- function(formula, data, group_by, n.cores = NULL, log_file =
# Fit models in parallel and capture the results
groups <- unique(data[[ group_by ]])
- results <- parallel_fit(groups, group_by, formula, data, n.cores, log_file, ...)
+ results <- parallel_fit(groups, group_by, formula, data, n.cores, log_file, cl_type, ...)
#results <- mergeListDataframes(results)
return(results)
}
diff --git a/R/identity_plot.R b/R/identity_plot.R
deleted file mode 100644
index 01b7ed94388841b495548ac3cf099907d815a3f9..0000000000000000000000000000000000000000
--- a/R/identity_plot.R
+++ /dev/null
@@ -1,39 +0,0 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
-
-
-#' Generate an identity plot
-#'
-#' This function generates an identity plot for comparing actual values with estimates.
-#'
-#' @param comparison_df A data frame containing comparison results with "actual" and "estimate" columns.
-#' @param ... additional parameters to pass ggplot2::aes
-#' @return A ggplot2 identity plot.
-#'
-#' @importFrom ggplot2 sym aes geom_point geom_abline facet_wrap theme_bw ggtitle scale_x_log10 scale_y_log10
-#' @importFrom rlang .data
-#' @export
-#' @examples
-#' comparison_data <- data.frame(
-#' actual = c(1, 2, 3, 4, 5),
-#' estimate = c(0.9, 2.2, 2.8, 4.1, 5.2),
-#' description = rep("Category A", 5))
-#' identity_plot(comparison_data)
-
-identity_plot <- function(comparison_df, ...){
-
- args <- lapply(list(...), function(x) if (!is.null(x)) ggplot2::sym(x))
-
-
- ggplot2::ggplot(comparison_df) +
- ggplot2::geom_point(ggplot2::aes(x = .data$actual, y = .data$estimate, !!!args), alpha = 0.6, size = 2) +
- ggplot2::geom_abline(intercept = 0, slope = 1, lty = 3, col = 'red', linewidth = 1) +
- ggplot2::facet_wrap(~description, scales = "free") +
- ggplot2::theme_bw() +
- ggplot2::ggtitle("Identity plot") #+
- #ggplot2::scale_x_log10() +
- #ggplot2::scale_y_log10()
-
-
-}
-
-
diff --git a/R/mlmetrics.R b/R/mlmetrics.R
new file mode 100644
index 0000000000000000000000000000000000000000..29807816152aa3d26e2a2a853ac18ab77ed3f386
--- /dev/null
+++ b/R/mlmetrics.R
@@ -0,0 +1,309 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+
+
+#' @title accuracy
+#'
+#' @description
+#' Compute the accuracy classification score.
+#'
+#' @param y_pred Predicted labels vector, as returned by a classifier
+#' @param y_true Ground truth (correct) 0-1 labels vector
+#' @return accuracy
+#' @examples
+#' data(cars)
+#' logreg <- glm(formula = vs ~ hp + wt,
+#' family = binomial(link = "logit"), data = mtcars)
+#' pred <- ifelse(logreg$fitted.values < 0.5, 0, 1)
+#' accuracy(y_pred = pred, y_true = mtcars$vs)
+#' @export
+
+accuracy <- function(y_pred, y_true) {
+ accuracy <- mean(y_true == y_pred)
+ return(accuracy)
+}
+
+
+#' @title Confusion Matrix
+#'
+#' @description
+#' Compute confusion matrix to evaluate the accuracy of a classification.
+#'
+#' @param y_pred Predicted labels vector, as returned by a classifier
+#' @param y_true Ground truth (correct) 0-1 labels vector
+#' @return a table of Confusion Matrix
+#' @examples
+#' data(cars)
+#' logreg <- glm(formula = vs ~ hp + wt,
+#' family = binomial(link = "logit"), data = mtcars)
+#' pred <- ifelse(logreg$fitted.values < 0.5, 0, 1)
+#' ConfusionMatrix(y_pred = pred, y_true = mtcars$vs)
+#' @export
+
+ConfusionMatrix <- function(y_pred, y_true) {
+ Confusion_Mat <- table(y_true, y_pred)
+ return(Confusion_Mat)
+}
+
+
+#' @title Confusion Matrix (Data Frame Format)
+#'
+#' @description
+#' Compute data frame format confusion matrix for internal usage.
+#'
+#' @param y_pred Predicted labels vector, as returned by a classifier
+#' @param y_true Ground truth (correct) 0-1 labels vector
+#' @return a data.frame of Confusion Matrix
+#' @examples
+#' data(cars)
+#' logreg <- glm(formula = vs ~ hp + wt,
+#' family = binomial(link = "logit"), data = mtcars)
+#' pred <- ifelse(logreg$fitted.values < 0.5, 0, 1)
+#' ConfusionDF(y_pred = pred, y_true = mtcars$vs)
+#' @keywords internal
+#' @export
+ConfusionDF <- function(y_pred, y_true) {
+ Confusion_DF <- transform(as.data.frame(ConfusionMatrix(y_pred, y_true)),
+ y_true = as.character(y_true),
+ y_pred = as.character(y_pred),
+ Freq = as.integer(Freq))
+ return(Confusion_DF)
+}
+
+#' @title precision
+#'
+#' @description
+#' Compute the precision score.
+#'
+#' @param y_pred Predicted labels vector, as returned by a classifier
+#' @param y_true Ground truth (correct) 0-1 labels vector
+#' @param positive An optional character string for the factor level that
+#' corresponds to a "positive" result
+#' @return precision
+#' @examples
+#' data(cars)
+#' logreg <- glm(formula = vs ~ hp + wt,
+#' family = binomial(link = "logit"), data = mtcars)
+#' pred <- ifelse(logreg$fitted.values < 0.5, 0, 1)
+#' precision(y_pred = pred, y_true = mtcars$vs, positive = "0")
+#' precision(y_pred = pred, y_true = mtcars$vs, positive = "1")
+#' @export
+precision <- function(y_true, y_pred, positive = NULL) {
+ Confusion_DF <- ConfusionDF(y_pred, y_true)
+ if (is.null(positive) == TRUE) positive <- as.character(Confusion_DF[1,1])
+ TP <- as.integer(subset(Confusion_DF, y_true==positive & y_pred==positive)["Freq"])
+ FP <- as.integer(sum(subset(Confusion_DF, y_true!=positive & y_pred==positive)["Freq"]))
+ precision <- TP/(TP+FP)
+ return(precision)
+}
+
+
+#' @title recall
+#'
+#' @description
+#' Compute the recall score.
+#'
+#' @param y_pred Predicted labels vector, as returned by a classifier
+#' @param y_true Ground truth (correct) 0-1 labels vector
+#' @param positive An optional character string for the factor level that
+#' corresponds to a "positive" result
+#' @return recall
+#' @examples
+#' data(cars)
+#' logreg <- glm(formula = vs ~ hp + wt,
+#' family = binomial(link = "logit"), data = mtcars)
+#' pred <- ifelse(logreg$fitted.values < 0.5, 0, 1)
+#' recall(y_pred = pred, y_true = mtcars$vs, positive = "0")
+#' recall(y_pred = pred, y_true = mtcars$vs, positive = "1")
+#' @export
+recall <- function(y_true, y_pred, positive = NULL) {
+ Confusion_DF <- ConfusionDF(y_pred, y_true)
+ if (is.null(positive) == TRUE) positive <- as.character(Confusion_DF[1,1])
+ TP <- as.integer(subset(Confusion_DF, y_true==positive & y_pred==positive)["Freq"])
+ FN <- as.integer(sum(subset(Confusion_DF, y_true==positive & y_pred!=positive)["Freq"]))
+ recall <- TP/(TP+FN)
+ return(recall)
+}
+
+
+#' @title sensitivity
+#'
+#' @description
+#' Compute the sensitivity score.
+#'
+#' @param y_pred Predicted labels vector, as returned by a classifier
+#' @param y_true Ground truth (correct) 0-1 labels vector
+#' @param positive An optional character string for the factor level that
+#' corresponds to a "positive" result
+#' @return sensitivity
+#' @examples
+#' data(cars)
+#' logreg <- glm(formula = vs ~ hp + wt,
+#' family = binomial(link = "logit"), data = mtcars)
+#' pred <- ifelse(logreg$fitted.values < 0.5, 0, 1)
+#' sensitivity(y_pred = pred, y_true = mtcars$vs, positive = "0")
+#' sensitivity(y_pred = pred, y_true = mtcars$vs, positive = "1")
+#' @export
+sensitivity <- function(y_true, y_pred, positive = NULL) {
+ Confusion_DF <- ConfusionDF(y_pred, y_true)
+ if (is.null(positive) == TRUE) positive <- as.character(Confusion_DF[1,1])
+ TP <- as.integer(subset(Confusion_DF, y_true==positive & y_pred==positive)["Freq"])
+ FN <- as.integer(sum(subset(Confusion_DF, y_true==positive & y_pred!=positive)["Freq"]))
+ sensitivity <- TP/(TP+FN)
+ return(sensitivity)
+}
+
+
+#' @title specificity
+#'
+#' @description
+#' Compute the specificity score.
+#'
+#' @param y_pred Predicted labels vector, as returned by a classifier
+#' @param y_true Ground truth (correct) 0-1 labels vector
+#' @param positive An optional character string for the factor level that
+#' corresponds to a "positive" result
+#' @return specificity
+#' @examples
+#' data(cars)
+#' logreg <- glm(formula = vs ~ hp + wt,
+#' family = binomial(link = "logit"), data = mtcars)
+#' pred <- ifelse(logreg$fitted.values < 0.5, 0, 1)
+#' specificity(y_pred = pred, y_true = mtcars$vs, positive = "0")
+#' specificity(y_pred = pred, y_true = mtcars$vs, positive = "1")
+#' @export
+specificity <- function(y_true, y_pred, positive = NULL) {
+ Confusion_DF <- ConfusionDF(y_pred, y_true)
+ if (is.null(positive) == TRUE) positive <- as.character(Confusion_DF[1,1])
+ TN <- as.integer(subset(Confusion_DF, y_true!=positive & y_pred!=positive)["Freq"])
+ FP <- as.integer(sum(subset(Confusion_DF, y_true!=positive & y_pred==positive)["Freq"]))
+ specificity <- TN/(TN+FP)
+ return(specificity)
+}
+
+
+
+#' @title Calculate the Area Under the Curve
+#'
+#' @description
+#' Calculate the area under the curve.
+#'
+#' @param x the x-points of the curve
+#' @param y the y-points of the curve
+#' @param method can be "trapezoid" (default), "step" or "spline"
+#' @param na.rm a logical value indicating whether NA values should be stripped before the computation proceeds
+#' @return Area Under the Curve (AUC)
+#' @examples
+#' x <- seq(0, pi, length.out = 200)
+#' plot(x = x, y = sin(x), type = "l")
+#' Area_Under_Curve(x = x, y = sin(x), method = "trapezoid", na.rm = TRUE)
+#' @importFrom stats integrate
+#' @importFrom stats na.omit
+#' @importFrom stats splinefun
+#' @export
+Area_Under_Curve <- function(x, y, method = c("trapezoid", "step", "spline"), na.rm = FALSE) {
+ if (na.rm == TRUE) {
+ xy_cbind <- na.omit(cbind(x, y))
+ x <- xy_cbind[, 1]
+ y <- xy_cbind[, 2]
+ }
+ if (length(x) != length(y)) {
+ stop("length x must equal length y")
+ }
+ idx <- order(x)
+ x <- x[idx]
+ y <- y[idx]
+ switch(match.arg(arg = method, choices = c("trapezoid", "step","spline")),
+ trapezoid = {
+ AUC <- sum((apply(cbind(y[-length(y)], y[-1]), 1, mean)) *(x[-1] - x[-length(x)]))},
+ step = {
+ AUC <- sum(y[-length(y)] * (x[-1] - x[-length(x)]))},
+ spline = {
+ AUC <- integrate(splinefun(x, y, method = "natural"), lower = min(x),upper = max(x))$value})
+ return(AUC)
+}
+
+#' @title Area Under the precision-recall Curve (PR AUC)
+#'
+#' @description
+#' Compute the Area Under the precision-recall Curve (PR AUC) from prediction scores.
+#'
+#' @param y_pred Predicted probabilities vector, as returned by a classifier
+#' @param y_true Ground truth (correct) 0-1 labels vector
+#' @return Area Under the PR Curve (PR AUC)
+#' @examples
+#' data(cars)
+#' logreg <- glm(formula = vs ~ hp + wt,
+#' family = binomial(link = "logit"), data = mtcars)
+#' PRAUC(y_pred = logreg$fitted.values, y_true = mtcars$vs)
+#' @export
+PRAUC <- function(y_pred, y_true) {
+ pred_obj <- prediction(y_pred, y_true)
+ perf_obj <- performance(pred_obj, measure = "prec", x.measure = "rec")
+ PRAUC <- Area_Under_Curve(perf_obj@x.values[[1]], perf_obj@y.values[[1]], method = "trapezoid", na.rm = TRUE)
+ return(PRAUC)
+}
+
+.performance.positive.predictive.value <-
+ function(predictions, labels, cutoffs, fp, tp, fn, tn,
+ n.pos, n.neg, n.pos.pred, n.neg.pred) {
+
+ ppv <- tp / (fp + tp)
+ list( cutoffs, ppv )
+ }
+
+.performance.false.positive.rate <-
+ function(predictions, labels, cutoffs, fp, tp, fn, tn,
+ n.pos, n.neg, n.pos.pred, n.neg.pred) {
+
+ list( cutoffs, fp / n.neg )
+ }
+
+
+.performance.true.positive.rate <-
+ function(predictions, labels, cutoffs, fp, tp, fn, tn,
+ n.pos, n.neg, n.pos.pred, n.neg.pred) {
+
+ list( cutoffs, tp / n.pos )
+ }
+
+.sarg <- function( arglist, ...) {
+ ll <- list(...)
+ for (argname in names(ll) ) {
+ arglist[[ argname ]] <- ll[[ argname ]]
+ }
+ return(arglist)
+}
+
+## return list of selected arguments, skipping those that
+## are not present in arglist
+.select.args <- function( arglist, args.to.select, complement=FALSE) {
+ match.bool <- names(arglist) %in% args.to.select
+ if (complement==TRUE) match.bool <- !match.bool
+ return( arglist[ match.bool] )
+}
+
+
+#' @title Area Under the Receiver Operating Characteristic Curve (ROC AUC)
+#'
+#' @description
+#' Compute the Area Under the Receiver Operating Characteristic Curve (ROC AUC) from prediction scores.
+#'
+#' @param y_pred Predicted probabilities vector, as returned by a classifier
+#' @param y_true Ground truth (correct) 0-1 labels vector
+#' @return Area Under the ROC Curve (ROC AUC)
+#' @examples
+#' data(cars)
+#' logreg <- glm(formula = vs ~ hp + wt,
+#' family = binomial(link = "logit"), data = mtcars)
+#' AUC(y_pred = logreg$fitted.values, y_true = mtcars$vs)
+#' @export
+AUC <- function(y_pred, y_true) {
+ rank <- rank(y_pred)
+ n_pos <- as.double(sum(y_true == 1))
+ n_neg <- as.double(sum(y_true == 0))
+ AUC <- (sum(rank[y_true == 1]) - n_pos * (n_pos + 1) / 2) / (n_pos * n_neg)
+ return(AUC)
+}
+
diff --git a/R/mock_rnaseq.R b/R/mock_rnaseq.R
index 6e3aef3d6f2431986810830fd7ff009fbcf72f03..e7ad322d4e713bd86985cd0fcc8f2c309b6a1e2e 100644
--- a/R/mock_rnaseq.R
+++ b/R/mock_rnaseq.R
@@ -108,18 +108,22 @@ mock_rnaseq <- function(list_var, n_genes, min_replicates, max_replicates, seque
libSize <- sum(colSums(dtf_countsTable))
settings_df <- getSettingsTable(n_genes, min_replicates, max_replicates, libSize)
- list2ret <- list(
- settings = settings_df,
- init = list_var,
- groundTruth = list(effects = df_inputSimulation, gene_dispersion = genes_dispersion),
- counts = dtf_countsTable,
- metadata = metaData)
+ list2ret <- list( settings = settings_df, init = list_var,
+ groundTruth = list(effects = df_inputSimulation, gene_dispersion = genes_dispersion),
+ counts = dtf_countsTable,
+ metadata = metaData)
+
+ ## -- clean garbage collector to save memory
+ invisible(gc(reset = TRUE, verbose = FALSE));
+
return(list2ret)
}
+
+
#' Validate and Filter Dispersion Values
#'
#' This function takes an input vector and validates it to ensure that it meets certain criteria.
diff --git a/R/plot_metrics.R b/R/plot_metrics.R
index 956e2dedd3e80881493343f02996b2a3d2ed7501..7fd01f459044cd0b972ad63f712ede3e841a9273 100644
--- a/R/plot_metrics.R
+++ b/R/plot_metrics.R
@@ -50,8 +50,8 @@ subset_glance <- function(glance_df, focus){
#' @examples
#' models_list <- fitModelParallel(Sepal.Length ~ Sepal.Width + Petal.Length,
#' group_by = "Species",n.cores = 1, data = iris)
-#' metrics_plot(models_list, focus = c("AIC", "BIC", "deviance"))
-metrics_plot <- function(list_tmb, focus = NULL) {
+#' diagnostic_plot(models_list, focus = c("AIC", "BIC", "deviance"))
+diagnostic_plot <- function(list_tmb, focus = NULL) {
glance_df <- glance_tmb(list_tmb)
glance_df$group_id <- rownames(glance_df)
if (!is.null(focus)) {
diff --git a/R/precision_recall.R b/R/precision_recall.R
new file mode 100644
index 0000000000000000000000000000000000000000..8326e841702f272875a8b2d184a02ee153db5f9d
--- /dev/null
+++ b/R/precision_recall.R
@@ -0,0 +1,140 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+
+#' Computes the precision-recall curve (AUC).
+#'
+#'
+#' @param dt A data frame with columns truth (first column) and score (second column).
+#' @return A dataframe with precision recall.
+#' @export
+compute_pr_curve <- function(dt){
+ ## --see .SDcols for order
+ pred_obj <- prediction(dt$p.adj , dt$isDE)
+ perf_obj = performance(pred_obj, measure = "prec", x.measure = "rec")
+ data2curve <- data.frame(x.name = perf_obj@x.values[[1]], y.name = perf_obj@y.values[[1]])
+ names(data2curve) <- c(unname(perf_obj@x.name), unname(perf_obj@y.name))
+ ## -- drop NA
+ data2curve <- na.omit(data2curve)
+ ## -- add start point
+ data2curve <- rbind(c(0,1), data2curve)
+ return(data2curve)
+}
+
+
+#' Computes area under the precision-recall curve (AUC).
+#'
+#' This function calculates the area under the precision-recall curve (AUC).
+#'
+#' @param dt A data table with columns for recall and precision.
+#' @return A numeric value representing the AUC.
+#' @export
+compute_pr_auc <- function(dt) PRAUC(y_pred = -log10(dt$p.adj) , y_true = dt$isDE)
+
+
+
+
+
+
+#' Gets precision-recall objects for a given parameter.
+#'
+#' This function takes a data table of evaluation parameters and returns precision-recall curves
+#' for each term and an aggregate precision-recall curve.
+#'
+#' @param evaldata_params Data table containing evaluation parameters.
+#' @param col_param Column name specifying the parameter for grouping.
+#' @param col_truth Column name for binary ground truth values.
+#' @param col_score Column name for predicted scores.
+#' @return A list containing precision-recall curves and AUCs for each group and an aggregate precision-recall curve and AUC.
+#' @importFrom data.table setDT
+#' @export
+get_pr_object <- function(evaldata_params, col_param = "description", col_truth = "isDE", col_score = "p.adj" ) {
+
+ ## -- data.table conversion
+ dt_evaldata_params <- data.table::setDT(evaldata_params)
+
+ ## -- by params
+ pr_curve_params <- dt_evaldata_params[, compute_pr_curve(.SD), by=c("from", col_param), .SDcols=c(col_truth, col_score)]
+ pr_auc_params <- dt_evaldata_params[, compute_pr_auc(.SD), by=c("from", col_param), .SDcols=c(col_score, col_truth)]
+ names(pr_auc_params)[ names(pr_auc_params) == "V1" ] <- "pr_AUC"
+
+ ## -- aggregate
+ pr_curve_agg <- dt_evaldata_params[, compute_pr_curve(.SD), by = "from", .SDcols=c(col_truth, col_score)]
+ pr_auc_agg <- dt_evaldata_params[, compute_pr_auc(.SD), by = "from", .SDcols=c(col_score, col_truth)]
+ names(pr_auc_agg)[ names(pr_auc_agg) == "V1" ] <- "pr_AUC"
+
+ return(list(byparams = list(pr_curve = as.data.frame(pr_curve_params),
+ pr_auc = as.data.frame(pr_auc_params)),
+ aggregate = list(pr_curve = as.data.frame(pr_curve_agg),
+ pr_auc = as.data.frame(pr_auc_agg)))
+ )
+
+}
+
+
+
+#' Builds a ggplot precision-recall curve.
+#'
+#' This function takes data frames for precision-recall curve and AUC and builds a ggplot precision-recall curve.
+#'
+#' @param data_curve Data frame with precision-recall curve.
+#' @param data_auc Data frame with AUC.
+#' @param palette_color list of colors used.
+#' @param ... Additional arguments to be passed to \code{ggplot2::geom_path}.
+#' @return A ggplot object representing the precision-recall curve.
+#' @importFrom ggplot2 ggplot geom_path geom_text theme_bw xlim ylim scale_color_manual aes sym
+#' @export
+build_gg_pr_curve <- function(data_curve, data_auc, palette_color = c("#500472", "#79cbb8"), ...){
+
+ #print(list(...))
+ #print(ggplot2::sym(list(...)))
+ #args <- lapply(list(...), function(x) if(!is.null(x)) ggplot2::sym(x) )
+
+
+ data_auc <- get_label_y_position(data_auc)
+
+
+ ggplot2::ggplot(data_curve) +
+ ggplot2::geom_path(ggplot2::aes(x = recall, y = precision , ... ), linewidth = 1) +
+ ggplot2::geom_text(data_auc,
+ mapping = ggplot2::aes(x = 0.75, y = pos_y,
+ label = paste("AUC :", round(pr_AUC, 2) , sep = ""), col = from )
+ ) +
+ ggplot2::theme_bw() +
+ ggplot2::xlim( 0, 1 ) +
+ ggplot2::ylim( 0, 1 ) +
+ ggplot2::scale_color_manual(values = palette_color)
+
+}
+
+
+
+#' Gets precision-recall curves and AUC for both aggregated and individual parameters.
+#'
+#' This function takes a precision-recall object and returns precision-recall curves and AUCs for both aggregated and individual parameters.
+#'
+#' @param pr_obj precision-recall object.
+#' @param ... Additional arguments to be passed to \code{ggplot2::geom_path}.
+#' @return precision-recall curves and AUCs for both aggregated and individual parameters.
+#' @importFrom ggplot2 facet_wrap coord_fixed
+#' @export
+get_pr_curve <- function(pr_obj, ...){
+
+ ## -- aggreg
+ data_curve <- pr_obj$aggregate$pr_curve
+ data_auc <- pr_obj$aggregate$pr_auc
+ pr_obj$aggregate$pr_curve <- build_gg_pr_curve(data_curve, data_auc, col = from , ... )
+
+ ## -- indiv
+ data_curve <- pr_obj$byparams$pr_curve
+ data_auc <- pr_obj$byparams$pr_auc
+ pr_obj$byparams$pr_curve <- build_gg_pr_curve(data_curve, data_auc, col = from , ... ) +
+ ggplot2::facet_wrap(~description) +
+ ggplot2::coord_fixed()
+
+ return(pr_obj)
+}
+
+
+
+
diff --git a/R/prepare_data2fit.R b/R/prepare_data2fit.R
index e88adf9c3575fdb2281105748ad400ef2c827fd1..e2cdd246261e2254e7e1cef30dd5483cd4cd8c82 100644
--- a/R/prepare_data2fit.R
+++ b/R/prepare_data2fit.R
@@ -40,13 +40,15 @@ countMatrix_2longDtf <- function(countMatrix, value_name = "kij", id_vars = "gen
getColumnWithSampleID <- function(dtf_countsLong, metadata) {
example_spleID <- as.character(dtf_countsLong[1, "sampleID"])
regex <- paste("^", as.character(dtf_countsLong[1, "sampleID"]), "$", sep = "")
- for (indice_col in dim(metadata)[2]) {
- if (grep(pattern = regex, metadata[, indice_col]) == 1) {
- return(colnames(metadata)[indice_col])
- } else {
- return(NA) # SampleID does not correspond between countMatrix and metadata
- }
+ ## -- init
+ name_column <- NA
+ for (indice_col in 1:dim(metadata)[2]) {
+ bool_column_samples <- grep(pattern = regex, metadata[, indice_col])
+ if (!identical(bool_column_samples, integer(0))) {
+ name_column <- colnames(metadata)[indice_col]
+ }
}
+ return(name_column)
}
#' Prepare data for fitting
diff --git a/R/receiver_operating_characteristic.R b/R/receiver_operating_characteristic.R
new file mode 100644
index 0000000000000000000000000000000000000000..55fac1c7c44486f09d25fb890c3d18ec6b365016
--- /dev/null
+++ b/R/receiver_operating_characteristic.R
@@ -0,0 +1,185 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+
+#' Get Labels for Expected Differential Expression
+#'
+#' This function assigns labels to genes based on whether their actual effect estimates
+#' indicate differential expression according to a given threshold and alternative hypothesis.
+#'
+#' @param comparison_df A data frame containing comparison results with actual effect estimates.
+#' @param coeff_threshold The threshold value for determining differential expression.
+#' @param alt_hypothesis The alternative hypothesis for comparison. Possible values are "greater",
+#' "less", and "greaterAbs".
+#' @return A modified data frame with an additional column indicating if the gene is differentially expressed.
+#'
+#' @examples
+#' # Generate a sample comparison data frame
+#' comparison_data <- data.frame(
+#' geneID = c("gene1", "gene2", "gene3"),
+#' actual = c(0.5, -0.3, 0.8)
+#' )
+#'
+#' # Get labels for expected differential expression
+#' labeled_data <- getLabelExpected(comparison_data, coeff_threshold = 0.2, alt_hypothesis = "greater")
+#'
+#' @export
+getLabelExpected <- function(comparison_df, coeff_threshold, alt_hypothesis) {
+ if (alt_hypothesis == "greater") {
+ idx_DE <- comparison_df$actual > coeff_threshold
+ comparison_df$isDE <- idx_DE
+ } else if (alt_hypothesis == "less") {
+ idx_DE <- comparison_df$actual < coeff_threshold
+ comparison_df$isDE <- idx_DE
+ } else if (alt_hypothesis == "greaterAbs") {
+ idx_DE <- abs(comparison_df$actual) > coeff_threshold
+ comparison_df$isDE <- idx_DE
+ }
+ return(comparison_df)
+}
+
+
+#' Computes the ROC curve.
+#'
+#' This function takes a data frame with binary truth values and predicted scores,
+#' computes the ROC curve, and returns a data frame containing specificity, sensitivity, and threshold values.
+#' This function is inspired by the yardstick package.
+#'
+#' @param dt A data frame with columns truth (first column) and score (second column).
+#' @return A data frame with specificity, sensitivity, and threshold values.
+#' @export
+compute_roc_curve <- function(dt){
+ pred_obj <- prediction( dt$p.adj, !dt$isDE)
+ perf_obj <- performance(pred_obj,"tpr","fpr")
+ data2curve <- data.frame(x.name = perf_obj@x.values[[1]], y.name = perf_obj@y.values[[1]])
+ names(data2curve) <- c(unname(perf_obj@x.name), unname(perf_obj@y.name))
+ return(data2curve)
+}
+
+
+#' Computes area under the ROC curve (AUC).
+#'
+#' This function calculates the area under the ROC curve (AUC) using specificity and sensitivity values.
+#'
+#' @param dt A data table with columns for y_pred (-log10(padj)) and y_true (idDE).
+#' @return A numeric value representing the AUC.
+#' @export
+compute_roc_auc <- function(dt) AUC(y_pred = -log10(dt$p.adj) , y_true = dt$isDE)
+
+
+
+
+#' Gets ROC objects for a given parameter.
+#'
+#' This function takes a data table of evaluation parameters and returns ROC curves for each term
+#' and an aggregate ROC curve along with corresponding AUC values.
+#'
+#' @param evaldata_params Data table containing evaluation parameters.
+#' @param col_param Column name specifying the parameter for grouping.
+#' @param col_truth Column name for binary ground truth values.
+#' @param col_score Column name for predicted scores.
+#' @return A list containing ROC curves and AUCs for each group and an aggregate ROC curve and AUC.
+#' @export
+get_roc_object <- function(evaldata_params, col_param = "description", col_truth = "isDE", col_score = "p.adj" ) {
+
+ ## -- data.table conversion
+ dt_evaldata_params <- data.table::setDT(evaldata_params)
+
+ ## -- by params
+ roc_curve_params <- dt_evaldata_params[, compute_roc_curve(.SD), by=c("from", col_param), .SDcols=c(col_truth, col_score)]
+ roc_auc_params <- dt_evaldata_params[, compute_roc_auc(.SD), by=c("from", col_param), .SDcols=c(col_score, col_truth)]
+ names(roc_auc_params)[ names(roc_auc_params) == "V1" ] <- "roc_AUC"
+
+ ## -- aggregate
+ roc_curve_agg <- dt_evaldata_params[, compute_roc_curve(.SD), by= "from", .SDcols=c(col_truth, col_score)]
+ roc_auc_agg <- dt_evaldata_params[, compute_roc_auc(.SD), by="from", .SDcols=c(col_score, col_truth)]
+ names(roc_auc_agg)[ names(roc_auc_agg) == "V1" ] <- "roc_AUC"
+
+ return(list(byparams = list(roc_curve = as.data.frame(roc_curve_params),
+ roc_auc = as.data.frame(roc_auc_params)),
+ aggregate = list(roc_curve = as.data.frame(roc_curve_agg),
+ roc_auc = as.data.frame(roc_auc_agg)))
+ )
+
+}
+
+
+#' Builds a ggplot ROC curve.
+#'
+#' This function takes data frames for ROC curve and AUC and builds a ggplot ROC curve.
+#'
+#' @param data_curve Data frame with ROC curve.
+#' @param data_auc Data frame with AUC.
+#' @param palette_color List of colors used.
+#' @param ... Additional arguments to be passed to ggplot2::geom_path.
+#' @return A ggplot object representing the ROC curve.
+#' @export
+build_gg_roc_curve <- function(data_curve, data_auc, palette_color = c("#500472", "#79cbb8") , ...){
+
+
+ data_auc <- get_label_y_position(data_auc)
+
+ ggplot2::ggplot(data_curve) +
+ ggplot2::geom_path(ggplot2::aes(x = `False positive rate` , y = `True positive rate`, ...), linewidth = 1) +
+ ggplot2::geom_text(data_auc,
+ mapping = ggplot2::aes(x = 0.75, y = pos_y,
+ label = paste("AUC :", round(roc_AUC, 2) , sep = ""), col = from)
+ ) +
+ ggplot2::theme_bw() +
+ ggplot2::xlim( 0, 1 ) +
+ ggplot2::ylim( 0, 1 ) +
+ ggplot2::scale_color_manual(values = palette_color)
+}
+
+
+
+#' Computes y-axis position for text labels.
+#'
+#' This function calculates the y-axis position for text labels in a ggplot based on the levels of a factor.
+#' It is specifically designed for use with ROC curve plotting.
+#'
+#' @param data_auc Data frame with AUC values and factor levels.
+#' @return A modified data frame with an additional column pos_y representing y-axis positions.
+#' @export
+get_label_y_position <- function(data_auc){
+ ## -- y text
+ l_y_pos <- c(0.15, 0.05)
+ lvls <- levels(as.factor(data_auc$from))
+ vec_pos_y <- data_auc$from == lvls[[1]]
+ vec_pos_y[vec_pos_y] <- l_y_pos[1]
+ vec_pos_y[!vec_pos_y] <- l_y_pos[2]
+ data_auc$pos_y <- vec_pos_y
+ return(data_auc)
+}
+
+
+#' Gets ROC curves and AUC for both aggregated and individual parameters.
+#'
+#' This function takes a ROC object and returns ROC curves and AUCs for both aggregated and individual parameters.
+#'
+#' @param roc_obj ROC object.
+#' @param ... Additional arguments to be passed to \code{ggplot2::geom_path}.
+#' @return ROC curves and AUCs for both aggregated and individual parameters.
+#' @export
+get_roc_curve <- function(roc_obj, ...){
+
+ ## -- aggreg
+ data_curve <- roc_obj$aggregate$roc_curve
+ data_auc <- roc_obj$aggregate$roc_auc
+ roc_obj$aggregate$roc_curve <- build_gg_roc_curve(data_curve, data_auc, col = from , ... )
+
+ ## -- indiv
+ data_curve <- roc_obj$byparams$roc_curve
+ data_auc <- roc_obj$byparams$roc_auc
+ roc_obj$byparams$roc_curve <- build_gg_roc_curve(data_curve, data_auc, col = from, ... ) +
+ ggplot2::facet_wrap(~description) +
+ ggplot2::coord_fixed()
+
+ return(roc_obj)
+}
+
+
+
+
+
+
diff --git a/R/roc_plot.R b/R/roc_plot.R
deleted file mode 100644
index 2b9e063243992d7a60c517e369f37bba7d00a1ad..0000000000000000000000000000000000000000
--- a/R/roc_plot.R
+++ /dev/null
@@ -1,93 +0,0 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
-
-
-
-#' Get Labels for Expected Differential Expression
-#'
-#' This function assigns labels to genes based on whether their actual effect estimates
-#' indicate differential expression according to a given threshold and alternative hypothesis.
-#'
-#' @param comparison_df A data frame containing comparison results with actual effect estimates.
-#' @param coeff_threshold The threshold value for determining differential expression.
-#' @param alt_hypothesis The alternative hypothesis for comparison. Possible values are "greater",
-#' "less", and "greaterAbs".
-#' @return A modified data frame with an additional column indicating if the gene is differentially expressed.
-#'
-#' @examples
-#' # Generate a sample comparison data frame
-#' comparison_data <- data.frame(
-#' geneID = c("gene1", "gene2", "gene3"),
-#' actual = c(0.5, -0.3, 0.8)
-#' )
-#'
-#' # Get labels for expected differential expression
-#' labeled_data <- getLabelExpected(comparison_data, coeff_threshold = 0.2, alt_hypothesis = "greater")
-#'
-#' @export
-getLabelExpected <- function(comparison_df, coeff_threshold, alt_hypothesis) {
- if (alt_hypothesis == "greater") {
- idx_DE <- comparison_df$actual > coeff_threshold
- comparison_df$isDE <- idx_DE
- } else if (alt_hypothesis == "less") {
- idx_DE <- comparison_df$actual < coeff_threshold
- comparison_df$isDE <- idx_DE
- } else if (alt_hypothesis == "greaterAbs") {
- idx_DE <- abs(comparison_df$actual) > coeff_threshold
- comparison_df$isDE <- idx_DE
- }
- return(comparison_df)
-}
-
-
-#' Generate ROC Curve Plot
-#'
-#' This function generates an ROC curve plot based on the comparison dataframe.
-#'
-#' @param comparison_df A dataframe containing comparison results.
-#' @param ... additional params to pass ggplot2::aes
-#' @return A ggplot object representing the ROC curve plot.
-#' @importFrom plotROC geom_roc
-#' @importFrom ggplot2 ggtitle theme_bw aes sym xlab ylab
-#' @importFrom rlang .data
-#' @examples
-#' comparison_data <- data.frame(
-#' geneID = c("gene1", "gene2", "gene3"),
-#' isDE = c(TRUE, FALSE, TRUE),
-#' p.adj = c(0.05, 0.2, 0.01)
-#' )
-#' roc_plot(comparison_data)
-#'
-#' @export
-roc_plot <- function(comparison_df, ...) {
-
- checkLabelValidityForROC <- function(labels) {
- if (all(labels == TRUE))
- message("WARNING : No FALSE label in 'isDE' column, ROC curve cannot be computed")
- if (all(labels == FALSE))
- message("WARNING : No TRUE label in 'isDE' column, ROC curve cannot be computed")
- }
-
- checkLabelValidityForROC(comparison_df$isDE)
-
- args <- lapply(list(...), function(x) if (!is.null(x)) ggplot2::sym(x))
-
- #comparison_df$isDE <- factor(comparison_df$isDE, levels= c(TRUE, FALSE))
- p <- ggplot2::ggplot(comparison_df, ggplot2::aes(d = !.data$isDE , m = .data$p.adj, !!!args )) +
- plotROC::geom_roc(n.cuts = 0, labels = FALSE) +
- ggplot2::theme_bw() +
- ggplot2::ggtitle("ROC curve") +
- ggplot2::xlab("False positive rate") +
- ggplot2::ylab("True positive rate")
-
- ## -- annotation AUC
- df_AUC <- subset(plotROC::calc_auc(p) , select = -c(PANEL, group))
- df_AUC$AUC <- round(df_AUC$AUC, digits = 3)
- if (nrow(df_AUC) == 1) annotations <- paste("AUC", df_AUC$AUC, sep = " : ")
- else annotations <- do.call(paste, c(df_AUC, sep = " - AUC: "))
- annotations <- paste(annotations, collapse = "\n")
- p <- p + ggplot2::annotate("text", x = .75, y = .25, label = annotations)
- return(p)
-}
-
-
-
diff --git a/R/rocr_functions.R b/R/rocr_functions.R
new file mode 100644
index 0000000000000000000000000000000000000000..8326e841702f272875a8b2d184a02ee153db5f9d
--- /dev/null
+++ b/R/rocr_functions.R
@@ -0,0 +1,140 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+
+#' Computes the precision-recall curve (AUC).
+#'
+#'
+#' @param dt A data frame with columns truth (first column) and score (second column).
+#' @return A dataframe with precision recall.
+#' @export
+compute_pr_curve <- function(dt){
+ ## --see .SDcols for order
+ pred_obj <- prediction(dt$p.adj , dt$isDE)
+ perf_obj = performance(pred_obj, measure = "prec", x.measure = "rec")
+ data2curve <- data.frame(x.name = perf_obj@x.values[[1]], y.name = perf_obj@y.values[[1]])
+ names(data2curve) <- c(unname(perf_obj@x.name), unname(perf_obj@y.name))
+ ## -- drop NA
+ data2curve <- na.omit(data2curve)
+ ## -- add start point
+ data2curve <- rbind(c(0,1), data2curve)
+ return(data2curve)
+}
+
+
+#' Computes area under the precision-recall curve (AUC).
+#'
+#' This function calculates the area under the precision-recall curve (AUC).
+#'
+#' @param dt A data table with columns for recall and precision.
+#' @return A numeric value representing the AUC.
+#' @export
+compute_pr_auc <- function(dt) PRAUC(y_pred = -log10(dt$p.adj) , y_true = dt$isDE)
+
+
+
+
+
+
+#' Gets precision-recall objects for a given parameter.
+#'
+#' This function takes a data table of evaluation parameters and returns precision-recall curves
+#' for each term and an aggregate precision-recall curve.
+#'
+#' @param evaldata_params Data table containing evaluation parameters.
+#' @param col_param Column name specifying the parameter for grouping.
+#' @param col_truth Column name for binary ground truth values.
+#' @param col_score Column name for predicted scores.
+#' @return A list containing precision-recall curves and AUCs for each group and an aggregate precision-recall curve and AUC.
+#' @importFrom data.table setDT
+#' @export
+get_pr_object <- function(evaldata_params, col_param = "description", col_truth = "isDE", col_score = "p.adj" ) {
+
+ ## -- data.table conversion
+ dt_evaldata_params <- data.table::setDT(evaldata_params)
+
+ ## -- by params
+ pr_curve_params <- dt_evaldata_params[, compute_pr_curve(.SD), by=c("from", col_param), .SDcols=c(col_truth, col_score)]
+ pr_auc_params <- dt_evaldata_params[, compute_pr_auc(.SD), by=c("from", col_param), .SDcols=c(col_score, col_truth)]
+ names(pr_auc_params)[ names(pr_auc_params) == "V1" ] <- "pr_AUC"
+
+ ## -- aggregate
+ pr_curve_agg <- dt_evaldata_params[, compute_pr_curve(.SD), by = "from", .SDcols=c(col_truth, col_score)]
+ pr_auc_agg <- dt_evaldata_params[, compute_pr_auc(.SD), by = "from", .SDcols=c(col_score, col_truth)]
+ names(pr_auc_agg)[ names(pr_auc_agg) == "V1" ] <- "pr_AUC"
+
+ return(list(byparams = list(pr_curve = as.data.frame(pr_curve_params),
+ pr_auc = as.data.frame(pr_auc_params)),
+ aggregate = list(pr_curve = as.data.frame(pr_curve_agg),
+ pr_auc = as.data.frame(pr_auc_agg)))
+ )
+
+}
+
+
+
+#' Builds a ggplot precision-recall curve.
+#'
+#' This function takes data frames for precision-recall curve and AUC and builds a ggplot precision-recall curve.
+#'
+#' @param data_curve Data frame with precision-recall curve.
+#' @param data_auc Data frame with AUC.
+#' @param palette_color list of colors used.
+#' @param ... Additional arguments to be passed to \code{ggplot2::geom_path}.
+#' @return A ggplot object representing the precision-recall curve.
+#' @importFrom ggplot2 ggplot geom_path geom_text theme_bw xlim ylim scale_color_manual aes sym
+#' @export
+build_gg_pr_curve <- function(data_curve, data_auc, palette_color = c("#500472", "#79cbb8"), ...){
+
+ #print(list(...))
+ #print(ggplot2::sym(list(...)))
+ #args <- lapply(list(...), function(x) if(!is.null(x)) ggplot2::sym(x) )
+
+
+ data_auc <- get_label_y_position(data_auc)
+
+
+ ggplot2::ggplot(data_curve) +
+ ggplot2::geom_path(ggplot2::aes(x = recall, y = precision , ... ), linewidth = 1) +
+ ggplot2::geom_text(data_auc,
+ mapping = ggplot2::aes(x = 0.75, y = pos_y,
+ label = paste("AUC :", round(pr_AUC, 2) , sep = ""), col = from )
+ ) +
+ ggplot2::theme_bw() +
+ ggplot2::xlim( 0, 1 ) +
+ ggplot2::ylim( 0, 1 ) +
+ ggplot2::scale_color_manual(values = palette_color)
+
+}
+
+
+
+#' Gets precision-recall curves and AUC for both aggregated and individual parameters.
+#'
+#' This function takes a precision-recall object and returns precision-recall curves and AUCs for both aggregated and individual parameters.
+#'
+#' @param pr_obj precision-recall object.
+#' @param ... Additional arguments to be passed to \code{ggplot2::geom_path}.
+#' @return precision-recall curves and AUCs for both aggregated and individual parameters.
+#' @importFrom ggplot2 facet_wrap coord_fixed
+#' @export
+get_pr_curve <- function(pr_obj, ...){
+
+ ## -- aggreg
+ data_curve <- pr_obj$aggregate$pr_curve
+ data_auc <- pr_obj$aggregate$pr_auc
+ pr_obj$aggregate$pr_curve <- build_gg_pr_curve(data_curve, data_auc, col = from , ... )
+
+ ## -- indiv
+ data_curve <- pr_obj$byparams$pr_curve
+ data_auc <- pr_obj$byparams$pr_auc
+ pr_obj$byparams$pr_curve <- build_gg_pr_curve(data_curve, data_auc, col = from , ... ) +
+ ggplot2::facet_wrap(~description) +
+ ggplot2::coord_fixed()
+
+ return(pr_obj)
+}
+
+
+
+
diff --git a/R/simulation_report.R b/R/simulation_report.R
index 2b3598836d6c85c1c59d3b3efd4e351b901038b1..c985c70671bcd7f2914676be91cb9cd69966eef3 100644
--- a/R/simulation_report.R
+++ b/R/simulation_report.R
@@ -9,7 +9,6 @@
#' @param report_file Path to the file where the report will be exported.
#' @param table_settings A table containing settings and parameters used in the analysis.
#' @param roc_curve A plot displaying the Receiver Operating Characteristic (ROC) curve.
-#' @param dispersion_plot A plot displaying the dispersion values.
#' @param id_plot A plot displaying unique identifiers.
#' @param counts_plot A plot displaying the gene counts.
#'
@@ -20,11 +19,10 @@
#'
#' @return report
#' @export
-exportReportFile <- function(report_file, table_settings, roc_curve, dispersion_plot, id_plot, counts_plot){
+exportReportFile <- function(report_file, table_settings, roc_curve, id_plot, counts_plot){
- middle_part <- gridExtra::arrangeGrob(counts_plot, dispersion_plot, heights = c(1, 1.5))
- left_part <- gridExtra::arrangeGrob(table_settings, roc_curve ,heights = c(1, 1.5))
- p2export <- gridExtra::grid.arrange(left_part, middle_part, id_plot ,ncol = 3, widths = c(1,1,2))
+ left_part <- gridExtra::arrangeGrob(table_settings, roc_curve, counts_plot ,heights = c(1, 1, 1))
+ p2export <- gridExtra::grid.arrange(left_part, id_plot ,ncol = 3, widths = c(1,1,2))
if (!is.null(report_file)) ggplot2::ggsave(report_file, p2export, height = 10, width = 15)
@@ -54,83 +52,360 @@ exportReportFile <- function(report_file, table_settings, roc_curve, dispersion_
#' table_grob <- getGrobTable(sample_data)
getGrobTable <- function(df){
theme_custom <- gridExtra::ttheme_minimal(
- core=list(bg_params = list(fill = c("#F8F9F9", "#E5E8E8"), col=NA)),
- colhead=list(fg_params=list(col="white", fontface=4L), bg_params = list(fill = "#5D6D7E", col=NA)),
- base_size = 15)
- grob_df <- gridExtra::tableGrob(df, rows=NULL, theme = theme_custom, widths = ggplot2::unit(x = c(0.4,0.3), "npc" ) )
+ core = list(bg_params = list(fill = c("#F8F9F9", "#E5E8E8"), col=NA)),
+ colhead = list(fg_params=list(col="white", fontface=4L),
+ bg_params = list(fill = "#5D6D7E", col=NA)), base_size = 15)
+ grob_df <- gridExtra::tableGrob(df, rows=NULL,
+ theme = theme_custom,
+ widths = ggplot2::unit(x = c(0.4,0.3), "npc" ) )
return(grob_df)
}
-#' Generate a simulation report
+
+#' Compute evaluation report for TMB/DESeq2 analysis
+#'
+#' This function computes an evaluation report for TMB/DESeq2 analysis using several graphical
+#' summaries like precision-recall (PR) curve, Receiver operating characteristic (ROC) curve
+#' and others. It takes as input several parameters like TMB results (\code{l_tmb}), DESeq2
+#' result (\code{dds}), mock object (\code{mock_obj}), coefficient (\code{coefficient}) and
+#' alternative hypothesis (\code{alt_hypothesis}). These parameters are processed by various
+#' functions like \code{get_eval_data}, \code{get_pr_object} and \code{get_roc_object} to
+#' perform computations and generate plots.
+#'
+#' @param l_tmb TMB results from analysis.
+#' @param dds DESeq2 results from differential gene expression analysis.
+#' @param mock_obj Mock object that represents the distribution of measurements corresponding
+#' to mock samples.
+#' @param coefficient Fold-change threshold used to define differential expression.
+#' @param alt_hypothesis Alternative hypothesis used for hypothesis testing.
+#' @param alpha_risk parameter that sets the threshold for alpha risk level (default 0.05).
+#' @param palette_color Optional parameter that sets the color palette for plots.
+#' @param ... Additional parameters to be passed to \code{get_pr_curve} and \code{get_roc_curve}.
+#'
+#' @return A list containing the following components:
+#' \item{identity}{A list containing model parameters and dispersion data.}
+#' \item{precision_recall}{A PR curve object generated from TMB and DESeq2 results.}
+#' \item{roc}{A ROC curve object generated from TMB and DESeq2 results.}
+#' \item{counts}{A counts plot generated from mock object.}
+#' @export
+evaluation_report <- function(l_tmb, dds, mock_obj, coefficient, alt_hypothesis, alpha_risk = 0.05, palette_color = NULL, ...) {
+
+ ## -- eval data
+ eval_data <- get_eval_data(l_tmb, dds, mock_obj, coefficient, alt_hypothesis)
+
+ ## -- identity plot
+ #identity_data <- rbind_model_params_and_dispersion(eval_data)
+ params_identity_eval <- eval_identityTerm(eval_data$modelparams)
+ dispersion_identity_eval <- eval_identityTerm(eval_data$modeldispersion)
+
+ ## -- pr curve
+ pr_curve_obj <- get_pr_object(eval_data$modelparams)
+ pr_curve_obj <- get_pr_curve(pr_curve_obj, ...)
+
+ ## -- auc curve
+ roc_curve_obj <- get_roc_object(eval_data$modelparams)
+ roc_curve_obj <- get_roc_curve(roc_curve_obj, ...)
+
+ ## -- acc, recall, sensib, speci, ...
+ metrics_obj <- get_ml_metrics_obj(eval_data$modelparams, alpha_risk )
+ ## -- merge all metrics in one obj
+ model_perf_obj <- get_performances_metrics_obj( params_identity_eval$R2,
+ dispersion_identity_eval$R2,
+ pr_curve_obj,
+ roc_curve_obj,
+ metrics_obj )
+
+ ## -- counts plot
+ counts_violinplot <- counts_plot(mock_obj)
+
+ ## -- clear memory
+ invisible(gc(reset = T, verbose = F, full = T)) ;
+
+ return(
+ list(
+ data = eval_data,
+ identity = list( params = params_identity_eval$p,
+ dispersion = dispersion_identity_eval$p ) ,
+ precision_recall = list( params = pr_curve_obj$byparams$pr_curve,
+ aggregate = pr_curve_obj$aggregate$pr_curve ),
+ roc = list( params = roc_curve_obj$byparams$roc_curve,
+ aggregate = roc_curve_obj$aggregate$roc_curve ),
+ counts = counts_violinplot,
+ performances = model_perf_obj)
+ )
+}
+
+
+
+#' Compute classification and regression performance metrics object
+#'
+#' This function computes metrics object for both classification and regression performance
+#' from evaluation objects generated by \code{evaluation_report} function. Metrics object
+#' contains the by-parameter and aggregate metrics for PR AUC, ROC AUC, R-squared and other
+#' classification metrics for precision, recall, sensitivity, and specificity. The function
+#' takes as input various evaluation objects including R-squared values (\code{r2_params}),
+#' dispersion values (\code{r2_dispersion}), PR object (\code{pr_obj}), ROC object
+#' (\code{roc_obj}), and machine learning performance metrics object (\code{ml_metrics_obj}).
+#' The function generates separate data frames for metric values by parameter value and for the
+#' aggregated metric values.
+#'
+#' @param r2_params R-squared values from model parameters evaluation object.
+#' @param r2_dispersion R-squared values from dispersion evaluation object.
+#' @param pr_obj PR object generated from evaluation report.
+#' @param roc_obj ROC object generated from evaluation report.
+#' @param ml_metrics_obj Machine learning performance metrics object.
+#'
+#' @return A list containing separate data frames for by-parameter and aggregated metric values.
+#' @export
+get_performances_metrics_obj <- function(r2_params , r2_dispersion,
+ pr_obj, roc_obj, ml_metrics_obj ){
+ ## -- by params
+ auc_mtrics_params <- join_dtf(pr_obj$byparams$pr_auc , roc_obj$byparams$roc_auc,
+ k1 = c("from", "description"), k2 = c("from", "description"))
+ metrics_params <- join_dtf(auc_mtrics_params, ml_metrics_obj$byparams,
+ k1 = c("from", "description"), k2 = c("from", "description"))
+ rsquare_mtrics <- rbind(r2_params, r2_dispersion)
+ metrics_params <- join_dtf(metrics_params, rsquare_mtrics,
+ k1 = c("from", "description"), k2 = c("from", "description"))
+ ## -- aggregate
+ auc_mtrics_agg <- join_dtf(pr_obj$aggregate$pr_auc , roc_obj$aggregate$roc_auc,
+ k1 = c("from"), k2 = c("from"))
+ metrics_agg <- join_dtf(auc_mtrics_agg , ml_metrics_obj$aggregate,
+ k1 = c("from"), k2 = c("from"))
+ return(list(byparams = metrics_params, aggregate = metrics_agg ))
+}
+
+
+#' Compute summary metrics on classification results
+#'
+#' This function computes several classification metrics like accuracy, precision, recall,
+#' sensitivity and specificity on classification results. The input to the function is a data frame
+#' (\code{dt}) containing the predicted classification result as \code{y_pred} and the actual
+#' classification as \code{isDE}. The function returns a data frame with the computed metrics.
+#'
+#' @param dt Data frame containing the predicted and actual classification results.
+#'
+#' @return A data frame with the computed classification metrics of accuracy, precision, recall,
+#' sensitivity and specificity.
+#' @export
+compute_metrics_summary <- function(dt) {
+
+ data.frame(
+ accuracy = accuracy( dt$y_pred, dt$isDE ),
+ precision = precision(dt$y_pred, y_true = dt$isDE, positive = "TRUE"),
+ recall = recall(dt$y_pred, y_true = dt$isDE, positive = "TRUE"),
+ sensitivity = sensitivity(dt$y_pred, y_true = dt$isDE, positive = "TRUE"),
+ specificity = specificity(dt$y_pred , y_true = dt$isDE, positive = "TRUE")
+ )
+}
+
+#' Get classification metrics for evaluation object
+#'
+#' This function extracts the classification metrics from an evaluation object generated by
+#' \code{get_eval_metrics} function. It takes as input the identity term of the evaluation object
+#' (\code{evaldata_params}) and an optional risk level for the alpha risk (\code{alpha_risk}).
+#' It retrieves the p-values from the identity term and computes the binary classification
+#' result by thresholding with the alpha risk level. It then computes the classification metrics
+#' using \code{compute_metrics_summary} function separately for each parameter value as well as
+#' for the aggregated results.
+#'
+#' @param evaldata_params Identity term of the evaluation object.
+#' @param alpha_risk parameter that sets the threshold for alpha risk level (default 0.05).
+#' @param col_param parameter that sets the column name for the parameter (default "description").
+#'
+#' @return A list containing separate data frames for classification metrics by parameter value
+#' and for aggregated classification metrics.
+#'
+#' @examples
+#' @importFrom data.table setDT
+#' @export
+get_ml_metrics_obj <- function(evaldata_params, alpha_risk = 0.05, col_param = "description"){
+
+ evaldata_params$y_pred <- evaldata_params$p.adj < alpha_risk
+
+ ## by params
+ dt_evaldata_params <- data.table::setDT(evaldata_params)
+ byparam_metrics <- dt_evaldata_params[, compute_metrics_summary(.SD), by=c("from", col_param), .SDcols=c("y_pred", "isDE")]
+
+ ## aggreg
+ agg_metrics <- dt_evaldata_params[, compute_metrics_summary(.SD), by=c("from"), .SDcols=c("y_pred", "isDE")]
+
+ return(list( byparams = as.data.frame(byparam_metrics), aggregate = as.data.frame(agg_metrics)))
+}
+
+#' Compute evaluation metrics from evaluation object
+#'
+#' This function computes the evaluation metrics from the evaluation object generated by
+#' \code{evaluation_report} function. It retrieves the R2 values from the identity plot,
+#' ROC AUC and PR AUC from ROC and precision-recall curves and combines them into a single
+#' data frame for easier analysis and interpretation.
+#'
+#' @param eval_obj Evaluation object generated from \code{evaluation_report} function.
+#'
+#' @return A data frame containing the R2 values from identity plot, ROC AUC and PR AUC values
+#' from ROC and precision-recall curves.
+#' @export
+get_eval_metrics <- function(eval_obj){
+ data_metrics <- rbind(eval_obj$identity$params$R2, eval_obj$identity$dispersion$R2)
+
+ ## -- rename ROC AUC
+ idx <- names(eval_obj$roc$byparams$roc_auc) == 'AUC'
+ names(eval_obj$roc$byparams$roc_auc)[idx] <- 'roc_AUC'
+
+ ## -- rename precisionrecall AUC
+ idx <- names(eval_obj$precision_recall$byparams$pr_auc) == 'AUC'
+ names(eval_obj$precision_recall$byparams$pr_auc)[idx] <- 'pr_AUC'
+
+ ## -- join data frames
+ data_auc <- join_dtf(eval_obj$roc$byparams$roc_auc, eval_obj$precision_recall$byparams$pr_auc,
+ k1 = c("from", "description"), k2 = c("from", "description") )
+ data_metrics <- join_dtf(data_metrics, data_auc ,
+ k1 = c("from", "description"), k2 = c("from", "description") )
+ return(data_metrics)
+}
+
+
+
+
+
+
+
+
+
+#' Extracts evaluation data from a list of TMB models.
+#'
+#' This function takes a list of TMB models, performs tidy evaluation, extracts model parameters,
+#' and compares them to the ground truth effects. Additionally, it evaluates and compares dispersion
+#' inferred from TMB with the ground truth gene dispersion. The results are organized in two data frames,
+#' one for model parameters and one for dispersion, both labeled as "HTRfit".
+#'
+#' @param list_tmb A list of TMB models.
+#' @param mock_obj A mock object containing ground truth information.
+#' @param coeff_threshold The coefficient threshold for wald test
+#' @param alt_hypothesis The alternative hypothesis for wald test
+#' @return A list containing data frames for model parameters and dispersion.
+#' @export
+get_eval_data_from_ltmb <- function(list_tmb, mock_obj, coeff_threshold, alt_hypothesis ){
+
+ ## -- reshape 2 dataframe
+ tidyRes <- tidy_results(list_tmb, coeff_threshold, alt_hypothesis)
+
+ ## -- model params
+ formula_used <- list_tmb[[1]]$modelInfo$allForm$formula
+ params_df <- compareInferenceToExpected(tidyRes, mock_obj$groundTruth$effects, formula_used)
+ params_df <- getLabelExpected(params_df, coeff_threshold, alt_hypothesis)
+ params_df$from <- "HTRfit"
+
+ ## -- dispersion
+ dispersion_inferred <- extract_tmbDispersion(list_tmb)
+ dispersion_df <- getDispersionComparison(dispersion_inferred, mock_obj$groundTruth$gene_dispersion)
+ dispersion_df$from <- "HTRfit"
+
+ return(list(modelparams = params_df, modeldispersion = dispersion_df ))
+}
+
+
+#' Extracts evaluation data from a DESeqDataSet (dds) object.
+#'
+#' This function takes a DESeqDataSet object, performs tidy evaluation, extracts model parameters
+#' (beta in the case of DESeqDataSet), and compares them to the ground truth effects. Additionally,
+#' it evaluates and compares dispersion inferred from DESeqDataSet with the ground truth gene dispersion.
+#' The results are organized in two data frames, one for model parameters and one for dispersion, both #' labeled as "HTRfit".
+#'
+#' @param dds A DESeqDataSet object.
+#' @param mock_obj A mock object containing ground truth information.
+#' @param coeff_threshold The coefficient threshold wald test
+#' @param alt_hypothesis The alternative hypothesis wald test
+#' @return A list containing data frames for model parameters and dispersion.
+#' @export
+get_eval_data_from_dds <- function(dds, mock_obj, coeff_threshold, alt_hypothesis){
+
+ ## -- reshape 2 dataframe
+ tidy_dds <- wrap_dds(dds, coeff_threshold, alt_hypothesis)
+
+ ## -- model params (beta in case of dds)
+ params_df <- inferenceToExpected_withFixedEff(tidy_dds$fixEff, mock_obj$groundTruth$effects)
+ params_df <- getLabelExpected(params_df, coeff_threshold, alt_hypothesis)
+ params_df$component <- NA
+ params_df$group <- NA
+ params_df$from <- "DESeq2"
+
+ ## -- dispersion
+ dispersion_inferred <- extract_ddsDispersion(tidy_dds)
+ dispersion_df <- getDispersionComparison(dispersion_inferred , mock_obj$groundTruth$gene_dispersion)
+ dispersion_df$from <- "DESeq2"
+
+ return(list(modelparams = params_df, modeldispersion = dispersion_df ))
+
+}
+
+
+
+
+#' Combines evaluation data from TMB and DESeqDataSet (dds) objects.
+#'
+#' This function combines model parameters and dispersion data frames from TMB and DESeqDataSet (dds) evaluations.
+#'
+#' @param evaldata_tmb Evaluation data from TMB models.
+#' @param evaldata_dds Evaluation data from DESeqDataSet (dds) object.
+#' @return A list containing combined data frames for model parameters and dispersion.
+#' @export
+rbind_evaldata_tmb_dds <- function(evaldata_tmb, evaldata_dds){
+ ## -- rbind
+ evaldata_dispersion <- rbind(evaldata_tmb$modeldispersion, evaldata_dds$modeldispersion)
+ evaldata_params <- rbind(evaldata_tmb$modelparams, evaldata_dds$modelparams)
+
+ ## -- res
+ return(list(modelparams = evaldata_params, modeldispersion = evaldata_dispersion ))
+}
+
+
+#' Combines model parameters and dispersion data frames.
+#'
+#' This function combines model parameters and dispersion data frames, ensuring proper alignment.
+#'
+#' @param eval_data Evaluation data containing model parameters and dispersion.
+#' @return A combined data frame with model parameters and dispersion.
+#' @export
+rbind_model_params_and_dispersion <- function(eval_data){
+ ## -- split
+ disp_df <- eval_data$modeldispersion
+ params_df <- eval_data$modelparams
+ ## -- merging model and dispersion param
+ disp_df[setdiff(names(params_df), names(disp_df))] <- NA
+ disp_df <- disp_df[names(params_df)]
+ ## -- rbind
+ res_df <- rbind(params_df, disp_df)
+ return(res_df)
+}
+
+
+
+#' Gets evaluation data from both TMB and DESeqDataSet (dds) objects.
#'
-#' This function generates a simulation report containing various plots and evaluation metrics.
+#' This function retrieves evaluation data from TMB and DESeqDataSet (dds) objects, combining
+#' the results into a list containing data frames for model parameters and dispersion.
#'
-#' @param mock_obj A list containing simulation data and ground truth.
-#' @param list_tmb A list of model results.
-#' @param coeff_threshold A threshold for comparing estimates.
-#' @param alt_hypothesis The alternative hypothesis for comparisons ("greater", "less", "greaterAbs").
-#' @param report_file File name to save the generated report. If NULL, the report will not be exported.
-#' @param dds_obj a DESeq2 object
-#' @importFrom ggplot2 aes geom_point geom_abline facet_wrap theme_bw ggtitle
-#' @return A list containing settings, plots, and evaluation results.
+#' @param l_tmb A list of TMB models (default is NULL).
+#' @param dds A DESeqDataSet object (default is NULL).
+#' @param mock_obj A mock object containing ground truth information.
+#' @param coefficient The coefficient threshold for waldtest.
+#' @param alt_hypothesis The alternative hypothesis for wald test
+#' @return A list containing data frames for model parameters and dispersion.
#' @export
-simulationReport <- function(mock_obj, list_tmb = NULL,
- coeff_threshold = 0, alt_hypothesis = "greaterAbs", report_file = NULL, dds_obj = NULL ){
-
- #-- init
- TMB_comparison_df <- data.frame()
- DESEQ_comparison_df <- data.frame()
- DESEQ_dispersion_df <- data.frame()
- TMB_dispersion_df <- data.frame()
-
- # -- build data from list_tmb
- if (!is.null(list_tmb)){
- tidyRes <- tidy_results(list_tmb, coeff_threshold, alt_hypothesis)
- formula_used <- list_tmb[[1]]$modelInfo$allForm$formula
- TMB_comparison_df <- compareInferenceToExpected(tidyRes, mock_obj$groundTruth$effects, formula_used)
- TMB_comparison_df <- getLabelExpected(TMB_comparison_df, coeff_threshold, alt_hypothesis)
- TMB_comparison_df$from <- "HTRfit"
- tmb_disp_inferred <- extract_tmbDispersion(list_tmb)
- TMB_dispersion_df <- getDispersionComparison(tmb_disp_inferred, mock_data$groundTruth$gene_dispersion)
- TMB_dispersion_df$from <- 'HTRfit'
- }
-
- if (!is.null(dds_obj)){
- deseq2_wrapped <- wrap_dds(dds, coeff_threshold, alt_hypothesis)
- DESEQ_comparison_df <- inferenceToExpected_withFixedEff(deseq2_wrapped$fixEff, mock_obj$groundTruth$effects)
- DESEQ_comparison_df <- getLabelExpected(DESEQ_comparison_df, coeff_threshold, alt_hypothesis)
- DESEQ_comparison_df$from <- "DESeq2"
- DESEQ_comparison_df$component <- NA
- DESEQ_comparison_df$group <- NA
- DESEQ_disp_inferred <- extract_ddsDispersion(deseq2_wrapped)
- DESEQ_dispersion_df <- getDispersionComparison(DESEQ_disp_inferred , mock_data$groundTruth$gene_dispersion)
- DESEQ_dispersion_df$from <- 'DESeq2'
- }
-
- comparison_df <- rbind( DESEQ_comparison_df, TMB_comparison_df )
-
-
- #color2use <- c("#D2B4DE", "#A2D9CE")
- color2use <- c("#500472", "#79cbb8")
- color2use <- color2use[c(!is.null(dds_obj), !is.null(list_tmb))]
-
- # -- plotting
- roc_curve <- roc_plot(comparison_df, col = "from" ) + ggplot2::scale_color_manual(values = color2use)
- id_plot <- identity_plot(comparison_df, col = "from", pch = "from") + ggplot2::scale_color_manual(values = color2use)
- #metrics_plot <- metrics_plot(list_tmb)
- evalDisp <- evaluateDispersion(TMB_dispersion_df, DESEQ_dispersion_df, color2use )
- dispersion_plot <- evalDisp$disp_plot
- counts_plot <- counts_plot(mock_obj)
-
- # -- export report
- df_settings <- mock_obj$settings
- grobTableSettings <- getGrobTable(df_settings)
- exportReportFile(report_file, grobTableSettings, roc_curve, dispersion_plot, id_plot, counts_plot)
-
- # -- return
- ret <- list(settings = df_settings, roc_plot = roc_curve,
- dispersionEvaluation = evalDisp, identity_plot = id_plot, counts_plot = counts_plot, data = comparison_df)
- return(ret)
+get_eval_data <- function(l_tmb = NULL, dds = NULL , mock_obj, coefficient, alt_hypothesis){
+ ## -- init
+ eval_data_tmb <- NULL
+ eval_data_dds <- NULL
+
+ ## -- evaluation data
+ eval_data_tmb <- if (!is.null(l_tmb)) get_eval_data_from_ltmb(l_tmb, mock_obj, coefficient, alt_hypothesis )
+ eval_data_dds <- if (!is.null(dds)) get_eval_data_from_dds(dds, mock_obj, coefficient, alt_hypothesis )
+ ## -- merge/rbind
+ eval_data <- rbind_evaldata_tmb_dds(eval_data_tmb, eval_data_dds)
+
+ return(eval_data)
}
+
diff --git a/R/update_fittedmodel.R b/R/update_fittedmodel.R
index ffafac2dd8667dc1474fff09a0102e7cc0caa80d..dac1bca13219c1a889cee7378fe05cc148a1686d 100644
--- a/R/update_fittedmodel.R
+++ b/R/update_fittedmodel.R
@@ -10,6 +10,7 @@
#' @param list_tmb List of glmmTMB objects.
#' @param n.cores Number of cores to use for parallel processing. If NULL, the function will use all available cores.
#' @param log_file File path for the log output (default: Rtmpdir/htrfit.log).
+#' @param cl_type cluster type (defautl "PSOCK"). "FORK" is recommanded for linux.
#' @param ... Additional arguments to be passed to the glmmTMB::glmmTMB function.
#' @export
#' @return A list of updated GLMNB models.
@@ -22,7 +23,8 @@
#' fitted_models <- fitModelParallel(formula, iris, group_by, n.cores = 1)
#' new_formula <- Sepal.Length ~ Sepal.Width
#' results <- updateParallel(new_formula, fitted_models, n.cores = 1)
-updateParallel <- function(formula, list_tmb, n.cores = NULL, log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"), ...) {
+updateParallel <- function(formula, list_tmb, n.cores = NULL, cl_type = "PSOCK",
+ log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"), ...) {
isValidInput2fit(list_tmb[[1]]$frame, formula)
@@ -33,7 +35,7 @@ updateParallel <- function(formula, list_tmb, n.cores = NULL, log_file = paste(t
message( paste("Log file location", log_file, sep =': ') )
# Fit models update in parallel and capture the results
- results <- parallel_update(formula, list_tmb, n.cores, log_file, ...)
+ results <- parallel_update(formula, list_tmb, n.cores, log_file, cl_type, ...)
return(results)
}
@@ -46,6 +48,7 @@ updateParallel <- function(formula, list_tmb, n.cores = NULL, log_file = paste(t
#' @param list_tmb List of glmmTMB objects.
#' @param n.cores Number of cores to use for parallel processing.
#' @param log_file File path for the log output (default : Rtmpdir/htrfit.log).
+#' @param cl_type cluster type (defautl "PSOCK"). "FORK" is recommanded for linux.
#' @param ... Additional arguments to be passed to the glmmTMB::glmmTMB function.
#' @export
#' @return A list of updated GLMNB models.
@@ -58,15 +61,20 @@ updateParallel <- function(formula, list_tmb, n.cores = NULL, log_file = paste(t
#' new_formula <- Sepal.Length ~ Sepal.Width
#' results <- parallel_update(new_formula, fitted_models, n.cores = 1)
parallel_update <- function(formula, list_tmb, n.cores = NULL,
- log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"), ...) {
+ log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"),
+ cl_type = "PSOCK" , ...) {
- if (is.null(n.cores)) n.cores <- parallel::detectCores()
- clust <- parallel::makeCluster(n.cores, outfile = log_file)
- #l_geneID <- attributes(l_tmb)$names
+ if (is.null(n.cores)) n.cores <- max(1, parallel::detectCores(logical = FALSE) - 1)
+
+ message(paste("CPU(s) number :", n.cores, sep = " "))
+ message(paste("Cluster type :", cl_type, sep = " "))
+
+
+ clust <- parallel::makeCluster(n.cores, type= cl_type, outfile = log_file)
parallel::clusterExport(clust, c("launchUpdate", "fitUpdate"), envir=environment())
updated_res <- parallel::parLapply(clust, X = list_tmb, fun = launchUpdate , formula = formula, ...)
- parallel::stopCluster(clust)
- #closeAllConnections()
+ parallel::stopCluster(clust) ; invisible(gc(reset = T, verbose = F, full = T));
+
return(updated_res)
}
@@ -92,6 +100,7 @@ parallel_update <- function(formula, list_tmb, n.cores = NULL,
fitUpdate <- function(group, glmm_obj, formula , ...){
data <- glmm_obj$frame
resUpdt <- stats::update(glmm_obj, formula, ...)
+
resUpdt$frame <- data
## save groupID => avoid error in future update
resUpdt$groupId <- group
@@ -102,6 +111,7 @@ fitUpdate <- function(group, glmm_obj, formula , ...){
## control in ... => avoid error in future update
controlArgs <- additional_args[['control']]
if (!is.null(controlArgs)) resUpdt$call$control <- controlArgs
+
return(resUpdt)
}
diff --git a/R/utils.R b/R/utils.R
index c25017f6d2660af7d0b879f64f791ab3acdb1a3d..8a9ef8b3c6bfb200b05e9801f7545e58dcc00144 100644
--- a/R/utils.R
+++ b/R/utils.R
@@ -235,10 +235,11 @@ generateGridCombination_fromListVar <- function (list_var){
#' @return A character vector with duplicated words removed from each string.
#' @export
#' @examples
-#' words <- c("hellohello", "worldworld", "programmingprogramming", "R isis great")
+#' words <- c("hellohello", "worldworld", "programmingprogramming", "R isis great", "duplicateeee1333")
#' cleaned_words <- removeDuplicatedWord(words)
removeDuplicatedWord <- function(strings){
- gsub("(.*)\\1+", "\\1", strings, perl = TRUE)
+ gsub("([A-Za-z]{1,})(\\1{1,})", "\\1", strings, perl = TRUE)
+ #gsub("(.*)\\1+", "\\1", strings, perl = TRUE)
}
@@ -266,3 +267,11 @@ reorderColumns <- function(df, columnOrder) {
}
+
+
+clear_memory <- function(except_obj){
+ a <- rm(list = setdiff(ls(), except_obj)) ; gc( reset = TRUE, verbose = FALSE )
+ return(invisible(NULL))
+}
+
+
diff --git a/dev/flat_full.Rmd b/dev/flat_full.Rmd
index 925148be38e0f42345d0a3c660cf4316a1b0c2c4..6bf3bbe619fc4c93e633fdd9823cb1689344e5eb 100644
--- a/dev/flat_full.Rmd
+++ b/dev/flat_full.Rmd
@@ -260,10 +260,11 @@ generateGridCombination_fromListVar <- function (list_var){
#' @return A character vector with duplicated words removed from each string.
#' @export
#' @examples
-#' words <- c("hellohello", "worldworld", "programmingprogramming", "R isis great")
+#' words <- c("hellohello", "worldworld", "programmingprogramming", "R isis great", "duplicateeee1333")
#' cleaned_words <- removeDuplicatedWord(words)
removeDuplicatedWord <- function(strings){
- gsub("(.*)\\1+", "\\1", strings, perl = TRUE)
+ gsub("([A-Za-z]{1,})(\\1{1,})", "\\1", strings, perl = TRUE)
+ #gsub("(.*)\\1+", "\\1", strings, perl = TRUE)
}
@@ -291,6 +292,14 @@ reorderColumns <- function(df, columnOrder) {
}
+
+
+clear_memory <- function(except_obj){
+ a <- rm(list = setdiff(ls(), except_obj)) ; gc( reset = TRUE, verbose = FALSE )
+ return(invisible(NULL))
+}
+
+
```
@@ -2020,18 +2029,22 @@ mock_rnaseq <- function(list_var, n_genes, min_replicates, max_replicates, seque
libSize <- sum(colSums(dtf_countsTable))
settings_df <- getSettingsTable(n_genes, min_replicates, max_replicates, libSize)
- list2ret <- list(
- settings = settings_df,
- init = list_var,
- groundTruth = list(effects = df_inputSimulation, gene_dispersion = genes_dispersion),
- counts = dtf_countsTable,
- metadata = metaData)
+ list2ret <- list( settings = settings_df, init = list_var,
+ groundTruth = list(effects = df_inputSimulation, gene_dispersion = genes_dispersion),
+ counts = dtf_countsTable,
+ metadata = metaData)
+
+ ## -- clean garbage collector to save memory
+ invisible(gc(reset = TRUE, verbose = FALSE));
+
return(list2ret)
}
+
+
#' Validate and Filter Dispersion Values
#'
#' This function takes an input vector and validates it to ensure that it meets certain criteria.
@@ -2235,13 +2248,15 @@ countMatrix_2longDtf <- function(countMatrix, value_name = "kij", id_vars = "gen
getColumnWithSampleID <- function(dtf_countsLong, metadata) {
example_spleID <- as.character(dtf_countsLong[1, "sampleID"])
regex <- paste("^", as.character(dtf_countsLong[1, "sampleID"]), "$", sep = "")
- for (indice_col in dim(metadata)[2]) {
- if (grep(pattern = regex, metadata[, indice_col]) == 1) {
- return(colnames(metadata)[indice_col])
- } else {
- return(NA) # SampleID does not correspond between countMatrix and metadata
- }
+ ## -- init
+ name_column <- NA
+ for (indice_col in 1:dim(metadata)[2]) {
+ bool_column_samples <- grep(pattern = regex, metadata[, indice_col])
+ if (!identical(bool_column_samples, integer(0))) {
+ name_column <- colnames(metadata)[indice_col]
+ }
}
+ return(name_column)
}
#' Prepare data for fitting
@@ -2548,7 +2563,9 @@ is_fullrank <- function(metadata, formula) {
#' fitModel("mtcars" , formula = mpg ~ cyl + disp, data = mtcars)
fitModel <- function(group , formula, data, ...) {
# Fit the model using glm.nb from the GLmmTMB package
- model <- glmmTMB::glmmTMB(formula, ..., data = data )
+ model <- glmmTMB::glmmTMB(formula, ..., data = data )
+
+ ## -- save additional info
model$frame <- data
model$groupId <- group
## family in ... => avoid error in future update
@@ -2558,6 +2575,7 @@ fitModel <- function(group , formula, data, ...) {
## control in ... => avoid error in future update
controlArgs <- additional_args[['control']]
if (!is.null(controlArgs)) model$call$control <- controlArgs
+
return(model)
}
@@ -2627,8 +2645,9 @@ launchFit <- function(data, group_by, formula, ...) {
#' @param formula Formula specifying the model formula
#' @param data Data frame containing the data
#' @param n.cores The number of CPU cores to use for parallel processing.
-#' If set to NULL (default), the number of available CPU cores will be automatically detected.
+#' If set to NULL (default), the number of available CPU (minus 1) cores will be automatically detected.
#' @param log_file File to write log (default : Rtmpdir/htrfit.log)
+#' @param cl_type cluster type (defautl "PSOCK"). "FORK" is recommanded for linux.
#' @param ... Additional arguments to be passed to the glmmTMB::glmmTMB function
#' @return List of fitted model objects or NULL for any errors
#' @export
@@ -2637,20 +2656,25 @@ launchFit <- function(data, group_by, formula, ...) {
#' formula = Sepal.Length ~ Sepal.Width + Petal.Length,
#' data = iris, n.cores = 1 )
parallel_fit <- function(groups, group_by, formula, data, n.cores = NULL,
- log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"), ...) {
+ log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"),
+ cl_type = "PSOCK", ...) {
+
+ if (is.null(n.cores)) n.cores <- max(1, parallel::detectCores(logical = FALSE) - 1)
- if (is.null(n.cores)) n.cores <- parallel::detectCores()
+ message(paste("CPU(s) number :", n.cores, sep = " "))
+ message(paste("Cluster type :", cl_type, sep = " "))
+
## get data for parallelization
l_data2parallel <- prepare_dataParallel(groups, group_by, data)
- clust <- parallel::makeCluster(n.cores, outfile = log_file)
+ clust <- parallel::makeCluster(n.cores, outfile = log_file , type= cl_type )
parallel::clusterExport(clust, c("fitModel"), envir=environment())
results_fit <- parallel::parLapply(clust, X = l_data2parallel,
fun = launchFit,
group_by = group_by, formula = formula, ...)
- parallel::stopCluster(clust)
+ parallel::stopCluster(clust) ; invisible(gc(reset = T, verbose = F, full = T));
#closeAllConnections()
return(results_fit)
}
@@ -2664,13 +2688,15 @@ parallel_fit <- function(groups, group_by, formula, data, n.cores = NULL,
#' @param n.cores The number of CPU cores to use for parallel processing.
#' If set to NULL (default), the number of available CPU cores will be automatically detected.
#' @param log_file File path to save the log messages (default : Rtmpdir/htrfit.log)
+#' @param cl_type cluster type (defautl "PSOCK"). "FORK" is recommanded for linux.
#' @param ... Additional arguments to be passed to the glmmTMB::glmmTMB function
#' @return List of fitted model objects or NULL for any errors
#' @export
#' @examples
#' fitModelParallel(formula = Sepal.Length ~ Sepal.Width + Petal.Length,
#' data = iris, group_by = "Species", n.cores = 1)
-fitModelParallel <- function(formula, data, group_by, n.cores = NULL, log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"), ...) {
+fitModelParallel <- function(formula, data, group_by, n.cores = NULL, cl_type = "PSOCK" ,
+ log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"), ...) {
## Some verification
isValidInput2fit(data, formula)
@@ -2682,7 +2708,7 @@ fitModelParallel <- function(formula, data, group_by, n.cores = NULL, log_file =
# Fit models in parallel and capture the results
groups <- unique(data[[ group_by ]])
- results <- parallel_fit(groups, group_by, formula, data, n.cores, log_file, ...)
+ results <- parallel_fit(groups, group_by, formula, data, n.cores, log_file, cl_type, ...)
#results <- mergeListDataframes(results)
return(results)
}
@@ -2933,6 +2959,7 @@ test_that("fitModelParallel fits models in parallel for each group and returns a
#' @param list_tmb List of glmmTMB objects.
#' @param n.cores Number of cores to use for parallel processing. If NULL, the function will use all available cores.
#' @param log_file File path for the log output (default: Rtmpdir/htrfit.log).
+#' @param cl_type cluster type (defautl "PSOCK"). "FORK" is recommanded for linux.
#' @param ... Additional arguments to be passed to the glmmTMB::glmmTMB function.
#' @export
#' @return A list of updated GLMNB models.
@@ -2945,7 +2972,8 @@ test_that("fitModelParallel fits models in parallel for each group and returns a
#' fitted_models <- fitModelParallel(formula, iris, group_by, n.cores = 1)
#' new_formula <- Sepal.Length ~ Sepal.Width
#' results <- updateParallel(new_formula, fitted_models, n.cores = 1)
-updateParallel <- function(formula, list_tmb, n.cores = NULL, log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"), ...) {
+updateParallel <- function(formula, list_tmb, n.cores = NULL, cl_type = "PSOCK",
+ log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"), ...) {
isValidInput2fit(list_tmb[[1]]$frame, formula)
@@ -2956,7 +2984,7 @@ updateParallel <- function(formula, list_tmb, n.cores = NULL, log_file = paste(t
message( paste("Log file location", log_file, sep =': ') )
# Fit models update in parallel and capture the results
- results <- parallel_update(formula, list_tmb, n.cores, log_file, ...)
+ results <- parallel_update(formula, list_tmb, n.cores, log_file, cl_type, ...)
return(results)
}
@@ -2969,6 +2997,7 @@ updateParallel <- function(formula, list_tmb, n.cores = NULL, log_file = paste(t
#' @param list_tmb List of glmmTMB objects.
#' @param n.cores Number of cores to use for parallel processing.
#' @param log_file File path for the log output (default : Rtmpdir/htrfit.log).
+#' @param cl_type cluster type (defautl "PSOCK"). "FORK" is recommanded for linux.
#' @param ... Additional arguments to be passed to the glmmTMB::glmmTMB function.
#' @export
#' @return A list of updated GLMNB models.
@@ -2981,15 +3010,20 @@ updateParallel <- function(formula, list_tmb, n.cores = NULL, log_file = paste(t
#' new_formula <- Sepal.Length ~ Sepal.Width
#' results <- parallel_update(new_formula, fitted_models, n.cores = 1)
parallel_update <- function(formula, list_tmb, n.cores = NULL,
- log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"), ...) {
+ log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"),
+ cl_type = "PSOCK" , ...) {
+
+ if (is.null(n.cores)) n.cores <- max(1, parallel::detectCores(logical = FALSE) - 1)
- if (is.null(n.cores)) n.cores <- parallel::detectCores()
- clust <- parallel::makeCluster(n.cores, outfile = log_file)
- #l_geneID <- attributes(l_tmb)$names
+ message(paste("CPU(s) number :", n.cores, sep = " "))
+ message(paste("Cluster type :", cl_type, sep = " "))
+
+
+ clust <- parallel::makeCluster(n.cores, type= cl_type, outfile = log_file)
parallel::clusterExport(clust, c("launchUpdate", "fitUpdate"), envir=environment())
updated_res <- parallel::parLapply(clust, X = list_tmb, fun = launchUpdate , formula = formula, ...)
- parallel::stopCluster(clust)
- #closeAllConnections()
+ parallel::stopCluster(clust) ; invisible(gc(reset = T, verbose = F, full = T));
+
return(updated_res)
}
@@ -3015,6 +3049,7 @@ parallel_update <- function(formula, list_tmb, n.cores = NULL,
fitUpdate <- function(group, glmm_obj, formula , ...){
data <- glmm_obj$frame
resUpdt <- stats::update(glmm_obj, formula, ...)
+
resUpdt$frame <- data
## save groupID => avoid error in future update
resUpdt$groupId <- group
@@ -3025,6 +3060,7 @@ fitUpdate <- function(group, glmm_obj, formula , ...){
## control in ... => avoid error in future update
controlArgs <- additional_args[['control']]
if (!is.null(controlArgs)) resUpdt$call$control <- controlArgs
+
return(resUpdt)
}
@@ -3746,8 +3782,8 @@ subset_glance <- function(glance_df, focus){
#' @examples
#' models_list <- fitModelParallel(Sepal.Length ~ Sepal.Width + Petal.Length,
#' group_by = "Species",n.cores = 1, data = iris)
-#' metrics_plot(models_list, focus = c("AIC", "BIC", "deviance"))
-metrics_plot <- function(list_tmb, focus = NULL) {
+#' diagnostic_plot(models_list, focus = c("AIC", "BIC", "deviance"))
+diagnostic_plot <- function(list_tmb, focus = NULL) {
glance_df <- glance_tmb(list_tmb)
glance_df$group_id <- rownames(glance_df)
if (!is.null(focus)) {
@@ -3784,7 +3820,7 @@ test_that("subset_glance subsets the glance DataFrame correctly", {
-test_that("metrics_plot returns a ggplot object", {
+test_that("diagnostic_plot returns a ggplot object", {
data(iris)
l_glmTMB <- list(
@@ -3795,7 +3831,7 @@ test_that("metrics_plot returns a ggplot object", {
virginica = glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length,
data = subset(iris, Species == "virginica"))
)
- p <- metrics_plot(l_glmTMB)
+ p <- diagnostic_plot(l_glmTMB)
expect_true(inherits(p, "gg"))
})
@@ -3811,31 +3847,6 @@ test_that("metrics_plot returns a ggplot object", {
```{r function-evaluate_dispersion, filename = "evaluate_dispersion"}
-#' Evaluate Dispersion Comparison
-#'
-#' Compares dispersion values between two data frames containing dispersion information.
-#'
-#' @param TMB_dispersion_df A data frame containing dispersion values from TMB.
-#' @param DESEQ_dispersion_df A data frame containing dispersion values from DESeq2.
-#' @param color2use vector of color use for points coloration
-#'
-#' @return A list containing a dispersion plot and a data frame with dispersion comparison.
-#' @importFrom ggplot2 scale_color_manual
-#' @export
-#'
-#' @examples
-#' \dontrun{
-#' disp_comparison <- evaluateDispersion(TMB_dispersion_df, DESEQ_dispersion_df, "red")
-#' plot_dispersion <- disp_comparison$disp_plot
-#' comparison_df <- disp_comparison$data
-#' }
-evaluateDispersion <- function(TMB_dispersion_df, DESEQ_dispersion_df, color2use) {
- disp_comparison_dtf <- rbind(TMB_dispersion_df, DESEQ_dispersion_df)
- disp_plot <- dispersion_plot(disp_comparison_dtf, col = "from", pch = "from") + ggplot2::scale_color_manual(values = color2use)
- return(list(disp_plot = disp_plot, data = disp_comparison_dtf))
-}
-
-
#' Get Dispersion Comparison
#'
#' Compares inferred dispersion values with actual dispersion values.
@@ -3852,10 +3863,12 @@ evaluateDispersion <- function(TMB_dispersion_df, DESEQ_dispersion_df, color2use
#' dispersion_comparison <- getDispersionComparison(inferred_disp, actual_disp)
#' }
getDispersionComparison <- function(inferred_dispersion, actual_dispersion) {
- actual_disp <- data.frame(actual_dispersion = actual_dispersion)
- actual_disp$geneID <- rownames(actual_disp)
+ actual_disp <- data.frame(actual = actual_dispersion)
+ actual_disp$ID <- rownames(actual_disp)
rownames(actual_disp) <- NULL
- disp_comparison <- join_dtf(actual_disp, inferred_dispersion, "geneID", "geneID")
+ disp_comparison <- join_dtf(actual_disp, inferred_dispersion, c("ID"), c("ID"))
+ disp_comparison$term <- 'dispersion'
+ disp_comparison$description <- 'dispersion'
return(disp_comparison)
}
@@ -3875,8 +3888,8 @@ getDispersionComparison <- function(inferred_dispersion, actual_dispersion) {
#' dispersion_df <- extract_ddsDispersion(deseq2_object)
#' }
extract_ddsDispersion <- function(dds_wrapped) {
- inferred_dispersion <- data.frame(inferred_dispersion = dds_wrapped$dispersion)
- inferred_dispersion$geneID <- rownames(inferred_dispersion)
+ inferred_dispersion <- data.frame(estimate = dds_wrapped$dispersion)
+ inferred_dispersion$ID <- rownames(inferred_dispersion)
rownames(inferred_dispersion) <- NULL
return(inferred_dispersion)
}
@@ -3898,66 +3911,18 @@ extract_ddsDispersion <- function(dds_wrapped) {
#' }
extract_tmbDispersion <- function(list_tmb) {
glanceRes <- glance_tmb(list_tmb)
- inferred_dispersion <- data.frame(inferred_dispersion = glanceRes$dispersion)
- inferred_dispersion$geneID <- rownames(glanceRes)
+ inferred_dispersion <- data.frame(estimate = glanceRes$dispersion)
+ inferred_dispersion$ID <- rownames(glanceRes)
rownames(inferred_dispersion) <- NULL
return(inferred_dispersion)
}
-
-#' Dispersion Evaluation Plot
-#'
-#' Creates a scatter plot to evaluate the dispersion values between actual and inferred dispersions.
-#'
-#' @param eval_dispersion A data frame containing actual and inferred dispersion values.
-#' @param ... Additional arguments to be passed to the ggplot2::aes function.
-#' @importFrom ggplot2 ggplot geom_point aes geom_abline theme_bw ggtitle scale_x_log10 scale_y_log10
-#' @importFrom rlang .data
-#' @return A ggplot2 scatter plot.
-#'
-#' @export
-#'
-#' @examples
-#' \dontrun{
-#' disp_plot <- dispersion_plot(disp_comparison_dtf, col = "from")
-#' print(disp_plot)
-#' }
-dispersion_plot <- function(eval_dispersion, ...) {
-
- args <- lapply(list(...), function(x) if (!is.null(x)) ggplot2::sym(x))
-
- p <- ggplot2::ggplot(eval_dispersion) +
- ggplot2::geom_point(ggplot2::aes(x = .data$actual_dispersion, y = .data$inferred_dispersion, !!!args), size = 3, alpha = 0.6) +
- ggplot2::geom_abline(intercept = 0, slope = 1, lty = 3, col = 'red', linewidth = 1) +
- ggplot2::theme_bw() +
- ggplot2::ggtitle("Dispersion evaluation") +
- ggplot2::scale_x_log10() +
- ggplot2::scale_y_log10()
-
- return(p)
-}
-
-
-
```
```{r test-evaluate_dispersion }
-# Example data
-
-
-# Tests
-test_that("dispersion_plot function works correctly", {
- eval_disp <- data.frame(
- actual_dispersion = c(0.1, 0.2, 0.3),
- inferred_dispersion = c(0.12, 0.18, 0.28),
- from = c("HTRfit", "HTRfit", "DESeq2")
- )
- disp_plot <- dispersion_plot(eval_disp, col = "from")
- expect_s3_class(disp_plot, "gg")
-})
test_that("extract_tmbDispersion function extracts dispersion correctly", {
N_GENES = 100
@@ -3971,11 +3936,11 @@ test_that("extract_tmbDispersion function extracts dispersion correctly", {
data = data2fit, group_by = "geneID",
family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
extracted_disp <- extract_tmbDispersion(l_res)
- expect_identical(colnames(extracted_disp), c("inferred_dispersion", "geneID"))
+ expect_identical(colnames(extracted_disp), c("estimate", "ID"))
})
test_that("extract_ddsDispersion function extracts dispersion correctly", {
- N_GENES = 100
+ N_GENES = 100
MAX_REPLICATES = 5
MIN_REPLICATES = 5
input_var_list <- init_variable(name = "varA", mu = 10, sd = 0.1, level = 3)
@@ -3989,7 +3954,7 @@ test_that("extract_ddsDispersion function extracts dispersion correctly", {
deseq_wrapped = wrap_dds(dds, 2, "greaterAbs")
extracted_disp <- extract_ddsDispersion(deseq_wrapped)
- expect_identical(colnames(extracted_disp), c("inferred_dispersion", "geneID"))
+ expect_identical(colnames(extracted_disp), c("estimate", "ID"))
})
test_that("getDispersionComparison function works correctly", {
@@ -4007,40 +3972,10 @@ test_that("getDispersionComparison function works correctly", {
tmb_disp_inferred <- extract_tmbDispersion(l_res)
comparison <- getDispersionComparison(tmb_disp_inferred, mock_data$groundTruth$gene_dispersion)
- expect_identical(colnames(comparison), c("actual_dispersion", "geneID", "inferred_dispersion"))
-})
-
-test_that("evaluateDispersion function works correctly", {
- N_GENES = 100
- MAX_REPLICATES = 5
- MIN_REPLICATES = 5
- input_var_list <- init_variable(name = "varA", mu = 10, sd = 0.1, level = 3)
- mock_data <- mock_rnaseq(input_var_list, N_GENES,
- min_replicates = MIN_REPLICATES, max_replicates = MAX_REPLICATES)
- data2fit <- prepareData2fit(countMatrix = mock_data$counts, metadata = mock_data$metadata)
- l_res <- fitModelParallel(formula = kij ~ varA,
- data = data2fit, group_by = "geneID",
- family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
- dds <- DESeq2::DESeqDataSetFromMatrix(
- countData = round(mock_data$counts),
- colData = mock_data$metadata,
- design = ~ varA)
- dds <- DESeq2::DESeq(dds, quiet = TRUE)
- deseq_wrapped = wrap_dds(dds, 2, "greaterAbs")
-
- tmb_disp_inferred <- extract_tmbDispersion(l_res)
- TMB_dispersion_df <- getDispersionComparison(tmb_disp_inferred, mock_data$groundTruth$gene_dispersion)
- TMB_dispersion_df$from <- 'HTRfit'
- DESEQ_disp_inferred <- extract_ddsDispersion(deseq_wrapped)
- DESEQ_dispersion_df <- getDispersionComparison(DESEQ_disp_inferred , mock_data$groundTruth$gene_dispersion)
- DESEQ_dispersion_df$from <- 'DESeq2'
-
- eval_disp <- evaluateDispersion(TMB_dispersion_df, DESEQ_dispersion_df, c("red", "blue"))
- expect_identical(names(eval_disp), c("disp_plot", "data"))
+ expect_identical(colnames(comparison), c("actual", "ID", "estimate", "term","description"))
})
-
```
@@ -5130,6 +5065,16 @@ test_that("Generate actual interaction fixed effect correctly", {
# -- fit data
data2fit <- prepareData2fit(countMatrix = mock_data$counts, metadata = mock_data$metadata)
+
+ dtf_countsLong <- countMatrix_2longDtf(mock_data$counts, "k_ij")
+ metadata_columnForjoining <- getColumnWithSampleID(dtf_countsLong, mock_data$metadata)
+
+ example_spleID <- as.character(dtf_countsLong[1, "sampleID"])
+ regex <- paste("^", as.character(dtf_countsLong[1, "sampleID"]), "$", sep = "")
+
+
+
+
results_fit <- fitModelParallel(formula = kij ~ varA + varB + varC + varA:varC,
data = data2fit, group_by = "geneID",
family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
@@ -5587,7 +5532,7 @@ test_that("results function performs statistical tests correctly", {
-```{r function-roc_plot, filename = "roc_plot"}
+```{r function-receiver_operating_characteristic, filename = "receiver_operating_characteristic"}
#' Get Labels for Expected Differential Expression
@@ -5627,61 +5572,153 @@ getLabelExpected <- function(comparison_df, coeff_threshold, alt_hypothesis) {
}
-#' Generate ROC Curve Plot
+#' Computes the ROC curve.
#'
-#' This function generates an ROC curve plot based on the comparison dataframe.
+#' This function takes a data frame with binary truth values and predicted scores,
+#' computes the ROC curve, and returns a data frame containing specificity, sensitivity, and threshold values.
+#' This function is inspired by the yardstick package.
#'
-#' @param comparison_df A dataframe containing comparison results.
-#' @param ... additional params to pass ggplot2::aes
-#' @return A ggplot object representing the ROC curve plot.
-#' @importFrom plotROC geom_roc
-#' @importFrom ggplot2 ggtitle theme_bw aes sym xlab ylab
-#' @importFrom rlang .data
-#' @examples
-#' comparison_data <- data.frame(
-#' geneID = c("gene1", "gene2", "gene3"),
-#' isDE = c(TRUE, FALSE, TRUE),
-#' p.adj = c(0.05, 0.2, 0.01)
-#' )
-#' roc_plot(comparison_data)
+#' @param dt A data frame with columns truth (first column) and score (second column).
+#' @return A data frame with specificity, sensitivity, and threshold values.
+#' @export
+compute_roc_curve <- function(dt){
+ pred_obj <- prediction( dt$p.adj, !dt$isDE)
+ perf_obj <- performance(pred_obj,"tpr","fpr")
+ data2curve <- data.frame(x.name = perf_obj@x.values[[1]], y.name = perf_obj@y.values[[1]])
+ names(data2curve) <- c(unname(perf_obj@x.name), unname(perf_obj@y.name))
+ return(data2curve)
+}
+
+
+#' Computes area under the ROC curve (AUC).
+#'
+#' This function calculates the area under the ROC curve (AUC) using specificity and sensitivity values.
+#'
+#' @param dt A data table with columns for y_pred (-log10(padj)) and y_true (idDE).
+#' @return A numeric value representing the AUC.
+#' @export
+compute_roc_auc <- function(dt) AUC(y_pred = -log10(dt$p.adj) , y_true = dt$isDE)
+
+
+
+
+#' Gets ROC objects for a given parameter.
#'
+#' This function takes a data table of evaluation parameters and returns ROC curves for each term
+#' and an aggregate ROC curve along with corresponding AUC values.
+#'
+#' @param evaldata_params Data table containing evaluation parameters.
+#' @param col_param Column name specifying the parameter for grouping.
+#' @param col_truth Column name for binary ground truth values.
+#' @param col_score Column name for predicted scores.
+#' @return A list containing ROC curves and AUCs for each group and an aggregate ROC curve and AUC.
#' @export
-roc_plot <- function(comparison_df, ...) {
+get_roc_object <- function(evaldata_params, col_param = "description", col_truth = "isDE", col_score = "p.adj" ) {
- checkLabelValidityForROC <- function(labels) {
- if (all(labels == TRUE))
- message("WARNING : No FALSE label in 'isDE' column, ROC curve cannot be computed")
- if (all(labels == FALSE))
- message("WARNING : No TRUE label in 'isDE' column, ROC curve cannot be computed")
- }
+ ## -- data.table conversion
+ dt_evaldata_params <- data.table::setDT(evaldata_params)
+
+ ## -- by params
+ roc_curve_params <- dt_evaldata_params[, compute_roc_curve(.SD), by=c("from", col_param), .SDcols=c(col_truth, col_score)]
+ roc_auc_params <- dt_evaldata_params[, compute_roc_auc(.SD), by=c("from", col_param), .SDcols=c(col_score, col_truth)]
+ names(roc_auc_params)[ names(roc_auc_params) == "V1" ] <- "roc_AUC"
- checkLabelValidityForROC(comparison_df$isDE)
-
- args <- lapply(list(...), function(x) if (!is.null(x)) ggplot2::sym(x))
-
- #comparison_df$isDE <- factor(comparison_df$isDE, levels= c(TRUE, FALSE))
- p <- ggplot2::ggplot(comparison_df, ggplot2::aes(d = !.data$isDE , m = .data$p.adj, !!!args )) +
- plotROC::geom_roc(n.cuts = 0, labels = FALSE) +
- ggplot2::theme_bw() +
- ggplot2::ggtitle("ROC curve") +
- ggplot2::xlab("False positive rate") +
- ggplot2::ylab("True positive rate")
-
- ## -- annotation AUC
- df_AUC <- subset(plotROC::calc_auc(p) , select = -c(PANEL, group))
- df_AUC$AUC <- round(df_AUC$AUC, digits = 3)
- if (nrow(df_AUC) == 1) annotations <- paste("AUC", df_AUC$AUC, sep = " : ")
- else annotations <- do.call(paste, c(df_AUC, sep = " - AUC: "))
- annotations <- paste(annotations, collapse = "\n")
- p <- p + ggplot2::annotate("text", x = .75, y = .25, label = annotations)
- return(p)
+ ## -- aggregate
+ roc_curve_agg <- dt_evaldata_params[, compute_roc_curve(.SD), by= "from", .SDcols=c(col_truth, col_score)]
+ roc_auc_agg <- dt_evaldata_params[, compute_roc_auc(.SD), by="from", .SDcols=c(col_score, col_truth)]
+ names(roc_auc_agg)[ names(roc_auc_agg) == "V1" ] <- "roc_AUC"
+
+ return(list(byparams = list(roc_curve = as.data.frame(roc_curve_params),
+ roc_auc = as.data.frame(roc_auc_params)),
+ aggregate = list(roc_curve = as.data.frame(roc_curve_agg),
+ roc_auc = as.data.frame(roc_auc_agg)))
+ )
+
+}
+
+
+#' Builds a ggplot ROC curve.
+#'
+#' This function takes data frames for ROC curve and AUC and builds a ggplot ROC curve.
+#'
+#' @param data_curve Data frame with ROC curve.
+#' @param data_auc Data frame with AUC.
+#' @param palette_color List of colors used.
+#' @param ... Additional arguments to be passed to ggplot2::geom_path.
+#' @return A ggplot object representing the ROC curve.
+#' @export
+build_gg_roc_curve <- function(data_curve, data_auc, palette_color = c("#500472", "#79cbb8") , ...){
+
+
+ data_auc <- get_label_y_position(data_auc)
+
+ ggplot2::ggplot(data_curve) +
+ ggplot2::geom_path(ggplot2::aes(x = `False positive rate` , y = `True positive rate`, ...), linewidth = 1) +
+ ggplot2::geom_text(data_auc,
+ mapping = ggplot2::aes(x = 0.75, y = pos_y,
+ label = paste("AUC :", round(roc_AUC, 2) , sep = ""), col = from)
+ ) +
+ ggplot2::theme_bw() +
+ ggplot2::xlim( 0, 1 ) +
+ ggplot2::ylim( 0, 1 ) +
+ ggplot2::scale_color_manual(values = palette_color)
+}
+
+
+
+#' Computes y-axis position for text labels.
+#'
+#' This function calculates the y-axis position for text labels in a ggplot based on the levels of a factor.
+#' It is specifically designed for use with ROC curve plotting.
+#'
+#' @param data_auc Data frame with AUC values and factor levels.
+#' @return A modified data frame with an additional column pos_y representing y-axis positions.
+#' @export
+get_label_y_position <- function(data_auc){
+ ## -- y text
+ l_y_pos <- c(0.15, 0.05)
+ lvls <- levels(as.factor(data_auc$from))
+ vec_pos_y <- data_auc$from == lvls[[1]]
+ vec_pos_y[vec_pos_y] <- l_y_pos[1]
+ vec_pos_y[!vec_pos_y] <- l_y_pos[2]
+ data_auc$pos_y <- vec_pos_y
+ return(data_auc)
+}
+
+
+#' Gets ROC curves and AUC for both aggregated and individual parameters.
+#'
+#' This function takes a ROC object and returns ROC curves and AUCs for both aggregated and individual parameters.
+#'
+#' @param roc_obj ROC object.
+#' @param ... Additional arguments to be passed to \code{ggplot2::geom_path}.
+#' @return ROC curves and AUCs for both aggregated and individual parameters.
+#' @export
+get_roc_curve <- function(roc_obj, ...){
+
+ ## -- aggreg
+ data_curve <- roc_obj$aggregate$roc_curve
+ data_auc <- roc_obj$aggregate$roc_auc
+ roc_obj$aggregate$roc_curve <- build_gg_roc_curve(data_curve, data_auc, col = from , ... )
+
+ ## -- indiv
+ data_curve <- roc_obj$byparams$roc_curve
+ data_auc <- roc_obj$byparams$roc_auc
+ roc_obj$byparams$roc_curve <- build_gg_roc_curve(data_curve, data_auc, col = from, ... ) +
+ ggplot2::facet_wrap(~description) +
+ ggplot2::coord_fixed()
+
+ return(roc_obj)
}
+
+
+
```
-```{r test-roc_plot}
+```{r test-receiver_operating_characteristic}
# Test cases for getLabelExpected function
@@ -5709,29 +5746,83 @@ test_that("getLabelExpected assigns labels correctly", {
})
-test_that("ROC plot is generated correctly", {
- comparison_data <- data.frame(
- geneID = c("gene1", "gene2", "gene3"),
- isDE = c(TRUE, FALSE, TRUE),
- p.adj = c(0.05, 0.2, 0.01),
- from = "example"
+
+
+
+test_that("compute_roc_curve computes ROC curve from data frame", {
+ # Test data
+ dt <- data.frame(
+ isDE = c(1, 0, 1, 0, 1),
+ p.adj = c(0.8, 0.6, 0.7, 0.4, 0.9)
+ )
+
+ # Test
+ result <- compute_roc_curve(dt)
+ expect_equal(names(result), c("False positive rate", "True positive rate"))
+})
+
+test_that("compute_roc_auc computes AUC from data frame", {
+ # Test data
+ dt <- data.frame(
+ isDE = c(0, 1, 1, 0, 0, 0, 1),
+ p.adj = c(1, 0.75, 0.75, 0.5, 0.25, 0, 0.1)
)
- plot <- roc_plot(comparison_data, col = "from")
-
- expect_true("gg" %in% class(plot))
-
- comparison_data <- data.frame(
- geneID = c("gene1", "gene2", "gene3"),
- isDE = c(TRUE, FALSE, TRUE),
- p.adj = c(0.05, 0.2, 0.01) )
-
- plot <- roc_plot(comparison_data)
-
- expect_true("gg" %in% class(plot))
+ # Expected output
+ expected_result <- 0.42
+
+ # Test
+ result <- compute_roc_auc(dt)
+ expect_equal(round(result,2 ), expected_result)
+})
+
+test_that("get_roc_object returns ROC curves and AUCs", {
+ # Test data
+ evaldata_params <- data.frame(
+ from = rep(c("HTRfit", "DESeq2"), each = 5),
+ description = rep(c("param1", "param2"), each = 5),
+ isDE = sample(0:1, 10, replace = TRUE),
+ p.adj = runif(10)
+ )
+
+ # Test
+ result <- get_roc_object(evaldata_params)
+ expect_equal(names(result), c("byparams", "aggregate"))
+ expect_equal(names(result$byparams), c("roc_curve", "roc_auc"))
+ expect_equal(names(result$aggregate), c("roc_curve", "roc_auc"))
+
+})
+
+test_that("build_gg_roc_curve builds ggplot ROC curve", {
+ # Test data
+ data_curve <- data.frame(
+ .threshold = c(-Inf, 0.9, 0.8, 0.7, 0.6, 0.4, Inf),
+ specificity = c(0, 1, 0.75, 0.5, 0.25, 0, 1),
+ sensitivity = c(1, 0.75, 0.75, 0.5, 0.25, 0, 0),
+ from = rep("HTRfit", 7)
+ )
+ data_auc <- data.frame(from = "HTRfit", AUC = 0.6875)
+
+ # Test
+ result <- build_gg_roc_curve(data_curve, data_auc)
+ # Ensure that the ggplot object is created without errors
+ expect_true("gg" %in% class(result))
+})
+
+test_that("get_label_y_position computes y-axis positions for labels", {
+ # Test data
+ data_auc <- data.frame(from = rep(c("HTRfit", "DESeq2"), each = 2), AUC = c(1, 0.90))
+
+ # Expected output
+ expected_result <- data.frame(from = rep(c("HTRfit", "DESeq2"), each = 2), AUC = c(1, 0.90), pos_y = c(0.05, 0.05, 0.15, 0.15))
+
+ # Test
+ result <- get_label_y_position(data_auc)
+ expect_equal(result, expected_result)
})
+
```
@@ -5789,47 +5880,109 @@ test_that("Counts plot is generated correctly", {
-```{r function-identity_plot, filename = "identity_plot"}
+```{r function-evaluation_identity, filename = "evaluation_identity"}
-#' Generate an identity plot
+
+
+
+#' Compute R-squared values for linear regression on grouped data
#'
-#' This function generates an identity plot for comparing actual values with estimates.
+#' This function takes a data frame, performs linear regression on specified grouping variables,
+#' and computes R-squared values for each group.
#'
-#' @param comparison_df A data frame containing comparison results with "actual" and "estimate" columns.
-#' @param ... additional parameters to pass ggplot2::aes
-#' @return A ggplot2 identity plot.
+#' @param data A data frame containing the variables 'actual' and 'estimate' for regression.
+#' @param grouping_by A character vector specifying the grouping variables for regression.
+#' @return A data frame with columns 'from', 'term', and 'R2' representing the grouping variables
+#' and the corresponding R-squared values.
+#' @export
+#' @examples
+#' data <- data.frame(from = c("A", "A", "A", "A"),
+#' term = c("X", "Y", "X", "Y"),
+#' actual = c(1, 2, 3, 4),
+#' estimate = c(1.5, 2.5, 3.5, 4.5))
+#' compute_rsquare(data, grouping_by = c("from", "term"))
#'
-#' @importFrom ggplot2 sym aes geom_point geom_abline facet_wrap theme_bw ggtitle scale_x_log10 scale_y_log10
-#' @importFrom rlang .data
+#' @importFrom data.table data.table
+compute_rsquare <- function(data, grouping_by = c("from", "description") ){
+ ## -- convert to data.table
+ dat <- data.table::data.table(data)
+ ## -- calculate the regression coefficient r^2
+ r_square_df <- as.data.frame(
+ dat[ , summary(lm(actual~estimate))$r.squared,
+ by = grouping_by ]
+ )
+ names(r_square_df)[names(r_square_df) == "V1"] <- "R2"
+ return(r_square_df)
+}
+
+
+#' Gets R-squared values for plotting.
+#'
+#' This function takes a data frame with R-squared values,
+#' computes position coordinates, and prepares data for plotting.
+#' @param data_rsquare Data frame with R-squared values.
+#' @return A data frame with additional columns for labeling in the plot.
+#' @export
+#' @examples
+#' data_rsquare <- data.frame(from = c("A", "B", "C"), description = c("Desc1", "Desc2", "Desc3"), R2 = c(0.9, 0.8, 0.7))
+#' result <- get_rsquare_2plot(data_rsquare)
+get_rsquare_2plot <- function(data_rsquare){
+ data_rsquare$pos_x <- -Inf
+ data_rsquare$pos_y <- Inf
+ data_rsquare$label_italic <- sprintf("italic(R^2) == %.2f", round(data_rsquare$R2, 3))
+ data_rsquare$label_vjust <- as.numeric(factor(data_rsquare$from))
+ return(data_rsquare)
+}
+
+
+
+#' Generate an identity term plot and get metrics associated
+#'
+#' This function generates an identity plot for comparing actual values with estimates
+#'
+#' @param data_identity A data frame containing comparison results with "actual" and "estimate" columns.
+#' @param palette_color dict-like palette default: palette_color = c(DESeq2 = "#500472", HTRfit ="#79cbb8")
+#' @param ... additional parameters to pass geom_point aes
+#' @return A ggplot2 identity plot and R2 metric associated
+#'
+#' @importFrom ggplot2 sym aes geom_point geom_abline facet_wrap theme_bw ggtitle scale_color_manual geom_text
+#' @importFrom rlang .data new_environment
#' @export
#' @examples
#' comparison_data <- data.frame(
#' actual = c(1, 2, 3, 4, 5),
#' estimate = c(0.9, 2.2, 2.8, 4.1, 5.2),
-#' description = rep("Category A", 5))
-#' identity_plot(comparison_data)
+#' description = rep("Category A", 5),
+#' term = rep("Category A", 5),
+#' from = c("A", "B", "B", "A", "B"))
+#' eval_identityTerm(comparison_data)
+eval_identityTerm <- function(data_identity, palette_color = c(DESeq2 = "#500472", HTRfit ="#79cbb8"), ...){
-identity_plot <- function(comparison_df, ...){
-
- args <- lapply(list(...), function(x) if (!is.null(x)) ggplot2::sym(x))
+ data_rsquare <- compute_rsquare(data_identity)
+ data_rsquare2plot <- get_rsquare_2plot(data_rsquare)
-
- ggplot2::ggplot(comparison_df) +
- ggplot2::geom_point(ggplot2::aes(x = .data$actual, y = .data$estimate, !!!args), alpha = 0.6, size = 2) +
+ p <- ggplot2::ggplot(data_identity, mapping = ggplot2::aes(x = .data$actual, y = .data$estimate, col = from, ...) )+
+ ggplot2::geom_point(alpha = 0.6, size = 2) +
ggplot2::geom_abline(intercept = 0, slope = 1, lty = 3, col = 'red', linewidth = 1) +
ggplot2::facet_wrap(~description, scales = "free") +
ggplot2::theme_bw() +
- ggplot2::ggtitle("Identity plot") #+
- #ggplot2::scale_x_log10() +
- #ggplot2::scale_y_log10()
-
+ ggplot2::geom_text(data = data_rsquare2plot,
+ mapping = ggplot2::aes(x = pos_x, y = pos_y, label = label_italic, col = from, vjust = label_vjust),
+ parse = TRUE, hjust = -0.3 ) +
+ ggplot2::ggtitle("Identity plot") +
+ ggplot2::scale_color_manual(values = palette_color )
+
+ p$plot_env <- rlang::new_environment()
+ obj_idTerm <- list(R2 = data_rsquare, p = p )
+
+ return(obj_idTerm)
}
```
-```{r test-identity_plot}
+```{r test-evaluation_identity}
# Test cases
@@ -5837,185 +5990,2172 @@ test_that("Identity plot is generated correctly", {
comparison_data <- data.frame(
actual = c(1, 2, 3, 4, 5),
estimate = c(0.9, 2.2, 2.8, 4.1, 5.2),
- description = rep("Category A", 5)
+ description = rep("Category A", 5),
+ from = c("A", "B", "A", "B", "A"),
+ term = rep("Category A", 5)
)
- plot <- identity_plot(comparison_data)
+ idTerm_obj <- eval_identityTerm(comparison_data)
- expect_true("gg" %in% class(plot))
+ expect_true("gg" %in% class(idTerm_obj$p))
+ expect_equal(c("from", "description", "R2"), colnames(idTerm_obj$R2))
+})
+
+
+
+# Test case 1: Check if the function returns a data frame
+test_that("compute_rsquare returns a data frame", {
+ data <- data.frame(from = c("A", "A", "A", "A"),
+ description = c("X", "Y", "X", "Y"),
+ actual = c(1, 2, 3, 4),
+ estimate = c(10, 20, 30, 40))
+ df_rsquare <- compute_rsquare(data, grouping_by = c("from", "description"))
+ expect_s3_class(df_rsquare, "data.frame")
+ expect_equal(df_rsquare$from, c("A", "A"))
+ expect_equal(df_rsquare$description, c("X", "Y"))
+ expect_equal(df_rsquare$R2, c(1, 1))
+
+})
+
+
+
+
+
+#' Unit Test for get_rsquare_2plot function.
+test_that("get_rsquare_2plot returns expected result", {
+ data_rsquare <- data.frame(from = c("A", "B", "C"), description = c("Desc1", "Desc2", "Desc3"), R2 = c(0.9, 0.8, 0.7))
+ result <- get_rsquare_2plot(data_rsquare)
+ expect_equal(names(result), c("from","description","R2" ,"pos_x", "pos_y", "label_italic","label_vjust"))
+ expect_equal(result$from, c("A","B", "C"))
+ expect_equal(result$description, c("Desc1","Desc2", "Desc3"))
+ expect_equal(result$label_vjust, c(1,2, 3))
+
})
```
+```{r function-MLmetrics, filename = "mlmetrics"}
-```{r function-simulation_report, filename = "simulation_report" }
-#' Export the Analysis Report to a File
-#'
-#' This function generates an analysis report by arranging and combining various plots
-#' and tables, and then exports the report to a specified file.
-#'
-#' @param report_file Path to the file where the report will be exported.
-#' @param table_settings A table containing settings and parameters used in the analysis.
-#' @param roc_curve A plot displaying the Receiver Operating Characteristic (ROC) curve.
-#' @param dispersion_plot A plot displaying the dispersion values.
-#' @param id_plot A plot displaying unique identifiers.
-#' @param counts_plot A plot displaying the gene counts.
-#'
-#'
-#' @importFrom gridExtra arrangeGrob grid.arrange
-#' @importFrom ggplot2 ggsave
+
+#' @title accuracy
#'
+#' @description
+#' Compute the accuracy classification score.
#'
-#' @return report
+#' @param y_pred Predicted labels vector, as returned by a classifier
+#' @param y_true Ground truth (correct) 0-1 labels vector
+#' @return accuracy
+#' @examples
+#' data(cars)
+#' logreg <- glm(formula = vs ~ hp + wt,
+#' family = binomial(link = "logit"), data = mtcars)
+#' pred <- ifelse(logreg$fitted.values < 0.5, 0, 1)
+#' accuracy(y_pred = pred, y_true = mtcars$vs)
#' @export
-exportReportFile <- function(report_file, table_settings, roc_curve, dispersion_plot, id_plot, counts_plot){
- middle_part <- gridExtra::arrangeGrob(counts_plot, dispersion_plot, heights = c(1, 1.5))
- left_part <- gridExtra::arrangeGrob(table_settings, roc_curve ,heights = c(1, 1.5))
- p2export <- gridExtra::grid.arrange(left_part, middle_part, id_plot ,ncol = 3, widths = c(1,1,2))
+accuracy <- function(y_pred, y_true) {
+ accuracy <- mean(y_true == y_pred)
+ return(accuracy)
+}
- if (!is.null(report_file)) ggplot2::ggsave(report_file, p2export, height = 10, width = 15)
- return(p2export)
+#' @title Confusion Matrix
+#'
+#' @description
+#' Compute confusion matrix to evaluate the accuracy of a classification.
+#'
+#' @param y_pred Predicted labels vector, as returned by a classifier
+#' @param y_true Ground truth (correct) 0-1 labels vector
+#' @return a table of Confusion Matrix
+#' @examples
+#' data(cars)
+#' logreg <- glm(formula = vs ~ hp + wt,
+#' family = binomial(link = "logit"), data = mtcars)
+#' pred <- ifelse(logreg$fitted.values < 0.5, 0, 1)
+#' ConfusionMatrix(y_pred = pred, y_true = mtcars$vs)
+#' @export
+
+ConfusionMatrix <- function(y_pred, y_true) {
+ Confusion_Mat <- table(y_true, y_pred)
+ return(Confusion_Mat)
}
-#' Generate a Formatted Table as a Grid Graphics Object
-#'
-#' This function generates a formatted table using the provided data frame and returns
-#' it as a grid graphics object.
+#' @title Confusion Matrix (Data Frame Format)
#'
-#' @param df The data frame to be converted into a formatted table.
+#' @description
+#' Compute data frame format confusion matrix for internal usage.
#'
-#' @return A grid graphics object representing the formatted table.
-#' @export
-#' @importFrom ggplot2 unit
-#' @importFrom gridExtra tableGrob ttheme_minimal
+#' @param y_pred Predicted labels vector, as returned by a classifier
+#' @param y_true Ground truth (correct) 0-1 labels vector
+#' @return a data.frame of Confusion Matrix
#' @examples
-#' # Create a sample data frame
-#' sample_data <- data.frame(
-#' Name = c("Alice", "Bob", "Charlie"),
-#' Age = c(25, 30, 28)
-#' )
-#'
-#' # Generate the formatted table
-#' table_grob <- getGrobTable(sample_data)
-getGrobTable <- function(df){
- theme_custom <- gridExtra::ttheme_minimal(
- core=list(bg_params = list(fill = c("#F8F9F9", "#E5E8E8"), col=NA)),
- colhead=list(fg_params=list(col="white", fontface=4L), bg_params = list(fill = "#5D6D7E", col=NA)),
- base_size = 15)
- grob_df <- gridExtra::tableGrob(df, rows=NULL, theme = theme_custom, widths = ggplot2::unit(x = c(0.4,0.3), "npc" ) )
- return(grob_df)
+#' data(cars)
+#' logreg <- glm(formula = vs ~ hp + wt,
+#' family = binomial(link = "logit"), data = mtcars)
+#' pred <- ifelse(logreg$fitted.values < 0.5, 0, 1)
+#' ConfusionDF(y_pred = pred, y_true = mtcars$vs)
+#' @keywords internal
+#' @export
+ConfusionDF <- function(y_pred, y_true) {
+ Confusion_DF <- transform(as.data.frame(ConfusionMatrix(y_pred, y_true)),
+ y_true = as.character(y_true),
+ y_pred = as.character(y_pred),
+ Freq = as.integer(Freq))
+ return(Confusion_DF)
+}
+
+#' @title precision
+#'
+#' @description
+#' Compute the precision score.
+#'
+#' @param y_pred Predicted labels vector, as returned by a classifier
+#' @param y_true Ground truth (correct) 0-1 labels vector
+#' @param positive An optional character string for the factor level that
+#' corresponds to a "positive" result
+#' @return precision
+#' @examples
+#' data(cars)
+#' logreg <- glm(formula = vs ~ hp + wt,
+#' family = binomial(link = "logit"), data = mtcars)
+#' pred <- ifelse(logreg$fitted.values < 0.5, 0, 1)
+#' precision(y_pred = pred, y_true = mtcars$vs, positive = "0")
+#' precision(y_pred = pred, y_true = mtcars$vs, positive = "1")
+#' @export
+precision <- function(y_true, y_pred, positive = NULL) {
+ Confusion_DF <- ConfusionDF(y_pred, y_true)
+ if (is.null(positive) == TRUE) positive <- as.character(Confusion_DF[1,1])
+ TP <- as.integer(subset(Confusion_DF, y_true==positive & y_pred==positive)["Freq"])
+ FP <- as.integer(sum(subset(Confusion_DF, y_true!=positive & y_pred==positive)["Freq"]))
+ precision <- TP/(TP+FP)
+ return(precision)
}
-#' Generate a simulation report
+#' @title recall
#'
-#' This function generates a simulation report containing various plots and evaluation metrics.
+#' @description
+#' Compute the recall score.
#'
-#' @param mock_obj A list containing simulation data and ground truth.
-#' @param list_tmb A list of model results.
-#' @param coeff_threshold A threshold for comparing estimates.
-#' @param alt_hypothesis The alternative hypothesis for comparisons ("greater", "less", "greaterAbs").
-#' @param report_file File name to save the generated report. If NULL, the report will not be exported.
-#' @param dds_obj a DESeq2 object
-#' @importFrom ggplot2 aes geom_point geom_abline facet_wrap theme_bw ggtitle
-#' @return A list containing settings, plots, and evaluation results.
+#' @param y_pred Predicted labels vector, as returned by a classifier
+#' @param y_true Ground truth (correct) 0-1 labels vector
+#' @param positive An optional character string for the factor level that
+#' corresponds to a "positive" result
+#' @return recall
+#' @examples
+#' data(cars)
+#' logreg <- glm(formula = vs ~ hp + wt,
+#' family = binomial(link = "logit"), data = mtcars)
+#' pred <- ifelse(logreg$fitted.values < 0.5, 0, 1)
+#' recall(y_pred = pred, y_true = mtcars$vs, positive = "0")
+#' recall(y_pred = pred, y_true = mtcars$vs, positive = "1")
#' @export
-simulationReport <- function(mock_obj, list_tmb = NULL,
- coeff_threshold = 0, alt_hypothesis = "greaterAbs", report_file = NULL, dds_obj = NULL ){
+recall <- function(y_true, y_pred, positive = NULL) {
+ Confusion_DF <- ConfusionDF(y_pred, y_true)
+ if (is.null(positive) == TRUE) positive <- as.character(Confusion_DF[1,1])
+ TP <- as.integer(subset(Confusion_DF, y_true==positive & y_pred==positive)["Freq"])
+ FN <- as.integer(sum(subset(Confusion_DF, y_true==positive & y_pred!=positive)["Freq"]))
+ recall <- TP/(TP+FN)
+ return(recall)
+}
+
+
+#' @title sensitivity
+#'
+#' @description
+#' Compute the sensitivity score.
+#'
+#' @param y_pred Predicted labels vector, as returned by a classifier
+#' @param y_true Ground truth (correct) 0-1 labels vector
+#' @param positive An optional character string for the factor level that
+#' corresponds to a "positive" result
+#' @return sensitivity
+#' @examples
+#' data(cars)
+#' logreg <- glm(formula = vs ~ hp + wt,
+#' family = binomial(link = "logit"), data = mtcars)
+#' pred <- ifelse(logreg$fitted.values < 0.5, 0, 1)
+#' sensitivity(y_pred = pred, y_true = mtcars$vs, positive = "0")
+#' sensitivity(y_pred = pred, y_true = mtcars$vs, positive = "1")
+#' @export
+sensitivity <- function(y_true, y_pred, positive = NULL) {
+ Confusion_DF <- ConfusionDF(y_pred, y_true)
+ if (is.null(positive) == TRUE) positive <- as.character(Confusion_DF[1,1])
+ TP <- as.integer(subset(Confusion_DF, y_true==positive & y_pred==positive)["Freq"])
+ FN <- as.integer(sum(subset(Confusion_DF, y_true==positive & y_pred!=positive)["Freq"]))
+ sensitivity <- TP/(TP+FN)
+ return(sensitivity)
+}
+
+
+#' @title specificity
+#'
+#' @description
+#' Compute the specificity score.
+#'
+#' @param y_pred Predicted labels vector, as returned by a classifier
+#' @param y_true Ground truth (correct) 0-1 labels vector
+#' @param positive An optional character string for the factor level that
+#' corresponds to a "positive" result
+#' @return specificity
+#' @examples
+#' data(cars)
+#' logreg <- glm(formula = vs ~ hp + wt,
+#' family = binomial(link = "logit"), data = mtcars)
+#' pred <- ifelse(logreg$fitted.values < 0.5, 0, 1)
+#' specificity(y_pred = pred, y_true = mtcars$vs, positive = "0")
+#' specificity(y_pred = pred, y_true = mtcars$vs, positive = "1")
+#' @export
+specificity <- function(y_true, y_pred, positive = NULL) {
+ Confusion_DF <- ConfusionDF(y_pred, y_true)
+ if (is.null(positive) == TRUE) positive <- as.character(Confusion_DF[1,1])
+ TN <- as.integer(subset(Confusion_DF, y_true!=positive & y_pred!=positive)["Freq"])
+ FP <- as.integer(sum(subset(Confusion_DF, y_true!=positive & y_pred==positive)["Freq"]))
+ specificity <- TN/(TN+FP)
+ return(specificity)
+}
+
+
+
+#' @title Calculate the Area Under the Curve
+#'
+#' @description
+#' Calculate the area under the curve.
+#'
+#' @param x the x-points of the curve
+#' @param y the y-points of the curve
+#' @param method can be "trapezoid" (default), "step" or "spline"
+#' @param na.rm a logical value indicating whether NA values should be stripped before the computation proceeds
+#' @return Area Under the Curve (AUC)
+#' @examples
+#' x <- seq(0, pi, length.out = 200)
+#' plot(x = x, y = sin(x), type = "l")
+#' Area_Under_Curve(x = x, y = sin(x), method = "trapezoid", na.rm = TRUE)
+#' @importFrom stats integrate
+#' @importFrom stats na.omit
+#' @importFrom stats splinefun
+#' @export
+Area_Under_Curve <- function(x, y, method = c("trapezoid", "step", "spline"), na.rm = FALSE) {
+ if (na.rm == TRUE) {
+ xy_cbind <- na.omit(cbind(x, y))
+ x <- xy_cbind[, 1]
+ y <- xy_cbind[, 2]
+ }
+ if (length(x) != length(y)) {
+ stop("length x must equal length y")
+ }
+ idx <- order(x)
+ x <- x[idx]
+ y <- y[idx]
+ switch(match.arg(arg = method, choices = c("trapezoid", "step","spline")),
+ trapezoid = {
+ AUC <- sum((apply(cbind(y[-length(y)], y[-1]), 1, mean)) *(x[-1] - x[-length(x)]))},
+ step = {
+ AUC <- sum(y[-length(y)] * (x[-1] - x[-length(x)]))},
+ spline = {
+ AUC <- integrate(splinefun(x, y, method = "natural"), lower = min(x),upper = max(x))$value})
+ return(AUC)
+}
+
+#' @title Area Under the precision-recall Curve (PR AUC)
+#'
+#' @description
+#' Compute the Area Under the precision-recall Curve (PR AUC) from prediction scores.
+#'
+#' @param y_pred Predicted probabilities vector, as returned by a classifier
+#' @param y_true Ground truth (correct) 0-1 labels vector
+#' @return Area Under the PR Curve (PR AUC)
+#' @examples
+#' data(cars)
+#' logreg <- glm(formula = vs ~ hp + wt,
+#' family = binomial(link = "logit"), data = mtcars)
+#' PRAUC(y_pred = logreg$fitted.values, y_true = mtcars$vs)
+#' @export
+PRAUC <- function(y_pred, y_true) {
+ pred_obj <- prediction(y_pred, y_true)
+ perf_obj <- performance(pred_obj, measure = "prec", x.measure = "rec")
+ PRAUC <- Area_Under_Curve(perf_obj@x.values[[1]], perf_obj@y.values[[1]], method = "trapezoid", na.rm = TRUE)
+ return(PRAUC)
+}
+
+.performance.positive.predictive.value <-
+ function(predictions, labels, cutoffs, fp, tp, fn, tn,
+ n.pos, n.neg, n.pos.pred, n.neg.pred) {
+
+ ppv <- tp / (fp + tp)
+ list( cutoffs, ppv )
+ }
+
+.performance.false.positive.rate <-
+ function(predictions, labels, cutoffs, fp, tp, fn, tn,
+ n.pos, n.neg, n.pos.pred, n.neg.pred) {
+
+ list( cutoffs, fp / n.neg )
+ }
+
+
+.performance.true.positive.rate <-
+ function(predictions, labels, cutoffs, fp, tp, fn, tn,
+ n.pos, n.neg, n.pos.pred, n.neg.pred) {
+
+ list( cutoffs, tp / n.pos )
+ }
+
+.sarg <- function( arglist, ...) {
+ ll <- list(...)
+ for (argname in names(ll) ) {
+ arglist[[ argname ]] <- ll[[ argname ]]
+ }
+ return(arglist)
+}
+
+## return list of selected arguments, skipping those that
+## are not present in arglist
+.select.args <- function( arglist, args.to.select, complement=FALSE) {
+ match.bool <- names(arglist) %in% args.to.select
+ if (complement==TRUE) match.bool <- !match.bool
+ return( arglist[ match.bool] )
+}
+
+
+#' @title Area Under the Receiver Operating Characteristic Curve (ROC AUC)
+#'
+#' @description
+#' Compute the Area Under the Receiver Operating Characteristic Curve (ROC AUC) from prediction scores.
+#'
+#' @param y_pred Predicted probabilities vector, as returned by a classifier
+#' @param y_true Ground truth (correct) 0-1 labels vector
+#' @return Area Under the ROC Curve (ROC AUC)
+#' @examples
+#' data(cars)
+#' logreg <- glm(formula = vs ~ hp + wt,
+#' family = binomial(link = "logit"), data = mtcars)
+#' AUC(y_pred = logreg$fitted.values, y_true = mtcars$vs)
+#' @export
+AUC <- function(y_pred, y_true) {
+ rank <- rank(y_pred)
+ n_pos <- as.double(sum(y_true == 1))
+ n_neg <- as.double(sum(y_true == 0))
+ AUC <- (sum(rank[y_true == 1]) - n_pos * (n_pos + 1) / 2) / (n_pos * n_neg)
+ return(AUC)
+}
+
+```
+
+
+```{r function-precision_recall , filename = "precision_recall"}
+
+
+#' Computes the precision-recall curve (AUC).
+#'
+#'
+#' @param dt A data frame with columns truth (first column) and score (second column).
+#' @return A dataframe with precision recall.
+#' @export
+compute_pr_curve <- function(dt){
+ ## --see .SDcols for order
+ pred_obj <- prediction(dt$p.adj , dt$isDE)
+ perf_obj = performance(pred_obj, measure = "prec", x.measure = "rec")
+ data2curve <- data.frame(x.name = perf_obj@x.values[[1]], y.name = perf_obj@y.values[[1]])
+ names(data2curve) <- c(unname(perf_obj@x.name), unname(perf_obj@y.name))
+ ## -- drop NA
+ data2curve <- na.omit(data2curve)
+ ## -- add start point
+ data2curve <- rbind(c(0,1), data2curve)
+ return(data2curve)
+}
+
+
+#' Computes area under the precision-recall curve (AUC).
+#'
+#' This function calculates the area under the precision-recall curve (AUC).
+#'
+#' @param dt A data table with columns for recall and precision.
+#' @return A numeric value representing the AUC.
+#' @export
+compute_pr_auc <- function(dt) PRAUC(y_pred = -log10(dt$p.adj) , y_true = dt$isDE)
+
+
+
+
+
+
+#' Gets precision-recall objects for a given parameter.
+#'
+#' This function takes a data table of evaluation parameters and returns precision-recall curves
+#' for each term and an aggregate precision-recall curve.
+#'
+#' @param evaldata_params Data table containing evaluation parameters.
+#' @param col_param Column name specifying the parameter for grouping.
+#' @param col_truth Column name for binary ground truth values.
+#' @param col_score Column name for predicted scores.
+#' @return A list containing precision-recall curves and AUCs for each group and an aggregate precision-recall curve and AUC.
+#' @importFrom data.table setDT
+#' @export
+get_pr_object <- function(evaldata_params, col_param = "description", col_truth = "isDE", col_score = "p.adj" ) {
+
+ ## -- data.table conversion
+ dt_evaldata_params <- data.table::setDT(evaldata_params)
+
+ ## -- by params
+ pr_curve_params <- dt_evaldata_params[, compute_pr_curve(.SD), by=c("from", col_param), .SDcols=c(col_truth, col_score)]
+ pr_auc_params <- dt_evaldata_params[, compute_pr_auc(.SD), by=c("from", col_param), .SDcols=c(col_score, col_truth)]
+ names(pr_auc_params)[ names(pr_auc_params) == "V1" ] <- "pr_AUC"
+
+ ## -- aggregate
+ pr_curve_agg <- dt_evaldata_params[, compute_pr_curve(.SD), by = "from", .SDcols=c(col_truth, col_score)]
+ pr_auc_agg <- dt_evaldata_params[, compute_pr_auc(.SD), by = "from", .SDcols=c(col_score, col_truth)]
+ names(pr_auc_agg)[ names(pr_auc_agg) == "V1" ] <- "pr_AUC"
+
+ return(list(byparams = list(pr_curve = as.data.frame(pr_curve_params),
+ pr_auc = as.data.frame(pr_auc_params)),
+ aggregate = list(pr_curve = as.data.frame(pr_curve_agg),
+ pr_auc = as.data.frame(pr_auc_agg)))
+ )
+
+}
+
+
+
+#' Builds a ggplot precision-recall curve.
+#'
+#' This function takes data frames for precision-recall curve and AUC and builds a ggplot precision-recall curve.
+#'
+#' @param data_curve Data frame with precision-recall curve.
+#' @param data_auc Data frame with AUC.
+#' @param palette_color list of colors used.
+#' @param ... Additional arguments to be passed to \code{ggplot2::geom_path}.
+#' @return A ggplot object representing the precision-recall curve.
+#' @importFrom ggplot2 ggplot geom_path geom_text theme_bw xlim ylim scale_color_manual aes sym
+#' @export
+build_gg_pr_curve <- function(data_curve, data_auc, palette_color = c("#500472", "#79cbb8"), ...){
+
+ #print(list(...))
+ #print(ggplot2::sym(list(...)))
+ #args <- lapply(list(...), function(x) if(!is.null(x)) ggplot2::sym(x) )
+
+
+ data_auc <- get_label_y_position(data_auc)
+
+
+ ggplot2::ggplot(data_curve) +
+ ggplot2::geom_path(ggplot2::aes(x = recall, y = precision , ... ), linewidth = 1) +
+ ggplot2::geom_text(data_auc,
+ mapping = ggplot2::aes(x = 0.75, y = pos_y,
+ label = paste("AUC :", round(pr_AUC, 2) , sep = ""), col = from )
+ ) +
+ ggplot2::theme_bw() +
+ ggplot2::xlim( 0, 1 ) +
+ ggplot2::ylim( 0, 1 ) +
+ ggplot2::scale_color_manual(values = palette_color)
+
+}
+
+
+
+#' Gets precision-recall curves and AUC for both aggregated and individual parameters.
+#'
+#' This function takes a precision-recall object and returns precision-recall curves and AUCs for both aggregated and individual parameters.
+#'
+#' @param pr_obj precision-recall object.
+#' @param ... Additional arguments to be passed to \code{ggplot2::geom_path}.
+#' @return precision-recall curves and AUCs for both aggregated and individual parameters.
+#' @importFrom ggplot2 facet_wrap coord_fixed
+#' @export
+get_pr_curve <- function(pr_obj, ...){
+
+ ## -- aggreg
+ data_curve <- pr_obj$aggregate$pr_curve
+ data_auc <- pr_obj$aggregate$pr_auc
+ pr_obj$aggregate$pr_curve <- build_gg_pr_curve(data_curve, data_auc, col = from , ... )
+
+ ## -- indiv
+ data_curve <- pr_obj$byparams$pr_curve
+ data_auc <- pr_obj$byparams$pr_auc
+ pr_obj$byparams$pr_curve <- build_gg_pr_curve(data_curve, data_auc, col = from , ... ) +
+ ggplot2::facet_wrap(~description) +
+ ggplot2::coord_fixed()
+
+ return(pr_obj)
+}
+
+
+
+
+```
+
+```{r test-precision_recall}
+
+
+
+test_that("compute_pr_curve computes precision-recall curve", {
+ # Mock data for testing
+ set.seed(42)
+ dt <- data.table::data.table(
+ description = rep(c("param1", "param2"), each = 50),
+ isDE = sample(0:1, 100, replace = TRUE),
+ p.adj = runif(100)
+ )
+
+ # Test the compute_pr_curve function
+ result <- compute_pr_curve(dt)
+ expect_true("recall" %in% names(result))
+ expect_true("precision" %in% names(result))
+})
+
+test_that("compute_pr_auc computes area under the precision-recall curve", {
+ # Mock data for testing
+ set.seed(42)
+ dt <- data.table::data.table(
+ description = rep(c("param1", "param2"), each = 50),
+ isDE = sample(0:1, 100, replace = TRUE),
+ p.adj = runif(100)
+ )
+
+ # Test the compute_pr_auc function
+ result <- compute_pr_auc(dt)
+ expect_equal(expected = 0.59, round(result, 2))
+})
+
+test_that("get_pr_object gets precision-recall objects", {
+ # Mock data for testing
+ set.seed(42)
+ dt_evaldata_params <- data.table::data.table(
+ description = rep(c("param1", "param2"), each = 50),
+ isDE = sample(0:1, 100, replace = TRUE),
+ from = c("A", "B"),
+ p.adj = runif(100)
+ )
+
+ # Test the get_pr_object function
+ result <- get_pr_object(dt_evaldata_params)
+
+ expect_true("byparams" %in% names(result))
+ expect_true("aggregate" %in% names(result))
+ expect_true("data.frame" %in% class(result$byparams$pr_curve))
+ expect_true("data.frame" %in% class(result$byparams$pr_auc))
+ expect_true("data.frame" %in% class(result$aggregate$pr_curve))
+ expect_true("data.frame" %in% class(result$aggregate$pr_auc))
+})
+
+test_that("build_gg_pr_curve builds ggplot precision-recall curve", {
+ # Mock data for testing
+ set.seed(42)
+ data_curve <- data.frame(
+ from = "A",
+ recall = seq(0, 1, length.out = 100),
+ precision = runif(100)
+ )
+ data_auc <- data.frame(from = "A", AUC = 0.75)
+
+ # Test the build_gg_pr_curve function
+ result <- build_gg_pr_curve(data_curve, data_auc)
+ expect_true("gg" %in% class(result))
+})
+
+test_that("get_pr_curve gets precision-recall curves and AUCs", {
+ # Mock data for testing
+ set.seed(42)
+ pr_obj <- list(
+ byparams = list(
+ pr_curve = data.frame(
+ from = c("A"),
+ description = rep(c("param1", "param2"), each = 50),
+ recall = seq(0, 1, length.out = 100),
+ precision = runif(100)
+ ),
+ pr_auc = data.frame(from = c("A"), description = c("param1", "param2"), AUC = c(0.75, 0.80))
+ ),
+ aggregate = list(
+ pr_curve = data.frame(
+ from = c("A"),
+ recall = seq(0, 1, length.out = 100),
+ precision = runif(100)
+ ),
+ pr_auc = data.frame(from = c("A"), description = c("param1", "param2"), AUC = c(0.75, 0.80))
+ )
+ )
+
+ # Test the get_pr_curve function
+ result <- get_pr_curve(pr_obj)
+ build_gg_pr_curve(pr_obj$aggregate$pr_curve, pr_obj$aggregate$pr_auc )
+ expect_true("byparams" %in% names(result))
+ expect_true("aggregate" %in% names(result))
+ expect_true("gg" %in% class(result$byparams$pr_curve))
+ expect_true("gg" %in% class(result$aggregate$pr_curve))
+})
+
+```
+
+
+```{r function-ROCR, filename = "rocr_functions"}
+
+#' @name prediction-class
+#' @aliases prediction-class
+#'
+#' @title Class \code{prediction}
+#'
+#' @description
+#' Object to encapsulate numerical predictions together with the
+#' corresponding true class labels, optionally collecting predictions and
+#' labels for several cross-validation or bootstrapping runs.
+#'
+#' @section Objects from the Class:
+#' Objects can be created by using the \code{prediction} function.
+#'
+#' @note
+#' Every \code{prediction} object contains information about the 2x2
+#' contingency table consisting of tp,tn,fp, and fn, along with the
+#' marginal sums n.pos,n.neg,n.pos.pred,n.neg.pred, because these form
+#' the basis for many derived performance measures.
+#'
+#' @slot predictions A list, in which each element is a vector of predictions
+#' (the list has length > 1 for x-validation data.
+#' @slot labels Analogously, a list in which each element is a vector of true
+#' class labels.
+#' @slot cutoffs A list in which each element is a vector of all necessary
+#' cutoffs. Each cutoff vector consists of the predicted scores (duplicates
+#' removed), in descending order.
+#' @slot fp A list in which each element is a vector of the number (not the
+#' rate!) of false positives induced by the cutoffs given in the corresponding
+#' 'cutoffs' list entry.
+#' @slot tp As fp, but for true positives.
+#' @slot tn As fp, but for true negatives.
+#' @slot fn As fp, but for false negatives.
+#' @slot n.pos A list in which each element contains the number of positive
+#' samples in the given x-validation run.
+#' @slot n.neg As n.pos, but for negative samples.
+#' @slot n.pos.pred A list in which each element is a vector of the number of
+#' samples predicted as positive at the cutoffs given in the corresponding
+#' 'cutoffs' entry.
+#' @slot n.neg.pred As n.pos.pred, but for negatively predicted samples.
+#'
+#'
+#' @author
+#' Tobias Sing \email{tobias.sing@gmail.com}, Oliver Sander
+#' \email{osander@gmail.com}
+#'
+#' @seealso
+#' \code{\link{prediction}},
+#' \code{\link{performance}},
+#' \code{\link{performance-class}},
+#' \code{\link{plot.performance}}
+#'
+#' @export
+setClass("prediction",
+ representation(predictions = "list",
+ labels = "list",
+ cutoffs = "list",
+ fp = "list",
+ tp = "list",
+ tn = "list",
+ fn = "list",
+ n.pos = "list",
+ n.neg = "list",
+ n.pos.pred = "list",
+ n.neg.pred = "list"))
+
+setMethod("show","prediction",
+ function(object){
+ cat("A ", class(object), " instance\n", sep = "")
+ if(length(object@predictions) > 1L){
+ cat(" with ", length(object@predictions)," cross ",
+ "validation runs ", sep = "")
+ if(length(unique(vapply(object@predictions,length,integer(1))))){
+ cat("(equal lengths)", sep = "")
+ } else {
+ cat("(different lengths)", sep = "")
+ }
+ } else {
+ cat(" with ", length(object@predictions[[1L]]),
+ " data points", sep = "")
+ }
+ })
+
+#' @name performance-class
+#' @aliases performance-class
+#'
+#' @title Class \code{performance}
+#'
+#' @description
+#' Object to capture the result of a performance evaluation, optionally
+#' collecting evaluations from several cross-validation or bootstrapping runs.
+#'
+#' @section Objects from the Class:
+#' Objects can be created by using the \code{performance} function.
+#'
+#' @details
+#' A \code{performance} object can capture information from four
+#' different evaluation scenarios:
+#' \itemize{
+#' \item The behaviour of a cutoff-dependent performance measure across
+#' the range of all cutoffs (e.g. \code{performance( predObj, 'acc' )} ). Here,
+#' \code{x.values} contains the cutoffs, \code{y.values} the
+#' corresponding values of the performance measure, and
+#' \code{alpha.values} is empty.\cr
+#' \item The trade-off between two performance measures across the
+#' range of all cutoffs (e.g. \code{performance( predObj,
+#' 'tpr', 'fpr' )} ). In this case, the cutoffs are stored in
+#' \code{alpha.values}, while \code{x.values} and \code{y.values}
+#' contain the corresponding values of the two performance measures.\cr
+#' \item A performance measure that comes along with an obligatory
+#' second axis (e.g. \code{performance( predObj, 'ecost' )} ). Here, the measure values are
+#' stored in \code{y.values}, while the corresponding values of the
+#' obligatory axis are stored in \code{x.values}, and \code{alpha.values}
+#' is empty.\cr
+#' \item A performance measure whose value is just a scalar
+#' (e.g. \code{performance( predObj, 'auc' )} ). The value is then stored in
+#' \code{y.values}, while \code{x.values} and \code{alpha.values} are
+#' empty.
+#' }
+#'
+#' @slot x.name Performance measure used for the x axis.
+#' @slot y.name Performance measure used for the y axis.
+#' @slot alpha.name Name of the unit that is used to create the parametrized
+#' curve. Currently, curves can only be parametrized by cutoff, so
+#' \code{alpha.name} is either \code{none} or \code{cutoff}.
+#' @slot x.values A list in which each entry contains the x values of the curve
+#' of this particular cross-validation run. \code{x.values[[i]]},
+#' \code{y.values[[i]]}, and \code{alpha.values[[i]]} correspond to each
+#' other.
+#' @slot y.values A list in which each entry contains the y values of the curve
+#' of this particular cross-validation run.
+#' @slot alpha.values A list in which each entry contains the cutoff values of
+#' the curve of this particular cross-validation run.
+#'
+#' @references
+#' A detailed list of references can be found on the ROCR homepage at
+#' \url{http://rocr.bioinf.mpi-sb.mpg.de}.
+#'
+#' @author
+#' Tobias Sing \email{tobias.sing@gmail.com}, Oliver Sander
+#' \email{osander@gmail.com}
+#'
+#' @seealso
+#' \code{\link{prediction}}
+#' \code{\link{performance}},
+#' \code{\link{prediction-class}},
+#' \code{\link{plot.performance}}
+#'
+#' @export
+setClass("performance",
+ representation(x.name = "character",
+ y.name = "character",
+ alpha.name = "character",
+ x.values = "list",
+ y.values = "list",
+ alpha.values = "list" ))
+
+setMethod("show","performance",
+ function(object){
+ cat("A ", class(object), " instance\n", sep = "")
+ if(length(object@y.values[[1L]]) > 1L){
+ cat(" '", object@x.name, "' vs. '", object@y.name,
+ "' (alpha: '",object@alpha.name,"')\n", sep = "")
+ } else {
+ cat(" '", object@y.name, "'\n", sep = "")
+ }
+ if(length(object@y.values) > 1L){
+ cat(" for ", length(object@y.values)," cross ",
+ "validation runs ", sep = "")
+ } else {
+ if(length(object@y.values[[1L]]) > 1L){
+ cat(" with ", length(object@y.values[[1L]])," data points",
+ sep = "")
+ }
+ }
+ })
+
+
+
+#' @name prediction
+#'
+#' @title Function to create prediction objects
+#'
+#' @description
+#' Every classifier evaluation using ROCR starts with creating a
+#' \code{prediction} object. This function is used to transform the input data
+#' (which can be in vector, matrix, data frame, or list form) into a
+#' standardized format.
+#'
+#' @details
+#' \code{predictions} and \code{labels} can simply be vectors of the same
+#' length. However, in the case of cross-validation data, different
+#' cross-validation runs can be provided as the *columns* of a matrix or
+#' data frame, or as the entries of a list. In the case of a matrix or
+#' data frame, all cross-validation runs must have the same length, whereas
+#' in the case of a list, the lengths can vary across the cross-validation
+#' runs. Internally, as described in section 'Value', all of these input
+#' formats are converted to list representation.
+#'
+#' Since scoring classifiers give relative tendencies towards a negative
+#' (low scores) or positive (high scores) class, it has to be declared
+#' which class label denotes the negative, and which the positive class.
+#' Ideally, labels should be supplied as ordered factor(s), the lower
+#' level corresponding to the negative class, the upper level to the
+#' positive class. If the labels are factors (unordered), numeric,
+#' logical or characters, ordering of the labels is inferred from
+#' R's built-in \code{<} relation (e.g. 0 < 1, -1 < 1, 'a' < 'b',
+#' FALSE < TRUE). Use \code{label.ordering} to override this default
+#' ordering. Please note that the ordering can be locale-dependent
+#' e.g. for character labels '-1' and '1'.
+#'
+#' Currently, ROCR supports only binary classification (extensions toward
+#' multiclass classification are scheduled for the next release,
+#' however). If there are more than two distinct label symbols, execution
+#' stops with an error message. If all predictions use the same two
+#' symbols that are used for the labels, categorical predictions are
+#' assumed. If there are more than two predicted values, but all numeric,
+#' continuous predictions are assumed (i.e. a scoring
+#' classifier). Otherwise, if more than two symbols occur in the
+#' predictions, and not all of them are numeric, execution stops with an
+#' error message.
+#'
+#' @param predictions A vector, matrix, list, or data frame containing the
+#' predictions.
+#' @param labels A vector, matrix, list, or data frame containing the true class
+#' labels. Must have the same dimensions as \code{predictions}.
+#' @param label.ordering The default ordering (cf.details) of the classes can
+#' be changed by supplying a vector containing the negative and the positive
+#' class label.
+#'
+#' @return An S4 object of class \code{prediction}.
+#'
+#' @author
+#' Tobias Sing \email{tobias.sing@gmail.com}, Oliver Sander
+#' \email{osander@gmail.com}
+#' @export
+prediction <- function(predictions, labels, label.ordering=NULL) {
+
+ ## bring 'predictions' and 'labels' into list format,
+ ## each list entry representing one x-validation run
+
+ ## convert predictions into canonical list format
+ if (is.data.frame(predictions)) {
+ names(predictions) <- c()
+ predictions <- as.list(predictions)
+ } else if (is.matrix(predictions)) {
+ predictions <- as.list(data.frame(predictions))
+ names(predictions) <- c()
+ } else if (is.vector(predictions) && !is.list(predictions)) {
+ predictions <- list(predictions)
+ } else if (!is.list(predictions)) {
+ stop("Format of predictions is invalid. It couldn't be coerced to a list.",
+ call. = FALSE)
+ }
+
+ ## convert labels into canonical list format
+ if (is.data.frame(labels)) {
+ names(labels) <- c()
+ labels <- as.list( labels)
+ } else if (is.matrix(labels)) {
+ labels <- as.list( data.frame( labels))
+ names(labels) <- c()
+ } else if ((is.vector(labels) ||
+ is.ordered(labels) ||
+ is.factor(labels)) &&
+ !is.list(labels)) {
+ labels <- list( labels)
+ } else if (!is.list(labels)) {
+ stop("Format of labels is invalid. It couldn't be coerced to a list.",
+ call. = FALSE)
+ }
+
+
+ if(any(vapply(predictions,anyNA, logical(1)))){
+ warnings("'predictions' contains NA. These missing predictions will be removed from evaluation")
+ nonNA_pred <- !is.na(predictions)
+ predictions <- predictions[nonNA_pred]
+ labels <- labels[nonNA_pred]
+ }
+
+
+ ## Length consistency checks
+ if (length(predictions) != length(labels))
+ stop(paste("Number of cross-validation runs must be equal",
+ "for predictions and labels."))
+ if (! all(sapply(predictions, length) == sapply(labels, length)))
+ stop(paste("Number of predictions in each run must be equal",
+ "to the number of labels for each run."))
+
+ ## only keep prediction/label pairs that are finite numbers
+ for (i in 1:length(predictions)) {
+ finite.bool <- is.finite( predictions[[i]] )
+ predictions[[i]] <- predictions[[i]][ finite.bool ]
+ labels[[i]] <- labels[[i]][ finite.bool ]
+ }
+
+ ## abort if 'labels' format is inconsistent across
+ ## different cross-validation runs
+ label.format="" ## one of 'normal','factor','ordered'
+ if (all(sapply( labels, is.factor)) &&
+ !any(sapply(labels, is.ordered))) {
+ label.format <- "factor"
+ } else if (all(sapply( labels, is.ordered))) {
+ label.format <- "ordered"
+ } else if (all(sapply( labels, is.character)) ||
+ all(sapply( labels, is.numeric)) ||
+ all(sapply( labels, is.logical))) {
+ label.format <- "normal"
+ } else {
+ stop(paste("Inconsistent label data type across different",
+ "cross-validation runs."))
+ }
+
+ ## abort if levels are not consistent across different
+ ## cross-validation runs
+ if (! all(sapply(labels, levels)==levels(labels[[1]])) ) {
+ stop(paste("Inconsistent factor levels across different",
+ "cross-validation runs."))
+ }
+
+ ## convert 'labels' into ordered factors, aborting if the number
+ ## of classes is not equal to 2.
+ levels <- c()
+ if ( label.format == "ordered" ) {
+ if (!is.null(label.ordering)) {
+ stop(paste("'labels' is already ordered. No additional",
+ "'label.ordering' must be supplied."))
+ } else {
+ levels <- levels(labels[[1]])
+ }
+ } else {
+ if ( is.null( label.ordering )) {
+ if ( label.format == "factor" ) levels <- sort(levels(labels[[1]]))
+ else levels <- sort( unique( unlist( labels)))
+ } else {
+ ## if (!setequal( levels, label.ordering)) {
+ if (!setequal( unique(unlist(labels)), label.ordering )) {
+ stop("Label ordering does not match class labels.")
+ }
+ levels <- label.ordering
+ }
+ for (i in 1:length(labels)) {
+ if (is.factor(labels))
+ labels[[i]] <- ordered(as.character(labels[[i]]),
+ levels=levels)
+ else labels[[i]] <- ordered( labels[[i]], levels=levels)
+ }
+
+ }
+
+ if (length(levels) != 2) {
+ message <- paste("Number of classes is not equal to 2.\n",
+ "HTRfit currently supports only evaluation of ",
+ "binary classification tasks.",sep="")
+ stop(message)
+ }
+
+ ## determine whether predictions are continuous or categorical
+ ## (in the latter case stop
+ if (!is.numeric( unlist( predictions ))) {
+ stop("Currently, only continuous predictions are supported by HTRfit")
+ }
+
+ ## compute cutoff/fp/tp data
+
+ cutoffs <- list()
+ fp <- list()
+ tp <- list()
+ fn <- list()
+ tn <- list()
+ n.pos <- list()
+ n.neg <- list()
+ n.pos.pred <- list()
+ n.neg.pred <- list()
+ for (i in 1:length(predictions)) {
+ n.pos <- c( n.pos, sum( labels[[i]] == levels[2] ))
+ n.neg <- c( n.neg, sum( labels[[i]] == levels[1] ))
+ ans <- .compute.unnormalized.roc.curve( predictions[[i]], labels[[i]] )
+ cutoffs <- c( cutoffs, list( ans$cutoffs ))
+ fp <- c( fp, list( ans$fp ))
+ tp <- c( tp, list( ans$tp ))
+ fn <- c( fn, list( n.pos[[i]] - tp[[i]] ))
+ tn <- c( tn, list( n.neg[[i]] - fp[[i]] ))
+ n.pos.pred <- c(n.pos.pred, list(tp[[i]] + fp[[i]]) )
+ n.neg.pred <- c(n.neg.pred, list(tn[[i]] + fn[[i]]) )
+ }
+
+
+ return( new("prediction", predictions=predictions,
+ labels=labels,
+ cutoffs=cutoffs,
+ fp=fp,
+ tp=tp,
+ fn=fn,
+ tn=tn,
+ n.pos=n.pos,
+ n.neg=n.neg,
+ n.pos.pred=n.pos.pred,
+ n.neg.pred=n.neg.pred))
+}
+
+## fast fp/tp computation based on cumulative summing
+.compute.unnormalized.roc.curve <- function( predictions, labels ) {
+ ## determine the labels that are used for the pos. resp. neg. class :
+ pos.label <- levels(labels)[2]
+ neg.label <- levels(labels)[1]
+
+ pred.order <- order(predictions, decreasing=TRUE)
+ predictions.sorted <- predictions[pred.order]
+ tp <- cumsum(labels[pred.order]==pos.label)
+ fp <- cumsum(labels[pred.order]==neg.label)
+
+ ## remove fp & tp for duplicated predictions
+ ## as duplicated keeps the first occurrence, but we want the last, two
+ ## rev are used.
+ ## Highest cutoff (Infinity) corresponds to tp=0, fp=0
+ dups <- rev(duplicated(rev(predictions.sorted)))
+ tp <- c(0, tp[!dups])
+ fp <- c(0, fp[!dups])
+ cutoffs <- c(Inf, predictions.sorted[!dups])
+
+ return(list( cutoffs=cutoffs, fp=fp, tp=tp ))
+}
+
+#' @name performance
+#'
+#' @title Function to create performance objects
+#'
+#' @description
+#' All kinds of predictor evaluations are performed using this function.
+#'
+#' @details
+#' Here is the list of available performance measures. Let Y and
+#' \eqn{\hat{Y}}{Yhat} be random variables representing the class and the prediction for
+#' a randomly drawn sample, respectively. We denote by
+#' \eqn{\oplus}{+} and \eqn{\ominus}{-} the positive and
+#' negative class, respectively. Further, we use the following
+#' abbreviations for empirical quantities: P (\# positive
+#' samples), N (\# negative samples), TP (\# true positives), TN (\# true
+#' negatives), FP (\# false positives), FN (\# false negatives).
+#' \describe{
+#' \item{\code{acc}:}{accuracy. \eqn{P(\hat{Y}=Y)}{P(Yhat = Y)}. Estimated
+#' as: \eqn{\frac{TP+TN}{P+N}}{(TP+TN)/(P+N)}.}
+#' \item{\code{err}:}{Error rate. \eqn{P(\hat{Y}\ne Y)}{P(Yhat !=
+#' Y)}. Estimated as: \eqn{\frac{FP+FN}{P+N}}{(FP+FN)/(P+N)}.}
+#' \item{\code{fpr}:}{False positive rate. \eqn{P(\hat{Y}=\oplus | Y =
+#' \ominus)}{P(Yhat = + | Y = -)}. Estimated as:
+#' \eqn{\frac{FP}{N}}{FP/N}.}
+#' \item{\code{fall}:}{Fallout. Same as \code{fpr}.}
+#' \item{\code{tpr}:}{True positive
+#' rate. \eqn{P(\hat{Y}=\oplus|Y=\oplus)}{P(Yhat = + | Y = +)}. Estimated
+#' as: \eqn{\frac{TP}{P}}{TP/P}.}
+#' \item{\code{rec}:}{recall. Same as \code{tpr}.}
+#' \item{\code{sens}:}{sensitivity. Same as \code{tpr}.}
+#' \item{\code{fnr}:}{False negative
+#' rate. \eqn{P(\hat{Y}=\ominus|Y=\oplus)}{P(Yhat = - | Y =
+#' +)}. Estimated as: \eqn{\frac{FN}{P}}{FN/P}.}
+#' \item{\code{miss}:}{Miss. Same as \code{fnr}.}
+#' \item{\code{tnr}:}{True negative rate. \eqn{P(\hat{Y} =
+#' \ominus|Y=\ominus)}{P(Yhat = - | Y = -)}.}
+#' \item{\code{spec}:}{specificity. Same as \code{tnr}.}
+#' \item{\code{ppv}:}{Positive predictive
+#' value. \eqn{P(Y=\oplus|\hat{Y}=\oplus)}{P(Y = + | Yhat =
+#' +)}. Estimated as: \eqn{\frac{TP}{TP+FP}}{TP/(TP+FP)}.}
+#' \item{\code{prec}:}{precision. Same as \code{ppv}.}
+#' \item{\code{npv}:}{Negative predictive
+#' value. \eqn{P(Y=\ominus|\hat{Y}=\ominus)}{P(Y = - | Yhat =
+#' -)}. Estimated as: \eqn{\frac{TN}{TN+FN}}{TN/(TN+FN)}.}
+#' \item{\code{pcfall}:}{Prediction-conditioned
+#' fallout. \eqn{P(Y=\ominus|\hat{Y}=\oplus)}{P(Y = - | Yhat =
+#' +)}. Estimated as: \eqn{\frac{FP}{TP+FP}}{FP/(TP+FP)}.}
+#' \item{\code{pcmiss}:}{Prediction-conditioned
+#' miss. \eqn{P(Y=\oplus|\hat{Y}=\ominus)}{P(Y = + | Yhat =
+#' -)}. Estimated as: \eqn{\frac{FN}{TN+FN}}{FN/(TN+FN)}.}
+#' \item{\code{rpp}:}{Rate of positive predictions. \eqn{P( \hat{Y} =
+#' \oplus)}{P(Yhat = +)}. Estimated as: (TP+FP)/(TP+FP+TN+FN).}
+#' \item{\code{rnp}:}{Rate of negative predictions. \eqn{P( \hat{Y} =
+#' \ominus)}{P(Yhat = -)}. Estimated as: (TN+FN)/(TP+FP+TN+FN).}
+#' \item{\code{phi}:}{Phi correlation coefficient. \eqn{\frac{TP \cdot
+#' TN - FP \cdot FN}{\sqrt{ (TP+FN) \cdot (TN+FP) \cdot (TP+FP)
+#' \cdot (TN+FN)}}}{(TP*TN -
+#' FP*FN)/(sqrt((TP+FN)*(TN+FP)*(TP+FP)*(TN+FN)))}. Yields a
+#' number between -1 and 1, with 1 indicating a perfect
+#' prediction, 0 indicating a random prediction. Values below 0
+#' indicate a worse than random prediction.}
+#' \item{\code{mat}:}{Matthews correlation coefficient. Same as \code{phi}.}
+#' \item{\code{mi}:}{Mutual information. \eqn{I(\hat{Y},Y) := H(Y) -
+#' H(Y|\hat{Y})}{I(Yhat, Y) := H(Y) - H(Y | Yhat)}, where H is the
+#' (conditional) entropy. Entropies are estimated naively (no bias
+#' correction).}
+#' \item{\code{chisq}:}{Chi square test statistic. \code{?chisq.test}
+#' for details. Note that R might raise a warning if the sample size
+#' is too small.}
+#' \item{\code{odds}:}{Odds ratio. \eqn{\frac{TP \cdot TN}{FN \cdot
+#' FP}}{(TP*TN)/(FN*FP)}. Note that odds ratio produces
+#' Inf or NA values for all cutoffs corresponding to FN=0 or
+#' FP=0. This can substantially decrease the plotted cutoff region.}
+#' \item{\code{lift}:}{Lift
+#' value. \eqn{\frac{P(\hat{Y}=\oplus|Y=\oplus)}{P(\hat{Y}=\oplus)}}{P(Yhat = + |
+#' Y = +)/P(Yhat = +)}.}
+#' \item{\code{f}:}{precision-recall F measure (van Rijsbergen, 1979). Weighted
+#' harmonic mean of precision (P) and recall (R). \eqn{F =
+#' \frac{1}{\alpha \frac{1}{P} + (1-\alpha)\frac{1}{R}}}{F = 1/
+#' (alpha*1/P + (1-alpha)*1/R)}. If
+#' \eqn{\alpha=\frac{1}{2}}{alpha=1/2}, the mean is balanced. A
+#' frequent equivalent formulation is
+#' \eqn{F = \frac{(\beta^2+1) \cdot P \cdot R}{R + \beta^2 \cdot
+#' P}}{F = (beta^2+1) * P * R / (R + beta^2 * P)}. In this formulation, the
+#' mean is balanced if \eqn{\beta=1}{beta=1}. Currently, ROCR only accepts
+#' the alpha version as input (e.g. \eqn{\alpha=0.5}{alpha=0.5}). If no
+#' value for alpha is given, the mean will be balanced by default.}
+#' \item{\code{rch}:}{ROC convex hull. A ROC (=\code{tpr} vs \code{fpr}) curve
+#' with concavities (which represent suboptimal choices of cutoff) removed
+#' (Fawcett 2001). Since the result is already a parametric performance
+#' curve, it cannot be used in combination with other measures.}
+#' \item{\code{auc}:}{Area under the ROC curve. This is equal to the value of the
+#' Wilcoxon-Mann-Whitney test statistic and also the probability that the
+#' classifier will score are randomly drawn positive sample higher than a
+#' randomly drawn negative sample. Since the output of
+#' \code{auc} is cutoff-independent, this
+#' measure cannot be combined with other measures into a parametric
+#' curve. The partial area under the ROC curve up to a given false
+#' positive rate can be calculated by passing the optional parameter
+#' \code{fpr.stop=0.5} (or any other value between 0 and 1) to
+#' \code{performance}.}
+#' \item{\code{aucpr}:}{Area under the precision/recall curve. Since the output
+#' of \code{aucpr} is cutoff-independent, this measure cannot be combined
+#' with other measures into a parametric curve.}
+#' \item{\code{prbe}:}{precision-recall break-even point. The cutoff(s) where
+#' precision and recall are equal. At this point, positive and negative
+#' predictions are made at the same rate as their prevalence in the
+#' data. Since the output of
+#' \code{prbe} is just a cutoff-independent scalar, this
+#' measure cannot be combined with other measures into a parametric curve.}
+#' \item{\code{cal}:}{Calibration error. The calibration error is the
+#' absolute difference between predicted confidence and actual reliability. This
+#' error is estimated at all cutoffs by sliding a window across the
+#' range of possible cutoffs. The default window size of 100 can be
+#' adjusted by passing the optional parameter \code{window.size=200}
+#' to \code{performance}. E.g., if for several
+#' positive samples the output of the classifier is around 0.75, you might
+#' expect from a well-calibrated classifier that the fraction of them
+#' which is correctly predicted as positive is also around 0.75. In a
+#' well-calibrated classifier, the probabilistic confidence estimates
+#' are realistic. Only for use with
+#' probabilistic output (i.e. scores between 0 and 1).}
+#' \item{\code{mxe}:}{Mean cross-entropy. Only for use with
+#' probabilistic output. \eqn{MXE :=-\frac{1}{P+N}( \sum_{y_i=\oplus}
+#' ln(\hat{y}_i) + \sum_{y_i=\ominus} ln(1-\hat{y}_i))}{MXE := - 1/(P+N) \sum_{y_i=+}
+#' ln(yhat_i) + \sum_{y_i=-} ln(1-yhat_i)}. Since the output of
+#' \code{mxe} is just a cutoff-independent scalar, this
+#' measure cannot be combined with other measures into a parametric curve.}
+#' \item{\code{rmse}:}{Root-mean-squared error. Only for use with
+#' numerical class labels. \eqn{RMSE:=\sqrt{\frac{1}{P+N}\sum_i (y_i
+#' - \hat{y}_i)^2}}{RMSE := sqrt(1/(P+N) \sum_i (y_i -
+#' yhat_i)^2)}. Since the output of
+#' \code{rmse} is just a cutoff-independent scalar, this
+#' measure cannot be combined with other measures into a parametric curve.}
+#' \item{\code{sar}:}{Score combinining performance measures of different
+#' characteristics, in the attempt of creating a more "robust"
+#' measure (cf. Caruana R., ROCAI2004):
+#' SAR = 1/3 * ( accuracy + Area under the ROC curve + Root
+#' mean-squared error ).}
+#' \item{\code{ecost}:}{Expected cost. For details on cost curves,
+#' cf. Drummond&Holte 2000,2004. \code{ecost} has an obligatory x
+#' axis, the so-called 'probability-cost function'; thus it cannot be
+#' combined with other measures. While using \code{ecost} one is
+#' interested in the lower envelope of a set of lines, it might be
+#' instructive to plot the whole set of lines in addition to the lower
+#' envelope. An example is given in \code{demo(ROCR)}.}
+#' \item{\code{cost}:}{Cost of a classifier when
+#' class-conditional misclassification costs are explicitly given.
+#' Accepts the optional parameters \code{cost.fp} and
+#' \code{cost.fn}, by which the costs for false positives and
+#' negatives can be adjusted, respectively. By default, both are set
+#' to 1.}
+#' }
+#'
+#' @note
+#' Here is how to call \code{performance()} to create some standard
+#' evaluation plots:
+#' \describe{
+#' \item{ROC curves:}{measure="tpr", x.measure="fpr".}
+#' \item{precision/recall graphs:}{measure="prec", x.measure="rec".}
+#' \item{sensitivity/specificity plots:}{measure="sens", x.measure="spec".}
+#' \item{Lift charts:}{measure="lift", x.measure="rpp".}
+#' }
+#'
+#' @param prediction.obj An object of class \code{prediction}.
+#' @param measure Performance measure to use for the evaluation. A complete list
+#' of the performance measures that are available for \code{measure} and
+#' \code{x.measure} is given in the 'Details' section.
+#' @param x.measure A second performance measure. If different from the default,
+#' a two-dimensional curve, with \code{x.measure} taken to be the unit in
+#' direction of the x axis, and \code{measure} to be the unit in direction of
+#' the y axis, is created. This curve is parametrized with the cutoff.
+#' @param ... Optional arguments (specific to individual performance measures).
+#'
+#' @return An S4 object of class \code{performance}.
+#'
+#' @author
+#' Tobias Sing \email{tobias.sing@gmail.com}, Oliver Sander
+#' \email{osander@gmail.com}
+#'
+#' @export
+performance <- function(prediction.obj,
+ measure,
+ x.measure="cutoff",
+ ...) {
+
+ ## define the needed environments
+ envir.list <- .define.environments()
+ long.unit.names <- envir.list$long.unit.names
+ function.names <- envir.list$function.names
+ obligatory.x.axis <- envir.list$obligatory.x.axis
+ optional.arguments <- envir.list$optional.arguments
+ default.values <- envir.list$default.values
+
+ ## abort in case of misuse
+ if (class(prediction.obj) != 'prediction' ||
+ !exists(measure, where=long.unit.names, inherits=FALSE) ||
+ !exists(x.measure, where=long.unit.names, inherits=FALSE)) {
+ stop(paste("Wrong argument types: First argument must be of type",
+ "'prediction'; second and optional third argument must",
+ "be available performance measures!"))
+ }
+
+ ## abort, if attempt is made to use a measure that has an obligatory
+ ## x.axis as the x.measure (cannot be combined)
+ if (exists( x.measure, where=obligatory.x.axis, inherits=FALSE )) {
+ message <- paste("The performance measure",
+ x.measure,
+ "can only be used as 'measure', because it has",
+ "the following obligatory 'x.measure':\n",
+ get( x.measure, envir=obligatory.x.axis))
+ stop(message)
+ }
+
+ ## if measure is a performance measure with obligatory x.axis, then
+ ## enforce this axis:
+ if (exists( measure, where=obligatory.x.axis, inherits=FALSE )) {
+ x.measure <- get( measure, envir=obligatory.x.axis )
+ }
+
+ if (x.measure == "cutoff" ||
+ exists( measure, where=obligatory.x.axis, inherits=FALSE )) {
+
+ ## fetch from '...' any optional arguments for the performance
+ ## measure at hand that are given, otherwise fill up the default values
+ optional.args <- list(...)
+ argnames <- c()
+ if ( exists( measure, where=optional.arguments, inherits=FALSE )) {
+ argnames <- get( measure, envir=optional.arguments )
+ default.arglist <- list()
+ for (i in 1:length(argnames)) {
+ default.arglist <- c(default.arglist,
+ get(paste(measure,":",argnames[i],sep=""),
+ envir=default.values, inherits=FALSE))
+ }
+ names(default.arglist) <- argnames
+
+ for (i in 1:length(argnames)) {
+ templist <- list(optional.args,
+ default.arglist[[i]])
+ names(templist) <- c('arglist', argnames[i])
+
+ optional.args <- do.call('.farg', templist)
+ }
+ }
+ optional.args <- .select.args( optional.args, argnames )
+
+ ## determine function name
+ function.name <- get( measure, envir=function.names )
+
+ ## for each x-validation run, compute the requested performance measure
+ x.values <- list()
+ y.values <- list()
+ for (i in 1:length( prediction.obj@predictions )) {
+ argumentlist <- .sarg(optional.args,
+ predictions= prediction.obj@predictions[[i]],
+ labels= prediction.obj@labels[[i]],
+ cutoffs= prediction.obj@cutoffs[[i]],
+ fp= prediction.obj@fp[[i]],
+ tp= prediction.obj@tp[[i]],
+ fn= prediction.obj@fn[[i]],
+ tn= prediction.obj@tn[[i]],
+ n.pos= prediction.obj@n.pos[[i]],
+ n.neg= prediction.obj@n.neg[[i]],
+ n.pos.pred= prediction.obj@n.pos.pred[[i]],
+ n.neg.pred= prediction.obj@n.neg.pred[[i]])
+
+ ans <- do.call( function.name, argumentlist )
+
+ if (!is.null(ans[[1]])) x.values <- c( x.values, list( ans[[1]] ))
+ y.values <- c( y.values, list( ans[[2]] ))
+ }
+
+ if (! (length(x.values)==0 || length(x.values)==length(y.values)) ) {
+ stop("Consistency error.")
+ }
+
+ ## create a new performance object
+ return( new("performance",
+ x.name = get( x.measure, envir=long.unit.names ),
+ y.name = get( measure, envir=long.unit.names ),
+ alpha.name = "none",
+ x.values = x.values,
+ y.values = y.values,
+ alpha.values = list() ))
+ } else {
+ perf.obj.1 <- performance( prediction.obj, measure=x.measure, ... )
+ perf.obj.2 <- performance( prediction.obj, measure=measure, ... )
+ return( .combine.performance.objects( perf.obj.1, perf.obj.2 ) )
+ }
+}
+
+#' @importFrom stats approxfun
+.combine.performance.objects <- function( p.obj.1, p.obj.2 ) {
+ ## some checks for misusage (in any way, this function is
+ ## only for internal use)
+ if ( p.obj.1@x.name != p.obj.2@x.name ) {
+ stop("Error: Objects need to have identical x axis.")
+ }
+ if ( p.obj.1@alpha.name != "none" || p.obj.2@alpha.name != "none") {
+ stop("Error: At least one of the two objects has already been merged.")
+ }
+ if (length(p.obj.1@x.values) != length(p.obj.2@x.values)) {
+ stop(paste("Only performance objects with identical number of",
+ "cross-validation runs can be combined."))
+ }
+
+ x.values <- list()
+ x.name <- p.obj.1@y.name
+ y.values <- list()
+ y.name <- p.obj.2@y.name
+ alpha.values <- list()
+ alpha.name <- p.obj.1@x.name
+
+ for (i in 1:length( p.obj.1@x.values )) {
+ x.values.1 <- p.obj.1@x.values[[i]]
+ y.values.1 <- p.obj.1@y.values[[i]]
+ x.values.2 <- p.obj.2@x.values[[i]]
+ y.values.2 <- p.obj.2@y.values[[i]]
+
+ ## cutoffs of combined object = merged cutoffs of simple objects
+ cutoffs <- sort( unique( c(x.values.1, x.values.2)), decreasing=TRUE )
+
+ ## calculate y.values at cutoffs using step function
+ y.values.int.1 <- stats::approxfun(x.values.1, y.values.1,
+ method="constant",f=1,rule=2)(cutoffs)
+ y.values.int.2 <- stats::approxfun(x.values.2, y.values.2,
+ method="constant",f=1,rule=2)(cutoffs)
+
+ ## 'approxfun' ignores NA and NaN
+ objs <- list( y.values.int.1, y.values.int.2)
+ objs.x <- list( x.values.1, x.values.2 )
+ na.cutoffs.1.bool <- is.na( y.values.1) & !is.nan( y.values.1 )
+ nan.cutoffs.1.bool <- is.nan( y.values.1)
+ na.cutoffs.2.bool <- is.na( y.values.2) & !is.nan( y.values.2 )
+ nan.cutoffs.2.bool <- is.nan( y.values.2)
+ bools <- list(na.cutoffs.1.bool, nan.cutoffs.1.bool,
+ na.cutoffs.2.bool, nan.cutoffs.2.bool)
+ values <- c(NA,NaN,NA,NaN)
+
+ for (j in 1:4) {
+ for (k in which(bools[[j]])) {
+ interval.max <- objs.x[[ ceiling(j/2) ]][k]
+ interval.min <- -Inf
+ if (k < length(objs.x[[ ceiling(j/2) ]])) {
+ interval.min <- objs.x[[ ceiling(j/2) ]][k+1]
+ }
+ objs[[ ceiling(j/2) ]][cutoffs <= interval.max &
+ cutoffs > interval.min ] <- values[j]
+ }
+ }
+
+ alpha.values <- c(alpha.values, list(cutoffs))
+ x.values <- c(x.values, list(objs[[1]]))
+ y.values <- c(y.values, list(objs[[2]]))
+ }
+
+ return( new("performance",
+ x.name=x.name, y.name=y.name,
+ alpha.name=alpha.name, x.values=x.values,
+ y.values=y.values, alpha.values=alpha.values))
+}
+
+.define.environments <- function() {
+ ## There are five environments: long.unit.names, function.names,
+ ## obligatory.x.axis, optional.arguments, default.values
+
+ ## Define long names corresponding to the measure abbreviations.
+ long.unit.names <- new.env()
+ assign("none","None", envir=long.unit.names)
+ assign("cutoff", "Cutoff", envir=long.unit.names)
+ assign("acc", "accuracy", envir=long.unit.names)
+ assign("err", "Error Rate", envir=long.unit.names)
+ assign("fpr", "False positive rate", envir=long.unit.names)
+ assign("tpr", "True positive rate", envir=long.unit.names)
+ assign("rec", "recall", envir=long.unit.names)
+ assign("sens", "sensitivity", envir=long.unit.names)
+ assign("fnr", "False negative rate", envir=long.unit.names)
+ assign("tnr", "True negative rate", envir=long.unit.names)
+ assign("spec", "specificity", envir=long.unit.names)
+ assign("ppv", "Positive predictive value", envir=long.unit.names)
+ assign("prec", "precision", envir=long.unit.names)
+ assign("npv", "Negative predictive value", envir=long.unit.names)
+ assign("fall", "Fallout", envir=long.unit.names)
+ assign("miss", "Miss", envir=long.unit.names)
+ assign("pcfall", "Prediction-conditioned fallout", envir=long.unit.names)
+ assign("pcmiss", "Prediction-conditioned miss", envir=long.unit.names)
+ assign("rpp", "Rate of positive predictions", envir=long.unit.names)
+ assign("rnp", "Rate of negative predictions", envir=long.unit.names)
+ assign("auc","Area under the ROC curve", envir=long.unit.names)
+ assign("aucpr","Area under the precision/recall curve", envir=long.unit.names)
+ assign("cal", "Calibration error", envir=long.unit.names)
+ assign("mwp", "Median window position", envir=long.unit.names)
+ assign("prbe","precision/recall break-even point", envir=long.unit.names)
+ assign("rch", "ROC convex hull", envir=long.unit.names)
+ assign("mxe", "Mean cross-entropy", envir=long.unit.names)
+ assign("rmse","Root-mean-square error", envir=long.unit.names)
+ assign("phi", "Phi correlation coefficient", envir=long.unit.names)
+ assign("mat","Matthews correlation coefficient", envir=long.unit.names)
+ assign("mi", "Mutual information", envir=long.unit.names)
+ assign("chisq", "Chi-square test statistic", envir=long.unit.names)
+ assign("odds","Odds ratio", envir=long.unit.names)
+ assign("lift", "Lift value", envir=long.unit.names)
+ assign("f","precision-recall F measure", envir=long.unit.names)
+ assign("sar", "SAR", envir=long.unit.names)
+ assign("ecost", "Expected cost", envir=long.unit.names)
+ assign("cost", "Explicit cost", envir=long.unit.names)
+
+ ## Define function names corresponding to the measure abbreviations.
+ function.names <- new.env()
+ assign("acc", ".performance.accuracy", envir=function.names)
+ assign("err", ".performance.error.rate", envir=function.names)
+ assign("fpr", ".performance.false.positive.rate", envir=function.names)
+ assign("tpr", ".performance.true.positive.rate", envir=function.names)
+ assign("rec", ".performance.true.positive.rate", envir=function.names)
+ assign("sens", ".performance.true.positive.rate", envir=function.names)
+ assign("fnr", ".performance.false.negative.rate", envir=function.names)
+ assign("tnr", ".performance.true.negative.rate", envir=function.names)
+ assign("spec", ".performance.true.negative.rate", envir=function.names)
+ assign("ppv", ".performance.positive.predictive.value",
+ envir=function.names)
+ assign("prec", ".performance.positive.predictive.value",
+ envir=function.names)
+ assign("npv", ".performance.negative.predictive.value",
+ envir=function.names)
+ assign("fall", ".performance.false.positive.rate", envir=function.names)
+ assign("miss", ".performance.false.negative.rate", envir=function.names)
+ assign("pcfall", ".performance.prediction.conditioned.fallout",
+ envir=function.names)
+ assign("pcmiss", ".performance.prediction.conditioned.miss",
+ envir=function.names)
+ assign("rpp", ".performance.rate.of.positive.predictions",
+ envir=function.names)
+ assign("rnp", ".performance.rate.of.negative.predictions",
+ envir=function.names)
+ assign("auc", ".performance.auc", envir=function.names)
+ assign("aucpr", ".performance.aucpr", envir=function.names)
+ assign("cal", ".performance.calibration.error", envir=function.names)
+ assign("prbe", ".performance.precision.recall.break.even.point",
+ envir=function.names)
+ assign("rch", ".performance.rocconvexhull", envir=function.names)
+ assign("mxe", ".performance.mean.cross.entropy", envir=function.names)
+ assign("rmse", ".performance.root.mean.squared.error",
+ envir=function.names)
+ assign("phi", ".performance.phi", envir=function.names)
+ assign("mat", ".performance.phi", envir=function.names)
+ assign("mi", ".performance.mutual.information", envir=function.names)
+ assign("chisq", ".performance.chisq", envir=function.names)
+ assign("odds", ".performance.odds.ratio", envir=function.names)
+ assign("lift", ".performance.lift", envir=function.names)
+ assign("f", ".performance.f", envir=function.names)
+ assign("sar", ".performance.sar", envir=function.names)
+ assign("ecost", ".performance.expected.cost", envir=function.names)
+ assign("cost", ".performance.cost", envir=function.names)
+
+ ## If a measure comes along with an obligatory x axis (including "none"),
+ ## list it here.
+ obligatory.x.axis <- new.env()
+ assign("mxe", "none", envir=obligatory.x.axis)
+ assign("rmse", "none", envir=obligatory.x.axis)
+ assign("prbe", "none", envir=obligatory.x.axis)
+ assign("auc", "none", envir=obligatory.x.axis)
+ assign("aucpr", "none", envir=obligatory.x.axis)
+ assign("rch","none", envir=obligatory.x.axis)
+ ## ecost requires probability cost function as x axis, which is handled
+ ## implicitly, not as an explicit performance measure.
+ assign("ecost","none", envir=obligatory.x.axis)
+
+ ## If a measure has optional arguments, list the names of the
+ ## arguments here.
+ optional.arguments <- new.env()
+ assign("cal", "window.size", envir=optional.arguments)
+ assign("f", "alpha", envir=optional.arguments)
+ assign("cost", c("cost.fp", "cost.fn"), envir=optional.arguments)
+ assign("auc", "fpr.stop", envir=optional.arguments)
+
+ ## If a measure has additional arguments, list the default values
+ ## for them here. Naming convention: e.g. "cal" has an optional
+ ## argument "window.size" the key to use here is "cal:window.size"
+ ## (colon as separator)
+ default.values <- new.env()
+ assign("cal:window.size", 100, envir=default.values)
+ assign("f:alpha", 0.5, envir=default.values)
+ assign("cost:cost.fp", 1, envir=default.values)
+ assign("cost:cost.fn", 1, envir=default.values)
+ assign("auc:fpr.stop", 1, envir=default.values)
+
+ list(long.unit.names=long.unit.names, function.names=function.names,
+ obligatory.x.axis=obligatory.x.axis,
+ optional.arguments=optional.arguments,
+ default.values=default.values)
+}
+
+```
+
+```{r function-simulation_report, filename = "simulation_report" }
+
+#' Export the Analysis Report to a File
+#'
+#' This function generates an analysis report by arranging and combining various plots
+#' and tables, and then exports the report to a specified file.
+#'
+#' @param report_file Path to the file where the report will be exported.
+#' @param table_settings A table containing settings and parameters used in the analysis.
+#' @param roc_curve A plot displaying the Receiver Operating Characteristic (ROC) curve.
+#' @param id_plot A plot displaying unique identifiers.
+#' @param counts_plot A plot displaying the gene counts.
+#'
+#'
+#' @importFrom gridExtra arrangeGrob grid.arrange
+#' @importFrom ggplot2 ggsave
+#'
+#'
+#' @return report
+#' @export
+exportReportFile <- function(report_file, table_settings, roc_curve, id_plot, counts_plot){
+
+ left_part <- gridExtra::arrangeGrob(table_settings, roc_curve, counts_plot ,heights = c(1, 1, 1))
+ p2export <- gridExtra::grid.arrange(left_part, id_plot ,ncol = 3, widths = c(1,1,2))
+
+ if (!is.null(report_file)) ggplot2::ggsave(report_file, p2export, height = 10, width = 15)
+
+ return(p2export)
+}
+
+
+#' Generate a Formatted Table as a Grid Graphics Object
+#'
+#' This function generates a formatted table using the provided data frame and returns
+#' it as a grid graphics object.
+#'
+#' @param df The data frame to be converted into a formatted table.
+#'
+#' @return A grid graphics object representing the formatted table.
+#' @export
+#' @importFrom ggplot2 unit
+#' @importFrom gridExtra tableGrob ttheme_minimal
+#' @examples
+#' # Create a sample data frame
+#' sample_data <- data.frame(
+#' Name = c("Alice", "Bob", "Charlie"),
+#' Age = c(25, 30, 28)
+#' )
+#'
+#' # Generate the formatted table
+#' table_grob <- getGrobTable(sample_data)
+getGrobTable <- function(df){
+ theme_custom <- gridExtra::ttheme_minimal(
+ core = list(bg_params = list(fill = c("#F8F9F9", "#E5E8E8"), col=NA)),
+ colhead = list(fg_params=list(col="white", fontface=4L),
+ bg_params = list(fill = "#5D6D7E", col=NA)), base_size = 15)
+ grob_df <- gridExtra::tableGrob(df, rows=NULL,
+ theme = theme_custom,
+ widths = ggplot2::unit(x = c(0.4,0.3), "npc" ) )
+ return(grob_df)
+}
+
+
+
+#' Compute evaluation report for TMB/DESeq2 analysis
+#'
+#' This function computes an evaluation report for TMB/DESeq2 analysis using several graphical
+#' summaries like precision-recall (PR) curve, Receiver operating characteristic (ROC) curve
+#' and others. It takes as input several parameters like TMB results (\code{l_tmb}), DESeq2
+#' result (\code{dds}), mock object (\code{mock_obj}), coefficient (\code{coefficient}) and
+#' alternative hypothesis (\code{alt_hypothesis}). These parameters are processed by various
+#' functions like \code{get_eval_data}, \code{get_pr_object} and \code{get_roc_object} to
+#' perform computations and generate plots.
+#'
+#' @param l_tmb TMB results from analysis.
+#' @param dds DESeq2 results from differential gene expression analysis.
+#' @param mock_obj Mock object that represents the distribution of measurements corresponding
+#' to mock samples.
+#' @param coefficient Fold-change threshold used to define differential expression.
+#' @param alt_hypothesis Alternative hypothesis used for hypothesis testing.
+#' @param alpha_risk parameter that sets the threshold for alpha risk level (default 0.05).
+#' @param palette_color Optional parameter that sets the color palette for plots.
+#' @param ... Additional parameters to be passed to \code{get_pr_curve} and \code{get_roc_curve}.
+#'
+#' @return A list containing the following components:
+#' \item{identity}{A list containing model parameters and dispersion data.}
+#' \item{precision_recall}{A PR curve object generated from TMB and DESeq2 results.}
+#' \item{roc}{A ROC curve object generated from TMB and DESeq2 results.}
+#' \item{counts}{A counts plot generated from mock object.}
+#' @export
+evaluation_report <- function(l_tmb, dds, mock_obj, coefficient, alt_hypothesis, alpha_risk = 0.05, palette_color = NULL, ...) {
+
+ ## -- eval data
+ eval_data <- get_eval_data(l_tmb, dds, mock_obj, coefficient, alt_hypothesis)
+
+ ## -- identity plot
+ #identity_data <- rbind_model_params_and_dispersion(eval_data)
+ params_identity_eval <- eval_identityTerm(eval_data$modelparams)
+ dispersion_identity_eval <- eval_identityTerm(eval_data$modeldispersion)
+
+ ## -- pr curve
+ pr_curve_obj <- get_pr_object(eval_data$modelparams)
+ pr_curve_obj <- get_pr_curve(pr_curve_obj, ...)
+
+ ## -- auc curve
+ roc_curve_obj <- get_roc_object(eval_data$modelparams)
+ roc_curve_obj <- get_roc_curve(roc_curve_obj, ...)
+
+ ## -- acc, recall, sensib, speci, ...
+ metrics_obj <- get_ml_metrics_obj(eval_data$modelparams, alpha_risk )
+ ## -- merge all metrics in one obj
+ model_perf_obj <- get_performances_metrics_obj( params_identity_eval$R2,
+ dispersion_identity_eval$R2,
+ pr_curve_obj,
+ roc_curve_obj,
+ metrics_obj )
+
+ ## -- counts plot
+ counts_violinplot <- counts_plot(mock_obj)
+
+ ## -- clear memory
+ invisible(gc(reset = T, verbose = F, full = T)) ;
+
+ return(
+ list(
+ data = eval_data,
+ identity = list( params = params_identity_eval$p,
+ dispersion = dispersion_identity_eval$p ) ,
+ precision_recall = list( params = pr_curve_obj$byparams$pr_curve,
+ aggregate = pr_curve_obj$aggregate$pr_curve ),
+ roc = list( params = roc_curve_obj$byparams$roc_curve,
+ aggregate = roc_curve_obj$aggregate$roc_curve ),
+ counts = counts_violinplot,
+ performances = model_perf_obj)
+ )
+}
+
+
+
+#' Compute classification and regression performance metrics object
+#'
+#' This function computes metrics object for both classification and regression performance
+#' from evaluation objects generated by \code{evaluation_report} function. Metrics object
+#' contains the by-parameter and aggregate metrics for PR AUC, ROC AUC, R-squared and other
+#' classification metrics for precision, recall, sensitivity, and specificity. The function
+#' takes as input various evaluation objects including R-squared values (\code{r2_params}),
+#' dispersion values (\code{r2_dispersion}), PR object (\code{pr_obj}), ROC object
+#' (\code{roc_obj}), and machine learning performance metrics object (\code{ml_metrics_obj}).
+#' The function generates separate data frames for metric values by parameter value and for the
+#' aggregated metric values.
+#'
+#' @param r2_params R-squared values from model parameters evaluation object.
+#' @param r2_dispersion R-squared values from dispersion evaluation object.
+#' @param pr_obj PR object generated from evaluation report.
+#' @param roc_obj ROC object generated from evaluation report.
+#' @param ml_metrics_obj Machine learning performance metrics object.
+#'
+#' @return A list containing separate data frames for by-parameter and aggregated metric values.
+#' @export
+get_performances_metrics_obj <- function(r2_params , r2_dispersion,
+ pr_obj, roc_obj, ml_metrics_obj ){
+ ## -- by params
+ auc_mtrics_params <- join_dtf(pr_obj$byparams$pr_auc , roc_obj$byparams$roc_auc,
+ k1 = c("from", "description"), k2 = c("from", "description"))
+ metrics_params <- join_dtf(auc_mtrics_params, ml_metrics_obj$byparams,
+ k1 = c("from", "description"), k2 = c("from", "description"))
+ rsquare_mtrics <- rbind(r2_params, r2_dispersion)
+ metrics_params <- join_dtf(metrics_params, rsquare_mtrics,
+ k1 = c("from", "description"), k2 = c("from", "description"))
+ ## -- aggregate
+ auc_mtrics_agg <- join_dtf(pr_obj$aggregate$pr_auc , roc_obj$aggregate$roc_auc,
+ k1 = c("from"), k2 = c("from"))
+ metrics_agg <- join_dtf(auc_mtrics_agg , ml_metrics_obj$aggregate,
+ k1 = c("from"), k2 = c("from"))
+ return(list(byparams = metrics_params, aggregate = metrics_agg ))
+}
+
+
+#' Compute summary metrics on classification results
+#'
+#' This function computes several classification metrics like accuracy, precision, recall,
+#' sensitivity and specificity on classification results. The input to the function is a data frame
+#' (\code{dt}) containing the predicted classification result as \code{y_pred} and the actual
+#' classification as \code{isDE}. The function returns a data frame with the computed metrics.
+#'
+#' @param dt Data frame containing the predicted and actual classification results.
+#'
+#' @return A data frame with the computed classification metrics of accuracy, precision, recall,
+#' sensitivity and specificity.
+#' @export
+compute_metrics_summary <- function(dt) {
+
+ data.frame(
+ accuracy = accuracy( dt$y_pred, dt$isDE ),
+ precision = precision(dt$y_pred, y_true = dt$isDE, positive = "TRUE"),
+ recall = recall(dt$y_pred, y_true = dt$isDE, positive = "TRUE"),
+ sensitivity = sensitivity(dt$y_pred, y_true = dt$isDE, positive = "TRUE"),
+ specificity = specificity(dt$y_pred , y_true = dt$isDE, positive = "TRUE")
+ )
+}
+
+#' Get classification metrics for evaluation object
+#'
+#' This function extracts the classification metrics from an evaluation object generated by
+#' \code{get_eval_metrics} function. It takes as input the identity term of the evaluation object
+#' (\code{evaldata_params}) and an optional risk level for the alpha risk (\code{alpha_risk}).
+#' It retrieves the p-values from the identity term and computes the binary classification
+#' result by thresholding with the alpha risk level. It then computes the classification metrics
+#' using \code{compute_metrics_summary} function separately for each parameter value as well as
+#' for the aggregated results.
+#'
+#' @param evaldata_params Identity term of the evaluation object.
+#' @param alpha_risk parameter that sets the threshold for alpha risk level (default 0.05).
+#' @param col_param parameter that sets the column name for the parameter (default "description").
+#'
+#' @return A list containing separate data frames for classification metrics by parameter value
+#' and for aggregated classification metrics.
+#'
+#' @examples
+#' @importFrom data.table setDT
+#' @export
+get_ml_metrics_obj <- function(evaldata_params, alpha_risk = 0.05, col_param = "description"){
+
+ evaldata_params$y_pred <- evaldata_params$p.adj < alpha_risk
+
+ ## by params
+ dt_evaldata_params <- data.table::setDT(evaldata_params)
+ byparam_metrics <- dt_evaldata_params[, compute_metrics_summary(.SD), by=c("from", col_param), .SDcols=c("y_pred", "isDE")]
+
+ ## aggreg
+ agg_metrics <- dt_evaldata_params[, compute_metrics_summary(.SD), by=c("from"), .SDcols=c("y_pred", "isDE")]
+
+ return(list( byparams = as.data.frame(byparam_metrics), aggregate = as.data.frame(agg_metrics)))
+}
+
+#' Compute evaluation metrics from evaluation object
+#'
+#' This function computes the evaluation metrics from the evaluation object generated by
+#' \code{evaluation_report} function. It retrieves the R2 values from the identity plot,
+#' ROC AUC and PR AUC from ROC and precision-recall curves and combines them into a single
+#' data frame for easier analysis and interpretation.
+#'
+#' @param eval_obj Evaluation object generated from \code{evaluation_report} function.
+#'
+#' @return A data frame containing the R2 values from identity plot, ROC AUC and PR AUC values
+#' from ROC and precision-recall curves.
+#' @export
+get_eval_metrics <- function(eval_obj){
+ data_metrics <- rbind(eval_obj$identity$params$R2, eval_obj$identity$dispersion$R2)
+
+ ## -- rename ROC AUC
+ idx <- names(eval_obj$roc$byparams$roc_auc) == 'AUC'
+ names(eval_obj$roc$byparams$roc_auc)[idx] <- 'roc_AUC'
+
+ ## -- rename precisionrecall AUC
+ idx <- names(eval_obj$precision_recall$byparams$pr_auc) == 'AUC'
+ names(eval_obj$precision_recall$byparams$pr_auc)[idx] <- 'pr_AUC'
+
+ ## -- join data frames
+ data_auc <- join_dtf(eval_obj$roc$byparams$roc_auc, eval_obj$precision_recall$byparams$pr_auc,
+ k1 = c("from", "description"), k2 = c("from", "description") )
+ data_metrics <- join_dtf(data_metrics, data_auc ,
+ k1 = c("from", "description"), k2 = c("from", "description") )
+ return(data_metrics)
+}
+
+
+
+
+
+```
+
+
+
+```{r test-simulation_report}
+
+
+# Test case 1: Testing with a sample data frame
+test_that("Generating a formatted table works correctly", {
+ sample_data <- data.frame(
+ Name = c("Alice", "Bob", "Charlie"),
+ Age = c(25, 30, 28)
+ )
+
+ table_grob <- getGrobTable(sample_data)
+
+ expect_s3_class(table_grob, "gtable")
+})
+
+# Test case 4: Testing with non-numeric values
+test_that("Handling non-numeric values in the data frame", {
+ non_numeric_data <- data.frame(
+ Name = c("Alice", "Bob", "Charlie"),
+ Age = c(25, "N/A", 28)
+)
+
+ table_grob <- getGrobTable(non_numeric_data)
+
+ expect_s3_class(table_grob, "gtable")
+})
+
+```
+
+
+```{r function-evaluation, filement = "evaluation"}
+
+
+
+#' Extracts evaluation data from a list of TMB models.
+#'
+#' This function takes a list of TMB models, performs tidy evaluation, extracts model parameters,
+#' and compares them to the ground truth effects. Additionally, it evaluates and compares dispersion
+#' inferred from TMB with the ground truth gene dispersion. The results are organized in two data frames,
+#' one for model parameters and one for dispersion, both labeled as "HTRfit".
+#'
+#' @param list_tmb A list of TMB models.
+#' @param mock_obj A mock object containing ground truth information.
+#' @param coeff_threshold The coefficient threshold for wald test
+#' @param alt_hypothesis The alternative hypothesis for wald test
+#' @return A list containing data frames for model parameters and dispersion.
+#' @export
+get_eval_data_from_ltmb <- function(list_tmb, mock_obj, coeff_threshold, alt_hypothesis ){
+
+ ## -- reshape 2 dataframe
+ tidyRes <- tidy_results(list_tmb, coeff_threshold, alt_hypothesis)
+
+ ## -- model params
+ formula_used <- list_tmb[[1]]$modelInfo$allForm$formula
+ params_df <- compareInferenceToExpected(tidyRes, mock_obj$groundTruth$effects, formula_used)
+ params_df <- getLabelExpected(params_df, coeff_threshold, alt_hypothesis)
+ params_df$from <- "HTRfit"
+
+ ## -- dispersion
+ dispersion_inferred <- extract_tmbDispersion(list_tmb)
+ dispersion_df <- getDispersionComparison(dispersion_inferred, mock_obj$groundTruth$gene_dispersion)
+ dispersion_df$from <- "HTRfit"
+
+ return(list(modelparams = params_df, modeldispersion = dispersion_df ))
+}
- #-- init
- TMB_comparison_df <- data.frame()
- DESEQ_comparison_df <- data.frame()
- DESEQ_dispersion_df <- data.frame()
- TMB_dispersion_df <- data.frame()
+
+#' Extracts evaluation data from a DESeqDataSet (dds) object.
+#'
+#' This function takes a DESeqDataSet object, performs tidy evaluation, extracts model parameters
+#' (beta in the case of DESeqDataSet), and compares them to the ground truth effects. Additionally,
+#' it evaluates and compares dispersion inferred from DESeqDataSet with the ground truth gene dispersion.
+#' The results are organized in two data frames, one for model parameters and one for dispersion, both #' labeled as "HTRfit".
+#'
+#' @param dds A DESeqDataSet object.
+#' @param mock_obj A mock object containing ground truth information.
+#' @param coeff_threshold The coefficient threshold wald test
+#' @param alt_hypothesis The alternative hypothesis wald test
+#' @return A list containing data frames for model parameters and dispersion.
+#' @export
+get_eval_data_from_dds <- function(dds, mock_obj, coeff_threshold, alt_hypothesis){
+
+ ## -- reshape 2 dataframe
+ tidy_dds <- wrap_dds(dds, coeff_threshold, alt_hypothesis)
+
+ ## -- model params (beta in case of dds)
+ params_df <- inferenceToExpected_withFixedEff(tidy_dds$fixEff, mock_obj$groundTruth$effects)
+ params_df <- getLabelExpected(params_df, coeff_threshold, alt_hypothesis)
+ params_df$component <- NA
+ params_df$group <- NA
+ params_df$from <- "DESeq2"
+
+ ## -- dispersion
+ dispersion_inferred <- extract_ddsDispersion(tidy_dds)
+ dispersion_df <- getDispersionComparison(dispersion_inferred , mock_obj$groundTruth$gene_dispersion)
+ dispersion_df$from <- "DESeq2"
+
+ return(list(modelparams = params_df, modeldispersion = dispersion_df ))
+
+}
+
+
+
+
+#' Combines evaluation data from TMB and DESeqDataSet (dds) objects.
+#'
+#' This function combines model parameters and dispersion data frames from TMB and DESeqDataSet (dds) evaluations.
+#'
+#' @param evaldata_tmb Evaluation data from TMB models.
+#' @param evaldata_dds Evaluation data from DESeqDataSet (dds) object.
+#' @return A list containing combined data frames for model parameters and dispersion.
+#' @export
+rbind_evaldata_tmb_dds <- function(evaldata_tmb, evaldata_dds){
+ ## -- rbind
+ evaldata_dispersion <- rbind(evaldata_tmb$modeldispersion, evaldata_dds$modeldispersion)
+ evaldata_params <- rbind(evaldata_tmb$modelparams, evaldata_dds$modelparams)
+
+ ## -- res
+ return(list(modelparams = evaldata_params, modeldispersion = evaldata_dispersion ))
+}
+
+
+#' Combines model parameters and dispersion data frames.
+#'
+#' This function combines model parameters and dispersion data frames, ensuring proper alignment.
+#'
+#' @param eval_data Evaluation data containing model parameters and dispersion.
+#' @return A combined data frame with model parameters and dispersion.
+#' @export
+rbind_model_params_and_dispersion <- function(eval_data){
+ ## -- split
+ disp_df <- eval_data$modeldispersion
+ params_df <- eval_data$modelparams
+ ## -- merging model and dispersion param
+ disp_df[setdiff(names(params_df), names(disp_df))] <- NA
+ disp_df <- disp_df[names(params_df)]
+ ## -- rbind
+ res_df <- rbind(params_df, disp_df)
+ return(res_df)
+}
+
+
+
+#' Gets evaluation data from both TMB and DESeqDataSet (dds) objects.
+#'
+#' This function retrieves evaluation data from TMB and DESeqDataSet (dds) objects, combining
+#' the results into a list containing data frames for model parameters and dispersion.
+#'
+#' @param l_tmb A list of TMB models (default is NULL).
+#' @param dds A DESeqDataSet object (default is NULL).
+#' @param mock_obj A mock object containing ground truth information.
+#' @param coefficient The coefficient threshold for waldtest.
+#' @param alt_hypothesis The alternative hypothesis for wald test
+#' @return A list containing data frames for model parameters and dispersion.
+#' @export
+get_eval_data <- function(l_tmb = NULL, dds = NULL , mock_obj, coefficient, alt_hypothesis){
+ ## -- init
+ eval_data_tmb <- NULL
+ eval_data_dds <- NULL
+
+ ## -- evaluation data
+ eval_data_tmb <- if (!is.null(l_tmb)) get_eval_data_from_ltmb(l_tmb, mock_obj, coefficient, alt_hypothesis )
+ eval_data_dds <- if (!is.null(dds)) get_eval_data_from_dds(dds, mock_obj, coefficient, alt_hypothesis )
+ ## -- merge/rbind
+ eval_data <- rbind_evaldata_tmb_dds(eval_data_tmb, eval_data_dds)
+
+ return(eval_data)
+}
+
+
+```
+
+```{r test-evaluation}
+
+
+# Test get_eval_data_from_ltmb
+test_that("get_eval_data_from_ltmb returns correct output", {
+
+ input_var_list <- init_variable( name = "varA", mu = 3, sd = 2, level = 3)
+
+ ## -- Required parameters
+ N_GENES = 3
+ MIN_REPLICATES = 3
+ MAX_REPLICATES = 3
+ ########################
+
+ ## -- simulate RNAseq data based on input_var_list, minimum input required
+ ## -- number of replicate randomly defined between MIN_REP and MAX_REP
+ mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES)
+ ## -- data from simulation
+ count_matrix <- mock_data$counts
+ metaData <- mock_data$metadata
+ ##############################
+ ## -- convert counts matrix and samples metadatas in a data frame for fitting
+ data2fit = prepareData2fit(countMatrix = count_matrix,
+ metadata = metaData,
+ normalization = F)
+ l_tmb <- fitModelParallel(formula = kij ~ varA ,
+ data = data2fit,
+ group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"),
+ n.cores = 1)
+
+ eval_data_ltmb <- get_eval_data_from_ltmb(l_tmb, mock_data, 0.27, 'greater')
+ expect_is(eval_data_ltmb, "list")
+ expect_named(eval_data_ltmb, c("modelparams", "modeldispersion"))
+})
+
+# Test get_eval_data_from_dds
+test_that("get_eval_data_from_dds returns correct output", {
+
+ input_var_list <- init_variable( name = "varA", mu = 3, sd = 2, level = 3)
- # -- build data from list_tmb
- if (!is.null(list_tmb)){
- tidyRes <- tidy_results(list_tmb, coeff_threshold, alt_hypothesis)
- formula_used <- list_tmb[[1]]$modelInfo$allForm$formula
- TMB_comparison_df <- compareInferenceToExpected(tidyRes, mock_obj$groundTruth$effects, formula_used)
- TMB_comparison_df <- getLabelExpected(TMB_comparison_df, coeff_threshold, alt_hypothesis)
- TMB_comparison_df$from <- "HTRfit"
- tmb_disp_inferred <- extract_tmbDispersion(list_tmb)
- TMB_dispersion_df <- getDispersionComparison(tmb_disp_inferred, mock_data$groundTruth$gene_dispersion)
- TMB_dispersion_df$from <- 'HTRfit'
- }
+ ## -- Required parameters
+ N_GENES = 100
+ MIN_REPLICATES = 3
+ MAX_REPLICATES = 3
+ ########################
- if (!is.null(dds_obj)){
- deseq2_wrapped <- wrap_dds(dds, coeff_threshold, alt_hypothesis)
- DESEQ_comparison_df <- inferenceToExpected_withFixedEff(deseq2_wrapped$fixEff, mock_obj$groundTruth$effects)
- DESEQ_comparison_df <- getLabelExpected(DESEQ_comparison_df, coeff_threshold, alt_hypothesis)
- DESEQ_comparison_df$from <- "DESeq2"
- DESEQ_comparison_df$component <- NA
- DESEQ_comparison_df$group <- NA
- DESEQ_disp_inferred <- extract_ddsDispersion(deseq2_wrapped)
- DESEQ_dispersion_df <- getDispersionComparison(DESEQ_disp_inferred , mock_data$groundTruth$gene_dispersion)
- DESEQ_dispersion_df$from <- 'DESeq2'
- }
+ ## -- simulate RNAseq data based on input_var_list, minimum input required
+ ## -- number of replicate randomly defined between MIN_REP and MAX_REP
+ mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES)
+ ## -- data from simulation
+ count_matrix <- mock_data$counts
+ metaData <- mock_data$metadata
+ ##############################
- comparison_df <- rbind( DESEQ_comparison_df, TMB_comparison_df )
+ dds <- DESeq2::DESeqDataSetFromMatrix(count_matrix, colData = metaData, ~ varA )
+ dds <- DESeq2::DESeq(dds)
+ eval_data_dds <- get_eval_data_from_dds(dds, mock_data, 0.27, "greater")
- #color2use <- c("#D2B4DE", "#A2D9CE")
- color2use <- c("#500472", "#79cbb8")
- color2use <- color2use[c(!is.null(dds_obj), !is.null(list_tmb))]
+ expect_is(eval_data_dds, "list")
+ expect_named(eval_data_dds, c("modelparams", "modeldispersion"))
+})
- # -- plotting
- roc_curve <- roc_plot(comparison_df, col = "from" ) + ggplot2::scale_color_manual(values = color2use)
- id_plot <- identity_plot(comparison_df, col = "from", pch = "from") + ggplot2::scale_color_manual(values = color2use)
- #metrics_plot <- metrics_plot(list_tmb)
- evalDisp <- evaluateDispersion(TMB_dispersion_df, DESEQ_dispersion_df, color2use )
- dispersion_plot <- evalDisp$disp_plot
- counts_plot <- counts_plot(mock_obj)
+# Test rbind_evaldata_tmb_dds
+test_that("rbind_evaldata_tmb_dds returns correct output", {
- # -- export report
- df_settings <- mock_obj$settings
- grobTableSettings <- getGrobTable(df_settings)
- exportReportFile(report_file, grobTableSettings, roc_curve, dispersion_plot, id_plot, counts_plot)
-
- # -- return
- ret <- list(settings = df_settings, roc_plot = roc_curve,
- dispersionEvaluation = evalDisp, identity_plot = id_plot, counts_plot = counts_plot, data = comparison_df)
- return(ret)
-}
-
-```
-
-
-
-```{r test-simulation_report}
+ input_var_list <- init_variable( name = "varA", mu = 3, sd = 2, level = 3)
+
+ ## -- Required parameters
+ N_GENES = 15
+ MIN_REPLICATES = 3
+ MAX_REPLICATES = 3
+ ########################
+
+ ## -- simulate RNAseq data based on input_var_list, minimum input required
+ ## -- number of replicate randomly defined between MIN_REP and MAX_REP
+ mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES)
+ ## -- data from simulation
+ count_matrix <- mock_data$counts
+ metaData <- mock_data$metadata
+ ##############################
+ ## -- convert counts matrix and samples metadatas in a data frame for fitting
+ data2fit = prepareData2fit(countMatrix = count_matrix,
+ metadata = metaData,
+ normalization = F)
+ l_tmb <- fitModelParallel(formula = kij ~ varA ,
+ data = data2fit,
+ group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"),
+ n.cores = 1)
+ dds <- DESeq2::DESeqDataSetFromMatrix(count_matrix, colData = metaData, ~ varA )
+ dds <- DESeq2::DESeq(dds)
+
+ eval_data_dds <- get_eval_data_from_dds(dds, mock_data, 0.27, "greater")
+ eval_data_ltmb <- get_eval_data_from_ltmb(l_tmb, mock_data, 0.27, 'greater')
+
+ combined_eval_data <- rbind_evaldata_tmb_dds(eval_data_ltmb, eval_data_dds)
+
+ expect_is(combined_eval_data, "list")
+ expect_named(combined_eval_data, c("modelparams", "modeldispersion"))
+})
+# Test rbind_model_params_and_dispersion
+test_that("rbind_model_params_and_dispersion returns correct output", {
+
+ input_var_list <- init_variable( name = "varA", mu = 3, sd = 2, level = 3)
+
+ ## -- Required parameters
+ N_GENES = 100
+ MIN_REPLICATES = 3
+ MAX_REPLICATES = 3
+ ########################
+
+ ## -- simulate RNAseq data based on input_var_list, minimum input required
+ ## -- number of replicate randomly defined between MIN_REP and MAX_REP
+ mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES)
+ ## -- data from simulation
+ count_matrix <- mock_data$counts
+ metaData <- mock_data$metadata
+ ##############################
-# Test case 1: Testing with a sample data frame
-test_that("Generating a formatted table works correctly", {
- sample_data <- data.frame(
- Name = c("Alice", "Bob", "Charlie"),
- Age = c(25, 30, 28)
- )
+ dds <- DESeq2::DESeqDataSetFromMatrix(count_matrix, colData = metaData, ~ varA )
+ dds <- DESeq2::DESeq(dds)
- table_grob <- getGrobTable(sample_data)
- expect_s3_class(table_grob, "gtable")
+ eval_data <- get_eval_data_from_dds(dds, mock_data, 0.27, "greater")
+
+ combined_data <- rbind_model_params_and_dispersion(eval_data)
+
+ expect_is(combined_data, "data.frame")
})
-# Test case 4: Testing with non-numeric values
-test_that("Handling non-numeric values in the data frame", {
- non_numeric_data <- data.frame(
- Name = c("Alice", "Bob", "Charlie"),
- Age = c(25, "N/A", 28)
-)
+# Test get_eval_data
+test_that("get_eval_data returns correct output", {
- table_grob <- getGrobTable(non_numeric_data)
+ input_var_list <- init_variable( name = "varA", mu = 3, sd = 2, level = 3)
- expect_s3_class(table_grob, "gtable")
+ ## -- Required parameters
+ N_GENES = 50
+ MIN_REPLICATES = 3
+ MAX_REPLICATES = 3
+ ########################
+
+ ## -- simulate RNAseq data based on input_var_list, minimum input required
+ ## -- number of replicate randomly defined between MIN_REP and MAX_REP
+ mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES)
+ ## -- data from simulation
+ count_matrix <- mock_data$counts
+ metaData <- mock_data$metadata
+ ##############################
+ ## -- convert counts matrix and samples metadatas in a data frame for fitting
+ data2fit = prepareData2fit(countMatrix = count_matrix,
+ metadata = metaData,
+ normalization = F)
+ l_tmb <- fitModelParallel(formula = kij ~ varA ,
+ data = data2fit,
+ group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"),
+ n.cores = 1)
+ dds <- DESeq2::DESeqDataSetFromMatrix(count_matrix, colData = metaData, ~ varA )
+ dds <- DESeq2::DESeq(dds)
+
+
+ eval_data <- get_eval_data(l_tmb, dds, mock_data, 0.27, "greater")
+
+ expect_is(eval_data, "list")
+ expect_named(eval_data, c("modelparams", "modeldispersion"))
+ expect_equal(unique(eval_data$modelparams$from), c("HTRfit", "DESeq2"))
+
+
+ ## -- dds == NULL
+ eval_data <- get_eval_data(l_tmb, NULL, mock_data, 0.27, "greater")
+ expect_is(eval_data, "list")
+ expect_named(eval_data, c("modelparams", "modeldispersion"))
+ expect_equal(unique(eval_data$modelparams$from), c("HTRfit"))
+
+
+ ## -- l_tmb == NULL
+ eval_data <- get_eval_data(NULL, dds, mock_data, 0.27, "greater")
+ expect_is(eval_data, "list")
+ expect_named(eval_data, c("modelparams", "modeldispersion"))
+ expect_equal(unique(eval_data$modelparams$from), c("DESeq2"))
+
})
+
+
```
@@ -6957,474 +9097,6 @@ test_that("calculate_actualMixed calculates actual mixed effects as expected", {
```
-# High-Throughput RNA-seq model fit
-
-In the realm of RNAseq analysis, various key experimental parameters play a crucial role in influencing the statistical power to detect expression changes. Parameters such as sequencing depth, the number of replicates, and more have a significant impact. To navigate the selection of optimal values for these experimental parameters, we introduce a comprehensive statistical framework known as **HTRfit**, underpinned by computational simulation. **HTRfit** serves as a versatile tool, not only for simulation but also for conducting differential expression analysis. It facilitates this analysis by fitting Generalized Linear Models (GLMs) with multiple variables, which could encompass genotypes, environmental factors, and more. These GLMs are highly adaptable, allowing the incorporation of fixed effects, mixed effects, and interactions between variables.
-
-
-# Initialize variable to simulate
-
-The `init_variable()` function, which is a key tool for defining the variables in your experimental design. You can specify the variables' names and the size of the effects involved. By manually setting the effect of a variable, you make it a fixed effect, while random effect definitions can make it either fixed or mixed.
-
-## Manually init my first variable
-
-The `init_variable()` function allows for precise control over the variables in your experimental design.
-In this example, we manually initialize **varA** with specifics size effects (mu) and levels.
-
-
-```{r example-init_variable_man, warning=FALSE, message=FALSE}
-input_var_list <- init_variable( name = "varA", mu = c(0.2, 4, -3), level = 3)
-```
-
-
-## Randomly init my first variable
-
-Alternatively, you can randomly initialize **varA** by specifying a mean (mu) and standard deviation (sd).
-This introduces variability into **varA**, making it either a fixed or mixed effect in your design.
-
-```{r example-init_variable_rand, warning=FALSE, message=FALSE}
-input_var_list <- init_variable( name = "varA", mu = 10, sd = 0.2, level = 5)
-```
-
-
-## Randomly init several variables
-
-You can also initialize multiple variables, such as **varA** and **varB**, with random values.
-This flexibility allows you to create diverse experimental designs.
-
-```{r example-init_variable_mult, warning=FALSE, message=FALSE}
-input_var_list <- init_variable( name = "varA", mu = 10, sd = 0.2, level = 5) %>%
- init_variable( name = "varB", mu = -3, sd = 0.34, level = 2)
-```
-
-## Add interaction between variable
-
-Similarly to `init_variable()`, `add_interaction()` allow to init an interaction between variable.
-
-In this example, we initialize **varA** and **varB**, and create an interaction between **varA**, and **varB** using `add_interaction()`.
-
-```{r example-add_interaction, warning=FALSE, message=FALSE}
-input_var_list <- init_variable( name = "varA", mu = 3, sd = 0.2, level = 2) %>%
- init_variable( name = "varB", mu = 2, sd = 0.43, level = 2) %>%
- add_interaction( between_var = c("varA", "varB"), mu = 0.44, sd = 0.2)
-```
-
-
-## Initialized a complex design
-
-Interactions can involve a maximum of three variables, such as **varA**, **varB**, and **varC**.
-
-```{r example-add_interaction_complex, eval=FALSE, message=FALSE, warning=FALSE, include=TRUE}
-## -- example not evaluate in the vignette
-input_var_list <- init_variable( name = "varA", mu = 5, sd = 0.2, level = 2) %>%
- init_variable( name = "varB", mu = 1, sd = 0.78, level = 2) %>%
- init_variable( name = "varC", mu = c(2, 3), sd = NA, level = 2) %>%
- add_interaction( between_var = c("varA", "varC"), mu = 0.44, sd = 0.2) %>%
- add_interaction( between_var = c("varA", "varB"), mu = 0.43, sd = 0.37) %>%
- add_interaction( between_var = c("varB", "varC"), mu = -0.33, sd = 0.12) %>%
- add_interaction( between_var = c("varA", "varB" ,"varC"), mu = 0.87, sd = 0.18)
-```
-
-
-# Simulate RNAseq data
-
-In this section, you will explore how to generate RNAseq data based on the previously defined input variables. The `mock_rnaseq()` function enables you to manage parameters in your RNAseq design, including the number of genes, the minimum and maximum number of replicates within your experimental setup. You can also adjust the sequencing depth, the basal gene expression, and the gene dispersion used for simulating counts.
-
-## Minimal example
-
-```{r example-mock_rnaseq_min, warning=FALSE, message=FALSE}
-## -- Required parameters
-N_GENES = 30
-MIN_REPLICATES = 2
-MAX_REPLICATES = 10
-########################
-
-## -- simulate RNAseq data based on input_var_list, minimum input required
-## -- number of replicate randomly defined between MIN_REP and MAX_REP
-mock_data <- mock_rnaseq(input_var_list, N_GENES,
- min_replicates = MIN_REPLICATES,
- max_replicates = MAX_REPLICATES)
-
-## -- simulate RNAseq data based on input_var_list, minimum input required
-## -- Same number of repicates between conditions
-mock_data <- mock_rnaseq(input_var_list, N_GENES,
- min_replicates = MAX_REPLICATES,
- max_replicates = MAX_REPLICATES)
-```
-
-
-## Scaling genes counts with sequencing depth
-
-Sequencing depth is a critical parameter affecting the statistical power of an RNAseq analysis. With the `sequencing_depth` option in the `mock_rnaseq()` function, you have the ability to control this parameter.
-
-```{r example-mock_rnaseq_seqDepth, warning=FALSE, message=FALSE}
-## -- Required parameters
-N_GENES = 30
-MIN_REPLICATES = 2
-MAX_REPLICATES = 10
-########################
-
-SEQ_DEPTH = c(100000, 5000000, 10000000)## -- Possible number of reads/sample
-SEQ_DEPTH = 10000000 ## -- all samples have same number of reads
-mock_data <- mock_rnaseq(input_var_list, N_GENES,
- min_replicates = MIN_REPLICATES,
- max_replicates = MAX_REPLICATES,
- sequencing_depth = SEQ_DEPTH)
-```
-
-## Set gene dispersion
-
-The dispersion parameter ($\alpha_i$), characterizes the relationship between the variance of the observed count and its mean value. In simple terms, it quantifies how much we expect the observed count to deviate from the mean value. You can specify the dispersion for individual genes using the dispersion parameter.
-
-```{r example-mock_rnaseq_disp, warning=FALSE, message=FALSE}
-
-## -- Required parameters
-N_GENES = 30
-MIN_REPLICATES = 2
-MAX_REPLICATES = 4
-########################
-
-DISP = 0.1 ## -- Same dispersion for each genes
-DISP = 1000 ## -- Same dispersion for each genes
-DISP = runif(N_GENES, 0, 1000) ## -- Dispersion can vary between genes
-mock_data <- mock_rnaseq(input_var_list, N_GENES,
- min_replicates = MIN_REPLICATES,
- max_replicates = MAX_REPLICATES,
- dispersion = DISP )
-
-```
-
-
-
-## Set basal gene expression
-
-The basal gene expression parameter, accessible through the basal_expression option, allows you to control the fundamental baseline gene expression level. It lets you adjust the expected count when no other factors are influencing gene expression, making it a key factor for simulating RNAseq data that aligns with your experimental design.
-
-```{r example-mock_rnaseq_bexpr, warning=FALSE, message=FALSE}
-## -- Required parameters
-N_GENES = 50
-MIN_REPLICATES = 10
-MAX_REPLICATES = 10
-########################
-
-BASAL_EXPR = -3 ## -- Value can be negative to simulate low expressed gene
-BASAL_EXPR = 2 ## -- Same basal gene expression for the N_GENES
-BASAL_EXPR = c( -3, -1, 2, 8, 9, 10 ) ## -- Basal expression can vary between genes
-mock_data <- mock_rnaseq(input_var_list, N_GENES,
- min_replicates = MIN_REPLICATES,
- max_replicates = MAX_REPLICATES,
- basal_expression = BASAL_EXPR)
-
-## -- output list attributes
-names(mock_data)
-```
-
-# Theory behind HTRfit simulation
-
-
-
-<div id="bg" align="center">
- <img src="./figs/htrfit_workflow.png" width="500" height="300">
-</div>
-
-
-In this modeling framework, counts denoted as $K_{ij}$ for gene i and sample j are generated using a negative binomial distribution. The negative binomial distribution considers a fitted mean $\mu_{ij}$ and a gene-specific dispersion parameter $\alpha_i$.
-
-The fitted mean $\mu_{ij}$ is determined by a parameter, $q_{ij}$, which is proportionally related to the sum of all effects specified using `init_variable()` or `add_interaction()`. If basal gene expressions are provided, the $\mu_{ij}$ values are scaled accordingly using the gene-specific basal expression value ($bexpr_i$).
-
-Furthermore, the coefficients $\beta_i$ represent the natural logarithm fold changes for gene i across each column of the model matrix X. The dispersion parameter $\alpha_i$ plays a crucial role in defining the relationship between the variance of observed counts and their mean value. In simpler terms, it quantifies how far we expect observed counts to deviate from the mean value.
-
-
-
-# Fitting models
-
-## Prepare data for fitting
-
-The `prepareData2fit()` function serves the purpose of converting the counts matrix and sample metadata into a dataframe that is compatible with downstream **HTRfit** functions designed for model fitting. This function also includes an option to perform median ratio normalization on the data counts.
-
-
-```{r example-prepareData, warning=FALSE, message=FALSE}
-## -- data from simulation or real data
-count_matrix <- mock_data$counts
-metaData <- mock_data$metadata
-##############################
-
-## -- convert counts matrix and samples metadatas in a data frame for fitting
-data2fit = prepareData2fit(countMatrix = count_matrix,
- metadata = metaData,
- normalization = F)
-
-
-## -- median ratio normalization
-data2fit = prepareData2fit(countMatrix = count_matrix,
- metadata = metaData,
- normalization = T,
- response_name = "kij")
-
-## -- output
-head(data2fit)
-```
-
-## Fit model from your data
-
-The `fitModelParallel()` function enables independent model fitting for each gene. The number of threads used for this process can be controlled by the `n.cores` parameter.
-
-```{r example-fitModelParallel, warning=FALSE, message=FALSE}
-l_tmb <- fitModelParallel(formula = kij ~ varA,
- data = data2fit,
- group_by = "geneID",
- family = glmmTMB::nbinom2(link = "log"),
- n.cores = 1)
-```
-
-
-## Use mixed effect in your model
-
-**HTRfit** uses the **glmmTMB** functions for model fitting algorithms. This choice allows for the utilization of random effects within your formula design. For further details on how to specify your model, please refer to the [mixed model documentation](https://rdrr.io/cran/glmmTMB/man/glmmTMBControl.html).
-
-
-```{r example-fitModelParallel_mixed, warning=FALSE, message=FALSE}
-l_tmb <- fitModelParallel(formula = kij ~ varA + ( 1 | varB ),
- data = data2fit,
- group_by = "geneID",
- family = glmmTMB::nbinom2(link = "log"),
- n.cores = 1)
-```
-
-## Additional settings
-
-The function provides precise control over model settings for fitting optimization, including options for specifying the [model family](https://www.rdocumentation.org/packages/stats/versions/3.6.2/topics/family) and [model control setting](https://rdrr.io/cran/glmmTMB/man/glmmTMBControl.html). By default, a Gaussian family model is fitted, but for RNA-seq data, it is highly recommended to specify `family = glmmTMB::nbinom2(link = "log")`.
-
-
-```{r example-fitModelParallel_addSet, warning=FALSE, message=FALSE}
-l_tmb <- fitModelParallel(formula = kij ~ varA,
- data = data2fit,
- group_by = "geneID",
- n.cores = 1,
- family = glmmTMB::nbinom2(link = "log"),
- control = glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e5,
- eval.max=1e5)))
-```
-
-## Not only RNAseq data
-
-As the model family can be customized, HTRfit is not exclusively tailored for RNA-seq data.
-
-```{r example-fitModelParallel_nonRNA, warning=FALSE, message=FALSE, eval=FALSE}
-## -- example not evaluate in the vignette
-data("iris")
-l_tmb <- fitModelParallel(formula = Sepal.Length ~ Sepal.Width + Petal.Length + Petal.Width ,
- data = iris,
- group_by = "Species",
- family = gaussian(),
- n.cores = 1)
-```
-
-## Update fit
-
-The `updateParallel()` function updates and re-fits a model for each gene. It offers options similar to those in `fitModelParallel()`.
-
-```{r example-update, warning=FALSE, message=FALSE}
-## -- update your fit modifying the model family
-l_tmb <- updateParallel(formula = kij ~ varA,
- list_tmb = l_tmb ,
- family = gaussian(),
- n.cores = 1)
-
-## -- update fit using additional model control settings
-l_tmb <- updateParallel(formula = kij ~ varA ,
- list_tmb = l_tmb ,
- family = gaussian(),
- n.cores = 1,
- control = glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,
- eval.max=1e3)))
-
-
-## -- update your model formula and your family model
-l_tmb <- updateParallel(formula = kij ~ varA + varB + varA:varB ,
- list_tmb = l_tmb ,
- family = glmmTMB::nbinom2(link = "log"),
- n.cores = 1)
-
-## -- output
-l_tmb$gene1
-```
-
-## Plot fit metrics
-
-Visualizing fit metrics is essential for evaluating your models. Here, we show you how to generate various plots to assess the quality of your models. You can explore all metrics or focus on specific aspects like dispersion and log-likelihood.
-
-```{r example-plotMetrics, warning=FALSE, message=FALSE, fig.align='center', fig.height=4, fig.width=6}
-## -- plot all metrics
-metrics_plot(list_tmb = l_tmb)
-```
-
-
-```{r example-plotMetricsFocus, warning=FALSE, message=FALSE, fig.align='center', fig.height=3, fig.width=4}
-## -- Focus on metrics
-metrics_plot(list_tmb = l_tmb, focus = c("dispersion", "logLik"))
-```
-
-## Anova to select the best model
-
-
-Utilizing the `anovaParallel()` function enables you to perform model selection by assessing the significance of the fixed effects. You can also include additional parameters like type. For more details, refer to [car::Anova](https://rdrr.io/cran/car/man/Anova.html).
-
-```{r example-anova, warning=FALSE, message=FALSE}
-## -- update your fit modifying the model family
-l_anova <- anovaParallel(list_tmb = l_tmb)
-
-## -- additional settings
-l_anova <- anovaParallel(list_tmb = l_tmb, type = "III" )
-
-## -- output
-l_anova$gene1
-```
-
-
-# Simulation evaluation report
-
-In this section, we delve into the evaluation of your simulation results. The `simulationReport()` function provide valuable insights into the performance of your simulated data and models.
-
-```{r example-simulationReport, warning = FALSE, message = FALSE, results='hide', fig.keep='none'}
-## -- get simulation/fit evaluation
-resSimu <- simulationReport(mock_data,
- list_tmb = l_tmb,
- coeff_threshold = 0.4,
- alt_hypothesis = "greaterAbs")
-```
-
-## Identity plot
-
-The identity plot, generated by the `simulationReport()` function, provides a visual means to compare the effects used in the simulation (actual effects) with those inferred by the model. This graphical representation facilitates the assessment of the correspondence between the values of the simulated effects and those estimated by the model, allowing for a visual analysis of the model's goodness of fit to the simulated data.
-
-
-```{r example-simulationReport_plotID, warning = FALSE, message = FALSE, fig.align='center', fig.height=4, fig.width=5}
-resSimu$identity_plot
-
-```
-
-## Dispersion plot
-
-The dispersion plot, generated by the `simulationReport()` function, offers a visual comparison of the dispersion parameters used in the simulation \(\alpha_i\) with those estimated by the model. This graphical representation provides an intuitive way to assess the alignment between the simulated dispersion values and the model-inferred values, enabling a visual evaluation of how well the model captures the underlying data characteristics.
-
-The area under the ROC curve (AUC) provides a single metric that summarizes the model's overall performance in distinguishing between differentially expressed and non-differentially expressed genes. A higher AUC indicates better model performance.
-
-```{r example-simulationReport_plotDisp, warning = FALSE, message = FALSE, fig.align='center', fig.height=4, fig.width=5}
-resSimu$dispersionEvaluation$disp_plot
-```
-
-## ROC curve
-
-The Receiver Operating Characteristic (ROC) curve is a valuable tool for assessing the performance of classification models, particularly in the context of identifying differentially expressed genes. It provides a graphical representation of the model's ability to distinguish between genes that are differentially expressed and those that are not, by varying the `coeff_threshold` and the `alt_hypothesis` parameters.
-
-```{r example-simulationReport_plotRoc, warning = FALSE, message = FALSE, fig.align='center', fig.height=4, fig.width=5}
-resSimu$roc_plot
-```
-
-## Compare HTRfit with DESeq2
-
-**HTRfit** offers a wrapper for **DESeq2** outputs. This functionality allows users to seamlessly integrate the results obtained from **DESeq2** into the **HTRfit** analysis pipeline. By doing so, you can readily compare the performance of **HTRfit** with **DESeq2** on your RNAseq data. This comparative analysis aids in determining which tool performs better for your specific research goals and dataset
-
-```{r example-ddsComparison, warning = FALSE, message = FALSE, results='hide', fig.keep='none'}
-## -- DESeq2
-library(DESeq2)
-dds <- DESeq2::DESeqDataSetFromMatrix(
- countData = count_matrix,
- colData = metaData,
- design = ~ varA + varB + varA:varB )
-dds <- DESeq2::DESeq(dds, quiet = TRUE)
-
-
-## -- get simulation/fit evaluation
-resSimu <- simulationReport(mock_data,
- list_tmb = l_tmb,
- dds_obj = dds,
- coeff_threshold = 0.4,
- alt_hypothesis = "greaterAbs")
-```
-
-```{r example-outputResSimu, warning = FALSE, message = FALSE, fig.align='center', fig.height=4, fig.width=5}
-## -- identity plot
-resSimu$identity_plot
-## -- dispersion
-resSimu$dispersionEvaluation$disp_plot
-## -- roc curve
-resSimu$roc_plot
-```
-
-## Focus evaluation on a subset of genes
-
-In this section, we showcase the assessment of model performance on a subset of genes. Specifically, we focus on evaluating genes with low expression levels, identified by their basal expression ($bexpr_i$) initialized below 0 during the simulation.
-
-```{r example-subsetGenes, warning = FALSE, message = FALSE, results='hide', fig.keep='none'}
-## -- Focus on low expressed genes
-low_expressed_df <- mock_data$groundTruth$effects[ mock_data$groundTruth$effects$basalExpr < 0, ]
-l_genes <- unique(low_expressed_df$geneID)
-mock_lowExpressed <- subsetGenes(l_genes, mock_data)
-
-
-## -- get simulation/fit evaluation
-resSimu <- simulationReport(mock_lowExpressed,
- list_tmb = l_tmb,
- dds_obj = dds,
- coeff_threshold = 0.4,
- alt_hypothesis = "greaterAbs")
-```
-
-As we compare this evaluation to the previous one, we observe a reduction in the AUC for both **HTRfit** and **DESeq2** inferences.
-
-```{r example-subsetGenes_rocPlot, warning=FALSE, message=FALSE, fig.align='center', fig.height=4, fig.width=5}
-## -- roc curve
-resSimu$roc_plot
-```
-
-# Evaluate model inference involving mixed effects
-
-For certain experimental scenarios, such as those involving a high number of levels or longitudinal data, the utilization of mixed effects within your design formula can be beneficial. The **HTRfit** simulation framework also offers the capability to assess this type of design formula.
-
-```{r example-evalMixed, warning = FALSE, message = FALSE, results='hide', fig.keep='none'}
-## -- init a design with a high number of levels
-input_var_list <- init_variable( name = "varA", mu = 0, sd = 0.29, level = 60) %>%
- init_variable( name = "varB", mu = 0.27, sd = 0.6, level = 2) %>%
- add_interaction( between_var = c("varA", "varB"), mu = 0.44, sd = 0.89)
-## -- simulate RNAseq data
-mock_data <- mock_rnaseq(input_var_list,
- n_genes = 30,
- min_replicates = 10,
- max_replicates = 10,
- basal_expression = 5 )
-## -- prepare data & fit a model with mixed effect
-data2fit = prepareData2fit(countMatrix = mock_data$counts,
- metadata = mock_data$metadata,
- normalization = F)
-l_tmb <- fitModelParallel(formula = kij ~ varB + (varB | varA),
- data = data2fit,
- group_by = "geneID",
- family = glmmTMB::nbinom2(link = "log"),
- n.cores = 1)
-## -- output
-l_tmb$gene1
-## -- evaluation
-resSimu <- simulationReport(mock_data,
- list_tmb = l_tmb,
- coeff_threshold = 0.27,
- alt_hypothesis = "greater")
-```
-
-```{r example-outputResSimuMixed, warning = FALSE, message = FALSE, fig.align='center', fig.height=4, fig.width=5}
-## -- identity plot
-resSimu$identity_plot
-## -- dispersion
-resSimu$dispersionEvaluation$disp_plot
-## -- roc curve
-resSimu$roc_plot
-```
-
-
-# About mixed model evaluation
-
-**HTRfit** offers a versatile simulation framework capable of fitting various types of models involving mixed effects, thanks to its implementation of **glmmTMB**. By combining the functionalities of `init_variable()` and `add_interaction()`, **HTRfit** enables the simulation of even the most complex experimental designs. However, it's important to note that as of now, HTRfit supports the evaluation of only *Type I* mixed models. In this context, *Type I* models are defined as those that follow the structure: `~ varA + (1 | varB)` or `~ varA + (varA | varB)`. Models not conforming to this specific form cannot be evaluated using **HTRfit's** current implementation. Nonetheless, you are welcome to extend its capabilities by implementing support for additional model types.
```{r development-inflate, eval=FALSE}
diff --git a/man/AUC.Rd b/man/AUC.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..cf85027e2d7474b1f5f0de29a716bf3c4d282d4e
--- /dev/null
+++ b/man/AUC.Rd
@@ -0,0 +1,25 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/mlmetrics.R
+\name{AUC}
+\alias{AUC}
+\title{Area Under the Receiver Operating Characteristic Curve (ROC AUC)}
+\usage{
+AUC(y_pred, y_true)
+}
+\arguments{
+\item{y_pred}{Predicted probabilities vector, as returned by a classifier}
+
+\item{y_true}{Ground truth (correct) 0-1 labels vector}
+}
+\value{
+Area Under the ROC Curve (ROC AUC)
+}
+\description{
+Compute the Area Under the Receiver Operating Characteristic Curve (ROC AUC) from prediction scores.
+}
+\examples{
+data(cars)
+logreg <- glm(formula = vs ~ hp + wt,
+ family = binomial(link = "logit"), data = mtcars)
+AUC(y_pred = logreg$fitted.values, y_true = mtcars$vs)
+}
diff --git a/man/Area_Under_Curve.Rd b/man/Area_Under_Curve.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..84894e1905eb0317b11163afb2b345c70b51113d
--- /dev/null
+++ b/man/Area_Under_Curve.Rd
@@ -0,0 +1,33 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/mlmetrics.R
+\name{Area_Under_Curve}
+\alias{Area_Under_Curve}
+\title{Calculate the Area Under the Curve}
+\usage{
+Area_Under_Curve(
+ x,
+ y,
+ method = c("trapezoid", "step", "spline"),
+ na.rm = FALSE
+)
+}
+\arguments{
+\item{x}{the x-points of the curve}
+
+\item{y}{the y-points of the curve}
+
+\item{method}{can be "trapezoid" (default), "step" or "spline"}
+
+\item{na.rm}{a logical value indicating whether NA values should be stripped before the computation proceeds}
+}
+\value{
+Area Under the Curve (AUC)
+}
+\description{
+Calculate the area under the curve.
+}
+\examples{
+x <- seq(0, pi, length.out = 200)
+plot(x = x, y = sin(x), type = "l")
+Area_Under_Curve(x = x, y = sin(x), method = "trapezoid", na.rm = TRUE)
+}
diff --git a/man/ConfusionDF.Rd b/man/ConfusionDF.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..5003f93fa7f053f048e71dee369ce4480be9cf66
--- /dev/null
+++ b/man/ConfusionDF.Rd
@@ -0,0 +1,27 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/mlmetrics.R
+\name{ConfusionDF}
+\alias{ConfusionDF}
+\title{Confusion Matrix (Data Frame Format)}
+\usage{
+ConfusionDF(y_pred, y_true)
+}
+\arguments{
+\item{y_pred}{Predicted labels vector, as returned by a classifier}
+
+\item{y_true}{Ground truth (correct) 0-1 labels vector}
+}
+\value{
+a data.frame of Confusion Matrix
+}
+\description{
+Compute data frame format confusion matrix for internal usage.
+}
+\examples{
+data(cars)
+logreg <- glm(formula = vs ~ hp + wt,
+ family = binomial(link = "logit"), data = mtcars)
+pred <- ifelse(logreg$fitted.values < 0.5, 0, 1)
+ConfusionDF(y_pred = pred, y_true = mtcars$vs)
+}
+\keyword{internal}
diff --git a/man/ConfusionMatrix.Rd b/man/ConfusionMatrix.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..f8b9c41b48bd70151c92874fb6752fb78967bcf5
--- /dev/null
+++ b/man/ConfusionMatrix.Rd
@@ -0,0 +1,26 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/mlmetrics.R
+\name{ConfusionMatrix}
+\alias{ConfusionMatrix}
+\title{Confusion Matrix}
+\usage{
+ConfusionMatrix(y_pred, y_true)
+}
+\arguments{
+\item{y_pred}{Predicted labels vector, as returned by a classifier}
+
+\item{y_true}{Ground truth (correct) 0-1 labels vector}
+}
+\value{
+a table of Confusion Matrix
+}
+\description{
+Compute confusion matrix to evaluate the accuracy of a classification.
+}
+\examples{
+data(cars)
+logreg <- glm(formula = vs ~ hp + wt,
+ family = binomial(link = "logit"), data = mtcars)
+pred <- ifelse(logreg$fitted.values < 0.5, 0, 1)
+ConfusionMatrix(y_pred = pred, y_true = mtcars$vs)
+}
diff --git a/man/PRAUC.Rd b/man/PRAUC.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..ab39fb27ad60a84f50b7b2dc5ef7094976c1e59c
--- /dev/null
+++ b/man/PRAUC.Rd
@@ -0,0 +1,25 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/mlmetrics.R
+\name{PRAUC}
+\alias{PRAUC}
+\title{Area Under the precision-recall Curve (PR AUC)}
+\usage{
+PRAUC(y_pred, y_true)
+}
+\arguments{
+\item{y_pred}{Predicted probabilities vector, as returned by a classifier}
+
+\item{y_true}{Ground truth (correct) 0-1 labels vector}
+}
+\value{
+Area Under the PR Curve (PR AUC)
+}
+\description{
+Compute the Area Under the precision-recall Curve (PR AUC) from prediction scores.
+}
+\examples{
+data(cars)
+logreg <- glm(formula = vs ~ hp + wt,
+ family = binomial(link = "logit"), data = mtcars)
+PRAUC(y_pred = logreg$fitted.values, y_true = mtcars$vs)
+}
diff --git a/man/accuracy.Rd b/man/accuracy.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..b6a13ec8b956441124e60c8c57f32ef844918f58
--- /dev/null
+++ b/man/accuracy.Rd
@@ -0,0 +1,26 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/mlmetrics.R
+\name{accuracy}
+\alias{accuracy}
+\title{accuracy}
+\usage{
+accuracy(y_pred, y_true)
+}
+\arguments{
+\item{y_pred}{Predicted labels vector, as returned by a classifier}
+
+\item{y_true}{Ground truth (correct) 0-1 labels vector}
+}
+\value{
+accuracy
+}
+\description{
+Compute the accuracy classification score.
+}
+\examples{
+data(cars)
+logreg <- glm(formula = vs ~ hp + wt,
+ family = binomial(link = "logit"), data = mtcars)
+pred <- ifelse(logreg$fitted.values < 0.5, 0, 1)
+accuracy(y_pred = pred, y_true = mtcars$vs)
+}
diff --git a/man/build_gg_pr_curve.Rd b/man/build_gg_pr_curve.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..3dbd05eb28903aa3be7755af7d098c239a48da01
--- /dev/null
+++ b/man/build_gg_pr_curve.Rd
@@ -0,0 +1,39 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/precision_recall.R, R/rocr_functions.R
+\name{build_gg_pr_curve}
+\alias{build_gg_pr_curve}
+\title{Builds a ggplot precision-recall curve.}
+\usage{
+build_gg_pr_curve(
+ data_curve,
+ data_auc,
+ palette_color = c("#500472", "#79cbb8"),
+ ...
+)
+
+build_gg_pr_curve(
+ data_curve,
+ data_auc,
+ palette_color = c("#500472", "#79cbb8"),
+ ...
+)
+}
+\arguments{
+\item{data_curve}{Data frame with precision-recall curve.}
+
+\item{data_auc}{Data frame with AUC.}
+
+\item{palette_color}{list of colors used.}
+
+\item{...}{Additional arguments to be passed to \code{ggplot2::geom_path}.}
+}
+\value{
+A ggplot object representing the precision-recall curve.
+
+A ggplot object representing the precision-recall curve.
+}
+\description{
+This function takes data frames for precision-recall curve and AUC and builds a ggplot precision-recall curve.
+
+This function takes data frames for precision-recall curve and AUC and builds a ggplot precision-recall curve.
+}
diff --git a/man/build_gg_roc_curve.Rd b/man/build_gg_roc_curve.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..bf443f7c4b0c9132da7b3bdb4cbedd1113035aa6
--- /dev/null
+++ b/man/build_gg_roc_curve.Rd
@@ -0,0 +1,28 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/receiver_operating_characteristic.R
+\name{build_gg_roc_curve}
+\alias{build_gg_roc_curve}
+\title{Builds a ggplot ROC curve.}
+\usage{
+build_gg_roc_curve(
+ data_curve,
+ data_auc,
+ palette_color = c("#500472", "#79cbb8"),
+ ...
+)
+}
+\arguments{
+\item{data_curve}{Data frame with ROC curve.}
+
+\item{data_auc}{Data frame with AUC.}
+
+\item{palette_color}{List of colors used.}
+
+\item{...}{Additional arguments to be passed to ggplot2::geom_path.}
+}
+\value{
+A ggplot object representing the ROC curve.
+}
+\description{
+This function takes data frames for ROC curve and AUC and builds a ggplot ROC curve.
+}
diff --git a/man/compute_metrics_summary.Rd b/man/compute_metrics_summary.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..d6b446457d948bca6d0cbba9d369e7818d62ecad
--- /dev/null
+++ b/man/compute_metrics_summary.Rd
@@ -0,0 +1,21 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_report.R
+\name{compute_metrics_summary}
+\alias{compute_metrics_summary}
+\title{Compute summary metrics on classification results}
+\usage{
+compute_metrics_summary(dt)
+}
+\arguments{
+\item{dt}{Data frame containing the predicted and actual classification results.}
+}
+\value{
+A data frame with the computed classification metrics of accuracy, precision, recall,
+sensitivity and specificity.
+}
+\description{
+This function computes several classification metrics like accuracy, precision, recall,
+sensitivity and specificity on classification results. The input to the function is a data frame
+(\code{dt}) containing the predicted classification result as \code{y_pred} and the actual
+classification as \code{isDE}. The function returns a data frame with the computed metrics.
+}
diff --git a/man/compute_pr_auc.Rd b/man/compute_pr_auc.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..cc252b1050ccd75d6427533424c59aaac68ce96f
--- /dev/null
+++ b/man/compute_pr_auc.Rd
@@ -0,0 +1,23 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/precision_recall.R, R/rocr_functions.R
+\name{compute_pr_auc}
+\alias{compute_pr_auc}
+\title{Computes area under the precision-recall curve (AUC).}
+\usage{
+compute_pr_auc(dt)
+
+compute_pr_auc(dt)
+}
+\arguments{
+\item{dt}{A data table with columns for recall and precision.}
+}
+\value{
+A numeric value representing the AUC.
+
+A numeric value representing the AUC.
+}
+\description{
+This function calculates the area under the precision-recall curve (AUC).
+
+This function calculates the area under the precision-recall curve (AUC).
+}
diff --git a/man/compute_pr_curve.Rd b/man/compute_pr_curve.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..49e23ace9232e5d4b1f01ba606d8bdb6ff1c07e3
--- /dev/null
+++ b/man/compute_pr_curve.Rd
@@ -0,0 +1,23 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/precision_recall.R, R/rocr_functions.R
+\name{compute_pr_curve}
+\alias{compute_pr_curve}
+\title{Computes the precision-recall curve (AUC).}
+\usage{
+compute_pr_curve(dt)
+
+compute_pr_curve(dt)
+}
+\arguments{
+\item{dt}{A data frame with columns truth (first column) and score (second column).}
+}
+\value{
+A dataframe with precision recall.
+
+A dataframe with precision recall.
+}
+\description{
+Computes the precision-recall curve (AUC).
+
+Computes the precision-recall curve (AUC).
+}
diff --git a/man/compute_roc_auc.Rd b/man/compute_roc_auc.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..429ba6e97f26a9fdb6f6cab1a2293b8fa88d7a31
--- /dev/null
+++ b/man/compute_roc_auc.Rd
@@ -0,0 +1,17 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/receiver_operating_characteristic.R
+\name{compute_roc_auc}
+\alias{compute_roc_auc}
+\title{Computes area under the ROC curve (AUC).}
+\usage{
+compute_roc_auc(dt)
+}
+\arguments{
+\item{dt}{A data table with columns for y_pred (-log10(padj)) and y_true (idDE).}
+}
+\value{
+A numeric value representing the AUC.
+}
+\description{
+This function calculates the area under the ROC curve (AUC) using specificity and sensitivity values.
+}
diff --git a/man/compute_roc_curve.Rd b/man/compute_roc_curve.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..fe0688b2c57ddcbe94fbfa2480b0f647835a7da2
--- /dev/null
+++ b/man/compute_roc_curve.Rd
@@ -0,0 +1,19 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/receiver_operating_characteristic.R
+\name{compute_roc_curve}
+\alias{compute_roc_curve}
+\title{Computes the ROC curve.}
+\usage{
+compute_roc_curve(dt)
+}
+\arguments{
+\item{dt}{A data frame with columns truth (first column) and score (second column).}
+}
+\value{
+A data frame with specificity, sensitivity, and threshold values.
+}
+\description{
+This function takes a data frame with binary truth values and predicted scores,
+computes the ROC curve, and returns a data frame containing specificity, sensitivity, and threshold values.
+This function is inspired by the yardstick package.
+}
diff --git a/man/compute_rsquare.Rd b/man/compute_rsquare.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..b5a1b669c18096065c59169bc7010c51093ea970
--- /dev/null
+++ b/man/compute_rsquare.Rd
@@ -0,0 +1,29 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/evaluation_identity.R
+\name{compute_rsquare}
+\alias{compute_rsquare}
+\title{Compute R-squared values for linear regression on grouped data}
+\usage{
+compute_rsquare(data, grouping_by = c("from", "description"))
+}
+\arguments{
+\item{data}{A data frame containing the variables 'actual' and 'estimate' for regression.}
+
+\item{grouping_by}{A character vector specifying the grouping variables for regression.}
+}
+\value{
+A data frame with columns 'from', 'term', and 'R2' representing the grouping variables
+and the corresponding R-squared values.
+}
+\description{
+This function takes a data frame, performs linear regression on specified grouping variables,
+and computes R-squared values for each group.
+}
+\examples{
+data <- data.frame(from = c("A", "A", "A", "A"),
+ term = c("X", "Y", "X", "Y"),
+ actual = c(1, 2, 3, 4),
+ estimate = c(1.5, 2.5, 3.5, 4.5))
+compute_rsquare(data, grouping_by = c("from", "term"))
+
+}
diff --git a/man/metrics_plot.Rd b/man/diagnostic_plot.Rd
similarity index 84%
rename from man/metrics_plot.Rd
rename to man/diagnostic_plot.Rd
index 89a21126074d2f9c99cead64adf82478cf2d1008..4352adce9e5756be4d6a881b423be0de8ed78fdb 100644
--- a/man/metrics_plot.Rd
+++ b/man/diagnostic_plot.Rd
@@ -1,10 +1,10 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/plot_metrics.R
-\name{metrics_plot}
-\alias{metrics_plot}
+\name{diagnostic_plot}
+\alias{diagnostic_plot}
\title{Plot Metrics for Generalized Linear Mixed Models (GLMM)}
\usage{
-metrics_plot(list_tmb, focus = NULL)
+diagnostic_plot(list_tmb, focus = NULL)
}
\arguments{
\item{list_tmb}{A list of GLMM objects to extract metrics from.}
@@ -23,5 +23,5 @@ list of generalized linear mixed models (GLMMs).
\examples{
models_list <- fitModelParallel(Sepal.Length ~ Sepal.Width + Petal.Length,
group_by = "Species",n.cores = 1, data = iris)
-metrics_plot(models_list, focus = c("AIC", "BIC", "deviance"))
+diagnostic_plot(models_list, focus = c("AIC", "BIC", "deviance"))
}
diff --git a/man/dispersion_plot.Rd b/man/dispersion_plot.Rd
deleted file mode 100644
index 2b7af5431a202daa810e3a53f2c39cbd9eb3457f..0000000000000000000000000000000000000000
--- a/man/dispersion_plot.Rd
+++ /dev/null
@@ -1,25 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/evaluate_dispersion.R
-\name{dispersion_plot}
-\alias{dispersion_plot}
-\title{Dispersion Evaluation Plot}
-\usage{
-dispersion_plot(eval_dispersion, ...)
-}
-\arguments{
-\item{eval_dispersion}{A data frame containing actual and inferred dispersion values.}
-
-\item{...}{Additional arguments to be passed to the ggplot2::aes function.}
-}
-\value{
-A ggplot2 scatter plot.
-}
-\description{
-Creates a scatter plot to evaluate the dispersion values between actual and inferred dispersions.
-}
-\examples{
-\dontrun{
-disp_plot <- dispersion_plot(disp_comparison_dtf, col = "from")
-print(disp_plot)
-}
-}
diff --git a/man/eval_identityTerm.Rd b/man/eval_identityTerm.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..79d901b735fbda7e1453db181289ac0fee735e60
--- /dev/null
+++ b/man/eval_identityTerm.Rd
@@ -0,0 +1,34 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/evaluation_identity.R
+\name{eval_identityTerm}
+\alias{eval_identityTerm}
+\title{Generate an identity term plot and get metrics associated}
+\usage{
+eval_identityTerm(
+ data_identity,
+ palette_color = c(DESeq2 = "#500472", HTRfit = "#79cbb8"),
+ ...
+)
+}
+\arguments{
+\item{data_identity}{A data frame containing comparison results with "actual" and "estimate" columns.}
+
+\item{palette_color}{dict-like palette default: palette_color = c(DESeq2 = "#500472", HTRfit ="#79cbb8")}
+
+\item{...}{additional parameters to pass geom_point aes}
+}
+\value{
+A ggplot2 identity plot and R2 metric associated
+}
+\description{
+This function generates an identity plot for comparing actual values with estimates
+}
+\examples{
+ comparison_data <- data.frame(
+ actual = c(1, 2, 3, 4, 5),
+ estimate = c(0.9, 2.2, 2.8, 4.1, 5.2),
+ description = rep("Category A", 5),
+ term = rep("Category A", 5),
+ from = c("A", "B", "B", "A", "B"))
+eval_identityTerm(comparison_data)
+}
diff --git a/man/evaluateDispersion.Rd b/man/evaluateDispersion.Rd
deleted file mode 100644
index cfe818fbeb807f3bf0fc25bf1a2550eb18d5af65..0000000000000000000000000000000000000000
--- a/man/evaluateDispersion.Rd
+++ /dev/null
@@ -1,28 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/evaluate_dispersion.R
-\name{evaluateDispersion}
-\alias{evaluateDispersion}
-\title{Evaluate Dispersion Comparison}
-\usage{
-evaluateDispersion(TMB_dispersion_df, DESEQ_dispersion_df, color2use)
-}
-\arguments{
-\item{TMB_dispersion_df}{A data frame containing dispersion values from TMB.}
-
-\item{DESEQ_dispersion_df}{A data frame containing dispersion values from DESeq2.}
-
-\item{color2use}{vector of color use for points coloration}
-}
-\value{
-A list containing a dispersion plot and a data frame with dispersion comparison.
-}
-\description{
-Compares dispersion values between two data frames containing dispersion information.
-}
-\examples{
-\dontrun{
-disp_comparison <- evaluateDispersion(TMB_dispersion_df, DESEQ_dispersion_df, "red")
-plot_dispersion <- disp_comparison$disp_plot
-comparison_df <- disp_comparison$data
-}
-}
diff --git a/man/evaluation_report.Rd b/man/evaluation_report.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..664746b2d4a8a48813299187c36338eb99a860bf
--- /dev/null
+++ b/man/evaluation_report.Rd
@@ -0,0 +1,51 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_report.R
+\name{evaluation_report}
+\alias{evaluation_report}
+\title{Compute evaluation report for TMB/DESeq2 analysis}
+\usage{
+evaluation_report(
+ l_tmb,
+ dds,
+ mock_obj,
+ coefficient,
+ alt_hypothesis,
+ alpha_risk = 0.05,
+ palette_color = NULL,
+ ...
+)
+}
+\arguments{
+\item{l_tmb}{TMB results from analysis.}
+
+\item{dds}{DESeq2 results from differential gene expression analysis.}
+
+\item{mock_obj}{Mock object that represents the distribution of measurements corresponding
+to mock samples.}
+
+\item{coefficient}{Fold-change threshold used to define differential expression.}
+
+\item{alt_hypothesis}{Alternative hypothesis used for hypothesis testing.}
+
+\item{alpha_risk}{parameter that sets the threshold for alpha risk level (default 0.05).}
+
+\item{palette_color}{Optional parameter that sets the color palette for plots.}
+
+\item{...}{Additional parameters to be passed to \code{get_pr_curve} and \code{get_roc_curve}.}
+}
+\value{
+A list containing the following components:
+\item{identity}{A list containing model parameters and dispersion data.}
+\item{precision_recall}{A PR curve object generated from TMB and DESeq2 results.}
+\item{roc}{A ROC curve object generated from TMB and DESeq2 results.}
+\item{counts}{A counts plot generated from mock object.}
+}
+\description{
+This function computes an evaluation report for TMB/DESeq2 analysis using several graphical
+summaries like precision-recall (PR) curve, Receiver operating characteristic (ROC) curve
+and others. It takes as input several parameters like TMB results (\code{l_tmb}), DESeq2
+result (\code{dds}), mock object (\code{mock_obj}), coefficient (\code{coefficient}) and
+alternative hypothesis (\code{alt_hypothesis}). These parameters are processed by various
+functions like \code{get_eval_data}, \code{get_pr_object} and \code{get_roc_object} to
+perform computations and generate plots.
+}
diff --git a/man/exportReportFile.Rd b/man/exportReportFile.Rd
index 83d8409568d81828297506827f6099bf9b6406b8..b3dd70f3042b42f057b5ca60ad47a811a6dae36b 100644
--- a/man/exportReportFile.Rd
+++ b/man/exportReportFile.Rd
@@ -4,14 +4,7 @@
\alias{exportReportFile}
\title{Export the Analysis Report to a File}
\usage{
-exportReportFile(
- report_file,
- table_settings,
- roc_curve,
- dispersion_plot,
- id_plot,
- counts_plot
-)
+exportReportFile(report_file, table_settings, roc_curve, id_plot, counts_plot)
}
\arguments{
\item{report_file}{Path to the file where the report will be exported.}
@@ -20,8 +13,6 @@ exportReportFile(
\item{roc_curve}{A plot displaying the Receiver Operating Characteristic (ROC) curve.}
-\item{dispersion_plot}{A plot displaying the dispersion values.}
-
\item{id_plot}{A plot displaying unique identifiers.}
\item{counts_plot}{A plot displaying the gene counts.}
diff --git a/man/fitModelParallel.Rd b/man/fitModelParallel.Rd
index 9212c78770cb4aef837079c707dc4b710bd9c8d5..7d8ad829bad4e0e56805bef625a4f9409ff4f7ac 100644
--- a/man/fitModelParallel.Rd
+++ b/man/fitModelParallel.Rd
@@ -10,6 +10,7 @@ fitModelParallel(
data,
group_by,
n.cores = NULL,
+ cl_type = "PSOCK",
log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"),
...
)
@@ -24,6 +25,8 @@ fitModelParallel(
\item{n.cores}{The number of CPU cores to use for parallel processing.
If set to NULL (default), the number of available CPU cores will be automatically detected.}
+\item{cl_type}{cluster type (defautl "PSOCK"). "FORK" is recommanded for linux.}
+
\item{log_file}{File path to save the log messages (default : Rtmpdir/htrfit.log)}
\item{...}{Additional arguments to be passed to the glmmTMB::glmmTMB function}
diff --git a/man/getLabelExpected.Rd b/man/getLabelExpected.Rd
index 0a1147e4a05a55c325946eed9de9ae844d4626bd..6b7e08ce2e50e7316be51a67960d4dd89693546d 100644
--- a/man/getLabelExpected.Rd
+++ b/man/getLabelExpected.Rd
@@ -1,5 +1,5 @@
% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/roc_plot.R
+% Please edit documentation in R/receiver_operating_characteristic.R
\name{getLabelExpected}
\alias{getLabelExpected}
\title{Get Labels for Expected Differential Expression}
diff --git a/man/get_eval_data.Rd b/man/get_eval_data.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..1b2a51a66b506823e3f7515ec37443ec61b405d3
--- /dev/null
+++ b/man/get_eval_data.Rd
@@ -0,0 +1,26 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_report.R
+\name{get_eval_data}
+\alias{get_eval_data}
+\title{Gets evaluation data from both TMB and DESeqDataSet (dds) objects.}
+\usage{
+get_eval_data(l_tmb = NULL, dds = NULL, mock_obj, coefficient, alt_hypothesis)
+}
+\arguments{
+\item{l_tmb}{A list of TMB models (default is NULL).}
+
+\item{dds}{A DESeqDataSet object (default is NULL).}
+
+\item{mock_obj}{A mock object containing ground truth information.}
+
+\item{coefficient}{The coefficient threshold for waldtest.}
+
+\item{alt_hypothesis}{The alternative hypothesis for wald test}
+}
+\value{
+A list containing data frames for model parameters and dispersion.
+}
+\description{
+This function retrieves evaluation data from TMB and DESeqDataSet (dds) objects, combining
+the results into a list containing data frames for model parameters and dispersion.
+}
diff --git a/man/get_eval_data_from_dds.Rd b/man/get_eval_data_from_dds.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..77029e27e2535403a007eced802724072a65ae92
--- /dev/null
+++ b/man/get_eval_data_from_dds.Rd
@@ -0,0 +1,26 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_report.R
+\name{get_eval_data_from_dds}
+\alias{get_eval_data_from_dds}
+\title{Extracts evaluation data from a DESeqDataSet (dds) object.}
+\usage{
+get_eval_data_from_dds(dds, mock_obj, coeff_threshold, alt_hypothesis)
+}
+\arguments{
+\item{dds}{A DESeqDataSet object.}
+
+\item{mock_obj}{A mock object containing ground truth information.}
+
+\item{coeff_threshold}{The coefficient threshold wald test}
+
+\item{alt_hypothesis}{The alternative hypothesis wald test}
+}
+\value{
+A list containing data frames for model parameters and dispersion.
+}
+\description{
+This function takes a DESeqDataSet object, performs tidy evaluation, extracts model parameters
+(beta in the case of DESeqDataSet), and compares them to the ground truth effects. Additionally,
+it evaluates and compares dispersion inferred from DESeqDataSet with the ground truth gene dispersion.
+The results are organized in two data frames, one for model parameters and one for dispersion, both #' labeled as "HTRfit".
+}
diff --git a/man/get_eval_data_from_ltmb.Rd b/man/get_eval_data_from_ltmb.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..427fb793f3e837e7e579c014ab657138659a89f9
--- /dev/null
+++ b/man/get_eval_data_from_ltmb.Rd
@@ -0,0 +1,26 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_report.R
+\name{get_eval_data_from_ltmb}
+\alias{get_eval_data_from_ltmb}
+\title{Extracts evaluation data from a list of TMB models.}
+\usage{
+get_eval_data_from_ltmb(list_tmb, mock_obj, coeff_threshold, alt_hypothesis)
+}
+\arguments{
+\item{list_tmb}{A list of TMB models.}
+
+\item{mock_obj}{A mock object containing ground truth information.}
+
+\item{coeff_threshold}{The coefficient threshold for wald test}
+
+\item{alt_hypothesis}{The alternative hypothesis for wald test}
+}
+\value{
+A list containing data frames for model parameters and dispersion.
+}
+\description{
+This function takes a list of TMB models, performs tidy evaluation, extracts model parameters,
+and compares them to the ground truth effects. Additionally, it evaluates and compares dispersion
+inferred from TMB with the ground truth gene dispersion. The results are organized in two data frames,
+one for model parameters and one for dispersion, both labeled as "HTRfit".
+}
diff --git a/man/get_eval_metrics.Rd b/man/get_eval_metrics.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..a3bc74ed7d5238e22e964843341eeea46d9067df
--- /dev/null
+++ b/man/get_eval_metrics.Rd
@@ -0,0 +1,21 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_report.R
+\name{get_eval_metrics}
+\alias{get_eval_metrics}
+\title{Compute evaluation metrics from evaluation object}
+\usage{
+get_eval_metrics(eval_obj)
+}
+\arguments{
+\item{eval_obj}{Evaluation object generated from \code{evaluation_report} function.}
+}
+\value{
+A data frame containing the R2 values from identity plot, ROC AUC and PR AUC values
+from ROC and precision-recall curves.
+}
+\description{
+This function computes the evaluation metrics from the evaluation object generated by
+\code{evaluation_report} function. It retrieves the R2 values from the identity plot,
+ROC AUC and PR AUC from ROC and precision-recall curves and combines them into a single
+data frame for easier analysis and interpretation.
+}
diff --git a/man/get_label_y_position.Rd b/man/get_label_y_position.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..2d7177933d54256bd4f1e37e760175ea10cc8238
--- /dev/null
+++ b/man/get_label_y_position.Rd
@@ -0,0 +1,18 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/receiver_operating_characteristic.R
+\name{get_label_y_position}
+\alias{get_label_y_position}
+\title{Computes y-axis position for text labels.}
+\usage{
+get_label_y_position(data_auc)
+}
+\arguments{
+\item{data_auc}{Data frame with AUC values and factor levels.}
+}
+\value{
+A modified data frame with an additional column pos_y representing y-axis positions.
+}
+\description{
+This function calculates the y-axis position for text labels in a ggplot based on the levels of a factor.
+It is specifically designed for use with ROC curve plotting.
+}
diff --git a/man/get_ml_metrics_obj.Rd b/man/get_ml_metrics_obj.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..fa6dca2a9fb80007a2028949ac47f0493af41223
--- /dev/null
+++ b/man/get_ml_metrics_obj.Rd
@@ -0,0 +1,32 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_report.R
+\name{get_ml_metrics_obj}
+\alias{get_ml_metrics_obj}
+\title{Get classification metrics for evaluation object}
+\usage{
+get_ml_metrics_obj(
+ evaldata_params,
+ alpha_risk = 0.05,
+ col_param = "description"
+)
+}
+\arguments{
+\item{evaldata_params}{Identity term of the evaluation object.}
+
+\item{alpha_risk}{parameter that sets the threshold for alpha risk level (default 0.05).}
+
+\item{col_param}{parameter that sets the column name for the parameter (default "description").}
+}
+\value{
+A list containing separate data frames for classification metrics by parameter value
+and for aggregated classification metrics.
+}
+\description{
+This function extracts the classification metrics from an evaluation object generated by
+\code{get_eval_metrics} function. It takes as input the identity term of the evaluation object
+(\code{evaldata_params}) and an optional risk level for the alpha risk (\code{alpha_risk}).
+It retrieves the p-values from the identity term and computes the binary classification
+result by thresholding with the alpha risk level. It then computes the classification metrics
+using \code{compute_metrics_summary} function separately for each parameter value as well as
+for the aggregated results.
+}
diff --git a/man/get_performances_metrics_obj.Rd b/man/get_performances_metrics_obj.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..86a47e521b2a74c171f142b5ec0e9fde1fc69dba
--- /dev/null
+++ b/man/get_performances_metrics_obj.Rd
@@ -0,0 +1,39 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_report.R
+\name{get_performances_metrics_obj}
+\alias{get_performances_metrics_obj}
+\title{Compute classification and regression performance metrics object}
+\usage{
+get_performances_metrics_obj(
+ r2_params,
+ r2_dispersion,
+ pr_obj,
+ roc_obj,
+ ml_metrics_obj
+)
+}
+\arguments{
+\item{r2_params}{R-squared values from model parameters evaluation object.}
+
+\item{r2_dispersion}{R-squared values from dispersion evaluation object.}
+
+\item{pr_obj}{PR object generated from evaluation report.}
+
+\item{roc_obj}{ROC object generated from evaluation report.}
+
+\item{ml_metrics_obj}{Machine learning performance metrics object.}
+}
+\value{
+A list containing separate data frames for by-parameter and aggregated metric values.
+}
+\description{
+This function computes metrics object for both classification and regression performance
+from evaluation objects generated by \code{evaluation_report} function. Metrics object
+contains the by-parameter and aggregate metrics for PR AUC, ROC AUC, R-squared and other
+classification metrics for precision, recall, sensitivity, and specificity. The function
+takes as input various evaluation objects including R-squared values (\code{r2_params}),
+dispersion values (\code{r2_dispersion}), PR object (\code{pr_obj}), ROC object
+(\code{roc_obj}), and machine learning performance metrics object (\code{ml_metrics_obj}).
+The function generates separate data frames for metric values by parameter value and for the
+aggregated metric values.
+}
diff --git a/man/get_pr_curve.Rd b/man/get_pr_curve.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..7474f13f92587143aabc77ba0cc32426942d771f
--- /dev/null
+++ b/man/get_pr_curve.Rd
@@ -0,0 +1,25 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/precision_recall.R, R/rocr_functions.R
+\name{get_pr_curve}
+\alias{get_pr_curve}
+\title{Gets precision-recall curves and AUC for both aggregated and individual parameters.}
+\usage{
+get_pr_curve(pr_obj, ...)
+
+get_pr_curve(pr_obj, ...)
+}
+\arguments{
+\item{pr_obj}{precision-recall object.}
+
+\item{...}{Additional arguments to be passed to \code{ggplot2::geom_path}.}
+}
+\value{
+precision-recall curves and AUCs for both aggregated and individual parameters.
+
+precision-recall curves and AUCs for both aggregated and individual parameters.
+}
+\description{
+This function takes a precision-recall object and returns precision-recall curves and AUCs for both aggregated and individual parameters.
+
+This function takes a precision-recall object and returns precision-recall curves and AUCs for both aggregated and individual parameters.
+}
diff --git a/man/get_pr_object.Rd b/man/get_pr_object.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..b0fed8a3287dcf4203f9659783f648a5559555ce
--- /dev/null
+++ b/man/get_pr_object.Rd
@@ -0,0 +1,41 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/precision_recall.R, R/rocr_functions.R
+\name{get_pr_object}
+\alias{get_pr_object}
+\title{Gets precision-recall objects for a given parameter.}
+\usage{
+get_pr_object(
+ evaldata_params,
+ col_param = "description",
+ col_truth = "isDE",
+ col_score = "p.adj"
+)
+
+get_pr_object(
+ evaldata_params,
+ col_param = "description",
+ col_truth = "isDE",
+ col_score = "p.adj"
+)
+}
+\arguments{
+\item{evaldata_params}{Data table containing evaluation parameters.}
+
+\item{col_param}{Column name specifying the parameter for grouping.}
+
+\item{col_truth}{Column name for binary ground truth values.}
+
+\item{col_score}{Column name for predicted scores.}
+}
+\value{
+A list containing precision-recall curves and AUCs for each group and an aggregate precision-recall curve and AUC.
+
+A list containing precision-recall curves and AUCs for each group and an aggregate precision-recall curve and AUC.
+}
+\description{
+This function takes a data table of evaluation parameters and returns precision-recall curves
+for each term and an aggregate precision-recall curve.
+
+This function takes a data table of evaluation parameters and returns precision-recall curves
+for each term and an aggregate precision-recall curve.
+}
diff --git a/man/get_roc_curve.Rd b/man/get_roc_curve.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..c5735ca6f39515c099c3f1638c31ae141650b850
--- /dev/null
+++ b/man/get_roc_curve.Rd
@@ -0,0 +1,19 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/receiver_operating_characteristic.R
+\name{get_roc_curve}
+\alias{get_roc_curve}
+\title{Gets ROC curves and AUC for both aggregated and individual parameters.}
+\usage{
+get_roc_curve(roc_obj, ...)
+}
+\arguments{
+\item{roc_obj}{ROC object.}
+
+\item{...}{Additional arguments to be passed to \code{ggplot2::geom_path}.}
+}
+\value{
+ROC curves and AUCs for both aggregated and individual parameters.
+}
+\description{
+This function takes a ROC object and returns ROC curves and AUCs for both aggregated and individual parameters.
+}
diff --git a/man/get_roc_object.Rd b/man/get_roc_object.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..4cc710853040c8fd3e92bf7eb6eda3c5d58bcfd1
--- /dev/null
+++ b/man/get_roc_object.Rd
@@ -0,0 +1,29 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/receiver_operating_characteristic.R
+\name{get_roc_object}
+\alias{get_roc_object}
+\title{Gets ROC objects for a given parameter.}
+\usage{
+get_roc_object(
+ evaldata_params,
+ col_param = "description",
+ col_truth = "isDE",
+ col_score = "p.adj"
+)
+}
+\arguments{
+\item{evaldata_params}{Data table containing evaluation parameters.}
+
+\item{col_param}{Column name specifying the parameter for grouping.}
+
+\item{col_truth}{Column name for binary ground truth values.}
+
+\item{col_score}{Column name for predicted scores.}
+}
+\value{
+A list containing ROC curves and AUCs for each group and an aggregate ROC curve and AUC.
+}
+\description{
+This function takes a data table of evaluation parameters and returns ROC curves for each term
+and an aggregate ROC curve along with corresponding AUC values.
+}
diff --git a/man/get_rsquare_2plot.Rd b/man/get_rsquare_2plot.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..8dc20c67dc0ac49eabcf121a259c8be60ed2f392
--- /dev/null
+++ b/man/get_rsquare_2plot.Rd
@@ -0,0 +1,22 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/evaluation_identity.R
+\name{get_rsquare_2plot}
+\alias{get_rsquare_2plot}
+\title{Gets R-squared values for plotting.}
+\usage{
+get_rsquare_2plot(data_rsquare)
+}
+\arguments{
+\item{data_rsquare}{Data frame with R-squared values.}
+}
+\value{
+A data frame with additional columns for labeling in the plot.
+}
+\description{
+This function takes a data frame with R-squared values,
+computes position coordinates, and prepares data for plotting.
+}
+\examples{
+data_rsquare <- data.frame(from = c("A", "B", "C"), description = c("Desc1", "Desc2", "Desc3"), R2 = c(0.9, 0.8, 0.7))
+result <- get_rsquare_2plot(data_rsquare)
+}
diff --git a/man/identity_plot.Rd b/man/identity_plot.Rd
deleted file mode 100644
index 858b776afac9e64884f4d58a98ff37d111640144..0000000000000000000000000000000000000000
--- a/man/identity_plot.Rd
+++ /dev/null
@@ -1,26 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/identity_plot.R
-\name{identity_plot}
-\alias{identity_plot}
-\title{Generate an identity plot}
-\usage{
-identity_plot(comparison_df, ...)
-}
-\arguments{
-\item{comparison_df}{A data frame containing comparison results with "actual" and "estimate" columns.}
-
-\item{...}{additional parameters to pass ggplot2::aes}
-}
-\value{
-A ggplot2 identity plot.
-}
-\description{
-This function generates an identity plot for comparing actual values with estimates.
-}
-\examples{
- comparison_data <- data.frame(
- actual = c(1, 2, 3, 4, 5),
- estimate = c(0.9, 2.2, 2.8, 4.1, 5.2),
- description = rep("Category A", 5))
-identity_plot(comparison_data)
-}
diff --git a/man/parallel_fit.Rd b/man/parallel_fit.Rd
index 60fb10ef1dc021361d5b02f6c512a8e226d36a69..9bebbfec5b2b03d319cb142cc72739b0f1fbbffc 100644
--- a/man/parallel_fit.Rd
+++ b/man/parallel_fit.Rd
@@ -12,6 +12,7 @@ parallel_fit(
data,
n.cores = NULL,
log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"),
+ cl_type = "PSOCK",
...
)
}
@@ -25,10 +26,12 @@ parallel_fit(
\item{data}{Data frame containing the data}
\item{n.cores}{The number of CPU cores to use for parallel processing.
-If set to NULL (default), the number of available CPU cores will be automatically detected.}
+If set to NULL (default), the number of available CPU (minus 1) cores will be automatically detected.}
\item{log_file}{File to write log (default : Rtmpdir/htrfit.log)}
+\item{cl_type}{cluster type (defautl "PSOCK"). "FORK" is recommanded for linux.}
+
\item{...}{Additional arguments to be passed to the glmmTMB::glmmTMB function}
}
\value{
diff --git a/man/parallel_update.Rd b/man/parallel_update.Rd
index 52d6d59eee8b3a1989472f9ae22d4dc9974bd2b8..2c6255e4069f0e292707fa2b8eb4800d036cd199 100644
--- a/man/parallel_update.Rd
+++ b/man/parallel_update.Rd
@@ -9,6 +9,7 @@ parallel_update(
list_tmb,
n.cores = NULL,
log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"),
+ cl_type = "PSOCK",
...
)
}
@@ -21,6 +22,8 @@ parallel_update(
\item{log_file}{File path for the log output (default : Rtmpdir/htrfit.log).}
+\item{cl_type}{cluster type (defautl "PSOCK"). "FORK" is recommanded for linux.}
+
\item{...}{Additional arguments to be passed to the glmmTMB::glmmTMB function.}
}
\value{
diff --git a/man/performance-class.Rd b/man/performance-class.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..3d3bc11f542186cdbd9bd6ffef695ab637853778
--- /dev/null
+++ b/man/performance-class.Rd
@@ -0,0 +1,77 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/fake-section-title.R
+\docType{class}
+\name{performance-class}
+\alias{performance-class}
+\title{Class \code{performance}}
+\description{
+Object to capture the result of a performance evaluation, optionally
+collecting evaluations from several cross-validation or bootstrapping runs.
+}
+\details{
+A \code{performance} object can capture information from four
+different evaluation scenarios:
+\itemize{
+\item The behaviour of a cutoff-dependent performance measure across
+the range of all cutoffs (e.g. \code{performance( predObj, 'acc' )} ). Here,
+\code{x.values} contains the cutoffs, \code{y.values} the
+corresponding values of the performance measure, and
+\code{alpha.values} is empty.\cr
+\item The trade-off between two performance measures across the
+range of all cutoffs (e.g. \code{performance( predObj,
+ 'tpr', 'fpr' )} ). In this case, the cutoffs are stored in
+\code{alpha.values}, while \code{x.values} and \code{y.values}
+contain the corresponding values of the two performance measures.\cr
+\item A performance measure that comes along with an obligatory
+second axis (e.g. \code{performance( predObj, 'ecost' )} ). Here, the measure values are
+stored in \code{y.values}, while the corresponding values of the
+obligatory axis are stored in \code{x.values}, and \code{alpha.values}
+is empty.\cr
+\item A performance measure whose value is just a scalar
+(e.g. \code{performance( predObj, 'auc' )} ). The value is then stored in
+\code{y.values}, while \code{x.values} and \code{alpha.values} are
+empty.
+}
+}
+\section{Slots}{
+
+\describe{
+\item{\code{x.name}}{Performance measure used for the x axis.}
+
+\item{\code{y.name}}{Performance measure used for the y axis.}
+
+\item{\code{alpha.name}}{Name of the unit that is used to create the parametrized
+curve. Currently, curves can only be parametrized by cutoff, so
+\code{alpha.name} is either \code{none} or \code{cutoff}.}
+
+\item{\code{x.values}}{A list in which each entry contains the x values of the curve
+of this particular cross-validation run. \code{x.values[[i]]},
+\code{y.values[[i]]}, and \code{alpha.values[[i]]} correspond to each
+other.}
+
+\item{\code{y.values}}{A list in which each entry contains the y values of the curve
+of this particular cross-validation run.}
+
+\item{\code{alpha.values}}{A list in which each entry contains the cutoff values of
+the curve of this particular cross-validation run.}
+}}
+
+\section{Objects from the Class}{
+
+Objects can be created by using the \code{performance} function.
+}
+
+\references{
+A detailed list of references can be found on the ROCR homepage at
+\url{http://rocr.bioinf.mpi-sb.mpg.de}.
+}
+\seealso{
+\code{\link{prediction}}
+\code{\link{performance}},
+\code{\link{prediction-class}},
+\code{\link{plot.performance}}
+}
+\author{
+Tobias Sing \email{tobias.sing@gmail.com}, Oliver Sander
+\email{osander@gmail.com}
+}
diff --git a/man/performance.Rd b/man/performance.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..886aee2b7bccdf04404eb1f60278cd14d4fabf34
--- /dev/null
+++ b/man/performance.Rd
@@ -0,0 +1,189 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/fake-section-title.R
+\name{performance}
+\alias{performance}
+\title{Function to create performance objects}
+\usage{
+performance(prediction.obj, measure, x.measure = "cutoff", ...)
+}
+\arguments{
+\item{prediction.obj}{An object of class \code{prediction}.}
+
+\item{measure}{Performance measure to use for the evaluation. A complete list
+of the performance measures that are available for \code{measure} and
+\code{x.measure} is given in the 'Details' section.}
+
+\item{x.measure}{A second performance measure. If different from the default,
+a two-dimensional curve, with \code{x.measure} taken to be the unit in
+direction of the x axis, and \code{measure} to be the unit in direction of
+the y axis, is created. This curve is parametrized with the cutoff.}
+
+\item{...}{Optional arguments (specific to individual performance measures).}
+}
+\value{
+An S4 object of class \code{performance}.
+}
+\description{
+All kinds of predictor evaluations are performed using this function.
+}
+\details{
+Here is the list of available performance measures. Let Y and
+\eqn{\hat{Y}}{Yhat} be random variables representing the class and the prediction for
+a randomly drawn sample, respectively. We denote by
+\eqn{\oplus}{+} and \eqn{\ominus}{-} the positive and
+negative class, respectively. Further, we use the following
+abbreviations for empirical quantities: P (\# positive
+samples), N (\# negative samples), TP (\# true positives), TN (\# true
+negatives), FP (\# false positives), FN (\# false negatives).
+\describe{
+\item{\code{acc}:}{accuracy. \eqn{P(\hat{Y}=Y)}{P(Yhat = Y)}. Estimated
+as: \eqn{\frac{TP+TN}{P+N}}{(TP+TN)/(P+N)}.}
+\item{\code{err}:}{Error rate. \eqn{P(\hat{Y}\ne Y)}{P(Yhat !=
+ Y)}. Estimated as: \eqn{\frac{FP+FN}{P+N}}{(FP+FN)/(P+N)}.}
+\item{\code{fpr}:}{False positive rate. \eqn{P(\hat{Y}=\oplus | Y =
+ \ominus)}{P(Yhat = + | Y = -)}. Estimated as:
+\eqn{\frac{FP}{N}}{FP/N}.}
+\item{\code{fall}:}{Fallout. Same as \code{fpr}.}
+\item{\code{tpr}:}{True positive
+rate. \eqn{P(\hat{Y}=\oplus|Y=\oplus)}{P(Yhat = + | Y = +)}. Estimated
+as: \eqn{\frac{TP}{P}}{TP/P}.}
+\item{\code{rec}:}{recall. Same as \code{tpr}.}
+\item{\code{sens}:}{sensitivity. Same as \code{tpr}.}
+\item{\code{fnr}:}{False negative
+rate. \eqn{P(\hat{Y}=\ominus|Y=\oplus)}{P(Yhat = - | Y =
+ +)}. Estimated as: \eqn{\frac{FN}{P}}{FN/P}.}
+\item{\code{miss}:}{Miss. Same as \code{fnr}.}
+\item{\code{tnr}:}{True negative rate. \eqn{P(\hat{Y} =
+ \ominus|Y=\ominus)}{P(Yhat = - | Y = -)}.}
+\item{\code{spec}:}{specificity. Same as \code{tnr}.}
+\item{\code{ppv}:}{Positive predictive
+value. \eqn{P(Y=\oplus|\hat{Y}=\oplus)}{P(Y = + | Yhat =
+ +)}. Estimated as: \eqn{\frac{TP}{TP+FP}}{TP/(TP+FP)}.}
+\item{\code{prec}:}{precision. Same as \code{ppv}.}
+\item{\code{npv}:}{Negative predictive
+value. \eqn{P(Y=\ominus|\hat{Y}=\ominus)}{P(Y = - | Yhat =
+ -)}. Estimated as: \eqn{\frac{TN}{TN+FN}}{TN/(TN+FN)}.}
+\item{\code{pcfall}:}{Prediction-conditioned
+fallout. \eqn{P(Y=\ominus|\hat{Y}=\oplus)}{P(Y = - | Yhat =
+ +)}. Estimated as: \eqn{\frac{FP}{TP+FP}}{FP/(TP+FP)}.}
+\item{\code{pcmiss}:}{Prediction-conditioned
+miss. \eqn{P(Y=\oplus|\hat{Y}=\ominus)}{P(Y = + | Yhat =
+ -)}. Estimated as: \eqn{\frac{FN}{TN+FN}}{FN/(TN+FN)}.}
+\item{\code{rpp}:}{Rate of positive predictions. \eqn{P( \hat{Y} =
+ \oplus)}{P(Yhat = +)}. Estimated as: (TP+FP)/(TP+FP+TN+FN).}
+\item{\code{rnp}:}{Rate of negative predictions. \eqn{P( \hat{Y} =
+ \ominus)}{P(Yhat = -)}. Estimated as: (TN+FN)/(TP+FP+TN+FN).}
+\item{\code{phi}:}{Phi correlation coefficient. \eqn{\frac{TP \cdot
+ TN - FP \cdot FN}{\sqrt{ (TP+FN) \cdot (TN+FP) \cdot (TP+FP)
+ \cdot (TN+FN)}}}{(TP*TN -
+ FP*FN)/(sqrt((TP+FN)*(TN+FP)*(TP+FP)*(TN+FN)))}. Yields a
+number between -1 and 1, with 1 indicating a perfect
+prediction, 0 indicating a random prediction. Values below 0
+indicate a worse than random prediction.}
+\item{\code{mat}:}{Matthews correlation coefficient. Same as \code{phi}.}
+\item{\code{mi}:}{Mutual information. \eqn{I(\hat{Y},Y) := H(Y) -
+ H(Y|\hat{Y})}{I(Yhat, Y) := H(Y) - H(Y | Yhat)}, where H is the
+(conditional) entropy. Entropies are estimated naively (no bias
+correction).}
+\item{\code{chisq}:}{Chi square test statistic. \code{?chisq.test}
+for details. Note that R might raise a warning if the sample size
+is too small.}
+\item{\code{odds}:}{Odds ratio. \eqn{\frac{TP \cdot TN}{FN \cdot
+ FP}}{(TP*TN)/(FN*FP)}. Note that odds ratio produces
+Inf or NA values for all cutoffs corresponding to FN=0 or
+FP=0. This can substantially decrease the plotted cutoff region.}
+\item{\code{lift}:}{Lift
+value. \eqn{\frac{P(\hat{Y}=\oplus|Y=\oplus)}{P(\hat{Y}=\oplus)}}{P(Yhat = + |
+ Y = +)/P(Yhat = +)}.}
+\item{\code{f}:}{precision-recall F measure (van Rijsbergen, 1979). Weighted
+harmonic mean of precision (P) and recall (R). \eqn{F =
+ \frac{1}{\alpha \frac{1}{P} + (1-\alpha)\frac{1}{R}}}{F = 1/
+ (alpha*1/P + (1-alpha)*1/R)}. If
+\eqn{\alpha=\frac{1}{2}}{alpha=1/2}, the mean is balanced. A
+frequent equivalent formulation is
+\eqn{F = \frac{(\beta^2+1) \cdot P \cdot R}{R + \beta^2 \cdot
+ P}}{F = (beta^2+1) * P * R / (R + beta^2 * P)}. In this formulation, the
+mean is balanced if \eqn{\beta=1}{beta=1}. Currently, ROCR only accepts
+the alpha version as input (e.g. \eqn{\alpha=0.5}{alpha=0.5}). If no
+value for alpha is given, the mean will be balanced by default.}
+\item{\code{rch}:}{ROC convex hull. A ROC (=\code{tpr} vs \code{fpr}) curve
+with concavities (which represent suboptimal choices of cutoff) removed
+(Fawcett 2001). Since the result is already a parametric performance
+curve, it cannot be used in combination with other measures.}
+\item{\code{auc}:}{Area under the ROC curve. This is equal to the value of the
+Wilcoxon-Mann-Whitney test statistic and also the probability that the
+classifier will score are randomly drawn positive sample higher than a
+randomly drawn negative sample. Since the output of
+\code{auc} is cutoff-independent, this
+measure cannot be combined with other measures into a parametric
+curve. The partial area under the ROC curve up to a given false
+positive rate can be calculated by passing the optional parameter
+\code{fpr.stop=0.5} (or any other value between 0 and 1) to
+\code{performance}.}
+\item{\code{aucpr}:}{Area under the precision/recall curve. Since the output
+of \code{aucpr} is cutoff-independent, this measure cannot be combined
+with other measures into a parametric curve.}
+\item{\code{prbe}:}{precision-recall break-even point. The cutoff(s) where
+precision and recall are equal. At this point, positive and negative
+predictions are made at the same rate as their prevalence in the
+data. Since the output of
+\code{prbe} is just a cutoff-independent scalar, this
+measure cannot be combined with other measures into a parametric curve.}
+\item{\code{cal}:}{Calibration error. The calibration error is the
+absolute difference between predicted confidence and actual reliability. This
+error is estimated at all cutoffs by sliding a window across the
+range of possible cutoffs. The default window size of 100 can be
+adjusted by passing the optional parameter \code{window.size=200}
+to \code{performance}. E.g., if for several
+positive samples the output of the classifier is around 0.75, you might
+expect from a well-calibrated classifier that the fraction of them
+which is correctly predicted as positive is also around 0.75. In a
+well-calibrated classifier, the probabilistic confidence estimates
+are realistic. Only for use with
+probabilistic output (i.e. scores between 0 and 1).}
+\item{\code{mxe}:}{Mean cross-entropy. Only for use with
+probabilistic output. \eqn{MXE :=-\frac{1}{P+N}( \sum_{y_i=\oplus}
+ ln(\hat{y}_i) + \sum_{y_i=\ominus} ln(1-\hat{y}_i))}{MXE := - 1/(P+N) \sum_{y_i=+}
+ ln(yhat_i) + \sum_{y_i=-} ln(1-yhat_i)}. Since the output of
+\code{mxe} is just a cutoff-independent scalar, this
+measure cannot be combined with other measures into a parametric curve.}
+\item{\code{rmse}:}{Root-mean-squared error. Only for use with
+numerical class labels. \eqn{RMSE:=\sqrt{\frac{1}{P+N}\sum_i (y_i
+ - \hat{y}_i)^2}}{RMSE := sqrt(1/(P+N) \sum_i (y_i -
+ yhat_i)^2)}. Since the output of
+\code{rmse} is just a cutoff-independent scalar, this
+measure cannot be combined with other measures into a parametric curve.}
+\item{\code{sar}:}{Score combinining performance measures of different
+characteristics, in the attempt of creating a more "robust"
+measure (cf. Caruana R., ROCAI2004):
+SAR = 1/3 * ( accuracy + Area under the ROC curve + Root
+mean-squared error ).}
+\item{\code{ecost}:}{Expected cost. For details on cost curves,
+cf. Drummond&Holte 2000,2004. \code{ecost} has an obligatory x
+axis, the so-called 'probability-cost function'; thus it cannot be
+combined with other measures. While using \code{ecost} one is
+interested in the lower envelope of a set of lines, it might be
+instructive to plot the whole set of lines in addition to the lower
+envelope. An example is given in \code{demo(ROCR)}.}
+\item{\code{cost}:}{Cost of a classifier when
+class-conditional misclassification costs are explicitly given.
+Accepts the optional parameters \code{cost.fp} and
+\code{cost.fn}, by which the costs for false positives and
+negatives can be adjusted, respectively. By default, both are set
+to 1.}
+}
+}
+\note{
+Here is how to call \code{performance()} to create some standard
+evaluation plots:
+\describe{
+\item{ROC curves:}{measure="tpr", x.measure="fpr".}
+\item{precision/recall graphs:}{measure="prec", x.measure="rec".}
+\item{sensitivity/specificity plots:}{measure="sens", x.measure="spec".}
+\item{Lift charts:}{measure="lift", x.measure="rpp".}
+}
+}
+\author{
+Tobias Sing \email{tobias.sing@gmail.com}, Oliver Sander
+\email{osander@gmail.com}
+}
diff --git a/man/precision.Rd b/man/precision.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..64fa6db0100a465d89e9a95d7b7398e21812e6e9
--- /dev/null
+++ b/man/precision.Rd
@@ -0,0 +1,30 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/mlmetrics.R
+\name{precision}
+\alias{precision}
+\title{precision}
+\usage{
+precision(y_true, y_pred, positive = NULL)
+}
+\arguments{
+\item{y_true}{Ground truth (correct) 0-1 labels vector}
+
+\item{y_pred}{Predicted labels vector, as returned by a classifier}
+
+\item{positive}{An optional character string for the factor level that
+corresponds to a "positive" result}
+}
+\value{
+precision
+}
+\description{
+Compute the precision score.
+}
+\examples{
+data(cars)
+logreg <- glm(formula = vs ~ hp + wt,
+ family = binomial(link = "logit"), data = mtcars)
+pred <- ifelse(logreg$fitted.values < 0.5, 0, 1)
+precision(y_pred = pred, y_true = mtcars$vs, positive = "0")
+precision(y_pred = pred, y_true = mtcars$vs, positive = "1")
+}
diff --git a/man/prediction-class.Rd b/man/prediction-class.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..472b9af76bed7e16d3fa0ae6e855ed89da7c76e5
--- /dev/null
+++ b/man/prediction-class.Rd
@@ -0,0 +1,67 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/fake-section-title.R
+\docType{class}
+\name{prediction-class}
+\alias{prediction-class}
+\title{Class \code{prediction}}
+\description{
+Object to encapsulate numerical predictions together with the
+corresponding true class labels, optionally collecting predictions and
+labels for several cross-validation or bootstrapping runs.
+}
+\section{Slots}{
+
+\describe{
+\item{\code{predictions}}{A list, in which each element is a vector of predictions
+(the list has length > 1 for x-validation data.}
+
+\item{\code{labels}}{Analogously, a list in which each element is a vector of true
+class labels.}
+
+\item{\code{cutoffs}}{A list in which each element is a vector of all necessary
+cutoffs. Each cutoff vector consists of the predicted scores (duplicates
+removed), in descending order.}
+
+\item{\code{fp}}{A list in which each element is a vector of the number (not the
+rate!) of false positives induced by the cutoffs given in the corresponding
+'cutoffs' list entry.}
+
+\item{\code{tp}}{As fp, but for true positives.}
+
+\item{\code{tn}}{As fp, but for true negatives.}
+
+\item{\code{fn}}{As fp, but for false negatives.}
+
+\item{\code{n.pos}}{A list in which each element contains the number of positive
+samples in the given x-validation run.}
+
+\item{\code{n.neg}}{As n.pos, but for negative samples.}
+
+\item{\code{n.pos.pred}}{A list in which each element is a vector of the number of
+samples predicted as positive at the cutoffs given in the corresponding
+'cutoffs' entry.}
+
+\item{\code{n.neg.pred}}{As n.pos.pred, but for negatively predicted samples.}
+}}
+
+\note{
+Every \code{prediction} object contains information about the 2x2
+contingency table consisting of tp,tn,fp, and fn, along with the
+marginal sums n.pos,n.neg,n.pos.pred,n.neg.pred, because these form
+the basis for many derived performance measures.
+}
+\section{Objects from the Class}{
+
+Objects can be created by using the \code{prediction} function.
+}
+
+\seealso{
+\code{\link{prediction}},
+\code{\link{performance}},
+\code{\link{performance-class}},
+\code{\link{plot.performance}}
+}
+\author{
+Tobias Sing \email{tobias.sing@gmail.com}, Oliver Sander
+\email{osander@gmail.com}
+}
diff --git a/man/prediction.Rd b/man/prediction.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..1d20b7865e3971ae541a0d0062d7d3fdd3186dcb
--- /dev/null
+++ b/man/prediction.Rd
@@ -0,0 +1,65 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/fake-section-title.R
+\name{prediction}
+\alias{prediction}
+\title{Function to create prediction objects}
+\usage{
+prediction(predictions, labels, label.ordering = NULL)
+}
+\arguments{
+\item{predictions}{A vector, matrix, list, or data frame containing the
+predictions.}
+
+\item{labels}{A vector, matrix, list, or data frame containing the true class
+labels. Must have the same dimensions as \code{predictions}.}
+
+\item{label.ordering}{The default ordering (cf.details) of the classes can
+be changed by supplying a vector containing the negative and the positive
+class label.}
+}
+\value{
+An S4 object of class \code{prediction}.
+}
+\description{
+Every classifier evaluation using ROCR starts with creating a
+\code{prediction} object. This function is used to transform the input data
+(which can be in vector, matrix, data frame, or list form) into a
+standardized format.
+}
+\details{
+\code{predictions} and \code{labels} can simply be vectors of the same
+length. However, in the case of cross-validation data, different
+cross-validation runs can be provided as the \emph{columns} of a matrix or
+data frame, or as the entries of a list. In the case of a matrix or
+data frame, all cross-validation runs must have the same length, whereas
+in the case of a list, the lengths can vary across the cross-validation
+runs. Internally, as described in section 'Value', all of these input
+formats are converted to list representation.
+
+Since scoring classifiers give relative tendencies towards a negative
+(low scores) or positive (high scores) class, it has to be declared
+which class label denotes the negative, and which the positive class.
+Ideally, labels should be supplied as ordered factor(s), the lower
+level corresponding to the negative class, the upper level to the
+positive class. If the labels are factors (unordered), numeric,
+logical or characters, ordering of the labels is inferred from
+R's built-in \code{<} relation (e.g. 0 < 1, -1 < 1, 'a' < 'b',
+FALSE < TRUE). Use \code{label.ordering} to override this default
+ordering. Please note that the ordering can be locale-dependent
+e.g. for character labels '-1' and '1'.
+
+Currently, ROCR supports only binary classification (extensions toward
+multiclass classification are scheduled for the next release,
+however). If there are more than two distinct label symbols, execution
+stops with an error message. If all predictions use the same two
+symbols that are used for the labels, categorical predictions are
+assumed. If there are more than two predicted values, but all numeric,
+continuous predictions are assumed (i.e. a scoring
+classifier). Otherwise, if more than two symbols occur in the
+predictions, and not all of them are numeric, execution stops with an
+error message.
+}
+\author{
+Tobias Sing \email{tobias.sing@gmail.com}, Oliver Sander
+\email{osander@gmail.com}
+}
diff --git a/man/rbind_evaldata_tmb_dds.Rd b/man/rbind_evaldata_tmb_dds.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..15b451bf1333888998240dcce52ea2d02ddbaee2
--- /dev/null
+++ b/man/rbind_evaldata_tmb_dds.Rd
@@ -0,0 +1,19 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_report.R
+\name{rbind_evaldata_tmb_dds}
+\alias{rbind_evaldata_tmb_dds}
+\title{Combines evaluation data from TMB and DESeqDataSet (dds) objects.}
+\usage{
+rbind_evaldata_tmb_dds(evaldata_tmb, evaldata_dds)
+}
+\arguments{
+\item{evaldata_tmb}{Evaluation data from TMB models.}
+
+\item{evaldata_dds}{Evaluation data from DESeqDataSet (dds) object.}
+}
+\value{
+A list containing combined data frames for model parameters and dispersion.
+}
+\description{
+This function combines model parameters and dispersion data frames from TMB and DESeqDataSet (dds) evaluations.
+}
diff --git a/man/rbind_model_params_and_dispersion.Rd b/man/rbind_model_params_and_dispersion.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..77b7c31813ca02ffbb74698775e47c95437b91e4
--- /dev/null
+++ b/man/rbind_model_params_and_dispersion.Rd
@@ -0,0 +1,17 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_report.R
+\name{rbind_model_params_and_dispersion}
+\alias{rbind_model_params_and_dispersion}
+\title{Combines model parameters and dispersion data frames.}
+\usage{
+rbind_model_params_and_dispersion(eval_data)
+}
+\arguments{
+\item{eval_data}{Evaluation data containing model parameters and dispersion.}
+}
+\value{
+A combined data frame with model parameters and dispersion.
+}
+\description{
+This function combines model parameters and dispersion data frames, ensuring proper alignment.
+}
diff --git a/man/recall.Rd b/man/recall.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..559cc15c4735c10cd1c790438d256ed5bbd8e104
--- /dev/null
+++ b/man/recall.Rd
@@ -0,0 +1,30 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/mlmetrics.R
+\name{recall}
+\alias{recall}
+\title{recall}
+\usage{
+recall(y_true, y_pred, positive = NULL)
+}
+\arguments{
+\item{y_true}{Ground truth (correct) 0-1 labels vector}
+
+\item{y_pred}{Predicted labels vector, as returned by a classifier}
+
+\item{positive}{An optional character string for the factor level that
+corresponds to a "positive" result}
+}
+\value{
+recall
+}
+\description{
+Compute the recall score.
+}
+\examples{
+data(cars)
+logreg <- glm(formula = vs ~ hp + wt,
+ family = binomial(link = "logit"), data = mtcars)
+pred <- ifelse(logreg$fitted.values < 0.5, 0, 1)
+recall(y_pred = pred, y_true = mtcars$vs, positive = "0")
+recall(y_pred = pred, y_true = mtcars$vs, positive = "1")
+}
diff --git a/man/removeDuplicatedWord.Rd b/man/removeDuplicatedWord.Rd
index 1e1e780101bdcf8a4be4a70dae76cc6f2d497c22..29119060ea8f2dd1c0b33afb33163b47696787fb 100644
--- a/man/removeDuplicatedWord.Rd
+++ b/man/removeDuplicatedWord.Rd
@@ -16,6 +16,6 @@ A character vector with duplicated words removed from each string.
This function takes a vector of strings and removes duplicated words within each string.
}
\examples{
-words <- c("hellohello", "worldworld", "programmingprogramming", "R isis great")
+words <- c("hellohello", "worldworld", "programmingprogramming", "R isis great", "duplicateeee1333")
cleaned_words <- removeDuplicatedWord(words)
}
diff --git a/man/roc_plot.Rd b/man/roc_plot.Rd
deleted file mode 100644
index bb68dfef407cfdcbb1cfb6705dc288ed69d4ce80..0000000000000000000000000000000000000000
--- a/man/roc_plot.Rd
+++ /dev/null
@@ -1,28 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/roc_plot.R
-\name{roc_plot}
-\alias{roc_plot}
-\title{Generate ROC Curve Plot}
-\usage{
-roc_plot(comparison_df, ...)
-}
-\arguments{
-\item{comparison_df}{A dataframe containing comparison results.}
-
-\item{...}{additional params to pass ggplot2::aes}
-}
-\value{
-A ggplot object representing the ROC curve plot.
-}
-\description{
-This function generates an ROC curve plot based on the comparison dataframe.
-}
-\examples{
-comparison_data <- data.frame(
- geneID = c("gene1", "gene2", "gene3"),
- isDE = c(TRUE, FALSE, TRUE),
- p.adj = c(0.05, 0.2, 0.01)
-)
-roc_plot(comparison_data)
-
-}
diff --git a/man/sensitivity.Rd b/man/sensitivity.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..038ae089347a36e34436c1dee0201ba1eef8edc9
--- /dev/null
+++ b/man/sensitivity.Rd
@@ -0,0 +1,30 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/mlmetrics.R
+\name{sensitivity}
+\alias{sensitivity}
+\title{sensitivity}
+\usage{
+sensitivity(y_true, y_pred, positive = NULL)
+}
+\arguments{
+\item{y_true}{Ground truth (correct) 0-1 labels vector}
+
+\item{y_pred}{Predicted labels vector, as returned by a classifier}
+
+\item{positive}{An optional character string for the factor level that
+corresponds to a "positive" result}
+}
+\value{
+sensitivity
+}
+\description{
+Compute the sensitivity score.
+}
+\examples{
+data(cars)
+logreg <- glm(formula = vs ~ hp + wt,
+ family = binomial(link = "logit"), data = mtcars)
+pred <- ifelse(logreg$fitted.values < 0.5, 0, 1)
+sensitivity(y_pred = pred, y_true = mtcars$vs, positive = "0")
+sensitivity(y_pred = pred, y_true = mtcars$vs, positive = "1")
+}
diff --git a/man/simulationReport.Rd b/man/simulationReport.Rd
deleted file mode 100644
index 9f4a148867c2145ba38103826fbe8218c3ba0873..0000000000000000000000000000000000000000
--- a/man/simulationReport.Rd
+++ /dev/null
@@ -1,34 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/simulation_report.R
-\name{simulationReport}
-\alias{simulationReport}
-\title{Generate a simulation report}
-\usage{
-simulationReport(
- mock_obj,
- list_tmb = NULL,
- coeff_threshold = 0,
- alt_hypothesis = "greaterAbs",
- report_file = NULL,
- dds_obj = NULL
-)
-}
-\arguments{
-\item{mock_obj}{A list containing simulation data and ground truth.}
-
-\item{list_tmb}{A list of model results.}
-
-\item{coeff_threshold}{A threshold for comparing estimates.}
-
-\item{alt_hypothesis}{The alternative hypothesis for comparisons ("greater", "less", "greaterAbs").}
-
-\item{report_file}{File name to save the generated report. If NULL, the report will not be exported.}
-
-\item{dds_obj}{a DESeq2 object}
-}
-\value{
-A list containing settings, plots, and evaluation results.
-}
-\description{
-This function generates a simulation report containing various plots and evaluation metrics.
-}
diff --git a/man/specificity.Rd b/man/specificity.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..ca73d95542f13fd0c05d59f4cdb6905a49eb02ac
--- /dev/null
+++ b/man/specificity.Rd
@@ -0,0 +1,30 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/mlmetrics.R
+\name{specificity}
+\alias{specificity}
+\title{specificity}
+\usage{
+specificity(y_true, y_pred, positive = NULL)
+}
+\arguments{
+\item{y_true}{Ground truth (correct) 0-1 labels vector}
+
+\item{y_pred}{Predicted labels vector, as returned by a classifier}
+
+\item{positive}{An optional character string for the factor level that
+corresponds to a "positive" result}
+}
+\value{
+specificity
+}
+\description{
+Compute the specificity score.
+}
+\examples{
+data(cars)
+logreg <- glm(formula = vs ~ hp + wt,
+ family = binomial(link = "logit"), data = mtcars)
+pred <- ifelse(logreg$fitted.values < 0.5, 0, 1)
+specificity(y_pred = pred, y_true = mtcars$vs, positive = "0")
+specificity(y_pred = pred, y_true = mtcars$vs, positive = "1")
+}
diff --git a/man/updateParallel.Rd b/man/updateParallel.Rd
index 7f779e1105ae0298315249bb830cc01c44a64ccc..665857d2a1a41a7d414823898c0d815215865922 100644
--- a/man/updateParallel.Rd
+++ b/man/updateParallel.Rd
@@ -8,6 +8,7 @@ updateParallel(
formula,
list_tmb,
n.cores = NULL,
+ cl_type = "PSOCK",
log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"),
...
)
@@ -19,6 +20,8 @@ updateParallel(
\item{n.cores}{Number of cores to use for parallel processing. If NULL, the function will use all available cores.}
+\item{cl_type}{cluster type (defautl "PSOCK"). "FORK" is recommanded for linux.}
+
\item{log_file}{File path for the log output (default: Rtmpdir/htrfit.log).}
\item{...}{Additional arguments to be passed to the glmmTMB::glmmTMB function.}
diff --git a/tests/testthat/test-actual_interactionfixeffects.R b/tests/testthat/test-actual_interactionfixeffects.R
index c930baa20ae242b7cf822d34443437384a9533f4..3dea605b867e89024f77a4c7c002f9e75f0d23cb 100644
--- a/tests/testthat/test-actual_interactionfixeffects.R
+++ b/tests/testthat/test-actual_interactionfixeffects.R
@@ -101,6 +101,16 @@ test_that("Generate actual interaction fixed effect correctly", {
# -- fit data
data2fit <- prepareData2fit(countMatrix = mock_data$counts, metadata = mock_data$metadata)
+
+ dtf_countsLong <- countMatrix_2longDtf(mock_data$counts, "k_ij")
+ metadata_columnForjoining <- getColumnWithSampleID(dtf_countsLong, mock_data$metadata)
+
+ example_spleID <- as.character(dtf_countsLong[1, "sampleID"])
+ regex <- paste("^", as.character(dtf_countsLong[1, "sampleID"]), "$", sep = "")
+
+
+
+
results_fit <- fitModelParallel(formula = kij ~ varA + varB + varC + varA:varC,
data = data2fit, group_by = "geneID",
family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
diff --git a/tests/testthat/test-basal_expression__scaling.R b/tests/testthat/test-basal_expression__scaling.R
deleted file mode 100644
index 86876f855ef01a1028d16ca8b40b76950f177c14..0000000000000000000000000000000000000000
--- a/tests/testthat/test-basal_expression__scaling.R
+++ /dev/null
@@ -1,75 +0,0 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
-
-
-test_that("generate_basal_expression returns correct number of genes", {
- be_data <- generate_basal_expression(n_genes = 100, 1)
- expect_equal(nrow(be_data), 100)
-})
-
-
-test_that("generate_basal_expression returns BE values within specified vector", {
- BE_vec <- c(1, 2, 33, 0.4)
- be_data <- generate_basal_expression(n_genes = 100, BE_vec)
- expect_true(all(be_data$basalExpr %in% BE_vec))
-})
-
-
-test_that("Test for addbasalExpre function",{
-
- list_var <- init_variable()
- N_GENES <- 5
- dtf_coef <- getInput2simulation(list_var, N_GENES)
- dtf_coef <- getLog_qij(dtf_coef)
-
- # Test the function
- dtf_coef_with_BE <- addBasalExpression(dtf_coef, N_GENES, 5)
-
- # Check if the output is a data frame
- expect_true(is.data.frame(dtf_coef_with_BE))
-
- # Check if the number of rows is equal to number of row in dtf_coef
- expect_equal(nrow(dtf_coef_with_BE), nrow(dtf_coef))
-
- # Check if the number of rows is equal to number of row in dtf_coef +1
- expect_equal(ncol(dtf_coef_with_BE), ncol(dtf_coef)+1)
-
- # Check if the data frame has a new column "BE"
- expect_true("basalExpr" %in% colnames(dtf_coef_with_BE))
-
- # Check if the values in the "BE" column are numeric
- expect_true(all(is.numeric(dtf_coef_with_BE$basalExpr)))
-
-})
-
-
-# Test 1: Check if the function returns the correct number of bins
-test_that("getBinExpression returns the correct number of bins", {
- dtf <- data.frame(mu_ij = c(10, 20, 30, 15, 25, 35, 40, 5, 12, 22))
- n_bins <- 3
- dtf_with_bins <- getBinExpression(dtf, n_bins)
- expect_equal(nrow(dtf_with_bins), nrow(dtf), label = "Number of rows should remain the same")
- expect_equal(ncol(dtf_with_bins), ncol(dtf) + 1, label = "Number of columns should increase by 1")
-})
-
-# Test 2: Check if the function adds the binExpression column correctly
-test_that("getBinExpression adds the binExpression column correctly", {
- dtf <- data.frame(mu_ij = c(10, 20, 30, 15, 25, 35, 40, 5, 12, 22))
- n_bins <- 3
- dtf_with_bins <- getBinExpression(dtf, n_bins)
- expected_bins <- c("BinExpression_1", "BinExpression_2", "BinExpression_3", "BinExpression_1", "BinExpression_2",
- "BinExpression_3", "BinExpression_3", "BinExpression_1", "BinExpression_1", "BinExpression_2")
- expect_equal(dtf_with_bins$binExpression, factor(expected_bins))
-})
-
-# Test 3: Check if the function handles negative values correctly
-test_that("getBinExpression handles negative values correctly", {
- dtf <- data.frame(mu_ij = c(10, -20, 30, -15, 25, 35, -40, 5, 12, -22))
- n_bins <- 4
- dtf_with_bins <- getBinExpression(dtf, n_bins)
- expected_bins <- c("BinExpression_3", "BinExpression_2", "BinExpression_4", "BinExpression_2", "BinExpression_4",
- "BinExpression_4", "BinExpression_1", "BinExpression_3", "BinExpression_3", "BinExpression_1")
- expect_equal(dtf_with_bins$binExpression, factor(expected_bins))
-})
-
-
-
diff --git a/tests/testthat/test-evaluate_dispersion.R b/tests/testthat/test-evaluate_dispersion.R
index 76e69a222ac3ec0cfb5a966ba165de73e9e613e3..46c4bce469b57943fe809ec34ec0f251d4640947 100644
--- a/tests/testthat/test-evaluate_dispersion.R
+++ b/tests/testthat/test-evaluate_dispersion.R
@@ -2,19 +2,6 @@
-# Example data
-
-
-# Tests
-test_that("dispersion_plot function works correctly", {
- eval_disp <- data.frame(
- actual_dispersion = c(0.1, 0.2, 0.3),
- inferred_dispersion = c(0.12, 0.18, 0.28),
- from = c("HTRfit", "HTRfit", "DESeq2")
- )
- disp_plot <- dispersion_plot(eval_disp, col = "from")
- expect_s3_class(disp_plot, "gg")
-})
test_that("extract_tmbDispersion function extracts dispersion correctly", {
N_GENES = 100
@@ -28,11 +15,11 @@ test_that("extract_tmbDispersion function extracts dispersion correctly", {
data = data2fit, group_by = "geneID",
family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
extracted_disp <- extract_tmbDispersion(l_res)
- expect_identical(colnames(extracted_disp), c("inferred_dispersion", "geneID"))
+ expect_identical(colnames(extracted_disp), c("estimate", "ID"))
})
test_that("extract_ddsDispersion function extracts dispersion correctly", {
- N_GENES = 100
+ N_GENES = 100
MAX_REPLICATES = 5
MIN_REPLICATES = 5
input_var_list <- init_variable(name = "varA", mu = 10, sd = 0.1, level = 3)
@@ -46,7 +33,7 @@ test_that("extract_ddsDispersion function extracts dispersion correctly", {
deseq_wrapped = wrap_dds(dds, 2, "greaterAbs")
extracted_disp <- extract_ddsDispersion(deseq_wrapped)
- expect_identical(colnames(extracted_disp), c("inferred_dispersion", "geneID"))
+ expect_identical(colnames(extracted_disp), c("estimate", "ID"))
})
test_that("getDispersionComparison function works correctly", {
@@ -64,37 +51,7 @@ test_that("getDispersionComparison function works correctly", {
tmb_disp_inferred <- extract_tmbDispersion(l_res)
comparison <- getDispersionComparison(tmb_disp_inferred, mock_data$groundTruth$gene_dispersion)
- expect_identical(colnames(comparison), c("actual_dispersion", "geneID", "inferred_dispersion"))
-})
-
-test_that("evaluateDispersion function works correctly", {
- N_GENES = 100
- MAX_REPLICATES = 5
- MIN_REPLICATES = 5
- input_var_list <- init_variable(name = "varA", mu = 10, sd = 0.1, level = 3)
- mock_data <- mock_rnaseq(input_var_list, N_GENES,
- min_replicates = MIN_REPLICATES, max_replicates = MAX_REPLICATES)
- data2fit <- prepareData2fit(countMatrix = mock_data$counts, metadata = mock_data$metadata)
- l_res <- fitModelParallel(formula = kij ~ varA,
- data = data2fit, group_by = "geneID",
- family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
- dds <- DESeq2::DESeqDataSetFromMatrix(
- countData = round(mock_data$counts),
- colData = mock_data$metadata,
- design = ~ varA)
- dds <- DESeq2::DESeq(dds, quiet = TRUE)
- deseq_wrapped = wrap_dds(dds, 2, "greaterAbs")
-
- tmb_disp_inferred <- extract_tmbDispersion(l_res)
- TMB_dispersion_df <- getDispersionComparison(tmb_disp_inferred, mock_data$groundTruth$gene_dispersion)
- TMB_dispersion_df$from <- 'HTRfit'
- DESEQ_disp_inferred <- extract_ddsDispersion(deseq_wrapped)
- DESEQ_dispersion_df <- getDispersionComparison(DESEQ_disp_inferred , mock_data$groundTruth$gene_dispersion)
- DESEQ_dispersion_df$from <- 'DESeq2'
-
- eval_disp <- evaluateDispersion(TMB_dispersion_df, DESEQ_dispersion_df, c("red", "blue"))
- expect_identical(names(eval_disp), c("disp_plot", "data"))
+ expect_identical(colnames(comparison), c("actual", "ID", "estimate", "term","description"))
})
-
diff --git a/tests/testthat/test-evaluation_identity.R b/tests/testthat/test-evaluation_identity.R
new file mode 100644
index 0000000000000000000000000000000000000000..1dedef1372f817c32baa8cdb8a2d1b142d0db23a
--- /dev/null
+++ b/tests/testthat/test-evaluation_identity.R
@@ -0,0 +1,53 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+
+# Test cases
+test_that("Identity plot is generated correctly", {
+ comparison_data <- data.frame(
+ actual = c(1, 2, 3, 4, 5),
+ estimate = c(0.9, 2.2, 2.8, 4.1, 5.2),
+ description = rep("Category A", 5),
+ from = c("A", "B", "A", "B", "A"),
+ term = rep("Category A", 5)
+ )
+
+ idTerm_obj <- eval_identityTerm(comparison_data)
+
+ expect_true("gg" %in% class(idTerm_obj$p))
+ expect_equal(c("from", "description", "R2"), colnames(idTerm_obj$R2))
+})
+
+
+
+# Test case 1: Check if the function returns a data frame
+test_that("compute_rsquare returns a data frame", {
+ data <- data.frame(from = c("A", "A", "A", "A"),
+ description = c("X", "Y", "X", "Y"),
+ actual = c(1, 2, 3, 4),
+ estimate = c(10, 20, 30, 40))
+ df_rsquare <- compute_rsquare(data, grouping_by = c("from", "description"))
+ expect_s3_class(df_rsquare, "data.frame")
+ expect_equal(df_rsquare$from, c("A", "A"))
+ expect_equal(df_rsquare$description, c("X", "Y"))
+ expect_equal(df_rsquare$R2, c(1, 1))
+
+})
+
+
+
+
+
+#' Unit Test for get_rsquare_2plot function.
+test_that("get_rsquare_2plot returns expected result", {
+ data_rsquare <- data.frame(from = c("A", "B", "C"), description = c("Desc1", "Desc2", "Desc3"), R2 = c(0.9, 0.8, 0.7))
+ result <- get_rsquare_2plot(data_rsquare)
+ expect_equal(names(result), c("from","description","R2" ,"pos_x", "pos_y", "label_italic","label_vjust"))
+ expect_equal(result$from, c("A","B", "C"))
+ expect_equal(result$description, c("Desc1","Desc2", "Desc3"))
+ expect_equal(result$label_vjust, c(1,2, 3))
+
+})
+
+
+
diff --git a/tests/testthat/test-identity_plot.R b/tests/testthat/test-identity_plot.R
deleted file mode 100644
index 2543b6fe1b5535a17f6d081108053ab1b01c969c..0000000000000000000000000000000000000000
--- a/tests/testthat/test-identity_plot.R
+++ /dev/null
@@ -1,19 +0,0 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
-
-
-
-# Test cases
-test_that("Identity plot is generated correctly", {
- comparison_data <- data.frame(
- actual = c(1, 2, 3, 4, 5),
- estimate = c(0.9, 2.2, 2.8, 4.1, 5.2),
- description = rep("Category A", 5)
- )
-
- plot <- identity_plot(comparison_data)
-
- expect_true("gg" %in% class(plot))
-})
-
-
-
diff --git a/tests/testthat/test-plot_metrics.R b/tests/testthat/test-plot_metrics.R
index 1f3c057923d96dc147171a36f2716e4ecb9b3ba0..d52f49d6059469a1886e819cf94aaa13db099ec3 100644
--- a/tests/testthat/test-plot_metrics.R
+++ b/tests/testthat/test-plot_metrics.R
@@ -17,7 +17,7 @@ test_that("subset_glance subsets the glance DataFrame correctly", {
-test_that("metrics_plot returns a ggplot object", {
+test_that("diagnostic_plot returns a ggplot object", {
data(iris)
l_glmTMB <- list(
@@ -28,7 +28,7 @@ test_that("metrics_plot returns a ggplot object", {
virginica = glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length,
data = subset(iris, Species == "virginica"))
)
- p <- metrics_plot(l_glmTMB)
+ p <- diagnostic_plot(l_glmTMB)
expect_true(inherits(p, "gg"))
})
diff --git a/tests/testthat/test-precision_recall.R b/tests/testthat/test-precision_recall.R
new file mode 100644
index 0000000000000000000000000000000000000000..c75285b29c9ee994afa753b9b0537fceff9e5b47
--- /dev/null
+++ b/tests/testthat/test-precision_recall.R
@@ -0,0 +1,102 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+
+
+test_that("compute_pr_curve computes precision-recall curve", {
+ # Mock data for testing
+ set.seed(42)
+ dt <- data.table::data.table(
+ description = rep(c("param1", "param2"), each = 50),
+ isDE = sample(0:1, 100, replace = TRUE),
+ p.adj = runif(100)
+ )
+
+ # Test the compute_pr_curve function
+ result <- compute_pr_curve(dt)
+ expect_true("recall" %in% names(result))
+ expect_true("precision" %in% names(result))
+})
+
+test_that("compute_pr_auc computes area under the precision-recall curve", {
+ # Mock data for testing
+ set.seed(42)
+ dt <- data.table::data.table(
+ description = rep(c("param1", "param2"), each = 50),
+ isDE = sample(0:1, 100, replace = TRUE),
+ p.adj = runif(100)
+ )
+
+ # Test the compute_pr_auc function
+ result <- compute_pr_auc(dt)
+ expect_equal(expected = 0.59, round(result, 2))
+})
+
+test_that("get_pr_object gets precision-recall objects", {
+ # Mock data for testing
+ set.seed(42)
+ dt_evaldata_params <- data.table::data.table(
+ description = rep(c("param1", "param2"), each = 50),
+ isDE = sample(0:1, 100, replace = TRUE),
+ from = c("A", "B"),
+ p.adj = runif(100)
+ )
+
+ # Test the get_pr_object function
+ result <- get_pr_object(dt_evaldata_params)
+
+ expect_true("byparams" %in% names(result))
+ expect_true("aggregate" %in% names(result))
+ expect_true("data.frame" %in% class(result$byparams$pr_curve))
+ expect_true("data.frame" %in% class(result$byparams$pr_auc))
+ expect_true("data.frame" %in% class(result$aggregate$pr_curve))
+ expect_true("data.frame" %in% class(result$aggregate$pr_auc))
+})
+
+test_that("build_gg_pr_curve builds ggplot precision-recall curve", {
+ # Mock data for testing
+ set.seed(42)
+ data_curve <- data.frame(
+ from = "A",
+ recall = seq(0, 1, length.out = 100),
+ precision = runif(100)
+ )
+ data_auc <- data.frame(from = "A", AUC = 0.75)
+
+ # Test the build_gg_pr_curve function
+ result <- build_gg_pr_curve(data_curve, data_auc)
+ expect_true("gg" %in% class(result))
+})
+
+test_that("get_pr_curve gets precision-recall curves and AUCs", {
+ # Mock data for testing
+ set.seed(42)
+ pr_obj <- list(
+ byparams = list(
+ pr_curve = data.frame(
+ from = c("A"),
+ description = rep(c("param1", "param2"), each = 50),
+ recall = seq(0, 1, length.out = 100),
+ precision = runif(100)
+ ),
+ pr_auc = data.frame(from = c("A"), description = c("param1", "param2"), AUC = c(0.75, 0.80))
+ ),
+ aggregate = list(
+ pr_curve = data.frame(
+ from = c("A"),
+ recall = seq(0, 1, length.out = 100),
+ precision = runif(100)
+ ),
+ pr_auc = data.frame(from = c("A"), description = c("param1", "param2"), AUC = c(0.75, 0.80))
+ )
+ )
+
+ # Test the get_pr_curve function
+ result <- get_pr_curve(pr_obj)
+ build_gg_pr_curve(pr_obj$aggregate$pr_curve, pr_obj$aggregate$pr_auc )
+ expect_true("byparams" %in% names(result))
+ expect_true("aggregate" %in% names(result))
+ expect_true("gg" %in% class(result$byparams$pr_curve))
+ expect_true("gg" %in% class(result$aggregate$pr_curve))
+})
+
diff --git a/tests/testthat/test-receiver_operating_characteristic.R b/tests/testthat/test-receiver_operating_characteristic.R
new file mode 100644
index 0000000000000000000000000000000000000000..2d5a08447cd9609ef463a80819ee5c86c80b617b
--- /dev/null
+++ b/tests/testthat/test-receiver_operating_characteristic.R
@@ -0,0 +1,106 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+
+# Test cases for getLabelExpected function
+test_that("getLabelExpected assigns labels correctly", {
+
+
+ # Sample comparison data frame
+ comparison_data <- data.frame(
+ geneID = c("gene1", "gene2", "gene3"),
+ actual = c(0.5, -0.3, 0.8)
+ )
+
+ # Test case 1: Alt hypothesis = "greater"
+ labeled_data_greater <- getLabelExpected(comparison_data, coeff_threshold = 0.2, alt_hypothesis = "greater")
+ expect_identical(labeled_data_greater$isDE, c(TRUE, FALSE, TRUE))
+
+ # Test case 2: Alt hypothesis = "less"
+ labeled_data_less <- getLabelExpected(comparison_data, coeff_threshold = -0.2, alt_hypothesis = "less")
+ expect_identical(labeled_data_less$isDE, c(FALSE, TRUE, FALSE))
+
+ # Test case 3: Alt hypothesis = "greaterAbs"
+ labeled_data_greaterAbs <- getLabelExpected(comparison_data, coeff_threshold = 0.6, alt_hypothesis = "greaterAbs")
+ expect_identical(labeled_data_greaterAbs$isDE, c(FALSE, FALSE, TRUE))
+
+})
+
+
+
+
+
+test_that("compute_roc_curve computes ROC curve from data frame", {
+ # Test data
+ dt <- data.frame(
+ isDE = c(1, 0, 1, 0, 1),
+ p.adj = c(0.8, 0.6, 0.7, 0.4, 0.9)
+ )
+
+ # Test
+ result <- compute_roc_curve(dt)
+ expect_equal(names(result), c("False positive rate", "True positive rate"))
+})
+
+test_that("compute_roc_auc computes AUC from data frame", {
+ # Test data
+ dt <- data.frame(
+ isDE = c(0, 1, 1, 0, 0, 0, 1),
+ p.adj = c(1, 0.75, 0.75, 0.5, 0.25, 0, 0.1)
+ )
+
+ # Expected output
+ expected_result <- 0.42
+
+ # Test
+ result <- compute_roc_auc(dt)
+ expect_equal(round(result,2 ), expected_result)
+})
+
+test_that("get_roc_object returns ROC curves and AUCs", {
+ # Test data
+ evaldata_params <- data.frame(
+ from = rep(c("HTRfit", "DESeq2"), each = 5),
+ description = rep(c("param1", "param2"), each = 5),
+ isDE = sample(0:1, 10, replace = TRUE),
+ p.adj = runif(10)
+ )
+
+ # Test
+ result <- get_roc_object(evaldata_params)
+ expect_equal(names(result), c("byparams", "aggregate"))
+ expect_equal(names(result$byparams), c("roc_curve", "roc_auc"))
+ expect_equal(names(result$aggregate), c("roc_curve", "roc_auc"))
+
+})
+
+test_that("build_gg_roc_curve builds ggplot ROC curve", {
+ # Test data
+ data_curve <- data.frame(
+ .threshold = c(-Inf, 0.9, 0.8, 0.7, 0.6, 0.4, Inf),
+ specificity = c(0, 1, 0.75, 0.5, 0.25, 0, 1),
+ sensitivity = c(1, 0.75, 0.75, 0.5, 0.25, 0, 0),
+ from = rep("HTRfit", 7)
+ )
+ data_auc <- data.frame(from = "HTRfit", AUC = 0.6875)
+
+ # Test
+ result <- build_gg_roc_curve(data_curve, data_auc)
+ # Ensure that the ggplot object is created without errors
+ expect_true("gg" %in% class(result))
+})
+
+test_that("get_label_y_position computes y-axis positions for labels", {
+ # Test data
+ data_auc <- data.frame(from = rep(c("HTRfit", "DESeq2"), each = 2), AUC = c(1, 0.90))
+
+ # Expected output
+ expected_result <- data.frame(from = rep(c("HTRfit", "DESeq2"), each = 2), AUC = c(1, 0.90), pos_y = c(0.05, 0.05, 0.15, 0.15))
+
+ # Test
+ result <- get_label_y_position(data_auc)
+ expect_equal(result, expected_result)
+})
+
+
+
diff --git a/tests/testthat/test-roc_plot.R b/tests/testthat/test-roc_plot.R
deleted file mode 100644
index 00a679b0f8272bf45a4d1079627284f252af4840..0000000000000000000000000000000000000000
--- a/tests/testthat/test-roc_plot.R
+++ /dev/null
@@ -1,52 +0,0 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
-
-
-
-# Test cases for getLabelExpected function
-test_that("getLabelExpected assigns labels correctly", {
-
-
- # Sample comparison data frame
- comparison_data <- data.frame(
- geneID = c("gene1", "gene2", "gene3"),
- actual = c(0.5, -0.3, 0.8)
- )
-
- # Test case 1: Alt hypothesis = "greater"
- labeled_data_greater <- getLabelExpected(comparison_data, coeff_threshold = 0.2, alt_hypothesis = "greater")
- expect_identical(labeled_data_greater$isDE, c(TRUE, FALSE, TRUE))
-
- # Test case 2: Alt hypothesis = "less"
- labeled_data_less <- getLabelExpected(comparison_data, coeff_threshold = -0.2, alt_hypothesis = "less")
- expect_identical(labeled_data_less$isDE, c(FALSE, TRUE, FALSE))
-
- # Test case 3: Alt hypothesis = "greaterAbs"
- labeled_data_greaterAbs <- getLabelExpected(comparison_data, coeff_threshold = 0.6, alt_hypothesis = "greaterAbs")
- expect_identical(labeled_data_greaterAbs$isDE, c(FALSE, FALSE, TRUE))
-
-})
-
-
-test_that("ROC plot is generated correctly", {
- comparison_data <- data.frame(
- geneID = c("gene1", "gene2", "gene3"),
- isDE = c(TRUE, FALSE, TRUE),
- p.adj = c(0.05, 0.2, 0.01),
- from = "example"
- )
-
- plot <- roc_plot(comparison_data, col = "from")
-
- expect_true("gg" %in% class(plot))
-
- comparison_data <- data.frame(
- geneID = c("gene1", "gene2", "gene3"),
- isDE = c(TRUE, FALSE, TRUE),
- p.adj = c(0.05, 0.2, 0.01) )
-
- plot <- roc_plot(comparison_data)
-
- expect_true("gg" %in% class(plot))
-})
-
-
diff --git a/tests/testthat/test-simulation_report.R b/tests/testthat/test-simulation_report.R
index d0d6694d18dc636457dbf85e0886135cc9700d4a..99899f9b59c70414f4aaabe68a281c5f4c6efd4b 100644
--- a/tests/testthat/test-simulation_report.R
+++ b/tests/testthat/test-simulation_report.R
@@ -26,3 +26,201 @@ test_that("Handling non-numeric values in the data frame", {
expect_s3_class(table_grob, "gtable")
})
+
+
+
+# Test get_eval_data_from_ltmb
+test_that("get_eval_data_from_ltmb returns correct output", {
+
+ input_var_list <- init_variable( name = "varA", mu = 3, sd = 2, level = 3)
+
+ ## -- Required parameters
+ N_GENES = 3
+ MIN_REPLICATES = 3
+ MAX_REPLICATES = 3
+ ########################
+
+ ## -- simulate RNAseq data based on input_var_list, minimum input required
+ ## -- number of replicate randomly defined between MIN_REP and MAX_REP
+ mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES)
+ ## -- data from simulation
+ count_matrix <- mock_data$counts
+ metaData <- mock_data$metadata
+ ##############################
+ ## -- convert counts matrix and samples metadatas in a data frame for fitting
+ data2fit = prepareData2fit(countMatrix = count_matrix,
+ metadata = metaData,
+ normalization = F)
+ l_tmb <- fitModelParallel(formula = kij ~ varA ,
+ data = data2fit,
+ group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"),
+ n.cores = 1)
+
+ eval_data_ltmb <- get_eval_data_from_ltmb(l_tmb, mock_data, 0.27, 'greater')
+ expect_is(eval_data_ltmb, "list")
+ expect_named(eval_data_ltmb, c("modelparams", "modeldispersion"))
+})
+
+# Test get_eval_data_from_dds
+test_that("get_eval_data_from_dds returns correct output", {
+
+ input_var_list <- init_variable( name = "varA", mu = 3, sd = 2, level = 3)
+
+ ## -- Required parameters
+ N_GENES = 100
+ MIN_REPLICATES = 3
+ MAX_REPLICATES = 3
+ ########################
+
+ ## -- simulate RNAseq data based on input_var_list, minimum input required
+ ## -- number of replicate randomly defined between MIN_REP and MAX_REP
+ mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES)
+ ## -- data from simulation
+ count_matrix <- mock_data$counts
+ metaData <- mock_data$metadata
+ ##############################
+
+ dds <- DESeq2::DESeqDataSetFromMatrix(count_matrix, colData = metaData, ~ varA )
+ dds <- DESeq2::DESeq(dds)
+
+ eval_data_dds <- get_eval_data_from_dds(dds, mock_data, 0.27, "greater")
+
+ expect_is(eval_data_dds, "list")
+ expect_named(eval_data_dds, c("modelparams", "modeldispersion"))
+})
+
+# Test rbind_evaldata_tmb_dds
+test_that("rbind_evaldata_tmb_dds returns correct output", {
+
+ input_var_list <- init_variable( name = "varA", mu = 3, sd = 2, level = 3)
+
+ ## -- Required parameters
+ N_GENES = 15
+ MIN_REPLICATES = 3
+ MAX_REPLICATES = 3
+ ########################
+
+ ## -- simulate RNAseq data based on input_var_list, minimum input required
+ ## -- number of replicate randomly defined between MIN_REP and MAX_REP
+ mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES)
+ ## -- data from simulation
+ count_matrix <- mock_data$counts
+ metaData <- mock_data$metadata
+ ##############################
+ ## -- convert counts matrix and samples metadatas in a data frame for fitting
+ data2fit = prepareData2fit(countMatrix = count_matrix,
+ metadata = metaData,
+ normalization = F)
+ l_tmb <- fitModelParallel(formula = kij ~ varA ,
+ data = data2fit,
+ group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"),
+ n.cores = 1)
+ dds <- DESeq2::DESeqDataSetFromMatrix(count_matrix, colData = metaData, ~ varA )
+ dds <- DESeq2::DESeq(dds)
+
+ eval_data_dds <- get_eval_data_from_dds(dds, mock_data, 0.27, "greater")
+ eval_data_ltmb <- get_eval_data_from_ltmb(l_tmb, mock_data, 0.27, 'greater')
+
+ combined_eval_data <- rbind_evaldata_tmb_dds(eval_data_ltmb, eval_data_dds)
+
+ expect_is(combined_eval_data, "list")
+ expect_named(combined_eval_data, c("modelparams", "modeldispersion"))
+})
+
+# Test rbind_model_params_and_dispersion
+test_that("rbind_model_params_and_dispersion returns correct output", {
+
+ input_var_list <- init_variable( name = "varA", mu = 3, sd = 2, level = 3)
+
+ ## -- Required parameters
+ N_GENES = 100
+ MIN_REPLICATES = 3
+ MAX_REPLICATES = 3
+ ########################
+
+ ## -- simulate RNAseq data based on input_var_list, minimum input required
+ ## -- number of replicate randomly defined between MIN_REP and MAX_REP
+ mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES)
+ ## -- data from simulation
+ count_matrix <- mock_data$counts
+ metaData <- mock_data$metadata
+ ##############################
+
+ dds <- DESeq2::DESeqDataSetFromMatrix(count_matrix, colData = metaData, ~ varA )
+ dds <- DESeq2::DESeq(dds)
+
+
+ eval_data <- get_eval_data_from_dds(dds, mock_data, 0.27, "greater")
+
+ combined_data <- rbind_model_params_and_dispersion(eval_data)
+
+ expect_is(combined_data, "data.frame")
+})
+
+# Test get_eval_data
+test_that("get_eval_data returns correct output", {
+
+ input_var_list <- init_variable( name = "varA", mu = 3, sd = 2, level = 3)
+
+ ## -- Required parameters
+ N_GENES = 50
+ MIN_REPLICATES = 3
+ MAX_REPLICATES = 3
+ ########################
+
+ ## -- simulate RNAseq data based on input_var_list, minimum input required
+ ## -- number of replicate randomly defined between MIN_REP and MAX_REP
+ mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES)
+ ## -- data from simulation
+ count_matrix <- mock_data$counts
+ metaData <- mock_data$metadata
+ ##############################
+ ## -- convert counts matrix and samples metadatas in a data frame for fitting
+ data2fit = prepareData2fit(countMatrix = count_matrix,
+ metadata = metaData,
+ normalization = F)
+ l_tmb <- fitModelParallel(formula = kij ~ varA ,
+ data = data2fit,
+ group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"),
+ n.cores = 1)
+ dds <- DESeq2::DESeqDataSetFromMatrix(count_matrix, colData = metaData, ~ varA )
+ dds <- DESeq2::DESeq(dds)
+
+
+ eval_data <- get_eval_data(l_tmb, dds, mock_data, 0.27, "greater")
+
+ expect_is(eval_data, "list")
+ expect_named(eval_data, c("modelparams", "modeldispersion"))
+ expect_equal(unique(eval_data$modelparams$from), c("HTRfit", "DESeq2"))
+
+
+ ## -- dds == NULL
+ eval_data <- get_eval_data(l_tmb, NULL, mock_data, 0.27, "greater")
+ expect_is(eval_data, "list")
+ expect_named(eval_data, c("modelparams", "modeldispersion"))
+ expect_equal(unique(eval_data$modelparams$from), c("HTRfit"))
+
+
+ ## -- l_tmb == NULL
+ eval_data <- get_eval_data(NULL, dds, mock_data, 0.27, "greater")
+ expect_is(eval_data, "list")
+ expect_named(eval_data, c("modelparams", "modeldispersion"))
+ expect_equal(unique(eval_data$modelparams$from), c("DESeq2"))
+
+})
+
+
+
diff --git a/vignettes/htrfit.Rmd b/vignettes/htrfit.Rmd
index f299228a706076ce8b1ef95d4340e96c45e5ae14..2c3b60bec2ff5435d06cb088e98026bda82e2631 100644
--- a/vignettes/htrfit.Rmd
+++ b/vignettes/htrfit.Rmd
@@ -31,490 +31,3 @@ If it is the first time you use {fusen}, after 'description', you can directly r
-->
-# High-Throughput RNA-seq model fit
-
-In the realm of RNAseq analysis, various key experimental parameters play a crucial role in influencing the statistical power to detect expression changes. Parameters such as sequencing depth, the number of replicates, and more have a significant impact. To navigate the selection of optimal values for these experimental parameters, we introduce a comprehensive statistical framework known as **HTRfit**, underpinned by computational simulation. **HTRfit** serves as a versatile tool, not only for simulation but also for conducting differential expression analysis. It facilitates this analysis by fitting Generalized Linear Models (GLMs) with multiple variables, which could encompass genotypes, environmental factors, and more. These GLMs are highly adaptable, allowing the incorporation of fixed effects, mixed effects, and interactions between variables.
-
-
-
-# Initialize variable to simulate
-
-The `init_variable()` function, which is a key tool for defining the variables in your experimental design. You can specify the variables' names and the size of the effects involved. By manually setting the effect of a variable, you make it a fixed effect, while random effect definitions can make it either fixed or mixed.
-
-
-## Manually init my first variable
-
-The `init_variable()` function allows for precise control over the variables in your experimental design.
-In this example, we manually initialize **varA** with specifics size effects (mu) and levels.
-
-
-
-```{r example-init_variable_man, warning = FALSE, message = FALSE}
-input_var_list <- init_variable( name = "varA", mu = c(0.2, 4, -3), level = 3)
-```
-
-## Randomly init my first variable
-
-Alternatively, you can randomly initialize **varA** by specifying a mean (mu) and standard deviation (sd).
-This introduces variability into **varA**, making it either a fixed or mixed effect in your design.
-
-
-```{r example-init_variable_rand, warning = FALSE, message = FALSE}
-input_var_list <- init_variable( name = "varA", mu = 10, sd = 0.2, level = 5)
-```
-
-## Randomly init several variables
-
-You can also initialize multiple variables, such as **varA** and **varB**, with random values.
-This flexibility allows you to create diverse experimental designs.
-
-
-```{r example-init_variable_mult, warning = FALSE, message = FALSE}
-input_var_list <- init_variable( name = "varA", mu = 10, sd = 0.2, level = 5) %>%
- init_variable( name = "varB", mu = -3, sd = 0.34, level = 2)
-```
-
-## Add interaction between variable
-
-Similarly to `init_variable()`, `add_interaction()` allow to init an interaction between variable.
-
-In this example, we initialize **varA** and **varB**, and create an interaction between **varA**, and **varB** using `add_interaction()`.
-
-
-```{r example-add_interaction, warning = FALSE, message = FALSE}
-input_var_list <- init_variable( name = "varA", mu = 3, sd = 0.2, level = 2) %>%
- init_variable( name = "varB", mu = 2, sd = 0.43, level = 2) %>%
- add_interaction( between_var = c("varA", "varB"), mu = 0.44, sd = 0.2)
-```
-
-## Initialized a complex design
-
-Interactions can involve a maximum of three variables, such as **varA**, **varB**, and **varC**.
-
-
-```{r example-add_interaction_complex, eval = FALSE, message = FALSE, warning = FALSE, include = TRUE}
-## -- example not evaluate in the vignette
-input_var_list <- init_variable( name = "varA", mu = 5, sd = 0.2, level = 2) %>%
- init_variable( name = "varB", mu = 1, sd = 0.78, level = 2) %>%
- init_variable( name = "varC", mu = c(2, 3), sd = NA, level = 2) %>%
- add_interaction( between_var = c("varA", "varC"), mu = 0.44, sd = 0.2) %>%
- add_interaction( between_var = c("varA", "varB"), mu = 0.43, sd = 0.37) %>%
- add_interaction( between_var = c("varB", "varC"), mu = -0.33, sd = 0.12) %>%
- add_interaction( between_var = c("varA", "varB" ,"varC"), mu = 0.87, sd = 0.18)
-```
-
-# Simulate RNAseq data
-
-In this section, you will explore how to generate RNAseq data based on the previously defined input variables. The `mock_rnaseq()` function enables you to manage parameters in your RNAseq design, including the number of genes, the minimum and maximum number of replicates within your experimental setup. You can also adjust the sequencing depth, the basal gene expression, and the gene dispersion used for simulating counts.
-
-
-## Minimal example
-
-```{r example-mock_rnaseq_min, warning = FALSE, message = FALSE}
-## -- Required parameters
-N_GENES = 30
-MIN_REPLICATES = 2
-MAX_REPLICATES = 10
-########################
-
-## -- simulate RNAseq data based on input_var_list, minimum input required
-## -- number of replicate randomly defined between MIN_REP and MAX_REP
-mock_data <- mock_rnaseq(input_var_list, N_GENES,
- min_replicates = MIN_REPLICATES,
- max_replicates = MAX_REPLICATES)
-
-## -- simulate RNAseq data based on input_var_list, minimum input required
-## -- Same number of repicates between conditions
-mock_data <- mock_rnaseq(input_var_list, N_GENES,
- min_replicates = MAX_REPLICATES,
- max_replicates = MAX_REPLICATES)
-```
-
-
-
-## Scaling genes counts with sequencing depth
-
-Sequencing depth is a critical parameter affecting the statistical power of an RNAseq analysis. With the `sequencing_depth` option in the `mock_rnaseq()` function, you have the ability to control this parameter.
-
-
-```{r example-mock_rnaseq_seqDepth, warning = FALSE, message = FALSE}
-## -- Required parameters
-N_GENES = 30
-MIN_REPLICATES = 2
-MAX_REPLICATES = 10
-########################
-
-SEQ_DEPTH = c(100000, 5000000, 10000000)## -- Possible number of reads/sample
-SEQ_DEPTH = 10000000 ## -- all samples have same number of reads
-mock_data <- mock_rnaseq(input_var_list, N_GENES,
- min_replicates = MIN_REPLICATES,
- max_replicates = MAX_REPLICATES,
- sequencing_depth = SEQ_DEPTH)
-```
-
-## Set gene dispersion
-
-The dispersion parameter ($\alpha_i$), characterizes the relationship between the variance of the observed count and its mean value. In simple terms, it quantifies how much we expect the observed count to deviate from the mean value. You can specify the dispersion for individual genes using the dispersion parameter.
-
-
-```{r example-mock_rnaseq_disp, warning = FALSE, message = FALSE}
-
-## -- Required parameters
-N_GENES = 30
-MIN_REPLICATES = 2
-MAX_REPLICATES = 4
-########################
-
-DISP = 0.1 ## -- Same dispersion for each genes
-DISP = 1000 ## -- Same dispersion for each genes
-DISP = runif(N_GENES, 0, 1000) ## -- Dispersion can vary between genes
-mock_data <- mock_rnaseq(input_var_list, N_GENES,
- min_replicates = MIN_REPLICATES,
- max_replicates = MAX_REPLICATES,
- dispersion = DISP )
-
-```
-
-## Set basal gene expression
-
-The basal gene expression parameter, accessible through the basal_expression option, allows you to control the fundamental baseline gene expression level. It lets you adjust the expected count when no other factors are influencing gene expression, making it a key factor for simulating RNAseq data that aligns with your experimental design.
-
-
-```{r example-mock_rnaseq_bexpr, warning = FALSE, message = FALSE}
-## -- Required parameters
-N_GENES = 50
-MIN_REPLICATES = 10
-MAX_REPLICATES = 10
-########################
-
-BASAL_EXPR = -3 ## -- Value can be negative to simulate low expressed gene
-BASAL_EXPR = 2 ## -- Same basal gene expression for the N_GENES
-BASAL_EXPR = c( -3, -1, 2, 8, 9, 10 ) ## -- Basal expression can vary between genes
-mock_data <- mock_rnaseq(input_var_list, N_GENES,
- min_replicates = MIN_REPLICATES,
- max_replicates = MAX_REPLICATES,
- basal_expression = BASAL_EXPR)
-
-## -- output list attributes
-names(mock_data)
-```
-
-# Theory behind HTRfit simulation
-
-<div id="bg" align="center">
- <img src="./figs/htrfit_workflow.png" width="500" height="300">
-</div>
-
-
-In this modeling framework, counts denoted as $K_{ij}$ for gene i and sample j are generated using a negative binomial distribution. The negative binomial distribution considers a fitted mean $\mu_{ij}$ and a gene-specific dispersion parameter $\alpha_i$.
-
-The fitted mean $\mu_{ij}$ is determined by a parameter, $q_{ij}$, which is proportionally related to the sum of all effects specified using `init_variable()` or `add_interaction()`. If basal gene expressions are provided, the $\mu_{ij}$ values are scaled accordingly using the gene-specific basal expression value ($bexpr_i$).
-
-Furthermore, the coefficients $\beta_i$ represent the natural logarithm fold changes for gene i across each column of the model matrix X. The dispersion parameter $\alpha_i$ plays a crucial role in defining the relationship between the variance of observed counts and their mean value. In simpler terms, it quantifies how far we expect observed counts to deviate from the mean value.
-
-
-
-
-# Fitting models
-
-## Prepare data for fitting
-
-The `prepareData2fit()` function serves the purpose of converting the counts matrix and sample metadata into a dataframe that is compatible with downstream **HTRfit** functions designed for model fitting. This function also includes an option to perform median ratio normalization on the data counts.
-
-
-
-```{r example-prepareData, warning = FALSE, message = FALSE}
-## -- data from simulation or real data
-count_matrix <- mock_data$counts
-metaData <- mock_data$metadata
-##############################
-
-## -- convert counts matrix and samples metadatas in a data frame for fitting
-data2fit = prepareData2fit(countMatrix = count_matrix,
- metadata = metaData,
- normalization = F)
-
-
-## -- median ratio normalization
-data2fit = prepareData2fit(countMatrix = count_matrix,
- metadata = metaData,
- normalization = T,
- response_name = "kij")
-
-## -- output
-head(data2fit)
-```
-
-## Fit model from your data
-
-The `fitModelParallel()` function enables independent model fitting for each gene. The number of threads used for this process can be controlled by the `n.cores` parameter.
-
-
-```{r example-fitModelParallel, warning = FALSE, message = FALSE}
-l_tmb <- fitModelParallel(formula = kij ~ varA,
- data = data2fit,
- group_by = "geneID",
- family = glmmTMB::nbinom2(link = "log"),
- n.cores = 1)
-```
-
-## Use mixed effect in your model
-
-**HTRfit** uses the **glmmTMB** functions for model fitting algorithms. This choice allows for the utilization of random effects within your formula design. For further details on how to specify your model, please refer to the [mixed model documentation](https://rdrr.io/cran/glmmTMB/man/glmmTMBControl.html).
-
-
-
-```{r example-fitModelParallel_mixed, warning = FALSE, message = FALSE}
-l_tmb <- fitModelParallel(formula = kij ~ varA + ( 1 | varB ),
- data = data2fit,
- group_by = "geneID",
- family = glmmTMB::nbinom2(link = "log"),
- n.cores = 1)
-```
-
-## Additional settings
-
-The function provides precise control over model settings for fitting optimization, including options for specifying the [model family](https://www.rdocumentation.org/packages/stats/versions/3.6.2/topics/family) and [model control setting](https://rdrr.io/cran/glmmTMB/man/glmmTMBControl.html). By default, a Gaussian family model is fitted, but for RNA-seq data, it is highly recommended to specify `family = glmmTMB::nbinom2(link = "log")`.
-
-
-
-```{r example-fitModelParallel_addSet, warning = FALSE, message = FALSE}
-l_tmb <- fitModelParallel(formula = kij ~ varA,
- data = data2fit,
- group_by = "geneID",
- n.cores = 1,
- family = glmmTMB::nbinom2(link = "log"),
- control = glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e5,
- eval.max=1e5)))
-```
-
-## Not only RNAseq data
-
-As the model family can be customized, HTRfit is not exclusively tailored for RNA-seq data.
-
-
-```{r example-fitModelParallel_nonRNA, warning = FALSE, message = FALSE, eval = FALSE}
-## -- example not evaluate in the vignette
-data("iris")
-l_tmb <- fitModelParallel(formula = Sepal.Length ~ Sepal.Width + Petal.Length + Petal.Width ,
- data = iris,
- group_by = "Species",
- family = gaussian(),
- n.cores = 1)
-```
-
-## Update fit
-
-The `updateParallel()` function updates and re-fits a model for each gene. It offers options similar to those in `fitModelParallel()`.
-
-
-```{r example-update, warning = FALSE, message = FALSE}
-## -- update your fit modifying the model family
-l_tmb <- updateParallel(formula = kij ~ varA,
- list_tmb = l_tmb ,
- family = gaussian(),
- n.cores = 1)
-
-## -- update fit using additional model control settings
-l_tmb <- updateParallel(formula = kij ~ varA ,
- list_tmb = l_tmb ,
- family = gaussian(),
- n.cores = 1,
- control = glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,
- eval.max=1e3)))
-
-
-## -- update your model formula and your family model
-l_tmb <- updateParallel(formula = kij ~ varA + varB + varA:varB ,
- list_tmb = l_tmb ,
- family = glmmTMB::nbinom2(link = "log"),
- n.cores = 1)
-
-## -- output
-l_tmb$gene1
-```
-
-## Plot fit metrics
-
-Visualizing fit metrics is essential for evaluating your models. Here, we show you how to generate various plots to assess the quality of your models. You can explore all metrics or focus on specific aspects like dispersion and log-likelihood.
-
-
-```{r example-plotMetrics, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 6}
-## -- plot all metrics
-metrics_plot(list_tmb = l_tmb)
-```
-
-```{r example-plotMetricsFocus, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 3, fig.width = 4}
-## -- Focus on metrics
-metrics_plot(list_tmb = l_tmb, focus = c("dispersion", "logLik"))
-```
-
-## Anova to select the best model
-
-Utilizing the `anovaParallel()` function enables you to perform model selection by assessing the significance of the fixed effects. You can also include additional parameters like type. For more details, refer to [car::Anova](https://rdrr.io/cran/car/man/Anova.html).
-
-
-```{r example-anova, warning = FALSE, message = FALSE}
-## -- update your fit modifying the model family
-l_anova <- anovaParallel(list_tmb = l_tmb)
-
-## -- additional settings
-l_anova <- anovaParallel(list_tmb = l_tmb, type = "III" )
-
-## -- output
-l_anova$gene1
-```
-
-# Simulation evaluation report
-
-In this section, we delve into the evaluation of your simulation results. The `simulationReport()` function provide valuable insights into the performance of your simulated data and models.
-
-
-```{r example-simulationReport, warning = FALSE, message = FALSE, results = 'hide', fig.keep = 'none'}
-## -- get simulation/fit evaluation
-resSimu <- simulationReport(mock_data,
- list_tmb = l_tmb,
- coeff_threshold = 0.4,
- alt_hypothesis = "greaterAbs")
-```
-
-## Identity plot
-
-The identity plot, generated by the `simulationReport()` function, provides a visual means to compare the effects used in the simulation (actual effects) with those inferred by the model. This graphical representation facilitates the assessment of the correspondence between the values of the simulated effects and those estimated by the model, allowing for a visual analysis of the model's goodness of fit to the simulated data.
-
-
-
-```{r example-simulationReport_plotID, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 5}
-resSimu$identity_plot
-
-```
-
-## Dispersion plot
-
-The dispersion plot, generated by the `simulationReport()` function, offers a visual comparison of the dispersion parameters used in the simulation \(\alpha_i\) with those estimated by the model. This graphical representation provides an intuitive way to assess the alignment between the simulated dispersion values and the model-inferred values, enabling a visual evaluation of how well the model captures the underlying data characteristics.
-
-The area under the ROC curve (AUC) provides a single metric that summarizes the model's overall performance in distinguishing between differentially expressed and non-differentially expressed genes. A higher AUC indicates better model performance.
-
-
-```{r example-simulationReport_plotDisp, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 5}
-resSimu$dispersionEvaluation$disp_plot
-```
-
-## ROC curve
-
-The Receiver Operating Characteristic (ROC) curve is a valuable tool for assessing the performance of classification models, particularly in the context of identifying differentially expressed genes. It provides a graphical representation of the model's ability to distinguish between genes that are differentially expressed and those that are not, by varying the `coeff_threshold` and the `alt_hypothesis` parameters.
-
-
-```{r example-simulationReport_plotRoc, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 5}
-resSimu$roc_plot
-```
-
-## Compare HTRfit with DESeq2
-
-**HTRfit** offers a wrapper for **DESeq2** outputs. This functionality allows users to seamlessly integrate the results obtained from **DESeq2** into the **HTRfit** analysis pipeline. By doing so, you can readily compare the performance of **HTRfit** with **DESeq2** on your RNAseq data. This comparative analysis aids in determining which tool performs better for your specific research goals and dataset
-
-
-```{r example-ddsComparison, warning = FALSE, message = FALSE, results = 'hide', fig.keep = 'none'}
-## -- DESeq2
-library(DESeq2)
-dds <- DESeq2::DESeqDataSetFromMatrix(
- countData = count_matrix,
- colData = metaData,
- design = ~ varA + varB + varA:varB )
-dds <- DESeq2::DESeq(dds, quiet = TRUE)
-
-
-## -- get simulation/fit evaluation
-resSimu <- simulationReport(mock_data,
- list_tmb = l_tmb,
- dds_obj = dds,
- coeff_threshold = 0.4,
- alt_hypothesis = "greaterAbs")
-```
-
-```{r example-outputResSimu, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 5}
-## -- identity plot
-resSimu$identity_plot
-## -- dispersion
-resSimu$dispersionEvaluation$disp_plot
-## -- roc curve
-resSimu$roc_plot
-```
-
-## Focus evaluation on a subset of genes
-
-In this section, we showcase the assessment of model performance on a subset of genes. Specifically, we focus on evaluating genes with low expression levels, identified by their basal expression ($bexpr_i$) initialized below 0 during the simulation.
-
-
-```{r example-subsetGenes, warning = FALSE, message = FALSE, results = 'hide', fig.keep = 'none'}
-## -- Focus on low expressed genes
-low_expressed_df <- mock_data$groundTruth$effects[ mock_data$groundTruth$effects$basalExpr < 0, ]
-l_genes <- unique(low_expressed_df$geneID)
-mock_lowExpressed <- subsetGenes(l_genes, mock_data)
-
-
-## -- get simulation/fit evaluation
-resSimu <- simulationReport(mock_lowExpressed,
- list_tmb = l_tmb,
- dds_obj = dds,
- coeff_threshold = 0.4,
- alt_hypothesis = "greaterAbs")
-```
-
-As we compare this evaluation to the previous one, we observe a reduction in the AUC for both **HTRfit** and **DESeq2** inferences.
-
-
-```{r example-subsetGenes_rocPlot, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 5}
-## -- roc curve
-resSimu$roc_plot
-```
-
-# Evaluate model inference involving mixed effects
-
-For certain experimental scenarios, such as those involving a high number of levels or longitudinal data, the utilization of mixed effects within your design formula can be beneficial. The **HTRfit** simulation framework also offers the capability to assess this type of design formula.
-
-
-```{r example-evalMixed, warning = FALSE, message = FALSE, results = 'hide', fig.keep = 'none'}
-## -- init a design with a high number of levels
-input_var_list <- init_variable( name = "varA", mu = 0, sd = 0.29, level = 60) %>%
- init_variable( name = "varB", mu = 0.27, sd = 0.6, level = 2) %>%
- add_interaction( between_var = c("varA", "varB"), mu = 0.44, sd = 0.89)
-## -- simulate RNAseq data
-mock_data <- mock_rnaseq(input_var_list,
- n_genes = 30,
- min_replicates = 10,
- max_replicates = 10,
- basal_expression = 5 )
-## -- prepare data & fit a model with mixed effect
-data2fit = prepareData2fit(countMatrix = mock_data$counts,
- metadata = mock_data$metadata,
- normalization = F)
-l_tmb <- fitModelParallel(formula = kij ~ varB + (varB | varA),
- data = data2fit,
- group_by = "geneID",
- family = glmmTMB::nbinom2(link = "log"),
- n.cores = 1)
-## -- output
-l_tmb$gene1
-## -- evaluation
-resSimu <- simulationReport(mock_data,
- list_tmb = l_tmb,
- coeff_threshold = 0.27,
- alt_hypothesis = "greater")
-```
-
-```{r example-outputResSimuMixed, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 5}
-## -- identity plot
-resSimu$identity_plot
-## -- dispersion
-resSimu$dispersionEvaluation$disp_plot
-## -- roc curve
-resSimu$roc_plot
-```
-
-# About mixed model evaluation
-
-**HTRfit** offers a versatile simulation framework capable of fitting various types of models involving mixed effects, thanks to its implementation of **glmmTMB**. By combining the functionalities of `init_variable()` and `add_interaction()`, **HTRfit** enables the simulation of even the most complex experimental designs. However, it's important to note that as of now, HTRfit supports the evaluation of only *Type I* mixed models. In this context, *Type I* models are defined as those that follow the structure: `~ varA + (1 | varB)` or `~ varA + (varA | varB)`. Models not conforming to this specific form cannot be evaluated using **HTRfit's** current implementation. Nonetheless, you are welcome to extend its capabilities by implementing support for additional model types.
-
-
-