R/aux_custom_ui.R

In MehdiChelh/triangle.tlbx: An Amazing Shiny App

#' @title customTabBox
#' @description Cutom tabBox element with "save-config" and "export-excel" buttons.
#' 
#' @param tabBox all parameters are identical to the shiny::tabBox function. the id paremeter is reused to define the id of "save-config" and "excel-export". (like NS(id, "save-config") and NS(id, "excel-export")).
#' 
#' @include aux_other.R
#' @import shiny
#' 
#' @export
#' @keywords internal
customTabBox <- function (..., id = NULL, selected = NULL, title = NULL, width = 6, 
          height = NULL, side = c("left", "right")) {
  
  side <- match.arg(side)
  content <- shiny::tabsetPanel(..., id = id, selected = selected)
  content$attribs$class <- "nav-tabs-custom"
  if (!is.null(height)) {
    content <- tagAppendAttributes(content, style = paste0("height: ", 
                                                           validateCssUnit(height)))
  }
  if (side == "right") {
    content$children[[1]] <- tagAppendAttributes(content$children[[1]], 
                                                 class = "pull-right")
  }
  if (!is.null(title)) {
    if (side == "left") 
      titleClass <- "pull-right"
    else titleClass <- "pull-left"
    content$children[[1]] <- htmltools::tagAppendChild(content$children[[1]], 
                                                       tags$li(class = paste("header", titleClass), 
                                                               title))
  }
  
  # >>>>>>>>>>>>>>>> Modifications Mazars
  
  #   Note :
  #     - content$children[[1]] correspond à ul.nav-tabs
  #     - content$children[[2]] correspond à div.tab-content
  ns <- NS(id)
  saveConfigBtn <- shinyjs::disabled(tags$li(actionLink(ns("save-config"), "Save config", icon("save")), style="float:right"))
  exportExcelBtn <- tags$li(exportExcelBtn(ns("export-excel"), "Exporter vers Excel"), style="float:right")
  # utiliser plutot htmltools::tagAppendChild
  last_child <- length(content$children[[1]]$children)
  content$children[[1]]$children[[ last_child + 1 ]] <- saveConfigBtn
  content$children[[1]]$children[[ last_child + 2 ]] <- exportExcelBtn
  
  # <<<<<<<<<<<<<<<< Fin modifications Mazars
  
  div(class = paste0("col-sm-", width), content)
}



#' @title projectDropdownMenu
#' @description Cutom ui element.
#' 
#' @param id id of the UI element
#' 
#' @import shiny
#' 
#' @export
#' @keywords internal
projectDropDownMenu <- function(id){
  ns <- NS(id)
  tags$li(
    tags$a(
      "Project",
      tags$b(class="caret"),
      class="dropdown-toggle", `data-toggle`="dropdown", `data-value`="More", `aria-expanded`="false"
    ),
    tags$ul(
      tags$li(
        tags$a(
          "Export Project",
          href="#", id=ns("project-export-shiny"), class="action-button"
        )
      ),
      tags$li(
        tags$a(
          "Export Excel Template",
          href="#", id=ns("project-export-excel"), class="action-button"
        )
      ),
      class="dropdown-menu", style=""
    )
  )
}

