flat_full.Rmd

---
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())
}

#' 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)
}



#' Detect rows in a matrix with all values below a given threshold
#'
#' This function detects rows in a matrix where all values are below a specified threshold.
#'
#' @param matrix The input matrix
#' @param threshold The threshold value
#' @return A logical vector indicating rows below the threshold
#' @export
detect_row_matx_bellow_threshold <- function(matrix, threshold) {
    apply(matrix, 1, function(row) all(row < threshold))
}


#' 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_12349309spe ")
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)
    
}

#' 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
#' @examples
#' data <- data.frame( Category1 = c("A", "B", "A", "B"),
#'                      Category2 = c("X", "Y", "X", "Z"),
#'                      Value = 1:4,
#'                      stringsAsFactors = FALSE )
#' ## -- Convert columns to factors
#' convert2Factor(data, columns = c("Category1", "Category2"))
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)
}

#' 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)
}


#' 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
#'
is_positive_definite <- function(mat) {
  if (nrow(mat) == 0 && ncol(mat) == 0) return(TRUE)
  eigenvalues <- eigen(mat)$values
  all(eigenvalues > 0)
}




#' Get the list of variable names
#'
#' @param list_var R list, e.g., output of init_variable
#'
#' @return
#' A character vector with the names of variables
#' @examples
#' getListVar(init_variable())
#' @export
getListVar <- function(list_var) attributes(list_var)$names

#' Get a given attribute from a list of variables
#'
#' @param list_var A list of variables (already initialized with init_variable)
#' @param attribute A string specifying the attribute to retrieve in all occurrences of the list
#' @export
#' @return
#' A list without NULL values
#' @examples
#' getGivenAttribute(init_variable(), "level")
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
#' @export
#' @return
#' A list of labels per variable
#' 
#' @examples
#' labels <- getLabels(c("varA", "varB"), c(2, 3))
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)
}


#' 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
#' @examples
#' generateGridCombination_fromListVar(init_variable())
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)
}

#' 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", "duplicateeee1333")
#' cleaned_words <- removeDuplicatedWord(words)
removeDuplicatedWord <- function(strings){
  gsub("([A-Za-z]{1,})(\\1{1,})", "\\1", strings, perl = TRUE)
  #gsub("(.*)\\1+", "\\1", strings, perl = TRUE)
}


#' 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)
}



#' Check if a list of glmmTMB objects is valid
#'
#' This function checks if a list of glmmTMB objects is valid. It ensures that the input 
#' list contains glmmTMB objects generated by the `fitModelParallel` function.
#'
#' @param list_tmb A list of glmmTMB objects.
#' @return TRUE if the list is valid, otherwise an error is thrown.
#' @export
isValidList_tmb <- function(list_tmb) {
  stopifnot(is.list(list_tmb))
  
  if (all(sapply(list_tmb, is.null))) {
    stop("All elements in 'list_tmb' are NULL")
  }
  
  invisible(lapply(names(list_tmb), function(i) isValidGlmmTmb(i, list_tmb[[i]])))
  return(TRUE)
}

#' Check if a glmmTMB object is valid
#'
#' This function checks if a glmmTMB object is valid. It ensures that the input object 
#' is a glmmTMB object generated by the `fitModelParallel` function.
#'
#' @param i The name of the object being checked.
#' @param obj The glmmTMB object being checked.
#' @return TRUE if the object is valid, otherwise an error is thrown.
#' @export
isValidGlmmTmb <- function(i, obj) {
  if (is.null(obj)) {
    return(TRUE)
  }
  
  if (!inherits(obj, "glmmTMB")) {
    stop(paste("Element", i, "is not a glmmTMB object. 'list_tmb' should be generated by fitModelParallel"))
  }
  return(TRUE)
}



