diff --git a/DESCRIPTION b/DESCRIPTION
new file mode 100644
index 0000000000000000000000000000000000000000..4c0fb104665c64ddc9562110cc359bcd0ea663dd
--- /dev/null
+++ b/DESCRIPTION
@@ -0,0 +1,33 @@
+Package: HTRfit
+Title: HTRfit
+Version: 0.0.0.9000
+Authors@R:
+ person("First", "Last", , "first.last@example.com", role = c("aut", "cre"),
+ comment = c(ORCID = "YOUR-ORCID-ID"))
+Description: What the package does (one paragraph).
+License: MIT + file LICENSE
+Imports:
+ car,
+ data.table,
+ ggplot2,
+ glmmTMB,
+ gridExtra,
+ magrittr,
+ MASS,
+ parallel,
+ plotROC,
+ reshape2,
+ rlang,
+ S4Vectors,
+ stats,
+ utils
+Suggests:
+ DESeq2,
+ knitr,
+ rmarkdown,
+ testthat
+VignetteBuilder:
+ knitr
+Encoding: UTF-8
+Roxygen: list(markdown = TRUE)
+RoxygenNote: 7.2.2
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000000000000000000000000000000000000..6e414245412be8738985623c2fd067b1ede41462
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,2 @@
+YEAR: 2023
+COPYRIGHT HOLDER: Arnaud DUVERMY
diff --git a/LICENSE.md b/LICENSE.md
new file mode 100644
index 0000000000000000000000000000000000000000..cbe7af7f376035d7755dc19ac09a4bc796b9d750
--- /dev/null
+++ b/LICENSE.md
@@ -0,0 +1,21 @@
+# MIT License
+
+Copyright (c) 2023 Arnaud DUVERMY
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
diff --git a/NAMESPACE b/NAMESPACE
new file mode 100644
index 0000000000000000000000000000000000000000..b44ed98584e99faffe3f0db66c5d60e2bbbf7766
--- /dev/null
+++ b/NAMESPACE
@@ -0,0 +1,170 @@
+# Generated by roxygen2: do not edit by hand
+
+export("%>%")
+export(.fitModel)
+export(.getColumnWithSampleID)
+export(.isDispersionMatrixValid)
+export(.parallel_fit)
+export(.parallel_update)
+export(.replicateByGroup)
+export(.replicateMatrix)
+export(.replicateRows)
+export(.subsetData_andfit)
+export(addBasalExpression)
+export(add_interaction)
+export(already_init_variable)
+export(anovaParallel)
+export(averageByGroup)
+export(build_missingColumn_with_na)
+export(calculate_actualMixed)
+export(calculate_actual_interactionX2_values)
+export(calculate_actual_interactionX3_values)
+export(check_input2interaction)
+export(clean_variable_name)
+export(compareInferenceToExpected)
+export(computeActualInteractionFixEff)
+export(compute_covariation)
+export(convert2Factor)
+export(correlation_matrix_2df)
+export(countMatrix_2longDtf)
+export(counts_plot)
+export(dispersion_plot)
+export(drop_randfx)
+export(endsWithDigit)
+export(evaluateDispersion)
+export(exportReportFile)
+export(extractDESeqDispersion)
+export(extractTMBDispersion)
+export(extract_fixed_effect)
+export(extract_ran_pars)
+export(fillInCovarMatrice)
+export(fillInInteraction)
+export(fillInVariable)
+export(filter_dataframe)
+export(findAttribute)
+export(fitModelParallel)
+export(fitUpdate)
+export(generateActualForMainFixEff)
+export(generateActualInteractionX2_FixEff)
+export(generateActualInteractionX3_FixEff)
+export(generateCountTable)
+export(generateGridCombination_fromListVar)
+export(generateReplicationMatrix)
+export(generate_BE)
+export(getActualInteractionFixEff)
+export(getActualIntercept)
+export(getActualMainFixEff)
+export(getActualMixed_typeI)
+export(getBinExpression)
+export(getCategoricalVar_inFixedEffect)
+export(getCoefficients)
+export(getCovarianceMatrix)
+export(getData2computeActualFixEffect)
+export(getDataFromMvrnorm)
+export(getDataFromUser)
+export(getDispersionComparison)
+export(getDispersionMatrix)
+export(getEstimate_df)
+export(getGeneMetadata)
+export(getGlance)
+export(getGridCombination)
+export(getGrobTable)
+export(getInput2mvrnorm)
+export(getInput2simulation)
+export(getLabelExpected)
+export(getLog_qij)
+export(getMu_ij)
+export(getMu_ij_matrix)
+export(getNumberOfCombinationsInInteraction)
+export(getReplicationMatrix)
+export(getSE_df)
+export(getSampleID)
+export(getSampleMetadata)
+export(getSettingsTable)
+export(getStandardDeviationInCorrelation)
+export(getTidyGlmmTMB)
+export(getValidDispersion)
+export(get_inference)
+export(glance_tmb)
+export(group_logQij_per_genes_and_labels)
+export(handleAnovaError)
+export(identity_plot)
+export(inferenceToExpected_withFixedEff)
+export(inferenceToExpected_withMixedEff)
+export(init_variable)
+export(inputs_checking)
+export(isValidInput2fit)
+export(is_formula_mixedTypeI)
+export(is_fullrank)
+export(is_mixedEffect_inFormula)
+export(is_positive_definite)
+export(join_dtf)
+export(launchFit)
+export(launchUpdate)
+export(medianRatioNormalization)
+export(metrics_plot)
+export(mock_rnaseq)
+export(prepareData2computeInteraction)
+export(prepareData2fit)
+export(removeDigitsAtEnd)
+export(removeDuplicatedWord)
+export(renameColumns)
+export(reorderColumns)
+export(roc_plot)
+export(samplingFromMvrnorm)
+export(scaleCountsTable)
+export(set_correlation)
+export(simulationReport)
+export(subsetByTermLabel)
+export(subsetFixEffectInferred)
+export(subsetGenes)
+export(subset_glance)
+export(tidy_results)
+export(tidy_tmb)
+export(updateParallel)
+export(wald_test)
+export(wrapper_DESeq2)
+export(wrapper_var_cor)
+importFrom(car,Anova)
+importFrom(data.table,data.table)
+importFrom(data.table,setDT)
+importFrom(data.table,setorderv)
+importFrom(data.table,tstrsplit)
+importFrom(ggplot2,aes)
+importFrom(ggplot2,element_blank)
+importFrom(ggplot2,facet_wrap)
+importFrom(ggplot2,geom_abline)
+importFrom(ggplot2,geom_density)
+importFrom(ggplot2,geom_point)
+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(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(stats,anova)
+importFrom(stats,as.formula)
+importFrom(stats,cor)
+importFrom(stats,median)
+importFrom(stats,model.matrix)
+importFrom(stats,p.adjust)
+importFrom(stats,pnorm)
+importFrom(stats,rnbinom)
+importFrom(stats,sd)
+importFrom(stats,setNames)
+importFrom(stats,terms)
+importFrom(stats,update)
+importFrom(utils,tail)
diff --git a/R/actualinteractionfixeffects.R b/R/actualinteractionfixeffects.R
new file mode 100644
index 0000000000000000000000000000000000000000..81ce0a05f4c030a4e4ab3a654c6bd03b2fb3fe5e
--- /dev/null
+++ b/R/actualinteractionfixeffects.R
@@ -0,0 +1,330 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+#' Filter DataFrame
+#'
+#' Filter a DataFrame based on the specified filter list.
+#'
+#' @param df The DataFrame to be filtered
+#' @param filter_list A list specifying the filters to be applied
+#' @return The filtered DataFrame
+#' @export
+#'
+#' @examples
+#' # Create a DataFrame
+#' df <- data.frame(ID = c(1, 2, 3, 4),
+#' Name = c("John", "Jane", "Mike", "Sarah"),
+#' Age = c(25, 30, 28, 32),
+#' Gender = c("Male", "Female", "Male", "Female"))
+#'
+#' # Create a filter list
+#' filter_list <- list(Name = c("John", "Mike"), Age = c(25, 28))
+#'
+#' # Filter the DataFrame
+#' filter_dataframe(df, filter_list)
+filter_dataframe <- function(df, filter_list ) {
+ filtered_df <- df
+
+ for (attr_name in attributes(filter_list)$names) {
+ attr_value <- filter_list[[attr_name]]
+
+ filtered_df <- filtered_df[filtered_df[[attr_name]] %in% attr_value, ]
+ }
+
+ return(filtered_df)
+}
+
+
+#' Calculate actual interaction values between two terms in a data frame.
+#'
+#' This function calculates the actual interaction values between two terms, \code{lbl_term_1} and \code{lbl_term_2},
+#' in the given data frame \code{data}. The interaction values are computed based on the mean log expression levels
+#' of the conditions satisfying the specified term combinations, and also considering a reference condition.
+#'
+#' @param data A data frame containing the expression data and associated terms.
+#' @param l_reference A data frame representing the reference condition for the interaction.
+#' @param clmn_term_1 The name of the column in \code{data} representing the first term.
+#' @param lbl_term_1 The label of the first term to compute interactions for.
+#' @param clmn_term_2 The name of the column in \code{data} representing the second term.
+#' @param lbl_term_2 The label of the second term to compute interactions for.
+#'
+#' @return A numeric vector containing the actual interaction values between the specified terms.
+#' @export
+#' @examples
+#' average_gt <- data.frame(clmn_term_1 = c("A", "A", "B", "B"),
+#' clmn_term_2 = c("X", "Y", "Y", "X"),
+#' logQij_mean = c(1.5, 8.0, 0.5, 4.0))
+#' # Définir les paramètres de la fonction
+#' l_label <- list(clmn_term_1 = c("A", "B"), clmn_term_2 = c("X", "Y"))
+#' clmn_term_1 <- "clmn_term_1"
+#' lbl_term_1 <- "B"
+#' clmn_term_2 <- "clmn_term_2"
+#' lbl_term_2 <- "Y"
+#' # Calculer la valeur d'interaction réelle
+#' actual_interaction <- calculate_actual_interactionX2_values(average_gt,
+#' l_label, clmn_term_1, lbl_term_1,
+#' clmn_term_2, lbl_term_2)
+calculate_actual_interactionX2_values <- function(data, l_reference , clmn_term_1, lbl_term_1, clmn_term_2, lbl_term_2) {
+ A <- data[data[[clmn_term_1]] == lbl_term_1 &
+ data[[clmn_term_2]] == lbl_term_2, ]
+ B <- data[data[[clmn_term_1]] == lbl_term_1 &
+ data[[clmn_term_2]] == l_reference[[clmn_term_2]][1], ]
+ C <- data[data[[clmn_term_1]] == l_reference[[clmn_term_1]][1] &
+ data[[clmn_term_2]] == lbl_term_2, ]
+ D <- data[data[[clmn_term_1]] == l_reference[[clmn_term_1]][1] &
+ data[[clmn_term_2]] == l_reference[[clmn_term_2]][1], ]
+ actual_interaction <- (A$logQij_mean - B$logQij_mean) - (C$logQij_mean - D$logQij_mean)
+ return(actual_interaction)
+}
+
+
+#' Prepare data for computing interaction values.
+#'
+#' This function prepares the data for computing interaction values between variables.
+#' It filters the \code{dataActual} data frame by selecting only the rows where the categorical variables
+#' specified in \code{categorical_vars} are at their reference levels.
+#'
+#' @param categorical_vars A character vector containing the names of categorical variables.
+#' @param categorical_varsInInteraction A character vector containing the names of categorical variables involved in interactions.
+#' @param dataActual A data frame containing the actual data with categorical variables and associated expression levels.
+#'
+#' @return A data frame containing the filtered data for computing interaction values.
+#' @export
+prepareData2computeInteraction <- function(categorical_vars, categorical_varsInInteraction, dataActual){
+ l_RefInCategoricalVars <- lapply(dataActual[, categorical_vars], function(vector) levels(vector)[1])
+ l_categoricalVars_NOT_InInteraction <- categorical_vars[! categorical_vars %in% categorical_varsInInteraction ]
+ l_filter <- l_RefInCategoricalVars[l_categoricalVars_NOT_InInteraction]
+ dataActual_2computeInteractionValues <- filter_dataframe(dataActual, l_filter)
+ return(dataActual_2computeInteractionValues)
+}
+
+
+
+#' Generate actual values for the interaction fixed effect.
+#'
+#' This function calculates the actual values for the interaction fixed effect
+#' based on the input labels in the interaction, categorical variables in the interaction,
+#' data to compute interaction values, actual intercept, and the reference levels in
+#' categorical variables.
+#'
+#' @param labelsInInteraction A vector containing the labels of the interaction terms.
+#' @param l_categoricalVarsInInteraction A vector containing the names of categorical variables
+#' involved in the interaction.
+#' @param data2computeInteraction The data frame used to compute interaction values.
+#' @param l_RefInCategoricalVars A list containing the reference levels of categorical variables.
+#'
+#' @return A data frame with the actual values for the interaction fixed effect.
+#' The data frame includes columns: term, actual, and description.
+#'
+#' @export
+generateActualInteractionX2_FixEff <- function(labelsInInteraction, l_categoricalVarsInInteraction,
+ data2computeInteraction, l_RefInCategoricalVars ){
+ clmn_term_1 <- l_categoricalVarsInInteraction[1]
+ lbl_term_1 <- labelsInInteraction[1]
+ clmn_term_2 <- l_categoricalVarsInInteraction[2]
+ lbl_term_2 <- labelsInInteraction[2]
+ interactionValues <- calculate_actual_interactionX2_values(data2computeInteraction,
+ l_RefInCategoricalVars, clmn_term_1,
+ lbl_term_1, clmn_term_2, lbl_term_2)
+
+
+ df_actualForMyInteraction <- data.frame(geneID = unique(data2computeInteraction$geneID))
+ df_actualForMyInteraction$term <- paste(labelsInInteraction, collapse = ":")
+ df_actualForMyInteraction$actual <- interactionValues
+ df_actualForMyInteraction$description <- paste(gsub("\\d+$", "", lbl_term_1) ,
+ gsub("\\d+$", "", lbl_term_2), sep = ":")
+
+ return(df_actualForMyInteraction)
+
+}
+
+
+#' Generate Actual Interaction Values for Three Fixed Effects
+#'
+#' This function generates actual interaction values for three fixed effects in a dataset. It takes the labels of the three fixed effects, the dataset, and the reference values for the categorical variables. The function computes the actual interaction values and returns a data frame containing the geneID, the term description, and the actual interaction values.
+#'
+#' @param labelsInInteraction A character vector of labels for the three fixed effects.
+#' @param l_categoricalVarsInInteraction A list of categorical variable names corresponding to the three fixed effects.
+#' @param data2computeInteraction The dataset on which to compute the interaction values.
+#' @param l_RefInCategoricalVars A list of reference values for the categorical variables.
+#'
+#' @return A data frame with geneID, term description, and actual interaction values.
+#'
+#' @export
+generateActualInteractionX3_FixEff <- function(labelsInInteraction, l_categoricalVarsInInteraction,
+ data2computeInteraction, l_RefInCategoricalVars) {
+
+ clmn_term_1 <- l_categoricalVarsInInteraction[1]
+ lbl_term_1 <- labelsInInteraction[1]
+ clmn_term_2 <- l_categoricalVarsInInteraction[2]
+ lbl_term_2 <- labelsInInteraction[2]
+ clmn_term_3 <- l_categoricalVarsInInteraction[3]
+ lbl_term_3 <- labelsInInteraction[3]
+ interactionValues <- calculate_actual_interactionX3_values(data2computeInteraction,
+ l_RefInCategoricalVars, clmn_term_1,
+ lbl_term_1, clmn_term_2, lbl_term_2, lbl_term_3, clmn_term_3)
+
+
+ df_actualForMyInteraction <- data.frame(geneID = unique(data2computeInteraction$geneID))
+ df_actualForMyInteraction$term <- paste(labelsInInteraction, collapse = ":")
+ df_actualForMyInteraction$actual <- interactionValues
+ df_actualForMyInteraction$description <- paste(gsub("\\d+$", "", lbl_term_1) ,
+ gsub("\\d+$", "", lbl_term_2),
+ gsub("\\d+$", "", lbl_term_3), sep = ":")
+
+ return(df_actualForMyInteraction)
+
+}
+
+
+#' Calculate Actual Interaction Values for Three Fixed Effects
+#'
+#' This function calculates actual interaction values for three fixed effects in a dataset. It takes the data, reference values for categorical variables, and the specifications for the fixed effects. The function computes the interaction values and returns the result.
+#'
+#' @param data The dataset on which to calculate interaction values.
+#' @param l_reference A list of reference values for categorical variables.
+#' @param clmn_term_1 The name of the first categorical variable.
+#' @param lbl_term_1 The label for the first categorical variable.
+#' @param clmn_term_2 The name of the second categorical variable.
+#' @param lbl_term_2 The label for the second categorical variable.
+#' @param lbl_term_3 The label for the third categorical variable.
+#' @param clmn_term_3 The name of the third categorical variable.
+#'
+#' @return The computed actual interaction values.
+#'
+#' @export
+calculate_actual_interactionX3_values <- function(data, l_reference, clmn_term_1, lbl_term_1,
+ clmn_term_2, lbl_term_2, lbl_term_3, clmn_term_3) {
+ ## Label term 3
+ A <- data[data[[clmn_term_1]] == lbl_term_1 &
+ data[[clmn_term_2]] == lbl_term_2 &
+ data[[clmn_term_3]] == lbl_term_3, ]
+
+ B <- data[data[[clmn_term_1]] == l_reference[[clmn_term_1]][1] &
+ data[[clmn_term_2]] == lbl_term_2 &
+ data[[clmn_term_3]] == lbl_term_3 , ]
+
+ C <- data[data[[clmn_term_1]] == lbl_term_1 &
+ data[[clmn_term_2]] == l_reference[[clmn_term_2]][1] &
+ data[[clmn_term_3]] == lbl_term_3, ]
+
+ D <- data[data[[clmn_term_1]] == l_reference[[clmn_term_1]][1] &
+ data[[clmn_term_2]] == l_reference[[clmn_term_2]][1] &
+ data[[clmn_term_3]] == lbl_term_3, ]
+
+ termA = (A$logQij_mean-B$logQij_mean) - (C$logQij_mean - D$logQij_mean)
+
+ ## Label term 3 == reference !
+ A <- data[data[[clmn_term_1]] == lbl_term_1 &
+ data[[clmn_term_2]] == lbl_term_2 &
+ data[[clmn_term_3]] == l_reference[[clmn_term_3]][1], ]
+
+ B <- data[data[[clmn_term_1]] == l_reference[[clmn_term_1]][1] &
+ data[[clmn_term_2]] == lbl_term_2 &
+ data[[clmn_term_3]] == l_reference[[clmn_term_3]][1] , ]
+
+ C <- data[data[[clmn_term_1]] == lbl_term_1 &
+ data[[clmn_term_2]] == l_reference[[clmn_term_2]][1] &
+ data[[clmn_term_3]] == l_reference[[clmn_term_3]][1], ]
+
+ D <- data[data[[clmn_term_1]] == l_reference[[clmn_term_1]][1] &
+ data[[clmn_term_2]] == l_reference[[clmn_term_2]][1] &
+ data[[clmn_term_3]] == l_reference[[clmn_term_3]][1], ]
+
+ termB = (A$logQij_mean-B$logQij_mean) - (C$logQij_mean - D$logQij_mean)
+ actual_interaction <- termA - termB
+ return(actual_interaction)
+}
+
+
+
+#' Get the actual interaction values for a given interaction term in the data.
+#'
+#' This function takes an interaction term, the dataset, and the names of the categorical variables
+#' as inputs. It calculates the actual interaction values based on the difference in log-transformed
+#' mean expression levels for the specified interaction term. The function first prepares the data for
+#' computing the interaction values and then generates the actual interaction values.
+#'
+#' @param labelsInInteraction A character vector containing the labels of the categorical levels
+#' involved in the interaction.
+#' @param data The dataset containing the gene expression data and categorical variables.
+#' @param categorical_vars A character vector containing the names of the categorical variables in
+#' the dataset.
+#' @return A data frame containing the actual interaction values.
+#' @export
+getActualInteractionFixEff <- function(labelsInInteraction, data, categorical_vars ){
+ l_RefInCategoricalVars <- lapply(data[, categorical_vars], function(vector) levels(vector)[1])
+ l_labelsInCategoricalVars <- lapply(data[, categorical_vars], levels)
+ l_categoricalVarsInInteraction <- lapply(labelsInInteraction,
+ function(label) findAttribute(label,
+ l_labelsInCategoricalVars)) %>%
+ unlist()
+ data2computeInteraction <- prepareData2computeInteraction(categorical_vars, l_categoricalVarsInInteraction, data )
+
+ ## Interaction x3
+ if (length(labelsInInteraction) == 3){
+ actualInteractionValues <- generateActualInteractionX3_FixEff(labelsInInteraction,
+ l_categoricalVarsInInteraction ,
+ data2computeInteraction,
+ l_RefInCategoricalVars)
+ }
+ # Interaction x2
+ if (length(labelsInInteraction) == 2){
+ actualInteractionValues <- generateActualInteractionX2_FixEff(labelsInInteraction,
+ l_categoricalVarsInInteraction ,
+ data2computeInteraction,
+ l_RefInCategoricalVars)
+ }
+ return(actualInteractionValues)
+}
+
+
+#' Compute actual interaction values for multiple interaction terms.
+#'
+#' This function calculates the actual interaction values for multiple interaction terms
+#' using the provided data.
+#'
+#' @param l_interactionTerm A list of interaction terms in the form of "term1:term2".
+#' @param categorical_vars A character vector containing the names of categorical variables in the data.
+#' @param dataActual The data frame containing the actual gene expression values and metadata.
+#'
+#' @return A data frame containing the actual interaction values for each interaction term.
+#' @export
+#' @examples
+#' N_GENES <- 4
+#' MIN_REPLICATES <- 3
+#' MAX_REPLICATES <- 3
+#' init_var <- init_variable(name = "varA", mu = 8, sd = 0.1, level = 3) %>%
+#' init_variable(name = "varB", mu = c(5,-5), NA , level = 2) %>%
+#' init_variable(name = "varC", mu = 1, 3, 3) %>%
+#' add_interaction(between_var = c("varA", "varC"), mu = 5, 0.1)
+#' mock_data <- mock_rnaseq(init_var, N_GENES,
+#' MIN_REPLICATES, MAX_REPLICATES )
+#' data2fit <- prepareData2fit(countMatrix = mock_data$counts,
+#' metadata = mock_data$metadata )
+#' results_fit <- fitModelParallel(formula = kij ~ varA + varB + varC + varA:varC,
+#' data = data2fit, group_by = "geneID",
+#' family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
+#' tidy_tmb <- tidy_tmb(results_fit)
+#' fixEff_dataInference <- subsetFixEffectInferred(tidy_tmb)
+#' fixEff_dataActual <- getData2computeActualFixEffect(mock_data$groundTruth$effects)
+#' interactionTerm <- fixEff_dataInference$fixed_term$interaction[[1]]
+#' categorical_vars <- fixEff_dataActual$categorical_vars
+#' dataActual <- fixEff_dataActual$data
+#' l_labelsInCategoricalVars <- lapply(dataActual[, categorical_vars], levels)
+#' l_interaction <- strsplit(interactionTerm, split = ":")[[1]]
+#' l_categoricalVarsInInteraction <- lapply(l_interaction,
+#' function(label) findAttribute(label,
+#' l_labelsInCategoricalVars)) %>%
+#' unlist()
+#' data_prepared <- prepareData2computeInteraction(categorical_vars,
+#' l_categoricalVarsInInteraction, dataActual)
+#' # Compute actual interaction values for multiple interactions
+#' actualInteraction <- computeActualInteractionFixEff(interactionTerm, categorical_vars, dataActual)
+computeActualInteractionFixEff <- function(l_interactionTerm, categorical_vars, dataActual){
+
+ l_interaction <- strsplit(l_interactionTerm, split = ":")
+ l_interactionActualValues <- lapply(l_interaction, function(labelsInInteraction)
+ getActualInteractionFixEff(labelsInInteraction, dataActual, categorical_vars))
+ actualInteraction_df <- do.call('rbind', l_interactionActualValues)
+ return(actualInteraction_df)
+}
diff --git a/R/actualmainfixeffects.R b/R/actualmainfixeffects.R
new file mode 100644
index 0000000000000000000000000000000000000000..09ecd4a593403f7d5d067a8654ba1b99d771dca3
--- /dev/null
+++ b/R/actualmainfixeffects.R
@@ -0,0 +1,246 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+#' Calculate average values by group
+#'
+#' @param data The input data frame
+#' @param column The name of the target variable
+#' @param group_by The names of the grouping variables
+#' @importFrom data.table setDT tstrsplit
+#' @importFrom rlang :=
+#' @return A data frame with average values calculated by group
+#' @export
+averageByGroup <- function(data, column, group_by) {
+ group_values <- split(data[[column]], data[group_by])
+ mean_values <- sapply(group_values, mean)
+ result <- data.frame(Group = names(mean_values), logQij_mean = mean_values)
+ data.table::setDT(result)[, {{ group_by }} := data.table::tstrsplit(Group, "[.]")]
+ result <- subset(as.data.frame(result), select = -Group)
+ return(result)
+}
+
+#' Convert specified columns to factor
+#'
+#' @param data The input data frame
+#' @param columns The column names to be converted to factors
+#' @return The modified data frame with specified columns converted to factors
+#' @export
+convert2Factor <- function(data, columns) {
+ if (is.character(columns)) {
+ columns <- match(columns, colnames(data))
+ }
+
+ if (length(columns) > 1) data[, columns] <- lapply(data[, columns], as.factor )
+ else data[, columns] <- as.factor(data[, columns])
+ return(data)
+}
+
+#' Subset Fixed Effect Inferred Terms
+#'
+#' This function subsets the tidy TMB object to extract the fixed effect inferred terms
+#' along with their categorization into interaction and non-interaction terms.
+#'
+#' @param tidy_tmb The tidy TMB object containing the inferred terms.
+#'
+#' @return A list with two elements:
+#' \describe{
+#' \item{fixed_term}{A list with two components - \code{nonInteraction} and \code{interaction},
+#' containing the names of the fixed effect inferred terms categorized as non-interaction and interaction terms, respectively.}
+#' \item{data}{A data frame containing the subset of tidy_tmb that contains the fixed effect inferred terms.}
+#' }
+#' @export
+#' @examples
+#' input_var_list <- init_variable()
+#' mock_data <- mock_rnaseq(input_var_list, 10, 2, 2)
+#' getData2computeActualFixEffect(mock_data$groundTruth$effect)
+#' data2fit = prepareData2fit(countMatrix = mock_data$counts, metadata = mock_data$metadata )
+#' #-- fit data
+#' resFit <- fitModelParallel(formula = kij ~ myVariable ,
+#' data = data2fit, group_by = "geneID",
+#' family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
+#' tidy_tmb <- tidy_tmb(resFit)
+#' subsetFixEffectInferred(tidy_tmb)
+subsetFixEffectInferred <- function(tidy_tmb){
+ fixed_tidy <- tidy_tmb[tidy_tmb$effect == "fixed",]
+ l_term <- unique(fixed_tidy$term)
+ l_term <- l_term[!l_term %in% c("(Intercept)", NA)]
+ index_interaction <- grepl(x = l_term, ":")
+ l_term_nonInteraction <- l_term[!index_interaction]
+ l_term_interaction <- l_term[index_interaction]
+ l_term2ret <- list(nonInteraction = l_term_nonInteraction, interaction = l_term_interaction )
+ return(list(fixed_term = l_term2ret, data = fixed_tidy))
+}
+
+
+#' Get data for calculating actual values
+#'
+#' @param groundTruth The ground truth data frame
+#' @return A list containing required data for calculating actual values
+#' @export
+#' @examples
+#' input_var_list <- init_variable()
+#' mock_data <- mock_rnaseq(input_var_list, 10, 2, 2)
+#' getData2computeActualFixEffect(mock_data$groundTruth$effect)
+getData2computeActualFixEffect <- function(groundTruth){
+ col_names <- colnames(groundTruth)
+ categorical_vars <- col_names[grepl(col_names, pattern = "label_")]
+ average_gt <- averageByGroup(groundTruth, "log_qij_scaled", c("geneID", categorical_vars))
+ average_gt <- convert2Factor(data = average_gt, columns = categorical_vars )
+ return(list(categorical_vars = categorical_vars, data = average_gt))
+}
+
+
+#' Get the intercept dataframe
+#'
+#' @param fixeEff_dataActual The input list containing the categorical variables and the data
+#' @return The intercept dataframe
+#' @export
+getActualIntercept <- function(fixeEff_dataActual) {
+ ## -- split list
+ data<- fixeEff_dataActual$data
+ categorical_vars <- fixeEff_dataActual$categorical_vars
+
+ if (length(categorical_vars) == 1){
+ l_labels <- list()
+ l_labels[[categorical_vars]] <- levels(data[, categorical_vars])
+
+ } else l_labels <- lapply(data[, categorical_vars], levels)
+ index_ref <- sapply(categorical_vars, function(var) data[[var]] == l_labels[[var]][1])
+ index_ref <- rowSums(index_ref) == dim(index_ref)[2]
+ df_intercept <- data[index_ref, ]
+ df_intercept$term <- "(Intercept)"
+ colnames(df_intercept)[colnames(df_intercept) == "logQij_mean"] <- "actual"
+ df_intercept$description <- "(Intercept)"
+
+ index2keep <- !colnames(df_intercept) %in% categorical_vars
+ df_intercept <- df_intercept[,index2keep]
+
+ return(df_intercept)
+}
+
+
+#' Generate actual values for a given term
+#'
+#' @param term The term for which actual values are calculated
+#' @param df_actualIntercept The intercept dataframe
+#' @param dataActual The average ground truth dataframe
+#' @param categorical_vars The names of the categorical variables
+#' @return The data frame with actual values for the given term
+#' @export
+generateActualForMainFixEff <- function(term , df_actualIntercept , dataActual , categorical_vars){
+
+ computeActualValueForMainFixEff <- function(df_actualIntercept, df_term) {
+ df_term$actual <- df_term$logQij_mean - df_actualIntercept$actual
+ return(subset(df_term, select = -c(logQij_mean)))
+ }
+
+ df_term <- subsetByTermLabel(dataActual, categorical_vars , term )
+ df_term <- computeActualValueForMainFixEff(df_actualIntercept, df_term)
+ df_term$description <- gsub("\\d+$", "", term)
+ return(df_term)
+}
+
+
+
+#' subset data By Term Label
+#'
+#'
+#' Get a subset of the data based on a specific term label in the categorical variables.
+#'
+#' @param data The data frame to subset
+#' @param categorical_vars The categorical variables to consider
+#' @param term_label The term label to search for
+#' @return A subset of the data frame containing rows where the categorical variables match the specified term label
+#' @export
+#'
+#' @examples
+#' # Create a data frame
+#' my_data <- data.frame(color = c("red", "blue", "green", "red"),
+#' size = c("small", "medium", "large", "medium"),
+#' shape = c("circle", "square", "triangle", "circle"))
+#' my_data[] <- lapply(my_data, as.factor)
+#'
+#' # Get the subset for the term "medium" in the "size" variable
+#' subsetByTermLabel(my_data, "size", "medium")
+#' # Output: A data frame with rows where "size" is "medium"
+#'
+#' # Get the subset for the term "red" in the "color" variable
+#' subsetByTermLabel(my_data, "color", "red")
+#' # Output: A data frame with rows where "color" is "red"
+subsetByTermLabel <- function(data, categorical_vars, term_label ) {
+ if (length(categorical_vars) == 1) {
+ l_labels <- list()
+ l_labels[[categorical_vars]] <- levels(data[, categorical_vars])
+ } else {
+ l_labels <- lapply(data[, categorical_vars], levels)
+ }
+
+ term_variable <- findAttribute(term_label, l_labels)
+ if(is.null(term_variable)) stop("term_label not in 'data'")
+
+ index_ref <- sapply(categorical_vars, function(var) {
+ if (var == term_variable) {
+ data[[var]] == term_label
+ } else {
+ data[[var]] == l_labels[[var]][1]
+ }
+ })
+
+ index_ref <- rowSums(index_ref) == dim(index_ref)[2]
+ df_term <- data[index_ref, ]
+ df_term$term <- term_label
+ return(df_term)
+}
+
+#' Find Attribute
+#'
+#' Find the attribute containing the specified term in a given list.
+#'
+#' @param term The term to search for
+#' @param list The list to search within
+#' @return The attribute containing the term, or NULL if the term is not found in any attribute
+#' @export
+#'
+#' @examples
+#' # Create a list
+#' my_list <- list(color = c("red", "blue", "green"),
+#' size = c("small", "medium", "large"),
+#' shape = c("circle", "square", "triangle"))
+#'
+#' # Find the attribute containing "medium"
+#' findAttribute("medium", my_list)
+findAttribute <- function(term, list) {
+ for (attr in names(list)) {
+ if (term %in% list[[attr]]) {
+ return(attr)
+ }
+ }
+ return(NULL) # If the term is not found in any attribute
+}
+
+#' Get actual values for non-interaction terms
+#'
+#' @param l_term list of term to compute
+#' @param fixeEff_dataActual A list containing required data for calculating actual values
+#' @param df_actualIntercept The data frame containing the actual intercept values
+#' @return A data frame with actual values for non-interaction terms
+#' @export
+getActualMainFixEff <- function( l_term , fixeEff_dataActual , df_actualIntercept ){
+ ## -- split list
+ categorical_vars <- fixeEff_dataActual$categorical_vars
+ data_groundTruth <- fixeEff_dataActual$data
+ ## -- iteration over term
+ l_actual <- lapply(l_term,
+ function(term){
+ generateActualForMainFixEff(term, df_actualIntercept,
+ data_groundTruth, categorical_vars)})
+ df_actual <- do.call("rbind", l_actual)
+ index2keep <- !colnames(df_actual) %in% categorical_vars
+ df_actual <- df_actual[,index2keep]
+ return(df_actual)
+}
+
+
+
+
+
diff --git a/R/anova.R b/R/anova.R
new file mode 100644
index 0000000000000000000000000000000000000000..ce7c023ae3e36331d1fe7e72647183656d0056fe
--- /dev/null
+++ b/R/anova.R
@@ -0,0 +1,64 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+#' Handle ANOVA Errors
+#'
+#' This function handles ANOVA errors and warnings during the ANOVA calculation process.
+#'
+#' @param l_TMB A list of fitted glmmTMB models.
+#' @param group A character string indicating the group for which ANOVA is calculated.
+#' @param ... Additional arguments to be passed to the \code{car::Anova} function.
+#'
+#' @return A data frame containing ANOVA results for the specified group.
+#' @export
+#'
+#' @examples
+#' l_tmb <- fitModelParallel(Sepal.Length ~ Sepal.Width + Petal.Length,
+#' data = iris, group_by = "Species", n.cores = 1)
+#' anova_res <- handleAnovaError(l_tmb, "setosa", type = "III")
+#'
+#' @importFrom car Anova
+#' @export
+handleAnovaError <- function(l_TMB, group, ...) {
+ tryCatch(
+ expr = {
+ withCallingHandlers(
+ car::Anova(l_TMB[[group]], ...),
+ warning = function(w) {
+ message(paste(Sys.time(), "warning for group", group, ":", conditionMessage(w)))
+ invokeRestart("muffleWarning")
+ })
+ },
+ error = function(e) {
+ message(paste(Sys.time(), "error for group", group, ":", conditionMessage(e)))
+ NULL
+ }
+ )
+}
+
+
+#' Perform ANOVA on Multiple glmmTMB Models in Parallel
+#'
+#' This function performs analysis of variance (ANOVA) on a list of \code{glmmTMB}
+#' models in parallel for different groups specified in the list. It returns a list
+#' of ANOVA results for each group.
+#'
+#' @param l_tmb A list of \code{glmmTMB} models, with model names corresponding to the groups.
+#' @param ... Additional arguments passed to \code{\link[stats]{anova}} function.
+#'
+#' @return A list of ANOVA results for each group.
+#' @importFrom stats setNames
+#' @examples
+#' # Perform ANOVA
+#' data(iris)
+#' l_tmb<- fitModelParallel( Sepal.Length ~ Sepal.Width + Petal.Length,
+#' data = iris, group_by = "Species", n.cores = 1 )
+#' anov_res <- anovaParallel(l_tmb , type = "III")
+#' @importFrom stats anova
+#' @export
+anovaParallel <- function(l_tmb, ...) {
+ l_group <- attributes(l_tmb)$names
+ lapply(stats::setNames(l_group, l_group), function(group) handleAnovaError(l_tmb, group, ...))
+}
+
+
diff --git a/R/countsplot.R b/R/countsplot.R
new file mode 100644
index 0000000000000000000000000000000000000000..d61a6effa691dcbca0ac20cce11f4923b92ea0d6
--- /dev/null
+++ b/R/countsplot.R
@@ -0,0 +1,32 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+#' Generate a density plot of gene counts
+#'
+#' This function generates a density plot of gene counts from mock data.
+#'
+#' @param mock_obj The mock data object containing gene counts.
+#'
+#' @return A ggplot2 density plot.
+#'
+#' @importFrom ggplot2 aes geom_density theme_bw ggtitle scale_x_log10 element_blank
+#' @export
+#'
+#' @examples
+#' mock_data <- list(counts = matrix(c(1, 2, 3, 4, 5, 6, 7, 8, 9), ncol = 3))
+#' counts_plot(mock_data)
+counts_plot <- function(mock_obj){
+
+ counts <- unname(unlist(mock_obj$counts))
+ p <- ggplot2::ggplot() +
+ ggplot2::aes(x = "Genes", y = counts) +
+ ggplot2::geom_point(position = "jitter", alpha = 0.6, size = 0.4, col = "#F0B27A") +
+ ggplot2::geom_violin(fill = "#F8F9F9", alpha = 0.4) +
+ ggplot2::stat_summary(fun = "mean", geom = "point", color = "#B63A0F", size = 5) +
+ ggplot2::theme_bw() +
+ ggplot2::ggtitle("Gene expression plot") +
+ ggplot2::theme(axis.title.x = ggplot2::element_blank())
+ return(p)
+}
+
+
diff --git a/R/datafrommvrnorm_manipulations.R b/R/datafrommvrnorm_manipulations.R
new file mode 100644
index 0000000000000000000000000000000000000000..5b9ae564f0c33c43f7380f911e86d7dd03df570a
--- /dev/null
+++ b/R/datafrommvrnorm_manipulations.R
@@ -0,0 +1,204 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+#' getInput2mvrnorm
+#'
+#' @inheritParams init_variable
+#'
+#' @return
+#' a list that can be used as input for MASS::mvrnorm
+#' @export
+#'
+#' @examples
+#' list_var <- init_variable(name = "my_var", mu = 0, sd = 2, level = 3)
+#' getInput2mvrnorm(list_var)
+getInput2mvrnorm <- function(list_var){
+ # -- pick up sd provided by user
+ variable_standard_dev <- getGivenAttribute(list_var, attribute = "sd") %>% unlist()
+ interaction_standard_dev <- getGivenAttribute(list_var$interactions, attribute = "sd") %>% unlist()
+ list_stdev_2covmatx <- c(variable_standard_dev, interaction_standard_dev)
+ if (is.null(list_stdev_2covmatx)) ## NO SD provided
+ return(list(mu = NULL, covMatrix = NULL))
+
+ # - COV matrix
+ covar_userProvided = getGivenAttribute(list_var$correlations, "covar")
+ covMatrix <- getCovarianceMatrix(list_stdev_2covmatx, covar_userProvided)
+
+ # -- MU
+ variable_mu <- getGivenAttribute(list_var, attribute = "mu") %>% unlist()
+ interaction_mu <- getGivenAttribute(list_var$interactions, attribute = "mu") %>% unlist()
+ list_mu <- c(variable_mu, interaction_mu)
+
+ return(list(mu = list_mu, covMatrix = covMatrix))
+
+}
+
+
+#' getCovarianceMatrix
+#' @param list_stdev standard deviation list
+#' @param list_covar covariance list
+#'
+#' @return
+#' covariance matrix
+#' @export
+#'
+#' @examples
+#' vector_sd <- c(1,2, 3)
+#' names(vector_sd) <- c("varA", "varB", "varC")
+#' vector_covar <- c(8, 12, 24)
+#' names(vector_covar) <- c("varA.varB", "varA.varC", "varB.varC")
+#' covMatrix <- getCovarianceMatrix(vector_sd, vector_covar)
+getCovarianceMatrix <- function(list_stdev, list_covar){
+ # -- cov(A, A) = sd(A)^2
+ diag_cov <- list_stdev^2
+ dimension <- length(diag_cov)
+ covariance_matrix <- matrix(0,nrow = dimension, ncol = dimension)
+ diag(covariance_matrix) <- diag_cov
+ colnames(covariance_matrix) <- paste("label", names(diag_cov), sep = "_")
+ rownames(covariance_matrix) <- paste("label", names(diag_cov), sep = "_")
+ names_covaration <- names(list_covar)
+
+ ###### -- utils -- #####
+ convertDF <- function(name, value){
+ ret <- data.frame(value)
+ colnames(ret) <- name
+ ret
+ }
+
+ ## -- needed to use reduce after ;)
+ l_covarUserDf <- lapply(names_covaration, function(n_cov) convertDF(n_cov, list_covar[n_cov] ))
+ covariance_matrix2ret <- Reduce(fillInCovarMatrice, x = l_covarUserDf, init = covariance_matrix)
+ covariance_matrix2ret
+}
+
+
+#' Fill in Covariance Matrix
+#'
+#' This function updates the covariance matrix with the specified covariance value between two variables.
+#'
+#' @param covarMatrice The input covariance matrix.
+#' @param covar A data frame containing the covariance value between two variables.
+#' @return The updated covariance matrix with the specified covariance value filled in.
+#' @export
+#' @examples
+#' covarMat <- matrix(0, nrow = 3, ncol = 3)
+#' colnames(covarMat) <- c("label_varA", "label_varB", "label_varC")
+#' rownames(covarMat) <- c("label_varA", "label_varB", "label_varC")
+#' covarValue <- data.frame("varA.varB" = 0.5)
+#' fillInCovarMatrice(covarMatrice = covarMat, covar = covarValue)
+fillInCovarMatrice <- function(covarMatrice, covar){
+ varsInCovar <- strsplit(colnames(covar), split = "[.]") %>% unlist()
+ index_matrix <- paste("label",varsInCovar, sep = "_")
+ covar_value <- covar[1,1]
+ covarMatrice[index_matrix[1], index_matrix[2]] <- covar_value
+ covarMatrice[index_matrix[2], index_matrix[1]] <- covar_value
+ return(covarMatrice)
+}
+
+
+#' Check if a matrix is positive definite
+#' This function checks whether a given matrix is positive definite, i.e., all of its eigenvalues are positive.
+#' @param mat The matrix to be checked.
+#' @return A logical value indicating whether the matrix is positive definite.
+#' @export
+#' @examples
+#' # Create a positive definite matrix
+#' mat1 <- matrix(c(4, 2, 2, 3), nrow = 2)
+#' is_positive_definite(mat1)
+#' # Expected output: TRUE
+#'
+#' # Create a non-positive definite matrix
+#' mat2 <- matrix(c(4, 2, 2, -3), nrow = 2)
+#' is_positive_definite(mat2)
+#' # Expected output: FALSE
+#'
+#' # Check an empty matrix
+#' mat3 <- matrix(nrow = 0, ncol = 0)
+#' is_positive_definite(mat3)
+#' # Expected output: TRUE
+#'
+#' @export
+is_positive_definite <- function(mat) {
+ if (nrow(mat) == 0 && ncol(mat) == 0) return(TRUE)
+ eigenvalues <- eigen(mat)$values
+ all(eigenvalues > 0)
+}
+
+
+
+#' getGeneMetadata
+#'
+#' @inheritParams init_variable
+#' @param n_genes Number of genes to simulate
+#'
+#' @return
+#' metadata matrix
+#'
+#' @export
+#'
+#' @examples
+#' list_var <- init_variable()
+#' metadata <- getGeneMetadata(list_var, n_genes = 10)
+getGeneMetadata <- function(list_var, n_genes) {
+ metaData <- generateGridCombination_fromListVar(list_var)
+ n_combinations <- dim(metaData)[1]
+ genes_vec <- base::paste("gene", 1:n_genes, sep = "")
+ geneID <- rep(genes_vec, each = n_combinations)
+ metaData <- cbind(geneID, metaData)
+
+ return(metaData)
+}
+
+
+#' getDataFromMvrnorm
+#'
+#' @inheritParams init_variable
+#' @param input2mvrnorm list with mu and covariance matrix, output of getInput2mvrnorm
+#' @param n_genes Number of genes to simulate
+#'
+#' @return
+#' data simulated from multivariate normal distribution
+#'
+#' @export
+#'
+#' @examples
+#' list_var <- init_variable()
+#' input <- getInput2mvrnorm(list_var)
+#' simulated_data <- getDataFromMvrnorm(list_var, input, n_genes = 10)
+getDataFromMvrnorm <- function(list_var, input2mvrnorm, n_genes = 1) {
+ if (is.null(input2mvrnorm$covMatrix))
+ return(list())
+
+ metaData <- getGeneMetadata(list_var, n_genes)
+ n_tirages <- dim(metaData)[1]
+
+ mtx_mvrnormSamplings <- samplingFromMvrnorm(n_samplings = n_tirages,
+ l_mu = input2mvrnorm$mu, matx_cov = input2mvrnorm$covMatrix)
+
+ dataFromMvrnorm <- cbind(metaData, mtx_mvrnormSamplings)
+
+ return(list(dataFromMvrnorm))
+}
+
+
+#' getDataFromMvrnorm
+#'
+#' @param n_samplings number of samplings using mvrnorm
+#' @param l_mu vector of mu
+#' @param matx_cov covariance matrix
+#'
+#' @return
+#' samples generated from multivariate normal distribution
+#'
+#' @export
+#'
+#' @examples
+#' n <- 100
+#' mu <- c(0, 0)
+#' covMatrix <- matrix(c(1, 0.5, 0.5, 1), ncol = 2)
+#' samples <- samplingFromMvrnorm(n_samplings = n, l_mu = mu, matx_cov = covMatrix)
+samplingFromMvrnorm <- function(n_samplings, l_mu, matx_cov) {
+ mvrnormSamp <- MASS::mvrnorm(n = n_samplings, mu = l_mu, Sigma = matx_cov, empirical = TRUE)
+
+ return(mvrnormSamp)
+}
+
diff --git a/R/datafromuser_manipulations.R b/R/datafromuser_manipulations.R
new file mode 100644
index 0000000000000000000000000000000000000000..1c3ee6d3970a34f18adccfae87b28e93192c26fd
--- /dev/null
+++ b/R/datafromuser_manipulations.R
@@ -0,0 +1,26 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+#' Get data from user
+#'
+#'
+#' @param list_var A list of variables (already initialized)
+#' @return A list of data to join
+#' @export
+#'
+#' @examples
+#' getDataFromUser(init_variable())
+getDataFromUser <- function(list_var) {
+ variable_data2join <- getGivenAttribute(list_var, "data")
+ id_var2join <- names(variable_data2join)
+ interaction_data2join <- getGivenAttribute(list_var$interactions, "data")
+ id_interaction2join <- names(interaction_data2join)
+
+ data2join <- list(variable_data2join, interaction_data2join) %>%
+ unlist(recursive = FALSE)
+ id2join <- c(id_var2join, id_interaction2join)
+ l_data2join <- lapply(id2join, function(id) data2join[[id]])
+
+ return(l_data2join)
+}
+
diff --git a/R/evaluatedispersion.R b/R/evaluatedispersion.R
new file mode 100644
index 0000000000000000000000000000000000000000..640aac058ff008e9f7b958dfb073fa8d64e77951
--- /dev/null
+++ b/R/evaluatedispersion.R
@@ -0,0 +1,135 @@
+# 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") + 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.
+#'
+#' @param inferred_dispersion A data frame containing inferred dispersion values.
+#' @param actual_dispersion A numeric vector containing actual dispersion values.
+#'
+#' @return A data frame comparing actual and inferred dispersion values.
+#'
+#' @export
+#'
+#' @examples
+#' \dontrun{
+#' dispersion_comparison <- getDispersionComparison(inferred_disp, actual_disp)
+#' print(dispersion_comparison)
+#' }
+getDispersionComparison <- function(inferred_dispersion, actual_dispersion) {
+ actual_disp <- data.frame(actual_dispersion = actual_dispersion)
+ actual_disp$geneID <- rownames(actual_disp)
+ rownames(actual_disp) <- NULL
+ disp_comparison <- join_dtf(actual_disp, inferred_dispersion, "geneID", "geneID")
+ return(disp_comparison)
+}
+
+
+#' Extract DESeq2 Dispersion Values
+#'
+#' Extracts inferred dispersion values from a DESeq2 wrapped object.
+#'
+#' @param deseq_wrapped A DESeq2 wrapped object containing dispersion values.
+#'
+#' @return A data frame containing inferred dispersion values.
+#'
+#' @export
+#'
+#' @examples
+#' \dontrun{
+#' dispersion_df <- extractDESeqDispersion(deseq2_object)
+#' print(dispersion_df)
+#' }
+extractDESeqDispersion <- function(deseq_wrapped) {
+ inferred_dispersion <- data.frame(inferred_dispersion = deseq_wrapped$dispersion)
+ inferred_dispersion$geneID <- rownames(inferred_dispersion)
+ rownames(inferred_dispersion) <- NULL
+ return(inferred_dispersion)
+}
+
+
+#' Extract TMB Dispersion Values
+#'
+#' Extracts inferred dispersion values from a TMB result object.
+#'
+#' @param l_tmb A TMB result object containing dispersion values.
+#'
+#' @return A data frame containing inferred dispersion values.
+#'
+#' @export
+#'
+#' @examples
+#' \dontrun{
+#' dispersion_df <- extractTMBDispersion(tmb_result)
+#' print(dispersion_df)
+#' }
+extractTMBDispersion <- function(l_tmb) {
+ glanceRes <- glance_tmb(l_tmb)
+ inferred_dispersion <- data.frame(inferred_dispersion = glanceRes$dispersion)
+ inferred_dispersion$geneID <- 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
+#' @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 = actual_dispersion, y = 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/evaluationwithmixedeffect.R b/R/evaluationwithmixedeffect.R
new file mode 100644
index 0000000000000000000000000000000000000000..4b204476fd04f6c2c663b4fcfb808de8dfcddd3d
--- /dev/null
+++ b/R/evaluationwithmixedeffect.R
@@ -0,0 +1,270 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+#' Check if the formula contains a mixed effect structure.
+#'
+#' This function checks if the formula contains a mixed effect structure indicated by the presence of "|".
+#'
+#' @param formula A formula object.
+#'
+#' @return \code{TRUE} if the formula contains a mixed effect structure, \code{FALSE} otherwise.
+#'
+#' @examples
+#' is_mixedEffect_inFormula(y ~ x + (1|group))
+#'
+#' @export
+is_mixedEffect_inFormula <- function(formula) {
+ return("|" %in% all.names(formula))
+}
+
+#' Check if the formula follows a specific type I mixed effect structure.
+#'
+#' This function checks if the formula follows a specific type I mixed effect structure, which consists of a fixed effect and a random effect indicated by the presence of "|".
+#'
+#' @param formula A formula object.
+#
+#' @return \code{TRUE} if the formula follows the specified type I mixed effect structure, \code{FALSE} otherwise.
+#
+#' @examples
+#' is_formula_mixedTypeI(formula = y ~ x + (1|group))
+#
+#' @export
+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)
+ return(TRUE)
+}
+
+
+#' Get the categorical variable associated with the fixed effect in a type I formula.
+#'
+#' This function extracts the categorical variable associated with the fixed effect in a type I formula from a tidy tibble.
+# The categorical variable is constructed by taking the label of the second main fixed effect term (ignoring any numeric suffix) and prefixing it with "label_".
+#
+#' @param tidy_tmb A tidy tibble containing model terms.
+#
+#' @return The categorical variable associated with the fixed effect in the type I formula.
+#
+#' @examples
+#' \dontrun{
+#' getCategoricalVar_inFixedEffect(tidy_tmb)
+#' }
+#' @export
+getCategoricalVar_inFixedEffect <- function(tidy_tmb) {
+ main_fixEffs <- unique(subset(tidy_tmb, effect == "fixed")$term)
+ categorical_var_inFixEff <- paste("label", gsub("\\d+$", "", main_fixEffs[2]), sep = "_")
+ return(categorical_var_inFixEff)
+}
+
+
+#' Group log_qij values per genes and labels.
+#'
+#' This function groups log_qij values in a ground truth tibble per genes and labels using a specified categorical variable.
+#
+#' @param ground_truth A tibble containing ground truth data.
+#' @param categorical_var The categorical variable to use for grouping.
+#
+#' @return A list of log_qij values grouped by genes and labels.
+#' @importFrom stats as.formula
+#' @importFrom reshape2 dcast
+#'
+#
+#' @examples
+#' \dontrun{
+#' group_logQij_per_genes_and_labels(ground_truth, categorical_var)
+#' }
+#' @export
+group_logQij_per_genes_and_labels <- function(ground_truth, categorical_var) {
+ str_formula <- paste(c(categorical_var, "geneID"), collapse = " ~ ")
+ formula <- stats::as.formula(str_formula)
+ list_logqij <- ground_truth %>%
+ reshape2::dcast(
+ formula,
+ value.var = "log_qij_scaled",
+ fun.aggregate = list
+ )
+ list_logqij[categorical_var] <- NULL
+ return(list_logqij)
+}
+
+#' Calculate actual mixed effect values for each gene.
+#'
+#' This function calculates actual mixed effect values for each gene using the provided data, reference labels, and other labels in a categorical variable.
+#
+#' @param list_logqij A list of log_qij values grouped by genes and labels.
+#' @param genes_iter_list A list of genes for which to calculate the actual mixed effect values.
+#' @param categoricalVar_infos Information about the categorical variable, including reference labels and other labels.
+#
+#' @return A data frame containing the actual mixed effect values for each gene.
+#
+#' @examples
+#' \dontrun{
+#' getActualMixed_typeI(list_logqij, genes_iter_list, categoricalVar_infos)
+#' }
+#' @export
+getActualMixed_typeI <- function(list_logqij, genes_iter_list, categoricalVar_infos) {
+ labelRef_InCategoricalVar <- categoricalVar_infos$ref
+ labels_InCategoricalVar <- categoricalVar_infos$labels
+ labelOther_inCategoricalVar <- categoricalVar_infos$labelsOther
+
+ data_per_gene <- lapply(genes_iter_list, function(g) {
+ data_gene <- data.frame(list_logqij[[g]])
+ colnames(data_gene) <- labels_InCategoricalVar
+ return(data_gene)
+ })
+
+ l_actual_per_gene <- lapply(genes_iter_list, function(g) {
+ data_gene <- data_per_gene[[g]]
+ res <- calculate_actualMixed(data_gene, labelRef_InCategoricalVar, labelOther_inCategoricalVar)
+ res$geneID <- g
+ return(res)
+ })
+
+ actual_mixedEff <- do.call("rbind", l_actual_per_gene)
+ rownames(actual_mixedEff) <- NULL
+ return(actual_mixedEff)
+}
+
+
+
+#' 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.
+#
+#' @param tidy_tmb tidy model results obtained from fitting a mixed-effects model.
+#' @param ground_truth_eff A data frame containing ground truth effects.
+#
+#' @return A data frame with the comparison of estimated mixed effects to expected values.
+#' @importFrom stats setNames
+#' @examples
+#' \dontrun{
+#' inferenceToExpected_withMixedEff(tidy_tmb(l_tmb), ground_truth_eff)
+#' }
+#' @export
+inferenceToExpected_withMixedEff <- function(tidy_tmb, ground_truth_eff){
+
+ # -- CategoricalVar involve in fixEff
+ categorical_var <- getCategoricalVar_inFixedEffect(tidy_tmb)
+ labels_InCategoricalVar <- levels(ground_truth_eff[, categorical_var])
+ labelRef_InCategoricalVar <- labels_InCategoricalVar[1]
+ labelOther_inCategoricalVar <- labels_InCategoricalVar[2:length(labels_InCategoricalVar)]
+ categoricalVar_infos <- list(ref = labelRef_InCategoricalVar,
+ labels = labels_InCategoricalVar,
+ labelsOther = labelOther_inCategoricalVar )
+
+ ## -- prepare data 2 get actual
+ l_logqij <- group_logQij_per_genes_and_labels(ground_truth_eff, categorical_var)
+ l_genes <- unique(ground_truth_eff$geneID)
+ genes_iter_list <- stats::setNames(l_genes,l_genes)
+ actual_mixedEff <- getActualMixed_typeI(l_logqij, genes_iter_list, categoricalVar_infos)
+
+ res <- join_dtf(actual_mixedEff, tidy_tmb ,c("geneID", "term"), c("ID", "term"))
+
+ ## -- reorder for convenience
+ actual <- res$actual
+ res <- res[, -1]
+ res$actual <- actual
+ return(res)
+}
+
+
+#' 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.
+#
+#' @param data_gene Data for a specific gene.
+#' @param labelRef_InCategoricalVar The reference label for the categorical variable.
+#' @param labelOther_inCategoricalVar Labels for the categorical variable other than the reference label.
+#' @importFrom stats sd cor
+#
+#' @return A data frame containing the calculated actual mixed effects.
+#
+#' @examples
+#' \dontrun{
+#' calculate_actualMixed(data_gene, labelRef_InCategoricalVar, labelOther_inCategoricalVar)
+#' }
+#' @export
+calculate_actualMixed <- function(data_gene, labelRef_InCategoricalVar, labelOther_inCategoricalVar ){
+ log_qij_scaled_intercept <- data_gene[labelRef_InCategoricalVar]
+ colnames(log_qij_scaled_intercept) <- '(Intercept)'
+
+ if (length(labelOther_inCategoricalVar == 1 )) {
+ log_qij_scaled_other <- data_gene[labelOther_inCategoricalVar]
+ } else log_qij_scaled_other <- data_gene[,labelOther_inCategoricalVar]
+ log_qij_scaled_transf <- log_qij_scaled_other - log_qij_scaled_intercept[,"(Intercept)"]
+
+ log_qij_scaled_transf <- cbind(log_qij_scaled_intercept, log_qij_scaled_transf)
+ ## -- fix eff
+ actual_fixedValues <- colMeans(log_qij_scaled_transf)
+
+ ## -- stdev values
+ std_values <- sapply(log_qij_scaled_transf, function(x) stats::sd(x))
+ names(std_values) <- paste("sd", names(std_values), sep = '_')
+
+ ## -- correlation
+ corr_mat <- stats::cor(log_qij_scaled_transf)
+ indx <- which(upper.tri(corr_mat, diag = FALSE), arr.ind = TRUE)
+ corr2keep = corr_mat[indx]
+ name_corr <- paste(rownames(corr_mat)[indx[, "row"]], colnames(corr_mat)[indx[, "col"]], sep = ".")
+ names(corr2keep) <- paste("cor", name_corr, sep = "__")
+
+ ## -- output
+ actual <- c(actual_fixedValues, std_values, corr2keep)
+ res <- as.data.frame(actual)
+ res$term <- rownames(res)
+ rownames(res) <- NULL
+ res$description <- sub("_.*", "", gsub("\\d+$", "" , res$term))
+ return(res)
+
+
+}
+
+
+#' Compare inference results to expected values for a given model.
+#'
+#' This function compares the inference results from a model to the expected values based on a ground truth dataset with the simulated effects. The function handles models with mixed effects and fixed effects separately, ensuring that the comparison is appropriate for the specific model type.
+#'
+#' If a model includes mixed effects, the function checks for support for the specific mixed effect structure and provides an informative error message if the structure is not supported.
+#'
+#' @param tidy_tmb A fitted model object convert to tidy dataframe.
+#' @param ground_truth_eff A ground truth dataset with the simulated effects.
+#' @param formula_used formula used in model
+#'
+#' @return A data frame containing the comparison results, including the term names, inference values, and expected values.
+#'
+#' @examples
+#' \dontrun{
+#' evalData <- compareInferenceToExpected(l_tmb, ground_truth_eff)
+#' }
+#' @export
+compareInferenceToExpected <- function(tidy_tmb, ground_truth_eff, formula_used) {
+ ## -- parsing formula & check mixed effect
+ involvMixedEffect <- is_mixedEffect_inFormula(formula_used)
+
+ msg_e_formula_type <- "This simulation evaluation supports certain types of formulas with mixed effects, but not all.
+ Please refer to the package documentation for information on supported formula structures.
+ You are welcome to implement additional functions to handle specific formula types with mixed effects that are not currently supported."
+
+ ## -- if mixed effect
+ if (involvMixedEffect){
+ message("Mixed effect detected in the formula structure.")
+
+ if(!is_formula_mixedTypeI(formula_used)){
+ stop(msg_e_formula_type)
+ }
+ evalData <- inferenceToExpected_withMixedEff(tidy_tmb, ground_truth_eff)
+
+ ## -- only fixed effect
+ } else {
+
+ message("Only fixed effects are detected in the formula structure.")
+ evalData <- inferenceToExpected_withFixedEff(tidy_tmb, ground_truth_eff)
+ }
+
+ return(evalData)
+}
+
+
diff --git a/R/fitmodel.R b/R/fitmodel.R
new file mode 100644
index 0000000000000000000000000000000000000000..24bfd0aff7c03d8694004e73eb8a6027fdff8a5d
--- /dev/null
+++ b/R/fitmodel.R
@@ -0,0 +1,252 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+#' Check if Data is Valid for Model Fitting
+#'
+#' This function checks whether the provided data contains all the variables required in the model formula for fitting.
+#'
+#' @param data2fit The data frame or tibble containing the variables to be used for model fitting.
+#' @param formula The formula specifying the model to be fitted.
+#'
+#' @return \code{TRUE} if all the variables required in the formula are present in \code{data2fit}, otherwise an error is raised.
+#'
+#' @examples
+#' data(iris)
+#' formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+#' isValidInput2fit(iris, formula) # Returns TRUE if all required variables are present
+#' @keywords internal
+#' @export
+isValidInput2fit <- function(data2fit, formula){
+ vec_bool <- all.vars(formula) %in% colnames(data2fit)
+ for (i in seq_along(vec_bool)){
+ if (isFALSE(vec_bool[i]) ) {
+ stop(paste("Variable", all.vars(formula)[i], "not found"))
+ }
+ }
+ return(TRUE)
+}
+
+
+#' Drop Random Effects from a Formula
+#'
+#' This function allows you to remove random effects from a formula by specifying
+#' which terms to drop. It checks for the presence of vertical bars ('|') in the
+#' terms of the formula and drops the random effects accordingly. If all terms
+#' are random effects, the function updates the formula to have only an intercept.
+#'
+#' @param form The formula from which random effects should be dropped.
+#'
+#' @return A modified formula with specified random effects dropped.
+#'
+#' @examples
+#' # Create a formula with random effects
+#' formula <- y ~ x1 + (1 | group) + (1 | subject)
+#' # Drop the random effects related to 'group'
+#' modified_formula <- drop_randfx(formula)
+#'
+#' @importFrom stats terms
+#' @importFrom stats update
+#'
+#' @export
+drop_randfx <- function(form) {
+ form.t <- stats::terms(form)
+ dr <- grepl("|", labels(form.t), fixed = TRUE)
+ if (mean(dr) == 1) {
+ form.u <- stats::update(form, . ~ 1)
+ } else {
+ if (mean(dr) == 0) {
+ form.u <- form
+ } else {
+ form.td <- stats::drop.terms(form.t, which(dr))
+ form.u <- stats::update(form, form.td)
+ }
+ }
+ form.u
+}
+
+
+
+#' Check if a Model Matrix is Full Rank
+#'
+#' This function checks whether a model matrix is full rank, which is essential for
+#' certain statistical analyses. It computes the eigenvalues of the crossproduct
+#' of the model matrix and determines if the first eigenvalue is positive and if
+#' the ratio of the last eigenvalue to the first is within a defined tolerance.
+#'
+#' This function is inspired by a similar function found in the Limma package.
+#'
+#' @param metadata The metadata used to create the model matrix.
+#' @param formula The formula used to specify the model matrix.
+#'
+#' @return \code{TRUE} if the model matrix is full rank, \code{FALSE} otherwise.
+#'
+#' @examples
+#' metadata <- data.frame(x = rnorm(10), y = rnorm(10))
+#' formula <- y ~ x
+#' is_fullrank(metadata, formula)
+#'
+#'
+#' @importFrom stats model.matrix
+#' @export
+is_fullrank <- function(metadata, formula) {
+ ## drop random eff
+ formula <- drop_randfx(formula)
+ ## TEST
+ model_matrix <- stats::model.matrix(data = metadata, formula)
+ e <- eigen(crossprod(model_matrix), symmetric = TRUE, only.values = TRUE)$values
+ modelFullRank <- e[1] > 0 && abs(e[length(e)] / e[1]) > 1e-13
+
+ if (!modelFullRank)
+ stop("The model matrix is not full rank, so the model cannot be fit as specified. One or more variables or interaction terms in the design formula are linear combinations of the others and must be removed.")
+
+ return(TRUE)
+}
+
+
+
+
+
+#' Fit a model using the fitModel function.
+#'
+#' @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
+#' @export
+#' @examples
+#' .fitModel(formula = mpg ~ cyl + disp, data = mtcars)
+.fitModel <- function(formula, data, ...) {
+ # Fit the model using glm.nb from the GLmmTMB package
+ model <- glmmTMB::glmmTMB(formula, ..., data = data )
+ model$frame <- data
+ ## family in ... => avoid error in future update
+ additional_args <- list(...)
+ familyArgs <- additional_args[['family']]
+ if (!is.null(familyArgs)) model$call$family <- familyArgs
+ ## control in ... => avoid error in future update
+ controlArgs <- additional_args[['control']]
+ if (!is.null(controlArgs)) model$call$control <- controlArgs
+ return(model)
+}
+
+
+
+#' Fit the model based using fitModel functions.
+#'
+#' @param group The specific group to fit the model for
+#' @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
+#' @export
+#' @examples
+#' .subsetData_andfit(group = "setosa", group_by = "Species",
+#' formula = Sepal.Length ~ Sepal.Width + Petal.Length,
+#' data = iris )
+.subsetData_andfit <- function(group, group_by, formula, data, ...) {
+ subset_data <- data[data[[group_by]] == group, ]
+ fit_res <- .fitModel(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
+}
+
+
+
+#' Launch the model fitting process for a specific group.
+#'
+#' 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 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",
+#' formula = Sepal.Length ~ Sepal.Width + Petal.Length,
+#' data = iris )
+launchFit <- function(group, group_by, formula, data, ...) {
+ tryCatch(
+ expr = {
+ withCallingHandlers(
+ .subsetData_andfit(group, group_by, formula, data, ...),
+ warning = function(w) {
+ message(paste(Sys.time(), "warning for group", group, ":", conditionMessage(w)))
+ invokeRestart("muffleWarning")
+ })
+ },
+ 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)))
+ }
+ )
+}
+
+
+#' Fit models in parallel for each group using mclapply and handle logging.
+#' Uses parallel_fit to fit the models.
+#'
+#' @param groups Vector of unique group values
+#' @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 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 to write log (default : log.txt)
+#' @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",
+#' formula = Sepal.Length ~ Sepal.Width + Petal.Length,
+#' data = iris, n.cores = 1, log_file = "log.txt" )
+.parallel_fit <- function(groups, group_by, formula, data, n.cores = NULL, log_file, ...) {
+ if (is.null(n.cores)) n.cores <- parallel::detectCores()
+
+ 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, ...)
+
+ parallel::stopCluster(clust)
+ #closeAllConnections()
+ return(results_fit)
+}
+
+#' Fit models in parallel for each group using mclapply and handle logging.
+#' Uses parallel_fit to fit the models.
+#'
+#' @param formula Formula specifying the model formula
+#' @param data Data frame containing the data
+#' @param group_by Column name in data representing the grouping variable
+#' @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 : log.txt)
+#' @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 = "log.txt", ...) {
+
+ ## SOme verification
+ isValidInput2fit(data, formula)
+ is_fullrank(data, formula)
+
+
+ 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, ...)
+ #results <- mergeListDataframes(results)
+ return(results)
+}
+
+
diff --git a/R/glance_tmb.R b/R/glance_tmb.R
new file mode 100644
index 0000000000000000000000000000000000000000..a9bd29e16e0ad99cc675a9af7b3f6b20c5143855
--- /dev/null
+++ b/R/glance_tmb.R
@@ -0,0 +1,46 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+#' Extracts the summary statistics from a list of glmmTMB models.
+#'
+#' This function takes a list of glmmTMB models and extracts the summary statistics (AIC, BIC, logLik, deviance,
+#' df.resid, and dispersion) for each model and returns them as a single DataFrame.
+#'
+#' @param l_tmb A list of glmmTMB models or a unique glmmTMB obj model
+#' @return A DataFrame with the summary statistics for all the glmmTMB models in the list.
+#' @export
+#' @importFrom stats setNames
+#' @examples
+#' data(mtcars)
+#' models <- fitModelParallel(Sepal.Length ~ Sepal.Width + Petal.Length,
+#' group_by = "Species",n.cores = 1, data = iris)
+#' result <- glance_tmb(models)
+glance_tmb <- function(l_tmb){
+ if (identical(class(l_tmb), "glmmTMB")) return(getGlance(l_tmb))
+ l_group <- attributes(l_tmb)$names
+ l_glance <- lapply(stats::setNames(l_group, l_group), function(group) getGlance(l_tmb[[group]]))
+ return(do.call("rbind", l_glance))
+}
+
+
+#' Extracts the summary statistics from a single glmmTMB model.
+#'
+#' This function takes a single glmmTMB model and extracts the summary statistics (AIC, BIC, logLik, deviance,
+#' df.resid, and dispersion) from the model and returns them as a DataFrame.
+#'
+#' @param x A glmmTMB model.
+#' @return A DataFrame with the summary statistics for the glmmTMB model.
+#' @export
+#'
+#' @examples
+#' data(mtcars)
+#' model <- glmmTMB::glmmTMB(mpg ~ wt + (1|cyl), data = mtcars)
+#' getGlance(model)
+getGlance <- function(x){
+ if (is.null(x)) return(NULL)
+ ret <- data.frame(t(summary(x)$AICtab))
+ ret$dispersion <- glmmTMB::sigma(x)
+ ret
+}
+
+
diff --git a/R/identityplot.R b/R/identityplot.R
new file mode 100644
index 0000000000000000000000000000000000000000..f16934bcb8814507440f9627862dd6cdc0e28c2a
--- /dev/null
+++ b/R/identityplot.R
@@ -0,0 +1,38 @@
+# 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
+#' @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 = actual, y = estimate, !!!args), alpha = 0.6) +
+ 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/inferencetoexpected.R b/R/inferencetoexpected.R
new file mode 100644
index 0000000000000000000000000000000000000000..b6128e596944129e2791f6b7c945c78a618d76ff
--- /dev/null
+++ b/R/inferencetoexpected.R
@@ -0,0 +1,45 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+#' Compare the results of inference with the ground truth data.
+#'
+#' This function takes the data frames containing the inference results and the ground truth data
+#' and generates a table to compare the inferred values with the expected values.
+#'
+#' @param tidy_tmb A data frame containing the results of inference.
+#' @param df_ground_truth A data frame containing the ground truth data used for simulation.
+#'
+#' @return A data frame
+#'
+#' @examples
+#' \dontrun{
+#' inferenceToExpected_withFixedEff(tidy_tmb, df_ground_truth)
+#' }
+#'
+#' @export
+inferenceToExpected_withFixedEff <- function(tidy_tmb , df_ground_truth) {
+
+ ## -- get data
+ fixEff_dataInference <- subsetFixEffectInferred(tidy_tmb)
+ fixEff_dataActual <- getData2computeActualFixEffect(df_ground_truth)
+ actual_intercept <- getActualIntercept(fixEff_dataActual)
+
+ ## -- main = non interaction
+ l_mainEffectTerm <- fixEff_dataInference$fixed_term$nonInteraction
+ actual_mainFixEff <- getActualMainFixEff(l_mainEffectTerm, fixEff_dataActual, actual_intercept)
+
+ ## -- interaction term
+ l_interactionTerm <- fixEff_dataInference$fixed_term$interaction
+ categorical_vars <- fixEff_dataActual$categorical_vars
+ data <- fixEff_dataActual$data
+ actualInteractionFixEff <- computeActualInteractionFixEff(l_interactionTerm, categorical_vars, data)
+
+ ## -- rbind Interaction & Main
+ actual_fixEff <- rbind(actual_mainFixEff , actualInteractionFixEff, actual_intercept )
+
+ ## -- join inference & actual
+ inference_fixEff <- fixEff_dataInference$data
+ res <- join_dtf(inference_fixEff, actual_fixEff , c("ID", "term"), c("geneID", "term"))
+ return(res)
+}
+
diff --git a/R/mock-rnaseq.R b/R/mock-rnaseq.R
new file mode 100644
index 0000000000000000000000000000000000000000..0beccbcf91a6c2cb7b32116ca23784f9e076c4f0
--- /dev/null
+++ b/R/mock-rnaseq.R
@@ -0,0 +1,210 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+#' Check the validity of the dispersion matrix
+#'
+#' Checks if the dispersion matrix has the correct dimensions.
+#'
+#' @param matx_dispersion Replication matrix
+#' @param matx_bool_replication Replication matrix
+#' @return TRUE if the dimensions are valid, FALSE otherwise
+#' @export
+#' @examples
+#' matx_dispersion <- matrix(1:12, nrow = 3, ncol = 4)
+#' matx_bool_replication <- matrix(TRUE, nrow = 3, ncol = 4)
+#' .isDispersionMatrixValid(matx_dispersion, matx_bool_replication)
+.isDispersionMatrixValid <- function(matx_dispersion, matx_bool_replication) {
+ expected_nb_column <- dim(matx_bool_replication)[2]
+ if (expected_nb_column != dim(matx_dispersion)[2]) {
+ return(FALSE)
+ }
+ return(TRUE)
+}
+
+#' Generate count table
+#'
+#' Generates the count table based on the mu_ij matrix, dispersion matrix, and replication matrix.
+#'
+#' @param mu_ij_matx_rep Replicated mu_ij matrix
+#' @param matx_dispersion_rep Replicated dispersion matrix
+#' @return Count table
+#' @export
+#' @examples
+#' mu_ij_matx_rep <- matrix(1:12, nrow = 3, ncol = 4)
+#' matx_dispersion_rep <- matrix(1:12, nrow = 3, ncol = 4)
+#' generateCountTable(mu_ij_matx_rep, matx_dispersion_rep)
+generateCountTable <- function(mu_ij_matx_rep, matx_dispersion_rep) {
+ message("k_ij ~ Nbinom(mu_ij, dispersion)")
+ n_genes <- dim(mu_ij_matx_rep)[1]
+ n_samples <- dim(mu_ij_matx_rep)[2]
+ n_samplings <- prod(n_genes * n_samples)
+ mat_countsTable <- rnbinom(n_samplings,
+ size = matx_dispersion_rep,
+ mu = mu_ij_matx_rep) %>%
+ matrix(nrow = n_genes, ncol = n_samples)
+ colnames(mat_countsTable) <- colnames(mu_ij_matx_rep)
+ rownames(mat_countsTable) <- rownames(mu_ij_matx_rep)
+ mat_countsTable[is.na(mat_countsTable)] <- 0
+ return(mat_countsTable)
+}
+
+
+#' Perform RNA-seq simulation
+#'
+#' Simulates RNA-seq data based on the input variables.
+#'
+#' @param list_var List of input variables
+#' @param n_genes Number of genes
+#' @param min_replicates Minimum replication count
+#' @param max_replicates Maximum replication count
+#' @param sequencing_depth Sequencing depth
+#' @param basal_expression base expression gene
+#' @param dispersion User-provided dispersion vector (optional)
+#' @return List containing the ground truth, counts, and metadata
+#' @export
+#' @examples
+#' mock_rnaseq(list_var = init_variable(),
+#' n_genes = 1000, min_replicates = 2,
+#' max_replicates = 4)
+mock_rnaseq <- function(list_var, n_genes, min_replicates, max_replicates, sequencing_depth = NULL,
+ basal_expression = 0 , dispersion = stats::runif(n_genes, min = 0, max = 1000) ) {
+
+ ## -- get my effect
+ df_inputSimulation <- getInput2simulation(list_var, n_genes)
+ ## -- add column logQij
+ df_inputSimulation <- getLog_qij(df_inputSimulation)
+ df_inputSimulation <- addBasalExpression(df_inputSimulation, n_genes, basal_expression)
+ df_inputSimulation <- getMu_ij(df_inputSimulation )
+
+ message("Building mu_ij matrix")
+ ## -- matrix
+ matx_Muij <- getMu_ij_matrix(df_inputSimulation)
+ l_sampleID <- getSampleID(list_var)
+ matx_bool_replication <- generateReplicationMatrix(list_var, min_replicates, max_replicates)
+ mu_ij_matx_rep <- .replicateMatrix(matx_Muij, matx_bool_replication)
+
+
+ dispersion <- getValidDispersion(dispersion)
+ genes_dispersion <- sample(dispersion , size = n_genes, replace = T)
+ matx_dispersion <- getDispersionMatrix(list_var, n_genes, genes_dispersion)
+ l_geneID = base::paste("gene", 1:n_genes, sep = "")
+ names(genes_dispersion) <- l_geneID
+
+ ## same order as mu_ij_matx_rep
+ matx_dispersion <- matx_dispersion[ order(row.names(matx_dispersion)), ]
+ matx_dispersion_rep <- .replicateMatrix(matx_dispersion, matx_bool_replication)
+ matx_countsTable <- generateCountTable(mu_ij_matx_rep, matx_dispersion_rep)
+
+ message("Counts simulation: Done")
+
+
+ dtf_countsTable <- matx_countsTable %>% as.data.frame()
+ if (!is.null(sequencing_depth)) {
+ message("Scaling count table according to sequencing depth.")
+ dtf_countsTable <- scaleCountsTable(dtf_countsTable, sequencing_depth)
+ }
+
+ 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)
+ return(list2ret)
+}
+
+
+
+
+#' Validate and Filter Dispersion Values
+#'
+#' This function takes an input vector and validates it to ensure that it meets certain criteria.
+#'
+#' @param input_vector A vector to be validated.
+#' @return A validated and filtered numeric vector.
+#' @details The function checks whether the input is a vector, suppresses warnings while converting to numeric,
+#' and filters out non-numeric elements. It also checks for values greater than zero and removes negative values.
+#' If the resulting vector has a length of zero, an error is thrown.
+#' @examples
+#' getValidDispersion(c(0.5, 1.2, -0.3, "invalid", 0.8))
+#' @export
+getValidDispersion <- function(input_vector) {
+ # Verify if it's a vector
+ if (!is.vector(input_vector)) {
+ stop("dispersion param is not a vector.")
+ }
+
+ input_vector <- suppressWarnings(as.numeric(input_vector))
+
+ # Filter numeric elements
+ numeric_elements <- !is.na(input_vector)
+ if (sum(!numeric_elements) > 0) {
+ message("Non-numeric elements were removed from the dispersion vector")
+ input_vector <- input_vector[numeric_elements]
+ }
+
+ # Check and filter values > 0
+ numeric_positive_elements <- input_vector > 0
+ if (sum(!numeric_positive_elements) > 0) {
+ message("Negative numeric values were removed from the dispersion vector")
+ input_vector <- input_vector[numeric_positive_elements]
+ }
+
+ if (length(input_vector) == 0) stop("Invalid dispersion values provided.")
+
+ return(input_vector)
+}
+
+
+#' Generate replication matrix
+#'
+#' Generates the replication matrix based on the minimum and maximum replication counts.
+#'
+#' @param list_var Number of samples
+#' @param min_replicates Minimum replication count
+#' @param max_replicates Maximum replication count
+#' @return Replication matrix
+#' @export
+#' @examples
+#' list_var = init_variable()
+#' generateReplicationMatrix(list_var, min_replicates = 2, max_replicates = 4)
+generateReplicationMatrix <- function(list_var, min_replicates, max_replicates) {
+ if (min_replicates > max_replicates) {
+ message("min_replicates > max_replicates have been supplied")
+ message("Automatic reversing")
+ tmp_min_replicates <- min_replicates
+ min_replicates <- max_replicates
+ max_replicates <- tmp_min_replicates
+ }
+ l_sampleIDs <- getSampleID(list_var)
+ n_samples <- length(l_sampleIDs)
+ return(getReplicationMatrix(min_replicates, max_replicates, n_samples = n_samples))
+}
+
+#' Replicate matrix
+#'
+#' Replicates a matrix based on a replication matrix.
+#'
+#' @param matrix Matrix to replicate
+#' @param replication_matrix Replication matrix
+#' @return Replicated matrix
+#' @export
+#' @examples
+#' matrix <- matrix(1:9, nrow = 3, ncol = 3)
+#' replication_matrix <- matrix(TRUE, nrow = 3, ncol = 3)
+#' .replicateMatrix(matrix, replication_matrix)
+.replicateMatrix <- function(matrix, replication_matrix) {
+ n_genes <- dim(matrix)[1]
+ rep_list <- colSums(replication_matrix)
+ replicated_indices <- rep(seq_len(ncol(matrix)), times = rep_list)
+ replicated_matrix <- matrix[, replicated_indices, drop = FALSE]
+ suffix_sampleID <- sequence(rep_list)
+ colnames(replicated_matrix) <- paste(colnames(replicated_matrix), suffix_sampleID, sep = "_")
+ return(replicated_matrix)
+}
+
+
diff --git a/R/plot_metrics.R b/R/plot_metrics.R
new file mode 100644
index 0000000000000000000000000000000000000000..49f39455e400ead1c7967639941d8ee56bffc0b2
--- /dev/null
+++ b/R/plot_metrics.R
@@ -0,0 +1,70 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+#' Subset the glance DataFrame based on selected variables.
+#'
+#' This function subsets the glance DataFrame to keep only the specified variables.
+#'
+#' @param glance_df The glance DataFrame to subset.
+#' @param focus A character vector of variable names to keep, including "AIC", "BIC", "logLik", "deviance",
+#' "df.resid", and "dispersion".
+#' @return A subsetted glance DataFrame with only the selected variables.
+#' @export
+#'
+#' @examples
+#' data(iris)
+#' models <- fitModelParallel(Sepal.Length ~ Sepal.Width + Petal.Length,
+#' group_by = "Species",n.cores = 1, data = iris)
+#' glance_df <- glance_tmb(models)
+#' glance_df$group_id <- rownames(glance_df)
+#' subset_glance(glance_df, c("AIC", "BIC"))
+subset_glance <- function(glance_df, focus){
+ idx_existing_column <- focus %in% c("AIC", "BIC", "logLik", "deviance" ,"df.resid", "dispersion" )
+ if(sum(!idx_existing_column) > 0) warning(paste(focus[!idx_existing_column], ": does not exist\n"))
+ focus <- focus[idx_existing_column]
+ if (identical(focus, character(0)))
+ stop(paste0("Please select at least one variable to focus on : ",
+ "AIC, BIC, logLik, deviance, df.resid, dispersion" ))
+ glance_df <- glance_df[ , c("group_id", focus)]
+ return(glance_df)
+}
+
+
+#' Plot Metrics for Generalized Linear Mixed Models (GLMM)
+#'
+#' This function generates a density plot of the specified metrics for the given
+#' list of generalized linear mixed models (GLMMs).
+#'
+#' @param l_tmb A list of GLMM objects to extract metrics from.
+#' @param focus A character vector specifying the metrics to focus on. Possible
+#' values include "AIC", "BIC", "logLik", "deviance", "df.resid", and
+#' "dispersion". If \code{NULL}, all available metrics will be plotted.
+#'
+#' @return A ggplot object displaying density plots for the specified metrics.
+#'
+#' @importFrom reshape2 melt
+#' @importFrom ggplot2 aes facet_wrap geom_density theme_bw theme ggtitle
+#'
+#' @export
+#'
+#' @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(l_tmb, focus = NULL) {
+ glance_df <- glance_tmb(l_tmb)
+ glance_df$group_id <- rownames(glance_df)
+ if (!is.null(focus)) {
+ glance_df <- subset_glance(glance_df, focus)
+ }
+ long_glance_df <- reshape2::melt(glance_df, variable.name = "metric")
+ p <- ggplot2::ggplot(long_glance_df) +
+ ggplot2::geom_density(ggplot2::aes(x = value, col = metric, fill = metric), alpha = 0.4) +
+ ggplot2::facet_wrap(~metric, scales = "free") +
+ ggplot2::theme_bw() +
+ ggplot2::theme(legend.position = 'null') +
+ ggplot2::ggtitle("Metrics plot")
+ return(p)
+}
+
+
diff --git a/R/prepare_data2fit.R b/R/prepare_data2fit.R
new file mode 100644
index 0000000000000000000000000000000000000000..33850af905e5cd0133408ccf91f93005434c6827
--- /dev/null
+++ b/R/prepare_data2fit.R
@@ -0,0 +1,133 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+#' Convert count matrix to long data frame
+#'
+#' Converts a count matrix to a long data frame format using geneID as the identifier.
+#'
+#' @param countMatrix Count matrix
+#' @param value_name Name for the value column
+#' @param id_vars Name for the id column (default "geneID")
+#' @return Long data frame
+#' @importFrom reshape2 melt
+#' @export
+#' @examples
+#' list_var <- init_variable()
+#' mock_data <- mock_rnaseq(list_var, n_genes = 3, 2, 2)
+#' countMatrix_2longDtf(mock_data$counts)
+countMatrix_2longDtf <- function(countMatrix, value_name = "kij", id_vars = "geneID") {
+ countMatrix <- as.data.frame(countMatrix)
+ countMatrix$geneID <- rownames(countMatrix)
+ dtf_countLong <- reshape2::melt(countMatrix, id.vars = id_vars, variable.name = "sampleID",
+ value.name = value_name)
+ dtf_countLong$sampleID <- as.character(dtf_countLong$sampleID)
+ return(dtf_countLong)
+}
+
+#' Get column name with sampleID
+#'
+#' Returns the column name in the metadata data frame that corresponds to the given sampleID.
+#'
+#' @param dtf_countsLong Long data frame of counts
+#' @param metadata Metadata data frame
+#' @return Column name with sampleID
+#' @export
+#' @examples
+#' list_var <- init_variable()
+#' mock_data <- mock_rnaseq(list_var, n_genes = 3, 2,2, 2)
+#' dtf_countLong <- countMatrix_2longDtf(mock_data$counts)
+#' .getColumnWithSampleID(dtf_countLong, mock_data$metadata)
+.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
+ }
+ }
+}
+
+#' Prepare data for fitting
+#'
+#' Prepares the countMatrix and metadata for fitting by converting the countMatrix to a long format and joining with metadata.
+#'
+#' @param countMatrix Count matrix
+#' @param metadata Metadata data frame
+#' @param normalization A boolean value indicating whether to apply median ratio
+#' normalization. If \code{TRUE} (default), the counts matrix will be
+#' normalized using median ratio normalization. If
+#' \code{FALSE}, no normalization will be applied.
+#' @param response_name String referring to target variable name that is being modeled and predicted (default : "kij")
+#' @param groupID String referring the group variable name (default : "geneID")
+#' @return Data frame for fitting
+#' @export
+#' @examples
+#' list_var <- init_variable()
+#' mock_data <- mock_rnaseq(list_var, n_genes = 3, 2,2, 2)
+#' data2fit <- prepareData2fit(mock_data$counts, mock_data$metadata)
+prepareData2fit <- function(countMatrix, metadata, normalization = TRUE , response_name = "kij", groupID = "geneID" ) {
+
+ ## -- scaling for size differences
+ if ( isTRUE(normalization) ) {
+ message("INFO: Median ratio normalization.")
+ countMatrix <- medianRatioNormalization(countMatrix)
+ }
+
+ dtf_countsLong <- countMatrix_2longDtf(countMatrix, response_name)
+ metadata_columnForjoining <- .getColumnWithSampleID(dtf_countsLong, metadata)
+ if (is.na(metadata_columnForjoining)) {
+ stop("SampleIDs do not seem to correspond between countMatrix and metadata")
+ }
+ data2fit <- join_dtf(dtf_countsLong, metadata, k1 = "sampleID", k2 = metadata_columnForjoining)
+ if (sum(is.na(data2fit[[groupID]])) > 0) {
+ warning("Something went wrong. NA introduced in the geneID column. Check the coherence between countMatrix and metadata.")
+ }
+ return(data2fit)
+}
+
+
+
+#' Apply Median Ratio Normalization to a Counts Matrix
+#'
+#' This function performs median ratio normalization on a counts matrix to
+#' adjust for differences in sequencing depth across samples.
+#'
+#' @param countsMatrix A counts matrix where rows represent genes and columns
+#' represent samples.
+#'
+#' @return A normalized counts matrix after applying median ratio normalization.
+#'
+#' @details This function calculates the logarithm of the counts matrix,
+#' computes the average log expression for each gene, and then scales each
+#' sample's counts by the exponential of the difference between its average log
+#' expression and the median of those averages.
+#'
+#' @importFrom stats median
+#'
+#' @examples
+#' counts <- matrix(c(100, 200, 300, 1000, 1500, 2500), ncol = 2)
+#' normalized_counts <- medianRatioNormalization(counts)
+#'
+#' @export
+medianRatioNormalization <- function(countsMatrix) {
+ log_data <- log(countsMatrix)
+ average_log <- rowMeans(log_data)
+
+ if (all(is.infinite(average_log)))
+ stop("Every gene contains at least one zero, cannot compute log geometric means")
+
+ idx2keep <- average_log != "-Inf"
+ average_log <- average_log[idx2keep]
+
+ ratio_data <- sweep(log_data[idx2keep, ], 1, average_log, "-")
+ sample_medians <- apply(ratio_data, 2, stats::median)
+
+ scaling_factors <- exp(sample_medians)
+ countsMatrix_normalized <- sweep(countsMatrix, 2, scaling_factors, "/")
+
+ return(countsMatrix_normalized)
+}
+
+
diff --git a/R/rocplot.R b/R/rocplot.R
new file mode 100644
index 0000000000000000000000000000000000000000..352ced38fe8e1f15727e3bb57411210cfba3edfc
--- /dev/null
+++ b/R/rocplot.R
@@ -0,0 +1,91 @@
+# 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
+#'
+#' @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 = !isDE , m = p.adj, !!!args )) +
+ plotROC::geom_roc(n.cuts = 0, labels = FALSE) +
+ ggplot2::theme_bw() +
+ ggplot2::ggtitle("ROC curve")
+
+ ## -- 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/scalinggeneexpression.R b/R/scalinggeneexpression.R
new file mode 100644
index 0000000000000000000000000000000000000000..19729b5c82a831e451830b8dd6630044ce0ce749
--- /dev/null
+++ b/R/scalinggeneexpression.R
@@ -0,0 +1,82 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+
+
+
+#' Get bin expression for a data frame.
+#'
+#' This function divides the values of a specified column in a data frame into \code{n_bins} bins of equal width.
+#' The bin labels are then added as a new column in the data frame.
+#'
+#' @param dtf_coef A data frame containing the values to be binned.
+#' @param n_bins The number of bins to create.
+#'
+#' @return A data frame with an additional column named \code{binExpression}, containing the bin labels.
+#' @export
+#' @examples
+#' dtf <- data.frame(mu_ij = c(10, 20, 30, 15, 25, 35, 40, 5, 12, 22))
+#' dtf_with_bins <- getBinExpression(dtf, n_bins = 3)
+#'
+getBinExpression <- function(dtf_coef, n_bins){
+ col2bin <- "mu_ij"
+ bin_labels <- cut(dtf_coef[[col2bin]], n_bins, labels = paste("BinExpression", 1:n_bins, sep = "_"))
+ dtf_coef$binExpression <- bin_labels
+ return(dtf_coef)
+}
+
+
+
+
+#' Generate BE data.
+#'
+#' This function generates BE data for a given number of genes, in a vector of BE values.
+#'
+#' @param n_genes The number of genes to generate BE data for.
+#' @param basal_expression a numeric vector from which sample BE for eacg genes
+#'
+#' @return A data frame containing gene IDs, BE values
+#'
+#' @examples
+#' generate_BE(n_genes = 100, 10)
+#'
+#' @export
+generate_BE <- function(n_genes, basal_expression) {
+ ## --avoid bug if one value in basal_expr
+ pool2sample <- c(basal_expression, basal_expression)
+ BE <- sample(x = pool2sample, size = n_genes, replace = T)
+ l_geneID <- base::paste("gene", 1:n_genes, sep = "")
+ ret <- list(geneID = l_geneID, basalExpr = BE) %>% as.data.frame()
+ return(ret)
+}
+
+
+
+#' Compute basal expresion for gene expression based on the coefficients data frame.
+#'
+#' This function takes the coefficients data frame \code{dtf_coef} and computes
+#' basal expression for gene expression. The scaling factors are generated
+#' using the function \code{generate_BE}.
+#'
+#' @param dtf_coef A data frame containing the coefficients for gene expression.
+#' @param n_genes number of genes in simulation
+#' @param basal_expression gene basal expression vector
+#'
+#' @return A modified data frame \code{dtf_coef} with an additional column containing
+#' the scaling factors for gene expression.
+#' @export
+#' @examples
+#' list_var <- init_variable()
+#' N_GENES <- 5
+#' dtf_coef <- getInput2simulation(list_var, N_GENES)
+#' dtf_coef <- getLog_qij(dtf_coef)
+#' addBasalExpression(dtf_coef, N_GENES, 1)
+addBasalExpression <- function(dtf_coef, n_genes, basal_expression){
+ BE_df <- generate_BE(n_genes, basal_expression )
+ dtf_coef <- join_dtf(dtf_coef, BE_df, "geneID", "geneID")
+ return(dtf_coef)
+}
+
+
+
+
diff --git a/R/scalingsequencingdepth.R b/R/scalingsequencingdepth.R
new file mode 100644
index 0000000000000000000000000000000000000000..7c0777b2dcd41765d4bb43cf8363d8f6e435e830
--- /dev/null
+++ b/R/scalingsequencingdepth.R
@@ -0,0 +1,32 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+#' Scale Counts Table
+#'
+#' This function scales a counts table based on the expected sequencing depth per sample.
+#'
+#' @param countsTable A counts table containing raw read counts.
+#' @param seq_depth sequencing depth vector
+#' @return A scaled counts table.
+#'
+#' @export
+#' @examples
+#' mock_data <- list(counts = matrix(c(10, 20, 30, 20, 30, 10, 10, 20, 20, 20, 30, 10), ncol = 4))
+#' scaled_counts <- scaleCountsTable(countsTable = mock_data$counts, 1000000)
+#'
+scaleCountsTable <- function(countsTable, seq_depth){
+ seq_depth_simu <- colSums(countsTable)
+
+ if (length(seq_depth) > length(seq_depth_simu))
+ message("INFO: The length of the sequencing_depth vector exceeds the number of samples. Only the first N values will be utilized.")
+ if (length(seq_depth) < length(seq_depth_simu))
+ message("INFO: The length of the sequencing_depth vector is shorter than the number of samples. Values will be recycled.")
+
+ scalingDepth_factor <- suppressWarnings(seq_depth/seq_depth_simu)
+ counts_scaled <- as.data.frame(sweep(as.matrix(countsTable), 2, scalingDepth_factor, "*"))
+ return(counts_scaled)
+}
+
+
+
+
diff --git a/R/setcorrelation.R b/R/setcorrelation.R
new file mode 100644
index 0000000000000000000000000000000000000000..34a837713c97548867df28c45d4f77f558dce072
--- /dev/null
+++ b/R/setcorrelation.R
@@ -0,0 +1,103 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+#' Compute Covariation from Correlation and Standard Deviations
+#'
+#' This function computes the covariation between two variables (A and B) given their correlation and standard deviations.
+#'
+#' @param corr_AB The correlation coefficient between variables A and B.
+#' @param sd_A The standard deviation of variable A.
+#' @param sd_B The standard deviation of variable B.
+#'
+#' @return The covariation between variables A and B.
+#' @export
+#' @examples
+#' corr <- 0.7
+#' sd_A <- 3
+#' sd_B <- 4
+#' compute_covariation(corr, sd_A, sd_B)
+compute_covariation <- function(corr_AB, sd_A, sd_B) {
+ cov_AB <- corr_AB * sd_A * sd_B
+ return(cov_AB)
+}
+
+
+#' Get Standard Deviations for Variables in Correlation
+#'
+#' This function extracts the standard deviations for the variables involved in the correlation.
+#'
+#' @param list_var A list containing the variables and their attributes.
+#' @param between_var A character vector containing the names of the variables involved in the correlation.
+#'
+#' @return A numeric vector containing the standard deviations for the variables in the correlation.
+#' @export
+#' @examples
+#' list_var <- init_variable(name = "varA", mu = 0, sd = 5, level = 3) %>%
+#' init_variable(name = "varB", mu = 0, sd = 25, level = 3)
+#' between_var <- c("varA", "varB")
+#' getStandardDeviationInCorrelation(list_var, between_var)
+getStandardDeviationInCorrelation <- function(list_var, between_var){
+ for (var in between_var) sd_List <- getGivenAttribute(list_var, "sd")
+ for (var in between_var) sd_ListFromInteraction <- getGivenAttribute(list_var$interactions, "sd")
+ sd_List <- c(sd_List, sd_ListFromInteraction)
+ return(unname(unlist(sd_List[between_var])))
+}
+
+
+
+#' Set Correlation between Variables
+#'
+#' Set the correlation between two or more variables in a simulation.
+#'
+#' @param list_var A list containing the variables used in the simulation, initialized using \code{\link{init_variable}}.
+#' @param between_var Character vector specifying the names of the variables to set the correlation between.
+#' @param corr Numeric value specifying the desired correlation between the variables.
+#'
+#' @return Updated \code{list_var} with the specified correlation set between the variables.
+#'
+#' @details The function checks if the variables specified in \code{between_var} are declared and initialized in the \code{list_var}. It also ensures that at least two variables with provided standard deviation are required to set a correlation in the simulation.
+#' The specified correlation value must be within the range (-1, 1). The function computes the corresponding covariance between the variables based on the specified correlation and standard deviations.
+#' The correlation information is then added to the \code{list_var} in the form of a data frame containing the correlation value and the corresponding covariance value.
+#' @export
+#' @examples
+#' list_var <- init_variable(name = "varA", mu = 0, sd = 5, level = 3) %>%
+#' init_variable(name = "varB", mu = 0, sd = 25, level = 3)
+#' list_var <- set_correlation(list_var, between_var = c("varA", "varB"), corr = 0.7)
+set_correlation <- function(list_var, between_var, corr) {
+
+ # Check if variables in between_var are declared and initialized
+ bool_checkBetweenVarValidity <- function(between_var, list_var) {
+ nb_varInCorrelation <- length(unique(between_var))
+ stopifnot(nb_varInCorrelation > 1)
+ # -- check also for interaction
+ varInitialized <- c(getListVar(list_var), getListVar(list_var$interactions))
+ existingVar_nb <- varInitialized %in% between_var %>% sum()
+ if (existingVar_nb != nb_varInCorrelation) {
+ return(FALSE)
+ } else {
+ return(TRUE)
+ }
+ }
+
+ name_correlation <- paste(between_var, collapse = ".")
+ bool_valid_corr <- bool_checkBetweenVarValidity(between_var, list_var)
+ if (!bool_valid_corr) {
+ stop("At least one variable in between_var is not declared. Variable not initialized cannot be used in a correlation.")
+ }
+
+ vec_standardDev <- getStandardDeviationInCorrelation(list_var, between_var)
+ if (length(vec_standardDev) < 2) {
+ stop("Exactly two variables with provided standard deviation are required to set a correlation in simulation.")
+ }
+ # Validate the specified correlation value to be within the range [-1, 1]
+ if (corr < -1 || corr > 1) {
+ stop("Invalid correlation value. Correlation must be in the range [-1, 1].")
+ }
+
+ name_interaction <- paste(between_var, collapse = ":")
+ corr <- data.frame(cor = corr, covar = compute_covariation(corr, vec_standardDev[1], vec_standardDev[2] ))
+ list_var$correlations[[name_correlation]] <- corr
+ return(list_var)
+}
+
+
diff --git a/R/simulation.R b/R/simulation.R
new file mode 100644
index 0000000000000000000000000000000000000000..b1a736a3ae64f5fe2b4431399c8332a46d75dffc
--- /dev/null
+++ b/R/simulation.R
@@ -0,0 +1,170 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+#' Get input for simulation based on coefficients
+#'
+#' This function generates input data for simulation based on the coefficients provided in the \code{list_var} argument.
+#'
+#' @param list_var A list of variables (already initialized)
+#' @param n_genes Number of genes to simulate (default: 1)
+#' @param input2mvrnorm Input to the \code{mvrnorm} function for simulating data from multivariate normal distribution (default: NULL)
+#' @return A data frame with input coefficients for simulation
+#' @export
+#' @examples
+#' # Example usage
+#' list_var <- init_variable()
+#' getInput2simulation(list_var, n_genes = 10)
+getInput2simulation <- function(list_var, n_genes = 1, input2mvrnorm = NULL) {
+
+ # Use default input to mvrnorm if not provided by the user
+ if (is.null(input2mvrnorm)) input2mvrnorm = getInput2mvrnorm(list_var)
+
+ l_dataFromMvrnorm = getDataFromMvrnorm(list_var, input2mvrnorm, n_genes)
+ l_dataFromUser = getDataFromUser(list_var)
+ df_input2simu <- getCoefficients(list_var, l_dataFromMvrnorm, l_dataFromUser, n_genes)
+ return(df_input2simu)
+}
+
+#' getCoefficients
+#'
+#' Get the coefficients.
+#'
+#' @param list_var A list of variables (already initialized)
+#' @param l_dataFromMvrnorm Data from the `getGeneMetadata` function (optional).
+#' @param l_dataFromUser Data from the `getDataFromUser` function (optional).
+#' @param n_genes The number of genes.
+#' @export
+#' @return A dataframe containing the coefficients.
+#' @examples
+#' # Example usage
+#' list_var <- init_variable()
+#' input2mvrnorm = getInput2mvrnorm(list_var)
+#' l_dataFromMvrnorm = getDataFromMvrnorm(list_var, input2mvrnorm, n_genes)
+#' l_dataFromUser = getDataFromUser(list_var)
+#' getCoefficients(list_var, l_dataFromMvrnorm, l_dataFromUser, n_genes = 3)
+getCoefficients <- function(list_var, l_dataFromMvrnorm, l_dataFromUser, n_genes) {
+ if (length(l_dataFromMvrnorm) == 0) {
+ metaData <- getGeneMetadata(list_var, n_genes)
+ l_dataFromMvrnorm <- list(metaData)
+ }
+ l_df2join <- c(l_dataFromMvrnorm, l_dataFromUser)
+
+
+ df_coef <- Reduce(function(d1, d2){ column_names = colnames(d2)
+ idx_key = grepl(pattern = "label", column_names )
+ keys = column_names[idx_key]
+ join_dtf(d1, d2, k1 = keys , k2 = keys)
+ }
+ , l_df2join ) %>% as.data.frame()
+ column_names <- colnames(df_coef)
+ idx_column2factor <- grep(pattern = "label_", column_names)
+
+ if (length(idx_column2factor) > 1) {
+ df_coef[, idx_column2factor] <- lapply(df_coef[, idx_column2factor], as.factor)
+ } else {
+ df_coef[, idx_column2factor] <- as.factor(df_coef[, idx_column2factor])
+ }
+
+ return(df_coef)
+}
+
+
+#' Get the log_qij values from the coefficient data frame.
+#'
+#' @param dtf_coef The coefficient data frame.
+#' @return The coefficient data frame with log_qij column added.
+#' @export
+getLog_qij <- function(dtf_coef) {
+ dtf_beta_numeric <- dtf_coef[sapply(dtf_coef, is.numeric)]
+ dtf_coef$log_qij <- rowSums(dtf_beta_numeric, na.rm = TRUE)
+ return(dtf_coef)
+}
+
+
+#' Calculate mu_ij values based on coefficient data frame and scaling factor
+#'
+#' This function calculates mu_ij values by raising 2 to the power of the log_qij values
+#' from the coefficient data frame and multiplying it by the provided scaling factor.
+#'
+#' @param dtf_coef Coefficient data frame containing the log_qij values
+#'
+#' @return Coefficient data frame with an additional mu_ij column
+#'
+#' @examples
+#' list_var <- init_variable()
+#' dtf_coef <- getInput2simulation(list_var, 10)
+#' dtf_coef <- getLog_qij(dtf_coef)
+#' dtf_coef <- addBasalExpression(dtf_coef, 10, c(10, 20, 0))
+#' getMu_ij(dtf_coef)
+#' @export
+getMu_ij <- function(dtf_coef) {
+ log_qij_scaled <- dtf_coef$log_qij + dtf_coef$basalExpr
+ dtf_coef$log_qij_scaled <- log_qij_scaled
+ mu_ij <- exp(log_qij_scaled)
+ dtf_coef$mu_ij <- mu_ij
+ return(dtf_coef)
+}
+
+#' getMu_ij_matrix
+#'
+#' Get the Mu_ij matrix.
+#'
+#' @param dtf_coef A dataframe containing the coefficients.
+#' @importFrom reshape2 dcast
+#' @importFrom stats as.formula
+
+#' @export
+#' @return A Mu_ij matrix.
+getMu_ij_matrix <- function(dtf_coef) {
+ column_names <- colnames(dtf_coef)
+ idx_var <- grepl(pattern = "label", column_names)
+ l_var <- column_names[idx_var]
+ str_formula_rigth <- paste(l_var, collapse = " + ")
+ if (str_formula_rigth == "") stop("no variable label detected")
+ str_formula <- paste(c("geneID", str_formula_rigth), collapse = " ~ ")
+ formula <- stats::as.formula(str_formula)
+ dtf_Muij <- dtf_coef %>% reshape2::dcast(formula = formula, value.var = "mu_ij", drop = F)
+ dtf_Muij[is.na(dtf_Muij)] <- 0
+ mtx_Muij <- data.frame(dtf_Muij[, -1], row.names = dtf_Muij[, 1]) %>% as.matrix()
+ mtx_Muij <- mtx_Muij[, order(colnames(mtx_Muij)), drop = F]
+ return(mtx_Muij)
+}
+
+#' getSubCountsTable
+#'
+#' Get the subcounts table.
+#'
+#' @param matx_Muij The Mu_ij matrix.
+#' @param matx_dispersion The dispersion matrix.
+#' @param replicateID The replication identifier.
+#' @param l_bool_replication A boolean vector indicating the replicates.
+#' @importFrom stats rnbinom
+#'
+#' @return A subcounts table.
+getSubCountsTable <- function(matx_Muij, matx_dispersion, replicateID, l_bool_replication) {
+ getKijMatrix <- function(matx_Muij, matx_dispersion, n_genes, n_samples) {
+ k_ij <- stats::rnbinom(n_genes * n_samples,
+ size = matx_dispersion,
+ mu = matx_Muij) %>%
+ matrix(nrow = n_genes, ncol = n_samples)
+
+ k_ij[is.na(k_ij)] <- 0
+ return(k_ij)
+ }
+
+ if (!any(l_bool_replication))
+ return(NULL)
+
+ matx_Muij <- matx_Muij[, l_bool_replication, drop = FALSE]
+ matx_dispersion <- matx_dispersion[, l_bool_replication, drop = FALSE]
+ l_sampleID <- colnames(matx_Muij)
+ l_geneID <- rownames(matx_Muij)
+ dimension_mtx <- dim(matx_Muij)
+ n_genes <- dimension_mtx[1]
+ n_samples <- dimension_mtx[2]
+ matx_kij <- getKijMatrix(matx_Muij, matx_dispersion, n_genes, n_samples)
+ colnames(matx_kij) <- paste(l_sampleID, replicateID, sep = "_")
+ rownames(matx_kij) <- l_geneID
+ return(matx_kij)
+}
+
+
diff --git a/R/simulation2.R b/R/simulation2.R
new file mode 100644
index 0000000000000000000000000000000000000000..7b5abfc8562e44c9c69825ea0ae5f1ef8ee7c617
--- /dev/null
+++ b/R/simulation2.R
@@ -0,0 +1,170 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+#' getReplicationMatrix
+#'
+#' @param minN Minimum number of replicates for each sample
+#' @param maxN Maximum number of replicates for each sample
+#' @param n_samples Number of samples
+#' @export
+#' @return A replication matrix indicating which samples are replicated
+getReplicationMatrix <- function(minN, maxN, n_samples) {
+
+ # Create a list of logical vectors representing the minimum number of replicates
+ l_replication_minimum = lapply(1:n_samples,
+ FUN = function(i) rep(TRUE, times = minN) )
+
+ # Create a list of random logical vectors representing additional replicates
+ l_replication_random = lapply(1:n_samples,
+ FUN = function(i) sample(x = c(TRUE, FALSE), size = maxN-minN, replace = T) )
+
+ # Combine the replication vectors into matrices
+ matx_replication_minimum <- do.call(cbind, l_replication_minimum)
+ matx_replication_random <- do.call(cbind, l_replication_random)
+
+ # Combine the minimum replicates and random replicates into a single matrix
+ matx_replication <- rbind(matx_replication_minimum, matx_replication_random)
+
+ # Sort the columns of the replication matrix in descending order
+ matx_replication = apply(matx_replication, 2, sort, decreasing = TRUE ) %>% matrix(nrow = maxN)
+
+ return(matx_replication)
+}
+
+#' getCountsTable
+#'
+#' @param matx_Muij Matrix of mean expression values for each gene and sample
+#' @param matx_dispersion Matrix of dispersion values for each gene and sample
+#' @param matx_bool_replication Replication matrix indicating which samples are replicated
+#'
+#' @return A counts table containing simulated read counts for each gene and sample
+getCountsTable <- function(matx_Muij , matx_dispersion, matx_bool_replication ){
+ max_replicates <- dim(matx_bool_replication)[1]
+
+ # Apply the getSubCountsTable function to each row of the replication matrix
+ l_countsTable = lapply(1:max_replicates, function(i) getSubCountsTable(matx_Muij , matx_dispersion, i, matx_bool_replication[i,] ))
+
+ # Combine the counts tables into a single matrix
+ countsTable = do.call(cbind, l_countsTable)
+
+ return(countsTable %>% as.data.frame())
+}
+
+#' getDispersionMatrix
+#'
+#' @param list_var A list of variables (already initialized)
+#' @param n_genes Number of genes
+#' @param dispersion Vector of dispersion values for each gene
+#' @export
+#'
+#' @return A matrix of dispersion values for each gene and sample
+getDispersionMatrix <- function(list_var, n_genes, dispersion = stats::runif(n_genes, min = 0, max = 1000)){
+ l_geneID = base::paste("gene", 1:n_genes, sep = "")
+ l_sampleID = getSampleID(list_var)
+ n_samples = length(l_sampleID)
+ l_dispersion <- dispersion
+
+ # Create a data frame for the dispersion values
+ dtf_dispersion = list(dispersion = l_dispersion) %>% as.data.frame()
+ dtf_dispersion <- dtf_dispersion[, rep("dispersion", n_samples)]
+ rownames(dtf_dispersion) = l_geneID
+ colnames(dtf_dispersion) = l_sampleID
+
+ matx_dispersion = dtf_dispersion %>% as.matrix()
+
+ return(matx_dispersion)
+}
+
+
+
+
+
+#' Replicate rows of a data frame by group
+#'
+#' Replicates the rows of a data frame based on a grouping variable and replication counts for each group.
+#'
+#' @param df Data frame to replicate
+#' @param group_var Name of the grouping variable in the data frame
+#' @param rep_list Vector of replication counts for each group
+#' @return Data frame with replicated rows
+#' @examples
+#' df <- data.frame(group = c("A", "B"), value = c(1, 2))
+#' .replicateByGroup(df, "group", c(2, 3))
+#'
+#' @export
+.replicateByGroup <- function(df, group_var, rep_list) {
+ l_group_var <- df[[group_var]]
+ group_levels <- unique(l_group_var)
+ names(rep_list) <- group_levels
+ group_indices <- rep_list[l_group_var]
+ replicated_indices <- rep(seq_len(nrow(df)), times = group_indices)
+ replicated_df <- df[replicated_indices, ]
+ suffix_sampleID <- sequence(group_indices)
+ replicated_df[["sampleID"]] <- paste(replicated_df[["sampleID"]], suffix_sampleID, sep = "_")
+ rownames(replicated_df) <- NULL
+ return(replicated_df)
+}
+
+
+
+#' Replicate rows of a data frame
+#'
+#' Replicates the rows of a data frame by a specified factor.
+#'
+#' @param df Data frame to replicate
+#' @param n Replication factor for each row
+#' @return Data frame with replicated rows
+#' @export
+#' @examples
+#' df <- data.frame(a = 1:3, b = letters[1:3])
+#' .replicateRows(df, 2)
+#'
+.replicateRows <- function(df, n) {
+ indices <- rep(seq_len(nrow(df)), each = n)
+ replicated_df <- df[indices, , drop = FALSE]
+ rownames(replicated_df) <- NULL
+ return(replicated_df)
+}
+
+#' Get sample metadata
+#'
+#' Generates sample metadata based on the input variables, replication matrix, and number of genes.
+#'
+#' @param list_var A list of variables (already initialized)
+#' @param replicationMatrix Replication matrix
+#' @param n_genes Number of genes
+#' @return Data frame of sample metadata
+#' @importFrom data.table setorderv
+#' @export
+#' @examples
+#' list_var <- init_variable()
+#' n_genes <- 10
+#' replicationMatrix <- generateReplicationMatrix(list_var ,2, 3)
+#' getSampleMetadata(list_var, n_genes, replicationMatrix)
+getSampleMetadata <- function(list_var, n_genes, replicationMatrix) {
+ l_sampleIDs = getSampleID(list_var)
+ metaData <- generateGridCombination_fromListVar(list_var)
+ metaData[] <- lapply(metaData, as.character) ## before reordering
+ data.table::setorderv(metaData, cols = colnames(metaData))
+ metaData[] <- lapply(metaData, as.factor)
+ metaData$sampleID <- l_sampleIDs
+ rep_list <- colSums(replicationMatrix)
+ metaData$sampleID <- as.character(metaData$sampleID) ## before replicating
+ sampleMetadata <- .replicateByGroup(metaData, "sampleID", rep_list)
+ colnames(sampleMetadata) <- gsub("label_", "", colnames(sampleMetadata))
+ return(sampleMetadata)
+}
+
+
+#' getSampleID
+#'
+#' @param list_var A list of variables (already initialized)
+#' @export
+#' @return A sorted vector of sample IDs
+getSampleID <- function(list_var){
+ gridCombination <- generateGridCombination_fromListVar(list_var)
+ l_sampleID <- apply( gridCombination , 1 , paste , collapse = "_" ) %>% unname()
+ return(sort(l_sampleID))
+}
+
+
diff --git a/R/simulation_initialization.R b/R/simulation_initialization.R
new file mode 100644
index 0000000000000000000000000000000000000000..9e0a068e5e651b840f9f96eb7ce7104ad1203b4e
--- /dev/null
+++ b/R/simulation_initialization.R
@@ -0,0 +1,392 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+#' Initialize variable
+#'
+#' @param list_var Either c() or output of init_variable
+#' @param name Variable name
+#' @param mu Either a numeric value or a numeric vector (of length = level)
+#' @param sd Either numeric value or NA
+#' @param level Numeric value to specify the number of levels to simulate
+#'
+#' @return
+#' A list with initialized variables
+#' @export
+#'
+#' @examples
+#' init_variable(name = "my_varA", mu = 2, sd = 9, level = 200)
+init_variable <- function(list_var = c(), name = "myVariable", mu = c(2,3), sd = NA, level = NA) {
+
+ name <- clean_variable_name(name)
+
+ # Only mu specified by user => set level param
+ if (is.na(level) && is.na(sd)) {
+ level <- length(mu)
+ }
+
+ # Validate inputs
+ inputs_checking(list_var, name, mu, sd, level)
+
+ if (endsWithDigit(name)) {
+ warning("Names ending with digits are not allowed. They will be removed from the variable name.")
+ name <- removeDigitsAtEnd(name)
+ }
+
+ # Initialize new variable
+ list_var[[name]] <- fillInVariable(name, mu, sd, level)
+
+ return(list_var)
+}
+
+
+
+#' Check if a string ends with a digit
+#'
+#' This function checks whether a given string ends with a digit.
+#'
+#' @param string The input string to be checked
+#' @return \code{TRUE} if the string ends with a digit, \code{FALSE} otherwise
+#' @export
+#' @examples
+#' endsWithDigit("abc123") # Output: TRUE
+#' endsWithDigit("xyz") # Output: FALSE
+endsWithDigit <- function(string) {
+ lastChar <- substring(string, nchar(string))
+ return(grepl("[0-9]", lastChar))
+}
+
+#' Remove digits at the end of a string
+#'
+#' This function removes any digits occurring at the end of a given string.
+#'
+#' @param string The input string from which digits are to be removed
+#' @return The modified string with digits removed from the end
+#' @export
+#' @examples
+#' removeDigitsAtEnd("abc123") # Output: "abc"
+#' removeDigitsAtEnd("xyz") # Output: "xyz"
+removeDigitsAtEnd <- function(string) {
+ return(gsub("\\d+$", "", string))
+}
+
+
+#' Check Input Parameters
+#'
+#' This function checks the validity of the input parameters for initializing a variable.
+#' It ensures that the necessary conditions are met for the input parameters.
+#'
+#' @param list_var List containing the variables to be initialized.
+#' @param name Name of the variable.
+#' @param mu Mean of the variable.
+#' @param sd Standard deviation of the variable (optional).
+#' @param level Number of levels for categorical variables.
+#'
+#' @return NULL
+#' @export
+#'
+#' @examples
+#' inputs_checking(list_var = c(), name = "var1", mu = 0, sd = 1, level = 2)
+inputs_checking <- function(list_var, name, mu, sd, level) {
+ stopifnot(name != "")
+ stopifnot(is.character(name))
+ stopifnot(is.numeric(mu))
+ stopifnot(is.numeric(sd) | is.na(sd))
+ stopifnot(is.numeric(level))
+ stopifnot(length(level) == 1)
+ stopifnot(level >= 2)
+
+ if (!is.null(list_var)) {
+ error_msg <- "Non conformable list_var parameter.\nlist_var must be set as an init_var output or initialized as c()"
+ if (!is.list(list_var)) {
+ stop(error_msg)
+ }
+ }
+
+ if (length(mu) > 1) {
+ stopifnot(length(mu) == level)
+ }
+
+ if (is.na(sd)) {
+ if (level != length(mu)) {
+ stop("sd was specified as NA. mu should have the same length as the number of levels\n")
+ }
+ }
+
+ # Check if variable is already initialized
+ name_not_in_list_var <- identical(which(already_init_variable(list_var, name)), integer(0))
+ if (!name_not_in_list_var) {
+ message(paste(name, "is already initialized in list_var.\nIt will be updated", sep = " "))
+ }
+
+ return(NULL)
+}
+
+
+#' Check if Variable is Already Initialized
+#'
+#' This function checks if a variable is already initialized in the variable list.
+#'
+#' @param list_var A list object representing the variable list.
+#' @param new_var_name A character string specifying the name of the new variable.
+#'
+#' @return TRUE if the variable is already initialized, FALSE otherwise.
+#' @export
+#'
+#' @examples
+#' my_list <- list(var1 = 1, var2 = 2, var3 = 3)
+#' already_initialized <- already_init_variable(list_var = my_list, new_var_name = "myVariable")
+already_init_variable <- function(list_var, new_var_name) {
+ if (is.null(list_var)) {
+ return(FALSE)
+ }
+
+ var_names <- names(list_var)
+ return(new_var_name %in% var_names)
+}
+
+#' Fill in Variable
+#'
+#' This function fills in a variable with simulated data based on the provided parameters.
+#'
+#' @param name The name of the variable.
+#' @param mu A numeric value or a numeric vector (of length = level) representing the mean.
+#' @param sd A numeric value representing the standard deviation, or NA if not applicable.
+#' @param level A numeric value specifying the number of levels to simulate.
+#'
+#' @return A data frame or a list containing the simulated data for the variable.
+#' @export
+#'
+#' @examples
+#' variable_data <- fillInVariable(name = "myVariable", mu = c(2, 3), sd = NA, level = 2)
+fillInVariable <- function(name, mu, sd, level) {
+
+ if (length(mu) > 1 | is.na(sd)) { # Effects given by user
+ level <- length(mu)
+ l_labels <- paste(name, 1:level, sep = '')
+ l_betaEffects <- mu
+ column_names <- c(paste("label", name, sep = "_"), name)
+ sub_obj <- build_sub_obj_return_to_user(level, metaData = l_labels,
+ effectsGivenByUser = l_betaEffects,
+ column_names)
+ } else {
+ sub_obj <- as.data.frame(list(mu = mu, sd = sd, level = level))
+ }
+
+ return(sub_obj)
+}
+
+#' Build Sub Object to Return to User
+#'
+#' This function builds the sub-object to be returned to the user.
+#'
+#' @param level A numeric value specifying the number of levels.
+#' @param metaData A list of labels.
+#' @param effectsGivenByUser A list of effects given by the user.
+#' @param col_names A character vector specifying the column names to use.
+#' @importFrom utils tail
+#'
+#' @return A list with the sub-object details.
+build_sub_obj_return_to_user <- function(level, metaData, effectsGivenByUser, col_names) {
+ sub_obj <- list(level = level)
+ data <- cbind(metaData, effectsGivenByUser) %>% as.data.frame()
+ colnames(data) <- col_names
+ var_name <- utils::tail(col_names, n = 1)
+ data[, var_name] <- as.numeric(data[, var_name])
+ sub_obj$data <- data
+ return(sub_obj)
+}
+
+
+#' Add interaction
+#'
+#' @param list_var A list of variables (already initialized)
+#' @param between_var A vector of variable names to include in the interaction
+#' @param mu Either a numeric value or a numeric vector (of length = level)
+#' @param sd Either numeric value or NA
+#'
+#' @return
+#' A list with initialized interaction
+#' @export
+#'
+#' @examples
+#' init_variable(name = "myvarA", mu = 2, sd = 3, level = 200) %>%
+#' init_variable(name = "myvarB", mu = 1, sd = 0.2, level = 2 ) %>%
+#' add_interaction(between_var = c("myvarA", "myvarB"), mu = 3, sd = 2)
+add_interaction <- function(list_var, between_var, mu, sd = NA) {
+ name_interaction <- paste(between_var, collapse = ":")
+ check_input2interaction(name_interaction, list_var, between_var, mu, sd)
+
+ # Check the number of variables in the interaction
+ if (length(between_var) > 3) {
+ stop("Cannot initialize an interaction with more than 3 variables.")
+ }
+
+ interactionCombinations <- getNumberOfCombinationsInInteraction(list_var, between_var)
+ list_var$interactions[[name_interaction]] <- fillInInteraction(list_var, between_var, mu, sd, interactionCombinations)
+ return(list_var)
+}
+
+#' Check input for interaction
+#'
+#' @param name_interaction String specifying the name of the interaction (example: "varA:varB")
+#' @param list_var A list of variables (already initialized)
+#' @param between_var A vector of variable names to include in the interaction
+#' @param mu Either a numeric value or a numeric vector (of length = level)
+#' @param sd Either numeric value or NA
+#'
+#' @return
+#' NULL (throws an error if the input is invalid)
+#' @export
+check_input2interaction <- function(name_interaction, list_var, between_var, mu, sd) {
+ # Check if variables in between_var are declared and initialized
+ bool_checkInteractionValidity <- function(between_var, list_var) {
+ nb_varInInteraction <- length(unique(between_var))
+ stopifnot(nb_varInInteraction > 1)
+ existingVar_nb <- getListVar(list_var) %in% between_var %>% sum()
+ if (existingVar_nb != nb_varInInteraction) {
+ return(FALSE)
+ } else {
+ return(TRUE)
+ }
+ }
+
+ bool_valid_interaction <- bool_checkInteractionValidity(between_var, list_var)
+ if (!bool_valid_interaction) {
+ stop("At least one variable in between_var is not declared. Variable not initialized cannot be used in an interaction.")
+ }
+
+ requestedNumberOfValues <- getNumberOfCombinationsInInteraction(list_var, between_var)
+ if (is.na(sd) && requestedNumberOfValues != length(mu)) {
+ msg_e <- "sd was specified as NA. mu should have the same length as the possible number of interactions:\n"
+ msg_e2 <- paste(requestedNumberOfValues, "interaction values are requested.")
+ stop(paste(msg_e, msg_e2))
+ }
+
+ level <- requestedNumberOfValues
+ inputs_checking(list_var$interactions, name_interaction, mu, sd, level)
+}
+
+#' Get the number of combinations in an interaction
+#'
+#' @param list_var A list of variables (already initialized)
+#' @param between A vector of variable names to include in the interaction
+#'
+#' @return
+#' The number of combinations in the interaction
+#' @export
+getNumberOfCombinationsInInteraction <- function(list_var, between) {
+ levelInlistVar <- getGivenAttribute(list_var, "level") %>% unlist()
+ n_combinations <- prod(levelInlistVar[between])
+ return(n_combinations)
+}
+
+#' getGridCombination
+#'
+#' Generates all possible combinations of labels.
+#'
+#' @param l_labels List of label vectors
+#'
+#' @return A data frame with all possible combinations of labels
+#' @export
+#'
+#' @examples
+#' l_labels <- list(
+#' c("A", "B", "C"),
+#' c("X", "Y")
+#' )
+#' getGridCombination(l_labels)
+getGridCombination <- function(l_labels) {
+ grid <- expand.grid(l_labels)
+ colnames(grid) <- paste("label", seq_along(l_labels), sep = "_")
+ return(grid)
+}
+
+
+
+#' Get grid combination from list_var
+#'
+#' @param list_var A list of variables (already initialized)
+#'
+#' @return
+#' The grid combination between variable in list_var
+#' @export
+generateGridCombination_fromListVar <- function (list_var){
+ l_levels <- getGivenAttribute(list_var, "level") %>% unlist()
+ vars <- names(l_levels)
+ l_levels <- l_levels[vars]
+ l_labels <- getLabels(l_variables2labelized = vars, l_nb_label = l_levels)
+ gridComb <- getGridCombination(l_labels)
+ colnames(gridComb) <- paste("label", vars, sep = "_")
+ return(gridComb)
+}
+
+
+#' Fill in interaction
+#'
+#' @param list_var A list of variables (already initialized)
+#' @param between A vector of variable names to include in the interaction
+#' @param mu Either a numeric value or a numeric vector (of length = level)
+#' @param sd Either numeric value or NA
+#' @param level Number of interactions
+#'
+#' @return
+#' A data frame with the filled-in interaction values
+#' @export
+fillInInteraction <- function(list_var, between, mu, sd, level) {
+ if (length(mu) > 1 || is.na(sd)) {
+ l_levels <- getGivenAttribute(list_var, "level") %>% unlist()
+ l_levelsOfInterest <- l_levels[between]
+ l_labels_varOfInterest <- getLabels(l_variables2labelized = between, l_nb_label = l_levelsOfInterest )
+
+ grid_combination <- getGridCombination(l_labels_varOfInterest)
+ n_combinations <- dim(grid_combination)[1]
+ column_names <- c(paste("label", between, sep = "_"), paste(between, collapse = ":"))
+ sub_dtf <- build_sub_obj_return_to_user(level = n_combinations,
+ metaData = grid_combination,
+ effectsGivenByUser = mu,
+ col_names = column_names)
+ } else {
+ sub_dtf <- list(mu = mu, sd = sd, level = level) %>% as.data.frame()
+ }
+
+ return(sub_dtf)
+}
+
+#' Get the list of variable names
+#'
+#' @param input R list, e.g., output of init_variable
+#'
+#' @return
+#' A character vector with the names of variables
+getListVar <- function(input) attributes(input)$names
+
+#' Get a given attribute from a list of variables
+#'
+#' @param list_var A list of variables (already initialized)
+#' @param attribute A string specifying the attribute to retrieve in all occurrences of the list
+#'
+#' @return
+#' A list without NULL values
+getGivenAttribute <- function(list_var, attribute) {
+ l <- lapply(list_var, FUN = function(var) var[[attribute]])
+ l_withoutNull <- l[!vapply(l, is.null, logical(1))]
+ return(l_withoutNull)
+}
+
+
+#' Get labels for variables
+#'
+#' @param l_variables2labelized A list of variables
+#' @param l_nb_label A list of numeric values representing the number of levels per variable
+#'
+#' @return
+#' A list of labels per variable
+getLabels <- function(l_variables2labelized, l_nb_label) {
+ getVarNameLabel <- function(name, level) {
+ list_label <- paste(name, 1:level, sep = "")
+ return(list_label)
+ }
+
+ listLabels <- Map(getVarNameLabel, l_variables2labelized, l_nb_label)
+ return(listLabels)
+}
+
diff --git a/R/simulationreport.R b/R/simulationreport.R
new file mode 100644
index 0000000000000000000000000000000000000000..3200568615d7ae2e116249152ba31f9004c6c36f
--- /dev/null
+++ b/R/simulationreport.R
@@ -0,0 +1,135 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+#' Export the Analysis Report to a File
+#'
+#' This function generates an analysis report by arranging and combining various plots
+#' and tables, and then exports the report to a specified file.
+#'
+#' @param report_file Path to the file where the report will be exported.
+#' @param table_settings A table containing settings and parameters used in the analysis.
+#' @param roc_curve A plot displaying the Receiver Operating Characteristic (ROC) curve.
+#' @param dispersion_plot A plot displaying the dispersion values.
+#' @param id_plot A plot displaying unique identifiers.
+#' @param counts_plot A plot displaying the gene counts.
+#'
+#'
+#' @importFrom gridExtra arrangeGrob grid.arrange
+#' @importFrom ggplot2 ggsave
+#'
+#'
+#' @return report
+#' @export
+exportReportFile <- function(report_file, table_settings, roc_curve, dispersion_plot, id_plot, counts_plot){
+
+ middle_part <- gridExtra::arrangeGrob(counts_plot, dispersion_plot, heights = c(1, 1.5))
+ left_part <- gridExtra::arrangeGrob(table_settings, roc_curve ,heights = c(1, 1.5))
+ p2export <- gridExtra::grid.arrange(left_part, middle_part, id_plot ,ncol = 3, widths = c(1,1,2))
+
+ 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)
+}
+
+
+#' Generate a simulation report
+#'
+#' This function generates a simulation report containing various plots and evaluation metrics.
+#'
+#' @param mock_obj A list containing simulation data and ground truth.
+#' @param list_tmb A list of model results.
+#' @param dds_obj a DESeq2 object
+#' @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.
+#' @importFrom ggplot2 aes geom_point geom_abline facet_wrap theme_bw ggtitle
+#' @return A list containing settings, plots, and evaluation results.
+#' @export
+simulationReport <- function(mock_obj, list_tmb = NULL, dds_obj = NULL ,
+ coeff_threshold = 0, alt_hypothesis = "greaterAbs", report_file = 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 <- extractTMBDispersion(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 <- wrapper_DESeq2(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 <- extractDESeqDispersion(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 <- color2use[c(!is.null(list_tmb), !is.null(dds_obj))]
+
+ # -- plotting
+ roc_curve <- roc_plot(comparison_df, col = "from" ) + ggplot2::scale_color_manual(values = color2use)
+ id_plot <- identity_plot(comparison_df, col = "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)
+}
+
diff --git a/R/subsetgenes.R b/R/subsetgenes.R
new file mode 100644
index 0000000000000000000000000000000000000000..af6dd190b9748bb45a5f515ba16c4559ced27fe4
--- /dev/null
+++ b/R/subsetgenes.R
@@ -0,0 +1,54 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+#' Subset Genes in Genomic Data
+#'
+#' This function filters and adjusts genomic data within the Roxygeb project, based on a specified list of genes.
+# It is designed to enhance precision and customization in transcriptomics analysis by retaining only the genes of interest.
+#
+#' @param l_genes A character vector specifying the genes to be retained in the dataset.
+#' @param mockObj An object containing relevant genomic information to be filtered.
+#'
+#' @return A modified version of the 'mockObj' data object, with genes filtered according to 'l_genes'.
+#'
+#' @description The 'subsetGenes' function selects and retains genes from 'mockObj' that match the genes specified in 'l_genes'.
+# It filters the 'groundTruth$effects' data to keep only the rows corresponding to the selected genes.
+# Additionally, it updates 'gene_dispersion' and the count data, ensuring that only the selected genes are retained.
+# The function also replaces the total number of genes in 'settings$values' with the length of 'l_genes'.
+# The result is a more focused and tailored genomic dataset, facilitating precision in subsequent analyses.
+#'
+#' @examples
+#' \dontrun{
+#' # Example list of genes to be retained
+#' selected_genes <- c("GeneA", "GeneB", "GeneC")
+#'
+#' # Example data object 'mockObj' (simplified structure)
+#' mockObj <- list(
+#' # ... (mockObj structure)
+#' )
+#'
+#' # Using the subsetGenes function to filter 'mockObj'
+#' filtered_mockObj <- subsetGenes(selected_genes, mockObj)
+#' }
+#' @export
+subsetGenes <- function(l_genes, mockObj) {
+ # Selects the indices of genes in 'groundTruth$effects$geneID' that are present in 'l_genes'.
+ idx_gt_effects <- mockObj$groundTruth$effects$geneID %in% l_genes
+
+ # Filters 'groundTruth$effects' to keep only the rows corresponding to the selected genes.
+ mockObj$groundTruth$effects <- mockObj$groundTruth$effects[idx_gt_effects, ]
+
+ # Updates 'gene_dispersion' by retaining values corresponding to the selected genes.
+ mockObj$groundTruth$gene_dispersion <- mockObj$groundTruth$gene_dispersion[l_genes]
+
+ # Filters the count data to keep only the rows corresponding to the selected genes.
+ mockObj$counts <- as.data.frame(mockObj$counts[l_genes, ])
+
+ # Replaces the total number of genes in 'settings$values' with the length of 'l_genes'.
+ mockObj$settings$values[1] <- length(l_genes)
+
+ # Returns the modified 'mockObj'.
+ return(mockObj)
+}
+
+
diff --git a/R/tidy_glmmtmb.R b/R/tidy_glmmtmb.R
new file mode 100644
index 0000000000000000000000000000000000000000..d262aa3dbfc986bf4a9edf23a801b0d66e5bf26f
--- /dev/null
+++ b/R/tidy_glmmtmb.R
@@ -0,0 +1,300 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+
+#' Extract Fixed Effects from a GLMMTMB Model Summary
+#'
+#' This function extracts fixed effects from the summary of a glmmTMB model.
+#'
+#' @param x A glmmTMB model object.
+#' @return A dataframe containing the fixed effects and their corresponding statistics.
+#' @export
+#' @examples
+#'
+#' model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length, data = iris)
+#' fixed_effects <- extract_fixed_effect(model)
+extract_fixed_effect <- function(x){
+ ss = summary(x)
+ as.data.frame(ss$coefficients$cond)
+ ss_reshaped <- lapply(ss$coefficients,
+ function(sub_obj){
+ if(is.null(sub_obj)) return(NULL)
+ sub_obj <- data.frame(sub_obj)
+ sub_obj$term <- removeDuplicatedWord(rownames(sub_obj))
+ rownames(sub_obj) <- NULL
+ sub_obj <- renameColumns(sub_obj)
+ sub_obj
+ }
+ )
+
+ ss_df <- do.call(rbind, ss_reshaped)
+ ss_df$component <- sapply(rownames(ss_df), function(x) strsplit(x, split = "[.]")[[1]][1])
+ ss_df$effect <- "fixed"
+ rownames(ss_df) <- NULL
+ ss_df
+}
+
+
+
+#' Extract Tidy Summary of glmmTMB Model
+#'
+#' This function extracts a tidy summary of the fixed and random effects from a glmmTMB model and binds them together in a data frame. Missing columns are filled with NA.
+#'
+#' @param glm_TMB A glmmTMB model object.
+#' @param ID An identifier to be included in the output data frame.
+#' @return A data frame containing a tidy summary of the fixed and random effects from the glmmTMB model.
+#' @export
+#' @examples
+#'
+#' model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length, data = iris)
+#' tidy_summary <- getTidyGlmmTMB(glm_TMB = model, ID = "Model1")
+getTidyGlmmTMB <- function(glm_TMB, ID){
+ if(is.null(glm_TMB)) return(NULL)
+ df1 <- extract_fixed_effect(glm_TMB)
+ df1 <- build_missingColumn_with_na(df1)
+ df2 <- extract_ran_pars(glm_TMB)
+ df2 <- build_missingColumn_with_na(df2)
+ df_2ret <- rbind(df1, df2)
+ df_2ret[df_2ret == "NaN"] <- NA
+ df_2ret <- df_2ret[rowSums(!is.na(df_2ret)) > 0, ] # drop rows full of NA
+ df_2ret$ID <- ID
+ df_2ret <- reorderColumns(df_2ret,
+ c("ID","effect", "component", "group", "term",
+ "estimate", "std.error", "statistic", "p.value"))
+ return(df_2ret)
+}
+
+
+
+#' Extract Tidy Summary of Multiple glmmTMB Models
+#'
+#' This function takes a list of glmmTMB models and extracts a tidy summary of the fixed and random effects from each model. It then combines the results into a single data frame.
+#'
+#' @param l_tmb A list of glmmTMB model objects.
+#' @return A data frame containing a tidy summary of the fixed and random effects from all glmmTMB models in the list.
+#' @export
+#' @examples
+#' model1 <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length + (1 | Species), data = iris)
+#' model2 <- glmmTMB::glmmTMB(Petal.Length ~ Sepal.Length + Sepal.Width + (1 | Species), data = iris)
+#' model_list <- list(Model1 = model1, Model2 = model2)
+#' tidy_summary <- tidy_tmb(model_list)
+tidy_tmb <- function(l_tmb){
+ if (identical(class(l_tmb), "glmmTMB")) return(getTidyGlmmTMB(l_tmb, "glmmTMB"))
+ attributes(l_tmb)$names
+ l_tidyRes <- lapply(attributes(l_tmb)$names,
+ function(ID)
+ {
+ glm_TMB <- l_tmb[[ID]]
+ getTidyGlmmTMB(glm_TMB, ID)
+ }
+ )
+ ret <- do.call("rbind", l_tidyRes)
+ return(ret)
+}
+
+
+#' Build DataFrame with Missing Columns and NA Values
+#'
+#' This function takes a DataFrame and a list of column names and adds missing columns with NA values to the DataFrame.
+#'
+#' @param df The input DataFrame.
+#' @param l_columns A character vector specifying the column names to be present in the DataFrame.
+#' @return A DataFrame with missing columns added and filled with NA values.
+#' @export
+#' @examples
+#'
+#' df <- data.frame(effect = "fixed", term = "Sepal.Length", estimate = 0.7)
+#' df_with_na <- build_missingColumn_with_na(df)
+build_missingColumn_with_na <- function(df, l_columns = c("effect", "component", "group",
+ "term", "estimate", "std.error", "statistic", "p.value")) {
+ df_missing_cols <- setdiff(l_columns, colnames(df))
+ # Ajouter les colonnes manquantes à df1
+ if (length(df_missing_cols) > 0) {
+ for (col in df_missing_cols) {
+ df[[col]] <- NA
+ }
+ }
+ return(df)
+}
+
+#' Remove Duplicated Words from Strings
+#'
+#' This function takes a vector of strings and removes duplicated words within each string.
+#'
+#' @param strings A character vector containing strings with potential duplicated words.
+#' @return A character vector with duplicated words removed from each string.
+#' @export
+#' @examples
+#'
+#' words <- c("hellohello", "worldworld", "programmingprogramming", "R isis great")
+#' cleaned_words <- removeDuplicatedWord(words)
+removeDuplicatedWord <- function(strings){
+ gsub("(.*)\\1+", "\\1", strings, perl = TRUE)
+}
+
+
+
+
+#' Convert Correlation Matrix to Data Frame
+#'
+#' This function converts a correlation matrix into a data frame containing the correlation values and their corresponding interaction names.
+#'
+#' @param corr_matrix A correlation matrix to be converted.
+#' @return A data frame with the correlation values and corresponding interaction names.
+#' @export
+#' @examples
+#' mat <- matrix(c(1, 0.7, 0.5, 0.7,
+#' 1, 0.3, 0.5, 0.3, 1),
+#' nrow = 3,
+#' dimnames = list(c("A", "B", "C"),
+#' c("A", "B", "C")))
+#' correlation_matrix_2df(mat)
+correlation_matrix_2df <- function(corr_matrix){
+ vec_corr <- corr_matrix[lower.tri(corr_matrix)]
+ col_names <- removeDuplicatedWord(colnames(corr_matrix))
+ row_names <- removeDuplicatedWord(rownames(corr_matrix))
+ interaction_names <- vector("character", length(vec_corr))
+ k <- 1
+ n <- nrow(corr_matrix)
+ for (i in 1:(n - 1)) {
+ for (j in (i + 1):n) {
+ interaction_names[k] <- paste("cor__", paste(col_names[i], ".", row_names[j], sep = ""), sep ="")
+ k <- k + 1
+ }
+ }
+ names(vec_corr) <- interaction_names
+ ret <- data.frame(estimate = vec_corr)
+ ret$term <- rownames(ret)
+ rownames(ret) <- NULL
+ ret
+}
+
+#' Wrapper for Extracting Variance-Covariance Components
+#'
+#' This function extracts variance-covariance components from a glmmTMB model object for a specific grouping factor and returns them as a data frame.
+#'
+#' @param var_cor A variance-covariance object from the glmmTMB model.
+#' @param elt A character indicating the type of effect, either "cond" or "zi".
+#' @return A data frame containing the standard deviation and correlation components for the specified grouping factor.
+#' @export
+#' @examples
+#' model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length + (1|Species),
+#' data = iris, family = gaussian)
+#' var_cor <- summary(model)$varcor$cond
+#' ran_pars_df <- wrapper_var_cor(var_cor, "Species")
+wrapper_var_cor <- function(var_cor, elt){
+ var_group <- attributes(var_cor)$names
+ l_ret <- lapply(var_group,
+ function(group)
+ {
+ ## -- standard dev
+ std_df <- data.frame(estimate = attributes(var_cor[[group]])$stddev)
+ std_df$term <- paste("sd_", removeDuplicatedWord(rownames(std_df)), sep = "")
+ ## -- correlation
+ corr_matrix <- attributes(var_cor[[group]])$correlation
+ #no correlation 2 return
+ if (nrow(corr_matrix) <= 1) ret <- std_df
+ else {
+ corr_df <- correlation_matrix_2df(corr_matrix)
+ ret <- rbind(std_df, corr_df)
+ }
+ ret$component <- elt
+ ret$effect <- "ran_pars"
+ ret$group <- group
+ rownames(ret) <- NULL
+ return(ret)
+ })
+ l_ret
+
+}
+
+
+#' Extract Random Parameters from a glmmTMB Model
+#'
+#' This function extracts the random parameters from a glmmTMB model and returns them as a data frame.
+#'
+#' @param x A glmmTMB model object.
+#' @return A data frame containing the random parameters and their estimates.
+#' @export
+#' @importFrom stats setNames
+#' @examples
+#' model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length + (1|Species), data = iris,
+#' family = gaussian)
+#' random_params <- extract_ran_pars(model)
+extract_ran_pars <- function(x){
+ ss <- summary(x)
+ l_2parcour <- c("cond", "zi")
+ l_res = lapply(stats::setNames(l_2parcour, l_2parcour),
+ function(elt)
+ {
+ var_cor <- ss$varcor[[elt]]
+ return(wrapper_var_cor(var_cor, elt))
+ })
+
+ ret <- rbind(do.call("rbind", l_res$cond),do.call("rbind", l_res$zi))
+ return(ret)
+
+}
+
+
+#' Rename Columns in a Data Frame
+#'
+#' This function renames columns in a data frame based on specified old names and corresponding new names.
+#'
+#' @param df A data frame.
+#' @param old_names A character vector containing the old column names to be replaced.
+#' @param new_names A character vector containing the corresponding new column names.
+#' @return The data frame with renamed columns.
+#' @export
+#' @examples
+#' df <- data.frame(Estimate = c(1.5, 2.0, 3.2),
+#' Std..Error = c(0.1, 0.3, 0.2),
+#' z.value = c(3.75, 6.67, 4.90),
+#' Pr...z.. = c(0.001, 0.0001, 0.002))
+#'
+#' renamed_df <- renameColumns(df, old_names = c("Estimate", "Std..Error", "z.value", "Pr...z.."),
+#' new_names = c("estimate", "std.error", "statistic", "p.value"))
+#'
+renameColumns <- function(df, old_names = c("Estimate","Std..Error", "z.value", "Pr...z.."),
+ new_names = c("estimate","std.error", "statistic", "p.value")) {
+ stopifnot(length(old_names) == length(new_names))
+
+ for (i in seq_along(old_names)) {
+ old_col <- old_names[i]
+ new_col <- new_names[i]
+
+ if (old_col %in% names(df)) {
+ names(df)[names(df) == old_col] <- new_col
+ } else {
+ warning(paste("Column", old_col, "not found in the data frame. Skipping renaming."))
+ }
+ }
+
+ return(df)
+}
+
+
+
+#' Reorder the columns of a dataframe
+#'
+#' This function reorders the columns of a dataframe according to the specified column order.
+#'
+#' @param df The input dataframe.
+#' @param columnOrder A vector specifying the desired order of columns.
+#'
+#' @return A dataframe with columns reordered according to the specified column order.
+#' @export
+#' @examples
+#' # Example dataframe
+#' df <- data.frame(A = 1:3, B = 4:6, C = 7:9)
+#'
+#' # Define the desired column order
+#' columnOrder <- c("B", "C", "A")
+#'
+#' # Reorder the columns of the dataframe
+#' df <- reorderColumns(df, columnOrder)
+reorderColumns <- function(df, columnOrder) {
+ df <- df[, columnOrder, drop = FALSE]
+ return(df)
+}
+
diff --git a/R/updatefitmodel.R b/R/updatefitmodel.R
new file mode 100644
index 0000000000000000000000000000000000000000..17370bd7bb2dd4e4fb6bc928e5030216555afd8a
--- /dev/null
+++ b/R/updatefitmodel.R
@@ -0,0 +1,136 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+
+#' Update GLMNB models in parallel.
+#'
+#' This function fits GLMNB models in parallel using multiple cores, allowing for faster computation.
+#'
+#' @param formula Formula for the GLMNB model.
+#' @param l_tmb List of GLMNB 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.
+#' @param ... Additional arguments to be passed to the glmmTMB::glmmTMB function.
+#' @export
+#' @return A list of updated GLMNB models.
+#'
+#' @examples
+#' data(iris)
+#' groups <- unique(iris$Species)
+#' group_by <- "Species"
+#' formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+#' 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, l_tmb, n.cores = NULL, log_file = "log.txt", ...) {
+
+ isValidInput2fit(l_tmb[[1]]$frame, formula)
+
+ is_fullrank(l_tmb[[1]]$frame, formula)
+
+ # Fit models update in parallel and capture the results
+ results <- .parallel_update(formula, l_tmb, n.cores, log_file, ...)
+ return(results)
+}
+
+
+#' Internal function to fit GLMNB models in parallel.
+#'
+#' This function is used internally by \code{\link{updateParallel}} to fit GLMNB models in parallel.
+#'
+#' @param formula Formula for the GLMNB model.
+#' @param l_tmb List of GLMNB objects.
+#' @param n.cores Number of cores to use for parallel processing.
+#' @param log_file File path for the log output.
+#' @param ... Additional arguments to be passed to the glmmTMB::glmmTMB function.
+#' @export
+#' @return A list of updated GLMNB models.
+#' @examples
+#' data(iris)
+#' groups <- unique(iris$Species)
+#' group_by <- "Species"
+#' formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+#' fitted_models <- fitModelParallel(formula, iris, group_by, n.cores = 1)
+#' new_formula <- Sepal.Length ~ Sepal.Width
+#' results <- .parallel_update(new_formula, fitted_models, n.cores = 1)
+.parallel_update <- function(formula, l_tmb, n.cores = NULL, log_file = "log.txt", ...) {
+ 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())
+ updated_res <- parallel::parLapply(clust, X = l_tmb, fun = launchUpdate , formula = formula, ...)
+ parallel::stopCluster(clust)
+ #closeAllConnections()
+ return(updated_res)
+}
+
+
+#' Fit and update a GLMNB model.
+#'
+#' This function fits and updates a GLMNB model using the provided formula.
+#'
+#' @param glmnb_obj A GLMNB object to be updated.
+#' @param formula Formula for the updated GLMNB model.
+#' @param ... Additional arguments to be passed to the glmmTMB::glmmTMB function.
+#' @export
+#' @return An updated GLMNB model.
+#'
+#' @examples
+#' data(iris)
+#' groups <- unique(iris$Species)
+#' group_by <- "Species"
+#' formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+#' fitted_models <- fitModelParallel(formula, iris, group_by, n.cores = 1)
+#' new_formula <- Sepal.Length ~ Sepal.Width
+#' updated_model <- fitUpdate(fitted_models[[1]], new_formula)
+fitUpdate <- function(glmnb_obj, formula , ...){
+ data = glmnb_obj$frame
+ resUpdt <- stats::update(glmnb_obj, formula, ...)
+ resUpdt$frame <- data
+ ## family in ... => avoid error in future update
+ additional_args <- list(...)
+ familyArgs <- additional_args[['family']]
+ if (!is.null(familyArgs)) resUpdt$call$family <- familyArgs
+ ## control in ... => avoid error in future update
+ controlArgs <- additional_args[['control']]
+ if (!is.null(controlArgs)) resUpdt$call$control <- controlArgs
+ return(resUpdt)
+}
+
+
+#' Launch the update process for a GLMNB model.
+#'
+#' This function launches the update process for a GLMNB model, capturing and handling warnings and errors.
+#'
+#' @param glmnb_obj A GLMNB object to be updated.
+#' @param formula Formula for the updated GLMNB model.
+#' @param ... Additional arguments to be passed to the glmmTMB::glmmTMB function.
+#' @export
+#' @return An updated GLMNB model or NULL if an error occurs.
+#'
+#' @examples
+#' data(iris)
+#' groups <- unique(iris$Species)
+#' group_by <- "Species"
+#' formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+#' fitted_models <- fitModelParallel(formula, iris, group_by, n.cores = 1)
+#' new_formula <- Sepal.Length ~ Sepal.Width
+#' updated_model <- launchUpdate(fitted_models[[1]], new_formula)
+launchUpdate <- function(glmnb_obj, formula, ...) {
+ group = deparse(substitute(glmnb_obj))
+ tryCatch(
+ expr = {
+ withCallingHandlers(
+ fitUpdate(glmnb_obj, formula, ...),
+ warning = function(w) {
+ message(paste(Sys.time(), "warning for group", group ,":", conditionMessage(w)))
+ invokeRestart("muffleWarning")
+ })
+ },
+ error = function(e) {
+ message(paste(Sys.time(), "error for group", group,":", conditionMessage(e)))
+ return(NULL)
+ }
+ )
+}
+
diff --git a/R/utils-pipe.R b/R/utils-pipe.R
new file mode 100644
index 0000000000000000000000000000000000000000..fd0b1d13db4ff91b7f836f72b7d5d88d958f6e1f
--- /dev/null
+++ b/R/utils-pipe.R
@@ -0,0 +1,14 @@
+#' Pipe operator
+#'
+#' See \code{magrittr::\link[magrittr:pipe]{\%>\%}} for details.
+#'
+#' @name %>%
+#' @rdname pipe
+#' @keywords internal
+#' @export
+#' @importFrom magrittr %>%
+#' @usage lhs \%>\% rhs
+#' @param lhs A value or the magrittr placeholder.
+#' @param rhs A function call using the magrittr semantics.
+#' @return The result of calling `rhs(lhs)`.
+NULL
diff --git a/R/utils.R b/R/utils.R
new file mode 100644
index 0000000000000000000000000000000000000000..76037f757518fe22e0760e60e26fe5b559fa9002
--- /dev/null
+++ b/R/utils.R
@@ -0,0 +1,86 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+#' Join two data frames using data.table
+#'
+#' @param d1 Data frame 1
+#' @param d2 Data frame 2
+#' @param k1 Key columns for data frame 1
+#' @param k2 Key columns for data frame 2
+#' @importFrom data.table data.table
+#' @return Joined data frame
+#' @export
+#'
+#' @examples
+#'
+#' # Example usage:
+#' df1 <- data.frame(id = 1:5, value = letters[1:5])
+#' df2 <- data.frame(id = 1:5, category = LETTERS[1:5])
+#' join_dtf(df1, df2, "id", "id")
+join_dtf <- function(d1, d2, k1, k2) {
+ d1.dt_table <- data.table::data.table(d1, key = k1)
+ d2.dt_table <- data.table::data.table(d2, key = k2)
+ dt_joined <- d1.dt_table[d2.dt_table, allow.cartesian = TRUE]
+ return(dt_joined %>% as.data.frame())
+}
+
+
+
+#' Clean Variable Name
+#'
+#' This function removes digits, spaces, and special characters from a variable name.
+#' If any of these are present, they will be replaced with an underscore '_'.
+#'
+#' @param name The input variable name to be cleaned.
+#' @return The cleaned variable name without digits, spaces, or special characters.
+#'
+#' @details
+#' This function will check the input variable name for the presence of digits,
+#' spaces, and special characters. If any of these are found, they will be removed
+#' from the variable name and replaced with an underscore '_'. Additionally, it will
+#' check if the cleaned name is not one of the reserved names "interactions" or
+#' "correlations" which are not allowed as variable names.
+#' @export
+#' @examples
+#' clean_variable_name("my_var,:&$àà(-i abl23 e_na__ç^me ")
+clean_variable_name <- function(name){
+ message("Variable name should not contain digits, spaces, or special characters.\nIf any of these are present, they will be removed from the variable name.")
+ # avoid space in variable name
+ name <- gsub(" ", "_", name, fixed = TRUE)
+ # avoid digit in variable name
+ name <- gsub("[0-9]", "", name)
+ # avoid special character in variable name
+ name <- gsub("[[:punct:]]", "", name)
+
+ forbidden_names <- c("interactions", "correlations")
+ if (name %in% forbidden_names) {
+ forbidden_str <- paste(forbidden_names, collapse = " and ")
+ stop(forbidden_str, "cannot be used as variable name")
+ }
+ return(name)
+
+}
+
+
+#' Get Setting Table
+#'
+#' Create a table of experimental settings.
+#'
+#' This function takes various experimental parameters and returns a data frame
+#' that represents the experimental settings.
+#'
+#' @param n_genes Number of genes in the experiment.
+#' @param max_replicates Maximum number of replicates for each gene.
+#' @param min_replicates Minimum number of replicates for each gene.
+#' @param lib_size total number of reads
+#'
+#' @return A data frame containing the experimental settings with their corresponding values.
+#' @export
+getSettingsTable <- function(n_genes, max_replicates, min_replicates, lib_size ){
+
+ settings_df <- data.frame(parameters = c("# genes", "Max # replicates", "Min # replicates", "Library size" ),
+ values = c(n_genes, max_replicates, min_replicates, lib_size))
+ rownames(settings_df) <- NULL
+
+ return(settings_df)
+}
+
diff --git a/R/waldtest.R b/R/waldtest.R
new file mode 100644
index 0000000000000000000000000000000000000000..8bfffbc4e38215fb5f98119841bab6361f94b310
--- /dev/null
+++ b/R/waldtest.R
@@ -0,0 +1,77 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+#' Wald test for hypothesis testing
+#'
+#' This function performs a Wald test for hypothesis testing by comparing an estimation
+#' to a reference value using the provided standard error. It allows testing for
+#' one-tailed alternatives: "greater" - β > reference_value, "less" - β < −reference_value,
+#' or two-tailed alternative: "greaterAbs" - |β| > reference_value.
+#' If the p-value obtained is greater than 1, it is set to 1 to avoid invalid p-values.
+#'
+#' @param estimation The estimated coefficient value.
+#' @param std_error The standard error of the estimation.
+#' @param reference_value The reference value for comparison (default is 0).
+#' @param alternative The type of alternative hypothesis to test (default is "greaterAbs").
+#' @return A list containing the test statistic and p-value.
+#' @importFrom stats pnorm
+#' @export
+#' @examples
+#' # Perform a Wald test with the default "greaterAbs" alternative
+#' wald_test(estimation = 0.1, std_error = 0.02, reference_value = 0.2)
+wald_test <- function(estimation, std_error, reference_value = 0, alternative = "greaterAbs") {
+ if (alternative == "greater") {
+ test_statistic <- (estimation - reference_value) / std_error
+ p_value <- 1 - stats::pnorm(test_statistic, mean = 0, sd = 1, lower.tail = TRUE)
+ } else if (alternative == "less") {
+ test_statistic <- (estimation - reference_value) / std_error
+ p_value <- pnorm(test_statistic, mean = 0, sd = 1, lower.tail = TRUE)
+ } else if (alternative == "greaterAbs") {
+ test_statistic <- (abs(estimation) - reference_value) / std_error
+ p_value <- 2 * (1 - pnorm(test_statistic, mean = 0, sd = 1, lower.tail = TRUE))
+ } else {
+ stop("Invalid alternative type. Use 'greater', 'less', or 'greaterAbs'.")
+ }
+
+ # Set p-value to 1 if it exceeds 1
+ p_value <- pmin(p_value, 1)
+ return(list(statistic = test_statistic, p.value = p_value))
+}
+
+
+
+
+#' Perform statistical tests and return tidy results
+#'
+#' 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 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".
+#'
+#' @return A tidy data frame containing the results of statistical tests for the estimated coefficients.
+#'
+#' @importFrom stats p.adjust
+#' @export
+#'
+#' @examples
+#' data(iris)
+#' model_list <- fitModelParallel(formula = Sepal.Length ~ Sepal.Width + Petal.Length,
+#' data = iris, group_by = "Species", n.cores = 1)
+#' results_df <- tidy_results(model_list, coeff_threshold = 0.1, alternative_hypothesis = "greater")
+tidy_results <- function(list_tmb, coeff_threshold = 0, alternative_hypothesis = "greaterAbs", correction_method = "BH") {
+ tidy_tmb_df <- tidy_tmb(list_tmb)
+ if (coeff_threshold != 0 || alternative_hypothesis != "greaterAbs") {
+ waldRes <- wald_test(tidy_tmb_df$estimate, tidy_tmb_df$std.error, coeff_threshold, alternative_hypothesis)
+ tidy_tmb_df$statistic <- waldRes$statistic
+ tidy_tmb_df$p.value <- waldRes$p.value
+ }
+ tidy_tmb_df$p.adj <- stats::p.adjust(tidy_tmb_df$p.value, method = correction_method)
+ return(tidy_tmb_df)
+}
+
+
diff --git a/R/wrapperdeseq2.R b/R/wrapperdeseq2.R
new file mode 100644
index 0000000000000000000000000000000000000000..f7b67a7e57fa258f9bebdc330c691a5696b59b9f
--- /dev/null
+++ b/R/wrapperdeseq2.R
@@ -0,0 +1,159 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+#' Wrapper Function for DESeq2 Analysis
+#'
+#' This function performs differential expression analysis using DESeq2 based on the provided
+#' DESeqDataSet (dds) object. It calculates the dispersion values from the dds object and then
+#' performs inference on the log-fold change (LFC) values using the specified parameters.
+#'
+#' @param dds A DESeqDataSet object containing the count data and experimental design.
+#' @param lfcThreshold The threshold for minimum log-fold change (LFC) to consider differentially expressed.
+#' @param altHypothesis The alternative hypothesis for the analysis, indicating the direction of change.
+#' Options are "greater", "less", or "two.sided".
+#' @param correction_method The method for p-value correction. Default is "BH" (Benjamini-Hochberg).
+#'
+#' @return A list containing the dispersion values and the results of the differential expression analysis.
+#' The dispersion values are calculated from the dds object and named according to sample names.
+#' The inference results include adjusted p-values and log2 fold changes for each gene.
+#'
+#' @examples
+#' N_GENES = 100
+#' MAX_REPLICATES = 5
+#' MIN_REPLICATES = 5
+#' ## --init variable
+#' input_var_list <- init_variable( name = "genotype", mu = 12, sd = 0.1, level = 3) %>%
+#' init_variable(name = "environment", mu = c(0,1), NA , level = 2)
+#'
+#' mock_data <- mock_rnaseq(input_var_list, N_GENES, MIN_REPLICATES, MAX_REPLICATES)
+#' dds <- DESeq2::DESeqDataSetFromMatrix(mock_data$counts ,
+#' mock_data$metadata, ~ genotype + environment)
+#' dds <- DESeq2::DESeq(dds, quiet = TRUE)
+#' result <- wrapper_DESeq2(dds, lfcThreshold = 1, altHypothesis = "greater")
+#' @export
+wrapper_DESeq2 <- function(dds, lfcThreshold , altHypothesis, correction_method = "BH") {
+ dds_full <- S4Vectors::mcols(dds) %>% as.data.frame()
+
+ ## -- dispersion
+ message("INFO: The dispersion values from DESeq2 were reparametrized to their reciprocals (1/dispersion).")
+ dispersion <- 1/dds_full$dispersion
+ names(dispersion) <- rownames(dds_full)
+
+ ## -- coeff
+ inference_df <- get_inference(dds_full, lfcThreshold, altHypothesis, correction_method)
+ res <- list(dispersion = dispersion, fixEff = inference_df)
+ return(res)
+}
+
+
+
+#' Calculate Inference for Differential Expression Analysis
+#'
+#' This function calculates inference for differential expression analysis based on the results of DESeq2.
+#'
+#' @param dds_full A data frame containing DESeq2 results, including estimate and standard error information.
+#' @param lfcThreshold Log fold change threshold for determining differentially expressed genes.
+#' @param altHypothesis Alternative hypothesis for testing, one of "greater", "less", or "two.sided".
+#' @param correction_method Method for multiple hypothesis correction, e.g., "BH" (Benjamini-Hochberg).
+#'
+#' @return A data frame containing inference results, including statistics, p-values, and adjusted p-values.
+#'
+#' @examples
+#' \dontrun{
+#' # Example usage of the function
+#' inference_result <- get_inference(dds_full, lfcThreshold = 0.5,
+#' altHypothesis = "greater",
+#' correction_method = "BH")
+#' }
+#' @importFrom stats p.adjust
+#' @export
+get_inference <- function(dds_full, lfcThreshold, altHypothesis, correction_method){
+
+ ## -- build subdtf
+ stdErr_df <- getSE_df(dds_full)
+ estim_df <- getEstimate_df(dds_full)
+ ## -- join
+ df2ret <- join_dtf(estim_df, stdErr_df, k1 = c("ID", "term") , k2 = c("ID", "term"))
+
+ ## -- convert to ln
+ message("INFO: The log2-fold change estimates and standard errors from DESeq2 were converted to the natural logarithm scale.")
+ df2ret$estimate <- df2ret$estimate*log(2)
+ df2ret$std.error <- df2ret$std.error*log(2)
+
+ ## -- some details reshaped
+ df2ret$term <- gsub("_vs_.*","", df2ret$term)
+ df2ret$term <- gsub(pattern = "_", df2ret$term, replacement = "")
+ df2ret$term <- removeDuplicatedWord(df2ret$term)
+ df2ret$term <- gsub(pattern = "[.]", df2ret$term, replacement = ":")
+ df2ret$effect <- "fixed"
+ idx_intercept <- df2ret$term == "Intercept"
+ df2ret$term[idx_intercept] <- "(Intercept)"
+
+ ## -- statistical part
+ waldRes <- wald_test(df2ret$estimate, df2ret$std.error, lfcThreshold, altHypothesis)
+ df2ret$statistic <- waldRes$statistic
+ df2ret$p.value <- waldRes$p.value
+ df2ret$p.adj <- stats::p.adjust(df2ret$p.value, method = correction_method)
+
+ return(df2ret)
+}
+
+
+#' Extract Standard Error Information from DESeq2 Results
+#'
+#' This function extracts the standard error (SE) information from DESeq2 results.
+#'
+#' @param dds_full A data frame containing DESeq2 results, including standard error columns.
+#'
+#' @return A data frame with melted standard error information, including gene IDs and terms.
+#'
+#' @examples
+#' \dontrun{
+#' # Example usage of the function
+#' se_info <- getSE_df(dds_full)
+#' }
+#' @importFrom reshape2 melt
+#' @export
+getSE_df <- function(dds_full){
+ columnsInDds_full <- colnames(dds_full)
+ SE_columns <- columnsInDds_full [ grepl("SE" , columnsInDds_full) ]
+ SE_df <- dds_full[, SE_columns]
+ SE_df$ID <- rownames(SE_df)
+ SE_df_long <- reshape2::melt(SE_df,
+ measure.vars = SE_columns,
+ variable.name = "term", value.name = "std.error", drop = F)
+ SE_df_long$term <- gsub(pattern = "SE_", SE_df_long$term, replacement = "")
+ return(SE_df_long)
+
+}
+
+
+#' Extract Inferred Estimate Information from DESeq2 Results
+#'
+#' This function extracts the inferred estimate values from DESeq2 results.
+#'
+#' @param dds_full A data frame containing DESeq2 results, including estimate columns.
+#'
+#' @return A data frame with melted inferred estimate information, including gene IDs and terms.
+#'
+#' @examples
+#' \dontrun{
+#' # Example usage of the function
+#' estimate_info <- getEstimate_df(dds_full)
+#' }
+#' @importFrom reshape2 melt
+#' @export
+getEstimate_df <- function(dds_full){
+ columnsInDds_full <- colnames(dds_full)
+ SE_columns <- columnsInDds_full [ grepl("SE" , columnsInDds_full) ]
+ inferedVal_columns <- gsub("SE_", "" , x = SE_columns)
+
+ estimate_df <- dds_full[, inferedVal_columns]
+ estimate_df$ID <- rownames(estimate_df)
+ estimate_df_long <- reshape2::melt(estimate_df,
+ measure.vars = inferedVal_columns,
+ variable.name = "term", value.name = "estimate", drop = F)
+ return(estimate_df_long)
+
+}
+
diff --git a/README.md b/README.md
new file mode 100644
index 0000000000000000000000000000000000000000..adb56380a9da35ff14afe9264f2c093c8eaebb9d
--- /dev/null
+++ b/README.md
@@ -0,0 +1,34 @@
+# HTRfit
+
+## Installation
+
+To install the latest version of HTRfit, run the following in your R console :
+
+```
+if (!requireNamespace("remotes", quietly = TRUE))
+ install.packages("remotes")
+remotes::install_github("https://gitbio.ens-lyon.fr/aduvermy/HTRfit", build_vignettes = T)
+```
+
+When dependencies are met, installation should take under 20 seconds.
+
+
+## CRAN packages dependencies
+
+```
+install.packages(c("car", "data.table", "parallel", "data.table", "ggplot2", "gridExtra", "glmmTMB", "magrittr", "MASS", "plotROC", "reshape2", "rlang", "S4Vectors", "stats", "utils"))
+```
+
+### System requirements
+
+
+
+### Getting started
+
+You can access the package's main vignette from your R console with
+
+```
+library(HTRfit)
+vignette("HTRfit")
+vignette("HTRfit-pdf")
+```
\ No newline at end of file
diff --git a/dev/DESCRIPTION b/dev/DESCRIPTION
new file mode 100644
index 0000000000000000000000000000000000000000..7ec9bc2d400aec629de148a7fc5a7a9dfeb4006b
--- /dev/null
+++ b/dev/DESCRIPTION
@@ -0,0 +1,9 @@
+Package: dev
+Version: 0.0.0.9000
+Title: HTRfit
+Description: What the package does (one paragraph).
+Authors@R: person("First", "Last", email = "first.last@example.com", role = c("aut", "cre"), comment = c(ORCID = "YOUR-ORCID-ID"))
+License: `use_mit_license()`, `use_gpl3_license()` or friends to pick a license
+Encoding: UTF-8
+Roxygen: list(markdown = TRUE)
+RoxygenNote: 7.2.2
diff --git a/dev/NAMESPACE b/dev/NAMESPACE
new file mode 100644
index 0000000000000000000000000000000000000000..6ae926839dd1829f1016a96f766d970ff184ad97
--- /dev/null
+++ b/dev/NAMESPACE
@@ -0,0 +1,2 @@
+# Generated by roxygen2: do not edit by hand
+
diff --git a/dev/flat_full.Rmd b/dev/flat_full.Rmd
new file mode 100644
index 0000000000000000000000000000000000000000..21306178514dbff0ecdc19f33284651b1cc8ede4
--- /dev/null
+++ b/dev/flat_full.Rmd
@@ -0,0 +1,7413 @@
+---
+title: "flat_full.Rmd for working package"
+output: html_document
+editor_options:
+ chunk_output_type: console
+---
+
+<!-- Run this 'development' chunk -->
+<!-- Store every call to library() that you need to explore your functions -->
+
+```{r development, include=FALSE}
+library(testthat)
+```
+
+<!--
+ You need to run the 'description' chunk in the '0-dev_history.Rmd' file before continuing your code there.
+
+If it is the first time you use {fusen}, after 'description', you can directly run the last chunk of the present file with inflate() inside.
+-->
+
+```{r development-load}
+# Load already included functions if relevant
+pkgload::load_all(export_all = FALSE)
+```
+
+
+```{r function-utils, filename = "utils"}
+#' Join two data frames using data.table
+#'
+#' @param d1 Data frame 1
+#' @param d2 Data frame 2
+#' @param k1 Key columns for data frame 1
+#' @param k2 Key columns for data frame 2
+#' @importFrom data.table data.table
+#' @return Joined data frame
+#' @export
+#'
+#' @examples
+#'
+#' # Example usage:
+#' df1 <- data.frame(id = 1:5, value = letters[1:5])
+#' df2 <- data.frame(id = 1:5, category = LETTERS[1:5])
+#' join_dtf(df1, df2, "id", "id")
+join_dtf <- function(d1, d2, k1, k2) {
+ d1.dt_table <- data.table::data.table(d1, key = k1)
+ d2.dt_table <- data.table::data.table(d2, key = k2)
+ dt_joined <- d1.dt_table[d2.dt_table, allow.cartesian = TRUE]
+ return(dt_joined %>% as.data.frame())
+}
+
+
+
+#' Clean Variable Name
+#'
+#' This function removes digits, spaces, and special characters from a variable name.
+#' If any of these are present, they will be replaced with an underscore '_'.
+#'
+#' @param name The input variable name to be cleaned.
+#' @return The cleaned variable name without digits, spaces, or special characters.
+#'
+#' @details
+#' This function will check the input variable name for the presence of digits,
+#' spaces, and special characters. If any of these are found, they will be removed
+#' from the variable name and replaced with an underscore '_'. Additionally, it will
+#' check if the cleaned name is not one of the reserved names "interactions" or
+#' "correlations" which are not allowed as variable names.
+#' @export
+#' @examples
+#' clean_variable_name("my_var,:&$àà(-i abl23 e_na__ç^me ")
+clean_variable_name <- function(name){
+ message("Variable name should not contain digits, spaces, or special characters.\nIf any of these are present, they will be removed from the variable name.")
+ # avoid space in variable name
+ name <- gsub(" ", "_", name, fixed = TRUE)
+ # avoid digit in variable name
+ name <- gsub("[0-9]", "", name)
+ # avoid special character in variable name
+ name <- gsub("[[:punct:]]", "", name)
+
+ forbidden_names <- c("interactions", "correlations")
+ if (name %in% forbidden_names) {
+ forbidden_str <- paste(forbidden_names, collapse = " and ")
+ stop(forbidden_str, "cannot be used as variable name")
+ }
+ return(name)
+
+}
+
+
+#' Get Setting Table
+#'
+#' Create a table of experimental settings.
+#'
+#' This function takes various experimental parameters and returns a data frame
+#' that represents the experimental settings.
+#'
+#' @param n_genes Number of genes in the experiment.
+#' @param max_replicates Maximum number of replicates for each gene.
+#' @param min_replicates Minimum number of replicates for each gene.
+#' @param lib_size total number of reads
+#'
+#' @return A data frame containing the experimental settings with their corresponding values.
+#' @export
+getSettingsTable <- function(n_genes, max_replicates, min_replicates, lib_size ){
+
+ settings_df <- data.frame(parameters = c("# genes", "Max # replicates", "Min # replicates", "Library size" ),
+ values = c(n_genes, max_replicates, min_replicates, lib_size))
+ rownames(settings_df) <- NULL
+
+ return(settings_df)
+}
+
+```
+
+
+```{r test-dataFromUser}
+# Test unitaires pour la fonction join_dtf
+test_that("join_dtf réalise la jointure correctement", {
+ # Création de données de test
+ df1 <- data.frame(id = 1:5, value = letters[1:5])
+ df2 <- data.frame(id = 1:5, category = LETTERS[1:5])
+
+ # Exécution de la fonction
+ result <- join_dtf(df1, df2, "id", "id")
+
+ # Vérification des résultats
+ expect_true(is.data.frame(result))
+ expect_equal(nrow(result), 5)
+ expect_equal(ncol(result), 3)
+ expect_equal(names(result), c("id", "value", "category"))
+ expect_true(all.equal(result$id, df1$id))
+ expect_true(all.equal(result$id, df2$id))
+})
+
+
+test_that("clean_variable_name correctly removes digits, spaces, and special characters", {
+ expect_equal(clean_variable_name("my variable name"), "myvariablename")
+ expect_equal(clean_variable_name("variable_1"), "variable")
+ expect_equal(clean_variable_name("^spec(ial#chars! "), "specialchars")
+})
+
+test_that("clean_variable_name handles reserved names properly", {
+ expect_error(clean_variable_name("interactions"))
+ expect_error(clean_variable_name("correlations"))
+})
+```
+
+
+```{r function-init_variable, filename = "simulation_initialization"}
+#' Initialize variable
+#'
+#' @param list_var Either c() or output of init_variable
+#' @param name Variable name
+#' @param mu Either a numeric value or a numeric vector (of length = level)
+#' @param sd Either numeric value or NA
+#' @param level Numeric value to specify the number of levels to simulate
+#'
+#' @return
+#' A list with initialized variables
+#' @export
+#'
+#' @examples
+#' init_variable(name = "my_varA", mu = 2, sd = 9, level = 200)
+init_variable <- function(list_var = c(), name = "myVariable", mu = c(2,3), sd = NA, level = NA) {
+
+ name <- clean_variable_name(name)
+
+ # Only mu specified by user => set level param
+ if (is.na(level) && is.na(sd)) {
+ level <- length(mu)
+ }
+
+ # Validate inputs
+ inputs_checking(list_var, name, mu, sd, level)
+
+ if (endsWithDigit(name)) {
+ warning("Names ending with digits are not allowed. They will be removed from the variable name.")
+ name <- removeDigitsAtEnd(name)
+ }
+
+ # Initialize new variable
+ list_var[[name]] <- fillInVariable(name, mu, sd, level)
+
+ return(list_var)
+}
+
+
+
+#' Check if a string ends with a digit
+#'
+#' This function checks whether a given string ends with a digit.
+#'
+#' @param string The input string to be checked
+#' @return \code{TRUE} if the string ends with a digit, \code{FALSE} otherwise
+#' @export
+#' @examples
+#' endsWithDigit("abc123") # Output: TRUE
+#' endsWithDigit("xyz") # Output: FALSE
+endsWithDigit <- function(string) {
+ lastChar <- substring(string, nchar(string))
+ return(grepl("[0-9]", lastChar))
+}
+
+#' Remove digits at the end of a string
+#'
+#' This function removes any digits occurring at the end of a given string.
+#'
+#' @param string The input string from which digits are to be removed
+#' @return The modified string with digits removed from the end
+#' @export
+#' @examples
+#' removeDigitsAtEnd("abc123") # Output: "abc"
+#' removeDigitsAtEnd("xyz") # Output: "xyz"
+removeDigitsAtEnd <- function(string) {
+ return(gsub("\\d+$", "", string))
+}
+
+
+#' Check Input Parameters
+#'
+#' This function checks the validity of the input parameters for initializing a variable.
+#' It ensures that the necessary conditions are met for the input parameters.
+#'
+#' @param list_var List containing the variables to be initialized.
+#' @param name Name of the variable.
+#' @param mu Mean of the variable.
+#' @param sd Standard deviation of the variable (optional).
+#' @param level Number of levels for categorical variables.
+#'
+#' @return NULL
+#' @export
+#'
+#' @examples
+#' inputs_checking(list_var = c(), name = "var1", mu = 0, sd = 1, level = 2)
+inputs_checking <- function(list_var, name, mu, sd, level) {
+ stopifnot(name != "")
+ stopifnot(is.character(name))
+ stopifnot(is.numeric(mu))
+ stopifnot(is.numeric(sd) | is.na(sd))
+ stopifnot(is.numeric(level))
+ stopifnot(length(level) == 1)
+ stopifnot(level >= 2)
+
+ if (!is.null(list_var)) {
+ error_msg <- "Non conformable list_var parameter.\nlist_var must be set as an init_var output or initialized as c()"
+ if (!is.list(list_var)) {
+ stop(error_msg)
+ }
+ }
+
+ if (length(mu) > 1) {
+ stopifnot(length(mu) == level)
+ }
+
+ if (is.na(sd)) {
+ if (level != length(mu)) {
+ stop("sd was specified as NA. mu should have the same length as the number of levels\n")
+ }
+ }
+
+ # Check if variable is already initialized
+ name_not_in_list_var <- identical(which(already_init_variable(list_var, name)), integer(0))
+ if (!name_not_in_list_var) {
+ message(paste(name, "is already initialized in list_var.\nIt will be updated", sep = " "))
+ }
+
+ return(NULL)
+}
+
+
+#' Check if Variable is Already Initialized
+#'
+#' This function checks if a variable is already initialized in the variable list.
+#'
+#' @param list_var A list object representing the variable list.
+#' @param new_var_name A character string specifying the name of the new variable.
+#'
+#' @return TRUE if the variable is already initialized, FALSE otherwise.
+#' @export
+#'
+#' @examples
+#' my_list <- list(var1 = 1, var2 = 2, var3 = 3)
+#' already_initialized <- already_init_variable(list_var = my_list, new_var_name = "myVariable")
+already_init_variable <- function(list_var, new_var_name) {
+ if (is.null(list_var)) {
+ return(FALSE)
+ }
+
+ var_names <- names(list_var)
+ return(new_var_name %in% var_names)
+}
+
+#' Fill in Variable
+#'
+#' This function fills in a variable with simulated data based on the provided parameters.
+#'
+#' @param name The name of the variable.
+#' @param mu A numeric value or a numeric vector (of length = level) representing the mean.
+#' @param sd A numeric value representing the standard deviation, or NA if not applicable.
+#' @param level A numeric value specifying the number of levels to simulate.
+#'
+#' @return A data frame or a list containing the simulated data for the variable.
+#' @export
+#'
+#' @examples
+#' variable_data <- fillInVariable(name = "myVariable", mu = c(2, 3), sd = NA, level = 2)
+fillInVariable <- function(name, mu, sd, level) {
+
+ if (length(mu) > 1 | is.na(sd)) { # Effects given by user
+ level <- length(mu)
+ l_labels <- paste(name, 1:level, sep = '')
+ l_betaEffects <- mu
+ column_names <- c(paste("label", name, sep = "_"), name)
+ sub_obj <- build_sub_obj_return_to_user(level, metaData = l_labels,
+ effectsGivenByUser = l_betaEffects,
+ column_names)
+ } else {
+ sub_obj <- as.data.frame(list(mu = mu, sd = sd, level = level))
+ }
+
+ return(sub_obj)
+}
+
+#' Build Sub Object to Return to User
+#'
+#' This function builds the sub-object to be returned to the user.
+#'
+#' @param level A numeric value specifying the number of levels.
+#' @param metaData A list of labels.
+#' @param effectsGivenByUser A list of effects given by the user.
+#' @param col_names A character vector specifying the column names to use.
+#' @importFrom utils tail
+#'
+#' @return A list with the sub-object details.
+build_sub_obj_return_to_user <- function(level, metaData, effectsGivenByUser, col_names) {
+ sub_obj <- list(level = level)
+ data <- cbind(metaData, effectsGivenByUser) %>% as.data.frame()
+ colnames(data) <- col_names
+ var_name <- utils::tail(col_names, n = 1)
+ data[, var_name] <- as.numeric(data[, var_name])
+ sub_obj$data <- data
+ return(sub_obj)
+}
+
+
+#' Add interaction
+#'
+#' @param list_var A list of variables (already initialized)
+#' @param between_var A vector of variable names to include in the interaction
+#' @param mu Either a numeric value or a numeric vector (of length = level)
+#' @param sd Either numeric value or NA
+#'
+#' @return
+#' A list with initialized interaction
+#' @export
+#'
+#' @examples
+#' init_variable(name = "myvarA", mu = 2, sd = 3, level = 200) %>%
+#' init_variable(name = "myvarB", mu = 1, sd = 0.2, level = 2 ) %>%
+#' add_interaction(between_var = c("myvarA", "myvarB"), mu = 3, sd = 2)
+add_interaction <- function(list_var, between_var, mu, sd = NA) {
+ name_interaction <- paste(between_var, collapse = ":")
+ check_input2interaction(name_interaction, list_var, between_var, mu, sd)
+
+ # Check the number of variables in the interaction
+ if (length(between_var) > 3) {
+ stop("Cannot initialize an interaction with more than 3 variables.")
+ }
+
+ interactionCombinations <- getNumberOfCombinationsInInteraction(list_var, between_var)
+ list_var$interactions[[name_interaction]] <- fillInInteraction(list_var, between_var, mu, sd, interactionCombinations)
+ return(list_var)
+}
+
+#' Check input for interaction
+#'
+#' @param name_interaction String specifying the name of the interaction (example: "varA:varB")
+#' @param list_var A list of variables (already initialized)
+#' @param between_var A vector of variable names to include in the interaction
+#' @param mu Either a numeric value or a numeric vector (of length = level)
+#' @param sd Either numeric value or NA
+#'
+#' @return
+#' NULL (throws an error if the input is invalid)
+#' @export
+check_input2interaction <- function(name_interaction, list_var, between_var, mu, sd) {
+ # Check if variables in between_var are declared and initialized
+ bool_checkInteractionValidity <- function(between_var, list_var) {
+ nb_varInInteraction <- length(unique(between_var))
+ stopifnot(nb_varInInteraction > 1)
+ existingVar_nb <- getListVar(list_var) %in% between_var %>% sum()
+ if (existingVar_nb != nb_varInInteraction) {
+ return(FALSE)
+ } else {
+ return(TRUE)
+ }
+ }
+
+ bool_valid_interaction <- bool_checkInteractionValidity(between_var, list_var)
+ if (!bool_valid_interaction) {
+ stop("At least one variable in between_var is not declared. Variable not initialized cannot be used in an interaction.")
+ }
+
+ requestedNumberOfValues <- getNumberOfCombinationsInInteraction(list_var, between_var)
+ if (is.na(sd) && requestedNumberOfValues != length(mu)) {
+ msg_e <- "sd was specified as NA. mu should have the same length as the possible number of interactions:\n"
+ msg_e2 <- paste(requestedNumberOfValues, "interaction values are requested.")
+ stop(paste(msg_e, msg_e2))
+ }
+
+ level <- requestedNumberOfValues
+ inputs_checking(list_var$interactions, name_interaction, mu, sd, level)
+}
+
+#' Get the number of combinations in an interaction
+#'
+#' @param list_var A list of variables (already initialized)
+#' @param between A vector of variable names to include in the interaction
+#'
+#' @return
+#' The number of combinations in the interaction
+#' @export
+getNumberOfCombinationsInInteraction <- function(list_var, between) {
+ levelInlistVar <- getGivenAttribute(list_var, "level") %>% unlist()
+ n_combinations <- prod(levelInlistVar[between])
+ return(n_combinations)
+}
+
+#' getGridCombination
+#'
+#' Generates all possible combinations of labels.
+#'
+#' @param l_labels List of label vectors
+#'
+#' @return A data frame with all possible combinations of labels
+#' @export
+#'
+#' @examples
+#' l_labels <- list(
+#' c("A", "B", "C"),
+#' c("X", "Y")
+#' )
+#' getGridCombination(l_labels)
+getGridCombination <- function(l_labels) {
+ grid <- expand.grid(l_labels)
+ colnames(grid) <- paste("label", seq_along(l_labels), sep = "_")
+ return(grid)
+}
+
+
+
+#' Get grid combination from list_var
+#'
+#' @param list_var A list of variables (already initialized)
+#'
+#' @return
+#' The grid combination between variable in list_var
+#' @export
+generateGridCombination_fromListVar <- function (list_var){
+ l_levels <- getGivenAttribute(list_var, "level") %>% unlist()
+ vars <- names(l_levels)
+ l_levels <- l_levels[vars]
+ l_labels <- getLabels(l_variables2labelized = vars, l_nb_label = l_levels)
+ gridComb <- getGridCombination(l_labels)
+ colnames(gridComb) <- paste("label", vars, sep = "_")
+ return(gridComb)
+}
+
+
+#' Fill in interaction
+#'
+#' @param list_var A list of variables (already initialized)
+#' @param between A vector of variable names to include in the interaction
+#' @param mu Either a numeric value or a numeric vector (of length = level)
+#' @param sd Either numeric value or NA
+#' @param level Number of interactions
+#'
+#' @return
+#' A data frame with the filled-in interaction values
+#' @export
+fillInInteraction <- function(list_var, between, mu, sd, level) {
+ if (length(mu) > 1 || is.na(sd)) {
+ l_levels <- getGivenAttribute(list_var, "level") %>% unlist()
+ l_levelsOfInterest <- l_levels[between]
+ l_labels_varOfInterest <- getLabels(l_variables2labelized = between, l_nb_label = l_levelsOfInterest )
+
+ grid_combination <- getGridCombination(l_labels_varOfInterest)
+ n_combinations <- dim(grid_combination)[1]
+ column_names <- c(paste("label", between, sep = "_"), paste(between, collapse = ":"))
+ sub_dtf <- build_sub_obj_return_to_user(level = n_combinations,
+ metaData = grid_combination,
+ effectsGivenByUser = mu,
+ col_names = column_names)
+ } else {
+ sub_dtf <- list(mu = mu, sd = sd, level = level) %>% as.data.frame()
+ }
+
+ return(sub_dtf)
+}
+
+#' Get the list of variable names
+#'
+#' @param input R list, e.g., output of init_variable
+#'
+#' @return
+#' A character vector with the names of variables
+getListVar <- function(input) attributes(input)$names
+
+#' Get a given attribute from a list of variables
+#'
+#' @param list_var A list of variables (already initialized)
+#' @param attribute A string specifying the attribute to retrieve in all occurrences of the list
+#'
+#' @return
+#' A list without NULL values
+getGivenAttribute <- function(list_var, attribute) {
+ l <- lapply(list_var, FUN = function(var) var[[attribute]])
+ l_withoutNull <- l[!vapply(l, is.null, logical(1))]
+ return(l_withoutNull)
+}
+
+
+#' Get labels for variables
+#'
+#' @param l_variables2labelized A list of variables
+#' @param l_nb_label A list of numeric values representing the number of levels per variable
+#'
+#' @return
+#' A list of labels per variable
+getLabels <- function(l_variables2labelized, l_nb_label) {
+ getVarNameLabel <- function(name, level) {
+ list_label <- paste(name, 1:level, sep = "")
+ return(list_label)
+ }
+
+ listLabels <- Map(getVarNameLabel, l_variables2labelized, l_nb_label)
+ return(listLabels)
+}
+
+```
+
+
+```{r tests-init_variable}
+
+test_that("endsWithDigit returns the correct result", {
+ expect_true(endsWithDigit("abc123"))
+ expect_false(endsWithDigit("xyz"))
+})
+
+test_that("removeDigitsAtEnd removes digits at the end of a string", {
+ expect_equal(removeDigitsAtEnd("abc123"), "abc")
+ expect_equal(removeDigitsAtEnd("xyz"), "xyz")
+})
+
+
+test_that("init_variable initializes a variable correctly", {
+ # Test case 1: Initialize a variable with default parameters
+ list_var <- init_variable()
+ expect_true("myVariable" %in% names(list_var))
+ expect_equal(nrow(list_var$myVariable$data), 2)
+
+ # Test case 2: Initialize a variable with custom parameters
+ list_var <- init_variable(name = "custom_variable", mu = c(1, 2, 3), sd = 0.5, level = 3)
+ expect_true("customvariable" %in% names(list_var))
+ expect_equal(nrow(list_var$customvariable$data), 3)
+})
+
+test_that("inputs_checking performs input validation", {
+
+ # Test case 1: Invalid inputs - sd is NA but mu has unique values
+ expect_error(inputs_checking(list_var = c(), name = "myVariable", mu = 2, sd = NA, level = 2))
+
+ # Test case 2: Invalid inputs - empty name
+ expect_error(inputs_checking(list_var = c(), name = "", mu = 2, sd = NA, level = 2))
+
+ # Test case 3: Invalid inputs - non-numeric mu
+ expect_error(inputs_checking(list_var = c(), name = "myVariable", mu = "invalid", sd = NA, level = 2))
+
+ # Test case 4: Invalid inputs - non-numeric sd
+ expect_error(inputs_checking(list_var = c(), name = "myVariable", mu = 2, sd = "invalid", level = 2))
+
+ # Test case 5: Invalid inputs - level less than 2
+ expect_error(inputs_checking(list_var = c(), name = "myVariable", mu = 2, sd = NA, level = 1))
+
+ # Test case 6: Invalid inputs - mu and level have different lengths
+ expect_error(inputs_checking(list_var = c(), name = "myVariable", mu = c(1, 2, 3), sd = NA, level = 2))
+
+ # Test case 7: Valid inputs
+ expect_silent(inputs_checking(list_var = c(), name = "myVariable", mu = c(1, 2, 3), sd = NA, level = 3))
+})
+
+
+
+test_that("already_init_variable checks if a variable is already initialized", {
+ list_var <- init_variable()
+
+ # Test case 1: Variable not initialized
+ list_var <- init_variable(name = "custom_variable", mu = c(2, 3), sd = NA, level = 2)
+ expect_true(already_init_variable(list_var, "customvariable"))
+
+ # Test case 2: Variable already initialized
+ expect_false(already_init_variable(list_var, "myVariable"))
+
+})
+
+test_that("fillInVariable fills in variable correctly", {
+ # Test case 1: Effects given by user
+ sub_obj <- fillInVariable("myVariable", c(1, 2, 3), NA, NA)
+ expect_equal(sub_obj$level, 3)
+ expect_equal(ncol(sub_obj$data), 2)
+
+ # Test case 2: Effects simulated using mvrnorm
+ sub_obj <- fillInVariable("myVariable", 2, 0.5, 3)
+ expect_equal(sub_obj$level, 3)
+ expect_equal(sub_obj$sd, 0.5)
+ expect_equal(sub_obj$mu, 2)
+})
+
+test_that("build_sub_obj_return_to_user returns the expected output", {
+ level <- 3
+ metaData <- paste("label", 1:level, sep = "_")
+ effectsGivenByUser <- c(2, 3, 4)
+ col_names <- c("metadata", "effects")
+
+ result <- build_sub_obj_return_to_user(level, metaData, effectsGivenByUser, col_names)
+
+ expect_equal(result$level, level)
+ expect_identical(result$data$metadata, metaData)
+ expect_identical(result$data$effects, effectsGivenByUser)
+
+
+})
+
+test_that("generateGridCombination_fromListVar returns expected output", {
+ result <- generateGridCombination_fromListVar(init_variable())
+ expect <- data.frame(label_myVariable = c("myVariable1", "myVariable2"))
+ expect_equal(nrow(result), nrow(expect))
+ expect_equal(ncol(result), ncol(expect))
+})
+
+test_that("add_interaction adds an interaction between variables", {
+ list_var <- init_variable(name = "varA", mu = 1, sd = 1, level = 2)
+ list_var <- init_variable(list_var, name = "varB", mu = 2, sd = 1, level = 3)
+ list_var <- add_interaction(list_var, between_var = c("varA", "varB"), mu = 0.5, sd = 3)
+ expect_true("varA:varB" %in% names(list_var$interactions))
+})
+
+test_that("add_interaction throws an error for invalid variables", {
+ list_var <- init_variable(name = "varA", mu = 1, sd = 1, level = 2)
+ expect_error(add_interaction(list_var, between_var = c("varA", "varB"), mu = 0.5, sd = NA))
+})
+
+
+test_that("getNumberOfCombinationsInInteraction calculates the number of combinations", {
+ list_var <- init_variable(name = "varA", mu = 1, sd = 1, level = 2)
+ list_var <- init_variable(list_var, name = "varB", mu = 2, sd = 1, level = 3)
+ expect_equal(getNumberOfCombinationsInInteraction(list_var, c("varA", "varB")), 6)
+})
+
+test_that("getLabels generates labels for variables", {
+ labels <- getLabels(c("varA", "varB"), c(2, 3))
+ expect_equal(length(labels), 2)
+ expect_equal(length(labels[[1]]), 2)
+ expect_equal(length(labels[[2]]), 3)
+})
+
+test_that("getGridCombination generates a grid of combinations", {
+ labels <- list(A = c("A1", "A2"), B = c("B1", "B2", "B3"))
+ grid_combination <- getGridCombination(labels)
+ expect_equal(dim(grid_combination), c(6, 2))
+})
+
+```
+
+```{r function-mvrnorm, filename = "datafrommvrnorm_manipulations" }
+#' getInput2mvrnorm
+#'
+#' @inheritParams init_variable
+#'
+#' @return
+#' a list that can be used as input for MASS::mvrnorm
+#' @export
+#'
+#' @examples
+#' list_var <- init_variable(name = "my_var", mu = 0, sd = 2, level = 3)
+#' getInput2mvrnorm(list_var)
+getInput2mvrnorm <- function(list_var){
+ # -- pick up sd provided by user
+ variable_standard_dev <- getGivenAttribute(list_var, attribute = "sd") %>% unlist()
+ interaction_standard_dev <- getGivenAttribute(list_var$interactions, attribute = "sd") %>% unlist()
+ list_stdev_2covmatx <- c(variable_standard_dev, interaction_standard_dev)
+ if (is.null(list_stdev_2covmatx)) ## NO SD provided
+ return(list(mu = NULL, covMatrix = NULL))
+
+ # - COV matrix
+ covar_userProvided = getGivenAttribute(list_var$correlations, "covar")
+ covMatrix <- getCovarianceMatrix(list_stdev_2covmatx, covar_userProvided)
+
+ # -- MU
+ variable_mu <- getGivenAttribute(list_var, attribute = "mu") %>% unlist()
+ interaction_mu <- getGivenAttribute(list_var$interactions, attribute = "mu") %>% unlist()
+ list_mu <- c(variable_mu, interaction_mu)
+
+ return(list(mu = list_mu, covMatrix = covMatrix))
+
+}
+
+
+#' getCovarianceMatrix
+#' @param list_stdev standard deviation list
+#' @param list_covar covariance list
+#'
+#' @return
+#' covariance matrix
+#' @export
+#'
+#' @examples
+#' vector_sd <- c(1,2, 3)
+#' names(vector_sd) <- c("varA", "varB", "varC")
+#' vector_covar <- c(8, 12, 24)
+#' names(vector_covar) <- c("varA.varB", "varA.varC", "varB.varC")
+#' covMatrix <- getCovarianceMatrix(vector_sd, vector_covar)
+getCovarianceMatrix <- function(list_stdev, list_covar){
+ # -- cov(A, A) = sd(A)^2
+ diag_cov <- list_stdev^2
+ dimension <- length(diag_cov)
+ covariance_matrix <- matrix(0,nrow = dimension, ncol = dimension)
+ diag(covariance_matrix) <- diag_cov
+ colnames(covariance_matrix) <- paste("label", names(diag_cov), sep = "_")
+ rownames(covariance_matrix) <- paste("label", names(diag_cov), sep = "_")
+ names_covaration <- names(list_covar)
+
+ ###### -- utils -- #####
+ convertDF <- function(name, value){
+ ret <- data.frame(value)
+ colnames(ret) <- name
+ ret
+ }
+
+ ## -- needed to use reduce after ;)
+ l_covarUserDf <- lapply(names_covaration, function(n_cov) convertDF(n_cov, list_covar[n_cov] ))
+ covariance_matrix2ret <- Reduce(fillInCovarMatrice, x = l_covarUserDf, init = covariance_matrix)
+ covariance_matrix2ret
+}
+
+
+#' Fill in Covariance Matrix
+#'
+#' This function updates the covariance matrix with the specified covariance value between two variables.
+#'
+#' @param covarMatrice The input covariance matrix.
+#' @param covar A data frame containing the covariance value between two variables.
+#' @return The updated covariance matrix with the specified covariance value filled in.
+#' @export
+#' @examples
+#' covarMat <- matrix(0, nrow = 3, ncol = 3)
+#' colnames(covarMat) <- c("label_varA", "label_varB", "label_varC")
+#' rownames(covarMat) <- c("label_varA", "label_varB", "label_varC")
+#' covarValue <- data.frame("varA.varB" = 0.5)
+#' fillInCovarMatrice(covarMatrice = covarMat, covar = covarValue)
+fillInCovarMatrice <- function(covarMatrice, covar){
+ varsInCovar <- strsplit(colnames(covar), split = "[.]") %>% unlist()
+ index_matrix <- paste("label",varsInCovar, sep = "_")
+ covar_value <- covar[1,1]
+ covarMatrice[index_matrix[1], index_matrix[2]] <- covar_value
+ covarMatrice[index_matrix[2], index_matrix[1]] <- covar_value
+ return(covarMatrice)
+}
+
+
+#' Check if a matrix is positive definite
+#' This function checks whether a given matrix is positive definite, i.e., all of its eigenvalues are positive.
+#' @param mat The matrix to be checked.
+#' @return A logical value indicating whether the matrix is positive definite.
+#' @export
+#' @examples
+#' # Create a positive definite matrix
+#' mat1 <- matrix(c(4, 2, 2, 3), nrow = 2)
+#' is_positive_definite(mat1)
+#' # Expected output: TRUE
+#'
+#' # Create a non-positive definite matrix
+#' mat2 <- matrix(c(4, 2, 2, -3), nrow = 2)
+#' is_positive_definite(mat2)
+#' # Expected output: FALSE
+#'
+#' # Check an empty matrix
+#' mat3 <- matrix(nrow = 0, ncol = 0)
+#' is_positive_definite(mat3)
+#' # Expected output: TRUE
+#'
+#' @export
+is_positive_definite <- function(mat) {
+ if (nrow(mat) == 0 && ncol(mat) == 0) return(TRUE)
+ eigenvalues <- eigen(mat)$values
+ all(eigenvalues > 0)
+}
+
+
+
+#' getGeneMetadata
+#'
+#' @inheritParams init_variable
+#' @param n_genes Number of genes to simulate
+#'
+#' @return
+#' metadata matrix
+#'
+#' @export
+#'
+#' @examples
+#' list_var <- init_variable()
+#' metadata <- getGeneMetadata(list_var, n_genes = 10)
+getGeneMetadata <- function(list_var, n_genes) {
+ metaData <- generateGridCombination_fromListVar(list_var)
+ n_combinations <- dim(metaData)[1]
+ genes_vec <- base::paste("gene", 1:n_genes, sep = "")
+ geneID <- rep(genes_vec, each = n_combinations)
+ metaData <- cbind(geneID, metaData)
+
+ return(metaData)
+}
+
+
+#' getDataFromMvrnorm
+#'
+#' @inheritParams init_variable
+#' @param input2mvrnorm list with mu and covariance matrix, output of getInput2mvrnorm
+#' @param n_genes Number of genes to simulate
+#'
+#' @return
+#' data simulated from multivariate normal distribution
+#'
+#' @export
+#'
+#' @examples
+#' list_var <- init_variable()
+#' input <- getInput2mvrnorm(list_var)
+#' simulated_data <- getDataFromMvrnorm(list_var, input, n_genes = 10)
+getDataFromMvrnorm <- function(list_var, input2mvrnorm, n_genes = 1) {
+ if (is.null(input2mvrnorm$covMatrix))
+ return(list())
+
+ metaData <- getGeneMetadata(list_var, n_genes)
+ n_tirages <- dim(metaData)[1]
+
+ mtx_mvrnormSamplings <- samplingFromMvrnorm(n_samplings = n_tirages,
+ l_mu = input2mvrnorm$mu, matx_cov = input2mvrnorm$covMatrix)
+
+ dataFromMvrnorm <- cbind(metaData, mtx_mvrnormSamplings)
+
+ return(list(dataFromMvrnorm))
+}
+
+
+#' getDataFromMvrnorm
+#'
+#' @param n_samplings number of samplings using mvrnorm
+#' @param l_mu vector of mu
+#' @param matx_cov covariance matrix
+#'
+#' @return
+#' samples generated from multivariate normal distribution
+#'
+#' @export
+#'
+#' @examples
+#' n <- 100
+#' mu <- c(0, 0)
+#' covMatrix <- matrix(c(1, 0.5, 0.5, 1), ncol = 2)
+#' samples <- samplingFromMvrnorm(n_samplings = n, l_mu = mu, matx_cov = covMatrix)
+samplingFromMvrnorm <- function(n_samplings, l_mu, matx_cov) {
+ mvrnormSamp <- MASS::mvrnorm(n = n_samplings, mu = l_mu, Sigma = matx_cov, empirical = TRUE)
+
+ return(mvrnormSamp)
+}
+
+```
+
+```{r tests-mvrnorm}
+test_that("getInput2mvrnorm returns the correct list", {
+ list_var <- init_variable()
+ input <- getInput2mvrnorm(list_var)
+ expect_is(input, "list")
+ expect_true("mu" %in% names(input))
+ expect_true("covMatrix" %in% names(input))
+})
+
+
+test_that("fillInCovarMatrice returns the correct matrix", {
+ covarMat <- matrix(0, nrow = 3, ncol = 3)
+ colnames(covarMat) <- c("label_varA", "label_varB", "label_varC")
+ rownames(covarMat) <- c("label_varA", "label_varB", "label_varC")
+ covarValue <- data.frame("varA.varB" = 18)
+ matrice <- fillInCovarMatrice(covarMatrice = covarMat, covar = covarValue)
+
+ expected_matrice <- matrix(0, nrow = 3, ncol = 3)
+ colnames(expected_matrice) <- c("label_varA", "label_varB", "label_varC")
+ rownames(expected_matrice) <- c("label_varA", "label_varB", "label_varC")
+ expected_matrice["label_varA", "label_varB"] <- 18
+ expected_matrice["label_varB", "label_varA"] <- 18
+ expect_identical(matrice, expected_matrice)
+})
+
+test_that("getCovarianceMatrix returns the correct covariance matrix", {
+ vector_sd <- c(1,2, 3)
+ names(vector_sd) <- c("varA", "varB", "varC")
+ vector_covar <- c(8, 12, 24)
+ names(vector_covar) <- c("varA.varB", "varA.varC", "varB.varC")
+ covMatrix <- getCovarianceMatrix(vector_sd, vector_covar)
+
+ expect_is(covMatrix, "matrix")
+ expect_equal(dim(covMatrix), c(3, 3))
+ expected_matrix <- matrix(c(1,8,12,8,4,24, 12,24,9), nrow = 3, byrow = T)
+ rownames(expected_matrix) <- c("label_varA", "label_varB", "label_varC")
+ colnames(expected_matrix) <- c("label_varA", "label_varB", "label_varC")
+ expect_equal(expected_matrix, covMatrix)
+})
+
+test_that("getGeneMetadata returns the correct metadata", {
+ list_var <- init_variable()
+ n_genes <- 10
+ metadata <- getGeneMetadata(list_var, n_genes)
+ expect_is(metadata, "data.frame")
+ expect_equal(colnames(metadata), c("geneID", paste("label", (attributes(list_var)$names), sep ="_")))
+ expect_equal(nrow(metadata), n_genes * list_var$myVariable$level)
+})
+
+test_that("getDataFromMvrnorm returns the correct data", {
+ list_var <- init_variable(name = "varA", mu = 1, sd = 4, level = 3) %>% init_variable("varB", mu = 2, sd = 1, level = 2)
+ input <- getInput2mvrnorm(list_var)
+ n_genes <- 10
+ n_samplings <- n_genes * (list_var$varA$level ) * (list_var$varB$level )
+ data <- getDataFromMvrnorm(list_var, input, n_genes)
+ expect_is(data, "list")
+ expect_equal(length(data), 1)
+ expect_is(data[[1]], "data.frame")
+ expect_equal(nrow(data[[1]]), n_samplings)
+
+})
+
+test_that("getDataFromMvrnomr returns empty list",{
+ list_var <- init_variable()
+ input <- getInput2mvrnorm(list_var)
+ n_genes <- 10
+ n_samplings <- n_genes * (list_var$varA$level ) * (list_var$varB$level )
+ data <- getDataFromMvrnorm(list_var, input, n_genes)
+ expect_is(data, "list")
+ expect_equal(data, list())
+})
+
+test_that("samplingFromMvrnorm returns the correct sampling", {
+ n_samplings <- 100
+ l_mu <- c(1, 2)
+ matx_cov <- matrix(c(1, 0.5, 0.5, 1), ncol = 2)
+ sampling <- samplingFromMvrnorm(n_samplings, l_mu, matx_cov)
+
+ expect_is(sampling, "matrix")
+ expect_equal(dim(sampling), c(n_samplings, length(l_mu)))
+})
+
+
+```
+
+```{r function-dataFromUser, filename = "datafromUser_manipulations"}
+
+#' Get data from user
+#'
+#'
+#' @param list_var A list of variables (already initialized)
+#' @return A list of data to join
+#' @export
+#'
+#' @examples
+#' getDataFromUser(init_variable())
+getDataFromUser <- function(list_var) {
+ variable_data2join <- getGivenAttribute(list_var, "data")
+ id_var2join <- names(variable_data2join)
+ interaction_data2join <- getGivenAttribute(list_var$interactions, "data")
+ id_interaction2join <- names(interaction_data2join)
+
+ data2join <- list(variable_data2join, interaction_data2join) %>%
+ unlist(recursive = FALSE)
+ id2join <- c(id_var2join, id_interaction2join)
+ l_data2join <- lapply(id2join, function(id) data2join[[id]])
+
+ return(l_data2join)
+}
+
+```
+
+```{r test-dataFromUser}
+# Test unitaires pour la fonction join_dtf
+test_that("join_dtf réalise la jointure correctement", {
+ # Création de données de test
+ df1 <- data.frame(id = 1:5, value = letters[1:5])
+ df2 <- data.frame(id = 1:5, category = LETTERS[1:5])
+
+ # Exécution de la fonction
+ result <- join_dtf(df1, df2, "id", "id")
+
+ # Vérification des résultats
+ expect_true(is.data.frame(result))
+ expect_equal(nrow(result), 5)
+ expect_equal(ncol(result), 3)
+ expect_equal(names(result), c("id", "value", "category"))
+ expect_true(all.equal(result$id, df1$id))
+ expect_true(all.equal(result$id, df2$id))
+})
+
+
+# Test unitaires pour la fonction getDataFromUser
+test_that("getDataFromUser renvoie les données appropriées", {
+ # Exécution de la fonction
+ list_var <- init_variable()
+ list_var <- init_variable(list_var, "second_var")
+ result <- getDataFromUser(list_var)
+
+ # Vérification des résultats
+ expect_true(is.list(result))
+ expect_equal(length(result), 2)
+ expect_true(all(sapply(result, is.data.frame)))
+ expect_equal(names(result[[1]]), c("label_myVariable", "myVariable"))
+})
+```
+
+```{r function-setCorrelation, filename = "setCorrelation"}
+
+#' Compute Covariation from Correlation and Standard Deviations
+#'
+#' This function computes the covariation between two variables (A and B) given their correlation and standard deviations.
+#'
+#' @param corr_AB The correlation coefficient between variables A and B.
+#' @param sd_A The standard deviation of variable A.
+#' @param sd_B The standard deviation of variable B.
+#'
+#' @return The covariation between variables A and B.
+#' @export
+#' @examples
+#' corr <- 0.7
+#' sd_A <- 3
+#' sd_B <- 4
+#' compute_covariation(corr, sd_A, sd_B)
+compute_covariation <- function(corr_AB, sd_A, sd_B) {
+ cov_AB <- corr_AB * sd_A * sd_B
+ return(cov_AB)
+}
+
+
+#' Get Standard Deviations for Variables in Correlation
+#'
+#' This function extracts the standard deviations for the variables involved in the correlation.
+#'
+#' @param list_var A list containing the variables and their attributes.
+#' @param between_var A character vector containing the names of the variables involved in the correlation.
+#'
+#' @return A numeric vector containing the standard deviations for the variables in the correlation.
+#' @export
+#' @examples
+#' list_var <- init_variable(name = "varA", mu = 0, sd = 5, level = 3) %>%
+#' init_variable(name = "varB", mu = 0, sd = 25, level = 3)
+#' between_var <- c("varA", "varB")
+#' getStandardDeviationInCorrelation(list_var, between_var)
+getStandardDeviationInCorrelation <- function(list_var, between_var){
+ for (var in between_var) sd_List <- getGivenAttribute(list_var, "sd")
+ for (var in between_var) sd_ListFromInteraction <- getGivenAttribute(list_var$interactions, "sd")
+ sd_List <- c(sd_List, sd_ListFromInteraction)
+ return(unname(unlist(sd_List[between_var])))
+}
+
+
+
+#' Set Correlation between Variables
+#'
+#' Set the correlation between two or more variables in a simulation.
+#'
+#' @param list_var A list containing the variables used in the simulation, initialized using \code{\link{init_variable}}.
+#' @param between_var Character vector specifying the names of the variables to set the correlation between.
+#' @param corr Numeric value specifying the desired correlation between the variables.
+#'
+#' @return Updated \code{list_var} with the specified correlation set between the variables.
+#'
+#' @details The function checks if the variables specified in \code{between_var} are declared and initialized in the \code{list_var}. It also ensures that at least two variables with provided standard deviation are required to set a correlation in the simulation.
+#' The specified correlation value must be within the range (-1, 1). The function computes the corresponding covariance between the variables based on the specified correlation and standard deviations.
+#' The correlation information is then added to the \code{list_var} in the form of a data frame containing the correlation value and the corresponding covariance value.
+#' @export
+#' @examples
+#' list_var <- init_variable(name = "varA", mu = 0, sd = 5, level = 3) %>%
+#' init_variable(name = "varB", mu = 0, sd = 25, level = 3)
+#' list_var <- set_correlation(list_var, between_var = c("varA", "varB"), corr = 0.7)
+set_correlation <- function(list_var, between_var, corr) {
+
+ # Check if variables in between_var are declared and initialized
+ bool_checkBetweenVarValidity <- function(between_var, list_var) {
+ nb_varInCorrelation <- length(unique(between_var))
+ stopifnot(nb_varInCorrelation > 1)
+ # -- check also for interaction
+ varInitialized <- c(getListVar(list_var), getListVar(list_var$interactions))
+ existingVar_nb <- varInitialized %in% between_var %>% sum()
+ if (existingVar_nb != nb_varInCorrelation) {
+ return(FALSE)
+ } else {
+ return(TRUE)
+ }
+ }
+
+ name_correlation <- paste(between_var, collapse = ".")
+ bool_valid_corr <- bool_checkBetweenVarValidity(between_var, list_var)
+ if (!bool_valid_corr) {
+ stop("At least one variable in between_var is not declared. Variable not initialized cannot be used in a correlation.")
+ }
+
+ vec_standardDev <- getStandardDeviationInCorrelation(list_var, between_var)
+ if (length(vec_standardDev) < 2) {
+ stop("Exactly two variables with provided standard deviation are required to set a correlation in simulation.")
+ }
+ # Validate the specified correlation value to be within the range [-1, 1]
+ if (corr < -1 || corr > 1) {
+ stop("Invalid correlation value. Correlation must be in the range [-1, 1].")
+ }
+
+ name_interaction <- paste(between_var, collapse = ":")
+ corr <- data.frame(cor = corr, covar = compute_covariation(corr, vec_standardDev[1], vec_standardDev[2] ))
+ list_var$correlations[[name_correlation]] <- corr
+ return(list_var)
+}
+
+
+```
+
+```{r test-setcorrelation}
+
+test_that("compute_covariation returns the correct covariation", {
+ # Test case 1: Positive correlation
+ corr <- 0.7
+ sd_A <- 3
+ sd_B <- 4
+ expected_cov <- corr * sd_A * sd_B
+ actual_cov <- compute_covariation(corr, sd_A, sd_B)
+ expect_equal(actual_cov, expected_cov)
+
+ # Test case 2: Negative correlation
+ corr <- -0.5
+ sd_A <- 2.5
+ sd_B <- 3.5
+ expected_cov <- corr * sd_A * sd_B
+ actual_cov <- compute_covariation(corr, sd_A, sd_B)
+ expect_equal(actual_cov, expected_cov)
+
+ # Test case 3: Zero correlation
+ corr <- 0
+ sd_A <- 1
+ sd_B <- 2
+ expected_cov <- corr * sd_A * sd_B
+ actual_cov <- compute_covariation(corr, sd_A, sd_B)
+ expect_equal(actual_cov, expected_cov)
+})
+
+
+# Unit tests for getStandardDeviationInCorrelation
+test_that("getStandardDeviationInCorrelation returns correct standard deviations", {
+
+ # Initialize list_var
+ list_var <- init_variable(name = "varA", mu = 0, sd = 5, level = 3) %>%
+ init_variable(name = "varB", mu = 0, sd = 25, level = 3)
+
+ # Test case 1: Two variables correlation
+ between_var_1 <- c("varA", "varB")
+ sd_expected_1 <- c(5, 25)
+ sd_result_1 <- getStandardDeviationInCorrelation(list_var, between_var_1)
+ expect_equal(sd_result_1, sd_expected_1)
+
+})
+
+
+
+test_that("set_correlation sets the correlation between variables correctly", {
+ # Initialize variables in the list_var
+ list_var <- init_variable(name = "varA", mu = 0, sd = 5, level = 3) %>%
+ init_variable(name = "varB", mu = 0, sd = 25, level = 3)
+
+ # Test setting correlation between varA and varB
+ list_var <- set_correlation(list_var, between_var = c("varA", "varB"), corr = 0.7)
+
+ corr_result <- list_var$correlations$varA.varB$cor
+ covar_result <- list_var$correlations$varA.varB$covar
+ expect_equal(corr_result, 0.7)
+ expect_equal(covar_result, 87.5)
+
+ # Test setting correlation between varA and varC (should raise an error)
+ expect_error(set_correlation(list_var, between_var = c("varA", "varC"), corr = 0.8),
+ "At least one variable in between_var is not declared. Variable not initialized cannot be used in a correlation.")
+
+ # Test setting correlation with invalid correlation value
+ expect_error(set_correlation(list_var, between_var = c("varA", "varB"), corr = 1.5))
+
+ # Test setting correlation with less than 2 variables with provided standard deviation
+ expect_error(set_correlation(list_var, between_var = c("varA"), corr = 0.7))
+})
+
+
+```
+
+```{r function-simulation , filename = "simulation"}
+#' Get input for simulation based on coefficients
+#'
+#' This function generates input data for simulation based on the coefficients provided in the \code{list_var} argument.
+#'
+#' @param list_var A list of variables (already initialized)
+#' @param n_genes Number of genes to simulate (default: 1)
+#' @param input2mvrnorm Input to the \code{mvrnorm} function for simulating data from multivariate normal distribution (default: NULL)
+#' @return A data frame with input coefficients for simulation
+#' @export
+#' @examples
+#' # Example usage
+#' list_var <- init_variable()
+#' getInput2simulation(list_var, n_genes = 10)
+getInput2simulation <- function(list_var, n_genes = 1, input2mvrnorm = NULL) {
+
+ # Use default input to mvrnorm if not provided by the user
+ if (is.null(input2mvrnorm)) input2mvrnorm = getInput2mvrnorm(list_var)
+
+ l_dataFromMvrnorm = getDataFromMvrnorm(list_var, input2mvrnorm, n_genes)
+ l_dataFromUser = getDataFromUser(list_var)
+ df_input2simu <- getCoefficients(list_var, l_dataFromMvrnorm, l_dataFromUser, n_genes)
+ return(df_input2simu)
+}
+
+#' getCoefficients
+#'
+#' Get the coefficients.
+#'
+#' @param list_var A list of variables (already initialized)
+#' @param l_dataFromMvrnorm Data from the `getGeneMetadata` function (optional).
+#' @param l_dataFromUser Data from the `getDataFromUser` function (optional).
+#' @param n_genes The number of genes.
+#' @export
+#' @return A dataframe containing the coefficients.
+#' @examples
+#' # Example usage
+#' list_var <- init_variable()
+#' input2mvrnorm = getInput2mvrnorm(list_var)
+#' l_dataFromMvrnorm = getDataFromMvrnorm(list_var, input2mvrnorm, n_genes)
+#' l_dataFromUser = getDataFromUser(list_var)
+#' getCoefficients(list_var, l_dataFromMvrnorm, l_dataFromUser, n_genes = 3)
+getCoefficients <- function(list_var, l_dataFromMvrnorm, l_dataFromUser, n_genes) {
+ if (length(l_dataFromMvrnorm) == 0) {
+ metaData <- getGeneMetadata(list_var, n_genes)
+ l_dataFromMvrnorm <- list(metaData)
+ }
+ l_df2join <- c(l_dataFromMvrnorm, l_dataFromUser)
+
+
+ df_coef <- Reduce(function(d1, d2){ column_names = colnames(d2)
+ idx_key = grepl(pattern = "label", column_names )
+ keys = column_names[idx_key]
+ join_dtf(d1, d2, k1 = keys , k2 = keys)
+ }
+ , l_df2join ) %>% as.data.frame()
+ column_names <- colnames(df_coef)
+ idx_column2factor <- grep(pattern = "label_", column_names)
+
+ if (length(idx_column2factor) > 1) {
+ df_coef[, idx_column2factor] <- lapply(df_coef[, idx_column2factor], as.factor)
+ } else {
+ df_coef[, idx_column2factor] <- as.factor(df_coef[, idx_column2factor])
+ }
+
+ return(df_coef)
+}
+
+
+#' Get the log_qij values from the coefficient data frame.
+#'
+#' @param dtf_coef The coefficient data frame.
+#' @return The coefficient data frame with log_qij column added.
+#' @export
+getLog_qij <- function(dtf_coef) {
+ dtf_beta_numeric <- dtf_coef[sapply(dtf_coef, is.numeric)]
+ dtf_coef$log_qij <- rowSums(dtf_beta_numeric, na.rm = TRUE)
+ return(dtf_coef)
+}
+
+
+#' Calculate mu_ij values based on coefficient data frame and scaling factor
+#'
+#' This function calculates mu_ij values by raising 2 to the power of the log_qij values
+#' from the coefficient data frame and multiplying it by the provided scaling factor.
+#'
+#' @param dtf_coef Coefficient data frame containing the log_qij values
+#'
+#' @return Coefficient data frame with an additional mu_ij column
+#'
+#' @examples
+#' list_var <- init_variable()
+#' dtf_coef <- getInput2simulation(list_var, 10)
+#' dtf_coef <- getLog_qij(dtf_coef)
+#' dtf_coef <- addBasalExpression(dtf_coef, 10, c(10, 20, 0))
+#' getMu_ij(dtf_coef)
+#' @export
+getMu_ij <- function(dtf_coef) {
+ log_qij_scaled <- dtf_coef$log_qij + dtf_coef$basalExpr
+ dtf_coef$log_qij_scaled <- log_qij_scaled
+ mu_ij <- exp(log_qij_scaled)
+ dtf_coef$mu_ij <- mu_ij
+ return(dtf_coef)
+}
+
+#' getMu_ij_matrix
+#'
+#' Get the Mu_ij matrix.
+#'
+#' @param dtf_coef A dataframe containing the coefficients.
+#' @importFrom reshape2 dcast
+#' @importFrom stats as.formula
+
+#' @export
+#' @return A Mu_ij matrix.
+getMu_ij_matrix <- function(dtf_coef) {
+ column_names <- colnames(dtf_coef)
+ idx_var <- grepl(pattern = "label", column_names)
+ l_var <- column_names[idx_var]
+ str_formula_rigth <- paste(l_var, collapse = " + ")
+ if (str_formula_rigth == "") stop("no variable label detected")
+ str_formula <- paste(c("geneID", str_formula_rigth), collapse = " ~ ")
+ formula <- stats::as.formula(str_formula)
+ dtf_Muij <- dtf_coef %>% reshape2::dcast(formula = formula, value.var = "mu_ij", drop = F)
+ dtf_Muij[is.na(dtf_Muij)] <- 0
+ mtx_Muij <- data.frame(dtf_Muij[, -1], row.names = dtf_Muij[, 1]) %>% as.matrix()
+ mtx_Muij <- mtx_Muij[, order(colnames(mtx_Muij)), drop = F]
+ return(mtx_Muij)
+}
+
+#' getSubCountsTable
+#'
+#' Get the subcounts table.
+#'
+#' @param matx_Muij The Mu_ij matrix.
+#' @param matx_dispersion The dispersion matrix.
+#' @param replicateID The replication identifier.
+#' @param l_bool_replication A boolean vector indicating the replicates.
+#' @importFrom stats rnbinom
+#'
+#' @return A subcounts table.
+getSubCountsTable <- function(matx_Muij, matx_dispersion, replicateID, l_bool_replication) {
+ getKijMatrix <- function(matx_Muij, matx_dispersion, n_genes, n_samples) {
+ k_ij <- stats::rnbinom(n_genes * n_samples,
+ size = matx_dispersion,
+ mu = matx_Muij) %>%
+ matrix(nrow = n_genes, ncol = n_samples)
+
+ k_ij[is.na(k_ij)] <- 0
+ return(k_ij)
+ }
+
+ if (!any(l_bool_replication))
+ return(NULL)
+
+ matx_Muij <- matx_Muij[, l_bool_replication, drop = FALSE]
+ matx_dispersion <- matx_dispersion[, l_bool_replication, drop = FALSE]
+ l_sampleID <- colnames(matx_Muij)
+ l_geneID <- rownames(matx_Muij)
+ dimension_mtx <- dim(matx_Muij)
+ n_genes <- dimension_mtx[1]
+ n_samples <- dimension_mtx[2]
+ matx_kij <- getKijMatrix(matx_Muij, matx_dispersion, n_genes, n_samples)
+ colnames(matx_kij) <- paste(l_sampleID, replicateID, sep = "_")
+ rownames(matx_kij) <- l_geneID
+ return(matx_kij)
+}
+
+
+```
+
+```{r test-simulation}
+
+
+# Test case 1: Check if the function returns a data frame
+test_that("getInput2simulation returns a data frame", {
+ list_var <- init_variable()
+ result <- getInput2simulation(list_var)
+ expect_is(result, "data.frame")
+ expected <- data.frame(geneID = c("gene1", "gene1"), label_myVariable = as.factor(c("myVariable1", "myVariable2")), myVariable = c(2,3))
+ expect_equal(result, expected)
+ })
+
+# Test for getCoefficients function
+test_that("getCoefficients returns the correct output", {
+ # Create dummy data
+ n_genes <- 3
+ list_var = init_variable()
+ # Call the function
+ coefficients <- getCoefficients(list_var, list(), list(), n_genes)
+
+ # Check the output
+ expect_equal(nrow(coefficients), n_genes*list_var$myVariable$level)
+ expect_equal(colnames(coefficients), c("geneID", "label_myVariable"))
+})
+
+# Test for getMu_ij_matrix function
+test_that("getMu_ij_matrix returns the correct output", {
+ # Create a dummy coefficients dataframe
+ dtf_coef <- data.frame(geneID = c("Gene1", "Gene1", "Gene1"),
+ label_varA = c("A1", "A2", "A3"),
+ label_varB = c("B1", "B2", "B3"),
+ mu_ij = c(1, 2, 3))
+
+ # Call the function
+ mu_matrix <- getMu_ij_matrix(dtf_coef)
+ # Check the output
+ expect_equal(dim(mu_matrix), c(1, 9))
+
+})
+
+# Test for getSubCountsTable function
+test_that("getSubCountsTable returns the correct output", {
+ # Create dummy data
+ l_genes <- c("gene1", "gene2", "gene3")
+ matx_Muij = data.frame(sple1 = c(1,3,4), sple2 = c(2, 0, 9), sple3 = c(1, 69, 2)) %>% as.matrix()
+ rownames(matx_Muij) <- l_genes
+ matx_dispersion <- matrix(0.5, nrow = 3, ncol = 3)
+ replicateID <- 1
+ l_bool_replication <- c(TRUE, FALSE, TRUE)
+
+ # Call the function
+ subcounts_table <- getSubCountsTable(matx_Muij, matx_dispersion, 1, l_bool_replication)
+
+ # Check the output
+ expect_equal(dim(subcounts_table), c(3, 2))
+ expect_equal(rownames(subcounts_table), l_genes)
+})
+
+
+```
+
+
+```{r function-simulation2 , filename = "simulation2"}
+
+#' getReplicationMatrix
+#'
+#' @param minN Minimum number of replicates for each sample
+#' @param maxN Maximum number of replicates for each sample
+#' @param n_samples Number of samples
+#' @export
+#' @return A replication matrix indicating which samples are replicated
+getReplicationMatrix <- function(minN, maxN, n_samples) {
+
+ # Create a list of logical vectors representing the minimum number of replicates
+ l_replication_minimum = lapply(1:n_samples,
+ FUN = function(i) rep(TRUE, times = minN) )
+
+ # Create a list of random logical vectors representing additional replicates
+ l_replication_random = lapply(1:n_samples,
+ FUN = function(i) sample(x = c(TRUE, FALSE), size = maxN-minN, replace = T) )
+
+ # Combine the replication vectors into matrices
+ matx_replication_minimum <- do.call(cbind, l_replication_minimum)
+ matx_replication_random <- do.call(cbind, l_replication_random)
+
+ # Combine the minimum replicates and random replicates into a single matrix
+ matx_replication <- rbind(matx_replication_minimum, matx_replication_random)
+
+ # Sort the columns of the replication matrix in descending order
+ matx_replication = apply(matx_replication, 2, sort, decreasing = TRUE ) %>% matrix(nrow = maxN)
+
+ return(matx_replication)
+}
+
+#' getCountsTable
+#'
+#' @param matx_Muij Matrix of mean expression values for each gene and sample
+#' @param matx_dispersion Matrix of dispersion values for each gene and sample
+#' @param matx_bool_replication Replication matrix indicating which samples are replicated
+#'
+#' @return A counts table containing simulated read counts for each gene and sample
+getCountsTable <- function(matx_Muij , matx_dispersion, matx_bool_replication ){
+ max_replicates <- dim(matx_bool_replication)[1]
+
+ # Apply the getSubCountsTable function to each row of the replication matrix
+ l_countsTable = lapply(1:max_replicates, function(i) getSubCountsTable(matx_Muij , matx_dispersion, i, matx_bool_replication[i,] ))
+
+ # Combine the counts tables into a single matrix
+ countsTable = do.call(cbind, l_countsTable)
+
+ return(countsTable %>% as.data.frame())
+}
+
+#' getDispersionMatrix
+#'
+#' @param list_var A list of variables (already initialized)
+#' @param n_genes Number of genes
+#' @param dispersion Vector of dispersion values for each gene
+#' @export
+#'
+#' @return A matrix of dispersion values for each gene and sample
+getDispersionMatrix <- function(list_var, n_genes, dispersion = stats::runif(n_genes, min = 0, max = 1000)){
+ l_geneID = base::paste("gene", 1:n_genes, sep = "")
+ l_sampleID = getSampleID(list_var)
+ n_samples = length(l_sampleID)
+ l_dispersion <- dispersion
+
+ # Create a data frame for the dispersion values
+ dtf_dispersion = list(dispersion = l_dispersion) %>% as.data.frame()
+ dtf_dispersion <- dtf_dispersion[, rep("dispersion", n_samples)]
+ rownames(dtf_dispersion) = l_geneID
+ colnames(dtf_dispersion) = l_sampleID
+
+ matx_dispersion = dtf_dispersion %>% as.matrix()
+
+ return(matx_dispersion)
+}
+
+
+
+
+
+#' Replicate rows of a data frame by group
+#'
+#' Replicates the rows of a data frame based on a grouping variable and replication counts for each group.
+#'
+#' @param df Data frame to replicate
+#' @param group_var Name of the grouping variable in the data frame
+#' @param rep_list Vector of replication counts for each group
+#' @return Data frame with replicated rows
+#' @examples
+#' df <- data.frame(group = c("A", "B"), value = c(1, 2))
+#' .replicateByGroup(df, "group", c(2, 3))
+#'
+#' @export
+.replicateByGroup <- function(df, group_var, rep_list) {
+ l_group_var <- df[[group_var]]
+ group_levels <- unique(l_group_var)
+ names(rep_list) <- group_levels
+ group_indices <- rep_list[l_group_var]
+ replicated_indices <- rep(seq_len(nrow(df)), times = group_indices)
+ replicated_df <- df[replicated_indices, ]
+ suffix_sampleID <- sequence(group_indices)
+ replicated_df[["sampleID"]] <- paste(replicated_df[["sampleID"]], suffix_sampleID, sep = "_")
+ rownames(replicated_df) <- NULL
+ return(replicated_df)
+}
+
+
+
+#' Replicate rows of a data frame
+#'
+#' Replicates the rows of a data frame by a specified factor.
+#'
+#' @param df Data frame to replicate
+#' @param n Replication factor for each row
+#' @return Data frame with replicated rows
+#' @export
+#' @examples
+#' df <- data.frame(a = 1:3, b = letters[1:3])
+#' .replicateRows(df, 2)
+#'
+.replicateRows <- function(df, n) {
+ indices <- rep(seq_len(nrow(df)), each = n)
+ replicated_df <- df[indices, , drop = FALSE]
+ rownames(replicated_df) <- NULL
+ return(replicated_df)
+}
+
+#' Get sample metadata
+#'
+#' Generates sample metadata based on the input variables, replication matrix, and number of genes.
+#'
+#' @param list_var A list of variables (already initialized)
+#' @param replicationMatrix Replication matrix
+#' @param n_genes Number of genes
+#' @return Data frame of sample metadata
+#' @importFrom data.table setorderv
+#' @export
+#' @examples
+#' list_var <- init_variable()
+#' n_genes <- 10
+#' replicationMatrix <- generateReplicationMatrix(list_var ,2, 3)
+#' getSampleMetadata(list_var, n_genes, replicationMatrix)
+getSampleMetadata <- function(list_var, n_genes, replicationMatrix) {
+ l_sampleIDs = getSampleID(list_var)
+ metaData <- generateGridCombination_fromListVar(list_var)
+ metaData[] <- lapply(metaData, as.character) ## before reordering
+ data.table::setorderv(metaData, cols = colnames(metaData))
+ metaData[] <- lapply(metaData, as.factor)
+ metaData$sampleID <- l_sampleIDs
+ rep_list <- colSums(replicationMatrix)
+ metaData$sampleID <- as.character(metaData$sampleID) ## before replicating
+ sampleMetadata <- .replicateByGroup(metaData, "sampleID", rep_list)
+ colnames(sampleMetadata) <- gsub("label_", "", colnames(sampleMetadata))
+ return(sampleMetadata)
+}
+
+
+#' getSampleID
+#'
+#' @param list_var A list of variables (already initialized)
+#' @export
+#' @return A sorted vector of sample IDs
+getSampleID <- function(list_var){
+ gridCombination <- generateGridCombination_fromListVar(list_var)
+ l_sampleID <- apply( gridCombination , 1 , paste , collapse = "_" ) %>% unname()
+ return(sort(l_sampleID))
+}
+
+
+```
+
+```{r test-simulations}
+
+test_that("getReplicationMatrix returns the correct replication matrix", {
+ minN <- 2
+ maxN <- 4
+ n_samples <- 3
+ expected <- matrix(c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, TRUE, FALSE), nrow = maxN)
+
+ set.seed(123)
+ result <- getReplicationMatrix(minN, maxN, n_samples)
+
+ expect_equal(result, expected)
+})
+
+test_that("getSampleID return the correct list of sampleID",{
+ expect_equal(getSampleID(init_variable()), c("myVariable1", "myVariable2"))
+})
+
+# Create a test case for getMu_ij
+test_that("getMu_ij returns the correct output", {
+ # Create a sample coefficient data frame
+ dtf_coef <- data.frame(
+ log_qij = c(1, 9, 0.1),
+ basalExpr = c(2, 3, 4)
+ )
+
+ # Call the getMu_ij function
+ result <- getMu_ij(dtf_coef)
+
+ # Check if the mu_ij column is added
+ expect_true("mu_ij" %in% colnames(result))
+
+ # Check the values of mu_ij
+ #expected_mu_ij <- c(20.08554, 162754.79142 , 60.34029)
+ #expect_equal(result$mu_ij, expected_mu_ij, tolerance = 0.000001)
+})
+
+
+# Create a test case for getLog_qij
+test_that("getLog_qij returns the correct output", {
+ # Create a sample coefficient data frame
+ dtf_coef <- data.frame(
+ beta1 = c(1.2, 2.3, 3.4),
+ beta2 = c(0.5, 1.0, 1.5),
+ non_numeric = c("a", "b", "c")
+ )
+
+ # Call the getLog_qij function
+ result <- getLog_qij(dtf_coef)
+
+ # Check if the log_qij column is added
+ expect_true("log_qij" %in% colnames(result))
+
+ # Check the values of log_qij
+ expected_log_qij <- c(1.7, 3.3, 4.9)
+ expect_equal(result$log_qij, expected_log_qij)
+})
+
+test_that("getCountsTable returns the correct counts table", {
+ mat_mu_ij <- matrix(c(1,2,3,4,5,6), ncol = 3, byrow = T)
+ rownames(mat_mu_ij) <- c("gene1", "gene2")
+ colnames(mat_mu_ij) <- c("sample1", "sample2", "sample3")
+ mat_disp <- matrix(c(0.3,0.3,0.3, 0.5,0.5,0.5), ncol = 3, byrow = T)
+ rownames(mat_disp) <- c("gene1", "gene2")
+ colnames(mat_disp) <- c("sample1", "sample2", "sample3")
+ mat_repl <- matrix(c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), ncol = 3, byrow = T)
+
+ expected_df <- matrix(c(0,0,1,0,0,0,0,1,0,2,34,18,0,0,3,10,7,2), nrow = 2, byrow = T) %>% as.data.frame()
+ rownames(expected_df) <- c("gene1", "gene2")
+ colnames(expected_df) <- c("sample1_1", "sample2_1", "sample3_1", "sample1_2",
+ "sample2_2","sample3_2","sample1_3", "sample2_3" ,"sample3_3")
+
+ set.seed(123)
+ result <- getCountsTable(mat_mu_ij, mat_disp, mat_repl)
+
+ expect_true(is.data.frame(result))
+ expect_equal(colnames(result), colnames(expected_df))
+ expect_equal(rownames(result), rownames(expected_df))
+
+})
+
+
+
+test_that("getSampleMetadata returns expected output", {
+ # Set up input variables
+ list_var <- init_variable()
+ n_genes <- 3
+ replicationMatrix <- matrix(TRUE, nrow = 2, ncol = 2)
+
+ # Run the function
+ result <- getSampleMetadata(list_var, n_genes, replicationMatrix)
+
+ # Define expected output
+ expected_colnames <- c("myVariable", "sampleID")
+ expect_equal(colnames(result), expected_colnames)
+
+ # Check the output class
+ expect_true(is.data.frame(result))
+
+ # check nrow output
+ expect_equal(nrow(result), 4)
+
+})
+
+
+test_that(".replicateByGroup return the correct ouptut", {
+ df <- data.frame(group = c("A", "B"), value = c(1, 2))
+ result <- .replicateByGroup(df, "group", c(2, 3))
+
+ expect <- data.frame(group = c("A", "A", "B", "B", "B"),
+ value = c(1, 1, 2,2,2),
+ sampleID = c("_1", "_2", "_1", "_2", "_3" ))
+ expect_equal(result, expect)
+
+})
+
+
+test_that("getDispersionMatrix returns the correct dispersion matrix", {
+ n_genes = 3
+ list_var = init_variable()
+ dispersion <- 1:3
+ expected <- matrix(1:3,byrow = F, nrow = 3, ncol = 2)
+ rownames(expected) <- c("gene1", "gene2", "gene3")
+ colnames(expected) <- c("myVariable1", "myVariable2")
+ result <- getDispersionMatrix(list_var, n_genes, dispersion )
+ expect_equal(result, expected)
+})
+
+
+
+```
+
+
+```{r function-mock , filename = "mock-rnaSeq" }
+
+#' Check the validity of the dispersion matrix
+#'
+#' Checks if the dispersion matrix has the correct dimensions.
+#'
+#' @param matx_dispersion Replication matrix
+#' @param matx_bool_replication Replication matrix
+#' @return TRUE if the dimensions are valid, FALSE otherwise
+#' @export
+#' @examples
+#' matx_dispersion <- matrix(1:12, nrow = 3, ncol = 4)
+#' matx_bool_replication <- matrix(TRUE, nrow = 3, ncol = 4)
+#' .isDispersionMatrixValid(matx_dispersion, matx_bool_replication)
+.isDispersionMatrixValid <- function(matx_dispersion, matx_bool_replication) {
+ expected_nb_column <- dim(matx_bool_replication)[2]
+ if (expected_nb_column != dim(matx_dispersion)[2]) {
+ return(FALSE)
+ }
+ return(TRUE)
+}
+
+#' Generate count table
+#'
+#' Generates the count table based on the mu_ij matrix, dispersion matrix, and replication matrix.
+#'
+#' @param mu_ij_matx_rep Replicated mu_ij matrix
+#' @param matx_dispersion_rep Replicated dispersion matrix
+#' @return Count table
+#' @export
+#' @examples
+#' mu_ij_matx_rep <- matrix(1:12, nrow = 3, ncol = 4)
+#' matx_dispersion_rep <- matrix(1:12, nrow = 3, ncol = 4)
+#' generateCountTable(mu_ij_matx_rep, matx_dispersion_rep)
+generateCountTable <- function(mu_ij_matx_rep, matx_dispersion_rep) {
+ message("k_ij ~ Nbinom(mu_ij, dispersion)")
+ n_genes <- dim(mu_ij_matx_rep)[1]
+ n_samples <- dim(mu_ij_matx_rep)[2]
+ n_samplings <- prod(n_genes * n_samples)
+ mat_countsTable <- rnbinom(n_samplings,
+ size = matx_dispersion_rep,
+ mu = mu_ij_matx_rep) %>%
+ matrix(nrow = n_genes, ncol = n_samples)
+ colnames(mat_countsTable) <- colnames(mu_ij_matx_rep)
+ rownames(mat_countsTable) <- rownames(mu_ij_matx_rep)
+ mat_countsTable[is.na(mat_countsTable)] <- 0
+ return(mat_countsTable)
+}
+
+
+#' Perform RNA-seq simulation
+#'
+#' Simulates RNA-seq data based on the input variables.
+#'
+#' @param list_var List of input variables
+#' @param n_genes Number of genes
+#' @param min_replicates Minimum replication count
+#' @param max_replicates Maximum replication count
+#' @param sequencing_depth Sequencing depth
+#' @param basal_expression base expression gene
+#' @param dispersion User-provided dispersion vector (optional)
+#' @return List containing the ground truth, counts, and metadata
+#' @export
+#' @examples
+#' mock_rnaseq(list_var = init_variable(),
+#' n_genes = 1000, min_replicates = 2,
+#' max_replicates = 4)
+mock_rnaseq <- function(list_var, n_genes, min_replicates, max_replicates, sequencing_depth = NULL,
+ basal_expression = 0 , dispersion = stats::runif(n_genes, min = 0, max = 1000) ) {
+
+ ## -- get my effect
+ df_inputSimulation <- getInput2simulation(list_var, n_genes)
+ ## -- add column logQij
+ df_inputSimulation <- getLog_qij(df_inputSimulation)
+ df_inputSimulation <- addBasalExpression(df_inputSimulation, n_genes, basal_expression)
+ df_inputSimulation <- getMu_ij(df_inputSimulation )
+
+ message("Building mu_ij matrix")
+ ## -- matrix
+ matx_Muij <- getMu_ij_matrix(df_inputSimulation)
+ l_sampleID <- getSampleID(list_var)
+ matx_bool_replication <- generateReplicationMatrix(list_var, min_replicates, max_replicates)
+ mu_ij_matx_rep <- .replicateMatrix(matx_Muij, matx_bool_replication)
+
+
+ dispersion <- getValidDispersion(dispersion)
+ genes_dispersion <- sample(dispersion , size = n_genes, replace = T)
+ matx_dispersion <- getDispersionMatrix(list_var, n_genes, genes_dispersion)
+ l_geneID = base::paste("gene", 1:n_genes, sep = "")
+ names(genes_dispersion) <- l_geneID
+
+ ## same order as mu_ij_matx_rep
+ matx_dispersion <- matx_dispersion[ order(row.names(matx_dispersion)), ]
+ matx_dispersion_rep <- .replicateMatrix(matx_dispersion, matx_bool_replication)
+ matx_countsTable <- generateCountTable(mu_ij_matx_rep, matx_dispersion_rep)
+
+ message("Counts simulation: Done")
+
+
+ dtf_countsTable <- matx_countsTable %>% as.data.frame()
+ if (!is.null(sequencing_depth)) {
+ message("Scaling count table according to sequencing depth.")
+ dtf_countsTable <- scaleCountsTable(dtf_countsTable, sequencing_depth)
+ }
+
+ 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)
+ return(list2ret)
+}
+
+
+
+
+#' Validate and Filter Dispersion Values
+#'
+#' This function takes an input vector and validates it to ensure that it meets certain criteria.
+#'
+#' @param input_vector A vector to be validated.
+#' @return A validated and filtered numeric vector.
+#' @details The function checks whether the input is a vector, suppresses warnings while converting to numeric,
+#' and filters out non-numeric elements. It also checks for values greater than zero and removes negative values.
+#' If the resulting vector has a length of zero, an error is thrown.
+#' @examples
+#' getValidDispersion(c(0.5, 1.2, -0.3, "invalid", 0.8))
+#' @export
+getValidDispersion <- function(input_vector) {
+ # Verify if it's a vector
+ if (!is.vector(input_vector)) {
+ stop("dispersion param is not a vector.")
+ }
+
+ input_vector <- suppressWarnings(as.numeric(input_vector))
+
+ # Filter numeric elements
+ numeric_elements <- !is.na(input_vector)
+ if (sum(!numeric_elements) > 0) {
+ message("Non-numeric elements were removed from the dispersion vector")
+ input_vector <- input_vector[numeric_elements]
+ }
+
+ # Check and filter values > 0
+ numeric_positive_elements <- input_vector > 0
+ if (sum(!numeric_positive_elements) > 0) {
+ message("Negative numeric values were removed from the dispersion vector")
+ input_vector <- input_vector[numeric_positive_elements]
+ }
+
+ if (length(input_vector) == 0) stop("Invalid dispersion values provided.")
+
+ return(input_vector)
+}
+
+
+#' Generate replication matrix
+#'
+#' Generates the replication matrix based on the minimum and maximum replication counts.
+#'
+#' @param list_var Number of samples
+#' @param min_replicates Minimum replication count
+#' @param max_replicates Maximum replication count
+#' @return Replication matrix
+#' @export
+#' @examples
+#' list_var = init_variable()
+#' generateReplicationMatrix(list_var, min_replicates = 2, max_replicates = 4)
+generateReplicationMatrix <- function(list_var, min_replicates, max_replicates) {
+ if (min_replicates > max_replicates) {
+ message("min_replicates > max_replicates have been supplied")
+ message("Automatic reversing")
+ tmp_min_replicates <- min_replicates
+ min_replicates <- max_replicates
+ max_replicates <- tmp_min_replicates
+ }
+ l_sampleIDs <- getSampleID(list_var)
+ n_samples <- length(l_sampleIDs)
+ return(getReplicationMatrix(min_replicates, max_replicates, n_samples = n_samples))
+}
+
+#' Replicate matrix
+#'
+#' Replicates a matrix based on a replication matrix.
+#'
+#' @param matrix Matrix to replicate
+#' @param replication_matrix Replication matrix
+#' @return Replicated matrix
+#' @export
+#' @examples
+#' matrix <- matrix(1:9, nrow = 3, ncol = 3)
+#' replication_matrix <- matrix(TRUE, nrow = 3, ncol = 3)
+#' .replicateMatrix(matrix, replication_matrix)
+.replicateMatrix <- function(matrix, replication_matrix) {
+ n_genes <- dim(matrix)[1]
+ rep_list <- colSums(replication_matrix)
+ replicated_indices <- rep(seq_len(ncol(matrix)), times = rep_list)
+ replicated_matrix <- matrix[, replicated_indices, drop = FALSE]
+ suffix_sampleID <- sequence(rep_list)
+ colnames(replicated_matrix) <- paste(colnames(replicated_matrix), suffix_sampleID, sep = "_")
+ return(replicated_matrix)
+}
+
+
+```
+
+```{r test-hiddenFunction}
+
+# Test case: Valid input vector with numeric and positive values
+test_that("Valid input vector with numeric and positive values", {
+ input_vector <- c(0.5, 1.2, 0.8)
+ result <- getValidDispersion(input_vector)
+ expect_identical(result, input_vector)
+})
+
+# Test case: Valid input vector with numeric, positive, and negative values
+test_that("Valid input vector with numeric, positive, and negative values", {
+ input_vector <- c(0.5, -0.3, 1.2, 0.8)
+ result <- getValidDispersion(input_vector)
+ expect_identical(result, c(0.5, 1.2, 0.8))
+})
+
+# Test case: Valid input vector with non-numeric elements
+test_that("Valid input vector with non-numeric elements", {
+ input_vector <- c(0.5, "invalid", 0.8)
+ result <- getValidDispersion(input_vector)
+ expect_identical(result, c(0.5, 0.8))
+})
+
+# Test case: Empty input vector
+test_that("Empty input vector", {
+ input_vector <- numeric(0)
+ expect_error(getValidDispersion(input_vector), "Invalid dispersion values provided.")
+})
+
+# Test case: unique value in vector
+test_that("unique value in vector", {
+ input_vector <- 5
+ expect_equal(getValidDispersion(input_vector), 5)
+})
+
+# Test case: All negative values
+test_that("All negative values", {
+ input_vector <- c(-0.5, -1.2, -0.8)
+ expect_error(getValidDispersion(input_vector), "Invalid dispersion values provided.")
+})
+
+
+# Test for .isDispersionMatrixValid
+test_that(".isDispersionMatrixValid returns TRUE for valid dimensions", {
+ matx_dispersion <- matrix(1:6, nrow = 2, ncol = 3)
+ matx_bool_replication <- matrix(TRUE, nrow = 2, ncol = 3)
+ expect_true(.isDispersionMatrixValid(matx_dispersion, matx_bool_replication))
+})
+
+test_that(".isDispersionMatrixValid throws an error for invalid dimensions", {
+ matx_dispersion <- matrix(1:4, nrow = 2, ncol = 2)
+ matx_bool_replication <- matrix(TRUE, nrow = 2, ncol = 3)
+ expect_false(.isDispersionMatrixValid(matx_dispersion, matx_bool_replication))
+})
+
+# Test for generateCountTable
+test_that("generateCountTable generates count table with correct dimensions", {
+ mu_ij_matx_rep <- matrix(1:6, nrow = 2, ncol = 3)
+ matx_dispersion_rep <- matrix(1:6, nrow = 2, ncol = 3)
+ count_table <- generateCountTable(mu_ij_matx_rep, matx_dispersion_rep)
+ expect_equal(dim(count_table), c(2, 3))
+})
+
+
+
+# Test for .replicateMatrix
+test_that(".replicateMatrix replicates matrix correctly", {
+ matrix <- matrix(1:9, nrow = 3, ncol = 3)
+ replication_matrix <- matrix(TRUE, nrow = 3, ncol = 3)
+ replicated_matrix <- .replicateMatrix(matrix, replication_matrix)
+ expect_equal(dim(replicated_matrix), c(3, 9))
+})
+
+```
+
+```{r test-mock}
+
+# Test for mock_rnaseq
+#test_that("mock_rnaseq returns expected output", {
+ # Set up input variables
+# list_var <- NULL
+# n_genes <- 3
+# min_replicates <- 2
+# max_replicates <- 4
+# df_inputSimulation <- data.frame(gene_id = 1:3, coef_value = c(0.5, 0.3, 0.2))
+# matx_dispersion <- matrix(1:9, nrow = 3, ncol = 3)
+
+ # Run the function
+# expect_error(mock_rnaseq(list_var, n_genes, min_replicates, max_replicates, df_inputSimulation,
+# matx_dispersion))
+
+
+ #list_var <- init_variable(name = "my_var", mu = c(10, 20), level = 2 )
+ #n_genes <- 10
+ #min_replicates <- 2
+ #max_replicates <- 4
+ #scaling_factor <- 1
+ #df_inputSimulation <- getInput2simulation(list_var, n_genes)
+ #dispersion <- getDispersionMatrix(list_var, n_genes, c(1000, 1000, 1000, 1000, 1000, 1, 1, 1, 1, 1))
+ #mock_rnaseq(list_var, n_genes, min_replicates,
+ # max_replicates,
+ # df_inputSimulation, dispersion)
+ #ERROOR
+#})
+
+
+# Test for generateReplicationMatrix
+test_that("generateReplicationMatrix generates replication matrix correctly", {
+ replication_matrix <- generateReplicationMatrix(init_variable(),min_replicates = 2, max_replicates = 4)
+ expect_equal(dim(replication_matrix), c(4, 2))
+})
+
+```
+
+
+```{r function-preparingData , filename = "prepare_data2fit"}
+
+#' Convert count matrix to long data frame
+#'
+#' Converts a count matrix to a long data frame format using geneID as the identifier.
+#'
+#' @param countMatrix Count matrix
+#' @param value_name Name for the value column
+#' @param id_vars Name for the id column (default "geneID")
+#' @return Long data frame
+#' @importFrom reshape2 melt
+#' @export
+#' @examples
+#' list_var <- init_variable()
+#' mock_data <- mock_rnaseq(list_var, n_genes = 3, 2, 2)
+#' countMatrix_2longDtf(mock_data$counts)
+countMatrix_2longDtf <- function(countMatrix, value_name = "kij", id_vars = "geneID") {
+ countMatrix <- as.data.frame(countMatrix)
+ countMatrix$geneID <- rownames(countMatrix)
+ dtf_countLong <- reshape2::melt(countMatrix, id.vars = id_vars, variable.name = "sampleID",
+ value.name = value_name)
+ dtf_countLong$sampleID <- as.character(dtf_countLong$sampleID)
+ return(dtf_countLong)
+}
+
+#' Get column name with sampleID
+#'
+#' Returns the column name in the metadata data frame that corresponds to the given sampleID.
+#'
+#' @param dtf_countsLong Long data frame of counts
+#' @param metadata Metadata data frame
+#' @return Column name with sampleID
+#' @export
+#' @examples
+#' list_var <- init_variable()
+#' mock_data <- mock_rnaseq(list_var, n_genes = 3, 2,2, 2)
+#' dtf_countLong <- countMatrix_2longDtf(mock_data$counts)
+#' .getColumnWithSampleID(dtf_countLong, mock_data$metadata)
+.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
+ }
+ }
+}
+
+#' Prepare data for fitting
+#'
+#' Prepares the countMatrix and metadata for fitting by converting the countMatrix to a long format and joining with metadata.
+#'
+#' @param countMatrix Count matrix
+#' @param metadata Metadata data frame
+#' @param normalization A boolean value indicating whether to apply median ratio
+#' normalization. If \code{TRUE} (default), the counts matrix will be
+#' normalized using median ratio normalization. If
+#' \code{FALSE}, no normalization will be applied.
+#' @param response_name String referring to target variable name that is being modeled and predicted (default : "kij")
+#' @param groupID String referring the group variable name (default : "geneID")
+#' @return Data frame for fitting
+#' @export
+#' @examples
+#' list_var <- init_variable()
+#' mock_data <- mock_rnaseq(list_var, n_genes = 3, 2,2, 2)
+#' data2fit <- prepareData2fit(mock_data$counts, mock_data$metadata)
+prepareData2fit <- function(countMatrix, metadata, normalization = TRUE , response_name = "kij", groupID = "geneID" ) {
+
+ ## -- scaling for size differences
+ if ( isTRUE(normalization) ) {
+ message("INFO: Median ratio normalization.")
+ countMatrix <- medianRatioNormalization(countMatrix)
+ }
+
+ dtf_countsLong <- countMatrix_2longDtf(countMatrix, response_name)
+ metadata_columnForjoining <- .getColumnWithSampleID(dtf_countsLong, metadata)
+ if (is.na(metadata_columnForjoining)) {
+ stop("SampleIDs do not seem to correspond between countMatrix and metadata")
+ }
+ data2fit <- join_dtf(dtf_countsLong, metadata, k1 = "sampleID", k2 = metadata_columnForjoining)
+ if (sum(is.na(data2fit[[groupID]])) > 0) {
+ warning("Something went wrong. NA introduced in the geneID column. Check the coherence between countMatrix and metadata.")
+ }
+ return(data2fit)
+}
+
+
+
+#' Apply Median Ratio Normalization to a Counts Matrix
+#'
+#' This function performs median ratio normalization on a counts matrix to
+#' adjust for differences in sequencing depth across samples.
+#'
+#' @param countsMatrix A counts matrix where rows represent genes and columns
+#' represent samples.
+#'
+#' @return A normalized counts matrix after applying median ratio normalization.
+#'
+#' @details This function calculates the logarithm of the counts matrix,
+#' computes the average log expression for each gene, and then scales each
+#' sample's counts by the exponential of the difference between its average log
+#' expression and the median of those averages.
+#'
+#' @importFrom stats median
+#'
+#' @examples
+#' counts <- matrix(c(100, 200, 300, 1000, 1500, 2500), ncol = 2)
+#' normalized_counts <- medianRatioNormalization(counts)
+#'
+#' @export
+medianRatioNormalization <- function(countsMatrix) {
+ log_data <- log(countsMatrix)
+ average_log <- rowMeans(log_data)
+
+ if (all(is.infinite(average_log)))
+ stop("Every gene contains at least one zero, cannot compute log geometric means")
+
+ idx2keep <- average_log != "-Inf"
+ average_log <- average_log[idx2keep]
+
+ ratio_data <- sweep(log_data[idx2keep, ], 1, average_log, "-")
+ sample_medians <- apply(ratio_data, 2, stats::median)
+
+ scaling_factors <- exp(sample_medians)
+ countsMatrix_normalized <- sweep(countsMatrix, 2, scaling_factors, "/")
+
+ return(countsMatrix_normalized)
+}
+
+
+```
+
+```{r test-prepareData2fit}
+
+
+# Unit tests for countMatrix_2longDtf
+test_that("countMatrix_2longDtf converts count matrix to long data frame", {
+ # Sample count matrix
+ list_var <- init_variable()
+ mock_data <- mock_rnaseq(list_var, n_genes = 3, 2,2, 1)
+ # Convert count matrix to long data frame
+ dtf_countLong <- countMatrix_2longDtf(mock_data$counts)
+ expect_true(is.character(dtf_countLong$sampleID))
+ expect_true(is.character(dtf_countLong$geneID))
+ expect_true(is.numeric(dtf_countLong$kij))
+ expect_equal(unique(dtf_countLong$geneID), c("gene1", "gene2", "gene3"))
+ expect_equal(unique(dtf_countLong$sampleID),c("myVariable1_1", "myVariable1_2",
+ "myVariable2_1", "myVariable2_2"))
+})
+
+# Unit tests for getColumnWithSampleID
+test_that("getColumnWithSampleID returns column name with sampleID", {
+ # dummy data
+ list_var <- init_variable()
+ mock_data <- mock_rnaseq(list_var, n_genes = 3, 2,2, 2)
+ dtf_countLong <- countMatrix_2longDtf(mock_data$counts)
+
+ # Expected output
+ expected_output <- "sampleID"
+
+ # Get column name with sampleID
+ column_name <- .getColumnWithSampleID(dtf_countLong, mock_data$metadata)
+
+ # Check if the output matches the expected output
+ expect_identical(column_name, expected_output)
+})
+
+# Unit tests for prepareData2fit
+test_that("prepareData2fit prepares data for fitting", {
+ # dummy data
+ list_var <- init_variable()
+ mock_data <- mock_rnaseq(list_var, n_genes = 3, 2,2, 2)
+
+ # Prepare data for fitting
+ data2fit <- prepareData2fit(mock_data$counts, mock_data$metadata)
+
+ expect_true(is.character(data2fit$sampleID))
+ expect_true(is.character(data2fit$geneID))
+ expect_true(is.numeric(data2fit$kij))
+ expect_equal(unique(data2fit$geneID), c("gene1", "gene2", "gene3"))
+ expect_equal(unique(data2fit$sampleID),c("myVariable1_1", "myVariable1_2",
+ "myVariable2_1", "myVariable2_2"))
+})
+
+
+
+
+
+# Test case 1: Normalization with positive counts
+test_that("Median ratio normalization works for positive counts", {
+ counts <- matrix(c(100, 200, 300, 1000, 1500, 2500), ncol = 2)
+ normalized_counts <- medianRatioNormalization(counts)
+
+ expected_normalized_counts <- matrix(c(288.6751 , 577.3503 , 866.0254 , 346.4102, 519.6152, 866.0254), ncol = 2)
+
+ expect_equal(normalized_counts, expected_normalized_counts, tolerance = 1e-4)
+})
+
+# Test case 2: Normalization with zero counts
+test_that("Median ratio normalization return error for zero counts", {
+ counts <- matrix(c(0, 0, 0, 1000, 1500, 2500), ncol = 2)
+ expect_error(medianRatioNormalization(counts))
+
+})
+
+
+# Test case 5: All-zero genes
+test_that("Throws an error when all-zero genes are encountered", {
+ counts <- matrix(c(0, 0, 0, 0, 0, 0), ncol = 2)
+ expect_error(medianRatioNormalization(counts))
+})
+
+
+```
+
+```{r functionFitModel, filename = "fitModel"}
+#' Check if Data is Valid for Model Fitting
+#'
+#' This function checks whether the provided data contains all the variables required in the model formula for fitting.
+#'
+#' @param data2fit The data frame or tibble containing the variables to be used for model fitting.
+#' @param formula The formula specifying the model to be fitted.
+#'
+#' @return \code{TRUE} if all the variables required in the formula are present in \code{data2fit}, otherwise an error is raised.
+#'
+#' @examples
+#' data(iris)
+#' formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+#' isValidInput2fit(iris, formula) # Returns TRUE if all required variables are present
+#' @keywords internal
+#' @export
+isValidInput2fit <- function(data2fit, formula){
+ vec_bool <- all.vars(formula) %in% colnames(data2fit)
+ for (i in seq_along(vec_bool)){
+ if (isFALSE(vec_bool[i]) ) {
+ stop(paste("Variable", all.vars(formula)[i], "not found"))
+ }
+ }
+ return(TRUE)
+}
+
+
+#' Drop Random Effects from a Formula
+#'
+#' This function allows you to remove random effects from a formula by specifying
+#' which terms to drop. It checks for the presence of vertical bars ('|') in the
+#' terms of the formula and drops the random effects accordingly. If all terms
+#' are random effects, the function updates the formula to have only an intercept.
+#'
+#' @param form The formula from which random effects should be dropped.
+#'
+#' @return A modified formula with specified random effects dropped.
+#'
+#' @examples
+#' # Create a formula with random effects
+#' formula <- y ~ x1 + (1 | group) + (1 | subject)
+#' # Drop the random effects related to 'group'
+#' modified_formula <- drop_randfx(formula)
+#'
+#' @importFrom stats terms
+#' @importFrom stats update
+#'
+#' @export
+drop_randfx <- function(form) {
+ form.t <- stats::terms(form)
+ dr <- grepl("|", labels(form.t), fixed = TRUE)
+ if (mean(dr) == 1) {
+ form.u <- stats::update(form, . ~ 1)
+ } else {
+ if (mean(dr) == 0) {
+ form.u <- form
+ } else {
+ form.td <- stats::drop.terms(form.t, which(dr))
+ form.u <- stats::update(form, form.td)
+ }
+ }
+ form.u
+}
+
+
+
+#' Check if a Model Matrix is Full Rank
+#'
+#' This function checks whether a model matrix is full rank, which is essential for
+#' certain statistical analyses. It computes the eigenvalues of the crossproduct
+#' of the model matrix and determines if the first eigenvalue is positive and if
+#' the ratio of the last eigenvalue to the first is within a defined tolerance.
+#'
+#' This function is inspired by a similar function found in the Limma package.
+#'
+#' @param metadata The metadata used to create the model matrix.
+#' @param formula The formula used to specify the model matrix.
+#'
+#' @return \code{TRUE} if the model matrix is full rank, \code{FALSE} otherwise.
+#'
+#' @examples
+#' metadata <- data.frame(x = rnorm(10), y = rnorm(10))
+#' formula <- y ~ x
+#' is_fullrank(metadata, formula)
+#'
+#'
+#' @importFrom stats model.matrix
+#' @export
+is_fullrank <- function(metadata, formula) {
+ ## drop random eff
+ formula <- drop_randfx(formula)
+ ## TEST
+ model_matrix <- stats::model.matrix(data = metadata, formula)
+ e <- eigen(crossprod(model_matrix), symmetric = TRUE, only.values = TRUE)$values
+ modelFullRank <- e[1] > 0 && abs(e[length(e)] / e[1]) > 1e-13
+
+ if (!modelFullRank)
+ stop("The model matrix is not full rank, so the model cannot be fit as specified. One or more variables or interaction terms in the design formula are linear combinations of the others and must be removed.")
+
+ return(TRUE)
+}
+
+
+
+
+
+#' Fit a model using the fitModel function.
+#'
+#' @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
+#' @export
+#' @examples
+#' .fitModel(formula = mpg ~ cyl + disp, data = mtcars)
+.fitModel <- function(formula, data, ...) {
+ # Fit the model using glm.nb from the GLmmTMB package
+ model <- glmmTMB::glmmTMB(formula, ..., data = data )
+ model$frame <- data
+ ## family in ... => avoid error in future update
+ additional_args <- list(...)
+ familyArgs <- additional_args[['family']]
+ if (!is.null(familyArgs)) model$call$family <- familyArgs
+ ## control in ... => avoid error in future update
+ controlArgs <- additional_args[['control']]
+ if (!is.null(controlArgs)) model$call$control <- controlArgs
+ return(model)
+}
+
+
+
+#' Fit the model based using fitModel functions.
+#'
+#' @param group The specific group to fit the model for
+#' @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
+#' @export
+#' @examples
+#' .subsetData_andfit(group = "setosa", group_by = "Species",
+#' formula = Sepal.Length ~ Sepal.Width + Petal.Length,
+#' data = iris )
+.subsetData_andfit <- function(group, group_by, formula, data, ...) {
+ subset_data <- data[data[[group_by]] == group, ]
+ fit_res <- .fitModel(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
+}
+
+
+
+#' Launch the model fitting process for a specific group.
+#'
+#' 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 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",
+#' formula = Sepal.Length ~ Sepal.Width + Petal.Length,
+#' data = iris )
+launchFit <- function(group, group_by, formula, data, ...) {
+ tryCatch(
+ expr = {
+ withCallingHandlers(
+ .subsetData_andfit(group, group_by, formula, data, ...),
+ warning = function(w) {
+ message(paste(Sys.time(), "warning for group", group, ":", conditionMessage(w)))
+ invokeRestart("muffleWarning")
+ })
+ },
+ 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)))
+ }
+ )
+}
+
+
+#' Fit models in parallel for each group using mclapply and handle logging.
+#' Uses parallel_fit to fit the models.
+#'
+#' @param groups Vector of unique group values
+#' @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 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 to write log (default : log.txt)
+#' @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",
+#' formula = Sepal.Length ~ Sepal.Width + Petal.Length,
+#' data = iris, n.cores = 1, log_file = "log.txt" )
+.parallel_fit <- function(groups, group_by, formula, data, n.cores = NULL, log_file, ...) {
+ if (is.null(n.cores)) n.cores <- parallel::detectCores()
+
+ 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, ...)
+
+ parallel::stopCluster(clust)
+ #closeAllConnections()
+ return(results_fit)
+}
+
+#' Fit models in parallel for each group using mclapply and handle logging.
+#' Uses parallel_fit to fit the models.
+#'
+#' @param formula Formula specifying the model formula
+#' @param data Data frame containing the data
+#' @param group_by Column name in data representing the grouping variable
+#' @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 : log.txt)
+#' @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 = "log.txt", ...) {
+
+ ## SOme verification
+ isValidInput2fit(data, formula)
+ is_fullrank(data, formula)
+
+
+ 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, ...)
+ #results <- mergeListDataframes(results)
+ return(results)
+}
+
+
+```
+
+
+```{r test-fitData}
+
+
+test_that("isValidInput2fit returns TRUE for valid data", {
+ data(iris)
+ formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+ result <- isValidInput2fit(iris, formula)
+ expect_true(result)
+})
+
+# Test that the function raises an error when a required variable is missing
+test_that("isValidInput2fit raises an error for missing variable", {
+ data(iris)
+ formula <- Sepal.Length ~ Sepal.Width + NonExistentVariable
+ expect_error(isValidInput2fit(iris, formula), "Variable NonExistentVariable not found")
+})
+
+test_that(".fitModel returns a fitted model object", {
+ data(mtcars)
+ formula <- mpg ~ cyl + disp
+ fitted_model <- suppressWarnings(.fitModel(formula, mtcars))
+ #expect_warning(.fitModel(formula, mtcars))
+ expect_s3_class(fitted_model, "glmmTMB")
+
+ # Test with invalid formula
+ invalid_formula <- mpg ~ cyl + disp + invalid_var
+ expect_error(.fitModel(invalid_formula, mtcars))
+
+
+ # Additional parameters:
+ #change family + formula
+ formula <- Sepal.Length ~ Sepal.Width + Petal.Length + (1 | Species)
+ fitted_models <- suppressWarnings(.fitModel(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(.fitModel(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)))
+
+
+
+})
+
+
+# Test if random effects are dropped correctly
+test_that("Drop random effects from formula", {
+ formula <- y ~ x1 + (1 | group) + (1 | subject)
+ modified_formula <- drop_randfx(formula)
+ expect_equal(deparse(modified_formula), "y ~ x1")
+})
+
+# Test if formula with no random effects remains unchanged
+test_that("Keep formula with no random effects unchanged", {
+ formula <- y ~ x1 + x2
+ modified_formula <- drop_randfx(formula)
+ expect_equal(deparse(modified_formula), "y ~ x1 + x2")
+})
+
+# Test if all random effects are dropped to intercept
+test_that("Drop all random effects to intercept", {
+ formula <- ~ (1 | group) + (1 | subject)
+ modified_formula <- drop_randfx(formula)
+ expect_equal(deparse(modified_formula), ". ~ 1")
+})
+
+
+# Test if a full-rank model matrix is identified correctly
+test_that("Identify full-rank model matrix", {
+ metadata <- data.frame(x = rnorm(10), y = rnorm(10))
+ formula <- y ~ x
+ expect_true(is_fullrank(metadata, formula))
+})
+
+# Test if a rank-deficient model matrix is detected and throws an error
+test_that("Detect rank-deficient model matrix and throw error", {
+ metadata <- data.frame(x = factor(rep(c("xA","xB"),each = 5)),
+ w = factor(rep(c("wA","wB"), each = 5)),
+ z = factor(rep(c("zA","zB"), each = 5)),
+ y = rnorm(10))
+ formula <- y ~ x + w + z + y:w
+ expect_error(is_fullrank(metadata, formula),
+ regexp = "The model matrix is not full rank, so the model cannot be fit as specified.")
+})
+
+# Test if a rank-deficient model matrix is detected and throws an error
+test_that("Detect rank-deficient model matrix and throw error (with random eff)", {
+ metadata <- data.frame(x = factor(rep(c("xA","xB"),each = 5)),
+ w = factor(rep(c("wA","wB"), each = 5)),
+ z = factor(rep(c("zA","zB"), each = 5)),
+ y = rnorm(10))
+ formula <- y ~ x + w + z + y:w + (1 | w)
+ expect_error(is_fullrank(metadata, formula),
+ regexp = "The model matrix is not full rank, so the model cannot be fit as specified.")
+})
+
+# Test if a rank-deficient model matrix is detected and throws an error
+test_that("Identify full-rank model matrix (with random eff)", {
+ metadata <- data.frame(x = factor(rep(c("xA","xB"),each = 5)),
+ w = factor(rep(c("wA","wB"), each = 5)),
+ z = factor(rep(c("zA","zB"), each = 5)),
+ y = rnorm(10))
+ formula <- y ~ x + (1 | w)
+ 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", {
+ 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)))
+
+})
+
+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",
+ 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"),
+ 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)))
+})
+
+test_that(".parallel_fit returns a list of fitted model objects or NULL for any errors", {
+ data(iris)
+ groups <- unique(iris$Species)
+ group_by <- "Species"
+ formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+ fitted_models <- .parallel_fit(groups, group_by, formula, iris, log_file = "log.txt", n.cores = 1)
+ expect_s3_class(fitted_models$setosa, "glmmTMB")
+ expect_length(fitted_models, length(groups))
+
+ # Test with invalid formula
+ invalid_formula <- blabla ~ cyl + disp
+ result <- suppressWarnings(.parallel_fit(groups, group_by, invalid_formula,
+ iris, log_file = "log.txt", n.cores = 1))
+ expect_equal(result, expected = list(setosa = NULL, versicolor = NULL, virginica = NULL))
+
+
+ # Additional parameters:
+ #change family + formula
+ formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+ fitted_models <- suppressWarnings(.parallel_fit(formula = formula,
+ data = iris,
+ group_by = group_by,
+ groups = "setosa",
+ log_file = "log.txt",
+ n.cores = 1,
+ family = glmmTMB::nbinom1(link = "log") ))
+ expect_s3_class(fitted_models$setosa$call$family, "family")
+ expect_equal(fitted_models$setosa$call$formula, formula)
+ #change control settings
+ fitted_models <- suppressWarnings(.parallel_fit(formula = formula,
+ data = iris,
+ group_by = group_by,
+ groups = "setosa",
+ log_file = "log.txt",
+ family = glmmTMB::nbinom1(link = "log"),
+ n.cores = 1,
+ 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)))
+})
+
+test_that("fitModelParallel fits models in parallel for each group and returns a list of fitted model objects or NULL for any errors", {
+ data(iris)
+ 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))
+
+ invalid_formula <- blabla ~ cyl + disp
+ expect_error(fitModelParallel(invalid_formula, iris, group_by ,log_file = "log.txt", n.cores = 1))
+
+ # Additional parameters:
+ #change family + formula
+ formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+ fitted_models <- suppressWarnings(fitModelParallel(formula = formula,
+ data = iris,
+ group_by = group_by,
+ n.cores = 1,
+ family = glmmTMB::nbinom1(link = "log") ))
+ expect_s3_class(fitted_models$setosa$call$family, "family")
+ expect_equal(fitted_models$setosa$call$formula, formula)
+ #change control settings
+ fitted_models <- suppressWarnings(fitModelParallel(formula = formula,
+ data = iris,
+ group_by = group_by,
+ n.cores = 1,
+ family = glmmTMB::nbinom1(link = "log"),
+ 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)))
+
+})
+
+```
+
+
+```{r functionUpdateFitModel, filename = "updateFitModel"}
+
+
+#' Update GLMNB models in parallel.
+#'
+#' This function fits GLMNB models in parallel using multiple cores, allowing for faster computation.
+#'
+#' @param formula Formula for the GLMNB model.
+#' @param l_tmb List of GLMNB 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.
+#' @param ... Additional arguments to be passed to the glmmTMB::glmmTMB function.
+#' @export
+#' @return A list of updated GLMNB models.
+#'
+#' @examples
+#' data(iris)
+#' groups <- unique(iris$Species)
+#' group_by <- "Species"
+#' formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+#' 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, l_tmb, n.cores = NULL, log_file = "log.txt", ...) {
+
+ isValidInput2fit(l_tmb[[1]]$frame, formula)
+
+ is_fullrank(l_tmb[[1]]$frame, formula)
+
+ # Fit models update in parallel and capture the results
+ results <- .parallel_update(formula, l_tmb, n.cores, log_file, ...)
+ return(results)
+}
+
+
+#' Internal function to fit GLMNB models in parallel.
+#'
+#' This function is used internally by \code{\link{updateParallel}} to fit GLMNB models in parallel.
+#'
+#' @param formula Formula for the GLMNB model.
+#' @param l_tmb List of GLMNB objects.
+#' @param n.cores Number of cores to use for parallel processing.
+#' @param log_file File path for the log output.
+#' @param ... Additional arguments to be passed to the glmmTMB::glmmTMB function.
+#' @export
+#' @return A list of updated GLMNB models.
+#' @examples
+#' data(iris)
+#' groups <- unique(iris$Species)
+#' group_by <- "Species"
+#' formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+#' fitted_models <- fitModelParallel(formula, iris, group_by, n.cores = 1)
+#' new_formula <- Sepal.Length ~ Sepal.Width
+#' results <- .parallel_update(new_formula, fitted_models, n.cores = 1)
+.parallel_update <- function(formula, l_tmb, n.cores = NULL, log_file = "log.txt", ...) {
+ 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())
+ updated_res <- parallel::parLapply(clust, X = l_tmb, fun = launchUpdate , formula = formula, ...)
+ parallel::stopCluster(clust)
+ #closeAllConnections()
+ return(updated_res)
+}
+
+
+#' Fit and update a GLMNB model.
+#'
+#' This function fits and updates a GLMNB model using the provided formula.
+#'
+#' @param glmnb_obj A GLMNB object to be updated.
+#' @param formula Formula for the updated GLMNB model.
+#' @param ... Additional arguments to be passed to the glmmTMB::glmmTMB function.
+#' @export
+#' @return An updated GLMNB model.
+#'
+#' @examples
+#' data(iris)
+#' groups <- unique(iris$Species)
+#' group_by <- "Species"
+#' formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+#' fitted_models <- fitModelParallel(formula, iris, group_by, n.cores = 1)
+#' new_formula <- Sepal.Length ~ Sepal.Width
+#' updated_model <- fitUpdate(fitted_models[[1]], new_formula)
+fitUpdate <- function(glmnb_obj, formula , ...){
+ data = glmnb_obj$frame
+ resUpdt <- stats::update(glmnb_obj, formula, ...)
+ resUpdt$frame <- data
+ ## family in ... => avoid error in future update
+ additional_args <- list(...)
+ familyArgs <- additional_args[['family']]
+ if (!is.null(familyArgs)) resUpdt$call$family <- familyArgs
+ ## control in ... => avoid error in future update
+ controlArgs <- additional_args[['control']]
+ if (!is.null(controlArgs)) resUpdt$call$control <- controlArgs
+ return(resUpdt)
+}
+
+
+#' Launch the update process for a GLMNB model.
+#'
+#' This function launches the update process for a GLMNB model, capturing and handling warnings and errors.
+#'
+#' @param glmnb_obj A GLMNB object to be updated.
+#' @param formula Formula for the updated GLMNB model.
+#' @param ... Additional arguments to be passed to the glmmTMB::glmmTMB function.
+#' @export
+#' @return An updated GLMNB model or NULL if an error occurs.
+#'
+#' @examples
+#' data(iris)
+#' groups <- unique(iris$Species)
+#' group_by <- "Species"
+#' formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+#' fitted_models <- fitModelParallel(formula, iris, group_by, n.cores = 1)
+#' new_formula <- Sepal.Length ~ Sepal.Width
+#' updated_model <- launchUpdate(fitted_models[[1]], new_formula)
+launchUpdate <- function(glmnb_obj, formula, ...) {
+ group = deparse(substitute(glmnb_obj))
+ tryCatch(
+ expr = {
+ withCallingHandlers(
+ fitUpdate(glmnb_obj, formula, ...),
+ warning = function(w) {
+ message(paste(Sys.time(), "warning for group", group ,":", conditionMessage(w)))
+ invokeRestart("muffleWarning")
+ })
+ },
+ error = function(e) {
+ message(paste(Sys.time(), "error for group", group,":", conditionMessage(e)))
+ return(NULL)
+ }
+ )
+}
+
+```
+
+
+```{r test-updateFit}
+# Test updateParallel function
+test_that("updateParallel function returns correct results", {
+ # Load the required data
+ data(iris)
+ groups <- unique(iris$Species)
+ group_by <- "Species"
+ formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+ 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)
+ expect_is(results, "list")
+ expect_equal(length(results), length(fitted_models))
+ expect_is(results$setosa, "glmmTMB")
+
+ #uncorrect formula
+ new_formula <- Sepal.Length ~ blabla
+ expect_error(updateParallel(new_formula, fitted_models, n.cores = 1))
+
+ # Additional parameters:
+ #change family + formula
+ new_formula <- Sepal.Length ~ Sepal.Width
+ updated_model <- suppressWarnings(updateParallel(l_tmb = fitted_models,
+ formula = new_formula,
+ n.cores = 1,
+ family = glmmTMB::nbinom1(link = "log") ))
+ expect_s3_class(updated_model$setosa$call$family, "family")
+ expect_equal(updated_model$setosa$call$formula, new_formula)
+ #change control settings
+ updated_model <- suppressWarnings(updateParallel(l_tmb = fitted_models,
+ formula = new_formula,
+ family = glmmTMB::nbinom1(link = "log"),
+ n.cores = 1,
+ control = glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,
+ eval.max=1e3))))
+ expect_equal(updated_model$setosa$call$control, glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,eval.max=1e3)))
+
+ # Update an updated model
+ updated_updated_model <- suppressWarnings(updateParallel(l_tmb = updated_model,
+ formula = new_formula,
+ n.cores = 1,
+ family = glmmTMB::ziGamma(link = "inverse")))
+ expect_s3_class(updated_updated_model$setosa$call$family, "family")
+})
+
+# Test .parallel_update function
+test_that(".parallel_update function returns correct results", {
+# Load the required data
+ data(iris)
+ groups <- unique(iris$Species)
+ group_by <- "Species"
+ formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+ fitted_models <- fitModelParallel(formula, iris, group_by, n.cores = 1)
+ new_formula <- Sepal.Length ~ Sepal.Width
+ results <- .parallel_update(new_formula, fitted_models, n.cores = 1)
+ expect_is(results, "list")
+ expect_equal(length(results), length(fitted_models))
+ expect_is(results$setosa, "glmmTMB")
+
+ #uncorrect formula
+ new_formula <- Sepal.Length ~ blabla
+ results <- .parallel_update(new_formula, fitted_models, n.cores = 1)
+ expect_is(results, "list")
+ expect_equal(length(results), length(fitted_models))
+ expect_equal(results$setosa, NULL)
+
+ # Additional parameters:
+ #change family + formula
+ new_formula <- Sepal.Length ~ Sepal.Width
+ updated_model <- suppressWarnings(.parallel_update(l_tmb = fitted_models,
+ formula = new_formula,
+ n.cores = 1,
+ family = glmmTMB::nbinom1(link = "log") ))
+ expect_s3_class(updated_model$setosa$call$family, "family")
+ expect_equal(updated_model$setosa$call$formula, new_formula)
+ #change control
+ updated_model <- suppressWarnings(.parallel_update(l_tmb = fitted_models,
+ formula = new_formula,
+ n.cores = 1,
+ family = glmmTMB::nbinom1(link = "log"),
+ control = glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,
+ eval.max=1e3))))
+ expect_equal(updated_model$setosa$call$control, glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,eval.max=1e3)))
+})
+
+# Test fitUpdate function
+test_that("fitUpdate function returns correct results", {
+ #Load the required data
+ data(iris)
+ groups <- unique(iris$Species)
+ group_by <- "Species"
+ formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+ fitted_models <- fitModelParallel(formula, iris, group_by, n.cores = 1)
+ new_formula <- Sepal.Length ~ Sepal.Width
+
+ updated_model <- fitUpdate(fitted_models[[1]], new_formula)
+ expect_is(updated_model, "glmmTMB")
+
+ # Additional parameters:
+ #change family + formula
+ updated_model <- suppressWarnings(fitUpdate(fitted_models[[1]], new_formula,
+ family = glmmTMB::nbinom1(link = "log") ))
+ expect_s3_class(updated_model$call$family, "family")
+ expect_equal(updated_model$call$formula, new_formula)
+ #change control
+ updated_model <- suppressWarnings(fitUpdate(fitted_models[[1]],
+ new_formula,
+ family = glmmTMB::nbinom1(link = "log"),
+ control = glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,
+ eval.max=1e3))))
+ expect_equal(updated_model$call$control, glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,eval.max=1e3)))
+
+})
+
+
+# Test launchUpdate function
+test_that("launchUpdate function returns correct results", {
+ data(iris)
+ groups <- unique(iris$Species)
+ group_by <- "Species"
+ formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+ fitted_models <- fitModelParallel(formula, iris, group_by, n.cores = 1)
+ new_formula <- Sepal.Length ~ Sepal.Width
+ updated_model <- launchUpdate(fitted_models[[1]], new_formula)
+ expect_is(updated_model, "glmmTMB")
+ # Additional parameters:
+ #change family + formula
+ updated_model <- launchUpdate(fitted_models[[1]], new_formula, family = glmmTMB::nbinom1(link = "log") )
+ expect_s3_class(updated_model$call$family, "family")
+ expect_equal(updated_model$call$formula, new_formula)
+ #change control
+ updated_model <- launchUpdate(fitted_models[[1]], new_formula, family = glmmTMB::nbinom1(link = "log"),
+ control = glmmTMB::glmmTMBControl(optimizer=optim, optArgs=list(method="BFGS")))
+ expect_equal(updated_model$call$control, glmmTMB::glmmTMBControl(optimizer=optim, optArgs=list(method="BFGS")))
+
+})
+
+```
+
+```{r functionTidyGLM, filename = "tidy_glmmTMB"}
+
+
+#' Extract Fixed Effects from a GLMMTMB Model Summary
+#'
+#' This function extracts fixed effects from the summary of a glmmTMB model.
+#'
+#' @param x A glmmTMB model object.
+#' @return A dataframe containing the fixed effects and their corresponding statistics.
+#' @export
+#' @examples
+#'
+#' model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length, data = iris)
+#' fixed_effects <- extract_fixed_effect(model)
+extract_fixed_effect <- function(x){
+ ss = summary(x)
+ as.data.frame(ss$coefficients$cond)
+ ss_reshaped <- lapply(ss$coefficients,
+ function(sub_obj){
+ if(is.null(sub_obj)) return(NULL)
+ sub_obj <- data.frame(sub_obj)
+ sub_obj$term <- removeDuplicatedWord(rownames(sub_obj))
+ rownames(sub_obj) <- NULL
+ sub_obj <- renameColumns(sub_obj)
+ sub_obj
+ }
+ )
+
+ ss_df <- do.call(rbind, ss_reshaped)
+ ss_df$component <- sapply(rownames(ss_df), function(x) strsplit(x, split = "[.]")[[1]][1])
+ ss_df$effect <- "fixed"
+ rownames(ss_df) <- NULL
+ ss_df
+}
+
+
+
+#' Extract Tidy Summary of glmmTMB Model
+#'
+#' This function extracts a tidy summary of the fixed and random effects from a glmmTMB model and binds them together in a data frame. Missing columns are filled with NA.
+#'
+#' @param glm_TMB A glmmTMB model object.
+#' @param ID An identifier to be included in the output data frame.
+#' @return A data frame containing a tidy summary of the fixed and random effects from the glmmTMB model.
+#' @export
+#' @examples
+#'
+#' model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length, data = iris)
+#' tidy_summary <- getTidyGlmmTMB(glm_TMB = model, ID = "Model1")
+getTidyGlmmTMB <- function(glm_TMB, ID){
+ if(is.null(glm_TMB)) return(NULL)
+ df1 <- extract_fixed_effect(glm_TMB)
+ df1 <- build_missingColumn_with_na(df1)
+ df2 <- extract_ran_pars(glm_TMB)
+ df2 <- build_missingColumn_with_na(df2)
+ df_2ret <- rbind(df1, df2)
+ df_2ret[df_2ret == "NaN"] <- NA
+ df_2ret <- df_2ret[rowSums(!is.na(df_2ret)) > 0, ] # drop rows full of NA
+ df_2ret$ID <- ID
+ df_2ret <- reorderColumns(df_2ret,
+ c("ID","effect", "component", "group", "term",
+ "estimate", "std.error", "statistic", "p.value"))
+ return(df_2ret)
+}
+
+
+
+#' Extract Tidy Summary of Multiple glmmTMB Models
+#'
+#' This function takes a list of glmmTMB models and extracts a tidy summary of the fixed and random effects from each model. It then combines the results into a single data frame.
+#'
+#' @param l_tmb A list of glmmTMB model objects.
+#' @return A data frame containing a tidy summary of the fixed and random effects from all glmmTMB models in the list.
+#' @export
+#' @examples
+#' model1 <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length + (1 | Species), data = iris)
+#' model2 <- glmmTMB::glmmTMB(Petal.Length ~ Sepal.Length + Sepal.Width + (1 | Species), data = iris)
+#' model_list <- list(Model1 = model1, Model2 = model2)
+#' tidy_summary <- tidy_tmb(model_list)
+tidy_tmb <- function(l_tmb){
+ if (identical(class(l_tmb), "glmmTMB")) return(getTidyGlmmTMB(l_tmb, "glmmTMB"))
+ attributes(l_tmb)$names
+ l_tidyRes <- lapply(attributes(l_tmb)$names,
+ function(ID)
+ {
+ glm_TMB <- l_tmb[[ID]]
+ getTidyGlmmTMB(glm_TMB, ID)
+ }
+ )
+ ret <- do.call("rbind", l_tidyRes)
+ return(ret)
+}
+
+
+#' Build DataFrame with Missing Columns and NA Values
+#'
+#' This function takes a DataFrame and a list of column names and adds missing columns with NA values to the DataFrame.
+#'
+#' @param df The input DataFrame.
+#' @param l_columns A character vector specifying the column names to be present in the DataFrame.
+#' @return A DataFrame with missing columns added and filled with NA values.
+#' @export
+#' @examples
+#'
+#' df <- data.frame(effect = "fixed", term = "Sepal.Length", estimate = 0.7)
+#' df_with_na <- build_missingColumn_with_na(df)
+build_missingColumn_with_na <- function(df, l_columns = c("effect", "component", "group",
+ "term", "estimate", "std.error", "statistic", "p.value")) {
+ df_missing_cols <- setdiff(l_columns, colnames(df))
+ # Ajouter les colonnes manquantes à df1
+ if (length(df_missing_cols) > 0) {
+ for (col in df_missing_cols) {
+ df[[col]] <- NA
+ }
+ }
+ return(df)
+}
+
+#' Remove Duplicated Words from Strings
+#'
+#' This function takes a vector of strings and removes duplicated words within each string.
+#'
+#' @param strings A character vector containing strings with potential duplicated words.
+#' @return A character vector with duplicated words removed from each string.
+#' @export
+#' @examples
+#'
+#' words <- c("hellohello", "worldworld", "programmingprogramming", "R isis great")
+#' cleaned_words <- removeDuplicatedWord(words)
+removeDuplicatedWord <- function(strings){
+ gsub("(.*)\\1+", "\\1", strings, perl = TRUE)
+}
+
+
+
+
+#' Convert Correlation Matrix to Data Frame
+#'
+#' This function converts a correlation matrix into a data frame containing the correlation values and their corresponding interaction names.
+#'
+#' @param corr_matrix A correlation matrix to be converted.
+#' @return A data frame with the correlation values and corresponding interaction names.
+#' @export
+#' @examples
+#' mat <- matrix(c(1, 0.7, 0.5, 0.7,
+#' 1, 0.3, 0.5, 0.3, 1),
+#' nrow = 3,
+#' dimnames = list(c("A", "B", "C"),
+#' c("A", "B", "C")))
+#' correlation_matrix_2df(mat)
+correlation_matrix_2df <- function(corr_matrix){
+ vec_corr <- corr_matrix[lower.tri(corr_matrix)]
+ col_names <- removeDuplicatedWord(colnames(corr_matrix))
+ row_names <- removeDuplicatedWord(rownames(corr_matrix))
+ interaction_names <- vector("character", length(vec_corr))
+ k <- 1
+ n <- nrow(corr_matrix)
+ for (i in 1:(n - 1)) {
+ for (j in (i + 1):n) {
+ interaction_names[k] <- paste("cor__", paste(col_names[i], ".", row_names[j], sep = ""), sep ="")
+ k <- k + 1
+ }
+ }
+ names(vec_corr) <- interaction_names
+ ret <- data.frame(estimate = vec_corr)
+ ret$term <- rownames(ret)
+ rownames(ret) <- NULL
+ ret
+}
+
+#' Wrapper for Extracting Variance-Covariance Components
+#'
+#' This function extracts variance-covariance components from a glmmTMB model object for a specific grouping factor and returns them as a data frame.
+#'
+#' @param var_cor A variance-covariance object from the glmmTMB model.
+#' @param elt A character indicating the type of effect, either "cond" or "zi".
+#' @return A data frame containing the standard deviation and correlation components for the specified grouping factor.
+#' @export
+#' @examples
+#' model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length + (1|Species),
+#' data = iris, family = gaussian)
+#' var_cor <- summary(model)$varcor$cond
+#' ran_pars_df <- wrapper_var_cor(var_cor, "Species")
+wrapper_var_cor <- function(var_cor, elt){
+ var_group <- attributes(var_cor)$names
+ l_ret <- lapply(var_group,
+ function(group)
+ {
+ ## -- standard dev
+ std_df <- data.frame(estimate = attributes(var_cor[[group]])$stddev)
+ std_df$term <- paste("sd_", removeDuplicatedWord(rownames(std_df)), sep = "")
+ ## -- correlation
+ corr_matrix <- attributes(var_cor[[group]])$correlation
+ #no correlation 2 return
+ if (nrow(corr_matrix) <= 1) ret <- std_df
+ else {
+ corr_df <- correlation_matrix_2df(corr_matrix)
+ ret <- rbind(std_df, corr_df)
+ }
+ ret$component <- elt
+ ret$effect <- "ran_pars"
+ ret$group <- group
+ rownames(ret) <- NULL
+ return(ret)
+ })
+ l_ret
+
+}
+
+
+#' Extract Random Parameters from a glmmTMB Model
+#'
+#' This function extracts the random parameters from a glmmTMB model and returns them as a data frame.
+#'
+#' @param x A glmmTMB model object.
+#' @return A data frame containing the random parameters and their estimates.
+#' @export
+#' @importFrom stats setNames
+#' @examples
+#' model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length + (1|Species), data = iris,
+#' family = gaussian)
+#' random_params <- extract_ran_pars(model)
+extract_ran_pars <- function(x){
+ ss <- summary(x)
+ l_2parcour <- c("cond", "zi")
+ l_res = lapply(stats::setNames(l_2parcour, l_2parcour),
+ function(elt)
+ {
+ var_cor <- ss$varcor[[elt]]
+ return(wrapper_var_cor(var_cor, elt))
+ })
+
+ ret <- rbind(do.call("rbind", l_res$cond),do.call("rbind", l_res$zi))
+ return(ret)
+
+}
+
+
+#' Rename Columns in a Data Frame
+#'
+#' This function renames columns in a data frame based on specified old names and corresponding new names.
+#'
+#' @param df A data frame.
+#' @param old_names A character vector containing the old column names to be replaced.
+#' @param new_names A character vector containing the corresponding new column names.
+#' @return The data frame with renamed columns.
+#' @export
+#' @examples
+#' df <- data.frame(Estimate = c(1.5, 2.0, 3.2),
+#' Std..Error = c(0.1, 0.3, 0.2),
+#' z.value = c(3.75, 6.67, 4.90),
+#' Pr...z.. = c(0.001, 0.0001, 0.002))
+#'
+#' renamed_df <- renameColumns(df, old_names = c("Estimate", "Std..Error", "z.value", "Pr...z.."),
+#' new_names = c("estimate", "std.error", "statistic", "p.value"))
+#'
+renameColumns <- function(df, old_names = c("Estimate","Std..Error", "z.value", "Pr...z.."),
+ new_names = c("estimate","std.error", "statistic", "p.value")) {
+ stopifnot(length(old_names) == length(new_names))
+
+ for (i in seq_along(old_names)) {
+ old_col <- old_names[i]
+ new_col <- new_names[i]
+
+ if (old_col %in% names(df)) {
+ names(df)[names(df) == old_col] <- new_col
+ } else {
+ warning(paste("Column", old_col, "not found in the data frame. Skipping renaming."))
+ }
+ }
+
+ return(df)
+}
+
+
+
+#' Reorder the columns of a dataframe
+#'
+#' This function reorders the columns of a dataframe according to the specified column order.
+#'
+#' @param df The input dataframe.
+#' @param columnOrder A vector specifying the desired order of columns.
+#'
+#' @return A dataframe with columns reordered according to the specified column order.
+#' @export
+#' @examples
+#' # Example dataframe
+#' df <- data.frame(A = 1:3, B = 4:6, C = 7:9)
+#'
+#' # Define the desired column order
+#' columnOrder <- c("B", "C", "A")
+#'
+#' # Reorder the columns of the dataframe
+#' df <- reorderColumns(df, columnOrder)
+reorderColumns <- function(df, columnOrder) {
+ df <- df[, columnOrder, drop = FALSE]
+ return(df)
+}
+
+```
+
+
+```{r test-tidyGLM}
+
+test_that("extract_fixed_effect returns the correct results for glmmTMB models", {
+ data(iris)
+ # Créer un modèle glmmTMB avec les données iris (exemple)
+ model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length + (1|Species), data = iris)
+
+ # Appeler la fonction extract_fixed_effect sur le modèle
+ result <- extract_fixed_effect(model)
+
+ # Check les résultats attendus
+ expect_s3_class(result, "data.frame")
+ expect_equal(result$effect, c("fixed", "fixed", "fixed"))
+ expect_equal(result$component , c("cond", "cond", "cond"))
+ expect_equal(result$term , c("(Intercept)", "Sepal.Width", "Petal.Length"))
+
+})
+
+
+test_that("getTidyGlmmTMB returns the correct results for glmmTMB models", {
+ data(iris)
+ # Créer un modèle glmmTMB avec les données iris (exemple)
+ model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length, data = iris)
+ tidy_summary <- getTidyGlmmTMB(glm_TMB = model, ID = "Model1")
+
+ # Check les résultats attendus
+ expect_s3_class(tidy_summary, "data.frame")
+ expect_equal(tidy_summary$effect, c("fixed", "fixed", "fixed"))
+ expect_equal(tidy_summary$component , c("cond", "cond", "cond"))
+ expect_equal(tidy_summary$term , c("(Intercept)", "Sepal.Width", "Petal.Length"))
+ expect_equal(tidy_summary$ID , c("Model1", "Model1", "Model1"))
+
+ #MODEL == NULL
+ tidy_summary <- getTidyGlmmTMB(glm_TMB = NULL, ID = "Model1")
+ expect_equal(tidy_summary, NULL)
+})
+
+
+test_that("build_missingColumn_with_na returns the correct results", {
+ df <- data.frame(effect = "fixed", term = "Sepal.Length", estimate = 0.7)
+ df_with_na <- build_missingColumn_with_na(df)
+ expected_df <- data.frame(effect = "fixed",
+ term = "Sepal.Length",
+ estimate = 0.7,
+ component = NA,
+ group = NA,
+ std.error = NA,
+ statistic = NA,
+ p.value = NA)
+
+ expect_equal(df_with_na, expected_df)
+})
+
+
+test_that("removeDuplicatedWord returns expected output", {
+ words <- c("hellohello", "worldworld", "programmingprogramming", "R isis great")
+ cleaned_words <- removeDuplicatedWord(words)
+ expect_equal(cleaned_words, c("hello", "world", "programming", "R is great"))
+})
+
+
+
+test_that("correlation_matrix_2df returns expected output",{
+
+ mat <- matrix(c(1, 0.7, 0.5, 0.7, 1, 0.3, 0.5, 0.3, 1), nrow = 3, dimnames = list(c("A", "B", "C"), c("A", "B", "C")))
+ df_corr <- correlation_matrix_2df(mat)
+ df_expected <- data.frame(estimate = c(0.7, 0.5, 0.3),
+ term = c("cor__A.B", "cor__A.C", "cor__B.C"))
+ expect_equal(df_corr, df_expected)
+})
+
+
+
+test_that("wrapper_var_cor returns expected output",{
+ data(iris)
+ model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length + (1|Species), data = iris, family = gaussian)
+ var_cor <- summary(model)$varcor$cond
+ ran_pars_df <- wrapper_var_cor(var_cor, "Species")
+ expected_l = list(data.frame(estimate = 0.4978083, term = "sd_(Intercept)",
+ component = "Species", effect = "ran_pars", group = "Species"))
+ expect_equal(ran_pars_df , expected_l, tolerance = 0.0000001)
+})
+
+
+test_that("extract_ran_pars returns expected output",{
+ model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length + (1|Species),
+ data = iris, family = gaussian)
+ random_params <- extract_ran_pars(model)
+
+ expected_df = data.frame(estimate = 0.4978083, term = "sd_(Intercept)",
+ component = "cond", effect = "ran_pars", group = "Species")
+ expect_equal(random_params , expected_df, tolerance = 0.0000001)
+})
+
+
+test_that("renameColumns returns expected output",{
+ df <- data.frame(Estimate = c(1.5, 2.0, 3.2),
+ Std..Error = c(0.1, 0.3, 0.2),
+ z.value = c(3.75, 6.67, 4.90),
+ Pr...z.. = c(0.001, 0.0001, 0.002))
+
+ new_colnames <- c("estimate", "std.error", "statistic", "p.value")
+ renamed_df <- renameColumns(df, old_names = c("Estimate", "Std..Error", "z.value", "Pr...z.."),
+ new_names = new_colnames)
+ expect_equal(colnames(renamed_df),c("estimate", "std.error", "statistic", "p.value"))
+ expect_equal(dim(renamed_df), dim(df))
+})
+
+
+test_that("reorderColumns returns expected output",{
+ df <- data.frame(A = 1:3, B = 4:6, C = 7:9)
+ # Define the desired column order
+ columnOrder <- c("B", "C", "A")
+ # Reorder the columns of the dataframe
+ df_reorder <- reorderColumns(df, columnOrder)
+ expect_equal(colnames(df_reorder), columnOrder)
+ expect_equal(dim(df_reorder), dim(df))
+
+})
+
+
+test_that("tidy_tmb returns expected output",{
+ model1 <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length + (1 | Species), data = iris)
+ model2 <- glmmTMB::glmmTMB(Petal.Length ~ Sepal.Length + Sepal.Width + (1 | Species), data = iris)
+ model_list <- list(Model1 = model1, Model2 = model2)
+ result <- tidy_tmb(model_list)
+ expect_equal(unique(result$ID), c("Model1", "Model2"))
+ expect_equal(unique(result$effect), c("fixed", "ran_pars"))
+ expect_equal(unique(result$component), "cond")
+ expect_equal(unique(result$term), c("(Intercept)", "Sepal.Width", "Petal.Length", "sd_(Intercept)", "Sepal.Length"))
+ expect_true("estimate" %in% colnames(result))
+ expect_true("std.error" %in% colnames(result))
+ expect_true("statistic" %in% colnames(result))
+ expect_true("p.value" %in% colnames(result))
+
+
+ # zi component
+ model2 <- glmmTMB::glmmTMB(Petal.Length ~ Sepal.Length + Sepal.Width + (1 | Species), data = iris, ziformula = ~1)
+ model_list <- list(Model1 = model1, Model2 = model2)
+ result_withZi <- tidy_tmb(model_list)
+ expect_equal(dim(result_withZi)[1], dim(result)[1] + 1 )
+ expect_equal(unique(result_withZi$component), c("cond", "zi"))
+
+ ## unique obect in list
+ model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length + (1|Species), data = iris)
+ result <- tidy_tmb(model)
+ expect_true("effect" %in% colnames(result))
+ expect_true("component" %in% colnames(result))
+ expect_true("group" %in% colnames(result))
+ expect_true("term" %in% colnames(result))
+ expect_true("estimate" %in% colnames(result))
+ expect_true("std.error" %in% colnames(result))
+ expect_true("statistic" %in% colnames(result))
+ expect_true("p.value" %in% colnames(result))
+})
+```
+
+
+```{r functionGlanceGLM, filename = "glance_tmb"}
+
+#' Extracts the summary statistics from a list of glmmTMB models.
+#'
+#' This function takes a list of glmmTMB models and extracts the summary statistics (AIC, BIC, logLik, deviance,
+#' df.resid, and dispersion) for each model and returns them as a single DataFrame.
+#'
+#' @param l_tmb A list of glmmTMB models or a unique glmmTMB obj model
+#' @return A DataFrame with the summary statistics for all the glmmTMB models in the list.
+#' @export
+#' @importFrom stats setNames
+#' @examples
+#' data(mtcars)
+#' models <- fitModelParallel(Sepal.Length ~ Sepal.Width + Petal.Length,
+#' group_by = "Species",n.cores = 1, data = iris)
+#' result <- glance_tmb(models)
+glance_tmb <- function(l_tmb){
+ if (identical(class(l_tmb), "glmmTMB")) return(getGlance(l_tmb))
+ l_group <- attributes(l_tmb)$names
+ l_glance <- lapply(stats::setNames(l_group, l_group), function(group) getGlance(l_tmb[[group]]))
+ return(do.call("rbind", l_glance))
+}
+
+
+#' Extracts the summary statistics from a single glmmTMB model.
+#'
+#' This function takes a single glmmTMB model and extracts the summary statistics (AIC, BIC, logLik, deviance,
+#' df.resid, and dispersion) from the model and returns them as a DataFrame.
+#'
+#' @param x A glmmTMB model.
+#' @return A DataFrame with the summary statistics for the glmmTMB model.
+#' @export
+#'
+#' @examples
+#' data(mtcars)
+#' model <- glmmTMB::glmmTMB(mpg ~ wt + (1|cyl), data = mtcars)
+#' getGlance(model)
+getGlance <- function(x){
+ if (is.null(x)) return(NULL)
+ ret <- data.frame(t(summary(x)$AICtab))
+ ret$dispersion <- glmmTMB::sigma(x)
+ ret
+}
+
+
+```
+
+
+```{r testGlanceGLM }
+
+test_that("glance_tmb returns the summary statistics for multiple models", {
+ data(iris)
+ models <- fitModelParallel(Sepal.Length ~ Sepal.Width + Petal.Length, group_by = "Species",n.cores = 1, data = iris)
+ result <- glance_tmb(models)
+ expect_true("AIC" %in% colnames(result))
+ expect_true("BIC" %in% colnames(result))
+ expect_true("logLik" %in% colnames(result))
+ expect_true("deviance" %in% colnames(result))
+ expect_true("df.resid" %in% colnames(result))
+ expect_true("dispersion" %in% colnames(result))
+ expect_true(sum(c("setosa","versicolor", "virginica") %in% rownames(result)) == 3)
+
+ ## unique obect in list
+ model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length + (1|Species), data = iris)
+ result <- glance_tmb(model)
+ expect_true("AIC" %in% colnames(result))
+ expect_true("BIC" %in% colnames(result))
+ expect_true("logLik" %in% colnames(result))
+ expect_true("deviance" %in% colnames(result))
+ expect_true("df.resid" %in% colnames(result))
+ expect_true("dispersion" %in% colnames(result))
+
+})
+
+test_that("getGlance returns the summary statistics for a single model", {
+ model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length + (1|Species), data = iris)
+ result <- getGlance(model)
+ expect_true("AIC" %in% colnames(result))
+ expect_true("BIC" %in% colnames(result))
+ expect_true("logLik" %in% colnames(result))
+ expect_true("deviance" %in% colnames(result))
+ expect_true("df.resid" %in% colnames(result))
+ expect_true("dispersion" %in% colnames(result))
+})
+```
+
+
+```{r functionPlotMetrics, filename = "plot_metrics"}
+
+#' Subset the glance DataFrame based on selected variables.
+#'
+#' This function subsets the glance DataFrame to keep only the specified variables.
+#'
+#' @param glance_df The glance DataFrame to subset.
+#' @param focus A character vector of variable names to keep, including "AIC", "BIC", "logLik", "deviance",
+#' "df.resid", and "dispersion".
+#' @return A subsetted glance DataFrame with only the selected variables.
+#' @export
+#'
+#' @examples
+#' data(iris)
+#' models <- fitModelParallel(Sepal.Length ~ Sepal.Width + Petal.Length,
+#' group_by = "Species",n.cores = 1, data = iris)
+#' glance_df <- glance_tmb(models)
+#' glance_df$group_id <- rownames(glance_df)
+#' subset_glance(glance_df, c("AIC", "BIC"))
+subset_glance <- function(glance_df, focus){
+ idx_existing_column <- focus %in% c("AIC", "BIC", "logLik", "deviance" ,"df.resid", "dispersion" )
+ if(sum(!idx_existing_column) > 0) warning(paste(focus[!idx_existing_column], ": does not exist\n"))
+ focus <- focus[idx_existing_column]
+ if (identical(focus, character(0)))
+ stop(paste0("Please select at least one variable to focus on : ",
+ "AIC, BIC, logLik, deviance, df.resid, dispersion" ))
+ glance_df <- glance_df[ , c("group_id", focus)]
+ return(glance_df)
+}
+
+
+#' Plot Metrics for Generalized Linear Mixed Models (GLMM)
+#'
+#' This function generates a density plot of the specified metrics for the given
+#' list of generalized linear mixed models (GLMMs).
+#'
+#' @param l_tmb A list of GLMM objects to extract metrics from.
+#' @param focus A character vector specifying the metrics to focus on. Possible
+#' values include "AIC", "BIC", "logLik", "deviance", "df.resid", and
+#' "dispersion". If \code{NULL}, all available metrics will be plotted.
+#'
+#' @return A ggplot object displaying density plots for the specified metrics.
+#'
+#' @importFrom reshape2 melt
+#' @importFrom ggplot2 aes facet_wrap geom_density theme_bw theme ggtitle
+#'
+#' @export
+#'
+#' @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(l_tmb, focus = NULL) {
+ glance_df <- glance_tmb(l_tmb)
+ glance_df$group_id <- rownames(glance_df)
+ if (!is.null(focus)) {
+ glance_df <- subset_glance(glance_df, focus)
+ }
+ long_glance_df <- reshape2::melt(glance_df, variable.name = "metric")
+ p <- ggplot2::ggplot(long_glance_df) +
+ ggplot2::geom_density(ggplot2::aes(x = value, col = metric, fill = metric), alpha = 0.4) +
+ ggplot2::facet_wrap(~metric, scales = "free") +
+ ggplot2::theme_bw() +
+ ggplot2::theme(legend.position = 'null') +
+ ggplot2::ggtitle("Metrics plot")
+ return(p)
+}
+
+
+```
+
+```{r testPlotMetrics }
+
+
+test_that("subset_glance subsets the glance DataFrame correctly", {
+ data(iris)
+ models <- fitModelParallel(Sepal.Length ~ Sepal.Width + Petal.Length, group_by = "Species",n.cores = 1, data = iris)
+ glance_df <- glance_tmb(models)
+ glance_df$group_id <- rownames(glance_df)
+ result <- subset_glance(glance_df, c("AIC", "BIC"))
+ expect_true("AIC" %in% colnames(result))
+ expect_true("BIC" %in% colnames(result))
+ expect_true("group_id" %in% colnames(result))
+ expect_true(sum(c("setosa","versicolor", "virginica") %in% rownames(result)) == 3)
+})
+
+
+
+
+test_that("metrics_plot returns a ggplot object", {
+
+ data(iris)
+ l_glmTMB <- list(
+ setosa = glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length,
+ data = subset(iris, Species == "setosa")),
+ versicolor = glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length,
+ data = subset(iris, Species == "versicolor")),
+ virginica = glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length,
+ data = subset(iris, Species == "virginica"))
+ )
+ p <- metrics_plot(l_glmTMB)
+ expect_true(inherits(p, "gg"))
+
+})
+
+
+```
+
+
+
+
+
+
+
+```{r functionEvalDispersion, filename = "evaluateDispersion"}
+
+#' 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") + 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.
+#'
+#' @param inferred_dispersion A data frame containing inferred dispersion values.
+#' @param actual_dispersion A numeric vector containing actual dispersion values.
+#'
+#' @return A data frame comparing actual and inferred dispersion values.
+#'
+#' @export
+#'
+#' @examples
+#' \dontrun{
+#' dispersion_comparison <- getDispersionComparison(inferred_disp, actual_disp)
+#' print(dispersion_comparison)
+#' }
+getDispersionComparison <- function(inferred_dispersion, actual_dispersion) {
+ actual_disp <- data.frame(actual_dispersion = actual_dispersion)
+ actual_disp$geneID <- rownames(actual_disp)
+ rownames(actual_disp) <- NULL
+ disp_comparison <- join_dtf(actual_disp, inferred_dispersion, "geneID", "geneID")
+ return(disp_comparison)
+}
+
+
+#' Extract DESeq2 Dispersion Values
+#'
+#' Extracts inferred dispersion values from a DESeq2 wrapped object.
+#'
+#' @param deseq_wrapped A DESeq2 wrapped object containing dispersion values.
+#'
+#' @return A data frame containing inferred dispersion values.
+#'
+#' @export
+#'
+#' @examples
+#' \dontrun{
+#' dispersion_df <- extractDESeqDispersion(deseq2_object)
+#' print(dispersion_df)
+#' }
+extractDESeqDispersion <- function(deseq_wrapped) {
+ inferred_dispersion <- data.frame(inferred_dispersion = deseq_wrapped$dispersion)
+ inferred_dispersion$geneID <- rownames(inferred_dispersion)
+ rownames(inferred_dispersion) <- NULL
+ return(inferred_dispersion)
+}
+
+
+#' Extract TMB Dispersion Values
+#'
+#' Extracts inferred dispersion values from a TMB result object.
+#'
+#' @param l_tmb A TMB result object containing dispersion values.
+#'
+#' @return A data frame containing inferred dispersion values.
+#'
+#' @export
+#'
+#' @examples
+#' \dontrun{
+#' dispersion_df <- extractTMBDispersion(tmb_result)
+#' print(dispersion_df)
+#' }
+extractTMBDispersion <- function(l_tmb) {
+ glanceRes <- glance_tmb(l_tmb)
+ inferred_dispersion <- data.frame(inferred_dispersion = glanceRes$dispersion)
+ inferred_dispersion$geneID <- 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
+#' @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 = actual_dispersion, y = 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 testPlotMetrics }
+
+
+# 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("extractTMBDispersion function extracts dispersion 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)
+ extracted_disp <- extractTMBDispersion(l_res)
+ expect_identical(colnames(extracted_disp), c("inferred_dispersion", "geneID"))
+})
+
+test_that("extractDESeqDispersion function extracts dispersion 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)
+ dds <- DESeq2::DESeqDataSetFromMatrix(
+ countData = round(mock_data$counts),
+ colData = mock_data$metadata,
+ design = ~ varA)
+ dds <- DESeq2::DESeq(dds, quiet = TRUE)
+ deseq_wrapped = wrapper_DESeq2(dds, 2, "greaterAbs")
+
+ extracted_disp <- extractDESeqDispersion(deseq_wrapped)
+ expect_identical(colnames(extracted_disp), c("inferred_dispersion", "geneID"))
+})
+
+test_that("getDispersionComparison 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)
+
+ tmb_disp_inferred <- extractTMBDispersion(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 = wrapper_DESeq2(dds, 2, "greaterAbs")
+
+ tmb_disp_inferred <- extractTMBDispersion(l_res)
+ TMB_dispersion_df <- getDispersionComparison(tmb_disp_inferred, mock_data$groundTruth$gene_dispersion)
+ TMB_dispersion_df$from <- 'HTRfit'
+ DESEQ_disp_inferred <- extractDESeqDispersion(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"))
+})
+
+
+
+```
+
+
+
+
+
+```{r function-seqDepth, filename = "scalingSequencingDepth"}
+
+#' Scale Counts Table
+#'
+#' This function scales a counts table based on the expected sequencing depth per sample.
+#'
+#' @param countsTable A counts table containing raw read counts.
+#' @param seq_depth sequencing depth vector
+#' @return A scaled counts table.
+#'
+#' @export
+#' @examples
+#' mock_data <- list(counts = matrix(c(10, 20, 30, 20, 30, 10, 10, 20, 20, 20, 30, 10), ncol = 4))
+#' scaled_counts <- scaleCountsTable(countsTable = mock_data$counts, 1000000)
+#'
+scaleCountsTable <- function(countsTable, seq_depth){
+ seq_depth_simu <- colSums(countsTable)
+
+ if (length(seq_depth) > length(seq_depth_simu))
+ message("INFO: The length of the sequencing_depth vector exceeds the number of samples. Only the first N values will be utilized.")
+ if (length(seq_depth) < length(seq_depth_simu))
+ message("INFO: The length of the sequencing_depth vector is shorter than the number of samples. Values will be recycled.")
+
+ scalingDepth_factor <- suppressWarnings(seq_depth/seq_depth_simu)
+ counts_scaled <- as.data.frame(sweep(as.matrix(countsTable), 2, scalingDepth_factor, "*"))
+ return(counts_scaled)
+}
+
+
+
+
+```
+
+```{r test-scalingSequencingDepth}
+
+# Test case 1: Scaling with valid min_seq_depth and max_seq_depth
+test_that("Valid scaling of counts table", {
+ # Test data
+ mock_data <- list(counts = matrix(c(10, 20, 30, 20, 30, 10, 10, 20, 20, 20, 30, 10), ncol = 4))
+ # Test function
+ scaled_counts <- scaleCountsTable(countsTable = mock_data$counts, 115000)
+
+ # Expected scaled counts
+ expected_scaled_counts <- matrix(c(5000, 10000, 15000, 10000, 15000, 5000,
+ 5000, 10000, 10000, 10000, 15000, 5000), ncol = 4)
+
+ # Check if the scaled counts match the expected scaled counts
+ expect_true(all(colSums(scaled_counts) == 115000))
+
+})
+
+```
+
+
+
+```{r function-geneExpressionScaling, filename = "scalingGeneExpression"}
+
+
+
+
+#' Get bin expression for a data frame.
+#'
+#' This function divides the values of a specified column in a data frame into \code{n_bins} bins of equal width.
+#' The bin labels are then added as a new column in the data frame.
+#'
+#' @param dtf_coef A data frame containing the values to be binned.
+#' @param n_bins The number of bins to create.
+#'
+#' @return A data frame with an additional column named \code{binExpression}, containing the bin labels.
+#' @export
+#' @examples
+#' dtf <- data.frame(mu_ij = c(10, 20, 30, 15, 25, 35, 40, 5, 12, 22))
+#' dtf_with_bins <- getBinExpression(dtf, n_bins = 3)
+#'
+getBinExpression <- function(dtf_coef, n_bins){
+ col2bin <- "mu_ij"
+ bin_labels <- cut(dtf_coef[[col2bin]], n_bins, labels = paste("BinExpression", 1:n_bins, sep = "_"))
+ dtf_coef$binExpression <- bin_labels
+ return(dtf_coef)
+}
+
+
+
+
+#' Generate BE data.
+#'
+#' This function generates BE data for a given number of genes, in a vector of BE values.
+#'
+#' @param n_genes The number of genes to generate BE data for.
+#' @param basal_expression a numeric vector from which sample BE for eacg genes
+#'
+#' @return A data frame containing gene IDs, BE values
+#'
+#' @examples
+#' generate_BE(n_genes = 100, 10)
+#'
+#' @export
+generate_BE <- function(n_genes, basal_expression) {
+ ## --avoid bug if one value in basal_expr
+ pool2sample <- c(basal_expression, basal_expression)
+ BE <- sample(x = pool2sample, size = n_genes, replace = T)
+ l_geneID <- base::paste("gene", 1:n_genes, sep = "")
+ ret <- list(geneID = l_geneID, basalExpr = BE) %>% as.data.frame()
+ return(ret)
+}
+
+
+
+#' Compute basal expresion for gene expression based on the coefficients data frame.
+#'
+#' This function takes the coefficients data frame \code{dtf_coef} and computes
+#' basal expression for gene expression. The scaling factors are generated
+#' using the function \code{generate_BE}.
+#'
+#' @param dtf_coef A data frame containing the coefficients for gene expression.
+#' @param n_genes number of genes in simulation
+#' @param basal_expression gene basal expression vector
+#'
+#' @return A modified data frame \code{dtf_coef} with an additional column containing
+#' the scaling factors for gene expression.
+#' @export
+#' @examples
+#' list_var <- init_variable()
+#' N_GENES <- 5
+#' dtf_coef <- getInput2simulation(list_var, N_GENES)
+#' dtf_coef <- getLog_qij(dtf_coef)
+#' addBasalExpression(dtf_coef, N_GENES, 1)
+addBasalExpression <- function(dtf_coef, n_genes, basal_expression){
+ BE_df <- generate_BE(n_genes, basal_expression )
+ dtf_coef <- join_dtf(dtf_coef, BE_df, "geneID", "geneID")
+ return(dtf_coef)
+}
+
+
+
+
+```
+
+```{r test-geneExpressionScaling}
+
+test_that("generate_BE returns correct number of genes", {
+ be_data <- generate_BE(n_genes = 100, 1)
+ expect_equal(nrow(be_data), 100)
+})
+
+
+test_that("generate_BE returns BE values within specified vector", {
+ BE_vec <- c(1, 2, 33, 0.4)
+ be_data <- generate_BE(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))
+})
+
+
+
+```
+
+
+
+```{r functionActualMainFixEff, filename = "actualMainFixEffects" }
+
+#' Calculate average values by group
+#'
+#' @param data The input data frame
+#' @param column The name of the target variable
+#' @param group_by The names of the grouping variables
+#' @importFrom data.table setDT tstrsplit
+#' @importFrom rlang :=
+#' @return A data frame with average values calculated by group
+#' @export
+averageByGroup <- function(data, column, group_by) {
+ group_values <- split(data[[column]], data[group_by])
+ mean_values <- sapply(group_values, mean)
+ result <- data.frame(Group = names(mean_values), logQij_mean = mean_values)
+ data.table::setDT(result)[, {{ group_by }} := data.table::tstrsplit(Group, "[.]")]
+ result <- subset(as.data.frame(result), select = -Group)
+ return(result)
+}
+
+#' Convert specified columns to factor
+#'
+#' @param data The input data frame
+#' @param columns The column names to be converted to factors
+#' @return The modified data frame with specified columns converted to factors
+#' @export
+convert2Factor <- function(data, columns) {
+ if (is.character(columns)) {
+ columns <- match(columns, colnames(data))
+ }
+
+ if (length(columns) > 1) data[, columns] <- lapply(data[, columns], as.factor )
+ else data[, columns] <- as.factor(data[, columns])
+ return(data)
+}
+
+#' Subset Fixed Effect Inferred Terms
+#'
+#' This function subsets the tidy TMB object to extract the fixed effect inferred terms
+#' along with their categorization into interaction and non-interaction terms.
+#'
+#' @param tidy_tmb The tidy TMB object containing the inferred terms.
+#'
+#' @return A list with two elements:
+#' \describe{
+#' \item{fixed_term}{A list with two components - \code{nonInteraction} and \code{interaction},
+#' containing the names of the fixed effect inferred terms categorized as non-interaction and interaction terms, respectively.}
+#' \item{data}{A data frame containing the subset of tidy_tmb that contains the fixed effect inferred terms.}
+#' }
+#' @export
+#' @examples
+#' input_var_list <- init_variable()
+#' mock_data <- mock_rnaseq(input_var_list, 10, 2, 2)
+#' getData2computeActualFixEffect(mock_data$groundTruth$effect)
+#' data2fit = prepareData2fit(countMatrix = mock_data$counts, metadata = mock_data$metadata )
+#' #-- fit data
+#' resFit <- fitModelParallel(formula = kij ~ myVariable ,
+#' data = data2fit, group_by = "geneID",
+#' family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
+#' tidy_tmb <- tidy_tmb(resFit)
+#' subsetFixEffectInferred(tidy_tmb)
+subsetFixEffectInferred <- function(tidy_tmb){
+ fixed_tidy <- tidy_tmb[tidy_tmb$effect == "fixed",]
+ l_term <- unique(fixed_tidy$term)
+ l_term <- l_term[!l_term %in% c("(Intercept)", NA)]
+ index_interaction <- grepl(x = l_term, ":")
+ l_term_nonInteraction <- l_term[!index_interaction]
+ l_term_interaction <- l_term[index_interaction]
+ l_term2ret <- list(nonInteraction = l_term_nonInteraction, interaction = l_term_interaction )
+ return(list(fixed_term = l_term2ret, data = fixed_tidy))
+}
+
+
+#' Get data for calculating actual values
+#'
+#' @param groundTruth The ground truth data frame
+#' @return A list containing required data for calculating actual values
+#' @export
+#' @examples
+#' input_var_list <- init_variable()
+#' mock_data <- mock_rnaseq(input_var_list, 10, 2, 2)
+#' getData2computeActualFixEffect(mock_data$groundTruth$effect)
+getData2computeActualFixEffect <- function(groundTruth){
+ col_names <- colnames(groundTruth)
+ categorical_vars <- col_names[grepl(col_names, pattern = "label_")]
+ average_gt <- averageByGroup(groundTruth, "log_qij_scaled", c("geneID", categorical_vars))
+ average_gt <- convert2Factor(data = average_gt, columns = categorical_vars )
+ return(list(categorical_vars = categorical_vars, data = average_gt))
+}
+
+
+#' Get the intercept dataframe
+#'
+#' @param fixeEff_dataActual The input list containing the categorical variables and the data
+#' @return The intercept dataframe
+#' @export
+getActualIntercept <- function(fixeEff_dataActual) {
+ ## -- split list
+ data<- fixeEff_dataActual$data
+ categorical_vars <- fixeEff_dataActual$categorical_vars
+
+ if (length(categorical_vars) == 1){
+ l_labels <- list()
+ l_labels[[categorical_vars]] <- levels(data[, categorical_vars])
+
+ } else l_labels <- lapply(data[, categorical_vars], levels)
+ index_ref <- sapply(categorical_vars, function(var) data[[var]] == l_labels[[var]][1])
+ index_ref <- rowSums(index_ref) == dim(index_ref)[2]
+ df_intercept <- data[index_ref, ]
+ df_intercept$term <- "(Intercept)"
+ colnames(df_intercept)[colnames(df_intercept) == "logQij_mean"] <- "actual"
+ df_intercept$description <- "(Intercept)"
+
+ index2keep <- !colnames(df_intercept) %in% categorical_vars
+ df_intercept <- df_intercept[,index2keep]
+
+ return(df_intercept)
+}
+
+
+#' Generate actual values for a given term
+#'
+#' @param term The term for which actual values are calculated
+#' @param df_actualIntercept The intercept dataframe
+#' @param dataActual The average ground truth dataframe
+#' @param categorical_vars The names of the categorical variables
+#' @return The data frame with actual values for the given term
+#' @export
+generateActualForMainFixEff <- function(term , df_actualIntercept , dataActual , categorical_vars){
+
+ computeActualValueForMainFixEff <- function(df_actualIntercept, df_term) {
+ df_term$actual <- df_term$logQij_mean - df_actualIntercept$actual
+ return(subset(df_term, select = -c(logQij_mean)))
+ }
+
+ df_term <- subsetByTermLabel(dataActual, categorical_vars , term )
+ df_term <- computeActualValueForMainFixEff(df_actualIntercept, df_term)
+ df_term$description <- gsub("\\d+$", "", term)
+ return(df_term)
+}
+
+
+
+#' subset data By Term Label
+#'
+#'
+#' Get a subset of the data based on a specific term label in the categorical variables.
+#'
+#' @param data The data frame to subset
+#' @param categorical_vars The categorical variables to consider
+#' @param term_label The term label to search for
+#' @return A subset of the data frame containing rows where the categorical variables match the specified term label
+#' @export
+#'
+#' @examples
+#' # Create a data frame
+#' my_data <- data.frame(color = c("red", "blue", "green", "red"),
+#' size = c("small", "medium", "large", "medium"),
+#' shape = c("circle", "square", "triangle", "circle"))
+#' my_data[] <- lapply(my_data, as.factor)
+#'
+#' # Get the subset for the term "medium" in the "size" variable
+#' subsetByTermLabel(my_data, "size", "medium")
+#' # Output: A data frame with rows where "size" is "medium"
+#'
+#' # Get the subset for the term "red" in the "color" variable
+#' subsetByTermLabel(my_data, "color", "red")
+#' # Output: A data frame with rows where "color" is "red"
+subsetByTermLabel <- function(data, categorical_vars, term_label ) {
+ if (length(categorical_vars) == 1) {
+ l_labels <- list()
+ l_labels[[categorical_vars]] <- levels(data[, categorical_vars])
+ } else {
+ l_labels <- lapply(data[, categorical_vars], levels)
+ }
+
+ term_variable <- findAttribute(term_label, l_labels)
+ if(is.null(term_variable)) stop("term_label not in 'data'")
+
+ index_ref <- sapply(categorical_vars, function(var) {
+ if (var == term_variable) {
+ data[[var]] == term_label
+ } else {
+ data[[var]] == l_labels[[var]][1]
+ }
+ })
+
+ index_ref <- rowSums(index_ref) == dim(index_ref)[2]
+ df_term <- data[index_ref, ]
+ df_term$term <- term_label
+ return(df_term)
+}
+
+#' Find Attribute
+#'
+#' Find the attribute containing the specified term in a given list.
+#'
+#' @param term The term to search for
+#' @param list The list to search within
+#' @return The attribute containing the term, or NULL if the term is not found in any attribute
+#' @export
+#'
+#' @examples
+#' # Create a list
+#' my_list <- list(color = c("red", "blue", "green"),
+#' size = c("small", "medium", "large"),
+#' shape = c("circle", "square", "triangle"))
+#'
+#' # Find the attribute containing "medium"
+#' findAttribute("medium", my_list)
+findAttribute <- function(term, list) {
+ for (attr in names(list)) {
+ if (term %in% list[[attr]]) {
+ return(attr)
+ }
+ }
+ return(NULL) # If the term is not found in any attribute
+}
+
+#' Get actual values for non-interaction terms
+#'
+#' @param l_term list of term to compute
+#' @param fixeEff_dataActual A list containing required data for calculating actual values
+#' @param df_actualIntercept The data frame containing the actual intercept values
+#' @return A data frame with actual values for non-interaction terms
+#' @export
+getActualMainFixEff <- function( l_term , fixeEff_dataActual , df_actualIntercept ){
+ ## -- split list
+ categorical_vars <- fixeEff_dataActual$categorical_vars
+ data_groundTruth <- fixeEff_dataActual$data
+ ## -- iteration over term
+ l_actual <- lapply(l_term,
+ function(term){
+ generateActualForMainFixEff(term, df_actualIntercept,
+ data_groundTruth, categorical_vars)})
+ df_actual <- do.call("rbind", l_actual)
+ index2keep <- !colnames(df_actual) %in% categorical_vars
+ df_actual <- df_actual[,index2keep]
+ return(df_actual)
+}
+
+
+
+
+
+```
+
+```{r test-actualMainFixEff}
+
+test_that("Test for subsetFixEffectInferred function", {
+ # Prepare the test data
+ input_var_list <- init_variable(name = "varA", mu = c(1,2,3), level = 3) %>%
+ init_variable(name = "varB", mu = c(2,-6), level = 2) %>%
+ add_interaction(between_var = c("varA", "varB"), mu = 1, sd = 3)
+
+ mock_data <- mock_rnaseq(input_var_list, 10, 2, 2)
+ getData2computeActualFixEffect(mock_data$groundTruth$effect)
+ data2fit <- prepareData2fit(countMatrix = mock_data$counts, metadata = mock_data$metadata, normalization = F)
+
+ # Fit data
+ resFit <- fitModelParallel(formula = kij ~ varA + varB + varA:varB,
+ data = data2fit, group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
+ tidy_tmb <- tidy_tmb(resFit)
+
+ # Test the subsetFixEffectInferred function
+ result <- subsetFixEffectInferred(tidy_tmb)
+ # Define expected output
+ expected_nonInteraction <- c("varA2", "varA3", "varB2")
+ expected_interaction <- c("varA2:varB2", "varA3:varB2")
+
+ # Compare the output with the expected values
+ expect_equal(result$fixed_term$nonInteraction, expected_nonInteraction)
+ expect_equal(result$fixed_term$interaction, expected_interaction)
+})
+
+
+# Tests for averageByGroup
+test_that("averageByGroup returns correct average values", {
+ # Create a sample data frame
+ data <- data.frame(
+ Group1 = rep(c("A", "B", "C", "D"), each = 2),
+ Group2 = rep(c("X", "Y"), times = 4),
+ Value = 1:8
+ )
+
+ # Calculate average values by group
+ result <- averageByGroup(data, column = "Value", group_by = c("Group1", "Group2"))
+
+ # Check the output
+ expect_equal(nrow(result), 8) # Number of rows
+ expect_equal(colnames(result), c("logQij_mean","Group1", "Group2" )) # Column names
+ expect_equal(result$logQij_mean, c(1, 3,5, 7, 2, 4, 6, 8)) # Average values
+})
+
+# Tests for convert2Factor
+test_that("convert2Factor converts specified columns to factors", {
+ # Create a sample data frame
+ data <- data.frame(
+ Category1 = c("A", "B", "A", "B"),
+ Category2 = c("X", "Y", "X", "Z"),
+ Value = 1:4,
+ stringsAsFactors = FALSE
+ )
+
+ # Convert columns to factors
+ result <- convert2Factor(data, columns = c("Category1", "Category2"))
+
+ # Check the output
+ expect_is(result$Category1, "factor") # Category1 column converted to factor
+ expect_is(result$Category2, "factor") # Category2 column converted to factor
+})
+
+# Tests for findAttribute
+test_that("findAttribute returns the correct attribute", {
+ # Create a sample list
+ my_list <- list(
+ color = c("red", "blue", "green"),
+ size = c("small", "medium", "large"),
+ shape = c("circle", "square", "triangle")
+ )
+
+ # Find attributes
+ attr1 <- findAttribute("medium", my_list)
+ attr2 <- findAttribute("rectangle", my_list)
+
+ # Check the output
+ expect_equal(attr1, "size") # Attribute containing "medium"
+ expect_equal(attr2, NULL) # Attribute containing "rectangle"
+})
+
+# Tests for getActualIntercept
+test_that("getActualIntercept returns the correct intercept dataframe", {
+ # Create a sample data frame
+ data <- data.frame(
+ Category1 = c("A", "B", "A", "B"),
+ Category2 = c("X", "Y", "X", "Z"),
+ logQij_mean = 1:4
+ )
+ data[, c("Category1", "Category2")] <- lapply(data[, c("Category1", "Category2")], as.factor )
+
+ l_fixEffDataActual= list(categorical_vars = c("Category1", "Category2"), data = data)
+ # Get the intercept dataframe
+ result <- getActualIntercept(l_fixEffDataActual)
+
+ # Check the output
+ expect_equal(nrow(result), 2) # Number of rows
+ expect_equal(unique(result$term), "(Intercept)") # Term column
+ expect_equal(result$actual, c(1, 3)) # Actual column
+})
+
+
+
+
+
+# Test subsetByTermLabel with single categorical variable
+test_that("subsetByTermLabel with single categorical variable", {
+ my_data <- list(color = c("red", "blue", "green", "red"),
+ size = c("small", "medium", "large", "medium"),
+ shape = c("circle", "square", "triangle", "circle"))
+ my_data <- expand.grid(my_data)
+ my_data[] <- lapply(my_data, as.factor)
+
+ subset_data <- subsetByTermLabel(my_data, categorical_vars = "size", term_label = "medium")
+ expected_data <- my_data[my_data$size == "medium", ]
+ expected_data$term <- "medium"
+
+ expect_equal(subset_data, expected_data)
+})
+
+# Test subsetByTermLabel with single term label in multiple categorical variables
+test_that("subsetByTermLabel with single term label in multiple categorical variables", {
+ my_data <- list(color = c("red", "blue", "green", "red"),
+ size = c("small", "medium", "large", "medium"),
+ shape = c("circle", "square", "triangle", "circle"))
+ my_data <- expand.grid(my_data)
+ my_data[] <- lapply(my_data, as.factor)
+
+ subset_data <- subsetByTermLabel(data = my_data, categorical_vars = c("color", "shape"), term_label = "circle")
+ expected_data <- my_data[my_data$shape == "circle" & my_data$color == "red" , ]
+ expected_data$term <- "circle"
+
+ expect_equal(subset_data, expected_data)
+})
+
+# Test subsetByTermLabel with non-existent term label expect error
+test_that("subsetByTermLabel with non-existent term label", {
+ my_data <- list(color = c("red", "blue", "green", "red"),
+ size = c("small", "medium", "large", "medium"),
+ shape = c("circle", "square", "triangle", "circle"))
+ my_data <- expand.grid(my_data)
+ my_data[] <- lapply(my_data, as.factor)
+
+ expect_error(subsetByTermLabel(data = my_data, categorical_vars = "size", term_label = "extra-large"))
+})
+
+
+
+# Test getActualMainFixEff
+test_that("getActualMainFixEff", {
+ input_var_list <- init_variable()
+ mock_data <- mock_rnaseq(input_var_list, 2, 2, 2)
+ data2fit <- prepareData2fit(mock_data$counts, mock_data$metadata)
+ inference <- fitModelParallel(kij ~ myVariable ,
+ group_by = "geneID", data2fit, n.cores = 1)
+ tidy_inference <- tidy_tmb(inference)
+ tidy_fix <- subsetFixEffectInferred(tidy_inference)
+ fixEff_dataActual <- getData2computeActualFixEffect(mock_data$groundTruth$effects)
+ actual_intercept <- getActualIntercept(fixEff_dataActual)
+ ## -- main = non interaction
+ actual_mainFixEff <- getActualMainFixEff(tidy_fix$fixed_term$nonInteraction,
+ fixEff_dataActual, actual_intercept)
+
+ expected_actual <- data.frame(geneID = c("gene1", "gene2"),
+ term = c("myVariable2", "myVariable2"),
+ actual = c(1, 1),
+ description = "myVariable")
+ rownames(actual_mainFixEff) <- NULL
+ rownames(actual_mainFixEff) <- NULL
+ expect_equal(actual_mainFixEff, expected_actual)
+})
+
+
+
+test_that("getData2computeActualFixEffect return correct output",{
+ # Prepare the test data
+ input_var_list <- init_variable()
+ mock_data <- mock_rnaseq(input_var_list, 2, 2, 2)
+ data2fit <- prepareData2fit(mock_data$counts, mock_data$metadata)
+ inference <- fitModelParallel(kij ~ myVariable, group_by = "geneID", data2fit, n.cores = 1)
+ tidy_inference <- tidy_tmb(inference)
+ tidy_fix <- subsetFixEffectInferred(tidy_inference)
+
+ # Call the function to test
+ fixEff_dataActual <- getData2computeActualFixEffect(mock_data$groundTruth$effects)
+
+ # Define expected output
+ expected_data <- data.frame(logQij_mean = c(2,2,3,3), geneID = c("gene1", "gene2", "gene1", "gene2"), label_myVariable = factor(c("myVariable1", "myVariable1", "myVariable2", "myVariable2")))
+ expected_categorical_vars <- "label_myVariable"
+ # Compare the output with the expected values
+ expect_equal(fixEff_dataActual$data, expected_data)
+ expect_equal(fixEff_dataActual$categorical_vars, expected_categorical_vars)
+})
+
+
+test_that("generateActualForMainFixEff returns correct values for main fixed effect term", {
+ # Prepare the test data
+ input_var_list <- init_variable()
+ mock_data <- mock_rnaseq(input_var_list, 2, 2, 2)
+ data2fit <- prepareData2fit(mock_data$counts, mock_data$metadata)
+ fixEff_dataActual <- getData2computeActualFixEffect(mock_data$groundTruth$effects)
+ actual_intercept <- getActualIntercept(fixEff_dataActual)
+ df_term <- generateActualForMainFixEff("myVariable2", actual_intercept, fixEff_dataActual$data, fixEff_dataActual$categorical_vars)
+
+ # Define expected output
+ expected <- data.frame(
+ geneID = c("gene1", "gene2"),
+ label_myVariable = factor(c("myVariable2", "myVariable2"), levels = c("myVariable1", "myVariable2")),
+ term = c("myVariable2", "myVariable2"),
+ actual = c(1, 1),
+ description = c("myVariable", "myVariable")
+ )
+ rownames(df_term) <- NULL
+ rownames(expected) <- NULL
+ # Compare the output with the expected values
+ expect_equal(df_term, expected)
+})
+
+
+```
+
+```{r functionActualInteractionFixEff, filename = "actualInteractionFixEffects" }
+#' Filter DataFrame
+#'
+#' Filter a DataFrame based on the specified filter list.
+#'
+#' @param df The DataFrame to be filtered
+#' @param filter_list A list specifying the filters to be applied
+#' @return The filtered DataFrame
+#' @export
+#'
+#' @examples
+#' # Create a DataFrame
+#' df <- data.frame(ID = c(1, 2, 3, 4),
+#' Name = c("John", "Jane", "Mike", "Sarah"),
+#' Age = c(25, 30, 28, 32),
+#' Gender = c("Male", "Female", "Male", "Female"))
+#'
+#' # Create a filter list
+#' filter_list <- list(Name = c("John", "Mike"), Age = c(25, 28))
+#'
+#' # Filter the DataFrame
+#' filter_dataframe(df, filter_list)
+filter_dataframe <- function(df, filter_list ) {
+ filtered_df <- df
+
+ for (attr_name in attributes(filter_list)$names) {
+ attr_value <- filter_list[[attr_name]]
+
+ filtered_df <- filtered_df[filtered_df[[attr_name]] %in% attr_value, ]
+ }
+
+ return(filtered_df)
+}
+
+
+#' Calculate actual interaction values between two terms in a data frame.
+#'
+#' This function calculates the actual interaction values between two terms, \code{lbl_term_1} and \code{lbl_term_2},
+#' in the given data frame \code{data}. The interaction values are computed based on the mean log expression levels
+#' of the conditions satisfying the specified term combinations, and also considering a reference condition.
+#'
+#' @param data A data frame containing the expression data and associated terms.
+#' @param l_reference A data frame representing the reference condition for the interaction.
+#' @param clmn_term_1 The name of the column in \code{data} representing the first term.
+#' @param lbl_term_1 The label of the first term to compute interactions for.
+#' @param clmn_term_2 The name of the column in \code{data} representing the second term.
+#' @param lbl_term_2 The label of the second term to compute interactions for.
+#'
+#' @return A numeric vector containing the actual interaction values between the specified terms.
+#' @export
+#' @examples
+#' average_gt <- data.frame(clmn_term_1 = c("A", "A", "B", "B"),
+#' clmn_term_2 = c("X", "Y", "Y", "X"),
+#' logQij_mean = c(1.5, 8.0, 0.5, 4.0))
+#' # Définir les paramètres de la fonction
+#' l_label <- list(clmn_term_1 = c("A", "B"), clmn_term_2 = c("X", "Y"))
+#' clmn_term_1 <- "clmn_term_1"
+#' lbl_term_1 <- "B"
+#' clmn_term_2 <- "clmn_term_2"
+#' lbl_term_2 <- "Y"
+#' # Calculer la valeur d'interaction réelle
+#' actual_interaction <- calculate_actual_interactionX2_values(average_gt,
+#' l_label, clmn_term_1, lbl_term_1,
+#' clmn_term_2, lbl_term_2)
+calculate_actual_interactionX2_values <- function(data, l_reference , clmn_term_1, lbl_term_1, clmn_term_2, lbl_term_2) {
+ A <- data[data[[clmn_term_1]] == lbl_term_1 &
+ data[[clmn_term_2]] == lbl_term_2, ]
+ B <- data[data[[clmn_term_1]] == lbl_term_1 &
+ data[[clmn_term_2]] == l_reference[[clmn_term_2]][1], ]
+ C <- data[data[[clmn_term_1]] == l_reference[[clmn_term_1]][1] &
+ data[[clmn_term_2]] == lbl_term_2, ]
+ D <- data[data[[clmn_term_1]] == l_reference[[clmn_term_1]][1] &
+ data[[clmn_term_2]] == l_reference[[clmn_term_2]][1], ]
+ actual_interaction <- (A$logQij_mean - B$logQij_mean) - (C$logQij_mean - D$logQij_mean)
+ return(actual_interaction)
+}
+
+
+#' Prepare data for computing interaction values.
+#'
+#' This function prepares the data for computing interaction values between variables.
+#' It filters the \code{dataActual} data frame by selecting only the rows where the categorical variables
+#' specified in \code{categorical_vars} are at their reference levels.
+#'
+#' @param categorical_vars A character vector containing the names of categorical variables.
+#' @param categorical_varsInInteraction A character vector containing the names of categorical variables involved in interactions.
+#' @param dataActual A data frame containing the actual data with categorical variables and associated expression levels.
+#'
+#' @return A data frame containing the filtered data for computing interaction values.
+#' @export
+prepareData2computeInteraction <- function(categorical_vars, categorical_varsInInteraction, dataActual){
+ l_RefInCategoricalVars <- lapply(dataActual[, categorical_vars], function(vector) levels(vector)[1])
+ l_categoricalVars_NOT_InInteraction <- categorical_vars[! categorical_vars %in% categorical_varsInInteraction ]
+ l_filter <- l_RefInCategoricalVars[l_categoricalVars_NOT_InInteraction]
+ dataActual_2computeInteractionValues <- filter_dataframe(dataActual, l_filter)
+ return(dataActual_2computeInteractionValues)
+}
+
+
+
+#' Generate actual values for the interaction fixed effect.
+#'
+#' This function calculates the actual values for the interaction fixed effect
+#' based on the input labels in the interaction, categorical variables in the interaction,
+#' data to compute interaction values, actual intercept, and the reference levels in
+#' categorical variables.
+#'
+#' @param labelsInInteraction A vector containing the labels of the interaction terms.
+#' @param l_categoricalVarsInInteraction A vector containing the names of categorical variables
+#' involved in the interaction.
+#' @param data2computeInteraction The data frame used to compute interaction values.
+#' @param l_RefInCategoricalVars A list containing the reference levels of categorical variables.
+#'
+#' @return A data frame with the actual values for the interaction fixed effect.
+#' The data frame includes columns: term, actual, and description.
+#'
+#' @export
+generateActualInteractionX2_FixEff <- function(labelsInInteraction, l_categoricalVarsInInteraction,
+ data2computeInteraction, l_RefInCategoricalVars ){
+ clmn_term_1 <- l_categoricalVarsInInteraction[1]
+ lbl_term_1 <- labelsInInteraction[1]
+ clmn_term_2 <- l_categoricalVarsInInteraction[2]
+ lbl_term_2 <- labelsInInteraction[2]
+ interactionValues <- calculate_actual_interactionX2_values(data2computeInteraction,
+ l_RefInCategoricalVars, clmn_term_1,
+ lbl_term_1, clmn_term_2, lbl_term_2)
+
+
+ df_actualForMyInteraction <- data.frame(geneID = unique(data2computeInteraction$geneID))
+ df_actualForMyInteraction$term <- paste(labelsInInteraction, collapse = ":")
+ df_actualForMyInteraction$actual <- interactionValues
+ df_actualForMyInteraction$description <- paste(gsub("\\d+$", "", lbl_term_1) ,
+ gsub("\\d+$", "", lbl_term_2), sep = ":")
+
+ return(df_actualForMyInteraction)
+
+}
+
+
+#' Generate Actual Interaction Values for Three Fixed Effects
+#'
+#' This function generates actual interaction values for three fixed effects in a dataset. It takes the labels of the three fixed effects, the dataset, and the reference values for the categorical variables. The function computes the actual interaction values and returns a data frame containing the geneID, the term description, and the actual interaction values.
+#'
+#' @param labelsInInteraction A character vector of labels for the three fixed effects.
+#' @param l_categoricalVarsInInteraction A list of categorical variable names corresponding to the three fixed effects.
+#' @param data2computeInteraction The dataset on which to compute the interaction values.
+#' @param l_RefInCategoricalVars A list of reference values for the categorical variables.
+#'
+#' @return A data frame with geneID, term description, and actual interaction values.
+#'
+#' @export
+generateActualInteractionX3_FixEff <- function(labelsInInteraction, l_categoricalVarsInInteraction,
+ data2computeInteraction, l_RefInCategoricalVars) {
+
+ clmn_term_1 <- l_categoricalVarsInInteraction[1]
+ lbl_term_1 <- labelsInInteraction[1]
+ clmn_term_2 <- l_categoricalVarsInInteraction[2]
+ lbl_term_2 <- labelsInInteraction[2]
+ clmn_term_3 <- l_categoricalVarsInInteraction[3]
+ lbl_term_3 <- labelsInInteraction[3]
+ interactionValues <- calculate_actual_interactionX3_values(data2computeInteraction,
+ l_RefInCategoricalVars, clmn_term_1,
+ lbl_term_1, clmn_term_2, lbl_term_2, lbl_term_3, clmn_term_3)
+
+
+ df_actualForMyInteraction <- data.frame(geneID = unique(data2computeInteraction$geneID))
+ df_actualForMyInteraction$term <- paste(labelsInInteraction, collapse = ":")
+ df_actualForMyInteraction$actual <- interactionValues
+ df_actualForMyInteraction$description <- paste(gsub("\\d+$", "", lbl_term_1) ,
+ gsub("\\d+$", "", lbl_term_2),
+ gsub("\\d+$", "", lbl_term_3), sep = ":")
+
+ return(df_actualForMyInteraction)
+
+}
+
+
+#' Calculate Actual Interaction Values for Three Fixed Effects
+#'
+#' This function calculates actual interaction values for three fixed effects in a dataset. It takes the data, reference values for categorical variables, and the specifications for the fixed effects. The function computes the interaction values and returns the result.
+#'
+#' @param data The dataset on which to calculate interaction values.
+#' @param l_reference A list of reference values for categorical variables.
+#' @param clmn_term_1 The name of the first categorical variable.
+#' @param lbl_term_1 The label for the first categorical variable.
+#' @param clmn_term_2 The name of the second categorical variable.
+#' @param lbl_term_2 The label for the second categorical variable.
+#' @param lbl_term_3 The label for the third categorical variable.
+#' @param clmn_term_3 The name of the third categorical variable.
+#'
+#' @return The computed actual interaction values.
+#'
+#' @export
+calculate_actual_interactionX3_values <- function(data, l_reference, clmn_term_1, lbl_term_1,
+ clmn_term_2, lbl_term_2, lbl_term_3, clmn_term_3) {
+ ## Label term 3
+ A <- data[data[[clmn_term_1]] == lbl_term_1 &
+ data[[clmn_term_2]] == lbl_term_2 &
+ data[[clmn_term_3]] == lbl_term_3, ]
+
+ B <- data[data[[clmn_term_1]] == l_reference[[clmn_term_1]][1] &
+ data[[clmn_term_2]] == lbl_term_2 &
+ data[[clmn_term_3]] == lbl_term_3 , ]
+
+ C <- data[data[[clmn_term_1]] == lbl_term_1 &
+ data[[clmn_term_2]] == l_reference[[clmn_term_2]][1] &
+ data[[clmn_term_3]] == lbl_term_3, ]
+
+ D <- data[data[[clmn_term_1]] == l_reference[[clmn_term_1]][1] &
+ data[[clmn_term_2]] == l_reference[[clmn_term_2]][1] &
+ data[[clmn_term_3]] == lbl_term_3, ]
+
+ termA = (A$logQij_mean-B$logQij_mean) - (C$logQij_mean - D$logQij_mean)
+
+ ## Label term 3 == reference !
+ A <- data[data[[clmn_term_1]] == lbl_term_1 &
+ data[[clmn_term_2]] == lbl_term_2 &
+ data[[clmn_term_3]] == l_reference[[clmn_term_3]][1], ]
+
+ B <- data[data[[clmn_term_1]] == l_reference[[clmn_term_1]][1] &
+ data[[clmn_term_2]] == lbl_term_2 &
+ data[[clmn_term_3]] == l_reference[[clmn_term_3]][1] , ]
+
+ C <- data[data[[clmn_term_1]] == lbl_term_1 &
+ data[[clmn_term_2]] == l_reference[[clmn_term_2]][1] &
+ data[[clmn_term_3]] == l_reference[[clmn_term_3]][1], ]
+
+ D <- data[data[[clmn_term_1]] == l_reference[[clmn_term_1]][1] &
+ data[[clmn_term_2]] == l_reference[[clmn_term_2]][1] &
+ data[[clmn_term_3]] == l_reference[[clmn_term_3]][1], ]
+
+ termB = (A$logQij_mean-B$logQij_mean) - (C$logQij_mean - D$logQij_mean)
+ actual_interaction <- termA - termB
+ return(actual_interaction)
+}
+
+
+
+#' Get the actual interaction values for a given interaction term in the data.
+#'
+#' This function takes an interaction term, the dataset, and the names of the categorical variables
+#' as inputs. It calculates the actual interaction values based on the difference in log-transformed
+#' mean expression levels for the specified interaction term. The function first prepares the data for
+#' computing the interaction values and then generates the actual interaction values.
+#'
+#' @param labelsInInteraction A character vector containing the labels of the categorical levels
+#' involved in the interaction.
+#' @param data The dataset containing the gene expression data and categorical variables.
+#' @param categorical_vars A character vector containing the names of the categorical variables in
+#' the dataset.
+#' @return A data frame containing the actual interaction values.
+#' @export
+getActualInteractionFixEff <- function(labelsInInteraction, data, categorical_vars ){
+ l_RefInCategoricalVars <- lapply(data[, categorical_vars], function(vector) levels(vector)[1])
+ l_labelsInCategoricalVars <- lapply(data[, categorical_vars], levels)
+ l_categoricalVarsInInteraction <- lapply(labelsInInteraction,
+ function(label) findAttribute(label,
+ l_labelsInCategoricalVars)) %>%
+ unlist()
+ data2computeInteraction <- prepareData2computeInteraction(categorical_vars, l_categoricalVarsInInteraction, data )
+
+ ## Interaction x3
+ if (length(labelsInInteraction) == 3){
+ actualInteractionValues <- generateActualInteractionX3_FixEff(labelsInInteraction,
+ l_categoricalVarsInInteraction ,
+ data2computeInteraction,
+ l_RefInCategoricalVars)
+ }
+ # Interaction x2
+ if (length(labelsInInteraction) == 2){
+ actualInteractionValues <- generateActualInteractionX2_FixEff(labelsInInteraction,
+ l_categoricalVarsInInteraction ,
+ data2computeInteraction,
+ l_RefInCategoricalVars)
+ }
+ return(actualInteractionValues)
+}
+
+
+#' Compute actual interaction values for multiple interaction terms.
+#'
+#' This function calculates the actual interaction values for multiple interaction terms
+#' using the provided data.
+#'
+#' @param l_interactionTerm A list of interaction terms in the form of "term1:term2".
+#' @param categorical_vars A character vector containing the names of categorical variables in the data.
+#' @param dataActual The data frame containing the actual gene expression values and metadata.
+#'
+#' @return A data frame containing the actual interaction values for each interaction term.
+#' @export
+#' @examples
+#' N_GENES <- 4
+#' MIN_REPLICATES <- 3
+#' MAX_REPLICATES <- 3
+#' init_var <- init_variable(name = "varA", mu = 8, sd = 0.1, level = 3) %>%
+#' init_variable(name = "varB", mu = c(5,-5), NA , level = 2) %>%
+#' init_variable(name = "varC", mu = 1, 3, 3) %>%
+#' add_interaction(between_var = c("varA", "varC"), mu = 5, 0.1)
+#' mock_data <- mock_rnaseq(init_var, N_GENES,
+#' MIN_REPLICATES, MAX_REPLICATES )
+#' data2fit <- prepareData2fit(countMatrix = mock_data$counts,
+#' metadata = mock_data$metadata )
+#' results_fit <- fitModelParallel(formula = kij ~ varA + varB + varC + varA:varC,
+#' data = data2fit, group_by = "geneID",
+#' family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
+#' tidy_tmb <- tidy_tmb(results_fit)
+#' fixEff_dataInference <- subsetFixEffectInferred(tidy_tmb)
+#' fixEff_dataActual <- getData2computeActualFixEffect(mock_data$groundTruth$effects)
+#' interactionTerm <- fixEff_dataInference$fixed_term$interaction[[1]]
+#' categorical_vars <- fixEff_dataActual$categorical_vars
+#' dataActual <- fixEff_dataActual$data
+#' l_labelsInCategoricalVars <- lapply(dataActual[, categorical_vars], levels)
+#' l_interaction <- strsplit(interactionTerm, split = ":")[[1]]
+#' l_categoricalVarsInInteraction <- lapply(l_interaction,
+#' function(label) findAttribute(label,
+#' l_labelsInCategoricalVars)) %>%
+#' unlist()
+#' data_prepared <- prepareData2computeInteraction(categorical_vars,
+#' l_categoricalVarsInInteraction, dataActual)
+#' # Compute actual interaction values for multiple interactions
+#' actualInteraction <- computeActualInteractionFixEff(interactionTerm, categorical_vars, dataActual)
+computeActualInteractionFixEff <- function(l_interactionTerm, categorical_vars, dataActual){
+
+ l_interaction <- strsplit(l_interactionTerm, split = ":")
+ l_interactionActualValues <- lapply(l_interaction, function(labelsInInteraction)
+ getActualInteractionFixEff(labelsInInteraction, dataActual, categorical_vars))
+ actualInteraction_df <- do.call('rbind', l_interactionActualValues)
+ return(actualInteraction_df)
+}
+```
+
+```{r test-actualInteractionFixEff }
+
+test_that("filter_dataframe retourne le dataframe filtré correctement", {
+ # Créer un exemple de dataframe
+ df <- data.frame(
+ col1 = c(1, 2, 3, 4, 5),
+ col2 = c("A", "B", "C", "D", "E"),
+ col3 = c("X", "Y", "Z", "X", "Y")
+ )
+
+ # Créer une liste de filtres
+ filter_list <- list(
+ col1 = c(2),
+ col2 = "B",
+ col3 = c("Y")
+ )
+
+ # Appliquer les filtres sur le dataframe
+ filtered_df <- filter_dataframe(df, filter_list)
+
+ # Vérifier que les lignes correspondantes sont présentes dans le dataframe filtré
+ expect_equal(nrow(filtered_df), 1)
+ expect_true(all(filtered_df$col1 %in% c(2)))
+ expect_true(all(filtered_df$col2 == "B"))
+ expect_true(all(filtered_df$col3 %in% c("Y")))
+})
+
+test_that("filter_dataframe retourne le dataframe d'origine si aucun filtre n'est spécifié", {
+ # Créer une liste de filtres vide
+ filter_list <- list()
+
+ # Appliquer les filtres sur le dataframe
+ filtered_df <- filter_dataframe(df, filter_list)
+
+ # Vérifier que le dataframe filtré est identique au dataframe d'origine
+ expect_identical(filtered_df, df)
+})
+
+test_that("calculate_actual_interactionX2_values retourne la valeur d'interaction réelle correctement", {
+ average_gt <- data.frame(
+ clmn_term_1 = c("A", "A", "B", "B"),
+ clmn_term_2 = c("X", "Y", "X", "Y"),
+ logQij_mean = c(1.5, 2.0, 85, 1.0)
+ )
+
+ # Définir les paramètres de la fonction
+ l_label <- list(clmn_term_1 = c("A", "B"), clmn_term_2 = c("X", "Y"))
+ clmn_term_1 <- "clmn_term_1"
+ lbl_term_1 <- "B"
+ clmn_term_2 <- "clmn_term_2"
+ lbl_term_2 <- "Y"
+
+ # Calculer la valeur d'interaction réelle
+ actual_interaction <- calculate_actual_interactionX2_values(average_gt, l_label, clmn_term_1, lbl_term_1, clmn_term_2, lbl_term_2)
+
+ # Vérifier que la valeur d'interaction réelle est correcte
+ expect_equal(actual_interaction, -84.5)
+})
+
+
+
+test_that("prepareData2computeInteraction filters data correctly", {
+
+ data <- data.frame(
+ geneID = c("gene1", "gene2", "gene3", "gene4"),
+ label_varA = factor(c("A", "A", "B", "B")),
+ label_varB = factor(c("X", "X", "Y", "Y")),
+ label_varC = factor(c("P", "P", "Q", "Q")),
+ logQij_mean = c(1.2, 3.4, 5.6, 7.8)
+ )
+ categorical_vars <- c("label_varA", "label_varB", "label_varC")
+ categorical_varsInInteraction <- c("label_varA", "label_varC")
+
+ dataActual_2computeInteractionValues <- prepareData2computeInteraction(categorical_vars, categorical_varsInInteraction, data)
+
+ expect_equal(nrow(dataActual_2computeInteractionValues), 2)
+ expect_true(all(dataActual_2computeInteractionValues$label_varA %in% c("A", "A")))
+ expect_true(all(dataActual_2computeInteractionValues$label_varB %in% c("X", "X")))
+ expect_true(all(dataActual_2computeInteractionValues$label_varC %in% c("P", "P")))
+ expect_equal(dataActual_2computeInteractionValues$logQij_mean, c(1.2, 3.4 ))
+})
+
+
+
+## TEST
+test_that("Generate actual interaction fixed effect correctly", {
+
+ ########################################################################"
+ N_GENES <- 4
+ MIN_REPLICATES <- 3
+ MAX_REPLICATES <- 3
+
+ init_var <- init_variable(name = "varA", mu = 8, sd = 0.1, level = 3) %>%
+ init_variable(name = "varB", mu = c(5, -5), NA, level = 2) %>%
+ init_variable(name = "varC", mu = 1, 3, 3) %>%
+ add_interaction(between_var = c("varA", "varC"), mu = 5, 0.1)
+
+ # -- simulation
+ mock_data <- mock_rnaseq(init_var, N_GENES, min_replicates = MIN_REPLICATES, max_replicates = MAX_REPLICATES)
+
+ # -- fit data
+ data2fit <- prepareData2fit(countMatrix = mock_data$counts, metadata = mock_data$metadata)
+ results_fit <- fitModelParallel(formula = kij ~ varA + varB + varC + varA:varC,
+ data = data2fit, group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
+
+ # -- inputs
+ tidy_tmb <- tidy_tmb(results_fit)
+ fixEff_dataInference <- subsetFixEffectInferred(tidy_tmb)
+ fixEff_dataActual <- getData2computeActualFixEffect(mock_data$groundTruth$effects)
+
+ interactionTerm <- fixEff_dataInference$fixed_term$interaction[[1]]
+ categorical_vars <- fixEff_dataActual$categorical_vars
+ dataActual <- fixEff_dataActual$data
+ l_labelsInCategoricalVars <- lapply(dataActual[, categorical_vars], levels)
+ l_interaction <- strsplit(interactionTerm, split = ":")[[1]]
+ l_categoricalVarsInInteraction <- lapply(l_interaction,
+ function(label) findAttribute(label, l_labelsInCategoricalVars)) %>% unlist()
+
+ data_prepared <- prepareData2computeInteraction(categorical_vars, l_categoricalVarsInInteraction, dataActual)
+ actual_intercept <- getActualIntercept(fixEff_dataActual)
+ l_RefInCategoricalVars <- lapply(dataActual[, categorical_vars], function(vector) levels(vector)[1])
+ #######################################################################
+
+ actualInteraction <- generateActualInteractionX2_FixEff(l_interaction, l_categoricalVarsInInteraction,
+ data_prepared, l_RefInCategoricalVars)
+
+ # Add your assertions here based on the expected values
+ # For example:
+ expect_true(nrow(actualInteraction) == 4)
+ expect_equal(actualInteraction$geneID, c("gene1", "gene2", "gene3", "gene4"))
+ expect_true(all(actualInteraction$term %in% 'varA2:varC2'))
+ #expect_true(all(actualInteraction$description %in% 'interaction'))
+ expect_true(is.numeric(actualInteraction$actual))
+
+ # Add more assertions as needed...
+})
+
+
+# Test the function `generateActualInteractionX2_FixEff`
+test_that("Test generateActualInteractionX2_FixEff function", {
+ # Generate example data
+ data <- data.frame(
+ geneID = rep(x = c("gene1", "gene2"), each = 8),
+ logQij_mean = 1:16
+
+ )
+ metadata = expand.grid(list(varA = factor(c("A1", "A2")),
+ varB = factor(c("B1", "B2")),
+ varC = factor(c("C1", "C2"))))
+ metadata = rbind(metadata, metadata)
+
+ data <- cbind(metadata, data)
+
+ categorical_vars <- c("varA", "varB", "varC")
+ labelsInInteraction <- c("A2", "C2")
+
+ actual_intercept <- data.frame(actual = c(23, 21 ),
+ geneID = c("gene1", "gene2"),
+ term = c("(Intercept)", "(Intercept)"),
+ description = c("(Intercept)", "(Intercept)"))
+ # Run the function
+
+ actualInteractionValues <- getActualInteractionFixEff(labelsInInteraction, data, categorical_vars )
+
+
+ # Define the expected output based on the example data
+ expected_output <- data.frame(
+ term = "A2:C2",
+ geneID = c("gene1", "gene2"),
+ actual = c(0, 0),
+ description = c("A:C", "A:C")
+ )
+
+ # Add your assertions here to compare the actual output with the expected output
+ expect_equal(nrow(actualInteractionValues), nrow(expected_output))
+ expect_equal(actualInteractionValues$geneID, expected_output$geneID)
+ expect_equal(actualInteractionValues$term, expected_output$term)
+ expect_equal(actualInteractionValues$actual, expected_output$actual)
+ #expect_equal(actualInteractionValues$description, expected_output$description)
+
+})
+
+
+
+# Test for generateActualInteractionX3FixEff
+test_that("generateActualInteractionX3FixEff returns correct data frame", {
+
+ # Create reference values
+ reference <- list(
+ varA = c("A1", "A2"),
+ varB = c("B1", "B2"),
+ varC = c("C1", "C2")
+ )
+ # Generate example data
+ set.seed(123)
+ data <- data.frame(
+ geneID = rep(x = c("gene1", "gene2"), each = 8),
+ logQij_mean = sample(x = -3:12, 16)
+
+ )
+ metadata = expand.grid(list(varA = factor(c("A1", "A2")),
+ varB = factor(c("B1", "B2")),
+ varC = factor(c("C1", "C2"))))
+ metadata = rbind(metadata, metadata)
+
+ data <- cbind(metadata, data)
+
+ # Call the function
+ result <- generateActualInteractionX3_FixEff(
+ labelsInInteraction = c("A2", "B2", "C2"),
+ l_categoricalVarsInInteraction = c("varA", "varB", "varC"),
+ data2computeInteraction = data,
+ l_RefInCategoricalVars = reference
+ )
+
+ # Check the result
+ expect_equal(nrow(result), 2)
+ expect_equal(ncol(result), 4)
+ expect_identical(result$term, c("A2:B2:C2","A2:B2:C2"))
+ expect_equal(result$actual, c(-3, 13))
+ expect_identical(result$description, c("A:B:C", "A:B:C"))
+})
+
+# Test for calculate_actual_interactionX3_values
+test_that("calculate_actual_interactionX3_values returns correct values", {
+ # Create reference values
+ reference <- list(
+ varA = c("A1", "A2"),
+ varB = c("B1", "B2"),
+ varC = c("C1", "C2")
+ )
+ # Generate example data
+ set.seed(123)
+ data <- data.frame(
+ geneID = rep(x = c("gene1", "gene2"), each = 8),
+ logQij_mean = sample(x = -8:8, 16)
+
+ )
+ metadata = expand.grid(list(varA = factor(c("A1", "A2")),
+ varB = factor(c("B1", "B2")),
+ varC = factor(c("C1", "C2"))))
+ metadata = rbind(metadata, metadata)
+
+ data <- cbind(metadata, data)
+ # Call the function
+ result <- calculate_actual_interactionX3_values(
+ data = data,
+ l_reference = reference,
+ clmn_term_1 = "varA",
+ lbl_term_1 = "A2",
+ clmn_term_2 = "varB",
+ lbl_term_2 = "B2",
+ lbl_term_3 = "C2",
+ clmn_term_3 = "varC"
+ )
+
+ # Check the result
+ expect_equal(result, c(-7, 11))
+})
+
+
+
+## Test interaction X2
+test_that("Test getActualInteractionFixEff", {
+
+ # Exemple de données d'entrée
+ N_GENES <- 4
+ MIN_REPLICATES <- 3
+ MAX_REPLICATES <- 3
+
+ init_var <- init_variable(name = "varA", mu = 8, sd = 0.1, level = 3) %>%
+ init_variable(name = "varB", mu = c(5,-5), NA, level = 2) %>%
+ init_variable(name = "varC", mu = 1, 3, 3) %>%
+ add_interaction(between_var = c("varA", "varC"), mu = 5, 0.1)
+
+ # Simulation
+ mock_data <- mock_rnaseq(init_var, N_GENES, min_replicates = MIN_REPLICATES, max_replicates = MAX_REPLICATES)
+
+ # Données de fit
+ data2fit <- prepareData2fit(countMatrix = mock_data$counts, metadata = mock_data$metadata)
+ results_fit <- fitModelParallel(formula = kij ~ varA + varB + varC + varA:varC,
+ data = data2fit, group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
+
+ # Données d'entrée
+ tidy_tmb <- tidy_tmb(results_fit)
+ fixEff_dataInference <- subsetFixEffectInferred(tidy_tmb)
+ fixEff_dataActual <- getData2computeActualFixEffect(mock_data$groundTruth$effects)
+ interactionTerm <- fixEff_dataInference$fixed_term$interaction[[1]]
+ categorical_vars <- fixEff_dataActual$categorical_vars
+ dataActual <- fixEff_dataActual$data
+ l_labelsInCategoricalVars <- lapply(dataActual[, categorical_vars], levels)
+ l_interaction <- strsplit(interactionTerm, split = ":")[[1]]
+ l_categoricalVarsInInteraction <- lapply(l_interaction,
+ function(label) findAttribute(label, l_labelsInCategoricalVars)) %>% unlist()
+
+ data_prepared <- prepareData2computeInteraction(categorical_vars, l_categoricalVarsInInteraction, dataActual)
+ #actual_intercept <- getActualIntercept(fixEff_dataActual)
+
+ # Appel de la fonction à tester
+ actualInteraction <- getActualInteractionFixEff(l_interaction, data_prepared, categorical_vars)
+
+
+ expect_true(nrow(actualInteraction) == 4)
+ expect_equal(actualInteraction$geneID, c("gene1", "gene2", "gene3", "gene4"))
+ expect_true(all(actualInteraction$term %in% 'varA2:varC2'))
+ #expect_true(all(actualInteraction$description %in% 'interaction'))
+ expect_true(is.numeric(actualInteraction$actual))
+})
+
+
+## Test interaction X3
+test_that("Test getActualInteractionFixEff", {
+
+ # Exemple de données d'entrée
+ N_GENES <- 4
+ MIN_REPLICATES <- 20
+ MAX_REPLICATES <- 20
+
+ init_var <- init_variable( name = "varA", mu = 3,sd = 1, level = 2) %>%
+ init_variable( name = "varB", mu = 2, sd = 2, level = 2) %>%
+ init_variable( name = "varC", mu = 2, sd = 1, level = 2) %>%
+ add_interaction(between_var = c("varA", 'varC'), mu = 0.3, sd = 1) %>%
+ add_interaction(between_var = c("varB", 'varC'), mu = 2, sd = 1) %>%
+ add_interaction(between_var = c("varA", 'varB'), mu = -2, sd = 1) %>%
+ add_interaction(between_var = c("varA", 'varB', "varC"), mu = 1, sd = 1)
+
+
+ # Simulation
+ mock_data <- mock_rnaseq(init_var, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES, dispersion = 100)
+
+ # Données de fit
+ data2fit <- prepareData2fit(countMatrix = mock_data$counts, metadata = mock_data$metadata)
+ results_fit <- fitModelParallel(formula = kij ~ varA + varB + varC + varA:varB + varB:varC + varA:varC + varA:varB:varC,
+ data = data2fit, group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
+
+ # Données d'entrée
+ tidy_tmb <- tidy_tmb(results_fit)
+ fixEff_dataInference <- subsetFixEffectInferred(tidy_tmb)
+ fixEff_dataActual <- getData2computeActualFixEffect(mock_data$groundTruth$effects)
+ interactionTerm <- fixEff_dataInference$fixed_term$interaction[[4]]
+ categorical_vars <- fixEff_dataActual$categorical_vars
+ dataActual <- fixEff_dataActual$data
+ l_labelsInCategoricalVars <- lapply(dataActual[, categorical_vars], levels)
+ l_interaction <- strsplit(interactionTerm, split = ":")[[1]]
+ l_categoricalVarsInInteraction <- lapply(l_interaction,
+ function(label) findAttribute(label, l_labelsInCategoricalVars)) %>% unlist()
+
+ data_prepared <- prepareData2computeInteraction(categorical_vars, l_categoricalVarsInInteraction, dataActual)
+
+ actualInteraction <- getActualInteractionFixEff(l_interaction, data_prepared, categorical_vars)
+
+
+ expect_true(nrow(actualInteraction) == 4)
+ expect_equal(actualInteraction$geneID, c("gene1", "gene2", "gene3", "gene4"))
+ expect_true(all(actualInteraction$term %in% 'varA2:varB2:varC2'))
+ expect_true(all(actualInteraction$description %in% 'varA:varB:varC'))
+ expect_true(is.numeric(actualInteraction$actual))
+})
+
+
+```
+
+```{r function-inferenceToExpected, filename = "inferenceToExpected" }
+
+#' Compare the results of inference with the ground truth data.
+#'
+#' This function takes the data frames containing the inference results and the ground truth data
+#' and generates a table to compare the inferred values with the expected values.
+#'
+#' @param tidy_tmb A data frame containing the results of inference.
+#' @param df_ground_truth A data frame containing the ground truth data used for simulation.
+#'
+#' @return A data frame
+#'
+#' @examples
+#' \dontrun{
+#' inferenceToExpected_withFixedEff(tidy_tmb, df_ground_truth)
+#' }
+#'
+#' @export
+inferenceToExpected_withFixedEff <- function(tidy_tmb , df_ground_truth) {
+
+ ## -- get data
+ fixEff_dataInference <- subsetFixEffectInferred(tidy_tmb)
+ fixEff_dataActual <- getData2computeActualFixEffect(df_ground_truth)
+ actual_intercept <- getActualIntercept(fixEff_dataActual)
+
+ ## -- main = non interaction
+ l_mainEffectTerm <- fixEff_dataInference$fixed_term$nonInteraction
+ actual_mainFixEff <- getActualMainFixEff(l_mainEffectTerm, fixEff_dataActual, actual_intercept)
+
+ ## -- interaction term
+ l_interactionTerm <- fixEff_dataInference$fixed_term$interaction
+ categorical_vars <- fixEff_dataActual$categorical_vars
+ data <- fixEff_dataActual$data
+ actualInteractionFixEff <- computeActualInteractionFixEff(l_interactionTerm, categorical_vars, data)
+
+ ## -- rbind Interaction & Main
+ actual_fixEff <- rbind(actual_mainFixEff , actualInteractionFixEff, actual_intercept )
+
+ ## -- join inference & actual
+ inference_fixEff <- fixEff_dataInference$data
+ res <- join_dtf(inference_fixEff, actual_fixEff , c("ID", "term"), c("geneID", "term"))
+ return(res)
+}
+
+```
+
+
+```{r function-waldTest, filename = "waldTest" }
+
+#' Wald test for hypothesis testing
+#'
+#' This function performs a Wald test for hypothesis testing by comparing an estimation
+#' to a reference value using the provided standard error. It allows testing for
+#' one-tailed alternatives: "greater" - β > reference_value, "less" - β < −reference_value,
+#' or two-tailed alternative: "greaterAbs" - |β| > reference_value.
+#' If the p-value obtained is greater than 1, it is set to 1 to avoid invalid p-values.
+#'
+#' @param estimation The estimated coefficient value.
+#' @param std_error The standard error of the estimation.
+#' @param reference_value The reference value for comparison (default is 0).
+#' @param alternative The type of alternative hypothesis to test (default is "greaterAbs").
+#' @return A list containing the test statistic and p-value.
+#' @importFrom stats pnorm
+#' @export
+#' @examples
+#' # Perform a Wald test with the default "greaterAbs" alternative
+#' wald_test(estimation = 0.1, std_error = 0.02, reference_value = 0.2)
+wald_test <- function(estimation, std_error, reference_value = 0, alternative = "greaterAbs") {
+ if (alternative == "greater") {
+ test_statistic <- (estimation - reference_value) / std_error
+ p_value <- 1 - stats::pnorm(test_statistic, mean = 0, sd = 1, lower.tail = TRUE)
+ } else if (alternative == "less") {
+ test_statistic <- (estimation - reference_value) / std_error
+ p_value <- pnorm(test_statistic, mean = 0, sd = 1, lower.tail = TRUE)
+ } else if (alternative == "greaterAbs") {
+ test_statistic <- (abs(estimation) - reference_value) / std_error
+ p_value <- 2 * (1 - pnorm(test_statistic, mean = 0, sd = 1, lower.tail = TRUE))
+ } else {
+ stop("Invalid alternative type. Use 'greater', 'less', or 'greaterAbs'.")
+ }
+
+ # Set p-value to 1 if it exceeds 1
+ p_value <- pmin(p_value, 1)
+ return(list(statistic = test_statistic, p.value = p_value))
+}
+
+
+
+
+#' Perform statistical tests and return tidy results
+#'
+#' 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 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".
+#'
+#' @return A tidy data frame containing the results of statistical tests for the estimated coefficients.
+#'
+#' @importFrom stats p.adjust
+#' @export
+#'
+#' @examples
+#' data(iris)
+#' model_list <- fitModelParallel(formula = Sepal.Length ~ Sepal.Width + Petal.Length,
+#' data = iris, group_by = "Species", n.cores = 1)
+#' results_df <- tidy_results(model_list, coeff_threshold = 0.1, alternative_hypothesis = "greater")
+tidy_results <- function(list_tmb, coeff_threshold = 0, alternative_hypothesis = "greaterAbs", correction_method = "BH") {
+ tidy_tmb_df <- tidy_tmb(list_tmb)
+ if (coeff_threshold != 0 || alternative_hypothesis != "greaterAbs") {
+ waldRes <- wald_test(tidy_tmb_df$estimate, tidy_tmb_df$std.error, coeff_threshold, alternative_hypothesis)
+ tidy_tmb_df$statistic <- waldRes$statistic
+ tidy_tmb_df$p.value <- waldRes$p.value
+ }
+ tidy_tmb_df$p.adj <- stats::p.adjust(tidy_tmb_df$p.value, method = correction_method)
+ return(tidy_tmb_df)
+}
+
+
+```
+
+
+
+```{r test-waldTest}
+
+# Test unitaires
+test_that("wald_test performs correct tests", {
+ # Test with "greater" alternative
+ result_greater <- wald_test(estimation = 0.1, std_error = 0.02, reference_value = 0.05, alternative = "greater")
+ expect_equal(result_greater$p.value, 1 - pnorm((0.1 - 0.05) / 0.02, mean = 0, sd = 1, lower.tail = TRUE))
+
+ # Test with "less" alternative
+ result_less <- wald_test(estimation = 0.1, std_error = 0.02, reference_value = 0.05, alternative = "less")
+ expect_equal(result_less$p.value, pnorm((0.1 - 0.05) / 0.02, mean = 0, sd = 1, lower.tail = TRUE))
+
+ # Test with "greaterAbs" alternative
+ result_greaterAbs <- wald_test(estimation = 0.1, std_error = 0.02, reference_value = 0.05, alternative = "greaterAbs")
+ expect_equal(result_greaterAbs$p.value, (2 * (1 - pnorm((abs(0.1) - 0.05) / 0.02, mean = 0, sd = 1, lower.tail = TRUE))))
+
+ # Test with invalid alternative
+ expect_error(wald_test(estimation = 0.1, std_error = 0.02, reference_value = 0.05, alternative = "invalid"))
+})
+
+
+
+test_that("results function performs statistical tests correctly", {
+ # Charger les données iris pour les tests
+ data(iris)
+ # Fit models and perform statistical tests
+ model_list <- fitModelParallel(formula = Sepal.Length ~ Sepal.Width + Petal.Length,
+ data = iris, group_by = "Species", n.cores = 1)
+ results_df <- tidy_results(model_list, coeff_threshold = 0.1, alternative_hypothesis = "greater")
+
+ # Vérifier que les colonnes 'statistic' et 'p.value' ont été ajoutées au dataframe
+ expect_true("statistic" %in% colnames(results_df))
+ expect_true("p.value" %in% colnames(results_df))
+
+ # Vérifier que les tests statistiques ont été effectués correctement
+ # Ici, nous ne vérifierons pas les valeurs exactes des résultats car elles peuvent varier en fonction de la machine et des packages utilisés.
+ # Nous nous assurerons seulement que les résultats sont dans le format attendu.
+ expect_is(results_df$statistic, "numeric")
+ expect_is(results_df$p.value, "numeric")
+ expect_is(results_df$p.adj, "numeric")
+
+
+ # Vérifier que les p-values ne dépassent pas 1
+ expect_true(all(results_df$p.value <= 1))
+
+ # Vérifier que les valeurs sont correctes pour les colonnes 'statistic' et 'p.value'
+ # (Cela dépend des données iris et des modèles ajustés)
+ # Remarque : Vous devrez peut-être ajuster ces tests en fonction des valeurs réelles des données iris et des modèles ajustés.
+ expect_true(all(!is.na(results_df$statistic)))
+ expect_true(all(!is.na(results_df$p.value)))
+
+ # Vérifier que le seuil des coefficients et l'hypothèse alternative sont correctement appliqués
+ # Ici, nous nous attendons à ce que les p-values soient uniquement pour les coefficients dépassant le seuil
+ expect_true(all(ifelse(abs(results_df$estimate) > 0.1, results_df$p.value <= 1, results_df$p.value == 1)))
+ expect_true(all(ifelse(abs(results_df$estimate) > 0.1, results_df$p.adj <= 1, results_df$p.adj == 1)))
+
+ })
+
+
+
+
+```
+
+
+
+```{r function-rocPlot, filename = "ROCplot"}
+
+
+#' 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
+#'
+#' @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 = !isDE , m = p.adj, !!!args )) +
+ plotROC::geom_roc(n.cuts = 0, labels = FALSE) +
+ ggplot2::theme_bw() +
+ ggplot2::ggtitle("ROC curve")
+
+ ## -- 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)
+}
+
+
+
+```
+
+```{r test-rocPlot}
+
+
+# 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))
+})
+
+
+```
+
+
+```{r function-countsPlot, filename = "countsPlot"}
+
+#' Generate a density plot of gene counts
+#'
+#' This function generates a density plot of gene counts from mock data.
+#'
+#' @param mock_obj The mock data object containing gene counts.
+#'
+#' @return A ggplot2 density plot.
+#'
+#' @importFrom ggplot2 aes geom_density theme_bw ggtitle scale_x_log10 element_blank
+#' @export
+#'
+#' @examples
+#' mock_data <- list(counts = matrix(c(1, 2, 3, 4, 5, 6, 7, 8, 9), ncol = 3))
+#' counts_plot(mock_data)
+counts_plot <- function(mock_obj){
+
+ counts <- unname(unlist(mock_obj$counts))
+ p <- ggplot2::ggplot() +
+ ggplot2::aes(x = "Genes", y = counts) +
+ ggplot2::geom_point(position = "jitter", alpha = 0.6, size = 0.4, col = "#F0B27A") +
+ ggplot2::geom_violin(fill = "#F8F9F9", alpha = 0.4) +
+ ggplot2::stat_summary(fun = "mean", geom = "point", color = "#B63A0F", size = 5) +
+ ggplot2::theme_bw() +
+ ggplot2::ggtitle("Gene expression plot") +
+ ggplot2::theme(axis.title.x = ggplot2::element_blank())
+ return(p)
+}
+
+
+```
+
+```{r test-countsPlot}
+
+
+
+# Test cases
+test_that("Counts plot is generated correctly", {
+ mock_data <- list(
+ counts = matrix(c(1, 2, 3, 4, 5, 6, 7, 8, 9), ncol = 3)
+ )
+
+ plot <- counts_plot(mock_data)
+
+ expect_true("gg" %in% class(plot))
+})
+
+
+
+```
+
+
+
+```{r function-identityPlot, filename = "identityPlot"}
+
+#' 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
+#' @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 = actual, y = estimate, !!!args), alpha = 0.6) +
+ 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()
+
+
+}
+
+
+```
+
+```{r test-identityPlot}
+
+
+# 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))
+})
+
+
+
+```
+
+
+```{r function-simulationReport, filename = "simulationReport" }
+
+#' Export the Analysis Report to a File
+#'
+#' This function generates an analysis report by arranging and combining various plots
+#' and tables, and then exports the report to a specified file.
+#'
+#' @param report_file Path to the file where the report will be exported.
+#' @param table_settings A table containing settings and parameters used in the analysis.
+#' @param roc_curve A plot displaying the Receiver Operating Characteristic (ROC) curve.
+#' @param dispersion_plot A plot displaying the dispersion values.
+#' @param id_plot A plot displaying unique identifiers.
+#' @param counts_plot A plot displaying the gene counts.
+#'
+#'
+#' @importFrom gridExtra arrangeGrob grid.arrange
+#' @importFrom ggplot2 ggsave
+#'
+#'
+#' @return report
+#' @export
+exportReportFile <- function(report_file, table_settings, roc_curve, dispersion_plot, id_plot, counts_plot){
+
+ middle_part <- gridExtra::arrangeGrob(counts_plot, dispersion_plot, heights = c(1, 1.5))
+ left_part <- gridExtra::arrangeGrob(table_settings, roc_curve ,heights = c(1, 1.5))
+ p2export <- gridExtra::grid.arrange(left_part, middle_part, id_plot ,ncol = 3, widths = c(1,1,2))
+
+ 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)
+}
+
+
+#' Generate a simulation report
+#'
+#' This function generates a simulation report containing various plots and evaluation metrics.
+#'
+#' @param mock_obj A list containing simulation data and ground truth.
+#' @param list_tmb A list of model results.
+#' @param dds_obj a DESeq2 object
+#' @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.
+#' @importFrom ggplot2 aes geom_point geom_abline facet_wrap theme_bw ggtitle
+#' @return A list containing settings, plots, and evaluation results.
+#' @export
+simulationReport <- function(mock_obj, list_tmb = NULL, dds_obj = NULL ,
+ coeff_threshold = 0, alt_hypothesis = "greaterAbs", report_file = 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 <- extractTMBDispersion(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 <- wrapper_DESeq2(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 <- extractDESeqDispersion(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 <- color2use[c(!is.null(list_tmb), !is.null(dds_obj))]
+
+ # -- plotting
+ roc_curve <- roc_plot(comparison_df, col = "from" ) + ggplot2::scale_color_manual(values = color2use)
+ id_plot <- identity_plot(comparison_df, col = "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)
+}
+
+```
+
+
+
+```{r test-simulationReport}
+
+
+# Test case 1: Testing with a sample data frame
+test_that("Generating a formatted table works correctly", {
+ sample_data <- data.frame(
+ Name = c("Alice", "Bob", "Charlie"),
+ Age = c(25, 30, 28)
+ )
+
+ table_grob <- getGrobTable(sample_data)
+
+ expect_s3_class(table_grob, "gtable")
+})
+
+# Test case 4: Testing with non-numeric values
+test_that("Handling non-numeric values in the data frame", {
+ non_numeric_data <- data.frame(
+ Name = c("Alice", "Bob", "Charlie"),
+ Age = c(25, "N/A", 28)
+)
+
+ table_grob <- getGrobTable(non_numeric_data)
+
+ expect_s3_class(table_grob, "gtable")
+})
+
+```
+
+
+```{r function-deseq2, filename = "wrapperDESeq2" }
+
+#' Wrapper Function for DESeq2 Analysis
+#'
+#' This function performs differential expression analysis using DESeq2 based on the provided
+#' DESeqDataSet (dds) object. It calculates the dispersion values from the dds object and then
+#' performs inference on the log-fold change (LFC) values using the specified parameters.
+#'
+#' @param dds A DESeqDataSet object containing the count data and experimental design.
+#' @param lfcThreshold The threshold for minimum log-fold change (LFC) to consider differentially expressed.
+#' @param altHypothesis The alternative hypothesis for the analysis, indicating the direction of change.
+#' Options are "greater", "less", or "two.sided".
+#' @param correction_method The method for p-value correction. Default is "BH" (Benjamini-Hochberg).
+#'
+#' @return A list containing the dispersion values and the results of the differential expression analysis.
+#' The dispersion values are calculated from the dds object and named according to sample names.
+#' The inference results include adjusted p-values and log2 fold changes for each gene.
+#'
+#' @examples
+#' N_GENES = 100
+#' MAX_REPLICATES = 5
+#' MIN_REPLICATES = 5
+#' ## --init variable
+#' input_var_list <- init_variable( name = "genotype", mu = 12, sd = 0.1, level = 3) %>%
+#' init_variable(name = "environment", mu = c(0,1), NA , level = 2)
+#'
+#' mock_data <- mock_rnaseq(input_var_list, N_GENES, MIN_REPLICATES, MAX_REPLICATES)
+#' dds <- DESeq2::DESeqDataSetFromMatrix(mock_data$counts ,
+#' mock_data$metadata, ~ genotype + environment)
+#' dds <- DESeq2::DESeq(dds, quiet = TRUE)
+#' result <- wrapper_DESeq2(dds, lfcThreshold = 1, altHypothesis = "greater")
+#' @export
+wrapper_DESeq2 <- function(dds, lfcThreshold , altHypothesis, correction_method = "BH") {
+ dds_full <- S4Vectors::mcols(dds) %>% as.data.frame()
+
+ ## -- dispersion
+ message("INFO: The dispersion values from DESeq2 were reparametrized to their reciprocals (1/dispersion).")
+ dispersion <- 1/dds_full$dispersion
+ names(dispersion) <- rownames(dds_full)
+
+ ## -- coeff
+ inference_df <- get_inference(dds_full, lfcThreshold, altHypothesis, correction_method)
+ res <- list(dispersion = dispersion, fixEff = inference_df)
+ return(res)
+}
+
+
+
+#' Calculate Inference for Differential Expression Analysis
+#'
+#' This function calculates inference for differential expression analysis based on the results of DESeq2.
+#'
+#' @param dds_full A data frame containing DESeq2 results, including estimate and standard error information.
+#' @param lfcThreshold Log fold change threshold for determining differentially expressed genes.
+#' @param altHypothesis Alternative hypothesis for testing, one of "greater", "less", or "two.sided".
+#' @param correction_method Method for multiple hypothesis correction, e.g., "BH" (Benjamini-Hochberg).
+#'
+#' @return A data frame containing inference results, including statistics, p-values, and adjusted p-values.
+#'
+#' @examples
+#' \dontrun{
+#' # Example usage of the function
+#' inference_result <- get_inference(dds_full, lfcThreshold = 0.5,
+#' altHypothesis = "greater",
+#' correction_method = "BH")
+#' }
+#' @importFrom stats p.adjust
+#' @export
+get_inference <- function(dds_full, lfcThreshold, altHypothesis, correction_method){
+
+ ## -- build subdtf
+ stdErr_df <- getSE_df(dds_full)
+ estim_df <- getEstimate_df(dds_full)
+ ## -- join
+ df2ret <- join_dtf(estim_df, stdErr_df, k1 = c("ID", "term") , k2 = c("ID", "term"))
+
+ ## -- convert to ln
+ message("INFO: The log2-fold change estimates and standard errors from DESeq2 were converted to the natural logarithm scale.")
+ df2ret$estimate <- df2ret$estimate*log(2)
+ df2ret$std.error <- df2ret$std.error*log(2)
+
+ ## -- some details reshaped
+ df2ret$term <- gsub("_vs_.*","", df2ret$term)
+ df2ret$term <- gsub(pattern = "_", df2ret$term, replacement = "")
+ df2ret$term <- removeDuplicatedWord(df2ret$term)
+ df2ret$term <- gsub(pattern = "[.]", df2ret$term, replacement = ":")
+ df2ret$effect <- "fixed"
+ idx_intercept <- df2ret$term == "Intercept"
+ df2ret$term[idx_intercept] <- "(Intercept)"
+
+ ## -- statistical part
+ waldRes <- wald_test(df2ret$estimate, df2ret$std.error, lfcThreshold, altHypothesis)
+ df2ret$statistic <- waldRes$statistic
+ df2ret$p.value <- waldRes$p.value
+ df2ret$p.adj <- stats::p.adjust(df2ret$p.value, method = correction_method)
+
+ return(df2ret)
+}
+
+
+#' Extract Standard Error Information from DESeq2 Results
+#'
+#' This function extracts the standard error (SE) information from DESeq2 results.
+#'
+#' @param dds_full A data frame containing DESeq2 results, including standard error columns.
+#'
+#' @return A data frame with melted standard error information, including gene IDs and terms.
+#'
+#' @examples
+#' \dontrun{
+#' # Example usage of the function
+#' se_info <- getSE_df(dds_full)
+#' }
+#' @importFrom reshape2 melt
+#' @export
+getSE_df <- function(dds_full){
+ columnsInDds_full <- colnames(dds_full)
+ SE_columns <- columnsInDds_full [ grepl("SE" , columnsInDds_full) ]
+ SE_df <- dds_full[, SE_columns]
+ SE_df$ID <- rownames(SE_df)
+ SE_df_long <- reshape2::melt(SE_df,
+ measure.vars = SE_columns,
+ variable.name = "term", value.name = "std.error", drop = F)
+ SE_df_long$term <- gsub(pattern = "SE_", SE_df_long$term, replacement = "")
+ return(SE_df_long)
+
+}
+
+
+#' Extract Inferred Estimate Information from DESeq2 Results
+#'
+#' This function extracts the inferred estimate values from DESeq2 results.
+#'
+#' @param dds_full A data frame containing DESeq2 results, including estimate columns.
+#'
+#' @return A data frame with melted inferred estimate information, including gene IDs and terms.
+#'
+#' @examples
+#' \dontrun{
+#' # Example usage of the function
+#' estimate_info <- getEstimate_df(dds_full)
+#' }
+#' @importFrom reshape2 melt
+#' @export
+getEstimate_df <- function(dds_full){
+ columnsInDds_full <- colnames(dds_full)
+ SE_columns <- columnsInDds_full [ grepl("SE" , columnsInDds_full) ]
+ inferedVal_columns <- gsub("SE_", "" , x = SE_columns)
+
+ estimate_df <- dds_full[, inferedVal_columns]
+ estimate_df$ID <- rownames(estimate_df)
+ estimate_df_long <- reshape2::melt(estimate_df,
+ measure.vars = inferedVal_columns,
+ variable.name = "term", value.name = "estimate", drop = F)
+ return(estimate_df_long)
+
+}
+
+```
+
+
+```{r test-wrapperDESeq2}
+
+
+test_that("get_inference returns a data frame with correct columns", {
+ # Create a sample dds_full data frame
+ N_GENES = 100
+ MAX_REPLICATES = 5
+ MIN_REPLICATES = 5
+ ## --init variable
+ input_var_list <- init_variable( name = "genotype", mu = 12, sd = 0.1, level = 3) %>%
+ init_variable(name = "environment", mu = c(0,1), NA , level = 2)
+
+ mock_data <- mock_rnaseq(input_var_list, N_GENES, MIN_REPLICATES, max_replicates = MAX_REPLICATES)
+ dds <- DESeq2::DESeqDataSetFromMatrix(mock_data$counts , mock_data$metadata, ~ genotype + environment)
+ dds <- DESeq2::DESeq(dds, quiet = TRUE)
+ dds_full <- S4Vectors::mcols(dds) %>% as.data.frame()
+
+ # Call the function
+ inference_results <- get_inference(dds_full, lfcThreshold = 0.5, altHypothesis = "greater", correction_method = "BH")
+
+ # Check if the returned object is a data frame
+ expect_true(is.data.frame(inference_results))
+
+ # Check if the data frame contains the correct columns
+ expect_true("ID" %in% colnames(inference_results))
+ expect_true("estimate" %in% colnames(inference_results))
+ expect_true("std.error" %in% colnames(inference_results))
+ expect_true("term" %in% colnames(inference_results))
+ expect_true("effect" %in% colnames(inference_results))
+ expect_true("statistic" %in% colnames(inference_results))
+ expect_true("p.value" %in% colnames(inference_results))
+ expect_true("p.adj" %in% colnames(inference_results))
+})
+
+
+
+
+
+
+test_that("getEstimate_df function works correctly", {
+
+ # Create a sample dds_full data frame
+ N_GENES = 100
+ MAX_REPLICATES = 5
+ MIN_REPLICATES = 5
+ ## --init variable
+ input_var_list <- init_variable( name = "genotype", mu = 12, sd = 0.1, level = 3) %>%
+ init_variable(name = "environment", mu = c(0,1), NA , level = 2)
+
+ mock_data <- mock_rnaseq(input_var_list, N_GENES, MIN_REPLICATES, max_replicates = MAX_REPLICATES)
+ dds <- DESeq2::DESeqDataSetFromMatrix(mock_data$counts , mock_data$metadata, ~ genotype + environment)
+ dds <- DESeq2::DESeq(dds, quiet = TRUE)
+ dds_full <- S4Vectors::mcols(dds) %>% as.data.frame()
+
+ # Call the function
+ estimate_df_long <- getEstimate_df(dds_full)
+
+ # Check if the resulting data frame has the expected structure
+ expect_true("ID" %in% colnames(estimate_df_long))
+ expect_true("term" %in% colnames(estimate_df_long))
+ expect_true("estimate" %in% colnames(estimate_df_long))
+})
+
+
+
+# Define a test context
+test_that("getSE_df function works correctly", {
+
+ # Create a sample dds_full data frame
+ N_GENES = 100
+ MAX_REPLICATES = 5
+ MIN_REPLICATES = 5
+ ## --init variable
+ input_var_list <- init_variable( name = "genotype", mu = 12, sd = 0.1, level = 3) %>%
+ init_variable(name = "environment", mu = c(0,1), NA , level = 2)
+
+ mock_data <- mock_rnaseq(input_var_list, N_GENES, MIN_REPLICATES, max_replicates = MAX_REPLICATES)
+ dds <- DESeq2::DESeqDataSetFromMatrix(mock_data$counts , mock_data$metadata, ~ genotype + environment)
+ dds <- DESeq2::DESeq(dds, quiet = TRUE)
+ dds_full <- S4Vectors::mcols(dds) %>% as.data.frame()
+
+ # Call the function
+ SE_df_long <- getSE_df(dds_full)
+
+ # Check if the resulting data frame has the expected structure
+ expect_true("ID" %in% colnames(SE_df_long))
+ expect_true("term" %in% colnames(SE_df_long))
+ expect_true("std.error" %in% colnames(SE_df_long))
+})
+
+
+# Define a test context
+test_that("wrapperDESeq2 function works correctly", {
+
+ # Create a sample dds_full data frame
+ N_GENES = 100
+ MAX_REPLICATES = 5
+ MIN_REPLICATES = 5
+ ## --init variable
+ input_var_list <- init_variable( name = "genotype", mu = 12, sd = 0.1, level = 3) %>%
+ init_variable(name = "environment", mu = c(0,1), NA , level = 2)
+
+ mock_data <- mock_rnaseq(input_var_list, N_GENES, MIN_REPLICATES, max_replicates = MAX_REPLICATES)
+ dds <- DESeq2::DESeqDataSetFromMatrix(mock_data$counts , mock_data$metadata, ~ genotype + environment)
+ dds <- DESeq2::DESeq(dds, quiet = TRUE)
+ deseq2_wrapped <- wrapper_DESeq2(dds, 0.2, "greaterAbs")
+
+ expect_true(is.list(deseq2_wrapped))
+
+ # Check if the resulting data frame has the expected structure
+ expect_true("ID" %in% colnames(deseq2_wrapped$fixEff))
+ expect_true("term" %in% colnames(deseq2_wrapped$fixEff))
+ expect_true("std.error" %in% colnames(deseq2_wrapped$fixEff))
+ expect_true("estimate" %in% colnames(deseq2_wrapped$fixEff))
+ expect_true("statistic" %in% colnames(deseq2_wrapped$fixEff))
+ expect_true("p.value" %in% colnames(deseq2_wrapped$fixEff))
+ expect_true("p.adj" %in% colnames(deseq2_wrapped$fixEff))
+
+})
+
+```
+
+
+```{r function-anova, filename = "anova"}
+
+#' Handle ANOVA Errors
+#'
+#' This function handles ANOVA errors and warnings during the ANOVA calculation process.
+#'
+#' @param l_TMB A list of fitted glmmTMB models.
+#' @param group A character string indicating the group for which ANOVA is calculated.
+#' @param ... Additional arguments to be passed to the \code{car::Anova} function.
+#'
+#' @return A data frame containing ANOVA results for the specified group.
+#' @export
+#'
+#' @examples
+#' l_tmb <- fitModelParallel(Sepal.Length ~ Sepal.Width + Petal.Length,
+#' data = iris, group_by = "Species", n.cores = 1)
+#' anova_res <- handleAnovaError(l_tmb, "setosa", type = "III")
+#'
+#' @importFrom car Anova
+#' @export
+handleAnovaError <- function(l_TMB, group, ...) {
+ tryCatch(
+ expr = {
+ withCallingHandlers(
+ car::Anova(l_TMB[[group]], ...),
+ warning = function(w) {
+ message(paste(Sys.time(), "warning for group", group, ":", conditionMessage(w)))
+ invokeRestart("muffleWarning")
+ })
+ },
+ error = function(e) {
+ message(paste(Sys.time(), "error for group", group, ":", conditionMessage(e)))
+ NULL
+ }
+ )
+}
+
+
+#' Perform ANOVA on Multiple glmmTMB Models in Parallel
+#'
+#' This function performs analysis of variance (ANOVA) on a list of \code{glmmTMB}
+#' models in parallel for different groups specified in the list. It returns a list
+#' of ANOVA results for each group.
+#'
+#' @param l_tmb A list of \code{glmmTMB} models, with model names corresponding to the groups.
+#' @param ... Additional arguments passed to \code{\link[stats]{anova}} function.
+#'
+#' @return A list of ANOVA results for each group.
+#' @importFrom stats setNames
+#' @examples
+#' # Perform ANOVA
+#' data(iris)
+#' l_tmb<- fitModelParallel( Sepal.Length ~ Sepal.Width + Petal.Length,
+#' data = iris, group_by = "Species", n.cores = 1 )
+#' anov_res <- anovaParallel(l_tmb , type = "III")
+#' @importFrom stats anova
+#' @export
+anovaParallel <- function(l_tmb, ...) {
+ l_group <- attributes(l_tmb)$names
+ lapply(stats::setNames(l_group, l_group), function(group) handleAnovaError(l_tmb, group, ...))
+}
+
+
+```
+
+
+```{r test-anova}
+
+
+test_that("handleAnovaError return correct ouptut", {
+ data(iris)
+ l_tmb <- fitModelParallel(Sepal.Length ~ Sepal.Width + Petal.Length,
+ data = iris, group_by = "Species", n.cores = 1)
+ anova_res <- handleAnovaError(l_tmb, "setosa", type = "III")
+
+ expect_s3_class(anova_res, "data.frame")
+ expect_equal(nrow(anova_res), 3) # Number of levels
+})
+
+test_that("handleAnovaError return correct ouptut", {
+ data(iris)
+ l_tmb <- fitModelParallel(Sepal.Length ~ Sepal.Width + Petal.Length,
+ data = iris, group_by = "Species", n.cores = 1)
+ anova_res <- handleAnovaError(l_tmb, "INALID_GROUP", type = "III")
+
+ expect_null(anova_res)
+})
+
+
+
+test_that("anovaParallel returns valid ANOVA results", {
+ data(iris)
+ l_tmb <- fitModelParallel(Sepal.Length ~ Sepal.Width + Petal.Length,
+ data = iris, group_by = "Species", n.cores = 1)
+ anov_res <- anovaParallel(l_tmb, type = "III")
+
+ expect_is(anov_res, "list")
+ expect_equal(length(anov_res), length(unique(iris$Species)))
+
+})
+
+
+
+
+
+```
+
+
+```{r function-subsetGenes, filename = "subsetGenes"}
+
+#' Subset Genes in Genomic Data
+#'
+#' This function filters and adjusts genomic data within the Roxygeb project, based on a specified list of genes.
+# It is designed to enhance precision and customization in transcriptomics analysis by retaining only the genes of interest.
+#
+#' @param l_genes A character vector specifying the genes to be retained in the dataset.
+#' @param mockObj An object containing relevant genomic information to be filtered.
+#'
+#' @return A modified version of the 'mockObj' data object, with genes filtered according to 'l_genes'.
+#'
+#' @description The 'subsetGenes' function selects and retains genes from 'mockObj' that match the genes specified in 'l_genes'.
+# It filters the 'groundTruth$effects' data to keep only the rows corresponding to the selected genes.
+# Additionally, it updates 'gene_dispersion' and the count data, ensuring that only the selected genes are retained.
+# The function also replaces the total number of genes in 'settings$values' with the length of 'l_genes'.
+# The result is a more focused and tailored genomic dataset, facilitating precision in subsequent analyses.
+#'
+#' @examples
+#' \dontrun{
+#' # Example list of genes to be retained
+#' selected_genes <- c("GeneA", "GeneB", "GeneC")
+#'
+#' # Example data object 'mockObj' (simplified structure)
+#' mockObj <- list(
+#' # ... (mockObj structure)
+#' )
+#'
+#' # Using the subsetGenes function to filter 'mockObj'
+#' filtered_mockObj <- subsetGenes(selected_genes, mockObj)
+#' }
+#' @export
+subsetGenes <- function(l_genes, mockObj) {
+ # Selects the indices of genes in 'groundTruth$effects$geneID' that are present in 'l_genes'.
+ idx_gt_effects <- mockObj$groundTruth$effects$geneID %in% l_genes
+
+ # Filters 'groundTruth$effects' to keep only the rows corresponding to the selected genes.
+ mockObj$groundTruth$effects <- mockObj$groundTruth$effects[idx_gt_effects, ]
+
+ # Updates 'gene_dispersion' by retaining values corresponding to the selected genes.
+ mockObj$groundTruth$gene_dispersion <- mockObj$groundTruth$gene_dispersion[l_genes]
+
+ # Filters the count data to keep only the rows corresponding to the selected genes.
+ mockObj$counts <- as.data.frame(mockObj$counts[l_genes, ])
+
+ # Replaces the total number of genes in 'settings$values' with the length of 'l_genes'.
+ mockObj$settings$values[1] <- length(l_genes)
+
+ # Returns the modified 'mockObj'.
+ return(mockObj)
+}
+
+
+```
+
+
+```{r function-evaluationWithMixedEffect, filename = "evaluationWithMixedEffect"}
+
+#' Check if the formula contains a mixed effect structure.
+#'
+#' This function checks if the formula contains a mixed effect structure indicated by the presence of "|".
+#'
+#' @param formula A formula object.
+#'
+#' @return \code{TRUE} if the formula contains a mixed effect structure, \code{FALSE} otherwise.
+#'
+#' @examples
+#' is_mixedEffect_inFormula(y ~ x + (1|group))
+#'
+#' @export
+is_mixedEffect_inFormula <- function(formula) {
+ return("|" %in% all.names(formula))
+}
+
+#' Check if the formula follows a specific type I mixed effect structure.
+#'
+#' This function checks if the formula follows a specific type I mixed effect structure, which consists of a fixed effect and a random effect indicated by the presence of "|".
+#'
+#' @param formula A formula object.
+#
+#' @return \code{TRUE} if the formula follows the specified type I mixed effect structure, \code{FALSE} otherwise.
+#
+#' @examples
+#' is_formula_mixedTypeI(formula = y ~ x + (1|group))
+#
+#' @export
+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)
+ return(TRUE)
+}
+
+
+#' Get the categorical variable associated with the fixed effect in a type I formula.
+#'
+#' This function extracts the categorical variable associated with the fixed effect in a type I formula from a tidy tibble.
+# The categorical variable is constructed by taking the label of the second main fixed effect term (ignoring any numeric suffix) and prefixing it with "label_".
+#
+#' @param tidy_tmb A tidy tibble containing model terms.
+#
+#' @return The categorical variable associated with the fixed effect in the type I formula.
+#
+#' @examples
+#' \dontrun{
+#' getCategoricalVar_inFixedEffect(tidy_tmb)
+#' }
+#' @export
+getCategoricalVar_inFixedEffect <- function(tidy_tmb) {
+ main_fixEffs <- unique(subset(tidy_tmb, effect == "fixed")$term)
+ categorical_var_inFixEff <- paste("label", gsub("\\d+$", "", main_fixEffs[2]), sep = "_")
+ return(categorical_var_inFixEff)
+}
+
+
+#' Group log_qij values per genes and labels.
+#'
+#' This function groups log_qij values in a ground truth tibble per genes and labels using a specified categorical variable.
+#
+#' @param ground_truth A tibble containing ground truth data.
+#' @param categorical_var The categorical variable to use for grouping.
+#
+#' @return A list of log_qij values grouped by genes and labels.
+#' @importFrom stats as.formula
+#' @importFrom reshape2 dcast
+#'
+#
+#' @examples
+#' \dontrun{
+#' group_logQij_per_genes_and_labels(ground_truth, categorical_var)
+#' }
+#' @export
+group_logQij_per_genes_and_labels <- function(ground_truth, categorical_var) {
+ str_formula <- paste(c(categorical_var, "geneID"), collapse = " ~ ")
+ formula <- stats::as.formula(str_formula)
+ list_logqij <- ground_truth %>%
+ reshape2::dcast(
+ formula,
+ value.var = "log_qij_scaled",
+ fun.aggregate = list
+ )
+ list_logqij[categorical_var] <- NULL
+ return(list_logqij)
+}
+
+#' Calculate actual mixed effect values for each gene.
+#'
+#' This function calculates actual mixed effect values for each gene using the provided data, reference labels, and other labels in a categorical variable.
+#
+#' @param list_logqij A list of log_qij values grouped by genes and labels.
+#' @param genes_iter_list A list of genes for which to calculate the actual mixed effect values.
+#' @param categoricalVar_infos Information about the categorical variable, including reference labels and other labels.
+#
+#' @return A data frame containing the actual mixed effect values for each gene.
+#
+#' @examples
+#' \dontrun{
+#' getActualMixed_typeI(list_logqij, genes_iter_list, categoricalVar_infos)
+#' }
+#' @export
+getActualMixed_typeI <- function(list_logqij, genes_iter_list, categoricalVar_infos) {
+ labelRef_InCategoricalVar <- categoricalVar_infos$ref
+ labels_InCategoricalVar <- categoricalVar_infos$labels
+ labelOther_inCategoricalVar <- categoricalVar_infos$labelsOther
+
+ data_per_gene <- lapply(genes_iter_list, function(g) {
+ data_gene <- data.frame(list_logqij[[g]])
+ colnames(data_gene) <- labels_InCategoricalVar
+ return(data_gene)
+ })
+
+ l_actual_per_gene <- lapply(genes_iter_list, function(g) {
+ data_gene <- data_per_gene[[g]]
+ res <- calculate_actualMixed(data_gene, labelRef_InCategoricalVar, labelOther_inCategoricalVar)
+ res$geneID <- g
+ return(res)
+ })
+
+ actual_mixedEff <- do.call("rbind", l_actual_per_gene)
+ rownames(actual_mixedEff) <- NULL
+ return(actual_mixedEff)
+}
+
+
+
+#' 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.
+#
+#' @param tidy_tmb tidy model results obtained from fitting a mixed-effects model.
+#' @param ground_truth_eff A data frame containing ground truth effects.
+#
+#' @return A data frame with the comparison of estimated mixed effects to expected values.
+#' @importFrom stats setNames
+#' @examples
+#' \dontrun{
+#' inferenceToExpected_withMixedEff(tidy_tmb(l_tmb), ground_truth_eff)
+#' }
+#' @export
+inferenceToExpected_withMixedEff <- function(tidy_tmb, ground_truth_eff){
+
+ # -- CategoricalVar involve in fixEff
+ categorical_var <- getCategoricalVar_inFixedEffect(tidy_tmb)
+ labels_InCategoricalVar <- levels(ground_truth_eff[, categorical_var])
+ labelRef_InCategoricalVar <- labels_InCategoricalVar[1]
+ labelOther_inCategoricalVar <- labels_InCategoricalVar[2:length(labels_InCategoricalVar)]
+ categoricalVar_infos <- list(ref = labelRef_InCategoricalVar,
+ labels = labels_InCategoricalVar,
+ labelsOther = labelOther_inCategoricalVar )
+
+ ## -- prepare data 2 get actual
+ l_logqij <- group_logQij_per_genes_and_labels(ground_truth_eff, categorical_var)
+ l_genes <- unique(ground_truth_eff$geneID)
+ genes_iter_list <- stats::setNames(l_genes,l_genes)
+ actual_mixedEff <- getActualMixed_typeI(l_logqij, genes_iter_list, categoricalVar_infos)
+
+ res <- join_dtf(actual_mixedEff, tidy_tmb ,c("geneID", "term"), c("ID", "term"))
+
+ ## -- reorder for convenience
+ actual <- res$actual
+ res <- res[, -1]
+ res$actual <- actual
+ return(res)
+}
+
+
+#' 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.
+#
+#' @param data_gene Data for a specific gene.
+#' @param labelRef_InCategoricalVar The reference label for the categorical variable.
+#' @param labelOther_inCategoricalVar Labels for the categorical variable other than the reference label.
+#' @importFrom stats sd cor
+#
+#' @return A data frame containing the calculated actual mixed effects.
+#
+#' @examples
+#' \dontrun{
+#' calculate_actualMixed(data_gene, labelRef_InCategoricalVar, labelOther_inCategoricalVar)
+#' }
+#' @export
+calculate_actualMixed <- function(data_gene, labelRef_InCategoricalVar, labelOther_inCategoricalVar ){
+ log_qij_scaled_intercept <- data_gene[labelRef_InCategoricalVar]
+ colnames(log_qij_scaled_intercept) <- '(Intercept)'
+
+ if (length(labelOther_inCategoricalVar == 1 )) {
+ log_qij_scaled_other <- data_gene[labelOther_inCategoricalVar]
+ } else log_qij_scaled_other <- data_gene[,labelOther_inCategoricalVar]
+ log_qij_scaled_transf <- log_qij_scaled_other - log_qij_scaled_intercept[,"(Intercept)"]
+
+ log_qij_scaled_transf <- cbind(log_qij_scaled_intercept, log_qij_scaled_transf)
+ ## -- fix eff
+ actual_fixedValues <- colMeans(log_qij_scaled_transf)
+
+ ## -- stdev values
+ std_values <- sapply(log_qij_scaled_transf, function(x) stats::sd(x))
+ names(std_values) <- paste("sd", names(std_values), sep = '_')
+
+ ## -- correlation
+ corr_mat <- stats::cor(log_qij_scaled_transf)
+ indx <- which(upper.tri(corr_mat, diag = FALSE), arr.ind = TRUE)
+ corr2keep = corr_mat[indx]
+ name_corr <- paste(rownames(corr_mat)[indx[, "row"]], colnames(corr_mat)[indx[, "col"]], sep = ".")
+ names(corr2keep) <- paste("cor", name_corr, sep = "__")
+
+ ## -- output
+ actual <- c(actual_fixedValues, std_values, corr2keep)
+ res <- as.data.frame(actual)
+ res$term <- rownames(res)
+ rownames(res) <- NULL
+ res$description <- sub("_.*", "", gsub("\\d+$", "" , res$term))
+ return(res)
+
+
+}
+
+
+#' Compare inference results to expected values for a given model.
+#'
+#' This function compares the inference results from a model to the expected values based on a ground truth dataset with the simulated effects. The function handles models with mixed effects and fixed effects separately, ensuring that the comparison is appropriate for the specific model type.
+#'
+#' If a model includes mixed effects, the function checks for support for the specific mixed effect structure and provides an informative error message if the structure is not supported.
+#'
+#' @param tidy_tmb A fitted model object convert to tidy dataframe.
+#' @param ground_truth_eff A ground truth dataset with the simulated effects.
+#' @param formula_used formula used in model
+#'
+#' @return A data frame containing the comparison results, including the term names, inference values, and expected values.
+#'
+#' @examples
+#' \dontrun{
+#' evalData <- compareInferenceToExpected(l_tmb, ground_truth_eff)
+#' }
+#' @export
+compareInferenceToExpected <- function(tidy_tmb, ground_truth_eff, formula_used) {
+ ## -- parsing formula & check mixed effect
+ involvMixedEffect <- is_mixedEffect_inFormula(formula_used)
+
+ msg_e_formula_type <- "This simulation evaluation supports certain types of formulas with mixed effects, but not all.
+ Please refer to the package documentation for information on supported formula structures.
+ You are welcome to implement additional functions to handle specific formula types with mixed effects that are not currently supported."
+
+ ## -- if mixed effect
+ if (involvMixedEffect){
+ message("Mixed effect detected in the formula structure.")
+
+ if(!is_formula_mixedTypeI(formula_used)){
+ stop(msg_e_formula_type)
+ }
+ evalData <- inferenceToExpected_withMixedEff(tidy_tmb, ground_truth_eff)
+
+ ## -- only fixed effect
+ } else {
+
+ message("Only fixed effects are detected in the formula structure.")
+ evalData <- inferenceToExpected_withFixedEff(tidy_tmb, ground_truth_eff)
+ }
+
+ return(evalData)
+}
+
+
+```
+
+```{r test-evaluationWithMixedEffect}
+
+
+
+test_that("Test is_mixedEffect_inFormula", {
+ formula1 <- y ~ a + (1 | B)
+ formula2 <- ~ a + (1 | B)
+ formula3 <- x ~ c + d
+
+ expect_true(is_mixedEffect_inFormula(formula1))
+ expect_true(is_mixedEffect_inFormula(formula2))
+ expect_false(is_mixedEffect_inFormula(formula3))
+})
+
+test_that("Test is_formula_mixedTypeI", {
+ formula1 <- y ~ x + (1 | group)
+ formula2 <- y ~ z + group1 + (1 | group1)
+ formula3 <- y ~ z + (1 | group1 + group2)
+ formula4 <- y ~ z + (1 | group1/z)
+
+ expect_true(is_formula_mixedTypeI(formula1))
+ expect_false(is_formula_mixedTypeI(formula2))
+ expect_false(is_formula_mixedTypeI(formula3))
+ expect_false(is_formula_mixedTypeI(formula4))
+
+})
+
+
+test_that("getCategoricalVar_inFixedEffect returns the correct result", {
+
+ ###### PREPARE DATA
+ N_GENES = 2
+ MAX_REPLICATES = 4
+ MIN_REPLICATES = 4
+
+ input_var_list <- init_variable( name = "genotype", mu = 2, sd = 0.5, level = 10) %>%
+ init_variable( name = "environment", mu = c(1, 3), sd = NA, level = 2) %>%
+ add_interaction(between_var = c("genotype", 'environment'), mu = 1, sd = 0.39)
+
+ mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES,
+ basal_expression = 3, dispersion = 100)
+
+ data2fit = prepareData2fit(countMatrix = mock_data$counts, metadata = mock_data$metadata, normalization = F)
+
+ l_tmb <- fitModelParallel(formula = kij ~ environment + (environment | genotype ),
+ data = data2fit, group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
+
+
+ tidy_tmb <- tidy_tmb(l_tmb)
+ categorical_var <- getCategoricalVar_inFixedEffect(tidy_tmb)
+ expect_equal(categorical_var, "label_environment")
+})
+
+test_that("group_logQij_per_genes_and_labels returns the correct result", {
+
+ ############ PREPARE DATA
+ N_GENES = 2
+ MAX_REPLICATES = 4
+ MIN_REPLICATES = 4
+ input_var_list <- init_variable( name = "genotype", mu = 2, sd = 0.5, level = 10) %>%
+ init_variable( name = "environment", mu = c(1, 3), sd = NA, level = 2) %>%
+ add_interaction(between_var = c("genotype", 'environment'), mu = 1, sd = 0.39)
+
+ mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES,
+ basal_expression = 3, dispersion = 100)
+
+ data2fit = prepareData2fit(countMatrix = mock_data$counts, metadata = mock_data$metadata, normalization = F)
+
+ l_tmb <- fitModelParallel(formula = kij ~ environment + (environment | genotype ),
+ data = data2fit, group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
+
+ ground_truth_eff <- mock_data$groundTruth$effects
+ categorical_var <- "label_environment"
+ logqij_list <- group_logQij_per_genes_and_labels(ground_truth_eff, categorical_var)
+
+ expect_is(logqij_list, "data.frame")
+ expect_equal(attributes(logqij_list)$names , c("gene1", "gene2"))
+ expect_equal(length(logqij_list$gene1), 2)
+ expect_equal(length(logqij_list$gene2), 2)
+ expect_equal(length(logqij_list$gene2[[1]]), 10)
+})
+
+test_that("getActualMixed_typeI returns the correct result", {
+ ############ PREPARE DATA
+ N_GENES = 2
+ MAX_REPLICATES = 4
+ MIN_REPLICATES = 4
+ input_var_list <- init_variable( name = "genotype", mu = 2, sd = 0.5, level = 10) %>%
+ init_variable( name = "environment", mu = c(1, 3), sd = NA, level = 2) %>%
+ add_interaction(between_var = c("genotype", 'environment'), mu = 1, sd = 0.39)
+
+ mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES,
+ basal_expression = 3, dispersion = 100)
+
+ data2fit = prepareData2fit(countMatrix = mock_data$counts, metadata = mock_data$metadata, normalization = F)
+
+ l_tmb <- fitModelParallel(formula = kij ~ environment + (environment | genotype ),
+ data = data2fit, group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
+
+ ground_truth_eff <- mock_data$groundTruth$effects
+ categorical_var <- "label_environment"
+ logqij_list <- group_logQij_per_genes_and_labels(ground_truth_eff, categorical_var)
+ l_genes <- unique(ground_truth_eff$geneID)
+ genes_iter_list <- stats::setNames(l_genes, l_genes)
+ categoricalVar_infos= list(ref = "environment1",
+ labels = c("environment1", "environment2"),
+ labelsOther = "environment2")
+
+ ## -- test
+ actual_mixedEff <- getActualMixed_typeI(logqij_list,
+ genes_iter_list,
+ categoricalVar_infos)
+
+ ## -- verif
+ expect_is(actual_mixedEff, "data.frame")
+ expect_equal(colnames(actual_mixedEff), c("actual", "term", "description", "geneID"))
+ expect_equal(unique(actual_mixedEff$geneID), c("gene1", "gene2"))
+ expect_equal(unique(actual_mixedEff$term), c("(Intercept)", "environment2",
+ "sd_(Intercept)", "sd_environment2", "cor__(Intercept).environment2"))
+
+})
+
+
+# Test for InferenceToExpected_withMixedEff
+test_that("inferenceToExpected_withMixedEff correctly compares inference to expected values", {
+
+ ## -- PREPARE DATA
+ N_GENES = 2
+ MAX_REPLICATES = 4
+ MIN_REPLICATES = 4
+
+ input_var_list <- init_variable(name = "genotype", mu = 2, sd = 0.5, level = 10) %>%
+ init_variable(name = "environment", mu = c(1, 3), sd = NA, level = 2) %>%
+ add_interaction(between_var = c("genotype", 'environment'), mu = 1, sd = 0.39)
+
+ mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES,
+ basal_expression = 3, dispersion = 100)
+
+ data2fit <- prepareData2fit(countMatrix = mock_data$counts, metadata = mock_data$metadata, normalization = FALSE)
+
+ l_tmb <- fitModelParallel(formula = kij ~ environment + (environment | genotype),
+ data = data2fit, group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
+
+ ## -- call fonction to test
+ compared_df <- inferenceToExpected_withMixedEff(tidy_tmb(l_tmb), mock_data$groundTruth$effects)
+
+ ## -- TEST VERIF
+ expect_equal(c("term", "description", "geneID", "effect",
+ "component", "group", "estimate", "std.error",
+ "statistic", "p.value", "actual" ) , colnames(compared_df))
+ expect_equal(c("gene1", "gene2" ) , unique(compared_df$geneID))
+ expect_equal(unique(compared_df$term), c("(Intercept)", "cor__(Intercept).environment2", "environment2",
+ "sd_(Intercept)", "sd_environment2"))
+
+})
+
+# Test for calculate_actualMixed
+test_that("calculate_actualMixed calculates actual mixed effects as expected", {
+ ## -- PREPARE DATA
+ N_GENES = 2
+ MAX_REPLICATES = 4
+ MIN_REPLICATES = 4
+
+ input_var_list <- init_variable(name = "genotype", mu = 2, sd = 0.5, level = 10) %>%
+ init_variable(name = "environment", mu = c(1, 3), sd = NA, level = 2) %>%
+ add_interaction(between_var = c("genotype", 'environment'), mu = 1, sd = 0.39)
+
+ mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES,
+ basal_expression = 3, dispersion = 100)
+
+ data2fit <- prepareData2fit(countMatrix = mock_data$counts, metadata = mock_data$metadata, normalization = FALSE)
+
+
+ ground_truth_eff <- mock_data$groundTruth$effects
+ categorical_var <- "label_environment"
+ logqij_list <- group_logQij_per_genes_and_labels(ground_truth_eff, categorical_var)
+ l_genes <- unique(ground_truth_eff$geneID)
+ genes_iter_list <- stats::setNames(l_genes, l_genes)
+ categoricalVar_infos= list(ref = "environment1",
+ labels = c("environment1", "environment2"),
+ labelsOther = "environment2")
+
+ ## -- call function & test
+ data_per_gene <- lapply(genes_iter_list, function(g) {
+ data_gene <- data.frame(logqij_list[[g]])
+ colnames(data_gene) <- categoricalVar_infos$labels
+ return(data_gene)
+ })
+ data_gene <- data_per_gene$gene1
+ actual_mixed <- calculate_actualMixed(data_gene,
+ labelRef_InCategoricalVar = categoricalVar_infos$ref ,
+ labelOther_inCategoricalVar = categoricalVar_infos$labelsOther)
+ expect_equal( colnames(actual_mixed), c("actual", "term", "description"))
+ expect_equal(actual_mixed$term, c("(Intercept)", "environment2",
+ "sd_(Intercept)", "sd_environment2",
+ "cor__(Intercept).environment2"))
+ expect_equal(actual_mixed$description, c("(Intercept)", "environment",
+ "sd", "sd",
+ "cor"))
+})
+
+
+
+```
+
+# High-Throughput RNA-seq model fit
+
+In the realm of RNAseq analysis, various key experimental parameters play a crucial role in influencing the statistical power to detect expression changes. Parameters such as sequencing depth, the number of replicates, and more have a significant impact. To navigate the selection of optimal values for these experimental parameters, we introduce a comprehensive statistical framework known as **HTRfit**, underpinned by computational simulation. **HTRfit** serves as a versatile tool, not only for simulation but also for conducting differential expression analysis. It facilitates this analysis by fitting Generalized Linear Models (GLMs) with multiple variables, which could encompass genotypes, environmental factors, and more. These GLMs are highly adaptable, allowing the incorporation of fixed effects, mixed effects, and interactions between variables.
+
+
+# Initialize variable to simulate
+
+The `init_variable()` function, which is a key tool for defining the variables in your experimental design. You can specify the variables' names and the size of the effects involved. By manually setting the effect of a variable, you make it a fixed effect, while random effect definitions can make it either fixed or mixed.
+
+## Manually init my first variable
+
+The `init_variable()` function allows for precise control over the variables in your experimental design.
+In this example, we manually initialize **varA** with specifics size effects (mu) and levels.
+
+
+```{r example-init_variable_man, warning=FALSE, message=FALSE}
+input_var_list <- init_variable( name = "varA", mu = c(0.2, 4, -3), level = 3)
+```
+
+
+## Randomly init my first variable
+
+Alternatively, you can randomly initialize **varA** by specifying a mean (mu) and standard deviation (sd).
+This introduces variability into **varA**, making it either a fixed or mixed effect in your design.
+
+```{r example-init_variable_rand, warning=FALSE, message=FALSE}
+input_var_list <- init_variable( name = "varA", mu = 10, sd = 0.2, level = 5)
+```
+
+
+## Randomly init several variables
+
+You can also initialize multiple variables, such as **varA** and **varB**, with random values.
+This flexibility allows you to create diverse experimental designs.
+
+```{r example-init_variable_mult, warning=FALSE, message=FALSE}
+input_var_list <- init_variable( name = "varA", mu = 10, sd = 0.2, level = 5) %>%
+ init_variable( name = "varB", mu = -3, sd = 0.34, level = 2)
+```
+
+## Add interaction between variable
+
+Similarly to `init_variable()`, `add_interaction()` allow to init an interaction between variable.
+
+In this example, we initialize **varA** and **varB**, and create an interaction between **varA**, and **varB** using `add_interaction()`.
+
+```{r example-add_interaction, warning=FALSE, message=FALSE}
+input_var_list <- init_variable( name = "varA", mu = 3, sd = 0.2, level = 2) %>%
+ init_variable( name = "varB", mu = 2, sd = 0.43, level = 2) %>%
+ add_interaction( between_var = c("varA", "varB"), mu = 0.44, sd = 0.2)
+```
+
+
+## Initialized a complex design
+
+Interactions can involve a maximum of three variables, such as **varA**, **varB**, and **varC**.
+
+```{r example-add_interaction_complex, eval=FALSE, message=FALSE, warning=FALSE, include=TRUE}
+## -- example not evaluate in the vignette
+input_var_list <- init_variable( name = "varA", mu = 5, sd = 0.2, level = 2) %>%
+ init_variable( name = "varB", mu = 1, sd = 0.78, level = 2) %>%
+ init_variable( name = "varC", mu = c(2, 3), sd = NA, level = 2) %>%
+ add_interaction( between_var = c("varA", "varC"), mu = 0.44, sd = 0.2) %>%
+ add_interaction( between_var = c("varA", "varB"), mu = 0.43, sd = 0.37) %>%
+ add_interaction( between_var = c("varB", "varC"), mu = -0.33, sd = 0.12) %>%
+ add_interaction( between_var = c("varA", "varB" ,"varC"), mu = 0.87, sd = 0.18)
+```
+
+
+# Simulate RNAseq data
+
+In this section, you will explore how to generate RNAseq data based on the previously defined input variables. The `mock_rnaseq()` function enables you to manage parameters in your RNAseq design, including the number of genes, the minimum and maximum number of replicates within your experimental setup. You can also adjust the sequencing depth, the basal gene expression, and the gene dispersion used for simulating counts.
+
+## Minimal example
+
+```{r example-mock_rnaseq_min, warning=FALSE, message=FALSE}
+## -- Required parameters
+N_GENES = 30
+MIN_REPLICATES = 2
+MAX_REPLICATES = 10
+########################
+
+## -- simulate RNAseq data based on input_var_list, minimum input required
+## -- number of replicate randomly defined between MIN_REP and MAX_REP
+mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES)
+
+## -- simulate RNAseq data based on input_var_list, minimum input required
+## -- Same number of repicates between conditions
+mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MAX_REPLICATES,
+ max_replicates = MAX_REPLICATES)
+```
+
+
+## Scaling genes counts with sequencing depth
+
+Sequencing depth is a critical parameter affecting the statistical power of an RNAseq analysis. With the `sequencing_depth` option in the `mock_rnaseq()` function, you have the ability to control this parameter.
+
+```{r example-mock_rnaseq_seqDepth, warning=FALSE, message=FALSE}
+## -- Required parameters
+N_GENES = 30
+MIN_REPLICATES = 2
+MAX_REPLICATES = 10
+########################
+
+SEQ_DEPTH = c(100000, 5000000, 10000000)## -- Possible number of reads/sample
+SEQ_DEPTH = 10000000 ## -- all samples have same number of reads
+mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES,
+ sequencing_depth = SEQ_DEPTH)
+```
+
+## Set gene dispersion
+
+The dispersion parameter (\alpha_i), characterizes the relationship between the variance of the observed count and its mean value. In simple terms, it quantifies how much we expect the observed count to deviate from the mean value. You can specify the dispersion for individual genes using the dispersion parameter.
+
+```{r example-mock_rnaseq_disp, warning=FALSE, message=FALSE}
+
+## -- Required parameters
+N_GENES = 30
+MIN_REPLICATES = 2
+MAX_REPLICATES = 4
+########################
+
+DISP = 0.1 ## -- Same dispersion for each genes
+DISP = 1000 ## -- Same dispersion for each genes
+DISP = runif(N_GENES, 0, 1000) ## -- Dispersion can vary between genes
+mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES,
+ dispersion = DISP )
+
+```
+
+
+
+## Set basal gene expression
+
+The basal gene expression parameter, accessible through the basal_expression option, allows you to control the fundamental baseline gene expression level. It lets you adjust the expected count when no other factors are influencing gene expression, making it a key factor for simulating RNAseq data that aligns with your experimental design.
+
+```{r example-mock_rnaseq_bexpr, warning=FALSE, message=FALSE}
+## -- Required parameters
+N_GENES = 50
+MIN_REPLICATES = 10
+MAX_REPLICATES = 10
+########################
+
+BASAL_EXPR = -3 ## -- Value can be negative to simulate low expressed gene
+BASAL_EXPR = 2 ## -- Same basal gene expression for the N_GENES
+BASAL_EXPR = c( -3, -1, 2, 8, 9, 10 ) ## -- Basal expression can vary between genes
+mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES,
+ basal_expression = BASAL_EXPR)
+
+## -- output list attributes
+names(mock_data)
+```
+
+# Theory behind HTRfit simulation
+
+
+
+<div id="bg" align="center">
+ <img src="./figs/htrfit_workflow.png" width="500" height="300">
+</div>
+
+
+In this modeling framework, counts denoted as $K_{ij}$ for gene i and sample j are generated using a negative binomial distribution. The negative binomial distribution considers a fitted mean $\mu_{ij}$ and a gene-specific dispersion parameter $\alpha_i$.
+
+The fitted mean $\mu_{ij}$ is determined by a parameter, qij, which is proportionally related to the sum of all effects specified using `init_variable()` or `add_interaction()`. If basal gene expressions are provided, the $\mu_{ij}$ values are scaled accordingly using the gene-specific basal expression value ($bexpr_i$).
+
+Furthermore, the coefficients $\beta_i$ represent the natural logarithm fold changes for gene i across each column of the model matrix X. The dispersion parameter $\alpha_i$ plays a crucial role in defining the relationship between the variance of observed counts and their mean value. In simpler terms, it quantifies how far we expect observed counts to deviate from the mean value.
+
+
+
+# Fitting models
+
+## Prepare data for fitting
+
+The `prepareData2fit()` function serves the purpose of converting the counts matrix and sample metadata into a dataframe that is compatible with downstream **HTRfit** functions designed for model fitting. This function also includes an option to perform median ratio normalization on the data counts.
+
+
+```{r example-prepareData, warning=FALSE, message=FALSE}
+## -- data from simulation or real data
+count_matrix <- mock_data$counts
+metaData <- mock_data$metadata
+##############################
+
+## -- convert counts matrix and samples metadatas in a data frame for fitting
+data2fit = prepareData2fit(countMatrix = count_matrix,
+ metadata = metaData,
+ normalization = F)
+
+
+## -- median ratio normalization
+data2fit = prepareData2fit(countMatrix = count_matrix,
+ metadata = metaData,
+ normalization = T,
+ response_name = "kij")
+
+## -- output
+head(data2fit)
+```
+
+## Fit model from your data
+
+The `fitModelParallel()` function enables independent model fitting for each gene. The number of threads used for this process can be controlled by the `n.cores` parameter.
+
+```{r example-fitModelParallel, warning=FALSE, message=FALSE}
+l_tmb <- fitModelParallel(formula = kij ~ varA,
+ data = data2fit,
+ group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"),
+ log_file = "log.txt",
+ n.cores = 1)
+```
+
+
+## Use mixed effect in your model
+
+**HTRfit** uses the **glmmTMB** functions for model fitting algorithms. This choice allows for the utilization of random effects within your formula design. For further details on how to specify your model, please refer to the [mixed model documentation](https://rdrr.io/cran/glmmTMB/man/glmmTMBControl.html).
+
+
+```{r example-fitModelParallel_mixed, warning=FALSE, message=FALSE}
+l_tmb <- fitModelParallel(formula = kij ~ varA + ( 1 | varB ),
+ data = data2fit,
+ group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"),
+ log_file = "log.txt",
+ n.cores = 1)
+```
+
+## Additional settings
+
+The function provides precise control over model settings for fitting optimization, including options for specifying the [model family](https://www.rdocumentation.org/packages/stats/versions/3.6.2/topics/family) and [model control setting](https://rdrr.io/cran/glmmTMB/man/glmmTMBControl.html). By default, a Gaussian family model is fitted, but for RNA-seq data, it is highly recommended to specify `family = glmmTMB::nbinom2(link = "log")`.
+
+
+```{r example-fitModelParallel_addSet, warning=FALSE, message=FALSE}
+l_tmb <- fitModelParallel(formula = kij ~ varA,
+ data = data2fit,
+ group_by = "geneID",
+ n.cores = 1,
+ log_file = "log.txt",
+ family = glmmTMB::nbinom2(link = "log"),
+ control = glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e5,
+ eval.max=1e5)))
+```
+
+## Not only RNAseq data
+
+As the model family can be customized, HTRfit is not exclusively tailored for RNA-seq data.
+
+```{r example-fitModelParallel_nonRNA, warning=FALSE, message=FALSE, eval=FALSE}
+## -- example not evaluate in the vignette
+data("iris")
+l_tmb <- fitModelParallel(formula = Sepal.Length ~ Sepal.Width + Petal.Length + Petal.Width ,
+ data = iris,
+ group_by = "Species",
+ family = gaussian(),
+ log_file = "log.txt",
+ n.cores = 1)
+```
+
+## Update fit
+
+The `updateParallel()` function updates and re-fits a model for each gene. It offers options similar to those in `fitModelParallel()`.
+
+```{r example-update, warning=FALSE, message=FALSE}
+## -- update your fit modifying the model family
+l_tmb <- updateParallel(formula = kij ~ varA,
+ l_tmb = l_tmb ,
+ family = gaussian(),
+ log_file = "log.txt",
+ n.cores = 1)
+
+## -- update fit using additional model control settings
+l_tmb <- updateParallel(formula = kij ~ varA ,
+ l_tmb = l_tmb ,
+ family = gaussian(),
+ log_file = "log.txt",
+ n.cores = 1,
+ control = glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,
+ eval.max=1e3)))
+
+
+## -- update your model formula and your family model
+l_tmb <- updateParallel(formula = kij ~ varA + varB + varA:varB ,
+ l_tmb = l_tmb ,
+ family = glmmTMB::nbinom2(link = "log"),
+ log_file = "log.txt",
+ n.cores = 1)
+
+## -- output
+l_tmb$gene1
+```
+
+## Plot fit metrics
+
+Visualizing fit metrics is essential for evaluating your models. Here, we show you how to generate various plots to assess the quality of your models. You can explore all metrics or focus on specific aspects like dispersion and log-likelihood.
+
+```{r example-plotMetrics, warning=FALSE, message=FALSE, fig.align='center', fig.height=4, fig.width=6}
+## -- plot all metrics
+metrics_plot(l_tmb = l_tmb)
+```
+
+
+```{r example-plotMetricsFocus, warning=FALSE, message=FALSE, fig.align='center', fig.height=3, fig.width=4}
+## -- Focus on metrics
+metrics_plot(l_tmb = l_tmb, focus = c("dispersion", "logLik"))
+```
+
+## Anova to select the best model
+
+
+Utilizing the `anovaParallel()` function enables you to perform model selection by assessing the significance of the fixed effects. You can also include additional parameters like type. For more details, refer to [car::Anova](https://rdrr.io/cran/car/man/Anova.html).
+
+```{r example-anova, warning=FALSE, message=FALSE}
+## -- update your fit modifying the model family
+l_anova <- anovaParallel(l_tmb = l_tmb)
+
+## -- additional settings
+l_anova <- anovaParallel(l_tmb = l_tmb, type = "III" )
+
+## -- output
+l_anova$gene1
+```
+
+
+# Simulation evaluation report
+
+In this section, we delve into the evaluation of your simulation results. The `simulationReport()` function provide valuable insights into the performance of your simulated data and models.
+
+```{r example-simulationReport, warning = FALSE, message = FALSE, results='hide', fig.keep='none'}
+## -- get simulation/fit evaluation
+resSimu <- simulationReport(mock_data,
+ list_tmb = l_tmb,
+ coeff_threshold = 0.4,
+ alt_hypothesis = "greaterAbs")
+```
+
+## Identity plot
+
+The identity plot, generated by the `simulationReport()` function, provides a visual means to compare the effects used in the simulation (actual effects) with those inferred by the model. This graphical representation facilitates the assessment of the correspondence between the values of the simulated effects and those estimated by the model, allowing for a visual analysis of the model's goodness of fit to the simulated data.
+
+
+```{r example-simulationReport_plotID, warning = FALSE, message = FALSE, fig.align='center', fig.height=4, fig.width=5}
+resSimu$identity_plot
+
+```
+
+## Dispersion plot
+
+The dispersion plot, generated by the `simulationReport()` function, offers a visual comparison of the dispersion parameters used in the simulation \(\alpha_i\) with those estimated by the model. This graphical representation provides an intuitive way to assess the alignment between the simulated dispersion values and the model-inferred values, enabling a visual evaluation of how well the model captures the underlying data characteristics.
+
+The area under the ROC curve (AUC) provides a single metric that summarizes the model's overall performance in distinguishing between differentially expressed and non-differentially expressed genes. A higher AUC indicates better model performance.
+
+```{r example-simulationReport_plotDisp, warning = FALSE, message = FALSE, fig.align='center', fig.height=4, fig.width=5}
+resSimu$dispersionEvaluation$disp_plot
+```
+
+## ROC curve
+
+The Receiver Operating Characteristic (ROC) curve is a valuable tool for assessing the performance of classification models, particularly in the context of identifying differentially expressed genes. It provides a graphical representation of the model's ability to distinguish between genes that are differentially expressed and those that are not, by varying the `coeff_threshold` and the `alt_hypothesis` parameters.
+
+```{r example-simulationReport_plotRoc, warning = FALSE, message = FALSE, fig.align='center', fig.height=4, fig.width=5}
+resSimu$roc_plot
+```
+
+## Compare HTRfit with DESeq2
+
+**HTRfit** offers a wrapper for **DESeq2** outputs. This functionality allows users to seamlessly integrate the results obtained from **DESeq2** into the **HTRfit** analysis pipeline. By doing so, you can readily compare the performance of **HTRfit** with **DESeq2** on your RNAseq data. This comparative analysis aids in determining which tool performs better for your specific research goals and dataset
+
+```{r example-ddsComparison, warning = FALSE, message = FALSE, results='hide', fig.keep='none'}
+## -- DESeq2
+library(DESeq2)
+dds <- DESeq2::DESeqDataSetFromMatrix(
+ countData = count_matrix,
+ colData = metaData,
+ design = ~ varA + varB + varA:varB )
+dds <- DESeq2::DESeq(dds, quiet = TRUE)
+
+
+## -- get simulation/fit evaluation
+resSimu <- simulationReport(mock_data,
+ list_tmb = l_tmb,
+ dds_obj = dds,
+ coeff_threshold = 0.4,
+ alt_hypothesis = "greaterAbs")
+```
+
+```{r example-outputResSimu, warning = FALSE, message = FALSE, fig.align='center', fig.height=4, fig.width=5}
+## -- identity plot
+resSimu$identity_plot
+## -- dispersion
+resSimu$dispersionEvaluation$disp_plot
+## -- roc curve
+resSimu$roc_plot
+```
+
+## Focus evaluation on a subset of genes
+
+In this section, we showcase the assessment of model performance on a subset of genes. Specifically, we focus on evaluating genes with low expression levels, identified by their basal expression ($bexpr_i$) initialized below 0 during the simulation.
+
+```{r example-subsetGenes, warning = FALSE, message = FALSE, results='hide', fig.keep='none'}
+## -- Focus on low expressed genes
+low_expressed_df <- mock_data$groundTruth$effects[ mock_data$groundTruth$effects$basalExpr < 0, ]
+l_genes <- unique(low_expressed_df$geneID)
+mock_lowExpressed <- subsetGenes(l_genes, mock_data)
+
+
+## -- get simulation/fit evaluation
+resSimu <- simulationReport(mock_lowExpressed,
+ list_tmb = l_tmb,
+ dds_obj = dds,
+ coeff_threshold = 0.4,
+ alt_hypothesis = "greaterAbs")
+```
+
+As we compare this evaluation to the previous one, we observe a reduction in the AUC for both **HTRfit** and **DESeq2** inferences.
+
+```{r example-subsetGenes_rocPlot, warning=FALSE, message=FALSE, fig.align='center', fig.height=4, fig.width=5}
+## -- roc curve
+resSimu$roc_plot
+```
+
+# Evaluate model inference involving mixed effects
+
+For certain experimental scenarios, such as those involving a high number of levels or longitudinal data, the utilization of mixed effects within your design formula can be beneficial. The **HTRfit** simulation framework also offers the capability to assess this type of design formula.
+
+```{r example-evalMixed, warning = FALSE, message = FALSE, results='hide', fig.keep='none'}
+## -- init a design with a high number of levels
+input_var_list <- init_variable( name = "varA", mu = 0, sd = 0.29, level = 60) %>%
+ init_variable( name = "varB", mu = 0.27, sd = 0.6, level = 2) %>%
+ add_interaction( between_var = c("varA", "varB"), mu = 0.44, sd = 0.89)
+## -- simulate RNAseq data
+mock_data <- mock_rnaseq(input_var_list,
+ n_genes = 30,
+ min_replicates = 10,
+ max_replicates = 10,
+ basal_expression = 5 )
+## -- prepare data & fit a model with mixed effect
+data2fit = prepareData2fit(countMatrix = mock_data$counts,
+ metadata = mock_data$metadata,
+ normalization = F)
+l_tmb <- fitModelParallel(formula = kij ~ varB + (varB | varA),
+ data = data2fit,
+ group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"),
+ log_file = "log.txt",
+ n.cores = 1)
+## -- evaluation
+resSimu <- simulationReport(mock_data,
+ list_tmb = l_tmb,
+ coeff_threshold = 0.27,
+ alt_hypothesis = "greater")
+```
+
+```{r example-outputResSimuMixed, warning = FALSE, message = FALSE, fig.align='center', fig.height=4, fig.width=5}
+## -- identity plot
+resSimu$identity_plot
+## -- dispersion
+resSimu$dispersionEvaluation$disp_plot
+## -- roc curve
+resSimu$roc_plot
+```
+
+
+```{r development-inflate, eval=FALSE}
+setwd("/Users/ex_dya/Documents/LBMC/HTRfit/")
+#usethis::create_package(path = "/Users/ex_dya/Documents/LBMC/HTRfit/")
+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
+# Execute in the console directly
+fusen::inflate(flat_file = "dev/flat_full.Rmd", vignette_name = "HTRfit")
+```
diff --git a/man/addBasalExpression.Rd b/man/addBasalExpression.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..12951bb8e27bac820f87e81ad13caf77de095628
--- /dev/null
+++ b/man/addBasalExpression.Rd
@@ -0,0 +1,31 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/scalinggeneexpression.R
+\name{addBasalExpression}
+\alias{addBasalExpression}
+\title{Compute basal expresion for gene expression based on the coefficients data frame.}
+\usage{
+addBasalExpression(dtf_coef, n_genes, basal_expression)
+}
+\arguments{
+\item{dtf_coef}{A data frame containing the coefficients for gene expression.}
+
+\item{n_genes}{number of genes in simulation}
+
+\item{basal_expression}{gene basal expression vector}
+}
+\value{
+A modified data frame \code{dtf_coef} with an additional column containing
+the scaling factors for gene expression.
+}
+\description{
+This function takes the coefficients data frame \code{dtf_coef} and computes
+basal expression for gene expression. The scaling factors are generated
+using the function \code{generate_BE}.
+}
+\examples{
+list_var <- init_variable()
+N_GENES <- 5
+dtf_coef <- getInput2simulation(list_var, N_GENES)
+dtf_coef <- getLog_qij(dtf_coef)
+addBasalExpression(dtf_coef, N_GENES, 1)
+}
diff --git a/man/add_interaction.Rd b/man/add_interaction.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..57859b268405ccacedeb389968e30f51063613e6
--- /dev/null
+++ b/man/add_interaction.Rd
@@ -0,0 +1,28 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_initialization.R
+\name{add_interaction}
+\alias{add_interaction}
+\title{Add interaction}
+\usage{
+add_interaction(list_var, between_var, mu, sd = NA)
+}
+\arguments{
+\item{list_var}{A list of variables (already initialized)}
+
+\item{between_var}{A vector of variable names to include in the interaction}
+
+\item{mu}{Either a numeric value or a numeric vector (of length = level)}
+
+\item{sd}{Either numeric value or NA}
+}
+\value{
+A list with initialized interaction
+}
+\description{
+Add interaction
+}
+\examples{
+init_variable(name = "myvarA", mu = 2, sd = 3, level = 200) \%>\%
+init_variable(name = "myvarB", mu = 1, sd = 0.2, level = 2 ) \%>\%
+add_interaction(between_var = c("myvarA", "myvarB"), mu = 3, sd = 2)
+}
diff --git a/man/already_init_variable.Rd b/man/already_init_variable.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..30a0ab8359b317ec111868a3649c322c3093cdcb
--- /dev/null
+++ b/man/already_init_variable.Rd
@@ -0,0 +1,23 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_initialization.R
+\name{already_init_variable}
+\alias{already_init_variable}
+\title{Check if Variable is Already Initialized}
+\usage{
+already_init_variable(list_var, new_var_name)
+}
+\arguments{
+\item{list_var}{A list object representing the variable list.}
+
+\item{new_var_name}{A character string specifying the name of the new variable.}
+}
+\value{
+TRUE if the variable is already initialized, FALSE otherwise.
+}
+\description{
+This function checks if a variable is already initialized in the variable list.
+}
+\examples{
+my_list <- list(var1 = 1, var2 = 2, var3 = 3)
+already_initialized <- already_init_variable(list_var = my_list, new_var_name = "myVariable")
+}
diff --git a/man/anovaParallel.Rd b/man/anovaParallel.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..5adbe52a75f489a78a035d5db0227a5105f2b2f6
--- /dev/null
+++ b/man/anovaParallel.Rd
@@ -0,0 +1,28 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/anova.R
+\name{anovaParallel}
+\alias{anovaParallel}
+\title{Perform ANOVA on Multiple glmmTMB Models in Parallel}
+\usage{
+anovaParallel(l_tmb, ...)
+}
+\arguments{
+\item{l_tmb}{A list of \code{glmmTMB} models, with model names corresponding to the groups.}
+
+\item{...}{Additional arguments passed to \code{\link[stats]{anova}} function.}
+}
+\value{
+A list of ANOVA results for each group.
+}
+\description{
+This function performs analysis of variance (ANOVA) on a list of \code{glmmTMB}
+models in parallel for different groups specified in the list. It returns a list
+of ANOVA results for each group.
+}
+\examples{
+# Perform ANOVA
+data(iris)
+l_tmb<- fitModelParallel( Sepal.Length ~ Sepal.Width + Petal.Length,
+ data = iris, group_by = "Species", n.cores = 1 )
+anov_res <- anovaParallel(l_tmb , type = "III")
+}
diff --git a/man/averageByGroup.Rd b/man/averageByGroup.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..8a19b2d1fcc385c553c0836801577276a321cf8b
--- /dev/null
+++ b/man/averageByGroup.Rd
@@ -0,0 +1,21 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/actualmainfixeffects.R
+\name{averageByGroup}
+\alias{averageByGroup}
+\title{Calculate average values by group}
+\usage{
+averageByGroup(data, column, group_by)
+}
+\arguments{
+\item{data}{The input data frame}
+
+\item{column}{The name of the target variable}
+
+\item{group_by}{The names of the grouping variables}
+}
+\value{
+A data frame with average values calculated by group
+}
+\description{
+Calculate average values by group
+}
diff --git a/man/build_missingColumn_with_na.Rd b/man/build_missingColumn_with_na.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..6defbfe2d86c7825baf37b71d741509461ecd9df
--- /dev/null
+++ b/man/build_missingColumn_with_na.Rd
@@ -0,0 +1,28 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/tidy_glmmtmb.R
+\name{build_missingColumn_with_na}
+\alias{build_missingColumn_with_na}
+\title{Build DataFrame with Missing Columns and NA Values}
+\usage{
+build_missingColumn_with_na(
+ df,
+ l_columns = c("effect", "component", "group", "term", "estimate", "std.error",
+ "statistic", "p.value")
+)
+}
+\arguments{
+\item{df}{The input DataFrame.}
+
+\item{l_columns}{A character vector specifying the column names to be present in the DataFrame.}
+}
+\value{
+A DataFrame with missing columns added and filled with NA values.
+}
+\description{
+This function takes a DataFrame and a list of column names and adds missing columns with NA values to the DataFrame.
+}
+\examples{
+
+df <- data.frame(effect = "fixed", term = "Sepal.Length", estimate = 0.7)
+df_with_na <- build_missingColumn_with_na(df)
+}
diff --git a/man/build_sub_obj_return_to_user.Rd b/man/build_sub_obj_return_to_user.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..6a899b7dcf9ba9f6dc8ebf2220171f8b620e3e45
--- /dev/null
+++ b/man/build_sub_obj_return_to_user.Rd
@@ -0,0 +1,23 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_initialization.R
+\name{build_sub_obj_return_to_user}
+\alias{build_sub_obj_return_to_user}
+\title{Build Sub Object to Return to User}
+\usage{
+build_sub_obj_return_to_user(level, metaData, effectsGivenByUser, col_names)
+}
+\arguments{
+\item{level}{A numeric value specifying the number of levels.}
+
+\item{metaData}{A list of labels.}
+
+\item{effectsGivenByUser}{A list of effects given by the user.}
+
+\item{col_names}{A character vector specifying the column names to use.}
+}
+\value{
+A list with the sub-object details.
+}
+\description{
+This function builds the sub-object to be returned to the user.
+}
diff --git a/man/calculate_actualMixed.Rd b/man/calculate_actualMixed.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..0b907b862dafc44240d317f6f9a2c6b1ea357b89
--- /dev/null
+++ b/man/calculate_actualMixed.Rd
@@ -0,0 +1,30 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/evaluationwithmixedeffect.R
+\name{calculate_actualMixed}
+\alias{calculate_actualMixed}
+\title{Calculate actual mixed effects.}
+\usage{
+calculate_actualMixed(
+ data_gene,
+ labelRef_InCategoricalVar,
+ labelOther_inCategoricalVar
+)
+}
+\arguments{
+\item{data_gene}{Data for a specific gene.}
+
+\item{labelRef_InCategoricalVar}{The reference label for the categorical variable.}
+
+\item{labelOther_inCategoricalVar}{Labels for the categorical variable other than the reference label.}
+}
+\value{
+A data frame containing the calculated actual mixed effects.
+}
+\description{
+This function calculates actual mixed effects based on the given data for a specific type I mixed-effect structure.
+}
+\examples{
+\dontrun{
+ calculate_actualMixed(data_gene, labelRef_InCategoricalVar, labelOther_inCategoricalVar)
+}
+}
diff --git a/man/calculate_actual_interactionX2_values.Rd b/man/calculate_actual_interactionX2_values.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..33bc332fb6ad7c1b5a1e0c8b733d2ccf8172bfa8
--- /dev/null
+++ b/man/calculate_actual_interactionX2_values.Rd
@@ -0,0 +1,51 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/actualinteractionfixeffects.R
+\name{calculate_actual_interactionX2_values}
+\alias{calculate_actual_interactionX2_values}
+\title{Calculate actual interaction values between two terms in a data frame.}
+\usage{
+calculate_actual_interactionX2_values(
+ data,
+ l_reference,
+ clmn_term_1,
+ lbl_term_1,
+ clmn_term_2,
+ lbl_term_2
+)
+}
+\arguments{
+\item{data}{A data frame containing the expression data and associated terms.}
+
+\item{l_reference}{A data frame representing the reference condition for the interaction.}
+
+\item{clmn_term_1}{The name of the column in \code{data} representing the first term.}
+
+\item{lbl_term_1}{The label of the first term to compute interactions for.}
+
+\item{clmn_term_2}{The name of the column in \code{data} representing the second term.}
+
+\item{lbl_term_2}{The label of the second term to compute interactions for.}
+}
+\value{
+A numeric vector containing the actual interaction values between the specified terms.
+}
+\description{
+This function calculates the actual interaction values between two terms, \code{lbl_term_1} and \code{lbl_term_2},
+in the given data frame \code{data}. The interaction values are computed based on the mean log expression levels
+of the conditions satisfying the specified term combinations, and also considering a reference condition.
+}
+\examples{
+average_gt <- data.frame(clmn_term_1 = c("A", "A", "B", "B"),
+ clmn_term_2 = c("X", "Y", "Y", "X"),
+ logQij_mean = c(1.5, 8.0, 0.5, 4.0))
+# Définir les paramètres de la fonction
+l_label <- list(clmn_term_1 = c("A", "B"), clmn_term_2 = c("X", "Y"))
+clmn_term_1 <- "clmn_term_1"
+lbl_term_1 <- "B"
+clmn_term_2 <- "clmn_term_2"
+lbl_term_2 <- "Y"
+# Calculer la valeur d'interaction réelle
+actual_interaction <- calculate_actual_interactionX2_values(average_gt,
+ l_label, clmn_term_1, lbl_term_1,
+ clmn_term_2, lbl_term_2)
+}
diff --git a/man/calculate_actual_interactionX3_values.Rd b/man/calculate_actual_interactionX3_values.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..a5512984d07da6a694347e71b54130d0d39f9f0a
--- /dev/null
+++ b/man/calculate_actual_interactionX3_values.Rd
@@ -0,0 +1,40 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/actualinteractionfixeffects.R
+\name{calculate_actual_interactionX3_values}
+\alias{calculate_actual_interactionX3_values}
+\title{Calculate Actual Interaction Values for Three Fixed Effects}
+\usage{
+calculate_actual_interactionX3_values(
+ data,
+ l_reference,
+ clmn_term_1,
+ lbl_term_1,
+ clmn_term_2,
+ lbl_term_2,
+ lbl_term_3,
+ clmn_term_3
+)
+}
+\arguments{
+\item{data}{The dataset on which to calculate interaction values.}
+
+\item{l_reference}{A list of reference values for categorical variables.}
+
+\item{clmn_term_1}{The name of the first categorical variable.}
+
+\item{lbl_term_1}{The label for the first categorical variable.}
+
+\item{clmn_term_2}{The name of the second categorical variable.}
+
+\item{lbl_term_2}{The label for the second categorical variable.}
+
+\item{lbl_term_3}{The label for the third categorical variable.}
+
+\item{clmn_term_3}{The name of the third categorical variable.}
+}
+\value{
+The computed actual interaction values.
+}
+\description{
+This function calculates actual interaction values for three fixed effects in a dataset. It takes the data, reference values for categorical variables, and the specifications for the fixed effects. The function computes the interaction values and returns the result.
+}
diff --git a/man/check_input2interaction.Rd b/man/check_input2interaction.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..95fe75dacfd9571eefec12bbbf650ac7c9ed641b
--- /dev/null
+++ b/man/check_input2interaction.Rd
@@ -0,0 +1,25 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_initialization.R
+\name{check_input2interaction}
+\alias{check_input2interaction}
+\title{Check input for interaction}
+\usage{
+check_input2interaction(name_interaction, list_var, between_var, mu, sd)
+}
+\arguments{
+\item{name_interaction}{String specifying the name of the interaction (example: "varA:varB")}
+
+\item{list_var}{A list of variables (already initialized)}
+
+\item{between_var}{A vector of variable names to include in the interaction}
+
+\item{mu}{Either a numeric value or a numeric vector (of length = level)}
+
+\item{sd}{Either numeric value or NA}
+}
+\value{
+NULL (throws an error if the input is invalid)
+}
+\description{
+Check input for interaction
+}
diff --git a/man/clean_variable_name.Rd b/man/clean_variable_name.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..f6580f38712f2424482ba40cc2c9c6da6838a719
--- /dev/null
+++ b/man/clean_variable_name.Rd
@@ -0,0 +1,28 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/utils.R
+\name{clean_variable_name}
+\alias{clean_variable_name}
+\title{Clean Variable Name}
+\usage{
+clean_variable_name(name)
+}
+\arguments{
+\item{name}{The input variable name to be cleaned.}
+}
+\value{
+The cleaned variable name without digits, spaces, or special characters.
+}
+\description{
+This function removes digits, spaces, and special characters from a variable name.
+If any of these are present, they will be replaced with an underscore '_'.
+}
+\details{
+This function will check the input variable name for the presence of digits,
+spaces, and special characters. If any of these are found, they will be removed
+from the variable name and replaced with an underscore '_'. Additionally, it will
+check if the cleaned name is not one of the reserved names "interactions" or
+"correlations" which are not allowed as variable names.
+}
+\examples{
+clean_variable_name("my_var,:&$àà(-i abl23 e_na__ç^me ")
+}
diff --git a/man/compareInferenceToExpected.Rd b/man/compareInferenceToExpected.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..5bca8afe6a2e9783a05fa2698febabec2fd63516
--- /dev/null
+++ b/man/compareInferenceToExpected.Rd
@@ -0,0 +1,29 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/evaluationwithmixedeffect.R
+\name{compareInferenceToExpected}
+\alias{compareInferenceToExpected}
+\title{Compare inference results to expected values for a given model.}
+\usage{
+compareInferenceToExpected(tidy_tmb, ground_truth_eff, formula_used)
+}
+\arguments{
+\item{tidy_tmb}{A fitted model object convert to tidy dataframe.}
+
+\item{ground_truth_eff}{A ground truth dataset with the simulated effects.}
+
+\item{formula_used}{formula used in model}
+}
+\value{
+A data frame containing the comparison results, including the term names, inference values, and expected values.
+}
+\description{
+This function compares the inference results from a model to the expected values based on a ground truth dataset with the simulated effects. The function handles models with mixed effects and fixed effects separately, ensuring that the comparison is appropriate for the specific model type.
+}
+\details{
+If a model includes mixed effects, the function checks for support for the specific mixed effect structure and provides an informative error message if the structure is not supported.
+}
+\examples{
+\dontrun{
+evalData <- compareInferenceToExpected(l_tmb, ground_truth_eff)
+}
+}
diff --git a/man/computeActualInteractionFixEff.Rd b/man/computeActualInteractionFixEff.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..80c705fa0d9d3514aa33d4e6f9ad60f3974006b9
--- /dev/null
+++ b/man/computeActualInteractionFixEff.Rd
@@ -0,0 +1,54 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/actualinteractionfixeffects.R
+\name{computeActualInteractionFixEff}
+\alias{computeActualInteractionFixEff}
+\title{Compute actual interaction values for multiple interaction terms.}
+\usage{
+computeActualInteractionFixEff(l_interactionTerm, categorical_vars, dataActual)
+}
+\arguments{
+\item{l_interactionTerm}{A list of interaction terms in the form of "term1:term2".}
+
+\item{categorical_vars}{A character vector containing the names of categorical variables in the data.}
+
+\item{dataActual}{The data frame containing the actual gene expression values and metadata.}
+}
+\value{
+A data frame containing the actual interaction values for each interaction term.
+}
+\description{
+This function calculates the actual interaction values for multiple interaction terms
+using the provided data.
+}
+\examples{
+N_GENES <- 4
+MIN_REPLICATES <- 3
+MAX_REPLICATES <- 3
+init_var <- init_variable(name = "varA", mu = 8, sd = 0.1, level = 3) \%>\%
+ init_variable(name = "varB", mu = c(5,-5), NA , level = 2) \%>\%
+ init_variable(name = "varC", mu = 1, 3, 3) \%>\%
+ add_interaction(between_var = c("varA", "varC"), mu = 5, 0.1)
+mock_data <- mock_rnaseq(init_var, N_GENES,
+ MIN_REPLICATES, MAX_REPLICATES )
+data2fit <- prepareData2fit(countMatrix = mock_data$counts,
+ metadata = mock_data$metadata )
+results_fit <- fitModelParallel(formula = kij ~ varA + varB + varC + varA:varC,
+ data = data2fit, group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
+tidy_tmb <- tidy_tmb(results_fit)
+fixEff_dataInference <- subsetFixEffectInferred(tidy_tmb)
+fixEff_dataActual <- getData2computeActualFixEffect(mock_data$groundTruth$effects)
+interactionTerm <- fixEff_dataInference$fixed_term$interaction[[1]]
+categorical_vars <- fixEff_dataActual$categorical_vars
+dataActual <- fixEff_dataActual$data
+l_labelsInCategoricalVars <- lapply(dataActual[, categorical_vars], levels)
+l_interaction <- strsplit(interactionTerm, split = ":")[[1]]
+l_categoricalVarsInInteraction <- lapply(l_interaction,
+ function(label) findAttribute(label,
+ l_labelsInCategoricalVars)) \%>\%
+ unlist()
+data_prepared <- prepareData2computeInteraction(categorical_vars,
+ l_categoricalVarsInInteraction, dataActual)
+# Compute actual interaction values for multiple interactions
+actualInteraction <- computeActualInteractionFixEff(interactionTerm, categorical_vars, dataActual)
+}
diff --git a/man/compute_covariation.Rd b/man/compute_covariation.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..d6785e8612d6b21f2989b3be0c626c145de5dae2
--- /dev/null
+++ b/man/compute_covariation.Rd
@@ -0,0 +1,27 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/setcorrelation.R
+\name{compute_covariation}
+\alias{compute_covariation}
+\title{Compute Covariation from Correlation and Standard Deviations}
+\usage{
+compute_covariation(corr_AB, sd_A, sd_B)
+}
+\arguments{
+\item{corr_AB}{The correlation coefficient between variables A and B.}
+
+\item{sd_A}{The standard deviation of variable A.}
+
+\item{sd_B}{The standard deviation of variable B.}
+}
+\value{
+The covariation between variables A and B.
+}
+\description{
+This function computes the covariation between two variables (A and B) given their correlation and standard deviations.
+}
+\examples{
+corr <- 0.7
+sd_A <- 3
+sd_B <- 4
+compute_covariation(corr, sd_A, sd_B)
+}
diff --git a/man/convert2Factor.Rd b/man/convert2Factor.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..73e53d12f3d6d0e05f307bdcea97e68804a73850
--- /dev/null
+++ b/man/convert2Factor.Rd
@@ -0,0 +1,19 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/actualmainfixeffects.R
+\name{convert2Factor}
+\alias{convert2Factor}
+\title{Convert specified columns to factor}
+\usage{
+convert2Factor(data, columns)
+}
+\arguments{
+\item{data}{The input data frame}
+
+\item{columns}{The column names to be converted to factors}
+}
+\value{
+The modified data frame with specified columns converted to factors
+}
+\description{
+Convert specified columns to factor
+}
diff --git a/man/correlation_matrix_2df.Rd b/man/correlation_matrix_2df.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..459b8e4c6fde562a9d069ca865d3bb126cb2acd0
--- /dev/null
+++ b/man/correlation_matrix_2df.Rd
@@ -0,0 +1,25 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/tidy_glmmtmb.R
+\name{correlation_matrix_2df}
+\alias{correlation_matrix_2df}
+\title{Convert Correlation Matrix to Data Frame}
+\usage{
+correlation_matrix_2df(corr_matrix)
+}
+\arguments{
+\item{corr_matrix}{A correlation matrix to be converted.}
+}
+\value{
+A data frame with the correlation values and corresponding interaction names.
+}
+\description{
+This function converts a correlation matrix into a data frame containing the correlation values and their corresponding interaction names.
+}
+\examples{
+mat <- matrix(c(1, 0.7, 0.5, 0.7,
+ 1, 0.3, 0.5, 0.3, 1),
+ nrow = 3,
+ dimnames = list(c("A", "B", "C"),
+ c("A", "B", "C")))
+correlation_matrix_2df(mat)
+}
diff --git a/man/countMatrix_2longDtf.Rd b/man/countMatrix_2longDtf.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..d53fd6dd7c00c83fc2f17f7c203e44b3875675a2
--- /dev/null
+++ b/man/countMatrix_2longDtf.Rd
@@ -0,0 +1,26 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/prepare_data2fit.R
+\name{countMatrix_2longDtf}
+\alias{countMatrix_2longDtf}
+\title{Convert count matrix to long data frame}
+\usage{
+countMatrix_2longDtf(countMatrix, value_name = "kij", id_vars = "geneID")
+}
+\arguments{
+\item{countMatrix}{Count matrix}
+
+\item{value_name}{Name for the value column}
+
+\item{id_vars}{Name for the id column (default "geneID")}
+}
+\value{
+Long data frame
+}
+\description{
+Converts a count matrix to a long data frame format using geneID as the identifier.
+}
+\examples{
+list_var <- init_variable()
+mock_data <- mock_rnaseq(list_var, n_genes = 3, 2, 2)
+countMatrix_2longDtf(mock_data$counts)
+}
diff --git a/man/counts_plot.Rd b/man/counts_plot.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..e95bef3c9f74099d31f0b35da2bf0b1e46c34bec
--- /dev/null
+++ b/man/counts_plot.Rd
@@ -0,0 +1,21 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/countsplot.R
+\name{counts_plot}
+\alias{counts_plot}
+\title{Generate a density plot of gene counts}
+\usage{
+counts_plot(mock_obj)
+}
+\arguments{
+\item{mock_obj}{The mock data object containing gene counts.}
+}
+\value{
+A ggplot2 density plot.
+}
+\description{
+This function generates a density plot of gene counts from mock data.
+}
+\examples{
+mock_data <- list(counts = matrix(c(1, 2, 3, 4, 5, 6, 7, 8, 9), ncol = 3))
+counts_plot(mock_data)
+}
diff --git a/man/dispersion_plot.Rd b/man/dispersion_plot.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..df34ab348c40f702437c63d3e83cfa8805655da4
--- /dev/null
+++ b/man/dispersion_plot.Rd
@@ -0,0 +1,25 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/evaluatedispersion.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/dot-fitModel.Rd b/man/dot-fitModel.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..7e392eff232e639e3e53ead62ad788db8cd9166e
--- /dev/null
+++ b/man/dot-fitModel.Rd
@@ -0,0 +1,24 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/fitmodel.R
+\name{.fitModel}
+\alias{.fitModel}
+\title{Fit a model using the fitModel function.}
+\usage{
+.fitModel(formula, data, ...)
+}
+\arguments{
+\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 a model using the fitModel function.
+}
+\examples{
+.fitModel(formula = mpg ~ cyl + disp, data = mtcars)
+}
diff --git a/man/dot-getColumnWithSampleID.Rd b/man/dot-getColumnWithSampleID.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..bc085af6c148eebf67d00f8a478f185b6b162601
--- /dev/null
+++ b/man/dot-getColumnWithSampleID.Rd
@@ -0,0 +1,25 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/prepare_data2fit.R
+\name{.getColumnWithSampleID}
+\alias{.getColumnWithSampleID}
+\title{Get column name with sampleID}
+\usage{
+.getColumnWithSampleID(dtf_countsLong, metadata)
+}
+\arguments{
+\item{dtf_countsLong}{Long data frame of counts}
+
+\item{metadata}{Metadata data frame}
+}
+\value{
+Column name with sampleID
+}
+\description{
+Returns the column name in the metadata data frame that corresponds to the given sampleID.
+}
+\examples{
+list_var <- init_variable()
+mock_data <- mock_rnaseq(list_var, n_genes = 3, 2,2, 2)
+dtf_countLong <- countMatrix_2longDtf(mock_data$counts)
+.getColumnWithSampleID(dtf_countLong, mock_data$metadata)
+}
diff --git a/man/dot-isDispersionMatrixValid.Rd b/man/dot-isDispersionMatrixValid.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..dcaaae9e4198eaee49a134e51e3092c1b2fa0cf9
--- /dev/null
+++ b/man/dot-isDispersionMatrixValid.Rd
@@ -0,0 +1,24 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/mock-rnaseq.R
+\name{.isDispersionMatrixValid}
+\alias{.isDispersionMatrixValid}
+\title{Check the validity of the dispersion matrix}
+\usage{
+.isDispersionMatrixValid(matx_dispersion, matx_bool_replication)
+}
+\arguments{
+\item{matx_dispersion}{Replication matrix}
+
+\item{matx_bool_replication}{Replication matrix}
+}
+\value{
+TRUE if the dimensions are valid, FALSE otherwise
+}
+\description{
+Checks if the dispersion matrix has the correct dimensions.
+}
+\examples{
+matx_dispersion <- matrix(1:12, nrow = 3, ncol = 4)
+matx_bool_replication <- matrix(TRUE, nrow = 3, ncol = 4)
+.isDispersionMatrixValid(matx_dispersion, matx_bool_replication)
+}
diff --git a/man/dot-parallel_fit.Rd b/man/dot-parallel_fit.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..af8d9d512366fa0e6f9d24e3683f8d1c774fdf9e
--- /dev/null
+++ b/man/dot-parallel_fit.Rd
@@ -0,0 +1,37 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/fitmodel.R
+\name{.parallel_fit}
+\alias{.parallel_fit}
+\title{Fit models in parallel for each group using mclapply and handle logging.
+Uses parallel_fit to fit the models.}
+\usage{
+.parallel_fit(groups, group_by, formula, data, n.cores = NULL, log_file, ...)
+}
+\arguments{
+\item{groups}{Vector of unique group values}
+
+\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{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{log_file}{File to write log (default : log.txt)}
+
+\item{...}{Additional arguments to be passed to the glmmTMB::glmmTMB function}
+}
+\value{
+List of fitted model objects or NULL for any errors
+}
+\description{
+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",
+ formula = Sepal.Length ~ Sepal.Width + Petal.Length,
+ data = iris, n.cores = 1, log_file = "log.txt" )
+}
diff --git a/man/dot-parallel_update.Rd b/man/dot-parallel_update.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..f3a251b3992f048966ae785f9d917887b95f08a9
--- /dev/null
+++ b/man/dot-parallel_update.Rd
@@ -0,0 +1,34 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/updatefitmodel.R
+\name{.parallel_update}
+\alias{.parallel_update}
+\title{Internal function to fit GLMNB models in parallel.}
+\usage{
+.parallel_update(formula, l_tmb, n.cores = NULL, log_file = "log.txt", ...)
+}
+\arguments{
+\item{formula}{Formula for the GLMNB model.}
+
+\item{l_tmb}{List of GLMNB objects.}
+
+\item{n.cores}{Number of cores to use for parallel processing.}
+
+\item{log_file}{File path for the log output.}
+
+\item{...}{Additional arguments to be passed to the glmmTMB::glmmTMB function.}
+}
+\value{
+A list of updated GLMNB models.
+}
+\description{
+This function is used internally by \code{\link{updateParallel}} to fit GLMNB models in parallel.
+}
+\examples{
+data(iris)
+groups <- unique(iris$Species)
+group_by <- "Species"
+formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+fitted_models <- fitModelParallel(formula, iris, group_by, n.cores = 1)
+new_formula <- Sepal.Length ~ Sepal.Width
+results <- .parallel_update(new_formula, fitted_models, n.cores = 1)
+}
diff --git a/man/dot-replicateByGroup.Rd b/man/dot-replicateByGroup.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..c50c45a84f6b7c1518675edfd7fa90d433ce8e94
--- /dev/null
+++ b/man/dot-replicateByGroup.Rd
@@ -0,0 +1,26 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation2.R
+\name{.replicateByGroup}
+\alias{.replicateByGroup}
+\title{Replicate rows of a data frame by group}
+\usage{
+.replicateByGroup(df, group_var, rep_list)
+}
+\arguments{
+\item{df}{Data frame to replicate}
+
+\item{group_var}{Name of the grouping variable in the data frame}
+
+\item{rep_list}{Vector of replication counts for each group}
+}
+\value{
+Data frame with replicated rows
+}
+\description{
+Replicates the rows of a data frame based on a grouping variable and replication counts for each group.
+}
+\examples{
+df <- data.frame(group = c("A", "B"), value = c(1, 2))
+.replicateByGroup(df, "group", c(2, 3))
+
+}
diff --git a/man/dot-replicateMatrix.Rd b/man/dot-replicateMatrix.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..3e775adc84d219f9e7ecefbdf0a3ce9de52686f8
--- /dev/null
+++ b/man/dot-replicateMatrix.Rd
@@ -0,0 +1,24 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/mock-rnaseq.R
+\name{.replicateMatrix}
+\alias{.replicateMatrix}
+\title{Replicate matrix}
+\usage{
+.replicateMatrix(matrix, replication_matrix)
+}
+\arguments{
+\item{matrix}{Matrix to replicate}
+
+\item{replication_matrix}{Replication matrix}
+}
+\value{
+Replicated matrix
+}
+\description{
+Replicates a matrix based on a replication matrix.
+}
+\examples{
+matrix <- matrix(1:9, nrow = 3, ncol = 3)
+replication_matrix <- matrix(TRUE, nrow = 3, ncol = 3)
+.replicateMatrix(matrix, replication_matrix)
+}
diff --git a/man/dot-replicateRows.Rd b/man/dot-replicateRows.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..497910b80a40291e9c1f73be1d2f5ed9d4592e46
--- /dev/null
+++ b/man/dot-replicateRows.Rd
@@ -0,0 +1,24 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation2.R
+\name{.replicateRows}
+\alias{.replicateRows}
+\title{Replicate rows of a data frame}
+\usage{
+.replicateRows(df, n)
+}
+\arguments{
+\item{df}{Data frame to replicate}
+
+\item{n}{Replication factor for each row}
+}
+\value{
+Data frame with replicated rows
+}
+\description{
+Replicates the rows of a data frame by a specified factor.
+}
+\examples{
+df <- data.frame(a = 1:3, b = letters[1:3])
+.replicateRows(df, 2)
+
+}
diff --git a/man/dot-subsetData_andfit.Rd b/man/dot-subsetData_andfit.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..f7db544f479ad270c0a668e1c1efd42519afe7ee
--- /dev/null
+++ b/man/dot-subsetData_andfit.Rd
@@ -0,0 +1,30 @@
+% 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/drop_randfx.Rd b/man/drop_randfx.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..8d9ea55a6cbeb3e45111730c3c659b6152661288
--- /dev/null
+++ b/man/drop_randfx.Rd
@@ -0,0 +1,27 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/fitmodel.R
+\name{drop_randfx}
+\alias{drop_randfx}
+\title{Drop Random Effects from a Formula}
+\usage{
+drop_randfx(form)
+}
+\arguments{
+\item{form}{The formula from which random effects should be dropped.}
+}
+\value{
+A modified formula with specified random effects dropped.
+}
+\description{
+This function allows you to remove random effects from a formula by specifying
+which terms to drop. It checks for the presence of vertical bars ('|') in the
+terms of the formula and drops the random effects accordingly. If all terms
+are random effects, the function updates the formula to have only an intercept.
+}
+\examples{
+# Create a formula with random effects
+formula <- y ~ x1 + (1 | group) + (1 | subject)
+# Drop the random effects related to 'group'
+modified_formula <- drop_randfx(formula)
+
+}
diff --git a/man/endsWithDigit.Rd b/man/endsWithDigit.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..1dd97b5266fba1658976474b24b8030dd9913a97
--- /dev/null
+++ b/man/endsWithDigit.Rd
@@ -0,0 +1,21 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_initialization.R
+\name{endsWithDigit}
+\alias{endsWithDigit}
+\title{Check if a string ends with a digit}
+\usage{
+endsWithDigit(string)
+}
+\arguments{
+\item{string}{The input string to be checked}
+}
+\value{
+\code{TRUE} if the string ends with a digit, \code{FALSE} otherwise
+}
+\description{
+This function checks whether a given string ends with a digit.
+}
+\examples{
+endsWithDigit("abc123") # Output: TRUE
+endsWithDigit("xyz") # Output: FALSE
+}
diff --git a/man/evaluateDispersion.Rd b/man/evaluateDispersion.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..73f7cf7eac954af872b9a68d52e51743c6c20484
--- /dev/null
+++ b/man/evaluateDispersion.Rd
@@ -0,0 +1,28 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/evaluatedispersion.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/exportReportFile.Rd b/man/exportReportFile.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..d612cde5d7c1ed69f0a0bddc5bf893db61b76d9e
--- /dev/null
+++ b/man/exportReportFile.Rd
@@ -0,0 +1,35 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulationreport.R
+\name{exportReportFile}
+\alias{exportReportFile}
+\title{Export the Analysis Report to a File}
+\usage{
+exportReportFile(
+ report_file,
+ table_settings,
+ roc_curve,
+ dispersion_plot,
+ id_plot,
+ counts_plot
+)
+}
+\arguments{
+\item{report_file}{Path to the file where the report will be exported.}
+
+\item{table_settings}{A table containing settings and parameters used in the analysis.}
+
+\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.}
+}
+\value{
+report
+}
+\description{
+This function generates an analysis report by arranging and combining various plots
+and tables, and then exports the report to a specified file.
+}
diff --git a/man/extractDESeqDispersion.Rd b/man/extractDESeqDispersion.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..b0155a8ffe83fee919f441b1c06f6ff33e122ceb
--- /dev/null
+++ b/man/extractDESeqDispersion.Rd
@@ -0,0 +1,23 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/evaluatedispersion.R
+\name{extractDESeqDispersion}
+\alias{extractDESeqDispersion}
+\title{Extract DESeq2 Dispersion Values}
+\usage{
+extractDESeqDispersion(deseq_wrapped)
+}
+\arguments{
+\item{deseq_wrapped}{A DESeq2 wrapped object containing dispersion values.}
+}
+\value{
+A data frame containing inferred dispersion values.
+}
+\description{
+Extracts inferred dispersion values from a DESeq2 wrapped object.
+}
+\examples{
+\dontrun{
+dispersion_df <- extractDESeqDispersion(deseq2_object)
+print(dispersion_df)
+}
+}
diff --git a/man/extractTMBDispersion.Rd b/man/extractTMBDispersion.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..dd586fdd3c61e90b3f36fc1368921422247f6fd2
--- /dev/null
+++ b/man/extractTMBDispersion.Rd
@@ -0,0 +1,23 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/evaluatedispersion.R
+\name{extractTMBDispersion}
+\alias{extractTMBDispersion}
+\title{Extract TMB Dispersion Values}
+\usage{
+extractTMBDispersion(l_tmb)
+}
+\arguments{
+\item{l_tmb}{A TMB result object containing dispersion values.}
+}
+\value{
+A data frame containing inferred dispersion values.
+}
+\description{
+Extracts inferred dispersion values from a TMB result object.
+}
+\examples{
+\dontrun{
+dispersion_df <- extractTMBDispersion(tmb_result)
+print(dispersion_df)
+}
+}
diff --git a/man/extract_fixed_effect.Rd b/man/extract_fixed_effect.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..125f2e15e904c75a754109964133f6d2c09a098f
--- /dev/null
+++ b/man/extract_fixed_effect.Rd
@@ -0,0 +1,22 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/tidy_glmmtmb.R
+\name{extract_fixed_effect}
+\alias{extract_fixed_effect}
+\title{Extract Fixed Effects from a GLMMTMB Model Summary}
+\usage{
+extract_fixed_effect(x)
+}
+\arguments{
+\item{x}{A glmmTMB model object.}
+}
+\value{
+A dataframe containing the fixed effects and their corresponding statistics.
+}
+\description{
+This function extracts fixed effects from the summary of a glmmTMB model.
+}
+\examples{
+
+model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length, data = iris)
+fixed_effects <- extract_fixed_effect(model)
+}
diff --git a/man/extract_ran_pars.Rd b/man/extract_ran_pars.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..34919cfbf657a1225e6dc4c6d988acd740f668d8
--- /dev/null
+++ b/man/extract_ran_pars.Rd
@@ -0,0 +1,22 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/tidy_glmmtmb.R
+\name{extract_ran_pars}
+\alias{extract_ran_pars}
+\title{Extract Random Parameters from a glmmTMB Model}
+\usage{
+extract_ran_pars(x)
+}
+\arguments{
+\item{x}{A glmmTMB model object.}
+}
+\value{
+A data frame containing the random parameters and their estimates.
+}
+\description{
+This function extracts the random parameters from a glmmTMB model and returns them as a data frame.
+}
+\examples{
+model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length + (1|Species), data = iris,
+ family = gaussian)
+random_params <- extract_ran_pars(model)
+}
diff --git a/man/fillInCovarMatrice.Rd b/man/fillInCovarMatrice.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..e706e08b506c30a1621fb242da81d09bed816e0c
--- /dev/null
+++ b/man/fillInCovarMatrice.Rd
@@ -0,0 +1,26 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/datafrommvrnorm_manipulations.R
+\name{fillInCovarMatrice}
+\alias{fillInCovarMatrice}
+\title{Fill in Covariance Matrix}
+\usage{
+fillInCovarMatrice(covarMatrice, covar)
+}
+\arguments{
+\item{covarMatrice}{The input covariance matrix.}
+
+\item{covar}{A data frame containing the covariance value between two variables.}
+}
+\value{
+The updated covariance matrix with the specified covariance value filled in.
+}
+\description{
+This function updates the covariance matrix with the specified covariance value between two variables.
+}
+\examples{
+covarMat <- matrix(0, nrow = 3, ncol = 3)
+colnames(covarMat) <- c("label_varA", "label_varB", "label_varC")
+rownames(covarMat) <- c("label_varA", "label_varB", "label_varC")
+covarValue <- data.frame("varA.varB" = 0.5)
+fillInCovarMatrice(covarMatrice = covarMat, covar = covarValue)
+}
diff --git a/man/fillInInteraction.Rd b/man/fillInInteraction.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..b5bf30944b6408d7407e54d0144e4929766f7b08
--- /dev/null
+++ b/man/fillInInteraction.Rd
@@ -0,0 +1,25 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_initialization.R
+\name{fillInInteraction}
+\alias{fillInInteraction}
+\title{Fill in interaction}
+\usage{
+fillInInteraction(list_var, between, mu, sd, level)
+}
+\arguments{
+\item{list_var}{A list of variables (already initialized)}
+
+\item{between}{A vector of variable names to include in the interaction}
+
+\item{mu}{Either a numeric value or a numeric vector (of length = level)}
+
+\item{sd}{Either numeric value or NA}
+
+\item{level}{Number of interactions}
+}
+\value{
+A data frame with the filled-in interaction values
+}
+\description{
+Fill in interaction
+}
diff --git a/man/fillInVariable.Rd b/man/fillInVariable.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..645bb61b32be40a0fb745d353e06fdb4ad227a1e
--- /dev/null
+++ b/man/fillInVariable.Rd
@@ -0,0 +1,26 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_initialization.R
+\name{fillInVariable}
+\alias{fillInVariable}
+\title{Fill in Variable}
+\usage{
+fillInVariable(name, mu, sd, level)
+}
+\arguments{
+\item{name}{The name of the variable.}
+
+\item{mu}{A numeric value or a numeric vector (of length = level) representing the mean.}
+
+\item{sd}{A numeric value representing the standard deviation, or NA if not applicable.}
+
+\item{level}{A numeric value specifying the number of levels to simulate.}
+}
+\value{
+A data frame or a list containing the simulated data for the variable.
+}
+\description{
+This function fills in a variable with simulated data based on the provided parameters.
+}
+\examples{
+variable_data <- fillInVariable(name = "myVariable", mu = c(2, 3), sd = NA, level = 2)
+}
diff --git a/man/filter_dataframe.Rd b/man/filter_dataframe.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..5a8b3e636a530b999148760c4e2c864f3fdf80fe
--- /dev/null
+++ b/man/filter_dataframe.Rd
@@ -0,0 +1,32 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/actualinteractionfixeffects.R
+\name{filter_dataframe}
+\alias{filter_dataframe}
+\title{Filter DataFrame}
+\usage{
+filter_dataframe(df, filter_list)
+}
+\arguments{
+\item{df}{The DataFrame to be filtered}
+
+\item{filter_list}{A list specifying the filters to be applied}
+}
+\value{
+The filtered DataFrame
+}
+\description{
+Filter a DataFrame based on the specified filter list.
+}
+\examples{
+# Create a DataFrame
+df <- data.frame(ID = c(1, 2, 3, 4),
+ Name = c("John", "Jane", "Mike", "Sarah"),
+ Age = c(25, 30, 28, 32),
+ Gender = c("Male", "Female", "Male", "Female"))
+
+# Create a filter list
+filter_list <- list(Name = c("John", "Mike"), Age = c(25, 28))
+
+# Filter the DataFrame
+filter_dataframe(df, filter_list)
+}
diff --git a/man/findAttribute.Rd b/man/findAttribute.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..2ebfc99a6077e4d9f46fc617b502e36e7abb6027
--- /dev/null
+++ b/man/findAttribute.Rd
@@ -0,0 +1,28 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/actualmainfixeffects.R
+\name{findAttribute}
+\alias{findAttribute}
+\title{Find Attribute}
+\usage{
+findAttribute(term, list)
+}
+\arguments{
+\item{term}{The term to search for}
+
+\item{list}{The list to search within}
+}
+\value{
+The attribute containing the term, or NULL if the term is not found in any attribute
+}
+\description{
+Find the attribute containing the specified term in a given list.
+}
+\examples{
+# Create a list
+my_list <- list(color = c("red", "blue", "green"),
+ size = c("small", "medium", "large"),
+ shape = c("circle", "square", "triangle"))
+
+# Find the attribute containing "medium"
+findAttribute("medium", my_list)
+}
diff --git a/man/fitModelParallel.Rd b/man/fitModelParallel.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..a37d644d4289bcd94b508a50825f9ebfaeb30cab
--- /dev/null
+++ b/man/fitModelParallel.Rd
@@ -0,0 +1,41 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/fitmodel.R
+\name{fitModelParallel}
+\alias{fitModelParallel}
+\title{Fit models in parallel for each group using mclapply and handle logging.
+Uses parallel_fit to fit the models.}
+\usage{
+fitModelParallel(
+ formula,
+ data,
+ group_by,
+ n.cores = NULL,
+ log_file = "log.txt",
+ ...
+)
+}
+\arguments{
+\item{formula}{Formula specifying the model formula}
+
+\item{data}{Data frame containing the data}
+
+\item{group_by}{Column name in data representing the grouping variable}
+
+\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{log_file}{File path to save the log messages (default : log.txt)}
+
+\item{...}{Additional arguments to be passed to the glmmTMB::glmmTMB function}
+}
+\value{
+List of fitted model objects or NULL for any errors
+}
+\description{
+Fit models in parallel for each group using mclapply and handle logging.
+Uses parallel_fit to fit the models.
+}
+\examples{
+fitModelParallel(formula = Sepal.Length ~ Sepal.Width + Petal.Length,
+ data = iris, group_by = "Species", n.cores = 1)
+}
diff --git a/man/fitUpdate.Rd b/man/fitUpdate.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..8df179fccb7748fef444c370653c54621ccb9b4a
--- /dev/null
+++ b/man/fitUpdate.Rd
@@ -0,0 +1,30 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/updatefitmodel.R
+\name{fitUpdate}
+\alias{fitUpdate}
+\title{Fit and update a GLMNB model.}
+\usage{
+fitUpdate(glmnb_obj, formula, ...)
+}
+\arguments{
+\item{glmnb_obj}{A GLMNB object to be updated.}
+
+\item{formula}{Formula for the updated GLMNB model.}
+
+\item{...}{Additional arguments to be passed to the glmmTMB::glmmTMB function.}
+}
+\value{
+An updated GLMNB model.
+}
+\description{
+This function fits and updates a GLMNB model using the provided formula.
+}
+\examples{
+data(iris)
+groups <- unique(iris$Species)
+group_by <- "Species"
+formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+fitted_models <- fitModelParallel(formula, iris, group_by, n.cores = 1)
+new_formula <- Sepal.Length ~ Sepal.Width
+updated_model <- fitUpdate(fitted_models[[1]], new_formula)
+}
diff --git a/man/generateActualForMainFixEff.Rd b/man/generateActualForMainFixEff.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..4ccfb7f0bf1407c0b8e85be70dd9a5c895bcbf3d
--- /dev/null
+++ b/man/generateActualForMainFixEff.Rd
@@ -0,0 +1,28 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/actualmainfixeffects.R
+\name{generateActualForMainFixEff}
+\alias{generateActualForMainFixEff}
+\title{Generate actual values for a given term}
+\usage{
+generateActualForMainFixEff(
+ term,
+ df_actualIntercept,
+ dataActual,
+ categorical_vars
+)
+}
+\arguments{
+\item{term}{The term for which actual values are calculated}
+
+\item{df_actualIntercept}{The intercept dataframe}
+
+\item{dataActual}{The average ground truth dataframe}
+
+\item{categorical_vars}{The names of the categorical variables}
+}
+\value{
+The data frame with actual values for the given term
+}
+\description{
+Generate actual values for a given term
+}
diff --git a/man/generateActualInteractionX2_FixEff.Rd b/man/generateActualInteractionX2_FixEff.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..9a95303f0bc8d77a5f5761d3d8d5764059369d2b
--- /dev/null
+++ b/man/generateActualInteractionX2_FixEff.Rd
@@ -0,0 +1,33 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/actualinteractionfixeffects.R
+\name{generateActualInteractionX2_FixEff}
+\alias{generateActualInteractionX2_FixEff}
+\title{Generate actual values for the interaction fixed effect.}
+\usage{
+generateActualInteractionX2_FixEff(
+ labelsInInteraction,
+ l_categoricalVarsInInteraction,
+ data2computeInteraction,
+ l_RefInCategoricalVars
+)
+}
+\arguments{
+\item{labelsInInteraction}{A vector containing the labels of the interaction terms.}
+
+\item{l_categoricalVarsInInteraction}{A vector containing the names of categorical variables
+involved in the interaction.}
+
+\item{data2computeInteraction}{The data frame used to compute interaction values.}
+
+\item{l_RefInCategoricalVars}{A list containing the reference levels of categorical variables.}
+}
+\value{
+A data frame with the actual values for the interaction fixed effect.
+The data frame includes columns: term, actual, and description.
+}
+\description{
+This function calculates the actual values for the interaction fixed effect
+based on the input labels in the interaction, categorical variables in the interaction,
+data to compute interaction values, actual intercept, and the reference levels in
+categorical variables.
+}
diff --git a/man/generateActualInteractionX3_FixEff.Rd b/man/generateActualInteractionX3_FixEff.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..d94478142c417cd3426277e6c77cbbf6b76b398a
--- /dev/null
+++ b/man/generateActualInteractionX3_FixEff.Rd
@@ -0,0 +1,28 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/actualinteractionfixeffects.R
+\name{generateActualInteractionX3_FixEff}
+\alias{generateActualInteractionX3_FixEff}
+\title{Generate Actual Interaction Values for Three Fixed Effects}
+\usage{
+generateActualInteractionX3_FixEff(
+ labelsInInteraction,
+ l_categoricalVarsInInteraction,
+ data2computeInteraction,
+ l_RefInCategoricalVars
+)
+}
+\arguments{
+\item{labelsInInteraction}{A character vector of labels for the three fixed effects.}
+
+\item{l_categoricalVarsInInteraction}{A list of categorical variable names corresponding to the three fixed effects.}
+
+\item{data2computeInteraction}{The dataset on which to compute the interaction values.}
+
+\item{l_RefInCategoricalVars}{A list of reference values for the categorical variables.}
+}
+\value{
+A data frame with geneID, term description, and actual interaction values.
+}
+\description{
+This function generates actual interaction values for three fixed effects in a dataset. It takes the labels of the three fixed effects, the dataset, and the reference values for the categorical variables. The function computes the actual interaction values and returns a data frame containing the geneID, the term description, and the actual interaction values.
+}
diff --git a/man/generateCountTable.Rd b/man/generateCountTable.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..6e3182d3ae8eae08b3210ba7585a39a0d8021c00
--- /dev/null
+++ b/man/generateCountTable.Rd
@@ -0,0 +1,24 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/mock-rnaseq.R
+\name{generateCountTable}
+\alias{generateCountTable}
+\title{Generate count table}
+\usage{
+generateCountTable(mu_ij_matx_rep, matx_dispersion_rep)
+}
+\arguments{
+\item{mu_ij_matx_rep}{Replicated mu_ij matrix}
+
+\item{matx_dispersion_rep}{Replicated dispersion matrix}
+}
+\value{
+Count table
+}
+\description{
+Generates the count table based on the mu_ij matrix, dispersion matrix, and replication matrix.
+}
+\examples{
+mu_ij_matx_rep <- matrix(1:12, nrow = 3, ncol = 4)
+matx_dispersion_rep <- matrix(1:12, nrow = 3, ncol = 4)
+generateCountTable(mu_ij_matx_rep, matx_dispersion_rep)
+}
diff --git a/man/generateGridCombination_fromListVar.Rd b/man/generateGridCombination_fromListVar.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..b8952b720c850bacb87854a9c2e3e610e8c6f4d8
--- /dev/null
+++ b/man/generateGridCombination_fromListVar.Rd
@@ -0,0 +1,17 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_initialization.R
+\name{generateGridCombination_fromListVar}
+\alias{generateGridCombination_fromListVar}
+\title{Get grid combination from list_var}
+\usage{
+generateGridCombination_fromListVar(list_var)
+}
+\arguments{
+\item{list_var}{A list of variables (already initialized)}
+}
+\value{
+The grid combination between variable in list_var
+}
+\description{
+Get grid combination from list_var
+}
diff --git a/man/generateReplicationMatrix.Rd b/man/generateReplicationMatrix.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..b958e369116db26bc00dc917c253c4d92a7819a6
--- /dev/null
+++ b/man/generateReplicationMatrix.Rd
@@ -0,0 +1,25 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/mock-rnaseq.R
+\name{generateReplicationMatrix}
+\alias{generateReplicationMatrix}
+\title{Generate replication matrix}
+\usage{
+generateReplicationMatrix(list_var, min_replicates, max_replicates)
+}
+\arguments{
+\item{list_var}{Number of samples}
+
+\item{min_replicates}{Minimum replication count}
+
+\item{max_replicates}{Maximum replication count}
+}
+\value{
+Replication matrix
+}
+\description{
+Generates the replication matrix based on the minimum and maximum replication counts.
+}
+\examples{
+list_var = init_variable()
+generateReplicationMatrix(list_var, min_replicates = 2, max_replicates = 4)
+}
diff --git a/man/generate_BE.Rd b/man/generate_BE.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..375df6eaa3b3f0286c39712b8d104f25919ad0fc
--- /dev/null
+++ b/man/generate_BE.Rd
@@ -0,0 +1,23 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/scalinggeneexpression.R
+\name{generate_BE}
+\alias{generate_BE}
+\title{Generate BE data.}
+\usage{
+generate_BE(n_genes, basal_expression)
+}
+\arguments{
+\item{n_genes}{The number of genes to generate BE data for.}
+
+\item{basal_expression}{a numeric vector from which sample BE for eacg genes}
+}
+\value{
+A data frame containing gene IDs, BE values
+}
+\description{
+This function generates BE data for a given number of genes, in a vector of BE values.
+}
+\examples{
+generate_BE(n_genes = 100, 10)
+
+}
diff --git a/man/getActualInteractionFixEff.Rd b/man/getActualInteractionFixEff.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..5e2652ddccaab568b676e7f56ad696108d77a34e
--- /dev/null
+++ b/man/getActualInteractionFixEff.Rd
@@ -0,0 +1,26 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/actualinteractionfixeffects.R
+\name{getActualInteractionFixEff}
+\alias{getActualInteractionFixEff}
+\title{Get the actual interaction values for a given interaction term in the data.}
+\usage{
+getActualInteractionFixEff(labelsInInteraction, data, categorical_vars)
+}
+\arguments{
+\item{labelsInInteraction}{A character vector containing the labels of the categorical levels
+involved in the interaction.}
+
+\item{data}{The dataset containing the gene expression data and categorical variables.}
+
+\item{categorical_vars}{A character vector containing the names of the categorical variables in
+the dataset.}
+}
+\value{
+A data frame containing the actual interaction values.
+}
+\description{
+This function takes an interaction term, the dataset, and the names of the categorical variables
+as inputs. It calculates the actual interaction values based on the difference in log-transformed
+mean expression levels for the specified interaction term. The function first prepares the data for
+computing the interaction values and then generates the actual interaction values.
+}
diff --git a/man/getActualIntercept.Rd b/man/getActualIntercept.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..83ece5d396ec0b9804cddc4bfd167419046bc2fb
--- /dev/null
+++ b/man/getActualIntercept.Rd
@@ -0,0 +1,17 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/actualmainfixeffects.R
+\name{getActualIntercept}
+\alias{getActualIntercept}
+\title{Get the intercept dataframe}
+\usage{
+getActualIntercept(fixeEff_dataActual)
+}
+\arguments{
+\item{fixeEff_dataActual}{The input list containing the categorical variables and the data}
+}
+\value{
+The intercept dataframe
+}
+\description{
+Get the intercept dataframe
+}
diff --git a/man/getActualMainFixEff.Rd b/man/getActualMainFixEff.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..882f46d56f973faeb834251201e530fedc2f2cc4
--- /dev/null
+++ b/man/getActualMainFixEff.Rd
@@ -0,0 +1,21 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/actualmainfixeffects.R
+\name{getActualMainFixEff}
+\alias{getActualMainFixEff}
+\title{Get actual values for non-interaction terms}
+\usage{
+getActualMainFixEff(l_term, fixeEff_dataActual, df_actualIntercept)
+}
+\arguments{
+\item{l_term}{list of term to compute}
+
+\item{fixeEff_dataActual}{A list containing required data for calculating actual values}
+
+\item{df_actualIntercept}{The data frame containing the actual intercept values}
+}
+\value{
+A data frame with actual values for non-interaction terms
+}
+\description{
+Get actual values for non-interaction terms
+}
diff --git a/man/getActualMixed_typeI.Rd b/man/getActualMixed_typeI.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..93d62f7a25859c8665c3ef8f368a9d6d9bba6ca3
--- /dev/null
+++ b/man/getActualMixed_typeI.Rd
@@ -0,0 +1,26 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/evaluationwithmixedeffect.R
+\name{getActualMixed_typeI}
+\alias{getActualMixed_typeI}
+\title{Calculate actual mixed effect values for each gene.}
+\usage{
+getActualMixed_typeI(list_logqij, genes_iter_list, categoricalVar_infos)
+}
+\arguments{
+\item{list_logqij}{A list of log_qij values grouped by genes and labels.}
+
+\item{genes_iter_list}{A list of genes for which to calculate the actual mixed effect values.}
+
+\item{categoricalVar_infos}{Information about the categorical variable, including reference labels and other labels.}
+}
+\value{
+A data frame containing the actual mixed effect values for each gene.
+}
+\description{
+This function calculates actual mixed effect values for each gene using the provided data, reference labels, and other labels in a categorical variable.
+}
+\examples{
+\dontrun{
+getActualMixed_typeI(list_logqij, genes_iter_list, categoricalVar_infos)
+}
+}
diff --git a/man/getBinExpression.Rd b/man/getBinExpression.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..3aa4829d6d44225f2095d5a0ead930d808122e38
--- /dev/null
+++ b/man/getBinExpression.Rd
@@ -0,0 +1,25 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/scalinggeneexpression.R
+\name{getBinExpression}
+\alias{getBinExpression}
+\title{Get bin expression for a data frame.}
+\usage{
+getBinExpression(dtf_coef, n_bins)
+}
+\arguments{
+\item{dtf_coef}{A data frame containing the values to be binned.}
+
+\item{n_bins}{The number of bins to create.}
+}
+\value{
+A data frame with an additional column named \code{binExpression}, containing the bin labels.
+}
+\description{
+This function divides the values of a specified column in a data frame into \code{n_bins} bins of equal width.
+The bin labels are then added as a new column in the data frame.
+}
+\examples{
+dtf <- data.frame(mu_ij = c(10, 20, 30, 15, 25, 35, 40, 5, 12, 22))
+dtf_with_bins <- getBinExpression(dtf, n_bins = 3)
+
+}
diff --git a/man/getCategoricalVar_inFixedEffect.Rd b/man/getCategoricalVar_inFixedEffect.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..c69cc002f187d5a3110f804cd11d84df480ff0eb
--- /dev/null
+++ b/man/getCategoricalVar_inFixedEffect.Rd
@@ -0,0 +1,22 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/evaluationwithmixedeffect.R
+\name{getCategoricalVar_inFixedEffect}
+\alias{getCategoricalVar_inFixedEffect}
+\title{Get the categorical variable associated with the fixed effect in a type I formula.}
+\usage{
+getCategoricalVar_inFixedEffect(tidy_tmb)
+}
+\arguments{
+\item{tidy_tmb}{A tidy tibble containing model terms.}
+}
+\value{
+The categorical variable associated with the fixed effect in the type I formula.
+}
+\description{
+This function extracts the categorical variable associated with the fixed effect in a type I formula from a tidy tibble.
+}
+\examples{
+\dontrun{
+getCategoricalVar_inFixedEffect(tidy_tmb)
+}
+}
diff --git a/man/getCoefficients.Rd b/man/getCoefficients.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..7da11dbde5b8eea87efffce59188351887e7700e
--- /dev/null
+++ b/man/getCoefficients.Rd
@@ -0,0 +1,31 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation.R
+\name{getCoefficients}
+\alias{getCoefficients}
+\title{getCoefficients}
+\usage{
+getCoefficients(list_var, l_dataFromMvrnorm, l_dataFromUser, n_genes)
+}
+\arguments{
+\item{list_var}{A list of variables (already initialized)}
+
+\item{l_dataFromMvrnorm}{Data from the \code{getGeneMetadata} function (optional).}
+
+\item{l_dataFromUser}{Data from the \code{getDataFromUser} function (optional).}
+
+\item{n_genes}{The number of genes.}
+}
+\value{
+A dataframe containing the coefficients.
+}
+\description{
+Get the coefficients.
+}
+\examples{
+# Example usage
+list_var <- init_variable()
+input2mvrnorm = getInput2mvrnorm(list_var)
+l_dataFromMvrnorm = getDataFromMvrnorm(list_var, input2mvrnorm, n_genes)
+l_dataFromUser = getDataFromUser(list_var)
+getCoefficients(list_var, l_dataFromMvrnorm, l_dataFromUser, n_genes = 3)
+}
diff --git a/man/getCountsTable.Rd b/man/getCountsTable.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..035c531436076d4c6477e33ad41d2ab421e4c184
--- /dev/null
+++ b/man/getCountsTable.Rd
@@ -0,0 +1,21 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation2.R
+\name{getCountsTable}
+\alias{getCountsTable}
+\title{getCountsTable}
+\usage{
+getCountsTable(matx_Muij, matx_dispersion, matx_bool_replication)
+}
+\arguments{
+\item{matx_Muij}{Matrix of mean expression values for each gene and sample}
+
+\item{matx_dispersion}{Matrix of dispersion values for each gene and sample}
+
+\item{matx_bool_replication}{Replication matrix indicating which samples are replicated}
+}
+\value{
+A counts table containing simulated read counts for each gene and sample
+}
+\description{
+getCountsTable
+}
diff --git a/man/getCovarianceMatrix.Rd b/man/getCovarianceMatrix.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..d24f40ffb3f805434a4a1ce34a3da71d3d6b9095
--- /dev/null
+++ b/man/getCovarianceMatrix.Rd
@@ -0,0 +1,26 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/datafrommvrnorm_manipulations.R
+\name{getCovarianceMatrix}
+\alias{getCovarianceMatrix}
+\title{getCovarianceMatrix}
+\usage{
+getCovarianceMatrix(list_stdev, list_covar)
+}
+\arguments{
+\item{list_stdev}{standard deviation list}
+
+\item{list_covar}{covariance list}
+}
+\value{
+covariance matrix
+}
+\description{
+getCovarianceMatrix
+}
+\examples{
+vector_sd <- c(1,2, 3)
+names(vector_sd) <- c("varA", "varB", "varC")
+vector_covar <- c(8, 12, 24)
+names(vector_covar) <- c("varA.varB", "varA.varC", "varB.varC")
+covMatrix <- getCovarianceMatrix(vector_sd, vector_covar)
+}
diff --git a/man/getData2computeActualFixEffect.Rd b/man/getData2computeActualFixEffect.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..59fd6369edb753049046f94ffe4e10db62569b61
--- /dev/null
+++ b/man/getData2computeActualFixEffect.Rd
@@ -0,0 +1,22 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/actualmainfixeffects.R
+\name{getData2computeActualFixEffect}
+\alias{getData2computeActualFixEffect}
+\title{Get data for calculating actual values}
+\usage{
+getData2computeActualFixEffect(groundTruth)
+}
+\arguments{
+\item{groundTruth}{The ground truth data frame}
+}
+\value{
+A list containing required data for calculating actual values
+}
+\description{
+Get data for calculating actual values
+}
+\examples{
+input_var_list <- init_variable()
+mock_data <- mock_rnaseq(input_var_list, 10, 2, 2)
+getData2computeActualFixEffect(mock_data$groundTruth$effect)
+}
diff --git a/man/getDataFromMvrnorm.Rd b/man/getDataFromMvrnorm.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..b6204b188f43bc8494c028c89061eb0c3b9973a1
--- /dev/null
+++ b/man/getDataFromMvrnorm.Rd
@@ -0,0 +1,26 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/datafrommvrnorm_manipulations.R
+\name{getDataFromMvrnorm}
+\alias{getDataFromMvrnorm}
+\title{getDataFromMvrnorm}
+\usage{
+getDataFromMvrnorm(list_var, input2mvrnorm, n_genes = 1)
+}
+\arguments{
+\item{list_var}{Either c() or output of init_variable}
+
+\item{input2mvrnorm}{list with mu and covariance matrix, output of getInput2mvrnorm}
+
+\item{n_genes}{Number of genes to simulate}
+}
+\value{
+data simulated from multivariate normal distribution
+}
+\description{
+getDataFromMvrnorm
+}
+\examples{
+list_var <- init_variable()
+input <- getInput2mvrnorm(list_var)
+simulated_data <- getDataFromMvrnorm(list_var, input, n_genes = 10)
+}
diff --git a/man/getDataFromUser.Rd b/man/getDataFromUser.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..8cb39ad1e3763802d61af182d304887366cc84b5
--- /dev/null
+++ b/man/getDataFromUser.Rd
@@ -0,0 +1,20 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/datafromuser_manipulations.R
+\name{getDataFromUser}
+\alias{getDataFromUser}
+\title{Get data from user}
+\usage{
+getDataFromUser(list_var)
+}
+\arguments{
+\item{list_var}{A list of variables (already initialized)}
+}
+\value{
+A list of data to join
+}
+\description{
+Get data from user
+}
+\examples{
+getDataFromUser(init_variable())
+}
diff --git a/man/getDispersionComparison.Rd b/man/getDispersionComparison.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..f4bd2539aad432243a629df957c4f0067af08c0d
--- /dev/null
+++ b/man/getDispersionComparison.Rd
@@ -0,0 +1,25 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/evaluatedispersion.R
+\name{getDispersionComparison}
+\alias{getDispersionComparison}
+\title{Get Dispersion Comparison}
+\usage{
+getDispersionComparison(inferred_dispersion, actual_dispersion)
+}
+\arguments{
+\item{inferred_dispersion}{A data frame containing inferred dispersion values.}
+
+\item{actual_dispersion}{A numeric vector containing actual dispersion values.}
+}
+\value{
+A data frame comparing actual and inferred dispersion values.
+}
+\description{
+Compares inferred dispersion values with actual dispersion values.
+}
+\examples{
+\dontrun{
+dispersion_comparison <- getDispersionComparison(inferred_disp, actual_disp)
+print(dispersion_comparison)
+}
+}
diff --git a/man/getDispersionMatrix.Rd b/man/getDispersionMatrix.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..52e76ef990f95a4b69e1c77a5a80e638729814d3
--- /dev/null
+++ b/man/getDispersionMatrix.Rd
@@ -0,0 +1,25 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation2.R
+\name{getDispersionMatrix}
+\alias{getDispersionMatrix}
+\title{getDispersionMatrix}
+\usage{
+getDispersionMatrix(
+ list_var,
+ n_genes,
+ dispersion = stats::runif(n_genes, min = 0, max = 1000)
+)
+}
+\arguments{
+\item{list_var}{A list of variables (already initialized)}
+
+\item{n_genes}{Number of genes}
+
+\item{dispersion}{Vector of dispersion values for each gene}
+}
+\value{
+A matrix of dispersion values for each gene and sample
+}
+\description{
+getDispersionMatrix
+}
diff --git a/man/getEstimate_df.Rd b/man/getEstimate_df.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..3599cb3ed2ea6abea0318b6445ccf8c5dd733c9f
--- /dev/null
+++ b/man/getEstimate_df.Rd
@@ -0,0 +1,23 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/wrapperdeseq2.R
+\name{getEstimate_df}
+\alias{getEstimate_df}
+\title{Extract Inferred Estimate Information from DESeq2 Results}
+\usage{
+getEstimate_df(dds_full)
+}
+\arguments{
+\item{dds_full}{A data frame containing DESeq2 results, including estimate columns.}
+}
+\value{
+A data frame with melted inferred estimate information, including gene IDs and terms.
+}
+\description{
+This function extracts the inferred estimate values from DESeq2 results.
+}
+\examples{
+\dontrun{
+# Example usage of the function
+estimate_info <- getEstimate_df(dds_full)
+ }
+}
diff --git a/man/getGeneMetadata.Rd b/man/getGeneMetadata.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..3dec7ca29256f8b1eefee0aba9581f00a4d59b64
--- /dev/null
+++ b/man/getGeneMetadata.Rd
@@ -0,0 +1,23 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/datafrommvrnorm_manipulations.R
+\name{getGeneMetadata}
+\alias{getGeneMetadata}
+\title{getGeneMetadata}
+\usage{
+getGeneMetadata(list_var, n_genes)
+}
+\arguments{
+\item{list_var}{Either c() or output of init_variable}
+
+\item{n_genes}{Number of genes to simulate}
+}
+\value{
+metadata matrix
+}
+\description{
+getGeneMetadata
+}
+\examples{
+list_var <- init_variable()
+metadata <- getGeneMetadata(list_var, n_genes = 10)
+}
diff --git a/man/getGivenAttribute.Rd b/man/getGivenAttribute.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..f29d9e522b73dac49bc0eae924373291686d7b83
--- /dev/null
+++ b/man/getGivenAttribute.Rd
@@ -0,0 +1,19 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_initialization.R
+\name{getGivenAttribute}
+\alias{getGivenAttribute}
+\title{Get a given attribute from a list of variables}
+\usage{
+getGivenAttribute(list_var, attribute)
+}
+\arguments{
+\item{list_var}{A list of variables (already initialized)}
+
+\item{attribute}{A string specifying the attribute to retrieve in all occurrences of the list}
+}
+\value{
+A list without NULL values
+}
+\description{
+Get a given attribute from a list of variables
+}
diff --git a/man/getGlance.Rd b/man/getGlance.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..4b79867df3ced684dc8b4c57c1118c8f3f1fd1e1
--- /dev/null
+++ b/man/getGlance.Rd
@@ -0,0 +1,23 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/glance_tmb.R
+\name{getGlance}
+\alias{getGlance}
+\title{Extracts the summary statistics from a single glmmTMB model.}
+\usage{
+getGlance(x)
+}
+\arguments{
+\item{x}{A glmmTMB model.}
+}
+\value{
+A DataFrame with the summary statistics for the glmmTMB model.
+}
+\description{
+This function takes a single glmmTMB model and extracts the summary statistics (AIC, BIC, logLik, deviance,
+df.resid, and dispersion) from the model and returns them as a DataFrame.
+}
+\examples{
+data(mtcars)
+model <- glmmTMB::glmmTMB(mpg ~ wt + (1|cyl), data = mtcars)
+getGlance(model)
+}
diff --git a/man/getGridCombination.Rd b/man/getGridCombination.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..b5489f6282f89587597203d8b62ead00f3bd97d8
--- /dev/null
+++ b/man/getGridCombination.Rd
@@ -0,0 +1,24 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_initialization.R
+\name{getGridCombination}
+\alias{getGridCombination}
+\title{getGridCombination}
+\usage{
+getGridCombination(l_labels)
+}
+\arguments{
+\item{l_labels}{List of label vectors}
+}
+\value{
+A data frame with all possible combinations of labels
+}
+\description{
+Generates all possible combinations of labels.
+}
+\examples{
+l_labels <- list(
+ c("A", "B", "C"),
+ c("X", "Y")
+)
+getGridCombination(l_labels)
+}
diff --git a/man/getGrobTable.Rd b/man/getGrobTable.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..f15c04d5e4edacea39a1c4c05b930ba3e71781bd
--- /dev/null
+++ b/man/getGrobTable.Rd
@@ -0,0 +1,28 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulationreport.R
+\name{getGrobTable}
+\alias{getGrobTable}
+\title{Generate a Formatted Table as a Grid Graphics Object}
+\usage{
+getGrobTable(df)
+}
+\arguments{
+\item{df}{The data frame to be converted into a formatted table.}
+}
+\value{
+A grid graphics object representing the formatted table.
+}
+\description{
+This function generates a formatted table using the provided data frame and returns
+it as a grid graphics object.
+}
+\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)
+}
diff --git a/man/getInput2mvrnorm.Rd b/man/getInput2mvrnorm.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..b87ce0b9a6e66672f53f483eb56bf7cae17731ea
--- /dev/null
+++ b/man/getInput2mvrnorm.Rd
@@ -0,0 +1,21 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/datafrommvrnorm_manipulations.R
+\name{getInput2mvrnorm}
+\alias{getInput2mvrnorm}
+\title{getInput2mvrnorm}
+\usage{
+getInput2mvrnorm(list_var)
+}
+\arguments{
+\item{list_var}{Either c() or output of init_variable}
+}
+\value{
+a list that can be used as input for MASS::mvrnorm
+}
+\description{
+getInput2mvrnorm
+}
+\examples{
+list_var <- init_variable(name = "my_var", mu = 0, sd = 2, level = 3)
+getInput2mvrnorm(list_var)
+}
diff --git a/man/getInput2simulation.Rd b/man/getInput2simulation.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..660db1d76bc901edbfae9d3503a4bf3a943050c3
--- /dev/null
+++ b/man/getInput2simulation.Rd
@@ -0,0 +1,26 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation.R
+\name{getInput2simulation}
+\alias{getInput2simulation}
+\title{Get input for simulation based on coefficients}
+\usage{
+getInput2simulation(list_var, n_genes = 1, input2mvrnorm = NULL)
+}
+\arguments{
+\item{list_var}{A list of variables (already initialized)}
+
+\item{n_genes}{Number of genes to simulate (default: 1)}
+
+\item{input2mvrnorm}{Input to the \code{mvrnorm} function for simulating data from multivariate normal distribution (default: NULL)}
+}
+\value{
+A data frame with input coefficients for simulation
+}
+\description{
+This function generates input data for simulation based on the coefficients provided in the \code{list_var} argument.
+}
+\examples{
+# Example usage
+list_var <- init_variable()
+getInput2simulation(list_var, n_genes = 10)
+}
diff --git a/man/getLabelExpected.Rd b/man/getLabelExpected.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..0b9791f0490dbf02e834c697e947003bd4a21801
--- /dev/null
+++ b/man/getLabelExpected.Rd
@@ -0,0 +1,34 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/rocplot.R
+\name{getLabelExpected}
+\alias{getLabelExpected}
+\title{Get Labels for Expected Differential Expression}
+\usage{
+getLabelExpected(comparison_df, coeff_threshold, alt_hypothesis)
+}
+\arguments{
+\item{comparison_df}{A data frame containing comparison results with actual effect estimates.}
+
+\item{coeff_threshold}{The threshold value for determining differential expression.}
+
+\item{alt_hypothesis}{The alternative hypothesis for comparison. Possible values are "greater",
+"less", and "greaterAbs".}
+}
+\value{
+A modified data frame with an additional column indicating if the gene is differentially expressed.
+}
+\description{
+This function assigns labels to genes based on whether their actual effect estimates
+indicate differential expression according to a given threshold and alternative hypothesis.
+}
+\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")
+
+}
diff --git a/man/getLabels.Rd b/man/getLabels.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..df259d30d33b010b23d2090a9a2f77d0de3725fb
--- /dev/null
+++ b/man/getLabels.Rd
@@ -0,0 +1,19 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_initialization.R
+\name{getLabels}
+\alias{getLabels}
+\title{Get labels for variables}
+\usage{
+getLabels(l_variables2labelized, l_nb_label)
+}
+\arguments{
+\item{l_variables2labelized}{A list of variables}
+
+\item{l_nb_label}{A list of numeric values representing the number of levels per variable}
+}
+\value{
+A list of labels per variable
+}
+\description{
+Get labels for variables
+}
diff --git a/man/getListVar.Rd b/man/getListVar.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..88257b2624249ec94b77119fa56b0c047825a766
--- /dev/null
+++ b/man/getListVar.Rd
@@ -0,0 +1,17 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_initialization.R
+\name{getListVar}
+\alias{getListVar}
+\title{Get the list of variable names}
+\usage{
+getListVar(input)
+}
+\arguments{
+\item{input}{R list, e.g., output of init_variable}
+}
+\value{
+A character vector with the names of variables
+}
+\description{
+Get the list of variable names
+}
diff --git a/man/getLog_qij.Rd b/man/getLog_qij.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..e5ce30cacbb3dc324c2156660bac0a5712897ccf
--- /dev/null
+++ b/man/getLog_qij.Rd
@@ -0,0 +1,17 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation.R
+\name{getLog_qij}
+\alias{getLog_qij}
+\title{Get the log_qij values from the coefficient data frame.}
+\usage{
+getLog_qij(dtf_coef)
+}
+\arguments{
+\item{dtf_coef}{The coefficient data frame.}
+}
+\value{
+The coefficient data frame with log_qij column added.
+}
+\description{
+Get the log_qij values from the coefficient data frame.
+}
diff --git a/man/getMu_ij.Rd b/man/getMu_ij.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..3ebb1e5efb0fdc36cd3c98249c194d120f182a79
--- /dev/null
+++ b/man/getMu_ij.Rd
@@ -0,0 +1,25 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation.R
+\name{getMu_ij}
+\alias{getMu_ij}
+\title{Calculate mu_ij values based on coefficient data frame and scaling factor}
+\usage{
+getMu_ij(dtf_coef)
+}
+\arguments{
+\item{dtf_coef}{Coefficient data frame containing the log_qij values}
+}
+\value{
+Coefficient data frame with an additional mu_ij column
+}
+\description{
+This function calculates mu_ij values by raising 2 to the power of the log_qij values
+from the coefficient data frame and multiplying it by the provided scaling factor.
+}
+\examples{
+list_var <- init_variable()
+dtf_coef <- getInput2simulation(list_var, 10)
+dtf_coef <- getLog_qij(dtf_coef)
+dtf_coef <- addBasalExpression(dtf_coef, 10, c(10, 20, 0))
+getMu_ij(dtf_coef)
+}
diff --git a/man/getMu_ij_matrix.Rd b/man/getMu_ij_matrix.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..67a057619ba159042f4b7b836688348a46299e75
--- /dev/null
+++ b/man/getMu_ij_matrix.Rd
@@ -0,0 +1,17 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation.R
+\name{getMu_ij_matrix}
+\alias{getMu_ij_matrix}
+\title{getMu_ij_matrix}
+\usage{
+getMu_ij_matrix(dtf_coef)
+}
+\arguments{
+\item{dtf_coef}{A dataframe containing the coefficients.}
+}
+\value{
+A Mu_ij matrix.
+}
+\description{
+Get the Mu_ij matrix.
+}
diff --git a/man/getNumberOfCombinationsInInteraction.Rd b/man/getNumberOfCombinationsInInteraction.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..c7984fee21befdf555a1617484e610ed1376f7ea
--- /dev/null
+++ b/man/getNumberOfCombinationsInInteraction.Rd
@@ -0,0 +1,19 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_initialization.R
+\name{getNumberOfCombinationsInInteraction}
+\alias{getNumberOfCombinationsInInteraction}
+\title{Get the number of combinations in an interaction}
+\usage{
+getNumberOfCombinationsInInteraction(list_var, between)
+}
+\arguments{
+\item{list_var}{A list of variables (already initialized)}
+
+\item{between}{A vector of variable names to include in the interaction}
+}
+\value{
+The number of combinations in the interaction
+}
+\description{
+Get the number of combinations in an interaction
+}
diff --git a/man/getReplicationMatrix.Rd b/man/getReplicationMatrix.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..e0edd1bdb39f21909ce477497b4439bf0bfa9ef5
--- /dev/null
+++ b/man/getReplicationMatrix.Rd
@@ -0,0 +1,21 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation2.R
+\name{getReplicationMatrix}
+\alias{getReplicationMatrix}
+\title{getReplicationMatrix}
+\usage{
+getReplicationMatrix(minN, maxN, n_samples)
+}
+\arguments{
+\item{minN}{Minimum number of replicates for each sample}
+
+\item{maxN}{Maximum number of replicates for each sample}
+
+\item{n_samples}{Number of samples}
+}
+\value{
+A replication matrix indicating which samples are replicated
+}
+\description{
+getReplicationMatrix
+}
diff --git a/man/getSE_df.Rd b/man/getSE_df.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..61533dddcece67821284bf599176bace260975f7
--- /dev/null
+++ b/man/getSE_df.Rd
@@ -0,0 +1,23 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/wrapperdeseq2.R
+\name{getSE_df}
+\alias{getSE_df}
+\title{Extract Standard Error Information from DESeq2 Results}
+\usage{
+getSE_df(dds_full)
+}
+\arguments{
+\item{dds_full}{A data frame containing DESeq2 results, including standard error columns.}
+}
+\value{
+A data frame with melted standard error information, including gene IDs and terms.
+}
+\description{
+This function extracts the standard error (SE) information from DESeq2 results.
+}
+\examples{
+\dontrun{
+# Example usage of the function
+se_info <- getSE_df(dds_full)
+}
+}
diff --git a/man/getSampleID.Rd b/man/getSampleID.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..81d4301faaf93291e9da17458ee73e1e73c824ff
--- /dev/null
+++ b/man/getSampleID.Rd
@@ -0,0 +1,17 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation2.R
+\name{getSampleID}
+\alias{getSampleID}
+\title{getSampleID}
+\usage{
+getSampleID(list_var)
+}
+\arguments{
+\item{list_var}{A list of variables (already initialized)}
+}
+\value{
+A sorted vector of sample IDs
+}
+\description{
+getSampleID
+}
diff --git a/man/getSampleMetadata.Rd b/man/getSampleMetadata.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..f16657224d2c2cf242b2059d5e1ef0a8d255f97e
--- /dev/null
+++ b/man/getSampleMetadata.Rd
@@ -0,0 +1,27 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation2.R
+\name{getSampleMetadata}
+\alias{getSampleMetadata}
+\title{Get sample metadata}
+\usage{
+getSampleMetadata(list_var, n_genes, replicationMatrix)
+}
+\arguments{
+\item{list_var}{A list of variables (already initialized)}
+
+\item{n_genes}{Number of genes}
+
+\item{replicationMatrix}{Replication matrix}
+}
+\value{
+Data frame of sample metadata
+}
+\description{
+Generates sample metadata based on the input variables, replication matrix, and number of genes.
+}
+\examples{
+list_var <- init_variable()
+n_genes <- 10
+replicationMatrix <- generateReplicationMatrix(list_var ,2, 3)
+getSampleMetadata(list_var, n_genes, replicationMatrix)
+}
diff --git a/man/getSettingsTable.Rd b/man/getSettingsTable.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..933a254310451682560c92f0c6bb47e185447296
--- /dev/null
+++ b/man/getSettingsTable.Rd
@@ -0,0 +1,27 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/utils.R
+\name{getSettingsTable}
+\alias{getSettingsTable}
+\title{Get Setting Table}
+\usage{
+getSettingsTable(n_genes, max_replicates, min_replicates, lib_size)
+}
+\arguments{
+\item{n_genes}{Number of genes in the experiment.}
+
+\item{max_replicates}{Maximum number of replicates for each gene.}
+
+\item{min_replicates}{Minimum number of replicates for each gene.}
+
+\item{lib_size}{total number of reads}
+}
+\value{
+A data frame containing the experimental settings with their corresponding values.
+}
+\description{
+Create a table of experimental settings.
+}
+\details{
+This function takes various experimental parameters and returns a data frame
+that represents the experimental settings.
+}
diff --git a/man/getStandardDeviationInCorrelation.Rd b/man/getStandardDeviationInCorrelation.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..b2a79a1c429cffcdcfd4cbc6ed29330b8e283009
--- /dev/null
+++ b/man/getStandardDeviationInCorrelation.Rd
@@ -0,0 +1,25 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/setcorrelation.R
+\name{getStandardDeviationInCorrelation}
+\alias{getStandardDeviationInCorrelation}
+\title{Get Standard Deviations for Variables in Correlation}
+\usage{
+getStandardDeviationInCorrelation(list_var, between_var)
+}
+\arguments{
+\item{list_var}{A list containing the variables and their attributes.}
+
+\item{between_var}{A character vector containing the names of the variables involved in the correlation.}
+}
+\value{
+A numeric vector containing the standard deviations for the variables in the correlation.
+}
+\description{
+This function extracts the standard deviations for the variables involved in the correlation.
+}
+\examples{
+list_var <- init_variable(name = "varA", mu = 0, sd = 5, level = 3) \%>\%
+ init_variable(name = "varB", mu = 0, sd = 25, level = 3)
+between_var <- c("varA", "varB")
+getStandardDeviationInCorrelation(list_var, between_var)
+}
diff --git a/man/getSubCountsTable.Rd b/man/getSubCountsTable.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..050cce7e9d9fcc282f83ee33dbbe785324fbccfb
--- /dev/null
+++ b/man/getSubCountsTable.Rd
@@ -0,0 +1,23 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation.R
+\name{getSubCountsTable}
+\alias{getSubCountsTable}
+\title{getSubCountsTable}
+\usage{
+getSubCountsTable(matx_Muij, matx_dispersion, replicateID, l_bool_replication)
+}
+\arguments{
+\item{matx_Muij}{The Mu_ij matrix.}
+
+\item{matx_dispersion}{The dispersion matrix.}
+
+\item{replicateID}{The replication identifier.}
+
+\item{l_bool_replication}{A boolean vector indicating the replicates.}
+}
+\value{
+A subcounts table.
+}
+\description{
+Get the subcounts table.
+}
diff --git a/man/getTidyGlmmTMB.Rd b/man/getTidyGlmmTMB.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..7a6483f5a24249a2c59b653e69d79d15032ec2a2
--- /dev/null
+++ b/man/getTidyGlmmTMB.Rd
@@ -0,0 +1,24 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/tidy_glmmtmb.R
+\name{getTidyGlmmTMB}
+\alias{getTidyGlmmTMB}
+\title{Extract Tidy Summary of glmmTMB Model}
+\usage{
+getTidyGlmmTMB(glm_TMB, ID)
+}
+\arguments{
+\item{glm_TMB}{A glmmTMB model object.}
+
+\item{ID}{An identifier to be included in the output data frame.}
+}
+\value{
+A data frame containing a tidy summary of the fixed and random effects from the glmmTMB model.
+}
+\description{
+This function extracts a tidy summary of the fixed and random effects from a glmmTMB model and binds them together in a data frame. Missing columns are filled with NA.
+}
+\examples{
+
+model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length, data = iris)
+tidy_summary <- getTidyGlmmTMB(glm_TMB = model, ID = "Model1")
+}
diff --git a/man/getValidDispersion.Rd b/man/getValidDispersion.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..aac2e249bfd1246654b42ef4ad272d483a4289cc
--- /dev/null
+++ b/man/getValidDispersion.Rd
@@ -0,0 +1,25 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/mock-rnaseq.R
+\name{getValidDispersion}
+\alias{getValidDispersion}
+\title{Validate and Filter Dispersion Values}
+\usage{
+getValidDispersion(input_vector)
+}
+\arguments{
+\item{input_vector}{A vector to be validated.}
+}
+\value{
+A validated and filtered numeric vector.
+}
+\description{
+This function takes an input vector and validates it to ensure that it meets certain criteria.
+}
+\details{
+The function checks whether the input is a vector, suppresses warnings while converting to numeric,
+and filters out non-numeric elements. It also checks for values greater than zero and removes negative values.
+If the resulting vector has a length of zero, an error is thrown.
+}
+\examples{
+getValidDispersion(c(0.5, 1.2, -0.3, "invalid", 0.8))
+}
diff --git a/man/get_inference.Rd b/man/get_inference.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..3d7864a6dcd7e3e07a3ba766942ab8e42e58a3cc
--- /dev/null
+++ b/man/get_inference.Rd
@@ -0,0 +1,31 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/wrapperdeseq2.R
+\name{get_inference}
+\alias{get_inference}
+\title{Calculate Inference for Differential Expression Analysis}
+\usage{
+get_inference(dds_full, lfcThreshold, altHypothesis, correction_method)
+}
+\arguments{
+\item{dds_full}{A data frame containing DESeq2 results, including estimate and standard error information.}
+
+\item{lfcThreshold}{Log fold change threshold for determining differentially expressed genes.}
+
+\item{altHypothesis}{Alternative hypothesis for testing, one of "greater", "less", or "two.sided".}
+
+\item{correction_method}{Method for multiple hypothesis correction, e.g., "BH" (Benjamini-Hochberg).}
+}
+\value{
+A data frame containing inference results, including statistics, p-values, and adjusted p-values.
+}
+\description{
+This function calculates inference for differential expression analysis based on the results of DESeq2.
+}
+\examples{
+\dontrun{
+# Example usage of the function
+inference_result <- get_inference(dds_full, lfcThreshold = 0.5,
+ altHypothesis = "greater",
+ correction_method = "BH")
+}
+}
diff --git a/man/glance_tmb.Rd b/man/glance_tmb.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..9f57dea776ec460ee8b145293f33fe0c258b9b32
--- /dev/null
+++ b/man/glance_tmb.Rd
@@ -0,0 +1,24 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/glance_tmb.R
+\name{glance_tmb}
+\alias{glance_tmb}
+\title{Extracts the summary statistics from a list of glmmTMB models.}
+\usage{
+glance_tmb(l_tmb)
+}
+\arguments{
+\item{l_tmb}{A list of glmmTMB models or a unique glmmTMB obj model}
+}
+\value{
+A DataFrame with the summary statistics for all the glmmTMB models in the list.
+}
+\description{
+This function takes a list of glmmTMB models and extracts the summary statistics (AIC, BIC, logLik, deviance,
+df.resid, and dispersion) for each model and returns them as a single DataFrame.
+}
+\examples{
+data(mtcars)
+models <- fitModelParallel(Sepal.Length ~ Sepal.Width + Petal.Length,
+ group_by = "Species",n.cores = 1, data = iris)
+result <- glance_tmb(models)
+}
diff --git a/man/group_logQij_per_genes_and_labels.Rd b/man/group_logQij_per_genes_and_labels.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..05aa7d7e21e9827e66b74f241a18f5068912c789
--- /dev/null
+++ b/man/group_logQij_per_genes_and_labels.Rd
@@ -0,0 +1,24 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/evaluationwithmixedeffect.R
+\name{group_logQij_per_genes_and_labels}
+\alias{group_logQij_per_genes_and_labels}
+\title{Group log_qij values per genes and labels.}
+\usage{
+group_logQij_per_genes_and_labels(ground_truth, categorical_var)
+}
+\arguments{
+\item{ground_truth}{A tibble containing ground truth data.}
+
+\item{categorical_var}{The categorical variable to use for grouping.}
+}
+\value{
+A list of log_qij values grouped by genes and labels.
+}
+\description{
+This function groups log_qij values in a ground truth tibble per genes and labels using a specified categorical variable.
+}
+\examples{
+\dontrun{
+group_logQij_per_genes_and_labels(ground_truth, categorical_var)
+}
+}
diff --git a/man/handleAnovaError.Rd b/man/handleAnovaError.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..156749c796cf6dcaf247c56ecc260a70d96fdcff
--- /dev/null
+++ b/man/handleAnovaError.Rd
@@ -0,0 +1,27 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/anova.R
+\name{handleAnovaError}
+\alias{handleAnovaError}
+\title{Handle ANOVA Errors}
+\usage{
+handleAnovaError(l_TMB, group, ...)
+}
+\arguments{
+\item{l_TMB}{A list of fitted glmmTMB models.}
+
+\item{group}{A character string indicating the group for which ANOVA is calculated.}
+
+\item{...}{Additional arguments to be passed to the \code{car::Anova} function.}
+}
+\value{
+A data frame containing ANOVA results for the specified group.
+}
+\description{
+This function handles ANOVA errors and warnings during the ANOVA calculation process.
+}
+\examples{
+l_tmb <- fitModelParallel(Sepal.Length ~ Sepal.Width + Petal.Length,
+ data = iris, group_by = "Species", n.cores = 1)
+anova_res <- handleAnovaError(l_tmb, "setosa", type = "III")
+
+}
diff --git a/man/identity_plot.Rd b/man/identity_plot.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..8d1223e1fb754b7ddd649a42b2b340932d564fe2
--- /dev/null
+++ b/man/identity_plot.Rd
@@ -0,0 +1,26 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/identityplot.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_withFixedEff.Rd b/man/inferenceToExpected_withFixedEff.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..4f51a89261c768f6ce997e41d239f91b5dd1fc0e
--- /dev/null
+++ b/man/inferenceToExpected_withFixedEff.Rd
@@ -0,0 +1,26 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/inferencetoexpected.R
+\name{inferenceToExpected_withFixedEff}
+\alias{inferenceToExpected_withFixedEff}
+\title{Compare the results of inference with the ground truth data.}
+\usage{
+inferenceToExpected_withFixedEff(tidy_tmb, df_ground_truth)
+}
+\arguments{
+\item{tidy_tmb}{A data frame containing the results of inference.}
+
+\item{df_ground_truth}{A data frame containing the ground truth data used for simulation.}
+}
+\value{
+A data frame
+}
+\description{
+This function takes the data frames containing the inference results and the ground truth data
+and generates a table to compare the inferred values with the expected values.
+}
+\examples{
+\dontrun{
+inferenceToExpected_withFixedEff(tidy_tmb, df_ground_truth)
+}
+
+}
diff --git a/man/inferenceToExpected_withMixedEff.Rd b/man/inferenceToExpected_withMixedEff.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..5e177211789ff923eb1bec9465cbe01e127db519
--- /dev/null
+++ b/man/inferenceToExpected_withMixedEff.Rd
@@ -0,0 +1,24 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/evaluationwithmixedeffect.R
+\name{inferenceToExpected_withMixedEff}
+\alias{inferenceToExpected_withMixedEff}
+\title{Compare the mixed-effects inference to expected values.}
+\usage{
+inferenceToExpected_withMixedEff(tidy_tmb, ground_truth_eff)
+}
+\arguments{
+\item{tidy_tmb}{tidy model results obtained from fitting a mixed-effects model.}
+
+\item{ground_truth_eff}{A data frame containing ground truth effects.}
+}
+\value{
+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.
+}
+\examples{
+\dontrun{
+inferenceToExpected_withMixedEff(tidy_tmb(l_tmb), ground_truth_eff)
+}
+}
diff --git a/man/init_variable.Rd b/man/init_variable.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..af434e92283a4c3eca6c89a4fc74871819d21e2b
--- /dev/null
+++ b/man/init_variable.Rd
@@ -0,0 +1,34 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_initialization.R
+\name{init_variable}
+\alias{init_variable}
+\title{Initialize variable}
+\usage{
+init_variable(
+ list_var = c(),
+ name = "myVariable",
+ mu = c(2, 3),
+ sd = NA,
+ level = NA
+)
+}
+\arguments{
+\item{list_var}{Either c() or output of init_variable}
+
+\item{name}{Variable name}
+
+\item{mu}{Either a numeric value or a numeric vector (of length = level)}
+
+\item{sd}{Either numeric value or NA}
+
+\item{level}{Numeric value to specify the number of levels to simulate}
+}
+\value{
+A list with initialized variables
+}
+\description{
+Initialize variable
+}
+\examples{
+init_variable(name = "my_varA", mu = 2, sd = 9, level = 200)
+}
diff --git a/man/inputs_checking.Rd b/man/inputs_checking.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..649dd3aeb06976b73a03149f89a1e46eff293fc2
--- /dev/null
+++ b/man/inputs_checking.Rd
@@ -0,0 +1,26 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_initialization.R
+\name{inputs_checking}
+\alias{inputs_checking}
+\title{Check Input Parameters}
+\usage{
+inputs_checking(list_var, name, mu, sd, level)
+}
+\arguments{
+\item{list_var}{List containing the variables to be initialized.}
+
+\item{name}{Name of the variable.}
+
+\item{mu}{Mean of the variable.}
+
+\item{sd}{Standard deviation of the variable (optional).}
+
+\item{level}{Number of levels for categorical variables.}
+}
+\description{
+This function checks the validity of the input parameters for initializing a variable.
+It ensures that the necessary conditions are met for the input parameters.
+}
+\examples{
+inputs_checking(list_var = c(), name = "var1", mu = 0, sd = 1, level = 2)
+}
diff --git a/man/isValidInput2fit.Rd b/man/isValidInput2fit.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..40eb9278af6cb0e795d3dfe9dcf62ed5208d6af8
--- /dev/null
+++ b/man/isValidInput2fit.Rd
@@ -0,0 +1,25 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/fitmodel.R
+\name{isValidInput2fit}
+\alias{isValidInput2fit}
+\title{Check if Data is Valid for Model Fitting}
+\usage{
+isValidInput2fit(data2fit, formula)
+}
+\arguments{
+\item{data2fit}{The data frame or tibble containing the variables to be used for model fitting.}
+
+\item{formula}{The formula specifying the model to be fitted.}
+}
+\value{
+\code{TRUE} if all the variables required in the formula are present in \code{data2fit}, otherwise an error is raised.
+}
+\description{
+This function checks whether the provided data contains all the variables required in the model formula for fitting.
+}
+\examples{
+data(iris)
+formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+isValidInput2fit(iris, formula) # Returns TRUE if all required variables are present
+}
+\keyword{internal}
diff --git a/man/is_formula_mixedTypeI.Rd b/man/is_formula_mixedTypeI.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..9ee9c985f2e19324b08a155d94da901863089118
--- /dev/null
+++ b/man/is_formula_mixedTypeI.Rd
@@ -0,0 +1,20 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/evaluationwithmixedeffect.R
+\name{is_formula_mixedTypeI}
+\alias{is_formula_mixedTypeI}
+\title{Check if the formula follows a specific type I mixed effect structure.}
+\usage{
+is_formula_mixedTypeI(formula)
+}
+\arguments{
+\item{formula}{A formula object.}
+}
+\value{
+\code{TRUE} if the formula follows the specified type I mixed effect structure, \code{FALSE} otherwise.
+}
+\description{
+This function checks if the formula follows a specific type I mixed effect structure, which consists of a fixed effect and a random effect indicated by the presence of "|".
+}
+\examples{
+is_formula_mixedTypeI(formula = y ~ x + (1|group))
+}
diff --git a/man/is_fullrank.Rd b/man/is_fullrank.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..88cb24f7d2947b8a72d4d49f6c5ad30579338383
--- /dev/null
+++ b/man/is_fullrank.Rd
@@ -0,0 +1,32 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/fitmodel.R
+\name{is_fullrank}
+\alias{is_fullrank}
+\title{Check if a Model Matrix is Full Rank}
+\usage{
+is_fullrank(metadata, formula)
+}
+\arguments{
+\item{metadata}{The metadata used to create the model matrix.}
+
+\item{formula}{The formula used to specify the model matrix.}
+}
+\value{
+\code{TRUE} if the model matrix is full rank, \code{FALSE} otherwise.
+}
+\description{
+This function checks whether a model matrix is full rank, which is essential for
+certain statistical analyses. It computes the eigenvalues of the crossproduct
+of the model matrix and determines if the first eigenvalue is positive and if
+the ratio of the last eigenvalue to the first is within a defined tolerance.
+}
+\details{
+This function is inspired by a similar function found in the Limma package.
+}
+\examples{
+metadata <- data.frame(x = rnorm(10), y = rnorm(10))
+formula <- y ~ x
+is_fullrank(metadata, formula)
+
+
+}
diff --git a/man/is_mixedEffect_inFormula.Rd b/man/is_mixedEffect_inFormula.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..69f0e17117229518f0ed772fa7c160f78066d082
--- /dev/null
+++ b/man/is_mixedEffect_inFormula.Rd
@@ -0,0 +1,21 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/evaluationwithmixedeffect.R
+\name{is_mixedEffect_inFormula}
+\alias{is_mixedEffect_inFormula}
+\title{Check if the formula contains a mixed effect structure.}
+\usage{
+is_mixedEffect_inFormula(formula)
+}
+\arguments{
+\item{formula}{A formula object.}
+}
+\value{
+\code{TRUE} if the formula contains a mixed effect structure, \code{FALSE} otherwise.
+}
+\description{
+This function checks if the formula contains a mixed effect structure indicated by the presence of "|".
+}
+\examples{
+is_mixedEffect_inFormula(y ~ x + (1|group))
+
+}
diff --git a/man/is_positive_definite.Rd b/man/is_positive_definite.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..46783066ef744cd900d22991ff7bf01f299b10de
--- /dev/null
+++ b/man/is_positive_definite.Rd
@@ -0,0 +1,36 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/datafrommvrnorm_manipulations.R
+\name{is_positive_definite}
+\alias{is_positive_definite}
+\title{Check if a matrix is positive definite
+This function checks whether a given matrix is positive definite, i.e., all of its eigenvalues are positive.}
+\usage{
+is_positive_definite(mat)
+}
+\arguments{
+\item{mat}{The matrix to be checked.}
+}
+\value{
+A logical value indicating whether the matrix is positive definite.
+}
+\description{
+Check if a matrix is positive definite
+This function checks whether a given matrix is positive definite, i.e., all of its eigenvalues are positive.
+}
+\examples{
+# Create a positive definite matrix
+mat1 <- matrix(c(4, 2, 2, 3), nrow = 2)
+is_positive_definite(mat1)
+# Expected output: TRUE
+
+# Create a non-positive definite matrix
+mat2 <- matrix(c(4, 2, 2, -3), nrow = 2)
+is_positive_definite(mat2)
+# Expected output: FALSE
+
+# Check an empty matrix
+mat3 <- matrix(nrow = 0, ncol = 0)
+is_positive_definite(mat3)
+# Expected output: TRUE
+
+}
diff --git a/man/join_dtf.Rd b/man/join_dtf.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..c197d6f13eb31c288bb6ca6cacd8b8d4ef69fbdc
--- /dev/null
+++ b/man/join_dtf.Rd
@@ -0,0 +1,30 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/utils.R
+\name{join_dtf}
+\alias{join_dtf}
+\title{Join two data frames using data.table}
+\usage{
+join_dtf(d1, d2, k1, k2)
+}
+\arguments{
+\item{d1}{Data frame 1}
+
+\item{d2}{Data frame 2}
+
+\item{k1}{Key columns for data frame 1}
+
+\item{k2}{Key columns for data frame 2}
+}
+\value{
+Joined data frame
+}
+\description{
+Join two data frames using data.table
+}
+\examples{
+
+# Example usage:
+df1 <- data.frame(id = 1:5, value = letters[1:5])
+df2 <- data.frame(id = 1:5, category = LETTERS[1:5])
+join_dtf(df1, df2, "id", "id")
+}
diff --git a/man/launchFit.Rd b/man/launchFit.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..4bb44a5cefcbb828a0c49735c7d2b3dbd2128336
--- /dev/null
+++ b/man/launchFit.Rd
@@ -0,0 +1,31 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/fitmodel.R
+\name{launchFit}
+\alias{launchFit}
+\title{Launch the model fitting process for a specific group.}
+\usage{
+launchFit(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{
+List with 'glance' and 'summary' attributes representing the fitted model or NULL if there was an error
+}
+\description{
+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.
+}
+\examples{
+launchFit(group = "setosa", group_by = "Species",
+ formula = Sepal.Length ~ Sepal.Width + Petal.Length,
+ data = iris )
+}
diff --git a/man/launchUpdate.Rd b/man/launchUpdate.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..cb9a8796b5ffd93df1b7f4887946f4b6e013d89e
--- /dev/null
+++ b/man/launchUpdate.Rd
@@ -0,0 +1,30 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/updatefitmodel.R
+\name{launchUpdate}
+\alias{launchUpdate}
+\title{Launch the update process for a GLMNB model.}
+\usage{
+launchUpdate(glmnb_obj, formula, ...)
+}
+\arguments{
+\item{glmnb_obj}{A GLMNB object to be updated.}
+
+\item{formula}{Formula for the updated GLMNB model.}
+
+\item{...}{Additional arguments to be passed to the glmmTMB::glmmTMB function.}
+}
+\value{
+An updated GLMNB model or NULL if an error occurs.
+}
+\description{
+This function launches the update process for a GLMNB model, capturing and handling warnings and errors.
+}
+\examples{
+data(iris)
+groups <- unique(iris$Species)
+group_by <- "Species"
+formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+fitted_models <- fitModelParallel(formula, iris, group_by, n.cores = 1)
+new_formula <- Sepal.Length ~ Sepal.Width
+updated_model <- launchUpdate(fitted_models[[1]], new_formula)
+}
diff --git a/man/medianRatioNormalization.Rd b/man/medianRatioNormalization.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..a6b3de5a1c4fc622c674491ed780ce45931ca05c
--- /dev/null
+++ b/man/medianRatioNormalization.Rd
@@ -0,0 +1,30 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/prepare_data2fit.R
+\name{medianRatioNormalization}
+\alias{medianRatioNormalization}
+\title{Apply Median Ratio Normalization to a Counts Matrix}
+\usage{
+medianRatioNormalization(countsMatrix)
+}
+\arguments{
+\item{countsMatrix}{A counts matrix where rows represent genes and columns
+represent samples.}
+}
+\value{
+A normalized counts matrix after applying median ratio normalization.
+}
+\description{
+This function performs median ratio normalization on a counts matrix to
+adjust for differences in sequencing depth across samples.
+}
+\details{
+This function calculates the logarithm of the counts matrix,
+computes the average log expression for each gene, and then scales each
+sample's counts by the exponential of the difference between its average log
+expression and the median of those averages.
+}
+\examples{
+counts <- matrix(c(100, 200, 300, 1000, 1500, 2500), ncol = 2)
+normalized_counts <- medianRatioNormalization(counts)
+
+}
diff --git a/man/metrics_plot.Rd b/man/metrics_plot.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..f252d49384a8660ddedbb30a6ae392a4a69bf8e7
--- /dev/null
+++ b/man/metrics_plot.Rd
@@ -0,0 +1,27 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/plot_metrics.R
+\name{metrics_plot}
+\alias{metrics_plot}
+\title{Plot Metrics for Generalized Linear Mixed Models (GLMM)}
+\usage{
+metrics_plot(l_tmb, focus = NULL)
+}
+\arguments{
+\item{l_tmb}{A list of GLMM objects to extract metrics from.}
+
+\item{focus}{A character vector specifying the metrics to focus on. Possible
+values include "AIC", "BIC", "logLik", "deviance", "df.resid", and
+"dispersion". If \code{NULL}, all available metrics will be plotted.}
+}
+\value{
+A ggplot object displaying density plots for the specified metrics.
+}
+\description{
+This function generates a density plot of the specified metrics for the given
+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"))
+}
diff --git a/man/mock_rnaseq.Rd b/man/mock_rnaseq.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..6f67997bdeba80905ec1e111990424e0b068a3a6
--- /dev/null
+++ b/man/mock_rnaseq.Rd
@@ -0,0 +1,42 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/mock-rnaseq.R
+\name{mock_rnaseq}
+\alias{mock_rnaseq}
+\title{Perform RNA-seq simulation}
+\usage{
+mock_rnaseq(
+ list_var,
+ n_genes,
+ min_replicates,
+ max_replicates,
+ sequencing_depth = NULL,
+ basal_expression = 0,
+ dispersion = stats::runif(n_genes, min = 0, max = 1000)
+)
+}
+\arguments{
+\item{list_var}{List of input variables}
+
+\item{n_genes}{Number of genes}
+
+\item{min_replicates}{Minimum replication count}
+
+\item{max_replicates}{Maximum replication count}
+
+\item{sequencing_depth}{Sequencing depth}
+
+\item{basal_expression}{base expression gene}
+
+\item{dispersion}{User-provided dispersion vector (optional)}
+}
+\value{
+List containing the ground truth, counts, and metadata
+}
+\description{
+Simulates RNA-seq data based on the input variables.
+}
+\examples{
+mock_rnaseq(list_var = init_variable(),
+ n_genes = 1000, min_replicates = 2,
+ max_replicates = 4)
+}
diff --git a/man/pipe.Rd b/man/pipe.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..a648c2969b222841abe76fb2e13c62c351078b2e
--- /dev/null
+++ b/man/pipe.Rd
@@ -0,0 +1,20 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/utils-pipe.R
+\name{\%>\%}
+\alias{\%>\%}
+\title{Pipe operator}
+\usage{
+lhs \%>\% rhs
+}
+\arguments{
+\item{lhs}{A value or the magrittr placeholder.}
+
+\item{rhs}{A function call using the magrittr semantics.}
+}
+\value{
+The result of calling \code{rhs(lhs)}.
+}
+\description{
+See \code{magrittr::\link[magrittr:pipe]{\%>\%}} for details.
+}
+\keyword{internal}
diff --git a/man/prepareData2computeInteraction.Rd b/man/prepareData2computeInteraction.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..c7e81c729ea64748658ad74eaa4fbdfc7aa9b989
--- /dev/null
+++ b/man/prepareData2computeInteraction.Rd
@@ -0,0 +1,27 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/actualinteractionfixeffects.R
+\name{prepareData2computeInteraction}
+\alias{prepareData2computeInteraction}
+\title{Prepare data for computing interaction values.}
+\usage{
+prepareData2computeInteraction(
+ categorical_vars,
+ categorical_varsInInteraction,
+ dataActual
+)
+}
+\arguments{
+\item{categorical_vars}{A character vector containing the names of categorical variables.}
+
+\item{categorical_varsInInteraction}{A character vector containing the names of categorical variables involved in interactions.}
+
+\item{dataActual}{A data frame containing the actual data with categorical variables and associated expression levels.}
+}
+\value{
+A data frame containing the filtered data for computing interaction values.
+}
+\description{
+This function prepares the data for computing interaction values between variables.
+It filters the \code{dataActual} data frame by selecting only the rows where the categorical variables
+specified in \code{categorical_vars} are at their reference levels.
+}
diff --git a/man/prepareData2fit.Rd b/man/prepareData2fit.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..4158249ff833b4560270f36c1ad8838acc285488
--- /dev/null
+++ b/man/prepareData2fit.Rd
@@ -0,0 +1,39 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/prepare_data2fit.R
+\name{prepareData2fit}
+\alias{prepareData2fit}
+\title{Prepare data for fitting}
+\usage{
+prepareData2fit(
+ countMatrix,
+ metadata,
+ normalization = TRUE,
+ response_name = "kij",
+ groupID = "geneID"
+)
+}
+\arguments{
+\item{countMatrix}{Count matrix}
+
+\item{metadata}{Metadata data frame}
+
+\item{normalization}{A boolean value indicating whether to apply median ratio
+normalization. If \code{TRUE} (default), the counts matrix will be
+normalized using median ratio normalization. If
+\code{FALSE}, no normalization will be applied.}
+
+\item{response_name}{String referring to target variable name that is being modeled and predicted (default : "kij")}
+
+\item{groupID}{String referring the group variable name (default : "geneID")}
+}
+\value{
+Data frame for fitting
+}
+\description{
+Prepares the countMatrix and metadata for fitting by converting the countMatrix to a long format and joining with metadata.
+}
+\examples{
+ list_var <- init_variable()
+ mock_data <- mock_rnaseq(list_var, n_genes = 3, 2,2, 2)
+ data2fit <- prepareData2fit(mock_data$counts, mock_data$metadata)
+}
diff --git a/man/removeDigitsAtEnd.Rd b/man/removeDigitsAtEnd.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..d25c0f3189bd7d42b5e61079c145f082be6781ea
--- /dev/null
+++ b/man/removeDigitsAtEnd.Rd
@@ -0,0 +1,21 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulation_initialization.R
+\name{removeDigitsAtEnd}
+\alias{removeDigitsAtEnd}
+\title{Remove digits at the end of a string}
+\usage{
+removeDigitsAtEnd(string)
+}
+\arguments{
+\item{string}{The input string from which digits are to be removed}
+}
+\value{
+The modified string with digits removed from the end
+}
+\description{
+This function removes any digits occurring at the end of a given string.
+}
+\examples{
+removeDigitsAtEnd("abc123") # Output: "abc"
+removeDigitsAtEnd("xyz") # Output: "xyz"
+}
diff --git a/man/removeDuplicatedWord.Rd b/man/removeDuplicatedWord.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..9b0938b56417f2d90000bdb0cd17f76bdcb5626c
--- /dev/null
+++ b/man/removeDuplicatedWord.Rd
@@ -0,0 +1,22 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/tidy_glmmtmb.R
+\name{removeDuplicatedWord}
+\alias{removeDuplicatedWord}
+\title{Remove Duplicated Words from Strings}
+\usage{
+removeDuplicatedWord(strings)
+}
+\arguments{
+\item{strings}{A character vector containing strings with potential duplicated words.}
+}
+\value{
+A character vector with duplicated words removed from each string.
+}
+\description{
+This function takes a vector of strings and removes duplicated words within each string.
+}
+\examples{
+
+words <- c("hellohello", "worldworld", "programmingprogramming", "R isis great")
+cleaned_words <- removeDuplicatedWord(words)
+}
diff --git a/man/renameColumns.Rd b/man/renameColumns.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..50517ef2c270b5a1a915704568c4fda4c8c123a8
--- /dev/null
+++ b/man/renameColumns.Rd
@@ -0,0 +1,35 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/tidy_glmmtmb.R
+\name{renameColumns}
+\alias{renameColumns}
+\title{Rename Columns in a Data Frame}
+\usage{
+renameColumns(
+ df,
+ old_names = c("Estimate", "Std..Error", "z.value", "Pr...z.."),
+ new_names = c("estimate", "std.error", "statistic", "p.value")
+)
+}
+\arguments{
+\item{df}{A data frame.}
+
+\item{old_names}{A character vector containing the old column names to be replaced.}
+
+\item{new_names}{A character vector containing the corresponding new column names.}
+}
+\value{
+The data frame with renamed columns.
+}
+\description{
+This function renames columns in a data frame based on specified old names and corresponding new names.
+}
+\examples{
+df <- data.frame(Estimate = c(1.5, 2.0, 3.2),
+ Std..Error = c(0.1, 0.3, 0.2),
+ z.value = c(3.75, 6.67, 4.90),
+ Pr...z.. = c(0.001, 0.0001, 0.002))
+
+renamed_df <- renameColumns(df, old_names = c("Estimate", "Std..Error", "z.value", "Pr...z.."),
+ new_names = c("estimate", "std.error", "statistic", "p.value"))
+
+}
diff --git a/man/reorderColumns.Rd b/man/reorderColumns.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..1204e33636cc803f4a38ec0b3c58599bd74e927e
--- /dev/null
+++ b/man/reorderColumns.Rd
@@ -0,0 +1,29 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/tidy_glmmtmb.R
+\name{reorderColumns}
+\alias{reorderColumns}
+\title{Reorder the columns of a dataframe}
+\usage{
+reorderColumns(df, columnOrder)
+}
+\arguments{
+\item{df}{The input dataframe.}
+
+\item{columnOrder}{A vector specifying the desired order of columns.}
+}
+\value{
+A dataframe with columns reordered according to the specified column order.
+}
+\description{
+This function reorders the columns of a dataframe according to the specified column order.
+}
+\examples{
+# Example dataframe
+df <- data.frame(A = 1:3, B = 4:6, C = 7:9)
+
+# Define the desired column order
+columnOrder <- c("B", "C", "A")
+
+# Reorder the columns of the dataframe
+df <- reorderColumns(df, columnOrder)
+}
diff --git a/man/roc_plot.Rd b/man/roc_plot.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..7b6ed205c65fe04b461bf65354374c16a1b44dcb
--- /dev/null
+++ b/man/roc_plot.Rd
@@ -0,0 +1,28 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/rocplot.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/samplingFromMvrnorm.Rd b/man/samplingFromMvrnorm.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..31cac61047c7b37dd4f1f5a0334b5efcce2e5c2d
--- /dev/null
+++ b/man/samplingFromMvrnorm.Rd
@@ -0,0 +1,27 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/datafrommvrnorm_manipulations.R
+\name{samplingFromMvrnorm}
+\alias{samplingFromMvrnorm}
+\title{getDataFromMvrnorm}
+\usage{
+samplingFromMvrnorm(n_samplings, l_mu, matx_cov)
+}
+\arguments{
+\item{n_samplings}{number of samplings using mvrnorm}
+
+\item{l_mu}{vector of mu}
+
+\item{matx_cov}{covariance matrix}
+}
+\value{
+samples generated from multivariate normal distribution
+}
+\description{
+getDataFromMvrnorm
+}
+\examples{
+n <- 100
+mu <- c(0, 0)
+covMatrix <- matrix(c(1, 0.5, 0.5, 1), ncol = 2)
+samples <- samplingFromMvrnorm(n_samplings = n, l_mu = mu, matx_cov = covMatrix)
+}
diff --git a/man/scaleCountsTable.Rd b/man/scaleCountsTable.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..349f87cc537d585271551aeef32d3001ac47ba52
--- /dev/null
+++ b/man/scaleCountsTable.Rd
@@ -0,0 +1,24 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/scalingsequencingdepth.R
+\name{scaleCountsTable}
+\alias{scaleCountsTable}
+\title{Scale Counts Table}
+\usage{
+scaleCountsTable(countsTable, seq_depth)
+}
+\arguments{
+\item{countsTable}{A counts table containing raw read counts.}
+
+\item{seq_depth}{sequencing depth vector}
+}
+\value{
+A scaled counts table.
+}
+\description{
+This function scales a counts table based on the expected sequencing depth per sample.
+}
+\examples{
+mock_data <- list(counts = matrix(c(10, 20, 30, 20, 30, 10, 10, 20, 20, 20, 30, 10), ncol = 4))
+scaled_counts <- scaleCountsTable(countsTable = mock_data$counts, 1000000)
+
+}
diff --git a/man/set_correlation.Rd b/man/set_correlation.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..adce396b3687c4aaca86aaabac6da33b90793aaf
--- /dev/null
+++ b/man/set_correlation.Rd
@@ -0,0 +1,31 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/setcorrelation.R
+\name{set_correlation}
+\alias{set_correlation}
+\title{Set Correlation between Variables}
+\usage{
+set_correlation(list_var, between_var, corr)
+}
+\arguments{
+\item{list_var}{A list containing the variables used in the simulation, initialized using \code{\link{init_variable}}.}
+
+\item{between_var}{Character vector specifying the names of the variables to set the correlation between.}
+
+\item{corr}{Numeric value specifying the desired correlation between the variables.}
+}
+\value{
+Updated \code{list_var} with the specified correlation set between the variables.
+}
+\description{
+Set the correlation between two or more variables in a simulation.
+}
+\details{
+The function checks if the variables specified in \code{between_var} are declared and initialized in the \code{list_var}. It also ensures that at least two variables with provided standard deviation are required to set a correlation in the simulation.
+The specified correlation value must be within the range (-1, 1). The function computes the corresponding covariance between the variables based on the specified correlation and standard deviations.
+The correlation information is then added to the \code{list_var} in the form of a data frame containing the correlation value and the corresponding covariance value.
+}
+\examples{
+list_var <- init_variable(name = "varA", mu = 0, sd = 5, level = 3) \%>\%
+ init_variable(name = "varB", mu = 0, sd = 25, level = 3)
+list_var <- set_correlation(list_var, between_var = c("varA", "varB"), corr = 0.7)
+}
diff --git a/man/simulationReport.Rd b/man/simulationReport.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..2d678f3d95e582e91e8ba1cb00257224fbfedc39
--- /dev/null
+++ b/man/simulationReport.Rd
@@ -0,0 +1,34 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/simulationreport.R
+\name{simulationReport}
+\alias{simulationReport}
+\title{Generate a simulation report}
+\usage{
+simulationReport(
+ mock_obj,
+ list_tmb = NULL,
+ dds_obj = NULL,
+ coeff_threshold = 0,
+ alt_hypothesis = "greaterAbs",
+ report_file = NULL
+)
+}
+\arguments{
+\item{mock_obj}{A list containing simulation data and ground truth.}
+
+\item{list_tmb}{A list of model results.}
+
+\item{dds_obj}{a DESeq2 object}
+
+\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.}
+}
+\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/subsetByTermLabel.Rd b/man/subsetByTermLabel.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..95138fb8f4a4ab4e99dde1f7418177c1c3a333d0
--- /dev/null
+++ b/man/subsetByTermLabel.Rd
@@ -0,0 +1,36 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/actualmainfixeffects.R
+\name{subsetByTermLabel}
+\alias{subsetByTermLabel}
+\title{subset data By Term Label}
+\usage{
+subsetByTermLabel(data, categorical_vars, term_label)
+}
+\arguments{
+\item{data}{The data frame to subset}
+
+\item{categorical_vars}{The categorical variables to consider}
+
+\item{term_label}{The term label to search for}
+}
+\value{
+A subset of the data frame containing rows where the categorical variables match the specified term label
+}
+\description{
+Get a subset of the data based on a specific term label in the categorical variables.
+}
+\examples{
+# Create a data frame
+my_data <- data.frame(color = c("red", "blue", "green", "red"),
+ size = c("small", "medium", "large", "medium"),
+ shape = c("circle", "square", "triangle", "circle"))
+my_data[] <- lapply(my_data, as.factor)
+
+# Get the subset for the term "medium" in the "size" variable
+subsetByTermLabel(my_data, "size", "medium")
+# Output: A data frame with rows where "size" is "medium"
+
+# Get the subset for the term "red" in the "color" variable
+subsetByTermLabel(my_data, "color", "red")
+# Output: A data frame with rows where "color" is "red"
+}
diff --git a/man/subsetFixEffectInferred.Rd b/man/subsetFixEffectInferred.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..aebd49bec3e14408f0b7317d35b1a84942701690
--- /dev/null
+++ b/man/subsetFixEffectInferred.Rd
@@ -0,0 +1,35 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/actualmainfixeffects.R
+\name{subsetFixEffectInferred}
+\alias{subsetFixEffectInferred}
+\title{Subset Fixed Effect Inferred Terms}
+\usage{
+subsetFixEffectInferred(tidy_tmb)
+}
+\arguments{
+\item{tidy_tmb}{The tidy TMB object containing the inferred terms.}
+}
+\value{
+A list with two elements:
+\describe{
+\item{fixed_term}{A list with two components - \code{nonInteraction} and \code{interaction},
+containing the names of the fixed effect inferred terms categorized as non-interaction and interaction terms, respectively.}
+\item{data}{A data frame containing the subset of tidy_tmb that contains the fixed effect inferred terms.}
+}
+}
+\description{
+This function subsets the tidy TMB object to extract the fixed effect inferred terms
+along with their categorization into interaction and non-interaction terms.
+}
+\examples{
+input_var_list <- init_variable()
+mock_data <- mock_rnaseq(input_var_list, 10, 2, 2)
+getData2computeActualFixEffect(mock_data$groundTruth$effect)
+data2fit = prepareData2fit(countMatrix = mock_data$counts, metadata = mock_data$metadata )
+#-- fit data
+resFit <- fitModelParallel(formula = kij ~ myVariable ,
+ data = data2fit, group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
+tidy_tmb <- tidy_tmb(resFit)
+subsetFixEffectInferred(tidy_tmb)
+}
diff --git a/man/subsetGenes.Rd b/man/subsetGenes.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..1b48bd6d0a0636cd024703a6c997bc4edde00aa0
--- /dev/null
+++ b/man/subsetGenes.Rd
@@ -0,0 +1,36 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/subsetgenes.R
+\name{subsetGenes}
+\alias{subsetGenes}
+\title{Subset Genes in Genomic Data}
+\usage{
+subsetGenes(l_genes, mockObj)
+}
+\arguments{
+\item{l_genes}{A character vector specifying the genes to be retained in the dataset.}
+
+\item{mockObj}{An object containing relevant genomic information to be filtered.}
+}
+\value{
+A modified version of the 'mockObj' data object, with genes filtered according to 'l_genes'.
+}
+\description{
+The 'subsetGenes' function selects and retains genes from 'mockObj' that match the genes specified in 'l_genes'.
+}
+\details{
+This function filters and adjusts genomic data within the Roxygeb project, based on a specified list of genes.
+}
+\examples{
+\dontrun{
+# Example list of genes to be retained
+selected_genes <- c("GeneA", "GeneB", "GeneC")
+
+# Example data object 'mockObj' (simplified structure)
+mockObj <- list(
+ # ... (mockObj structure)
+)
+
+# Using the subsetGenes function to filter 'mockObj'
+filtered_mockObj <- subsetGenes(selected_genes, mockObj)
+}
+}
diff --git a/man/subset_glance.Rd b/man/subset_glance.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..6499e812833c2ab101614ed02226cf23dcb674d6
--- /dev/null
+++ b/man/subset_glance.Rd
@@ -0,0 +1,28 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/plot_metrics.R
+\name{subset_glance}
+\alias{subset_glance}
+\title{Subset the glance DataFrame based on selected variables.}
+\usage{
+subset_glance(glance_df, focus)
+}
+\arguments{
+\item{glance_df}{The glance DataFrame to subset.}
+
+\item{focus}{A character vector of variable names to keep, including "AIC", "BIC", "logLik", "deviance",
+"df.resid", and "dispersion".}
+}
+\value{
+A subsetted glance DataFrame with only the selected variables.
+}
+\description{
+This function subsets the glance DataFrame to keep only the specified variables.
+}
+\examples{
+data(iris)
+models <- fitModelParallel(Sepal.Length ~ Sepal.Width + Petal.Length,
+ group_by = "Species",n.cores = 1, data = iris)
+glance_df <- glance_tmb(models)
+glance_df$group_id <- rownames(glance_df)
+subset_glance(glance_df, c("AIC", "BIC"))
+}
diff --git a/man/tidy_results.Rd b/man/tidy_results.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..bfe7f35e54fe376cd864f59b0b227c4395a28f23
--- /dev/null
+++ b/man/tidy_results.Rd
@@ -0,0 +1,37 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/waldtest.R
+\name{tidy_results}
+\alias{tidy_results}
+\title{Perform statistical tests and return tidy results}
+\usage{
+tidy_results(
+ list_tmb,
+ coeff_threshold = 0,
+ alternative_hypothesis = "greaterAbs",
+ correction_method = "BH"
+)
+}
+\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{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".}
+}
+\value{
+A tidy data frame containing the results of statistical tests for the estimated coefficients.
+}
+\description{
+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.
+}
+\examples{
+data(iris)
+model_list <- fitModelParallel(formula = Sepal.Length ~ Sepal.Width + Petal.Length,
+ data = iris, group_by = "Species", n.cores = 1)
+results_df <- tidy_results(model_list, coeff_threshold = 0.1, alternative_hypothesis = "greater")
+}
diff --git a/man/tidy_tmb.Rd b/man/tidy_tmb.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..34688772aadd23ec9dc6dbcb95f456aa44832d2f
--- /dev/null
+++ b/man/tidy_tmb.Rd
@@ -0,0 +1,23 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/tidy_glmmtmb.R
+\name{tidy_tmb}
+\alias{tidy_tmb}
+\title{Extract Tidy Summary of Multiple glmmTMB Models}
+\usage{
+tidy_tmb(l_tmb)
+}
+\arguments{
+\item{l_tmb}{A list of glmmTMB model objects.}
+}
+\value{
+A data frame containing a tidy summary of the fixed and random effects from all glmmTMB models in the list.
+}
+\description{
+This function takes a list of glmmTMB models and extracts a tidy summary of the fixed and random effects from each model. It then combines the results into a single data frame.
+}
+\examples{
+model1 <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length + (1 | Species), data = iris)
+model2 <- glmmTMB::glmmTMB(Petal.Length ~ Sepal.Length + Sepal.Width + (1 | Species), data = iris)
+model_list <- list(Model1 = model1, Model2 = model2)
+tidy_summary <- tidy_tmb(model_list)
+}
diff --git a/man/updateParallel.Rd b/man/updateParallel.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..ca48ac4da540fcf572b734efa792e8b5a1d2d410
--- /dev/null
+++ b/man/updateParallel.Rd
@@ -0,0 +1,34 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/updatefitmodel.R
+\name{updateParallel}
+\alias{updateParallel}
+\title{Update GLMNB models in parallel.}
+\usage{
+updateParallel(formula, l_tmb, n.cores = NULL, log_file = "log.txt", ...)
+}
+\arguments{
+\item{formula}{Formula for the GLMNB model.}
+
+\item{l_tmb}{List of GLMNB objects.}
+
+\item{n.cores}{Number of cores to use for parallel processing. If NULL, the function will use all available cores.}
+
+\item{log_file}{File path for the log output.}
+
+\item{...}{Additional arguments to be passed to the glmmTMB::glmmTMB function.}
+}
+\value{
+A list of updated GLMNB models.
+}
+\description{
+This function fits GLMNB models in parallel using multiple cores, allowing for faster computation.
+}
+\examples{
+data(iris)
+groups <- unique(iris$Species)
+group_by <- "Species"
+formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+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)
+}
diff --git a/man/wald_test.Rd b/man/wald_test.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..7da14ddcb3ce4316b5a99c58b982ddf2bdaaeed2
--- /dev/null
+++ b/man/wald_test.Rd
@@ -0,0 +1,36 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/waldtest.R
+\name{wald_test}
+\alias{wald_test}
+\title{Wald test for hypothesis testing}
+\usage{
+wald_test(
+ estimation,
+ std_error,
+ reference_value = 0,
+ alternative = "greaterAbs"
+)
+}
+\arguments{
+\item{estimation}{The estimated coefficient value.}
+
+\item{std_error}{The standard error of the estimation.}
+
+\item{reference_value}{The reference value for comparison (default is 0).}
+
+\item{alternative}{The type of alternative hypothesis to test (default is "greaterAbs").}
+}
+\value{
+A list containing the test statistic and p-value.
+}
+\description{
+This function performs a Wald test for hypothesis testing by comparing an estimation
+to a reference value using the provided standard error. It allows testing for
+one-tailed alternatives: "greater" - β > reference_value, "less" - β < −reference_value,
+or two-tailed alternative: "greaterAbs" - |β| > reference_value.
+If the p-value obtained is greater than 1, it is set to 1 to avoid invalid p-values.
+}
+\examples{
+# Perform a Wald test with the default "greaterAbs" alternative
+wald_test(estimation = 0.1, std_error = 0.02, reference_value = 0.2)
+}
diff --git a/man/wrapper_DESeq2.Rd b/man/wrapper_DESeq2.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..2b3f5b388c8316e85b1f8568cab43dcbe026c164
--- /dev/null
+++ b/man/wrapper_DESeq2.Rd
@@ -0,0 +1,42 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/wrapperdeseq2.R
+\name{wrapper_DESeq2}
+\alias{wrapper_DESeq2}
+\title{Wrapper Function for DESeq2 Analysis}
+\usage{
+wrapper_DESeq2(dds, lfcThreshold, altHypothesis, correction_method = "BH")
+}
+\arguments{
+\item{dds}{A DESeqDataSet object containing the count data and experimental design.}
+
+\item{lfcThreshold}{The threshold for minimum log-fold change (LFC) to consider differentially expressed.}
+
+\item{altHypothesis}{The alternative hypothesis for the analysis, indicating the direction of change.
+Options are "greater", "less", or "two.sided".}
+
+\item{correction_method}{The method for p-value correction. Default is "BH" (Benjamini-Hochberg).}
+}
+\value{
+A list containing the dispersion values and the results of the differential expression analysis.
+The dispersion values are calculated from the dds object and named according to sample names.
+The inference results include adjusted p-values and log2 fold changes for each gene.
+}
+\description{
+This function performs differential expression analysis using DESeq2 based on the provided
+DESeqDataSet (dds) object. It calculates the dispersion values from the dds object and then
+performs inference on the log-fold change (LFC) values using the specified parameters.
+}
+\examples{
+N_GENES = 100
+MAX_REPLICATES = 5
+MIN_REPLICATES = 5
+## --init variable
+input_var_list <- init_variable( name = "genotype", mu = 12, sd = 0.1, level = 3) \%>\%
+ init_variable(name = "environment", mu = c(0,1), NA , level = 2)
+
+mock_data <- mock_rnaseq(input_var_list, N_GENES, MIN_REPLICATES, MAX_REPLICATES)
+dds <- DESeq2::DESeqDataSetFromMatrix(mock_data$counts ,
+ mock_data$metadata, ~ genotype + environment)
+dds <- DESeq2::DESeq(dds, quiet = TRUE)
+result <- wrapper_DESeq2(dds, lfcThreshold = 1, altHypothesis = "greater")
+}
diff --git a/man/wrapper_var_cor.Rd b/man/wrapper_var_cor.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..ac90a567959438423dcf5afd0ece5908be9001ef
--- /dev/null
+++ b/man/wrapper_var_cor.Rd
@@ -0,0 +1,25 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/tidy_glmmtmb.R
+\name{wrapper_var_cor}
+\alias{wrapper_var_cor}
+\title{Wrapper for Extracting Variance-Covariance Components}
+\usage{
+wrapper_var_cor(var_cor, elt)
+}
+\arguments{
+\item{var_cor}{A variance-covariance object from the glmmTMB model.}
+
+\item{elt}{A character indicating the type of effect, either "cond" or "zi".}
+}
+\value{
+A data frame containing the standard deviation and correlation components for the specified grouping factor.
+}
+\description{
+This function extracts variance-covariance components from a glmmTMB model object for a specific grouping factor and returns them as a data frame.
+}
+\examples{
+model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length + (1|Species),
+ data = iris, family = gaussian)
+var_cor <- summary(model)$varcor$cond
+ran_pars_df <- wrapper_var_cor(var_cor, "Species")
+}
diff --git a/tests/testthat.R b/tests/testthat.R
new file mode 100644
index 0000000000000000000000000000000000000000..46326fb4e3261893e8e61a7b511ac123b93b3992
--- /dev/null
+++ b/tests/testthat.R
@@ -0,0 +1,4 @@
+library(testthat)
+library(HTRfit)
+
+test_check("HTRfit")
diff --git a/tests/testthat/test-actualinteractionfixeffects.R b/tests/testthat/test-actualinteractionfixeffects.R
new file mode 100644
index 0000000000000000000000000000000000000000..c930baa20ae242b7cf822d34443437384a9533f4
--- /dev/null
+++ b/tests/testthat/test-actualinteractionfixeffects.R
@@ -0,0 +1,366 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+test_that("filter_dataframe retourne le dataframe filtré correctement", {
+ # Créer un exemple de dataframe
+ df <- data.frame(
+ col1 = c(1, 2, 3, 4, 5),
+ col2 = c("A", "B", "C", "D", "E"),
+ col3 = c("X", "Y", "Z", "X", "Y")
+ )
+
+ # Créer une liste de filtres
+ filter_list <- list(
+ col1 = c(2),
+ col2 = "B",
+ col3 = c("Y")
+ )
+
+ # Appliquer les filtres sur le dataframe
+ filtered_df <- filter_dataframe(df, filter_list)
+
+ # Vérifier que les lignes correspondantes sont présentes dans le dataframe filtré
+ expect_equal(nrow(filtered_df), 1)
+ expect_true(all(filtered_df$col1 %in% c(2)))
+ expect_true(all(filtered_df$col2 == "B"))
+ expect_true(all(filtered_df$col3 %in% c("Y")))
+})
+
+test_that("filter_dataframe retourne le dataframe d'origine si aucun filtre n'est spécifié", {
+ # Créer une liste de filtres vide
+ filter_list <- list()
+
+ # Appliquer les filtres sur le dataframe
+ filtered_df <- filter_dataframe(df, filter_list)
+
+ # Vérifier que le dataframe filtré est identique au dataframe d'origine
+ expect_identical(filtered_df, df)
+})
+
+test_that("calculate_actual_interactionX2_values retourne la valeur d'interaction réelle correctement", {
+ average_gt <- data.frame(
+ clmn_term_1 = c("A", "A", "B", "B"),
+ clmn_term_2 = c("X", "Y", "X", "Y"),
+ logQij_mean = c(1.5, 2.0, 85, 1.0)
+ )
+
+ # Définir les paramètres de la fonction
+ l_label <- list(clmn_term_1 = c("A", "B"), clmn_term_2 = c("X", "Y"))
+ clmn_term_1 <- "clmn_term_1"
+ lbl_term_1 <- "B"
+ clmn_term_2 <- "clmn_term_2"
+ lbl_term_2 <- "Y"
+
+ # Calculer la valeur d'interaction réelle
+ actual_interaction <- calculate_actual_interactionX2_values(average_gt, l_label, clmn_term_1, lbl_term_1, clmn_term_2, lbl_term_2)
+
+ # Vérifier que la valeur d'interaction réelle est correcte
+ expect_equal(actual_interaction, -84.5)
+})
+
+
+
+test_that("prepareData2computeInteraction filters data correctly", {
+
+ data <- data.frame(
+ geneID = c("gene1", "gene2", "gene3", "gene4"),
+ label_varA = factor(c("A", "A", "B", "B")),
+ label_varB = factor(c("X", "X", "Y", "Y")),
+ label_varC = factor(c("P", "P", "Q", "Q")),
+ logQij_mean = c(1.2, 3.4, 5.6, 7.8)
+ )
+ categorical_vars <- c("label_varA", "label_varB", "label_varC")
+ categorical_varsInInteraction <- c("label_varA", "label_varC")
+
+ dataActual_2computeInteractionValues <- prepareData2computeInteraction(categorical_vars, categorical_varsInInteraction, data)
+
+ expect_equal(nrow(dataActual_2computeInteractionValues), 2)
+ expect_true(all(dataActual_2computeInteractionValues$label_varA %in% c("A", "A")))
+ expect_true(all(dataActual_2computeInteractionValues$label_varB %in% c("X", "X")))
+ expect_true(all(dataActual_2computeInteractionValues$label_varC %in% c("P", "P")))
+ expect_equal(dataActual_2computeInteractionValues$logQij_mean, c(1.2, 3.4 ))
+})
+
+
+
+## TEST
+test_that("Generate actual interaction fixed effect correctly", {
+
+ ########################################################################"
+ N_GENES <- 4
+ MIN_REPLICATES <- 3
+ MAX_REPLICATES <- 3
+
+ init_var <- init_variable(name = "varA", mu = 8, sd = 0.1, level = 3) %>%
+ init_variable(name = "varB", mu = c(5, -5), NA, level = 2) %>%
+ init_variable(name = "varC", mu = 1, 3, 3) %>%
+ add_interaction(between_var = c("varA", "varC"), mu = 5, 0.1)
+
+ # -- simulation
+ mock_data <- mock_rnaseq(init_var, N_GENES, min_replicates = MIN_REPLICATES, max_replicates = MAX_REPLICATES)
+
+ # -- fit data
+ data2fit <- prepareData2fit(countMatrix = mock_data$counts, metadata = mock_data$metadata)
+ results_fit <- fitModelParallel(formula = kij ~ varA + varB + varC + varA:varC,
+ data = data2fit, group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
+
+ # -- inputs
+ tidy_tmb <- tidy_tmb(results_fit)
+ fixEff_dataInference <- subsetFixEffectInferred(tidy_tmb)
+ fixEff_dataActual <- getData2computeActualFixEffect(mock_data$groundTruth$effects)
+
+ interactionTerm <- fixEff_dataInference$fixed_term$interaction[[1]]
+ categorical_vars <- fixEff_dataActual$categorical_vars
+ dataActual <- fixEff_dataActual$data
+ l_labelsInCategoricalVars <- lapply(dataActual[, categorical_vars], levels)
+ l_interaction <- strsplit(interactionTerm, split = ":")[[1]]
+ l_categoricalVarsInInteraction <- lapply(l_interaction,
+ function(label) findAttribute(label, l_labelsInCategoricalVars)) %>% unlist()
+
+ data_prepared <- prepareData2computeInteraction(categorical_vars, l_categoricalVarsInInteraction, dataActual)
+ actual_intercept <- getActualIntercept(fixEff_dataActual)
+ l_RefInCategoricalVars <- lapply(dataActual[, categorical_vars], function(vector) levels(vector)[1])
+ #######################################################################
+
+ actualInteraction <- generateActualInteractionX2_FixEff(l_interaction, l_categoricalVarsInInteraction,
+ data_prepared, l_RefInCategoricalVars)
+
+ # Add your assertions here based on the expected values
+ # For example:
+ expect_true(nrow(actualInteraction) == 4)
+ expect_equal(actualInteraction$geneID, c("gene1", "gene2", "gene3", "gene4"))
+ expect_true(all(actualInteraction$term %in% 'varA2:varC2'))
+ #expect_true(all(actualInteraction$description %in% 'interaction'))
+ expect_true(is.numeric(actualInteraction$actual))
+
+ # Add more assertions as needed...
+})
+
+
+# Test the function `generateActualInteractionX2_FixEff`
+test_that("Test generateActualInteractionX2_FixEff function", {
+ # Generate example data
+ data <- data.frame(
+ geneID = rep(x = c("gene1", "gene2"), each = 8),
+ logQij_mean = 1:16
+
+ )
+ metadata = expand.grid(list(varA = factor(c("A1", "A2")),
+ varB = factor(c("B1", "B2")),
+ varC = factor(c("C1", "C2"))))
+ metadata = rbind(metadata, metadata)
+
+ data <- cbind(metadata, data)
+
+ categorical_vars <- c("varA", "varB", "varC")
+ labelsInInteraction <- c("A2", "C2")
+
+ actual_intercept <- data.frame(actual = c(23, 21 ),
+ geneID = c("gene1", "gene2"),
+ term = c("(Intercept)", "(Intercept)"),
+ description = c("(Intercept)", "(Intercept)"))
+ # Run the function
+
+ actualInteractionValues <- getActualInteractionFixEff(labelsInInteraction, data, categorical_vars )
+
+
+ # Define the expected output based on the example data
+ expected_output <- data.frame(
+ term = "A2:C2",
+ geneID = c("gene1", "gene2"),
+ actual = c(0, 0),
+ description = c("A:C", "A:C")
+ )
+
+ # Add your assertions here to compare the actual output with the expected output
+ expect_equal(nrow(actualInteractionValues), nrow(expected_output))
+ expect_equal(actualInteractionValues$geneID, expected_output$geneID)
+ expect_equal(actualInteractionValues$term, expected_output$term)
+ expect_equal(actualInteractionValues$actual, expected_output$actual)
+ #expect_equal(actualInteractionValues$description, expected_output$description)
+
+})
+
+
+
+# Test for generateActualInteractionX3FixEff
+test_that("generateActualInteractionX3FixEff returns correct data frame", {
+
+ # Create reference values
+ reference <- list(
+ varA = c("A1", "A2"),
+ varB = c("B1", "B2"),
+ varC = c("C1", "C2")
+ )
+ # Generate example data
+ set.seed(123)
+ data <- data.frame(
+ geneID = rep(x = c("gene1", "gene2"), each = 8),
+ logQij_mean = sample(x = -3:12, 16)
+
+ )
+ metadata = expand.grid(list(varA = factor(c("A1", "A2")),
+ varB = factor(c("B1", "B2")),
+ varC = factor(c("C1", "C2"))))
+ metadata = rbind(metadata, metadata)
+
+ data <- cbind(metadata, data)
+
+ # Call the function
+ result <- generateActualInteractionX3_FixEff(
+ labelsInInteraction = c("A2", "B2", "C2"),
+ l_categoricalVarsInInteraction = c("varA", "varB", "varC"),
+ data2computeInteraction = data,
+ l_RefInCategoricalVars = reference
+ )
+
+ # Check the result
+ expect_equal(nrow(result), 2)
+ expect_equal(ncol(result), 4)
+ expect_identical(result$term, c("A2:B2:C2","A2:B2:C2"))
+ expect_equal(result$actual, c(-3, 13))
+ expect_identical(result$description, c("A:B:C", "A:B:C"))
+})
+
+# Test for calculate_actual_interactionX3_values
+test_that("calculate_actual_interactionX3_values returns correct values", {
+ # Create reference values
+ reference <- list(
+ varA = c("A1", "A2"),
+ varB = c("B1", "B2"),
+ varC = c("C1", "C2")
+ )
+ # Generate example data
+ set.seed(123)
+ data <- data.frame(
+ geneID = rep(x = c("gene1", "gene2"), each = 8),
+ logQij_mean = sample(x = -8:8, 16)
+
+ )
+ metadata = expand.grid(list(varA = factor(c("A1", "A2")),
+ varB = factor(c("B1", "B2")),
+ varC = factor(c("C1", "C2"))))
+ metadata = rbind(metadata, metadata)
+
+ data <- cbind(metadata, data)
+ # Call the function
+ result <- calculate_actual_interactionX3_values(
+ data = data,
+ l_reference = reference,
+ clmn_term_1 = "varA",
+ lbl_term_1 = "A2",
+ clmn_term_2 = "varB",
+ lbl_term_2 = "B2",
+ lbl_term_3 = "C2",
+ clmn_term_3 = "varC"
+ )
+
+ # Check the result
+ expect_equal(result, c(-7, 11))
+})
+
+
+
+## Test interaction X2
+test_that("Test getActualInteractionFixEff", {
+
+ # Exemple de données d'entrée
+ N_GENES <- 4
+ MIN_REPLICATES <- 3
+ MAX_REPLICATES <- 3
+
+ init_var <- init_variable(name = "varA", mu = 8, sd = 0.1, level = 3) %>%
+ init_variable(name = "varB", mu = c(5,-5), NA, level = 2) %>%
+ init_variable(name = "varC", mu = 1, 3, 3) %>%
+ add_interaction(between_var = c("varA", "varC"), mu = 5, 0.1)
+
+ # Simulation
+ mock_data <- mock_rnaseq(init_var, N_GENES, min_replicates = MIN_REPLICATES, max_replicates = MAX_REPLICATES)
+
+ # Données de fit
+ data2fit <- prepareData2fit(countMatrix = mock_data$counts, metadata = mock_data$metadata)
+ results_fit <- fitModelParallel(formula = kij ~ varA + varB + varC + varA:varC,
+ data = data2fit, group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
+
+ # Données d'entrée
+ tidy_tmb <- tidy_tmb(results_fit)
+ fixEff_dataInference <- subsetFixEffectInferred(tidy_tmb)
+ fixEff_dataActual <- getData2computeActualFixEffect(mock_data$groundTruth$effects)
+ interactionTerm <- fixEff_dataInference$fixed_term$interaction[[1]]
+ categorical_vars <- fixEff_dataActual$categorical_vars
+ dataActual <- fixEff_dataActual$data
+ l_labelsInCategoricalVars <- lapply(dataActual[, categorical_vars], levels)
+ l_interaction <- strsplit(interactionTerm, split = ":")[[1]]
+ l_categoricalVarsInInteraction <- lapply(l_interaction,
+ function(label) findAttribute(label, l_labelsInCategoricalVars)) %>% unlist()
+
+ data_prepared <- prepareData2computeInteraction(categorical_vars, l_categoricalVarsInInteraction, dataActual)
+ #actual_intercept <- getActualIntercept(fixEff_dataActual)
+
+ # Appel de la fonction à tester
+ actualInteraction <- getActualInteractionFixEff(l_interaction, data_prepared, categorical_vars)
+
+
+ expect_true(nrow(actualInteraction) == 4)
+ expect_equal(actualInteraction$geneID, c("gene1", "gene2", "gene3", "gene4"))
+ expect_true(all(actualInteraction$term %in% 'varA2:varC2'))
+ #expect_true(all(actualInteraction$description %in% 'interaction'))
+ expect_true(is.numeric(actualInteraction$actual))
+})
+
+
+## Test interaction X3
+test_that("Test getActualInteractionFixEff", {
+
+ # Exemple de données d'entrée
+ N_GENES <- 4
+ MIN_REPLICATES <- 20
+ MAX_REPLICATES <- 20
+
+ init_var <- init_variable( name = "varA", mu = 3,sd = 1, level = 2) %>%
+ init_variable( name = "varB", mu = 2, sd = 2, level = 2) %>%
+ init_variable( name = "varC", mu = 2, sd = 1, level = 2) %>%
+ add_interaction(between_var = c("varA", 'varC'), mu = 0.3, sd = 1) %>%
+ add_interaction(between_var = c("varB", 'varC'), mu = 2, sd = 1) %>%
+ add_interaction(between_var = c("varA", 'varB'), mu = -2, sd = 1) %>%
+ add_interaction(between_var = c("varA", 'varB', "varC"), mu = 1, sd = 1)
+
+
+ # Simulation
+ mock_data <- mock_rnaseq(init_var, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES, dispersion = 100)
+
+ # Données de fit
+ data2fit <- prepareData2fit(countMatrix = mock_data$counts, metadata = mock_data$metadata)
+ results_fit <- fitModelParallel(formula = kij ~ varA + varB + varC + varA:varB + varB:varC + varA:varC + varA:varB:varC,
+ data = data2fit, group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
+
+ # Données d'entrée
+ tidy_tmb <- tidy_tmb(results_fit)
+ fixEff_dataInference <- subsetFixEffectInferred(tidy_tmb)
+ fixEff_dataActual <- getData2computeActualFixEffect(mock_data$groundTruth$effects)
+ interactionTerm <- fixEff_dataInference$fixed_term$interaction[[4]]
+ categorical_vars <- fixEff_dataActual$categorical_vars
+ dataActual <- fixEff_dataActual$data
+ l_labelsInCategoricalVars <- lapply(dataActual[, categorical_vars], levels)
+ l_interaction <- strsplit(interactionTerm, split = ":")[[1]]
+ l_categoricalVarsInInteraction <- lapply(l_interaction,
+ function(label) findAttribute(label, l_labelsInCategoricalVars)) %>% unlist()
+
+ data_prepared <- prepareData2computeInteraction(categorical_vars, l_categoricalVarsInInteraction, dataActual)
+
+ actualInteraction <- getActualInteractionFixEff(l_interaction, data_prepared, categorical_vars)
+
+
+ expect_true(nrow(actualInteraction) == 4)
+ expect_equal(actualInteraction$geneID, c("gene1", "gene2", "gene3", "gene4"))
+ expect_true(all(actualInteraction$term %in% 'varA2:varB2:varC2'))
+ expect_true(all(actualInteraction$description %in% 'varA:varB:varC'))
+ expect_true(is.numeric(actualInteraction$actual))
+})
+
+
diff --git a/tests/testthat/test-actualmainfixeffects.R b/tests/testthat/test-actualmainfixeffects.R
new file mode 100644
index 0000000000000000000000000000000000000000..f8d8d3279749fe982684ae593cd22e36cba58b75
--- /dev/null
+++ b/tests/testthat/test-actualmainfixeffects.R
@@ -0,0 +1,223 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+test_that("Test for subsetFixEffectInferred function", {
+ # Prepare the test data
+ input_var_list <- init_variable(name = "varA", mu = c(1,2,3), level = 3) %>%
+ init_variable(name = "varB", mu = c(2,-6), level = 2) %>%
+ add_interaction(between_var = c("varA", "varB"), mu = 1, sd = 3)
+
+ mock_data <- mock_rnaseq(input_var_list, 10, 2, 2)
+ getData2computeActualFixEffect(mock_data$groundTruth$effect)
+ data2fit <- prepareData2fit(countMatrix = mock_data$counts, metadata = mock_data$metadata, normalization = F)
+
+ # Fit data
+ resFit <- fitModelParallel(formula = kij ~ varA + varB + varA:varB,
+ data = data2fit, group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
+ tidy_tmb <- tidy_tmb(resFit)
+
+ # Test the subsetFixEffectInferred function
+ result <- subsetFixEffectInferred(tidy_tmb)
+ # Define expected output
+ expected_nonInteraction <- c("varA2", "varA3", "varB2")
+ expected_interaction <- c("varA2:varB2", "varA3:varB2")
+
+ # Compare the output with the expected values
+ expect_equal(result$fixed_term$nonInteraction, expected_nonInteraction)
+ expect_equal(result$fixed_term$interaction, expected_interaction)
+})
+
+
+# Tests for averageByGroup
+test_that("averageByGroup returns correct average values", {
+ # Create a sample data frame
+ data <- data.frame(
+ Group1 = rep(c("A", "B", "C", "D"), each = 2),
+ Group2 = rep(c("X", "Y"), times = 4),
+ Value = 1:8
+ )
+
+ # Calculate average values by group
+ result <- averageByGroup(data, column = "Value", group_by = c("Group1", "Group2"))
+
+ # Check the output
+ expect_equal(nrow(result), 8) # Number of rows
+ expect_equal(colnames(result), c("logQij_mean","Group1", "Group2" )) # Column names
+ expect_equal(result$logQij_mean, c(1, 3,5, 7, 2, 4, 6, 8)) # Average values
+})
+
+# Tests for convert2Factor
+test_that("convert2Factor converts specified columns to factors", {
+ # Create a sample data frame
+ data <- data.frame(
+ Category1 = c("A", "B", "A", "B"),
+ Category2 = c("X", "Y", "X", "Z"),
+ Value = 1:4,
+ stringsAsFactors = FALSE
+ )
+
+ # Convert columns to factors
+ result <- convert2Factor(data, columns = c("Category1", "Category2"))
+
+ # Check the output
+ expect_is(result$Category1, "factor") # Category1 column converted to factor
+ expect_is(result$Category2, "factor") # Category2 column converted to factor
+})
+
+# Tests for findAttribute
+test_that("findAttribute returns the correct attribute", {
+ # Create a sample list
+ my_list <- list(
+ color = c("red", "blue", "green"),
+ size = c("small", "medium", "large"),
+ shape = c("circle", "square", "triangle")
+ )
+
+ # Find attributes
+ attr1 <- findAttribute("medium", my_list)
+ attr2 <- findAttribute("rectangle", my_list)
+
+ # Check the output
+ expect_equal(attr1, "size") # Attribute containing "medium"
+ expect_equal(attr2, NULL) # Attribute containing "rectangle"
+})
+
+# Tests for getActualIntercept
+test_that("getActualIntercept returns the correct intercept dataframe", {
+ # Create a sample data frame
+ data <- data.frame(
+ Category1 = c("A", "B", "A", "B"),
+ Category2 = c("X", "Y", "X", "Z"),
+ logQij_mean = 1:4
+ )
+ data[, c("Category1", "Category2")] <- lapply(data[, c("Category1", "Category2")], as.factor )
+
+ l_fixEffDataActual= list(categorical_vars = c("Category1", "Category2"), data = data)
+ # Get the intercept dataframe
+ result <- getActualIntercept(l_fixEffDataActual)
+
+ # Check the output
+ expect_equal(nrow(result), 2) # Number of rows
+ expect_equal(unique(result$term), "(Intercept)") # Term column
+ expect_equal(result$actual, c(1, 3)) # Actual column
+})
+
+
+
+
+
+# Test subsetByTermLabel with single categorical variable
+test_that("subsetByTermLabel with single categorical variable", {
+ my_data <- list(color = c("red", "blue", "green", "red"),
+ size = c("small", "medium", "large", "medium"),
+ shape = c("circle", "square", "triangle", "circle"))
+ my_data <- expand.grid(my_data)
+ my_data[] <- lapply(my_data, as.factor)
+
+ subset_data <- subsetByTermLabel(my_data, categorical_vars = "size", term_label = "medium")
+ expected_data <- my_data[my_data$size == "medium", ]
+ expected_data$term <- "medium"
+
+ expect_equal(subset_data, expected_data)
+})
+
+# Test subsetByTermLabel with single term label in multiple categorical variables
+test_that("subsetByTermLabel with single term label in multiple categorical variables", {
+ my_data <- list(color = c("red", "blue", "green", "red"),
+ size = c("small", "medium", "large", "medium"),
+ shape = c("circle", "square", "triangle", "circle"))
+ my_data <- expand.grid(my_data)
+ my_data[] <- lapply(my_data, as.factor)
+
+ subset_data <- subsetByTermLabel(data = my_data, categorical_vars = c("color", "shape"), term_label = "circle")
+ expected_data <- my_data[my_data$shape == "circle" & my_data$color == "red" , ]
+ expected_data$term <- "circle"
+
+ expect_equal(subset_data, expected_data)
+})
+
+# Test subsetByTermLabel with non-existent term label expect error
+test_that("subsetByTermLabel with non-existent term label", {
+ my_data <- list(color = c("red", "blue", "green", "red"),
+ size = c("small", "medium", "large", "medium"),
+ shape = c("circle", "square", "triangle", "circle"))
+ my_data <- expand.grid(my_data)
+ my_data[] <- lapply(my_data, as.factor)
+
+ expect_error(subsetByTermLabel(data = my_data, categorical_vars = "size", term_label = "extra-large"))
+})
+
+
+
+# Test getActualMainFixEff
+test_that("getActualMainFixEff", {
+ input_var_list <- init_variable()
+ mock_data <- mock_rnaseq(input_var_list, 2, 2, 2)
+ data2fit <- prepareData2fit(mock_data$counts, mock_data$metadata)
+ inference <- fitModelParallel(kij ~ myVariable ,
+ group_by = "geneID", data2fit, n.cores = 1)
+ tidy_inference <- tidy_tmb(inference)
+ tidy_fix <- subsetFixEffectInferred(tidy_inference)
+ fixEff_dataActual <- getData2computeActualFixEffect(mock_data$groundTruth$effects)
+ actual_intercept <- getActualIntercept(fixEff_dataActual)
+ ## -- main = non interaction
+ actual_mainFixEff <- getActualMainFixEff(tidy_fix$fixed_term$nonInteraction,
+ fixEff_dataActual, actual_intercept)
+
+ expected_actual <- data.frame(geneID = c("gene1", "gene2"),
+ term = c("myVariable2", "myVariable2"),
+ actual = c(1, 1),
+ description = "myVariable")
+ rownames(actual_mainFixEff) <- NULL
+ rownames(actual_mainFixEff) <- NULL
+ expect_equal(actual_mainFixEff, expected_actual)
+})
+
+
+
+test_that("getData2computeActualFixEffect return correct output",{
+ # Prepare the test data
+ input_var_list <- init_variable()
+ mock_data <- mock_rnaseq(input_var_list, 2, 2, 2)
+ data2fit <- prepareData2fit(mock_data$counts, mock_data$metadata)
+ inference <- fitModelParallel(kij ~ myVariable, group_by = "geneID", data2fit, n.cores = 1)
+ tidy_inference <- tidy_tmb(inference)
+ tidy_fix <- subsetFixEffectInferred(tidy_inference)
+
+ # Call the function to test
+ fixEff_dataActual <- getData2computeActualFixEffect(mock_data$groundTruth$effects)
+
+ # Define expected output
+ expected_data <- data.frame(logQij_mean = c(2,2,3,3), geneID = c("gene1", "gene2", "gene1", "gene2"), label_myVariable = factor(c("myVariable1", "myVariable1", "myVariable2", "myVariable2")))
+ expected_categorical_vars <- "label_myVariable"
+ # Compare the output with the expected values
+ expect_equal(fixEff_dataActual$data, expected_data)
+ expect_equal(fixEff_dataActual$categorical_vars, expected_categorical_vars)
+})
+
+
+test_that("generateActualForMainFixEff returns correct values for main fixed effect term", {
+ # Prepare the test data
+ input_var_list <- init_variable()
+ mock_data <- mock_rnaseq(input_var_list, 2, 2, 2)
+ data2fit <- prepareData2fit(mock_data$counts, mock_data$metadata)
+ fixEff_dataActual <- getData2computeActualFixEffect(mock_data$groundTruth$effects)
+ actual_intercept <- getActualIntercept(fixEff_dataActual)
+ df_term <- generateActualForMainFixEff("myVariable2", actual_intercept, fixEff_dataActual$data, fixEff_dataActual$categorical_vars)
+
+ # Define expected output
+ expected <- data.frame(
+ geneID = c("gene1", "gene2"),
+ label_myVariable = factor(c("myVariable2", "myVariable2"), levels = c("myVariable1", "myVariable2")),
+ term = c("myVariable2", "myVariable2"),
+ actual = c(1, 1),
+ description = c("myVariable", "myVariable")
+ )
+ rownames(df_term) <- NULL
+ rownames(expected) <- NULL
+ # Compare the output with the expected values
+ expect_equal(df_term, expected)
+})
+
+
diff --git a/tests/testthat/test-anova.R b/tests/testthat/test-anova.R
new file mode 100644
index 0000000000000000000000000000000000000000..5959558737740b4545d2faa8e8ca5a13087e2eee
--- /dev/null
+++ b/tests/testthat/test-anova.R
@@ -0,0 +1,40 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+
+test_that("handleAnovaError return correct ouptut", {
+ data(iris)
+ l_tmb <- fitModelParallel(Sepal.Length ~ Sepal.Width + Petal.Length,
+ data = iris, group_by = "Species", n.cores = 1)
+ anova_res <- handleAnovaError(l_tmb, "setosa", type = "III")
+
+ expect_s3_class(anova_res, "data.frame")
+ expect_equal(nrow(anova_res), 3) # Number of levels
+})
+
+test_that("handleAnovaError return correct ouptut", {
+ data(iris)
+ l_tmb <- fitModelParallel(Sepal.Length ~ Sepal.Width + Petal.Length,
+ data = iris, group_by = "Species", n.cores = 1)
+ anova_res <- handleAnovaError(l_tmb, "INALID_GROUP", type = "III")
+
+ expect_null(anova_res)
+})
+
+
+
+test_that("anovaParallel returns valid ANOVA results", {
+ data(iris)
+ l_tmb <- fitModelParallel(Sepal.Length ~ Sepal.Width + Petal.Length,
+ data = iris, group_by = "Species", n.cores = 1)
+ anov_res <- anovaParallel(l_tmb, type = "III")
+
+ expect_is(anov_res, "list")
+ expect_equal(length(anov_res), length(unique(iris$Species)))
+
+})
+
+
+
+
+
diff --git a/tests/testthat/test-countsplot.R b/tests/testthat/test-countsplot.R
new file mode 100644
index 0000000000000000000000000000000000000000..e0c29ee85640dce33d386516f080da17cfa27e08
--- /dev/null
+++ b/tests/testthat/test-countsplot.R
@@ -0,0 +1,18 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+
+
+# Test cases
+test_that("Counts plot is generated correctly", {
+ mock_data <- list(
+ counts = matrix(c(1, 2, 3, 4, 5, 6, 7, 8, 9), ncol = 3)
+ )
+
+ plot <- counts_plot(mock_data)
+
+ expect_true("gg" %in% class(plot))
+})
+
+
+
diff --git a/tests/testthat/test-datafrommvrnorm_manipulations.R b/tests/testthat/test-datafrommvrnorm_manipulations.R
new file mode 100644
index 0000000000000000000000000000000000000000..7e1bb398bbe2ee8e0081a234644c6e46a49e0fd6
--- /dev/null
+++ b/tests/testthat/test-datafrommvrnorm_manipulations.R
@@ -0,0 +1,84 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+test_that("getInput2mvrnorm returns the correct list", {
+ list_var <- init_variable()
+ input <- getInput2mvrnorm(list_var)
+ expect_is(input, "list")
+ expect_true("mu" %in% names(input))
+ expect_true("covMatrix" %in% names(input))
+})
+
+
+test_that("fillInCovarMatrice returns the correct matrix", {
+ covarMat <- matrix(0, nrow = 3, ncol = 3)
+ colnames(covarMat) <- c("label_varA", "label_varB", "label_varC")
+ rownames(covarMat) <- c("label_varA", "label_varB", "label_varC")
+ covarValue <- data.frame("varA.varB" = 18)
+ matrice <- fillInCovarMatrice(covarMatrice = covarMat, covar = covarValue)
+
+ expected_matrice <- matrix(0, nrow = 3, ncol = 3)
+ colnames(expected_matrice) <- c("label_varA", "label_varB", "label_varC")
+ rownames(expected_matrice) <- c("label_varA", "label_varB", "label_varC")
+ expected_matrice["label_varA", "label_varB"] <- 18
+ expected_matrice["label_varB", "label_varA"] <- 18
+ expect_identical(matrice, expected_matrice)
+})
+
+test_that("getCovarianceMatrix returns the correct covariance matrix", {
+ vector_sd <- c(1,2, 3)
+ names(vector_sd) <- c("varA", "varB", "varC")
+ vector_covar <- c(8, 12, 24)
+ names(vector_covar) <- c("varA.varB", "varA.varC", "varB.varC")
+ covMatrix <- getCovarianceMatrix(vector_sd, vector_covar)
+
+ expect_is(covMatrix, "matrix")
+ expect_equal(dim(covMatrix), c(3, 3))
+ expected_matrix <- matrix(c(1,8,12,8,4,24, 12,24,9), nrow = 3, byrow = T)
+ rownames(expected_matrix) <- c("label_varA", "label_varB", "label_varC")
+ colnames(expected_matrix) <- c("label_varA", "label_varB", "label_varC")
+ expect_equal(expected_matrix, covMatrix)
+})
+
+test_that("getGeneMetadata returns the correct metadata", {
+ list_var <- init_variable()
+ n_genes <- 10
+ metadata <- getGeneMetadata(list_var, n_genes)
+ expect_is(metadata, "data.frame")
+ expect_equal(colnames(metadata), c("geneID", paste("label", (attributes(list_var)$names), sep ="_")))
+ expect_equal(nrow(metadata), n_genes * list_var$myVariable$level)
+})
+
+test_that("getDataFromMvrnorm returns the correct data", {
+ list_var <- init_variable(name = "varA", mu = 1, sd = 4, level = 3) %>% init_variable("varB", mu = 2, sd = 1, level = 2)
+ input <- getInput2mvrnorm(list_var)
+ n_genes <- 10
+ n_samplings <- n_genes * (list_var$varA$level ) * (list_var$varB$level )
+ data <- getDataFromMvrnorm(list_var, input, n_genes)
+ expect_is(data, "list")
+ expect_equal(length(data), 1)
+ expect_is(data[[1]], "data.frame")
+ expect_equal(nrow(data[[1]]), n_samplings)
+
+})
+
+test_that("getDataFromMvrnomr returns empty list",{
+ list_var <- init_variable()
+ input <- getInput2mvrnorm(list_var)
+ n_genes <- 10
+ n_samplings <- n_genes * (list_var$varA$level ) * (list_var$varB$level )
+ data <- getDataFromMvrnorm(list_var, input, n_genes)
+ expect_is(data, "list")
+ expect_equal(data, list())
+})
+
+test_that("samplingFromMvrnorm returns the correct sampling", {
+ n_samplings <- 100
+ l_mu <- c(1, 2)
+ matx_cov <- matrix(c(1, 0.5, 0.5, 1), ncol = 2)
+ sampling <- samplingFromMvrnorm(n_samplings, l_mu, matx_cov)
+
+ expect_is(sampling, "matrix")
+ expect_equal(dim(sampling), c(n_samplings, length(l_mu)))
+})
+
+
diff --git a/tests/testthat/test-datafromuser_manipulations.R b/tests/testthat/test-datafromuser_manipulations.R
new file mode 100644
index 0000000000000000000000000000000000000000..f2fd8db34ba49488f1efb98b456a5a6fd1a35513
--- /dev/null
+++ b/tests/testthat/test-datafromuser_manipulations.R
@@ -0,0 +1,34 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+# Test unitaires pour la fonction join_dtf
+test_that("join_dtf réalise la jointure correctement", {
+ # Création de données de test
+ df1 <- data.frame(id = 1:5, value = letters[1:5])
+ df2 <- data.frame(id = 1:5, category = LETTERS[1:5])
+
+ # Exécution de la fonction
+ result <- join_dtf(df1, df2, "id", "id")
+
+ # Vérification des résultats
+ expect_true(is.data.frame(result))
+ expect_equal(nrow(result), 5)
+ expect_equal(ncol(result), 3)
+ expect_equal(names(result), c("id", "value", "category"))
+ expect_true(all.equal(result$id, df1$id))
+ expect_true(all.equal(result$id, df2$id))
+})
+
+
+# Test unitaires pour la fonction getDataFromUser
+test_that("getDataFromUser renvoie les données appropriées", {
+ # Exécution de la fonction
+ list_var <- init_variable()
+ list_var <- init_variable(list_var, "second_var")
+ result <- getDataFromUser(list_var)
+
+ # Vérification des résultats
+ expect_true(is.list(result))
+ expect_equal(length(result), 2)
+ expect_true(all(sapply(result, is.data.frame)))
+ expect_equal(names(result[[1]]), c("label_myVariable", "myVariable"))
+})
diff --git a/tests/testthat/test-evaluatedispersion.R b/tests/testthat/test-evaluatedispersion.R
new file mode 100644
index 0000000000000000000000000000000000000000..fef80adca74ccccb05a34cc2ec0af36d67699699
--- /dev/null
+++ b/tests/testthat/test-evaluatedispersion.R
@@ -0,0 +1,100 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+
+# 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("extractTMBDispersion function extracts dispersion 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)
+ extracted_disp <- extractTMBDispersion(l_res)
+ expect_identical(colnames(extracted_disp), c("inferred_dispersion", "geneID"))
+})
+
+test_that("extractDESeqDispersion function extracts dispersion 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)
+ dds <- DESeq2::DESeqDataSetFromMatrix(
+ countData = round(mock_data$counts),
+ colData = mock_data$metadata,
+ design = ~ varA)
+ dds <- DESeq2::DESeq(dds, quiet = TRUE)
+ deseq_wrapped = wrapper_DESeq2(dds, 2, "greaterAbs")
+
+ extracted_disp <- extractDESeqDispersion(deseq_wrapped)
+ expect_identical(colnames(extracted_disp), c("inferred_dispersion", "geneID"))
+})
+
+test_that("getDispersionComparison 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)
+
+ tmb_disp_inferred <- extractTMBDispersion(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 = wrapper_DESeq2(dds, 2, "greaterAbs")
+
+ tmb_disp_inferred <- extractTMBDispersion(l_res)
+ TMB_dispersion_df <- getDispersionComparison(tmb_disp_inferred, mock_data$groundTruth$gene_dispersion)
+ TMB_dispersion_df$from <- 'HTRfit'
+ DESEQ_disp_inferred <- extractDESeqDispersion(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"))
+})
+
+
+
diff --git a/tests/testthat/test-evaluationwithmixedeffect.R b/tests/testthat/test-evaluationwithmixedeffect.R
new file mode 100644
index 0000000000000000000000000000000000000000..854e95c3f78c48ff302edebc20cdaaa1cbadec86
--- /dev/null
+++ b/tests/testthat/test-evaluationwithmixedeffect.R
@@ -0,0 +1,218 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+
+
+test_that("Test is_mixedEffect_inFormula", {
+ formula1 <- y ~ a + (1 | B)
+ formula2 <- ~ a + (1 | B)
+ formula3 <- x ~ c + d
+
+ expect_true(is_mixedEffect_inFormula(formula1))
+ expect_true(is_mixedEffect_inFormula(formula2))
+ expect_false(is_mixedEffect_inFormula(formula3))
+})
+
+test_that("Test is_formula_mixedTypeI", {
+ formula1 <- y ~ x + (1 | group)
+ formula2 <- y ~ z + group1 + (1 | group1)
+ formula3 <- y ~ z + (1 | group1 + group2)
+ formula4 <- y ~ z + (1 | group1/z)
+
+ expect_true(is_formula_mixedTypeI(formula1))
+ expect_false(is_formula_mixedTypeI(formula2))
+ expect_false(is_formula_mixedTypeI(formula3))
+ expect_false(is_formula_mixedTypeI(formula4))
+
+})
+
+
+test_that("getCategoricalVar_inFixedEffect returns the correct result", {
+
+ ###### PREPARE DATA
+ N_GENES = 2
+ MAX_REPLICATES = 4
+ MIN_REPLICATES = 4
+
+ input_var_list <- init_variable( name = "genotype", mu = 2, sd = 0.5, level = 10) %>%
+ init_variable( name = "environment", mu = c(1, 3), sd = NA, level = 2) %>%
+ add_interaction(between_var = c("genotype", 'environment'), mu = 1, sd = 0.39)
+
+ mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES,
+ basal_expression = 3, dispersion = 100)
+
+ data2fit = prepareData2fit(countMatrix = mock_data$counts, metadata = mock_data$metadata, normalization = F)
+
+ l_tmb <- fitModelParallel(formula = kij ~ environment + (environment | genotype ),
+ data = data2fit, group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
+
+
+ tidy_tmb <- tidy_tmb(l_tmb)
+ categorical_var <- getCategoricalVar_inFixedEffect(tidy_tmb)
+ expect_equal(categorical_var, "label_environment")
+})
+
+test_that("group_logQij_per_genes_and_labels returns the correct result", {
+
+ ############ PREPARE DATA
+ N_GENES = 2
+ MAX_REPLICATES = 4
+ MIN_REPLICATES = 4
+ input_var_list <- init_variable( name = "genotype", mu = 2, sd = 0.5, level = 10) %>%
+ init_variable( name = "environment", mu = c(1, 3), sd = NA, level = 2) %>%
+ add_interaction(between_var = c("genotype", 'environment'), mu = 1, sd = 0.39)
+
+ mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES,
+ basal_expression = 3, dispersion = 100)
+
+ data2fit = prepareData2fit(countMatrix = mock_data$counts, metadata = mock_data$metadata, normalization = F)
+
+ l_tmb <- fitModelParallel(formula = kij ~ environment + (environment | genotype ),
+ data = data2fit, group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
+
+ ground_truth_eff <- mock_data$groundTruth$effects
+ categorical_var <- "label_environment"
+ logqij_list <- group_logQij_per_genes_and_labels(ground_truth_eff, categorical_var)
+
+ expect_is(logqij_list, "data.frame")
+ expect_equal(attributes(logqij_list)$names , c("gene1", "gene2"))
+ expect_equal(length(logqij_list$gene1), 2)
+ expect_equal(length(logqij_list$gene2), 2)
+ expect_equal(length(logqij_list$gene2[[1]]), 10)
+})
+
+test_that("getActualMixed_typeI returns the correct result", {
+ ############ PREPARE DATA
+ N_GENES = 2
+ MAX_REPLICATES = 4
+ MIN_REPLICATES = 4
+ input_var_list <- init_variable( name = "genotype", mu = 2, sd = 0.5, level = 10) %>%
+ init_variable( name = "environment", mu = c(1, 3), sd = NA, level = 2) %>%
+ add_interaction(between_var = c("genotype", 'environment'), mu = 1, sd = 0.39)
+
+ mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES,
+ basal_expression = 3, dispersion = 100)
+
+ data2fit = prepareData2fit(countMatrix = mock_data$counts, metadata = mock_data$metadata, normalization = F)
+
+ l_tmb <- fitModelParallel(formula = kij ~ environment + (environment | genotype ),
+ data = data2fit, group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
+
+ ground_truth_eff <- mock_data$groundTruth$effects
+ categorical_var <- "label_environment"
+ logqij_list <- group_logQij_per_genes_and_labels(ground_truth_eff, categorical_var)
+ l_genes <- unique(ground_truth_eff$geneID)
+ genes_iter_list <- stats::setNames(l_genes, l_genes)
+ categoricalVar_infos= list(ref = "environment1",
+ labels = c("environment1", "environment2"),
+ labelsOther = "environment2")
+
+ ## -- test
+ actual_mixedEff <- getActualMixed_typeI(logqij_list,
+ genes_iter_list,
+ categoricalVar_infos)
+
+ ## -- verif
+ expect_is(actual_mixedEff, "data.frame")
+ expect_equal(colnames(actual_mixedEff), c("actual", "term", "description", "geneID"))
+ expect_equal(unique(actual_mixedEff$geneID), c("gene1", "gene2"))
+ expect_equal(unique(actual_mixedEff$term), c("(Intercept)", "environment2",
+ "sd_(Intercept)", "sd_environment2", "cor__(Intercept).environment2"))
+
+})
+
+
+# Test for InferenceToExpected_withMixedEff
+test_that("inferenceToExpected_withMixedEff correctly compares inference to expected values", {
+
+ ## -- PREPARE DATA
+ N_GENES = 2
+ MAX_REPLICATES = 4
+ MIN_REPLICATES = 4
+
+ input_var_list <- init_variable(name = "genotype", mu = 2, sd = 0.5, level = 10) %>%
+ init_variable(name = "environment", mu = c(1, 3), sd = NA, level = 2) %>%
+ add_interaction(between_var = c("genotype", 'environment'), mu = 1, sd = 0.39)
+
+ mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES,
+ basal_expression = 3, dispersion = 100)
+
+ data2fit <- prepareData2fit(countMatrix = mock_data$counts, metadata = mock_data$metadata, normalization = FALSE)
+
+ l_tmb <- fitModelParallel(formula = kij ~ environment + (environment | genotype),
+ data = data2fit, group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"), n.cores = 1)
+
+ ## -- call fonction to test
+ compared_df <- inferenceToExpected_withMixedEff(tidy_tmb(l_tmb), mock_data$groundTruth$effects)
+
+ ## -- TEST VERIF
+ expect_equal(c("term", "description", "geneID", "effect",
+ "component", "group", "estimate", "std.error",
+ "statistic", "p.value", "actual" ) , colnames(compared_df))
+ expect_equal(c("gene1", "gene2" ) , unique(compared_df$geneID))
+ expect_equal(unique(compared_df$term), c("(Intercept)", "cor__(Intercept).environment2", "environment2",
+ "sd_(Intercept)", "sd_environment2"))
+
+})
+
+# Test for calculate_actualMixed
+test_that("calculate_actualMixed calculates actual mixed effects as expected", {
+ ## -- PREPARE DATA
+ N_GENES = 2
+ MAX_REPLICATES = 4
+ MIN_REPLICATES = 4
+
+ input_var_list <- init_variable(name = "genotype", mu = 2, sd = 0.5, level = 10) %>%
+ init_variable(name = "environment", mu = c(1, 3), sd = NA, level = 2) %>%
+ add_interaction(between_var = c("genotype", 'environment'), mu = 1, sd = 0.39)
+
+ mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES,
+ basal_expression = 3, dispersion = 100)
+
+ data2fit <- prepareData2fit(countMatrix = mock_data$counts, metadata = mock_data$metadata, normalization = FALSE)
+
+
+ ground_truth_eff <- mock_data$groundTruth$effects
+ categorical_var <- "label_environment"
+ logqij_list <- group_logQij_per_genes_and_labels(ground_truth_eff, categorical_var)
+ l_genes <- unique(ground_truth_eff$geneID)
+ genes_iter_list <- stats::setNames(l_genes, l_genes)
+ categoricalVar_infos= list(ref = "environment1",
+ labels = c("environment1", "environment2"),
+ labelsOther = "environment2")
+
+ ## -- call function & test
+ data_per_gene <- lapply(genes_iter_list, function(g) {
+ data_gene <- data.frame(logqij_list[[g]])
+ colnames(data_gene) <- categoricalVar_infos$labels
+ return(data_gene)
+ })
+ data_gene <- data_per_gene$gene1
+ actual_mixed <- calculate_actualMixed(data_gene,
+ labelRef_InCategoricalVar = categoricalVar_infos$ref ,
+ labelOther_inCategoricalVar = categoricalVar_infos$labelsOther)
+ expect_equal( colnames(actual_mixed), c("actual", "term", "description"))
+ expect_equal(actual_mixed$term, c("(Intercept)", "environment2",
+ "sd_(Intercept)", "sd_environment2",
+ "cor__(Intercept).environment2"))
+ expect_equal(actual_mixed$description, c("(Intercept)", "environment",
+ "sd", "sd",
+ "cor"))
+})
+
+
+
diff --git a/tests/testthat/test-fitmodel.R b/tests/testthat/test-fitmodel.R
new file mode 100644
index 0000000000000000000000000000000000000000..0ea0fb5498f8e2cf86ecd55aa86e2a0aa362b347
--- /dev/null
+++ b/tests/testthat/test-fitmodel.R
@@ -0,0 +1,271 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+
+test_that("isValidInput2fit returns TRUE for valid data", {
+ data(iris)
+ formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+ result <- isValidInput2fit(iris, formula)
+ expect_true(result)
+})
+
+# Test that the function raises an error when a required variable is missing
+test_that("isValidInput2fit raises an error for missing variable", {
+ data(iris)
+ formula <- Sepal.Length ~ Sepal.Width + NonExistentVariable
+ expect_error(isValidInput2fit(iris, formula), "Variable NonExistentVariable not found")
+})
+
+test_that(".fitModel returns a fitted model object", {
+ data(mtcars)
+ formula <- mpg ~ cyl + disp
+ fitted_model <- suppressWarnings(.fitModel(formula, mtcars))
+ #expect_warning(.fitModel(formula, mtcars))
+ expect_s3_class(fitted_model, "glmmTMB")
+
+ # Test with invalid formula
+ invalid_formula <- mpg ~ cyl + disp + invalid_var
+ expect_error(.fitModel(invalid_formula, mtcars))
+
+
+ # Additional parameters:
+ #change family + formula
+ formula <- Sepal.Length ~ Sepal.Width + Petal.Length + (1 | Species)
+ fitted_models <- suppressWarnings(.fitModel(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(.fitModel(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)))
+
+
+
+})
+
+
+# Test if random effects are dropped correctly
+test_that("Drop random effects from formula", {
+ formula <- y ~ x1 + (1 | group) + (1 | subject)
+ modified_formula <- drop_randfx(formula)
+ expect_equal(deparse(modified_formula), "y ~ x1")
+})
+
+# Test if formula with no random effects remains unchanged
+test_that("Keep formula with no random effects unchanged", {
+ formula <- y ~ x1 + x2
+ modified_formula <- drop_randfx(formula)
+ expect_equal(deparse(modified_formula), "y ~ x1 + x2")
+})
+
+# Test if all random effects are dropped to intercept
+test_that("Drop all random effects to intercept", {
+ formula <- ~ (1 | group) + (1 | subject)
+ modified_formula <- drop_randfx(formula)
+ expect_equal(deparse(modified_formula), ". ~ 1")
+})
+
+
+# Test if a full-rank model matrix is identified correctly
+test_that("Identify full-rank model matrix", {
+ metadata <- data.frame(x = rnorm(10), y = rnorm(10))
+ formula <- y ~ x
+ expect_true(is_fullrank(metadata, formula))
+})
+
+# Test if a rank-deficient model matrix is detected and throws an error
+test_that("Detect rank-deficient model matrix and throw error", {
+ metadata <- data.frame(x = factor(rep(c("xA","xB"),each = 5)),
+ w = factor(rep(c("wA","wB"), each = 5)),
+ z = factor(rep(c("zA","zB"), each = 5)),
+ y = rnorm(10))
+ formula <- y ~ x + w + z + y:w
+ expect_error(is_fullrank(metadata, formula),
+ regexp = "The model matrix is not full rank, so the model cannot be fit as specified.")
+})
+
+# Test if a rank-deficient model matrix is detected and throws an error
+test_that("Detect rank-deficient model matrix and throw error (with random eff)", {
+ metadata <- data.frame(x = factor(rep(c("xA","xB"),each = 5)),
+ w = factor(rep(c("wA","wB"), each = 5)),
+ z = factor(rep(c("zA","zB"), each = 5)),
+ y = rnorm(10))
+ formula <- y ~ x + w + z + y:w + (1 | w)
+ expect_error(is_fullrank(metadata, formula),
+ regexp = "The model matrix is not full rank, so the model cannot be fit as specified.")
+})
+
+# Test if a rank-deficient model matrix is detected and throws an error
+test_that("Identify full-rank model matrix (with random eff)", {
+ metadata <- data.frame(x = factor(rep(c("xA","xB"),each = 5)),
+ w = factor(rep(c("wA","wB"), each = 5)),
+ z = factor(rep(c("zA","zB"), each = 5)),
+ y = rnorm(10))
+ formula <- y ~ x + (1 | w)
+ 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", {
+ 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)))
+
+})
+
+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",
+ 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"),
+ 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)))
+})
+
+test_that(".parallel_fit returns a list of fitted model objects or NULL for any errors", {
+ data(iris)
+ groups <- unique(iris$Species)
+ group_by <- "Species"
+ formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+ fitted_models <- .parallel_fit(groups, group_by, formula, iris, log_file = "log.txt", n.cores = 1)
+ expect_s3_class(fitted_models$setosa, "glmmTMB")
+ expect_length(fitted_models, length(groups))
+
+ # Test with invalid formula
+ invalid_formula <- blabla ~ cyl + disp
+ result <- suppressWarnings(.parallel_fit(groups, group_by, invalid_formula,
+ iris, log_file = "log.txt", n.cores = 1))
+ expect_equal(result, expected = list(setosa = NULL, versicolor = NULL, virginica = NULL))
+
+
+ # Additional parameters:
+ #change family + formula
+ formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+ fitted_models <- suppressWarnings(.parallel_fit(formula = formula,
+ data = iris,
+ group_by = group_by,
+ groups = "setosa",
+ log_file = "log.txt",
+ n.cores = 1,
+ family = glmmTMB::nbinom1(link = "log") ))
+ expect_s3_class(fitted_models$setosa$call$family, "family")
+ expect_equal(fitted_models$setosa$call$formula, formula)
+ #change control settings
+ fitted_models <- suppressWarnings(.parallel_fit(formula = formula,
+ data = iris,
+ group_by = group_by,
+ groups = "setosa",
+ log_file = "log.txt",
+ family = glmmTMB::nbinom1(link = "log"),
+ n.cores = 1,
+ 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)))
+})
+
+test_that("fitModelParallel fits models in parallel for each group and returns a list of fitted model objects or NULL for any errors", {
+ data(iris)
+ 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))
+
+ invalid_formula <- blabla ~ cyl + disp
+ expect_error(fitModelParallel(invalid_formula, iris, group_by ,log_file = "log.txt", n.cores = 1))
+
+ # Additional parameters:
+ #change family + formula
+ formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+ fitted_models <- suppressWarnings(fitModelParallel(formula = formula,
+ data = iris,
+ group_by = group_by,
+ n.cores = 1,
+ family = glmmTMB::nbinom1(link = "log") ))
+ expect_s3_class(fitted_models$setosa$call$family, "family")
+ expect_equal(fitted_models$setosa$call$formula, formula)
+ #change control settings
+ fitted_models <- suppressWarnings(fitModelParallel(formula = formula,
+ data = iris,
+ group_by = group_by,
+ n.cores = 1,
+ family = glmmTMB::nbinom1(link = "log"),
+ 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)))
+
+})
+
diff --git a/tests/testthat/test-glance_tmb.R b/tests/testthat/test-glance_tmb.R
new file mode 100644
index 0000000000000000000000000000000000000000..9e5d6cc172db0eecfe54a1b6e803a2c03c06ab87
--- /dev/null
+++ b/tests/testthat/test-glance_tmb.R
@@ -0,0 +1,37 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+test_that("glance_tmb returns the summary statistics for multiple models", {
+ data(iris)
+ models <- fitModelParallel(Sepal.Length ~ Sepal.Width + Petal.Length, group_by = "Species",n.cores = 1, data = iris)
+ result <- glance_tmb(models)
+ expect_true("AIC" %in% colnames(result))
+ expect_true("BIC" %in% colnames(result))
+ expect_true("logLik" %in% colnames(result))
+ expect_true("deviance" %in% colnames(result))
+ expect_true("df.resid" %in% colnames(result))
+ expect_true("dispersion" %in% colnames(result))
+ expect_true(sum(c("setosa","versicolor", "virginica") %in% rownames(result)) == 3)
+
+ ## unique obect in list
+ model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length + (1|Species), data = iris)
+ result <- glance_tmb(model)
+ expect_true("AIC" %in% colnames(result))
+ expect_true("BIC" %in% colnames(result))
+ expect_true("logLik" %in% colnames(result))
+ expect_true("deviance" %in% colnames(result))
+ expect_true("df.resid" %in% colnames(result))
+ expect_true("dispersion" %in% colnames(result))
+
+})
+
+test_that("getGlance returns the summary statistics for a single model", {
+ model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length + (1|Species), data = iris)
+ result <- getGlance(model)
+ expect_true("AIC" %in% colnames(result))
+ expect_true("BIC" %in% colnames(result))
+ expect_true("logLik" %in% colnames(result))
+ expect_true("deviance" %in% colnames(result))
+ expect_true("df.resid" %in% colnames(result))
+ expect_true("dispersion" %in% colnames(result))
+})
diff --git a/tests/testthat/test-identityplot.R b/tests/testthat/test-identityplot.R
new file mode 100644
index 0000000000000000000000000000000000000000..2543b6fe1b5535a17f6d081108053ab1b01c969c
--- /dev/null
+++ b/tests/testthat/test-identityplot.R
@@ -0,0 +1,19 @@
+# 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
new file mode 100644
index 0000000000000000000000000000000000000000..5f8bba26b3390fc6d07aad3817980c3f17733de6
--- /dev/null
+++ b/tests/testthat/test-mock-rnaseq.R
@@ -0,0 +1,111 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+# Test case: Valid input vector with numeric and positive values
+test_that("Valid input vector with numeric and positive values", {
+ input_vector <- c(0.5, 1.2, 0.8)
+ result <- getValidDispersion(input_vector)
+ expect_identical(result, input_vector)
+})
+
+# Test case: Valid input vector with numeric, positive, and negative values
+test_that("Valid input vector with numeric, positive, and negative values", {
+ input_vector <- c(0.5, -0.3, 1.2, 0.8)
+ result <- getValidDispersion(input_vector)
+ expect_identical(result, c(0.5, 1.2, 0.8))
+})
+
+# Test case: Valid input vector with non-numeric elements
+test_that("Valid input vector with non-numeric elements", {
+ input_vector <- c(0.5, "invalid", 0.8)
+ result <- getValidDispersion(input_vector)
+ expect_identical(result, c(0.5, 0.8))
+})
+
+# Test case: Empty input vector
+test_that("Empty input vector", {
+ input_vector <- numeric(0)
+ expect_error(getValidDispersion(input_vector), "Invalid dispersion values provided.")
+})
+
+# Test case: unique value in vector
+test_that("unique value in vector", {
+ input_vector <- 5
+ expect_equal(getValidDispersion(input_vector), 5)
+})
+
+# Test case: All negative values
+test_that("All negative values", {
+ input_vector <- c(-0.5, -1.2, -0.8)
+ expect_error(getValidDispersion(input_vector), "Invalid dispersion values provided.")
+})
+
+
+# Test for .isDispersionMatrixValid
+test_that(".isDispersionMatrixValid returns TRUE for valid dimensions", {
+ matx_dispersion <- matrix(1:6, nrow = 2, ncol = 3)
+ matx_bool_replication <- matrix(TRUE, nrow = 2, ncol = 3)
+ expect_true(.isDispersionMatrixValid(matx_dispersion, matx_bool_replication))
+})
+
+test_that(".isDispersionMatrixValid throws an error for invalid dimensions", {
+ matx_dispersion <- matrix(1:4, nrow = 2, ncol = 2)
+ matx_bool_replication <- matrix(TRUE, nrow = 2, ncol = 3)
+ expect_false(.isDispersionMatrixValid(matx_dispersion, matx_bool_replication))
+})
+
+# Test for generateCountTable
+test_that("generateCountTable generates count table with correct dimensions", {
+ mu_ij_matx_rep <- matrix(1:6, nrow = 2, ncol = 3)
+ matx_dispersion_rep <- matrix(1:6, nrow = 2, ncol = 3)
+ count_table <- generateCountTable(mu_ij_matx_rep, matx_dispersion_rep)
+ expect_equal(dim(count_table), c(2, 3))
+})
+
+
+
+# Test for .replicateMatrix
+test_that(".replicateMatrix replicates matrix correctly", {
+ matrix <- matrix(1:9, nrow = 3, ncol = 3)
+ replication_matrix <- matrix(TRUE, nrow = 3, ncol = 3)
+ replicated_matrix <- .replicateMatrix(matrix, replication_matrix)
+ expect_equal(dim(replicated_matrix), c(3, 9))
+})
+
+
+
+# Test for mock_rnaseq
+#test_that("mock_rnaseq returns expected output", {
+ # Set up input variables
+# list_var <- NULL
+# n_genes <- 3
+# min_replicates <- 2
+# max_replicates <- 4
+# df_inputSimulation <- data.frame(gene_id = 1:3, coef_value = c(0.5, 0.3, 0.2))
+# matx_dispersion <- matrix(1:9, nrow = 3, ncol = 3)
+
+ # Run the function
+# expect_error(mock_rnaseq(list_var, n_genes, min_replicates, max_replicates, df_inputSimulation,
+# matx_dispersion))
+
+
+ #list_var <- init_variable(name = "my_var", mu = c(10, 20), level = 2 )
+ #n_genes <- 10
+ #min_replicates <- 2
+ #max_replicates <- 4
+ #scaling_factor <- 1
+ #df_inputSimulation <- getInput2simulation(list_var, n_genes)
+ #dispersion <- getDispersionMatrix(list_var, n_genes, c(1000, 1000, 1000, 1000, 1000, 1, 1, 1, 1, 1))
+ #mock_rnaseq(list_var, n_genes, min_replicates,
+ # max_replicates,
+ # df_inputSimulation, dispersion)
+ #ERROOR
+#})
+
+
+# Test for generateReplicationMatrix
+test_that("generateReplicationMatrix generates replication matrix correctly", {
+ replication_matrix <- generateReplicationMatrix(init_variable(),min_replicates = 2, max_replicates = 4)
+ expect_equal(dim(replication_matrix), c(4, 2))
+})
+
diff --git a/tests/testthat/test-plot_metrics.R b/tests/testthat/test-plot_metrics.R
new file mode 100644
index 0000000000000000000000000000000000000000..1f3c057923d96dc147171a36f2716e4ecb9b3ba0
--- /dev/null
+++ b/tests/testthat/test-plot_metrics.R
@@ -0,0 +1,36 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+
+test_that("subset_glance subsets the glance DataFrame correctly", {
+ data(iris)
+ models <- fitModelParallel(Sepal.Length ~ Sepal.Width + Petal.Length, group_by = "Species",n.cores = 1, data = iris)
+ glance_df <- glance_tmb(models)
+ glance_df$group_id <- rownames(glance_df)
+ result <- subset_glance(glance_df, c("AIC", "BIC"))
+ expect_true("AIC" %in% colnames(result))
+ expect_true("BIC" %in% colnames(result))
+ expect_true("group_id" %in% colnames(result))
+ expect_true(sum(c("setosa","versicolor", "virginica") %in% rownames(result)) == 3)
+})
+
+
+
+
+test_that("metrics_plot returns a ggplot object", {
+
+ data(iris)
+ l_glmTMB <- list(
+ setosa = glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length,
+ data = subset(iris, Species == "setosa")),
+ versicolor = glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length,
+ data = subset(iris, Species == "versicolor")),
+ virginica = glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length,
+ data = subset(iris, Species == "virginica"))
+ )
+ p <- metrics_plot(l_glmTMB)
+ expect_true(inherits(p, "gg"))
+
+})
+
+
diff --git a/tests/testthat/test-prepare_data2fit.R b/tests/testthat/test-prepare_data2fit.R
new file mode 100644
index 0000000000000000000000000000000000000000..08a7172d4905841c7fd21523e7d115fb5fa5de25
--- /dev/null
+++ b/tests/testthat/test-prepare_data2fit.R
@@ -0,0 +1,82 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+
+# Unit tests for countMatrix_2longDtf
+test_that("countMatrix_2longDtf converts count matrix to long data frame", {
+ # Sample count matrix
+ list_var <- init_variable()
+ mock_data <- mock_rnaseq(list_var, n_genes = 3, 2,2, 1)
+ # Convert count matrix to long data frame
+ dtf_countLong <- countMatrix_2longDtf(mock_data$counts)
+ expect_true(is.character(dtf_countLong$sampleID))
+ expect_true(is.character(dtf_countLong$geneID))
+ expect_true(is.numeric(dtf_countLong$kij))
+ expect_equal(unique(dtf_countLong$geneID), c("gene1", "gene2", "gene3"))
+ expect_equal(unique(dtf_countLong$sampleID),c("myVariable1_1", "myVariable1_2",
+ "myVariable2_1", "myVariable2_2"))
+})
+
+# Unit tests for getColumnWithSampleID
+test_that("getColumnWithSampleID returns column name with sampleID", {
+ # dummy data
+ list_var <- init_variable()
+ mock_data <- mock_rnaseq(list_var, n_genes = 3, 2,2, 2)
+ dtf_countLong <- countMatrix_2longDtf(mock_data$counts)
+
+ # Expected output
+ expected_output <- "sampleID"
+
+ # Get column name with sampleID
+ column_name <- .getColumnWithSampleID(dtf_countLong, mock_data$metadata)
+
+ # Check if the output matches the expected output
+ expect_identical(column_name, expected_output)
+})
+
+# Unit tests for prepareData2fit
+test_that("prepareData2fit prepares data for fitting", {
+ # dummy data
+ list_var <- init_variable()
+ mock_data <- mock_rnaseq(list_var, n_genes = 3, 2,2, 2)
+
+ # Prepare data for fitting
+ data2fit <- prepareData2fit(mock_data$counts, mock_data$metadata)
+
+ expect_true(is.character(data2fit$sampleID))
+ expect_true(is.character(data2fit$geneID))
+ expect_true(is.numeric(data2fit$kij))
+ expect_equal(unique(data2fit$geneID), c("gene1", "gene2", "gene3"))
+ expect_equal(unique(data2fit$sampleID),c("myVariable1_1", "myVariable1_2",
+ "myVariable2_1", "myVariable2_2"))
+})
+
+
+
+
+
+# Test case 1: Normalization with positive counts
+test_that("Median ratio normalization works for positive counts", {
+ counts <- matrix(c(100, 200, 300, 1000, 1500, 2500), ncol = 2)
+ normalized_counts <- medianRatioNormalization(counts)
+
+ expected_normalized_counts <- matrix(c(288.6751 , 577.3503 , 866.0254 , 346.4102, 519.6152, 866.0254), ncol = 2)
+
+ expect_equal(normalized_counts, expected_normalized_counts, tolerance = 1e-4)
+})
+
+# Test case 2: Normalization with zero counts
+test_that("Median ratio normalization return error for zero counts", {
+ counts <- matrix(c(0, 0, 0, 1000, 1500, 2500), ncol = 2)
+ expect_error(medianRatioNormalization(counts))
+
+})
+
+
+# Test case 5: All-zero genes
+test_that("Throws an error when all-zero genes are encountered", {
+ counts <- matrix(c(0, 0, 0, 0, 0, 0), ncol = 2)
+ expect_error(medianRatioNormalization(counts))
+})
+
+
diff --git a/tests/testthat/test-rocplot.R b/tests/testthat/test-rocplot.R
new file mode 100644
index 0000000000000000000000000000000000000000..00a679b0f8272bf45a4d1079627284f252af4840
--- /dev/null
+++ b/tests/testthat/test-rocplot.R
@@ -0,0 +1,52 @@
+# 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-scalinggeneexpression.R b/tests/testthat/test-scalinggeneexpression.R
new file mode 100644
index 0000000000000000000000000000000000000000..93f1391490532594c25b9b1cc7814fe8a77e48d3
--- /dev/null
+++ b/tests/testthat/test-scalinggeneexpression.R
@@ -0,0 +1,75 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+test_that("generate_BE returns correct number of genes", {
+ be_data <- generate_BE(n_genes = 100, 1)
+ expect_equal(nrow(be_data), 100)
+})
+
+
+test_that("generate_BE returns BE values within specified vector", {
+ BE_vec <- c(1, 2, 33, 0.4)
+ be_data <- generate_BE(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-scalingsequencingdepth.R b/tests/testthat/test-scalingsequencingdepth.R
new file mode 100644
index 0000000000000000000000000000000000000000..0f1e0a84c1f48b00b76de1f26adc1b8ece4b1ac5
--- /dev/null
+++ b/tests/testthat/test-scalingsequencingdepth.R
@@ -0,0 +1,19 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+# Test case 1: Scaling with valid min_seq_depth and max_seq_depth
+test_that("Valid scaling of counts table", {
+ # Test data
+ mock_data <- list(counts = matrix(c(10, 20, 30, 20, 30, 10, 10, 20, 20, 20, 30, 10), ncol = 4))
+ # Test function
+ scaled_counts <- scaleCountsTable(countsTable = mock_data$counts, 115000)
+
+ # Expected scaled counts
+ expected_scaled_counts <- matrix(c(5000, 10000, 15000, 10000, 15000, 5000,
+ 5000, 10000, 10000, 10000, 15000, 5000), ncol = 4)
+
+ # Check if the scaled counts match the expected scaled counts
+ expect_true(all(colSums(scaled_counts) == 115000))
+
+})
+
diff --git a/tests/testthat/test-setcorrelation.R b/tests/testthat/test-setcorrelation.R
new file mode 100644
index 0000000000000000000000000000000000000000..e70b19df80a04530150d613a63638584cac847ea
--- /dev/null
+++ b/tests/testthat/test-setcorrelation.R
@@ -0,0 +1,72 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+test_that("compute_covariation returns the correct covariation", {
+ # Test case 1: Positive correlation
+ corr <- 0.7
+ sd_A <- 3
+ sd_B <- 4
+ expected_cov <- corr * sd_A * sd_B
+ actual_cov <- compute_covariation(corr, sd_A, sd_B)
+ expect_equal(actual_cov, expected_cov)
+
+ # Test case 2: Negative correlation
+ corr <- -0.5
+ sd_A <- 2.5
+ sd_B <- 3.5
+ expected_cov <- corr * sd_A * sd_B
+ actual_cov <- compute_covariation(corr, sd_A, sd_B)
+ expect_equal(actual_cov, expected_cov)
+
+ # Test case 3: Zero correlation
+ corr <- 0
+ sd_A <- 1
+ sd_B <- 2
+ expected_cov <- corr * sd_A * sd_B
+ actual_cov <- compute_covariation(corr, sd_A, sd_B)
+ expect_equal(actual_cov, expected_cov)
+})
+
+
+# Unit tests for getStandardDeviationInCorrelation
+test_that("getStandardDeviationInCorrelation returns correct standard deviations", {
+
+ # Initialize list_var
+ list_var <- init_variable(name = "varA", mu = 0, sd = 5, level = 3) %>%
+ init_variable(name = "varB", mu = 0, sd = 25, level = 3)
+
+ # Test case 1: Two variables correlation
+ between_var_1 <- c("varA", "varB")
+ sd_expected_1 <- c(5, 25)
+ sd_result_1 <- getStandardDeviationInCorrelation(list_var, between_var_1)
+ expect_equal(sd_result_1, sd_expected_1)
+
+})
+
+
+
+test_that("set_correlation sets the correlation between variables correctly", {
+ # Initialize variables in the list_var
+ list_var <- init_variable(name = "varA", mu = 0, sd = 5, level = 3) %>%
+ init_variable(name = "varB", mu = 0, sd = 25, level = 3)
+
+ # Test setting correlation between varA and varB
+ list_var <- set_correlation(list_var, between_var = c("varA", "varB"), corr = 0.7)
+
+ corr_result <- list_var$correlations$varA.varB$cor
+ covar_result <- list_var$correlations$varA.varB$covar
+ expect_equal(corr_result, 0.7)
+ expect_equal(covar_result, 87.5)
+
+ # Test setting correlation between varA and varC (should raise an error)
+ expect_error(set_correlation(list_var, between_var = c("varA", "varC"), corr = 0.8),
+ "At least one variable in between_var is not declared. Variable not initialized cannot be used in a correlation.")
+
+ # Test setting correlation with invalid correlation value
+ expect_error(set_correlation(list_var, between_var = c("varA", "varB"), corr = 1.5))
+
+ # Test setting correlation with less than 2 variables with provided standard deviation
+ expect_error(set_correlation(list_var, between_var = c("varA"), corr = 0.7))
+})
+
+
diff --git a/tests/testthat/test-simulation.R b/tests/testthat/test-simulation.R
new file mode 100644
index 0000000000000000000000000000000000000000..3d29ae51a9f7a4f8ac3f1b1a1634d5f9d91dd14c
--- /dev/null
+++ b/tests/testthat/test-simulation.R
@@ -0,0 +1,60 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+
+# Test case 1: Check if the function returns a data frame
+test_that("getInput2simulation returns a data frame", {
+ list_var <- init_variable()
+ result <- getInput2simulation(list_var)
+ expect_is(result, "data.frame")
+ expected <- data.frame(geneID = c("gene1", "gene1"), label_myVariable = as.factor(c("myVariable1", "myVariable2")), myVariable = c(2,3))
+ expect_equal(result, expected)
+ })
+
+# Test for getCoefficients function
+test_that("getCoefficients returns the correct output", {
+ # Create dummy data
+ n_genes <- 3
+ list_var = init_variable()
+ # Call the function
+ coefficients <- getCoefficients(list_var, list(), list(), n_genes)
+
+ # Check the output
+ expect_equal(nrow(coefficients), n_genes*list_var$myVariable$level)
+ expect_equal(colnames(coefficients), c("geneID", "label_myVariable"))
+})
+
+# Test for getMu_ij_matrix function
+test_that("getMu_ij_matrix returns the correct output", {
+ # Create a dummy coefficients dataframe
+ dtf_coef <- data.frame(geneID = c("Gene1", "Gene1", "Gene1"),
+ label_varA = c("A1", "A2", "A3"),
+ label_varB = c("B1", "B2", "B3"),
+ mu_ij = c(1, 2, 3))
+
+ # Call the function
+ mu_matrix <- getMu_ij_matrix(dtf_coef)
+ # Check the output
+ expect_equal(dim(mu_matrix), c(1, 9))
+
+})
+
+# Test for getSubCountsTable function
+test_that("getSubCountsTable returns the correct output", {
+ # Create dummy data
+ l_genes <- c("gene1", "gene2", "gene3")
+ matx_Muij = data.frame(sple1 = c(1,3,4), sple2 = c(2, 0, 9), sple3 = c(1, 69, 2)) %>% as.matrix()
+ rownames(matx_Muij) <- l_genes
+ matx_dispersion <- matrix(0.5, nrow = 3, ncol = 3)
+ replicateID <- 1
+ l_bool_replication <- c(TRUE, FALSE, TRUE)
+
+ # Call the function
+ subcounts_table <- getSubCountsTable(matx_Muij, matx_dispersion, 1, l_bool_replication)
+
+ # Check the output
+ expect_equal(dim(subcounts_table), c(3, 2))
+ expect_equal(rownames(subcounts_table), l_genes)
+})
+
+
diff --git a/tests/testthat/test-simulation2.R b/tests/testthat/test-simulation2.R
new file mode 100644
index 0000000000000000000000000000000000000000..79662fbfde371c3cfc2d060f269fc9cec74c4b1e
--- /dev/null
+++ b/tests/testthat/test-simulation2.R
@@ -0,0 +1,131 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+test_that("getReplicationMatrix returns the correct replication matrix", {
+ minN <- 2
+ maxN <- 4
+ n_samples <- 3
+ expected <- matrix(c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE, TRUE, FALSE), nrow = maxN)
+
+ set.seed(123)
+ result <- getReplicationMatrix(minN, maxN, n_samples)
+
+ expect_equal(result, expected)
+})
+
+test_that("getSampleID return the correct list of sampleID",{
+ expect_equal(getSampleID(init_variable()), c("myVariable1", "myVariable2"))
+})
+
+# Create a test case for getMu_ij
+test_that("getMu_ij returns the correct output", {
+ # Create a sample coefficient data frame
+ dtf_coef <- data.frame(
+ log_qij = c(1, 9, 0.1),
+ basalExpr = c(2, 3, 4)
+ )
+
+ # Call the getMu_ij function
+ result <- getMu_ij(dtf_coef)
+
+ # Check if the mu_ij column is added
+ expect_true("mu_ij" %in% colnames(result))
+
+ # Check the values of mu_ij
+ #expected_mu_ij <- c(20.08554, 162754.79142 , 60.34029)
+ #expect_equal(result$mu_ij, expected_mu_ij, tolerance = 0.000001)
+})
+
+
+# Create a test case for getLog_qij
+test_that("getLog_qij returns the correct output", {
+ # Create a sample coefficient data frame
+ dtf_coef <- data.frame(
+ beta1 = c(1.2, 2.3, 3.4),
+ beta2 = c(0.5, 1.0, 1.5),
+ non_numeric = c("a", "b", "c")
+ )
+
+ # Call the getLog_qij function
+ result <- getLog_qij(dtf_coef)
+
+ # Check if the log_qij column is added
+ expect_true("log_qij" %in% colnames(result))
+
+ # Check the values of log_qij
+ expected_log_qij <- c(1.7, 3.3, 4.9)
+ expect_equal(result$log_qij, expected_log_qij)
+})
+
+test_that("getCountsTable returns the correct counts table", {
+ mat_mu_ij <- matrix(c(1,2,3,4,5,6), ncol = 3, byrow = T)
+ rownames(mat_mu_ij) <- c("gene1", "gene2")
+ colnames(mat_mu_ij) <- c("sample1", "sample2", "sample3")
+ mat_disp <- matrix(c(0.3,0.3,0.3, 0.5,0.5,0.5), ncol = 3, byrow = T)
+ rownames(mat_disp) <- c("gene1", "gene2")
+ colnames(mat_disp) <- c("sample1", "sample2", "sample3")
+ mat_repl <- matrix(c(TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE), ncol = 3, byrow = T)
+
+ expected_df <- matrix(c(0,0,1,0,0,0,0,1,0,2,34,18,0,0,3,10,7,2), nrow = 2, byrow = T) %>% as.data.frame()
+ rownames(expected_df) <- c("gene1", "gene2")
+ colnames(expected_df) <- c("sample1_1", "sample2_1", "sample3_1", "sample1_2",
+ "sample2_2","sample3_2","sample1_3", "sample2_3" ,"sample3_3")
+
+ set.seed(123)
+ result <- getCountsTable(mat_mu_ij, mat_disp, mat_repl)
+
+ expect_true(is.data.frame(result))
+ expect_equal(colnames(result), colnames(expected_df))
+ expect_equal(rownames(result), rownames(expected_df))
+
+})
+
+
+
+test_that("getSampleMetadata returns expected output", {
+ # Set up input variables
+ list_var <- init_variable()
+ n_genes <- 3
+ replicationMatrix <- matrix(TRUE, nrow = 2, ncol = 2)
+
+ # Run the function
+ result <- getSampleMetadata(list_var, n_genes, replicationMatrix)
+
+ # Define expected output
+ expected_colnames <- c("myVariable", "sampleID")
+ expect_equal(colnames(result), expected_colnames)
+
+ # Check the output class
+ expect_true(is.data.frame(result))
+
+ # check nrow output
+ expect_equal(nrow(result), 4)
+
+})
+
+
+test_that(".replicateByGroup return the correct ouptut", {
+ df <- data.frame(group = c("A", "B"), value = c(1, 2))
+ result <- .replicateByGroup(df, "group", c(2, 3))
+
+ expect <- data.frame(group = c("A", "A", "B", "B", "B"),
+ value = c(1, 1, 2,2,2),
+ sampleID = c("_1", "_2", "_1", "_2", "_3" ))
+ expect_equal(result, expect)
+
+})
+
+
+test_that("getDispersionMatrix returns the correct dispersion matrix", {
+ n_genes = 3
+ list_var = init_variable()
+ dispersion <- 1:3
+ expected <- matrix(1:3,byrow = F, nrow = 3, ncol = 2)
+ rownames(expected) <- c("gene1", "gene2", "gene3")
+ colnames(expected) <- c("myVariable1", "myVariable2")
+ result <- getDispersionMatrix(list_var, n_genes, dispersion )
+ expect_equal(result, expected)
+})
+
+
+
diff --git a/tests/testthat/test-simulation_initialization.R b/tests/testthat/test-simulation_initialization.R
new file mode 100644
index 0000000000000000000000000000000000000000..b0c4b1116f1fe43ad1ec68944abab47c137e34de
--- /dev/null
+++ b/tests/testthat/test-simulation_initialization.R
@@ -0,0 +1,131 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+test_that("endsWithDigit returns the correct result", {
+ expect_true(endsWithDigit("abc123"))
+ expect_false(endsWithDigit("xyz"))
+})
+
+test_that("removeDigitsAtEnd removes digits at the end of a string", {
+ expect_equal(removeDigitsAtEnd("abc123"), "abc")
+ expect_equal(removeDigitsAtEnd("xyz"), "xyz")
+})
+
+
+test_that("init_variable initializes a variable correctly", {
+ # Test case 1: Initialize a variable with default parameters
+ list_var <- init_variable()
+ expect_true("myVariable" %in% names(list_var))
+ expect_equal(nrow(list_var$myVariable$data), 2)
+
+ # Test case 2: Initialize a variable with custom parameters
+ list_var <- init_variable(name = "custom_variable", mu = c(1, 2, 3), sd = 0.5, level = 3)
+ expect_true("customvariable" %in% names(list_var))
+ expect_equal(nrow(list_var$customvariable$data), 3)
+})
+
+test_that("inputs_checking performs input validation", {
+
+ # Test case 1: Invalid inputs - sd is NA but mu has unique values
+ expect_error(inputs_checking(list_var = c(), name = "myVariable", mu = 2, sd = NA, level = 2))
+
+ # Test case 2: Invalid inputs - empty name
+ expect_error(inputs_checking(list_var = c(), name = "", mu = 2, sd = NA, level = 2))
+
+ # Test case 3: Invalid inputs - non-numeric mu
+ expect_error(inputs_checking(list_var = c(), name = "myVariable", mu = "invalid", sd = NA, level = 2))
+
+ # Test case 4: Invalid inputs - non-numeric sd
+ expect_error(inputs_checking(list_var = c(), name = "myVariable", mu = 2, sd = "invalid", level = 2))
+
+ # Test case 5: Invalid inputs - level less than 2
+ expect_error(inputs_checking(list_var = c(), name = "myVariable", mu = 2, sd = NA, level = 1))
+
+ # Test case 6: Invalid inputs - mu and level have different lengths
+ expect_error(inputs_checking(list_var = c(), name = "myVariable", mu = c(1, 2, 3), sd = NA, level = 2))
+
+ # Test case 7: Valid inputs
+ expect_silent(inputs_checking(list_var = c(), name = "myVariable", mu = c(1, 2, 3), sd = NA, level = 3))
+})
+
+
+
+test_that("already_init_variable checks if a variable is already initialized", {
+ list_var <- init_variable()
+
+ # Test case 1: Variable not initialized
+ list_var <- init_variable(name = "custom_variable", mu = c(2, 3), sd = NA, level = 2)
+ expect_true(already_init_variable(list_var, "customvariable"))
+
+ # Test case 2: Variable already initialized
+ expect_false(already_init_variable(list_var, "myVariable"))
+
+})
+
+test_that("fillInVariable fills in variable correctly", {
+ # Test case 1: Effects given by user
+ sub_obj <- fillInVariable("myVariable", c(1, 2, 3), NA, NA)
+ expect_equal(sub_obj$level, 3)
+ expect_equal(ncol(sub_obj$data), 2)
+
+ # Test case 2: Effects simulated using mvrnorm
+ sub_obj <- fillInVariable("myVariable", 2, 0.5, 3)
+ expect_equal(sub_obj$level, 3)
+ expect_equal(sub_obj$sd, 0.5)
+ expect_equal(sub_obj$mu, 2)
+})
+
+test_that("build_sub_obj_return_to_user returns the expected output", {
+ level <- 3
+ metaData <- paste("label", 1:level, sep = "_")
+ effectsGivenByUser <- c(2, 3, 4)
+ col_names <- c("metadata", "effects")
+
+ result <- build_sub_obj_return_to_user(level, metaData, effectsGivenByUser, col_names)
+
+ expect_equal(result$level, level)
+ expect_identical(result$data$metadata, metaData)
+ expect_identical(result$data$effects, effectsGivenByUser)
+
+
+})
+
+test_that("generateGridCombination_fromListVar returns expected output", {
+ result <- generateGridCombination_fromListVar(init_variable())
+ expect <- data.frame(label_myVariable = c("myVariable1", "myVariable2"))
+ expect_equal(nrow(result), nrow(expect))
+ expect_equal(ncol(result), ncol(expect))
+})
+
+test_that("add_interaction adds an interaction between variables", {
+ list_var <- init_variable(name = "varA", mu = 1, sd = 1, level = 2)
+ list_var <- init_variable(list_var, name = "varB", mu = 2, sd = 1, level = 3)
+ list_var <- add_interaction(list_var, between_var = c("varA", "varB"), mu = 0.5, sd = 3)
+ expect_true("varA:varB" %in% names(list_var$interactions))
+})
+
+test_that("add_interaction throws an error for invalid variables", {
+ list_var <- init_variable(name = "varA", mu = 1, sd = 1, level = 2)
+ expect_error(add_interaction(list_var, between_var = c("varA", "varB"), mu = 0.5, sd = NA))
+})
+
+
+test_that("getNumberOfCombinationsInInteraction calculates the number of combinations", {
+ list_var <- init_variable(name = "varA", mu = 1, sd = 1, level = 2)
+ list_var <- init_variable(list_var, name = "varB", mu = 2, sd = 1, level = 3)
+ expect_equal(getNumberOfCombinationsInInteraction(list_var, c("varA", "varB")), 6)
+})
+
+test_that("getLabels generates labels for variables", {
+ labels <- getLabels(c("varA", "varB"), c(2, 3))
+ expect_equal(length(labels), 2)
+ expect_equal(length(labels[[1]]), 2)
+ expect_equal(length(labels[[2]]), 3)
+})
+
+test_that("getGridCombination generates a grid of combinations", {
+ labels <- list(A = c("A1", "A2"), B = c("B1", "B2", "B3"))
+ grid_combination <- getGridCombination(labels)
+ expect_equal(dim(grid_combination), c(6, 2))
+})
+
diff --git a/tests/testthat/test-simulationreport.R b/tests/testthat/test-simulationreport.R
new file mode 100644
index 0000000000000000000000000000000000000000..d0d6694d18dc636457dbf85e0886135cc9700d4a
--- /dev/null
+++ b/tests/testthat/test-simulationreport.R
@@ -0,0 +1,28 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+
+# Test case 1: Testing with a sample data frame
+test_that("Generating a formatted table works correctly", {
+ sample_data <- data.frame(
+ Name = c("Alice", "Bob", "Charlie"),
+ Age = c(25, 30, 28)
+ )
+
+ table_grob <- getGrobTable(sample_data)
+
+ expect_s3_class(table_grob, "gtable")
+})
+
+# Test case 4: Testing with non-numeric values
+test_that("Handling non-numeric values in the data frame", {
+ non_numeric_data <- data.frame(
+ Name = c("Alice", "Bob", "Charlie"),
+ Age = c(25, "N/A", 28)
+)
+
+ table_grob <- getGrobTable(non_numeric_data)
+
+ expect_s3_class(table_grob, "gtable")
+})
+
diff --git a/tests/testthat/test-tidy_glmmtmb.R b/tests/testthat/test-tidy_glmmtmb.R
new file mode 100644
index 0000000000000000000000000000000000000000..2b7a36d9bc2e129aba20eacd9e043b5d032b11d2
--- /dev/null
+++ b/tests/testthat/test-tidy_glmmtmb.R
@@ -0,0 +1,156 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+test_that("extract_fixed_effect returns the correct results for glmmTMB models", {
+ data(iris)
+ # Créer un modèle glmmTMB avec les données iris (exemple)
+ model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length + (1|Species), data = iris)
+
+ # Appeler la fonction extract_fixed_effect sur le modèle
+ result <- extract_fixed_effect(model)
+
+ # Check les résultats attendus
+ expect_s3_class(result, "data.frame")
+ expect_equal(result$effect, c("fixed", "fixed", "fixed"))
+ expect_equal(result$component , c("cond", "cond", "cond"))
+ expect_equal(result$term , c("(Intercept)", "Sepal.Width", "Petal.Length"))
+
+})
+
+
+test_that("getTidyGlmmTMB returns the correct results for glmmTMB models", {
+ data(iris)
+ # Créer un modèle glmmTMB avec les données iris (exemple)
+ model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length, data = iris)
+ tidy_summary <- getTidyGlmmTMB(glm_TMB = model, ID = "Model1")
+
+ # Check les résultats attendus
+ expect_s3_class(tidy_summary, "data.frame")
+ expect_equal(tidy_summary$effect, c("fixed", "fixed", "fixed"))
+ expect_equal(tidy_summary$component , c("cond", "cond", "cond"))
+ expect_equal(tidy_summary$term , c("(Intercept)", "Sepal.Width", "Petal.Length"))
+ expect_equal(tidy_summary$ID , c("Model1", "Model1", "Model1"))
+
+ #MODEL == NULL
+ tidy_summary <- getTidyGlmmTMB(glm_TMB = NULL, ID = "Model1")
+ expect_equal(tidy_summary, NULL)
+})
+
+
+test_that("build_missingColumn_with_na returns the correct results", {
+ df <- data.frame(effect = "fixed", term = "Sepal.Length", estimate = 0.7)
+ df_with_na <- build_missingColumn_with_na(df)
+ expected_df <- data.frame(effect = "fixed",
+ term = "Sepal.Length",
+ estimate = 0.7,
+ component = NA,
+ group = NA,
+ std.error = NA,
+ statistic = NA,
+ p.value = NA)
+
+ expect_equal(df_with_na, expected_df)
+})
+
+
+test_that("removeDuplicatedWord returns expected output", {
+ words <- c("hellohello", "worldworld", "programmingprogramming", "R isis great")
+ cleaned_words <- removeDuplicatedWord(words)
+ expect_equal(cleaned_words, c("hello", "world", "programming", "R is great"))
+})
+
+
+
+test_that("correlation_matrix_2df returns expected output",{
+
+ mat <- matrix(c(1, 0.7, 0.5, 0.7, 1, 0.3, 0.5, 0.3, 1), nrow = 3, dimnames = list(c("A", "B", "C"), c("A", "B", "C")))
+ df_corr <- correlation_matrix_2df(mat)
+ df_expected <- data.frame(estimate = c(0.7, 0.5, 0.3),
+ term = c("cor__A.B", "cor__A.C", "cor__B.C"))
+ expect_equal(df_corr, df_expected)
+})
+
+
+
+test_that("wrapper_var_cor returns expected output",{
+ data(iris)
+ model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length + (1|Species), data = iris, family = gaussian)
+ var_cor <- summary(model)$varcor$cond
+ ran_pars_df <- wrapper_var_cor(var_cor, "Species")
+ expected_l = list(data.frame(estimate = 0.4978083, term = "sd_(Intercept)",
+ component = "Species", effect = "ran_pars", group = "Species"))
+ expect_equal(ran_pars_df , expected_l, tolerance = 0.0000001)
+})
+
+
+test_that("extract_ran_pars returns expected output",{
+ model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length + (1|Species),
+ data = iris, family = gaussian)
+ random_params <- extract_ran_pars(model)
+
+ expected_df = data.frame(estimate = 0.4978083, term = "sd_(Intercept)",
+ component = "cond", effect = "ran_pars", group = "Species")
+ expect_equal(random_params , expected_df, tolerance = 0.0000001)
+})
+
+
+test_that("renameColumns returns expected output",{
+ df <- data.frame(Estimate = c(1.5, 2.0, 3.2),
+ Std..Error = c(0.1, 0.3, 0.2),
+ z.value = c(3.75, 6.67, 4.90),
+ Pr...z.. = c(0.001, 0.0001, 0.002))
+
+ new_colnames <- c("estimate", "std.error", "statistic", "p.value")
+ renamed_df <- renameColumns(df, old_names = c("Estimate", "Std..Error", "z.value", "Pr...z.."),
+ new_names = new_colnames)
+ expect_equal(colnames(renamed_df),c("estimate", "std.error", "statistic", "p.value"))
+ expect_equal(dim(renamed_df), dim(df))
+})
+
+
+test_that("reorderColumns returns expected output",{
+ df <- data.frame(A = 1:3, B = 4:6, C = 7:9)
+ # Define the desired column order
+ columnOrder <- c("B", "C", "A")
+ # Reorder the columns of the dataframe
+ df_reorder <- reorderColumns(df, columnOrder)
+ expect_equal(colnames(df_reorder), columnOrder)
+ expect_equal(dim(df_reorder), dim(df))
+
+})
+
+
+test_that("tidy_tmb returns expected output",{
+ model1 <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length + (1 | Species), data = iris)
+ model2 <- glmmTMB::glmmTMB(Petal.Length ~ Sepal.Length + Sepal.Width + (1 | Species), data = iris)
+ model_list <- list(Model1 = model1, Model2 = model2)
+ result <- tidy_tmb(model_list)
+ expect_equal(unique(result$ID), c("Model1", "Model2"))
+ expect_equal(unique(result$effect), c("fixed", "ran_pars"))
+ expect_equal(unique(result$component), "cond")
+ expect_equal(unique(result$term), c("(Intercept)", "Sepal.Width", "Petal.Length", "sd_(Intercept)", "Sepal.Length"))
+ expect_true("estimate" %in% colnames(result))
+ expect_true("std.error" %in% colnames(result))
+ expect_true("statistic" %in% colnames(result))
+ expect_true("p.value" %in% colnames(result))
+
+
+ # zi component
+ model2 <- glmmTMB::glmmTMB(Petal.Length ~ Sepal.Length + Sepal.Width + (1 | Species), data = iris, ziformula = ~1)
+ model_list <- list(Model1 = model1, Model2 = model2)
+ result_withZi <- tidy_tmb(model_list)
+ expect_equal(dim(result_withZi)[1], dim(result)[1] + 1 )
+ expect_equal(unique(result_withZi$component), c("cond", "zi"))
+
+ ## unique obect in list
+ model <- glmmTMB::glmmTMB(Sepal.Length ~ Sepal.Width + Petal.Length + (1|Species), data = iris)
+ result <- tidy_tmb(model)
+ expect_true("effect" %in% colnames(result))
+ expect_true("component" %in% colnames(result))
+ expect_true("group" %in% colnames(result))
+ expect_true("term" %in% colnames(result))
+ expect_true("estimate" %in% colnames(result))
+ expect_true("std.error" %in% colnames(result))
+ expect_true("statistic" %in% colnames(result))
+ expect_true("p.value" %in% colnames(result))
+})
diff --git a/tests/testthat/test-updatefitmodel.R b/tests/testthat/test-updatefitmodel.R
new file mode 100644
index 0000000000000000000000000000000000000000..b7f15d5305acac42d061390f76b3bdc3e73c7e0d
--- /dev/null
+++ b/tests/testthat/test-updatefitmodel.R
@@ -0,0 +1,138 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+# Test updateParallel function
+test_that("updateParallel function returns correct results", {
+ # Load the required data
+ data(iris)
+ groups <- unique(iris$Species)
+ group_by <- "Species"
+ formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+ 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)
+ expect_is(results, "list")
+ expect_equal(length(results), length(fitted_models))
+ expect_is(results$setosa, "glmmTMB")
+
+ #uncorrect formula
+ new_formula <- Sepal.Length ~ blabla
+ expect_error(updateParallel(new_formula, fitted_models, n.cores = 1))
+
+ # Additional parameters:
+ #change family + formula
+ new_formula <- Sepal.Length ~ Sepal.Width
+ updated_model <- suppressWarnings(updateParallel(l_tmb = fitted_models,
+ formula = new_formula,
+ n.cores = 1,
+ family = glmmTMB::nbinom1(link = "log") ))
+ expect_s3_class(updated_model$setosa$call$family, "family")
+ expect_equal(updated_model$setosa$call$formula, new_formula)
+ #change control settings
+ updated_model <- suppressWarnings(updateParallel(l_tmb = fitted_models,
+ formula = new_formula,
+ family = glmmTMB::nbinom1(link = "log"),
+ n.cores = 1,
+ control = glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,
+ eval.max=1e3))))
+ expect_equal(updated_model$setosa$call$control, glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,eval.max=1e3)))
+
+ # Update an updated model
+ updated_updated_model <- suppressWarnings(updateParallel(l_tmb = updated_model,
+ formula = new_formula,
+ n.cores = 1,
+ family = glmmTMB::ziGamma(link = "inverse")))
+ expect_s3_class(updated_updated_model$setosa$call$family, "family")
+})
+
+# Test .parallel_update function
+test_that(".parallel_update function returns correct results", {
+# Load the required data
+ data(iris)
+ groups <- unique(iris$Species)
+ group_by <- "Species"
+ formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+ fitted_models <- fitModelParallel(formula, iris, group_by, n.cores = 1)
+ new_formula <- Sepal.Length ~ Sepal.Width
+ results <- .parallel_update(new_formula, fitted_models, n.cores = 1)
+ expect_is(results, "list")
+ expect_equal(length(results), length(fitted_models))
+ expect_is(results$setosa, "glmmTMB")
+
+ #uncorrect formula
+ new_formula <- Sepal.Length ~ blabla
+ results <- .parallel_update(new_formula, fitted_models, n.cores = 1)
+ expect_is(results, "list")
+ expect_equal(length(results), length(fitted_models))
+ expect_equal(results$setosa, NULL)
+
+ # Additional parameters:
+ #change family + formula
+ new_formula <- Sepal.Length ~ Sepal.Width
+ updated_model <- suppressWarnings(.parallel_update(l_tmb = fitted_models,
+ formula = new_formula,
+ n.cores = 1,
+ family = glmmTMB::nbinom1(link = "log") ))
+ expect_s3_class(updated_model$setosa$call$family, "family")
+ expect_equal(updated_model$setosa$call$formula, new_formula)
+ #change control
+ updated_model <- suppressWarnings(.parallel_update(l_tmb = fitted_models,
+ formula = new_formula,
+ n.cores = 1,
+ family = glmmTMB::nbinom1(link = "log"),
+ control = glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,
+ eval.max=1e3))))
+ expect_equal(updated_model$setosa$call$control, glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,eval.max=1e3)))
+})
+
+# Test fitUpdate function
+test_that("fitUpdate function returns correct results", {
+ #Load the required data
+ data(iris)
+ groups <- unique(iris$Species)
+ group_by <- "Species"
+ formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+ fitted_models <- fitModelParallel(formula, iris, group_by, n.cores = 1)
+ new_formula <- Sepal.Length ~ Sepal.Width
+
+ updated_model <- fitUpdate(fitted_models[[1]], new_formula)
+ expect_is(updated_model, "glmmTMB")
+
+ # Additional parameters:
+ #change family + formula
+ updated_model <- suppressWarnings(fitUpdate(fitted_models[[1]], new_formula,
+ family = glmmTMB::nbinom1(link = "log") ))
+ expect_s3_class(updated_model$call$family, "family")
+ expect_equal(updated_model$call$formula, new_formula)
+ #change control
+ updated_model <- suppressWarnings(fitUpdate(fitted_models[[1]],
+ new_formula,
+ family = glmmTMB::nbinom1(link = "log"),
+ control = glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,
+ eval.max=1e3))))
+ expect_equal(updated_model$call$control, glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,eval.max=1e3)))
+
+})
+
+
+# Test launchUpdate function
+test_that("launchUpdate function returns correct results", {
+ data(iris)
+ groups <- unique(iris$Species)
+ group_by <- "Species"
+ formula <- Sepal.Length ~ Sepal.Width + Petal.Length
+ fitted_models <- fitModelParallel(formula, iris, group_by, n.cores = 1)
+ new_formula <- Sepal.Length ~ Sepal.Width
+ updated_model <- launchUpdate(fitted_models[[1]], new_formula)
+ expect_is(updated_model, "glmmTMB")
+ # Additional parameters:
+ #change family + formula
+ updated_model <- launchUpdate(fitted_models[[1]], new_formula, family = glmmTMB::nbinom1(link = "log") )
+ expect_s3_class(updated_model$call$family, "family")
+ expect_equal(updated_model$call$formula, new_formula)
+ #change control
+ updated_model <- launchUpdate(fitted_models[[1]], new_formula, family = glmmTMB::nbinom1(link = "log"),
+ control = glmmTMB::glmmTMBControl(optimizer=optim, optArgs=list(method="BFGS")))
+ expect_equal(updated_model$call$control, glmmTMB::glmmTMBControl(optimizer=optim, optArgs=list(method="BFGS")))
+
+})
+
diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R
new file mode 100644
index 0000000000000000000000000000000000000000..9aaf15c6080753e4c13fd037be810139847617f6
--- /dev/null
+++ b/tests/testthat/test-utils.R
@@ -0,0 +1,31 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+# Test unitaires pour la fonction join_dtf
+test_that("join_dtf réalise la jointure correctement", {
+ # Création de données de test
+ df1 <- data.frame(id = 1:5, value = letters[1:5])
+ df2 <- data.frame(id = 1:5, category = LETTERS[1:5])
+
+ # Exécution de la fonction
+ result <- join_dtf(df1, df2, "id", "id")
+
+ # Vérification des résultats
+ expect_true(is.data.frame(result))
+ expect_equal(nrow(result), 5)
+ expect_equal(ncol(result), 3)
+ expect_equal(names(result), c("id", "value", "category"))
+ expect_true(all.equal(result$id, df1$id))
+ expect_true(all.equal(result$id, df2$id))
+})
+
+
+test_that("clean_variable_name correctly removes digits, spaces, and special characters", {
+ expect_equal(clean_variable_name("my variable name"), "myvariablename")
+ expect_equal(clean_variable_name("variable_1"), "variable")
+ expect_equal(clean_variable_name("^spec(ial#chars! "), "specialchars")
+})
+
+test_that("clean_variable_name handles reserved names properly", {
+ expect_error(clean_variable_name("interactions"))
+ expect_error(clean_variable_name("correlations"))
+})
diff --git a/tests/testthat/test-waldtest.R b/tests/testthat/test-waldtest.R
new file mode 100644
index 0000000000000000000000000000000000000000..9aad7dab1a557111eea090a4ca41acda3ad5d785
--- /dev/null
+++ b/tests/testthat/test-waldtest.R
@@ -0,0 +1,62 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+# Test unitaires
+test_that("wald_test performs correct tests", {
+ # Test with "greater" alternative
+ result_greater <- wald_test(estimation = 0.1, std_error = 0.02, reference_value = 0.05, alternative = "greater")
+ expect_equal(result_greater$p.value, 1 - pnorm((0.1 - 0.05) / 0.02, mean = 0, sd = 1, lower.tail = TRUE))
+
+ # Test with "less" alternative
+ result_less <- wald_test(estimation = 0.1, std_error = 0.02, reference_value = 0.05, alternative = "less")
+ expect_equal(result_less$p.value, pnorm((0.1 - 0.05) / 0.02, mean = 0, sd = 1, lower.tail = TRUE))
+
+ # Test with "greaterAbs" alternative
+ result_greaterAbs <- wald_test(estimation = 0.1, std_error = 0.02, reference_value = 0.05, alternative = "greaterAbs")
+ expect_equal(result_greaterAbs$p.value, (2 * (1 - pnorm((abs(0.1) - 0.05) / 0.02, mean = 0, sd = 1, lower.tail = TRUE))))
+
+ # Test with invalid alternative
+ expect_error(wald_test(estimation = 0.1, std_error = 0.02, reference_value = 0.05, alternative = "invalid"))
+})
+
+
+
+test_that("results function performs statistical tests correctly", {
+ # Charger les données iris pour les tests
+ data(iris)
+ # Fit models and perform statistical tests
+ model_list <- fitModelParallel(formula = Sepal.Length ~ Sepal.Width + Petal.Length,
+ data = iris, group_by = "Species", n.cores = 1)
+ results_df <- tidy_results(model_list, coeff_threshold = 0.1, alternative_hypothesis = "greater")
+
+ # Vérifier que les colonnes 'statistic' et 'p.value' ont été ajoutées au dataframe
+ expect_true("statistic" %in% colnames(results_df))
+ expect_true("p.value" %in% colnames(results_df))
+
+ # Vérifier que les tests statistiques ont été effectués correctement
+ # Ici, nous ne vérifierons pas les valeurs exactes des résultats car elles peuvent varier en fonction de la machine et des packages utilisés.
+ # Nous nous assurerons seulement que les résultats sont dans le format attendu.
+ expect_is(results_df$statistic, "numeric")
+ expect_is(results_df$p.value, "numeric")
+ expect_is(results_df$p.adj, "numeric")
+
+
+ # Vérifier que les p-values ne dépassent pas 1
+ expect_true(all(results_df$p.value <= 1))
+
+ # Vérifier que les valeurs sont correctes pour les colonnes 'statistic' et 'p.value'
+ # (Cela dépend des données iris et des modèles ajustés)
+ # Remarque : Vous devrez peut-être ajuster ces tests en fonction des valeurs réelles des données iris et des modèles ajustés.
+ expect_true(all(!is.na(results_df$statistic)))
+ expect_true(all(!is.na(results_df$p.value)))
+
+ # Vérifier que le seuil des coefficients et l'hypothèse alternative sont correctement appliqués
+ # Ici, nous nous attendons à ce que les p-values soient uniquement pour les coefficients dépassant le seuil
+ expect_true(all(ifelse(abs(results_df$estimate) > 0.1, results_df$p.value <= 1, results_df$p.value == 1)))
+ expect_true(all(ifelse(abs(results_df$estimate) > 0.1, results_df$p.adj <= 1, results_df$p.adj == 1)))
+
+ })
+
+
+
+
diff --git a/tests/testthat/test-wrapperdeseq2.R b/tests/testthat/test-wrapperdeseq2.R
new file mode 100644
index 0000000000000000000000000000000000000000..cee2492d4be8daa60c577b944701c9afac69c911
--- /dev/null
+++ b/tests/testthat/test-wrapperdeseq2.R
@@ -0,0 +1,121 @@
+# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+
+
+
+test_that("get_inference returns a data frame with correct columns", {
+ # Create a sample dds_full data frame
+ N_GENES = 100
+ MAX_REPLICATES = 5
+ MIN_REPLICATES = 5
+ ## --init variable
+ input_var_list <- init_variable( name = "genotype", mu = 12, sd = 0.1, level = 3) %>%
+ init_variable(name = "environment", mu = c(0,1), NA , level = 2)
+
+ mock_data <- mock_rnaseq(input_var_list, N_GENES, MIN_REPLICATES, max_replicates = MAX_REPLICATES)
+ dds <- DESeq2::DESeqDataSetFromMatrix(mock_data$counts , mock_data$metadata, ~ genotype + environment)
+ dds <- DESeq2::DESeq(dds, quiet = TRUE)
+ dds_full <- S4Vectors::mcols(dds) %>% as.data.frame()
+
+ # Call the function
+ inference_results <- get_inference(dds_full, lfcThreshold = 0.5, altHypothesis = "greater", correction_method = "BH")
+
+ # Check if the returned object is a data frame
+ expect_true(is.data.frame(inference_results))
+
+ # Check if the data frame contains the correct columns
+ expect_true("ID" %in% colnames(inference_results))
+ expect_true("estimate" %in% colnames(inference_results))
+ expect_true("std.error" %in% colnames(inference_results))
+ expect_true("term" %in% colnames(inference_results))
+ expect_true("effect" %in% colnames(inference_results))
+ expect_true("statistic" %in% colnames(inference_results))
+ expect_true("p.value" %in% colnames(inference_results))
+ expect_true("p.adj" %in% colnames(inference_results))
+})
+
+
+
+
+
+
+test_that("getEstimate_df function works correctly", {
+
+ # Create a sample dds_full data frame
+ N_GENES = 100
+ MAX_REPLICATES = 5
+ MIN_REPLICATES = 5
+ ## --init variable
+ input_var_list <- init_variable( name = "genotype", mu = 12, sd = 0.1, level = 3) %>%
+ init_variable(name = "environment", mu = c(0,1), NA , level = 2)
+
+ mock_data <- mock_rnaseq(input_var_list, N_GENES, MIN_REPLICATES, max_replicates = MAX_REPLICATES)
+ dds <- DESeq2::DESeqDataSetFromMatrix(mock_data$counts , mock_data$metadata, ~ genotype + environment)
+ dds <- DESeq2::DESeq(dds, quiet = TRUE)
+ dds_full <- S4Vectors::mcols(dds) %>% as.data.frame()
+
+ # Call the function
+ estimate_df_long <- getEstimate_df(dds_full)
+
+ # Check if the resulting data frame has the expected structure
+ expect_true("ID" %in% colnames(estimate_df_long))
+ expect_true("term" %in% colnames(estimate_df_long))
+ expect_true("estimate" %in% colnames(estimate_df_long))
+})
+
+
+
+# Define a test context
+test_that("getSE_df function works correctly", {
+
+ # Create a sample dds_full data frame
+ N_GENES = 100
+ MAX_REPLICATES = 5
+ MIN_REPLICATES = 5
+ ## --init variable
+ input_var_list <- init_variable( name = "genotype", mu = 12, sd = 0.1, level = 3) %>%
+ init_variable(name = "environment", mu = c(0,1), NA , level = 2)
+
+ mock_data <- mock_rnaseq(input_var_list, N_GENES, MIN_REPLICATES, max_replicates = MAX_REPLICATES)
+ dds <- DESeq2::DESeqDataSetFromMatrix(mock_data$counts , mock_data$metadata, ~ genotype + environment)
+ dds <- DESeq2::DESeq(dds, quiet = TRUE)
+ dds_full <- S4Vectors::mcols(dds) %>% as.data.frame()
+
+ # Call the function
+ SE_df_long <- getSE_df(dds_full)
+
+ # Check if the resulting data frame has the expected structure
+ expect_true("ID" %in% colnames(SE_df_long))
+ expect_true("term" %in% colnames(SE_df_long))
+ expect_true("std.error" %in% colnames(SE_df_long))
+})
+
+
+# Define a test context
+test_that("wrapperDESeq2 function works correctly", {
+
+ # Create a sample dds_full data frame
+ N_GENES = 100
+ MAX_REPLICATES = 5
+ MIN_REPLICATES = 5
+ ## --init variable
+ input_var_list <- init_variable( name = "genotype", mu = 12, sd = 0.1, level = 3) %>%
+ init_variable(name = "environment", mu = c(0,1), NA , level = 2)
+
+ mock_data <- mock_rnaseq(input_var_list, N_GENES, MIN_REPLICATES, max_replicates = MAX_REPLICATES)
+ dds <- DESeq2::DESeqDataSetFromMatrix(mock_data$counts , mock_data$metadata, ~ genotype + environment)
+ dds <- DESeq2::DESeq(dds, quiet = TRUE)
+ deseq2_wrapped <- wrapper_DESeq2(dds, 0.2, "greaterAbs")
+
+ expect_true(is.list(deseq2_wrapped))
+
+ # Check if the resulting data frame has the expected structure
+ expect_true("ID" %in% colnames(deseq2_wrapped$fixEff))
+ expect_true("term" %in% colnames(deseq2_wrapped$fixEff))
+ expect_true("std.error" %in% colnames(deseq2_wrapped$fixEff))
+ expect_true("estimate" %in% colnames(deseq2_wrapped$fixEff))
+ expect_true("statistic" %in% colnames(deseq2_wrapped$fixEff))
+ expect_true("p.value" %in% colnames(deseq2_wrapped$fixEff))
+ expect_true("p.adj" %in% colnames(deseq2_wrapped$fixEff))
+
+})
+
diff --git a/vignettes/figs/htrfit_workflow.png b/vignettes/figs/htrfit_workflow.png
new file mode 100644
index 0000000000000000000000000000000000000000..935352d8fdad6729dcb76c3d1b560dcb5afd5b01
Binary files /dev/null and b/vignettes/figs/htrfit_workflow.png differ
diff --git a/vignettes/htrfit.Rmd b/vignettes/htrfit.Rmd
new file mode 100644
index 0000000000000000000000000000000000000000..38619891eaecd9b971fc664e0b7ab094db9d12f4
--- /dev/null
+++ b/vignettes/htrfit.Rmd
@@ -0,0 +1,521 @@
+---
+title: "HTRfit"
+output: rmarkdown::html_vignette
+vignette: >
+ %\VignetteIndexEntry{htrfit}
+ %\VignetteEngine{knitr::rmarkdown}
+ %\VignetteEncoding{UTF-8}
+---
+
+```{r, include = FALSE}
+knitr::opts_chunk$set(
+ collapse = TRUE,
+ comment = "#>"
+)
+```
+
+```{r setup}
+devtools::load_all()
+library(HTRfit)
+```
+
+<!-- WARNING - This vignette is generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand -->
+
+<!-- Run this 'development' chunk -->
+<!-- Store every call to library() that you need to explore your functions -->
+
+
+<!--
+ You need to run the 'description' chunk in the '0-dev_history.Rmd' file before continuing your code there.
+
+If it is the first time you use {fusen}, after 'description', you can directly run the last chunk of the present file with inflate() inside.
+-->
+
+
+# High-Throughput RNA-seq model fit
+
+In the realm of RNAseq analysis, various key experimental parameters play a crucial role in influencing the statistical power to detect expression changes. Parameters such as sequencing depth, the number of replicates, and more have a significant impact. To navigate the selection of optimal values for these experimental parameters, we introduce a comprehensive statistical framework known as **HTRfit**, underpinned by computational simulation. **HTRfit** serves as a versatile tool, not only for simulation but also for conducting differential expression analysis. It facilitates this analysis by fitting Generalized Linear Models (GLMs) with multiple variables, which could encompass genotypes, environmental factors, and more. These GLMs are highly adaptable, allowing the incorporation of fixed effects, mixed effects, and interactions between variables.
+
+
+
+# Initialize variable to simulate
+
+The `init_variable()` function, which is a key tool for defining the variables in your experimental design. You can specify the variables' names and the size of the effects involved. By manually setting the effect of a variable, you make it a fixed effect, while random effect definitions can make it either fixed or mixed.
+
+
+## Manually init my first variable
+
+The `init_variable()` function allows for precise control over the variables in your experimental design.
+In this example, we manually initialize **varA** with specifics size effects (mu) and levels.
+
+
+
+```{r example-init_variable_man, warning = FALSE, message = FALSE}
+input_var_list <- init_variable( name = "varA", mu = c(0.2, 4, -3), level = 3)
+```
+
+## Randomly init my first variable
+
+Alternatively, you can randomly initialize **varA** by specifying a mean (mu) and standard deviation (sd).
+This introduces variability into **varA**, making it either a fixed or mixed effect in your design.
+
+
+```{r example-init_variable_rand, warning = FALSE, message = FALSE}
+input_var_list <- init_variable( name = "varA", mu = 10, sd = 0.2, level = 5)
+```
+
+## Randomly init several variables
+
+You can also initialize multiple variables, such as **varA** and **varB**, with random values.
+This flexibility allows you to create diverse experimental designs.
+
+
+```{r example-init_variable_mult, warning = FALSE, message = FALSE}
+input_var_list <- init_variable( name = "varA", mu = 10, sd = 0.2, level = 5) %>%
+ init_variable( name = "varB", mu = -3, sd = 0.34, level = 2)
+```
+
+## Add interaction between variable
+
+Similarly to `init_variable()`, `add_interaction()` allow to init an interaction between variable.
+
+In this example, we initialize **varA** and **varB**, and create an interaction between **varA**, and **varB** using `add_interaction()`.
+
+
+```{r example-add_interaction, warning = FALSE, message = FALSE}
+input_var_list <- init_variable( name = "varA", mu = 3, sd = 0.2, level = 2) %>%
+ init_variable( name = "varB", mu = 2, sd = 0.43, level = 2) %>%
+ add_interaction( between_var = c("varA", "varB"), mu = 0.44, sd = 0.2)
+```
+
+## Initialized a complex design
+
+Interactions can involve a maximum of three variables, such as **varA**, **varB**, and **varC**.
+
+
+```{r example-add_interaction_complex, eval = FALSE, message = FALSE, warning = FALSE, include = TRUE}
+## -- example not evaluate in the vignette
+input_var_list <- init_variable( name = "varA", mu = 5, sd = 0.2, level = 2) %>%
+ init_variable( name = "varB", mu = 1, sd = 0.78, level = 2) %>%
+ init_variable( name = "varC", mu = c(2, 3), sd = NA, level = 2) %>%
+ add_interaction( between_var = c("varA", "varC"), mu = 0.44, sd = 0.2) %>%
+ add_interaction( between_var = c("varA", "varB"), mu = 0.43, sd = 0.37) %>%
+ add_interaction( between_var = c("varB", "varC"), mu = -0.33, sd = 0.12) %>%
+ add_interaction( between_var = c("varA", "varB" ,"varC"), mu = 0.87, sd = 0.18)
+```
+
+# Simulate RNAseq data
+
+In this section, you will explore how to generate RNAseq data based on the previously defined input variables. The `mock_rnaseq()` function enables you to manage parameters in your RNAseq design, including the number of genes, the minimum and maximum number of replicates within your experimental setup. You can also adjust the sequencing depth, the basal gene expression, and the gene dispersion used for simulating counts.
+
+
+## Minimal example
+
+```{r example-mock_rnaseq_min, warning = FALSE, message = FALSE}
+## -- Required parameters
+N_GENES = 30
+MIN_REPLICATES = 2
+MAX_REPLICATES = 10
+########################
+
+## -- simulate RNAseq data based on input_var_list, minimum input required
+## -- number of replicate randomly defined between MIN_REP and MAX_REP
+mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES)
+
+## -- simulate RNAseq data based on input_var_list, minimum input required
+## -- Same number of repicates between conditions
+mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MAX_REPLICATES,
+ max_replicates = MAX_REPLICATES)
+```
+
+
+
+## Scaling genes counts with sequencing depth
+
+Sequencing depth is a critical parameter affecting the statistical power of an RNAseq analysis. With the `sequencing_depth` option in the `mock_rnaseq()` function, you have the ability to control this parameter.
+
+
+```{r example-mock_rnaseq_seqDepth, warning = FALSE, message = FALSE}
+## -- Required parameters
+N_GENES = 30
+MIN_REPLICATES = 2
+MAX_REPLICATES = 10
+########################
+
+SEQ_DEPTH = c(100000, 5000000, 10000000)## -- Possible number of reads/sample
+SEQ_DEPTH = 10000000 ## -- all samples have same number of reads
+mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES,
+ sequencing_depth = SEQ_DEPTH)
+```
+
+## Set gene dispersion
+
+The dispersion parameter (\alpha_i), characterizes the relationship between the variance of the observed count and its mean value. In simple terms, it quantifies how much we expect the observed count to deviate from the mean value. You can specify the dispersion for individual genes using the dispersion parameter.
+
+
+```{r example-mock_rnaseq_disp, warning = FALSE, message = FALSE}
+
+## -- Required parameters
+N_GENES = 30
+MIN_REPLICATES = 2
+MAX_REPLICATES = 4
+########################
+
+DISP = 0.1 ## -- Same dispersion for each genes
+DISP = 1000 ## -- Same dispersion for each genes
+DISP = runif(N_GENES, 0, 1000) ## -- Dispersion can vary between genes
+mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES,
+ dispersion = DISP )
+
+```
+
+## Set basal gene expression
+
+The basal gene expression parameter, accessible through the basal_expression option, allows you to control the fundamental baseline gene expression level. It lets you adjust the expected count when no other factors are influencing gene expression, making it a key factor for simulating RNAseq data that aligns with your experimental design.
+
+
+```{r example-mock_rnaseq_bexpr, warning = FALSE, message = FALSE}
+## -- Required parameters
+N_GENES = 50
+MIN_REPLICATES = 10
+MAX_REPLICATES = 10
+########################
+
+BASAL_EXPR = -3 ## -- Value can be negative to simulate low expressed gene
+BASAL_EXPR = 2 ## -- Same basal gene expression for the N_GENES
+BASAL_EXPR = c( -3, -1, 2, 8, 9, 10 ) ## -- Basal expression can vary between genes
+mock_data <- mock_rnaseq(input_var_list, N_GENES,
+ min_replicates = MIN_REPLICATES,
+ max_replicates = MAX_REPLICATES,
+ basal_expression = BASAL_EXPR)
+
+## -- output list attributes
+names(mock_data)
+```
+
+# Theory behind HTRfit simulation
+
+<div id="bg" align="center">
+ <img src="./figs/htrfit_workflow.png" width="500" height="300">
+</div>
+
+
+In this modeling framework, counts denoted as $K_{ij}$ for gene i and sample j are generated using a negative binomial distribution. The negative binomial distribution considers a fitted mean $\mu_{ij}$ and a gene-specific dispersion parameter $\alpha_i$.
+
+The fitted mean $\mu_{ij}$ is determined by a parameter, qij, which is proportionally related to the sum of all effects specified using `init_variable()` or `add_interaction()`. If basal gene expressions are provided, the $\mu_{ij}$ values are scaled accordingly using the gene-specific basal expression value ($bexpr_i$).
+
+Furthermore, the coefficients $\beta_i$ represent the natural logarithm fold changes for gene i across each column of the model matrix X. The dispersion parameter $\alpha_i$ plays a crucial role in defining the relationship between the variance of observed counts and their mean value. In simpler terms, it quantifies how far we expect observed counts to deviate from the mean value.
+
+
+
+
+# Fitting models
+
+## Prepare data for fitting
+
+The `prepareData2fit()` function serves the purpose of converting the counts matrix and sample metadata into a dataframe that is compatible with downstream **HTRfit** functions designed for model fitting. This function also includes an option to perform median ratio normalization on the data counts.
+
+
+
+```{r example-prepareData, warning = FALSE, message = FALSE}
+## -- data from simulation or real data
+count_matrix <- mock_data$counts
+metaData <- mock_data$metadata
+##############################
+
+## -- convert counts matrix and samples metadatas in a data frame for fitting
+data2fit = prepareData2fit(countMatrix = count_matrix,
+ metadata = metaData,
+ normalization = F)
+
+
+## -- median ratio normalization
+data2fit = prepareData2fit(countMatrix = count_matrix,
+ metadata = metaData,
+ normalization = T,
+ response_name = "kij")
+
+## -- output
+head(data2fit)
+```
+
+## Fit model from your data
+
+The `fitModelParallel()` function enables independent model fitting for each gene. The number of threads used for this process can be controlled by the `n.cores` parameter.
+
+
+```{r example-fitModelParallel, warning = FALSE, message = FALSE}
+l_tmb <- fitModelParallel(formula = kij ~ varA,
+ data = data2fit,
+ group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"),
+ log_file = "log.txt",
+ n.cores = 1)
+```
+
+## Use mixed effect in your model
+
+**HTRfit** uses the **glmmTMB** functions for model fitting algorithms. This choice allows for the utilization of random effects within your formula design. For further details on how to specify your model, please refer to the [mixed model documentation](https://rdrr.io/cran/glmmTMB/man/glmmTMBControl.html).
+
+
+
+```{r example-fitModelParallel_mixed, warning = FALSE, message = FALSE}
+l_tmb <- fitModelParallel(formula = kij ~ varA + ( 1 | varB ),
+ data = data2fit,
+ group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"),
+ log_file = "log.txt",
+ n.cores = 1)
+```
+
+## Additional settings
+
+The function provides precise control over model settings for fitting optimization, including options for specifying the [model family](https://www.rdocumentation.org/packages/stats/versions/3.6.2/topics/family) and [model control setting](https://rdrr.io/cran/glmmTMB/man/glmmTMBControl.html). By default, a Gaussian family model is fitted, but for RNA-seq data, it is highly recommended to specify `family = glmmTMB::nbinom2(link = "log")`.
+
+
+
+```{r example-fitModelParallel_addSet, warning = FALSE, message = FALSE}
+l_tmb <- fitModelParallel(formula = kij ~ varA,
+ data = data2fit,
+ group_by = "geneID",
+ n.cores = 1,
+ log_file = "log.txt",
+ family = glmmTMB::nbinom2(link = "log"),
+ control = glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e5,
+ eval.max=1e5)))
+```
+
+## Not only RNAseq data
+
+As the model family can be customized, HTRfit is not exclusively tailored for RNA-seq data.
+
+
+```{r example-fitModelParallel_nonRNA, warning = FALSE, message = FALSE, eval = FALSE}
+## -- example not evaluate in the vignette
+data("iris")
+l_tmb <- fitModelParallel(formula = Sepal.Length ~ Sepal.Width + Petal.Length + Petal.Width ,
+ data = iris,
+ group_by = "Species",
+ family = gaussian(),
+ log_file = "log.txt",
+ n.cores = 1)
+```
+
+## Update fit
+
+The `updateParallel()` function updates and re-fits a model for each gene. It offers options similar to those in `fitModelParallel()`.
+
+
+```{r example-update, warning = FALSE, message = FALSE}
+## -- update your fit modifying the model family
+l_tmb <- updateParallel(formula = kij ~ varA,
+ l_tmb = l_tmb ,
+ family = gaussian(),
+ log_file = "log.txt",
+ n.cores = 1)
+
+## -- update fit using additional model control settings
+l_tmb <- updateParallel(formula = kij ~ varA ,
+ l_tmb = l_tmb ,
+ family = gaussian(),
+ log_file = "log.txt",
+ n.cores = 1,
+ control = glmmTMB::glmmTMBControl(optCtrl=list(iter.max=1e3,
+ eval.max=1e3)))
+
+
+## -- update your model formula and your family model
+l_tmb <- updateParallel(formula = kij ~ varA + varB + varA:varB ,
+ l_tmb = l_tmb ,
+ family = glmmTMB::nbinom2(link = "log"),
+ log_file = "log.txt",
+ n.cores = 1)
+
+## -- output
+l_tmb$gene1
+```
+
+## Plot fit metrics
+
+Visualizing fit metrics is essential for evaluating your models. Here, we show you how to generate various plots to assess the quality of your models. You can explore all metrics or focus on specific aspects like dispersion and log-likelihood.
+
+
+```{r example-plotMetrics, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 6}
+## -- plot all metrics
+metrics_plot(l_tmb = l_tmb)
+```
+
+```{r example-plotMetricsFocus, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 3, fig.width = 4}
+## -- Focus on metrics
+metrics_plot(l_tmb = l_tmb, focus = c("dispersion", "logLik"))
+```
+
+## Anova to select the best model
+
+Utilizing the `anovaParallel()` function enables you to perform model selection by assessing the significance of the fixed effects. You can also include additional parameters like type. For more details, refer to [car::Anova](https://rdrr.io/cran/car/man/Anova.html).
+
+
+```{r example-anova, warning = FALSE, message = FALSE}
+## -- update your fit modifying the model family
+l_anova <- anovaParallel(l_tmb = l_tmb)
+
+## -- additional settings
+l_anova <- anovaParallel(l_tmb = l_tmb, type = "III" )
+
+## -- output
+l_anova$gene1
+```
+
+# Simulation evaluation report
+
+In this section, we delve into the evaluation of your simulation results. The `simulationReport()` function provide valuable insights into the performance of your simulated data and models.
+
+
+```{r example-simulationReport, warning = FALSE, message = FALSE, results = 'hide', fig.keep = 'none'}
+## -- get simulation/fit evaluation
+resSimu <- simulationReport(mock_data,
+ list_tmb = l_tmb,
+ coeff_threshold = 0.4,
+ alt_hypothesis = "greaterAbs")
+```
+
+## Identity plot
+
+The identity plot, generated by the `simulationReport()` function, provides a visual means to compare the effects used in the simulation (actual effects) with those inferred by the model. This graphical representation facilitates the assessment of the correspondence between the values of the simulated effects and those estimated by the model, allowing for a visual analysis of the model's goodness of fit to the simulated data.
+
+
+
+```{r example-simulationReport_plotID, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 5}
+resSimu$identity_plot
+
+```
+
+## Dispersion plot
+
+The dispersion plot, generated by the `simulationReport()` function, offers a visual comparison of the dispersion parameters used in the simulation \(\alpha_i\) with those estimated by the model. This graphical representation provides an intuitive way to assess the alignment between the simulated dispersion values and the model-inferred values, enabling a visual evaluation of how well the model captures the underlying data characteristics.
+
+The area under the ROC curve (AUC) provides a single metric that summarizes the model's overall performance in distinguishing between differentially expressed and non-differentially expressed genes. A higher AUC indicates better model performance.
+
+
+```{r example-simulationReport_plotDisp, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 5}
+resSimu$dispersionEvaluation$disp_plot
+```
+
+## ROC curve
+
+The Receiver Operating Characteristic (ROC) curve is a valuable tool for assessing the performance of classification models, particularly in the context of identifying differentially expressed genes. It provides a graphical representation of the model's ability to distinguish between genes that are differentially expressed and those that are not, by varying the `coeff_threshold` and the `alt_hypothesis` parameters.
+
+
+```{r example-simulationReport_plotRoc, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 5}
+resSimu$roc_plot
+```
+
+## Compare HTRfit with DESeq2
+
+**HTRfit** offers a wrapper for **DESeq2** outputs. This functionality allows users to seamlessly integrate the results obtained from **DESeq2** into the **HTRfit** analysis pipeline. By doing so, you can readily compare the performance of **HTRfit** with **DESeq2** on your RNAseq data. This comparative analysis aids in determining which tool performs better for your specific research goals and dataset
+
+
+```{r example-ddsComparison, warning = FALSE, message = FALSE, results = 'hide', fig.keep = 'none'}
+## -- DESeq2
+library(DESeq2)
+dds <- DESeq2::DESeqDataSetFromMatrix(
+ countData = count_matrix,
+ colData = metaData,
+ design = ~ varA + varB + varA:varB )
+dds <- DESeq2::DESeq(dds, quiet = TRUE)
+
+
+## -- get simulation/fit evaluation
+resSimu <- simulationReport(mock_data,
+ list_tmb = l_tmb,
+ dds_obj = dds,
+ coeff_threshold = 0.4,
+ alt_hypothesis = "greaterAbs")
+```
+
+```{r example-outputResSimu, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 5}
+## -- identity plot
+resSimu$identity_plot
+## -- dispersion
+resSimu$dispersionEvaluation$disp_plot
+## -- roc curve
+resSimu$roc_plot
+```
+
+## Focus evaluation on a subset of genes
+
+In this section, we showcase the assessment of model performance on a subset of genes. Specifically, we focus on evaluating genes with low expression levels, identified by their basal expression ($bexpr_i$) initialized below 0 during the simulation.
+
+
+```{r example-subsetGenes, warning = FALSE, message = FALSE, results = 'hide', fig.keep = 'none'}
+## -- Focus on low expressed genes
+low_expressed_df <- mock_data$groundTruth$effects[ mock_data$groundTruth$effects$basalExpr < 0, ]
+l_genes <- unique(low_expressed_df$geneID)
+mock_lowExpressed <- subsetGenes(l_genes, mock_data)
+
+
+## -- get simulation/fit evaluation
+resSimu <- simulationReport(mock_lowExpressed,
+ list_tmb = l_tmb,
+ dds_obj = dds,
+ coeff_threshold = 0.4,
+ alt_hypothesis = "greaterAbs")
+```
+
+As we compare this evaluation to the previous one, we observe a reduction in the AUC for both **HTRfit** and **DESeq2** inferences.
+
+
+```{r example-subsetGenes_rocPlot, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 5}
+## -- roc curve
+resSimu$roc_plot
+```
+
+# Evaluate model inference involving mixed effects
+
+For certain experimental scenarios, such as those involving a high number of levels or longitudinal data, the utilization of mixed effects within your design formula can be beneficial. The **HTRfit** simulation framework also offers the capability to assess this type of design formula.
+
+
+```{r example-evalMixed, warning = FALSE, message = FALSE, results = 'hide', fig.keep = 'none'}
+## -- init a design with a high number of levels
+input_var_list <- init_variable( name = "varA", mu = 0, sd = 0.29, level = 60) %>%
+ init_variable( name = "varB", mu = 0.27, sd = 0.6, level = 2) %>%
+ add_interaction( between_var = c("varA", "varB"), mu = 0.44, sd = 0.89)
+## -- simulate RNAseq data
+mock_data <- mock_rnaseq(input_var_list,
+ n_genes = 30,
+ min_replicates = 10,
+ max_replicates = 10,
+ basal_expression = 5 )
+## -- prepare data & fit a model with mixed effect
+data2fit = prepareData2fit(countMatrix = mock_data$counts,
+ metadata = mock_data$metadata,
+ normalization = F)
+l_tmb <- fitModelParallel(formula = kij ~ varB + (varB | varA),
+ data = data2fit,
+ group_by = "geneID",
+ family = glmmTMB::nbinom2(link = "log"),
+ log_file = "log.txt",
+ n.cores = 1)
+## -- evaluation
+resSimu <- simulationReport(mock_data,
+ list_tmb = l_tmb,
+ coeff_threshold = 0.27,
+ alt_hypothesis = "greater")
+```
+
+```{r example-outputResSimuMixed, warning = FALSE, message = FALSE, fig.align = 'center', fig.height = 4, fig.width = 5}
+## -- identity plot
+resSimu$identity_plot
+## -- dispersion
+resSimu$dispersionEvaluation$disp_plot
+## -- roc curve
+resSimu$roc_plot
+```
+