#' @title customNavbarPage
#' @description Cutom navbarPage element with project dropdown menu and import data button.
#' 
#' @param navbarPage All parameters are identical to the shiny::navbarPage function. the id paremeter is reused to define the id of the project dropdown menu and import button.
#' 
#' @import shiny
#' 
#' @export
#' @keywords internal
customNavbarPage <- function (title, ..., id = NULL, selected = NULL, position = c("static-top", 
                                                                                   "fixed-top", "fixed-bottom"), header = NULL, 
                              footer = NULL, inverse = FALSE, collapsible = FALSE, collapsable, 
                              fluid = TRUE, responsive = NULL, theme = NULL, windowTitle = title) {
  
  if (!missing(collapsable)) {
    shinyDeprecated("`collapsable` is deprecated; use `collapsible` instead.")
    collapsible <- collapsable
  }
  pageTitle <- title
  navbarClass <- "navbar navbar-default"
  position <- match.arg(position)
  if (!is.null(position)) 
    navbarClass <- paste(navbarClass, " navbar-", position, 
                         sep = "")
  if (inverse) 
    navbarClass <- paste(navbarClass, "navbar-inverse")
  if (!is.null(id)) 
    selected <- restoreInput(id = id, default = selected)
  tabs <- list(...)
  tabset <- shiny:::buildTabset(tabs, "nav navbar-nav", NULL, 
                                id, selected)
  
  # >>>>>>>>>>>>>>>> Modifications Mazars
  
  nbChild <- length(tabset$navList$children)
  for (i in nbChild:1)
    tabset$navList$children[[i + 2]] <- tabset$navList$children[[i]]
  
  tabset$navList$children[[1]] <- projectDropDownMenu(id)
  tabset$navList$children[[2]] <- tags$li(tags$a(tagList("Import data", 
                                                         tags$i(class="fa fa-file-upload")), 
                                                 id=NS(id, "import-data"),
                                                 href="#", 
                                                 class="action-button shiny-bound-input", 
                                                 style="color:#777; font-size:14px"))
  
  saveProjectBtn <- tags$ul(shinyjs::disabled(tags$li(actionLink(NS(id, "project-save"), " Save project", icon("save")))), class="nav navbar-nav", style="float:right")
  
  # <<<<<<<<<<<<<<<< Fin modifications Mazars
  
  className <- function(name) {
    if (fluid) 
      paste(name, "-fluid", sep = "")
    else name
  }
  if (collapsible) {
    navId <- paste("navbar-collapse-", p_randomInt(1000, 
                                                   10000), sep = "")
    containerDiv <- div(class = className("container"), 
                        div(class = "navbar-header", tags$button(type = "button", 
                                                                 class = "navbar-toggle collapsed", `data-toggle` = "collapse", 
                                                                 `data-target` = paste0("#", navId), 
                                                                 span(class = "sr-only", "Toggle navigation"), 
                                                                 span(class = "icon-bar"), span(class = "icon-bar"), 
                                                                 span(class = "icon-bar")), span(class = "navbar-brand", 
                                                                                                 pageTitle)), div(class = "navbar-collapse collapse", 
                                                                                                                  id = navId, tabset$navList,
                                                                                                                  # >>>>>>>>>>>>>>>> Modifications Mazars
                                                                                                                  saveProjectBtn))
    # <<<<<<<<<<<<<<<< Fin modifications Mazars
  }
  else {
    
    containerDiv <- div(class = className("container"), 
                        div(class = "navbar-header", span(class = "navbar-brand", 
                                                          pageTitle)), tabset$navList, 
                        # >>>>>>>>>>>>>>>> Modifications Mazars
                        saveProjectBtn)
    # <<<<<<<<<<<<<<<< Fin modifications Mazars
    
  }
  contentDiv <- div(class = className("container"))
  if (!is.null(header)) 
    contentDiv <- tagAppendChild(contentDiv, div(class = "row", 
                                                 header))
  contentDiv <- tagAppendChild(contentDiv, tabset$content)
  if (!is.null(footer)) 
    contentDiv <- tagAppendChild(contentDiv, div(class = "row", 
                                                 footer))
  bootstrapPage(title = windowTitle, responsive = responsive, 
                theme = theme, tags$nav(class = navbarClass, role = "navigation", 
                                        containerDiv), contentDiv)
}


#' @title errorOutput
#' @description Text output for displaying errors.
#' 
#' @param id OutputId of the errorOutput element. The errorOutput element behaves exactly like a textOutput element and can be used with renderText.
#' 
#' @import shiny
#' 
#' @export
#' @keywords internal
errorOutput <- function(id){
  # textOutput(id, container = function(...){ tag("error", list(...)) })
  uiOutput(id, container = function(...){ tag("error", list(...)) })
}