#' Checks if an object corresponds to a mock object generated by `mock_rnaseq()`.
#'
#' This function verifies if the provided object matches the structure of a mock object generated
#' by `mock_rnaseq()`. A mock object should contain specific named elements: "settings", "init",
#' "groundTruth", "counts", and "metadata".
#'
#' @param obj Object to be checked.
#' @return TRUE or error message
#' @export
isValidMock_obj <- function(obj) {
  message_err <- "'mock_obj' does not correspond to HTRfit mock_obj. 'mock_obj' can be generated using mock_rnaseq()."
  
  if (!is.list(obj)) {
    stop(message_err)
  }
  
  expected_names <- c("settings", "init", "groundTruth", "counts", "metadata", "scaling_factors")
  
  if (!all(expected_names %in% names(obj))) {
    stop(message_err)
  }
  
  if (!all(names(obj) %in% expected_names)){
    warning("Unexpected list element in 'mock_obj'")
  }
    
  return(TRUE)
}



clear_memory <- function(except_obj){
  rm(list = setdiff(ls(), except_obj)) ; invisible(gc( reset = TRUE, verbose = FALSE ))
}


#' Custom Theme for htrfit Plots
#'
#' This function defines a custom theme for plots created with htrfit package.
#' It sets various visual parameters such as background color, grid lines, axis lines, etc.,
#' to provide a consistent and aesthetically pleasing appearance to the plots.
#'
#' @return A ggplot2 theme object with customized visual parameters.
#'
#' @importFrom ggplot2 theme element_rect element_line element_blank element_text
#' @export
theme_htrfit <- function() {
  ggplot2::theme(
    panel.background = ggplot2::element_rect("#ffffff", "#ffffff"),
    panel.grid.major = ggplot2::element_line(color = "#826A50", linetype = "dashed", size = 0.02),
    panel.grid.minor = ggplot2::element_blank(),
    panel.border = ggplot2::element_blank(),
    axis.line.x = ggplot2::element_line(size = 0.5, linetype = "solid", colour = "#362C21"),
    axis.line.y = ggplot2::element_line(size = 0.5, linetype = "solid", colour = "#362C21"),
    strip.background = ggplot2::element_rect(
      color = "white", fill = "#ECEFF1", linewidth = 0.5, linetype = "solid"
    ),
    axis.title = ggplot2::element_text(
      size = 10, color = "black",
      face = "italic"
    ),
    legend.title = ggplot2::element_text(
      size = 10, color = "black",
      face = "italic"
    )
  )
}


```


```{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
  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"))
})


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))
})


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))
})

# 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
})

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 for detect_row_matx_bellow_threshold function
test_that("detect_row_matx_bellow_threshold detects rows below threshold", {
  # Create a sample matrix
  matrix <- matrix(c(0.5, 0.7, 1.2, 0.2, 0.9, 0.9), nrow = 2)
  # Test with threshold 1
  expect_equal(detect_row_matx_bellow_threshold(matrix, 1), c(FALSE, TRUE))
  # Test with threshold 0.5
  expect_equal(detect_row_matx_bellow_threshold(matrix, 0.5), c(FALSE, FALSE))
  expect_equal(detect_row_matx_bellow_threshold(matrix, 2), c(TRUE, TRUE))
})


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( "generateGridCombination_fromListVar return expected output", {
    ## case 1
    gridcom <- generateGridCombination_fromListVar(init_variable())
    expect_s3_class(gridcom, "data.frame")
    expect_equal(gridcom$label_myVariable, factor(c("myVariable1", "myVariable2")))

    ## case 2
    init_variables <- init_variable() %>% init_variable(name = "var" , mu = 2, sd = 1, level = 3) 
    gridcom <- generateGridCombination_fromListVar(init_variables)
    expect_s3_class(gridcom, "data.frame")
    expect_equal(unique(gridcom$label_myVariable), factor(c("myVariable1", "myVariable2")))
    expect_equal(unique(gridcom$label_var), factor(c("var1", "var2", "var3")))

  })

