utilities-quarto.R

`%||%` <- function(x, y) {
  if (rlang::is_null(x)) {
    y
  } else {
    x
  }
}

# Quarto extension functions are based on the quartools package:
# https://github.com/ElianHugh/quartools/

as_txt <- function(x,
                   replace_na = TRUE,
                   replace = "",
                   collapse = "\n") {
  if (replace_na) {
    x[is.na(x)] <- replace
  }

  paste0(x, collapse = collapse)
}

# See: https://github.com/ElianHugh/quartools/issues/2
as_quarto_img <- function(src,
                          caption = "",
                          alt = NULL,
                          reference = NULL,
                          align = NULL,
                          pos = NULL,
                          width = NULL,
                          height = NULL,
                          href = NULL,
                          title = NULL,
                          error = TRUE) {
  if (error && (!file.exists(src) || !grepl("^(f|ht)tps?://", src))) {
    rlang::abort(
      "{.arg src} must be an existing file or a valid web path."
    )
  }

  img <- span_attr(caption, attr = src, before = "!")

  before <- NULL

  values <- c(
    "fig-alt" = alt,
    "fig-align" = align,
    "fig-pos" = pos,
    "width" = width,
    "height" = height
  )

  if (!is.null(reference)) {
    prefix <- "#"

    if (!grepl("^fig-", reference)) {
      prefix <- "#fig-"
    }

    before <- paste0("{", prefix, reference)
  } else if (!is.null(values)) {
    before <- "{"
  }

  img <- paste0(
    img,
    as_key_values(values, before = before, after = "}") %||% ""
  )

  if (is.null(href)) {
    return(as_quarto_block(img))
  }

  if (!is.null(title)) {
    href <- paste0(href, ' "', title, '"')
  }

  as_quarto_block(span_attr(img, attr = href))
}

# See: https://github.com/ElianHugh/quartools/issues/1
as_quarto_callout <- function(...,
                              type = c("note", "tip", "warning", "caution", "important"),
                              heading = NULL,
                              collapse = NULL,
                              appearance = NULL,
                              icon = NULL,
                              title = NULL,
                              id = NULL,
                              class = NULL,
                              values = NULL,
                              keys = NULL,
                              level = "##",
                              sep = " ",
                              fence = ":::") {
  type <- rlang::arg_match(type)
  class <- paste0("callout-", type)

  if (!is.null(appearance)) {
    appearance <- rlang::arg_match0(appearance, c("default", "simple", "minimal"))
  }

  keys <- keys %||% names(values)

  stopifnot(
    is.null(values) || is.character(keys)
  )

  values <- c(
    "collapse" = collapse,
    "appearance" = appearance,
    "icon" = icon,
    values,
    "title" = title
  )

  if (is.null(heading) || is.na(heading)) {
    callout <- as_quarto_div(
      ...,
      class = class,
      id = id,
      values = values,
      fence = fence,
      sep = sep
    )

    return(callout)
  }

  as_quarto_div(
    paste0(level, " ", heading, "\n\n"),
    ...,
    class = class,
    id = id,
    values = values,
    fence = fence,
    sep = sep
  )
}

#' [as_quarto_div()] based on [quartools::div()]
as_quarto_div <- function(...,
                          class = NULL,
                          id = NULL,
                          values = NULL,
                          keys = NULL,
                          sep = " ",
                          collapse = "",
                          fence = ":::") {
  attr <- div_attributes(
    id = id,
    class = class,
    values = values,
    keys = keys
  )

  if (attr != "") {
    attr <- paste0("{", attr, "}")
  }

  as_quarto_block(
    paste0(
      "\n", fence, attr, "\n",
      paste0(..., sep = sep, collapse = collapse),
      "\n", fence, "\n",
      collapse = ""
    )
  )
}

