R/aux_other.R

In MehdiChelh/triangle.tlbx: An Amazing Shiny App

#' @title datatableWrapper
#' 
#' @description Wrapper for datatable.
#' 
#' @param data a dataframe or matrix.
#' @param format (optionnal) Describe the data should be formated in the client borwser. Should be one of 'default', 'thousands', 'percent'.
#' @param ... additionnal options passed to the datatable function.
#' 
#' @example renderDT({ datatableWrapper(data, 'thousands', ...) })
datatableWrapper <- function(data, format='standard', triangle=FALSE, selection='none', extensions=c("Buttons"), buttons=FALSE, buttonsOptions=list('copy', 'print', 'csv', 'excel', 'pdf'), ...){
  
  # > rowCallback correspond à une fonction javascript appelée une fois que le datatable est généré,
  #   et avant qu'il soit affiché dans le navigateur
  if (format == 'thousands') {
    rowCallback <- JS(
      "function(row, data) {",
        "var ncol = data.length;",
        "for (i = 1; i < ncol; i++){",
          "if (data[i] != null){",
            "console.log(data[i]);",
            "var num = data[i].toString().replace(/\\B(?=(\\d{3})+(?!\\d))/g, ' ');",
            "console.log(num);",
          "} else {",
            "var num = data[i];",
          "}",
          "$('td:eq('+i+')', row).html(num);",
        "}",
      "}")
  } else {
    rowCallback <- NULL
  }
  
  if(!buttons)
    buttonsOptions <- list()
    
  dt <- datatable({ data }, 
                  extensions = extensions, 
                  class = 'stripe compact', 
                  selection = selection,
                  options = list(dom='Bfrtip',
                                 scrollY = TRUE, scrollX = TRUE, 
                                 ordering = FALSE, paging = FALSE, 
                                 searching = FALSE, info = FALSE,
                                 columnDefs = list(list(className = 'dt-right', targets = 'cell')),
                                 rowCallback = rowCallback,
                                 buttons = buttonsOptions), 
                  ...)
  
  if (triangle)
    dt <- dt %>% formatStyle(colnames(data),
                             backgroundColor = styleEqual(NA, c('lightgray')))
  
  return(dt)
}




#' @title exportExcelBtn
#' 
#' @description Voir shiny::downloadButton. Cette fonction correspond simplement à la fonction downloadButton de shiny légèrement modifiée : seule le style du bouton a été modifiées.
exportExcelBtn <- function (outputId, label = "Download", class = NULL, ...) 
{
  aTag <- tags$a(id = outputId, class = paste("shiny-download-link", 
                                              class), href = "", target = "_blank", download = NA, 
                 icon("file-excel"), label, ...)
}


#' @title validateDontStop
#' 
#' @description 
validateDontStop <- function (..., errorClass = character(0)) {
  
  results <- sapply(list(...), function(x) {
    if (is.null(x)) 
      return(NA_character_)
    else if (identical(x, FALSE)) 
      return("")
    else if (is.character(x)) 
      return(paste(as.character(x), collapse = "\n"))
    else stop("Unexpected validation result: ", as.character(x))
  })
  results <- stats::na.omit(results)
  if (length(results) == 0) 
    return(invisible())
  results <- results[nzchar(results)]
  return(results)
}