diff --git a/.dockerfile/2.0.0-beta/dockerfile b/.dockerfile/2.0.0-beta/dockerfile
new file mode 100644
index 0000000000000000000000000000000000000000..7a91b90f7b9e212d2fb95d53c76943f660657e2f
--- /dev/null
+++ b/.dockerfile/2.0.0-beta/dockerfile
@@ -0,0 +1,15 @@
+FROM rocker/r-base:4.3.1
+
+
+RUN apt-get -y update && \
+ apt-get -y install cmake libxml2-dev libcurl4-gnutls-dev
+
+COPY HTRfit_2.0.0-beta.tar.gz /HTRfit_2.0.0-beta.tar.gz
+
+RUN R -e "install.packages(c('parallel', 'data.table', 'ggplot2', 'gridExtra', 'glmmTMB', 'magrittr', 'MASS', 'reshape2', 'rlang', 'stats', 'utils', 'BiocManager', 'car'))"
+
+RUN R -e "BiocManager::install('S4Vectors', update = FALSE)"
+
+RUN R -e "BiocManager::install('DESeq2', update = FALSE)"
+
+RUN R -e "install.packages('/HTRfit_2.0.0-beta.tar.gz', repos = NULL, type='source')"
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000000000000000000000000000000000000..c84bd3f0060631fddd073be699a7bfbe4699406d
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,6 @@
+inst/doc
+.Rproj.user
+.Rbuildignore
+HTRfit.Rproj
+.Rhistory
+vignettes/log.txt
diff --git a/CHANGELOG b/CHANGELOG
index e4ec350761cfd4056563507b38926cbc82caacf1..04fcf38ba5f8a858ebfbc0edf6d8d8517ff258a7 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -25,3 +25,10 @@ To do:
- Fix bug with packageVersion("HTRfit")
+# v2.0.0 : Enhanced evaluation metrics
+
+ - Improved Documentation: Clearer and more comprehensive information on HTRfit functionalities and usage.
+ - Additional Metrics: Added PR curve, precision, recall, accuracy, and R2 for enhanced model evaluation.
+ - Reduced Dependencies: Streamlined installation by removing the need for plotROC.
+
+
diff --git a/DESCRIPTION b/DESCRIPTION
index 39a3fdc6ba8882b5df5d996125028e61b498c8ec..100a8d95c29febb0d4ce4fa1fb6571e7cedf4000 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,6 +1,6 @@
Package: HTRfit
Title: HTRfit
-Version: 1.0.2
+Version: 2.0.0
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 bd1c8e33dc27762287f9d98187f4add7f2503186..2d61f27fa5aeb1fb8aff4ca690584377bf9495a1 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -1,28 +1,42 @@
# Generated by roxygen2: do not edit by hand
export("%>%")
+export(Area_Under_Curve)
+export(ConfusionDF)
+export(ConfusionMatrix)
+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)
export(calculate_actual_interactionX3_values)
+export(checkFractionOfZero)
export(check_input2interaction)
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 +94,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)
@@ -95,16 +120,24 @@ export(is_formula_mixedTypeI)
export(is_fullrank)
export(is_mixedEffect_inFormula)
export(is_positive_definite)
+export(is_truthLabels_valid)
+export(is_validGroupBy)
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)
@@ -112,13 +145,12 @@ 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(subsetData_andfit)
export(subsetFixEffectInferred)
export(subsetGenes)
export(subset_glance)
@@ -128,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)
@@ -135,35 +169,38 @@ 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)
@@ -174,6 +211,7 @@ 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/evaluation_withmixedeffect.R b/R/evaluation_withmixedeffect.R
index 4b204476fd04f6c2c663b4fcfb808de8dfcddd3d..7a406bd487232220af0a5a3e787672631aecf1aa 100644
--- a/R/evaluation_withmixedeffect.R
+++ b/R/evaluation_withmixedeffect.R
@@ -33,6 +33,8 @@ is_formula_mixedTypeI <- function(formula) {
if (length(all.vars(formula)) != 3) return(FALSE)
if (sum(all.names(formula) == "+") > 1) return(FALSE)
if (sum(all.names(formula) == "/") > 0) return(FALSE)
+ all_var_in_formula <- all.vars(formula, unique = F)
+ if (length(all_var_in_formula) == 4 && all_var_in_formula[2] != all_var_in_formula[3]) return(FALSE)
return(TRUE)
}
@@ -130,7 +132,8 @@ getActualMixed_typeI <- function(list_logqij, genes_iter_list, categoricalVar_in
#' Compare the mixed-effects inference to expected values.
#'
-#' This function compares the mixed-effects inference obtained from a mixed-effects model to expected values derived from a ground truth dataset. The function assumes a specific type I mixed-effect structure in the input model.
+#' This function compares the mixed-effects inference obtained from a mixed-effects model to expected values derived from a ground truth dataset.
+#' The function assumes a specific type I mixed-effect structure in the input model.
#
#' @param tidy_tmb tidy model results obtained from fitting a mixed-effects model.
#' @param ground_truth_eff A data frame containing ground truth effects.
@@ -172,8 +175,8 @@ inferenceToExpected_withMixedEff <- function(tidy_tmb, ground_truth_eff){
#' Calculate actual mixed effects.
#'
#' This function calculates actual mixed effects based on the given data for a specific type I mixed-effect structure.
-# It calculates the expected values, standard deviations, and correlations between the fixed and random effects.
-# The function is designed to work with specific input data for type I mixed-effect calculations.
+# It calculates the expected values, standard deviations, and correlations between the fixed and random effects.
+# The function is designed to work with specific input data for type I mixed-effect calculations.
#
#' @param data_gene Data for a specific gene.
#' @param labelRef_InCategoricalVar The reference label for the categorical variable.
diff --git a/R/fake-section-title.R b/R/fake-section-title.R
new file mode 100644
index 0000000000000000000000000000000000000000..72d65fe5ac370bd3d2ef754583daf56a0f49251e
--- /dev/null
+++ b/R/fake-section-title.R
@@ -0,0 +1,931 @@
+# 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."))
+
+ ## replace infinite numbers by max values
+ ## avoid prob with infinite values
+ #for (i in 1:length(predictions)) {
+ # epsilon <- max(predictions[[i]][is.finite(predictions[[i]] )])
+ # idx_inf_values <- !is.finite( predictions[[i]] )
+ # predictions[[i]][idx_inf_values] <- epsilon
+ #}
+
+ ## 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)
+ }
+
+ }
+ #print(levels)
+ #print(labels)
+ 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 b38b1df102da2b147a3ba260d89d2c791439a288..4ae9cb79a03730683ed1869a0e36c896f59fb6b8 100644
--- a/R/fitmodel.R
+++ b/R/fitmodel.R
@@ -25,6 +25,27 @@ isValidInput2fit <- function(data2fit, formula){
}
+
+#' Check if group by exist in data
+#'
+#' @param data The data framecontaining the variables to be used for model fitting.
+#' @param group_by Column name in data representing the grouping variable
+#'
+#' @return \code{TRUE} if exist otherwise an error is raised
+#'
+#' @examples
+#' is_validGroupBy(mtcars, 'mpg')
+#' @export
+is_validGroupBy <- function(data, group_by){
+ validGroupBy <- group_by %in% names(data)
+ if (!validGroupBy)
+ stop("<Group by> doen't exist in data !")
+ return(TRUE)
+}
+
+
+
+
#' Drop Random Effects from a Formula
#'
#' This function allows you to remove random effects from a formula by specifying
@@ -105,7 +126,7 @@ is_fullrank <- function(metadata, formula) {
#' Fit a model using the fitModel function.
-#' @param group group id to save in glmmTMB obj (usefull for update !)
+#' @param group ID to fit
#' @param formula Formula specifying the model formula
#' @param data Data frame containing the data
#' @param ... Additional arguments to be passed to the glmmTMB::glmmTMB function
@@ -113,9 +134,11 @@ is_fullrank <- function(metadata, formula) {
#' @export
#' @examples
#' fitModel("mtcars" , formula = mpg ~ cyl + disp, data = mtcars)
-fitModel <- function(group, formula, data, ...) {
+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
@@ -125,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)
}
@@ -132,24 +156,22 @@ fitModel <- function(group, formula, data, ...) {
#' Fit the model based using fitModel functions.
#'
-#' @param group The specific group to fit the model for
+#' @param groups list of group ID
#' @param group_by Column name in data representing the grouping variable
-#' @param formula Formula specifying the model formula
#' @param data Data frame containing the data
-#' @param ... Additional arguments to be passed to the glmmTMB::glmmTMB function
-#' @return Fitted model object or NULL if there was an error
+#' @return list of dataframe
#' @export
+#' @importFrom stats setNames
#' @examples
-#' subsetData_andfit(group = "setosa", group_by = "Species",
-#' formula = Sepal.Length ~ Sepal.Width + Petal.Length,
+#' prepare_dataParallel(groups = iris$Species, group_by = "Species",
#' data = iris )
-subsetData_andfit <- function(group, group_by, formula, data, ...) {
- subset_data <- data[data[[group_by]] == group, ]
- fit_res <- fitModel(group, formula, subset_data, ...)
- #glance_df <- glance.negbin(group_by ,group , fit_res)
- #tidy_df <- tidy.negbin(group_by ,group,fit_res )
- #list(glance = glance_df, summary = tidy_df)
- fit_res
+prepare_dataParallel <- function(groups, group_by, data) {
+
+ l_data2parallel <- lapply( stats::setNames(groups, groups) , function( group_id ){
+ subset_data <- data[ data[[ group_by ]] == group_id, ]
+ return(subset_data)
+ })
+ return(l_data2parallel)
}
@@ -159,22 +181,22 @@ subsetData_andfit <- function(group, group_by, formula, data, ...) {
#' This function fits the model using the specified group, group_by, formula, and data.
#' It handles warnings and errors during the fitting process and returns the fitted model or NULL if there was an error.
#'
-#' @param group The specific group to fit the model for
+#' @param data Data frame containing the data
#' @param group_by Column name in data representing the grouping variable
#' @param formula Formula specifying the model formula
-#' @param data Data frame containing the data
#' @param ... Additional arguments to be passed to the glmmTMB::glmmTMB function
#' @return List with 'glance' and 'summary' attributes representing the fitted model or NULL if there was an error
#' @export
#' @examples
-#' launchFit(group = "setosa", group_by = "Species",
+#' launchFit(group_by = "Species",
#' formula = Sepal.Length ~ Sepal.Width + Petal.Length,
-#' data = iris )
-launchFit <- function(group, group_by, formula, data, ...) {
+#' data = iris[ iris[["Species"]] == "setosa" , ] )
+launchFit <- function(data, group_by, formula, ...) {
+ group <- unique(data[[ group_by ]])
tryCatch(
expr = {
withCallingHandlers(
- subsetData_andfit(group, group_by, formula, data, ...),
+ fitModel(group , formula, data, ...),
warning = function(w) {
message(paste(Sys.time(), "warning for group", group, ":", conditionMessage(w)))
invokeRestart("muffleWarning")
@@ -183,7 +205,6 @@ launchFit <- function(group, group_by, formula, data, ...) {
error = function(e) {
message(paste(Sys.time(), "error for group", group, ":", conditionMessage(e)))
NULL
- #return(list(glance = empty.glance.negbin(group_by, group), summary = empty.tidy.negbin(group_by, group)))
}
)
}
@@ -197,27 +218,36 @@ launchFit <- function(group, group_by, formula, data, ...) {
#' @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
-#' @importFrom stats setNames
#' @export
#' @examples
-#' parallel_fit(group_by = "Species", "setosa",
+#' parallel_fit(group_by = "Species", groups = iris$Species,
#' 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 = " "))
+
- clust <- parallel::makeCluster(n.cores, outfile = log_file)
- parallel::clusterExport(clust, c("subsetData_andfit", "fitModel"), envir=environment())
- results_fit <- parallel::parLapply(clust, X = stats::setNames(groups, groups), fun = launchFit,
- group_by = group_by, formula = formula, data = data, ...)
+ ## get data for parallelization
+ l_data2parallel <- prepare_dataParallel(groups, group_by, data)
+
+ clust <- parallel::makeCluster(n.cores, outfile = log_file , type= cl_type )
+ parallel::clusterExport(clust, c("fitModel"))
+ 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)
}
@@ -231,24 +261,27 @@ 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
+ ## Some verification
isValidInput2fit(data, formula)
is_fullrank(data, formula)
-
+ is_validGroupBy(data, group_by)
+
## -- print log location
message( paste("Log file location", log_file, sep =': ') )
- groups <- unique(data[[group_by]])
# Fit models in parallel and capture the results
- results <- parallel_fit(groups, group_by, formula, data, n.cores, log_file, ...)
+ groups <- unique(data[[ group_by ]])
+ 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..dcf8a0581d43df41c0379a17314b2a23d4114e1e
--- /dev/null
+++ b/R/mlmetrics.R
@@ -0,0 +1,259 @@
+# 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"
+#' @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")
+#' @importFrom stats splinefun
+#' @export
+Area_Under_Curve <- function(x, y, method = "trapezoid"){
+ idx <- order(x)
+ x <- x[idx]
+ y <- y[idx]
+ if (method == 'trapezoid'){
+ auc <- sum((rowMeans(cbind(y[-length(y)], y[-1]))) * (x[-1] - x[-length(x)]))
+ }else if (method == 'step'){
+ auc <- sum(y[-length(y)] * (x[-1] - x[-length(x)]))
+ }else if (method == 'spline'){
+ auc <- integrate(splinefun(x, y, method = "natural"), lower = min(x), upper = max(x))
+ auc <- auc$value
+ }
+ return(auc)
+}
+
+
+
+.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] )
+}
+
+
+
diff --git a/R/mock_rnaseq.R b/R/mock_rnaseq.R
index 6e3aef3d6f2431986810830fd7ff009fbcf72f03..7fc440aedddce49d047fdee2e3a127f914e1aaad 100644
--- a/R/mock_rnaseq.R
+++ b/R/mock_rnaseq.R
@@ -104,20 +104,54 @@ mock_rnaseq <- function(list_var, n_genes, min_replicates, max_replicates, seque
dtf_countsTable <- scaleCountsTable(dtf_countsTable, sequencing_depth)
}
+ checkFractionOfZero(dtf_countsTable)
+
metaData <- getSampleMetadata(list_var, n_genes, matx_bool_replication)
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)
}
+#' Check Fraction of Zero or One in Counts Table
+#'
+#' This function checks the percentage of counts in a given counts table that are either zero or one.
+#' If more than 50% of the counts fall in this category, a warning is issued, suggesting a review of input parameters.
+#'
+#' @param counts_table A matrix or data frame representing counts.
+#' @return NULL
+#' @export
+#' @examples
+#' # Example usage:
+#' counts_table <- matrix(c(0, 1, 2, 3, 4, 0, 0, 1, 1), ncol = 3)
+#' checkFractionOfZero(counts_table)
+checkFractionOfZero <- function(counts_table){
+
+ dim_matrix <- dim(counts_table)
+
+ n_counts <- dim_matrix[1]*dim_matrix[2]
+
+ n_zero_or_one <- sum(counts_table < 1)
+
+ fractionOfZero <- n_zero_or_one/n_counts*100
+
+ if( fractionOfZero > 50) {
+ message("50% of the counts simulated are bellow 1. Consider reviewing your input parameters.")
+ }
+
+ return(NULL)
+
+}
+
#' Validate and Filter Dispersion Values
diff --git a/R/na-na.R b/R/na-na.R
new file mode 100644
index 0000000000000000000000000000000000000000..72d65fe5ac370bd3d2ef754583daf56a0f49251e
--- /dev/null
+++ b/R/na-na.R
@@ -0,0 +1,931 @@
+# 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."))
+
+ ## replace infinite numbers by max values
+ ## avoid prob with infinite values
+ #for (i in 1:length(predictions)) {
+ # epsilon <- max(predictions[[i]][is.finite(predictions[[i]] )])
+ # idx_inf_values <- !is.finite( predictions[[i]] )
+ # predictions[[i]][idx_inf_values] <- epsilon
+ #}
+
+ ## 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)
+ }
+
+ }
+ #print(levels)
+ #print(labels)
+ 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/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..c9ececc8d5e98ed705aafad1d3182b0be9638884
--- /dev/null
+++ b/R/precision_recall.R
@@ -0,0 +1,159 @@
+# 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){
+ ## -- replace 0 by minimum machine
+ dt$p.adj[ dt$p.adj == 0 ] <- 1e-217
+ ## --see .SDcols for order
+ pred_obj <- prediction( -log10(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) Area_Under_Curve( dt$recall, dt$precision )
+
+
+#' 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" ) {
+
+ ## -- subset fixed eff
+ evaldata_params <- subset(evaldata_params, effect == "fixed")
+
+ ## -- by params -- random class AUC
+ prop_table <- table(evaldata_params[[col_param]], evaldata_params[[col_truth]])
+ random_classifier_auc_params <- prop_table[,"TRUE"]/rowSums(prop_table)
+ random_classifier_auc_params <- as.data.frame(random_classifier_auc_params)
+ random_classifier_auc_params[col_param] <- rownames(random_classifier_auc_params)
+
+ ## -- aggregate -- random class AUC
+ prop_table <- table(evaldata_params[[col_truth]])
+ random_classifier_auc_agg <- unname(prop_table["TRUE"]/sum(prop_table))
+
+ ## -- 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 <- pr_curve_params[, compute_pr_auc(.SD), by=c("from", col_param), .SDcols=c("recall", "precision")]
+ names(pr_auc_params)[ names(pr_auc_params) == "V1" ] <- "pr_AUC"
+ pr_auc_params <- join_dtf(pr_auc_params, random_classifier_auc_params ,
+ k1 = col_param, k2 = col_param)
+ names(pr_auc_params)[ names(pr_auc_params) == "random_classifier_auc_params" ] <- "pr_randm_AUC"
+
+
+
+
+ ## -- aggregate
+ pr_curve_agg <- dt_evaldata_params[, compute_pr_curve(.SD), by = "from", .SDcols=c(col_truth, col_score)]
+ pr_auc_agg <- pr_curve_agg[, compute_pr_auc(.SD), by = "from", .SDcols=c("recall", "precision")]
+ names(pr_auc_agg)[ names(pr_auc_agg) == "V1" ] <- "pr_AUC"
+ pr_auc_agg$pr_randm_AUC <- random_classifier_auc_agg
+
+
+ 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..27854c7b7297a7a0fdae61c850954b8b705493c1
--- /dev/null
+++ b/R/receiver_operating_characteristic.R
@@ -0,0 +1,195 @@
+# 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
+ }
+ ## isDE for random params == NA
+ idx_ran_pars <- comparison_df$effect == "ran_pars"
+ comparison_df$isDE[idx_ran_pars] <- NA
+ 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){
+ ## -- replace 0 by minimum machine
+ dt$p.adj[ dt$p.adj == 0 ] <- 1e-217
+ pred_obj <- prediction( -log10(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 True positive rate and False positive rate
+#' @return A numeric value representing the AUC.
+#' @export
+compute_roc_auc <- function(dt) Area_Under_Curve(x = dt$`False positive rate`, y = dt$`True positive rate`)
+
+
+
+
+#' 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" ) {
+
+ ## -- subset fixed eff
+ evaldata_params <- subset(evaldata_params, effect == "fixed")
+
+ ## -- 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 <- roc_curve_params[, compute_roc_auc(.SD), by=c("from", col_param), .SDcols=c("False positive rate", "True positive rate")]
+ names(roc_auc_params)[ names(roc_auc_params) == "V1" ] <- "roc_AUC"
+ roc_auc_params$roc_randm_AUC <- 0.5
+
+ ## -- aggregate
+ roc_curve_agg <- dt_evaldata_params[, compute_roc_curve(.SD), by= "from", .SDcols=c(col_truth, col_score)]
+ roc_auc_agg <- roc_curve_agg[, compute_roc_auc(.SD), by="from", .SDcols=c("False positive rate", "True positive rate")]
+ names(roc_auc_agg)[ names(roc_auc_agg) == "V1" ] <- "roc_AUC"
+ roc_auc_agg$roc_randm_AUC <- 0.5
+
+ 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..c9ececc8d5e98ed705aafad1d3182b0be9638884
--- /dev/null
+++ b/R/rocr_functions.R
@@ -0,0 +1,159 @@
+# 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){
+ ## -- replace 0 by minimum machine
+ dt$p.adj[ dt$p.adj == 0 ] <- 1e-217
+ ## --see .SDcols for order
+ pred_obj <- prediction( -log10(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) Area_Under_Curve( dt$recall, dt$precision )
+
+
+#' 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" ) {
+
+ ## -- subset fixed eff
+ evaldata_params <- subset(evaldata_params, effect == "fixed")
+
+ ## -- by params -- random class AUC
+ prop_table <- table(evaldata_params[[col_param]], evaldata_params[[col_truth]])
+ random_classifier_auc_params <- prop_table[,"TRUE"]/rowSums(prop_table)
+ random_classifier_auc_params <- as.data.frame(random_classifier_auc_params)
+ random_classifier_auc_params[col_param] <- rownames(random_classifier_auc_params)
+
+ ## -- aggregate -- random class AUC
+ prop_table <- table(evaldata_params[[col_truth]])
+ random_classifier_auc_agg <- unname(prop_table["TRUE"]/sum(prop_table))
+
+ ## -- 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 <- pr_curve_params[, compute_pr_auc(.SD), by=c("from", col_param), .SDcols=c("recall", "precision")]
+ names(pr_auc_params)[ names(pr_auc_params) == "V1" ] <- "pr_AUC"
+ pr_auc_params <- join_dtf(pr_auc_params, random_classifier_auc_params ,
+ k1 = col_param, k2 = col_param)
+ names(pr_auc_params)[ names(pr_auc_params) == "random_classifier_auc_params" ] <- "pr_randm_AUC"
+
+
+
+
+ ## -- aggregate
+ pr_curve_agg <- dt_evaldata_params[, compute_pr_curve(.SD), by = "from", .SDcols=c(col_truth, col_score)]
+ pr_auc_agg <- pr_curve_agg[, compute_pr_auc(.SD), by = "from", .SDcols=c("recall", "precision")]
+ names(pr_auc_agg)[ names(pr_auc_agg) == "V1" ] <- "pr_AUC"
+ pr_auc_agg$pr_randm_AUC <- random_classifier_auc_agg
+
+
+ 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..18baf350a21f9fcebd4e9410b9fa9b2325f49421 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,446 @@ 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
+
+#' Check Validity of Truth Labels
+#'
+#' This function checks the validity of truth labels for HTRfit evaluation, specifically designed for binary classification.
+#'
+#' @param eval_data Data frame containing evaluation parameters.
+#' @param col_param Column name specifying the parameter for grouping.
+#' @param col_truth Column name for binary ground truth values (default is "isDE").
+#' @return Logical value indicating the validity of truth labels.
+#' @export
+is_truthLabels_valid <- function(eval_data, col_param = "description", col_truth = "isDE" ) {
+
+ ## --init
+ isValid <- TRUE
+
+ ## -- subset fixed effect
+ eval_data_fixed <- subset(eval_data, effect == "fixed")
+
+ table_summary <- table(eval_data_fixed[[col_param]], eval_data_fixed[[col_truth]])
+ ## -- 2 lines needed (FALSE/TRUE)
+ n_labels <- dim(table_summary)[2]
+ if(n_labels != 2) {
+ labels_str <- paste(colnames(table_summary), collapse = ", ")
+ msg <- paste("Both FALSE/TRUE truth labels (isDE) are required for classification evaluation.\nFound : ", labels_str )
+ message(msg)
+ isValid <- FALSE
+ }
+ ## -- one label found 0 time !
+ label_not_found <- which(table_summary == 0, arr.ind=TRUE)
+ if(dim(label_not_found)[1] > 0){
+ description <- rownames(label_not_found)
+ label_not_found <- colnames(table_summary)[label_not_found[,"col"]]
+ msg <- "Both TRUE and FALSE labels are required for HTRfit evaluation.\n"
+ msg2 <- paste("Label isDE ==", label_not_found, "not found for description ==", description, collapse = '\n')
+ msg3 <- "Please review your threshold or alternative hypothesis, and consider checking the identity plot for further insights."
+ msg <- paste(msg, msg2, ".\n", msg3 , sep = "")
+ message(msg)
+ isValid <- FALSE
+ }
+ return(isValid)
+}
+
+
+
+#' 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 threshold (\code{coeff_threshold}) and
+#' alternative hypothesis (\code{alt_hypothesis}).
#'
-#' This function generates a simulation report containing various plots and evaluation metrics.
+#' @param list_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 coeff_threshold A non-negative value which specifies a ln(fold change) threshold. The Threshold is used for the Wald test to determine whether the coefficient (β) is significant or not, depending on \code{alt_hypothesis} parameter. Default is 0, ln(FC = 1).
+#' @param alt_hypothesis Alternative hypothesis for the Wald test (default is "greaterAbs").
+#' Possible choice:
+#' "greater"
+#' - β > coeff_threshold,
+#' "less"
+#' - β < −coeff_threshold,
+#' or two-tailed alternative:
+#' "greaterAbs"
+#' - |β| > coeff_threshold
+#' @param alpha_risk parameter that sets the threshold for alpha risk level while testing coefficient (β). Default: 0.05.
+#' @param palette_color Optional parameter that sets the color palette for plots.Default : c(DESeq2 = "#500472", HTRfit ="#79cbb8").
+#' @param skip_eval_intercept indicate whether to calculate precision-recall and ROC metrics for the intercept (default TRUE).
+#' @param ... Additional parameters to be passed to aesthetics \code{get_pr_curve} and \code{get_roc_curve}.
#'
-#' @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.
+#' @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.}
+#' \item{performances}{A summary of the performances obtained.}
#' @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'
+evaluation_report <- function(list_tmb, dds, mock_obj, coeff_threshold, alt_hypothesis, alpha_risk = 0.05, palette_color = c(DESeq2 = "#500472", HTRfit ="#79cbb8"), skip_eval_intercept = TRUE, ...) {
+
+ ## -- eval data
+ eval_data <- get_eval_data(list_tmb, dds, mock_obj, coeff_threshold, alt_hypothesis)
+
+ ## -- identity plot
+ #identity_data <- rbind_model_params_and_dispersion(eval_data)
+ params_identity_eval <- eval_identityTerm(eval_data$modelparams, palette_color)
+ dispersion_identity_eval <- eval_identityTerm(eval_data$modeldispersion, palette_color)
+
+ if (isTRUE(skip_eval_intercept)){
+ eval_data2metrics <- subset(eval_data$modelparams,
+ term != "(Intercept)")
}
+ else{
+ eval_data2metrics <- eval_data$modelparams
+ }
+
+ ## -- counts plot
+ counts_violinplot <- counts_plot(mock_obj)
- 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'
+ ## -- check if eval data ok
+ if(isFALSE(is_truthLabels_valid(eval_data2metrics))){
+
+ message("The required truth labels for HTRfit classification metrics evaluation are not met. Only the identity plot and counts plot will be returned.")
+ ## -- 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 ),
+ counts = counts_violinplot
+
+ ))
+
+
}
+
+
+
+ ## -- pr curve
+ pr_curve_obj <- get_pr_object(eval_data2metrics)
+ pr_curve_obj <- get_pr_curve(pr_curve_obj, palette_color = palette_color, ...)
+
+ ## -- auc curve
+ roc_curve_obj <- get_roc_object(eval_data2metrics)
+ roc_curve_obj <- get_roc_curve(roc_curve_obj, palette_color = palette_color, ...)
+
+ ## -- acc, recall, sensib, speci, ...
+ metrics_obj <- get_ml_metrics_obj(eval_data2metrics, alpha_risk )
+ ## -- merge all metrics in one obj
+ model_perf_obj <- get_performances_metrics_obj( r2_params = params_identity_eval$R2, dispersion_identity_eval$R2,
+ pr_curve_obj,
+ roc_curve_obj,
+ metrics_obj )
- comparison_df <- rbind( DESEQ_comparison_df, TMB_comparison_df )
+ ## -- counts plot
+ counts_violinplot <- counts_plot(mock_obj)
+ ## -- clear memory
+ invisible(gc(reset = T, verbose = F, full = T)) ;
- #color2use <- c("#D2B4DE", "#A2D9CE")
- color2use <- c("#500472", "#79cbb8")
- color2use <- color2use[c(!is.null(dds_obj), !is.null(list_tmb))]
+ 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 ))
+}
+
- # -- 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)
+#' 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"){
+
+ ## -- subset fixed eff
+ evaldata_params <- subset(evaldata_params, effect == "fixed")
+
+
+ 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'
- # -- export report
- df_settings <- mock_obj$settings
- grobTableSettings <- getGrobTable(df_settings)
- exportReportFile(report_file, grobTableSettings, roc_curve, dispersion_plot, id_plot, counts_plot)
+ ## -- 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 ){
- # -- 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)
+ ## -- 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 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 Threshold value for coefficient testing (default is 0). This threshold corresponds to the natural logarithm of the fold change (ln(FC)).
+#' @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)
+}
+
+
diff --git a/R/update_fittedmodel.R b/R/update_fittedmodel.R
index ffafac2dd8667dc1474fff09a0102e7cc0caa80d..24ba2e8a7e73dcd752d7a68b6b351f9e79d68386 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
- parallel::clusterExport(clust, c("launchUpdate", "fitUpdate"), envir=environment())
+ 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"))
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/R/waldtest.R b/R/waldtest.R
index 8bfffbc4e38215fb5f98119841bab6361f94b310..9728ef5a35ba68e066d0f9c14d923669bf3912d7 100644
--- a/R/waldtest.R
+++ b/R/waldtest.R
@@ -46,10 +46,16 @@ wald_test <- function(estimation, std_error, reference_value = 0, alternative =
#' This function takes a list of glmmTMB objects and performs statistical tests based on the estimated coefficients and their standard errors. The results are returned in a tidy data frame format.
#'
#' @param list_tmb A list of glmmTMB objects representing the fitted models.
-#' @param coeff_threshold The threshold value for coefficient testing (default is 0).
-#' @param alternative_hypothesis The type of alternative hypothesis for the statistical test (default is "greaterAbs").
-#' Possible options are "greater" (for greater than threshold), "less" (for less than threshold),
-#' and "greaterAbs" (for greater than absolute value of threshold).
+#' @param coeff_threshold A non-negative value which specifies a ln(fold change) threshold. The Threshold is used for the Wald test to determine whether the coefficient (β) is significant or not, depending on \code{alt_hypothesis} parameter. Default is 0, ln(FC = 1).
+#' @param alt_hypothesis Alternative hypothesis for the Wald test (default is "greaterAbs").
+#' Possible choice:
+#' "greater"
+#' - β > coeff_threshold,
+#' "less"
+#' - β < −coeff_threshold,
+#' or two-tailed alternative:
+#' "greaterAbs"
+#' - |β| > coeff_threshold
#' @param correction_method a character string indicating the correction method to apply to p-values. Possible values are:
#' "holm", "hochberg", "hommel", #' "bonferroni", "BH", "BY", "fdr", and "none".
#'
diff --git a/README.md b/README.md
index 1698309e079593fc2f7c15f6016c99593f19c38f..051c2be1803f40a2a46c079ded59451b031d75c4 100644
--- a/README.md
+++ b/README.md
@@ -4,7 +4,7 @@
HTRfit provides a robust statistical framework that allows you to investigate the essential experimental parameters influencing your ability to detect expression changes. Whether you're examining sequencing depth, the number of replicates, or other critical factors, HTRfit's computational simulation is your go-to solution.
-Furthermore, by enabling the inclusion of fixed effects, mixed effects, and interactions in your RNAseq data analysis, HTRfit provides the flexibility needed to conduct your differential expression analysis effectively.
+Furthermore, by enabling the inclusion of fixed effects, mixed effects, and interactions in your RNAseq data analysis, HTRfit provides the flexibility needed to conduct your differential expression analysis effectively. HTRfit is particularly adapted for the analysis of large number of samples, or highly multiplexed experiments.
- [Installation](#installation)
@@ -13,16 +13,12 @@ Furthermore, by enabling the inclusion of fixed effects, mixed effects, and inte
- [HTRfit simulation workflow](#htrfit-simulation-workflow)
- [Getting started](#getting-started)
-
-
-
-
## Installation
#### method A:
To install the latest version of HTRfit, run the following in your R console :
-```
+```r
if (!requireNamespace("remotes", quietly = TRUE))
install.packages("remotes")
remotes::install_git("https://gitbio.ens-lyon.fr/aduvermy/HTRfit")
@@ -30,11 +26,11 @@ remotes::install_git("https://gitbio.ens-lyon.fr/aduvermy/HTRfit")
#### method B:
-You also have the option to download a release directly from the [HTRfit release page](https://gitbio.ens-lyon.fr/aduvermy/HTRfit/-/releases). Once you've downloaded the release, simply untar the archive. After that, open your R console and execute the following command, where HTRfit-v1.0.0 should be replaced with the path to the untarred folder:
+You also have the option to download a release directly from the [HTRfit release page](https://gitbio.ens-lyon.fr/aduvermy/HTRfit/-/tags). Once you've downloaded the release, simply launch following command.
-```
-## -- Example using the HTRfit-v1.0.0 release
-install.packages('/HTRfit-v1.0.0', repos = NULL, type='source')
+```r
+## -- Example using the HTRfit-v2.0.0 release
+install.packages('HTRfit-v2.0.0.tar.gz', repos = NULL, type='source')
```
@@ -45,10 +41,9 @@ When dependencies are met, installation should take a few minutes.
The following depandencies are required:
-```
+```r
## -- required
-install.packages(c('car', 'parallel', 'data.table', 'ggplot2', 'gridExtra', 'glmmTMB',
- 'magrittr', 'MASS', 'plotROC', 'reshape2', 'rlang', 'stats', 'utils', 'BiocManager'))
+install.packages(c('parallel', 'data.table', 'ggplot2', 'gridExtra', 'glmmTMB', 'magrittr', 'MASS', 'reshape2', 'rlang', 'stats', 'utils', 'BiocManager', 'car'))
BiocManager::install('S4Vectors', update = FALSE)
## -- optional
BiocManager::install('DESeq2', update = FALSE)
@@ -56,15 +51,40 @@ BiocManager::install('DESeq2', update = FALSE)
## Docker
-We have developed [Docker images](https://hub.docker.com/repository/docker/ruanad/htrfit/general) to simplify the package's utilization. For an optimal development and coding experience with the Docker container, we recommend using Visual Studio Code (VSCode) along with the DevContainer extension. This setup provides a convenient and isolated environment for development and testing.
+We have developed [Docker images](https://hub.docker.com/r/ruanad/htrfit/tags) to simplify the package's utilization.
-1. Install VSCode.
-2. Install Docker on your system and on VSCode.
-3. Launch the HTRfit container directly from VSCode
-4. Install the DevContainer extension for VSCode.
-5. Launch a remote window connected to the running Docker container.
-6. Install the R extension for VSCode.
-7. Enjoy HTRfit !
+```sh
+docker pull ruanad/htrfit:v2.0.0-beta
+docker run -it --rm ruanad/htrfit:v2.0.0-beta
+```
+
+HTRfit allows building graphs to visualize results. Inside Docker, displaying a window from the R terminal can be tricky and requires specific settings before running the container. Following commands worked for us:
+
+```sh
+# Prepare target env
+CONTAINER_DISPLAY="0"
+CONTAINER_HOSTNAME="htrfit_user"
+# Create a directory for the socket
+mkdir -p display/socket
+touch display/Xauthority
+# Get the DISPLAY slot
+DISPLAY_NUMBER=$(echo $DISPLAY | cut -d. -f1 | cut -d: -f2)
+# Extract current authentication cookie
+AUTH_COOKIE=$(xauth list | grep "^$(hostname)/unix:${DISPLAY_NUMBER} " | awk '{print $3}')
+# Create the new X Authority file
+xauth -f display/Xauthority add ${CONTAINER_HOSTNAME}/unix:${CONTAINER_DISPLAY} MIT-MAGIC-COOKIE-1 ${AUTH_COOKIE}
+# Proxy with the :0 DISPLAY
+socat UNIX-LISTEN:display/socket/X${CONTAINER_DISPLAY},fork TCP4:localhost:60${DISPLAY_NUMBER} &
+# Launch the container
+docker run -it --rm \
+ -e DISPLAY=:${CONTAINER_DISPLAY} \
+ -e XAUTHORITY=/tmp/.Xauthority \
+ -v ${PWD}/display/socket:/tmp/.X11-unix \
+ -v ${PWD}/display/Xauthority:/tmp/.Xauthority \
+ --hostname ${CONTAINER_HOSTNAME} \
+ ruanad/htrfit:v2.0.0-beta
+## inspired by : https://blog.yadutaf.fr/2017/09/10/running-a-graphical-app-in-a-docker-container-on-a-remote-server/
+```
## Biosphere virtual machine
@@ -75,7 +95,7 @@ A straightforward way to use **HTRfit** is to run it on a Virtual Machine (VM) t
## HTRfit simulation workflow
-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. Moreover, **HTRfit** offers seamless compatibility with DESeq2 outputs, facilitating a comprehensive evaluation of RNAseq analysis.
+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 others are expected to impact statistical power. To navigate the selection of optimal values for these experimental parameters, we introduce a comprehensive statistical framework known as **HTRfit**, underpinned by computational simulation. Moreover, **HTRfit** offers seamless compatibility with DESeq2 outputs, facilitating a comprehensive evaluation of RNAseq analysis.
<div id="bg" align="center">
@@ -86,12 +106,12 @@ In the realm of RNAseq analysis, various key experimental parameters play a cruc
## Getting started
-[Download the vignette](https://gitbio.ens-lyon.fr/aduvermy/HTRfit/-/raw/master/vignettes/HTRfit.html?ref_type=heads&inline=false) for more in-depth information.
+[Download the vignette](https://gitbio.ens-lyon.fr/aduvermy/HTRfit/-/raw/master/vignettes/HTRfit.html?ref_type=heads&inline=false) for more in-depth information about how to use HTRfit.
### Init a design and simulate RNAseq data
-```
+```r
library('HTRfit')
## -- init a design
input_var_list <- init_variable( name = "varA", mu = 0, sd = 0.29, level = 2000) %>%
@@ -105,22 +125,15 @@ mock_data <- mock_rnaseq(input_var_list,
```
-The simulation process in HTRfit has been optimized to generate RNAseq counts for 30,000 genes and 4,000 experimental conditions (2000 levels in varA, 2 levels in varB), each replicated 4 times, resulting in a total of 16,000 samples, in less than 5 minutes. However, the object generated by the framework under these conditions can consume a significant amount of RAM, approximately 50 GB. For an equivalent simulation with 6,000 genes, less than a minute and 10 GB of RAM are required.
-
-
-<div id="bg" align="center">
- <img src="./vignettes/figs/simulation_step.png" width="500" height="200">
-</div>
-
-
### Fit your model
-```
+```r
## -- prepare data & fit a model with mixed effect
data2fit = prepareData2fit(countMatrix = mock_data$counts,
metadata = mock_data$metadata,
- normalization = F)
+ normalization = F,
+ response_name = "kij")
l_tmb <- fitModelParallel(formula = kij ~ varB + (varB | varA),
data = data2fit,
group_by = "geneID",
@@ -128,47 +141,104 @@ l_tmb <- fitModelParallel(formula = kij ~ varB + (varB | varA),
n.cores = 8)
```
-The `fitModelParallel()` function in **HTRfit** provides a powerful way to fit models independently for each gene. This allows for efficient parallelization of the modeling process by specifying the `n.cores` option. However, it's essential to note that as more cores are utilized, there is a corresponding increase in the required RAM. This is because the data necessary for fitting the model needs to be loaded into memory. Our simulations have demonstrated significant time savings when employing more cores. For instance, using 25 cores was nearly three times faster for processing 6,000 genes and 2,000 experimental conditions (2000 levels in varA, 2 levels in varB - 8000 samples). However, using 50 cores yielded minimal time savings but had a noticeable impact on RAM consumption. Therefore, users must carefully balance computation speed and memory usage when selecting the number of cores. To aid in making this decision, the graph below can assist in defining the optimal trade-off between computation speed and memory usage when choosing the number of cores.
+The `fitModelParallel()` function in **HTRfit** provides a powerful way to fit models independently for each gene. This allows for efficient parallelization of the modeling process by specifying the `n.cores` option. However, it's essential to note that as more cores are utilized, there is a corresponding increase in the required RAM. This is because the data necessary for fitting the model needs to be loaded into memory. Our simulations have demonstrated significant time savings when employing more cores. For instance, using 25 cores was nearly three times faster for processing 6,000 genes and 2,000 experimental conditions (2000 levels in varA, 2 levels in varB - 8000 samples). However, using 50 cores yielded minimal time savings but had a noticeable impact on RAM consumption. Therefore, users must carefully balance computation speed and memory usage when selecting the number of cores.
-<div id="bg" align="center">
- <img src="./vignettes/figs/fit_step.png" width="836" height="220">
-</div>
-
-Furthermore, it's worth noting that the output object generated by fitModelParallel can be substantial in terms of memory (RAM) usage. In simulations involving 6,000 genes and 2,000 experimental conditions (equivalent to 8,000 samples), the output object can occupy a significant amount of memory, reaching approximately 10 GB. Therefore, users need to ensure that their computing environment has enough available RAM to handle these large output objects.
-
### Diagnostic metrics
-The `metrics_plot()` function allows to plot a diagnostic plot of AIC (Akaike Information Criterion), BIC (Bayesian Information Criterion), logLik (log-likelihood), deviance, df.resid (residual degrees of freedom), and dispersion. These metrics provide insights into how well the model fits the data and help in comparing different models. By examining these metrics, users can quickly identify any anomalies or potential issues in the fitting process
+The `diagnostic_plot()` function allows to plot a diagnostic plot of AIC (Akaike Information Criterion), BIC (Bayesian Information Criterion), logLik (log-likelihood), deviance, df.resid (residual degrees of freedom), and dispersion. These metrics provide insights into how well the model fits the data and help in comparing different models. By examining these metrics, users can quickly identify any anomalies or potential issues in the fitting process.
-```
+```r
## -- plot all metrics
-p <- metrics_plot(list_tmb = l_tmb)
+p <- diagnostic_plot(list_tmb = l_tmb)
```
<div id="bg" align="center">
<img src="./vignettes/figs/diagnostic_plot.png" width="600" height="360">
</div>
+The diagnostic metrics show that the fit is not as good for all genes.
-### Evaluation
+### Extracts a tidy result table from a list tmb object
+The tidy_results function extracts a dataframe containing estimates of ln(fold changes), standard errors, test statistics, p-values, and adjusted p-values for fixed effects. Additionally, it provides access to correlation terms and standard deviations for random effects, offering a detailed view of HTRfit modeling results.
+
+```r
+## -- get tidy results
+tidy_res <- tidy_results(l_tmb, coeff_threshold = 0.1, alternative_hypothesis = "greater")
```
+
+### Evaluation
+
+```r
## -- evaluation
-resSimu <- simulationReport(mock_data,
- list_tmb = l_tmb,
+resSimu <- evaluation_report(list_tmb = l_tmb,
+ mock_obj = mock_data,
coeff_threshold = 0.27,
alt_hypothesis = "greater")
```
-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.
+The identity plot, generated by the `evaluation_report()` 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. For a quantitative evaluation of inference quality, the R-squared (R2) metric can be employed.
-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 evaluation of model performance in distinguishing between differentially expressed and non-differentially expressed genes relies on the area under the ROC curve (AUC), a comprehensive metric offering a singular summary of the model's overall effectiveness. A higher AUC is indicative of superior model performance. It is noteworthy that we not only calculate the AUC for the ROC curve but also extend this assessment to the Precision-Recall (PR) curve. In the case of the ROC curve, this AUC should be compared to the value of 0.5, representing a random classifier. On the other hand, for the PR curve, we compute the pr_AUC_random, serving as a baseline for comparison. This dual evaluation approach ensures a thorough understanding of the model's discrimination capabilities under different scenarios, providing valuable insights into its robustness and reliability.
-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. 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.
+In addition to evaluating model performance through the AUC for both ROC and PR curves, we provide access to key classification metrics, including Accuracy, Precision, Recall (or Sensitivity), and Specificity. These metrics offer a comprehensive view of the model's classification capabilities.
+All metrics are computed for each parameter (excluding the intercept when skip_eval_intercept = TRUE), providing detailed insights into individual parameter contributions. Furthermore, an aggregated assessment is performed, considering all parameters (except the intercept by default), offering a perspective on the model's overall classification effectiveness.
-<div id="bg" align="center">
- <img src="./vignettes/figs/evaluation.png" width="680" height="400">
-</div>
\ No newline at end of file
+### Comparing performances of HTRfit & 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
+## -- init a design
+input_var_list <- init_variable( name = "varA", mu = 0, sd = 0.29, level = 2) %>%
+ 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)
+N_GENES = 1000
+MIN_REPLICATES = 4
+MAX_REPLICATES = 4
+BASAL_EXPR = 2
+SEQ_DEPTH = 1e+7
+
+## -- simulate RNAseq data
+mock_data <- mock_rnaseq(input_var_list,
+ n_genes = N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES,
+ basal_expression = BASAL_EXPR,
+ sequencing_depth = SEQ_DEPTH )
+
+## -- prepare data & fit a model with HTRfit
+data2fit = prepareData2fit(countMatrix = mock_data$counts,
+ metadata = mock_data$metadata,
+ normalization = F)
+l_tmb <- fitModelParallel(formula = kij ~ varA + varB + varA:varB,
+ data = data2fit,
+ group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"),
+ n.cores = 8)
+
+
+## -- DESeq2
+library(DESeq2)
+dds <- DESeq2::DESeqDataSetFromMatrix(
+ countData = round(mock_data$counts),
+ colData = mock_data$metadata,
+ design = ~ varA + varB + varA:varB )
+dds <- DESeq2::DESeq(dds, quiet = TRUE)
+
+
+## -- get simulation/fit evaluation
+resSimu <- evaluation_report(list_tmb = l_tmb,
+ dds = dds,
+ mock_obj = mock_data,
+ coeff_threshold = 0.4,
+ alt_hypothesis = "greaterAbs")
+```
+
+
+*** ADD plot ***
\ No newline at end of file
diff --git a/dev/flat_full.Rmd b/dev/flat_full.Rmd
index 0cd25064ec59cfea270aea87dc56d6531d124c4f..738abec6ff75092ba3d1584cf9ed26d6e21c5b3a 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))
+}
+
+
```
@@ -2016,20 +2025,54 @@ mock_rnaseq <- function(list_var, n_genes, min_replicates, max_replicates, seque
dtf_countsTable <- scaleCountsTable(dtf_countsTable, sequencing_depth)
}
+ checkFractionOfZero(dtf_countsTable)
+
metaData <- getSampleMetadata(list_var, n_genes, matx_bool_replication)
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)
}
+#' Check Fraction of Zero or One in Counts Table
+#'
+#' This function checks the percentage of counts in a given counts table that are either zero or one.
+#' If more than 50% of the counts fall in this category, a warning is issued, suggesting a review of input parameters.
+#'
+#' @param counts_table A matrix or data frame representing counts.
+#' @return NULL
+#' @export
+#' @examples
+#' # Example usage:
+#' counts_table <- matrix(c(0, 1, 2, 3, 4, 0, 0, 1, 1), ncol = 3)
+#' checkFractionOfZero(counts_table)
+checkFractionOfZero <- function(counts_table){
+
+ dim_matrix <- dim(counts_table)
+
+ n_counts <- dim_matrix[1]*dim_matrix[2]
+
+ n_zero_or_one <- sum(counts_table < 1)
+
+ fractionOfZero <- n_zero_or_one/n_counts*100
+
+ if( fractionOfZero > 50) {
+ message("50% of the counts simulated are bellow 1. Consider reviewing your input parameters.")
+ }
+
+ return(NULL)
+
+}
+
#' Validate and Filter Dispersion Values
@@ -2147,6 +2190,18 @@ test_that("generateCountTable generates count table with correct dimensions", {
+test_that("checkFractionofZero issues a warning for high fraction of zeros/ones", {
+ # Test case 1: Less than 50% zeros and ones
+ counts_table_1 <- matrix(c(0, 1, 2, 0, 0, 0, 0, 1, 1), ncol = 3)
+ expect_message(checkFractionOfZero(counts_table_1), "50% of the counts simulated are bellow 1. Consider reviewing your input parameters.")
+
+ # Test case 2: More than 50% zeros and ones
+ counts_table_2 <- matrix(c(0, 1, 0, 0, 1, 10, 100, 1, 1), ncol = 3)
+ expect_null(checkFractionOfZero(counts_table_2))
+
+})
+
+
# Test for replicateMatrix
test_that("replicateMatrix replicates matrix correctly", {
matrix <- matrix(1:9, nrow = 3, ncol = 3)
@@ -2235,13 +2290,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
@@ -2437,6 +2494,27 @@ isValidInput2fit <- function(data2fit, formula){
}
+
+#' Check if group by exist in data
+#'
+#' @param data The data framecontaining the variables to be used for model fitting.
+#' @param group_by Column name in data representing the grouping variable
+#'
+#' @return \code{TRUE} if exist otherwise an error is raised
+#'
+#' @examples
+#' is_validGroupBy(mtcars, 'mpg')
+#' @export
+is_validGroupBy <- function(data, group_by){
+ validGroupBy <- group_by %in% names(data)
+ if (!validGroupBy)
+ stop("<Group by> doen't exist in data !")
+ return(TRUE)
+}
+
+
+
+
#' Drop Random Effects from a Formula
#'
#' This function allows you to remove random effects from a formula by specifying
@@ -2517,7 +2595,7 @@ is_fullrank <- function(metadata, formula) {
#' Fit a model using the fitModel function.
-#' @param group group id to save in glmmTMB obj (usefull for update !)
+#' @param group ID to fit
#' @param formula Formula specifying the model formula
#' @param data Data frame containing the data
#' @param ... Additional arguments to be passed to the glmmTMB::glmmTMB function
@@ -2525,9 +2603,11 @@ is_fullrank <- function(metadata, formula) {
#' @export
#' @examples
#' fitModel("mtcars" , formula = mpg ~ cyl + disp, data = mtcars)
-fitModel <- function(group, formula, data, ...) {
+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
@@ -2537,6 +2617,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)
}
@@ -2544,24 +2625,22 @@ fitModel <- function(group, formula, data, ...) {
#' Fit the model based using fitModel functions.
#'
-#' @param group The specific group to fit the model for
+#' @param groups list of group ID
#' @param group_by Column name in data representing the grouping variable
-#' @param formula Formula specifying the model formula
#' @param data Data frame containing the data
-#' @param ... Additional arguments to be passed to the glmmTMB::glmmTMB function
-#' @return Fitted model object or NULL if there was an error
+#' @return list of dataframe
#' @export
+#' @importFrom stats setNames
#' @examples
-#' subsetData_andfit(group = "setosa", group_by = "Species",
-#' formula = Sepal.Length ~ Sepal.Width + Petal.Length,
+#' prepare_dataParallel(groups = iris$Species, group_by = "Species",
#' data = iris )
-subsetData_andfit <- function(group, group_by, formula, data, ...) {
- subset_data <- data[data[[group_by]] == group, ]
- fit_res <- fitModel(group, formula, subset_data, ...)
- #glance_df <- glance.negbin(group_by ,group , fit_res)
- #tidy_df <- tidy.negbin(group_by ,group,fit_res )
- #list(glance = glance_df, summary = tidy_df)
- fit_res
+prepare_dataParallel <- function(groups, group_by, data) {
+
+ l_data2parallel <- lapply( stats::setNames(groups, groups) , function( group_id ){
+ subset_data <- data[ data[[ group_by ]] == group_id, ]
+ return(subset_data)
+ })
+ return(l_data2parallel)
}
@@ -2571,22 +2650,22 @@ subsetData_andfit <- function(group, group_by, formula, data, ...) {
#' This function fits the model using the specified group, group_by, formula, and data.
#' It handles warnings and errors during the fitting process and returns the fitted model or NULL if there was an error.
#'
-#' @param group The specific group to fit the model for
+#' @param data Data frame containing the data
#' @param group_by Column name in data representing the grouping variable
#' @param formula Formula specifying the model formula
-#' @param data Data frame containing the data
#' @param ... Additional arguments to be passed to the glmmTMB::glmmTMB function
#' @return List with 'glance' and 'summary' attributes representing the fitted model or NULL if there was an error
#' @export
#' @examples
-#' launchFit(group = "setosa", group_by = "Species",
+#' launchFit(group_by = "Species",
#' formula = Sepal.Length ~ Sepal.Width + Petal.Length,
-#' data = iris )
-launchFit <- function(group, group_by, formula, data, ...) {
+#' data = iris[ iris[["Species"]] == "setosa" , ] )
+launchFit <- function(data, group_by, formula, ...) {
+ group <- unique(data[[ group_by ]])
tryCatch(
expr = {
withCallingHandlers(
- subsetData_andfit(group, group_by, formula, data, ...),
+ fitModel(group , formula, data, ...),
warning = function(w) {
message(paste(Sys.time(), "warning for group", group, ":", conditionMessage(w)))
invokeRestart("muffleWarning")
@@ -2595,7 +2674,6 @@ launchFit <- function(group, group_by, formula, data, ...) {
error = function(e) {
message(paste(Sys.time(), "error for group", group, ":", conditionMessage(e)))
NULL
- #return(list(glance = empty.glance.negbin(group_by, group), summary = empty.tidy.negbin(group_by, group)))
}
)
}
@@ -2609,27 +2687,36 @@ launchFit <- function(group, group_by, formula, data, ...) {
#' @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
-#' @importFrom stats setNames
#' @export
#' @examples
-#' parallel_fit(group_by = "Species", "setosa",
+#' parallel_fit(group_by = "Species", groups = iris$Species,
#' 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 = " "))
+
- clust <- parallel::makeCluster(n.cores, outfile = log_file)
- parallel::clusterExport(clust, c("subsetData_andfit", "fitModel"), envir=environment())
- results_fit <- parallel::parLapply(clust, X = stats::setNames(groups, groups), fun = launchFit,
- group_by = group_by, formula = formula, data = data, ...)
+ ## get data for parallelization
+ l_data2parallel <- prepare_dataParallel(groups, group_by, data)
+
+ clust <- parallel::makeCluster(n.cores, outfile = log_file , type= cl_type )
+ parallel::clusterExport(clust, c("fitModel"))
+ 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)
}
@@ -2643,24 +2730,27 @@ 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
+ ## Some verification
isValidInput2fit(data, formula)
is_fullrank(data, formula)
-
+ is_validGroupBy(data, group_by)
+
## -- print log location
message( paste("Log file location", log_file, sep =': ') )
- groups <- unique(data[[group_by]])
# Fit models in parallel and capture the results
- results <- parallel_fit(groups, group_by, formula, data, n.cores, log_file, ...)
+ groups <- unique(data[[ group_by ]])
+ results <- parallel_fit(groups, group_by, formula, data, n.cores, log_file, cl_type, ...)
#results <- mergeListDataframes(results)
return(results)
}
@@ -2785,83 +2875,34 @@ test_that("Identify full-rank model matrix (with random eff)", {
expect_true(is_fullrank(metadata, formula))
})
-#test_that(".fitMixteModel returns a fitted mixed-effects model object or NULL if there was an error", {
-# data(mtcars)
-# formula <- mpg ~ cyl + disp + (1|gear)
-# fitted_model <- .fitMixteModel(formula, mtcars)
- # Add appropriate expectations for the fitted mixed-effects model object
-
- # Test with invalid formula
-# invalid_formula <- formula + "invalid"
-# fitted_model_error <- .fitMixteModel(invalid_formula, mtcars)
-# expect_null(fitted_model_error)
-#})
-test_that("subsetData_andfit returns a glmTMB obj", {
+test_that("prepare_dataParallel returns a list of dataframe", {
+ ## -- valid input
data(iris)
- group <- "setosa"
group_by <- "Species"
- formula <- Sepal.Length ~ Sepal.Width + Petal.Length
- fitted_model <- subsetData_andfit(group, group_by, formula, iris)
- expect_s3_class(fitted_model, "glmmTMB")
-
- # Test with invalid formula
- invalid_formula <- Sepal.Length ~ Sepal.Width + Petal.Length + invalid_var
- expect_error(subsetData_andfit(group, group_by, invalid_formula, mtcars))
-
-
- # Additional parameters:
- #change family + formula
- formula <- Sepal.Length ~ Sepal.Width + Petal.Length + (1 | Species)
- fitted_models <- suppressWarnings(subsetData_andfit(group,
- group_by,
- formula = formula,
- data = iris,
- family = glmmTMB::nbinom1(link = "log") ))
- expect_s3_class(fitted_models$call$family, "family")
- expect_equal(fitted_models$call$formula, formula)
- #change control settings
- fitted_models <- suppressWarnings(subsetData_andfit(group,
- group_by,
- formula = formula,
- data = iris,
- family = glmmTMB::nbinom1(link = "log"),
- control = glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,
- eval.max=1e3))))
- expect_equal(fitted_models$call$control, glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,eval.max=1e3)))
+ groups <- unique(iris$Species)
+ l_data <- prepare_dataParallel(groups , group_by, iris)
+ expect_type(l_data, "list")
+ expect_equal(names(l_data), c("setosa", "versicolor", "virginica"))
})
test_that("launchFit handles warnings and errors during the fitting process", {
- data(mtcars)
- group <- "Group1"
- group_by <- "Group"
- formula <- mpg ~ cyl + disp
- fitted_model <- suppressWarnings(launchFit(group, group_by, formula, mtcars))
- expect_s3_class(fitted_model, "glmmTMB")
- # Test with invalid formula
- invalid_formula <- Sepal.Length ~ Sepal.Width + Petal.Length
- output_msg <- capture_message( launchFit(group, group_by, invalid_formula, mtcars))
- expect_match(output_msg$message, ".* error for group Group1 : object 'Sepal.Length' not found")
-
-
# Additional parameters:
#change family + formula
formula <- Sepal.Length ~ Sepal.Width + Petal.Length
fitted_models <- suppressWarnings(launchFit(formula = formula,
- data = iris,
- group_by = group_by,
- group = "setosa",
+ data = iris[ iris$Species == "setosa" , ],
+ group_by = "Species",
family = glmmTMB::nbinom1(link = "log") ))
expect_s3_class(fitted_models$call$family, "family")
expect_equal(fitted_models$call$formula, formula)
#change control settings
fitted_models <- suppressWarnings(launchFit(formula = formula,
- data = iris,
- group_by = group_by,
- group = "setosa",
- family = glmmTMB::nbinom1(link = "log"),
+ data = iris[ iris$Species == "setosa" , ],
+ group_by = "Species",
+ family = glmmTMB::nbinom1(link = "log") ,
control = glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,
eval.max=1e3))))
expect_equal(fitted_models$call$control, glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,eval.max=1e3)))
@@ -2911,8 +2952,6 @@ test_that("fitModelParallel fits models in parallel for each group and returns a
groups <- unique(iris$Species)
group_by <- "Species"
formula <- Sepal.Length ~ Sepal.Width + Petal.Length
- #is.numeric(iris)
- #iris <- data.frame(lapply(iris, function(y) if(is.numeric(y)) round(y, 0) else y))
fitted_models <- fitModelParallel(formula, iris, group_by, n.cores = 1)
expect_s3_class(fitted_models$setosa, "glmmTMB")
expect_length(fitted_models, length(groups))
@@ -2939,6 +2978,12 @@ test_that("fitModelParallel fits models in parallel for each group and returns a
control = glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,
eval.max=1e3))))
expect_equal(fitted_models$setosa$call$control, glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,eval.max=1e3)))
+
+ ## -- invalid group by
+ data(iris)
+ group_by <- "invalid_groupBy"
+ formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+ expect_error(fitModelParallel(formula, iris, group_by, n.cores = 1))
})
@@ -2956,6 +3001,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.
@@ -2968,7 +3014,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)
@@ -2979,7 +3026,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)
}
@@ -2992,6 +3039,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.
@@ -3004,15 +3052,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)
+
+ message(paste("CPU(s) number :", n.cores, sep = " "))
+ message(paste("Cluster type :", cl_type, sep = " "))
+
- if (is.null(n.cores)) n.cores <- parallel::detectCores()
- clust <- parallel::makeCluster(n.cores, outfile = log_file)
- #l_geneID <- attributes(l_tmb)$names
- parallel::clusterExport(clust, c("launchUpdate", "fitUpdate"), envir=environment())
+ clust <- parallel::makeCluster(n.cores, type= cl_type, outfile = log_file)
+ parallel::clusterExport(clust, c("launchUpdate", "fitUpdate"))
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)
}
@@ -3038,6 +3091,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
@@ -3048,6 +3102,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)
}
@@ -3769,8 +3824,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)) {
@@ -3807,7 +3862,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(
@@ -3818,7 +3873,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"))
})
@@ -3834,31 +3889,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.
@@ -3875,10 +3905,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)
}
@@ -3898,8 +3930,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)
}
@@ -3921,66 +3953,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
@@ -3994,11 +3978,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)
@@ -4012,7 +3996,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", {
@@ -4030,40 +4014,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"))
})
-
```
@@ -5153,6 +5107,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)
@@ -5512,10 +5476,16 @@ wald_test <- function(estimation, std_error, reference_value = 0, alternative =
#' This function takes a list of glmmTMB objects and performs statistical tests based on the estimated coefficients and their standard errors. The results are returned in a tidy data frame format.
#'
#' @param list_tmb A list of glmmTMB objects representing the fitted models.
-#' @param coeff_threshold The threshold value for coefficient testing (default is 0).
-#' @param alternative_hypothesis The type of alternative hypothesis for the statistical test (default is "greaterAbs").
-#' Possible options are "greater" (for greater than threshold), "less" (for less than threshold),
-#' and "greaterAbs" (for greater than absolute value of threshold).
+#' @param coeff_threshold A non-negative value which specifies a ln(fold change) threshold. The Threshold is used for the Wald test to determine whether the coefficient (β) is significant or not, depending on \code{alt_hypothesis} parameter. Default is 0, ln(FC = 1).
+#' @param alt_hypothesis Alternative hypothesis for the Wald test (default is "greaterAbs").
+#' Possible choice:
+#' "greater"
+#' - β > coeff_threshold,
+#' "less"
+#' - β < −coeff_threshold,
+#' or two-tailed alternative:
+#' "greaterAbs"
+#' - |β| > coeff_threshold
#' @param correction_method a character string indicating the correction method to apply to p-values. Possible values are:
#' "holm", "hochberg", "hommel", #' "bonferroni", "BH", "BY", "fdr", and "none".
#'
@@ -5610,7 +5580,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
@@ -5646,65 +5616,167 @@ getLabelExpected <- function(comparison_df, coeff_threshold, alt_hypothesis) {
idx_DE <- abs(comparison_df$actual) > coeff_threshold
comparison_df$isDE <- idx_DE
}
+ ## isDE for random params == NA
+ idx_ran_pars <- comparison_df$effect == "ran_pars"
+ comparison_df$isDE[idx_ran_pars] <- NA
return(comparison_df)
}
-#' 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){
+ ## -- replace 0 by minimum machine
+ dt$p.adj[ dt$p.adj == 0 ] <- 1e-217
+ pred_obj <- prediction( -log10(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 True positive rate and False positive rate
+#' @return A numeric value representing the AUC.
#' @export
-roc_plot <- function(comparison_df, ...) {
+compute_roc_auc <- function(dt) Area_Under_Curve(x = dt$`False positive rate`, y = dt$`True positive rate`)
+
+
+
+
+#' 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" ) {
+
+ ## -- subset fixed eff
+ evaldata_params <- subset(evaldata_params, effect == "fixed")
+
+ ## -- 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 <- roc_curve_params[, compute_roc_auc(.SD), by=c("from", col_param), .SDcols=c("False positive rate", "True positive rate")]
+ names(roc_auc_params)[ names(roc_auc_params) == "V1" ] <- "roc_AUC"
+ roc_auc_params$roc_randm_AUC <- 0.5
+
+ ## -- aggregate
+ roc_curve_agg <- dt_evaldata_params[, compute_roc_curve(.SD), by= "from", .SDcols=c(col_truth, col_score)]
+ roc_auc_agg <- roc_curve_agg[, compute_roc_auc(.SD), by="from", .SDcols=c("False positive rate", "True positive rate")]
+ names(roc_auc_agg)[ names(roc_auc_agg) == "V1" ] <- "roc_AUC"
+ roc_auc_agg$roc_randm_AUC <- 0.5
+
+ 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)))
+ )
- 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")
- }
+}
+
+
+#' 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)
- 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)
+ 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
@@ -5732,29 +5804,103 @@ 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) )
+ roc_curve_obj <- compute_roc_curve(dt)
+ # Test
+ result <- compute_roc_auc(roc_curve_obj)
- plot <- roc_plot(comparison_data)
+ # Expected output
+ expected_result <- 0.42
+ expect_equal(round(result,2 ), expected_result)
+})
+
+test_that("get_roc_object returns ROC curves and AUCs", {
+ # Test data
+ set.seed(101)
+ 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),
+ effect = rep("fixed", 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"))
+
+ ## -- not only fixed effect
+ set.seed(101)
+ 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),
+ effect = c(rep("fixed", 8), 'ran_pars', 'ran_pars')
+ )
+
+ 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"))
- expect_true("gg" %in% class(plot))
+
+
+})
+
+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)
})
+
```
@@ -5812,47 +5958,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
-#'
-#' This function generates an identity plot for comparing actual values with estimates.
+
+
+
+#' Compute R-squared values for linear regression on grouped data
#'
-#' @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.
+#' This function takes a data frame, performs linear regression on specified grouping variables,
+#' and computes R-squared values for each group.
#'
-#' @importFrom ggplot2 sym aes geom_point geom_abline facet_wrap theme_bw ggtitle scale_x_log10 scale_y_log10
-#' @importFrom rlang .data
+#' @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
-#' 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)
+#' 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)
+}
-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) +
+#' 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::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
@@ -5860,185 +6068,2264 @@ 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)
+ )
+
+ 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))
+
+})
+
+
+
+```
+
+```{r function-MLmetrics, filename = "mlmetrics"}
+
+
+
+#' @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"
+#' @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")
+#' @importFrom stats splinefun
+#' @export
+Area_Under_Curve <- function(x, y, method = "trapezoid"){
+ idx <- order(x)
+ x <- x[idx]
+ y <- y[idx]
+ if (method == 'trapezoid'){
+ auc <- sum((rowMeans(cbind(y[-length(y)], y[-1]))) * (x[-1] - x[-length(x)]))
+ }else if (method == 'step'){
+ auc <- sum(y[-length(y)] * (x[-1] - x[-length(x)]))
+ }else if (method == 'spline'){
+ auc <- integrate(splinefun(x, y, method = "natural"), lower = min(x), upper = max(x))
+ auc <- auc$value
+ }
+ return(auc)
+}
+
+
+
+.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] )
+}
+
+
+
+```
+
+
+```{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){
+ ## -- replace 0 by minimum machine
+ dt$p.adj[ dt$p.adj == 0 ] <- 1e-217
+ ## --see .SDcols for order
+ pred_obj <- prediction( -log10(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) Area_Under_Curve( dt$recall, dt$precision )
+
+
+#' 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" ) {
+
+ ## -- subset fixed eff
+ evaldata_params <- subset(evaldata_params, effect == "fixed")
+
+ ## -- by params -- random class AUC
+ prop_table <- table(evaldata_params[[col_param]], evaldata_params[[col_truth]])
+ random_classifier_auc_params <- prop_table[,"TRUE"]/rowSums(prop_table)
+ random_classifier_auc_params <- as.data.frame(random_classifier_auc_params)
+ random_classifier_auc_params[col_param] <- rownames(random_classifier_auc_params)
+
+ ## -- aggregate -- random class AUC
+ prop_table <- table(evaldata_params[[col_truth]])
+ random_classifier_auc_agg <- unname(prop_table["TRUE"]/sum(prop_table))
+
+ ## -- 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 <- pr_curve_params[, compute_pr_auc(.SD), by=c("from", col_param), .SDcols=c("recall", "precision")]
+ names(pr_auc_params)[ names(pr_auc_params) == "V1" ] <- "pr_AUC"
+ pr_auc_params <- join_dtf(pr_auc_params, random_classifier_auc_params ,
+ k1 = col_param, k2 = col_param)
+ names(pr_auc_params)[ names(pr_auc_params) == "random_classifier_auc_params" ] <- "pr_randm_AUC"
+
+
+
+
+ ## -- aggregate
+ pr_curve_agg <- dt_evaldata_params[, compute_pr_curve(.SD), by = "from", .SDcols=c(col_truth, col_score)]
+ pr_auc_agg <- pr_curve_agg[, compute_pr_auc(.SD), by = "from", .SDcols=c("recall", "precision")]
+ names(pr_auc_agg)[ names(pr_auc_agg) == "V1" ] <- "pr_AUC"
+ pr_auc_agg$pr_randm_AUC <- random_classifier_auc_agg
+
+
+ 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
+ pr_curve <- compute_pr_curve(dt)
+ result <- compute_pr_auc(pr_curve)
+ expect_equal(expected = 0.60, 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(c("FALSE","TRUE"), 100, replace = TRUE),
+ from = c("A", "B"),
+ p.adj = runif(100),
+ effect = "fixed"
+ )
+
+ # 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))
+
+ ## -- not only fixed effect
+ # Mock data for testing
+ set.seed(42)
+ dt_evaldata_params <- data.table::data.table(
+ description = rep(c("param1", "param2"), each = 50),
+ isDE = sample(c(TRUE,FALSE), 100, replace = TRUE),
+ from = c("A", "B"),
+ p.adj = runif(100),
+ effect = sample(c("fixed","ran_pars"), 100, replace = TRUE)
+ )
+
+ # 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."))
+
+ ## replace infinite numbers by max values
+ ## avoid prob with infinite values
+ #for (i in 1:length(predictions)) {
+ # epsilon <- max(predictions[[i]][is.finite(predictions[[i]] )])
+ # idx_inf_values <- !is.finite( predictions[[i]] )
+ # predictions[[i]][idx_inf_values] <- epsilon
+ #}
+
+ ## 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)
+ }
+
+ }
+ #print(levels)
+ #print(labels)
+ 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)
+}
+
+
+
+#' Check Validity of Truth Labels
+#'
+#' This function checks the validity of truth labels for HTRfit evaluation, specifically designed for binary classification.
+#'
+#' @param eval_data Data frame containing evaluation parameters.
+#' @param col_param Column name specifying the parameter for grouping.
+#' @param col_truth Column name for binary ground truth values (default is "isDE").
+#' @return Logical value indicating the validity of truth labels.
+#' @export
+is_truthLabels_valid <- function(eval_data, col_param = "description", col_truth = "isDE" ) {
+
+ ## --init
+ isValid <- TRUE
+
+ ## -- subset fixed effect
+ eval_data_fixed <- subset(eval_data, effect == "fixed")
+
+ table_summary <- table(eval_data_fixed[[col_param]], eval_data_fixed[[col_truth]])
+ ## -- 2 lines needed (FALSE/TRUE)
+ n_labels <- dim(table_summary)[2]
+ if(n_labels != 2) {
+ labels_str <- paste(colnames(table_summary), collapse = ", ")
+ msg <- paste("Both FALSE/TRUE truth labels (isDE) are required for classification evaluation.\nFound : ", labels_str )
+ message(msg)
+ isValid <- FALSE
+ }
+ ## -- one label found 0 time !
+ label_not_found <- which(table_summary == 0, arr.ind=TRUE)
+ if(dim(label_not_found)[1] > 0){
+ description <- rownames(label_not_found)
+ label_not_found <- colnames(table_summary)[label_not_found[,"col"]]
+ msg <- "Both TRUE and FALSE labels are required for HTRfit evaluation.\n"
+ msg2 <- paste("Label isDE ==", label_not_found, "not found for description ==", description, collapse = '\n')
+ msg3 <- "Please review your threshold or alternative hypothesis, and consider checking the identity plot for further insights."
+ msg <- paste(msg, msg2, ".\n", msg3 , sep = "")
+ message(msg)
+ isValid <- FALSE
+ }
+ return(isValid)
+}
+
+
+
+#' 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 threshold (\code{coeff_threshold}) and
+#' alternative hypothesis (\code{alt_hypothesis}).
+#'
+#' @param list_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 coeff_threshold A non-negative value which specifies a ln(fold change) threshold. The Threshold is used for the Wald test to determine whether the coefficient (β) is significant or not, depending on \code{alt_hypothesis} parameter. Default is 0, ln(FC = 1).
+#' @param alt_hypothesis Alternative hypothesis for the Wald test (default is "greaterAbs").
+#' Possible choice:
+#' "greater"
+#' - β > coeff_threshold,
+#' "less"
+#' - β < −coeff_threshold,
+#' or two-tailed alternative:
+#' "greaterAbs"
+#' - |β| > coeff_threshold
+#' @param alpha_risk parameter that sets the threshold for alpha risk level while testing coefficient (β). Default: 0.05.
+#' @param palette_color Optional parameter that sets the color palette for plots.Default : c(DESeq2 = "#500472", HTRfit ="#79cbb8").
+#' @param skip_eval_intercept indicate whether to calculate precision-recall and ROC metrics for the intercept (default TRUE).
+#' @param ... Additional parameters to be passed to aesthetics \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.}
+#' \item{performances}{A summary of the performances obtained.}
+#' @export
+evaluation_report <- function(list_tmb, dds, mock_obj, coeff_threshold, alt_hypothesis, alpha_risk = 0.05, palette_color = c(DESeq2 = "#500472", HTRfit ="#79cbb8"), skip_eval_intercept = TRUE, ...) {
+
+ ## -- eval data
+ eval_data <- get_eval_data(list_tmb, dds, mock_obj, coeff_threshold, alt_hypothesis)
+
+ ## -- identity plot
+ #identity_data <- rbind_model_params_and_dispersion(eval_data)
+ params_identity_eval <- eval_identityTerm(eval_data$modelparams, palette_color)
+ dispersion_identity_eval <- eval_identityTerm(eval_data$modeldispersion, palette_color)
+
+ if (isTRUE(skip_eval_intercept)){
+ eval_data2metrics <- subset(eval_data$modelparams,
+ term != "(Intercept)")
+ }
+ else{
+ eval_data2metrics <- eval_data$modelparams
+ }
+
+ ## -- counts plot
+ counts_violinplot <- counts_plot(mock_obj)
+
+ ## -- check if eval data ok
+ if(isFALSE(is_truthLabels_valid(eval_data2metrics))){
+
+ message("The required truth labels for HTRfit classification metrics evaluation are not met. Only the identity plot and counts plot will be returned.")
+ ## -- 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 ),
+ counts = counts_violinplot
+
+ ))
+
+
+ }
+
+
+
+ ## -- pr curve
+ pr_curve_obj <- get_pr_object(eval_data2metrics)
+ pr_curve_obj <- get_pr_curve(pr_curve_obj, palette_color = palette_color, ...)
+
+ ## -- auc curve
+ roc_curve_obj <- get_roc_object(eval_data2metrics)
+ roc_curve_obj <- get_roc_curve(roc_curve_obj, palette_color = palette_color, ...)
+
+ ## -- acc, recall, sensib, speci, ...
+ metrics_obj <- get_ml_metrics_obj(eval_data2metrics, alpha_risk )
+ ## -- merge all metrics in one obj
+ model_perf_obj <- get_performances_metrics_obj( r2_params = 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"){
+
+ ## -- subset fixed eff
+ evaldata_params <- subset(evaldata_params, effect == "fixed")
+
+
+ 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)
+)
- plot <- identity_plot(comparison_data)
+ table_grob <- getGrobTable(non_numeric_data)
- expect_true("gg" %in% class(plot))
+ expect_s3_class(table_grob, "gtable")
})
+```
-```
+```{r function-evaluation, filement = "evaluation"}
-```{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.
+#' 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".
#'
-#' @importFrom gridExtra arrangeGrob grid.arrange
-#' @importFrom ggplot2 ggsave
+#' @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".
#'
-#' @return report
+#' @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
-exportReportFile <- function(report_file, table_settings, roc_curve, dispersion_plot, id_plot, counts_plot){
+get_eval_data_from_dds <- function(dds, mock_obj, coeff_threshold, alt_hypothesis){
- 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))
+ ## -- reshape 2 dataframe
+ tidy_dds <- wrap_dds(dds, coeff_threshold, alt_hypothesis)
- if (!is.null(report_file)) ggplot2::ggsave(report_file, p2export, height = 10, width = 15)
+ ## -- 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 ))
- 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.
+
+
+#' Combines evaluation data from TMB and DESeqDataSet (dds) objects.
#'
-#' @param df The data frame to be converted into a formatted table.
+#' This function combines model parameters and dispersion data frames from TMB and DESeqDataSet (dds) evaluations.
#'
-#' @return A grid graphics object representing the formatted table.
+#' @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
-#' @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)
+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 ))
}
-#' Generate a simulation report
+#' Combines model parameters and dispersion data frames.
#'
-#' This function generates a simulation report containing various plots and evaluation metrics.
+#' This function combines model parameters and dispersion data frames, ensuring proper alignment.
#'
-#' @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 eval_data Evaluation data containing model parameters and dispersion.
+#' @return A combined data frame with model parameters and dispersion.
#' @export
-simulationReport <- function(mock_obj, list_tmb = NULL,
- coeff_threshold = 0, alt_hypothesis = "greaterAbs", report_file = NULL, dds_obj = NULL ){
+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)
+}
- #-- 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)
+#' 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 Threshold value for coefficient testing (default is 0). This threshold corresponds to the natural logarithm of the fold change (ln(FC)).
+#' @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}
-```{r test-simulation_report}
+# 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 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)
- )
+# Test rbind_evaldata_tmb_dds
+test_that("rbind_evaldata_tmb_dds returns correct output", {
- table_grob <- getGrobTable(sample_data)
+ input_var_list <- init_variable( name = "varA", mu = 3, sd = 2, level = 3)
- expect_s3_class(table_grob, "gtable")
+ ## -- 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 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 rbind_model_params_and_dispersion
+test_that("rbind_model_params_and_dispersion 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 = 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"))
+
})
+
+
```
@@ -6524,6 +8811,8 @@ is_formula_mixedTypeI <- function(formula) {
if (length(all.vars(formula)) != 3) return(FALSE)
if (sum(all.names(formula) == "+") > 1) return(FALSE)
if (sum(all.names(formula) == "/") > 0) return(FALSE)
+ all_var_in_formula <- all.vars(formula, unique = F)
+ if (length(all_var_in_formula) == 4 && all_var_in_formula[2] != all_var_in_formula[3]) return(FALSE)
return(TRUE)
}
@@ -6621,7 +8910,8 @@ getActualMixed_typeI <- function(list_logqij, genes_iter_list, categoricalVar_in
#' Compare the mixed-effects inference to expected values.
#'
-#' This function compares the mixed-effects inference obtained from a mixed-effects model to expected values derived from a ground truth dataset. The function assumes a specific type I mixed-effect structure in the input model.
+#' This function compares the mixed-effects inference obtained from a mixed-effects model to expected values derived from a ground truth dataset.
+#' The function assumes a specific type I mixed-effect structure in the input model.
#
#' @param tidy_tmb tidy model results obtained from fitting a mixed-effects model.
#' @param ground_truth_eff A data frame containing ground truth effects.
@@ -6663,8 +8953,8 @@ inferenceToExpected_withMixedEff <- function(tidy_tmb, ground_truth_eff){
#' Calculate actual mixed effects.
#'
#' This function calculates actual mixed effects based on the given data for a specific type I mixed-effect structure.
-# It calculates the expected values, standard deviations, and correlations between the fixed and random effects.
-# The function is designed to work with specific input data for type I mixed-effect calculations.
+# It calculates the expected values, standard deviations, and correlations between the fixed and random effects.
+# The function is designed to work with specific input data for type I mixed-effect calculations.
#
#' @param data_gene Data for a specific gene.
#' @param labelRef_InCategoricalVar The reference label for the categorical variable.
@@ -6780,11 +9070,14 @@ test_that("Test is_formula_mixedTypeI", {
formula2 <- y ~ z + group1 + (1 | group1)
formula3 <- y ~ z + (1 | group1 + group2)
formula4 <- y ~ z + (1 | group1/z)
-
+ formula5 <- y ~ z + ( group | z ) ## z is fixed then expected on the left in parenthesis
+
expect_true(is_formula_mixedTypeI(formula1))
expect_false(is_formula_mixedTypeI(formula2))
expect_false(is_formula_mixedTypeI(formula3))
expect_false(is_formula_mixedTypeI(formula4))
+ expect_false(is_formula_mixedTypeI(formula5))
+
})
@@ -6980,33 +9273,36 @@ 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.
+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 others are expected to impact this statistical power. To help with 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.
+# Initializing variables for simulation
-## Manually init my first variable
+The `init_variable()` function is used for defining the variables in your experimental design. Sizes of effects for each variable and interaction term can be defined in two different ways: 1) The user can manually sets values of all levels of a variable, in which case the effects are necessarily considered fixed in the model; 2) The effects can be randomly picked in a normal distribution with mean and standard deviation defined by the user, in which case the user can decide whether the effects are considered fixed or random in the model.
+
+
+## Manually init a single 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.
+In this example, we manually initialize **varA** with specific size effects (mu) for three 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)
+list_var <- init_variable( name = "varA", mu = c(0.2, 4, -3), level = 3)
```
-## Randomly init my first variable
+## Randomly init a single 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.
+This introduces variability into **varA**, making it either a fixed or random 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)
+list_var <- init_variable( name = "varA", mu = 10, sd = 0.2, level = 5)
```
@@ -7015,31 +9311,35 @@ input_var_list <- init_variable( name = "varA", mu = 10, sd = 0.2, level = 5)
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) %>%
+list_var <- 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.
+Similarly to `init_variable()`, `add_interaction()` allows to define 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) %>%
+list_var <- 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
+## 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) %>%
+
+```{r example-add_interaction_complex, eval= FALSE, message=FALSE, warning=FALSE, include=TRUE}
+## /!\ not evaluated in Vignette
+list_var <- 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) %>%
@@ -7049,60 +9349,70 @@ input_var_list <- init_variable( name = "varA", mu = 5, sd = 0.2, level = 2) %>%
```
-# Simulate RNAseq data
+## Structure of list_var object
+
+```{r example-str_obj_init, warning=FALSE, message=FALSE}
+str(list_var)
+```
+
+
+# Simulation of 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 number of genes, minimum and maximum number of replicates within your experimental setup, sequencing depth, basal expression of each gene, and dispersion of gene expression used for simulating counts.
-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
+N_GENES = 6000
MIN_REPLICATES = 2
MAX_REPLICATES = 10
########################
-## -- simulate RNAseq data based on input_var_list, minimum input required
+## -- simulate RNAseq data based on list_var, minimum input required
## -- number of replicate randomly defined between MIN_REP and MAX_REP
-mock_data <- mock_rnaseq(input_var_list, N_GENES,
+mock_data <- mock_rnaseq(list_var, 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,
+## -- simulate RNAseq data based on list_var, minimum input required
+## -- Same number of replicates between conditions
+mock_data <- mock_rnaseq(list_var, N_GENES,
min_replicates = MAX_REPLICATES,
max_replicates = MAX_REPLICATES)
```
-
-## Scaling genes counts with sequencing depth
+
+## Scaling genes counts based on 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
+N_GENES = 6000
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,
+mock_data <- mock_rnaseq(list_var, 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.
+## Set dispersion of gene expression
-```{r example-mock_rnaseq_disp, warning=FALSE, message=FALSE}
+The dispersion parameter ($dispersion_i$), characterizes the relationship between the variance of the observed read counts and its mean value. In simple terms, it quantifies how much we expect observed counts 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
+N_GENES = 6000
MIN_REPLICATES = 2
MAX_REPLICATES = 4
########################
@@ -7110,22 +9420,20 @@ 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,
+mock_data <- mock_rnaseq(list_var, 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.
+The basal gene expression parameter, defined using the basal_expression option, allows you to control the fundamental baseline of expression level of genes. When a single value is specified, the basal expression of all genes is the same and the effects of variables defined in list_var are applied from this basal expression level. When several values are specified, the basal expression of each gene is picked randomly among these values (with replacement). The effects of variables are then applied from the basal expression of each gene. This represents the fact that expression levels can vary among genes even when not considering the effects of the defined variables (for example, some genes are constitutively more highly expressed than others because they have stronger basal promoters).
-```{r example-mock_rnaseq_bexpr, warning=FALSE, message=FALSE}
+```{r example-mock_rnaseq_bexpr, warning = FALSE, message = FALSE}
## -- Required parameters
-N_GENES = 50
+N_GENES = 6000
MIN_REPLICATES = 10
MAX_REPLICATES = 10
########################
@@ -7133,30 +9441,35 @@ 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,
+mock_data <- mock_rnaseq(list_var, N_GENES,
min_replicates = MIN_REPLICATES,
max_replicates = MAX_REPLICATES,
basal_expression = BASAL_EXPR)
-## -- output list attributes
-names(mock_data)
```
-# Theory behind HTRfit simulation
+## Mock RNAseq object
+
+```{r example-str_obj_mock, warning=FALSE, message=FALSE}
+str(mock_data, max.level = 1)
+```
+
+
+# Theory behind HTRfit
+
<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$.
+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 $dispersion_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.
-
+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 $dispersion_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 for each genes.
# Fitting models
@@ -7166,7 +9479,22 @@ Furthermore, the coefficients $\beta_i$ represent the natural logarithm fold cha
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}
+```{r example-prepareData, warning=FALSE, message=FALSE}
+## -- simulate small example to prevent excessively lengthy vignette construction
+list_var <- 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)
+N_GENES = 30
+MIN_REPLICATES = 4
+MAX_REPLICATES = 4
+BASAL_EXPR = rnorm(N_GENES , 0 , 1 )
+mock_data <- mock_rnaseq(list_var, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES,
+ basal_expression = BASAL_EXPR)
+########################
+
+
## -- data from simulation or real data
count_matrix <- mock_data$counts
metaData <- mock_data$metadata
@@ -7175,7 +9503,8 @@ 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)
+ normalization = F,
+ response_name = "kij")
## -- median ratio normalization
@@ -7183,11 +9512,9 @@ 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.
@@ -7206,7 +9533,7 @@ l_tmb <- fitModelParallel(formula = kij ~ varA,
**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}
+```{r example-fitModelParallel_mixed, warning=FALSE, message=FALSE}
l_tmb <- fitModelParallel(formula = kij ~ varA + ( 1 | varB ),
data = data2fit,
group_by = "geneID",
@@ -7234,15 +9561,24 @@ l_tmb <- fitModelParallel(formula = kij ~ varA,
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 ,
+l_tmb_iris <- fitModelParallel(formula = Sepal.Length ~ Sepal.Width + Petal.Length + Petal.Width ,
data = iris,
group_by = "Species",
family = gaussian(),
n.cores = 1)
```
+## Extracts a tidy result table from a list tmb object
+
+The tidy_results function extracts a dataframe containing estimates of ln(fold changes), standard errors, test statistics, p-values, and adjusted p-values for fixed effects. Additionally, it provides access to correlation terms and standard deviations for random effects, offering a detailed view of HTRfit modeling results.
+
+```{r example-tidyRes, warning=FALSE, message=FALSE}
+## -- get tidy results
+tidy_results(l_tmb_iris, coeff_threshold = 0.1, alternative_hypothesis = "greaterAbs")
+```
+
+
## Update fit
The `updateParallel()` function updates and re-fits a model for each gene. It offers options similar to those in `fitModelParallel()`.
@@ -7268,24 +9604,29 @@ l_tmb <- updateParallel(formula = kij ~ varA + varB + varA:varB ,
list_tmb = l_tmb ,
family = glmmTMB::nbinom2(link = "log"),
n.cores = 1)
+```
+
+#### Struture of list tmb object
-## -- output
-l_tmb$gene1
+
+```{r example-str_obj_l_tmb, warning=FALSE, message=FALSE}
+str(l_tmb$gene1, max.level = 1)
```
+
## 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}
+```{r example-plotMetrics , warning=FALSE, message=FALSE, fig.align='center', fig.height=4, fig.width=8}
## -- plot all metrics
-metrics_plot(list_tmb = l_tmb)
+diagnostic_plot(list_tmb = l_tmb)
```
-```{r example-plotMetricsFocus, warning=FALSE, message=FALSE, fig.align='center', fig.height=3, fig.width=4}
+```{r example-plotMetricsFocus, warning=FALSE, message=FALSE, fig.align='center', fig.height=3, fig.width=8}
## -- Focus on metrics
-metrics_plot(list_tmb = l_tmb, focus = c("dispersion", "logLik"))
+diagnostic_plot(list_tmb = l_tmb, focus = c("dispersion", "logLik"))
```
## Anova to select the best model
@@ -7300,55 +9641,86 @@ 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.
+In this section, we delve into the evaluation of your simulation results. The `evaluation_report()` 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'}
+```{r example-evaluation_report, 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")
+resSimu <- evaluation_report(list_tmb = l_tmb,
+ dds = NULL,
+ mock_obj = mock_data,
+ coeff_threshold = 0.4,
+ alpha_risk = 0.05,
+ 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.
+The `evaluation_report()` function produces an identity plot, offering a visual tool to juxtapose the simulated effects (actual effects) with the model-inferred effects. This graphical representation simplifies assessing how well the model aligns with the values of the simulated effects, enabling a visual analysis of the model's goodness of fit to the simulated data. For a more quantitative evaluation of inference quality, the R-squared (R2) metric can be employed.
+
+#### Model parameters
+
+```{r example-outputIdentity_params, warning = FALSE, message = FALSE, fig.align='center', fig.height=4, fig.width=5}
+## -- Model params
+resSimu$identity$params
+```
+
+#### Dispersion parameter
+
+```{r example-outputIdentity_disp, warning = FALSE, message = FALSE, fig.align='center', fig.height=4, fig.width=5}
+## -- Dispersion params
+resSimu$identity$dispersion
+```
+
+The dispersion plot, generated by the `evaluation_report()` 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.
+
+
+## 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_plotID, warning = FALSE, message = FALSE, fig.align='center', fig.height=4, fig.width=5}
-resSimu$identity_plot
+```{r example-outputROC, warning = FALSE, message = FALSE, fig.align='center', fig.height=4, fig.width=7}
+## -- ROC curve
+resSimu$roc$params
```
-## 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.
+## Precision-recall curve
+
-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.
+The precision-recall curve (PR curve) illustrates the relationship between precision and recall at various classification thresholds. It is particularly valuable in the context of imbalanced data, where one class is significantly more prevalent than the other. Unlike the ROC curve, which can be influenced by class distribution, the PR curve focuses on the model's ability to correctly identify examples of the minority class while maintaining high precision.
-```{r example-simulationReport_plotDisp, warning = FALSE, message = FALSE, fig.align='center', fig.height=4, fig.width=5}
-resSimu$dispersionEvaluation$disp_plot
+
+```{r example-outputPR, warning = FALSE, message = FALSE, fig.align='center', fig.height=4, fig.width=7}
+## -- precision-recall curve
+resSimu$precision_recall$params
```
-## ROC curve
+## AUC and classification performance metrics
-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.
+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. In the case of the ROC curve, this AUC should be compared to the value of 0.5, representing a random classifier. On the other hand, for the PR curve, we compute the pr_AUC_random, serving as a baseline for comparison.
-```{r example-simulationReport_plotRoc, warning = FALSE, message = FALSE, fig.align='center', fig.height=4, fig.width=5}
-resSimu$roc_plot
+
+In addition to evaluating model performance through the AUC for both ROC and PR curves, we provide access to key classification metrics, including Accuracy, Precision, Recall (or Sensitivity), and Specificity. These metrics offer a comprehensive view of the model's classification capabilities. These metrics are computed for each parameter (excluding the intercept when skip_eval_intercept = TRUE), providing detailed insights into individual parameter contributions. Furthermore, an aggregated assessment is performed, considering all parameters (except the intercept by default), offering a perspective on the model's overall classification effectiveness.
+
+
+```{r example-outputPerf, warning = FALSE, message = FALSE, fig.align='center', fig.height=4, fig.width=7}
+## -- precision-recall curve
+resSimu$performances
```
+
## 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)
@@ -7360,20 +9732,29 @@ dds <- DESeq2::DESeq(dds, quiet = TRUE)
## -- get simulation/fit evaluation
-resSimu <- simulationReport(mock_data,
- list_tmb = l_tmb,
- dds_obj = dds,
+resSimu <- evaluation_report(list_tmb = l_tmb,
+ dds = dds,
+ mock_obj = mock_data,
coeff_threshold = 0.4,
alt_hypothesis = "greaterAbs")
```
-```{r example-outputResSimu, warning = FALSE, message = FALSE, fig.align='center', fig.height=4, fig.width=5}
+
+```{r example-outputResSimu_id, 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
+###### 1) Model params
+resSimu$identity$params
+###### Dispersion params
+resSimu$identity$dispersion
+```
+
+```{r example-outputResSimu_metric, warning = FALSE, message = FALSE, fig.align='center', fig.height=4, fig.width=7}
+## -- precision-recall curve
+resSimu$precision_recall$params
+## -- ROC curve
+resSimu$roc$params
+## -- Performances metrics
+resSimu$performances
```
## Focus evaluation on a subset of genes
@@ -7388,21 +9769,62 @@ mock_lowExpressed <- subsetGenes(l_genes, mock_data)
## -- get simulation/fit evaluation
-resSimu <- simulationReport(mock_lowExpressed,
- list_tmb = l_tmb,
- dds_obj = dds,
+resSimu <- evaluation_report(list_tmb = l_tmb,
+ dds = dds,
+ mock_obj = mock_lowExpressed,
+ coeff_threshold = 0.4,
+ alt_hypothesis = "greaterAbs")
+```
+
+As we compare this evaluation to the previous one, we observe a reduction in performances for both **HTRfit** and **DESeq2** inferences.
+
+```{r example-subsetGenes_id, warning=FALSE, message=FALSE, fig.align='center', fig.height=4, fig.width=5}
+## -- identity plot
+###### 1) Model params
+resSimu$identity$params
+###### Dispersion params
+resSimu$identity$dispersion
+```
+
+```{r example-subsetGenes_metrics, warning=FALSE, message=FALSE, fig.align='center', fig.height=4, fig.width=7}
+## -- precision-recall curve
+resSimu$precision_recall$params
+## -- ROC curve
+resSimu$roc$params
+## -- Performances metrics
+resSimu$performances
+```
+
+
+## Modifying your alpha risk
+
+```{r example-alphaRisk_1, warning = FALSE, message = FALSE}
+## -- get simulation/fit evaluation
+resSimu <- evaluation_report(list_tmb = l_tmb,
+ dds = dds,
+ mock_obj = mock_data,
coeff_threshold = 0.4,
+ alpha_risk = 0.05, ## -- default
alt_hypothesis = "greaterAbs")
+## -- Performances metrics
+resSimu$performances
```
-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
+```{r example-alphaRiskk_2, warning = FALSE, message = FALSE}
+## -- get simulation/fit evaluation
+resSimu <- evaluation_report(list_tmb = l_tmb,
+ dds = dds,
+ mock_obj = mock_data,
+ coeff_threshold = 0.4,
+ alpha_risk = 0.01,
+ alt_hypothesis = "greaterAbs")
+## -- Performances metrics
+resSimu$performances
```
-# Evaluate model inference involving mixed effects
+
+## 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.
@@ -7413,41 +9835,60 @@ input_var_list <- init_variable( name = "varA", mu = 0, sd = 0.29, level = 60) %
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,
+ n_genes = 30, ## small number to prevent excessively lengthy vignette construction
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)
+ normalization = F,
+ response_name = "kij")
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")
+resSimu <- evaluation_report(list_tmb = l_tmb,
+ dds = NULL,
+ mock_obj = mock_data,
+ coeff_threshold = 0.27,
+ alt_hypothesis = "greater")
```
-```{r example-outputResSimuMixed, warning = FALSE, message = FALSE, fig.align='center', fig.height=4, fig.width=5}
+```{r example-outputResSimuMixed_id, 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
+###### 1) Model params
+resSimu$identity$params
+###### Dispersion params
+resSimu$identity$dispersion
+```
+
+```{r example-outputResSimuMixed_metric, warning = FALSE, message = FALSE, fig.align='center', fig.height=4, fig.width=7}
+## -- precision-recall curve
+resSimu$precision_recall$params
+## -- ROC curve
+resSimu$roc$params
+## -- Performances metrics
+resSimu$performances
+```
+
+## Structure of evaluation report object
+
+
+```{r example-str_eval_report, warning=FALSE, message=FALSE}
+str(resSimu, max.level = 1)
```
+## 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 complex experimental designs. As of now, HTRfit supports the evaluation of *Type I* mixed models. In this context, *Type I* models are defined as those that follow the structure:
+- `~ varA + (1 | varB)` : where `varA` is defined as fixed effect and `varB` as random effect
+- `~ varA + (varA | varB)`: where `varA` is defined as mixed effect (fixed + random) and `varB` as random effect.
-# About mixed model evaluation
+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.
-**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}
@@ -7457,7 +9898,7 @@ fusen::fill_description(fields = list(Title = "HTRfit"), overwrite = T)
usethis::use_mit_license("Arnaud DUVERMY")
usethis::use_pipe(export = TRUE)
devtools::document()
-.# Keep eval=FALSE to avoid infinite loop in case you hit the knit button
+# Keep eval=FALSE to avoid infinite loop in case you hit the knit button
# Execute in the console directly
fusen::inflate(flat_file = "dev/flat_full.Rmd", vignette_name = "HTRfit", open_vignette = T, overwrite = T)
```
diff --git a/man/Area_Under_Curve.Rd b/man/Area_Under_Curve.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..dfb6d8652540651e7e1d3b5b0222cb082a54743c
--- /dev/null
+++ b/man/Area_Under_Curve.Rd
@@ -0,0 +1,26 @@
+% 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 = "trapezoid")
+}
+\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"}
+}
+\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")
+}
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/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/checkFractionOfZero.Rd b/man/checkFractionOfZero.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..198bfe4a9d7fac5f39c76c18cf3740678e4e5aed
--- /dev/null
+++ b/man/checkFractionOfZero.Rd
@@ -0,0 +1,20 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/mock_rnaseq.R
+\name{checkFractionOfZero}
+\alias{checkFractionOfZero}
+\title{Check Fraction of Zero or One in Counts Table}
+\usage{
+checkFractionOfZero(counts_table)
+}
+\arguments{
+\item{counts_table}{A matrix or data frame representing counts.}
+}
+\description{
+This function checks the percentage of counts in a given counts table that are either zero or one.
+If more than 50\% of the counts fall in this category, a warning is issued, suggesting a review of input parameters.
+}
+\examples{
+# Example usage:
+counts_table <- matrix(c(0, 1, 2, 3, 4, 0, 0, 1, 1), ncol = 3)
+checkFractionOfZero(counts_table)
+}
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..08511585af5c2f637ea8af0c5ed4502d98c3a6a6
--- /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 True positive rate and False positive rate}
+}
+\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..9d142a4298137871ce3941d7cfd1aa8c73023e4c
--- /dev/null
+++ b/man/evaluation_report.Rd
@@ -0,0 +1,63 @@
+% 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(
+ list_tmb,
+ dds,
+ mock_obj,
+ coeff_threshold,
+ alt_hypothesis,
+ alpha_risk = 0.05,
+ palette_color = c(DESeq2 = "#500472", HTRfit = "#79cbb8"),
+ skip_eval_intercept = TRUE,
+ ...
+)
+}
+\arguments{
+\item{list_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{coeff_threshold}{A non-negative value which specifies a ln(fold change) threshold. The Threshold is used for the Wald test to determine whether the coefficient (β) is significant or not, depending on \code{alt_hypothesis} parameter. Default is 0, ln(FC = 1).}
+
+\item{alt_hypothesis}{Alternative hypothesis for the Wald test (default is "greaterAbs").
+Possible choice:
+"greater"
+\itemize{
+\item β > coeff_threshold,
+"less"
+\item β < −coeff_threshold,
+or two-tailed alternative:
+"greaterAbs"
+\item |β| > coeff_threshold
+}}
+
+\item{alpha_risk}{parameter that sets the threshold for alpha risk level while testing coefficient (β). Default: 0.05.}
+
+\item{palette_color}{Optional parameter that sets the color palette for plots.Default : c(DESeq2 = "#500472", HTRfit ="#79cbb8").}
+
+\item{skip_eval_intercept}{indicate whether to calculate precision-recall and ROC metrics for the intercept (default TRUE).}
+
+\item{...}{Additional parameters to be passed to aesthetics \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.}
+\item{performances}{A summary of the performances obtained.}
+}
+\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 threshold (\code{coeff_threshold}) and
+alternative hypothesis (\code{alt_hypothesis}).
+}
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/fitModel.Rd b/man/fitModel.Rd
index 56f945e526c9efd1253547e3f3f06047d30acd41..67a588c7d93d429140a79757ecb2d3c1ef50cc59 100644
--- a/man/fitModel.Rd
+++ b/man/fitModel.Rd
@@ -7,7 +7,7 @@
fitModel(group, formula, data, ...)
}
\arguments{
-\item{group}{group id to save in glmmTMB obj (usefull for update !)}
+\item{group}{ID to fit}
\item{formula}{Formula specifying the model formula}
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..d3c89297f447d8f22901fe523162bd56b24620c9
--- /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}{Threshold value for coefficient testing (default is 0). This threshold corresponds to the natural logarithm of the fold change (ln(FC)).}
+
+\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/inferenceToExpected_withMixedEff.Rd b/man/inferenceToExpected_withMixedEff.Rd
index bcb6dff787af2e14d8408b95cad8bf417992be49..113810bda47a17a905ef87cfc1f0f507d35da78f 100644
--- a/man/inferenceToExpected_withMixedEff.Rd
+++ b/man/inferenceToExpected_withMixedEff.Rd
@@ -15,7 +15,8 @@ inferenceToExpected_withMixedEff(tidy_tmb, ground_truth_eff)
A data frame with the comparison of estimated mixed effects to expected values.
}
\description{
-This function compares the mixed-effects inference obtained from a mixed-effects model to expected values derived from a ground truth dataset. The function assumes a specific type I mixed-effect structure in the input model.
+This function compares the mixed-effects inference obtained from a mixed-effects model to expected values derived from a ground truth dataset.
+The function assumes a specific type I mixed-effect structure in the input model.
}
\examples{
\dontrun{
diff --git a/man/is_truthLabels_valid.Rd b/man/is_truthLabels_valid.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..a812e18d1c9dac7a1bfe2e8298ceedffc70f6837
--- /dev/null
+++ b/man/is_truthLabels_valid.Rd
@@ -0,0 +1,21 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_report.R
+\name{is_truthLabels_valid}
+\alias{is_truthLabels_valid}
+\title{Check Validity of Truth Labels}
+\usage{
+is_truthLabels_valid(eval_data, col_param = "description", col_truth = "isDE")
+}
+\arguments{
+\item{eval_data}{Data frame containing evaluation parameters.}
+
+\item{col_param}{Column name specifying the parameter for grouping.}
+
+\item{col_truth}{Column name for binary ground truth values (default is "isDE").}
+}
+\value{
+Logical value indicating the validity of truth labels.
+}
+\description{
+This function checks the validity of truth labels for HTRfit evaluation, specifically designed for binary classification.
+}
diff --git a/man/is_validGroupBy.Rd b/man/is_validGroupBy.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..7af8d6373674d83e209692eadf03ff8f401e97b6
--- /dev/null
+++ b/man/is_validGroupBy.Rd
@@ -0,0 +1,22 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/fitmodel.R
+\name{is_validGroupBy}
+\alias{is_validGroupBy}
+\title{Check if group by exist in data}
+\usage{
+is_validGroupBy(data, group_by)
+}
+\arguments{
+\item{data}{The data framecontaining the variables to be used for model fitting.}
+
+\item{group_by}{Column name in data representing the grouping variable}
+}
+\value{
+\code{TRUE} if exist otherwise an error is raised
+}
+\description{
+Check if group by exist in data
+}
+\examples{
+is_validGroupBy(mtcars, 'mpg')
+}
diff --git a/man/launchFit.Rd b/man/launchFit.Rd
index 4bb44a5cefcbb828a0c49735c7d2b3dbd2128336..92b9ed65f746e91d66f7d94422776738ac50fa58 100644
--- a/man/launchFit.Rd
+++ b/man/launchFit.Rd
@@ -4,17 +4,15 @@
\alias{launchFit}
\title{Launch the model fitting process for a specific group.}
\usage{
-launchFit(group, group_by, formula, data, ...)
+launchFit(data, group_by, formula, ...)
}
\arguments{
-\item{group}{The specific group to fit the model for}
+\item{data}{Data frame containing the data}
\item{group_by}{Column name in data representing the grouping variable}
\item{formula}{Formula specifying the model formula}
-\item{data}{Data frame containing the data}
-
\item{...}{Additional arguments to be passed to the glmmTMB::glmmTMB function}
}
\value{
@@ -25,7 +23,7 @@ This function fits the model using the specified group, group_by, formula, and d
It handles warnings and errors during the fitting process and returns the fitted model or NULL if there was an error.
}
\examples{
-launchFit(group = "setosa", group_by = "Species",
+launchFit(group_by = "Species",
formula = Sepal.Length ~ Sepal.Width + Petal.Length,
- data = iris )
+ data = iris[ iris[["Species"]] == "setosa" , ] )
}
diff --git a/man/parallel_fit.Rd b/man/parallel_fit.Rd
index 77ebb71c1ed0cb50b1c270953b624558f66ffb43..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{
@@ -39,7 +42,7 @@ Fit models in parallel for each group using mclapply and handle logging.
Uses parallel_fit to fit the models.
}
\examples{
-parallel_fit(group_by = "Species", "setosa",
+parallel_fit(group_by = "Species", groups = iris$Species,
formula = Sepal.Length ~ Sepal.Width + Petal.Length,
data = iris, n.cores = 1 )
}
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..9e8e4d53da0679f529019eefb02826695c77afe2
--- /dev/null
+++ b/man/performance-class.Rd
@@ -0,0 +1,134 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/fake-section-title.R, R/na-na.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.
+
+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.
+}
+
+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.}
+
+\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.
+
+
+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}.
+
+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}}
+
+\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..aebc6c484d4db008f3185db80769c84430f9631f
--- /dev/null
+++ b/man/performance.Rd
@@ -0,0 +1,350 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/fake-section-title.R, R/na-na.R
+\name{performance}
+\alias{performance}
+\title{Function to create performance objects}
+\usage{
+performance(prediction.obj, measure, x.measure = "cutoff", ...)
+
+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}.
+
+An S4 object of class \code{performance}.
+}
+\description{
+All kinds of predictor evaluations are performed using this function.
+
+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.}
+}
+
+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".}
+}
+
+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..87a05dabbb5e3ec149315fdcda6b6f2d22bb43fb
--- /dev/null
+++ b/man/prediction-class.Rd
@@ -0,0 +1,115 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/fake-section-title.R, R/na-na.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.
+
+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.}
+
+\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.
+
+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.
+
+
+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}}
+
+\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..9d9848629d46cbad846609a5b79319dd363eae78
--- /dev/null
+++ b/man/prediction.Rd
@@ -0,0 +1,106 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/fake-section-title.R, R/na-na.R
+\name{prediction}
+\alias{prediction}
+\title{Function to create prediction objects}
+\usage{
+prediction(predictions, labels, label.ordering = NULL)
+
+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}.
+
+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.
+
+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.
+
+\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/prepare_dataParallel.Rd b/man/prepare_dataParallel.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..e21e637a0c0c6b4084e087b97d89051608794b92
--- /dev/null
+++ b/man/prepare_dataParallel.Rd
@@ -0,0 +1,25 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/fitmodel.R
+\name{prepare_dataParallel}
+\alias{prepare_dataParallel}
+\title{Fit the model based using fitModel functions.}
+\usage{
+prepare_dataParallel(groups, group_by, data)
+}
+\arguments{
+\item{groups}{list of group ID}
+
+\item{group_by}{Column name in data representing the grouping variable}
+
+\item{data}{Data frame containing the data}
+}
+\value{
+list of dataframe
+}
+\description{
+Fit the model based using fitModel functions.
+}
+\examples{
+prepare_dataParallel(groups = iris$Species, group_by = "Species",
+ data = iris )
+}
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/subsetData_andfit.Rd b/man/subsetData_andfit.Rd
deleted file mode 100644
index e84b1baf65417fc4723a2ebb6f294ebcb6dc1529..0000000000000000000000000000000000000000
--- a/man/subsetData_andfit.Rd
+++ /dev/null
@@ -1,30 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/fitmodel.R
-\name{subsetData_andfit}
-\alias{subsetData_andfit}
-\title{Fit the model based using fitModel functions.}
-\usage{
-subsetData_andfit(group, group_by, formula, data, ...)
-}
-\arguments{
-\item{group}{The specific group to fit the model for}
-
-\item{group_by}{Column name in data representing the grouping variable}
-
-\item{formula}{Formula specifying the model formula}
-
-\item{data}{Data frame containing the data}
-
-\item{...}{Additional arguments to be passed to the glmmTMB::glmmTMB function}
-}
-\value{
-Fitted model object or NULL if there was an error
-}
-\description{
-Fit the model based using fitModel functions.
-}
-\examples{
-subsetData_andfit(group = "setosa", group_by = "Species",
- formula = Sepal.Length ~ Sepal.Width + Petal.Length,
- data = iris )
-}
diff --git a/man/tidy_results.Rd b/man/tidy_results.Rd
index bfe7f35e54fe376cd864f59b0b227c4395a28f23..03479bb5ba409d3eaf954dc1eb5c2e6572c64f93 100644
--- a/man/tidy_results.Rd
+++ b/man/tidy_results.Rd
@@ -14,14 +14,22 @@ tidy_results(
\arguments{
\item{list_tmb}{A list of glmmTMB objects representing the fitted models.}
-\item{coeff_threshold}{The threshold value for coefficient testing (default is 0).}
-
-\item{alternative_hypothesis}{The type of alternative hypothesis for the statistical test (default is "greaterAbs").
-Possible options are "greater" (for greater than threshold), "less" (for less than threshold),
-and "greaterAbs" (for greater than absolute value of threshold).}
+\item{coeff_threshold}{A non-negative value which specifies a ln(fold change) threshold. The Threshold is used for the Wald test to determine whether the coefficient (β) is significant or not, depending on \code{alt_hypothesis} parameter. Default is 0, ln(FC = 1).}
\item{correction_method}{a character string indicating the correction method to apply to p-values. Possible values are:
"holm", "hochberg", "hommel", #' "bonferroni", "BH", "BY", "fdr", and "none".}
+
+\item{alt_hypothesis}{Alternative hypothesis for the Wald test (default is "greaterAbs").
+Possible choice:
+"greater"
+\itemize{
+\item β > coeff_threshold,
+"less"
+\item β < −coeff_threshold,
+or two-tailed alternative:
+"greaterAbs"
+\item |β| > coeff_threshold
+}}
}
\value{
A tidy data frame containing the results of statistical tests for the estimated coefficients.
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-evaluation_withmixedeffect.R b/tests/testthat/test-evaluation_withmixedeffect.R
index 854e95c3f78c48ff302edebc20cdaaa1cbadec86..fbaee4dc2fbae2dc9493183126ed22c89b1470a0 100644
--- a/tests/testthat/test-evaluation_withmixedeffect.R
+++ b/tests/testthat/test-evaluation_withmixedeffect.R
@@ -18,11 +18,14 @@ test_that("Test is_formula_mixedTypeI", {
formula2 <- y ~ z + group1 + (1 | group1)
formula3 <- y ~ z + (1 | group1 + group2)
formula4 <- y ~ z + (1 | group1/z)
-
+ formula5 <- y ~ z + ( group | z ) ## z is fixed then expected on the left in parenthesis
+
expect_true(is_formula_mixedTypeI(formula1))
expect_false(is_formula_mixedTypeI(formula2))
expect_false(is_formula_mixedTypeI(formula3))
expect_false(is_formula_mixedTypeI(formula4))
+ expect_false(is_formula_mixedTypeI(formula5))
+
})
diff --git a/tests/testthat/test-fitmodel.R b/tests/testthat/test-fitmodel.R
index edd210ae2288e3e291110e3447afe8dc95d1eb45..e6a11fc56206bbd54735b905ccc9369a0b2d3cf4 100644
--- a/tests/testthat/test-fitmodel.R
+++ b/tests/testthat/test-fitmodel.R
@@ -115,83 +115,34 @@ test_that("Identify full-rank model matrix (with random eff)", {
expect_true(is_fullrank(metadata, formula))
})
-#test_that(".fitMixteModel returns a fitted mixed-effects model object or NULL if there was an error", {
-# data(mtcars)
-# formula <- mpg ~ cyl + disp + (1|gear)
-# fitted_model <- .fitMixteModel(formula, mtcars)
- # Add appropriate expectations for the fitted mixed-effects model object
-
- # Test with invalid formula
-# invalid_formula <- formula + "invalid"
-# fitted_model_error <- .fitMixteModel(invalid_formula, mtcars)
-# expect_null(fitted_model_error)
-#})
-test_that("subsetData_andfit returns a glmTMB obj", {
+test_that("prepare_dataParallel returns a list of dataframe", {
+ ## -- valid input
data(iris)
- group <- "setosa"
group_by <- "Species"
- formula <- Sepal.Length ~ Sepal.Width + Petal.Length
- fitted_model <- subsetData_andfit(group, group_by, formula, iris)
- expect_s3_class(fitted_model, "glmmTMB")
-
- # Test with invalid formula
- invalid_formula <- Sepal.Length ~ Sepal.Width + Petal.Length + invalid_var
- expect_error(subsetData_andfit(group, group_by, invalid_formula, mtcars))
-
-
- # Additional parameters:
- #change family + formula
- formula <- Sepal.Length ~ Sepal.Width + Petal.Length + (1 | Species)
- fitted_models <- suppressWarnings(subsetData_andfit(group,
- group_by,
- formula = formula,
- data = iris,
- family = glmmTMB::nbinom1(link = "log") ))
- expect_s3_class(fitted_models$call$family, "family")
- expect_equal(fitted_models$call$formula, formula)
- #change control settings
- fitted_models <- suppressWarnings(subsetData_andfit(group,
- group_by,
- formula = formula,
- data = iris,
- family = glmmTMB::nbinom1(link = "log"),
- control = glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,
- eval.max=1e3))))
- expect_equal(fitted_models$call$control, glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,eval.max=1e3)))
+ groups <- unique(iris$Species)
+ l_data <- prepare_dataParallel(groups , group_by, iris)
+ expect_type(l_data, "list")
+ expect_equal(names(l_data), c("setosa", "versicolor", "virginica"))
})
test_that("launchFit handles warnings and errors during the fitting process", {
- data(mtcars)
- group <- "Group1"
- group_by <- "Group"
- formula <- mpg ~ cyl + disp
- fitted_model <- suppressWarnings(launchFit(group, group_by, formula, mtcars))
- expect_s3_class(fitted_model, "glmmTMB")
- # Test with invalid formula
- invalid_formula <- Sepal.Length ~ Sepal.Width + Petal.Length
- output_msg <- capture_message( launchFit(group, group_by, invalid_formula, mtcars))
- expect_match(output_msg$message, ".* error for group Group1 : object 'Sepal.Length' not found")
-
-
# Additional parameters:
#change family + formula
formula <- Sepal.Length ~ Sepal.Width + Petal.Length
fitted_models <- suppressWarnings(launchFit(formula = formula,
- data = iris,
- group_by = group_by,
- group = "setosa",
+ data = iris[ iris$Species == "setosa" , ],
+ group_by = "Species",
family = glmmTMB::nbinom1(link = "log") ))
expect_s3_class(fitted_models$call$family, "family")
expect_equal(fitted_models$call$formula, formula)
#change control settings
fitted_models <- suppressWarnings(launchFit(formula = formula,
- data = iris,
- group_by = group_by,
- group = "setosa",
- family = glmmTMB::nbinom1(link = "log"),
+ data = iris[ iris$Species == "setosa" , ],
+ group_by = "Species",
+ family = glmmTMB::nbinom1(link = "log") ,
control = glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,
eval.max=1e3))))
expect_equal(fitted_models$call$control, glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,eval.max=1e3)))
@@ -241,8 +192,6 @@ test_that("fitModelParallel fits models in parallel for each group and returns a
groups <- unique(iris$Species)
group_by <- "Species"
formula <- Sepal.Length ~ Sepal.Width + Petal.Length
- #is.numeric(iris)
- #iris <- data.frame(lapply(iris, function(y) if(is.numeric(y)) round(y, 0) else y))
fitted_models <- fitModelParallel(formula, iris, group_by, n.cores = 1)
expect_s3_class(fitted_models$setosa, "glmmTMB")
expect_length(fitted_models, length(groups))
@@ -269,6 +218,12 @@ test_that("fitModelParallel fits models in parallel for each group and returns a
control = glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,
eval.max=1e3))))
expect_equal(fitted_models$setosa$call$control, glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,eval.max=1e3)))
+
+ ## -- invalid group by
+ data(iris)
+ group_by <- "invalid_groupBy"
+ formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+ expect_error(fitModelParallel(formula, iris, group_by, n.cores = 1))
})
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-mock_rnaseq.R b/tests/testthat/test-mock_rnaseq.R
index f08ef4cdaf38ca0ddaa442f6220eb32f2d451b24..ac3bcf3ec4c76daa86769cccc92ae50fff875432 100644
--- a/tests/testthat/test-mock_rnaseq.R
+++ b/tests/testthat/test-mock_rnaseq.R
@@ -24,6 +24,18 @@ test_that("generateCountTable generates count table with correct dimensions", {
+test_that("checkFractionofZero issues a warning for high fraction of zeros/ones", {
+ # Test case 1: Less than 50% zeros and ones
+ counts_table_1 <- matrix(c(0, 1, 2, 0, 0, 0, 0, 1, 1), ncol = 3)
+ expect_message(checkFractionOfZero(counts_table_1), "50% of the counts simulated are bellow 1. Consider reviewing your input parameters.")
+
+ # Test case 2: More than 50% zeros and ones
+ counts_table_2 <- matrix(c(0, 1, 0, 0, 1, 10, 100, 1, 1), ncol = 3)
+ expect_null(checkFractionOfZero(counts_table_2))
+
+})
+
+
# Test for replicateMatrix
test_that("replicateMatrix replicates matrix correctly", {
matrix <- matrix(1:9, nrow = 3, ncol = 3)
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..da447006972340880ded1822e9c5a7ba06a0e31e
--- /dev/null
+++ b/tests/testthat/test-precision_recall.R
@@ -0,0 +1,127 @@
+# 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
+ pr_curve <- compute_pr_curve(dt)
+ result <- compute_pr_auc(pr_curve)
+ expect_equal(expected = 0.60, 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(c("FALSE","TRUE"), 100, replace = TRUE),
+ from = c("A", "B"),
+ p.adj = runif(100),
+ effect = "fixed"
+ )
+
+ # 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))
+
+ ## -- not only fixed effect
+ # Mock data for testing
+ set.seed(42)
+ dt_evaldata_params <- data.table::data.table(
+ description = rep(c("param1", "param2"), each = 50),
+ isDE = sample(c(TRUE,FALSE), 100, replace = TRUE),
+ from = c("A", "B"),
+ p.adj = runif(100),
+ effect = sample(c("fixed","ran_pars"), 100, replace = TRUE)
+ )
+
+ # 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..4e4aeacfa33e687f78e384adbd728050ace21747
--- /dev/null
+++ b/tests/testthat/test-receiver_operating_characteristic.R
@@ -0,0 +1,126 @@
+# 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)
+ )
+
+ roc_curve_obj <- compute_roc_curve(dt)
+ # Test
+ result <- compute_roc_auc(roc_curve_obj)
+
+ # Expected output
+ expected_result <- 0.42
+ expect_equal(round(result,2 ), expected_result)
+})
+
+test_that("get_roc_object returns ROC curves and AUCs", {
+ # Test data
+ set.seed(101)
+ 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),
+ effect = rep("fixed", 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"))
+
+ ## -- not only fixed effect
+ set.seed(101)
+ 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),
+ effect = c(rep("fixed", 8), 'ran_pars', 'ran_pars')
+ )
+
+ 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/figs/htrfit_workflow.png b/vignettes/figs/htrfit_workflow.png
index 935352d8fdad6729dcb76c3d1b560dcb5afd5b01..b6d813cf0d81383bac7d8efeddf681a1f70d4182 100644
Binary files a/vignettes/figs/htrfit_workflow.png and b/vignettes/figs/htrfit_workflow.png differ
diff --git a/vignettes/figs/simulation_step.png b/vignettes/figs/simulation_step.png
deleted file mode 100644
index 3ad52b7527046b369f00738f3e9438ac913fc469..0000000000000000000000000000000000000000
Binary files a/vignettes/figs/simulation_step.png and /dev/null differ
diff --git a/vignettes/htrfit.Rmd b/vignettes/htrfit.Rmd
index cbd246aac8a390f7da142a7cd89d2d7ff57473b2..12444de83b744bb1db163ef4f917b65004a3d40e 100644
--- a/vignettes/htrfit.Rmd
+++ b/vignettes/htrfit.Rmd
@@ -34,34 +34,36 @@ 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.
+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 others are expected to impact this statistical power. To help with 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.
+# Initializing variables for simulation
+The `init_variable()` function is used for defining the variables in your experimental design. Sizes of effects for each variable and interaction term can be defined in two different ways: 1) The user can manually sets values of all levels of a variable, in which case the effects are necessarily considered fixed in the model; 2) The effects can be randomly picked in a normal distribution with mean and standard deviation defined by the user, in which case the user can decide whether the effects are considered fixed or random in the model.
-## Manually init my first variable
+
+
+## Manually init a single 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.
+In this example, we manually initialize **varA** with specific size effects (mu) for three 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)
+list_var <- init_variable( name = "varA", mu = c(0.2, 4, -3), level = 3)
```
-## Randomly init my first variable
+## Randomly init a single 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.
+This introduces variability into **varA**, making it either a fixed or random 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)
+list_var <- init_variable( name = "varA", mu = 10, sd = 0.2, level = 5)
```
## Randomly init several variables
@@ -70,32 +72,35 @@ You can also initialize multiple variables, such as **varA** and **varB**, with
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) %>%
+list_var <- 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.
+Similarly to `init_variable()`, `add_interaction()` allows to define 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) %>%
+list_var <- 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
+## 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) %>%
+## /!\ not evaluated in Vignette
+list_var <- 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) %>%
@@ -104,64 +109,70 @@ input_var_list <- init_variable( name = "varA", mu = 5, sd = 0.2, level = 2) %>%
add_interaction( between_var = c("varA", "varB" ,"varC"), mu = 0.87, sd = 0.18)
```
-# Simulate RNAseq data
+## Structure of list_var object
+
+```{r example-str_obj_init, warning = FALSE, message = FALSE}
+str(list_var)
+```
+
+# Simulation of 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 number of genes, minimum and maximum number of replicates within your experimental setup, sequencing depth, basal expression of each gene, and dispersion of gene expression used for simulating counts.
-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
+N_GENES = 6000
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,
+mock_data <- mock_rnaseq(list_var, 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,
+## -- Same number of replicates between conditions
+mock_data <- mock_rnaseq(list_var, N_GENES,
min_replicates = MAX_REPLICATES,
max_replicates = MAX_REPLICATES)
```
-
-
-## Scaling genes counts with sequencing depth
+## Scaling genes counts based on 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
+N_GENES = 6000
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,
+mock_data <- mock_rnaseq(list_var, N_GENES,
min_replicates = MIN_REPLICATES,
max_replicates = MAX_REPLICATES,
sequencing_depth = SEQ_DEPTH)
```
-## Set gene dispersion
+## Set dispersion of gene expression
+
+The dispersion parameter ($dispersion_i$), characterizes the relationship between the variance of the observed read counts and its mean value. In simple terms, it quantifies how much we expect observed counts to deviate from the mean value. You can specify the dispersion for individual genes using the dispersion parameter.
-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
+N_GENES = 6000
MIN_REPLICATES = 2
MAX_REPLICATES = 4
########################
@@ -169,7 +180,7 @@ 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,
+mock_data <- mock_rnaseq(list_var, N_GENES,
min_replicates = MIN_REPLICATES,
max_replicates = MAX_REPLICATES,
dispersion = DISP )
@@ -178,12 +189,12 @@ mock_data <- mock_rnaseq(input_var_list, N_GENES,
## 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.
+The basal gene expression parameter, defined using the basal_expression option, allows you to control the fundamental baseline of expression level of genes. When a single value is specified, the basal expression of all genes is the same and the effects of variables defined in list_var are applied from this basal expression level. When several values are specified, the basal expression of each gene is picked randomly among these values (with replacement). The effects of variables are then applied from the basal expression of each gene. This represents the fact that expression levels can vary among genes even when not considering the effects of the defined variables (for example, some genes are constitutively more highly expressed than others because they have stronger basal promoters).
```{r example-mock_rnaseq_bexpr, warning = FALSE, message = FALSE}
## -- Required parameters
-N_GENES = 50
+N_GENES = 6000
MIN_REPLICATES = 10
MAX_REPLICATES = 10
########################
@@ -191,28 +202,31 @@ 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,
+mock_data <- mock_rnaseq(list_var, N_GENES,
min_replicates = MIN_REPLICATES,
max_replicates = MAX_REPLICATES,
basal_expression = BASAL_EXPR)
-## -- output list attributes
-names(mock_data)
```
-# Theory behind HTRfit simulation
+## Mock RNAseq object
+
+```{r example-str_obj_mock, warning = FALSE, message = FALSE}
+str(mock_data, max.level = 1)
+```
+
+# Theory behind HTRfit
<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$.
+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 $dispersion_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.
-
+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 $dispersion_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 for each genes.
@@ -225,6 +239,21 @@ The `prepareData2fit()` function serves the purpose of converting the counts mat
```{r example-prepareData, warning = FALSE, message = FALSE}
+## -- simulate small example to prevent excessively lengthy vignette construction
+list_var <- 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)
+N_GENES = 30
+MIN_REPLICATES = 4
+MAX_REPLICATES = 4
+BASAL_EXPR = rnorm(N_GENES , 0 , 1 )
+mock_data <- mock_rnaseq(list_var, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES,
+ basal_expression = BASAL_EXPR)
+########################
+
+
## -- data from simulation or real data
count_matrix <- mock_data$counts
metaData <- mock_data$metadata
@@ -233,7 +262,8 @@ 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)
+ normalization = F,
+ response_name = "kij")
## -- median ratio normalization
@@ -241,9 +271,6 @@ data2fit = prepareData2fit(countMatrix = count_matrix,
metadata = metaData,
normalization = T,
response_name = "kij")
-
-## -- output
-head(data2fit)
```
## Fit model from your data
@@ -294,16 +321,25 @@ l_tmb <- fitModelParallel(formula = kij ~ varA,
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
+```{r example-fitModelParallel_nonRNA, warning = FALSE, message = FALSE, eval = TRUE}
data("iris")
-l_tmb <- fitModelParallel(formula = Sepal.Length ~ Sepal.Width + Petal.Length + Petal.Width ,
+l_tmb_iris <- fitModelParallel(formula = Sepal.Length ~ Sepal.Width + Petal.Length + Petal.Width ,
data = iris,
group_by = "Species",
family = gaussian(),
n.cores = 1)
```
+## Extracts a tidy result table from a list tmb object
+
+The tidy_results function extracts a dataframe containing estimates of ln(fold changes), standard errors, test statistics, p-values, and adjusted p-values for fixed effects. Additionally, it provides access to correlation terms and standard deviations for random effects, offering a detailed view of HTRfit modeling results.
+
+
+```{r example-tidyRes, warning = FALSE, message = FALSE}
+## -- get tidy results
+tidy_results(l_tmb_iris, coeff_threshold = 0.1, alternative_hypothesis = "greaterAbs")
+```
+
## Update fit
The `updateParallel()` function updates and re-fits a model for each gene. It offers options similar to those in `fitModelParallel()`.
@@ -330,9 +366,12 @@ l_tmb <- updateParallel(formula = kij ~ varA + varB + varA:varB ,
list_tmb = l_tmb ,
family = glmmTMB::nbinom2(link = "log"),
n.cores = 1)
+```
+
+#### Struture of list tmb object
-## -- output
-l_tmb$gene1
+```{r example-str_obj_l_tmb, warning = FALSE, message = FALSE}
+str(l_tmb$gene1, max.level = 1)
```
## Plot fit metrics
@@ -340,14 +379,14 @@ l_tmb$gene1
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}
+```{r example-plotMetrics, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 8}
## -- plot all metrics
-metrics_plot(list_tmb = l_tmb)
+diagnostic_plot(list_tmb = l_tmb)
```
-```{r example-plotMetricsFocus, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 3, fig.width = 4}
+```{r example-plotMetricsFocus, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 3, fig.width = 8}
## -- Focus on metrics
-metrics_plot(list_tmb = l_tmb, focus = c("dispersion", "logLik"))
+diagnostic_plot(list_tmb = l_tmb, focus = c("dispersion", "logLik"))
```
## Anova to select the best model
@@ -362,52 +401,80 @@ 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.
+In this section, we delve into the evaluation of your simulation results. The `evaluation_report()` 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'}
+```{r example-evaluation_report, 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")
+resSimu <- evaluation_report(list_tmb = l_tmb,
+ dds = NULL,
+ mock_obj = mock_data,
+ coeff_threshold = 0.4,
+ alpha_risk = 0.05,
+ 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.
+The `evaluation_report()` function produces an identity plot, offering a visual tool to juxtapose the simulated effects (actual effects) with the model-inferred effects. This graphical representation simplifies assessing how well the model aligns with the values of the simulated effects, enabling a visual analysis of the model's goodness of fit to the simulated data. For a more quantitative evaluation of inference quality, the R-squared (R2) metric can be employed.
+#### Model parameters
-```{r example-simulationReport_plotID, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 5}
-resSimu$identity_plot
+```{r example-outputIdentity_params, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 5}
+## -- Model params
+resSimu$identity$params
+```
+
+#### Dispersion parameter
+```{r example-outputIdentity_disp, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 5}
+## -- Dispersion params
+resSimu$identity$dispersion
```
-## Dispersion plot
+The dispersion plot, generated by the `evaluation_report()` 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 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.
+## 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_plotDisp, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 5}
-resSimu$dispersionEvaluation$disp_plot
+
+
+```{r example-outputROC, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 7}
+## -- ROC curve
+resSimu$roc$params
```
-## ROC curve
+## Precision-recall 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.
+The precision-recall curve (PR curve) illustrates the relationship between precision and recall at various classification thresholds. It is particularly valuable in the context of imbalanced data, where one class is significantly more prevalent than the other. Unlike the ROC curve, which can be influenced by class distribution, the PR curve focuses on the model's ability to correctly identify examples of the minority class while maintaining high precision.
-```{r example-simulationReport_plotRoc, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 5}
-resSimu$roc_plot
+
+```{r example-outputPR, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 7}
+## -- precision-recall curve
+resSimu$precision_recall$params
+```
+
+## AUC and classification performance metrics
+
+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. In the case of the ROC curve, this AUC should be compared to the value of 0.5, representing a random classifier. On the other hand, for the PR curve, we compute the pr_AUC_random, serving as a baseline for comparison.
+
+
+In addition to evaluating model performance through the AUC for both ROC and PR curves, we provide access to key classification metrics, including Accuracy, Precision, Recall (or Sensitivity), and Specificity. These metrics offer a comprehensive view of the model's classification capabilities. These metrics are computed for each parameter (excluding the intercept when skip_eval_intercept = TRUE), providing detailed insights into individual parameter contributions. Furthermore, an aggregated assessment is performed, considering all parameters (except the intercept by default), offering a perspective on the model's overall classification effectiveness.
+
+
+
+```{r example-outputPerf, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 7}
+## -- precision-recall curve
+resSimu$performances
```
## Compare HTRfit with DESeq2
@@ -415,6 +482,7 @@ resSimu$roc_plot
**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)
@@ -426,20 +494,28 @@ dds <- DESeq2::DESeq(dds, quiet = TRUE)
## -- get simulation/fit evaluation
-resSimu <- simulationReport(mock_data,
- list_tmb = l_tmb,
- dds_obj = dds,
+resSimu <- evaluation_report(list_tmb = l_tmb,
+ dds = dds,
+ mock_obj = mock_data,
coeff_threshold = 0.4,
alt_hypothesis = "greaterAbs")
```
-```{r example-outputResSimu, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 5}
+```{r example-outputResSimu_id, 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
+###### 1) Model params
+resSimu$identity$params
+###### Dispersion params
+resSimu$identity$dispersion
+```
+
+```{r example-outputResSimu_metric, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 7}
+## -- precision-recall curve
+resSimu$precision_recall$params
+## -- ROC curve
+resSimu$roc$params
+## -- Performances metrics
+resSimu$performances
```
## Focus evaluation on a subset of genes
@@ -455,22 +531,60 @@ 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")
+resSimu <- evaluation_report(list_tmb = l_tmb,
+ dds = dds,
+ mock_obj = mock_lowExpressed,
+ coeff_threshold = 0.4,
+ alt_hypothesis = "greaterAbs")
+```
+
+As we compare this evaluation to the previous one, we observe a reduction in performances for both **HTRfit** and **DESeq2** inferences.
+
+
+```{r example-subsetGenes_id, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 5}
+## -- identity plot
+###### 1) Model params
+resSimu$identity$params
+###### Dispersion params
+resSimu$identity$dispersion
```
-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_metrics, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 7}
+## -- precision-recall curve
+resSimu$precision_recall$params
+## -- ROC curve
+resSimu$roc$params
+## -- Performances metrics
+resSimu$performances
+```
+## Modifying your alpha risk
-```{r example-subsetGenes_rocPlot, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 5}
-## -- roc curve
-resSimu$roc_plot
+```{r example-alphaRisk_1, warning = FALSE, message = FALSE}
+## -- get simulation/fit evaluation
+resSimu <- evaluation_report(list_tmb = l_tmb,
+ dds = dds,
+ mock_obj = mock_data,
+ coeff_threshold = 0.4,
+ alpha_risk = 0.05, ## -- default
+ alt_hypothesis = "greaterAbs")
+## -- Performances metrics
+resSimu$performances
```
-# Evaluate model inference involving mixed effects
+```{r example-alphaRiskk_2, warning = FALSE, message = FALSE}
+## -- get simulation/fit evaluation
+resSimu <- evaluation_report(list_tmb = l_tmb,
+ dds = dds,
+ mock_obj = mock_data,
+ coeff_threshold = 0.4,
+ alpha_risk = 0.01,
+ alt_hypothesis = "greaterAbs")
+## -- Performances metrics
+resSimu$performances
+```
+
+## 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.
@@ -482,40 +596,55 @@ input_var_list <- init_variable( name = "varA", mu = 0, sd = 0.29, level = 60) %
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,
+ n_genes = 30, ## small number to prevent excessively lengthy vignette construction
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)
+ normalization = F,
+ response_name = "kij")
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")
+resSimu <- evaluation_report(list_tmb = l_tmb,
+ dds = NULL,
+ mock_obj = mock_data,
+ coeff_threshold = 0.27,
+ alt_hypothesis = "greater")
```
-```{r example-outputResSimuMixed, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 5}
+```{r example-outputResSimuMixed_id, 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
+###### 1) Model params
+resSimu$identity$params
+###### Dispersion params
+resSimu$identity$dispersion
+```
+
+```{r example-outputResSimuMixed_metric, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 7}
+## -- precision-recall curve
+resSimu$precision_recall$params
+## -- ROC curve
+resSimu$roc$params
+## -- Performances metrics
+resSimu$performances
```
-# About mixed model evaluation
+## Structure of evaluation report object
+
+```{r example-str_eval_report, warning = FALSE, message = FALSE}
+str(resSimu, max.level = 1)
+```
+
+## 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.
-**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.