gadenbuie / metathis
1
#' Initialize a List of HTML Metadata Tags
2
#'
3
#' Initialize a _metathis_ object (i.e. a list of HTML metadata tags), test if
4
#' an object is a _metathis_ object, or coerce a list of `meta` tags to be a
5
#' _metathis_ object.
6
#'
7
#' @template describe-meta-return
8
#'
9
#' @export
10
meta <- function() {
11 10
  as_meta(list())
12
}
13

14
#' Include Metadata Tags in HTML Document
15
#'
16
#' Use `include_meta()` to explicitly declare the [meta()] tags as an HTML
17
#' dependency. In general, this is not required when knitting to an HTML
18
#' document. This function explicitly attaches an [htmltools::htmlDependency()]
19
#' and may work in some unusual cases.
20
#'
21
#' @template describe-meta
22
#' @return An [htmltools::htmlDependency()] containing the metadata tags to be
23
#'   included in the `<head>` of the HTML document.
24
#'
25
#' @family meta_actions
26
#'
27
#' @examples
28
#' meta() %>%
29
#'   meta_name("github-repo" = "gadenbuie/metathis") %>%
30
#'   include_meta()
31
#'
32
#' @export
33
include_meta <- function(.meta) {
34 10
  assert_is_meta(.meta)
35

36 10
  htmltools::tagList(metaDependency(.meta))
37
}
38

39

40
#' Create name/content metadata tag pairs
41
#'
42
#' Creates metadata tag pairs where the arguments are the name values and their
43
#' values are content values.
44
#'
45
#' @template describe-meta
46
#' @param ... Name (argument names) and content (argument value) pairs.
47
#' @examples
48
#' meta() %>%
49
#'   meta_name("github-repo" = "hadley/r4ds")
50
#'
51
#' @template describe-meta-return
52
#' @export
53
meta_name <- function(.meta = meta(), ...) {
54 10
  assert_is_meta(.meta)
55

56 10
  name_meta <- list(...) %>%
57 10
    collapse_single_string() %>%
58 10
    tag_meta_list()
59

60 10
  append_to_meta(.meta, name_meta)
61
}
62

63
#' Create a metadata tag for attribute/value pairs
64
#'
65
#' Creates a `<meta>` tag for attribute value pairs, where argument names
66
#' correspond to attribute names.
67
#'
68
#' @template describe-meta
69
#' @param ... Attribute names and values as `attribute = value`. Values must be
70
#'   a single character string.
71
#' @examples
72
#' meta() %>%
73
#'   meta_tag(
74
#'     "http-equiv" = "Content-Security-Policy",
75
#'     content = "default-src 'self'"
76
#'   )
77
#'
78
#' @template describe-meta-return
79
#' @export
80
meta_tag <- function(.meta = meta(), ...) {
81 10
  assert_is_meta(.meta)
82 10
  attrs <- list(...)
83

84 10
  len_gt_1 <- purrr::keep(attrs, ~ length(.) > 1)
85 10
  if (length(len_gt_1)) {
86 10
    stop(
87 10
      "All values must be length 1: '",
88 10
      paste0(names(len_gt_1), collapse = "', '"),
89
      "'"
90
    )
91
  }
92

93 10
  append_to_meta(.meta, list(tag_meta(...)))
94
}
95

96
#' @describeIn meta Test if an objects is a _metathis_ object
97
#' @examples
98
#' meta() %>%
99
#'   meta_viewport() %>%
100
#'   is_meta()
101
#'
102
#' @export
103
is_meta <- function(x) {
104 10
  inherits(x, "meta")
105
}
106

107
assert_is_meta <- function(x, var = ".meta") {
108 10
  if (!is_meta(x)) {
109 10
    stop("`", var, "` must be a meta object from meta() or as_meta()")
110
  } else {
111 10
    invisible(TRUE)
112
  }
113
}
114

115
#' @describeIn meta Convert a list of meta tags into a _metathis_ object.
116
#'
117
#' @param x A list or metathis object
118
#'
119
#' @examples
120
#' list_of_meta_tags <- list(
121
#'   htmltools::tags$meta(github = "gadenbuie"),
122
#'   htmltools::tags$meta(twitter = "grrrck")
123
#' )
124
#'
125
#' as_meta(list_of_meta_tags)
126
#' @export
127 10
as_meta <- function(x) UseMethod("as_meta", x)
128

129
#' @export
130
as_meta.list <- function(x) {
131 10
  head <- htmltools::tags$head()
132 10
  head$children <- x
133 10
  structure(list(head), class = c("meta", "shiny.tag.list", "list"))
134
}
135

136
#' @export
137
as_meta.default <- function(x) {
138 10
  x_class <- paste(class(x), collapse = ", ")
139 10
  stop(
140 10
    "I don't know how to convert an object of class '",
141 10
    x_class,
142 10
    "' into a list of <meta> tags"
143
  )
144
}
145

