166 lines
4.6 KiB
R
166 lines
4.6 KiB
R
getBoxTitle <- function(box) {
|
|
header_tags <- htmltools::tagQuery(box)$find(".box-header")$selectedTags()
|
|
if (length(header_tags) == 0) {
|
|
return(NULL)
|
|
}
|
|
title_tags <- htmltools::tagQuery(box)$find(".box-title")$selectedTags()
|
|
if (length(title_tags) == 0) {
|
|
return(NULL)
|
|
}
|
|
title_tags[[1]]$children
|
|
}
|
|
|
|
#' Add attributes to .box elements (`shinydashboard::box`)
|
|
#'
|
|
#' @param box The box to set the attributes on
|
|
#' @param ... The attributes to set on the box
|
|
#'
|
|
#' @return The modified box
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' x <- shinydashboard::box()
|
|
#' htmlAddBoxAttributes(
|
|
#' x, role = "region", `aria-label` = "This is a special box"
|
|
#' )
|
|
htmlAddBoxAttributes <- function(box, ...) {
|
|
htmltools::tagQuery(box)$find(".box")$addAttr(...)$allTags()
|
|
}
|
|
|
|
#' Creates an aria landmark for a `shinydashboard::box` from the box title
|
|
#'
|
|
#' @param box The box to set the aria landmark on
|
|
#'
|
|
#' @return The modified box
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' x <- shinydashboard::box(title = "This is a powerful box")
|
|
#' htmlAddBoxRegionFromTitle(x)
|
|
htmlAddBoxRegionFromTitle <- function(box) {
|
|
title <- getBoxTitle(box)
|
|
if (is.null(title)) {
|
|
return(box)
|
|
}
|
|
htmlAddBoxAttributes(box, role = "region", `aria-label` = title)
|
|
}
|
|
|
|
#' Replaces the default `shinydashboard::box` title level (h3)
|
|
#'
|
|
#' @param box The box to set the title level on
|
|
#' @param newLevel The new title level (default = 2)
|
|
#'
|
|
#' @return The modified box
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' x <- shinydashboard::box(title = "This is a box")
|
|
#' htmlReplaceBoxTitleLevel(x, 2)
|
|
htmlReplaceBoxTitleLevel <- function(box, newLevel = 2) {
|
|
box_titles <- htmltools::tagQuery(box)$find(".box-title")$selectedTags()
|
|
box_titles <- lapply(box_titles, function(bt) {
|
|
bt$name <- paste0("h", newLevel)
|
|
bt
|
|
})
|
|
htmltools::tagQuery(box)$find(".box-title")$replaceWith(box_titles)$allTags()
|
|
}
|
|
|
|
#' Adds "aria-label" attribute to the box collapse/expand button
|
|
#'
|
|
#' @param box The box to set the attributes on
|
|
#' @param context The context for the aria label. Defaults to the box title if
|
|
#' not set
|
|
#'
|
|
#' @return The modified box
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' x <- shinydashboard::box(title = "This is a box")
|
|
#' htmlFixBoxCollapseButtonAria(x)
|
|
htmlFixBoxCollapseButtonAria <- function(box, context = NULL) {
|
|
if (is.null(context)) {
|
|
context <- getBoxTitle(box)
|
|
}
|
|
htmltools::tagQuery(box)$
|
|
find(".box-tools button.btn-box-tool")$
|
|
addAttrs(`aria-label` = paste0("Expand/Collapse ", context))$allTags()
|
|
}
|
|
|
|
#' Adds a "help" (question mark) icon to a box tools section (right side)
|
|
#'
|
|
#' The uri to load can have a replacement marker supplied '%box%' which will be
|
|
#' substituded with a sanitized copy of the box title.
|
|
#'
|
|
#' @param box The box to add a help icon/link to
|
|
#' @param href The help uri to load
|
|
#' @param title Optional title for the help link. Defaults to box title
|
|
#'
|
|
#' @return The modified box
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' x <- shinydashboard::box(title = "This is a box")
|
|
#' htmlAddBoxHelpLink(x, href = "http://example.com/help-guide#%box%")
|
|
htmlAddBoxHelpLink <- function(box, href, title = NULL) {
|
|
header_tags <- htmltools::tagQuery(box)$find(".box-header")$selectedTags()
|
|
if (length(header_tags) == 0) {
|
|
return(box)
|
|
}
|
|
|
|
tools_tags <- htmltools::tagQuery(box)$find(".box-tools")$selectedTags()
|
|
if (length(tools_tags) == 0) {
|
|
box <- htmltools::tagInsertChildren(
|
|
box,
|
|
after = 0,
|
|
.cssSelector = ".box-header",
|
|
htmltools::tags$div(class = "box-tools pull-right")
|
|
)
|
|
}
|
|
|
|
box_title <- getBoxTitle(box)
|
|
if (is.null(box_title)) {
|
|
box_title <- "UNDEFINED"
|
|
}
|
|
if (is.null(title)) {
|
|
title <- box_title
|
|
}
|
|
box_title <- htmlSlugify(box_title)
|
|
|
|
htmltools::tagInsertChildren(
|
|
box,
|
|
after = 0,
|
|
.cssSelector = ".box-tools",
|
|
htmltools::tags$a(
|
|
href = gsub("%box%", box_title, href),
|
|
target = "_blank",
|
|
class = "btn btn-box-tool pl-3 pr-3",
|
|
htmlRemoveAttributes(shiny::icon("question"), "aria-label"),
|
|
title = paste(trimws(title), " help link")
|
|
)
|
|
)
|
|
}
|
|
|
|
#' Removes title from box element (leaving an un-titled box with header if
|
|
#' required)
|
|
#'
|
|
#' @param box The box to remove the title from
|
|
#' @param removeHeader Remove the header as well
|
|
#'
|
|
#' @return The modified box
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' x <- shinydashboard::box(title = "TBR")
|
|
#' htmlRemoveBoxTitle(x)
|
|
htmlRemoveBoxTitle <- function(box, removeHeader = FALSE) {
|
|
if (removeHeader) {
|
|
htmltools::tagQuery(box)$find(".box-header")$remove()$allTags()
|
|
} else {
|
|
htmltools::tagQuery(box)$find(".box-title")$replace(
|
|
htmltools::tags$span(
|
|
class = "empty-box-title", htmltools::HTML(" ")
|
|
)
|
|
)$allTags()
|
|
}
|
|
}
|