R/bulma-navbar.R

In tjpalanca/bulma.R: Bulma CSS Framework for R

#' @title
#' Bulma Navigation Bar
#'
#' @description
#' A responsive horizontal navbar that can support images, links, buttons,
#' and dropdowns. The navbar component is a responsive and versatile horizontal
#' navigation bar with the following structure:
#'
#' * `bulma_navbar()` - main container
#'   * `bulma_navbar_brand()` - left side, always visible, usually contains the
#'     logo and important links/icons.
#'   * `bulma_navbar_burger()` - hamburger icon which toggles the navbar menu
#'     on touch devices.
#'   * `bulma_navbar_menu()` - right side, hidden on touch devices and visible
#'     only on desktop.
#'     * `bulma_navbar_start()` - left part of the menu
#'     * `bulma_navbar_end()` - right part of the menu
#'     * `bulma_navbar_item()` - each single item, either link or not
#'     * `bulma_navbar_dropdown()` - dropdown menu with items and dividers
#'     * `bulma_navbar_link()` - sibling of dropdown with an arrow
#'     * `bulma_navbar_divider` - dividing line inside a dropdown.
#'
#' [Navbar](https://bulma.io/documentation/components/navbar/)
#'
#' @family Bulma Components
#' @name bulma_navbar
NULL

#' @describeIn bulma_navbar main container
#'
#' @param ...   (tags) content
#' @param color (string) color
#' @param transparent (flag) transparent navbar to seamlessly integrate the
#'        navbar in any visual context
#' @param spaced (flag) adds extra spacing around the navbar
#' @param shadow (flag) adds a small amount of shadow around the navbar
#' @param fixed (string) whether the navbar is fixed to the top or bottom of
#'        the screen. This also adds a property to the body so that the viewport
#'        contains an adjustment.
#' @param tag default HTML tag
#'
#' @export
bulma_navbar <- function(...,
                         color = c("primary", "link", "info",
                                   "success", "warning", "danger",
                                   "white", "black", "light", "dark"),
                         transparent = FALSE,
                         spaced = FALSE,
                         shadow = FALSE,
                         fixed = c("top", "bottom"),
                         tag = tags$nav) {

  assert_function(tag)
  walk(tagList(...),
       ~assert_multi_class(., c("bulma_navbar_brand",
                                "bulma_navbar_menu")))
  color <- match_arg(color)
  fixed <- match_arg(fixed)

  tag(class = "navbar", ...) %>%
    when(transparent, bulma_is(., "transparent")) %>%
    when(!is.null(fixed), {
      tagList(
        bulma_is(., glue("fixed-{fixed}")),
        singleton(tags$head(tags$script(glueb(
          "
          document.addEventListener('DOMContentLoaded', function() {
            document.body.classList.add('has-navbar-fixed-{{fixed}}');
          });
          "
        ))))
      )
    }) %>%
    bulma_color(color) %>%
    when(spaced, bulma_is(., "spaced")) %>%
    when(shadow, bulma_has(., "shadow")) %>%
    add_class("bulma_navbar")

}

#' @describeIn bulma_navbar brand, always visible on all breakpoints
#' @export
bulma_navbar_brand <- function(..., tag = tags$div) {

  assert_function(tag)

  tag(class = "navbar-brand", ...) %>%
    add_class("bulma_navbar_brand")

}

#' @describeIn bulma_navbar
#' burger menu that is supposed to make the navbar appear on mobile
#'
#' @param target_id (string) ID target that this burger will make more visible
#'
#' @export
bulma_navbar_burger <- function(target_id = NULL, ..., tag = tags$a) {

  assert_function(tag)
  assert_string(target_id, null.ok = TRUE)

  tag(
    class = "navbar-burger",
    role  = "button",
    `data-target` = target_id,
    tags$span(),
    tags$span(),
    tags$span(),
    ...
  ) %>%
    add_class("bulma_navbar_burger")

}

