add fusen file

src/v4/HTRSIM/dev/0-dev_history.Rmd

+---
+title: "Development actions history"
+output: html_document
+editor_options: 
+  chunk_output_type: console
+---
+
+All commands that you use to use when developing packages...
+
+# First time just after creating the project
+
+- Fill the following chunk to create the DESCRIPTION of your package
+
+```{r description, eval=FALSE}
+# Describe your package
+fusen::fill_description(
+  pkg = here::here(),
+  fields = list(
+    Title = "HTRSIM",
+    Description = "To do.",
+    `Authors@R` = c(
+      person("Arnaud", "DUVERMY", email = "aduvermy@ens-lyon1.fr", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-1565-9313")),
+      person(given = "ThinkR", role = "cph")
+    )
+  )
+)
+# Define License with use_*_license()
+usethis::use_mit_license("Arnaud Duvermy")
+```
+
+# Set extra sources of documentation
+
+```{r, eval=FALSE}
+# Install a first time
+remotes::install_local()
+# README
+usethis::use_readme_rmd()
+# NEWS
+#usethis::use_news_md()
+```
+
+**From now, you will need to "inflate" your package at least once to be able to use the following commands. Let's go to your flat template, and come back here later if/when needed.**
+
+
+# Package development tools
+## Use once
+
+```{r, eval=FALSE}
+# Already run
+# Pipe
+#usethis::use_pipe()
+
+# package-level documentation
+#usethis::use_package_doc()
+
+# Add new flat template
+#fusen::add_flat_template("add")
+```
+
+## Use everytime needed
+
+```{r}
+# Simulate package installation
+pkgload::load_all()
+
+# Generate documentation and deal with dependencies
+attachment::att_amend_desc()
+
+# Check the package
+devtools::check()
+```
+
+# Share the package
+
+```{r}
+# set and try pkgdown documentation website
+usethis::use_pkgdown()
+pkgdown::build_site()
+
+# build the tar.gz with vignettes to share with others
+devtools::build(vignettes = TRUE)
+```
+

