R/00-utils.R

In GuiFabre/fabR: Wrapper Functions Collection Used in Data Pipelines

#' @title
#' Call to online documentation
#'
#' @description
#' Direct call to the online documentation for the package, which includes a
#' description of the latest version of the package, vignettes, user guides,
#' and a reference list of functions and help pages.
#'
#' @return
#' Nothing to be returned. The function opens a web page.
#'
#' @examples
#' {
#'
#' fabR_website()
#'
#' }
#'
#' @importFrom utils browseURL
#'
#' @export
fabR_website <- function(){

  browseURL("https://guifabre.github.io/fabR-documentation/")
  return(invisible(NULL))

}

#' @title
#' Shortcut to display a message and acceptation on prompt
#'
#' @description
#' Shortcut allowing to provide user a prompt and a message that is to be read
#' and validated before pursuing process. This function is targeted for function
#' creators where user interaction is required.
#'
#' @param ... String character to put in a message
#'
#' @return
#' Nothing to be returned. The function sends a message as a prompt in the
#' console.
#'
#' @examples
#' {
#'
#' message_on_prompt("Do you want to continue? Press `enter` or `esc`")
#'
#' }
#'
#' @import dplyr
#' @importFrom rlang .data
#' @export
message_on_prompt <- function(...){
  invisible(readline(cat(prompt = paste(...))))
}

#' @title
#' Shortcut to silently run a code chunk avoiding error, messages and warnings
#'
#' @description
#' Shortcut avoiding user to get messages, warnings and being stopped by an
#' error. The usage is very similar to [suppressWarnings()]. This function
#' is targeted for function creators where user experience enhancement is
#' sought.
#'
#' @param ... R code
#'
#' @return
#' The output of the R code, unless the output is a message, a warning or an
#' error, nothing will be returned in that case.
#'
#' @seealso
#' [invisible()], [suppressWarnings()], [suppressMessages()]
#'
#' @examples
#' {
#'
#' as.integer("text")
#' silently_run(as.integer("text"))
#'
#' }
#'
#' @import dplyr
#' @importFrom rlang .data
#' @export
silently_run <- function(...){
  return(suppressWarnings(suppressMessages(try(...,silent = TRUE))))
}

#' @title
#' Shortcut to turn String character into R code
#'
#' @description
#' Shortcut to [parse()] and [eval()] evaluate R expression in a
#' character string, and turns it into actual R code. This function is targeted
#' for interaction with external files (where expression is stored in text
#' format) ; for tidy elements where code expression is generated using
#' [dplyr::mutate()], combined with [paste0()] ; in for while, map, etc.
#' loops where character string expression can be indexed or iteratively
#' generated and evaluated ; objects to be created (using assign, <- or <<- obj)
#' where the name of the R object is stored in a string. Some issues may occur
#' when parceval is used in a different environment, such as in a function.
#' Prefer eval(parse(text = ...) instead.
#'
#' @param ... String character to be parsed and evaluated
#'
#' @return
#' Any output generated by the evaluation of the string character.
#'
#' @seealso
#' [parse()], [eval()]
#'
#'
#' @examples
#' {
#'
#' ##### Example 1 -------------------------------------------------------------
#' # Simple assignation will assign 'b' in parceval environment (which is
#' # associated to a function and different from .GlobalEnv, by definition).
#' # Double assignation will put 'b' in .GlobalEnv.
#' # (similar to assign(x = "b",value = 1,envir = .GlobalEnv))
#'
#' a <- 1
#' parceval("print(a)")
#'
#' ##### Example 2 -------------------------------------------------------------
#' # use rowwise to directly use parceval in a tibble, or use a for loop.
#' library(dplyr)
#' library(tidyr)
#'
#' tibble(cars) %>%
#'   mutate(
#'     to_eval = paste0(speed,"/",dist)) %>%
#'   rowwise() %>%
#'   mutate(
#'     eval = parceval(to_eval))
#'
#' ##### Example 3 -------------------------------------------------------------
#' # parceval can be parcevaled itself!
#'
#' code_R <-
#'   'as_tibble(cars) %>%
#'   mutate(
#'     to_eval = paste0(speed,"/",dist)) %>%
#'   rowwise() %>%
#'   mutate(
#'     eval = parceval(to_eval))'
#'
#' cat(code_R)
#' parceval(code_R)
#'
#' }
#'
#' @import dplyr stringr
#' @importFrom rlang .data
#' @export
parceval <- function(...){
  eval(
    parse(
      text = str_squish(...) %>% str_remove_all("\\\r")))
}

