R/semantic_dashboard.R

In Appsilon/semantic.dashboard: Dashboard with Fomantic UI Support for Shiny

#' semantic.dashboard
#'
#' @name semantic.dashboard
#' @import htmltools
#' @import glue
#' @import checkmate
#' @keywords internal
NULL

#' Create a header of a dashboard.
#' @description Create a header of a dashboard with other additional UI elements.
#'              Hint: use \code{shiny::tagList()} if you want to add multiple elements in
#'              \code{left} / \code{center} or \code{right}.
#' @param ... UI elements to include within the header. They will be displayed on the right side.
#' @param left UI element to put on the left of the header. It will be placed after (to the right)
#'   the title and menu button (if they exist).
#' @param center UI element to put in the center of the header.
#' @param right UI element to put to the right of the header. It will be placed before elements
#'   defined in \code{...} (if there are any).
#' @param title Dashboard title to be displayed in the upper left corner. If NULL, will not display
#'   any title field. Use "" for an empty title.
#' @param titleWidth Title field width, one of \code{c(NULL, "very thin", "thin", "wide",
#'   "very wide")}
#' @param logo_align Where should logo be placed. One of \code{c("left", "center")}
#' @param logo_path Path or URL of the logo to be shown in the header.
#' @param color Color of the sidebar / text / icons (depending on the value of `inverted` parameter.
#'   One of \code{c("", "red", "orange", "yellow", "olive", "green", "teal", "blue", "violet",
#'   "purple", "pink", "brown", "grey", "black")}
#' @param inverted If FALSE sidebar will be white and text will be colored. \
#'   If TRUE text will be white and background will be colored. Default is \code{FALSE}.
#' @param disable If \code{TRUE}, don't display the header.
#' @param show_menu_button If \code{FALSE}, don't display the menu button. Default is \code{TRUE}.
#' @param menu_button_label Text of the menu button. Default is \code{"Menu"}.
#' @param class CSS class to be applied to the container of \code{dashboardHeader}.
#' @return A header that can be passed to \code{\link[semantic.dashboard]{dashboardPage}}
#' @export
#' @examples
#' if(interactive()) {
#'
#'   library(shiny)
#'   library(semantic.dashboard)
#'
#'   ui <- dashboardPage(
#'     dashboardHeader(color = "blue", inverted = TRUE),
#'     dashboardSidebar(side = "left", size = "thin", color = "teal",
#'                      sidebarMenu(
#'                        menuItem(tabName = "tab1", "Tab 1"),
#'                        menuItem(tabName = "tab2", "Tab 2"))),
#'     dashboardBody(tabItems(
#'       tabItem(tabName = "tab1", p("Tab 1")),
#'       tabItem(tabName = "tab2", p("Tab 2"))))
#'   )
#'
#'   server <- function(input, output) {
#'   }
#'
#'   shinyApp(ui, server)
#' }
dashboard_header <- function(..., left = NULL, center = NULL, right = NULL,
                             title = NULL, titleWidth = "thin",
                             logo_align = "center", logo_path = "",
                             color = "", inverted = FALSE, disable = FALSE,
                             show_menu_button = TRUE, menu_button_label = "Menu",
                             class = "") {
  if (disable) {
    NULL
  } else {
    verify_value_allowed("color", ALLOWED_COLORS)
    verify_value_allowed("titleWidth", ALLOWED_SIDEBAR_SIZES)

    inverted_value <- get_inverted_class(inverted)

    title_span <- if (!is.null(title)) {
      title_class <- paste(
        c("ui menu dashboard-title", titleWidth, inverted_value, color),
        collapse = " "
      )
      shiny::span(title, class = title_class)
    } else {
      NULL
    }

    logo <- if (logo_path != "") {
      shiny::tags$img(
        class = "logo",
        src = logo_path
      )
    } else {
      NULL
    }

    menu_button <- if (isTRUE(show_menu_button)) {
      shiny::tags$a(
        id = "toggle_menu", class = "item",
        shiny::tags$i(class = "sidebar icon"),
        menu_button_label
      )
    } else {
      NULL
    }

    logo_left <- if (logo_align == "left") logo
    logo_center <- if (logo_align == "center") logo
    logo_right <- if (logo_align == "right") logo

    left_content <- div(
      class = "header-part header-part__left",
      title_span,
      menu_button,
      logo_left,
      left
    )
    center_content <- div(class = "header-part header-part__center", logo_center, center)
    right_content <- div(class = "header-part header-part__right", logo_right, right, ...)

    shiny::div(
      class = paste("ui top attached dashboard-header", inverted_value, color, "menu", class),
      left_content,
      center_content,
      right_content
    )
  }
}