test_that( "getGivenAttribute return expected output", {
  ## -- case 1
  level_attr <- getGivenAttribute(init_variable(), "level")
  expect_equal(level_attr$myVariable, 2)

  ## -- case 2
  init_variables <- init_variable() %>% init_variable(name = "var" , mu = 2, sd = 1, level = 3) 
  mu_attr <- getGivenAttribute(init_variables, "mu")
  expect_equal(mu_attr$var, 2)
} )



test_that("isValidList_tmb function", {
  # Test with a valid list of glmmTMB objects
  l_tmb <- list("model1" = glmmTMB::glmmTMB(mpg ~ hp + vs + am + (1|cyl), data = mtcars),
                 "model2" = glmmTMB::glmmTMB(mpg ~ hp + vs + am + (1|cyl), data = mtcars))
  expect_true(isValidList_tmb(l_tmb))
  
  # Test with a list containing NULL elements
  expect_error(isValidList_tmb(list(NULL, NULL)), "All elements in 'list_tmb' are NULL")
  
  # Test with an empty list
  expect_error(isValidList_tmb(list()), "All elements in 'list_tmb' are NULL")
})

test_that("isValidGlmmTmb function", {
  # Test with a valid glmmTMB object
  valid_model <- glmmTMB::glmmTMB(mpg ~ hp + vs + am + (1|cyl), data = mtcars)
  expect_true(isValidGlmmTmb("model", valid_model))
  
  # Test with an invalid object (not a glmmTMB object)
  invalid_object <- list(a = 1, b = 2)
  expect_error(isValidGlmmTmb("object", invalid_object), "Element object is not a glmmTMB object.")
  
  # Test with NULL object
  expect_true(isValidGlmmTmb("model", NULL))
})



# Mock object

test_that("isValidMock_obj checks if the provided object is a valid mock object", {
  mock_obj <- mock_rnaseq(init_variable(), n_genes = 100, 4, 4)

  # Test with a valid mock object
  expect_true(isValidMock_obj(mock_obj))
  
  # Test with an object missing an element
  missing_element_obj <- list(settings = list(), init = list(), groundTruth = list(), counts = list())
  expect_error(isValidMock_obj(missing_element_obj))
  
  # Test with an object containing additional elements
  additional_element_obj <- mock_obj
  additional_element_obj$error_name <- list()
  expect_warning(isValidMock_obj(additional_element_obj))
})

```


```{r function-init_variable, filename = "simulation_initialization"}
#' Initialize variable
#'
#' @param list_var Either c() or output of init_variable
#' @param name Variable name
#' @param sd Either numeric value or NA. Use to specify range of effect sizes.
#' @param level Numeric value to specify the number of levels to simulate. Default = 2.
#' @param mu Either a numeric value or a numeric vector (of length = level). Default : 0. Not recommended to modify.
#'
#' @return
#' A list with initialized variables
#' @export
#'
#' @examples
#' init_variable(name = "my_varA", sd = 0.50, level = 200)
init_variable <- function(list_var = c(), name = "myVariable", sd = 0.2, level = 2, mu = 0) {
  
  name <- clean_variable_name(name)
  
  # Only mu specified by user => set level param
  if (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 sd Either numeric value or NA. Use to specify range of effect sizes. Default 0 for no interaction effects.
#' @param mu Either a numeric value or a numeric vector (of length = level). Default : 0. Not recommended to modify.

#'
#' @return
#' A list with initialized interaction
#' @export
#'
#' @examples
#' init_variable(name = "myvarA", sd = 3, level = 200) %>%
#' init_variable(name = "myvarB", sd = 0.2, level = 2 ) %>%
#' add_interaction(between_var = c("myvarA", "myvarB"), sd = 2)
add_interaction <- function(list_var, between_var, sd = 0, mu = 0) {
  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)
}

#' 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)
}

```


```{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))

  # 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"))