src/v4/HTRSIM/dev/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)
+```
+
+
+# Initialize variable to simulate
+
+<!--
+Create a chunk for the core of the function
+
+- The chunk needs to be named `function` at least
+- It contains the code of a documented function
+- The chunk can also be named `function-my_median` to make it easily
+findable in your Rmd
+- Let the `@examples` part empty, and use the next `examples` chunk instead to present reproducible examples
+
+After inflating the template
+
+-  This function code will automatically be added in a new file in the "R/" directory
+-->
+
+```{r function-init_variable, filename = "simulation_initialization"}
+#' init variable
+#'
+#' @param list_var either c() or output of init_variable
+#' @param name variable name
+#' @param mu either a numeric value or a numeric vector (of length = level)
+#' @param sd either numeric value  or NA
+#' @param level numeric value to specify the number of level to simulate
+#'
+#' @return
+#' a list with initialized variables 
+#' @export
+#'
+#' @examples
+init_variable <- function(list_var = c(), name = "my_variable", mu = c(2,3), sd = NA, level = NA){
+  
+  # avoid space in variable name
+  name <- gsub(" ", "_", name, fixed = TRUE)
+  
+  # only mu specified by user => set level param
+  if (is.na(level) & is.na(sd)) level = length(mu)
+  
+  ## Avoid unexplained errors
+  inputs_checking(list_var, name, mu, sd, level)
+  # -- init new var
+  list_var[[name]] = fillInVariable(name,  mu, sd, level)
+  return(list_var)
+}
+
+#' Core of the init variable not exported
+#' @inheritParams init_variable
+#' 
+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)) { 
+    msg_e = "Non conformable list_var parameter.\n list_var have to be set as an init_var output or init as c()"
+    if(!is.list(list_var)) stop(msg_e)
+  }
+  if (length(mu) > 1) {
+      stopifnot(length(mu) == level) 
+  }
+  
+  if (is.na(sd)) { 
+    if(level != length(mu)) {
+    msg_e = "sd was specified as NA. mu should have the same length as level number\n"
+    stop(msg_e)
+    }
+  }
+  # -- Variable already init
+  nameNotInlistVar= identical(which(alreadyInitVariable(list_var, name)), integer(0))
+  if(isFALSE(nameNotInlistVar)) { message(paste(name , "is already initialized in list_var.\nWill be updated", sep = " ")) }
+  return(NULL)
+}
+
+
+
+#' Core of the inputs_checking not exported
+#' @inheritParams init_variable
+#' @param new_var_name string specifying new variable to initialized 
+alreadyInitVariable <- function(list_var, new_var_name){
+  if (is.null(list_var)){ #if list_var = c()
+    return(FALSE)
+  }
+  var_name_in_list = attributes(list_var)$names
+  return( var_name_in_list == new_var_name)
+}
+
+
+#' Core of the init_variable not exported
+#' @inheritParams init_variable
+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_subObjReturn2User( level, metaData = l_labels ,
+                                       effectsGivenByUser = l_betaEffects, 
+                                       column_names )
+  }
+  ## Effects will be simulated using mvrnorm
+  else sub_obj = as.data.frame(list(mu = mu, sd = sd, level = level))
+
+  return(sub_obj)  
+}
+
+#' Core of the init_variable not exported
+#' @param col_names column names to use
+#' @param effectsGivenByUser list of effect given by user
+#' @param metaData list of labels
+#' @param level numeric value to specify the number of level to simulate
+build_subObjReturn2User <- function(level, metaData, effectsGivenByUser, col_names){
+    sub_obj = list(level = level)
+    data = cbind(metaData, effectsGivenByUser) %>% as.data.frame()
+    colnames(data) <- col_names
+    var_name <- tail(col_names, n=1)
+    data[ ,var_name] <- as.numeric(data[ ,var_name])
+    sub_obj$data = data
+    return(sub_obj)
+}
+```
+
+<!--
+Create a chunk with an example of use for your function
+
+- The chunk needs to be named `examples` at least
+- It contains working examples of your function
+- The chunk is better be named `examples-my_median` to be handled
+correctly when inflated as a vignette
+
+After inflating the template
+
+-  This example will automatically be added in the '@examples' part of our function above in the "R/" directory
+- This example will automatically be added in the vignette created from this Rmd template
+-->
+
+```{r examples-init_variable}
+l_variable2simulate =  init_variable( name = "genotype", mu = 2, sd = 3, level = 1000) %>% 
+                        init_variable(name = "environment", mu = c(2, 3) )
+```
+
+
+<!--
+Create a chunk with a test of use for your function
+
+- The chunk needs to be named `tests` at least
+- It contains working tests of your function
+- The chunk is better be named `tests-my_median` to be handled
+correctly when inflated as a vignette
+
+After inflating the template
+
+-  This test code will automatically be added in the "tests/testthat/" directory
+-->
+
+```{r tests-init_variable}
+test_that("inputs_checking tests", {
+  expect_equal(inputs_checking(c(), "varA", 2 , 3, 2), NULL) # everything performed well
+  expect_equal(inputs_checking(c(), "varA", mu = c(2, 3, 4, 6), sd = NA, level = 4), NULL) # everything performed well
+  expect_equal(inputs_checking(c(), "varA", mu = c(2, 3, 4, 6), sd = 8, level = 4), NULL) # everything performed well
+  expect_error(inputs_checking(c(), "varA", c(3, 2, 3) , NA, 2)) # length mu != level
+  expect_error(inputs_checking(c(), "varA", "nonNum_MU" , 3, 4))
+  expect_error(inputs_checking(c(), "varA", 2 , "nonNum_SD", 2))
+  expect_error(inputs_checking(c(), "varA", 2 , 3, "nonNum_LEVEL"))
+  expect_error(inputs_checking(c(), 33, 2 , 3, 2)) # NAME is not characters
+  expect_error(inputs_checking(c(), "", 2 , 3, 2)) # NAME is == "" 
+  expect_error(inputs_checking("nonList", "varA", 2 , 3, 2)) 
+  expected_list <- list(varA = list(mu = 2, sd = 3, level = 1000) %>% as.data.frame())
+  expect_message(inputs_checking(expected_list, "varA", 2 , 3, 2)) 
+
+
+})
+
+test_that("build_subObjReturn2User tests", {
+  expected_list <- list(level = 2, data = list("label_varA" = c("Aa", "Ab") , "varA" = c(1,6)) %>% as.data.frame())
+  expect_equal(build_subObjReturn2User(level = 2, metaData = c("Aa", "Ab"), effectsGivenByUser = c(1,6), col_names = c("label_varA", "varA")), expected_list)
+  expected_list <- list(level = 2, data = list("label_varA" = c("A1", "A2", "A1", "A2") , 
+                                               "label_varB" = c("B2", "B2", "B3", "B3")  ,"effects" = c(1,6, 1, 6)) %>% data.frame())
+  colnames(expected_list$data)[3] <- "varA:varB" 
+  expect_equal(build_subObjReturn2User(level = 2, 
+                                          metaData = list(A = c("A1", "A2", "A1", "A2"), B = c("B2", "B2", "B3", "B3")) %>% as.data.frame(), 
+                                          effectsGivenByUser = c(1,6), col_names = c("label_varA", "label_varB", "varA:varB")), expected_list)
+})
+
+test_that("already_init_var tests", {
+  l_var <- list(varA = list(mu = 2, sd = 3, level = 100) %>% as.data.frame(), varB = list(mu = 3, sd = 1, level = 3) %>% as.data.frame() )
+  expect_equal(alreadyInitVariable(l_var, 'new_var'), c(FALSE, FALSE) )
+  expect_equal(alreadyInitVariable(l_var, 'varA'), c(TRUE, FALSE))
+  expect_equal(alreadyInitVariable(l_var, 'varB'), c(FALSE, TRUE) )
+  expect_equal(alreadyInitVariable(c(), 'new_var'), FALSE )
+})
+
+
+test_that("fillInVariable tests", {
+  expected_df <- list(mu = 8, sd = 2, level = 20) %>% as.data.frame()
+  expect_equal(fillInVariable('varA', 8, 2, 20), expected_df )
+  
+  expected_df <- list(level = 3, data = list(label_varA = c('varA1',"varA2","varA3"), varA = c(1,3,4)) %>% as.data.frame())
+  expect_equal(fillInVariable('varA', c(1, 3, 4), NA, 3), expected_df )
+  
+})
+
+
+test_that("init_variable test", {
+  expected_list <- list(varA = list(mu = 2, sd = 3, level = 1000) %>% as.data.frame())
+  expect_equal(init_variable( name = "varA", mu = 2, sd = 3, level = 1000), expected_list)
+  expected_list <- list(varA = list(level = 2, data = list(label_varA = c("varA1", "varA2"), varA = c(2,3)) %>% as.data.frame()))
+  expect_equal(init_variable(name = "varA", mu = c(2, 3) ), expected_list)
+  
+})
+
+```
+
+
+# Add interaction to simulate
+
+<!--
+Create a chunk for the core of the function
+
+- The chunk needs to be named `function` at least
+- It contains the code of a documented function
+- The chunk can also be named `function-my_median` to make it easily
+findable in your Rmd
+- Let the `@examples` part empty, and use the next `examples` chunk instead to present reproducible examples
+
+After inflating the template
+
+-  This function code will automatically be added in a new file in the "R/" directory
+-->
+
+```{r function-add_interaction, filename = "simulation_initialization"}
+
+#' init variable
+#'
+#' @inheritParams init_variable
+#' @param between_var vector of variable (already initialized) in interaction
+#'
+#' @return
+#' a list with initialized interaction 
+#' @export
+#'
+#' @examples
+add_interaction <- function(list_var , between_var, mu, sd){
+  name_interaction =  paste(between_var, collapse = ":")
+  check_input2interaction(name_interaction, list_var , between_var, mu, sd)
+  interactionCombinations = getNumberOfCombinationsInInteraction(list_var, between_var)
+  list_var$interactions[[name_interaction]] = fillInInteraction(list_var,between_var, mu ,sd , level = interactionCombinations )
+  return(list_var)
+  
+} 
+
+#' Core of the inputs_checking not exported
+#' @inheritParams add_interaction
+#' @param name_interaction string specifying the name of the interaction (example : "varA:varB") 
+check_input2interaction <- function( name_interaction, list_var ,between_var, mu , sd ){
+  bool_checkInteractionValidity <- function(between_var, listVar){
+      nb_varInInteraction = length(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\nVariable not init 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 possible interactions number\n"
+      msg_e2 = paste(requestedNumberOfValues, "interactions values are requested")
+      stop(paste(msg_e, msg_e2))
+
+  }
+  level = requestedNumberOfValues
+  inputs_checking(list_var$interactions, name_interaction, mu, sd, level)
+}
+
+#' Core of the add_interaction not exported
+#' @inheritParams add_interaction
+getNumberOfCombinationsInInteraction <- function(list_var, between){
+      levelInlistVar = getGivenAttribute(list_var, "level") %>% unlist()
+      n_combinations = prod(levelInlistVar[between]) 
+      return(n_combinations)
+}
+
+#' Core of the add_interaction not exported
+#' @inheritParams add_interaction
+fillInInteraction <- function(list_var, between, mu, sd, level){
+  if (length(mu) > 1 | is.na(sd)){ ## Effects given by user
+    
+      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_subObjReturn2User(level = n_combinations,
+                                           metaData = grid_combination, effectsGivenByUser = mu, 
+                                           col_names = column_names )
+  }
+  ## Effects simulated using mvrnorm
+  else sub_dtf = list(mu = mu, sd = sd, level = level) %>% as.data.frame()
+  return(sub_dtf)
+}
+
+
+
+############ GLOBAL FUNCTIONS ################
+#' GLOBAL function 
+#' @inheritParams add_interaction
+getListVar <- function(input) attributes(input)$names
+
+
+#' GLOBAL function 
+#' @inheritParams add_interaction
+#' @param attribute string of an attribute to get back in all occurrence of the list
+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)
+}
+
+
+#' GLOBAL function 
+#' @param l_variables2labelized list of variable
+#' @param l_nb_label list of numeric representing the nb of level per variable
+getLabels <- function(l_variables2labelized, l_nb_label ){
+    getVarNameLabel <- function(name, level) {
+        list_label = paste(name, 1:level, sep = "")
+        return(list_label)
+    }
+    listLabels = lapply(l_variables2labelized, FUN = function(var) getVarNameLabel(var, l_nb_label[var]))
+    return(listLabels)
+}
+
+#' GLOBAL function 
+#' @param l_labels list of label per variable
+getGridCombination <- function(l_labels){
+  return(expand.grid(l_labels) %>% as.data.frame() )
+}
+```
+
+<!--
+Create a chunk with an example of use for your function
+
+- The chunk needs to be named `examples` at least
+- It contains working examples of your function
+- The chunk is better be named `examples-my_median` to be handled
+correctly when inflated as a vignette
+
+After inflating the template
+
+-  This example will automatically be added in the '@examples' part of our function above in the "R/" directory
+- This example will automatically be added in the vignette created from this Rmd template
+-->
+
+```{r examples-add_interaction}
+l_variable2simulate =  init_variable( name = "genotype", mu = 2, sd = 3, level = 2) %>% 
+                        init_variable(name = "environment", mu = c(2, 3) )  %>%
+                          add_interaction(between_var = c("genotype", "environment"), mu = c(1,2,3,4), sd = NA) 
+```
+
+
+<!--
+Create a chunk with a test of use for your function
+
+- The chunk needs to be named `tests` at least
+- It contains working tests of your function
+- The chunk is better be named `tests-my_median` to be handled
+correctly when inflated as a vignette
+
+After inflating the template
+
+-  This test code will automatically be added in the "tests/testthat/" directory
+-->
+
+```{r tests-add_interaction}
+
+test_that("add_interaction test", {
+  
+  expect_error(add_interaction(c() , "interaction", 2, 3))
+  expect_error(add_interaction(c() , c("unkownVarA", "unknownVarB"), 8, 3)) # 
+  
+  init_var_list <- list(varA = list(mu = 2, sd = 3, level = 2) %>% as.data.frame(), 
+                     varB = list(level = 2, data = list(label_varB = c("varB1", "varB2"), varB = c(2,3)) %>% as.data.frame()))
+  
+  ########## interaction effect to simulate  #########
+  expected_list <- list(varA = list(mu = 2, sd = 3, level = 2) %>% as.data.frame(), 
+                        varB = list(level = 2, 
+                                    data = list(label_varB = c("varB1","varB2"), varB = c(2,3)) %>% data.frame()), 
+                        interactions = list("varA:varB" = list(mu = 8, sd = 3, level = 4) %>% as.data.frame()))
+  expect_equal(add_interaction(init_var_list , c("varA", "varB"), 8, sd = 3), expected_list) # 
+  
+  ########## interaction given by user #########
+  expected_list <- list(varA = list(mu = 2, sd = 3, level = 2) %>% as.data.frame(), 
+                        varB = list(level = 2, 
+                                    data = list(label_varB = c("varB1","varB2"), varB = c(2,3)) %>% data.frame()), 
+                        interactions = list("varA:varB" = list(level = 4, 
+                                                              data = list(label_varA = factor(c("varA1","varA2","varA1","varA2")), 
+                                                                          label_varB =  factor(c("varB1","varB1","varB2","varB2")),
+                                                                          "varA:varB" = c(1,2,3,4)) %>% data.frame())))
+  colnames(expected_list$interactions$`varA:varB`$data) = c("label_varA", "label_varB", "varA:varB")
+  expect_equal(add_interaction(init_var_list , c("varA", "varB"), c(1,2,3,4), sd = NA), expected_list)
+  
+
+    ########## triple interactions #########
+    init_var_list <- list(varA = list(mu = 2, sd = 3, level = 2) %>% as.data.frame(), 
+                          varB = list(mu = 1, sd = 9, level = 2) %>% as.data.frame(),
+                          varC = list(level = 2, data = list(label_varB = c("varB1", "varB2"), varB = c(2,3)) %>% as.data.frame()))
+    expected_list <- list(varA = list(mu = 2, sd = 3, level = 2) %>% as.data.frame(),
+                          varB = list(mu = 1, sd = 9, level = 2) %>% as.data.frame(), 
+                          varC = list(level = 2, 
+                                    data = list(label_varB = c("varB1","varB2"), varB = c(2,3)) %>% data.frame()), 
+                        interactions = list("varA:varB:varC" = list(mu = 8, sd = 3, level = 8) %>% as.data.frame()))
+
+    expect_equal(add_interaction(init_var_list , c("varA", "varB", "varC"), 8, 3), expected_list)
+
+})
+
+```
+
+
+<!--
+# There can be development actions
+
+Create a chunk with 'development' actions
+
+- The chunk needs to be named `development` or `dev`
+- It contains functions that are used for package development only
+- Note that you may want to store most of these functions in the 0-dev_history.Rmd file
+
+These are only included in the present flat template file, their content will not be part of the package anywhere else.
+-->
+
+```{r development-inflate, eval=FALSE}
+# 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 = "Get started")
+```
+
+
+```{r development, include=FALSE}
+library(covr)
+covr::package_coverage()
+# Dans un R ou le package n'est pas loader !!
+```