#' @describeIn dashboard_header Create a header of a dashboard (alias for \code{dashboard_header}
#'   for compatibility with \code{shinydashboard})
#' @export
dashboardHeader <- dashboard_header


#' Create a sidebar of a dashboard.
#' @description Create a pushable sidebar of a dashboard with menu items and other additional UI
#'   elements.
#' @param ... UI elements to include within the sidebar.
#' @param  side Placement of the sidebar. One of \code{c("left", "right", "top", "bottom")}
#' @param  size Size of the sidebar. One of \code{c("", "thin", "very thin", "wide", "very wide")}
#' @param  color Color of the sidebar / text / icons (depending on the value of `inverted`
#'   parameter. One of \code{c("", "red", "orange", "yellow", "olive", "green", "teal", "blue",
#'   "violet","purple", "pink", "brown", "grey", "black")}
#' @param inverted If FALSE sidebar will be white and text will be colored. \
#'   If TRUE text will be white and background will be colored. Default is \code{FALSE}.
#' @param  center Should label and icon be centerd on menu items. Default to \code{FALSE}
#' @param  visible Should sidebar be visible on start. Default to \code{TRUE}
#' @param disable If \code{TRUE}, don't display the sidebar.
#' @param closable If \code{TRUE} allow close sidebar by clicking in the body. Default to
#'   \code{FALSE}
#' @param pushable If \code{TRUE} the menu button is active. Default to \code{TRUE}
#' @param overlay If \code{TRUE}, opened sidebar will cover the tab content. Otherwise it is
#'   displayed next to the content. Relevant only for sidebar positioned on left or right. Default
#'   to \code{FALSE}
#' @param dim_page If \code{TRUE}, page content will be darkened when sidebr is open. Default to
#'   \code{FALSE}
#' @param class CSS class to be applied to the container of \code{dashboardSidebar}.
#' @return A sidebar that can be passed to \code{\link[semantic.dashboard]{dashboardPage}}
#' @export
#' @examples
#' if(interactive()){
#'
#'   library(shiny)
#'   library(semantic.dashboard)
#'
#'   ui <- dashboardPage(
#'     dashboardHeader(color = "blue"),
#'     dashboardSidebar(side = "left", size = "thin", color = "teal",
#'                      sidebarMenu(
#'                        menuItem(tabName = "tab1", "Tab 1"),
#'                        menuItem(tabName = "tab2", "Tab 2"))),
#'     dashboardBody(tabItems(
#'       tabItem(tabName = "tab1", p("Tab 1")),
#'       tabItem(tabName = "tab2", p("Tab 2"))))
#'   )
#'
#'   server <- function(input, output) {
#'   }
#'
#'   shinyApp(ui, server)
#' }
dashboard_sidebar <- function(..., side = "left", size = "thin", color = "", inverted = FALSE,
                              closable = FALSE, pushable = TRUE, center = FALSE, visible = TRUE,
                              disable = FALSE, overlay = FALSE, dim_page = FALSE, class = "") {
  if (disable || length(list(...)) < 1) {
    NULL
  } else {
    arguments <- list(...)
    verify_value_allowed("side", ALLOWED_SIDEBAR_SIDES)
    verify_value_allowed("size", ALLOWED_SIDEBAR_SIZES)
    verify_value_allowed("color", ALLOWED_COLORS)

    display_type <- ifelse(center, "labeled icon", "")
    uncover_class <- ifelse(isTRUE(visible) & isFALSE(overlay), "uncover", "")
    if (side %in% c("top", "bottom")) uncover_class <- ""
    overlay_class <- ifelse(isTRUE(visible) & isTRUE(overlay), "overlay", "")
    inverted_value <- get_inverted_class(inverted)

    closable <- ifelse(closable, quote(true), quote(false))
    pushable <- ifelse(pushable, quote(true), quote(false))
    overlay <- ifelse(overlay, quote(true), quote(false))
    dim_page <- ifelse(dim_page, quote(true), quote(false))

    do.call(
      shiny::div,
      list(
        closable = glue::glue("{closable}"),
        id = arguments$id,
        class = paste(
          "dashboard-sidebar ui",
          size,
          side,
          color,
          ifelse(side %in% c("top", "bottom"), "", "vertical"),
          display_type,
          ifelse(visible, "visible", ""),
          inverted_value,
          "menu sidebar",
          uncover_class,
          overlay_class,
          class
        ),
        arguments,
        shiny::tags$script(glue::glue(
          "initialize_sidebar({closable}, {pushable}, {overlay}, {dim_page})"
        )),
        shiny::tags$script(src = "src/updateTabItems.js")
      )
    )
  }
}

