diff --git a/DESCRIPTION b/DESCRIPTION index b3a3116..eea3b4a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -14,9 +14,11 @@ Encoding: UTF-8 Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.3 Imports: - htmltools + htmltools, + rlang Suggests: shiny, shinydashboard, + slugify, testthat (>= 3.0.0) -Config/testthat/edition: 3 +Config/testthat/edition: 3 \ No newline at end of file diff --git a/NAMESPACE b/NAMESPACE index 66198a5..d82ac60 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,12 +1,14 @@ # Generated by roxygen2: do not edit by hand export(htmlAddBoxAttributes) +export(htmlAddBoxHelpLink) export(htmlAddBoxRegionFromTitle) export(htmlDisableAutocomplete) export(htmlFixBoxCollapseButtonAria) export(htmlMarkOptional) export(htmlMarkRequired) export(htmlRemoveAttributes) +export(htmlRemoveBoxTitle) export(htmlReplaceBoxTitleLevel) export(htmlSetMaxLength) export(htmlSetMinLength) diff --git a/R/htmlBoxManipulation.R b/R/htmlBoxManipulation.R index 792dea2..00011c0 100644 --- a/R/htmlBoxManipulation.R +++ b/R/htmlBoxManipulation.R @@ -87,3 +87,93 @@ htmlFixBoxCollapseButtonAria <- function(box, context = NULL) { 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. Preference is given to +#' the slugify package, however if unavailable a warning is generated and the +#' fallback of URLEncode is used. +#' +#' @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 + } + + if (requireNamespace("slugify")) { + box_title <- slugify::slugify(box_title) + } else { + rlang::warn( + "slugify is not installed, resorting to URLencode", + .frequency = "regularly", + .frequency_id = "htmlAddBoxHelpLink::slugify" + ) + box_title <- utils::URLencode(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() + } +} diff --git a/man/htmlAddBoxHelpLink.Rd b/man/htmlAddBoxHelpLink.Rd new file mode 100644 index 0000000..6512b0c --- /dev/null +++ b/man/htmlAddBoxHelpLink.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/htmlBoxManipulation.R +\name{htmlAddBoxHelpLink} +\alias{htmlAddBoxHelpLink} +\title{Adds a "help" (question mark) icon to a box tools section (right side)} +\usage{ +htmlAddBoxHelpLink(box, href, title = NULL) +} +\arguments{ +\item{box}{The box to add a help icon/link to} + +\item{href}{The help uri to load} + +\item{title}{Optional title for the help link. Defaults to box title} +} +\value{ +The modified box +} +\description{ +The uri to load can have a replacement marker supplied '\%box\%' which will be +substituded with a sanitized copy of the box title. Preference is given to +the slugify package, however if unavailable a warning is generated and the +fallback of URLEncode is used. +} +\examples{ +x <- shinydashboard::box(title = "This is a box") +htmlAddBoxHelpLink(x, href = "http://example.com/help-guide#\%box\%") +} diff --git a/man/htmlRemoveBoxTitle.Rd b/man/htmlRemoveBoxTitle.Rd new file mode 100644 index 0000000..c2e5a58 --- /dev/null +++ b/man/htmlRemoveBoxTitle.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/htmlBoxManipulation.R +\name{htmlRemoveBoxTitle} +\alias{htmlRemoveBoxTitle} +\title{Removes title from box element (leaving an un-titled box with header if required)} +\usage{ +htmlRemoveBoxTitle(box, removeHeader = FALSE) +} +\arguments{ +\item{box}{The box to remove the title from} + +\item{removeHeader}{Remove the header as well} +} +\value{ +The modified box +} +\description{ +Removes title from box element (leaving an un-titled box with header if required) +} +\examples{ +x <- shinydashboard::box(title = "TBR") +htmlRemoveBoxTitle(x) +}