diff --git a/DESCRIPTION b/DESCRIPTION
index c630ea9b26c4868b61e9f453dc027a59c78489bb..a3b76599c5bcbf58be85a757f3749815715aeb41 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -40,6 +40,7 @@ Suggests:
testthat
VignetteBuilder:
knitr
+Config/fusen/version: 0.5.2
Encoding: UTF-8
Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.2
+RoxygenNote: 7.3.1
diff --git a/NAMESPACE b/NAMESPACE
index 7430465129f64a0bfc34573f81a4aa43000154ad..9761c660605472324438a510426f67bba78a26fc 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -32,6 +32,7 @@ export(convert2Factor)
export(correlation_matrix_2df)
export(countMatrix_2longDtf)
export(counts_plot)
+export(detect_categoricals_vars)
export(diagnostic_plot)
export(drop_randfx)
export(endsWithDigit)
@@ -46,6 +47,7 @@ export(fillInInteraction)
export(fillInVariable)
export(filter_dataframe)
export(findAttribute)
+export(first_non_null_index)
export(fitModel)
export(fitModelParallel)
export(fitUpdate)
@@ -135,6 +137,8 @@ export(prepare_dataParallel)
export(rbind_evaldata_tmb_dds)
export(rbind_model_params_and_dispersion)
export(recall)
+export(relevel_list_tmb_frame)
+export(relevelling_factors)
export(removeDigitsAtEnd)
export(removeDuplicatedWord)
export(renameColumns)
diff --git a/R/actual_interactionfixeffects.R b/R/actual_interactionfixeffects.R
index 81ce0a05f4c030a4e4ab3a654c6bd03b2fb3fe5e..2498ba0568ca954ace9bc5b605ae56c4f220401e 100644
--- a/R/actual_interactionfixeffects.R
+++ b/R/actual_interactionfixeffects.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
#' Filter DataFrame
#'
diff --git a/R/actual_mainfixeffects.R b/R/actual_mainfixeffects.R
index 6642c14a199445e3c2a2c6dd7bb1fcf06b195c46..eed250c3062531dbf0f18d700301bf6455508e73 100644
--- a/R/actual_mainfixeffects.R
+++ b/R/actual_mainfixeffects.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
#' Calculate average values by group
diff --git a/R/anova.R b/R/anova.R
index c2a2c75b93412a58981f6bd3b3b2c2e050e43ffa..63c42702227ecf0df62af147484be451031e42cb 100644
--- a/R/anova.R
+++ b/R/anova.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
#' Handle ANOVA Errors
diff --git a/R/basal_expression_scaling.R b/R/basal_expression_scaling.R
index c2ddc5d3bbcaf8167cc73024562309602443501d..83b7bfa7cd0ca2e568a082d563357f6aafe5ec41 100644
--- a/R/basal_expression_scaling.R
+++ b/R/basal_expression_scaling.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
@@ -17,7 +17,7 @@
#' @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 = "_"))
diff --git a/R/counts_plot.R b/R/counts_plot.R
index d61a6effa691dcbca0ac20cce11f4923b92ea0d6..1d19fa9740ab21e77657c6a06d8900f910497a03 100644
--- a/R/counts_plot.R
+++ b/R/counts_plot.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
#' Generate a density plot of gene counts
diff --git a/R/datafrommvrnorm_manipulations.R b/R/datafrommvrnorm_manipulations.R
index cbc046f574486dede578eadb8adce36e329815d7..50f3b65b6bf90622ba9a35a0f49b0fa2d944ee90 100644
--- a/R/datafrommvrnorm_manipulations.R
+++ b/R/datafrommvrnorm_manipulations.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
#' getInput2mvrnorm
#'
diff --git a/R/datafromuser_manipulations.R b/R/datafromuser_manipulations.R
index 1c3ee6d3970a34f18adccfae87b28e93192c26fd..d7c796f67861b76f952aa7b3d74dd9f58cffa9fa 100644
--- a/R/datafromuser_manipulations.R
+++ b/R/datafromuser_manipulations.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
#' Get data from user
diff --git a/R/evaluate_dispersion.R b/R/evaluate_dispersion.R
index 0b30f99ba036a100f9c7678ebe27d36525acf5e3..cf7d4d5db92f8e3e1e6197178240ac348ea1df12 100644
--- a/R/evaluate_dispersion.R
+++ b/R/evaluate_dispersion.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
#' Get Dispersion Comparison
diff --git a/R/evaluation_identity.R b/R/evaluation_identity.R
index 76d9efac6fa51f625a90bb4de27bf05da4055ba9..fb74451540a6f0d445a2848a28f4412a6d3325b7 100644
--- a/R/evaluation_identity.R
+++ b/R/evaluation_identity.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
@@ -43,7 +43,9 @@ compute_rsquare <- function(data, grouping_by = c("from", "description") ){
#' @return A data frame with additional columns for labeling in the plot.
#' @export
#' @examples
-#' data_rsquare <- data.frame(from = c("A", "B", "C"), description = c("Desc1", "Desc2", "Desc3"), R2 = c(0.9, 0.8, 0.7))
+#' data_rsquare <- data.frame(from = c("A", "B", "C"),
+#' description = c("Desc1", "Desc2", "Desc3"),
+#' R2 = c(0.9, 0.8, 0.7))
#' result <- get_rsquare_2plot(data_rsquare)
get_rsquare_2plot <- function(data_rsquare){
data_rsquare$pos_x <- -Inf
diff --git a/R/evaluation_withmixedeffect.R b/R/evaluation_withmixedeffect.R
index 7a406bd487232220af0a5a3e787672631aecf1aa..1264d4395590cae6e8ebbedb53d07dc1f5817229 100644
--- a/R/evaluation_withmixedeffect.R
+++ b/R/evaluation_withmixedeffect.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
#' Check if the formula contains a mixed effect structure.
diff --git a/R/fake-section-title.R b/R/fake-section-title.R
index 72d65fe5ac370bd3d2ef754583daf56a0f49251e..4da9d9a29f8503a46497c662c39a4375ad5ace84 100644
--- a/R/fake-section-title.R
+++ b/R/fake-section-title.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
#' @name prediction-class
diff --git a/R/fitmodel.R b/R/fitmodel.R
index 4ae9cb79a03730683ed1869a0e36c896f59fb6b8..01cd6299c5536140b45152b8ea03a03d71e90291 100644
--- a/R/fitmodel.R
+++ b/R/fitmodel.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
#' Check if Data is Valid for Model Fitting
#'
@@ -115,8 +115,11 @@ is_fullrank <- function(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.")
+ if (!modelFullRank) {
+ warning("The model matrix is not full rank. One or more variables or interaction terms in the design formula are linear combinations of the others.")
+ return(FALSE)
+ }
+
return(TRUE)
}
@@ -135,6 +138,7 @@ is_fullrank <- function(metadata, formula) {
#' @examples
#' fitModel("mtcars" , formula = mpg ~ cyl + disp, data = mtcars)
fitModel <- function(group , formula, data, ...) {
+ is_fullrank(data, formula)
# Fit the model using glm.nb from the GLmmTMB package
model <- glmmTMB::glmmTMB(formula, ..., data = data )
@@ -242,7 +246,7 @@ parallel_fit <- function(groups, group_by, formula, data, n.cores = NULL,
l_data2parallel <- prepare_dataParallel(groups, group_by, data)
clust <- parallel::makeCluster(n.cores, outfile = log_file , type= cl_type )
- parallel::clusterExport(clust, c("fitModel"))
+ parallel::clusterExport(clust, c("fitModel", "is_fullrank", "drop_randfx"))
results_fit <- parallel::parLapply(clust, X = l_data2parallel,
fun = launchFit,
group_by = group_by, formula = formula, ...)
@@ -273,7 +277,6 @@ fitModelParallel <- function(formula, data, group_by, n.cores = NULL, cl_type =
## Some verification
isValidInput2fit(data, formula)
- is_fullrank(data, formula)
is_validGroupBy(data, group_by)
## -- print log location
diff --git a/R/glance_glmmtmb.R b/R/glance_glmmtmb.R
index 1fbea83c67210c30b656343e58a20278f45417ba..822fd423e33f4918dda850e74a8e61c9b6854fe3 100644
--- a/R/glance_glmmtmb.R
+++ b/R/glance_glmmtmb.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
#' Extracts the summary statistics from a list of glmmTMB models.
diff --git a/R/inferencetoexpected.R b/R/inferencetoexpected.R
index b6128e596944129e2791f6b7c945c78a618d76ff..e0ac974668e16f95a717a811672e0062fb9239e5 100644
--- a/R/inferencetoexpected.R
+++ b/R/inferencetoexpected.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
#' Compare the results of inference with the ground truth data.
diff --git a/R/mlmetrics.R b/R/mlmetrics.R
index dcf8a0581d43df41c0379a17314b2a23d4114e1e..c2778d35cba79c277edc9013d4813bbad6c87111 100644
--- a/R/mlmetrics.R
+++ b/R/mlmetrics.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
diff --git a/R/mock_rnaseq.R b/R/mock_rnaseq.R
index a2227cdc1c1e2bf1c92e245f15a752a4ec5e6b97..1ea3751ae341d21e0873fa1ae19e437b8d2086dc 100644
--- a/R/mock_rnaseq.R
+++ b/R/mock_rnaseq.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
#' Check the validity of the dispersion matrix
diff --git a/R/plot_metrics.R b/R/plot_metrics.R
index 7fd01f459044cd0b972ad63f712ede3e841a9273..2b94c1e20ebf4c2a58d9f0c4ae4c570b93354705 100644
--- a/R/plot_metrics.R
+++ b/R/plot_metrics.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
#' Subset the glance DataFrame based on selected variables.
diff --git a/R/precision_recall.R b/R/precision_recall.R
index c9ececc8d5e98ed705aafad1d3182b0be9638884..b61bccd3f1ff90c5485d95f0f614505ad452398b 100644
--- a/R/precision_recall.R
+++ b/R/precision_recall.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
diff --git a/R/prepare_data2fit.R b/R/prepare_data2fit.R
index 482c5b3a004e1521d454259a68a963a57f652c9c..f173d2ace685c7ed433c3a406e744c76afddb287 100644
--- a/R/prepare_data2fit.R
+++ b/R/prepare_data2fit.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
#' Convert count matrix to long data frame
diff --git a/R/receiver_operating_characteristic.R b/R/receiver_operating_characteristic.R
index bb3754e4844133b5a3e185ae8881084702c2e853..4dd28910e6f569d15a0433c1346791be02802df4 100644
--- a/R/receiver_operating_characteristic.R
+++ b/R/receiver_operating_characteristic.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
diff --git a/R/rocr_functions.R b/R/rocr_functions.R
index c9ececc8d5e98ed705aafad1d3182b0be9638884..b61bccd3f1ff90c5485d95f0f614505ad452398b 100644
--- a/R/rocr_functions.R
+++ b/R/rocr_functions.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
diff --git a/R/sequencing_depth_scaling.R b/R/sequencing_depth_scaling.R
index 7c0777b2dcd41765d4bb43cf8363d8f6e435e830..f1bad838438b9cce52e453f653685d87f7e22005 100644
--- a/R/sequencing_depth_scaling.R
+++ b/R/sequencing_depth_scaling.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
#' Scale Counts Table
diff --git a/R/setcorrelation.R b/R/setcorrelation.R
index 34a837713c97548867df28c45d4f77f558dce072..c38666a81732156c7e9409e95e56628feaf91b62 100644
--- a/R/setcorrelation.R
+++ b/R/setcorrelation.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
#' Compute Covariation from Correlation and Standard Deviations
diff --git a/R/simulation.R b/R/simulation.R
index 4399ec472fbcf2e20e4411214d341efc1e433b05..6e25b6f7d65a8c0e7468f1c69b2ab549632907e7 100644
--- a/R/simulation.R
+++ b/R/simulation.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
#' Get input for simulation based on coefficients
#'
diff --git a/R/simulation_initialization.R b/R/simulation_initialization.R
index 65e22f671c4c3473307ad41c098b4e2a2f735313..416a0aefb1fdda4ea191ce72892b235d6c418382 100644
--- a/R/simulation_initialization.R
+++ b/R/simulation_initialization.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
#' Initialize variable
#'
diff --git a/R/simulation_report.R b/R/simulation_report.R
index c3548f0f8ad43da016127a73c8560a575b53efe3..6955f61e9d83d3123f6c26b7ceedcd6d06d742b7 100644
--- a/R/simulation_report.R
+++ b/R/simulation_report.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
@@ -85,7 +85,7 @@ is_truthLabels_valid <- function(eval_data, col_param = "description", col_truth
#' report <- evaluation_report(l_res, NULL, mock_data,
#' coeff_threshold = 0.67, alt_hypothesis = "greaterAbs")
#' }
-#'
+#'
evaluation_report <- function(list_tmb, dds, mock_obj, coeff_threshold, alt_hypothesis, alpha_risk = 0.05,
palette_color = c(DESeq2 = "#500472", HTRfit ="#79cbb8"),
palette_shape = c(DESeq2 = 17, HTRfit = 19),
diff --git a/R/subsetgenes.R b/R/subsetgenes.R
index 74171bcfa0f0adfdf418c4decf7ea67136747eda..351d045c014feff73ee65ac7fdf2c8263bdeec02 100644
--- a/R/subsetgenes.R
+++ b/R/subsetgenes.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
#' Subset Genes in Genomic Data
diff --git a/R/tidy_glmmtmb.R b/R/tidy_glmmtmb.R
index 7c2ebb87447e47eecc0a1a76373a8cf4028aea85..435160d5071be377cbbcfbe90c8bb9b1680ae5cd 100644
--- a/R/tidy_glmmtmb.R
+++ b/R/tidy_glmmtmb.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
diff --git a/R/update_fittedmodel.R b/R/update_fittedmodel.R
index 24ba2e8a7e73dcd752d7a68b6b351f9e79d68386..4ce264c3906a3deb4dc166a4ace24270b4fcbe64 100644
--- a/R/update_fittedmodel.R
+++ b/R/update_fittedmodel.R
@@ -1,21 +1,25 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
#' Update glmmTMB models in parallel.
#'
-#' This function fits glmmTMB models in parallel using multiple cores, allowing for faster computation.
+#' This function updates glmmTMB models in parallel using multiple cores, allowing for faster computation.
+#' It updates the models with new reference labels if specified.
+#' It can also be used to fit a new formula or to change additional parameters of glmmTMB (param : "...").
#'
#' @param formula Formula for the GLMNB model.
#' @param list_tmb List of glmmTMB objects.
+#' @param reference_labels Vector of reference labels. Default is c(), selecting the first alphanumeric label as reference.
#' @param n.cores Number of cores to use for parallel processing. If NULL, the function will use all available cores.
#' @param log_file File path for the log output (default: Rtmpdir/htrfit.log).
-#' @param cl_type cluster type (defautl "PSOCK"). "FORK" is recommanded for linux.
+#' @param cl_type cluster type (default "PSOCK"). "FORK" is recommended for linux.
#' @param ... Additional arguments to be passed to the glmmTMB::glmmTMB function.
#' @export
#' @return A list of updated GLMNB models.
#'
#' @examples
+#' # -- Example usage: update formula
#' data(iris)
#' groups <- unique(iris$Species)
#' group_by <- "Species"
@@ -23,23 +27,154 @@
#' fitted_models <- fitModelParallel(formula, iris, group_by, n.cores = 1)
#' new_formula <- Sepal.Length ~ Sepal.Width
#' results <- updateParallel(new_formula, fitted_models, n.cores = 1)
-updateParallel <- function(formula, list_tmb, n.cores = NULL, cl_type = "PSOCK",
- log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"), ...) {
-
-
- isValidInput2fit(list_tmb[[1]]$frame, formula)
-
- is_fullrank(list_tmb[[1]]$frame, formula)
+#' # Example usage: update reference
+#' # -- Load the mtcars dataset
+#' data("mtcars")
+#' # -- Specify categorical variables
+#' mtcars$vs <- factor(mtcars$vs) ## Engine (0 = V-shaped, 1 = straight)
+#' levels(mtcars$vs) <- c("V-shaped", "straight")
+#' mtcars$am <- factor(mtcars$am) ## Transmission (0 = automatic, 1 = manual)
+#' levels(mtcars$am) <- c("automatic", "manual")
+#' # -- For each group of number of cylinders:
+#' # -- Explain fuel consumption with engine shape, Gross horsepower, and transmission type
+#' list_tmb <- fitModelParallel(formula = mpg ~ hp + vs + am,
+#' data = mtcars, group_by = "cyl", n.cores = 1)
+#' # -- Relevel transmission and engine shape variables
+#' list_tmb <- updateParallel(formula = mpg ~ hp + vs + am, list_tmb,
+#' reference_labels = c("straight", "manual"), n.cores = 1)
+updateParallel <- function (formula, list_tmb, reference_labels = c(), n.cores = NULL, cl_type = "PSOCK",
+ log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"),
+ ...) {
+ stopifnot(is.list(list_tmb))
+ non_null_idx <- first_non_null_index(list_tmb)
+ if (!is.null(non_null_idx)){
+ stopifnot(is.data.frame(list_tmb[[non_null_idx]]$frame))
+ isValidInput2fit(list_tmb[[non_null_idx]]$frame, formula)
+ list_tmb <- relevelling_factors(list_tmb, reference_labels)
+ message(paste("Log file location", log_file, sep = ": "))
+ list_tmb <- parallel_update(formula, list_tmb, n.cores, log_file, cl_type, ...)
+ clear_memory(except_obj = list_tmb)
+ }
+ return(list_tmb)
+}
+
+
+#' Re-levels categorical variables in a the frame of a list of glmmTMB objects.
+#'
+#' This function re-levels categorical variables in a list of glmmTMB objects using the specified reference labels.
+#'
+#' @param list_tmb List of glmmTMB objects.
+#' @param categorical_vars Names of the categorical variables to be re-leveled.
+#' @param ref_labels Vector of reference labels corresponding to the categorical variables.
+#' @return A list of glmmTMB objects with re-leveled categorical variables.
+#' @export
+#'
+#' @examples
+#' # Example usage:
+#' # -- Load the mtcars dataset
+#' data("mtcars")
+#' ## -- specify categorical var
+#' mtcars$vs <- factor(mtcars$vs) ## Engine (0 = V-shaped, 1 = straight)
+#' levels(mtcars$vs) <- c("V-shaped", "straight")
+#' mtcars$am <- factor(mtcars$am) ## Transmission (0 = automatic, 1 = manual)
+#' levels(mtcars$am) <- c("automatic", "manual")
+#' # -- For each group of number of cylinders,
+#' # -- Explain fuel consumption with engine shape, Gross horsepower, and transmission type
+#' list_tmb <- fitModelParallel(formula = mpg ~ hp + vs + am,
+#' data = mtcars, group_by = "cyl", n.cores = 1)
+#' # -- Relevel transmission and engine shape variables
+#' relevel_list_tmb_frame(list_tmb, c("am", "vs"), c("manual", "straight"))
+relevel_list_tmb_frame <- function(list_tmb, categorical_vars, ref_labels){
+ names(ref_labels) <- categorical_vars
+ lapply(list_tmb, function( tmb_obj ) {
+ if (!is.null(tmb_obj)){
+ for (categorical_var in names(ref_labels)) {
+ reference_label <- ref_labels[categorical_var]
+ tmb_obj$frame[[categorical_var]] <- stats::relevel(tmb_obj$frame[[categorical_var]], ref = reference_label)
+ }
+ }
+ return(tmb_obj)
+ })
+}
+
+
+#' Detects categorical variables based on reference labels in a glmmTMB object.
+#'
+#' This function detects categorical variables based on reference labels in a glmmTMB object's frame.
+#'
+#' @param tmb_frame The data frame of a glmmTMB object.
+#' @param ref_labels Vector of reference labels corresponding to categorical variables.
+#' @return Names of the categorical variables detected.
+#' @export
+#'
+#' @examples
+#' data("mtcars")
+#' ## -- specify categorical var
+#' mtcars$vs <- factor(mtcars$vs) ## Engine (0 = V-shaped, 1 = straight)
+#' levels(mtcars$vs) <- c("V-shaped", "straight")
+#' mtcars$am <- factor(mtcars$am) ## Transmission (0 = automatic, 1 = manual)
+#' levels(mtcars$am) <- c("automatic", "manual")
+#' ## -- For each group of number of cylinder,
+#' ## -- explain fuel consumption with engine shape, Gross horsepower, and transmission type
+#' list_tmb <- fitModelParallel(formula = mpg ~ hp + vs + am,
+#' data = mtcars, group_by = "cyl" , n.cores = 1)
+#' detect_categoricals_vars(list_tmb[["6"]]$frame, c("straight", "manual"))
+detect_categoricals_vars <- function(tmb_frame, ref_labels){
+ idx_col <- c()
+ for (reference_label in ref_labels){
+
+ catego_var_idx_col <- unique(which(tmb_frame == reference_label, arr.ind = T)[, "col"])
+
+ if (length(catego_var_idx_col) > 1) {
+ message_err <- paste("Label", reference_label, " detected in the metadata across different columns.\nUnable to determine the correct columns for re-leveling.\nPlease ensure that reference labels are specific to individual columns for re-leveling")
+ stop(message_err)
+ }
+
+ if (length(catego_var_idx_col) == 0) {
+ ref_label_str <- paste(ref_labels , collapse = ", ")
+ message_err <- paste("Label", reference_label, "not found in metadata.")
+ stop(message_err)
+ }
+
+ idx_col <- c(idx_col, catego_var_idx_col)
+ }
- ## -- ## -- print log location
- message( paste("Log file location", log_file, sep =': ') )
-
- # Fit models update in parallel and capture the results
- results <- parallel_update(formula, list_tmb, n.cores, log_file, cl_type, ...)
- return(results)
+ return(colnames(tmb_frame)[idx_col])
+}
+
+#' Relevels factors in a list of glmmTMB objects using specified reference labels.
+#'
+#' This function re-levels factors in a list of glmmTMB objects based on the specified reference labels.
+#'
+#' @param list_tmb List of glmmTMB objects.
+#' @param reference_labels Vector of reference labels.
+#' @return A list of glmmTMB objects with re-leveled factors.
+#' @export
+#'
+#' @examples
+#' data("mtcars")
+#' ## -- specify categorical var
+#' mtcars$vs <- factor(mtcars$vs) ## Engine (0 = V-shaped, 1 = straight)
+#' levels(mtcars$vs) <- c("V-shaped", "straight")
+#' mtcars$am <- factor(mtcars$am) ## Transmission (0 = automatic, 1 = manual)
+#' levels(mtcars$am) <- c("automatic", "manual")
+#' ## -- For each group of number of cylinder,
+#' ## -- explain fuel consumption with engine shape, Gross horsepower, and transmission type
+#' list_tmb <- fitModelParallel(formula = mpg ~ hp + vs + am,
+#' data = mtcars, group_by = "cyl", n.cores = 1 )
+#' relevelling_factors(list_tmb , c("straight", "manual"))
+relevelling_factors <- function(list_tmb, reference_labels ){
+ if (length(reference_labels) > 0){
+ l_categorical_vars <- detect_categoricals_vars(list_tmb[[1]]$frame, reference_labels)
+ list_tmb <- relevel_list_tmb_frame(list_tmb, l_categorical_vars, reference_labels)
+ }
+ return(list_tmb)
}
+
+
+
#' Internal function to fit glmmTMB models in parallel.
#'
#' This function is used internally by \code{\link{updateParallel}} to fit glmmTMB models in parallel.
@@ -63,18 +198,13 @@ updateParallel <- function(formula, list_tmb, n.cores = NULL, cl_type = "PSOCK",
parallel_update <- function(formula, list_tmb, n.cores = NULL,
log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"),
cl_type = "PSOCK" , ...) {
-
if (is.null(n.cores)) n.cores <- max(1, parallel::detectCores(logical = FALSE) - 1)
-
message(paste("CPU(s) number :", n.cores, sep = " "))
message(paste("Cluster type :", cl_type, sep = " "))
-
-
clust <- parallel::makeCluster(n.cores, type= cl_type, outfile = log_file)
- parallel::clusterExport(clust, c("launchUpdate", "fitUpdate"))
+ parallel::clusterExport(clust, c("launchUpdate", "fitUpdate", "is_fullrank", "drop_randfx"))
updated_res <- parallel::parLapply(clust, X = list_tmb, fun = launchUpdate , formula = formula, ...)
parallel::stopCluster(clust) ; invisible(gc(reset = T, verbose = F, full = T));
-
return(updated_res)
}
@@ -99,8 +229,8 @@ parallel_update <- function(formula, list_tmb, n.cores = NULL,
#' updated_model <- fitUpdate("setosa", fitted_models[[1]], new_formula)
fitUpdate <- function(group, glmm_obj, formula , ...){
data <- glmm_obj$frame
+ is_fullrank(data, formula)
resUpdt <- stats::update(glmm_obj, formula, ...)
-
resUpdt$frame <- data
## save groupID => avoid error in future update
resUpdt$groupId <- group
@@ -111,7 +241,6 @@ fitUpdate <- function(group, glmm_obj, formula , ...){
## control in ... => avoid error in future update
controlArgs <- additional_args[['control']]
if (!is.null(controlArgs)) resUpdt$call$control <- controlArgs
-
return(resUpdt)
}
@@ -135,11 +264,12 @@ fitUpdate <- function(group, glmm_obj, formula , ...){
#' new_formula <- Sepal.Length ~ Sepal.Width
#' updated_model <- launchUpdate(fitted_models[[1]], new_formula)
launchUpdate <- function(glmm_obj, formula, ...) {
+ if (is.null(glmm_obj)) return(NULL)
group <- glmm_obj$groupId
tryCatch(
expr = {
withCallingHandlers(
- fitUpdate(group ,glmm_obj, formula, ...),
+ fitUpdate(group, glmm_obj, formula, ...),
warning = function(w) {
message(paste(Sys.time(), "warning for group", group ,":", conditionMessage(w)))
invokeRestart("muffleWarning")
diff --git a/R/utils.R b/R/utils.R
index 8a9ef8b3c6bfb200b05e9801f7545e58dcc00144..e3e3bd37aa39a3bfd8703470de8165b38b3c97bd 100644
--- a/R/utils.R
+++ b/R/utils.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
#' Join two data frames using data.table
#'
@@ -23,7 +23,25 @@ join_dtf <- function(d1, d2, k1, k2) {
return(dt_joined %>% as.data.frame())
}
-
+#' Finds the index of the first non-null element in a list.
+#'
+#' This function searches a list and returns the index of the first non-null element.
+#'
+#' @param lst The list to search.
+#' @return The index of the first non-null element, or NULL if no non-null element is found.
+#' @export
+#'
+#' @examples
+#' my_list <- list(NULL, NULL, 3, 5, NULL)
+#' first_non_null_index(my_list) # Returns 3
+first_non_null_index <- function(lst) {
+ for (i in seq_along(lst)) {
+ if (!is.null(lst[[i]])) {
+ return(i)
+ }
+ }
+ return(NULL)
+}
#' Clean Variable Name
#'
@@ -270,8 +288,7 @@ reorderColumns <- function(df, columnOrder) {
clear_memory <- function(except_obj){
- a <- rm(list = setdiff(ls(), except_obj)) ; gc( reset = TRUE, verbose = FALSE )
- return(invisible(NULL))
+ rm(list = setdiff(ls(), except_obj)) ; invisible(gc( reset = TRUE, verbose = FALSE ))
}
diff --git a/R/waldtest.R b/R/waldtest.R
index af7b2d086bd985b7b857fa03599013e3e4730141..e430a2fd238d282f40c8cfd59d8cc95239eb6e53 100644
--- a/R/waldtest.R
+++ b/R/waldtest.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
#' Wald test for hypothesis testing
diff --git a/R/wrapper_dds.R b/R/wrapper_dds.R
index 81b4f01cc2a07bd3d5069e2b29b2b2582607ee30..b2c050c48dce73bfe5c35a9c3c6de57809bef56a 100644
--- a/R/wrapper_dds.R
+++ b/R/wrapper_dds.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
#' Wrapper Function for DESeq2 Analysis
@@ -32,7 +32,7 @@
#' result <- wrap_dds(dds, lfcThreshold = 1, altHypothesis = "greater")
#' @export
wrap_dds <- function(dds, lfcThreshold , altHypothesis, correction_method = "BH") {
- dds_full <- S4Vectors::mcols(dds) %>% as.data.frame()
+ dds_full <- as.data.frame(S4Vectors::mcols(dds))
## -- dispersion
message("INFO: The dispersion values from DESeq2 were reparametrized to their reciprocals (1/dispersion).")
diff --git a/dev/flat_full.Rmd b/dev/flat_full.Rmd
index 3ea6f7b327ac329cf5f0c3ca7d2ab43274fa1159..c99374ae75892a496a76d4e315235df0a3160be7 100644
--- a/dev/flat_full.Rmd
+++ b/dev/flat_full.Rmd
@@ -48,7 +48,25 @@ join_dtf <- function(d1, d2, k1, k2) {
return(dt_joined %>% as.data.frame())
}
-
+#' Finds the index of the first non-null element in a list.
+#'
+#' This function searches a list and returns the index of the first non-null element.
+#'
+#' @param lst The list to search.
+#' @return The index of the first non-null element, or NULL if no non-null element is found.
+#' @export
+#'
+#' @examples
+#' my_list <- list(NULL, NULL, 3, 5, NULL)
+#' first_non_null_index(my_list) # Returns 3
+first_non_null_index <- function(lst) {
+ for (i in seq_along(lst)) {
+ if (!is.null(lst[[i]])) {
+ return(i)
+ }
+ }
+ return(NULL)
+}
#' Clean Variable Name
#'
@@ -295,8 +313,7 @@ reorderColumns <- function(df, columnOrder) {
clear_memory <- function(except_obj){
- a <- rm(list = setdiff(ls(), except_obj)) ; gc( reset = TRUE, verbose = FALSE )
- return(invisible(NULL))
+ rm(list = setdiff(ls(), except_obj)) ; invisible(gc( reset = TRUE, verbose = FALSE ))
}
@@ -304,6 +321,15 @@ clear_memory <- function(except_obj){
```{r tests-utils}
+
+# Test for first_non_null_index function
+test_that("first_non_null_index returns the correct index", {
+ lst <- list(NULL, NULL, 3, 5, NULL)
+ expect_equal(first_non_null_index(lst), 3)
+})
+
+
+
# Test unitaires pour la fonction join_dtf
test_that("join_dtf réalise la jointure correctement", {
# Création de données de test
@@ -2592,8 +2618,11 @@ is_fullrank <- function(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.")
+ if (!modelFullRank) {
+ warning("The model matrix is not full rank. One or more variables or interaction terms in the design formula are linear combinations of the others.")
+ return(FALSE)
+ }
+
return(TRUE)
}
@@ -2612,6 +2641,7 @@ is_fullrank <- function(metadata, formula) {
#' @examples
#' fitModel("mtcars" , formula = mpg ~ cyl + disp, data = mtcars)
fitModel <- function(group , formula, data, ...) {
+ is_fullrank(data, formula)
# Fit the model using glm.nb from the GLmmTMB package
model <- glmmTMB::glmmTMB(formula, ..., data = data )
@@ -2719,7 +2749,7 @@ parallel_fit <- function(groups, group_by, formula, data, n.cores = NULL,
l_data2parallel <- prepare_dataParallel(groups, group_by, data)
clust <- parallel::makeCluster(n.cores, outfile = log_file , type= cl_type )
- parallel::clusterExport(clust, c("fitModel"))
+ parallel::clusterExport(clust, c("fitModel", "is_fullrank", "drop_randfx"))
results_fit <- parallel::parLapply(clust, X = l_data2parallel,
fun = launchFit,
group_by = group_by, formula = formula, ...)
@@ -2750,7 +2780,6 @@ fitModelParallel <- function(formula, data, group_by, n.cores = NULL, cl_type =
## Some verification
isValidInput2fit(data, formula)
- is_fullrank(data, formula)
is_validGroupBy(data, group_by)
## -- print log location
@@ -2858,8 +2887,9 @@ test_that("Detect rank-deficient model matrix and throw error", {
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.")
+ expect_warning(is_fullrank(metadata, formula))
+ res <- suppressWarnings(is_fullrank(metadata, formula))
+ expect_false(res)
})
# Test if a rank-deficient model matrix is detected and throws an error
@@ -2869,8 +2899,9 @@ test_that("Detect rank-deficient model matrix and throw error (with random eff)"
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.")
+ expect_warning(is_fullrank(metadata, formula))
+ res <- suppressWarnings(is_fullrank(metadata, formula))
+ expect_false(res)
})
# Test if a rank-deficient model matrix is detected and throws an error
@@ -3003,18 +3034,22 @@ test_that("fitModelParallel fits models in parallel for each group and returns a
#' Update glmmTMB models in parallel.
#'
-#' This function fits glmmTMB models in parallel using multiple cores, allowing for faster computation.
+#' This function updates glmmTMB models in parallel using multiple cores, allowing for faster computation.
+#' It updates the models with new reference labels if specified.
+#' It can also be used to fit a new formula or to change additional parameters of glmmTMB (param : "...").
#'
#' @param formula Formula for the GLMNB model.
#' @param list_tmb List of glmmTMB objects.
+#' @param reference_labels Vector of reference labels. Default is c(), selecting the first alphanumeric label as reference.
#' @param n.cores Number of cores to use for parallel processing. If NULL, the function will use all available cores.
#' @param log_file File path for the log output (default: Rtmpdir/htrfit.log).
-#' @param cl_type cluster type (defautl "PSOCK"). "FORK" is recommanded for linux.
+#' @param cl_type cluster type (default "PSOCK"). "FORK" is recommended for linux.
#' @param ... Additional arguments to be passed to the glmmTMB::glmmTMB function.
#' @export
#' @return A list of updated GLMNB models.
#'
#' @examples
+#' # -- Example usage: update formula
#' data(iris)
#' groups <- unique(iris$Species)
#' group_by <- "Species"
@@ -3022,22 +3057,153 @@ test_that("fitModelParallel fits models in parallel for each group and returns a
#' fitted_models <- fitModelParallel(formula, iris, group_by, n.cores = 1)
#' new_formula <- Sepal.Length ~ Sepal.Width
#' results <- updateParallel(new_formula, fitted_models, n.cores = 1)
-updateParallel <- function(formula, list_tmb, n.cores = NULL, cl_type = "PSOCK",
- log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"), ...) {
-
-
- isValidInput2fit(list_tmb[[1]]$frame, formula)
-
- is_fullrank(list_tmb[[1]]$frame, formula)
+#' #' # Example usage: update reference
+#' # -- Load the mtcars dataset
+#' data("mtcars")
+#' # -- Specify categorical variables
+#' mtcars$vs <- factor(mtcars$vs) ## Engine (0 = V-shaped, 1 = straight)
+#' levels(mtcars$vs) <- c("V-shaped", "straight")
+#' mtcars$am <- factor(mtcars$am) ## Transmission (0 = automatic, 1 = manual)
+#' levels(mtcars$am) <- c("automatic", "manual")
+#' # -- For each group of number of cylinders:
+#' # -- Explain fuel consumption with engine shape, Gross horsepower, and transmission type
+#' list_tmb <- fitModelParallel(formula = mpg ~ hp + vs + am,
+#' data = mtcars, group_by = "cyl", n.cores = 1)
+#' # -- Relevel transmission and engine shape variables
+#' list_tmb <- updateParallel(formula = mpg ~ hp + vs + am, list_tmb,
+#' reference_labels = c("straight", "manual"), n.cores = 1)
+updateParallel <- function (formula, list_tmb, reference_labels = c(), n.cores = NULL, cl_type = "PSOCK",
+ log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"),
+ ...) {
+ stopifnot(is.list(list_tmb))
+ non_null_idx <- first_non_null_index(list_tmb)
+ if (!is.null(non_null_idx)){
+ stopifnot(is.data.frame(list_tmb[[non_null_idx]]$frame))
+ isValidInput2fit(list_tmb[[non_null_idx]]$frame, formula)
+ list_tmb <- relevelling_factors(list_tmb, reference_labels)
+ message(paste("Log file location", log_file, sep = ": "))
+ list_tmb <- parallel_update(formula, list_tmb, n.cores, log_file, cl_type, ...)
+ clear_memory(except_obj = list_tmb)
+ }
+ return(list_tmb)
+}
+
+
+#' Re-levels categorical variables in a the frame of a list of glmmTMB objects.
+#'
+#' This function re-levels categorical variables in a list of glmmTMB objects using the specified reference labels.
+#'
+#' @param list_tmb List of glmmTMB objects.
+#' @param categorical_vars Names of the categorical variables to be re-leveled.
+#' @param ref_labels Vector of reference labels corresponding to the categorical variables.
+#' @return A list of glmmTMB objects with re-leveled categorical variables.
+#' @export
+#'
+#' @examples
+#' # Example usage:
+#' # -- Load the mtcars dataset
+#' data("mtcars")
+#' ## -- specify categorical var
+#' mtcars$vs <- factor(mtcars$vs) ## Engine (0 = V-shaped, 1 = straight)
+#' levels(mtcars$vs) <- c("V-shaped", "straight")
+#' mtcars$am <- factor(mtcars$am) ## Transmission (0 = automatic, 1 = manual)
+#' levels(mtcars$am) <- c("automatic", "manual")
+#' # -- For each group of number of cylinders,
+#' # -- Explain fuel consumption with engine shape, Gross horsepower, and transmission type
+#' list_tmb <- fitModelParallel(formula = mpg ~ hp + vs + am,
+#' data = mtcars, group_by = "cyl", n.cores = 1)
+#' # -- Relevel transmission and engine shape variables
+#' relevel_list_tmb_frame(list_tmb, c("am", "vs"), c("manual", "straight"))
+relevel_list_tmb_frame <- function(list_tmb, categorical_vars, ref_labels){
+ names(ref_labels) <- categorical_vars
+ lapply(list_tmb, function( tmb_obj ) {
+ if (!is.null(tmb_obj)){
+ for (categorical_var in names(ref_labels)) {
+ reference_label <- ref_labels[categorical_var]
+ tmb_obj$frame[[categorical_var]] <- stats::relevel(tmb_obj$frame[[categorical_var]], ref = reference_label)
+ }
+ }
+ return(tmb_obj)
+ })
+}
+
+
+#' Detects categorical variables based on reference labels in a glmmTMB object.
+#'
+#' This function detects categorical variables based on reference labels in a glmmTMB object's frame.
+#'
+#' @param tmb_frame The data frame of a glmmTMB object.
+#' @param ref_labels Vector of reference labels corresponding to categorical variables.
+#' @return Names of the categorical variables detected.
+#' @export
+#'
+#' @examples
+#' data("mtcars")
+#' ## -- specify categorical var
+#' mtcars$vs <- factor(mtcars$vs) ## Engine (0 = V-shaped, 1 = straight)
+#' levels(mtcars$vs) <- c("V-shaped", "straight")
+#' mtcars$am <- factor(mtcars$am) ## Transmission (0 = automatic, 1 = manual)
+#' levels(mtcars$am) <- c("automatic", "manual")
+#' ## -- For each group of number of cylinder,
+#' ## -- explain fuel consumption with engine shape, Gross horsepower, and transmission type
+#' list_tmb <- fitModelParallel(formula = mpg ~ hp + vs + am,
+#' data = mtcars, group_by = "cyl" , n.cores = 1)
+#' detect_categoricals_vars(list_tmb[["6"]]$frame, c("straight", "manual"))
+detect_categoricals_vars <- function(tmb_frame, ref_labels){
+ idx_col <- c()
+ for (reference_label in ref_labels){
+
+ catego_var_idx_col <- unique(which(tmb_frame == reference_label, arr.ind = T)[, "col"])
+
+ if (length(catego_var_idx_col) > 1) {
+ message_err <- paste("Label", reference_label, " detected in the metadata across different columns.\nUnable to determine the correct columns for re-leveling.\nPlease ensure that reference labels are specific to individual columns for re-leveling")
+ stop(message_err)
+ }
+
+ if (length(catego_var_idx_col) == 0) {
+ ref_label_str <- paste(ref_labels , collapse = ", ")
+ message_err <- paste("Label", reference_label, "not found in metadata.")
+ stop(message_err)
+ }
+
+ idx_col <- c(idx_col, catego_var_idx_col)
+ }
- ## -- ## -- print log location
- message( paste("Log file location", log_file, sep =': ') )
-
- # Fit models update in parallel and capture the results
- results <- parallel_update(formula, list_tmb, n.cores, log_file, cl_type, ...)
- return(results)
+ return(colnames(tmb_frame)[idx_col])
}
+#' Relevels factors in a list of glmmTMB objects using specified reference labels.
+#'
+#' This function re-levels factors in a list of glmmTMB objects based on the specified reference labels.
+#'
+#' @param list_tmb List of glmmTMB objects.
+#' @param reference_labels Vector of reference labels.
+#' @return A list of glmmTMB objects with re-leveled factors.
+#' @export
+#'
+#' @examples
+#' data("mtcars")
+#' ## -- specify categorical var
+#' mtcars$vs <- factor(mtcars$vs) ## Engine (0 = V-shaped, 1 = straight)
+#' levels(mtcars$vs) <- c("V-shaped", "straight")
+#' mtcars$am <- factor(mtcars$am) ## Transmission (0 = automatic, 1 = manual)
+#' levels(mtcars$am) <- c("automatic", "manual")
+#' ## -- For each group of number of cylinder,
+#' ## -- explain fuel consumption with engine shape, Gross horsepower, and transmission type
+#' list_tmb <- fitModelParallel(formula = mpg ~ hp + vs + am,
+#' data = mtcars, group_by = "cyl", n.cores = 1 )
+#' relevelling_factors(list_tmb , c("straight", "manual"))
+relevelling_factors <- function(list_tmb, reference_labels ){
+ if (length(reference_labels) > 0){
+ l_categorical_vars <- detect_categoricals_vars(list_tmb[[1]]$frame, reference_labels)
+ list_tmb <- relevel_list_tmb_frame(list_tmb, l_categorical_vars, reference_labels)
+ }
+ return(list_tmb)
+}
+
+
+
+
#' Internal function to fit glmmTMB models in parallel.
#'
@@ -3062,18 +3228,13 @@ updateParallel <- function(formula, list_tmb, n.cores = NULL, cl_type = "PSOCK",
parallel_update <- function(formula, list_tmb, n.cores = NULL,
log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"),
cl_type = "PSOCK" , ...) {
-
if (is.null(n.cores)) n.cores <- max(1, parallel::detectCores(logical = FALSE) - 1)
-
message(paste("CPU(s) number :", n.cores, sep = " "))
message(paste("Cluster type :", cl_type, sep = " "))
-
-
clust <- parallel::makeCluster(n.cores, type= cl_type, outfile = log_file)
- parallel::clusterExport(clust, c("launchUpdate", "fitUpdate"))
+ parallel::clusterExport(clust, c("launchUpdate", "fitUpdate", "is_fullrank", "drop_randfx"))
updated_res <- parallel::parLapply(clust, X = list_tmb, fun = launchUpdate , formula = formula, ...)
parallel::stopCluster(clust) ; invisible(gc(reset = T, verbose = F, full = T));
-
return(updated_res)
}
@@ -3098,8 +3259,8 @@ parallel_update <- function(formula, list_tmb, n.cores = NULL,
#' updated_model <- fitUpdate("setosa", fitted_models[[1]], new_formula)
fitUpdate <- function(group, glmm_obj, formula , ...){
data <- glmm_obj$frame
+ is_fullrank(data, formula)
resUpdt <- stats::update(glmm_obj, formula, ...)
-
resUpdt$frame <- data
## save groupID => avoid error in future update
resUpdt$groupId <- group
@@ -3110,7 +3271,6 @@ fitUpdate <- function(group, glmm_obj, formula , ...){
## control in ... => avoid error in future update
controlArgs <- additional_args[['control']]
if (!is.null(controlArgs)) resUpdt$call$control <- controlArgs
-
return(resUpdt)
}
@@ -3134,11 +3294,12 @@ fitUpdate <- function(group, glmm_obj, formula , ...){
#' new_formula <- Sepal.Length ~ Sepal.Width
#' updated_model <- launchUpdate(fitted_models[[1]], new_formula)
launchUpdate <- function(glmm_obj, formula, ...) {
+ if (is.null(glmm_obj)) return(NULL)
group <- glmm_obj$groupId
tryCatch(
expr = {
withCallingHandlers(
- fitUpdate(group ,glmm_obj, formula, ...),
+ fitUpdate(group, glmm_obj, formula, ...),
warning = function(w) {
message(paste(Sys.time(), "warning for group", group ,":", conditionMessage(w)))
invokeRestart("muffleWarning")
@@ -3197,8 +3358,105 @@ test_that("updateParallel function returns correct results", {
n.cores = 1,
family = glmmTMB::ziGamma(link = "inverse")))
expect_s3_class(updated_updated_model$setosa$call$family, "family")
+
+
+ ## -- update label reference
+ data("mtcars")
+ # -- Specify categorical variables
+ mtcars$vs <- factor(mtcars$vs) ## Engine (0 = V-shaped, 1 = straight)
+ levels(mtcars$vs) <- c("V-shaped", "straight")
+ mtcars$am <- factor(mtcars$am) ## Transmission (0 = automatic, 1 = manual)
+ levels(mtcars$am) <- c("automatic", "manual")
+ # -- For each group of number of cylinders:
+ # -- Explain fuel consumption with engine shape, Gross horsepower, and transmission type
+ list_tmb <- fitModelParallel(formula = mpg ~ hp + vs + am, data = mtcars, group_by = "cyl", n.cores = 1)
+ # -- Relevel transmission and engine shape variables
+ reference_labels <- c("straight", "manual")
+ result <- updateParallel(formula = mpg ~ hp + vs + am, list_tmb = list_tmb, reference_labels = reference_labels, n.cores = 1)
+
+ # Check if the returned list has the same length as the mock list
+ expect_equal(length(result), length(list_tmb))
+ expect_equal(levels(result[["6"]]$frame$am)[1] , "manual")
+ expect_equal(levels(result[["4"]]$frame$am)[1] , "manual")
+ expect_equal(levels(result[["6"]]$frame$vs)[1] , "straight")
+ expect_equal(levels(result[["4"]]$frame$vs)[1] , "straight")
+
+})
+
+
+
+# Test for relevel_list_tmb_frame function
+test_that("relevel_list_tmb_frame re-levels categorical variables correctly", {
+ data("mtcars")
+ # -- Specify categorical variables
+ mtcars$vs <- factor(mtcars$vs) ## Engine (0 = V-shaped, 1 = straight)
+ levels(mtcars$vs) <- c("V-shaped", "straight")
+ mtcars$am <- factor(mtcars$am) ## Transmission (0 = automatic, 1 = manual)
+ levels(mtcars$am) <- c("automatic", "manual")
+ # -- For each group of number of cylinders:
+ # -- Explain fuel consumption with engine shape, Gross horsepower, and transmission type
+ list_tmb <- fitModelParallel(formula = mpg ~ hp + vs + am, data = mtcars, group_by = "cyl", n.cores = 1)
+ # -- Relevel transmission and engine shape variables
+ reference_labels <- c("straight", "manual")
+ result <- relevel_list_tmb_frame(list_tmb, c("vs", "am"), reference_labels)
+
+ # Check if the returned list has the same length as the mock list
+ expect_equal(length(result), length(list_tmb))
+ # Check if categorical variables have been re-leveled correctly
+ expect_equal(levels(result[["6"]]$frame$am)[1] , "manual")
+ expect_equal(levels(result[["4"]]$frame$am)[1] , "manual")
+ expect_equal(levels(result[["6"]]$frame$vs)[1] , "straight")
+ expect_equal(levels(result[["4"]]$frame$vs)[1] , "straight")
+})
+
+# Test for relevelling_factors function
+test_that("relevelling_factors relevel categorical variables correctly", {
+ data("mtcars")
+ # -- Specify categorical variables
+ mtcars$vs <- factor(mtcars$vs) ## Engine (0 = V-shaped, 1 = straight)
+ levels(mtcars$vs) <- c("V-shaped", "straight")
+ mtcars$am <- factor(mtcars$am) ## Transmission (0 = automatic, 1 = manual)
+ levels(mtcars$am) <- c("automatic", "manual")
+ # -- For each group of number of cylinders:
+ # -- Explain fuel consumption with engine shape, Gross horsepower, and transmission type
+ list_tmb <- fitModelParallel(formula = mpg ~ hp + vs + am, data = mtcars, group_by = "cyl", n.cores = 1)
+ # -- Relevel transmission and engine shape variables
+ reference_labels <- c("straight", "manual")
+ result <- relevelling_factors(list_tmb, reference_labels)
+
+ # Check if the returned list has the same length as the mock list
+ expect_equal(length(result), length(list_tmb))
+ # Check if categorical variables have been re-leveled correctly
+ expect_equal(levels(result[["6"]]$frame$am)[1] , "manual")
+ expect_equal(levels(result[["4"]]$frame$am)[1] , "manual")
+ expect_equal(levels(result[["6"]]$frame$vs)[1] , "straight")
+ expect_equal(levels(result[["4"]]$frame$vs)[1] , "straight")
+})
+
+
+
+# Test for detect_categoricals_vars function
+test_that("detect_categoricals_vars detect categorical variables correctly", {
+ data("mtcars")
+ # -- Specify categorical variables
+ mtcars$vs <- factor(mtcars$vs) ## Engine (0 = V-shaped, 1 = straight)
+ levels(mtcars$vs) <- c("V-shaped", "straight")
+ mtcars$am <- factor(mtcars$am) ## Transmission (0 = automatic, 1 = manual)
+ levels(mtcars$am) <- c("automatic", "manual")
+ # -- For each group of number of cylinders:
+ # -- Explain fuel consumption with engine shape, Gross horsepower, and transmission type
+ list_tmb <- fitModelParallel(formula = mpg ~ hp + vs + am, data = mtcars, group_by = "cyl", n.cores = 1)
+ # -- Relevel transmission and engine shape variables
+ reference_labels <- c("straight", "manual")
+ result <- detect_categoricals_vars(list_tmb[["6"]]$frame, reference_labels)
+
+ # Check if the returned list has the same length as the mock list
+ expect_equal(length(result), length(reference_labels))
+ # Check if categorical variables have been re-leveled correctly
+ expect_equal(result, c("vs", "am"))
})
+
# Test parallel_update function
test_that("parallel_update function returns correct results", {
# Load the required data
@@ -6011,7 +6269,9 @@ compute_rsquare <- function(data, grouping_by = c("from", "description") ){
#' @return A data frame with additional columns for labeling in the plot.
#' @export
#' @examples
-#' data_rsquare <- data.frame(from = c("A", "B", "C"), description = c("Desc1", "Desc2", "Desc3"), R2 = c(0.9, 0.8, 0.7))
+#' data_rsquare <- data.frame(from = c("A", "B", "C"),
+#' description = c("Desc1", "Desc2", "Desc3"),
+#' R2 = c(0.9, 0.8, 0.7))
#' result <- get_rsquare_2plot(data_rsquare)
get_rsquare_2plot <- function(data_rsquare){
data_rsquare$pos_x <- -Inf
@@ -8405,7 +8665,7 @@ test_that("get_eval_data returns correct output", {
#' result <- wrap_dds(dds, lfcThreshold = 1, altHypothesis = "greater")
#' @export
wrap_dds <- function(dds, lfcThreshold , altHypothesis, correction_method = "BH") {
- dds_full <- S4Vectors::mcols(dds) %>% as.data.frame()
+ dds_full <- as.data.frame(S4Vectors::mcols(dds))
## -- dispersion
message("INFO: The dispersion values from DESeq2 were reparametrized to their reciprocals (1/dispersion).")
@@ -8653,6 +8913,7 @@ test_that("wrapperDESeq2 function works correctly", {
})
+
```
@@ -9342,7 +9603,7 @@ test_that("calculate_actualMixed calculates actual mixed effects as expected", {
```
```{r development-inflate, eval=FALSE}
-setwd("/Users/ex_dya/Documents/LBMC/HTRfit/")
+setwd("/home/adminarnaud/Documents/HTRfit/")
#usethis::create_package(path = "/Users/ex_dya/Documents/LBMC/HTRfit/")
fusen::fill_description(fields = list(Title = "HTRfit"), overwrite = T)
usethis::use_gpl_license(version = 3, include_future = TRUE)
@@ -9350,5 +9611,6 @@ 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 = NA, open_vignette = F, overwrite = T)
+fusen::inflate(pkg = "/home/adminarnaud/Documents/HTRfit/", flat_file = "dev/flat_full.Rmd",
+ vignette_name = NA, open_vignette = F, overwrite = T)
```
diff --git a/man/detect_categoricals_vars.Rd b/man/detect_categoricals_vars.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..c4b7014e97871a3f093cb72cf2a72f97724698fb
--- /dev/null
+++ b/man/detect_categoricals_vars.Rd
@@ -0,0 +1,32 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/update_fittedmodel.R
+\name{detect_categoricals_vars}
+\alias{detect_categoricals_vars}
+\title{Detects categorical variables based on reference labels in a glmmTMB object.}
+\usage{
+detect_categoricals_vars(tmb_frame, ref_labels)
+}
+\arguments{
+\item{tmb_frame}{The data frame of a glmmTMB object.}
+
+\item{ref_labels}{Vector of reference labels corresponding to categorical variables.}
+}
+\value{
+Names of the categorical variables detected.
+}
+\description{
+This function detects categorical variables based on reference labels in a glmmTMB object's frame.
+}
+\examples{
+data("mtcars")
+## -- specify categorical var
+mtcars$vs <- factor(mtcars$vs) ## Engine (0 = V-shaped, 1 = straight)
+levels(mtcars$vs) <- c("V-shaped", "straight")
+mtcars$am <- factor(mtcars$am) ## Transmission (0 = automatic, 1 = manual)
+levels(mtcars$am) <- c("automatic", "manual")
+## -- For each group of number of cylinder,
+## -- explain fuel consumption with engine shape, Gross horsepower, and transmission type
+list_tmb <- fitModelParallel(formula = mpg ~ hp + vs + am,
+ data = mtcars, group_by = "cyl" , n.cores = 1)
+detect_categoricals_vars(list_tmb[["6"]]$frame, c("straight", "manual"))
+}
diff --git a/man/first_non_null_index.Rd b/man/first_non_null_index.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..1335087032e620b19406b84a3bc599fd11533528
--- /dev/null
+++ b/man/first_non_null_index.Rd
@@ -0,0 +1,21 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/utils.R
+\name{first_non_null_index}
+\alias{first_non_null_index}
+\title{Finds the index of the first non-null element in a list.}
+\usage{
+first_non_null_index(lst)
+}
+\arguments{
+\item{lst}{The list to search.}
+}
+\value{
+The index of the first non-null element, or NULL if no non-null element is found.
+}
+\description{
+This function searches a list and returns the index of the first non-null element.
+}
+\examples{
+my_list <- list(NULL, NULL, 3, 5, NULL)
+first_non_null_index(my_list) # Returns 3
+}
diff --git a/man/get_rsquare_2plot.Rd b/man/get_rsquare_2plot.Rd
index 8dc20c67dc0ac49eabcf121a259c8be60ed2f392..37bb6647f511a5e30f26f068e8544eee74dc4038 100644
--- a/man/get_rsquare_2plot.Rd
+++ b/man/get_rsquare_2plot.Rd
@@ -17,6 +17,8 @@ This function takes a data frame with R-squared values,
computes position coordinates, and prepares data for plotting.
}
\examples{
-data_rsquare <- data.frame(from = c("A", "B", "C"), description = c("Desc1", "Desc2", "Desc3"), R2 = c(0.9, 0.8, 0.7))
+data_rsquare <- data.frame(from = c("A", "B", "C"),
+ description = c("Desc1", "Desc2", "Desc3"),
+ R2 = c(0.9, 0.8, 0.7))
result <- get_rsquare_2plot(data_rsquare)
}
diff --git a/man/relevel_list_tmb_frame.Rd b/man/relevel_list_tmb_frame.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..81d1c33afb9487f4f9711866f3fb59ec54364323
--- /dev/null
+++ b/man/relevel_list_tmb_frame.Rd
@@ -0,0 +1,37 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/update_fittedmodel.R
+\name{relevel_list_tmb_frame}
+\alias{relevel_list_tmb_frame}
+\title{Re-levels categorical variables in a the frame of a list of glmmTMB objects.}
+\usage{
+relevel_list_tmb_frame(list_tmb, categorical_vars, ref_labels)
+}
+\arguments{
+\item{list_tmb}{List of glmmTMB objects.}
+
+\item{categorical_vars}{Names of the categorical variables to be re-leveled.}
+
+\item{ref_labels}{Vector of reference labels corresponding to the categorical variables.}
+}
+\value{
+A list of glmmTMB objects with re-leveled categorical variables.
+}
+\description{
+This function re-levels categorical variables in a list of glmmTMB objects using the specified reference labels.
+}
+\examples{
+# Example usage:
+# -- Load the mtcars dataset
+data("mtcars")
+## -- specify categorical var
+mtcars$vs <- factor(mtcars$vs) ## Engine (0 = V-shaped, 1 = straight)
+levels(mtcars$vs) <- c("V-shaped", "straight")
+mtcars$am <- factor(mtcars$am) ## Transmission (0 = automatic, 1 = manual)
+levels(mtcars$am) <- c("automatic", "manual")
+# -- For each group of number of cylinders,
+# -- Explain fuel consumption with engine shape, Gross horsepower, and transmission type
+list_tmb <- fitModelParallel(formula = mpg ~ hp + vs + am,
+ data = mtcars, group_by = "cyl", n.cores = 1)
+# -- Relevel transmission and engine shape variables
+relevel_list_tmb_frame(list_tmb, c("am", "vs"), c("manual", "straight"))
+}
diff --git a/man/relevelling_factors.Rd b/man/relevelling_factors.Rd
new file mode 100644
index 0000000000000000000000000000000000000000..94013d0b18569ed9d851df6b61d4c9f3bdfcc1bb
--- /dev/null
+++ b/man/relevelling_factors.Rd
@@ -0,0 +1,32 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/update_fittedmodel.R
+\name{relevelling_factors}
+\alias{relevelling_factors}
+\title{Relevels factors in a list of glmmTMB objects using specified reference labels.}
+\usage{
+relevelling_factors(list_tmb, reference_labels)
+}
+\arguments{
+\item{list_tmb}{List of glmmTMB objects.}
+
+\item{reference_labels}{Vector of reference labels.}
+}
+\value{
+A list of glmmTMB objects with re-leveled factors.
+}
+\description{
+This function re-levels factors in a list of glmmTMB objects based on the specified reference labels.
+}
+\examples{
+data("mtcars")
+## -- specify categorical var
+mtcars$vs <- factor(mtcars$vs) ## Engine (0 = V-shaped, 1 = straight)
+levels(mtcars$vs) <- c("V-shaped", "straight")
+mtcars$am <- factor(mtcars$am) ## Transmission (0 = automatic, 1 = manual)
+levels(mtcars$am) <- c("automatic", "manual")
+## -- For each group of number of cylinder,
+## -- explain fuel consumption with engine shape, Gross horsepower, and transmission type
+list_tmb <- fitModelParallel(formula = mpg ~ hp + vs + am,
+ data = mtcars, group_by = "cyl", n.cores = 1 )
+relevelling_factors(list_tmb , c("straight", "manual"))
+}
diff --git a/man/updateParallel.Rd b/man/updateParallel.Rd
index 665857d2a1a41a7d414823898c0d815215865922..616c6cc74b7503062d79a86f8d4119f04ecfb334 100644
--- a/man/updateParallel.Rd
+++ b/man/updateParallel.Rd
@@ -7,6 +7,7 @@
updateParallel(
formula,
list_tmb,
+ reference_labels = c(),
n.cores = NULL,
cl_type = "PSOCK",
log_file = paste(tempdir(check = FALSE), "htrfit.log", sep = "/"),
@@ -18,9 +19,11 @@ updateParallel(
\item{list_tmb}{List of glmmTMB objects.}
+\item{reference_labels}{Vector of reference labels. Default is c(), selecting the first alphanumeric label as reference.}
+
\item{n.cores}{Number of cores to use for parallel processing. If NULL, the function will use all available cores.}
-\item{cl_type}{cluster type (defautl "PSOCK"). "FORK" is recommanded for linux.}
+\item{cl_type}{cluster type (default "PSOCK"). "FORK" is recommended for linux.}
\item{log_file}{File path for the log output (default: Rtmpdir/htrfit.log).}
@@ -30,9 +33,12 @@ updateParallel(
A list of updated GLMNB models.
}
\description{
-This function fits glmmTMB models in parallel using multiple cores, allowing for faster computation.
+This function updates glmmTMB models in parallel using multiple cores, allowing for faster computation.
+It updates the models with new reference labels if specified.
+It can also be used to fit a new formula or to change additional parameters of glmmTMB (param : "...").
}
\examples{
+# -- Example usage: update formula
data(iris)
groups <- unique(iris$Species)
group_by <- "Species"
@@ -40,4 +46,19 @@ 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)
+# Example usage: update reference
+# -- Load the mtcars dataset
+data("mtcars")
+# -- Specify categorical variables
+mtcars$vs <- factor(mtcars$vs) ## Engine (0 = V-shaped, 1 = straight)
+levels(mtcars$vs) <- c("V-shaped", "straight")
+mtcars$am <- factor(mtcars$am) ## Transmission (0 = automatic, 1 = manual)
+levels(mtcars$am) <- c("automatic", "manual")
+# -- For each group of number of cylinders:
+# -- Explain fuel consumption with engine shape, Gross horsepower, and transmission type
+list_tmb <- fitModelParallel(formula = mpg ~ hp + vs + am,
+ data = mtcars, group_by = "cyl", n.cores = 1)
+# -- Relevel transmission and engine shape variables
+list_tmb <- updateParallel(formula = mpg ~ hp + vs + am, list_tmb,
+ reference_labels = c("straight", "manual"), n.cores = 1)
}
diff --git a/tests/testthat/test-actual_interactionfixeffects.R b/tests/testthat/test-actual_interactionfixeffects.R
index 3dea605b867e89024f77a4c7c002f9e75f0d23cb..fdd12c253c65fcc8962fd7fa2d94f64c72bffb34 100644
--- a/tests/testthat/test-actual_interactionfixeffects.R
+++ b/tests/testthat/test-actual_interactionfixeffects.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
test_that("filter_dataframe retourne le dataframe filtré correctement", {
diff --git a/tests/testthat/test-actual_mainfixeffects.R b/tests/testthat/test-actual_mainfixeffects.R
index 0c47b6aae29a7214fb4163570b124c188708ba1e..308ad816dc00cba812d1b7e4eb78b37a250a3654 100644
--- a/tests/testthat/test-actual_mainfixeffects.R
+++ b/tests/testthat/test-actual_mainfixeffects.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
test_that("Test for subsetFixEffectInferred function", {
diff --git a/tests/testthat/test-anova.R b/tests/testthat/test-anova.R
index 5959558737740b4545d2faa8e8ca5a13087e2eee..d8b544b8c6fcf662dc2bb0f8bb97069a8317037d 100644
--- a/tests/testthat/test-anova.R
+++ b/tests/testthat/test-anova.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
diff --git a/tests/testthat/test-basal_expression_scaling.R b/tests/testthat/test-basal_expression_scaling.R
index 86876f855ef01a1028d16ca8b40b76950f177c14..170623fe7cae9b3c66a61de4a79e487e1d1e8f90 100644
--- a/tests/testthat/test-basal_expression_scaling.R
+++ b/tests/testthat/test-basal_expression_scaling.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
test_that("generate_basal_expression returns correct number of genes", {
diff --git a/tests/testthat/test-counts_plot.R b/tests/testthat/test-counts_plot.R
index e0c29ee85640dce33d386516f080da17cfa27e08..5f2bad2fa39733a68dca9f5706086fb29c5f5655 100644
--- a/tests/testthat/test-counts_plot.R
+++ b/tests/testthat/test-counts_plot.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
diff --git a/tests/testthat/test-datafrommvrnorm_manipulations.R b/tests/testthat/test-datafrommvrnorm_manipulations.R
index 7e1bb398bbe2ee8e0081a234644c6e46a49e0fd6..8b2dcbb1c1fa15ec0d34983d37e46a7e171ecb96 100644
--- a/tests/testthat/test-datafrommvrnorm_manipulations.R
+++ b/tests/testthat/test-datafrommvrnorm_manipulations.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# 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()
diff --git a/tests/testthat/test-datafromuser_manipulations.R b/tests/testthat/test-datafromuser_manipulations.R
index f2fd8db34ba49488f1efb98b456a5a6fd1a35513..a8997d19af361a1812fecf219be0fe041cc2d840 100644
--- a/tests/testthat/test-datafromuser_manipulations.R
+++ b/tests/testthat/test-datafromuser_manipulations.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# 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", {
diff --git a/tests/testthat/test-evaluate_dispersion.R b/tests/testthat/test-evaluate_dispersion.R
index 46c4bce469b57943fe809ec34ec0f251d4640947..cb7215836d1afb669e4a928ace67caae07f1776d 100644
--- a/tests/testthat/test-evaluate_dispersion.R
+++ b/tests/testthat/test-evaluate_dispersion.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
diff --git a/tests/testthat/test-evaluation_identity.R b/tests/testthat/test-evaluation_identity.R
index 1dedef1372f817c32baa8cdb8a2d1b142d0db23a..793bee512296e253a52be40d35c496fb089d9694 100644
--- a/tests/testthat/test-evaluation_identity.R
+++ b/tests/testthat/test-evaluation_identity.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
diff --git a/tests/testthat/test-evaluation_withmixedeffect.R b/tests/testthat/test-evaluation_withmixedeffect.R
index fbaee4dc2fbae2dc9493183126ed22c89b1470a0..0d7af6f761ac101850dd14cf8e063718e2dde0a7 100644
--- a/tests/testthat/test-evaluation_withmixedeffect.R
+++ b/tests/testthat/test-evaluation_withmixedeffect.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
diff --git a/tests/testthat/test-fitmodel.R b/tests/testthat/test-fitmodel.R
index e6a11fc56206bbd54735b905ccc9369a0b2d3cf4..5b0d2e8b81ab9a58b75792b3aa0a7256dd3984ff 100644
--- a/tests/testthat/test-fitmodel.R
+++ b/tests/testthat/test-fitmodel.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
@@ -90,8 +90,9 @@ test_that("Detect rank-deficient model matrix and throw error", {
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.")
+ expect_warning(is_fullrank(metadata, formula))
+ res <- suppressWarnings(is_fullrank(metadata, formula))
+ expect_false(res)
})
# Test if a rank-deficient model matrix is detected and throws an error
@@ -101,8 +102,9 @@ test_that("Detect rank-deficient model matrix and throw error (with random eff)"
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.")
+ expect_warning(is_fullrank(metadata, formula))
+ res <- suppressWarnings(is_fullrank(metadata, formula))
+ expect_false(res)
})
# Test if a rank-deficient model matrix is detected and throws an error
diff --git a/tests/testthat/test-glance_glmmtmb.R b/tests/testthat/test-glance_glmmtmb.R
index 9e5d6cc172db0eecfe54a1b6e803a2c03c06ab87..6b1c4a4dd4784817ce7945ad29a07a1a87f68f8a 100644
--- a/tests/testthat/test-glance_glmmtmb.R
+++ b/tests/testthat/test-glance_glmmtmb.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# 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", {
diff --git a/tests/testthat/test-mock_rnaseq.R b/tests/testthat/test-mock_rnaseq.R
index ac3bcf3ec4c76daa86769cccc92ae50fff875432..6596bc42db8ffa8c6faff3855e488ef0751b6aa8 100644
--- a/tests/testthat/test-mock_rnaseq.R
+++ b/tests/testthat/test-mock_rnaseq.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
# Test for is_dispersionMatrixValid
diff --git a/tests/testthat/test-plot_metrics.R b/tests/testthat/test-plot_metrics.R
index d52f49d6059469a1886e819cf94aaa13db099ec3..777d3835f3893e9c8fbc1d949661326c5aafde1a 100644
--- a/tests/testthat/test-plot_metrics.R
+++ b/tests/testthat/test-plot_metrics.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
diff --git a/tests/testthat/test-precision_recall.R b/tests/testthat/test-precision_recall.R
index da447006972340880ded1822e9c5a7ba06a0e31e..047b1b762b268f47fdcfa57d5fd1c73cb347ee58 100644
--- a/tests/testthat/test-precision_recall.R
+++ b/tests/testthat/test-precision_recall.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
diff --git a/tests/testthat/test-prepare_data2fit.R b/tests/testthat/test-prepare_data2fit.R
index beb3720b6cba2b6e3fd11cb8b6d0cad45126b1d8..4e7a7b659127ad4e98de5c7628c31f17778ef4ac 100644
--- a/tests/testthat/test-prepare_data2fit.R
+++ b/tests/testthat/test-prepare_data2fit.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
diff --git a/tests/testthat/test-receiver_operating_characteristic.R b/tests/testthat/test-receiver_operating_characteristic.R
index 4e4aeacfa33e687f78e384adbd728050ace21747..016cf0a29f541c3974a1898b7fa9f660aa558f78 100644
--- a/tests/testthat/test-receiver_operating_characteristic.R
+++ b/tests/testthat/test-receiver_operating_characteristic.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
diff --git a/tests/testthat/test-sequencing_depth_scaling.R b/tests/testthat/test-sequencing_depth_scaling.R
index 0f1e0a84c1f48b00b76de1f26adc1b8ece4b1ac5..294f05fd537ae1627baf386c5e5c2433e9fb39c2 100644
--- a/tests/testthat/test-sequencing_depth_scaling.R
+++ b/tests/testthat/test-sequencing_depth_scaling.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# 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
diff --git a/tests/testthat/test-setcorrelation.R b/tests/testthat/test-setcorrelation.R
index e70b19df80a04530150d613a63638584cac847ea..118479d6d28ef5e66cdef10c9df39ef5f7748b4e 100644
--- a/tests/testthat/test-setcorrelation.R
+++ b/tests/testthat/test-setcorrelation.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
test_that("compute_covariation returns the correct covariation", {
diff --git a/tests/testthat/test-simulation.R b/tests/testthat/test-simulation.R
index c39d27f36ca4b2abea38be2317ad646c2ba5e41a..0868462c39ce176d6f00730ea482f60971fcfe4d 100644
--- a/tests/testthat/test-simulation.R
+++ b/tests/testthat/test-simulation.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# 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", {
diff --git a/tests/testthat/test-simulation_initialization.R b/tests/testthat/test-simulation_initialization.R
index 01dffa29db1e9084801af2016669e9bb24dedf14..6c3263b1a6a5590e2648b4c3cef4749fc46e70e5 100644
--- a/tests/testthat/test-simulation_initialization.R
+++ b/tests/testthat/test-simulation_initialization.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
test_that("endsWithDigit returns the correct result", {
diff --git a/tests/testthat/test-simulation_report.R b/tests/testthat/test-simulation_report.R
index 4f06316253912f6ca74b4af9ca044dd8f26e6c5f..cdca5d26cb9b59369ff4ecf65f60627bf6a2ba6c 100644
--- a/tests/testthat/test-simulation_report.R
+++ b/tests/testthat/test-simulation_report.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
diff --git a/tests/testthat/test-subsetgenes.R b/tests/testthat/test-subsetgenes.R
index 40ebcb88574d2213a4b0a90be2952a7daafddc72..e79d2fefc1390de66aa4bfa2b536223471673ea8 100644
--- a/tests/testthat/test-subsetgenes.R
+++ b/tests/testthat/test-subsetgenes.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
test_that("subsetGenes return correct ouptut", {
N_GENES = 100
diff --git a/tests/testthat/test-tidy_glmmtmb.R b/tests/testthat/test-tidy_glmmtmb.R
index 06ce9c42ca0e6b57d713a17c1e57da8f9df6283b..40aff2d42b6a8ecfbc6f831b6964d761c3dcfae0 100644
--- a/tests/testthat/test-tidy_glmmtmb.R
+++ b/tests/testthat/test-tidy_glmmtmb.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# 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", {
diff --git a/tests/testthat/test-update_fittedmodel.R b/tests/testthat/test-update_fittedmodel.R
index 74702cd5fdd2d1b56aa21bf7d20a1e56437147e3..9bdadb005ed92f5700c4c65fe87c94f0a3026044 100644
--- a/tests/testthat/test-update_fittedmodel.R
+++ b/tests/testthat/test-update_fittedmodel.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
# Test updateParallel function
test_that("updateParallel function returns correct results", {
@@ -42,8 +42,105 @@ test_that("updateParallel function returns correct results", {
n.cores = 1,
family = glmmTMB::ziGamma(link = "inverse")))
expect_s3_class(updated_updated_model$setosa$call$family, "family")
+
+
+ ## -- update label reference
+ data("mtcars")
+ # -- Specify categorical variables
+ mtcars$vs <- factor(mtcars$vs) ## Engine (0 = V-shaped, 1 = straight)
+ levels(mtcars$vs) <- c("V-shaped", "straight")
+ mtcars$am <- factor(mtcars$am) ## Transmission (0 = automatic, 1 = manual)
+ levels(mtcars$am) <- c("automatic", "manual")
+ # -- For each group of number of cylinders:
+ # -- Explain fuel consumption with engine shape, Gross horsepower, and transmission type
+ list_tmb <- fitModelParallel(formula = mpg ~ hp + vs + am, data = mtcars, group_by = "cyl", n.cores = 1)
+ # -- Relevel transmission and engine shape variables
+ reference_labels <- c("straight", "manual")
+ result <- updateParallel(formula = mpg ~ hp + vs + am, list_tmb = list_tmb, reference_labels = reference_labels, n.cores = 1)
+
+ # Check if the returned list has the same length as the mock list
+ expect_equal(length(result), length(list_tmb))
+ expect_equal(levels(result[["6"]]$frame$am)[1] , "manual")
+ expect_equal(levels(result[["4"]]$frame$am)[1] , "manual")
+ expect_equal(levels(result[["6"]]$frame$vs)[1] , "straight")
+ expect_equal(levels(result[["4"]]$frame$vs)[1] , "straight")
+
+})
+
+
+
+# Test for relevel_list_tmb_frame function
+test_that("relevel_list_tmb_frame re-levels categorical variables correctly", {
+ data("mtcars")
+ # -- Specify categorical variables
+ mtcars$vs <- factor(mtcars$vs) ## Engine (0 = V-shaped, 1 = straight)
+ levels(mtcars$vs) <- c("V-shaped", "straight")
+ mtcars$am <- factor(mtcars$am) ## Transmission (0 = automatic, 1 = manual)
+ levels(mtcars$am) <- c("automatic", "manual")
+ # -- For each group of number of cylinders:
+ # -- Explain fuel consumption with engine shape, Gross horsepower, and transmission type
+ list_tmb <- fitModelParallel(formula = mpg ~ hp + vs + am, data = mtcars, group_by = "cyl", n.cores = 1)
+ # -- Relevel transmission and engine shape variables
+ reference_labels <- c("straight", "manual")
+ result <- relevel_list_tmb_frame(list_tmb, c("vs", "am"), reference_labels)
+
+ # Check if the returned list has the same length as the mock list
+ expect_equal(length(result), length(list_tmb))
+ # Check if categorical variables have been re-leveled correctly
+ expect_equal(levels(result[["6"]]$frame$am)[1] , "manual")
+ expect_equal(levels(result[["4"]]$frame$am)[1] , "manual")
+ expect_equal(levels(result[["6"]]$frame$vs)[1] , "straight")
+ expect_equal(levels(result[["4"]]$frame$vs)[1] , "straight")
})
+# Test for relevelling_factors function
+test_that("relevelling_factors relevel categorical variables correctly", {
+ data("mtcars")
+ # -- Specify categorical variables
+ mtcars$vs <- factor(mtcars$vs) ## Engine (0 = V-shaped, 1 = straight)
+ levels(mtcars$vs) <- c("V-shaped", "straight")
+ mtcars$am <- factor(mtcars$am) ## Transmission (0 = automatic, 1 = manual)
+ levels(mtcars$am) <- c("automatic", "manual")
+ # -- For each group of number of cylinders:
+ # -- Explain fuel consumption with engine shape, Gross horsepower, and transmission type
+ list_tmb <- fitModelParallel(formula = mpg ~ hp + vs + am, data = mtcars, group_by = "cyl", n.cores = 1)
+ # -- Relevel transmission and engine shape variables
+ reference_labels <- c("straight", "manual")
+ result <- relevelling_factors(list_tmb, reference_labels)
+
+ # Check if the returned list has the same length as the mock list
+ expect_equal(length(result), length(list_tmb))
+ # Check if categorical variables have been re-leveled correctly
+ expect_equal(levels(result[["6"]]$frame$am)[1] , "manual")
+ expect_equal(levels(result[["4"]]$frame$am)[1] , "manual")
+ expect_equal(levels(result[["6"]]$frame$vs)[1] , "straight")
+ expect_equal(levels(result[["4"]]$frame$vs)[1] , "straight")
+})
+
+
+
+# Test for detect_categoricals_vars function
+test_that("detect_categoricals_vars detect categorical variables correctly", {
+ data("mtcars")
+ # -- Specify categorical variables
+ mtcars$vs <- factor(mtcars$vs) ## Engine (0 = V-shaped, 1 = straight)
+ levels(mtcars$vs) <- c("V-shaped", "straight")
+ mtcars$am <- factor(mtcars$am) ## Transmission (0 = automatic, 1 = manual)
+ levels(mtcars$am) <- c("automatic", "manual")
+ # -- For each group of number of cylinders:
+ # -- Explain fuel consumption with engine shape, Gross horsepower, and transmission type
+ list_tmb <- fitModelParallel(formula = mpg ~ hp + vs + am, data = mtcars, group_by = "cyl", n.cores = 1)
+ # -- Relevel transmission and engine shape variables
+ reference_labels <- c("straight", "manual")
+ result <- detect_categoricals_vars(list_tmb[["6"]]$frame, reference_labels)
+
+ # Check if the returned list has the same length as the mock list
+ expect_equal(length(result), length(reference_labels))
+ # Check if categorical variables have been re-leveled correctly
+ expect_equal(result, c("vs", "am"))
+})
+
+
# Test parallel_update function
test_that("parallel_update function returns correct results", {
# Load the required data
diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R
index bca87e27de380be42b17f0504db736677f0d0d4b..dbf6fa08f00335de901bbc3d63f298e7dbae3714 100644
--- a/tests/testthat/test-utils.R
+++ b/tests/testthat/test-utils.R
@@ -1,4 +1,13 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
+
+
+# Test for first_non_null_index function
+test_that("first_non_null_index returns the correct index", {
+ lst <- list(NULL, NULL, 3, 5, NULL)
+ expect_equal(first_non_null_index(lst), 3)
+})
+
+
# Test unitaires pour la fonction join_dtf
test_that("join_dtf réalise la jointure correctement", {
diff --git a/tests/testthat/test-waldtest.R b/tests/testthat/test-waldtest.R
index 9aad7dab1a557111eea090a4ca41acda3ad5d785..75d872e96b9e670bc85760b71685bf0932016068 100644
--- a/tests/testthat/test-waldtest.R
+++ b/tests/testthat/test-waldtest.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
# Test unitaires
diff --git a/tests/testthat/test-wrapper_dds.R b/tests/testthat/test-wrapper_dds.R
index 03d57e1e5009191dd0ba0dec6a6f5734020204af..59a2d4eff54a5c37f01caf72f515c1f65753cbe9 100644
--- a/tests/testthat/test-wrapper_dds.R
+++ b/tests/testthat/test-wrapper_dds.R
@@ -1,4 +1,4 @@
-# WARNING - Generated by {fusen} from /dev/flat_full.Rmd: do not edit by hand
+# WARNING - Generated by {fusen} from dev/flat_full.Rmd: do not edit by hand
@@ -119,3 +119,4 @@ test_that("wrapperDESeq2 function works correctly", {
})
+
diff --git a/vignettes/03-rnaseq_analysis.Rmd b/vignettes/03-rnaseq_analysis.Rmd
index bbbc423b13ba144619f7d291acfef5e36652193a..e87f7fd1e35e017448fbe2ba306abb95d56f2fb0 100644
--- a/vignettes/03-rnaseq_analysis.Rmd
+++ b/vignettes/03-rnaseq_analysis.Rmd
@@ -139,7 +139,7 @@ my_tidy_res[1:3,]
## Update fit
-The `updateParallel()` function updates and re-fits a model for each gene. It offers options similar to those in `fitModelParallel()`.
+The `updateParallel()` function updates and re-fits a model for each gene. It offers options similar to those in `fitModelParallel()`. In addition, it is possible to modify the reference level of the categorical variable used in your model in order to use different contrast.
```{r example-update, warning = FALSE, message = FALSE}
@@ -166,6 +166,16 @@ l_tmb <- updateParallel(
list_tmb = l_tmb ,
family = glmmTMB::nbinom2(link = "log"),
n.cores = 1)
+
+## -- modif reference levels
+## -- genotype reference = "genotype2"
+## -- environment reference = "environment2"
+l_tmb <- updateParallel(
+ formula = kij ~ genotype + environment ,
+ list_tmb = l_tmb ,
+ family = glmmTMB::nbinom2(link = "log"),
+ n.cores = 1,
+ reference_labels = c("genotype2", "environment2"))
```
#### Struture of list tmb object