146
#' @export
147
as_meta.data.frame <- function(x) {
148 10
  NextMethod()
149
}
150

151
#' @export
152
as.character.meta <- function(x, ...) {
153 10
  x[[1]]$children %>% purrr::map_chr(as.character)
154
}
155

156
#' @export
157
format.meta <- function(x, ...) {
158 10
  collapse(as.character(x), "\n")
159
}
160

161
#' @export
162
print.meta <- function(x, ...) {
163 10
  cat(format(x))
164
}
165

166
#' @export
167
knit_print.meta <- function(.meta, ...) {
168 10
  assert_is_meta(.meta)
169

170
  # nocov start
171
  if (!grepl("html", knitr::opts_knit$get("rmarkdown.pandoc.to"))) {
172
    warning(
173
      "knitr output format is not HTML. Use `include_meta()` to ensure ",
174
      "that the <meta> tags are properly included in the <head> output ",
175
      "(if possible).",
176
      call. = FALSE
177
    )
178
  }
179

180
  if (guess_blogdown()) {
181
    warning(
182
      "{metathis} can't directly include <meta> tags inside blogdown posts ",
183
      "because the mechanism for including tags in the <head> section of a ",
184
      "page depends on the Hugo template. ",
185
      "If you see this message but are not rendering a blogdown post, you can ",
186
      "use metathis::include_meta() to avoid this check. ",
187
      "See ?meta for more information.",
188
      call. = FALSE
189
    )
190
    return(collapse(.meta, "\n"))
191
  }
192
  #nocov end
193

194
  # Thank you: https://github.com/haozhu233/kableExtra/blob/master/R/print.R#L56
195 10
  knitr::asis_output("", meta = list(metaDependency(.meta)))
196
}
197

198
append_to_meta <- function(.meta, .list = NULL) {
199 10
  assert_is_meta(.meta)
200 10
  .meta[[1]]$children <- append(.meta[[1]]$children, .list)
201 10
  .meta
202
}
203

204
prepend_to_meta <- function(.meta, .list = NULL) {
205 10
  assert_is_meta(.meta)
206 10
  .meta[[1]]$children <- purrr::prepend(.meta[[1]]$children, .list)
207 10
  .meta
208
}
209

210
metaDependency <- function(.meta) {
211 10
  assert_is_meta(.meta)
212

213 10
  htmltools::htmlDependency(
214 10
    paste0("metathis", "-", random_id()),
215 10
    version = metathis_version,
216 10
    src = system.file(package = "metathis"),
217 10
    all_files = FALSE,
218 10
    head = .meta %>% paste()
219
  )
220
}
221

222
random_id <- function(n = 6) {
223 10
  c(letters[1:6], 0:9) %>%
224 10
    sample(8, replace = TRUE) %>%
225 10
    collapse("")
226
}
227

228
guess_blogdown <- function() {
229 10
  blogdown_root <- find_config(getwd())
230 10
  if (is.null(blogdown_root)) return(FALSE)
231

232
  # Check for blogdown config files and confirm if they contain "baseURL"
233 10
  config_files <- dir(blogdown_root, "config[.](yaml|toml|json)", full.names = TRUE)
234 10
  if (length(config_files)) {
235 10
    for (config in config_files) {
236 10
      if (grepl("baseURL", collapse(readLines(config, warn = FALSE)))) {
237 10
        return(TRUE)
238
      }
239
    }
240
  }
241

242
  # Check if config file + "content" + "layouts" + "static"
243 10
  blogdown_files <- dir(blogdown_root, "content|layouts|static")
244 10
  if (length(blogdown_files) == 3 && length(config_files)) {
245 10
    return(TRUE)
246
  }
247

248 10
  FALSE
249
}
250

251
find_config <- function(path) {
252 10
  if (length(dir(path, "config[.](yaml|toml|json)"))) {
253 10
    return(path)
254
  }
255

256 10
  path_up <- normalizePath(file.path(path, ".."))
257 10
  if (path == path_up) return(NULL)
258 10
  find_config(path_up)
259
}
260

261
meta_find_description <- function(.meta) {
262
  # check existing metadata for description
263 10
  has_description <- has_meta_with_property(.meta, value = "description")
264 10
  if (!any(has_description)) {
265 10
    return(NULL)
266
  }
267

268 10
  desc_existing <- .meta[[1]]$children %>%
269 10
    purrr::keep(has_description) %>%
270 10
    purrr::map_chr(~ .$attribs$content) %>%
271 10
    unique()
272

273 10
  if (length(desc_existing) > 1) {
274 10
    warning(
275 10
      "Multiple existing descriptions were found, using first for ",
276 10
      "social cards:\n",
277 10
      strwrap(desc_existing[1], indent = 4)
278
    )
279
  }
280 10
  desc_existing[1]
281
}

Read our documentation on viewing source code .

Loading