#' @describeIn dashboard_sidebar Create a sidebar of a dashboard (alias for \code{dashboard_sidebar}
#'   for compatibility with \code{shinydashboard})
#' @export
dashboardSidebar <- dashboard_sidebar


#' Create a body of a dashboard.
#' @description Create a body of a dashboard with tabs and other additional UI elements.
#' @param ... UI elements to include within the body.
#' @param class CSS class to be applied to the container of \code{dashboardBody}. Note it's not the
#'   \code{<body>} tag.
#' @return A tab that can be passed to \code{\link[semantic.dashboard]{dashboardPage}}
#' @export
#' @examples
#' if(interactive()){
#'
#'   library(shiny)
#'   library(semantic.dashboard)
#'
#'   ui <- dashboardPage(
#'     dashboardHeader(color = "blue"),
#'     dashboardSidebar(side = "left", size = "thin", color = "teal",
#'                      sidebarMenu(
#'                        menuItem(tabName = "tab1", "Tab 1"),
#'                        menuItem(tabName = "tab2", "Tab 2"))),
#'     dashboardBody(tabItems(
#'       tabItem(tabName = "tab1", p("Tab 1")),
#'       tabItem(tabName = "tab2", p("Tab 2"))))
#'   )
#'
#'   server <- function(input, output) {
#'   }
#'
#'   shinyApp(ui, server)
#' }
dashboard_body <- function(..., class = "") {
  shiny::div(class = paste("ui grid pusher dashboard-body", class), ...)
}

#' @describeIn dashboard_body Create a body of a dashboard (alias for \code{dashboard_body} for
#'   compatibility with \code{shinydashboard})
#' @export
dashboardBody <- dashboard_body

#' Create a dashboard.
#' @description Create a page with menu item sidebar and body containing tabs and other additional
#'   elements.
#' @param header Header of a dashboard.
#' @param sidebar Sidebar of a dashboard.
#' @param body Body of a dashboard.
#' @param title Title of a dashboard.
#' @param margin If \code{TRUE}, margin to be applied to the whole dashboard.
#' Defaults to \code{TRUE}.
#' @param theme Theme name or path. For possible options see
#'   \code{\link[shiny.semantic]{semanticPage}}.
#' @param class CSS class to be applied to the page container (\code{<body>} tag).
#' @param sidebar_and_body_container_class CSS class to be applied to the \code{div} containing
#' \code{dashboardSidebar} and \code{dashboardBody}.
#' @param suppress_bootstrap There are some conflicts in CSS styles between
#' FomanticUI and Bootstrap. For the time being it's better to suppress Bootstrap.
#' If \code{TRUE} bootstrap dependency from \code{shiny} will be disabled.
#' @return Dashboard.
#' @export
#' @examples
#' if(interactive()){
#'
#'   library(shiny)
#'   library(semantic.dashboard)
#'
#'   ui <- dashboardPage(
#'     dashboardHeader(color = "blue"),
#'     dashboardSidebar(side = "left", size = "thin", color = "teal",
#'                      sidebarMenu(
#'                        menuItem(tabName = "tab1", "Tab 1"),
#'                        menuItem(tabName = "tab2", "Tab 2"))),
#'     dashboardBody(tabItems(
#'       tabItem(tabName = "tab1", p("Tab 1")),
#'       tabItem(tabName = "tab2", p("Tab 2"))))
#'   )
#'
#'   server <- function(input, output) {
#'   }
#'
#'   shinyApp(ui, server)
#' }
dashboard_page <- function(header, sidebar, body, title = "",
                           suppress_bootstrap = TRUE, theme = NULL,
                           margin = TRUE, class = "", sidebar_and_body_container_class = "") { # nolint: object_length_linter
  # TODO: Remove this line when it is added to semanticPage()
  if (is.null(sidebar)) header$children[[1]] <- NULL
  sidebar_and_body <- div(
    class = paste("ui bottom attached segment pushable", sidebar_and_body_container_class),
    sidebar,
    body
  )

  margin_class <- ifelse(isFALSE(margin), "no-margin", "")
  class <- paste("dashboard-page", margin_class, class)
  shiny.semantic::semanticPage(
    header,
    sidebar_and_body,
    get_dashboard_dependencies(),
    margin = "0",
    title = title,
    theme = theme,
    suppress_bootstrap = suppress_bootstrap,
    class = class
  )
}

#' @describeIn dashboard_page Create a dashboard (alias for \code{dashboard_page} for compatibility
#'   with \code{shinydashboard})
#' @export
dashboardPage <- dashboard_page