Add external link function and bad link text examples

.Rbuildignore

@@ -7,3 +7,4 @@
 ^docs$
 ^pkgdown$
 ^.lintr$
+^data-raw$

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: dfeshiny
 Title: DfE R-Shiny Standards
-Version: 0.3.0
+Version: 0.4.0
 Authors@R: c(
     person("Rich", "Bielby", , "[email protected]", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0001-9070-9969")),
@@ -35,3 +35,6 @@ RoxygenNote: 7.3.2
 URL: https://dfe-analytical-services.github.io/dfeshiny/
      https://www.github.com/dfe-analytical-services/dfeshiny/
 VignetteBuilder: knitr
+Depends: 
+    R (>= 2.10)
+LazyData: true

NAMESPACE

@@ -6,6 +6,7 @@ export(cookies_panel_server)
 export(cookies_panel_ui)
 export(custom_disconnect_message)
 export(dfe_cookies_script)
+export(external_link)
 export(init_analytics)
 export(init_cookies)
 export(support_panel)

NEWS.md

@@ -1,3 +1,7 @@
+# dfeshiny 0.4.0
+
+* Add new `external_link()` function and look up data for `bad_link_text`.
+
 # dfeshiny 0.3.0
 
 ## New features

R/data-bad_link_text.R

@@ -0,0 +1,17 @@
+#' Lookup for bad link text
+#'
+#' A single column data frame, listing out known examples of bad link text that
+#' check for in the `external_link()` function.
+#'
+#' We've started curating this list so we can create automated checks to help
+#' all link text to be as descriptive as possible in line with
+#' [WCAG 2.2 success criteria 2.4.4: Link Purpose (In Context)](
+#' https://www.w3.org/WAI/WCAG22/Understanding/link-purpose-in-context).
+#'
+#' @format ## `bad_link_text`
+#' A data frame with 48 rows and 1 columns:
+#' \describe{
+#'   \item{bad_link_text}{Lower cased examples of non-descriptive link text}
+#' }
+#' @source Curated by explore.statistics@@education.gov.uk
+"bad_link_text"

R/external_link.R

@@ -0,0 +1,102 @@
+#' External link
+#'
+#' Intentionally basic wrapper for html anchor elements making it easier to
+#' create safe external links with standard and accessible behaviour. For more
+#' information on how the tag is generated, see \code{\link[htmltools]{tags}}.
+#'
+#' @description
+#' It is commonplace for external links to open in a new tab, and when we do
+#' this we should be careful...
+#'
+#' This function automatically adds the following to your link:
+#' * `target="_blank"` to open in new tab
+#' * `rel="noopener noreferrer"` to prevent [reverse tabnabbing](
+#' https://owasp.org/www-community/attacks/Reverse_Tabnabbing)
+#'
+#' By default this function also adds "(opens in new tab)" to your link text
+#' to warn users of the behaviour.
+#'
+#' This also adds "This link opens in a new tab" as a visually hidden span
+#' element within the html outputted to warn non-visual users of the behaviour.
+#'
+#' Related links and guidance:
+#'
+#' * [Government digital services guidelines on the use of links](
+#' https://design-system.service.gov.uk/styles/links/)
+#'
+#' * [Anchor tag html element and its properties](
+#' https://developer.mozilla.org/en-US/docs/Web/HTML/Element/a)
+#'
+#' * [WCAG 2.2 success criteria 2.4.4: Link Purpose (In Context)](
+#' https://www.w3.org/WAI/WCAG22/Understanding/link-purpose-in-context)
+#'
+#' * [Web Accessibility standards link text behaviour](
+#' https://www.w3.org/TR/WCAG20-TECHS/G200.html)
+#'
+#' @param href URL that you want the link to point to
+#' @param link_text Text that will appear describing your link, must be
+#' descriptive of the page you are linking to. Vague text like 'click here' or
+#' 'here' will cause an error.
+#' @param add_warning Boolean for adding "(opens in new tab)" at the end of the
+#' link text to warn users of the behaviour. Be careful and consider
+#' accessibility before removing the visual warning.
+#' @return shiny.tag object
+#' @export
+#'
+#' @examples
+#' external_link("https://shiny.posit.co/", "R Shiny")
+#'
+#' external_link(
+#'   "https://shiny.posit.co/",
+#'   "R Shiny",
+#'   add_warning = FALSE
+#' )
+external_link <- function(href, link_text, add_warning = TRUE) {
+  if (!is.logical(add_warning)) {
+    stop("add_warning must be a TRUE or FALSE value")
+  }
+
+  # Create a basic check for raw URLs
+  is_url <- function(text) {
+    url_pattern <- "^(https://|http://|www\\.)"
+    grepl(url_pattern, text)
+  }
+
+  if (is_url(link_text)) {
+    stop(paste0(
+      link_text,
+      " has been recognise as a raw URL, please change the link_text value to",
+      " a description of the page being linked to instead"
+    ))
+  }
+
+  # Check against curated data set for link text we should banish into room 101
+  if (tolower(link_text) %in% dfeshiny::bad_link_text$bad_link_text) {
+    stop(
+      paste0(
+        link_text,
+        " is not descriptive enough and has has been recognised as bad link",
+        " text, please replace the link_text argument with more descriptive",
+        " text."
+      )
+    )
+  }
+
+  if (add_warning) {
+    link_text <- paste(link_text, "(opens in new tab)")
+    hidden_span <- NULL # don't have extra hidden text if clear in main text
+  } else {
+    hidden_span <-
+      htmltools::span(class = "visually-hidden", "This link opens in a new tab")
+  }
+
+  # Create link using htmltools::tags$a
+  htmltools::tags$a(
+    hidden_span,
+    href = href,
+    link_text,
+    target = "_blank",
+    rel = "noopener noreferrer",
+    .noWS = "after"
+  )
+}

_pkgdown.yml

@@ -6,19 +6,23 @@ template:
     pkgdown-nav-height: 81.4468px
 
 reference:
-- title: Maintenance
-  contents:
-  - tidy_code
 - title: Cookies
   contents:
   - has_concept("cookies")
-- title: Standard panels
-  contents:
-  - support_panel
 - title: Connectivity
   contents:
   - custom_disconnect_message
 - title: Initialisation functions
   desc: One time functions used to set up or update standardised scripts and workflows needed for your dashboard
   contents:
   - starts_with("init")
+- title: Links
+  contents:
+  - external_link
+  - bad_link_text
+- title: Maintenance
+  contents:
+  - tidy_code
+- title: Standard panels
+  contents:
+  - support_panel

data-raw/bad_link_text.R

@@ -0,0 +1,17 @@
+bad_link_text <- data.frame(
+  bad_link_text = c(
+    # one word examples
+    "click", "csv", "dashboard", "document", "download", "file", "form",
+    "guidance", "here", "information", "jpeg", "jpg", "learn", "link", "more",
+    "next", "page", "pdf", "previous", "read", "site", "svg", "this", "web",
+    "webpage", "website", "word", "xslx",
+    # two word examples
+    "click here", "click this link", "download csv", "download document",
+    "download file", "download here", "download jpg", "download jpeg",
+    "download pdf", "download png", "download svg", "download word",
+    "download xslx", "further information", "go here", "learn more",
+    "read more", "this page", "web page", "web site"
+  )
+)
+
+usethis::use_data(bad_link_text, overwrite = TRUE)

tests/testthat/test-data-bad_link_text.R

@@ -0,0 +1,24 @@
+test_that("Returns data frame", {
+  expect_true(is.data.frame(dfeshiny::bad_link_text))
+})
+
+test_that("Matches description", {
+  # If this test fails, update the notes in R/data-bad_link_text.R
+  expect_equal(nrow(dfeshiny::bad_link_text), 48)
+  expect_equal(names(dfeshiny::bad_link_text), "bad_link_text")
+})
+
+test_that("All are string values", {
+  expect_true(all(sapply(dfeshiny::bad_link_text$bad_link_text, is.character)))
+})
+
+test_that("Is all lower case", {
+  expect_true(all(
+    dfeshiny::bad_link_text$bad_link_text ==
+      tolower(dfeshiny::bad_link_text$bad_link_text)
+  ))
+})
+
+test_that("There are no duplicates", {
+  expect_true(!anyDuplicated(dfeshiny::bad_link_text))
+})

tests/testthat/test-external_link.R

@@ -0,0 +1,55 @@
+# Create a test link ==========================================================
+test_link <- external_link("https://shiny.posit.co/", "R Shiny")
+
+# Run rest of tests against the test link -------------------------------------
+test_that("Returns shiny.tag object", {
+  expect_s3_class(test_link, "shiny.tag")
+})
+
+test_that("content and URL are correctly formatted", {
+  expect_equal(test_link$attribs$href, "https://shiny.posit.co/")
+  expect_true(grepl("R Shiny", test_link$children[[2]]))
+})
+
+test_that("New tab warning appends", {
+  expect_true(grepl("\\(opens in new tab\\)", test_link$children[[2]]))
+})
+
+test_that("attributes are attached properly", {
+  expect_equal(test_link$attribs$rel, "noopener noreferrer")
+  expect_equal(test_link$attribs$target, "_blank")
+})
+
+test_that("hidden text is skipped", {
+  expect_true(is.null(test_link$children[[1]]))
+})
+
+# Rest of tests against the function ==========================================
+test_that("Rejects dodgy link text", {
+  expect_error(external_link("https://shiny.posit.co/", "Click here"))
+  expect_error(external_link("https://shiny.posit.co/", "here"))
+  expect_error(external_link("https://shiny.posit.co/", "PDF"))
+  expect_error(external_link("https://shiny.posit.co/", "https://shiny.posit.co/"))
+  expect_error(external_link("https://shiny.posit.co/", "http://shiny.posit.co/"))
+  expect_error(external_link("https://shiny.posit.co/", "www.google.com"))
+})
+
+test_that("Rejects non-boolean for add_warning", {
+  expect_error(
+    external_link(
+      "https://shiny.posit.co/",
+      "R Shiny",
+      add_warning = "Funky non-boolean"
+    ),
+    "add_warning must be a TRUE or FALSE value"
+  )
+})
+
+test_that("New tab warning always stays for non-visual users", {
+  test_link_hidden <-
+    external_link("https://shiny.posit.co/", "R Shiny", add_warning = FALSE)
+
+  expect_true(
+    grepl("This link opens in a new tab", test_link_hidden$children[[1]])
+  )
+})