#' @title
#' Read all Excel sheets using [readxl::read_excel()] recursively
#'
#' @description
#' The Excel file is read and the values are placed in a list of tibbles, with
#' each sheet in a separate element in the list. If the Excel file has only one
#' sheet, the output is a single tibble.
#'
#' @param filename A character string of the path of the Excel file.
#' @param sheets A vector containing only the sheets to be read.
#' @param keep_as_list A Boolean to say whether the object should be a list or
#' a tibble, when there is only one sheet provided. FALSE by default.
#'
#' @return
#' A list of tibbles corresponding to the sheets read, or a single tibble
#' if the number of sheets is one.
#'
#' @seealso
#' [readxl::read_excel()]
#'
#' @examples
#' {
#'
#' try(read_excel_allsheets(filename = tempfile()), silent = TRUE)
#'
#' }
#'
#' @import dplyr readxl purrr
#' @importFrom rlang .data
#' @export
read_excel_allsheets <- function(filename, sheets = "", keep_as_list = FALSE) {

  if(toString(sheets) == ""){
    sheets_name <- excel_sheets(filename)
  }else{
    sheets_name <-
      excel_sheets(filename) %>%
      as_tibble %>% dplyr::filter(.data$value %in% c(sheets)) %>%
      pull(.data$value)

    if(length(sheets_name) != length(sheets)){
      stop(call. = FALSE,
      "{",sheets[(sheets %in% sheets_name)] %>% toString, "}
Sheet name(s) not found in the excel file")}}

  if(is_empty(sheets_name)){
    stop(call. = FALSE, "The sheet name(s) you provided do not exist")}else{
      x <- lapply(sheets_name,
                  function(X) read_excel(
                    path      = filename,
                    sheet     = X,
                    guess_max =
                      suppressWarnings(
                        read_excel(filename, sheet = X) %>% nrow)))
      names(x) <- sheets_name
      if(length(x) == 1 & keep_as_list == FALSE){return(x[[1]])}else{return(x)}
    }
}


#' @title
#' Write all Excel sheets using [writexl::write_xlsx()] recursively
#'
#' @description
#' The R objects are read and the values are placed in separated sheets.
#' This function is inspired by the function proposed in
#' https://statmethods.wordpress.com/2014/06/19/quickly-export-multiple-r-objects-to-an-excel-workbook/
#'
#' @param list R objects, coma separated.
#' @param filename A character string of the path of the Excel file.
#'
#' @seealso
#' [writexl::write_xlsx()]
#'
#' @return
#' Nothing to be returned. The file is created at the path declared in the
#' environment.
#'
#' @examples
#' {
#'
#' unlink(
#'   write_excel_allsheets(
#'     list = list(iris = iris, mtcars = mtcars),
#'     filename = tempfile()))
#'
#' }
#'
#' @import dplyr stringr fs writexl
#' @importFrom rlang .data
#' @export
write_excel_allsheets <- function(list, filename){

  objnames <- list %>% names
  fargs <- as.list(match.call(expand.dots = TRUE))

  if(is.null(objnames)) {
    objnames <-
      as.character(fargs[['expand.dots']]) %>%
      str_remove("^list\\(") %>%
      str_remove("\\)$") %>%
      str_split(", ") %>% unlist
    names(list) <- objnames}

  dir_create(dirname(filename))
  write_xlsx(x = list, path = filename)

}



#' @title
#' Read a csv file using read_csv and avoid errors
#'
#' @description
#' `r lifecycle::badge("experimental")`
#' The csv file is read twice to detect the number of lines to use in
#' attributing the column type ('guess_max' parameter of read_csv). This avoids
#' common errors when reading csv files.
#'
#' @param filename A character string of the path of the csv file.
#'
#' @return
#' A tibble corresponding to the csv read.
#'
#' @seealso [readr::read_csv()], [readr::read_csv2()]
#'
#' @examples
#' {
#'
#' try(read_csv_any_formats(filename = tempfile()),silent = TRUE)
#'
#' }
#'
#' @import readr stringr tidyr
#' @importFrom rlang .data
#' @export
read_csv_any_formats <- function(filename){

  csv_0 <- silently_run(read_csv2(filename))

  if(class(csv_0)[1] != "try-error"){

    csv   <- silently_run(read_csv2(filename,guess_max = nrow(csv_0)))
    if(ncol(csv) == 1)
      csv <- read_csv(filename,guess_max = nrow(csv_0))

  }else{

    csv_0 <-
      silently_run(read_csv2(
        filename,locale = locale(encoding ="latin1")))
    csv   <-
      silently_run(read_csv2(
        filename,locale = locale(encoding ="latin1"),guess_max = nrow(csv_0)))

    if(ncol(csv) == 1)
      csv <- read_csv(
        filename,locale = locale(encoding ="latin1"),guess_max = nrow(csv_0))
  }

  return(csv)
}

#' @title
#' Add an index column at the first place of a tibble
#'
#' @description
#' Add an index, possibly by group, at the first place of a data frame or a
#' tibble The name by default is 'index' but can be named. If 'index' already
#' exists, or the given name, the column can be forced to be created, and
#' replace the other one.
#'
#' @param tbl tibble or data frame
#' @param name_index A character string of the name of the column.
#' @param start integer indicating first index number. 1 by default.
#' @param .force TRUE or FALSE, that parameter indicates whether or not the
#' column is created if already exists. FALSE by default.
#'
#' @return
#' A tibble or a data frame containing one extra first column 'index' or
#' any given name.
#'
#' @examples
#' {
#'
#' ##### Example 1 -------------------------------------------------------------
#' # add an index for the tibble
#' add_index(iris, "my_index")
#'
#' ##### Example 2 -------------------------------------------------------------
#' # add an index for the grouped tibble
#' library(tidyr)
#' library(dplyr)
#'
#' my_tbl <- tibble(iris) %>% group_by(Species) %>% slice(1:3)
#' add_index(my_tbl, "my_index")
#'
#' }
#'
#' @import dplyr stringr
#' @importFrom rlang .data
#'
#' @export
add_index <- function(tbl, name_index = "index", start = 1, .force = FALSE){

  class_tbl <- toString(class(tbl))
  group_name <- group_vars(tbl)
  `fabR::start` <- start

  tbl_index <-
    data.frame(index = NA_integer_) %>%
    rename_with(.cols = 'index', ~ name_index)

  if(.force == FALSE){

    if(name_index %in% (tbl %>% names)){
      stop(paste0("\n\nThe column ",name_index," already exists.\n",
                  "Please specifie another name or use .force = TRUE\n"))}

    tbl <- suppressMessages(bind_cols(tbl_index,tbl))
  }else{
    tbl <- suppressMessages(bind_cols(tbl_index,tbl %>%
                                        select(-any_of(name_index))))}


  if(length(group_name)) tbl <- group_by_at(tbl, group_name)

  tbl <- tbl %>% mutate(across(all_of(name_index),
                               ~ as.integer(row_number() + `fabR::start` - 1)))

  if(str_detect(class_tbl,"tbl")) tbl <- tibble(tbl)

  return(tbl)
}

#' @title
#' Get the paths of branches in a list
#'
#' @description
#' Function that recursively go through a list object and store in a tibble the
#' path of each element in the list. The paths can be after that edited and
#' accessed using [parceval()] for example.
#'
#' @param list_obj R list object to be evaluated
#' @param .map_list non usable parameter. This parameter is only there to ensure
#' recursivity. Any modification of this object returns NULL
#'
#' @seealso
#' [parceval()]
#'
#' @return
#' A tibble containing all the paths of each element of the list and the
#' class of each leaf (can be a list, or R objects).
#'
#' @examples
#' {
#'
#' library(dplyr)
#' get_path_list(
#'   list(
#'     tibble = iris,
#'     list = list(t1 = mtcars, t2 = tibble(iris)),
#'     char = "foo"))
#'
#' }
#'
#' @import dplyr stringr tidyr
#' @importFrom rlang .data
#' @export
get_path_list <- function(list_obj, .map_list = NULL){

  if(is.null(.map_list)){

    .map_list <-
      tibble(root_name = quote(list_obj) %>% as.character()) %>%
      mutate(
        leaf_class =
          eval(parse(
            text = paste0(.data$root_name," %>% class %>% toString()"))))

    .map_list <- list(
      map_list = .map_list,
      big_list = .map_list
    )

    return(get_path_list(list_obj, .map_list))

  }else{

    while(str_detect(
      .map_list$map_list$leaf_class %>% toString, "list")){

      .map_list$map_list <-
        .map_list$map_list %>%
        rowwise() %>%
        mutate(
          leaf_name = names(eval(parse(text = .data$root_name))) %>%
            toString()) %>%
        separate_rows(.data$leaf_name, sep = ", ") %>%
        rowwise() %>%
        mutate(
          leaf_class2  =
            eval(
              parse(text = paste0(.data$root_name,"[[",shQuote(.data$leaf_name),
                                  "]] %>% class %>% toString()"))),

          leaf_name   =
            ifelse(.data$leaf_class2 == "list",
                   paste0("[[",shQuote(.data$leaf_name),"]]"),
                   paste0("[",shQuote(.data$leaf_name),"]")),

          root_name   =
            ifelse(.data$leaf_class == "list",
                   paste0(.data$root_name,.data$leaf_name),
                   .data$root_name),

          leaf_class = .data$leaf_class2) %>%
        select(.data$root_name, .data$leaf_class)

      .map_list$big_list <-
        .map_list$big_list %>%
        bind_rows(.map_list$map_list) %>%
        distinct

      return(get_path_list(list_obj, .map_list))}}

  return(.map_list$big_list)
}

#' @title
#' Shortcut to create beautiful names in a list
#'
#' @description
#' Generate a name for an element in a list. This function is targeted for
#' functions creations which handle lists. Those lists may need names to go
#' through each elements. This function can works with [stats::setNames()] and
#' allows the user to provide name shorter, more user-friendly in their lists.
#'
#' @param args_list A list of character string of same length of list_elem
#' @param list_elem A list of character string of same length of args_list
#'
#' @seealso
#' [stats::setNames()]
#'
#' @return
#' A character string simplified to be used as names in a list.
#'
#' @examples
#' {
#'
#' library(tidyr)
#' library(stats)
#'
#' #### Example 1 --------------------------------------------------------------
#' # make_name_list generates names that are informative through a line of code
#' # or function. tibble(iris), iris %>% tibble and
#' # list(iris = tibble(mytibble) %>% select(Species)) will have 'iris' as name.
#'
#' list(tibble(iris), tibble(mtcars)) %>%
#'   setNames(make_name_list(list(tibble(iris), tibble(mtcars)), args_list =
#'     c("IRIS %>% complicated_code","complicated_function(MTCARS)")))
#'
#' #### Example 2 --------------------------------------------------------------
#' # make_name_list can be used when a function uses arguments provided by the
#' # user to generate a list. The name is simplified and given to the list
#' # itself
#'
#' library(dplyr)
#' my_function <- function(df){
#'
#'   .fargs <- as.list(match.call(expand.dots = TRUE))
#'   list_df <-
#'     list(df) %>%
#'     setNames(.,make_name_list(as.character(.fargs['df']),list(df)))
#'   return(list_df)}
#'
#' my_function(tibble(iris))
#' my_function(iris %>% tibble %>% select(Species))
#'
#' }
#'
#' @import dplyr stringr
#' @importFrom rlang .data
#' @export
make_name_list <- function(args_list, list_elem){

  name_list <-
    args_list %>%
    str_squish() %>%
    str_split(",") %>%
    unlist %>%
    str_remove_all("\\(\\)") %>%
    str_remove("\\=.*") %>%
    str_remove("\\%\\>\\%.*") %>%
    str_remove(".*\\([\\`]+") %>%
    str_remove("[\\`]+\\).*") %>%
    str_remove("\\[.*") %>%
    str_remove_all("\\`") %>%
    str_remove(".*\\(") %>%
    str_remove("\\).*") %>%
    str_remove("\\$.*") %>%
    str_squish()

  if(length(list_elem) != length(name_list)) {
    warning(
      "\nThe names of your elements in your list might have been wrongly parsed.
Please verify the names of your elements and reparse.\n", call. = FALSE)
  }

  return(name_list[c(seq_len(length(list_elem)))])

}

#' @title
#' Collects and Generates documentation of a package in a tibble format.
#'
#' @description
#' This function crawls and aggregates roxygen documentation into a tibble
#' format. To work properly, elements must be separated with the named fields at
#' title, at description, at ...), each at will be used as column name. The
#' column name will also have 80 character to show the margin limit of each
#' chunk of documentation.
#'
#' @param folder_r A character string identifying the folder to index. If not
#' specified, 'R/' is the default.
#'
#' @return
#' A tibble where each line represents a function described in a package, and
#' each column is documentation field. Most common fields (title, description,
#' details, param, see also, return and examples are placed ahead).
#'
#' @examples
#' {
#'
#' library(tidyr)
#' try({tibble(collect_roxygen(tempfile()))}, silent = FALSE)
#'
#' }
#'
#' @import dplyr tidyr stringr
#' @importFrom rlang .data
#' @export
collect_roxygen <- function(folder_r = "R"){

  # collect
  idx <- file_index_create(folder_r)
  doc <- tibble()
  for(i in idx$file_path){
    doc <- bind_rows(doc,tibble(value = readLines(i), page = basename(i)))}

  doc <-
    # trim
    doc %>%
    mutate(value = str_squish(.data$`value`)) %>%
    dplyr::filter(str_detect(.data$`value`,"^#'") |
             str_detect(.data$`value`, '<- function\\(')) %>%

    # classify
    mutate(
      class = ifelse(str_detect(.data$`value`,"<- function\\(")    ,
                     "FUNCTION"   ,NA_character_),
      class = ifelse(str_detect(.data$`value`,"^#' \\@title")      ,
                     "TITLE"      ,.data$`class`),
      class = ifelse(str_detect(.data$`value`,"^#' \\@description"),
                     "DESCRIPTION",.data$`class`),
      class = ifelse(str_detect(.data$`value`,"^#' \\@details")    ,
                     "DETAILS"    ,.data$`class`),
      class = ifelse(str_detect(.data$`value`,"^#' \\@format")     ,
                     "FORMAT"     ,.data$`class`),
      class = ifelse(str_detect(.data$`value`,"^#' \\@seealso")    ,
                     "SEEALSO"    ,.data$`class`),
      class = ifelse(str_detect(.data$`value`,"^#' \\@param")      ,
                     "PARAM"      ,.data$`class`),
      class = ifelse(str_detect(.data$`value`,"^#' \\@return")     ,
                     "RETURN"     ,.data$`class`),
      class = ifelse(str_detect(.data$`value`,"^#' \\@examples")   ,
                     "EXAMPLES"   ,.data$`class`),
      class = ifelse(str_detect(.data$`value`,"^#' \\@import")     ,
                     "IMPORT"     ,.data$`class`),
      class = ifelse(str_detect(.data$`value`,"^#' \\@export")     ,
                     "EXPORT"     ,.data$`class`)) %>%
    mutate(value =
             ifelse(
               .data$`class` %in% "FUNCTION",
               str_remove(.data$`value`,"<- function.+$"),
               .data$`value`)) %>%
    mutate(across(everything(), ~str_squish(.))) %>%
    dplyr::filter(.data$`value` != "#'")

  doc <-
    doc %>%
    add_index() %>%
    mutate(class_2 =
             ifelse(
               .data$`class` == 'TITLE',
               paste0("function_",.data$`index`), NA)) %>%
    fill(.data$`class_2`,.direction = "down") %>%
    fill(.data$`class`,.direction = "down") %>%
    select(-.data$`index`)

  # pivot
  doc <-
    doc %>%
    group_by(.data$`class_2`, .data$`class`, .data$`page`) %>%
    summarise(
      value = paste0(.data$`value`,collapse = "\n"),.groups = "keep") %>%
    pivot_wider(names_from = .data$`class`, values_from = .data$`value`) %>%
    ungroup %>%
    select(
      `page` = .data$`page`,
      matches('FUNCTION'   ),
      matches('TITLE'      ),
      matches('DESCRIPTION'),
      matches('DETAILS'    ),
      matches('FORMAT'     ),
      matches('SEEALSO'    ),
      matches('PARAM'      ),
      matches('RETURN'     ),
      matches('EXAMPLE'    ),
      matches('IMPORT'     ),
      matches('EXPORT'     )) %>%
    add_index()

  return(doc)
}