#' [as_quarto_block()] based on [quartools::as_markdown()]
as_quarto_block <- function(..., collapse = "") {
  structure(
    paste0(..., collapse = collapse),
    class = c("knit_asis", "quarto_block")
  )
}

as_knit_asis <- function(..., collapse = "") {
  structure(
    paste0(..., collapse = collapse),
    class = c("knit_asis")
  )
}

span_attr <- function(..., attr, before = "", after = "") {
  paste0(before, "[", ..., "](", attr, ")", after)
}

div_attributes <- function(id = NULL,
                           class = NULL,
                           values = NULL,
                           keys = NULL) {
  if (!is.null(id) && !grepl("^#", id)) {
    id <- paste0("#", id)
  }

  if (!is.null(class) && !grepl("^\\.", class)) {
    class <- paste0(".", class)
  }

  if (!is.null(values)) {
    values <- as_key_values(values, keys, collapse = " ")
  }

  if (is.null(c(id, class, values))) {
    return("")
  }

  paste0(c(id, class, values), collapse = " ")
}


as_key_values <- function(values = NULL,
                          keys = NULL,
                          op = "=",
                          collapse = " ",
                          before = "",
                          after = "") {
  if (is.null(values)) {
    if (!is.null(before) && !is.null(after)) {
      return(paste0(before, after))
    }

    return(values)
  }

  if (rlang::is_named(values)) {
    keys <- keys %||% names(values)
  }

  values <- vapply(
    values,
    \(x) {
      if (is.logical(x)) {
        return(tolower(x))
      }
      if (is.character(x)) {
        return(paste0("'", x, "'"))
      }
      as.character(x)
    },
    NA_character_
  )

  values <- paste0(keys, op, values, collapse = collapse)

  paste0(before, values, after)
}


#' [quarto_render_data()] is a wrapper for [quarto::quarto_render()] that adds a
#' `execute_data` parameter that is serialized as JSON using
#' [jsonlite::toJSON()] and then passed as a named parameter (using `data_nm`)
#' to `execute_params`.
#'
quarto_render_data <- function(input = NULL,
                               output_file = NULL,
                               output_format = NULL,
                               ...,
                               execute_data = NULL,
                               data_nm = NULL,
                               execute_params = NULL,
                               drop_cols = NULL,
                               .envir = parent.frame()) {
  if (!is.null(execute_data)) {
    # FIXME: ggplot2 list columns can't be converted to or from a JSON. Figure
    # out how to drop them automatically.
    if (!is.null(drop_cols)) {
      execute_data <- dplyr::select(
        execute_data,
        !dplyr::any_of(drop_cols)
      )
    }

    execute_data <- list(jsonlite::toJSON(execute_data))

    execute_data <- rlang::set_names(
      execute_data,
      data_nm
    )
  }

  execute_params <- c(execute_data, execute_params)

  if (is.null(output_format)) {
    output_file <- glue::glue(output_file, .envir = .envir)
  }

  quarto::quarto_render(
    input = input,
    output_format = output_format,
    output_file = output_file,
    ...,
    execute_params = execute_params
  )
}

#' [walk_quarto_render()] passes a data frame list of execute_data to
#' [quarto_render_data()] using [purrr::walk2()] to create a set of rendered
#' documents.
walk_quarto_render <- function(.list, output_file, data_nm, ...) {
  purrr::walk(
    .list,
    \(x) {
      quarto_render_data(
        execute_data = x,
        output_file = output_file,
        ...,
        data_nm = data_nm
      )
    }
  )
}

#' [walk2_quarto_render()] passes a data frame list and a character vector of
#' output file names to [quarto_render_data()] using [purrr::walk2()] to create
#' a set of rendered documents.
walk2_quarto_render <- function(.list, .files, data_nm, ...) {
  purrr::walk2(
    .list,
    .files,
    \(x, y) {
      quarto_render_data(
        execute_data = x,
        output_file = y,
        data_nm = data_nm,
        ...
      )
    }
  )
}