#' @describeIn bulma_navbar
#' main navbar, hidden on mobile (unless burgered). Contains
#' `bulma_navbar_start()` and `bulma_navbar_end()`.
#'
#' @param active (flag) whether or not this is visible all the time
#'
#' @export
bulma_navbar_menu <- function(...,
                              active = FALSE,
                              tag = tags$div) {

  assert_function(tag)
  walk(tagList(...),
       ~assert_multi_class(., c("bulma_navbar_start",
                                "bulma_navbar_end")))

  tag(
    class = "navbar-menu",
    ...
  ) %>%
    when(active, bulma_is(., "active")) %>%
    add_class("bulma_navbar_menu")

}

#' @describeIn bulma_navbar left part of the menu
#' @export
bulma_navbar_start <- function(..., tag = tags$div) {

  assert_function(tag)
  walk(tagList(...),
       ~assert_class(., "bulma_navbar_item"))

  tag(
    class = "navbar-start",
    ...
  ) %>%
    add_class("bulma_navbar_start")

}

#' @describeIn bulma_navbar right part of the menu
#' @export
bulma_navbar_end <- function(..., tag = tags$div) {

  assert_function(tag)
  walk(tagList(...),
       ~assert_class(., "bulma_navbar_item"))

  tag(
    class = "navbar-end",
    ...
  ) %>%
    add_class("bulma_navbar_end")

}

#' @describeIn bulma_navbar a navigation item, link or not
#'
#' @param dropdown (flag) dropdown
#' @param expanded (flag) extend to full width
#' @param dropdown_hoverable (flag) activate dropdown on hover
#' @param dropdown_active    (flag) is dropdown activated
#' @param dropdown_right     (flag) is dropdown right aligned
#' @param dropdown_dropup    (flag) is dropdown going up (for bottom navbar)
#' @param tab                (flag) whether this appears like a tab.
#'
#' @export
bulma_navbar_item <- function(...,
                              dropdown = FALSE,
                              expanded = FALSE,
                              dropdown_hoverable = FALSE,
                              dropdown_active = FALSE,
                              dropdown_right = FALSE,
                              dropdown_dropup = FALSE,
                              tab = FALSE,
                              tag = if (dropdown) tags$div else tags$a) {

  assert_function(tag)
  assert_flag(dropdown)
  if (dropdown) {
    walk(unnamed(...),
         assert_multi_class,
         c("bulma_navbar_dropdown", "bulma_navbar_link"))
  } else {
    assert_false(dropdown_hoverable)
    assert_false(dropdown_active)
    assert_false(dropdown_right)
    assert_false(dropdown_dropup)
  }

  tag(
    class = "navbar-item",
    ...
  ) %>%
    when(dropdown, bulma_has(., "dropdown")) %>%
    when(dropdown_active, bulma_is(., "active")) %>%
    when(dropdown_hoverable, bulma_is(., "hoverable")) %>%
    when(dropdown_right, bulma_is(., "right")) %>%
    when(dropdown_dropup, bulma_has(., "dropdown-up")) %>%
    when(expanded, bulma_is(., "expanded")) %>%
    when(tab, bulma_is(., "tab")) %>%
    add_class("bulma_navbar_item")

}

#' @describeIn bulma_navbar divider item, horizontal rule
#' @export
bulma_navbar_divider <- function(tag = tags$hr) {

  assert_function(tag)

  tag(class = "navbar-divider") %>%
    add_class("bulma_navbar_divider")

}

#' @describeIn bulma_navbar link beside the dropdown
#' @param arrow (flag) whether or not the arrow should exist
#' @export
bulma_navbar_link <- function(..., arrow = TRUE, tag = tags$a) {

  assert_function(tag)

  tag(class = "navbar-link", ...) %>%
    when(!arrow, bulma_is(., "arrowless")) %>%
    add_class("bulma_navbar_link")

}

#' @describeIn bulma_navbar dropdown inside the dropdown item
#' @param boxed (flag) boxed appearance for the dropdown
#' @export
bulma_navbar_dropdown <- function(..., boxed = FALSE, tag = tags$div) {

  assert_function(tag)
  walk(tagList(...),
       ~assert_multi_class(., c("bulma_navbar_item",
                                "bulma_navbar_divider")))

  tag(class = "navbar-dropdown", ...) %>%
    when(boxed, bulma_is(., "boxed")) %>%
    add_class("bulma_navbar_dropdown")

}