community coverage - 77.16%

Files
Source

#' Format a JavaScript Color Palette
#'
#' Make a specially-formatted color palette based on color codes.
#'
#' @param colors A vector of color names or HEX codes, or a matrix-like object with
#' colors in columns, and their RGB values in separate rows.
#' @param continuous Logical; if \code{TRUE}, \code{colors} are treated as points in a linear
#' gradient. One provided color will be from white to that color. Two provided colors will
#' be between those colors. Three or four provided colors will be between the first and
#' last color, with the central color (or average of the central colors) as the midpoint.
#' @param divergent Logical; if \code{TRUE}, marks continuous scales as divergent,
#' which will reverse the lower half of the scale.
#' @param polynomial Logical; if \code{TRUE}, will fit a polynomial regression model to each color
#' channel in the specified \code{colors} sequence. Used to either compress a long sequence
#' (e.g., model a fully manually specified scale), or interpolate a scale between anchors.
#' @param degrees Number of polynomial degrees, if \code{polynomial} is \code{TRUE}.
#' @param pad If \code{polynomial} is \code{TRUE}, number of repeated observations of the
#' initial and final colors in the sequence to add in order to reduce warping at the edges.
#' @param name Name of the palette.
#' @param preview Logical; if \code{TRUE}, makes a plot showing the palette colors / scale.
#' @param print Logical; if \code{FALSE}, will not print a version of the palette.
#' @examples
#' # a discrete palette
#' util_make_palette(c("red", "green", "blue"), FALSE)
#'
#' # a continuous palette
#' util_make_palette("red")
#'
#' # a divergent continuous palette
#' util_make_palette(c("red", "green"), divergent = TRUE)
#' @return An invisible list of the created palette.
#' @export

util_make_palette <- function(colors, continuous = length(colors) < 5, divergent = length(colors) > 2,
                              polynomial = FALSE, degrees = 6, pad = 10, name = "custom", preview = TRUE, print = TRUE) {
  if (missing(polynomial) && (!missing(degrees) || !missing(pad))) polynomial <- TRUE
  if (polynomial) {
    if (missing(divergent)) divergent <- FALSE
    if (!missing(continuous) && !continuous) {
      cli_alert_warning(
        "{.arg polynomial} if {.val TRUE}, so {.arg continuous} will also be {.val TRUE}"
      )
    }
    continuous <- TRUE
  }
  if (is.character(colors)) {
    cols <- col2rgb(colors)
  } else {
    cols <- colors
    if (is.null(dim(cols))) {
      cols <- if (is.list(cols)) {
        as.data.frame(cols)
      } else {
        matrix(cols, 3, dimnames = list(c("red", "green", "blue")))
      }
    } else if (ncol(cols) == 3 && nrow(cols) != 3) cols <- t(cols)
  }
  if (nrow(cols) != 3) cli_abort("{.arg colors} could not be resolved to a matrix of RGB vectors")
  palette <- if (continuous) {
    if (polynomial) {
      rownames(cols) <- c("red", "green", "blue")
      colnames(cols) <- NULL
      x <- seq.int(0, 1, length.out = ncol(cols))
      if (max(cols) <= 1) cols <- cols * 256
      ori <- list(x = x, cols = cols)
      if (is.numeric(pad) && pad > 0) {
        x <- c(numeric(pad), x, rep(1, pad))
        cols <- cbind(
          matrix(rep(as.numeric(cols[, 1]), pad), 3, dimnames = list(rownames(cols))),
          cols,
          matrix(rep(as.numeric(cols[, ncol(cols)]), pad), 3, dimnames = list(rownames(cols)))
        )
      }
      coefs <- vapply(1:3, function(ch) {
        as.numeric(lm(cols[ch, ] ~ poly(x, degree = degrees, raw = TRUE, simple = TRUE))$coefficients)
      }, numeric(degrees + 1))
      if (anyNA(coefs)) cli_abort("this combination of inputs resulted in missing coefficient estimates")
      if (preview) {
        mm <- cbind(1, poly(ori$x, degrees, raw = TRUE))
        plot(
          NA,
          xlim = c(0, 1), ylim = c(0, 1), axes = FALSE, pch = 15, cex = 2,
          main = "Palette Comparison", ylab = "Palette", xlab = "Value"
        )
        mtext(paste0("Degrees: ", degrees, ", Padding: ", pad), 3)
        axis(1)
        axis(2, c(.70, .30), c("Original", "Derived"), lwd = 0)
        n <- length(ori$x)
        points(ori$x, rep(.70, n), pch = "|", cex = 7, col = do.call(rgb, as.data.frame(t(ori$cols) / 256)))
        points(ori$x, rep(.30, n), pch = "|", cex = 7, col = do.call(rgb, lapply(1:3, function(ch) {
          cv <- (mm %*% coefs[, ch]) / 256
          cv[cv < 0] <- 0
          cv[cv > 1] <- 1
          cv
        })))
      }
      list(
        name = name,
        type = paste0("continuous", "-polynomial"),
        colors = coefs
      )
    } else {
      if (length(colors) < 3) {
        if (length(colors) == 1) cols <- cbind(c(0, 0, 0), cols)
        cols <- cbind(cols[, 1], rowMeans(cols), cols[, 2])
      } else {
        if (ncol(cols) != 3) cols <- cbind(cols[, 1], rowMeans(cols[, 2:3]), cols[, 4])
      }
      cols <- t(cols)
      list(
        name = name,
        type = paste0("continuous", if (divergent) "-divergent"),
        colors = list(
          rbind(cols[3, ], cols[2, ] - cols[3, ]),
          cols[2, ],
          rbind(cols[1, ], cols[2, ] - cols[1, ])
        )
      )
    }
  } else {
    list(
      name = name,
      type = "discrete",
      colors = unlist(lapply(
        as.data.frame(cols / 255), function(col) do.call(rgb, as.list(col))
      ), use.names = FALSE)
    )
  }
  if (print) cat(jsonlite::toJSON(palette, auto_unbox = TRUE, pretty = TRUE))
  invisible(palette)
}

#' Check Data Repositories
#'
#' Performs a series of checks to see if data in a given repository can be ingested by a datacommons project.
#'
#' @param dir Root directory of the data repository.
#' @param search_pattern Regular expression used to search for data files.
#' @param exclude Subdirectories to exclude from the file search.
#' @param value Name of the column containing variable values.
#' @param value_name Name of the column containing variable names.
#' @param id Column name of IDs that uniquely identify entities.
#' @param time Column name of the variable representing time.
#' @param dataset Column name used to separate data into sets (such as by region), or a vector
#' of datasets, with \code{id}s as names, used to map IDs to datasets.
#' @param entity_info A vector of variable names to go into making \code{entity_info.json}.
#' @param check_values Logical; if \code{FALSE}, will perform more intensive checks on values.
#' If not specified, these are skipped if there are more that 5 million rows in the given dataset,
#' in which case \code{TRUE} will force checks.
#' @param attempt_repair Logical; if \code{TRUE}, will attempt to fix most warnings in data files.
#' Use with caution, as this will often remove rows (given \code{NA}s) and rewrite the file.
#' @param write_infos Logical; if \code{TRUE}, will save standardized and rendered versions of each measure info file.
#' @param verbose Logical; If \code{FALSE}, will not print status messages or check results.
#' @examples
#' \dontrun{
#' # from a data repository
#' check_repository()
#'
#' # to automatically fix most warnings
#' check_repository(attempt_repair = TRUE)
#' }
#' @return An invisible list of check results, in the form of paths to files and/or measure name.
#' These may include \strong{general} entries:
#' \itemize{
#'   \item \strong{\code{info}} (always): All measurement information (\code{measure_info.json}) files found.
#'   \item \strong{\code{data}} (always): All data files found.
#'   \item \strong{\code{not_considered}}: Subset of data files that do not contain the minimal
#'     columns (\code{id} and \code{value}), and so are not checked further.
#'   \item \strong{\code{summary}} (always): Summary of results.
#' }
#' or those relating to issues with \strong{measure information} (see \code{\link{data_measure_info}}) files:
#' \itemize{
#'   \item \strong{\code{info_malformed}}: Files that are not in the expected format (a single object with
#'     named entries for each measure), but can be converted automatically.
#'   \item \strong{\code{info_incomplete}}: Measure entries that are missing some of the required fields.
#'   \item \strong{\code{info_invalid}}: Files that could not be read in (probably because they do not contain valid JSON).
#'   \item \strong{\code{info_refs_names}}: Files with a \code{_references} entry with no names
#'     (where it should be a named list).
#'   \item \strong{\code{info_refs_missing}}: Files with an entry in its \code{_references} entry that
#'     is missing one or more required entries (\code{author}, \code{year}, and/or \code{title}).
#'   \item \strong{\code{info_refs_*}}: Files with an entry in its \code{_references} entry that has an entry
#'     (\code{*}) that is a list (where they should all be strings).
#'   \item \strong{\code{info_refs_author_entry}}: Files with an entry in its \code{_references} entry that has an
#'     \code{author} entry that is missing a \code{family} entry.
#'   \item \strong{\code{info_source_missing}}: Measures with an entry in its \code{source} entry that is missing a
#'     required entry (\code{name} and/or \code{date_accessed}).
#'   \item \strong{\code{info_source_*}}: Measures with an entry (\code{*}) in its \code{source} entry that is a
#'     list (where they should all be strings).
#'   \item \strong{\code{info_citation}}: Measures with a \code{citation} entry that cannot be found in any
#'     \code{_references} entries across measure info files within the repository.
#'   \item \strong{\code{info_layer_source}}: Measures with an entry in its \code{layer} entry that is missing a
#'     \code{source} entry.
#'   \item \strong{\code{info_layer_source_url}}: Measures with an entry in its \code{layer} entry that has a list
#'     \code{source} entry that is missing a \code{url} entry. \code{source} entries can either be a string containing a
#'     URL, or a list with a \code{url} entry.
#'   \item \strong{\code{info_layer_filter}}: Measures with an entry in its \code{layer} entry that has a \code{filter}
#'     entry that is missing required entries (\code{feature}, \code{operator}, and/or \code{value}).
#' }
#' or relating to data files with \strong{warnings}:
#' \itemize{
#'   \item \strong{\code{warn_compressed}}: Files that do not have compression extensions
#'     (\code{.gz}, \code{.bz2}, or \code{.xz}).
#'   \item \strong{\code{warn_blank_colnames}}: Files with blank column names (often due to saving files with row names).
#'   \item \strong{\code{warn_value_nas}}: Files that have \code{NA}s in their \code{value} columns; \code{NA}s here
#'     are redundant with the tall format, and so, should be removed.
#'   \item \strong{\code{warn_double_ints}}: Variable names that have an \code{int} type, but with values that have
#'     remainders.
#'   \item \strong{\code{warn_small_percents}}: Variable names that have a \code{percent} type, but that are all under
#'     \code{1} (which are assumed to be raw proportions).
#'   \item \strong{\code{warn_small_values}}: Variable names with many values (over 40%) that are under \code{.00001}, and
#'     no values under \code{0} or over \code{1}. These values should be scaled in some way to be displayed reliably.
#'   \item \strong{\code{warn_value_name_nas}}: Files that have \code{NA}s in their \code{name} column.
#'   \item \strong{\code{warn_entity_info_nas}}: Files that have \code{NA}s in any of their \code{entity_info} columns.
#'   \item \strong{\code{warn_dataset_nas}}: Files that have \code{NA}s in their \code{dataset} column.
#'   \item \strong{\code{warn_time_nas}}: Files that have \code{NA}s in their \code{time} column.
#'   \item \strong{\code{warn_id_nas}}: Files that have \code{NA}s in their \code{id} column.
#'   \item \strong{\code{warn_scientific}}: Files with IDs that appear to have scientific notation (e.g., \code{1e+5});
#'     likely introduced when the ID column was converted from numbers to characters -- IDs should always be saved as
#'     characters.
#'   \item \strong{\code{warn_bg_agg}}: Files with IDs that appear to be census block group GEOIDs,
#'     that do not include their tract parents (i.e., IDs consisting of 12 digits, and there are no IDs consisting of
#'     their first 11 digits). These are automatically aggregated by \code{\link{site_build}}, but they should
#'     be manually aggregated.
#'   \item \strong{\code{warn_tr_agg}}: Files with IDs that appear to be census tract GEOIDs,
#'     that do not include their county parents (i.e., IDs consisting of 11 digits, and there are no IDs consisting of
#'     their first 5 digits). These are automatically aggregated by \code{\link{site_build}}, but they should
#'     be manually aggregated.
#'   \item \strong{\code{warn_missing_info}}: Measures in files that do not have a corresponding \code{measure_info.json}
#'     entry. Sometimes this happens because the entry includes a prefix that cannot be derived from the file name
#'     (which is the part after a year, such as \code{category} from \code{set_geo_2015_category.csv.xz}).
#'     It is recommended that entries not include prefixes, and that measure names be specific
#'     (e.g., \code{category_count} rather than \code{count} with a \code{category:count} entry).
#' }
#' or relating to data files with \strong{failures}:
#' \itemize{
#'   \item \strong{\code{fail_read}}: Files that could not be read in.
#'   \item \strong{\code{fail_rows}}: Files containing no rows.
#'   \item \strong{\code{fail_time}}: Files with no \code{time} column.
#'   \item \strong{\code{fail_idlen_county}}: Files with "county" \code{dataset}s with corresponding IDs
#'     that are not consistently 5 characters long.
#'   \item \strong{\code{fail_idlen_tract}}: Files with "tract" \code{dataset}s with corresponding IDs
#'     that are not consistently 11 characters long.
#'   \item \strong{\code{fail_idlen_block_group}}: Files with "block group" \code{dataset}s with corresponding IDs
#'     that are not consistently 12 characters long.
#' }
#' @export

check_repository <- function(dir = ".", search_pattern = "\\.csv(?:\\.[gbx]z2?)?$", exclude = NULL,
                             value = "value", value_name = "measure", id = "geoid", time = "year", dataset = "region_type",
                             entity_info = c("region_type", "region_name"), check_values = TRUE, attempt_repair = FALSE,
                             write_infos = FALSE, verbose = TRUE) {
  if (!dir.exists(dir)) cli_abort("{.path {dir}} does not exist")
  project_check <- check_template("repository", dir = dir)
  if (project_check$exists) {
    if (length(project_check$incomplete)) {
      cli_alert_warning("please update template content in {.file {project_check$incomplete}}")
    }
  }
  files <- list.files(dir, search_pattern, recursive = TRUE, full.names = TRUE)
  files <- sort(files[!grepl(paste0(
    "[/\\](?:docs|code|working|original",
    if (length(exclude)) paste0("|", paste(exclude, collapse = "|")),
    ")[/\\]"
  ), files, TRUE)])
  if (!length(files)) cli_abort("no files found")
  i <- 0
  if (verbose) cli_h1("measure info")
  meta <- list()
  info_files <- sort(list.files(dir, "^measure_info[^.]*\\.json$", full.names = TRUE, recursive = TRUE))
  info_files <- info_files[
    !grepl("docs/data", info_files, fixed = TRUE) & !duplicated(gsub("_rendered|/code/|/data/", "", info_files))
  ]
  results <- list(data = files, info = info_files)
  required_fields <- c(
    "category", "long_name", "short_name", "long_description", "aggregation_method", "data_type"
  )
  required_refs <- c("author", "year", "title")
  required_source <- c("name", "date_accessed")
  required_layer_filter <- c("feature", "operator", "value")
  known_references <- NULL
  flagged_references <- list()
  if (verbose) {
    cli_progress_step(
      "checking {i} of {length(info_files)} measure info files",
      "checked {length(info_files)} measure info files",
      spinner = TRUE
    )
  }
  all_issues <- list()
  for (f in info_files) {
    m <- tryCatch(data_measure_info(
      f,
      render = TRUE, write = write_infos, verbose = FALSE, open_after = FALSE
    ), error = function(e) NULL)
    if (is.null(m)) cli_abort("measure info is malformed: {.file {f}}")
    i <- i + 1
    if (verbose) cli_progress_update()
    issues <- NULL
    if (!is.null(m$unit) && !is.null(m$short_name)) {
      issues <- "recoverably malformed (should be an object with named entries for each measure)"
      results$info_malformed <- c(results$info_malformed, f)
      m <- list(m)
      names(m) <- m[[1]]$measure
    }
    if ("_references" %in% names(m)) {
      refs <- m[["_references"]]
      if (is.null(names(refs))) {
        if (length(refs)) {
          results$info_refs_names[[f]] <- c(results$info_refs_names, f)
          issues <- c(issues, "{.arg _references} entries have no names")
        }
      } else {
        for (e in names(refs)) {
          known_references <- unique(c(known_references, e))
          su <- !required_refs %in% names(refs[[e]])
          if (any(su)) {
            missing_required <- required_refs[su]
            results$info_refs_missing[[f]] <- c(
              results$info_refs_missing[[f]], paste0(e, ":", paste(missing_required, collapse = ","))
            )
            issues <- c(issues, paste0(
              "{.arg _references} {.strong {.field ", e, "}} is missing ",
              if (sum(su) > 1) "entries: " else "an entry: ",
              paste0("{.pkg ", missing_required, "}", collapse = ", ")
            ))
          }
          if ("author" %in% names(refs[[e]])) {
            if (!is.list(refs[[e]]$author) || !is.null(names(refs[[e]]$author))) refs[[e]]$author <- list(refs[[e]]$author)
            for (i in seq_along(refs[[e]]$author)) {
              if (is.list(refs[[e]]$author[[i]]) && is.null(refs[[e]]$author[[i]]$family)) {
                results$info_refs_author_entry[[f]] <- c(
                  results$info_refs_author_entry[[f]], paste0(e, ":", i)
                )
                issues <- c(issues, paste0(
                  "{.arg _references} {.strong {.field ", e, "}}'s number ", i,
                  " author is missing a {.pkg family} entry"
                ))
              }
            }
          }
          for (re in c("year", "title", "journal", "volume", "page", "doi", "version", "url")) {
            if (is.list(refs[[e]][[re]])) {
              type <- paste0("info_refs_", re)
              results[[type]][[f]] <- c(results[[type]][[f]], e)
              issues <- c(issues, paste0(
                "{.arg _references} {.strong {.field ", e, "}}'s {.pkg ", re, "} entry is a list"
              ))
            }
          }
        }
      }
    }
    for (n in sort(names(m))) {
      if (!grepl("^_", n)) {
        cm <- Filter(function(e) length(e) && (length(e) > 1 || e != ""), m[[n]])
        entries <- names(cm)
        mf <- required_fields[!required_fields %in% entries]
        if (length(mf)) {
          results$info_incomplete[[f]] <- c(results$info_incomplete[[f]], n)
          issues <- c(issues, paste0(
            "{.strong {.field ", n, "}} is missing ", if (length(mf) > 1) "fields" else "a field", ": ",
            paste(paste0("{.pkg ", mf, "}"), collapse = ", ")
          ))
        }
        if ("sources" %in% entries) {
          if (!is.null(names(cm$sources))) cm$sources <- list(cm$sources)
          for (i in seq_along(cm$sources)) {
            s <- cm$sources[[i]]
            if (length(s) && is.list(s)) {
              su <- !required_source %in% names(s)
              if (any(su)) {
                missing_required <- required_source[su]
                results$info_source_missing[[f]] <- c(
                  results$info_source_missing[[f]], paste0(m, ":", paste(missing_required, collapse = ","))
                )
                issues <- c(issues, paste0(
                  "{.strong {.field ", n, "}}'s number ", i, " {.arg source} entry is missing ",
                  if (sum(su) > 1) "entries: " else "an entry: ",
                  paste0("{.pkg ", missing_required, "}", collapse = ", ")
                ))
              }
            }
            for (re in c(required_source, "location", "location_url")) {
              if (is.list(s[[re]])) {
                type <- paste0("info_source_", re)
                results[[type]][[f]] <- c(results[[type]][[f]], n)
                issues <- c(issues, paste0(
                  "{.strong {.field ", n, "}}'s number ", i, " {.arg source} entry's {.pkg ", re, "} entry is a list"
                ))
              }
            }
          }
        }
        if ("citations" %in% entries) {
          citations <- unlist(cm$citations, use.names = FALSE)
          su <- !citations %in% known_references
          if (any(su)) {
            name <- paste0(f, ":::", n)
            flagged_references[[name]] <- citations[su]
          }
        }
        if ("layer" %in% entries) {
          if ("source" %in% names(cm$layer)) {
            if (is.list(cm$layer$source) && !"url" %in% names(cm$layer$source)) {
              results$info_layer_source_url[[f]] <- c(results$info_layer_source_url[[f]], n)
              issues <- c(issues, paste0(
                "{.strong {.field ", n, "}}'s {.arg source} entry is a list, but doesn't have a {.pkg url} entry"
              ))
            }
          } else {
            results$info_layer_source[[f]] <- c(results$info_layer_source[[f]], n)
            issues <- c(issues, paste0(
              "{.strong {.field ", n, "}}'s {.arg layer} entry is missing a {.pkg source} entry"
            ))
          }
          if ("filter" %in% names(cm$layer)) {
            if (!is.null(names(cm$layer$filter))) cm$layer$filter <- list(cm$layer$filter)
            for (i in seq_along(cm$layer$filter)) {
              missing_required <- required_layer_filter[!required_layer_filter %in% names(cm$layer$filter[[i]])]
              if (length(missing_required)) {
                results$info_layer_filter[[f]] <- c(results$info_layer_filter[[f]], n)
                issues <- c(issues, paste0(
                  "{.strong {.field ", n, "}}'s number ", i, " {.arg filter} entry is missing ",
                  if (length(missing_required) > 1) "entries: " else "an entry: ",
                  paste(paste0("{.pkg ", missing_required, "}"), collapse = ", ")
                ))
              }
            }
          }
        }
      }
    }
    if (length(issues)) {
      names(issues) <- rep(">", length(issues))
      all_issues[[f]] <- issues
    }
    if (length(m)) {
      meta <- c(meta, m)
    } else {
      results$info_invalid <- c(results$info_invalid, f)
    }
  }
  rendered_names <- names(meta)
  if (verbose) cli_progress_done()
  if (verbose && !length(meta)) cli_alert_danger("no valid measure info")
  if (length(flagged_references)) {
    for (r in sort(names(flagged_references))) {
      su <- !flagged_references[[r]] %in% known_references
      if (any(su)) {
        f <- strsplit(r, ":::", fixed = TRUE)[[1]]
        results$info_citation[[f[1]]] <- c(results$info_citation[[f[1]]], paste0(
          f[2], ": ", paste(flagged_references[[r]][su], collapse = ", ")
        ))
        all_issues[[f[1]]] <- c(all_issues[[f[1]]], c(">" = paste0(
          "unknown {.arg citation} ", if (sum(su) > 1) "entries" else "entry",
          " in {.strong {.field ", f[2], "}}: ",
          paste0("{.pkg ", flagged_references[[r]][su], "}", collapse = ", ")
        )))
      }
    }
  }
  if (verbose && length(all_issues)) {
    cli_h2("{length(all_issues)} measure info file{? has/s have} issues")
    for (f in names(all_issues)) {
      cli_alert_danger("{.file {f}}:")
      cli_bullets(all_issues[[f]])
    }
  }

  i <- 0
  if (verbose) {
    cli_h1("data")
    cli_progress_step(
      "checking {i} of {length(files)} data file{?/s}", "checked {length(files)} data file{?/s}",
      spinner = TRUE
    )
  }
  census_geolayers <- c(county = 5, tract = 11, "block group" = 12)
  required <- c(id, value_name, value)
  dataset_map <- NULL
  if (length(dataset) > 1) {
    dataset_map <- dataset
    dataset <- "dataset"
  }
  vars <- unique(c(required, time, dataset, entity_info))
  entity_info <- entity_info[!entity_info %in% c(required, time)]
  files_short <- sub("^/", "", sub(dir, "", files, fixed = TRUE))
  for (i in seq_along(files)) {
    if (verbose) cli_progress_update()
    path <- files[[i]]
    f <- files_short[[i]]
    sep <- if (grepl(".csv", path, fixed = TRUE)) "," else "\t"
    cols <- tryCatch(scan(path, "", sep = sep, nlines = 1, quiet = TRUE), error = function(e) NULL)
    lcols <- tolower(cols)
    su <- !cols %in% vars & lcols %in% vars
    if (any(su)) cols[su] <- lcols[su]
    if (all(required %in% cols)) {
      d <- if (is.null(cols)) {
        NULL
      } else {
        tryCatch(as.data.frame(read_delim_arrow(
          gzfile(path), sep,
          skip = 1, col_names = cols,
          col_types = paste(c("c", "n")[as.integer(cols %in% c(value, time)) + 1L], collapse = "")
        )), error = function(e) NULL)
      }
      if (is.null(d)) {
        results$fail_read <- c(results$fail_read, f)
      } else {
        if (nrow(d)) {
          ck_values <- check_values && length(meta)
          if (missing(check_values) && nrow(d) > 5e6) {
            cli_alert_info(paste(
              "skipping value checks for {.field {f}} due to size ({prettyNum(nrow(d), big.mark = ',')} rows);",
              "set {.arg check_values} to {.pkg TRUE} to force checks"
            ))
            ck_values <- FALSE
          }
          d[[id]] <- sub("^\\s+|\\s+$", "", d[[id]])
          if (!time %in% cols) results$fail_time <- c(results$fail_time, f)
          all_entity_info <- all(entity_info %in% cols)

          if (attempt_repair) {
            repairs <- NULL
            if (!grepl("\\.[bgx]z2?$", f)) repairs <- "warn_compression"
            if (any(cols == "")) {
              repairs <- c(repairs, "warn_blank_colnames")
              d <- d[, cols != ""]
            }
            if (anyNA(d[[value]])) {
              d <- d[!is.na(d[[value]]), ]
              repairs <- c(repairs, "warn_value_nas")
              if (ck_values) d[[value]][is.na(d[[value]])] <- 0
            }
            su <- grep("\\de[+-]?\\d", d[[id]])
            if (length(su)) {
              d[[id]][su] <- gsub("^\\s+|\\s+$", "", format(as.numeric(d[[id]][su]), scientific = FALSE))
              repairs <- c(repairs, "warn_scientific")
            }
            if (nrow(d)) {
              if (anyNA(d[[id]])) {
                repairs <- c(repairs, "warn_id_nas")
                d <- d[!is.na(d[[id]]), ]
              }
            }
            if (nrow(d)) {
              if (anyNA(d[[value_name]])) {
                repairs <- c(repairs, "warn_value_name_nas")
                d <- d[!is.na(d[[value_name]]), ]
              }
            }
            if (length(dataset_map)) {
              data$dataset <- dataset_map[data[[id]]]
              cols <- c(cols, "dataset")
            }
            if (nrow(d) && dataset %in% cols) {
              if (anyNA(d[[dataset]])) {
                repairs <- c(repairs, "warn_dataset_nas")
                d <- d[!is.na(d[[dataset]]), ]
              }
            }
            if (nrow(d) && time %in% cols) {
              if (anyNA(d[[time]])) {
                repairs <- c(repairs, "warn_time_nas")
                d <- d[!is.na(d[[time]]), ]
              }
            }
            if (nrow(d) && all_entity_info) {
              if (anyNA(d[, entity_info])) {
                repairs <- c(repairs, "warn_entity_info_nas")
                d <- d[rowSums(is.na(d[, entity_info, drop = FALSE])) == 0, ]
              }
            }
            if (ck_values && nrow(d)) {
              md <- split(d[[value]], d[[value_name]])
              for (m in names(md)) {
                mm <- meta[[m]]
                mvs <- md[[m]]
                if (!is.null(mm)) {
                  type <- mm$aggregation_method
                  if (is.null(type) || type == "") {
                    type <- if (!is.null(mm$measure_type) && mm$measure_type == "") mm$type else mm$measure_type
                    if (is.null(type)) type <- ""
                  }
                  if (grepl("percent", type, fixed = TRUE)) {
                    if (any(mvs > 0) && !any(mvs > 1)) {
                      d[[value]][d[[value_name]] == m] <- d[[value]][d[[value_name]] == m] * 100
                      repairs <- c(repairs, "warn_small_percents")
                    }
                  }
                }
              }
            }
            if (length(repairs)) {
              if (!nrow(d)) {
                if (verbose) cli_alert_danger("{.strong attempting repairs ({repairs}) removed all rows of {.file {f}}}")
              } else {
                tf <- sub("\\..+(?:\\.[bgx]z2?)?$", ".csv.xz", path)
                w <- tryCatch(
                  {
                    write.csv(d, xzfile(tf), row.names = FALSE)
                    TRUE
                  },
                  error = function(e) NULL
                )
                if (is.null(w)) {
                  if (verbose) cli_alert_danger("failed to write repairs ({.field {repairs}}) to {.file {f}}")
                } else {
                  if (path != tf) {
                    unlink(path)
                  }
                  if (verbose) cli_alert_info("wrote repairs ({.field {repairs}}) to {.file {tf}}")
                }
              }
            }
          } else {
            if (!grepl("[bgx]z2?$", f)) results$warn_compressed <- c(results$warn_compressed, f)
            if (any(cols == "")) results$warn_blank_colnames <- c(results$warn_blank_colnames, f)
            if (anyNA(d[[value]])) {
              results$warn_value_nas <- c(results$warn_value_nas, f)
              if (ck_values) d[[value]][is.na(d[[value]])] <- 0
            }
            if (anyNA(d[[id]])) {
              results$warn_id_nas <- c(results$warn_id_nas, f)
              d[[id]][is.na(d[[id]])] <- "NA"
            }
            if (any(grepl("\\de[+-]\\d", d[[id]]))) results$warn_scientific <- c(results$warn_scientific, f)
            if (anyNA(d[[value_name]])) {
              results$warn_value_name_nas <- c(results$warn_value_name_nas, f)
              d[[value_name]][is.na(d[[value_name]])] <- "NA"
            }
            if (dataset %in% cols && anyNA(d[[dataset]])) {
              results$warn_dataset_nas <- c(results$warn_dataset_nas, f)
              d[[dataset]][is.na(d[[dataset]])] <- "NA"
            }
            if (all_entity_info && anyNA(d[, entity_info])) results$warn_entity_info_nas <- c(results$warn_entity_info_nas, f)
            if (time %in% cols && anyNA(d[[time]])) {
              results$warn_time_nas <- c(results$warn_time_nas, f)
              d[[time]][is.na(d[[time]])] <- "NA"
            }
          }

          if (nrow(d)) {
            if (dataset %in% cols) {
              for (l in names(census_geolayers)) {
                if (l %in% d[[dataset]]) {
                  su <- d[[dataset]] == l
                  n_match <- sum(nchar(d[[id]][su]) == census_geolayers[[l]])
                  if (n_match && n_match < sum(su)) {
                    e <- paste0("fail_idlen_", sub(" ", "", l, fixed = TRUE))
                    results[[e]] <- c(results[[e]], f)
                  }
                }
              }
            }

            measures <- unique(d[[value_name]])
            measures <- sort(measures[measures != "NA"])
            su <- !measures %in% rendered_names
            if (any(su)) su[su] <- !make_full_name(f, measures[su]) %in% names(meta)
            if (any(su)) results$warn_missing_info[[f]] <- c(results$warn_missing_info[[f]], measures[su])

            smids <- split(d[[id]], d[[value_name]])
            if (ck_values) md <- split(d[[value]], d[[value_name]])
            for (m in measures) {
              mids <- smids[[m]]
              id_chars <- nchar(mids)
              su <- which(id_chars == 12)
              if (length(su)) {
                su <- su[grep("[^0-9]", mids[su], invert = TRUE)]
                if (length(su) && !any(unique(substring(mids[su], 1, 11)) %in% mids)) {
                  results$warn_bg_agg[[f]] <- c(results$warn_bg_agg[[f]], m)
                }
              }
              su <- which(id_chars == 11)
              if (length(su)) {
                su <- su[grep("[^0-9]", mids[su], invert = TRUE)]
                if (length(su) && !any(unique(substring(mids[su], 1, 5)) %in% mids)) {
                  results$warn_tr_agg[[f]] <- c(results$warn_tr_agg[[f]], m)
                }
              }

              if (ck_values) {
                mm <- meta[[m]]
                mvs <- md[[m]]
                if (!is.null(mm)) {
                  type <- mm$aggregation_method
                  if (is.null(type) || type == "") {
                    type <- if (!is.null(mm$measure_type) && mm$measure_type == "") mm$type else mm$measure_type
                    if (is.null(type)) type <- ""
                  }
                  maxv <- max(mvs)
                  if (grepl("percent", type, fixed = TRUE)) {
                    if (maxv > 0 && !any(mvs > 1)) {
                      results$warn_small_percents[[f]] <- c(results$warn_small_percents[[f]], m)
                    }
                  }
                  if (!is.null(mm$data_type) && mm$data_type == "integer") {
                    if (any(mvs %% 1 != 0)) {
                      results$warn_double_ints[[f]] <- c(results$warn_double_ints[[f]], m)
                    }
                  } else {
                    vm <- min(mvs)
                    if (vm >= 0 && maxv < 1 && mean(mvs > 0 & mvs < 1e-4) > .4) {
                      results$warn_small_values[[f]] <- c(results$warn_small_values[[f]], m)
                    }
                  }
                }
              }
            }
          }
        } else {
          results$fail_rows <- c(results$fail_rows, f)
        }
      }
    } else {
      results$not_considered <- c(results$not_considered, f)
    }
  }
  if (verbose) cli_progress_done()

  long_paths <- files_short[nchar(files_short) > 140]
  n_long_paths <- length(long_paths)
  if (verbose && n_long_paths) {
    cli_alert_warning("{.strong {n_long_paths} {?path is/paths are} very long (over 140 character):}")
    cli_bullets(structure(
      paste0("(", nchar(long_paths), ") {.field ", long_paths, "}"),
      names = rep(">", n_long_paths)
    ))
  }

  res_summary <- c(FAIL = 0, WARN = 0, SKIP = 0, PASS = 0)
  if (length(results$not_considered)) {
    res_summary["SKIP"] <- length(results$not_considered)
    if (verbose) {
      cli_alert_info(paste(
        '{.strong skipped {res_summary["SKIP"]} file{?/s} because {?it does/they do}',
        "not include all base columns ({.pkg {required}}):}"
      ))
      cli_bullets(structure(
        paste0("{.field ", results$not_considered, "}"),
        names = rep(">", length(results$not_considered))
      ))
    }
  }

  warnings <- unique(unlist(lapply(grep("^warn_", sort(names(results)), value = TRUE), function(w) {
    if (is.list(results[[w]])) names(results[[w]]) else results[[w]]
  }), use.names = FALSE))
  n_warn <- length(warnings)
  if (n_warn) {
    res_summary["WARN"] <- n_warn
    if (verbose) cli_h2("{n_warn} file{? has/s have} warnings")
    sections <- list(
      warn_compressed = "not compressed:",
      warn_blank_colnames = "contains blank column names:",
      warn_value_nas = "{.pkg {value}} column contains NAs (which are redundant):",
      warn_id_nas = "{.pkg {id}} column contains NAs:",
      warn_scientific = "{.pkg {id}} column appears to contain values in scientific notation:",
      warn_value_name_nas = "{.pkg {value_name}} column contains NAs:",
      warn_dataset_nas = "{.pkg {dataset}} column contains NAs:",
      warn_time_nas = "{.pkg {time}} column contains NAs:",
      warn_entity_info_nas = "entity information column{?/s} ({.pkg {entity_info}}) contain{?s/} NAs:"
    )
    for (s in names(sections)) {
      if (verbose && length(results[[s]])) {
        cli_alert_warning(paste0("{.strong ", sections[[s]], "}"))
        cli_bullets(structure(
          paste0("{.field ", results[[s]], "}"),
          names = rep(">", length(results[[s]]))
        ))
      }
    }
    sections <- list(
      warn_missing_info = "missing measure info entries:",
      warn_small_percents = "no values with a {.pkg percent} type are over 1",
      warn_double_ints = "values with an {.pkg integer} data_type have decimals",
      warn_small_values = "non-zero values are very small (under .00001) -- they will display as 0s",
      warn_bg_agg = "may have block groups that have not been aggregated to tracts:",
      warn_tr_agg = "may have tracts that have not been aggregated to counties:"
    )
    for (s in names(sections)) {
      if (length(results[[s]])) {
        if (verbose) cli_alert_warning(paste0("{.strong ", sections[[s]], "}"))
        if (s == "warn_missing_info") meta_base <- sub("^[^:]*:", "", names(meta))
        missing_info <- unlist(lapply(
          names(results[[s]]),
          if (s == "warn_missing_info") {
            function(f) {
              vars <- results[[s]][[f]]
              paste0(
                if (length(vars) > 20) {
                  paste(prettyNum(length(vars), big.mark = ","), "variables")
                } else {
                  sub("}, ([^}]+)}$", "}, and \\1}", paste0(paste0("{.pkg ", vars, "}"), vapply(vars, function(m) {
                    w <- meta_base == m
                    if (any(w)) paste0(" (base matches {.emph ", names(meta)[which(w)[1]], "})") else ""
                  }, ""), collapse = ", "))
                },
                " in {.field ", f, "}"
              )
            }
          } else {
            function(f) {
              vars <- results[[s]][[f]]
              paste0(
                if (length(vars) > 20) {
                  paste(prettyNum(length(vars), big.mark = ","), "variables")
                } else {
                  paste0("{.pkg ", vars, "}", collapse = ", ")
                }, " in {.field ", f, "}"
              )
            }
          }
        ), use.names = FALSE)
        if (verbose) cli_bullets(structure(missing_info, names = rep(">", length(missing_info))))
      }
    }
  }

  failures <- unique(unlist(results[grep("^fail_", names(results))], use.names = FALSE))
  n_fails <- length(failures)
  if (n_fails) {
    res_summary["FAIL"] <- n_fails
    if (verbose) cli_h2("{n_fails} file{?/s} failed checks")
    sections <- list(
      fail_read = "failed to read in:",
      fail_rows = "contains no data:",
      fail_time = "no {.pkg {time}} column:",
      fail_idlen_county = "not all county GEOIDs are 5 characters long:",
      fail_idlen_tract = "not all tract GEOIDs are 11 characters long:",
      fail_idlen_block_group = "not all block group GEOIDs are 12 characters long:"
    )
    for (s in names(sections)) {
      if (verbose && length(results[[s]])) {
        cli_alert_danger(paste0("{.strong ", sections[[s]], "}"))
        cli_bullets(structure(
          paste0("{.field ", results[[s]], "}"),
          names = rep(">", length(results[[s]]))
        ))
      }
    }
  }

  res_summary["PASS"] <- sum(!files_short %in% c(results$not_considered, warnings, failures))
  results$summary <- res_summary

  if (verbose) {
    cat("\n")
    print(res_summary)
  }
  invisible(results)
}

#' Check the structure of a templated project
#'
#' Check if the parts of a template are in place, based on the template's spec.
#'
#' @param template Name of the template (e.g., \code{"function"}).
#' @param name Name of the template instance (e.g., \code{"test_function"}).
#' @param dir Path to the base directory of the template.
#' @param spec The template's spec; specify if template spec files do not exist.
#' @examples
#' \dontrun{
#' # precheck before a new template is made
#' check_template("template_new", list(name = "new", context = "new", files = list("new.R")))
#'
#' # check the new template after creation
#' check_template("new")
#' }
#' @return A list with results of the check:
#' \tabular{rl}{
#'   \strong{dir} \tab Path of the checked directory. \cr
#'   \strong{files} \tab Path(s) of the checked files. \cr
#'   \strong{spec} \tab A list with the template's spec. \cr
#'   \strong{status} \tab A named logical vector indicating whether each components exist. \cr
#'   \strong{incomplete} \tab A character vector with any existing files that still have template text. \cr
#'   \strong{exists} \tab \code{all(status)} \cr
#'   \strong{message} \tab A character vector including messages associated with failures. \cr
#' }
#' @export

check_template <- function(template, name = "", dir = ".", spec = NULL) {
  if (missing(template)) cli_abort("{.arg template} must be specified")
  template <- sub("^init_", "", template)
  report <- list(
    dir = dir,
    files = list(),
    spec = spec,
    status = c(spec = !is.null(spec), dir = FALSE, strict = TRUE, set = TRUE),
    incomplete = character(),
    exists = FALSE,
    message = character()
  )
  if (is.null(spec)) {
    path <- paste0(
      path.package("community"),
      if (file.exists(paste0(path.package("community"), "/inst"))) "/inst",
      "/specs/",
      sub(".json", "", template, fixed = TRUE),
      ".json"
    )
    report$status["spec"] <- file.exists(path)
    if (!report$status["spec"]) {
      report$status[] <- FALSE
      return(report)
    }
    spec <- jsonlite::read_json(path)
  }
  report$spec <- spec
  if (missing(name)) {
    name <- spec$name
  }
  strict <- vapply(spec$files, function(f) is.character(f) && length(f) == 1, TRUE)
  dir <- paste0(normalizePath(paste0(dir, "/", spec$dir), "/", FALSE), "/")
  report$dir <- dir
  report$status["dir"] <- dir.exists(dir)
  if (spec$context != spec$name) {
    check_context <- check_template(spec$context, dir = dir)
    if (!check_context$exists) cli_abort(c("context {spec$context} check failed for {name}:", check_context$message))
  }
  if (!report$status["dir"]) {
    report$message <- c(x = paste0(
      "the required directory ({.path ",
      spec$dir,
      "}) is not present in {.path ",
      normalizePath(dir, "/", FALSE),
      "}"
    ))
  }
  if (any(strict)) {
    files <- gsub("{name}", name, paste0(dir, unlist(spec$files[strict])), fixed = TRUE)
    report$files <- files
    present <- file.exists(files)
    report$status["strict"] <- all(present)
    if (!report$status["strict"]) {
      report$message <- c(report$message, x = paste0(
        "required file",
        if (sum(!present) == 1) " is" else "s are",
        " not present: ",
        paste0("{.path ", files[!present], "}", collapse = ", ")
      ))
    } else {
      for (f in files[present]) {
        if (!dir.exists(f) && grepl("<template:", paste(readLines(f, warn = FALSE), collapse = ""), fixed = TRUE)) {
          report$incomplete <- c(report$incomplete, f)
        }
      }
    }
  }
  if (any(!strict)) {
    file_set <- spec$files[!strict][[1]]
    if (length(file_set) == 1) {
      files <- gsub("{name}", spec$name, paste0(dir, file_set[[1]]), fixed = TRUE)
      report$files <- c(report$files, files)
      present <- file.exists(files)
      report$status["set"] <- any(present)
      if (!report$status["set"]) {
        report$message <- c(report$message, x = paste(
          "one of these files is required, but none were present:",
          paste(files, collapse = ", ")
        ))
      } else {
        for (f in files[present]) {
          if (!dir.exists(f) && grepl("<template:", paste(readLines(f, warn = FALSE), collapse = ""), fixed = TRUE)) {
            report$incomplete <- c(report$incomplete, f)
          }
        }
      }
    } else {
      file_set <- lapply(file_set, function(fl) gsub("{name}", spec$name, paste0(dir, fl), fixed = TRUE))
      report$files <- c(report$files, unlist(file_set))
      present <- vapply(file_set, function(fl) all(file.exists(fl)), TRUE)
      report$status["set"] <- any(present)
      if (!report$status["set"]) {
        report$message <- c(report$message, paste(
          x = "none of the required file sets were complete:",
          file_set
        ))
      } else {
        for (fl in file_set[present]) {
          for (f in fl) {
            if (!dir.exists(f) && grepl("<template:", paste(readLines(f, warn = FALSE), collapse = ""), fixed = TRUE)) {
              report$incomplete <- c(report$incomplete, f)
            }
          }
        }
      }
    }
  }
  if (report$status["dir"] && any(!report$status[c("strict", "set")])) {
    report$message <- c(
      report$message,
      i = "use {.fn template_{name}} to create required structure"
    )
  }
  if (all(report$status)) report$exists <- TRUE
  report
}

#' Make a Copy of a Data Site
#'
#' Copies baseline files from an existing data site. Useful for making different sites
#' based on the same data.
#'
#' @param parent Directory or GitHub repository name of the existing site to be copied.
#' @param dir Directory of the child site to put copies in.
#' @param update Logical; if \code{TRUE}, replaces existing site files if they are older than existing
#' files (from a local directory). Same as \code{overwrite} for remote sites. By default, only the
#' \code{datapackage.json} file is updated.
#' @param overwrite Logical; if \code{TRUE}, overwrites any existing site files. \code{datapackage.json}
#' is always overwritten.
#' @param protect A vector of file paths to prevent from being overwritten, relative to the site directory.
#' @param include A vector of paths to additional files to update from the parent site, relative to the
#' site's base directory.
#' @param quiet Logical; if \code{TRUE}, does not send messages.
#' @examples
#' \dontrun{
#' site_make_child("uva-bi-sdad/community_example", "../community_example")
#' }
#' @return Invisible path to the child directory.
#' @export

site_make_child <- function(parent, dir, update = FALSE, overwrite = FALSE, protect = "site.R",
                            include = NULL, quiet = !interactive()) {
  if (missing(dir)) cli_abort('{.arg dir} must be speficied (e.g., dir = "child_site")')
  check <- check_template("site", dir = dir)
  if (!quiet && any(file.exists(check$files)) && !overwrite) {
    cli_bullets(c(`!` = "site files already exist", i = "add {.code overwrite = TRUE} to overwrite them"))
  }
  dir <- normalizePath(paste0(dir, "/", check$spec$dir), "/", FALSE)
  dir.create(dir, FALSE, TRUE)
  dir.create(paste0(dir, "/docs/data"), FALSE, TRUE)
  files <- unique(c(unlist(check$spec$files, use.names = FALSE), "docs/data/datapackage.json", include))
  filled <- copied <- structure(!file.exists(paste0(dir, "/", files)), names = files)
  copied[] <- FALSE
  if (!file.exists(paste0(dir, "/build.R"))) {
    copied["build.R"] <- TRUE
    args <- lapply(match.call()[-1], eval, parent.frame())
    writeLines(paste(c(
      paste0("# this is a child site spawned from ", parent, ":"),
      paste0(
        "site_make_child(\n  ",
        paste(vapply(names(args), function(a) {
          if (a %in% c("parent", "dir")) {
            paste0(a, ' = "', normalizePath(args[[a]], "/", FALSE), '"')
          } else {
            paste(a, "=", args[[a]])
          }
        }, ""), collapse = ",\n  "),
        "\n)"
      ),
      ""
    ), collapse = "\n"), paste0(dir, "/build.R"))
  }
  init_site(dir, with_data = FALSE, quiet = TRUE)
  never_update <- c("build.R", "README.rm", protect)
  always_update <- c("docs/data/datapackage.json", include)
  if (!dir.exists(parent)) {
    parent <- regmatches(parent, regexec("^(?:.*github\\.com/)?([^/]+/[^/@]+)", parent))[[1]][2]
    repo <- tryCatch(jsonlite::read_json(
      paste0("https://api.github.com/repos/", parent, "/contents")
    ), error = function(e) e$message)
    if (is.character(repo)) cli_abort("treated {.arg parent} as a GitHub repository, but failed to retrieve it: {repo}")
    if (missing(update)) update <- FALSE
    repo <- c(
      repo,
      tryCatch(jsonlite::read_json(
        paste0("https://api.github.com/repos/", parent, "/contents/docs")
      ), error = function(e) NULL),
      tryCatch(jsonlite::read_json(
        paste0("https://api.github.com/repos/", parent, "/contents/docs/data")
      ), error = function(e) NULL)
    )
    for (f in repo) {
      if (f$path %in% files[!files %in% never_update]) {
        dest <- paste0(dir, "/", f$path)
        if (f$path %in% always_update || overwrite || update || filled[[f$path]]) {
          unlink(dest)
          tryCatch(download.file(f$download_url, dest, quiet = TRUE), error = function(e) NULL)
          copied[[f$path]] <- file.exists(dest)
        }
      }
    }
  } else {
    for (f in files[!files %in% never_update]) {
      pf <- paste0(parent, "/", f)
      dest <- paste0(dir, "/", f)
      if (file.exists(pf) && (f %in% always_update || overwrite || filled[[f]] || (update && file.mtime(pf) > file.mtime(dest)))) {
        unlink(dest)
        file.copy(pf, dest)
        copied[[f]] <- file.exists(dest)
      }
    }
  }
  if (!quiet) {
    if (any(copied)) {
      cli_bullets(c(
        v = "copied from {.path {parent}}:",
        "*" = paste0("{.path ", names(which(copied)), "}")
      ))
    }
    if (any(filled & !copied)) {
      cli_bullets(c(
        v = "created from template:",
        "*" = paste0("{.path ", names(which(filled & !copied)), "}")
      ))
    }
    if (!any(filled | copied)) {
      cli_alert_success("no site files were replaced")
    }
  }
  invisible(dir)
}

#' Add checkboxes, radio buttons, or switches to a website
#'
#' Adds a set of checkbox, radio buttons, or switches to a website.
#'
#' @param label Label of the input for the user.
#' @param options A vector of options, the name of a variable from which to pull levels, or either \code{"datasets"}
#' or \code{"variables"} to select names of datasets or variables.
#' @param default A vector of items to check by default (or "all" or "none") if \code{multi} is \code{TRUE}, or
#' the option to select by default.
#' @param display A display version of the options.
#' @param id Unique id of the element to be created.
#' @param ... Additional attributes to set on the element.
#' @param note Text to display as a tooltip for the input.
#' @param variable The name of a variable from which to get levels (overwritten by \code{depends}).
#' @param dataset The name of an included dataset, where \code{variable} should be looked for; only applies when
#' there are multiple datasets with the same variable name.
#' @param depends The id of another input on which the options depend; this will take president over \code{dataset}
#' and \code{variable}, depending on this type of input \code{depends} points to.
#' @param multi Logical; if \code{FALSE}, only one option can be selected at a time, turning the checkboxes into radio
#' buttons.
#' @param as.switch Logical; if \code{TRUE}, displays checkboxes or radio buttons as switches.
#' @examples
#' \dontrun{
#' input_checkbox("Label", c("a", "b", "c"))
#' }
#' @return A character vector of the contents to be added.
#' @seealso For a single switch or checkbox, use \code{\link{input_switch}}.
#' @export

input_checkbox <- function(label, options, default = "all", display = options, id = label, ..., note = NULL, variable = NULL,
                           dataset = NULL, depends = NULL, multi = TRUE, as.switch = FALSE) {
  if (multi && length(default) == 1) {
    if ((is.logical(default) && default) || default == "all") {
      default <- options
    } else if ((is.logical(default) && !default) || default == "none") {
      default <- NULL
    }
  } else if (!multi && is.character(default)) {
    default <- which((if (default %in% display) display else options) == default)
    if (!length(default)) default <- 1
  }
  id <- gsub("\\s", "", id)
  a <- list(...)
  type <- if (multi) "checkbox" else "radio"
  r <- c(
    '<div class="wrapper checkbox-wrapper">',
    paste0(
      "<fieldset",
      if (length(a)) paste("", paste(names(a), paste0('"', unlist(a), '"'), sep = "=")),
      ">"
    ),
    paste0("<legend>", label, "</legend>"),
    paste0(
      '<div class="auto-input" role="group" data-autoType="', type, '" id="', id, '" ',
      if (is.character(options) && length(options) == 1) paste0('data-optionSource="', options, '"'),
      if (!is.null(default)) paste0(' data-default="', paste(default, collapse = ","), '"'),
      if (!is.null(depends)) paste0(' data-depends="', depends, '"'),
      if (!is.null(note)) paste0(' aria-description="', note, '"'),
      if (!is.null(dataset)) paste0(' data-dataset="', dataset, '"'),
      if (!is.null(variable)) paste0(' data-variable="', variable, '"'),
      if (as.switch) paste0(' data-switch="', as.switch, '"'),
      if (length(a)) unlist(lapply(seq_along(a), function(i) paste0(" ", names(a)[i], '="', a[[i]], '"'))),
      ">"
    ),
    if (length(options) > 1) {
      unlist(lapply(seq_along(options), function(i) {
        c(
          paste0('<div class="form-check', if (as.switch) " form-switch", '">'),
          paste0(
            '<input type="', type, '" autocomplete="off" class="form-check-input" name="',
            id, '_options" id="', id, "_option", i, if (as.switch) '" role="switch', '" value="',
            options[i], '"', if ((multi && options[i] %in% default) || i == default) " checked", ">"
          ),
          paste0('<label class="form-check-label" for="', id, "_option", i, '">', display[i], "</label>"),
          "</div>"
        )
      }), use.names = FALSE)
    },
    "</div>",
    "</fieldset>",
    "</div>"
  )
  caller <- parent.frame()
  if (!is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts") {
    caller$content <- c(caller$content, r)
  }
  r
}

#' Add a number input to a website
#'
#' Adds an direct number input element to a website.
#'
#' @param label Label of the input for the user.
#' @param id Unique ID of the element to be created.
#' @param ... Other attributes to add to the input.
#' @param default Default value of the input, the ID of an input to use as the default, or \code{"min"} or \code{"max"}
#' to default to the current minimum or maximum value.
#' @param variable The name of a variable or ID of a variable selector to get a range from.
#' @param min The smallest allowed value.
#' @param max The largest allowed value.
#' @param step Amount to increase or decrease the value by when changed with arrows.
#' @param type Name of the input's type -- other number-based types like \code{date} might make sense.
#' @param class Class names to add to the input's list.
#' @param note Text to display as a tooltip for the input.
#' @param dataview ID of a \code{\link{input_dataview}}, to use as a source of variables.
#' @param floating_label Logical; if \code{FALSE}, labels are separate from their input elements.
#' @param buttons Logical; if \code{TRUE}, adds increment and decrement buttons to the sides of the input.
#' @param show_range Logical; if \code{TRUE}, adds min and max indicators around the input field.
#' @examples
#' \dontrun{
#' input_text("entered_text", "Enter Text:")
#' }
#' @return A character vector of the contents to be added.
#' @export

input_number <- function(label, id = label, ..., default = NULL, variable = NULL, min = NULL, max = NULL, step = NULL,
                         type = "number", class = NULL, note = NULL, dataview = NULL, floating_label = TRUE,
                         buttons = FALSE, show_range = FALSE) {
  id <- gsub("\\s", "", id)
  r <- c(
    if (buttons || show_range) '<div class="wrapper number-input-row">',
    if (show_range) {
      paste0(
        '<div><button role="button" label="set value to min" class="text-muted indicator-min"><span>', min, "</span></button></div>"
      )
    },
    if (buttons) '<button role="button" label="decrease value" class="btn number-down">&lt;</button>',
    paste0('<div class="wrapper text-wrapper', if (floating_label) " form-floating", '">'),
    if (!floating_label) paste0('<label for="', id, '">', label, "</label>"),
    paste0(c(
      '<input type="', type, '"',
      ' id="', id, '"',
      if (!is.null(default)) paste0(' data-default="', default, '"'),
      if (!is.null(note)) paste0(' aria-description="', note, '"'),
      if (!is.null(variable)) paste0(' data-variable="', variable, '"'),
      if (!is.null(min)) paste0(' min="', min, '"'),
      if (!is.null(max)) paste0(' max="', max, '"'),
      if (!is.null(step)) paste0(' step="', step, '"'),
      if (!is.null(dataview)) paste0(' data-view="', dataview, '"'),
      unlist(list(...)),
      ' class="form-control auto-input', if (!is.null(class)) paste("", class), '" data-autoType="number">',
      if (floating_label) paste0('<label for="', id, '">', label, "</label>")
    ), collapse = ""),
    "</div>",
    if (buttons) '<button role="button" label="increase value" class="btn number-up">&gt;</button>',
    if (show_range) {
      paste0(
        '<div><button role="button" label="set value to max" class="text-muted indicator-max"><span>', max, "</span></button></div>"
      )
    },
    if (buttons || show_range) "</div>"
  )
  caller <- parent.frame()
  if (!is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts") {
    caller$content <- c(caller$content, r)
  }
  r
}

#' Add a unified data view to a website
#'
#' Collects specified inputs to create a filtered dataset from which outputs can pull.
#'
#' @param id An ID of the data view, for association with output elements. Defaults to \code{'view'} appended
#' with a zero-index of views, based on the order in which they were specified
#' (e.g., \code{'view0'} for the first view).
#' @param y Primary variable of interest, used by default to color elements in outputs, and shown on the y-axis
#' of plots; name of a variable or ID of a variable selector.
#' @param x Secondary variable, shown by default on the x-axis of plots, and across columns in a single-variable table;
#' name of a variable or ID of a variable selector.
#' @param time Name of a variable giving names to multiple time points (such as a vector of years). Defaults to
#' the time specified in an associated metadata, or a sequence along each variable.
#' @param time_agg Specifies how multiple time points should be treated when a single value is required.
#' Default is to use the last time with data. This could point to an input which selects a time.
#' @param time_filters A list with entries specifying which years to display. Each entry should be a list
#' with entries for \code{"variable"} (which variable is being filtered, which can be \code{"index"}),
#' \code{"type"} (specifying the operator, such as \code{">"}), and \code{"value"}. The value of each entry
#' can be static (e.g., referring to a variable) or the ID of an input.
#' @param dataset Select which dataset to pull from; the name of an included dataset, or ID of a
#' selector of dataset names.
#' @param ids Select which IDs to include; a vector of IDs that appear in the specified dataset, or the ID of a
#' selector of IDs. If an IDs map is included in the site's datapackage, mapped components can be referred to here.
#' @param features Select IDs based on their features; a named list or vector, with names corresponding to
#' the names of features included in an \code{ids} field of the site's datapackage, and values corresponding to
#' a value or vector of values, or a selector of values.
#' @param variables Select IDs based on the values of their variables; a list of lists with entries for
#' \code{"variable"} (name of the variable), \code{"type"} (comparison operator), and \code{"value"} (value to
#' check against). For example, \code{list(list(variable = "a", type = ">", value = 0))}. Each entry
#' may also refer to another input.
#' @param palette The name of the color palette used in maps and plots (from
#' \href{https://colorbrewer2.org}{colorbrewer}); one of \code{"rdylbu7"} (default), \code{"orrd7"}, \code{"gnbu7"},
#' \code{"brbg7"}, \code{"puor7"}, \code{"prgn6"}, \code{"reds5"}, \code{"greens5"}, \code{"greys4"}, \code{"paired4"}.
#' @examples
#' \dontrun{
#' input_dataview()
#' }
#' @return A list of the entered options.
#' @export

input_dataview <- function(id = NULL, y = NULL, x = NULL, time = NULL, time_agg = "last", time_filters = list(),
                           dataset = NULL, ids = NULL, features = NULL, variables = NULL, palette = "") {
  caller <- parent.frame()
  building <- !is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts"
  r <- list(palette = tolower(palette))
  if (!is.null(y)) r$y <- y
  if (!is.null(x)) r$x <- x
  if (!is.null(time)) r$time <- time
  if (!is.null(time_agg)) r$time_agg <- time_agg
  if (!length(time_filters)) r$time_filters <- time_filters
  if (!is.null(dataset)) r$dataset <- dataset
  if (!is.null(ids)) r$ids <- ids
  if (!is.null(features)) r$features <- as.list(features)
  if (!is.null(variables)) r$variables <- if (!is.list(variables[[1]])) list(variables) else variables
  if (length(r) && building) {
    caller$dataviews[[if (is.null(id)) paste0("view", length(caller$dataviews)) else id]] <- r
  }
  r
}

#' Create a Data Repository
#'
#' Create a repository for a dataset, which may include data documentation and/or a data site.
#'
#' @param dir Directory in which to create the repository's structure. Will be created if it does not exist.
#' @param datasets A character vector of dataset names; for each of these, a subdirectory will be made
#' containing \code{code} and \code{data} directories.
#' @param init_data Logical; if \code{FALSE}, will not run \code{\link{init_data}} on the repository.
#' @param init_site Logical; if \code{FALSE}, will not run \code{\link{init_site}} on the repository.
#' @param init_git Logical; if \code{FALSE}, will not run \code{git init} on the repository.
#' @param template A character indicating which site and build template to use, between
#' \code{sdad_dashboard} (default) and \code{repository_site}.
#' @param overwrite Logical; if \code{TRUE}, will overwrite existing site files in \code{dir}.
#' @param quiet Logical; if \code{TRUE}, suppresses messages.
#' @examples
#' \dontrun{
#' # initialize repository in the current working directory
#' init_repository(".")
#' }
#' @return Path to the created repository directory.
#' @export

init_repository <- function(dir, datasets = NULL, init_data = TRUE, init_site = TRUE, init_git = TRUE,
                            template = "sdad_dashboard", overwrite = FALSE, quiet = !interactive()) {
  if (missing(dir)) cli_abort('{.arg dir} must be speficied (e.g., dir = ".")')
  check <- check_template("repository", dir = dir)
  datasets_inited <- file.exists(paste0(dir, "/", datasets, "/data"))
  dir <- normalizePath(paste0(dir, "/", check$spec$dir), "/", FALSE)
  dir.create(dir, FALSE, TRUE)
  dir.create(paste0(dir, "/docs"), FALSE)
  paths <- paste0(dir, "/", c("README.md", ".gitignore", "build.R", "site.R"))
  if (!file.exists(paths[1])) {
    writeLines(c(
      "<template: Describe the repository>",
      "\n# Structure",
      "This is a community data repository, created with the `community::init_repository()` function.",
      "1. `{set}/code/distribution/ingest.R` should download and prepare data from a public source, and output files to `{set}/data/distribution`.",
      "2. `{set}/data/distribution/measure_info.json` should contain metadata for each of the measures in the distribution data file(s).",
      if (init_site) {
        paste(
          "3. `build.R` will convert the distribution data to site-ready versions,",
          "and `site.R` specifies the interface of the repository-specific data site."
        )
      }
    ), paths[1])
  }
  if (!file.exists(paths[2])) {
    writeLines(c(
      ".Rproj.user",
      ".Rhistory",
      ".RData",
      ".httr-oauth",
      ".DS_Store",
      ".netlify",
      "*.Rproj",
      "node_modules",
      "package-lock.json",
      "dist",
      "original"
    ), paths[2])
  }
  if (init_site) {
    td <- paste0(path.package("community"), c("/inst", ""), "/templates/", template, "/")
    td <- td[which(file.exists(td))[1]]
    if (is.na(td)) td <- paste0(path.package("community"), "/templates/sdad_dashboard")
    if (overwrite) unlink(paste0(dir, c("/build.R", "/site.R")))
    if (!file.exists(paste0(dir, "/build.R"))) {
      file.copy(paste0(td, "/build.R"), paste0(dir, "/build.R"))
    }
    if (!file.exists(paste0(dir, "/site.R"))) {
      file.copy(paste0(td, "/site.R"), paste0(dir, "/site.R"))
    }
    init_site(dir, with_data = init_data, quiet = TRUE)
  } else if (init_data) {
    init_data("data", quiet = TRUE)
  }
  if (is.character(datasets) && any(!datasets_inited)) {
    for (i in seq_along(datasets)) {
      dataset <- datasets[i]
      dirs <- paste0(dir, "/", dataset, c("/code/distribution", "/data"))
      if (!any(file.exists(dirs))) {
        dir.create(dirs[[1]], FALSE, TRUE)
        ingest_file <- paste0(dirs[[1]], "/ingest.R")
        if (!file.exists(ingest_file)) {
          writeLines(
            "# <template: use this file to set up the creation and/or preparation of the data>",
            ingest_file
          )
        }
        dir.create(paste0(dirs[[2]], "/original"), FALSE, TRUE)
        dir.create(paste0(dirs[[2]], "/working"), FALSE)
        dir.create(paste0(dirs[[2]], "/distribution"), FALSE)
        info_file <- paste0(dirs[[2]], "/distribution/measure_info.json")
        if (!file.exists(info_file)) writeLines("{}", info_file)
      }
    }
  }
  if (init_git && !file.exists(paste0(dir, "/.git")) && Sys.which("git") != "") {
    wd <- getwd()
    on.exit(setwd(wd))
    setwd(dir)
    system2("git", "init")
  }
  invisible(dir)
}

#' Add static text elements to a website.
#'
#' Adds regular text elements to a website.
#'
#' @param text A character vector of text to add. Each entry will be a separate element. Text can include
#' links to be embedded, in the form \code{"[text](url)"}.
#' @param ... Attributes to add to each element.
#' @param tag The tag name of each element.
#' @examples
#' \dontrun{
#' # regular text
#' page_text("text to be added")
#' }
#' @return A character vector of the content to be added.
#' @export

page_text <- function(text, ..., tag = "p") {
  n <- length(text)
  tag <- rep_len(tag, n)
  atr <- lapply(list(...), function(a) rep_len(as.character(a), n))
  r <- unlist(lapply(seq_len(n), function(i) {
    txt <- text[i]
    m <- regmatches(txt, gregexpr("\\[.*?\\]\\(.*?\\)", txt))[[1]]
    for (l in m) {
      parts <- strsplit(substr(l, 2, nchar(l) - 1), "](", fixed = TRUE)[[1]]
      txt <- sub(
        l,
        paste0('<a target="_blank" rel="noreferrer" href="', parts[2], '">', parts[1], "</a>"),
        txt,
        fixed = TRUE
      )
    }
    paste0(
      "<", tag[i],
      if (length(atr)) paste("", paste(paste0(names(atr), '="', vapply(atr, "[[", "", i), '"'), collapse = " ")) else "",
      ">", txt, "</", tag[i], ">"
    )
  }), use.names = FALSE)
  caller <- parent.frame()
  if (!is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts") {
    caller$content <- c(caller$content, r)
  }
  r
}

#' Attempt to locate variables in a set of mapped variables.
#'
#' Somewhat fuzzily match entered variable names to mapped variable names, which
#' might be useful if variable names are specified in a view, but are changed slightly
#' in their source repositories.
#'
#' @param missed A vector of variable names or keywords to search for in the full set of mapped variables,
#' or the name of or path to a data commons view, from which to extract missed variables.
#' @param map Path to the \code{variable_map.csv} file created by \code{\link{datacommons_map_files}},
#' the path to a data commons project, or a variable map \code{data.frame}.
#' @param sep A regular expression to be treated as a term separator.
#' @param top Number of possible matches to return per \code{missed} entry.
#' @param metric Name of the similarity metric to use; see \code{\link[lingmatch]{lma_simets}}.
#' @examples
#' \dontrun{
#' # from a data commons project directory
#' datacommons_find_variables(c("variable_a", "variable_b"))
#'
#' # try to find matches to any missed variables in a view
#' datacommons_find_variables("view_name")
#' }
#' @return A list with an entry for each entered variable, containing \code{top} possible matches,
#' which are entries from the variable map, with an added .
#' @export

datacommons_find_variables <- function(missed, map = ".", sep = "[_:]", top = 3, metric = "cosine") {
  if (missing(missed)) cli_abort("{.arg missed} must be provided")
  nm <- length(missed)
  variable_map <- NULL
  if (is.character(map)) {
    if (file.exists(map)) {
      variable_map <- if (dir.exists(map)) {
        if (nm == 1 && file.exists(paste0(map, "/views/", missed))) {
          missed <- paste0(map, "/views/", missed)
        }
        datacommons_map_files(map, verbose = FALSE)$variables
      } else {
        read.csv(map)
      }
    } else {
      cli_abort("{.arg map} appears to be a path, but it does not exist")
    }
  } else {
    variable_map <- map
  }
  if (is.null(variable_map$full_name)) {
    cli_abort(
      "{.arg map} does not appear to be or point to a valid variable map"
    )
  }
  full_names <- unique(variable_map$full_name)
  if (nm == 1 && file.exists(missed)) {
    missed <- jsonlite::read_json(if (dir.exists(missed)) paste0(missed, "/view.json") else missed)
    missed <- as.character(missed$variables)
    if (!length(missed)) cli_abort("did not find any variables in the {.arg missed} view definition")
    missed <- missed[!missed %in% full_names]
    if (!length(missed)) cli_abort("all variables in the {.arg missed} view definition were found")
    nm <- length(missed)
  }
  mi <- seq_len(nm)
  snames <- gsub(sep, " ", c(missed, full_names))
  dtm <- lma_dtm(snames, numbers = TRUE, punct = TRUE, to.lower = FALSE)
  sim <- lma_simets(dtm[mi, ], dtm[-mi, ], metric, pairwise = FALSE)
  if (is.null(dim(sim))) sim <- matrix(sim, nm)
  top <- seq_len(min(top, length(full_names)))
  res <- lapply(mi, function(i) {
    v <- missed[[i]]
    if (v %in% full_names) {
      cbind(variable_map[variable_map$full_name == v, ], similarity = 1)
    } else {
      do.call(rbind, lapply(order(sim[i, ], decreasing = TRUE)[top], function(o) {
        vr <- variable_map[variable_map$full_name == full_names[[o]], , drop = FALSE]
        vr$similarity <- sim[i, o]
        vr
      }))
    }
  })
  names(res) <- missed
  res
}

#' Add dynamic text to a website
#'
#' Adds a textual output based on the current state of input elements.
#'
#' @param text A vector of text to be parsed; see details.
#' @param tag Tag name of the element containing the text.
#' @param id Unique ID of the output element.
#' @param class Class names to add to the output's element.
#' @param condition A conditional statement to decide visibility of the entire output element.
#' @details
#' \describe{
#'   \item{Input References}{\code{text} can include references to inputs by ID within curly brackets
#'     (e.g., \code{"{input_id}").}}
#'   \item{Conditions}{Multiple entries in \code{text} translate to separate elements. Each entry can be
#'     conditioned on a statement within curly brackets following an initial question mark
#'     (e.g., \code{"?{input_a != 1}Input A is not 1"}). If no statement is included after the question mark,
#'     the entry will be conditioned on a referred to input (\code{TRUE} if anything is selected).}
#'   \item{Buttons}{Embedded reset buttons can be specified within square brackets (e.g., \code{"Reset[r input_id]"}).
#'     Text before the brackets will be the button's display text, with multiple words included within parentheses
#'     (e.g., \code{"(Reset Input A)[r input_a]"}). If the text is a reference, this will be the default reset
#'     reference (e.g., \code{"{input_a}[r]"} is the same as \code{"{input_a}[r input_a]"}).}
#' }
#' @examples
#' # text that shows the current value of `input_a`, and resets it on click
#' output_text("Selection: {input_a}[r]")
#'
#' # adds a parenthetical if the value of the input is 0
#' output_text(c("Selection: {input_a}[r]", "?{input_a == 0}(input is zero)"))
#' @return A character vector of the containing element of the text.
#' @export

output_text <- function(text, tag = "p", id = NULL, class = NULL, condition = NULL) {
  caller <- parent.frame()
  building <- !is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts"
  if (is.null(id)) id <- paste0("text", caller$uid)
  parsed <- list()
  if (!is.null(names(text))) text <- list(text)
  parse_text <- function(e) {
    res <- list()

    # extracting expressions
    ex <- gsub("^\\{|\\}$", "", regmatches(e, gregexpr("\\{.*?\\}", e))[[1]])

    # extracting conditional expressions
    if (grepl("^\\?", e)) {
      if (grepl("^\\?\\{", e)) {
        res$condition <- parse_rule(ex[1])
        ex <- ex[-1]
        e <- sub("^\\?\\{.*?\\}", "", e)
      } else {
        res$condition <- parse_rule(paste(ex, collapse = " & "))
        e <- gsub("?", "", e, fixed = TRUE)
      }
    }

    # extracting buttons
    if (grepl("[", e, fixed = TRUE)) {
      m <- gregexpr("(?:\\([^)[]*?\\)|\\{[^}[]*?\\}|\\b\\w+?)?\\[.*?\\]", e)
      rb <- regmatches(e, m)[[1]]
      if (length(rb)) {
        res$button <- list()
        for (b in seq_along(rb)) {
          rbb <- rb[b]
          bid <- paste0("b", b)
          res$button[[bid]] <- list(
            text = as.list(sub(
              "}", "", strsplit(gsub("^\\(|\\)?\\[.*$", "", rbb), "{", fixed = TRUE)[[1]],
              fixed = TRUE
            )),
            type = if (grepl("[r", rbb, fixed = TRUE)) "reset" else if (grepl("[n", rbb, fixed = TRUE)) "note" else "update",
            target = strsplit(gsub("^[^[]*\\[[^\\s]+\\s?|\\]$", "", rbb, perl = TRUE), ",")[[1]]
          )
          if (!length(res$button[[bid]]$target)) {
            res$button[[bid]]$target <- strsplit(if (grepl("{", rbb, fixed = TRUE)) {
              gsub("^[^{].*\\{|\\}.*$", "", rbb)
            } else {
              sub("\\[.*$", "", rbb)
            }, ",")[[1]]
          }
        }
        regmatches(e, m) <- as.list(paste0("_SPLT_", paste0("b", seq_along(rb)), "_SPLT_"))
      }
    }

    res$text <- Filter(nchar, strsplit(e, "[{}]|_SPLT_")[[1]])
    res
  }
  for (i in seq_along(text)) {
    e <- text[[i]]
    if (is.null(names(e))) {
      parsed[[i]] <- parse_text(e)
    } else {
      parsed[[i]] <- lapply(seq_along(e), function(i) {
        r <- parse_text(e[[i]])
        r$condition <- parse_rule(names(e)[i])
        r
      })
    }
  }
  r <- paste0(c(
    "<", tag, ' data-autoType="text" id="', id, '"',
    ' class="auto-output output-text', if (!is.null(class)) paste("", class), '"',
    "></", tag, ">"
  ), collapse = "")
  if (building) {
    caller$text[[id]] <- c(list(text = parsed), if (!is.null(condition)) condition <- parse_rule(condition))
    caller$content <- c(caller$content, r)
    caller$uid <- caller$uid + 1
  }
  r
}

#' Map Data Commons Files
#'
#' Extract variables and IDs from files in datacommons repositories
#'
#' @param dir Directory of the data commons projects.
#' @param search_pattern A regular expression string used be passed to \code{\link{list.files}}.
#' @param variable_location The name of a column contain variable names in each dataset, or a function to retrieve
#' variable names (e.g., \code{colnames}).
#' @param id_location The name of a column contain IDs in each dataset, or a function to retrieve
#' IDs (e.g., \code{rownames}).
#' @param reader A function capable of handling a connection in its first argument, which returns a matrix-like object.
#' @param overwrite Logical; if \code{TRUE}, creates a new map even if one exists.
#' @param verbose Logical; if \code{FALSE}, does not print status messages.
#' @examples
#' \dontrun{
#' # from a data commons project directory
#' map <- datacommons_map_files(".")
#' }
#' @return An invisible \code{list}, including a \code{data.frame} of the mapped variables, with \code{variable} (variable name),
#' \code{repo} (the repository containing the file), \code{dir_name} (variable name with a prefix from the parent directories),
#' \code{full_name} (variable name with a prefix from the last part of the file's name, after a year or year range),
#' and \code{file} (path to the file) columns, and a \code{list} of the mapped IDs, with an entry for each ID,
#' each of which with entries for \code{repos} (repositories in which the ID appears) and \code{files} (files in which the ID appears).
#' @export

datacommons_map_files <- function(dir, search_pattern = "\\.csv(?:\\.[gbx]z2?)?$", variable_location = "measure",
                                  id_location = "geoid", reader = read.csv, overwrite = FALSE, verbose = TRUE) {
  if (missing(dir)) cli_abort("{.arg dir} must be specified")
  dir <- paste0(normalizePath(dir, "/", FALSE), "/")
  check <- check_template("datacommons", dir = dir)
  if (!check$exists) {
    cli_abort(c(
      x = "{.arg dir} does not appear to point to a data commons project",
      i = paste0('initialize it with {.code init_datacommons("', dir, '")}')
    ))
  }
  if (!dir.exists(paste0(dir, "repos"))) {
    cli_abort(c(
      x = "no {.path repos} directory found in {.arg dir}",
      i = paste0('use {.code datacommons_refresh("', dir, '")} to bring in remote data')
    ))
  }
  commons <- jsonlite::read_json(paste0(dir, "commons.json"))
  all_files <- list.files(paste0(dir, c("cache", "repos")), search_pattern, full.names = TRUE, recursive = TRUE)
  all_files <- sort(all_files[!grepl("[/\\](?:code|docs|working|original)[/\\]|variable_map", all_files)])
  if (!length(all_files)) cli_abort("no files were found")
  res <- paste0(dir, "cache/", c("variable_map.csv", "id_map.rds"))
  if (overwrite) unlink(res)
  if (all(file.exists(res)) && all(file.mtime(res) > max(file.mtime(all_files)))) {
    if (verbose) cli_alert_success("the maps are up to date")
    return(invisible(list(variables = read.csv(res[1]), ids = readRDS(res[2]))))
  }
  i <- 1
  map <- idmap <- list()
  noread <- novars <- noids <- empty <- NULL
  repos <- sort(unlist(commons$repositories))
  manifest <- measure_info <- list()
  if (verbose) {
    cli_progress_step(
      "scanning files in repos: {i}/{length(repos)}",
      msg_done = "created file maps: {.file {res}}", spinner = TRUE
    )
  }
  for (i in seq_along(repos)) {
    r <- repos[[i]]
    manifest[[r]] <- list()
    files <- sort(list.files(
      paste0(dir, c("repos", "cache"), "/", sub("^[^/]+/", "", r)), search_pattern,
      full.names = TRUE, recursive = TRUE, ignore.case = TRUE
    ))
    measure_info_files <- sort(list.files(
      paste0(dir, "repos/", sub("^.+/", "", r)), "^measure_info[^.]*\\.json$",
      full.names = TRUE, recursive = TRUE
    ))
    measure_info_files <- measure_info_files[
      !duplicated(gsub("_rendered|/code/|/data/", "", measure_info_files))
    ]
    if (length(measure_info_files)) {
      measure_info <- c(measure_info, lapply(
        structure(measure_info_files, names = sub(
          paste0(dir, "repos/"), paste0(sub("/.*$", "", r), "/"), measure_info_files,
          fixed = TRUE
        )),
        function(f) {
          tryCatch(data_measure_info(
            f,
            render = TRUE, write = FALSE, verbose = FALSE, open_after = FALSE, include_empty = FALSE
          ), error = function(e) {
            cli_alert_warning("failed to read measure info: {.file {f}}")
            NULL
          })
        }
      ))
    }
    files <- files[files %in% all_files]
    for (f in files) {
      d <- attempt_read(f, id_location)
      if (!is.null(d)) {
        if (nrow(d)) {
          lcols <- tolower(colnames(d))
          vars <- c(id_location, variable_location)
          if (any(!vars %in% colnames(d))) {
            l <- !colnames(d) %in% vars & lcols %in% vars
            colnames(d)[l] <- lcols[l]
          }
          if (is.character(variable_location) && !variable_location %in% colnames(d)) {
            novars <- c(novars, f)
            next
          }
          if (is.character(id_location) && !id_location %in% colnames(d)) {
            noids <- c(noids, f)
            next
          }
          hash <- md5sum(f)[[1]]
          relf <- sub(paste0(dir, "repos/", sub("^.+/", "", r), "/"), "", f, fixed = TRUE)
          manifest[[r]][[hash]]$name <- relf
          manifest[[r]][[hash]]$providers <- c(manifest[[r]][[hash]]$provider, if (grepl("repos/", f, fixed = TRUE)) "github" else "dataverse")
          vars <- if (is.function(variable_location)) variable_location(d) else d[[variable_location]]
          if (length(vars)) {
            vars <- unique(vars[!is.na(vars)])
            map[[f]] <- data.frame(
              variable = vars,
              dir_name = paste0(gsub(paste0(dir, "|cache/|repos/|data/|distribution/"), "", paste0(dirname(f), "/")), vars),
              full_name = make_full_name(f, vars),
              repo = r,
              file = sub(dir, "", f, fixed = TRUE)
            )
            manifest[[r]][[hash]]$variables <- vars
          } else {
            novars <- c(novars, f)
          }
          ids <- if (is.function(id_location)) id_location(d) else d[[id_location]]
          if (length(ids)) {
            ids <- gsub("^\\s+|\\s+$", "", format(unique(ids), scientific = FALSE))
            idmap[[f]] <- data.frame(id = ids, repo = r, file = relf)
            manifest[[r]][[hash]]$ids <- ids
          } else {
            noids <- c(noids, f)
          }
        } else {
          empty <- c(empty, f)
        }
      } else {
        noread <- c(noread, f)
      }
    }
    if (verbose) cli_progress_update()
  }
  if (verbose) cli_progress_done()
  if (length(measure_info)) {
    jsonlite::write_json(measure_info, paste0(dir, "cache/measure_info.json"), auto_unbox = TRUE)
  }
  map <- do.call(rbind, unname(map))
  idmap <- do.call(rbind, unname(idmap))
  if (verbose) {
    if (length(noread)) cli_warn("file{?s} could not be read in: {noread}")
    if (length(empty)) cli_warn("{?files have/file had} no rows: {empty}")
    if (length(novars)) cli_warn("{.arg {variable_location}} was not in {?some files'/a file's} column names: {novars}")
    if (length(noids)) cli_warn("{.arg {id_location}} was not in {?some files'/a file's} column names: {noids}")
  }
  if (!length(idmap)) cli_abort("no IDs were mapped")
  dir.create(paste0(dir, "manifest"), FALSE)
  jsonlite::write_json(manifest, paste0(dir, "manifest/files.json"), auto_unbox = TRUE, pretty = TRUE)
  dir.create(paste0(dir, "cache"), FALSE)
  idmap <- lapply(split(idmap, idmap$id), function(d) list(repos = unique(d$repo), files = unique(d$file)))
  saveRDS(idmap, res[2], compress = "xz")
  write.csv(map, res[1], row.names = FALSE)
  init_datacommons(dir, refresh_after = FALSE, verbose = FALSE)
  invisible(list(variables = map, ids = idmap))
}

#' Add a combobox select input to a website
#'
#' Adds an input to select from the entered options,
#' allowing for multiple selection, dynamic filtering, and custom entries.
#'
#' @param label Label of the input for the user.
#' @param options A vector of options, the name of a variable from which to pull levels, or \code{"datasets"},
#' \code{"variables"}, \code{"ids"}, or \code{"palettes"} to select names of datasets, variables, entity ids, or
#' color palettes. If there is a map with overlay layers with properties, can also be \code{"overlay_properties"},
#' to select between properties.
#' @param default Which of the options to default to; either its index or value.
#' @param display A display version of the options.
#' @param id Unique ID of the element to be created.
#' @param ... Additional attributes to set on the input element.
#' @param strict Logical; if \code{FALSE}, allows arbitrary user input, rather than limiting input to the
#' option set.
#' @param numeric Logical; if \code{TRUE}, will treat all numeric inputs as custom values,
#' rather than as potential option indices.
#' @param search Logical; if \code{FALSE}, does not dynamically filter the option set on user input.
#' @param multi Logical; if \code{TRUE}, allows multiple options to be selected.
#' @param accordion Logical; if \code{TRUE}, option groups will be collapsible.
#' @param clearable Logical; if \code{TRUE}, adds a button to clear the selection.
#' @param note Text to display as a tooltip for the input.
#' @param group_feature Name of a measure or entity feature to use as a source of option grouping,
#' if \code{options} is \code{"variables"} or \code{"ids"}.
#' @param variable The name of a variable from which to get levels (overwritten by \code{depends}).
#' @param dataset The name of an included dataset, where \code{variable} should be looked for; only applies when
#' there are multiple datasets with the same variable name.
#' @param depends The ID of another input on which the options depend; this will take president over \code{dataset}
#' and \code{variable}, depending on this type of input \code{depends} points to.
#' @param dataview The ID of an \code{\link{input_dataview}}, used to filter the set of options, and potentially
#' specify dataset if none is specified here.
#' @param subset Determines the subset of options shown if \code{options} is \code{"ids"}; mainly \code{"filtered"}
#' (default) to apply all filters, including the current selection, or \code{"full_filter"} to apply all
#' feature and variable filters, but not the current selection. \code{"siblings"} is a special case given a selection,
#' which will show other IDs with the same parent.
#' @param selection_subset Subset to use when a selection is made; defaults to \code{"full_filter"}.
#' @param filters A list with names of \code{meta} entries (from \code{variable} entry in \code{\link{data_add}}'s
#' \code{meta} list), and values of target values for those entries, or the IDs of value selectors.
#' @param reset_button If specified, adds a button after the input element that will revert the selection
#' to its default; either \code{TRUE}, or text for the reset button's label.
#' @param button_class Class name to add to the reset button.
#' @param as.row Logical; if \code{TRUE}, the label and input are in separate columns within a row.
#' @param floating_label Logical; if \code{FALSE} or \code{as.row} is \code{TRUE}, labels are separate from
#' their inputs.
#' @seealso See \code{\link{input_select}} for a more standard select input, or \code{\link{input_text}}
#' for a free-form input.
#' @examples
#' \dontrun{
#' input_combobox("Options", c("a", "b"))
#' }
#' @return A character vector of the contents to be added.
#' @export

input_combobox <- function(label, options, default = -1, display = options, id = label, ...,
                           strict = TRUE, numeric = FALSE, search = TRUE, multi = FALSE, accordion = FALSE,
                           clearable = FALSE, note = NULL, group_feature = NULL, variable = NULL, dataset = NULL,
                           depends = NULL, dataview = NULL, subset = "filtered", selection_subset = "full_filter",
                           filters = NULL, reset_button = FALSE, button_class = NULL, as.row = FALSE,
                           floating_label = TRUE) {
  id <- gsub("\\s", "", id)
  a <- list(...)
  if (as.row) floating_label <- FALSE
  r <- c(
    '<div class="wrapper combobox-wrapper">',
    if (!floating_label) paste0('<label id="', id, '-label" for="', id, '-input">', label, "</label>"),
    paste0('<div class="', paste(c(
      if (reset_button) "input-group", if (floating_label) "form-floating"
    ), collapse = " "), '">'),
    paste0(
      '<div class="auto-input form-select combobox combobox-component" data-autoType="combobox"',
      ' id="', id, '" ',
      if (is.character(options) && length(options) == 1) paste0('data-optionSource="', options, '"'),
      if (!is.null(default)) paste0(' data-default="', default, '"'),
      if (!is.null(note)) paste0(' aria-description="', note, '"'),
      if (!is.null(dataview)) paste0(' data-view="', dataview, '"'),
      if (!is.null(subset)) paste0(' data-subset="', subset, '"'),
      if (!is.null(selection_subset)) paste0(' data-selectionsubset="', selection_subset, '"'),
      if (!is.null(depends)) paste0(' data-depends="', depends, '"'),
      if (!is.null(dataset)) paste0(' data-dataset="', dataset, '"'),
      if (!is.null(variable)) paste0(' data-variable="', variable, '"'),
      if (length(a)) unlist(lapply(seq_along(a), function(i) paste0(" ", names(a)[i], '="', a[[i]], '"'))),
      '><div class="combobox-selection combobox-component">',
      '<span aria-live="assertive" aria-atomic="true" role="log" class="combobox-component"></span>',
      '<input class="combobox-input combobox-component" role="combobox" type="text" ',
      'aria-expanded="false" aria-autocomplete="list" aria-controls="', id,
      '-listbox" aria-controls="', id, '-listbox" id="', id, '-input" autocomplete="off"></div>',
      if (clearable) '<button type="button" class="btn-close" title="clear selection"></button>',
      "</div>"
    ),
    paste0(
      '<div class="combobox-options combobox-component', if (multi) " multi", '" role="listbox"',
      ' id="', id, '-listbox" aria-labelledby="', id, '-label">'
    ),
    if (is.list(options)) {
      i <- 0
      if (is.null(names(options))) names(options) <- seq_along(options)
      if (missing(accordion)) accordion <- TRUE
      unlist(lapply(names(options), function(g) {
        group <- paste0(
          '<div class="combobox-group combobox-component',
          if (accordion) " accordion-item",
          '" data-group="', g, '">'
        )
        if (accordion) {
          gid <- paste0(id, "_", gsub("[\\s,/._-]+", "", g))
          group <- c(
            group,
            paste0('<div id="', gid, '-label" class="accordion-header combobox-component">'),
            paste0(
              '<button role="button" ',
              'data-bs-toggle="collapse" data-bs-target="#', gid,
              '" aria-expanded=false aria-controls="', gid,
              '" class="accordion-button combobox-component collapsed">',
              g, "</button></div>"
            ),
            paste0(
              '<div id="', gid, '" class="combobox-component accordion-collapse collapse" ',
              'data-group="', g, '" data-bs-parent="#', id,
              '-listbox"><div class="accordion-body combobox-component">'
            )
          )
        }
        for (gi in seq_along(options[[g]])) {
          i <<- i + 1
          group <- c(group, paste0(
            '<div class="combobox-option combobox-component', if (i == default) " selected", '" role="option" tabindex="0"',
            ' data-group="', g, '" id="', id, "-option", i, '" data-value="', options[[g]][[gi]], '" aria-selected="',
            if (i == default) "true" else "false", '">', display[[g]][[gi]], "</div>"
          ))
        }
        c(group, "</div>", if (accordion) "</div></div>")
      }), use.names = FALSE)
    } else if (length(options) > 1 || !options %in% c("datasets", "variables", "ids", "palettes")) {
      unlist(lapply(seq_along(options), function(i) {
        paste0(
          '<div class="combobox-component', if (i == default) " selected", '" role="option" tabindex="0"',
          ' id="', id, "-option", i, '" data-value="', options[i], '" aria-selected="',
          if (i == default) "true" else "false", '">', display[i], "</div>"
        )
      }), use.names = FALSE)
    },
    "</div>",
    if (floating_label) paste0('<label id="', id, '-label" for="', id, '-input">', label, "</label>"),
    if (!missing(reset_button)) {
      paste(c(
        '<button type="button" class="btn btn-link', if (!is.null(button_class)) paste("", button_class), ' select-reset">',
        if (is.character(reset_button)) reset_button else "Reset",
        "</button>"
      ), collapse = "")
    },
    "</div>",
    "</div>"
  )
  if (missing(accordion) && !is.null(group_feature)) accordion <- TRUE
  if (as.row) r <- to_input_row(r)
  caller <- parent.frame()
  if (!is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts") {
    if (strict) caller$combobox[[id]]$strict <- strict
    if (numeric) caller$combobox[[id]]$numeric <- numeric
    if (search) caller$combobox[[id]]$search <- search
    if (multi) caller$combobox[[id]]$multi <- multi
    if (accordion) caller$combobox[[id]]$accordion <- accordion && (is.list(options) || !is.null(group_feature))
    if (!is.null(group_feature)) caller$combobox[[id]]$group <- group_feature
    if (!is.null(filters)) caller$combobox[[id]]$filters <- as.list(filters)
    caller$content <- c(caller$content, r)
  }
  r
}

#' Add a tooltip-like display to a website
#'
#' Adds an output to display information about a hovered-over or selected data point.
#'
#' @param title Title text, or the source of title text.
#' @param body A list of entries in the info body section, which can be raw text or references to features or
#' data variables.
#' @param row_style A character specifying how rows should be displayed: \code{"table"} (default)
#' to place names and values in separate columns of a table row, or \code{"stack"} to place names over values.
#' Repeats over rows.
#' @param default A list with entries for \code{"title"} and \code{"body"}, which are treated as raw text.
#' @param dataview The ID of a dataview, used for the persistent display.
#' @param variable Name of the variable from which to display variable information and values. If not specified,
#' this will default to the coloring variable of maps and plots, or the y variable of a dataview.
#' @param subto A vector of output IDs to receive hover events from.
#' @param id Unique id of the element.
#' @param variable_info Logical; if \code{TRUE} (default), variable names can be clicked for more information.
#' @param floating Logical; if \code{TRUE}, the information pane will appear next to the cursor.
#' @examples
#' \dontrun{
#' output_info("Initial View", "Hover over plot elements for more information.")
#' }
#' @return A character vector of the content to be added.
#' @export

output_info <- function(title = NULL, body = NULL, row_style = "table", default = NULL, dataview = NULL,
                        variable = NULL, subto = NULL, id = NULL, variable_info = TRUE, floating = FALSE) {
  caller <- parent.frame()
  building <- !is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts"
  if (is.null(id)) id <- paste0("info", caller$uid)
  r <- paste0(
    '<div class="auto-output text-display',
    if (floating) ' floating"' else '"',
    if (!is.null(dataview)) paste0(' data-view="', dataview, '"'),
    ' data-autoType="info" id="', id, '"></div>'
  )
  row_style <- rep_len(row_style, length(body))
  if (building) {
    caller$content <- c(caller$content, r)
    caller$info[[id]] <- Filter(function(e) length(e) > 1 || (length(e) && e != "" && !isFALSE(e)), list(
      title = if (is.null(title)) "" else title,
      body = lapply(seq_along(body), function(i) {
        list(name = if (is.null(names(body))) "" else names(body)[i], value = body[[i]], style = row_style[[i]])
      }),
      default = as.list(default),
      floating = floating
    ))
    if (!is.null(dataview)) caller$info[[id]]$dataview <- dataview
    if (!is.null(variable)) caller$info[[id]]$variable <- variable
    if (!is.null(subto)) caller$info[[id]]$subto <- subto
    if (variable_info) caller$info[[id]]$variable_info <- variable_info
    caller$uid <- caller$uid + 1
  }
  r
}

#' Add a button to a website
#'
#' Adds a button to reset an input or trigger a predefined function (including data export) to a website.
#'
#' @param label Text in the button for the user.
#' @param target The ID of an input element to reset, a vector with IDs of input elements as names and values to set
#' those inputs to as values, or the name of a function to trigger (e.g., \code{c(input_a = 1)}). Available function
#' are \code{refresh} (to force a reprocessing of the current input state), \code{reset_selection} (to reset all input
#' elements that are not settings), \code{reset_storage} (to clear local storage, reset all settings, and reload),
#' \code{export} (to download data), \code{copy} (to save an API link to the clipboard), and
#' \code{filter} (to open a data filter menu).
#' This can also be a URL (including protocol) for a button-like link.
#' @param id Unique ID of the element to be created.
#' @param dataview Name of a data view to get selection and filter options from for export.
#' @param query A list of query parameters, if \code{target} is \code{"export"} or \code{"copy"}. See the API section.
#' @param from_api Logical; if \code{TRUE}, \code{target} is \code{"export"}, and an endpoint has been provided
#' in \code{\link{site_build}}, links to the API rather than exporting from the browser.
#' @param class Additional class names to add to the element.
#' @param ... Additional attributes to set on the element.
#' @param note Text to display as a tooltip for the button.
#' @seealso For buttons to select between a set of options, use \code{\link{input_buttongroup}}.
#' @section API Query:
#' The \code{query} argument can be used to specify export options for a download button.
#' These options can also be included as query parameters in a site API's URL:
#' \describe{
#'   \item{Format}{
#'     These options affect the format of the returned file:
#'     \itemize{
#'       \item \strong{\code{file_format}}: Specifies the separator between columns:
#'       \code{'csv'} (default) for commas, or \code{'tsv'} for tabs.
#'       \item \strong{\code{table_format}}: Specifies the layout of the data:
#'       \code{'tall'} for a row for each value, with all values in the same column
#'       (repeats over entities, times, and variables);
#'       \code{'mixed'} (default) for a row for each time, with a column for each variable
#'       (repeats over entities);
#'       \code{'wide'} for a row for each entity, with a column for each variable at each time.
#'       \item \strong{\code{features}}: Specifies which features to include in the
#'       first columns of the file: A list with names for year column name, and value with the
#'       feature name to include in that column. Currently not available through the URL.
#'       \item \strong{\code{include}}: Specifies which variables to include:
#'       a vector or variable names, or (for the URL interface) a string with variable
#'       names separated by commas. By default, all variables are included.
#'       \item \strong{\code{exclude}}: Specifies which variables to exclude:
#'       a vector or variable names, or (for the URL interface) a string with variable
#'       names separated by commas.
#'     }
#'   }
#'   \item{Filters}{
#'     These options can be used to subset data:
#'     \itemize{
#'       \item \strong{\code{dataset}}: The name of a dataset, or vector (comma separated string)
#'       of dataset names. Includes all datasets by default.
#'       \item \strong{\code{variable[component]=value}}: Sets conditions
#'       on the summary of a variable. The summary of a variable is within each entity, which results in
#'       a set of summary components: \code{"first"}, \code{"min"}, \code{"mean"}, \code{"sum"},
#'       \code{"max"}, \code{"last"}. The \code{=} sign can be another operator:
#'       \code{"!="}, \code{">="}, \code{"<="}. values can be comma-separated sets of values.
#'       \item \strong{\code{feature=value}}: Sets conditions on a feature of each entity.
#'       \item \strong{\code{time_range}}: Selects a time or time range to include:
#'       \code{">="} or \code{"<="} with a single minimal or maximal time, or \code{"="}
#'       with a single time, or comma-separated set of two times.
#'     }
#'   }
#' }
#' @examples
#' \dontrun{
#' # a selection reset button
#' input_button("Reset")
#'
#' # a button to export all data, plus some added features
#' input_button("Download All Data", "export", query = list(
#'   features = list(ID = "id", Feature_A = "ft_a")
#' ))
#'
#' # a button to export a special subset
#' # from a URL:
#' #   https://example.com/api?dataset=set_a&include=variable_a,variable_b&
#' #   variable_a[min]>=10&feature_a=type_a,type_b
#' input_button("Download Subset", "export", query = list(
#'   dataset = "set_a", include = c("variable_a", "variable_b"),
#'   variable_a = list(component = "min", operator = ">", value = 10),
#'   feature_a = c("type_a", "type_b")
#' ))
#' }
#' @return A character vector of the contents to be added.
#' @export

input_button <- function(label, target = "reset_selection", id = label, dataview = NULL,
                         query = list(), from_api = FALSE, class = "", ..., note = NULL) {
  id <- gsub("\\s", "", id)
  a <- list(...)
  if (missing(target) && !(missing(dataview) || missing(query))) {
    target <- "export"
  }
  r <- c(
    '<div class="wrapper button-wrapper">',
    if (is.character(target) && length(target) == 1 && grepl("://", target, fixed = TRUE)) {
      paste0(
        '<a role="button" class="btn', if (class != "") paste("", class),
        '" id="', id, '" target="_blank" rel="noreferrer" href="', target, '"',
        if (length(a)) unlist(lapply(seq_along(a), function(i) paste0(" ", names(a)[i], '="', a[[i]], '"'))),
        if (!is.null(note)) paste0(' aria-description="', note, '"'),
        ">", label, "</a>"
      )
    } else {
      paste0(
        '<button type="button" data-autoType="button" class="auto-input btn', if (class != "") paste("", class),
        '" id="', id, '"', if (length(target) == 1 && !is.list(target) && is.null(names(target))) paste0(' data-target="', target, '"'),
        if (length(a)) unlist(lapply(seq_along(a), function(i) paste0(" ", names(a)[i], '="', a[[i]], '"'))),
        if (!is.null(note)) paste0(' aria-description="', note, '"'),
        ">", label, "</button>"
      )
    },
    "</div>"
  )
  caller <- parent.frame()
  if (!is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts") {
    if (length(target) == 1 && target %in% c("export", "copy")) {
      caller$button[[id]] <- Filter(function(e) length(e) > 1 || (length(e) && (!is.logical(e) || e)), list(
        effects = target,
        dataview = dataview,
        query = query,
        api = from_api
      ))
    } else if (!is.null(names(target))) caller$button[[id]] <- list(effects = target)
    caller$content <- c(caller$content, r)
  }
  r
}

#' Adds documentation of a dataset to a datapackage
#'
#' Add information about variables in a dataset to a \code{datapackage.json} metadata file.
#'
#' @param filename A character vector of paths to plain-text tabular data files, relative to \code{dir}.
#' @param meta Information about each data file. A list with a list entry for each entry in
#' \code{filename}; see details. If a single list is provided for multiple data files, it will apply to all.
#' @param packagename Package to add the metadata to; path to the \code{.json} file relative to
#' \code{dir}, or a list with the read-in version.
#' @param dir Directory in which to look for \code{filename}, and write \code{packagename}.
#' @param write Logical; if \code{FALSE}, returns the \code{paths} metadata without reading or rewriting
#' \code{packagename}.
#' @param refresh Logical; if \code{FALSE}, will retain any existing dataset information.
#' @param sha A number specifying the Secure Hash Algorithm function,
#' if \code{openssl} is available (checked with \code{Sys.which('openssl')}).
#' @param clean Logical; if \code{TRUE}, strips special characters before saving.
#' @param open_after Logical; if \code{TRUE}, opens the written datapackage after saving.
#' @details
#' \code{meta} should be a list with unnamed entries for entry in \code{filename},
#' and each entry can include a named entry for any of these:
#' \describe{
#'   \item{source}{
#'   A list or list of lists with entries for at least \code{name}, and ideally for \code{url}.
#'   }
#'   \item{ids}{
#'   A list or list of lists with entries for at least \code{variable} (the name of a variable in the dataset).
#'   Might also include \code{map} with a list or path to a JSON file resulting in a list with an
#'   entry for each ID, and additional information about that entity, to be read in a its features.
#'   All files will be loaded to help with aggregation, but local files will be included in the datapackage,
#'   whereas hosted files will be loaded client-side.
#'   }
#'   \item{time}{
#'   A string giving the name of a variable in the dataset representing a repeated observation of the same entity.
#'   }
#'   \item{variables}{
#'   A list with named entries providing more information about the variables in the dataset.
#'   See \code{\link{data_measure_info}}.
#'   }
#' }
#' @examples
#' \dontrun{
#' # write example data
#' write.csv(mtcars, "mtcars.csv")
#'
#' # add it to an existing datapackage.json file in the current working directory
#' data_add("mtcars.csv")
#' }
#' @return An invisible version of the updated datapackage, which is also written to
#' \code{datapackage.json} if \code{write = TRUE}.
#' @seealso Initialize the \code{datapackage.json} file with \code{\link{init_data}}.
#' @export

data_add <- function(filename, meta = list(), packagename = "datapackage.json", dir = ".", write = TRUE,
                     refresh = TRUE, sha = "512", clean = FALSE, open_after = FALSE) {
  if (missing(filename)) cli_abort("{.arg filename} must be specified")
  setnames <- names(filename)
  if (file.exists(filename[[1]])) {
    if (dir == ".") dir <- dirname(filename[[1]])
    filename <- basename(filename)
  }
  if (check_template("site", dir = dir)$status[["strict"]] &&
    all(file.exists(paste0(dir, "/docs/data/", filename)))) {
    dir <- paste0(dir, "/docs/data")
  }
  if (any(!file.exists(paste0(dir, "/", filename)))) {
    filename <- filename[!file.exists(filename)]
    cli_abort("{?a file/files} did not exist: {filename}")
  }
  package <- if (is.character(packagename) && file.exists(paste0(dir, "/", packagename))) {
    paste0(dir, "/", packagename)
  } else {
    packagename
  }
  if (write) {
    if (is.character(package)) {
      package <- paste0(dir, "/", packagename)
      package <- if (file.exists(package)) {
        packagename <- package
        jsonlite::read_json(package)
      } else {
        init_data(if (!is.null(setnames)) setnames[[1]] else filename[[1]], dir = dir)
      }
    }
    if (!is.list(package)) {
      cli_abort(c(
        "{.arg package} does not appear to be in the right format",
        i = "this should be (or be read in from JSON as) a list with a {.code resource} entry"
      ))
    }
  }
  if (!is.list(package)) package <- list()
  collect_metadata <- function(file) {
    f <- paste0(dir, "/", filename[[file]])
    m <- if (single_meta) meta else metas[[file]]
    format <- if (grepl(".csv", f, fixed = TRUE)) "csv" else if (grepl(".rds", f, fixed = TRUE)) "rds" else "tsv"
    if (is.na(format)) format <- "rds"
    info <- file.info(f)
    metas <- list()
    unpack_meta <- function(n) {
      if (!length(m[[n]])) list() else if (is.list(m[[n]][[1]])) m[[n]] else list(m[[n]])
    }
    ids <- unpack_meta("ids")
    idvars <- NULL
    for (i in seq_along(ids)) {
      if (is.list(ids[[i]])) {
        if (length(ids[[i]]$map) == 1 && is.character(ids[[i]]$map) && file.exists(ids[[i]]$map)) {
          ids[[i]]$map_content <- paste(readLines(ids[[i]]$map, warn = FALSE), collapse = "")
        }
      } else {
        ids[[i]] <- list(variable = ids[[i]])
      }
      if (!ids[[i]]$variable %in% idvars) idvars <- c(idvars, ids[[i]]$variable)
    }
    data <- if (format == "rds") {
      tryCatch(readRDS(f), error = function(e) NULL)
    } else {
      attempt_read(f, if (length(idvars)) idvars[1] else "")
    }
    if (is.null(data)) {
      cli_abort(c(
        paste0("failed to read in the data file ({.file {f}})"),
        i = "check that it is in a compatible format"
      ))
    }
    if (!all(rownames(data) == seq_len(nrow(data)))) data <- cbind(`_row` = rownames(data), data)
    timevar <- unlist(unpack_meta("time"))
    times <- if (is.null(timevar)) rep(1, nrow(data)) else data[[timevar]]
    times_unique <- unique(times)
    if (!single_meta) {
      varinf <- unpack_meta("variables")
      if (length(varinf) == 1 && is.character(varinf[[1]])) {
        if (!file.exists(varinf[[1]])) varinf[[1]] <- paste0(dir, "/", varinf[[1]])
        if (file.exists(varinf[[1]])) {
          if (varinf[[1]] %in% names(metas)) {
            varinf <- metas[[varinf[[1]]]]
          } else {
            varinf <- metas[[varinf[[1]]]] <- data_measure_info(varinf[[1]], write = FALSE, render = TRUE)
          }
          varinf <- varinf[varinf != ""]
        }
      }
      varinf_full <- names(varinf)
      varinf_suf <- sub("^[^:]+:", "", varinf_full)
    }
    res <- list(
      bytes = as.integer(info$size),
      encoding = stri_enc_detect(f)[[1]][1, 1],
      md5 = md5sum(f)[[1]],
      format = format,
      name = if (!is.null(setnames)) {
        setnames[file]
      } else if (!is.null(m$name)) {
        m$name
      } else {
        sub("\\.[^.]*$", "", basename(filename[[file]]))
      },
      filename = filename[[file]],
      source = unpack_meta("source"),
      ids = ids,
      id_length = if (length(idvars)) {
        id_lengths <- nchar(data[[idvars[1]]])
        if (all(id_lengths == id_lengths[1])) id_lengths[1] else 0
      } else {
        0
      },
      time = timevar,
      profile = "data-resource",
      created = as.character(info$mtime),
      last_modified = as.character(info$ctime),
      row_count = nrow(data),
      entity_count = if (length(idvars)) length(unique(data[[idvars[1]]])) else nrow(data),
      schema = list(
        fields = lapply(colnames(data)[!colnames(data) %in% idvars], function(cn) {
          v <- data[[cn]]
          invalid <- !is.finite(v)
          r <- list(name = cn, duplicates = sum(duplicated(v)))
          if (!single_meta) {
            if (cn %in% varinf_full) {
              r$info <- varinf[[cn]]
            } else if (cn %in% varinf_suf) {
              r$info <- varinf[[which(varinf_suf == cn)]]
            }
            r$info <- r$info[r$info != ""]
          }
          su <- !is.na(v)
          if (any(su)) {
            r$time_range <- which(times_unique %in% range(times[su])) - 1
            r$time_range <- if (length(r$time_range)) r$time_range[c(1, length(r$time_range))] else c(-1, -1)
          } else {
            r$time_range <- c(-1, -1)
          }
          if (!is.character(v) && all(invalid)) {
            r$type <- "unknown"
            r$missing <- length(v)
          } else if (is.numeric(v)) {
            r$type <- if (all(invalid | as.integer(v) == v)) "integer" else "float"
            r$missing <- sum(invalid)
            r$mean <- round(mean(v, na.rm = TRUE), 6)
            r$sd <- round(sd(v, na.rm = TRUE), 6)
            r$min <- round(min(v, na.rm = TRUE), 6)
            r$max <- round(max(v, na.rm = TRUE), 6)
          } else {
            r$type <- "string"
            if (!is.factor(v)) v <- as.factor(as.character(v))
            r$missing <- sum(is.na(v) | is.nan(v) | grepl("^[\\s.-]$", v))
            r$table <- structure(as.list(tabulate(v)), names = levels(v))
          }
          r
        })
      )
    )
    if (!single_meta && "_references" %in% names(varinf)) res[["_references"]] <- varinf[["_references"]]
    if (Sys.which("openssl") != "") {
      res[[paste0("sha", sha)]] <- calculate_sha(f, sha)
    }
    res
  }
  single_meta <- FALSE
  metas <- if (!is.null(names(meta))) {
    if (!is.null(setnames) && all(setnames %in% names(meta))) {
      meta[setnames]
    } else {
      single_meta <- TRUE
      if (length(meta$variables) == 1 && is.character(meta$variables)) {
        if (!file.exists(meta$variables)) meta$variables <- paste0(dir, "/", meta$variables)
        if (file.exists(meta$variables)) meta$variables <- jsonlite::read_json(meta$variables)
      }
      meta$variables <- replace_equations(meta$variables)
      meta
    }
  } else {
    meta[seq_along(filename)]
  }
  if (!single_meta) {
    metas <- lapply(metas, function(m) {
      m$variables <- replace_equations(m$variables)
      m
    })
  }
  metadata <- lapply(seq_along(filename), collect_metadata)
  if (single_meta) package$measure_info <- lapply(meta$variables, function(e) e[e != ""])
  package$resources <- c(metadata, if (!refresh) package$resources)
  names <- vapply(package$resources, "[[", "", "filename")
  if (anyDuplicated(names)) {
    package$resources <- package$resources[!duplicated(names)]
  }
  if (clean) {
    cf <- lma_dict("special", perl = TRUE, as.function = gsub)
    package <- jsonlite::fromJSON(cf(jsonlite::toJSON(package, auto_unbox = TRUE)))
  }
  if (write) {
    packagename <- if (is.character(packagename)) packagename else "datapackage.json"
    jsonlite::write_json(
      package, if (file.exists(packagename)) packagename else paste0(dir, "/", packagename),
      auto_unbox = TRUE, digits = 6
    )
    if (interactive()) {
      cli_bullets(c(v = paste(
        if (refresh) "updated resource in" else "added resource to", "datapackage.json:"
      ), "*" = paste0("{.path ", packagename, "}")))
      if (open_after) navigateToFile(packagename)
    }
  }
  invisible(package)
}

#' Create a datapackage.json template
#'
#' Initialize dataset documentation with a \code{datapackage.json} template, based on a
#' \href{https://specs.frictionlessdata.io/data-package}{Data Package} standard.
#'
#' @param name A unique name for the dataset; allowed characters are \code{[a-z._/-]}.
#' @param title A display name for the dataset; if not specified, will be a formatted version of \code{name}.
#' @param dir Directory in which to save the \code{datapackage.json} file.
#' @param ... passes arguments to \code{\link{data_add}}.
#' @param write Logical; if \code{FALSE}, the package object will not be written to a file.
#' @param overwrite Logical; if \code{TRUE} and \code{write} is \code{TRUE}, an existing
#' \code{datapackage.json} file will be overwritten.
#' @param quiet Logical; if \code{TRUE}, will not print messages or navigate to files.
#' @examples
#' \dontrun{
#' # make a template datapackage.json file in the current working directory
#' init_data("mtcars", "Motor Trend Car Road Tests")
#' }
#' @return An invisible list with the content written to the \code{datapackage.json} file.
#' @seealso Add basic information about a dataset with \code{\link{data_add}}.
#' @export

init_data <- function(name, title = name, dir = ".", ..., write = TRUE, overwrite = FALSE, quiet = !interactive()) {
  if (missing(name)) cli_abort("{.arg name} must be specified")
  package <- list(
    name = name,
    title = if (title == name) gsub("\\b(\\w)", "\\U\\1", gsub("[._/-]", " ", name), perl = TRUE) else title,
    licence = list(
      url = "http://opendatacommons.org/licenses/pddl",
      name = "Open Data Commons Public Domain",
      version = "1.0",
      id = "odc-pddl"
    ),
    resources = list()
  )
  package_path <- normalizePath(paste0(dir, "/datapackage.json"), "/", FALSE)
  if (write && !overwrite && file.exists(package_path)) {
    cli_abort(c("datapackage ({.path {package_path}}) already exists", i = "add {.code overwrite = TRUE} to overwrite it"))
  }
  if (length(list(...))) package$resources <- data_add(..., dir = dir, write = FALSE)
  if (write) {
    if (!dir.exists(dir)) dir.create(dir, recursive = TRUE)
    jsonlite::write_json(package, package_path, auto_unbox = TRUE, digits = 6, pretty = TRUE)
    if (!quiet) {
      cli_bullets(c(v = "created metadata template for {name}:", "*" = paste0("{.path ", package_path, "}")))
      navigateToFile(package_path)
    }
  }
  invisible(package)
}

#' Add a navbar (header) section to a website
#'
#' Adds a bar at the top of the page, potentially with a title and logo image.
#'
#' @param ... Content to add to the navbar. Can be lists specifying submenus and their items.
#' Each list can have entries for \code{"name"} (the navbar button text), \code{"title"} (the menu title),
#' \code{"foot"} (the menu footer), \code{"id"} (the ID of the menu element),
#' \code{"class"} (class of the menu element), \code{"placement"} (start, top, end, or bottom),
#' \code{"backdrop"} (logical, where \code{FALSE} disables the backdrop and makes the menu shift
#' main content), and \code{items} (a list of menu items).
#' @param title A title to appear in the header.
#' @param logo URL of an image to appear in the header.
#' @param breakpoint Bootstrap breakpoint code specifying the width at which the menu collapses;
#' default is \code{"md"}.
#' @param logo.height Character or number setting the height of the logo.
#' @param logo.width Character or number setting the width of the logo.
#' @examples
#' page_navbar(
#'   title = "Site Name",
#'   list(
#'     name = "menu",
#'     title = "Menu",
#'     items = list(input_select("menu select", c("a", "b")))
#'   )
#' )
#' @return A character vector of the content to be added.
#' @export

page_navbar <- function(..., title = "", logo = "", breakpoint = "md", logo.height = "24px", logo.width = "24px") {
  caller <- parent.frame()
  building <- !is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts"
  parts <- new.env()
  attr(parts, "name") <- "community_site_parts"
  submenus <- substitute(...())
  n <- length(submenus)
  parts$uid <- caller$uid
  r <- c(
    paste0('<nav class="navbar navbar-dark navbar-expand-', breakpoint, '">'),
    '<div class="container-fluid">',
    if (!missing(logo)) {
      paste0(
        '<span class="navbar-brand"><img alt="site logo" height=', logo.height, " width=", logo.width, ' src="', logo, '">'
      )
    },
    if (!missing(title)) paste0("<span>", title, "</span>"),
    if (!missing(logo)) "</span>"
  )
  menus <- NULL
  if (n) {
    r <- c(
      r,
      paste(
        '<button type="button" class="navbar-toggler" data-bs-toggle="collapse"',
        'data-bs-target="#navbar_menu"',
        'aria-controls="narbar_menu" aria-expanded="false" aria-label="toggle navbar menu">'
      ),
      '<span class="navbar-toggler-icon"></span>',
      "</button>",
      '<div class="collapse navbar-collapse" id="navbar_menu">',
      '<ul class="navbar-nav">'
    )
    for (i in seq_len(n)) {
      if (submenus[[i]][[1]] == "list") {
        if (is.null(names(submenus[[i]]))) submenus[[i]] <- list(items = submenus[[i]])
        id <- if (is.null(submenus[[i]]$id)) paste0("submenu", parts$uid, i) else submenus[[i]]$id
        if (is.null(submenus[[i]]$name)) submenus[[i]]$name <- if (!is.null(names(submenus))) names(submenus)[i] else "Menu"
        r <- c(r, paste0(
          '<li class="nav-item">',
          '<button class="btn btn-link" type="button" data-bs-toggle="offcanvas" data-bs-target="#',
          id, '" aria-controls="', id, '">', submenus[[i]]$name, "</button>",
          "</li>"
        ))
        has_foot <- !is.null(submenus[[i]]$foot)
        menus <- c(
          menus,
          paste(c(
            '<div tabindex="-1" id="', id, '" aria-labelledby="', id, '_label" class="offcanvas offcanvas-',
            if (is.null(submenus[[i]]$placement)) "end" else submenus[[i]]$placement,
            if (!is.null(submenus[[i]]$class)) paste("", submenus[[i]]$class),
            if (!is.null(submenus[[i]]$backdrop)) c('" data-bs-backdrop="', submenus[[i]]$backdrop),
            '">'
          ), collapse = ""),
          '<div class="offcanvas-header">',
          paste0(
            '<h5 class="offcanvas-title" id="', id, '_label">',
            submenus[[i]][if (is.null(submenus[[i]]$title)) "name" else "title"],
            "</h5>"
          ),
          '<button class="btn-close text-reset" type="button" data-bs-dismiss="offcanvas" title="Close"></button>',
          "</div>",
          paste0('<div class="offcanvas-body"', if (has_foot) ' style="bottom: 46px"', ">"),
          unlist(lapply(submenus[[i]]$items[-1], eval, parts), use.names = FALSE),
          "</div>",
          if (has_foot) {
            c(
              '<div class="offcanvas-footer">',
              unlist(lapply(submenus[[i]]$foot[-1], eval, parts), use.names = FALSE),
              "</div>"
            )
          },
          "</div>"
        )
      } else {
        r <- c(r, paste0('<li class="nav-item">', paste(eval(submenus[[i]]), collapse = ""), "</li>"))
      }
    }
  }
  r <- c(r, "</ul></div></div></nav>", menus)
  if (building) {
    caller$header <- r
    for (n in names(parts)) if (n != "content" && n != "uid") caller[[n]] <- c(caller[[n]], parts[[n]])
    caller$uid <- parts$uid + 1
  }
  r
}

#' Interact with a Data Commons View
#'
#' Add, edit, or refresh a view within a data commons project.
#'
#' @param commons Path to the data commons project.
#' @param name Name of the view (it's directory in the project's \code{"views"} directory).
#' Defaults to the first view.
#' @param output Path to a site project's main directory.
#' @param ... Passes arguments to \code{\link{data_reformat_sdad}} if the view is to be executed.
#' @param variables A vector of variables, to be added to the view's \code{view.json} file.
#' @param ids A vector of ids, to be added to the view's \code{view.json} file.
#' @param files A regular expression string used to filter files containing \code{variables}.
#' @param run_after Path to a script to be sourced after refreshing the view, or code to
#' be added to such a script (e.g., \code{"../data_site/build.R"}).
#' @param run_before Path to a script to be sourced before refreshing the view, or code to
#' be added to such a script.
#' @param measure_info A list of variable metadata to include in the \code{measure_info.json}
#' file created from such files in each data repository (such as general entries like
#' \code{"_references"}). These will supersede any entries of the same name found in data repositories.
#' @param remote Name of the view's GitHub repository (\code{"username/reponame"}).
#' @param url URL of the view's site; defaults to the GitHub Pages URL associated with \code{remote}
#' if provided (\code{"https://username.github.io/reponame"}).
#' @param children A list of child sites associated with the view. Each entry should contain at least a
#' \code{remote} entry (GitHub repository, including user name and repo name), and optionally \code{name}
#' and \code{url} (link to the served site), which will otherwise be derived from \code{remote}.
#' @param execute Logical; if \code{FALSE}, will create/update, but not run the view.
#' @param prefer_repo Logical; if \code{FALSE}, will prefer distribution files (such as from Dataverse)
#' over those in the repositories.
#' @param preselect_files Logical; if \code{TRUE}, will select files by ID coverage before processing them,
#' which can save time, but might miss data spread across multiple files.
#' @param refresh_map Logical; if \code{TRUE}, overwrites any existing map files.
#' @param overwrite Logical; if \code{TRUE}, reformatted files in \code{output}.
#' @param verbose Logical; if \code{FALSE}, will not show status messages.
#' @examples
#' \dontrun{
#' # create a view within a data commons project
#' datacommons_view(".", "view_name", variables = c("variable_a", "variable_b"))
#'
#' # refresh that view
#' datacommons_view(".", "view_name")
#' }
#' @return An invisible version of the view list (the view's \code{view.json} file).
#' @export

datacommons_view <- function(commons, name, output = NULL, ..., variables = NULL, ids = NULL,
                             files = NULL, run_after = NULL, run_before = NULL, measure_info = list(),
                             remote = NULL, url = NULL, children = list(), execute = TRUE, prefer_repo = TRUE,
                             preselect_files = FALSE, refresh_map = FALSE, overwrite = FALSE, verbose = TRUE) {
  if (missing(commons)) cli_abort('{.arg commons} must be speficied (e.g., commons = ".")')
  if (missing(name)) {
    name <- list.files(paste0(commons, "/views"))[1]
    if (is.na(name)) cli_abort("{.arg name} must be specified since no views are present in {commons}")
  }
  check <- check_template("datacommons", dir = commons)
  view_dir <- normalizePath(paste0(commons, "/views/", name), "/", FALSE)
  dir.create(view_dir, FALSE, TRUE)
  paths <- paste0(view_dir, "/", c("view.json", "manifest.json", "run_after.R", "run_before.R"))
  base_run_after <- run_after
  if (!is.null(run_after)) {
    if (length(run_after) > 1 || !grepl("\\w\\.\\w+$", run_after)) {
      if (verbose) cli_alert_info("writting {.file run_after.R}")
      writeLines(run_after, paths[3])
      base_run_after <- run_after <- paths[3]
    } else if (!file.exists(run_after)) {
      base_run_after <- paste0(commons, "/", run_after)
    }
  }
  if (!is.null(run_before) && (length(run_before) > 1 || !file.exists(run_before))) {
    if (verbose) cli_alert_info("writting {.file run_before.R}")
    writeLines(run_before, paths[4])
    run_before <- paths[4]
  }
  write_view <- FALSE
  if (!is.null(variables)) variables <- variables[!grepl("^_", variables)]
  if (!file.exists(paths[1])) {
    if (verbose) cli_alert_info("writting new {.file view.json}")
    view <- list(
      name = name,
      remote = remote,
      url = url,
      output = output,
      run_after = run_after,
      run_before = run_before,
      variables = variables,
      ids = ids,
      files = files,
      children = children
    )
    write_view <- TRUE
  } else {
    view <- jsonlite::read_json(paths[1])
    if (!is.null(remote) && !identical(view$remote, remote)) {
      view$remote <- remote
      write_view <- TRUE
    }
    if (!is.null(url) && !identical(view$url, url)) {
      view$url <- url
      write_view <- TRUE
    }
    if (!is.null(output) && !identical(view$output, output)) {
      view$output <- output
      write_view <- TRUE
    }
    if (!is.null(run_after) && !identical(view$run_after, run_after)) {
      view$run_after <- run_after
      write_view <- TRUE
    } else if (length(view$run_after)) {
      base_run_after <- view$run_after
      if (!file.exists(base_run_after)) base_run_after <- paste0(commons, "/", base_run_after)
    }
    if (!is.null(run_before) && !identical(view$run_before, run_before)) {
      view$run_before <- run_before
      write_view <- TRUE
    }
    if (!is.null(variables) && !identical(view$variables, variables)) {
      view$variables <- variables
      write_view <- TRUE
    }
    if (!is.null(ids) && !identical(view$ids, ids)) {
      view$ids <- ids
      write_view <- TRUE
    }
    if (!is.null(ids) && !identical(view$files, files)) {
      view$files <- files
      write_view <- TRUE
    }
    if (!is.null(children) && !identical(view$children, children)) {
      view$children <- children
      write_view <- TRUE
    }
    if (verbose && write_view) cli_alert_info("updating existing {.file view.json}")
  }
  outbase <- outdir <- view$output
  if (!is.null(outdir)) {
    if (!dir.exists(outdir)) {
      if (dir.exists(paste0(commons, "/", outdir))) {
        outdir <- paste0(commons, "/", outdir)
      } else {
        dir.create(outdir, FALSE, TRUE)
      }
    }
    outbase <- sub("/docs(?:/data)?$", "", outdir)
  }
  if (length(view$remote)) {
    remote_parts <- strsplit(sub("^(?:https?://)?(?:www\\.)?github\\.com/", "", view$remote), "/")[[1]]
    if (is.null(view$url)) view$url <- paste0("https://", remote_parts[1], ".github.io/", remote_parts[2])
    if (!is.null(outdir)) {
      if (!dir.exists(outbase)) {
        outbase <- dirname(outbase)
        dir.create(outbase, FALSE, TRUE)
        wdir <- getwd()
        setwd(outbase)
        if (verbose) cli_alert_info(paste0("cloning remote view: {.url https://github.com/", view$remote, "}"))
        overwrite <- TRUE
        tryCatch(
          system2("git", c("clone", paste0("https://github.com/", view$remote, ".git")), stdout = TRUE),
          error = function(e) warning("remote clone failed: ", e$message)
        )
        setwd(wdir)
      }
    }
  }
  if (length(view$children)) {
    if (!is.null(names(view$children))) view$children <- list(view$children)
    view$children <- lapply(view$children, function(ch) {
      if (is.null(ch$name)) {
        ch$name <- sub("^.*/", "", ch$remote)
      }
      if (is.null(ch$url)) {
        remote_parts <- strsplit(sub("^(?:https?://)?(?:www\\.)?github\\.com/", "", ch$remote), "/")[[1]]
        ch$url <- paste0("https://", remote_parts[1], ".github.io/", remote_parts[2])
      }
      ch
    })
  }
  if (length(view$variables)) view$variables <- as.character(view$variables)
  if (length(view$ids)) view$ids <- as.character(view$ids)
  if (!is.null(outbase) && !dir.exists(outbase)) init_site(outbase, view$name, quiet = TRUE)
  if (is.null(view$output)) outdir <- view_dir
  if (write_view) jsonlite::write_json(view, paths[1], auto_unbox = TRUE)
  if (execute) {
    source_env <- new.env()
    source_env$datacommons_view <- function(...) {}
    if (length(view$run_before) && file.exists(view$run_before)) {
      if (verbose) cli_alert_info("running pre-view script ({.file {view$run_before}})")
      src <- parse(text = gsub("community::datacommons_view", "datacommons_view", readLines(view$run_before, warn = FALSE), fixed = TRUE))
      source(local = source_env, exprs = src)
    }
    if (verbose) cli_alert_info("checking for file maps")
    map <- datacommons_map_files(commons, overwrite = refresh_map, verbose = verbose)
    files <- map$variables[
      (if (length(view$files)) grepl(view$files, map$variables$file) else TRUE) &
        (if (length(view$variables)) {
          map$variables$full_name %in% view$variables | map$variables$dir_name %in% view$variables | map$variables$variable %in% view$variables
        } else {
          TRUE
        }) &
        (if (length(view$ids)) {
          sub("^[^/]+/[^/]+/", "", map$variables$file) %in% unique(unlist(
            lapply(map$ids[view$ids %in% names(map$ids)], "[[", "files"),
            use.names = FALSE
          ))
        } else {
          TRUE
        }), ,
      drop = FALSE
    ]
    manifest <- NULL
    if (nrow(files)) {
      cfs <- paste0("/", files$file)
      files <- files[order(
        grepl(if (prefer_repo) "cache/" else "repos/", files$file) -
          Reduce("+", lapply(view$ids, function(id) cfs %in% map$ids[[id]]$file))
      ), ]
      files <- files[!duplicated(paste(files$dir_name, basename(files$file))), , drop = FALSE]
      if (preselect_files) {
        sel_files <- unique(unlist(lapply(split(files, files$dir_name), function(fs) {
          if (nrow(fs) == 1) {
            fs$file
          } else {
            ccfs <- sub("^/", "", fs$file)
            ifm <- vapply(map$ids[view$ids], function(im) ccfs %in% sub("^/", "", im$files), logical(length(ccfs)))
            is <- colSums(ifm) != 0
            sel <- NULL
            for (i in seq_along(ccfs)) {
              if (any(is[ifm[i, ]])) {
                sel <- c(sel, fs$file[i])
                is[ifm[i, ]] <- FALSE
              }
            }
            sel
          }
        }), use.names = FALSE))
        files <- files[files$file %in% sel_files, ]
      }
      files <- files[order(file.mtime(paste0(commons, "/", files$file)), decreasing = TRUE), ]
      if (verbose) cli_alert_info("updating manifest: {.file {paths[2]}}")
      repo_manifest <- jsonlite::read_json(paste0(commons, "/manifest/repos.json"))
      manifest <- lapply(split(files, files$repo), function(r) {
        hr <- repo_manifest[[r$repo[[1]]]]
        files <- paste0(commons, "/", unique(r$file))
        names(files) <- sub("^[^/]+/[^/]+/", "", unique(r$file))
        list(
          files = lapply(files, function(f) {
            name <- sub("^/[^/]+/[^/]+/", "", sub(commons, "", f, fixed = TRUE))
            if (grepl("repos/", f, fixed = TRUE)) {
              m <- hr$files[[name]]
              m$baseurl <- hr$url
            } else {
              m <- hr$distributions$dataverse$files[[name]]
              m$baseurl <- hr$distributions$dataverse$server
            }
            m
          })
        )
      })
      if (is.character(measure_info)) {
        measure_info <- if (length(measure_info) == 1 && file.exists(measure_info)) {
          jsonlite::read_json(measure_info)
        } else {
          as.list(measure_info)
        }
      }
      base_vars <- sub("^[^:/]+[:/]", "", view$variables)
      for (r in unique(files$repo)) {
        measure_info_files <- sort(list.files(
          paste0(commons, "/repos/", sub("^.+/", "", r)), "^measure_info[^.]*\\.json$",
          full.names = TRUE, recursive = TRUE
        ))
        measure_info_files <- measure_info_files[
          !grepl("/docs/data/", measure_info_files, fixed = TRUE) &
            !duplicated(gsub("_rendered|/code/|/data/", "", measure_info_files))
        ]
        ri <- lapply(measure_info_files, function(f) {
          m <- tryCatch(jsonlite::read_json(f), error = function(e) {
            cli_alert_warning("failed to read measure info: {.file {f}}")
            NULL
          })
          if (all(c("measure", "type", "short_description") %in% names(m))) {
            m <- list(m)
            names(m) <- m[[1]]$measure
          }
          remote <- paste0(get_git_remote(sub("(^.+repos/[^/]+/).*$", "\\1.git/config", f)), "/")
          source_file <- sub("^/[^/]+/[^/]+/", remote, sub(commons, "", f, fixed = TRUE))
          for (mn in names(m)) {
            if (substring(mn, 1, 1) != "_") {
              m[[mn]]$source_file <- source_file
            }
          }
          m
        })
        if (length(ri)) {
          ri <- unlist(ri, recursive = FALSE)
          nri <- names(ri)
          if (any(nri == "")) for (mname in which(nri == "")) names(ri)[mname] <- ri[[mname]]$measure
          es <- nri[substring(nri, 1, 1) == "_" & !nri %in% view$variables]
          if (length(es)) {
            for (e in es) {
              if (!is.null(names(ri[[e]]))) {
                if (is.null(measure_info[[e]])) measure_info[[e]] <- list()
                su <- !names(ri[[e]]) %in% names(measure_info[[e]])
                if (any(su)) measure_info[[e]] <- c(measure_info[[e]], ri[[e]][su])
              }
            }
          }
          if (length(view$variables) && any(!nri %in% view$variables)) {
            for (i in seq_along(nri)) {
              n <- nri[i]
              if (n %in% base_vars) {
                names(ri)[i] <- view$variables[which(base_vars == n)[1]]
              } else {
                n <- sub("^[^:]*:", "", nri[i])
                if (n %in% view$variables) {
                  names(ri)[i] <- n
                }
              }
            }
            nri <- names(ri)
          }
          rendered_names <- render_info_names(ri)
          ri <- ri[(if (length(view$variables)) {
            nri %in% rendered_names[names(rendered_names) %in% view$variables]
          } else {
            TRUE
          }) & !nri %in% names(measure_info)]
          if (length(ri)) {
            measure_info[names(ri)] <- lapply(
              ri, function(e) if (is.null(names(e)) && !is.null(names(e[[1]]))) e[[1]] else e
            )
          }
        }
      }
      args <- list(...)
      if (length(measure_info)) args$measure_info <- measure_info
      args$files <- paste0(commons, "/", unique(files$file))
      args$out <- outdir
      args$variables <- view$variables
      args$ids <- view$ids
      args$overwrite <- overwrite
      args$verbose <- verbose
      do.call(data_reformat_sdad, args)
    } else {
      cli_warn("no files were found")
    }
    if (length(base_run_after) && file.exists(base_run_after)) {
      if (verbose) cli_alert_info("running post-view script ({.file {base_run_after}})")
      src <- parse(text = gsub("community::datacommons_view", "datacommons_view", readLines(base_run_after, warn = FALSE), fixed = TRUE))
      source(local = source_env, exprs = src)
    }
    jsonlite::write_json(manifest, paste0(outdir, "/manifest.json"), auto_unbox = TRUE, pretty = TRUE)
  }
  init_datacommons(commons, refresh_after = FALSE, verbose = FALSE)
  invisible(view)
}

#' Add a table to a webpage
#'
#' Adds a table to a webpage, based on specified or selected variables.
#'
#' @param variables The ID of a variable selecting input, or a list specifying columns (if \code{wide} is
#' \code{TRUE}) or included variables. Each entry should be a list with at least have a \code{name} entry with a
#' variable name. A \code{title} entry can be used to set a different display name for the variable. \code{name}
#' can also refer to feature names, which can be specified with a \code{source} entry set to \code{"features"}.
#' For example, \code{list(title = "Variable A", name = "a", source = "features")}. A vector can also be used
#' to specify variable names, with names setting titles (e.g., \code{c("Variable A" = "a")}). If not specified,
#' sources are attempted to be resolved automatically.
#' @param dataset The name of a dataset, or ID of a dataset selector, to find \code{variables} in;
#' used if \code{dataview} is not specified.
#' @param dataview The ID of an \code{\link{input_dataview}} component.
#' @param id Unique ID of the table.
#' @param click The ID of an input to set to a clicked row's entity ID.
#' @param subto A vector of output IDs to receive hover events from.
#' @param options A list of configuration options if \code{datatables} is \code{TRUE}, see
#' \href{https://datatables.net/reference/option}{DataTables Documentation}; otherwise,
#' only the \code{scrollY} option has an effect.
#' @param features A list of features columns to include if multiple variables are included and \code{wide} is
#' \code{TRUE}.
#' @param filters A list with names of \code{meta} entries (from \code{variable} entry in \code{\link{data_add}}'s
#' \code{meta} list), and values of target values for those entries, or the IDs of value selectors.
#' @param wide Logical; if \code{FALSE}, variables and years are spread across rows rather than columns.
#' If \code{variables} specifies a single variable, \code{wide = FALSE} will show the variable in a column, and
#' \code{wide = TRUE} will show the variable across time columns.
#' @param class Class names to add to the table.
#' @param datatables Logical; if \code{TRUE}, uses \href{https://datatables.net}{DataTables}.
#' @examples
#' output_table()
#' @return A character vector of the content to be added.
#' @export

output_table <- function(variables = NULL, dataset = NULL, dataview = NULL, id = NULL, click = NULL, subto = NULL,
                         options = NULL, features = NULL, filters = NULL, wide = TRUE, class = "compact", datatables = TRUE) {
  caller <- parent.frame()
  building <- !is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts"
  if (is.null(id)) id <- paste0("table", caller$uid)
  defaults <- list(
    paging = TRUE, scrollY = 500, scrollX = 500, scrollCollapse = TRUE,
    scroller = TRUE, deferRender = TRUE
  )
  if (!is.null(options$height)) {
    options$scrollY <- options$height
    options$height <- NULL
  }
  so <- names(options)
  if (!datatables && (!wide || (length(so) && any(so != "scrollY")))) {
    cli_warn(paste(
      "because {.arg datatables} is disabled, the {.arg wide} argument is ignored,",
      "and all {.arg options} except {.arg options$scrollY} are ignored"
    ))
  }
  for (n in names(defaults)) if (!n %in% so) options[[n]] <- defaults[[n]]
  type <- if (datatables) "datatable" else "table"
  r <- paste(c(
    paste0(
      if (!datatables) {
        paste0(
          '<div class="table-wrapper" style="max-height: ', options$scrollY, if (is.numeric(options$scrollY)) "px", '">'
        )
      },
      '<table class="auto-output tables', if (is.null(class)) "" else paste("", class), '"'
    ),
    if (!is.null(dataview)) paste0('data-view="', dataview, '"'),
    if (!is.null(click)) paste0('data-click="', click, '"'),
    paste0('id="', id, '" data-autoType="', type, '"></table>', if (!datatables) "</div>")
  ), collapse = " ")
  if (building) {
    if (!is.null(variables)) {
      if (!is.character(variables) || length(variables) > 1) {
        if (!is.list(variables)) {
          variables <- as.list(variables)
        } else if (!is.list(variables[[1]])) variables <- list(variables)
        vnames <- names(variables)
        for (i in seq_along(variables)) {
          if (is.null(names(variables[[i]]))) variables[[i]] <- list(name = variables[[i]][[1]])
          if (!is.null(vnames[i])) variables[[i]]$title <- vnames[i]
        }
      }
      options$variables <- variables
    }
    if (!is.null(features)) {
      if (!is.character(features) || length(features) > 1) {
        if (!is.list(features)) {
          features <- as.list(features)
        } else if (!is.list(features[[1]]) && "name" %in% names(features)) features <- list(features)
        vnames <- names(features)
        for (i in seq_along(features)) {
          if (is.null(names(features[[i]]))) features[[i]] <- list(name = features[[i]][[1]])
          if (!is.null(vnames[i])) features[[i]]$title <- vnames[i]
        }
      }
      options$features <- unname(features)
    }
    options$subto <- if (!is.null(subto) && length(subto) == 1) list(subto) else subto
    options$filters <- filters
    options$dataset <- dataset
    options$single_variable <- wide && length(variables) == 1
    options$wide <- if (!wide && length(variables) == 1) TRUE else wide
    if (datatables) {
      caller$dependencies$jquery <- list(
        type = "script",
        src = "https://cdn.jsdelivr.net/npm/jquery@3.7.0/dist/jquery.min.js",
        hash = "sha384-NXgwF8Kv9SSAr+jemKKcbvQsz+teULH/a5UNJvZc6kP47hZgl62M1vGnw6gHQhb1",
        loading = "defer"
      )
      caller$dependencies$datatables_style <- list(
        type = "stylesheet",
        src = "https://cdn.datatables.net/1.13.6/css/jquery.dataTables.min.css",
        hash = "sha384-w9ufcIOKS67vY4KePhJtmWDp4+Ai5DMaHvqqF85VvjaGYSW2AhIbqorgKYqIJopv"
      )
      caller$dependencies$datatables <- list(
        type = "script",
        src = "https://cdn.datatables.net/v/dt/dt-1.13.6/b-2.4.1/b-html5-2.4.1/sc-2.2.0/datatables.min.js",
        hash = "sha384-MKeoYlNiH9UNKbs4gwc9iEx9XxG7iq11nnfJSxm0keXixzRSsRiFR4qVdvHnmts1",
        loading = "defer"
      )
      caller$credits$datatables <- list(
        name = "DataTables",
        url = "https://datatables.net",
        version = "1.13.6"
      )
    }
    if (datatables) caller$datatable[[id]] <- options else caller$table[[id]] <- options
    caller$content <- c(caller$content, r)
    caller$uid <- caller$uid + 1
  }
  r
}

#' Adds an organizational section to a website
#'
#' Adds a section (such as a row or column) to a website, optionally placing its elements within rows or columns.
#'
#' @param ... Elements to appear in the section.
#' @param type The class of the top-level section; usually either \code{"row"} or \code{"col"};
#' \code{NULL} for no class.
#' @param wraps The class of wrapper to place elements in; either \code{"row"}, \code{"col"}, or \code{""}
#' (to not wrap the element). Can specify 1 for every element, or a different class for each element.
#' @param sizes The relative size of each wrapper, between 1 and 12, or \code{"auto"}; default is equal size.
#' @param breakpoints Bootstrap breakpoint of each wrapper; one of \code{""} (extra small), \code{"sm"},
#' \code{"md"}, \code{"lg"}, \code{"xl"}, or \code{"xxl"}.
#' @param conditions A character for each element representing the conditions in which that should be showing
#' (e.g., \code{c("", "input_a == a", "")}); \code{""} means the element's display is not conditional.
#' Adding \code{"lock: "} before the condition will disable inputs rather than hide the element.
#' @param id Unique ID of the section.
#' @details See the \href{https://getbootstrap.com/docs/5.1/layout/grid}{Bootstrap grid documentation}.
#' @examples
#' \dontrun{
#' page_section(
#'   "<p>column</p>",
#'   "<p>row</p>",
#'   type = "row",
#'   wraps = c("col", "row")
#' )
#' }
#' @return A character vector of the content to be added.
#' @export

page_section <- function(..., type = "row", wraps = NA, sizes = NA, breakpoints = NA, conditions = "", id = NULL) {
  caller <- parent.frame()
  building <- !is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts"
  parts <- new.env()
  attr(parts, "name") <- "community_site_parts"
  parts$uid <- caller$uid
  elements <- substitute(...())
  n <- length(elements)
  wraps <- rep_len(wraps, n)
  sizes <- rep_len(sizes, n)
  breakpoints <- rep_len(breakpoints, n)
  conditions <- rep_len(conditions, n)
  ids <- paste0("sec", parts$uid, seq_len(n))
  r <- c(
    paste(c(
      "<div", if (!is.null(id)) c(' id="', id, '"'), if (!is.null(type)) c(' class="', type, '"'), ">"
    ), collapse = ""),
    unlist(lapply(seq_len(n), function(i) {
      wrap <- !is.na(wraps[i]) || conditions[i] != ""
      c(
        if (wrap) {
          paste(c(
            '<div class="', if (is.na(wraps[i])) "" else wraps[i],
            if (!is.na(breakpoints[i])) c("-", breakpoints[i]),
            if (!is.na(sizes[i])) c("-", sizes[i]),
            '"', if (conditions[i] != "") paste0(' id="', ids[i], '"'), ">"
          ), collapse = "")
        },
        eval(elements[[i]], parts, caller),
        if (wrap) "</div>"
      )
    }), use.names = FALSE),
    "</div>"
  )
  if (building) {
    caller$content <- c(caller$content, r)
    for (n in names(parts)) if (n != "content" && n != "uid") caller[[n]] <- c(caller[[n]], parts[[n]])
    process_conditions(conditions, ids, caller)
    caller$uid <- parts$uid + 1
  }
  r
}

#' Add a plot to a webpage
#'
#' Adds a Plotly plot to a webpage, based on specified or selected variables.
#'
#' @param x The name of a variable, or ID of a variable selector to plot along the x-axis.
#' @param y The name of a variable, or ID of a variable selector to plot along the y-axis.
#' @param color The name of a variable, or ID of a variable selector to use to color lines.
#' @param color_time The ID of a selector to specify which timepoint of \code{color} to use.
#' @param dataview The ID of an \code{\link{input_dataview}} component.
#' @param id Unique ID for the plot.
#' @param click The ID of an input to set to a clicked line's ID.
#' @param subto A vector of output IDs to receive hover events from.
#' @param options A list of configuration options, with named entries for any of \code{data}, \code{layout},
#' or \code{options}, potentially extracted from a saved plotly object (see
#' \href{https://plotly.com/javascript/configuration-options}{Plotly documentation}), if \code{plotly} is \code{TRUE}.
#' @param plotly Logical; if \code{TRUE}, uses \href{https://plotly.com/javascript}{Plotly}.
#' @examples
#' # for mpg ~ wt * am in a site based on mtcars data
#' output_plot("wt", "mpg", "am")
#' @return A character vector of the content to be added.
#' @export

output_plot <- function(x = NULL, y = NULL, color = NULL, color_time = NULL, dataview = NULL,
                        id = NULL, click = NULL, subto = NULL, options = list(), plotly = TRUE) {
  caller <- parent.frame()
  building <- !is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts"
  if (is.null(id)) id <- paste0("plot", caller$uid)
  entries <- c("layout", "config", "data")
  if (is.character(options)) options <- jsonlite::fromJSON(options)
  if ("x" %in% names(options)) options <- options$x
  options <- options[entries[entries %in% names(options)]]
  defaults <- list(
    layout = list(hovermode = "closest", margin = list(t = 25, r = 10, b = 40, l = 60)),
    config = list(
      showSendToCloud = FALSE, responsive = TRUE, showTips = FALSE, displaylogo = FALSE,
      modeBarButtonsToAdd = c("hoverclosest", "hovercompare")
    ),
    data = data.frame(hoverinfo = "text", mode = "lines+markers", type = "scatter")
  )
  so <- names(options)
  for (e in names(defaults)) {
    if (!e %in% so) {
      options[[e]] <- defaults[[e]]
    } else {
      soo <- names(options[[e]])
      for (eo in names(defaults[[e]])) if (!eo %in% soo) options[[e]][[eo]] <- defaults[[e]][[eo]]
    }
  }
  options$subto <- if (!is.null(subto) && length(subto) == 1) list(subto) else subto
  type <- if (plotly) "plotly" else "echarts"
  r <- paste(c(
    '<div class="plotly-wrap"><div class="auto-output plotly"',
    if (!is.null(dataview)) paste0('data-view="', dataview, '"'),
    if (!is.null(click)) paste0('data-click="', click, '"'),
    if (!is.null(x)) paste0('data-x="', x, '"'),
    if (!is.null(y)) paste0('data-y="', y, '"'),
    if (!is.null(color)) paste0('data-color="', color, '"'),
    if (!is.null(color_time)) paste0('data-colorTime="', color_time, '"'),
    paste0('id="', id, '" data-autoType="', type, '"></table></div></div>')
  ), collapse = " ")
  if (building) {
    caller$dependencies$plotly <- list(
      type = "script",
      src = "https://cdn.jsdelivr.net/npm/plotly.js@2.26.0/dist/plotly.min.js",
      hash = "sha384-xuh4dD2xC9BZ4qOrUrLt8psbgevXF2v+K+FrXxV4MlJHnWKgnaKoh74vd/6Ik8uF"
    )
    caller$credits$plotly <- list(
      name = "Plotly",
      url = "https://plotly.com/javascript/getting-started",
      version = "2.26.0"
    )
    if (plotly) caller$plotly[[id]] <- options else caller$echarts[[id]] <- options
    caller$content <- c(caller$content, r)
    caller$uid <- caller$uid + 1
  }
  r
}

#' Download Dataverse Dataset Files
#'
#' Download one or all files in a Dataverse dataset.
#'
#' @param id The dataset's persistent ID (e.g., \code{"doi:10.18130/V3/SWK71R"}), or a GitHub repository
#' (\code{"username/repo"}) with a \code{R/sysdata.rda} file containing a \code{dataset_doi}.
#' @param outdir Directory in which to save files; defaults to a temporary directory.
#' @param files Names (full or partial) of files to download, or a number or vector of numbers
#' identifying file by index as listed on Dataverse; downloads all files in a dataset if not specified.
#' @param version Version of the dataset to download. Specifying this will download all files,
#' even if only a selection is requested.
#' @param server Dataverse server; tries to get this from the DOI redirect, but falls back on
#' \code{Sys.getenv("DATAVERSE_SERVER")}, then \code{getOption("dataverse.server")}, then
#' \code{"dataverse.lib.virginia.edu"}.
#' @param key Dataverse API key; only needed if the requested dataset is not published. If not specified,
#' looks for the key in \code{Sys.getenv("DATAVERSE_KEY")} and \code{getOption("dataverse.key")}.
#' @param load Logical; if \code{FALSE}, files will be downloaded but not loaded.
#' @param decompress Logical; if \code{TRUE}, will attempt to decompress compressed files.
#' @param refresh Logical; if \code{TRUE}, downloads and replaces any existing files.
#' @param branch Name of the repository branch, if \code{id} is the name of a repository; uses the default branch
#' if not specified.
#' @param verbose Logical; if \code{TRUE}, prints status updates and warnings.
#' @examples
#' \dontrun{
#' metadata <- download_dataverse_info("doi:10.18130/V3/SWK71R", verbose = TRUE)
#' data <- download_dataverse_data("doi:10.18130/V3/SWK71R", verbose = TRUE)
#' }
#' @return \code{download_dataverse_data}: If \code{load} is \code{TRUE}, an invisible list with
#' an entry for each data file if there are multiple files, or the loaded data file if a single file
#' is requested. Tabular data files are loaded as \code{data.table}s. If \code{load} is \code{FALSE},
#' a list with the dataset's metadata.
#' @export

download_dataverse_data <- function(id, outdir = tempdir(), files = NULL, version = ":latest",
                                    server = NULL, key = NULL, load = TRUE, decompress = FALSE,
                                    refresh = FALSE, branch = NULL, verbose = FALSE) {
  if (missing(id)) cli_abort("{.arg id} must be specified")
  if (!is.character(outdir)) cli_abort("{.arg outdir} must be a character")
  meta <- download_dataverse_info(id, server = server, key = key, refresh = refresh, branch = branch)
  fs <- vapply(meta$latestVersion$files, function(m) m$dataFile$filename, "")
  which_files <- if (!is.null(files)) {
    if (is.numeric(files)) {
      files[files <= length(fs)]
    } else {
      grep(paste0(
        "(?:", paste(gsub(".", "\\.", files, fixed = TRUE), collapse = "|"), ")"
      ), fs, TRUE)
    }
  } else {
    seq_along(fs)
  }
  if (!length(which_files)) {
    cli_abort(cli_bullets(c(
      x = "{.arg files} could not be matched to available files",
      i = paste0("check {.url ", meta$persistentUrl, "}")
    )))
  }
  outdir <- paste0(normalizePath(outdir, "/", FALSE), "/")
  dir.create(outdir, FALSE, TRUE)
  data <- list()
  ffsx <- paste0(outdir, fs)
  ffs <- sub("\\.[gbx]z2?$", "", ffsx)
  if (refresh) unlink(c(ffsx, ffs))
  if (is.null(key)) {
    if (verbose) cli_alert_info("looking for API key in fall-backs")
    key <- Sys.getenv("DATAVERSE_KEY")
    if (key == "") {
      key <- getOption("dataverse.key")
    }
  }
  if (length(which_files) == length(fs) || !missing(version)) {
    zf <- paste0(outdir, gsub("\\W", "", meta$latestVersion$datasetPersistentId), ".zip")
    if (verbose) cli_alert_info("downloading dataset: {meta$latestVersion$datasetPersistentId}")
    if (is.character(key)) {
      if (verbose) cli_alert_info("trying with key")
      tryCatch(
        system2("curl", c(
          paste0("-H X-Dataverse-key:", key),
          "-o", zf,
          paste0(
            meta$server, "api/access/dataset/:persistentId/versions/", version, "?persistentId=",
            meta$latestVersion$datasetPersistentId
          )
        ), stdout = TRUE),
        error = function(e) NULL
      )
    } else {
      if (verbose) cli_alert_info("trying without key")
      tryCatch(
        download.file(paste0(
          meta$server, "api/access/dataset/:persistentId/versions/", version, "?persistentId=",
          meta$latestVersion$datasetPersistentId
        ), zf, quiet = TRUE, mode = "wb"),
        error = function(e) NULL
      )
    }
    if (file.exists(zf)) {
      unzip(zf, exdir = sub("/$", "", outdir))
      unlink(zf)
    } else if (verbose) cli_alert_info("failed to download dataset {meta$id}; trying individual files...")
  }
  for (i in which_files) {
    m <- meta$latestVersion$files[[i]]
    meta$latestVersion$files[[i]]$local <- ffs[i]
    if (!file.exists(ffs[i]) && !file.exists(ffsx[i])) {
      if (verbose) cli_alert_info("downloading file: {.file {m$label}}")
      if (is.null(key)) {
        if (verbose) cli_alert_info("trying without key")
        tryCatch(
          download.file(
            paste0(meta$server, "api/access/datafile/", m$dataFile$id), ffsx[i],
            quiet = TRUE, mode = "wb"
          ),
          error = function(e) NULL
        )
      } else {
        if (verbose) cli_alert_info("trying with key")
        tryCatch(
          system2("curl", c(
            paste0("-H X-Dataverse-key:", key),
            "-o", ffsx[i],
            paste0(meta$server, "api/access/datafile/", m$dataFile$id)
          ), stdout = TRUE),
          error = function(e) NULL
        )
      }
      if (verbose && !file.exists(ffsx[i])) cli_alert_info("failed to download file: {.file {m$label}}")
    }
    if (file.exists(ffsx[i])) {
      if (verbose && m$dataFile$md5 != md5sum(ffsx[i])) {
        cli_warn("file was downloaded but its checksum did not match: {.file {ffsx[i]}}")
      }
      if (decompress && grepl("[gbx]z2?$", ffsx[i])) {
        if (verbose) cli_alert_info("decompressing file: {.file {ffsx[i]}}")
        system2(
          c(xz = "xz", bz = "bunzip2", gz = "gzip")[substring(ffsx[i], nchar(ffsx[i]) - 1)],
          c("-df", shQuote(ffsx[i]))
        )
      }
    }
    if (load && file.exists(if (decompress) ffs[i] else ffsx[i])) {
      if (verbose) cli_alert_info("loading file: {.file {ffs[i]}}")
      fn <- sub("\\..*", "", m$label)
      json <- grepl("\\.json$", ffs[i])
      data[[fn]] <- tryCatch(
        if (json) {
          jsonlite::read_json(ffs[i], simplifyVector = TRUE)
        } else {
          read_delim_arrow(gzfile(ffsx[i]), if (grepl("csv", format, fixed = TRUE)) "," else "\t")
        },
        error = function(e) NULL
      )
      if (verbose && is.null(data[[fn]])) {
        cli_warn("file was downloaded but failed to load: {.file {ffs[i]}}")
      }
    }
  }
  if (!decompress) ffs <- ffsx
  ffs <- ffs[which_files]
  if (verbose && any(!file.exists(ffs))) {
    cli_warn("failed to download file{?s}: {.file {ffs[!file.exists(ffs)]}}")
  }
  invisible(if (load) if (length(data) == 1) data[[1]] else data else meta)
}

#' Reformat an SDAD-formatted dataset
#'
#' Unify multiple files, which each contain a tall set of variables associated with regions.
#'
#' The basic assumption is that there are (a) entities which (b) exist in a hierarchy, and
#' (c1) have a static set of features and (c2) a set of variable features which
#' (d) are assessed at multiple time points.
#'
#' For example (and generally), entities are (a) regions, with (b) smaller regions making up larger regions,
#' and which (c1) have names, and (c2) population and demographic counts (d) between 2009 and 2019.
#'
#' @param files A character vector of file paths, or the path to a directory containing data files.
#' @param out Path to a directory to write files to; if not specified, files will not be written.
#' @param variables Vector of variable names (in the \code{value_name} column) to be included.
#' @param ids Vector of IDs (in the \code{id} column) to be included.
#' @param value Name of the column containing variable values.
#' @param value_name Name of the column containing variable names; assumed to be a single variable per file if
#' not present.
#' @param id Column name of IDs which uniquely identify entities.
#' @param time Column name of the variable representing time.
#' @param dataset Column name used to separate entity scales.
#' @param entity_info A list containing variable names to extract and create an ids map from (
#' \code{entity_info.json}, created in the output directory). Entries can be named to rename the
#' variables they refer to in entity features.
#' @param measure_info Measure info to add file information to (as \code{origin}) to, and write to \code{out}.
#' @param metadata A matrix-like object with additional information associated with entities,
#' (such as region types and names) to be merged by \code{id}.
#' @param formatters A list of functions to pass columns through, with names identifying those columns
#' (e.g., \code{list(region_name = function(x) sub(",.*$", "", x))} to strip text after a comma in the
#' "region_name" column).
#' @param compression A character specifying the type of compression to use on the created files,
#' between \code{"gzip"}, \code{"bzip2"}, and \code{"xz"}. Set to \code{FALSE} to disable compression.
#' @param read_existing Logical; if \code{FALSE}, will not read in existing sets.
#' @param overwrite Logical; if \code{TRUE}, will overwrite existing reformatted files, even if
#' the source files are older than it.
#' @param get_coverage Logical; if \code{FALSE}, will not calculate a summary of variable coverage (\code{coverage.csv}).
#' @param verbose Logical; if \code{FALSE}, will not print status messages.
#' @examples
#' dir <- paste0(tempdir(), "/reformat_example")
#' dir.create(dir, FALSE)
#'
#' # minimal example
#' data <- data.frame(
#'   geoid = 1:10,
#'   value = 1
#' )
#' write.csv(data, paste0(dir, "/data.csv"), row.names = FALSE)
#' (data_reformat_sdad(dir))
#'
#' # multiple variables
#' data <- data.frame(
#'   geoid = 1:10,
#'   value = 1,
#'   measure = paste0("v", 1:2)
#' )
#' write.csv(data, paste0(dir, "/data.csv"), row.names = FALSE)
#' (data_reformat_sdad(dir))
#'
#' # multiple datasets
#' data <- data.frame(
#'   geoid = 1:10,
#'   value = 1,
#'   measure = paste0("v", 1:2),
#'   region_type = rep(c("a", "b"), each = 5)
#' )
#' write.csv(data, paste0(dir, "/data.csv"), row.names = FALSE)
#' (data_reformat_sdad(dir))
#' @return An invisible list of the unified variable datasets, split into datasets.
#' @export

data_reformat_sdad <- function(files, out = NULL, variables = NULL, ids = NULL, value = "value", value_name = "measure",
                               id = "geoid", time = "year", dataset = "region_type",
                               entity_info = c(type = "region_type", name = "region_name"), measure_info = list(),
                               metadata = NULL, formatters = NULL, compression = "xz", read_existing = TRUE,
                               overwrite = FALSE, get_coverage = TRUE, verbose = TRUE) {
  base_dir <- "./"
  if (length(files) == 1 && dir.exists(files)) {
    base_dir <- files
    files <- list.files(files, full.names = TRUE)
  }
  if (any(!file.exists(files))) {
    files <- files[!file.exists(files)]
    cli_abort("file{? does/s do} not exist: {files}")
  }
  if (!is.null(metadata) && !id %in% colnames(metadata)) cli_abort("{.arg metadata} does not have an id ({id}) column")
  vars <- c(value, value_name, id, time, dataset)
  spec <- c(
    missing(value), missing(value_name), missing(id), missing(time), missing(dataset),
    rep(missing(entity_info), length(entity_info))
  )
  data <- list()
  names <- list()
  i <- 0
  if (verbose) cli_progress_step("reading in {i}/{length(files)} original file{?s}", spinner = TRUE)
  max_age <- max(file.mtime(files))
  check_variables <- check_ids <- FALSE
  if (length(ids)) {
    check_ids <- TRUE
    ids <- unique(as.character(ids))
  }
  for (f in files) {
    if (verbose) {
      i <- i + 1
      cli_progress_update()
    }
    d <- attempt_read(f, id)
    if (is.null(d)) {
      if (verbose) cli_warn("failed to read in file: {f}")
      next
    }
    if (!id %in% colnames(d)) {
      if (verbose) cli_warn("file has no ID column: {f}")
      next
    }
    if (anyNA(d[[id]])) d <- d[!is.na(d[[id]]), ]
    if (!nrow(d)) {
      if (verbose) cli_warn("file has no observations: {f}")
      next
    }
    lcols <- tolower(colnames(d))
    if (any(!vars %in% colnames(d))) {
      l <- !colnames(d) %in% vars & lcols %in% vars
      colnames(d)[l] <- lcols[l]
    }
    d[[id]] <- gsub("^\\s+|\\s+$", "", d[[id]])
    if (check_ids) {
      su <- grepl("\\de[+-]\\d", d[[id]], perl = TRUE)
      if (any(su)) {
        d[[id]][su] <- gsub("^\\s+|\\s+$", "", format(as.numeric(d[[id]][su]), scientific = FALSE))
      }
      su <- d[[id]] %in% ids
      if (!all(su)) d <- d[su, ]
      if (!nrow(d)) {
        if (verbose) cli_warn("file has none of the requested IDs: {f}")
        next
      }
    }
    if (any(su <- !vars %in% colnames(d))) {
      if (all(su)) {
        cli_warn("no variables found in file {f}")
        next
      }
      if (any(!spec[su])) {
        cli_warn(
          "table from {f} does not have {?a column name/column names} {.var {vars[su][!spec[su]]}}"
        )
        next
      }
      vars <- vars[!su]
      spec <- spec[!su]
    }
    names <- c(names, list(colnames(d)))
    if (grepl("repos/", f, fixed = TRUE)) {
      remote <- get_git_remote(sub("(^.+repos/[^/]+/).*$", "\\1.git/config", f))
      if (length(remote)) d$file <- paste0(remote, sub("^.+repos/[^/]+", "", f))
      if (!"file" %in% colnames(d)) d$file <- sub("^.+repos/", "", f)
    } else {
      if (!grepl("/$", base_dir)) base_dir <- paste0(base_dir, "/")
      remote <- get_git_remote(paste0(base_dir, ".git/config"))
      d$file <- gsub("//+", "/", if (length(remote)) {
        paste0(remote, "/", sub(base_dir, "", f, fixed = TRUE))
      } else {
        sub(base_dir, "", f, fixed = TRUE)
      })
    }
    data <- c(data, list(d))
  }
  if (verbose) cli_progress_done()
  common <- Reduce(intersect, names)
  if (!value %in% vars) {
    a <- common[!common %in% vars]
    if (!length(a)) cli_abort("could not figure out which column might contain values")
    if (length(a) > 1) a <- a[which(vapply(a, function(col) is.numeric(d[[col]]), TRUE))]
    if (!length(a)) {
      cli_abort(c(
        "no potential value columns were numeric",
        i = "check variable classes, or specify {.arg value}"
      ))
    }
    value <- a[1]
    vars <- c(value, vars)
  }
  all <- unique(unlist(names))
  all <- all[all %in% vars & (all == id | !all %in% colnames(metadata))]
  vars <- c(all, "file")
  if (length(variables)) {
    check_variables <- TRUE
    variables <- unique(as.character(variables))
  }
  data <- do.call(rbind, lapply(seq_along(data), function(i) {
    d <- data[[i]]
    mv <- vars[!vars %in% colnames(d)]
    if (length(mv)) d[, vars[!vars %in% colnames(d)]] <- ""
    d <- d[, vars]
    if (anyNA(d)) d <- d[rowSums(is.na(d)) == 0, ]
    if (check_variables) {
      ovars <- unique(d[[value_name]])
      su <- !ovars %in% variables
      if (any(su)) {
        names(ovars) <- ovars
        ovars[] <- make_full_name(d$file[[1]], ovars)
        su <- su & ovars %in% variables
        for (i in which(su)) d[[value_name]][d[[value_name]] == names(ovars)[i]] <- ovars[i]
      }
      d <- d[d[[value_name]] %in% variables, ]
    }
    d
  }))
  if (is.null(data) || !nrow(data)) cli_abort("no datasets contained selected variables and/or IDs")
  cn <- colnames(data)
  if (!id %in% vars) {
    id <- "id"
    vars <- c(id, vars)
    data <- cbind(id = unlist(lapply(table(data$file), seq_len), use.names = FALSE), data)
  }
  data[[id]] <- as.character(data[[id]])
  if (!is.null(metadata)) {
    su <- colnames(data) != id & colnames(data) %in% colnames(metadata)
    if (any(su)) data <- data[, colnames(data) == id | !su, drop = FALSE]
    if (verbose) cli_progress_step("merging in metadata", msg_done = "merged in metadata")
    metadata <- as.data.frame(metadata[!duplicated(metadata[[id]]) & metadata[[id]] %in% data[[id]], ])
    if (!nrow(metadata)) cli_abort("{.arg metadata} had no ids in common with data")
    rownames(metadata) <- metadata[[id]]
    metadata[[id]] <- NULL
    su <- data[[id]] %in% rownames(metadata)
    if (!all(su)) {
      if (verbose) cli_warn("{sum(!su)} rows contain IDs not in {.arg metadata} IDs, and will be dropped")
      data <- data[su, ]
    }
    data <- cbind(data, metadata[data[[id]], , drop = FALSE])
    cn <- colnames(data)
    vars <- c(vars, colnames(metadata))
    if (verbose) cli_progress_done()
  }
  if (!is.null(formatters)) {
    for (n in names(formatters)) {
      if (n %in% cn) {
        data[[n]] <- formatters[[n]](data[[n]])
      }
    }
  }
  if (!dataset %in% vars) {
    dataset <- "dataset"
    vars <- c(vars, dataset)
    data$dataset <- dataset
  }
  if (!time %in% vars) {
    time <- "time"
    vars <- c(vars, time)
    data$time <- 1
  }
  if (!any(value_name %in% vars)) {
    vars <- c(vars, value_name)
    data[[value_name]] <- sub("\\.[^.]+$", "", basename(data$file))
  }
  data[[dataset]] <- gsub("\\s+", "_", data[[dataset]])
  datasets <- sort(unique(data[[dataset]]))
  present_vars <- unique(data[[value_name]])
  if (check_variables) {
    present_vars <- variables[variables %in% present_vars]
    if (verbose) {
      absent_variables <- variables[!variables %in% present_vars]
      if (length(absent_variables)) cli_warn("requested variable{?s} not found in datasets: {.val {absent_variables}}")
    }
  }
  times <- sort(unique(data[[time]]))
  if (all(nchar(times) == 4)) times <- seq(min(times), max(times))
  n <- length(times)
  files <- paste0(out, "/", gsub("\\s+", "_", tolower(datasets)), ".csv")
  if (is.character(compression) && grepl("^[gbx]", compression, FALSE)) {
    compression <- tolower(substr(compression, 1, 1))
    files <- paste0(files, ".", c(g = "gz", b = "bz2", x = "xz")[[compression]])
  } else {
    compression <- FALSE
  }
  names(files) <- datasets
  write <- vapply(files, function(f) is.null(out) || overwrite || !file.exists(f) || max_age > file.mtime(f), TRUE)
  if (!is.null(out) && (is.list(entity_info) || is.character(entity_info))) {
    entity_info_file <- paste0(out, "/entity_info.json")
    if (overwrite || !file.exists(entity_info_file) || any(write)) {
      entity_info <- as.list(entity_info)
      entity_info <- entity_info[unlist(entity_info) %in% colnames(data)]
      if (length(entity_info)) {
        if (verbose) {
          cli_progress_step(
            "writing entity file",
            msg_done = paste0("wrote entity metadata file: {.file ", entity_info_file, "}")
          )
        }
        e <- data[, unique(c(id, dataset, unlist(entity_info))), drop = FALSE]
        if (!is.null(names(entity_info))) {
          for (en in names(entity_info)) {
            if (en != "" && entity_info[[en]] %in% colnames(e)) colnames(e)[colnames(e) == entity_info[[en]]] <- en
          }
        }
        jsonlite::write_json(
          lapply(split(e, e[, 2]), function(g) {
            lapply(
              split(g[, -(1:2), drop = FALSE], g[, 1]),
              function(l) lapply(l, function(r) r[which(r != "")[1]])
            )
          }),
          entity_info_file,
          auto_unbox = TRUE,
          digits = 6
        )
        if (verbose) cli_progress_done()
      }
    }
  }
  svars <- c(id, value, value_name, time, "file", dataset)
  data <- unique(data[, svars[svars %in% vars]])
  if (length(measure_info)) {
    dynamic_names <- render_info_names(measure_info)
  }
  sets <- lapply(datasets, function(dn) {
    if (read_existing && !is.null(out) && file.exists(files[[dn]]) && !write[[dn]]) {
      if (verbose) cli_progress_step("reading in existing {dn} dataset", msg_done = "read existing {dn} dataset")
      read.csv(gzfile(files[[dn]]), check.names = FALSE)
    } else {
      d <- if (dataset %in% vars) data[data[[dataset]] == dn, ] else data
      dc <- list()
      ids <- unique(d[[id]])
      i <- 0
      if (verbose) {
        cli_progress_step(
          "creating {dn} dataset (ID {i}/{length(ids)})",
          msg_done = "created {dn} dataset ({length(ids)} IDs)", spinner = TRUE
        )
      }
      d <- d[!duplicated(paste(d[[id]], d[[value_name]], d[[time]])), ]
      if (length(measure_info)) {
        source <- unique(d[, c(value_name, "file")])
        source <- structure(source[[2]], names = source[[1]])
        for (measure in names(source)) {
          iname <- if (length(measure_info[[dynamic_names[measure]]])) dynamic_names[measure] else measure
          if (length(measure_info[[iname]])) {
            measure_info[[iname]]$origin <<- unique(c(
              measure_info[[iname]]$origin, source[[measure]]
            ))
          }
        }
      }
      sd <- split(d, d[[id]])
      ssel <- c(time, value)
      for (i in seq_along(ids)) {
        if (verbose) cli_progress_update()
        e <- ids[[i]]
        ed <- sd[[e]]
        r <- data.frame(
          ID = rep(as.character(e), n), time = times, check.names = FALSE,
          matrix(NA, n, length(present_vars), dimnames = list(times, present_vars))
        )
        if (all(c(value_name, value) %in% names(ed))) {
          ed <- ed[!is.na(ed[[value]]), ]
          ed <- split(ed[, ssel], ed[[value_name]])
          for (v in names(ed)) {
            vals <- ed[[v]]
            if (nrow(vals)) r[as.character(vals[[time]]), v] <- vals[[value]]
          }
        }
        rownames(r) <- NULL
        dc[[i]] <- r
      }
      do.call(rbind, dc)
    }
  })
  names(sets) <- datasets
  if (length(measure_info)) {
    measure_info_file <- paste0(out, "/measure_info.json")
    if (verbose) cli_alert_info("updating measure info: {.file {measure_info_file}}")
    jsonlite::write_json(measure_info[sort(names(measure_info))], measure_info_file, auto_unbox = TRUE, pretty = TRUE)
  }
  if (!is.null(out)) {
    if (get_coverage && read_existing) {
      if (verbose) cli_progress_step("updating coverage report", msg_done = "updated coverage report")
      variables <- sort(if (length(variables)) variables else unique(unlist(lapply(sets, colnames), use.names = FALSE)))
      allcounts <- structure(numeric(length(variables)), names = variables)
      write.csv(vapply(sets, function(d) {
        counts <- colSums(!is.na(d))
        counts <- counts[names(counts) %in% variables]
        allcounts[names(counts)] <- counts
        allcounts
      }, numeric(length(variables))), paste0(out, "/coverage.csv"))
      if (verbose) cli_progress_done()
    }
    if (any(write)) {
      if (verbose) cli_progress_step("writing data files", msg_done = "wrote reformatted datasets:")
      for (i in seq_along(sets)) {
        if (write[[i]]) {
          if (is.character(compression)) o <- do.call(paste0(compression, "zfile"), list(files[[i]]))
          write_csv_arrow(sets[[i]], o)
        }
      }
      if (verbose) {
        cli_progress_done()
        cli_bullets(structure(
          paste0("{.file ", files[write], "}"),
          names = rep("*", sum(write))
        ))
      }
    } else if (verbose) {
      cli_bullets(c(
        v = "all files are already up to date:",
        structure(paste0("{.file ", files, "}"), names = rep("*", length(files)))
      ))
    }
  }
  invisible(sets)
}

#' Refresh Data Commons Repositories
#'
#' Clone and/or pull repositories that are part of a data commons project.
#'
#' @param dir Directory of the data commons projects, as created by \code{\link{init_datacommons}}.
#' @param clone_method Means of cloning new repositories; either \code{"http"} (default) or \code{"ssh"}.
#' @param include_distributions Logical; if \code{TRUE}, will attempt to locate and cache copies of datasets
#' pointed to from the data repositories (so far just from Dataverse, implicitly from DOI files).
#' @param refresh_distributions Logical; if \code{TRUE}, will download fresh copies of the distribution metadata.
#' @param only_new Logical; if \code{TRUE}, only repositories that do not yet exist will be processed.
#' @param reset_repos Logical; if \code{TRUE}, will fetch and hard reset the repositories to remove any local changes.
#' @param reset_on_fail Logical; if \code{TRUE}, will reset only if a regular pull fails.
#' @param rescan_only Logical; if \code{TRUE}, will only read the files that are already in place, without checking for
#' updates from the remote repository.
#' @param run_checks Logical; if \code{FALSE}, will not run \code{\link{check_repository}} on each repository.
#' @param dataset_map A named vector of ID to dataset mappings to pass to \code{\link{check_repository}}
#' if \code{run_checks} is \code{TRUE}.
#' @param force_value_check Logical; if \code{TRUE}, will always intensively check values, even on large files.
#' @param verbose Logical; if \code{FALSE}, will not show updated repositories.
#' @examples
#' \dontrun{
#' # refresh from a data commons working directory
#' datacommons_refresh(".")
#' }
#' @return An invisible character vector of updated repositories.
#' @export

datacommons_refresh <- function(dir, clone_method = "http", include_distributions = FALSE, refresh_distributions = FALSE,
                                only_new = FALSE, reset_repos = FALSE, reset_on_fail = FALSE, rescan_only = FALSE,
                                run_checks = TRUE, dataset_map = "region_type", force_value_check = FALSE, verbose = TRUE) {
  if (missing(dir)) cli_abort('{.arg dir} must be specified (e.g., as ".")')
  if (Sys.which("git") == "") {
    cli_abort(c(
      x = "the {.emph git} command could not be located",
      i = "you might need to install git: {.url https://git-scm.com/downloads}"
    ))
  }
  check <- check_template("datacommons", dir = dir)
  if (!check$exists) {
    cli_abort(c(
      x = "{.arg dir} does not appear to point to a data commons project",
      i = paste0('initialize it with {.code init_datacommons("', dir, '")}')
    ))
  }
  dir <- normalizePath(dir, "/", FALSE)
  commons <- jsonlite::read_json(paste0(dir, "/commons.json"))
  repos <- sort(unique(unlist(Filter(length, c(
    commons$repositories, readLines(paste0(dir, "/scripts/repos.txt"))
  )))))
  if (!length(repos)) cli_abort("no repositories are listed in {.file commons.json}.")
  repos <- gsub("^[\"']+|['\"]+$|^.*github\\.com/", "", repos)
  su <- !grepl("/", repos, fixed = TRUE)
  if (any(su)) {
    repos <- repos[su]
    cli_abort("repo{?s are/ is} missing a username prefix: {.files {repos}}")
  }
  repos <- sub("^([^/]+/[^/#@]+)[^/]*$", "\\1", repos)
  if (!identical(unlist(commons$repositories, use.names = FALSE), repos)) {
    commons$repositories <- repos
    jsonlite::write_json(commons, paste0(dir, "/commons.json"), auto_unbox = TRUE, pretty = TRUE)
  }
  writeLines(repos, paste0(dir, "/scripts/repos.txt"))
  if (only_new) {
    repos <- repos[!file.exists(paste0(dir, "/repos/", sub("^.*/", "", repos)))]
    if (!length(repos)) {
      if (verbose) cli_alert_success("no new repositories")
      return(invisible(repos))
    }
  }
  updated <- dist_updated <- failed <- logical(length(repos))
  wd <- getwd()
  on.exit(setwd(wd))
  repo_dir <- paste0(normalizePath(paste0(dir, "/repos/"), "/", FALSE), "/")
  dir.create(repo_dir, FALSE, TRUE)
  setwd(repo_dir)
  method <- if (clone_method == "ssh") "git@github.com:" else "https://github.com/"
  if (include_distributions) dir.create(paste0(dir, "/cache"), FALSE)
  manifest_file <- paste0(dir, "/manifest/repos.json")
  repo_manifest <- list()
  for (i in seq_along(repos)) {
    r <- repos[[i]]
    rn <- sub("^.*/", "", r)
    cr <- paste0(repo_dir, rn, "/")
    if (!rescan_only) {
      change_dir <- dir.exists(rn)
      if (verbose) cli_alert_info(paste(if (change_dir) "pulling" else "cloning", rn))
      if (change_dir) setwd(cr)
      s <- tryCatch(if (change_dir) {
        if (reset_repos || reset_on_fail) {
          attempt <- if (reset_on_fail) system2("git", "pull", stdout = TRUE) else NULL
          if (!is.null(attr(attempt, "status"))) {
            system2("git", "clean --f", stdout = TRUE)
            system2("git", "fetch", stdout = TRUE)
            system2("git", "reset --hard FETCH_HEAD", stdout = TRUE)
          } else {
            attempt
          }
        } else {
          system2("git", "pull", stdout = TRUE)
        }
      } else {
        system2("git", c("clone", paste0(method, r, ".git")), stdout = TRUE)
      }, error = function(e) e$message)
      if (change_dir) setwd(repo_dir)
      if (length(s) != 1 || s != "Already up to date.") {
        if (!is.null(attr(s, "status"))) {
          failed[i] <- TRUE
          cli_alert_warning(c(
            x = paste0("failed to retrieve ", r, ": ", paste(s, collapse = " "))
          ))
        } else {
          updated[i] <- TRUE
        }
      } else if (!length(list.files(rn))) system2("rm", c("-rf", rn))
    }
    repo_manifest[[r]]$base_url <- get_git_remote(paste0(cr, ".git/config"))
    files <- sort(list.files(
      cr, "\\.(?:csv|tsv|txt|dat|rda|rdata)(?:\\.[gbx]z2?)?$",
      full.names = TRUE, recursive = TRUE, ignore.case = TRUE
    ))
    files <- normalizePath(files, "/")
    for (f in files) {
      repo_manifest[[r]]$files[[sub("^.*/repos/[^/]+/", "", f)]] <- list(
        size = file.size(f),
        sha = system2("git", c("hash-object", shQuote(f)), stdout = TRUE),
        md5 = md5sum(f)[[1]]
      )
    }
    doi <- repo_manifest[[r]]$distributions$dataverse$doi
    if (include_distributions && !is.null(doi)) {
      if (verbose) {
        ul <- cli_ul()
        iul <- cli_ul()
        cli_li("including Dataverse distribution for {.emph {doi}}")
      }
      meta_file <- paste0(dir, "/cache/", rn, "/dataverse_metadata.json")
      meta <- if (!refresh_distributions && file.exists(meta_file)) {
        jsonlite::read_json(meta_file, simplifyVector = TRUE)
      } else {
        tryCatch(download_dataverse_info(doi, refresh = refresh_distributions), error = function(e) NULL)
      }
      if (is.null(meta)) {
        if (verbose) {
          cli_li(col_red("failed to download Dataverse metadata for {.emph {doi}}"))
          cli_end(iul)
          cli_end(ul)
        }
      } else {
        if (is.null(meta$latestVersion)) meta$latestVersion <- list(files = meta$files)
        dir.create(paste0(dir, "/cache/", rn), FALSE)
        jsonlite::write_json(meta, meta_file, auto_unbox = TRUE)
        repo_manifest[[r]]$distributions$dataverse$id <- meta$datasetId
        repo_manifest[[r]]$distributions$dataverse$server <- meta$server
        repo_manifest[[r]]$distributions$dataverse$files <- list()
        if (length(meta$latestVersion$files)) {
          for (f in meta$latestVersion$files) {
            existing <- paste0(dir, "/cache/", rn, "/", f$dataFile$filename)
            if (file.exists(existing)) {
              if (verbose) cli_li("checking existing version of {.file {f$dataFile$filename}}")
              if (md5sum(existing) != f$dataFile$md5) unlink(existing)
            }
            if (!file.exists(existing)) {
              if (verbose) cli_li("downloading {.file {f$dataFile$filename}}")
              res <- tryCatch(download_dataverse_data(
                doi, paste0(dir, "/cache/", rn),
                files = f$label, load = FALSE, decompress = FALSE
              ), error = function(e) NULL)
              if (is.null(res)) {
                if (verbose) cli_li(col_red("failed to download {.file {f$dataFile$filename}}"))
              } else {
                dist_updated[i] <- TRUE
              }
            }
            if (file.exists(existing)) {
              repo_manifest[[r]]$distributions$dataverse$files[[sub("^.*/cache/[^/]+/", "", existing)]] <- list(
                id = f$dataFile$id,
                size = file.size(existing),
                md5 = md5sum(existing)[[1]]
              )
            }
          }
        }
      }
      if (verbose) {
        cli_end(iul)
        cli_end(ul)
      }
    }
    if (run_checks) {
      if (verbose) cli_progress_step("running checks...", msg_done = "ran checks:")
      repo_manifest[[r]]$repo_checks <- tryCatch(
        check_repository(cr, dataset = dataset_map, verbose = FALSE),
        error = function(e) NULL
      )
      repo_manifest[[r]]$repo_checks <- lapply(repo_manifest[[r]]$repo_checks[
        grep("^summary|^(?:info|warn|fail)_", names(repo_manifest[[r]]$repo_checks))
      ], function(l) {
        if (is.character(l)) l <- sub("^.*/repos/[^/]+/", "", l)
        if (!is.null(names(l))) names(l) <- sub("^.*/repos/[^/]+/", "", names(l))
        l
      })
      if (verbose) {
        cli_progress_done()
        if (length(repo_manifest[[r]]$repo_checks$summary)) {
          print(repo_manifest[[r]]$repo_checks$summary)
          cat("\n")
        }
      }
    }
  }
  if (verbose) {
    if (any(updated)) {
      updated_repos <- repos[updated]
      cli_alert_success("updated data repositor{?ies/y}: {.file {updated_repos}}")
    }
    if (any(dist_updated)) {
      updated_distributions <- repos[dist_updated]
      cli_alert_success("updated distributed file{?s} in: {.file {updated_distributions}}")
    }
    if (any(failed)) {
      failed_repos <- repos[failed]
      cli_alert_danger("failed to retrieve repositor{?ies/y}: {.file {failed_repos}}")
    } else if (!any(updated | dist_updated)) {
      cli_alert_success("all data repositories are up to date")
    }
  }
  if (length(repo_manifest)) {
    su <- names(repo_manifest) %in% repos
    if (any(su)) {
      jsonlite::write_json(repo_manifest[su], manifest_file, auto_unbox = TRUE)
    } else {
      cli_warn("no repos were found in the existing repo manifest")
    }
  }
  init_datacommons(dir, refresh_after = FALSE, verbose = FALSE)
  invisible(repos[updated | dist_updated])
}

init_package <- function(name = "package", dir = ".") {
  dir.create(paste0(dir, "/", name, "/R"), FALSE, TRUE)
  dir.create(paste0(dir, "/", name, "/inst/specs"), FALSE, TRUE)
  dir.create(paste0(dir, "/", name, "/tests/testthat"), FALSE, TRUE)
}

parse_rule <- function(condition) {
  comb_type <- grepl("|", condition, fixed = TRUE)
  conds <- strsplit(gsub("\\s*([&|><=]+|!=+)\\s*", " \\1 ", gsub("=+", "=", condition)), " [&|]+ ")[[1]]
  lapply(conds, function(co) {
    co <- strsplit(co, "\\s")[[1]]
    if (length(co) == 1) co <- c(sub("^!+", "", co), if (grepl("^!\\w", co)) "!" else "", "")
    Filter(function(e) {
      length(e) != 1 || if (is.logical(e)) e else TRUE
    }, if (tolower(co[2]) %in% c("true", "false")) {
      list(
        id = co[1],
        type = if (tolower(co[2]) == "true") "" else "!",
        value = ""
      )
    } else {
      list(
        id = co[1],
        type = co[2],
        value = if (grepl("^\\d+$", co[3])) {
          as.numeric(co[3])
        } else {
          gsub("[\"']", "", co[3])
        },
        any = comb_type
      )
    })
  })
}

process_conditions <- function(conditions, ids, caller) {
  for (i in seq_along(conditions)) {
    if (conditions[i] != "") {
      display <- TRUE
      if (grepl("^[dl][^:]*:", conditions[i], TRUE)) {
        if (grepl("^l", conditions[i], TRUE)) display <- FALSE
        conditions[i] <- sub("^[dl][^:]*:\\s*", "", conditions[i], TRUE)
      }
      caller$rules <- c(caller$rules, list(list(
        condition = parse_rule(conditions[i]),
        effects = if (display) list(display = ids[i]) else list(lock = ids[i])
      )))
    }
  }
}

to_input_row <- function(e) {
  c(
    '<div class="col">', e[2], "</div>",
    '<div class="col">', e[-c(1:2, length(e))], "</div>"
  )
}

make_build_environment <- function() {
  e <- new.env()
  attr(e, "name") <- "community_site_parts"
  e$site_build <- function(...) {}
  e$uid <- 0
  e
}

calculate_sha <- function(file, level) {
  if (Sys.which("openssl") != "") {
    tryCatch(
      strsplit(
        system2("openssl", c("dgst", paste0("-sha", level), shQuote(file)), TRUE), " ",
        fixed = TRUE
      )[[1]][2],
      error = function(e) ""
    )
  } else {
    ""
  }
}

head_import <- function(d, dir = ".") {
  if (!is.null(d$src) && (!d$src %in% c("script.js", "style.css") || (file.exists(paste0(dir, "/docs/", d$src)) &&
    file.size(paste0(dir, "/docs/", d$src))))) {
    paste(c(
      "<", if (d$type == "script") 'script type="application/javascript" src="' else 'link href="', d$src, '"',
      if (!is.null(d$hash)) c(' integrity="', d$hash, '"', ' crossorigin="anonymous"'),
      if (d$type == "stylesheet") {
        c(
          ' rel="', if (!is.null(d$loading)) d$loading else "preload", '" as="style" media="all"',
          ' onload="this.onload=null;this.rel=\'stylesheet\'"'
        )
      },
      if (d$type == "script") {
        if (is.null(d$loading)) {
          " async"
        } else {
          if (d$loading == "") "" else c(" ", d$loading)
        }
      }, ">", if (d$type == "script") "</script>"
    ), collapse = "")
  }
}

make_full_name <- function(filename, variable) {
  sub("^:", "", paste0(sub(
    "^.*[\\\\/]", "",
    gsub("^.*\\d{4}(?:q\\d)?_|\\.\\w{3,4}(?:\\.[gbx]z2?)?$|\\..*$", "", basename(filename))
  ), ":", variable))
}

replace_equations <- function(info) {
  lapply(info, function(e) {
    descriptions <- grep("description", names(e), fixed = TRUE)
    if (length(descriptions)) {
      for (d in descriptions) {
        p <- gregexpr(
          "(?:\\$|\\\\\\[|\\\\\\(|\\\\begin\\{math\\})(.+?)(?:\\$|\\\\\\]|\\\\\\)|\\\\end\\{math\\})(?=\\s|$)",
          e[[d]],
          perl = TRUE
        )[[1]]
        if (p[[1]] != -1) {
          re <- paste("", e[[d]], "")
          fm <- regmatches(e[[d]], p)
          for (i in seq_along(p)) {
            mp <- attr(p, "capture.start")[i, ]
            eq <- substring(e[[d]], mp, mp + attr(p, "capture.length")[i, ] - 1)
            parsed <- tryCatch(katex_mathml(eq), error = function(e) NULL)
            if (!is.null(parsed)) {
              re <- paste(
                strsplit(re, fm[[i]], fixed = TRUE)[[1]],
                collapse = sub("^<[^>]*>", "", sub("<[^>]*>$", "", parsed))
              )
            }
          }
          e[[d]] <- gsub("^ | $", "", re)
        }
      }
    }
    if (is.list(e$categories)) e$categories <- replace_equations(e$categories)
    if (is.list(e$variants)) e$variants <- replace_equations(e$variants)
    e
  })
}

preprocess <- function(l) {
  if (!is.list(l)) l <- sapply(l, function(n) list())
  ns <- names(l)
  for (i in seq_along(l)) {
    name <- if (ns[i] == "blank") "" else ns[i]
    l[[i]]$name <- name
    if (is.null(l[[i]]$default)) l[[i]]$default <- name
  }
  l
}

replace_dynamic <- function(e, p, s, v = NULL, default = "default") {
  m <- gregexpr(p, e)
  if (m[[1]][[1]] != -1) {
    t <- regmatches(e, m)[[1]]
    tm <- structure(gsub("\\{[^.]+\\.?|\\}", "", t), names = t)
    tm <- tm[!duplicated(names(tm))]
    tm[tm == ""] <- default
    for (tar in names(tm)) {
      us <- (if (is.null(v) || substring(tar, 2, 2) == "c") s else v)
      entry <- tm[[tar]]
      if (is.null(us[[entry]]) && grepl("description", entry, fixed = TRUE)) {
        entry <- default <- "description"
      }
      if (is.null(us[[entry]]) && entry == default) entry <- "default"
      if (is.null(us[[entry]])) cli_abort("failed to render measure info from {tar}")
      e <- gsub(tar, us[[entry]], e, fixed = TRUE)
    }
  }
  e
}

prepare_source <- function(o, s, p) {
  if (length(o)) {
    lapply(o, function(e) {
      if (is.character(e) && length(e) == 1) replace_dynamic(e, p, s) else e
    })
  } else {
    list(name = "", default = "")
  }
}

render_info_names <- function(infos) {
  r <- lapply(names(infos), function(n) render_info(infos[n], TRUE))
  structure(rep(names(infos), vapply(r, length, 0)), names = unlist(r))
}

render_info <- function(info, names_only = FALSE) {
  base_name <- names(info)
  base <- info[[1]]
  if (is.null(base$categories) && is.null(base$variants)) {
    return(if (names_only) base_name else info)
  }
  categories <- preprocess(base$categories)
  variants <- preprocess(base$variants)
  base$categories <- NULL
  base$variants <- NULL
  expanded <- NULL
  vars <- strsplit(as.character(outer(
    if (is.null(names(categories))) "" else names(categories),
    if (is.null(names(variants))) "" else names(variants),
    paste,
    sep = "|||"
  )), "|||", fixed = TRUE)
  for (var in vars) {
    cs <- if (var[1] == "") list() else categories[[var[1]]]
    vs <- if (length(var) == 1 || var[2] == "") list() else variants[[var[2]]]
    cs <- prepare_source(cs, vs, "\\{variants?(?:\\.[^}]+?)?\\}")
    vs <- prepare_source(vs, cs, "\\{categor(?:y|ies)(?:\\.[^}]+?)?\\}")
    s <- c(cs, vs[!names(vs) %in% names(cs)])
    p <- "\\{(?:categor(?:y|ies)|variants?)(?:\\.[^}]+?)?\\}"
    key <- replace_dynamic(base_name, p, cs, vs)
    if (names_only) {
      expanded <- c(expanded, key)
    } else {
      expanded[[key]] <- c(
        structure(lapply(names(base), function(n) {
          e <- base[[n]]
          if (is.character(e) && length(e) == 1) e <- replace_dynamic(e, p, cs, vs, n)
          e
        }), names = names(base)),
        s[!names(s) %in% c(
          "default",
          "name",
          if (any(base[c("long_description", "short_description")] != "")) "description",
          names(base)
        )]
      )
    }
  }
  expanded
}

get_git_remote <- function(config) {
  if (file.exists(config)) {
    conf <- readLines(config)
    branch <- grep("[branch", conf, fixed = TRUE, value = TRUE)
    url <- grep("url =", conf, fixed = TRUE, value = TRUE)
    if (length(branch) && length(url)) {
      paste0(
        gsub("^.+=\\s|\\.git", "", url[[1]]), "/blob/",
        gsub('^[^"]+"|"\\]', "", branch[[1]])
      )
    }
  }
}

attempt_read <- function(file, id_col) {
  tryCatch(
    {
      sep <- if (grepl(".csv", file, fixed = TRUE)) "," else "\t"
      cols <- scan(file, "", nlines = 1, sep = sep, quiet = TRUE)
      types <- rep("?", length(cols))
      types[cols == id_col] <- "c"
      read_delim_arrow(
        gzfile(file), sep,
        col_names = cols, col_types = paste(types, collapse = ""), skip = 1
      )
    },
    error = function(e) NULL
  )
}

#' @rdname download_dataverse_data
#' @return \code{download_dataverse_info}: A list with the dataset's metadata.
#' @export

download_dataverse_info <- function(id, server = NULL, key = NULL, refresh = FALSE, branch = NULL,
                                    version = ":latest", verbose = FALSE) {
  if (missing(id)) cli_abort("an id must be specified")
  if (!grepl("doi", tolower(id), fixed = TRUE) && (grepl("github", id, fixed = TRUE) || grepl("^[^/]+/[^/]+$", id))) {
    if (is.null(branch) && grepl("@|/tree/", id)) {
      branch <- regmatches(id, regexec("(?:@|tree/)([^/]+)", id))[[1]][2]
      if (is.na(branch)) branch <- NULL
    }
    id <- regmatches(id, regexec("^(?:.*github\\.com/)?([^/]+/[^/@]+)", id))[[1]][2]
    repo <- tryCatch(jsonlite::read_json(
      paste0("https://api.github.com/repos/", id)
    ), error = function(e) NULL)
    if (!is.null(repo$default_branch)) {
      if (verbose) cli_alert_info("getting ID from Github repository {id}")
      dataset_doi <- NULL
      tryCatch(
        load(file(paste0(
          "https://raw.githubusercontent.com/", id, "/",
          if (is.null(branch)) repo$default_branch else branch, "/R/sysdata.rda"
        ))),
        error = function(e) NULL
      )
      if (!is.null(dataset_doi)) {
        id <- dataset_doi[[1]]
      } else {
        cli_abort(paste0(
          "{.arg id} points to a Github repository that does not have an appropriate",
          "{.file /R/sysdata.rda} file"
        ))
      }
    }
  }
  id <- sub("^(http|doi)[^\\d]*", "", id, perl = TRUE)
  temp <- paste0(tempdir(), "/", gsub("\\W", "", id), ".json")
  if (refresh) unlink(temp)
  if (!file.exists(temp)) {
    if (is.null(server)) {
      server <- if (Sys.which("curl") != "") {
        if (verbose) cli_alert_info("getting server from DOI ({id}) redirect")
        tryCatch(
          {
            url <- gsub("<[^>]*>", "", system2("curl", paste0("https://doi.org/", id), stdout = TRUE)[5])
            if (grepl("^http", url)) gsub("^https?://|/citation.*$", "", url) else NA
          },
          error = function(e) {
            if (verbose) cli_alert_info("failed to get server from DOI ({id}) redirect")
            NA
          }
        )
      } else {
        NA
      }
      if (is.na(server)) {
        if (verbose) cli_alert_info("looking for server in fall-backs")
        server <- Sys.getenv("DATAVERSE_SERVER")
        if (server == "") {
          server <- getOption("dataverse.server")
          if (is.null(server)) server <- "dataverse.lib.virginia.edu"
        }
      }
    }
    if (is.null(key)) {
      if (verbose) cli_alert_info("looking for API key in fall-backs")
      key <- Sys.getenv("DATAVERSE_KEY", getOption("dataverse.key", ""))
    }
    if (!grepl("://", server, fixed = TRUE)) server <- paste0("https://", server)
    server <- sub("/api/.*$", "/", gsub("//+$", "/", paste0(server, "/")))
  }
  res <- tryCatch(
    {
      if (!file.exists(temp)) {
        if (verbose) cli_alert_info("downloading dataset metadata for {id} from {server}")
        if (is.character(key) && key != "") {
          if (verbose) cli_alert_info("trying with key")
          download.file(
            paste0(server, "api/datasets/:persistentId/versions/", version, "?persistentId=doi:", id), temp,
            quiet = TRUE, headers = c("X-Dataverse-key" = key)
          )
          if (file.exists(temp)) {
            res <- jsonlite::read_json(temp)
            if (is.null(res$data)) {
              unlink(temp)
              stop(res$message)
            }
            res <- res$data
          } else {
            stop("download failed")
          }
        } else {
          if (verbose) cli_alert_info("trying without key")
          res <- jsonlite::read_json(
            paste0(server, "api/datasets/:persistentId/versions/", version, "?persistentId=doi:", id)
          )$data
        }
        res$server <- server
        jsonlite::write_json(res, temp, auto_unbox = TRUE)
        res
      } else {
        if (verbose) cli_alert_info("reading in existing metadata for {id}")
        jsonlite::read_json(temp)
      }
    },
    error = function(e) e$message
  )
  if (is.character(res)) {
    if (file.exists(temp)) {
      cli_abort(cli_bullets(c(
        x = "downloaded the metadata, but failed to read it in: {res}",
        i = paste0("check {.file ", temp, "}")
      )))
    } else {
      cli_abort(cli_bullets(c(
        x = "failed to retrive info",
        i = paste0(
          "tried for this dataset: {.url ", server, "dataset.xhtml?persistentId=doi:", id, "}"
        ),
        if (length(res)) c("!" = paste("got this error:", res))
      )))
    }
  }
  if (is.null(res$latestVersion)) res$latestVersion <- res
  res
}

#' Create a new package function
#'
#' Create initial script and test files for a function that is to be added to a package.
#'
#' @param name Name of the function. Should start with the function's category, followed by a specific name,
#' separated by an underscore (\code{'_'}) (e.g., \code{'init_function'}).
#' @param dir Path to the package's development directory; default is the current working directory.
#' @param overwrite Logical; if \code{TRUE}, replaces existing files with templates.
#' @examples
#' \dontrun{
#'
#' # creates a skeleton for a `measure_new` function
#' init_function("measure_new")
#' }
#' @return Creates files in \code{dir/R} and \code{dir/tests/testthat}, attempts to navigate to the code file,
#' and returns a character vector to their paths.
#' @export

init_function <- function(name, dir = ".", overwrite = FALSE) {
  if (missing(name)) cli_abort("{.arg name} must be specified")
  name <- sub("\\.[Rr]$", "", name[[1]])
  dir <- paste0(normalizePath(dir, "/"), "/")
  if (!check_template("package", dir = dir)$exists) {
    cli_abort(paste(
      "{.arg dir} must be a package directory,",
      "but {.code check_template('package')} failed"
    ))
  }
  paths <- paste0(dir, c("R/", "tests/testthat/test-"), name, ".R")
  if (!overwrite && any(file.exists(paths))) cli_abort("files exist -- set overwrite to {.code TRUE} to overwrite them")
  if (!grepl("_", name, fixed = TRUE)) cli_abort("name should be in a {.emph prefix_suffix} format")
  writeLines(paste0(
    "#' <template: Short, high-level description of function.>",
    "\n#'\n#' <template: Full description of function.>\n#'",
    "\n#' @param argument <template: Argument description.>",
    "\n#' @examples\n#' \\dontrun{",
    "\n#' <template: a working example for illustration; add outside of \\dontrun{} when possible>\n#' }",
    "\n#' @return <template: Description of what is returned.>",
    "\n#' @export",
    "\n\n", name, " <- function(argument){\n\n}"
  ), paths[1])
  writeLines(paste0("test_that('a test has been written for ", name, "', {\n  expect_true(FALSE)\n})"), paths[2])
  msg <- c("created files for function {name}:", paste0("{.file ", paths, "}"))
  names(msg) <- c("v", rep("*", length(paths)))
  if (interactive()) {
    cli_bullets(msg)
    navigateToFile(paths[1])
  }
  invisible(paths)
}

#' Create a website
#'
#' Create a repository for a static website for data documentation and exploration.
#'
#' @param dir Directory in which to create the site's structure. Will be created if it does not exist.
#' @param title Title of the site.
#' @param template Name of a template to use, which are pre-constructed \code{site.R} and \code{build.R}
#' files. If \code{FALSE} or not found, no such files will be made.
#' @param with_data Logical; if \code{TRUE}, a data sub-directory and datapackage will be created.
#' @param node_project Logical; if \code{TRUE}, includes files used to run the site from a Node.js server.
#' @param include_api Logical; if \code{TRUE}, will make a \code{netlify.toml} config file to specify the
#' function directory for the API function, if included by \code{\link{site_build}}.
#' @param overwrite Logical; if \code{TRUE}, will overwrite existing site files in \code{dir}.
#' @param quiet Logical; if \code{TRUE}, suppresses messages and does not navigate to the file when finished.
#' @examples
#' \dontrun{
#' # initialize site in the current working directory
#' init_site(".")
#' }
#' @return Path to the created site directory.
#' @export

init_site <- function(dir, title = "app", template = "mtcars", with_data = FALSE, node_project = FALSE,
                      include_api = FALSE, overwrite = FALSE, quiet = !interactive()) {
  if (missing(dir)) cli_abort('{.arg dir} must be speficied (e.g., dir = ".")')
  check <- check_template("site", dir = dir)
  if (!quiet && check$exists && !overwrite) {
    cli_bullets(c(`!` = "site files already exist", i = "add {.code overwrite = TRUE} to overwrite them"))
  }
  dir <- normalizePath(paste0(dir, "/", check$spec$dir), "/", FALSE)
  dir.create(dir, FALSE, TRUE)
  dir <- normalizePath(dir, "/", FALSE)
  paths <- paste0(dir, "/", c(
    "README.md", "site.R", "package.json", "server.js", ".gitignore", "build.R",
    "project.Rproj", "netlify.toml"
  ))
  if (overwrite) unlink(paths, TRUE)
  if (!file.exists(paths[1])) {
    writeLines(c(
      paste("#", title),
      "<template: Describe the site>",
      "\n## Run",
      "```R",
      '# remotes::install_github("uva-bi-sdad/community")',
      "library(community)",
      "\n# from the site directory:",
      'site_build(".")',
      "```"
    ), paths[1])
  }
  template <- paste0(path.package("community"), c("/inst", ""), "/templates/", template, "/")
  template <- template[which(file.exists(template))[1]]
  if (!is.na(template)) {
    if (!file.exists(paths[2])) file.copy(paste0(template, "site.R"), paths[2])
    if (!file.exists(paths[6])) file.copy(paste0(template, "build.R"), paths[6])
  }
  if (node_project && !file.exists(paths[3])) {
    jsonlite::write_json(list(
      name = gsub("\\s+", "_", tolower(title)),
      version = "1.0.0",
      description = "",
      main = "server.js",
      directories = list(doc = "docs"),
      scripts = list(start = "node server.js"),
      dependencies = list(express = "latest"),
      author = "",
      license = "ISC"
    ), paths[3], auto_unbox = TRUE, pretty = TRUE)
  }
  if (node_project && !file.exists(paths[4])) {
    writeLines(c(
      "'use strict'",
      "const express = require('express'), app = express()",
      "app.use(express.static('docs'))",
      "app.listen(3000, function () {",
      "  console.log('listening on port 3000')",
      "})"
    ), paths[4])
  }
  if (!file.exists(paths[5])) {
    writeLines(c(
      ".Rproj.user",
      ".Rhistory",
      ".Rdata",
      ".httr-oauth",
      ".DS_Store",
      ".netlify",
      "*.Rproj",
      "node_modules",
      "package-lock.json",
      "docs/dist"
    ), paths[5])
  }
  if (!file.exists(paths[7]) && !any(grepl("\\.Rproj$", list.files(dir)))) writeLines("Version: 1.0\n", paths[7])
  if (include_api && !file.exists(paths[8])) {
    writeLines(c(
      "[build]",
      "  publish = 'docs'",
      "[[redirects]]",
      "  from = '/api'",
      "  to = '/.netlify/functions/api'",
      "  status = 200",
      "[functions]",
      "  directory = 'docs/functions'"
    ), paths[8])
  }
  dir.create(paste0(dir, "/docs"), FALSE)
  dir.create(paste0(dir, "/docs/functions"), FALSE)
  docs <- grep("/docs/", check$files, fixed = TRUE, value = TRUE)
  if (any(!file.exists(docs))) file.create(docs[!file.exists(docs)])
  if (with_data && !file.exists(paste0(dir, "/docs/data/datapackage.json"))) {
    dir.create(paste0(dir, "/docs/data"), FALSE)
    init_data(title, dir = paste0(dir, "/docs/data"), quiet = TRUE)
  }
  if (!quiet) {
    cli_bullets(c(
      v = "created a site skeleton for {title}:",
      "*" = paste0("{.path ", normalizePath(dir, "/", FALSE), "}")
    ))
    if (file.exists(paths[2])) navigateToFile(paths[2])
  }
  invisible(dir)
}

#' Add a map to a webpage
#'
#' Adds a Leaflet map to a webpage, based on specified or selected inputs.
#'
#' @param shapes A list or list of lists specifying GeoJSON files. Each list should have at least
#' a \code{url} entry (the URL of the file), and will need a \code{name} entry (associating it
#' with one of the site's datasets) if the site has multiple datasets. The file's features
#' must each have a \code{properties} field containing an ID found in the data -- by default
#' this is assumed to be called \code{"geoid"}, but this can be specified with an \code{id_property}
#' entry in the list. For example \code{shapes = list(name = "data", }\code{
#' url = "https://example.com/shapes.geojson", id_property = "id")}. A \code{time} entry can also
#' specify different maps for the same dataset, based on the selected time, along with a \code{resolution}
#' entry to specify how to match the year; either \code{"decade"} (default) or \code{"exact"}.
#' @param overlays additional layers to add to the map, based on the selected variable; a list or list of
#' lists with entries at least for \code{variable} (name of the variable associated with the layer) and
#' \code{source} (path to the layer file, or a list with entries including \code{url} and
#' \code{time}). Entries can also include a \code{filter} entry, with a list or list of lists of conditions,
#' including entries for \code{feature} (name of the feature on which to condition entity inclusion),
#' \code{operator}, and \code{value}.
#' @param color The name of a variable, or id of a variable selector, to be used to color polygons.
#' @param color_time The ID of a selector to specify which timepoint of \code{color} to use.
#' @param dataview The ID of an \code{\link{input_dataview}} component.
#' @param id Unique ID for the map.
#' @param click The ID of an input to set to a clicked polygon's ID.
#' @param subto A vector of output IDs to receive hover events from.
#' @param background_shapes The name of a dataset (shapes) to show within a selection, regardless of
#' selected dataset. Useful to show lower-level regions within higher-level regions.
#' @param options A list of configuration options, potentially extracted from a saved leaflet object (see
#' \href{https://leafletjs.com/reference-1.7.1.html#map-example}{Leaflet documentation}).
#' @param overlays_from_measures Logical; if \code{TRUE}, will look for overlay information in
#' measurement information.
#' @param tiles A list or list of lists containing provider information (see
#' \href{https://leaflet-extras.github.io/leaflet-providers/preview/}{leaflet providers}; e.g.,
#' \code{list(}\code{url = "https://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png"}, \code{options = list(maxZoom = 19))}).
#' @param attribution A list with tile attribution information to be included in a credits section. To add
#' attributions to the map, include them in \code{tile}'s \code{options} list.
#' @examples
#' output_map()
#' @return A character vector of the content to be added.
#' @export

output_map <- function(shapes = NULL, overlays = NULL, color = NULL, color_time = NULL, dataview = NULL,
                       id = NULL, click = NULL, subto = NULL, background_shapes = NULL,
                       options = list(), overlays_from_measures = TRUE, tiles = list(
                         url = "https://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png",
                         options = list(maxZoom = 19)
                       ), attribution = list(
                         name = "OpenStreetMap",
                         url = "https://www.openstreetmap.org/copyright"
                       )) {
  caller <- parent.frame()
  building <- !is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts"
  if (is.null(id)) id <- paste0("map", caller$uid)
  if (building) {
    caller$dependencies$leaflet_style <- list(
      type = "stylesheet",
      src = "https://cdn.jsdelivr.net/npm/leaflet@1.9.4/dist/leaflet.min.css",
      hash = "sha384-EdLG5Q0/L1OytQXhWSU1bWVqvLMxlmdSRaA09iy8FGYjlpP7vnB3MueQ6ZloG9oF"
    )
    caller$dependencies$leaflet <- list(
      type = "script",
      src = "https://cdn.jsdelivr.net/npm/leaflet@1.9.4/dist/leaflet.min.js",
      hash = "sha384-u5N8qJeJOO2iqNjIKTdl6KeKsEikMAmCUBPc6sC6uGpgL34aPJ4VgNhuhumedpEk"
    )
    options$overlays_from_measures <- overlays_from_measures
    options$subto <- if (!is.null(subto) && length(subto) == 1) list(subto) else subto
    if (is.null(options[["center"]])) options$center <- c(40, -95)
    if (is.null(options[["zoom"]])) options$zoom <- 4
    if (!is.null(background_shapes) && is.null(options[["background_shapes"]])) {
      options$background_shapes <- background_shapes
    }
    if (is.character(shapes)) shapes <- lapply(shapes, function(s) list(url = s))
    if (is.list(shapes) && !is.list(shapes[[1]])) shapes <- list(shapes)
    snames <- names(shapes)
    for (i in seq_along(shapes)) {
      if (!is.null(snames[i])) shapes[[i]]$name <- snames[i]
      if (is.null(shapes[[i]]$id_property)) shapes[[i]]$id_property <- "geoid"
    }
    if (!is.null(overlays)) {
      if (is.character(overlays)) overlays <- lapply(overlays, function(s) list(url = s))
      if (is.list(overlays) && !is.list(overlays[[1]])) overlays <- list(overlays)
      snames <- names(overlays)
      for (i in seq_along(overlays)) {
        if (!is.null(snames[i])) overlays[[i]]$name <- snames[i]
      }
    }
    caller$map[[id]] <- Filter(length, list(
      shapes = unname(shapes), overlays = unname(overlays), options = options, tiles = tiles
    ))
  }
  r <- paste(c(
    '<div class="auto-output leaflet"',
    if (!is.null(dataview)) paste0('data-view="', dataview, '"'),
    if (!is.null(click)) paste0('data-click="', click, '"'),
    if (!is.null(color)) paste0('data-color="', color, '"'),
    if (!is.null(color_time)) paste0('data-colorTime="', color_time, '"'),
    paste0('id="', id, '"'),
    'data-autoType="map"></div>'
  ), collapse = " ")
  if (building) {
    caller$content <- c(caller$content, r)
    caller$credits$leaflet <- list(
      name = "Leaflet",
      url = "https://leafletjs.com",
      version = "1.9.4",
      description = "A JS library for interactive maps"
    )
    if (!missing(attribution) || missing(tiles)) {
      if (!is.null(attribution$name)) {
        caller$credits[[attribution$name]] <- attribution
      } else if (!is.null(attribution[[1]]$name)) {
        for (a in attribution) caller$credits[[a$name]] <- a
      }
    }
    caller$uid <- caller$uid + 1
  }
  r
}

#' Adds a menu to a website
#'
#' Adds a section to arrange inputs, that can optionally be collapsed, and positioned on any side.
#'
#' @param ... Elements to appear in the menu.
#' @param position A character indicating which side to place the menu on; one of
#' \code{"top"}, \code{"right"}, \code{"bottom"}, or \code{"left"}.
#' @param width Width of the menu, if \code{position} is \code{"left"} or \code{"right"}.
#' @param height Height of the menu, if \code{position} is \code{"top"} or \code{"bottom"}.
#' @param collapsible Logical; if \code{FALSE}, removes the button to open or close the menu.
#' @param default_open Logical; if \code{TRUE}, the menu will start open.
#' @param wraps Logical or character (\code{"row" or "col"}); if \code{FALSE},
#' elements of the menu will not be wrapped in row or column elements.
#' @param sizes The relative size of each wrapper, between 1 and 12, or \code{"auto"}; default is equal size.
#' @param breakpoints Bootstrap breakpoint of each wrapper; one of \code{""} (extra small), \code{"sm"},
#' @param conditions A character for each element representing the conditions in which that should be showing
#' (e.g., \code{c("", "input_a == a", "")}); \code{""} means the element's display is not conditional.
#' Adding \code{"lock: "} before the condition will disable inputs rather than hide the element.
#' @examples
#' \dontrun{
#' page_menu(
#'   input_select("menu item", c("a", "b", "c"))
#' )
#' }
#' @return A character vector of the content to be added.
#' @export

page_menu <- function(..., position = "right", width = "300px", height = NULL, collapsible = TRUE,
                      default_open = FALSE, wraps = TRUE, sizes = NA, breakpoints = NA, conditions = "") {
  caller <- parent.frame()
  building <- !is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts"
  parts <- new.env()
  attr(parts, "name") <- "community_site_parts"
  parts$uid <- caller$uid
  elements <- substitute(...(), environment())
  n <- length(elements)
  vertical <- position %in% c("left", "right")
  wraps <- rep_len(if (length(wraps) == 1 && !is.character(wraps) && wraps) {
    if (vertical) "row" else "col"
  } else {
    wraps
  }, n)
  sizes <- rep_len(sizes, n)
  breakpoints <- rep_len(breakpoints, n)
  conditions <- rep_len(conditions, n)
  ids <- paste0("menu", parts$uid, seq_len(n))
  parts$uid <- parts$uid + 1
  if (is.numeric(width)) width <- paste0(width, "px")
  if (is.numeric(height)) height <- paste0(height, "px")
  r <- c(
    paste0(c(
      '<div data-state="', if (default_open) "open" else "closed", '" class="menu-wrapper menu-', position, '"',
      c(
        ' style="', position, ": ", if (default_open) 0 else paste0("-", width), "; ",
        if (!is.null(height)) c("; height: ", height),
        '"'
      ),
      ">"
    ), collapse = ""),
    paste0(
      '<div class="menu', if (vertical) " col" else " row",
      if (!default_open) " hidden", " menu-", position, '">'
    ),
    unlist(lapply(seq_len(n), function(i) {
      c(
        if (!is.na(wraps[i])) {
          paste(c(
            '<div class="', wraps[i],
            if (!is.na(breakpoints[i])) c("-", breakpoints[i]),
            if (!is.na(sizes[i])) c("-", sizes[i]),
            '"', if (conditions[i] != "") paste0(' id="', ids[i], '"'), ">"
          ), collapse = "")
        },
        eval(elements[[i]], parts),
        if (!is.na(wraps[i])) "</div>"
      )
    }), use.names = FALSE),
    "</div>",
    if (collapsible) paste0('<button type="button" class="menu-toggle" title="', position, ' menu"></button>'),
    "</div>"
  )
  if (building) {
    caller$body <- c(caller$body, r)
    for (n in names(parts)) if (n != "content") caller[[n]] <- c(caller[[n]], parts[[n]])
    caller$uid <- parts$uid
    process_conditions(conditions, ids, caller)
  }
  r
}

#' Create new template initializer
#'
#' Create a new initializer function, and a spec file against which initialized templates can be checked.
#'
#' @param name Name of the template to be checked.
#' @param files List of paths to required files, relative to dir.
#' \code{"{name}"} included in a path string will be replaced with \code{name} during checks.
#' A list within the main list is treated as either alternatives files (when there is a single character vector),
#' or alternative strict sets of files (must contain all of at least one list;
#' when there are multiple character vectors).
#' @param dir Package directory.
#' @param spec_dir Parent directory of the \code{files}.
#' @param context name of the template's context: itself, or another templated structure.
#' @param overwrite logical; if \code{TRUE}, new files will replace existing ones.
#' @examples
#' \dontrun{
#'
#' # creates a version of the function spec.
#' init_template("function", list("R/{name}.R", "tests/testthat/text-{name}.R"))
#'
#' # creates a version of the shiny function, showing alternative sets
#' init_template("shiny", list(
#'   list(
#'     c("ui.R", "server.R"),
#'     "app.R"
#'   ),
#'   "README.md"
#' ), spec_dir = "app")
#' }
#' @return Creates a name.json file (in \code{dir/inst/specs} if it exists, or the current working directory),
#' and invisibly returns its path.
#' @export

init_template <- function(name, files, dir = ".", spec_dir = ".", context = name, overwrite = FALSE) {
  if (missing(name)) cli_abort("{.arg name} must be specified")
  if (missing(files)) cli_abort("{.arg files} must be specified")
  name <- sub("^init_", "", name)
  dir <- normalizePath(dir, "/", FALSE)
  spec <- list(
    name = name,
    context = context,
    dir = spec_dir,
    files = files
  )
  test_path <- paste0(dir, "/tests/testthat/test-init_", name, ".R")
  template_test <- file.exists(test_path)
  init_function(paste0("init_", name), dir = dir, overwrite = overwrite)
  if (overwrite || !template_test) {
    writeLines(paste0(
      "test_that(\"check_template passes\", {",
      "\n  dir <- tempdir(TRUE)",
      "\n  on.exit(unlink(dir, TRUE, TRUE))",
      if (spec$name != spec$context) {
        paste0("\n  init_", spec$context, "(\"test_context\", dir = dir)\n  dir <- paste0(dir, \"/test_context\")")
      },
      "\n  init_", name, "(\"test_", name, "\", dir = dir)",
      "\n  expect_true(check_template(\"", name, "\", \"test_", name, "\", dir = dir)$exists)",
      "\n})",
      sep = ""
    ), test_path)
  }
  path <- normalizePath(paste0(
    dir,
    if (file.exists(paste0(dir, "/inst"))) "/inst",
    "/specs/",
    name,
    ".json"
  ), "/", FALSE)
  if (overwrite || !file.exists(path)) jsonlite::write_json(spec, path, auto_unbox = TRUE)
  if (interactive()) {
    cli_bullets(c(v = "created a spec file for {name}:", "*" = paste0("{.file ", path, "}")))
  }
  invisible(path)
}

#' Add a button toggle group to a website
#'
#' Adds a group of radio-like buttons, where only one can be selected at a time.
#'
#' @param label Label of the input for the user.
#' @param options A vector of options, the name of a variable from which to pull levels, or either \code{"datasets"}
#' or \code{"variables"} to select names of datasets or variables.
#' @param default Which of the options to default to; either its index or value.
#' @param display A display version of the options.
#' @param id Unique id of the element to be created.
#' @param ... Additional attributes to set on the element.
#' @param button_class Class name to add to each label (which appears as the button).
#' @param variable The name of a variable from which to get levels (overwritten by \code{depends}).
#' @param dataset The name of an included dataset, where \code{variable} should be looked for; only applies when
#' there are multiple datasets with the same variable name.
#' @param depends The id of another input on which the options depend; this will take president over \code{dataset}
#' and \code{variable}, depending on this type of input \code{depends} points to.
#' @seealso For a button to set an input or trigger a function, see \code{\link{input_button}}.
#' @examples
#' \dontrun{
#' input_buttongroup()
#' }
#' @return A character vector of the contents to be added.
#' @export

input_buttongroup <- function(label, options, default = 0, display = options, id = label, ..., button_class = NULL,
                              variable = NULL, dataset = NULL, depends = NULL) {
  if (!is.character(options) && is.character(default)) {
    default <- which((if (default %in% display) display else options) == default)
  }
  id <- gsub("\\s", "", id)
  a <- list(...)
  r <- c(
    '<div class="wrapper buttongroup-wrapper">',
    paste0('<label for="', id, '">', label, "</label>"),
    paste0(
      '<div class="auto-input btn-group" role="group" data-autoType="buttongroup" id="', id, '" ',
      if (is.character(options) && length(options) == 1) paste0('data-optionSource="', options, '"'),
      if (!is.null(default)) paste0(' data-default="', default, '"'),
      if (!is.null(depends)) paste0(' data-depends="', depends, '"'),
      if (!is.null(dataset)) paste0(' data-dataset="', dataset, '"'),
      if (!is.null(variable)) paste0(' data-variable="', variable, '"'),
      if (length(a)) unlist(lapply(seq_along(a), function(i) paste0(" ", names(a)[i], '="', a[[i]], '"'))),
      ">"
    ),
    if (length(options) > 1) {
      unlist(lapply(seq_along(options), function(i) {
        c(
          paste0(
            '<input type="radio" class="btn-check" autocomplete="off" name="',
            id, '_options" id="', id, "_option", i, '" value="',
            options[i], '"', if (i == default) " checked", ">"
          ),
          paste0(
            '<label class="btn', if (!is.null(button_class)) paste("", button_class),
            '" for="', id, "_option", i, '">', display[i], "</label>"
          )
        )
      }), use.names = FALSE)
    },
    "</div>",
    "</div>"
  )
  caller <- parent.frame()
  if (!is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts") {
    caller$content <- c(caller$content, r)
  }
  r
}

#' Adds a legend to a website
#'
#' Adds a legend based on a specified color palette.
#'
#' @param palette Name of an included color palette, or palette selection input;
#' for discrete scales, one of \code{"rdylbu7"}, \code{"orrd7"}, \code{"gnbu7"},
#' \code{"brbg7"}, \code{"puor7"}, \code{"prgn6"}, \code{"reds5"}, \code{"greens5"}, \code{"greys4"}, \code{"paired4"} (from
#' \href{https://colorbrewer2.org}{colorbrewer}); for continuous scales, one of \code{"grey"}, \code{"brown"}, \code{"purple"},
#' \code{"prgn"}, \code{"puor"}, \code{"rbbu"}, \code{"prgn"}, \code{"vik"} (default), or \code{"lajolla"}.
#' @param variable Name of a variable or ID of a variable selector to display values of. Defaults to
#' the \code{y} variable of \code{dataview} if one is specified.
#' @param dataview The ID of an \code{\link{input_dataview}} component.
#' @param id Unique ID of the legend element.
#' @param subto A vector of output IDs to receive hover events from.
#' @param click The ID of an input to set to an entity's ID near the current cursor location on the current scale.
#' @param class Class names to add to the legend element.
#' @param show_na Logical; if \code{FALSE}, does not add the separate section showing the color of missing values.
#' @examples
#' output_legend()
#' @return A character vector of the contents to be added.
#' @export

output_legend <- function(palette = "", variable = NULL, dataview = NULL, id = NULL,
                          click = NULL, subto = NULL, class = "", show_na = TRUE) {
  caller <- parent.frame()
  building <- !is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts"
  if (is.null(id)) id <- paste0("legend", caller$uid)
  r <- c(
    if (show_na) {
      c(
        '<div class="legend-wrap">',
        '<div class="legend-na">',
        '<div class="legend-ticks"></div>',
        '<div class="legend-scale"><span class="na"></span></div>',
        '<div class="legend-summary"><p>NA</p></div>',
        "</div>"
      )
    },
    paste(c(
      '<div id="', id, '" data-autoType="legend" class="auto-output legend',
      if (class != "") c(" ", class), '"',
      if (!is.null(variable)) paste0(' data-variable="', variable, '"'),
      if (!is.null(dataview)) paste0(' data-view="', dataview, '"'),
      if (!is.null(click)) paste0(' data-click="', click, '"'),
      ">"
    ), collapse = ""),
    '<div class="legend-ticks"></div>',
    '<div class="legend-scale"></div>',
    '<div class="legend-summary"></div>',
    "</div>",
    if (show_na) "</div>"
  )
  if (building) {
    caller$legend[[id]] <- list(palette = palette, subto = subto)
    caller$content <- c(caller$content, r)
    caller$uid <- caller$uid + 1
  }
  r
}

#' Add a range slider to a website
#'
#' Adds an input to select within the entered range.
#'
#' @param label Label of the input for the user.
#' @param id Unique id of the element to be created.
#' @param ... Additional attributes to set on the element.
#' @param min The smallest value in the range.
#' @param max The largest value in the range.
#' @param step How much moving the handle adjusts the selected value.
#' @param default Starting value of the slider handle.
#' @param note Text to display as a tooltip for the input.
#' @param dataset The name of an included dataset, where \code{variable} should be looked for; only applies when
#' there are multiple datasets with the same variable name.
#' @param depends The id of another input on which the options depend; this will take president over \code{dataset}
#' and \code{variable}, depending on this type of input \code{depends} points to.
#' @examples
#' \dontrun{
#' input_slider()
#' }
#' @return A character vector of the contents to be added.
#' @export

input_slider <- function(label, id = label, ..., min = 0, max = 1, step = 1, default = max,
                         note = NULL, dataset = NULL, depends = NULL) {
  id <- gsub("\\s", "", id)
  a <- list(...)
  r <- c(
    '<div class="wrapper slider-wrapper">',
    paste0('<label class="form-label" for="', id, '">', label, "</label>"),
    paste0(
      '<input role="slider" type="range" class="auto-input form-range" data-autoType="number" id="', id, '" data-default=', default,
      " step=", step, " min=", min, " max=", max,
      if (!is.null(depends)) {
        paste0(' data-depends="', depends, '"')
      } else if (!is.null(dataset)) paste0('data-dataset="', dataset, '"'),
      if (length(a)) unlist(lapply(seq_along(a), function(i) paste0(" ", names(a)[i], '="', a[[i]], '"'))),
      if (!is.null(note)) paste0(' aria-description="', note, '"'),
      ">"
    ),
    paste0('<div class="slider-display"><span>', default, "</span></div>"),
    "</div>"
  )
  caller <- parent.frame()
  if (!is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts") {
    caller$content <- c(caller$content, r)
  }
  r
}

#' Initialize a Data Commons
#'
#' Initialize a project to keep track of separate dataset repositories and distributions.
#'
#' @param dir Path to the desired data commons directory.
#' @param name Name of the data commons.
#' @param repos A vector of repository names to add to \code{commons.json}.
#' @param default_user GitHub username to prepend to repository names if needed.
#' @param remote Name of the data commons' GitHub repository (\code{"username/reponame"}).
#' @param url URL of the data commons' monitor site; defaults to the GitHub Pages URL associated with \code{remote}
#' if provided (\code{"https://username.github.io/reponame"}).
#' @param refresh_after Logical; if \code{FALSE}, will not run \code{\link{datacommons_refresh}}
#' after initiating the project. Defaults to \code{TRUE} when first creating a data commons project.
#' @param overwrite Logical; if \code{TRUE}, will overwrite existing datacommons files in \code{dir}.
#' The included \code{.js} and \code{.sh} files are always rewritten, and if \code{name},
#' \code{repos}, or \code{default_user} is specified, \code{commons.json} will also be rewritten
#' regardless of \code{overwrite}.
#' @param serve Logical; if \code{TRUE}, will serve the \code{docs} directory.
#' @param host The IPv4 address to listen to if \code{serve} is \code{TRUE}; defaults to \code{"127.0.0.1"}.
#' @param port The port to listen on if \code{serve} is \code{TRUE}; defaults to 3000.
#' @param use_local Logical; if \code{TRUE}, will use a \code{datacommons.js} script located in
#' a local \code{dist/docs/dev} directory, relative to \code{dir}.
#' @param verbose Logical; if \code{FALSE}, suppresses messages.
#' @details
#' The shell scripts included in the project's \code{scripts} directory can be used to retrieve
#' and update repositories over SSH.
#'
#' This will clone or pull repositories listed in \code{scripts/repos.txt}:
#' \code{sh scripts/get_repos.sh}
#'
#' This will add, commit, and push all changes in all repositories:
#' \code{sh scripts/update_repos.sh "commit message"}
#' @examples
#' \dontrun{
#' init_datacommons(
#'   "../datacommons",
#'   name = "Data Commons",
#'   remote = ""
#' )
#' }
#' @return Path to the datacommons directory.
#' @export

init_datacommons <- function(dir, name = "Data Commons", repos = NULL, default_user = "",
                             remote = NULL, url = NULL, refresh_after = FALSE, overwrite = FALSE, serve = FALSE,
                             host = "127.0.0.1", port = 3000, use_local = FALSE, verbose = interactive()) {
  if (missing(dir)) cli_abort('{.arg dir} must be speficied (e.g., dir = ".")')
  check <- check_template("datacommons", dir = dir)
  if (missing(refresh_after) && !check$exists) refresh_after <- TRUE
  odir <- substitute(dir)
  dir <- normalizePath(paste0(dir, "/", check$spec$dir), "/", FALSE)
  dir.create(paste0(dir, "/repos"), FALSE, TRUE)
  dir.create(paste0(dir, "/manifest"), FALSE)
  dir.create(paste0(dir, "/cache"), FALSE)
  dir.create(paste0(dir, "/views"), FALSE)
  dir.create(paste0(dir, "/docs"), FALSE)
  dir.create(paste0(dir, "/scripts"), FALSE)
  paths <- paste0(dir, "/", c(
    "commons.json", "README.md", ".gitignore", "project.Rproj",
    "scripts/repos.txt", "scripts/get_repos.sh", "scripts/update_repos.sh",
    "docs/index.html", "docs/request.js"
  ))
  if (overwrite) unlink(paths, TRUE)
  if (
    file.exists(paths[5]) && (!length(repos) ||
      (file.exists(paths[1]) && file.mtime(paths[5]) > file.mtime(paths[1])))
  ) {
    repos <- unique(c(repos, readLines(paths[5], warn = FALSE)))
  }
  if (file.exists(paths[1])) {
    existing <- jsonlite::read_json(paths[1])
    if (missing(name)) name <- existing$name
    if (!length(repos)) repos <- existing$repositories
  }
  if (length(repos)) {
    if (default_user != "") repos <- paste0(default_user, "/", repos)
    repos <- unlist(regmatches(repos, regexec("[^/]+/[^/#@]+$", repos)), use.names = FALSE)
  }
  jsonlite::write_json(list(name = name, repositories = repos), paths[1], auto_unbox = TRUE, pretty = TRUE)
  if (!file.exists(paths[2])) {
    writeLines(c(
      paste("#", name),
      "",
      "Consists of the repositories listed in [commons.json](commons.json).",
      "",
      "You can clone this repository and run these commands to establish and work from local data:",
      "```R",
      '# remotes::install_github("uva-bi-sdad/community")',
      "library(community)",
      "",
      "# clone and/or pull repositories and distributions:",
      'datacommons_refresh(".")',
      "",
      "# map files:",
      'datacommons_map_files(".")',
      "",
      "# refresh a view (rebuild a view's site data):",
      'datacommons_view(".", "view_name")',
      "",
      "# run the monitor site locally:",
      'init_datacommons(".", serve = TRUE)',
      "```",
      ""
    ), paths[2])
  }
  if (!file.exists(paths[3])) {
    writeLines(c(
      ".Rproj.user",
      ".Rhistory",
      ".Rdata",
      ".httr-oauth",
      ".DS_Store",
      "*.Rproj",
      "node_modules",
      "package-lock.json",
      "repos",
      "cache",
      "docs/dist",
      ""
    ), paths[3])
  }
  if (!file.exists(paths[4]) && !any(grepl("\\.Rproj$", list.files(dir)))) {
    writeLines("Version: 1.0\n", paths[4])
  }
  writeLines(if (length(repos)) Filter(nchar, repos) else "", paths[5])
  inst <- paste0(path.package("community"), c("/inst", ""), "/templates/datacommons/")
  inst <- inst[which(file.exists(inst))[1]]
  file.copy(paste0(inst, "get_repos.sh"), paths[6], TRUE)
  file.copy(paste0(inst, "update_repos.sh"), paths[7], TRUE)
  manifest_files <- paste0(dir, "/manifest/", c("repos", "files"), ".json")
  measure_infos <- paste0(dir, "/cache/measure_info.json")
  writeLines(c(
    "<!doctype html>",
    '<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">',
    "<head>",
    '<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />',
    '<meta http-equiv="X-UA-Compatible" content="IE=edge,chrome=1" />',
    '<meta name="viewport" content="width=device-width,initial-scale=1" />',
    "<title>Data Commons Monitor</title>",
    '<meta name="description" content="Data commons monitoring site.">',
    unlist(lapply(c(
      if (use_local) {
        list(
          list(type = "stylesheet", src = "dist/dev/datacommons.css"),
          list(type = "script", src = "dist/dev/datacommons.js")
        )
      } else {
        list(
          list(type = "stylesheet", src = "https://uva-bi-sdad.github.io/community/dist/css/datacommons.min.css"),
          list(type = "script", src = "https://uva-bi-sdad.github.io/community/dist/js/datacommons.min.js")
        )
      },
      list(
        bootstrap_style = list(
          type = "stylesheet",
          src = "https://cdn.jsdelivr.net/npm/bootstrap@5.3.2/dist/css/bootstrap.min.css",
          hash = "sha384-T3c6CoIi6uLrA9TneNEoa7RxnatzjcDSCmG1MXxSR1GAsXEV/Dwwykc2MPK8M2HN"
        ),
        bootstrap = list(
          type = "script",
          src = "https://cdn.jsdelivr.net/npm/bootstrap@5.3.2/dist/js/bootstrap.bundle.min.js",
          hash = "sha384-C6RzsynM9kWDrMNeT87bh95OGNyZPhcTNXj1NW7RuBCsyN/o0jlpcV8Qyq46cDfL"
        )
      )
    ), head_import, dir = dir)),
    paste0('<meta name="generator" content="community v', packageVersion("community"), '" />'),
    paste(c(
      '<script type="text/javascript">',
      "var commons",
      paste0(
        "window.onload = function(){commons = new DataCommons(",
        gsub("\\s+", "", paste0(readLines(paste0(dir, "/commons.json")), collapse = "")),
        ", {",
        "repos:", if (file.exists(manifest_files[1])) paste0(readLines(manifest_files[1]), collapse = "") else "{}",
        ",files:", if (file.exists(manifest_files[2])) paste0(readLines(manifest_files[2]), collapse = "") else "{}",
        ",variables:", if (file.exists(measure_infos)) paste0(readLines(measure_infos), collapse = "") else "{}",
        "}, ",
        jsonlite::toJSON(Filter(length, lapply(
          list.dirs(paste0(dir, "/views"), FALSE)[-1], function(v) {
            f <- paste0(dir, "/views/", v, "/", "view.json")
            if (file.exists(f)) list(name = v, view = jsonlite::read_json(f))
          }
        )), auto_unbox = TRUE),
        ")}"
      ),
      "</script>"
    ), collapse = "\n"),
    "</head>",
    "<body>",
    '<div id="site_wrap" style="position: fixed; height: 100%; width: 100%">',
    page_navbar(
      title = paste(name, "Monitor"),
      input_button("variables", id = "variables_tab_button"),
      input_button("repos", id = "repos_tab_button"),
      input_button("views", id = "views_tab_button")
    ),
    '<div class="content container-fluid">',
    "</div>",
    "</div>",
    '<noscript style="width: 100%; text-align: center; padding: 5em">Please enable JavaScript to view this site.</noscript>',
    "</body>",
    "</html>"
  ), paths[8])
  file.copy(paste0(inst, "request.js"), paths[9], TRUE)
  if (verbose) {
    cli_bullets(c(
      v = paste(if (check$exists) "updated" else "created", "{name}:"),
      "*" = paste0("{.path ", normalizePath(dir, "/", FALSE), "}"),
      i = if (!length(repos)) {
        paste0(
          "add repository names to {.file {paste0(dir, '/commons.json')}} or {.file {paste0(dir, '/scripts/repos.txt')}},",
          " then use {.code datacommons_refresh(", odir, ")} to clone them"
        )
      }
    ))
  }
  if (refresh_after && length(repos)) datacommons_refresh(dir, verbose = verbose)
  if (serve) site_start_server(dir, host, port)
  invisible(dir)
}

#' Add a select input to a website
#'
#' Adds an input to select from the entered options.
#'
#' @param label Label of the input for the user.
#' @param options A vector of options, the name of a variable from which to pull levels, or \code{"datasets"},
#' \code{"variables"}, \code{"ids"}, or \code{"palettes"} to select names of datasets, variables, entity ids, or
#' color palettes. If there is a map with overlay layers with properties, can also be \code{"overlay_properties"},
#' to select between properties.
#' @param default Which of the options to default to; either its index or value.
#' @param display A display version of the options.
#' @param id Unique ID of the element to be created.
#' @param ... Additional attributes to set on the select element.
#' @param note Text to display as a tooltip for the input.
#' @param group_feature Name of a measure or entity feature to use as a source of option grouping,
#' if \code{options} is \code{"variables"} or \code{"ids"}.
#' @param variable The name of a variable from which to get levels (overwritten by \code{depends}).
#' @param dataset The name of an included dataset, where \code{variable} should be looked for; only applies when
#' there are multiple datasets with the same variable name.
#' @param depends The ID of another input on which the options depend; this will take president over \code{dataset}
#' and \code{variable}, depending on this type of input \code{depends} points to.
#' @param dataview The ID of an \code{\link{input_dataview}}, used to filter the set of options, and potentially
#' specify dataset if none is specified here.
#' @param subset Determines the subset of options shown if \code{options} is \code{"ids"}; mainly \code{"filtered"}
#' (default) to apply all filters, including the current selection, or \code{"full_filter"} to apply all
#' feature and variable filters, but not the current selection. \code{"siblings"} is a special case given a selection,
#' which will show other IDs with the same parent.
#' @param selection_subset Subset to use when a selection is made; defaults to \code{"full_filter"}.
#' @param filters A list with names of \code{meta} entries (from \code{variable} entry in \code{\link{data_add}}'s
#' \code{meta} list), and values of target values for those entries, or the IDs of value selectors.
#' @param reset_button If specified, adds a button after the select element that will revert the selection
#' to its default; either \code{TRUE}, or text for the reset button's label.
#' @param button_class Class name to add to the reset button.
#' @param as.row Logical; if \code{TRUE}, the label and input are in separate columns within a row.
#' @param floating_label Logical; if \code{FALSE} or \code{as.row} is \code{TRUE}, labels are separate from
#' their inputs.
#' @examples
#' \dontrun{
#' input_select()
#' }
#' @return A character vector of the contents to be added.
#' @export

input_select <- function(label, options, default = -1, display = options, id = label, ...,
                         note = NULL, group_feature = NULL, variable = NULL, dataset = NULL, depends = NULL,
                         dataview = NULL, subset = "filtered", selection_subset = "full_filter", filters = NULL,
                         reset_button = FALSE, button_class = NULL, as.row = FALSE, floating_label = TRUE) {
  id <- gsub("\\s", "", id)
  a <- list(...)
  if (as.row) floating_label <- FALSE
  r <- c(
    '<div class="wrapper select-wrapper">',
    if (!floating_label) paste0('<label for="', id, '">', label, "</label>"),
    paste0('<div class="', paste(c(
      if (reset_button) "input-group", if (floating_label) "form-floating"
    ), collapse = " "), '">'),
    paste0(
      '<select class="auto-input form-select" data-autoType="select" id="', id, '" ',
      if (is.character(options) && length(options) == 1) paste0('data-optionSource="', options, '"'),
      if (!is.null(default)) paste0(' data-default="', default, '"'),
      if (!is.null(note)) paste0(' aria-description="', note, '"'),
      if (!is.null(dataview)) paste0(' data-view="', dataview, '"'),
      if (!is.null(subset)) paste0(' data-subset="', subset, '"'),
      if (!is.null(selection_subset)) paste0(' data-selectionSubset="', selection_subset, '"'),
      if (!is.null(depends)) paste0(' data-depends="', depends, '"'),
      if (!is.null(dataset)) paste0(' data-dataset="', dataset, '"'),
      if (!is.null(variable)) paste0(' data-variable="', variable, '"'),
      if (length(a)) unlist(lapply(seq_along(a), function(i) paste0(" ", names(a)[i], '="', a[[i]], '"'))),
      ">"
    ),
    if (is.list(options)) {
      i <- 0
      if (is.null(names(options))) names(options) <- seq_along(options)
      unlist(lapply(names(options), function(g) {
        group <- paste0('<optgroup label="', g, '">')
        for (gi in seq_along(options[[g]])) {
          i <<- i + 1
          group <- c(group, paste0(
            '<option value="', options[[g]][[gi]], '"', if (i == default) "selected", ">", display[[g]][[gi]], "</option>"
          ))
        }
        c(group, "</optgroup>")
      }), use.names = FALSE)
    } else if (length(options) > 1 || !options %in% c("datasets", "variables", "ids", "palettes", "overlay_properties")) {
      unlist(lapply(seq_along(options), function(i) {
        paste0('<option value="', options[i], '"', if (i == default) "selected", ">", display[i], "</option>")
      }), use.names = FALSE)
    },
    "</select>",
    if (floating_label) paste0('<label for="', id, '">', label, "</label>"),
    if (!missing(reset_button)) {
      paste(c(
        '<button type="button" class="btn btn-link', if (!is.null(button_class)) paste("", button_class), ' select-reset">',
        if (is.character(reset_button)) reset_button else "Reset",
        "</button>"
      ), collapse = "")
    },
    "</div>",
    "</div>"
  )
  if (as.row) r <- to_input_row(r)
  caller <- parent.frame()
  if (!is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts") {
    if (!is.null(group_feature)) caller$select[[id]]$group <- group_feature
    if (!is.null(filters)) caller$select[[id]]$filters <- as.list(filters)
    caller$content <- c(caller$content, r)
  }
  r
}

#' Add an input rule to a website
#'
#' Specifies if-then conditions for inputs; that is, when one input is changed, change another based on
#' the entered conditions.
#'
#' @param condition A string representing the condition (e.g., "input_a == 'a'"), with multiple conditions
#' separated by \code{"&"}. If all conditions are \code{TRUE}, all \code{effects} will be set.
#' @param effects A list with names corresponding to input IDs, and values of what they should be set to.
#' @examples
#' \dontrun{
#' input_select("input_a", c("a", "b", "c"))
#' input_slider("input_b", c(0, 10))
#' input_rule("input_a == 'a' && input_b != 0", list(input_b = 10))
#' }
#' @return The entered condition and effects.
#' @export

input_rule <- function(condition, effects) {
  conditions <- substitute(condition)
  if (!is.character(condition)) condition <- deparse(condition)
  r <- list(condition = parse_rule(condition), effects = as.list(effects))
  caller <- parent.frame()
  if (!is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts") {
    caller$rules <- c(caller$rules, list(r))
  }
  r
}

#' @rdname site_build
#' @examples
#' \dontrun{
#' # serve a site that has already been built
#' # from the parent directory of a "docs" directory to be served
#' site_start_server(".")
#' }
#' @export

site_start_server <- function(dir, host = "127.0.0.1", port = 3000) {
  static_path <- list("/" = staticPath(paste0(dir, "/docs"), TRUE))
  server_exists <- FALSE
  for (s in listServers()) {
    if (s$getHost() == host && s$getPort() == port) {
      if (!identical(s$getStaticPaths(), static_path)) {
        stopServer(s)
      } else {
        server_exists <- TRUE
      }
      break
    }
  }
  if (!server_exists) {
    s <- tryCatch(startServer(host, port, list(staticPaths = static_path)), error = function(e) NULL)
    if (is.null(s)) {
      cli_warn(paste0("failed to create server on ", host, ":", port))
    }
  }
  cli_alert_info(paste0("listening on ", host, ":", port))
}

#' Adds credits to a website
#'
#' Adds a credits section, which is automatically filled with the libraries used.
#' These can be added to or edited.
#'
#' @param add A list of credits to add. Each credit should be a list with at least entries for \code{"name"}
#' and \code{"url"}, and optionally a \code{"version"} and/or \code{"description"}. These can be named,
#' which will overwrite other credits with the same name.
#' @param exclude Names of automatic credits to exclude. The automatic credits are \code{"bootstrap"},
#' \code{"leaflet"} (from \code{\link{output_map}}), \code{"plotly"} (from \code{\link{output_plot}}), and
#' \code{"datatables"} (from \code{\link{output_table}}).
#' @examples
#' \dontrun{
#' # adds an institution credit, and excludes the default colorbrewer credit
#' output_credits(
#'   list(name = "Institution", url = "https://example.com", description = "The institution."),
#'   "colorbrewer"
#' )
#' }
#' @return A character vector of the contents to be added.
#' @export

output_credits <- function(add = NULL, exclude = NULL) {
  caller <- parent.frame()
  building <- !is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts"
  id <- paste0("credits", caller$uid)
  r <- paste0('<div id="', id, '" class="auto-output credits" data-autoType="credits"></div>')
  if (building) {
    caller$content <- c(caller$content, r)
    if (!is.null(add) || !is.null(exclude)) {
      if (!is.null(names(add)) && "name" %in% names(add)) add <- list(add)
      caller$credit_output[[id]] <- list(add = add, exclude = exclude)
    }
    caller$uid <- caller$uid + 1
  }
  r
}

#' Adds an organizational panel to a website
#'
#' Adds a panel to a website outside of the main content area.
#'
#' @param title Text to appear in the panel's header area.
#' @param ... Elements to appear in the panel's body area.
#' @param foot Content to appear in the panel's footer area.
#' @param position The side of the screen on which the panel appears; \code{"left"} (default) or \code{"right"}.
#' @param wraps The class of wrapper to place elements in; either \code{"row"}, \code{"col"}, or \code{""}
#' (to not wrap the element). Can specify 1 for every element, or a different class for each element.
#' @param sizes The relative size of each wrapper, between 1 and 12, or \code{"auto"}; default is equal size.
#' @param breakpoints Bootstrap breakpoint of each wrapper; one of \code{""} (extra small), \code{"sm"},
#' \code{"md"}, \code{"lg"}, \code{"xl"}, or \code{"xxl"}.
#' @param conditions A character for each element representing the conditions in which that should be showing
#' (e.g., \code{c("", "input_a == a", "")}); \code{""} means the element's display is not conditional.
#' Adding \code{"lock: "} before the condition will disable inputs rather than hide the element.
#' @param id Unique ID of the section.
#' @details See the \href{https://getbootstrap.com/docs/5.1/layout/grid}{Bootstrap grid documentation}.
#' @examples
#' \dontrun{
#' page_panel(
#'   "<h1>Title</h1>",
#'   "<p>body</p>",
#' )
#' }
#' @return A character vector of the content to be added.
#' @export

page_panel <- function(title = "Side Panel", ..., foot = NULL, position = "left", wraps = NA, sizes = NA,
                       breakpoints = NA, conditions = "", id = NULL) {
  caller <- parent.frame()
  building <- !is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts"
  parts <- new.env()
  attr(parts, "name") <- "community_site_parts"
  parts$uid <- caller$uid
  pid <- paste0("panel", parts$uid)
  elements <- substitute(...())
  footer <- if (missing(foot)) NULL else substitute(foot)
  n <- length(elements)
  wraps <- rep_len(wraps, n)
  sizes <- rep_len(sizes, n)
  breakpoints <- rep_len(breakpoints, n)
  conditions <- rep_len(conditions, n)
  ids <- paste0("panel", parts$uid, seq_len(n))
  title <- substitute(title)
  r <- c(
    paste0('<div class="card panel panel-', position, '" id="', pid, '">'),
    paste0(c('<div class="card-header">', eval(title, parts, caller), "</div>"), collapse = ""),
    '<div class="card-body">',
    unlist(lapply(seq_len(n), function(i) {
      wrap <- !is.na(wraps[i]) || conditions[i] != ""
      c(
        if (wrap) {
          paste(c(
            '<div class="', if (is.na(wraps[i])) "" else wraps[i],
            if (!is.na(breakpoints[i])) c("-", breakpoints[i]),
            if (!is.na(sizes[i])) c("-", sizes[i]),
            '"', if (conditions[i] != "") c(' id="', ids[i], '"'), ">"
          ), collapse = "")
        },
        eval(elements[[i]], parts, caller),
        if (wrap) "</div>"
      )
    }), use.names = FALSE),
    "</div>",
    if (length(footer)) {
      c(
        '<div class="card-footer">',
        unlist(lapply(if (is.list(footer)) footer else list(footer), eval, parts), use.names = FALSE),
        "</div>"
      )
    },
    paste0(
      '<button type="button" title="toggle panel" aria-controls="', pid,
      '" aria-expanded="true" class="btn panel-toggle">&Verbar;</button>'
    ),
    "</div>"
  )
  if (building) {
    caller$body <- c(caller$body, r)
    for (n in names(parts)) if (n != "content" && n != "uid") caller[[n]] <- c(caller[[n]], parts[[n]])
    process_conditions(conditions, ids, caller)
    caller$uid <- parts$uid + 1
  }
  r
}

#' Write content to the head of a website
#'
#' Adds to the \code{<head>} tag of a page being build with \code{\link{site_build}}.
#'
#' @param ... Content to be added to the \code{<head>} tag, such as a \code{<meta>} or \code{<link>} tag.
#' @param title Text to appear as the site's name (as in a browser tab); added to a \code{<title>} tag.
#' @param description Text describing the site; added to a \code{<meta>} tag.
#' @param icon Path to an image for the site's icon.
#' @examples
#' \dontrun{
#' page_head(title = "Site Name")
#' }
#' @return A character vector of the content to be added.
#' @export

page_head <- function(..., title = "", description = "", icon = "") {
  r <- lapply(list(...), as.character)
  caller <- parent.frame()
  building <- !is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts"
  if (building) for (e in names(caller$head)) if (!e %in% names(r)) r[[e]] <- caller$head[[e]]
  if (!missing(title)) {
    r$title <- c(
      paste0("<title>", title, "</title>"),
      paste0('<meta name="title" content="', title, '">')
    )
  }
  if (!missing(description)) r$description <- paste0('<meta name="description" content="', description, '">')
  if (!missing(icon)) r$icon <- paste0('<link rel="icon" href="', icon, '">')
  if (building) caller$head <- r
  r
}

#' Add a single switch or checkbox to a website
#'
#' Adds a single toggle, displayed as a switch or checkbox to a website.
#'
#' @param label Label of the input for the user.
#' @param id Unique id of the element to be created.
#' @param ... Additional attributes to set on the element.
#' @param note Text to display as a tooltip for the input.
#' @param default_on Logical; if \code{TRUE}, the switch will start on.
#' @param as.checkbox Logical; if \code{TRUE}, display the switch as a checkbox.
#' @examples
#' \dontrun{
#' input_switch("Label")
#' }
#' @return A character vector of the contents to be added.
#' @seealso For a group of switches, checkboxes, or radio buttons, use \code{\link{input_checkbox}}.
#' @export

input_switch <- function(label, id = label, ..., note = NULL, default_on = FALSE, as.checkbox = FALSE) {
  id <- gsub("\\s", "", id)
  a <- list(...)
  r <- c(
    paste0(
      '<div class="wrapper switch-wrapper"',
      if (length(a)) unlist(lapply(seq_along(a), function(i) paste0(" ", names(a)[i], '="', a[[i]], '"'))),
      ">"
    ),
    paste0('<div class="form-check', if (!as.checkbox) " form-switch", '">'),
    paste0('<label class="form-check-label" for="', id, '">', label, "</label>"),
    paste0(
      '<input data-autoType="switch" type="checkbox" autocomplete="off"',
      ' class="auto-input form-check-input"', if (!as.checkbox) ' role="switch"', ' id="', id, '"',
      if (!is.null(note)) paste0(' aria-description="', note, '"'),
      if (default_on) " checked", ">"
    ),
    "</div>",
    "</div>"
  )
  caller <- parent.frame()
  if (!is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts") {
    caller$content <- c(caller$content, r)
  }
  r
}

#' Adds a group of tabs to a website
#'
#' Adds a group of tabs, each of which contains input and/or output components.
#'
#' @param ... A separately entered list for each tab and its content. Named entries in each tab entry can be
#' \code{"name"} (for the text appearing in the navigation tab), \code{"id"}, \code{"class"}, and \code{"condition"}.
#' Unnamed entries in each list entry are considered the content to be added to the tab's pane. See examples.
#' @param id Unique ID of the tabgroup.
#' @param class A class name to add to the tabgroup.
#' @param condition A string representing the display condition of the entire tabgroup.
#' @details See the \href{https://getbootstrap.com/docs/5.1/layout/grid}{Bootstrap grid documentation}.
#' @examples
#' \dontrun{
#' page_tabgroup(
#'   "Map" = list(id = "map_tab", output_map()),
#'   "Data" = list(output_table()),
#' )
#' }
#' @return A character vector of the content to be added.
#' @export

page_tabgroup <- function(..., id = NULL, class = NULL, condition = NULL) {
  caller <- parent.frame()
  building <- !is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts"
  parts <- new.env()
  attr(parts, "name") <- "community_site_parts"
  parts$uid <- caller$uid
  elements <- substitute(...())
  n <- length(elements)
  pre <- if (!is.null(id)) id else paste0("tg", parts$uid)
  ids <- paste0(pre, seq_len(n))
  head <- rep(
    '<button type="button" data-bs-toggle="tab" aria-controls="',
    n
  )
  body <- rep('<div role="tabpanel" aria-labelledby="', n)
  for (i in seq_along(elements)) {
    e <- elements[[i]]
    ns <- names(e)
    if (!"name" %in% ns) e$name <- names(elements)[i]
    if (!"id" %in% ns) e$id <- ids[i]
    if (!"class" %in% ns) e$class <- ""
    if (!"condition" %in% ns) e$condition <- ""
    head[i] <- paste(c(
      head[i], e$id, '" class="nav-link', if (i == 1) " active",
      if (i == 1) '" aria-current="page', '" data-bs-target="#',
      e$id, '" id="', e$id, '-tab">', e$name, "</button>"
    ), collapse = "")
    body[i] <- paste0(c(
      body[i], e$id, '-tab" class="tab-pane fade', if (i == 1) " show active", if (e$class != "") c(" ", e$class),
      '" id="', e$id, '"', if (e$condition != "") c(' condition="', e$condition, '"'),
      ">", unlist(eval(e[names(e) == ""], parts), use.names = FALSE), "</div>"
    ), collapse = "")
  }
  r <- c(
    "<nav>",
    paste(c(
      "<div",
      if (!is.null(id)) c(' id="', id, '"'),
      ' class="nav nav-tabs', if (!is.null(class)) c(" ", class), '"',
      if (!is.null(condition)) c(' condition="', condition, '"'),
      ">"
    ), collapse = ""),
    head,
    "</div>",
    "</nav>",
    '<div class="tab-content">',
    body,
    "</div>"
  )
  if (building) {
    caller$content <- c(caller$content, r)
    for (n in names(parts)) if (n != "content" && n != "uid") caller[[n]] <- c(caller[[n]], parts[[n]])
    caller$uid <- parts$uid + 1
  }
  r
}

#' Add a guided tour to a website
#'
#' Adds a set of instructions that will guide a user through a process.
#'
#' Tutorials take over control of the interface to walk the user through some process.
#'
#' @param ... Lists specifying each tutorial, or a single list of such lists:
#' \itemize{
#'   \item \strong{\code{name}}: Short name used for reference (as in links). Taken from
#'     the name of entries if omitted.
#'   \item \strong{\code{title}}: Display title of the tutorial.
#'   \item \strong{\code{description}}: A description of what the tutorial will do.
#'   \item \strong{\code{steps}} (required): A list containing step specifications:
#'   \itemize{
#'     \item \strong{\code{description}}: Text description to accompany the step.
#'     \item \strong{\code{focus}}: Query selector for the element to focus on (e.g., \code{"#input_a"}).
#'     \item \strong{\code{option}}: Name (value) of an option in a dropdown menu to highlight.
#'     \item \strong{\code{before}}: A vector of actions to perform before showing the step, where
#'     names are of input elements, and values are either \code{"click"} to click on the element
#'     (mainly for elements with toggleable menus -- elements that do not accept a value will always
#'     be clicked), \code{"reset"} to reset the input, or a value to set the input to
#'     (e.g., \code{c("input_a" = "a"}). An unnamed actions or values will apply to the \code{focus} element.
#'     If \code{focus} or the named element has options and \code{option} is included, \code{"set"},
#'     will set those options. If a dialogue-like element is open, \code{"close"} will close it.
#'     \item \strong{\code{after}}: A vector of actions to perform after the step has advanced,
#'     before the next step starts (if any).
#'     \item \strong{\code{wait}}: Number of milliseconds to wait before starting the step. Useful
#'     to add time to allow loads or animations to finish; defaults to \code{400}.
#'     \item \strong{\code{time}}: Number of seconds to wait before auto-advancing. If omitted,
#'     will not auto-advance.
#'     \item \strong{\code{disable_continue}}: Logical; if \code{TRUE}, will disable the continue button.
#'   }
#'   \item \strong{\code{reset}}: Logical; if \code{TRUE}, will reset the interface
#'   before starting the tutorial.
#' }
#' @param button Text to show a button to show the tutorials listing menu, or \code{FALSE}
#' to not create a button.
#' @param id Unique ID of the button element to be created.
#' @param class Additional class names to add to the button element.
#' @param note Text to display as a tooltip for the button.
#' @examples
#' page_tutorials(
#'   use_menu = list(
#'     title = "Use Settings Menu",
#'     steps = list(
#'       list(
#'         description = "Click on the settings button.",
#'         focus = "#navbar_menu .nav-item:nth-child(3)",
#'         after = "click"
#'       ),
#'       list(
#'         description = "Locate setting A.",
#'         focus = "setting.a"
#'       )
#'     )
#'   )
#' )
#' @return A character vector of the content to be added.
#' @export

page_tutorials <- function(..., button = "Tutorials", id = NULL, class = NULL, note = NULL) {
  caller <- parent.frame()
  building <- !is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts"
  parts <- new.env()
  attr(parts, "name") <- "community_site_parts"
  tutorials <- list(...)
  if (length(tutorials) == 1) {
    if ("name" %in% names(tutorials)) {
      tutorials <- list(tutorials)
    } else if (is.null(names(tutorials))) {
      tutorials <- unlist(tutorials, recursive = FALSE)
    }
  }
  for (i in seq_along(tutorials)) {
    if (is.null(tutorials[[i]]$name)) {
      tutorials[[i]]$name <- if (is.null(names(tutorials)[i])) paste("tutorial", i) else names(tutorials)[i]
    }
    tutorials[[i]]$steps <- lapply(tutorials[[i]]$steps, function(s) {
      if (!is.null(s$before)) s$before <- as.list(s$before)
      if (!is.null(s$after)) s$after <- as.list(s$after)
      s
    })
  }
  names(tutorials) <- vapply(tutorials, "[[", "", "name")
  r <- c(
    '<div class="wrapper button-wrapper">',
    paste0(
      '<button type="button" data-bs-toggle="modal" data-bs-target="#community_tutorials_menu" class="btn',
      if (!is.null(class)) paste("", class), '"',
      if (!is.null(id)) paste0(' id="', id, '"'),
      if (!is.null(note)) paste0(' aria-description="', note, '"'),
      ">", button, "</button>"
    ),
    "</div>"
  )
  if (building) {
    if (is.character(button)) caller$content <- c(caller$content, r)
    caller$tutorials <- c(caller$tutorials, tutorials)
  }
  r
}

#' Add a text input to a website
#'
#' Adds an direct text input element to a website.
#'
#' @param label Label of the input for the user.
#' @param id Unique ID of the element to be created.
#' @param ... Other attributes to add to the input.
#' @param default Default value of the input, which will appear as a placeholder.
#' @param multiline Logical; if \code{TRUE}, create a \code{textarea} element, instead of an \code{input} element
#' to accept multiple lines of text.
#' @param class Class names to add to the input's list.
#' @param note Text to display as a tooltip for the input or textarea.
#' @param floating_label Logical; if \code{FALSE}, labels are separate from their input elements.
#' @examples
#' \dontrun{
#' input_text("Enter Text:", "entered_text")
#' }
#' @return A character vector of the contents to be added.
#' @export

input_text <- function(label, id = label, ..., default = NULL, note = NULL, multiline = FALSE, class = NULL,
                       floating_label = TRUE) {
  id <- gsub("\\s", "", id)
  a <- list(...)
  r <- c(
    paste0('<div class="wrapper text-wrapper', if (floating_label) " form-floating", '">'),
    if (!floating_label) paste0('<label for="', id, '">', label, "</label>"),
    paste0(c(
      "<", if (multiline) "textarea" else 'input type="text"',
      ' id="', id, '"',
      if (!is.null(default)) {
        c(
          ' placeholder="', default, '"',
          ' value="', default, '"'
        )
      },
      if (length(a)) unlist(lapply(seq_along(a), function(i) paste0(" ", names(a)[i], '="', a[[i]], '"'))),
      if (!is.null(note)) c(' aria-description="', note, '"'),
      ' class="form-control auto-input', if (!is.null(class)) paste("", class), '" data-autoType="intext">',
      if (multiline) "</textarea>",
      if (floating_label) paste0('<label for="', id, '">', label, "</label>")
    ), collapse = ""),
    "</div>"
  )
  caller <- parent.frame()
  if (!is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts") {
    caller$content <- c(caller$content, r)
  }
  r
}

#' Add an internal variable to a website
#'
#' Creates an internal variable (virtual input), which can be used for display logic.
#'
#' @param id Name of the variable, which can be referred to by other inputs of outputs.
#' @param cases A list of conditions with names specifying conditions, and values to set the variable to
#' in that condition (e.g., \code{list("input_a == 1" = 1)}).
#' These can also be specified separately with an \code{\link{input_rule}}.
#' @param default The value to set if no condition is \code{TRUE}.
#' @param display A list mapping cases names to display names (e.g., \code{list(value = "Value")}).
#' @examples
#' \dontrun{
#' input_select("input_a", c("a", "b", "c"))
#' input_variable("vinput_a", list("input_a == c" = "b"), "a")
#'
#' # vinput_a will be "a" unless input_a is "c"
#' }
#' @return A version of the resulting variable object.
#' @export

input_variable <- function(id, cases, default = "", display = list()) {
  r <- Filter(length, list(
    id = id,
    states = lapply(seq_along(cases), function(i) {
      list(
        condition = parse_rule(names(cases[i])),
        value = cases[[i]]
      )
    }),
    default = default,
    display = display
  ))
  caller <- parent.frame()
  if (!is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts") {
    caller$variables <- c(caller$variables, list(r))
  }
  r
}

1		#' Map Data Commons Files
2		#'
3		#' Extract variables and IDs from files in datacommons repositories
4		#'
5		#' @param dir Directory of the data commons projects.
6		#' @param search_pattern A regular expression string used be passed to \code{\link{list.files}}.
7		#' @param variable_location The name of a column contain variable names in each dataset, or a function to retrieve
8		#' variable names (e.g., \code{colnames}).
9		#' @param id_location The name of a column contain IDs in each dataset, or a function to retrieve
10		#' IDs (e.g., \code{rownames}).
11		#' @param reader A function capable of handling a connection in its first argument, which returns a matrix-like object.
12		#' @param overwrite Logical; if \code{TRUE}, creates a new map even if one exists.
13		#' @param verbose Logical; if \code{FALSE}, does not print status messages.
14		#' @examples
15		#' \dontrun{
16		#' # from a data commons project directory
17		#' map <- datacommons_map_files(".")
18		#' }
19		#' @return An invisible \code{list}, including a \code{data.frame} of the mapped variables, with \code{variable} (variable name),
20		#' \code{repo} (the repository containing the file), \code{dir_name} (variable name with a prefix from the parent directories),
21		#' \code{full_name} (variable name with a prefix from the last part of the file's name, after a year or year range),
22		#' and \code{file} (path to the file) columns, and a \code{list} of the mapped IDs, with an entry for each ID,
23		#' each of which with entries for \code{repos} (repositories in which the ID appears) and \code{files} (files in which the ID appears).
24		#' @export
25
26		datacommons_map_files <- function(dir, search_pattern = "\\.csv(?:\\.[gbx]z2?)?$", variable_location = "measure",
27		id_location = "geoid", reader = read.csv, overwrite = FALSE, verbose = TRUE) {
28	!	if (missing(dir)) cli_abort("{.arg dir} must be specified")
29	5x	dir <- paste0(normalizePath(dir, "/", FALSE), "/")
30	5x	check <- check_template("datacommons", dir = dir)
31	5x	if (!check$exists) {
32	!	cli_abort(c(
33	!	x = "{.arg dir} does not appear to point to a data commons project",
34	!	i = paste0('initialize it with {.code init_datacommons("', dir, '")}')
35		))
36		}
37	5x	if (!dir.exists(paste0(dir, "repos"))) {
38	!	cli_abort(c(
39	!	x = "no {.path repos} directory found in {.arg dir}",
40	!	i = paste0('use {.code datacommons_refresh("', dir, '")} to bring in remote data')
41		))
42		}
43	5x	commons <- jsonlite::read_json(paste0(dir, "commons.json"))
44	5x	all_files <- list.files(paste0(dir, c("cache", "repos")), search_pattern, full.names = TRUE, recursive = TRUE)
45	5x	all_files <- sort(all_files[!grepl("[/\\](?:code\|docs\|working\|original)[/\\]\|variable_map", all_files)])
46	!	if (!length(all_files)) cli_abort("no files were found")
47	5x	res <- paste0(dir, "cache/", c("variable_map.csv", "id_map.rds"))
48	1x	if (overwrite) unlink(res)
49	5x	if (all(file.exists(res)) && all(file.mtime(res) > max(file.mtime(all_files)))) {
50	!	if (verbose) cli_alert_success("the maps are up to date")
51	4x	return(invisible(list(variables = read.csv(res[1]), ids = readRDS(res[2]))))
52		}
53	1x	i <- 1
54	1x	map <- idmap <- list()
55	1x	noread <- novars <- noids <- empty <- NULL
56	1x	repos <- sort(unlist(commons$repositories))
57	1x	manifest <- measure_info <- list()
58	1x	if (verbose) {
59	1x	cli_progress_step(
60	1x	"scanning files in repos: {i}/{length(repos)}",
61	1x	msg_done = "created file maps: {.file {res}}", spinner = TRUE
62		)
63		}
64	1x	for (i in seq_along(repos)) {
65	1x	r <- repos[[i]]
66	1x	manifest[[r]] <- list()
67	1x	files <- sort(list.files(
68	1x	paste0(dir, c("repos", "cache"), "/", sub("^[^/]+/", "", r)), search_pattern,
69	1x	full.names = TRUE, recursive = TRUE, ignore.case = TRUE
70		))
71	1x	measure_info_files <- sort(list.files(
72	1x	paste0(dir, "repos/", sub("^.+/", "", r)), "^measure_info[^.]*\\.json$",
73	1x	full.names = TRUE, recursive = TRUE
74		))
75	1x	measure_info_files <- measure_info_files[
76	1x	!duplicated(gsub("_rendered\|/code/\|/data/", "", measure_info_files))
77		]
78	1x	if (length(measure_info_files)) {
79	1x	measure_info <- c(measure_info, lapply(
80	1x	structure(measure_info_files, names = sub(
81	1x	paste0(dir, "repos/"), paste0(sub("/.*$", "", r), "/"), measure_info_files,
82	1x	fixed = TRUE
83		)),
84	1x	function(f) {
85	5x	tryCatch(data_measure_info(
86	5x	f,
87	5x	render = TRUE, write = FALSE, verbose = FALSE, open_after = FALSE, include_empty = FALSE
88	5x	), error = function(e) {
89	!	cli_alert_warning("failed to read measure info: {.file {f}}")
90	!	NULL
91		})
92		}
93		))
94		}
95	1x	files <- files[files %in% all_files]
96	1x	for (f in files) {
97	7x	d <- attempt_read(f, id_location)
98	7x	if (!is.null(d)) {
99	7x	if (nrow(d)) {
100	7x	lcols <- tolower(colnames(d))
101	7x	vars <- c(id_location, variable_location)
102	7x	if (any(!vars %in% colnames(d))) {
103	!	l <- !colnames(d) %in% vars & lcols %in% vars
104	!	colnames(d)[l] <- lcols[l]
105		}
106	7x	if (is.character(variable_location) && !variable_location %in% colnames(d)) {
107	!	novars <- c(novars, f)
108	!	next
109		}
110	7x	if (is.character(id_location) && !id_location %in% colnames(d)) {
111	!	noids <- c(noids, f)
112	!	next
113		}
114	7x	hash <- md5sum(f)[[1]]
115	7x	relf <- sub(paste0(dir, "repos/", sub("^.+/", "", r), "/"), "", f, fixed = TRUE)
116	7x	manifest[[r]][[hash]]$name <- relf
117	7x	manifest[[r]][[hash]]$providers <- c(manifest[[r]][[hash]]$provider, if (grepl("repos/", f, fixed = TRUE)) "github" else "dataverse")
118	7x	vars <- if (is.function(variable_location)) variable_location(d) else d[[variable_location]]
119	7x	if (length(vars)) {
120	7x	vars <- unique(vars[!is.na(vars)])
121	7x	map[[f]] <- data.frame(
122	7x	variable = vars,
123	7x	dir_name = paste0(gsub(paste0(dir, "\|cache/\|repos/\|data/\|distribution/"), "", paste0(dirname(f), "/")), vars),
124	7x	full_name = make_full_name(f, vars),
125	7x	repo = r,
126	7x	file = sub(dir, "", f, fixed = TRUE)
127		)
128	7x	manifest[[r]][[hash]]$variables <- vars
129		} else {
130	!	novars <- c(novars, f)
131		}
132	7x	ids <- if (is.function(id_location)) id_location(d) else d[[id_location]]
133	7x	if (length(ids)) {
134	7x	ids <- gsub("^\\s+\|\\s+$", "", format(unique(ids), scientific = FALSE))
135	7x	idmap[[f]] <- data.frame(id = ids, repo = r, file = relf)
136	7x	manifest[[r]][[hash]]$ids <- ids
137		} else {
138	!	noids <- c(noids, f)
139		}
140		} else {
141	!	empty <- c(empty, f)
142		}
143		} else {
144	!	noread <- c(noread, f)
145		}
146		}
147	1x	if (verbose) cli_progress_update()
148		}
149	1x	if (verbose) cli_progress_done()
150	1x	if (length(measure_info)) {
151	1x	jsonlite::write_json(measure_info, paste0(dir, "cache/measure_info.json"), auto_unbox = TRUE)
152		}
153	1x	map <- do.call(rbind, unname(map))
154	1x	idmap <- do.call(rbind, unname(idmap))
155	1x	if (verbose) {
156	!	if (length(noread)) cli_warn("file{?s} could not be read in: {noread}")
157	!	if (length(empty)) cli_warn("{?files have/file had} no rows: {empty}")
158	!	if (length(novars)) cli_warn("{.arg {variable_location}} was not in {?some files'/a file's} column names: {novars}")
159	!	if (length(noids)) cli_warn("{.arg {id_location}} was not in {?some files'/a file's} column names: {noids}")
160		}
161	!	if (!length(idmap)) cli_abort("no IDs were mapped")
162	1x	dir.create(paste0(dir, "manifest"), FALSE)
163	1x	jsonlite::write_json(manifest, paste0(dir, "manifest/files.json"), auto_unbox = TRUE, pretty = TRUE)
164	1x	dir.create(paste0(dir, "cache"), FALSE)
165	1x	idmap <- lapply(split(idmap, idmap$id), function(d) list(repos = unique(d$repo), files = unique(d$file)))
166	1x	saveRDS(idmap, res[2], compress = "xz")
167	1x	write.csv(map, res[1], row.names = FALSE)
168	1x	init_datacommons(dir, refresh_after = FALSE, verbose = FALSE)
169	1x	invisible(list(variables = map, ids = idmap))
170		}

1		#' Adds a modal dialog (popup) to a website
2		#'
3		#' Adds a button which triggers a modal dialog (popup) with specified content.
4		#'
5		#' @param text Text in the triggering button.
6		#' @param ... Elements to appear in the popup's body area.
7		#' @param title Content to appear in the popup's header area. Defaults to \code{text}.
8		#' @param footer A list of elements to include in the footer.
9		#' @param wraps The class of wrapper to place elements in; either \code{"row"}, \code{"col"}, or \code{""}
10		#' (to not wrap the element). Can specify 1 for every element, or a different class for each element.
11		#' @param sizes The relative size of each wrapper, between 1 and 12, or \code{"auto"}; default is equal size.
12		#' @param breakpoints Bootstrap breakpoint of each wrapper; one of \code{""} (extra small), \code{"sm"},
13		#' \code{"md"}, \code{"lg"}, \code{"xl"}, or \code{"xxl"}.
14		#' @param conditions A character for each element representing the conditions in which that should be showing
15		#' (e.g., \code{c("", "input_a == a", "")}); \code{""} means the element's display is not conditional.
16		#' Adding \code{"lock: "} before the condition will disable inputs rather than hide the element.
17		#' @param id Unique ID of the section.
18		#' @details See the \href{https://getbootstrap.com/docs/5.1/layout/grid}{Bootstrap grid documentation}.
19		#' @examples
20		#' \dontrun{
21		#' page_popup(
22		#' "<h1>Title</h1>",
23		#' "<p>body</p>",
24		#' )
25		#' }
26		#' @return A character vector of the content to be added.
27		#' @export
28
29		page_popup <- function(text = "Popup", ..., title = text, footer = NULL, wraps = NA, sizes = NA,
30		breakpoints = NA, conditions = "", id = NULL) {
31	3x	caller <- parent.frame()
32	3x	building <- !is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts"
33	3x	parts <- new.env()
34	3x	attr(parts, "name") <- "community_site_parts"
35	3x	parts$uid <- caller$uid
36	3x	elements <- substitute(...())
37	3x	n <- length(elements)
38	3x	wraps <- rep_len(wraps, n)
39	3x	sizes <- rep_len(sizes, n)
40	3x	breakpoints <- rep_len(breakpoints, n)
41	3x	conditions <- rep_len(conditions, n)
42	3x	ids <- paste0("modal", parts$uid, seq_len(n))
43	3x	r <- paste0(
44	3x	'<button type="button" class="btn popup-button" data-bs-toggle="modal" data-bs-target="#dialog',
45	3x	parts$uid, '"', if (!is.null(id)) paste0(' id="', id, '"'), ">", text, "</button>"
46		)
47	3x	b <- c(
48	3x	paste0(
49	3x	'<div class="modal" tabindex="-1" id="dialog', parts$uid,
50	3x	'"><div class="modal-dialog"><div class="modal-content">'
51		),
52	3x	paste0(
53	3x	'<div class="modal-header"><div class="modal-title">', paste(title, collapse = ""), "</div>",
54	3x	'<button type="button" class="btn-close" data-bs-dismiss="modal" aria-label="Close"></button>',
55	3x	"</div>"
56		),
57	3x	'<div class="modal-body">',
58	3x	unlist(lapply(seq_len(n), function(i) {
59	3x	c(
60	3x	if (!is.na(wraps[i]) \|\| conditions[i] != "") {
61	!	paste(c(
62	!	'<div class="', if (is.na(wraps[i])) "" else wraps[i],
63	!	if (!is.na(breakpoints[i])) c("-", breakpoints[i]),
64	!	if (!is.na(sizes[i])) c("-", sizes[i]),
65	!	'"', if (conditions[i] != "") c(' id="', ids[i], '"'), ">"
66	!	), collapse = "")
67		},
68	3x	eval(elements[[i]], parts),
69	3x	if (!is.na(wraps[i])) "</div>"
70		)
71	3x	}), use.names = FALSE),
72	3x	"</div>",
73	3x	if (!is.null(footer)) {
74	!	c(
75	!	'<div class="modal-footer">',
76	!	unlist(lapply(footer, function(e) {
77	!	eval(e, parts, caller)
78	!	}), use.names = FALSE),
79	!	"</div>"
80		)
81		},
82	3x	"</div></div></div>"
83		)
84	3x	if (building) {
85	1x	caller$body <- c(caller$body, b)
86	1x	caller$content <- c(caller$content, r)
87	!	for (n in names(parts)) if (n != "content" && n != "uid") caller[[n]] <- c(caller[[n]], parts[[n]])
88	1x	process_conditions(conditions, ids, caller)
89	1x	caller$uid <- parts$uid + 1
90		}
91	3x	r
92		}

1		#' Format a JavaScript Color Palette
2		#'
3		#' Make a specially-formatted color palette based on color codes.
4		#'
5		#' @param colors A vector of color names or HEX codes, or a matrix-like object with
6		#' colors in columns, and their RGB values in separate rows.
7		#' @param continuous Logical; if \code{TRUE}, \code{colors} are treated as points in a linear
8		#' gradient. One provided color will be from white to that color. Two provided colors will
9		#' be between those colors. Three or four provided colors will be between the first and
10		#' last color, with the central color (or average of the central colors) as the midpoint.
11		#' @param divergent Logical; if \code{TRUE}, marks continuous scales as divergent,
12		#' which will reverse the lower half of the scale.
13		#' @param polynomial Logical; if \code{TRUE}, will fit a polynomial regression model to each color
14		#' channel in the specified \code{colors} sequence. Used to either compress a long sequence
15		#' (e.g., model a fully manually specified scale), or interpolate a scale between anchors.
16		#' @param degrees Number of polynomial degrees, if \code{polynomial} is \code{TRUE}.
17		#' @param pad If \code{polynomial} is \code{TRUE}, number of repeated observations of the
18		#' initial and final colors in the sequence to add in order to reduce warping at the edges.
19		#' @param name Name of the palette.
20		#' @param preview Logical; if \code{TRUE}, makes a plot showing the palette colors / scale.
21		#' @param print Logical; if \code{FALSE}, will not print a version of the palette.
22		#' @examples
23		#' # a discrete palette
24		#' util_make_palette(c("red", "green", "blue"), FALSE)
25		#'
26		#' # a continuous palette
27		#' util_make_palette("red")
28		#'
29		#' # a divergent continuous palette
30		#' util_make_palette(c("red", "green"), divergent = TRUE)
31		#' @return An invisible list of the created palette.
32		#' @export
33
34		util_make_palette <- function(colors, continuous = length(colors) < 5, divergent = length(colors) > 2,
35		polynomial = FALSE, degrees = 6, pad = 10, name = "custom", preview = TRUE, print = TRUE) {
36	!	if (missing(polynomial) && (!missing(degrees) \|\| !missing(pad))) polynomial <- TRUE
37	7x	if (polynomial) {
38	1x	if (missing(divergent)) divergent <- FALSE
39	1x	if (!missing(continuous) && !continuous) {
40	!	cli_alert_warning(
41	!	"{.arg polynomial} if {.val TRUE}, so {.arg continuous} will also be {.val TRUE}"
42		)
43		}
44	1x	continuous <- TRUE
45		}
46	7x	if (is.character(colors)) {
47	6x	cols <- col2rgb(colors)
48		} else {
49	1x	cols <- colors
50	1x	if (is.null(dim(cols))) {
51	1x	cols <- if (is.list(cols)) {
52	!	as.data.frame(cols)
53		} else {
54	1x	matrix(cols, 3, dimnames = list(c("red", "green", "blue")))
55		}
56	!	} else if (ncol(cols) == 3 && nrow(cols) != 3) cols <- t(cols)
57		}
58	!	if (nrow(cols) != 3) cli_abort("{.arg colors} could not be resolved to a matrix of RGB vectors")
59	7x	palette <- if (continuous) {
60	4x	if (polynomial) {
61	1x	rownames(cols) <- c("red", "green", "blue")
62	1x	colnames(cols) <- NULL
63	1x	x <- seq.int(0, 1, length.out = ncol(cols))
64	!	if (max(cols) <= 1) cols <- cols * 256
65	1x	ori <- list(x = x, cols = cols)
66	1x	if (is.numeric(pad) && pad > 0) {
67	1x	x <- c(numeric(pad), x, rep(1, pad))
68	1x	cols <- cbind(
69	1x	matrix(rep(as.numeric(cols[, 1]), pad), 3, dimnames = list(rownames(cols))),
70	1x	cols,
71	1x	matrix(rep(as.numeric(cols[, ncol(cols)]), pad), 3, dimnames = list(rownames(cols)))
72		)
73		}
74	1x	coefs <- vapply(1:3, function(ch) {
75	3x	as.numeric(lm(cols[ch, ] ~ poly(x, degree = degrees, raw = TRUE, simple = TRUE))$coefficients)
76	1x	}, numeric(degrees + 1))
77	!	if (anyNA(coefs)) cli_abort("this combination of inputs resulted in missing coefficient estimates")
78	1x	if (preview) {
79	1x	mm <- cbind(1, poly(ori$x, degrees, raw = TRUE))
80	1x	plot(
81	1x	NA,
82	1x	xlim = c(0, 1), ylim = c(0, 1), axes = FALSE, pch = 15, cex = 2,
83	1x	main = "Palette Comparison", ylab = "Palette", xlab = "Value"
84		)
85	1x	mtext(paste0("Degrees: ", degrees, ", Padding: ", pad), 3)
86	1x	axis(1)
87	1x	axis(2, c(.70, .30), c("Original", "Derived"), lwd = 0)
88	1x	n <- length(ori$x)
89	1x	points(ori$x, rep(.70, n), pch = "\|", cex = 7, col = do.call(rgb, as.data.frame(t(ori$cols) / 256)))
90	1x	points(ori$x, rep(.30, n), pch = "\|", cex = 7, col = do.call(rgb, lapply(1:3, function(ch) {
91	3x	cv <- (mm %*% coefs[, ch]) / 256
92	3x	cv[cv < 0] <- 0
93	3x	cv[cv > 1] <- 1
94	3x	cv
95		})))
96		}
97	1x	list(
98	1x	name = name,
99	1x	type = paste0("continuous", "-polynomial"),
100	1x	colors = coefs
101		)
102		} else {
103	3x	if (length(colors) < 3) {
104	1x	if (length(colors) == 1) cols <- cbind(c(0, 0, 0), cols)
105	2x	cols <- cbind(cols[, 1], rowMeans(cols), cols[, 2])
106		} else {
107	1x	if (ncol(cols) != 3) cols <- cbind(cols[, 1], rowMeans(cols[, 2:3]), cols[, 4])
108		}
109	3x	cols <- t(cols)
110	3x	list(
111	3x	name = name,
112	3x	type = paste0("continuous", if (divergent) "-divergent"),
113	3x	colors = list(
114	3x	rbind(cols[3, ], cols[2, ] - cols[3, ]),
115	3x	cols[2, ],
116	3x	rbind(cols[1, ], cols[2, ] - cols[1, ])
117		)
118		)
119		}
120		} else {
121	3x	list(
122	3x	name = name,
123	3x	type = "discrete",
124	3x	colors = unlist(lapply(
125	3x	as.data.frame(cols / 255), function(col) do.call(rgb, as.list(col))
126	3x	), use.names = FALSE)
127		)
128		}
129	2x	if (print) cat(jsonlite::toJSON(palette, auto_unbox = TRUE, pretty = TRUE))
130	7x	invisible(palette)
131		}

1		#' Check the structure of a templated project
2		#'
3		#' Check if the parts of a template are in place, based on the template's spec.
4		#'
5		#' @param template Name of the template (e.g., \code{"function"}).
6		#' @param name Name of the template instance (e.g., \code{"test_function"}).
7		#' @param dir Path to the base directory of the template.
8		#' @param spec The template's spec; specify if template spec files do not exist.
9		#' @examples
10		#' \dontrun{
11		#' # precheck before a new template is made
12		#' check_template("template_new", list(name = "new", context = "new", files = list("new.R")))
13		#'
14		#' # check the new template after creation
15		#' check_template("new")
16		#' }
17		#' @return A list with results of the check:
18		#' \tabular{rl}{
19		#' \strong{dir} \tab Path of the checked directory. \cr
20		#' \strong{files} \tab Path(s) of the checked files. \cr
21		#' \strong{spec} \tab A list with the template's spec. \cr
22		#' \strong{status} \tab A named logical vector indicating whether each components exist. \cr
23		#' \strong{incomplete} \tab A character vector with any existing files that still have template text. \cr
24		#' \strong{exists} \tab \code{all(status)} \cr
25		#' \strong{message} \tab A character vector including messages associated with failures. \cr
26		#' }
27		#' @export
28
29		check_template <- function(template, name = "", dir = ".", spec = NULL) {
30	!	if (missing(template)) cli_abort("{.arg template} must be specified")
31	45x	template <- sub("^init_", "", template)
32	45x	report <- list(
33	45x	dir = dir,
34	45x	files = list(),
35	45x	spec = spec,
36	45x	status = c(spec = !is.null(spec), dir = FALSE, strict = TRUE, set = TRUE),
37	45x	incomplete = character(),
38	45x	exists = FALSE,
39	45x	message = character()
40		)
41	45x	if (is.null(spec)) {
42	45x	path <- paste0(
43	45x	path.package("community"),
44	45x	if (file.exists(paste0(path.package("community"), "/inst"))) "/inst",
45	45x	"/specs/",
46	45x	sub(".json", "", template, fixed = TRUE),
47	45x	".json"
48		)
49	45x	report$status["spec"] <- file.exists(path)
50	45x	if (!report$status["spec"]) {
51	!	report$status[] <- FALSE
52	!	return(report)
53		}
54	45x	spec <- jsonlite::read_json(path)
55		}
56	45x	report$spec <- spec
57	45x	if (missing(name)) {
58	39x	name <- spec$name
59		}
60	45x	strict <- vapply(spec$files, function(f) is.character(f) && length(f) == 1, TRUE)
61	45x	dir <- paste0(normalizePath(paste0(dir, "/", spec$dir), "/", FALSE), "/")
62	45x	report$dir <- dir
63	45x	report$status["dir"] <- dir.exists(dir)
64	45x	if (spec$context != spec$name) {
65	2x	check_context <- check_template(spec$context, dir = dir)
66	!	if (!check_context$exists) cli_abort(c("context {spec$context} check failed for {name}:", check_context$message))
67		}
68	45x	if (!report$status["dir"]) {
69	6x	report$message <- c(x = paste0(
70	6x	"the required directory ({.path ",
71	6x	spec$dir,
72	6x	"}) is not present in {.path ",
73	6x	normalizePath(dir, "/", FALSE),
74		"}"
75		))
76		}
77	45x	if (any(strict)) {
78	45x	files <- gsub("{name}", name, paste0(dir, unlist(spec$files[strict])), fixed = TRUE)
79	45x	report$files <- files
80	45x	present <- file.exists(files)
81	45x	report$status["strict"] <- all(present)
82	45x	if (!report$status["strict"]) {
83	17x	report$message <- c(report$message, x = paste0(
84	17x	"required file",
85	17x	if (sum(!present) == 1) " is" else "s are",
86	17x	" not present: ",
87	17x	paste0("{.path ", files[!present], "}", collapse = ", ")
88		))
89		} else {
90	28x	for (f in files[present]) {
91	173x	if (!dir.exists(f) && grepl("<template:", paste(readLines(f, warn = FALSE), collapse = ""), fixed = TRUE)) {
92	9x	report$incomplete <- c(report$incomplete, f)
93		}
94		}
95		}
96		}
97	45x	if (any(!strict)) {
98	!	file_set <- spec$files[!strict][[1]]
99	!	if (length(file_set) == 1) {
100	!	files <- gsub("{name}", spec$name, paste0(dir, file_set[[1]]), fixed = TRUE)
101	!	report$files <- c(report$files, files)
102	!	present <- file.exists(files)
103	!	report$status["set"] <- any(present)
104	!	if (!report$status["set"]) {
105	!	report$message <- c(report$message, x = paste(
106	!	"one of these files is required, but none were present:",
107	!	paste(files, collapse = ", ")
108		))
109		} else {
110	!	for (f in files[present]) {
111	!	if (!dir.exists(f) && grepl("<template:", paste(readLines(f, warn = FALSE), collapse = ""), fixed = TRUE)) {
112	!	report$incomplete <- c(report$incomplete, f)
113		}
114		}
115		}
116		} else {
117	!	file_set <- lapply(file_set, function(fl) gsub("{name}", spec$name, paste0(dir, fl), fixed = TRUE))
118	!	report$files <- c(report$files, unlist(file_set))
119	!	present <- vapply(file_set, function(fl) all(file.exists(fl)), TRUE)
120	!	report$status["set"] <- any(present)
121	!	if (!report$status["set"]) {
122	!	report$message <- c(report$message, paste(
123	!	x = "none of the required file sets were complete:",
124	!	file_set
125		))
126		} else {
127	!	for (fl in file_set[present]) {
128	!	for (f in fl) {
129	!	if (!dir.exists(f) && grepl("<template:", paste(readLines(f, warn = FALSE), collapse = ""), fixed = TRUE)) {
130	!	report$incomplete <- c(report$incomplete, f)
131		}
132		}
133		}
134		}
135		}
136		}
137	45x	if (report$status["dir"] && any(!report$status[c("strict", "set")])) {
138	11x	report$message <- c(
139	11x	report$message,
140	11x	i = "use {.fn template_{name}} to create required structure"
141		)
142		}
143	28x	if (all(report$status)) report$exists <- TRUE
144	45x	report
145		}

1		#' Make a Copy of a Data Site
2		#'
3		#' Copies baseline files from an existing data site. Useful for making different sites
4		#' based on the same data.
5		#'
6		#' @param parent Directory or GitHub repository name of the existing site to be copied.
7		#' @param dir Directory of the child site to put copies in.
8		#' @param update Logical; if \code{TRUE}, replaces existing site files if they are older than existing
9		#' files (from a local directory). Same as \code{overwrite} for remote sites. By default, only the
10		#' \code{datapackage.json} file is updated.
11		#' @param overwrite Logical; if \code{TRUE}, overwrites any existing site files. \code{datapackage.json}
12		#' is always overwritten.
13		#' @param protect A vector of file paths to prevent from being overwritten, relative to the site directory.
14		#' @param include A vector of paths to additional files to update from the parent site, relative to the
15		#' site's base directory.
16		#' @param quiet Logical; if \code{TRUE}, does not send messages.
17		#' @examples
18		#' \dontrun{
19		#' site_make_child("uva-bi-sdad/community_example", "../community_example")
20		#' }
21		#' @return Invisible path to the child directory.
22		#' @export
23
24		site_make_child <- function(parent, dir, update = FALSE, overwrite = FALSE, protect = "site.R",
25		include = NULL, quiet = !interactive()) {
26	!	if (missing(dir)) cli_abort('{.arg dir} must be speficied (e.g., dir = "child_site")')
27	1x	check <- check_template("site", dir = dir)
28	1x	if (!quiet && any(file.exists(check$files)) && !overwrite) {
29	!	cli_bullets(c(`!` = "site files already exist", i = "add {.code overwrite = TRUE} to overwrite them"))
30		}
31	1x	dir <- normalizePath(paste0(dir, "/", check$spec$dir), "/", FALSE)
32	1x	dir.create(dir, FALSE, TRUE)
33	1x	dir.create(paste0(dir, "/docs/data"), FALSE, TRUE)
34	1x	files <- unique(c(unlist(check$spec$files, use.names = FALSE), "docs/data/datapackage.json", include))
35	1x	filled <- copied <- structure(!file.exists(paste0(dir, "/", files)), names = files)
36	1x	copied[] <- FALSE
37	1x	if (!file.exists(paste0(dir, "/build.R"))) {
38	1x	copied["build.R"] <- TRUE
39	1x	args <- lapply(match.call()[-1], eval, parent.frame())
40	1x	writeLines(paste(c(
41	1x	paste0("# this is a child site spawned from ", parent, ":"),
42	1x	paste0(
43	1x	"site_make_child(\n ",
44	1x	paste(vapply(names(args), function(a) {
45	2x	if (a %in% c("parent", "dir")) {
46	2x	paste0(a, ' = "', normalizePath(args[[a]], "/", FALSE), '"')
47		} else {
48	!	paste(a, "=", args[[a]])
49		}
50	1x	}, ""), collapse = ",\n "),
51	1x	"\n)"
52		),
53		""
54	1x	), collapse = "\n"), paste0(dir, "/build.R"))
55		}
56	1x	init_site(dir, with_data = FALSE, quiet = TRUE)
57	1x	never_update <- c("build.R", "README.rm", protect)
58	1x	always_update <- c("docs/data/datapackage.json", include)
59	1x	if (!dir.exists(parent)) {
60	1x	parent <- regmatches(parent, regexec("^(?:.*github\\.com/)?([^/]+/[^/@]+)", parent))[[1]][2]
61	1x	repo <- tryCatch(jsonlite::read_json(
62	1x	paste0("https://api.github.com/repos/", parent, "/contents")
63	1x	), error = function(e) e$message)
64	!	if (is.character(repo)) cli_abort("treated {.arg parent} as a GitHub repository, but failed to retrieve it: {repo}")
65	1x	if (missing(update)) update <- FALSE
66	1x	repo <- c(
67	1x	repo,
68	1x	tryCatch(jsonlite::read_json(
69	1x	paste0("https://api.github.com/repos/", parent, "/contents/docs")
70	1x	), error = function(e) NULL),
71	1x	tryCatch(jsonlite::read_json(
72	1x	paste0("https://api.github.com/repos/", parent, "/contents/docs/data")
73	1x	), error = function(e) NULL)
74		)
75	1x	for (f in repo) {
76	27x	if (f$path %in% files[!files %in% never_update]) {
77	7x	dest <- paste0(dir, "/", f$path)
78	7x	if (f$path %in% always_update \|\| overwrite \|\| update \|\| filled[[f$path]]) {
79	7x	unlink(dest)
80	7x	tryCatch(download.file(f$download_url, dest, quiet = TRUE), error = function(e) NULL)
81	7x	copied[[f$path]] <- file.exists(dest)
82		}
83		}
84		}
85		} else {
86	!	for (f in files[!files %in% never_update]) {
87	!	pf <- paste0(parent, "/", f)
88	!	dest <- paste0(dir, "/", f)
89	!	if (file.exists(pf) && (f %in% always_update \|\| overwrite \|\| filled[[f]] \|\| (update && file.mtime(pf) > file.mtime(dest)))) {
90	!	unlink(dest)
91	!	file.copy(pf, dest)
92	!	copied[[f]] <- file.exists(dest)
93		}
94		}
95		}
96	1x	if (!quiet) {
97	!	if (any(copied)) {
98	!	cli_bullets(c(
99	!	v = "copied from {.path {parent}}:",
100	!	"*" = paste0("{.path ", names(which(copied)), "}")
101		))
102		}
103	!	if (any(filled & !copied)) {
104	!	cli_bullets(c(
105	!	v = "created from template:",
106	!	"*" = paste0("{.path ", names(which(filled & !copied)), "}")
107		))
108		}
109	!	if (!any(filled \| copied)) {
110	!	cli_alert_success("no site files were replaced")
111		}
112		}
113	1x	invisible(dir)
114		}

1		#' Add checkboxes, radio buttons, or switches to a website
2		#'
3		#' Adds a set of checkbox, radio buttons, or switches to a website.
4		#'
5		#' @param label Label of the input for the user.
6		#' @param options A vector of options, the name of a variable from which to pull levels, or either \code{"datasets"}
7		#' or \code{"variables"} to select names of datasets or variables.
8		#' @param default A vector of items to check by default (or "all" or "none") if \code{multi} is \code{TRUE}, or
9		#' the option to select by default.
10		#' @param display A display version of the options.
11		#' @param id Unique id of the element to be created.
12		#' @param ... Additional attributes to set on the element.
13		#' @param note Text to display as a tooltip for the input.
14		#' @param variable The name of a variable from which to get levels (overwritten by \code{depends}).
15		#' @param dataset The name of an included dataset, where \code{variable} should be looked for; only applies when
16		#' there are multiple datasets with the same variable name.
17		#' @param depends The id of another input on which the options depend; this will take president over \code{dataset}
18		#' and \code{variable}, depending on this type of input \code{depends} points to.
19		#' @param multi Logical; if \code{FALSE}, only one option can be selected at a time, turning the checkboxes into radio
20		#' buttons.
21		#' @param as.switch Logical; if \code{TRUE}, displays checkboxes or radio buttons as switches.
22		#' @examples
23		#' \dontrun{
24		#' input_checkbox("Label", c("a", "b", "c"))
25		#' }
26		#' @return A character vector of the contents to be added.
27		#' @seealso For a single switch or checkbox, use \code{\link{input_switch}}.
28		#' @export
29
30		input_checkbox <- function(label, options, default = "all", display = options, id = label, ..., note = NULL, variable = NULL,
31		dataset = NULL, depends = NULL, multi = TRUE, as.switch = FALSE) {
32	3x	if (multi && length(default) == 1) {
33	3x	if ((is.logical(default) && default) \|\| default == "all") {
34	3x	default <- options
35	!	} else if ((is.logical(default) && !default) \|\| default == "none") {
36	!	default <- NULL
37		}
38	!	} else if (!multi && is.character(default)) {
39	!	default <- which((if (default %in% display) display else options) == default)
40	!	if (!length(default)) default <- 1
41		}
42	3x	id <- gsub("\\s", "", id)
43	3x	a <- list(...)
44	3x	type <- if (multi) "checkbox" else "radio"
45	3x	r <- c(
46	3x	'<div class="wrapper checkbox-wrapper">',
47	3x	paste0(
48	3x	"<fieldset",
49	3x	if (length(a)) paste("", paste(names(a), paste0('"', unlist(a), '"'), sep = "=")),
50		">"
51		),
52	3x	paste0("<legend>", label, "</legend>"),
53	3x	paste0(
54	3x	'<div class="auto-input" role="group" data-autoType="', type, '" id="', id, '" ',
55	3x	if (is.character(options) && length(options) == 1) paste0('data-optionSource="', options, '"'),
56	3x	if (!is.null(default)) paste0(' data-default="', paste(default, collapse = ","), '"'),
57	3x	if (!is.null(depends)) paste0(' data-depends="', depends, '"'),
58	3x	if (!is.null(note)) paste0(' aria-description="', note, '"'),
59	3x	if (!is.null(dataset)) paste0(' data-dataset="', dataset, '"'),
60	3x	if (!is.null(variable)) paste0(' data-variable="', variable, '"'),
61	3x	if (as.switch) paste0(' data-switch="', as.switch, '"'),
62	3x	if (length(a)) unlist(lapply(seq_along(a), function(i) paste0(" ", names(a)[i], '="', a[[i]], '"'))),
63		">"
64		),
65	3x	if (length(options) > 1) {
66	3x	unlist(lapply(seq_along(options), function(i) {
67	9x	c(
68	9x	paste0('<div class="form-check', if (as.switch) " form-switch", '">'),
69	9x	paste0(
70	9x	'<input type="', type, '" autocomplete="off" class="form-check-input" name="',
71	9x	id, '_options" id="', id, "_option", i, if (as.switch) '" role="switch', '" value="',
72	9x	options[i], '"', if ((multi && options[i] %in% default) \|\| i == default) " checked", ">"
73		),
74	9x	paste0('<label class="form-check-label" for="', id, "_option", i, '">', display[i], "</label>"),
75	9x	"</div>"
76		)
77	3x	}), use.names = FALSE)
78		},
79	3x	"</div>",
80	3x	"</fieldset>",
81	3x	"</div>"
82		)
83	3x	caller <- parent.frame()
84	3x	if (!is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts") {
85	1x	caller$content <- c(caller$content, r)
86		}
87	3x	r
88		}

1		#' Add a number input to a website
2		#'
3		#' Adds an direct number input element to a website.
4		#'
5		#' @param label Label of the input for the user.
6		#' @param id Unique ID of the element to be created.
7		#' @param ... Other attributes to add to the input.
8		#' @param default Default value of the input, the ID of an input to use as the default, or \code{"min"} or \code{"max"}
9		#' to default to the current minimum or maximum value.
10		#' @param variable The name of a variable or ID of a variable selector to get a range from.
11		#' @param min The smallest allowed value.
12		#' @param max The largest allowed value.
13		#' @param step Amount to increase or decrease the value by when changed with arrows.
14		#' @param type Name of the input's type -- other number-based types like \code{date} might make sense.
15		#' @param class Class names to add to the input's list.
16		#' @param note Text to display as a tooltip for the input.
17		#' @param dataview ID of a \code{\link{input_dataview}}, to use as a source of variables.
18		#' @param floating_label Logical; if \code{FALSE}, labels are separate from their input elements.
19		#' @param buttons Logical; if \code{TRUE}, adds increment and decrement buttons to the sides of the input.
20		#' @param show_range Logical; if \code{TRUE}, adds min and max indicators around the input field.
21		#' @examples
22		#' \dontrun{
23		#' input_text("entered_text", "Enter Text:")
24		#' }
25		#' @return A character vector of the contents to be added.
26		#' @export
27
28		input_number <- function(label, id = label, ..., default = NULL, variable = NULL, min = NULL, max = NULL, step = NULL,
29		type = "number", class = NULL, note = NULL, dataview = NULL, floating_label = TRUE,
30		buttons = FALSE, show_range = FALSE) {
31	3x	id <- gsub("\\s", "", id)
32	3x	r <- c(
33	3x	if (buttons \|\| show_range) '<div class="wrapper number-input-row">',
34	3x	if (show_range) {
35	!	paste0(
36	!	'<div><button role="button" label="set value to min" class="text-muted indicator-min"><span>', min, "</span></button></div>"
37		)
38		},
39	3x	if (buttons) '<button role="button" label="decrease value" class="btn number-down"><</button>',
40	3x	paste0('<div class="wrapper text-wrapper', if (floating_label) " form-floating", '">'),
41	3x	if (!floating_label) paste0('<label for="', id, '">', label, "</label>"),
42	3x	paste0(c(
43	3x	'<input type="', type, '"',
44	3x	' id="', id, '"',
45	3x	if (!is.null(default)) paste0(' data-default="', default, '"'),
46	3x	if (!is.null(note)) paste0(' aria-description="', note, '"'),
47	3x	if (!is.null(variable)) paste0(' data-variable="', variable, '"'),
48	3x	if (!is.null(min)) paste0(' min="', min, '"'),
49	3x	if (!is.null(max)) paste0(' max="', max, '"'),
50	3x	if (!is.null(step)) paste0(' step="', step, '"'),
51	3x	if (!is.null(dataview)) paste0(' data-view="', dataview, '"'),
52	3x	unlist(list(...)),
53	3x	' class="form-control auto-input', if (!is.null(class)) paste("", class), '" data-autoType="number">',
54	3x	if (floating_label) paste0('<label for="', id, '">', label, "</label>")
55	3x	), collapse = ""),
56	3x	"</div>",
57	3x	if (buttons) '<button role="button" label="increase value" class="btn number-up">></button>',
58	3x	if (show_range) {
59	!	paste0(
60	!	'<div><button role="button" label="set value to max" class="text-muted indicator-max"><span>', max, "</span></button></div>"
61		)
62		},
63	3x	if (buttons \|\| show_range) "</div>"
64		)
65	3x	caller <- parent.frame()
66	3x	if (!is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts") {
67	1x	caller$content <- c(caller$content, r)
68		}
69	3x	r
70		}

1		#' Add a unified data view to a website
2		#'
3		#' Collects specified inputs to create a filtered dataset from which outputs can pull.
4		#'
5		#' @param id An ID of the data view, for association with output elements. Defaults to \code{'view'} appended
6		#' with a zero-index of views, based on the order in which they were specified
7		#' (e.g., \code{'view0'} for the first view).
8		#' @param y Primary variable of interest, used by default to color elements in outputs, and shown on the y-axis
9		#' of plots; name of a variable or ID of a variable selector.
10		#' @param x Secondary variable, shown by default on the x-axis of plots, and across columns in a single-variable table;
11		#' name of a variable or ID of a variable selector.
12		#' @param time Name of a variable giving names to multiple time points (such as a vector of years). Defaults to
13		#' the time specified in an associated metadata, or a sequence along each variable.
14		#' @param time_agg Specifies how multiple time points should be treated when a single value is required.
15		#' Default is to use the last time with data. This could point to an input which selects a time.
16		#' @param time_filters A list with entries specifying which years to display. Each entry should be a list
17		#' with entries for \code{"variable"} (which variable is being filtered, which can be \code{"index"}),
18		#' \code{"type"} (specifying the operator, such as \code{">"}), and \code{"value"}. The value of each entry
19		#' can be static (e.g., referring to a variable) or the ID of an input.
20		#' @param dataset Select which dataset to pull from; the name of an included dataset, or ID of a
21		#' selector of dataset names.
22		#' @param ids Select which IDs to include; a vector of IDs that appear in the specified dataset, or the ID of a
23		#' selector of IDs. If an IDs map is included in the site's datapackage, mapped components can be referred to here.
24		#' @param features Select IDs based on their features; a named list or vector, with names corresponding to
25		#' the names of features included in an \code{ids} field of the site's datapackage, and values corresponding to
26		#' a value or vector of values, or a selector of values.
27		#' @param variables Select IDs based on the values of their variables; a list of lists with entries for
28		#' \code{"variable"} (name of the variable), \code{"type"} (comparison operator), and \code{"value"} (value to
29		#' check against). For example, \code{list(list(variable = "a", type = ">", value = 0))}. Each entry
30		#' may also refer to another input.
31		#' @param palette The name of the color palette used in maps and plots (from
32		#' \href{https://colorbrewer2.org}{colorbrewer}); one of \code{"rdylbu7"} (default), \code{"orrd7"}, \code{"gnbu7"},
33		#' \code{"brbg7"}, \code{"puor7"}, \code{"prgn6"}, \code{"reds5"}, \code{"greens5"}, \code{"greys4"}, \code{"paired4"}.
34		#' @examples
35		#' \dontrun{
36		#' input_dataview()
37		#' }
38		#' @return A list of the entered options.
39		#' @export
40
41		input_dataview <- function(id = NULL, y = NULL, x = NULL, time = NULL, time_agg = "last", time_filters = list(),
42		dataset = NULL, ids = NULL, features = NULL, variables = NULL, palette = "") {
43	3x	caller <- parent.frame()
44	3x	building <- !is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts"
45	3x	r <- list(palette = tolower(palette))
46	!	if (!is.null(y)) r$y <- y
47	!	if (!is.null(x)) r$x <- x
48	!	if (!is.null(time)) r$time <- time
49	3x	if (!is.null(time_agg)) r$time_agg <- time_agg
50	3x	if (!length(time_filters)) r$time_filters <- time_filters
51	3x	if (!is.null(dataset)) r$dataset <- dataset
52	3x	if (!is.null(ids)) r$ids <- ids
53	3x	if (!is.null(features)) r$features <- as.list(features)
54	!	if (!is.null(variables)) r$variables <- if (!is.list(variables[[1]])) list(variables) else variables
55	3x	if (length(r) && building) {
56	1x	caller$dataviews[[if (is.null(id)) paste0("view", length(caller$dataviews)) else id]] <- r
57		}
58	3x	r
59		}

1		#' Create a Data Repository
2		#'
3		#' Create a repository for a dataset, which may include data documentation and/or a data site.
4		#'
5		#' @param dir Directory in which to create the repository's structure. Will be created if it does not exist.
6		#' @param datasets A character vector of dataset names; for each of these, a subdirectory will be made
7		#' containing \code{code} and \code{data} directories.
8		#' @param init_data Logical; if \code{FALSE}, will not run \code{\link{init_data}} on the repository.
9		#' @param init_site Logical; if \code{FALSE}, will not run \code{\link{init_site}} on the repository.
10		#' @param init_git Logical; if \code{FALSE}, will not run \code{git init} on the repository.
11		#' @param template A character indicating which site and build template to use, between
12		#' \code{sdad_dashboard} (default) and \code{repository_site}.
13		#' @param overwrite Logical; if \code{TRUE}, will overwrite existing site files in \code{dir}.
14		#' @param quiet Logical; if \code{TRUE}, suppresses messages.
15		#' @examples
16		#' \dontrun{
17		#' # initialize repository in the current working directory
18		#' init_repository(".")
19		#' }
20		#' @return Path to the created repository directory.
21		#' @export
22
23		init_repository <- function(dir, datasets = NULL, init_data = TRUE, init_site = TRUE, init_git = TRUE,
24		template = "sdad_dashboard", overwrite = FALSE, quiet = !interactive()) {
25	!	if (missing(dir)) cli_abort('{.arg dir} must be speficied (e.g., dir = ".")')
26	3x	check <- check_template("repository", dir = dir)
27	3x	datasets_inited <- file.exists(paste0(dir, "/", datasets, "/data"))
28	3x	dir <- normalizePath(paste0(dir, "/", check$spec$dir), "/", FALSE)
29	3x	dir.create(dir, FALSE, TRUE)
30	3x	dir.create(paste0(dir, "/docs"), FALSE)
31	3x	paths <- paste0(dir, "/", c("README.md", ".gitignore", "build.R", "site.R"))
32	3x	if (!file.exists(paths[1])) {
33	2x	writeLines(c(
34	2x	"<template: Describe the repository>",
35	2x	"\n# Structure",
36	2x	"This is a community data repository, created with the `community::init_repository()` function.",
37	2x	"1. `{set}/code/distribution/ingest.R` should download and prepare data from a public source, and output files to `{set}/data/distribution`.",
38	2x	"2. `{set}/data/distribution/measure_info.json` should contain metadata for each of the measures in the distribution data file(s).",
39	2x	if (init_site) {
40	2x	paste(
41	2x	"3. `build.R` will convert the distribution data to site-ready versions,",
42	2x	"and `site.R` specifies the interface of the repository-specific data site."
43		)
44		}
45	2x	), paths[1])
46		}
47	3x	if (!file.exists(paths[2])) {
48	2x	writeLines(c(
49	2x	".Rproj.user",
50	2x	".Rhistory",
51	2x	".RData",
52	2x	".httr-oauth",
53	2x	".DS_Store",
54	2x	".netlify",
55	2x	"*.Rproj",
56	2x	"node_modules",
57	2x	"package-lock.json",
58	2x	"dist",
59	2x	"original"
60	2x	), paths[2])
61		}
62	3x	if (init_site) {
63	3x	td <- paste0(path.package("community"), c("/inst", ""), "/templates/", template, "/")
64	3x	td <- td[which(file.exists(td))[1]]
65	!	if (is.na(td)) td <- paste0(path.package("community"), "/templates/sdad_dashboard")
66	!	if (overwrite) unlink(paste0(dir, c("/build.R", "/site.R")))
67	3x	if (!file.exists(paste0(dir, "/build.R"))) {
68	2x	file.copy(paste0(td, "/build.R"), paste0(dir, "/build.R"))
69		}
70	3x	if (!file.exists(paste0(dir, "/site.R"))) {
71	2x	file.copy(paste0(td, "/site.R"), paste0(dir, "/site.R"))
72		}
73	3x	init_site(dir, with_data = init_data, quiet = TRUE)
74	!	} else if (init_data) {
75	!	init_data("data", quiet = TRUE)
76		}
77	3x	if (is.character(datasets) && any(!datasets_inited)) {
78	3x	for (i in seq_along(datasets)) {
79	3x	dataset <- datasets[i]
80	3x	dirs <- paste0(dir, "/", dataset, c("/code/distribution", "/data"))
81	3x	if (!any(file.exists(dirs))) {
82	3x	dir.create(dirs[[1]], FALSE, TRUE)
83	3x	ingest_file <- paste0(dirs[[1]], "/ingest.R")
84	3x	if (!file.exists(ingest_file)) {
85	3x	writeLines(
86	3x	"# <template: use this file to set up the creation and/or preparation of the data>",
87	3x	ingest_file
88		)
89		}
90	3x	dir.create(paste0(dirs[[2]], "/original"), FALSE, TRUE)
91	3x	dir.create(paste0(dirs[[2]], "/working"), FALSE)
92	3x	dir.create(paste0(dirs[[2]], "/distribution"), FALSE)
93	3x	info_file <- paste0(dirs[[2]], "/distribution/measure_info.json")
94	3x	if (!file.exists(info_file)) writeLines("{}", info_file)
95		}
96		}
97		}
98	3x	if (init_git && !file.exists(paste0(dir, "/.git")) && Sys.which("git") != "") {
99	1x	wd <- getwd()
100	1x	on.exit(setwd(wd))
101	1x	setwd(dir)
102	1x	system2("git", "init")
103		}
104	3x	invisible(dir)
105		}

1		#' Add static text elements to a website.
2		#'
3		#' Adds regular text elements to a website.
4		#'
5		#' @param text A character vector of text to add. Each entry will be a separate element. Text can include
6		#' links to be embedded, in the form \code{"[text](url)"}.
7		#' @param ... Attributes to add to each element.
8		#' @param tag The tag name of each element.
9		#' @examples
10		#' \dontrun{
11		#' # regular text
12		#' page_text("text to be added")
13		#' }
14		#' @return A character vector of the content to be added.
15		#' @export
16
17		page_text <- function(text, ..., tag = "p") {
18	4x	n <- length(text)
19	4x	tag <- rep_len(tag, n)
20	4x	atr <- lapply(list(...), function(a) rep_len(as.character(a), n))
21	4x	r <- unlist(lapply(seq_len(n), function(i) {
22	4x	txt <- text[i]
23	4x	m <- regmatches(txt, gregexpr("\\[.?\\]\\(.?\\)", txt))[[1]]
24	4x	for (l in m) {
25	!	parts <- strsplit(substr(l, 2, nchar(l) - 1), "](", fixed = TRUE)[[1]]
26	!	txt <- sub(
27	!	l,
28	!	paste0('<a target="_blank" rel="noreferrer" href="', parts[2], '">', parts[1], "</a>"),
29	!	txt,
30	!	fixed = TRUE
31		)
32		}
33	4x	paste0(
34	4x	"<", tag[i],
35	4x	if (length(atr)) paste("", paste(paste0(names(atr), '="', vapply(atr, "[[", "", i), '"'), collapse = " ")) else "",
36	4x	">", txt, "</", tag[i], ">"
37		)
38	4x	}), use.names = FALSE)
39	4x	caller <- parent.frame()
40	4x	if (!is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts") {
41	2x	caller$content <- c(caller$content, r)
42		}
43	4x	r
44		}

1		#' Attempt to locate variables in a set of mapped variables.
2		#'
3		#' Somewhat fuzzily match entered variable names to mapped variable names, which
4		#' might be useful if variable names are specified in a view, but are changed slightly
5		#' in their source repositories.
6		#'
7		#' @param missed A vector of variable names or keywords to search for in the full set of mapped variables,
8		#' or the name of or path to a data commons view, from which to extract missed variables.
9		#' @param map Path to the \code{variable_map.csv} file created by \code{\link{datacommons_map_files}},
10		#' the path to a data commons project, or a variable map \code{data.frame}.
11		#' @param sep A regular expression to be treated as a term separator.
12		#' @param top Number of possible matches to return per \code{missed} entry.
13		#' @param metric Name of the similarity metric to use; see \code{\link[lingmatch]{lma_simets}}.
14		#' @examples
15		#' \dontrun{
16		#' # from a data commons project directory
17		#' datacommons_find_variables(c("variable_a", "variable_b"))
18		#'
19		#' # try to find matches to any missed variables in a view
20		#' datacommons_find_variables("view_name")
21		#' }
22		#' @return A list with an entry for each entered variable, containing \code{top} possible matches,
23		#' which are entries from the variable map, with an added .
24		#' @export
25
26		datacommons_find_variables <- function(missed, map = ".", sep = "[_:]", top = 3, metric = "cosine") {
27	!	if (missing(missed)) cli_abort("{.arg missed} must be provided")
28	1x	nm <- length(missed)
29	1x	variable_map <- NULL
30	1x	if (is.character(map)) {
31	1x	if (file.exists(map)) {
32	1x	variable_map <- if (dir.exists(map)) {
33	1x	if (nm == 1 && file.exists(paste0(map, "/views/", missed))) {
34	!	missed <- paste0(map, "/views/", missed)
35		}
36	1x	datacommons_map_files(map, verbose = FALSE)$variables
37		} else {
38	!	read.csv(map)
39		}
40		} else {
41	!	cli_abort("{.arg map} appears to be a path, but it does not exist")
42		}
43		} else {
44	!	variable_map <- map
45		}
46	1x	if (is.null(variable_map$full_name)) {
47	!	cli_abort(
48	!	"{.arg map} does not appear to be or point to a valid variable map"
49		)
50		}
51	1x	full_names <- unique(variable_map$full_name)
52	1x	if (nm == 1 && file.exists(missed)) {
53	!	missed <- jsonlite::read_json(if (dir.exists(missed)) paste0(missed, "/view.json") else missed)
54	!	missed <- as.character(missed$variables)
55	!	if (!length(missed)) cli_abort("did not find any variables in the {.arg missed} view definition")
56	!	missed <- missed[!missed %in% full_names]
57	!	if (!length(missed)) cli_abort("all variables in the {.arg missed} view definition were found")
58	!	nm <- length(missed)
59		}
60	1x	mi <- seq_len(nm)
61	1x	snames <- gsub(sep, " ", c(missed, full_names))
62	1x	dtm <- lma_dtm(snames, numbers = TRUE, punct = TRUE, to.lower = FALSE)
63	1x	sim <- lma_simets(dtm[mi, ], dtm[-mi, ], metric, pairwise = FALSE)
64	1x	if (is.null(dim(sim))) sim <- matrix(sim, nm)
65	1x	top <- seq_len(min(top, length(full_names)))
66	1x	res <- lapply(mi, function(i) {
67	1x	v <- missed[[i]]
68	1x	if (v %in% full_names) {
69	!	cbind(variable_map[variable_map$full_name == v, ], similarity = 1)
70		} else {
71	1x	do.call(rbind, lapply(order(sim[i, ], decreasing = TRUE)[top], function(o) {
72	3x	vr <- variable_map[variable_map$full_name == full_names[[o]], , drop = FALSE]
73	3x	vr$similarity <- sim[i, o]
74	3x	vr
75		}))
76		}
77		})
78	1x	names(res) <- missed
79	1x	res
80		}

1		#' Add dynamic text to a website
2		#'
3		#' Adds a textual output based on the current state of input elements.
4		#'
5		#' @param text A vector of text to be parsed; see details.
6		#' @param tag Tag name of the element containing the text.
7		#' @param id Unique ID of the output element.
8		#' @param class Class names to add to the output's element.
9		#' @param condition A conditional statement to decide visibility of the entire output element.
10		#' @details
11		#' \describe{
12		#' \item{Input References}{\code{text} can include references to inputs by ID within curly brackets
13		#' (e.g., \code{"{input_id}").}}
14		#' \item{Conditions}{Multiple entries in \code{text} translate to separate elements. Each entry can be
15		#' conditioned on a statement within curly brackets following an initial question mark
16		#' (e.g., \code{"?{input_a != 1}Input A is not 1"}). If no statement is included after the question mark,
17		#' the entry will be conditioned on a referred to input (\code{TRUE} if anything is selected).}
18		#' \item{Buttons}{Embedded reset buttons can be specified within square brackets (e.g., \code{"Reset[r input_id]"}).
19		#' Text before the brackets will be the button's display text, with multiple words included within parentheses
20		#' (e.g., \code{"(Reset Input A)[r input_a]"}). If the text is a reference, this will be the default reset
21		#' reference (e.g., \code{"{input_a}[r]"} is the same as \code{"{input_a}[r input_a]"}).}
22		#' }
23		#' @examples
24		#' # text that shows the current value of `input_a`, and resets it on click
25		#' output_text("Selection: {input_a}[r]")
26		#'
27		#' # adds a parenthetical if the value of the input is 0
28		#' output_text(c("Selection: {input_a}[r]", "?{input_a == 0}(input is zero)"))
29		#' @return A character vector of the containing element of the text.
30		#' @export
31
32		output_text <- function(text, tag = "p", id = NULL, class = NULL, condition = NULL) {
33	4x	caller <- parent.frame()
34	4x	building <- !is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts"
35	3x	if (is.null(id)) id <- paste0("text", caller$uid)
36	4x	parsed <- list()
37	!	if (!is.null(names(text))) text <- list(text)
38	4x	parse_text <- function(e) {
39	5x	res <- list()
40
41		# extracting expressions
42	5x	ex <- gsub("^\\{\|\\}$", "", regmatches(e, gregexpr("\\{.*?\\}", e))[[1]])
43
44		# extracting conditional expressions
45	5x	if (grepl("^\\?", e)) {
46	1x	if (grepl("^\\?\\{", e)) {
47	1x	res$condition <- parse_rule(ex[1])
48	1x	ex <- ex[-1]
49	1x	e <- sub("^\\?\\{.*?\\}", "", e)
50		} else {
51	!	res$condition <- parse_rule(paste(ex, collapse = " & "))
52	!	e <- gsub("?", "", e, fixed = TRUE)
53		}
54		}
55
56		# extracting buttons
57	5x	if (grepl("[", e, fixed = TRUE)) {
58	1x	m <- gregexpr("(?:\\([^)[]?\\)\|\\{[^}[]?\\}\|\\b\\w+?)?\\[.*?\\]", e)
59	1x	rb <- regmatches(e, m)[[1]]
60	1x	if (length(rb)) {
61	1x	res$button <- list()
62	1x	for (b in seq_along(rb)) {
63	1x	rbb <- rb[b]
64	1x	bid <- paste0("b", b)
65	1x	res$button[[bid]] <- list(
66	1x	text = as.list(sub(
67	1x	"}", "", strsplit(gsub("^\\(\|\\)?\\[.*$", "", rbb), "{", fixed = TRUE)[[1]],
68	1x	fixed = TRUE
69		)),
70	1x	type = if (grepl("[r", rbb, fixed = TRUE)) "reset" else if (grepl("[n", rbb, fixed = TRUE)) "note" else "update",
71	1x	target = strsplit(gsub("^[^[]*\\[[^\\s]+\\s?\|\\]$", "", rbb, perl = TRUE), ",")[[1]]
72		)
73	1x	if (!length(res$button[[bid]]$target)) {
74	!	res$button[[bid]]$target <- strsplit(if (grepl("{", rbb, fixed = TRUE)) {
75	!	gsub("^[^{].\\{\|\\}.$", "", rbb)
76		} else {
77	!	sub("\\[.*$", "", rbb)
78	!	}, ",")[[1]]
79		}
80		}
81	1x	regmatches(e, m) <- as.list(paste0("_SPLT_", paste0("b", seq_along(rb)), "_SPLT_"))
82		}
83		}
84
85	5x	res$text <- Filter(nchar, strsplit(e, "[{}]\|_SPLT_")[[1]])
86	5x	res
87		}
88	4x	for (i in seq_along(text)) {
89	5x	e <- text[[i]]
90	5x	if (is.null(names(e))) {
91	5x	parsed[[i]] <- parse_text(e)
92		} else {
93	!	parsed[[i]] <- lapply(seq_along(e), function(i) {
94	!	r <- parse_text(e[[i]])
95	!	r$condition <- parse_rule(names(e)[i])
96	!	r
97		})
98		}
99		}
100	4x	r <- paste0(c(
101	4x	"<", tag, ' data-autoType="text" id="', id, '"',
102	4x	' class="auto-output output-text', if (!is.null(class)) paste("", class), '"',
103	4x	"></", tag, ">"
104	4x	), collapse = "")
105	4x	if (building) {
106	2x	caller$text[[id]] <- c(list(text = parsed), if (!is.null(condition)) condition <- parse_rule(condition))
107	2x	caller$content <- c(caller$content, r)
108	2x	caller$uid <- caller$uid + 1
109		}
110	4x	r
111		}

1		#' Render a Website
2		#'
3		#' Write HTML output from the \code{site.R} file in a site project.
4		#'
5		#' @param dir Path to the site project directory.
6		#' @param file Name of the R file to build the site from.
7		#' @param name Name of the HTML file to be created.
8		#' @param variables A character vector of variable names to include from the data. If no specified,
9		#' all variables are included.
10		#' @param options A list with options to be passed to the site. These will be written to \code{docs/settings.json},
11		#' which can be edited by hand.
12		#' @param bundle_data Logical; if \code{TRUE}, will write the data to the site file; useful when
13		#' running the site locally without a server (viewing the file directly in a browser).
14		#' Otherwise, the data will be loaded separately through an http request.
15		#' @param bundle_package Logical; if \code{TRUE}, will include parts of the \code{datapackage.json} file in the
16		#' \code{settings.json} and \code{index.html} files. Otherwise, this will be loaded separately through an http request.
17		#' @param bundle_libs Logical; if \code{TRUE}, will download dependencies to the \code{docs/lib} directory.
18		#' This can allow you to run the site offline for all but Leaflet tiles and any remote resources specified in
19		#' \code{file} (such as map shapes) or metadata (such as map overlays).
20		#' @param libs_overwrite Logical; if \code{TRUE}, will re-download existing dependencies.
21		#' @param libs_base_only Logical; if \code{TRUE}, will only download the base community dependencies to be served locally.
22		#' @param remote_data_handler Logical; if \code{FALSE}, will load the data handler script from the site's directory,
23		#' (which is updated on rebuild) even when \code{version} is custom. Useful for locally testing an API.
24		#' @param open_after Logical; if \code{TRUE}, will open the site in a browser after it is built.
25		#' @param aggregate Logical; if \code{TRUE}, and there is a larger datasets with IDs that partially match
26		#' IDs in a smaller dataset or that has a map to those IDs, and there are NAs in the smaller dataset, will
27		#' attempt to fill NAs with averages from the larger dataset.
28		#' @param sparse_time Logical; if \code{FALSE}, will not trim times from a variable that are all missing.
29		#' @param force Logical; if \code{TRUE}, will reprocess data even if the source data is older than the existing
30		#' processed version.
31		#' @param version Version of the base script and stylesheet: \code{"stable"} (default) for the current stable release,
32		#' \code{"dev"} for the current unstable release, or \code{"local"} for a copy of the development files
33		#' (\code{community.js} and \code{community.css}) served from \code{http://localhost:8000}. Can also
34		#' be a URL where files can be found (\code{{version}/community.js} and \code{{version}/community.css}).
35		#' @param parent Directory path or repository URL of a data site from which to use data, rather than using local data.
36		#' @param include_api Logical; if \code{TRUE}, will write the \code{docs/functions/api.js} file.
37		#' @param endpoint URL of the served API.
38		#' @param tag_id Google tag ID (in the form of \code{GTM-XXXXXX}, were \code{GTM-} might be different depending on the
39		#' tag type (such as \code{G-} or \code{GT-}); see \href{tagmanager.google.com}{https://tagmanager.google.com}),
40		#' which will enables tracking, conditional on the \code{settings.tracking} setting.

1		#' Add a combobox select input to a website
2		#'
3		#' Adds an input to select from the entered options,
4		#' allowing for multiple selection, dynamic filtering, and custom entries.
5		#'
6		#' @param label Label of the input for the user.
7		#' @param options A vector of options, the name of a variable from which to pull levels, or \code{"datasets"},
8		#' \code{"variables"}, \code{"ids"}, or \code{"palettes"} to select names of datasets, variables, entity ids, or
9		#' color palettes. If there is a map with overlay layers with properties, can also be \code{"overlay_properties"},
10		#' to select between properties.
11		#' @param default Which of the options to default to; either its index or value.
12		#' @param display A display version of the options.
13		#' @param id Unique ID of the element to be created.
14		#' @param ... Additional attributes to set on the input element.
15		#' @param strict Logical; if \code{FALSE}, allows arbitrary user input, rather than limiting input to the
16		#' option set.
17		#' @param numeric Logical; if \code{TRUE}, will treat all numeric inputs as custom values,
18		#' rather than as potential option indices.
19		#' @param search Logical; if \code{FALSE}, does not dynamically filter the option set on user input.
20		#' @param multi Logical; if \code{TRUE}, allows multiple options to be selected.
21		#' @param accordion Logical; if \code{TRUE}, option groups will be collapsible.
22		#' @param clearable Logical; if \code{TRUE}, adds a button to clear the selection.
23		#' @param note Text to display as a tooltip for the input.
24		#' @param group_feature Name of a measure or entity feature to use as a source of option grouping,
25		#' if \code{options} is \code{"variables"} or \code{"ids"}.
26		#' @param variable The name of a variable from which to get levels (overwritten by \code{depends}).
27		#' @param dataset The name of an included dataset, where \code{variable} should be looked for; only applies when
28		#' there are multiple datasets with the same variable name.
29		#' @param depends The ID of another input on which the options depend; this will take president over \code{dataset}
30		#' and \code{variable}, depending on this type of input \code{depends} points to.
31		#' @param dataview The ID of an \code{\link{input_dataview}}, used to filter the set of options, and potentially
32		#' specify dataset if none is specified here.
33		#' @param subset Determines the subset of options shown if \code{options} is \code{"ids"}; mainly \code{"filtered"}
34		#' (default) to apply all filters, including the current selection, or \code{"full_filter"} to apply all
35		#' feature and variable filters, but not the current selection. \code{"siblings"} is a special case given a selection,
36		#' which will show other IDs with the same parent.
37		#' @param selection_subset Subset to use when a selection is made; defaults to \code{"full_filter"}.
38		#' @param filters A list with names of \code{meta} entries (from \code{variable} entry in \code{\link{data_add}}'s
39		#' \code{meta} list), and values of target values for those entries, or the IDs of value selectors.
40		#' @param reset_button If specified, adds a button after the input element that will revert the selection
41		#' to its default; either \code{TRUE}, or text for the reset button's label.
42		#' @param button_class Class name to add to the reset button.
43		#' @param as.row Logical; if \code{TRUE}, the label and input are in separate columns within a row.
44		#' @param floating_label Logical; if \code{FALSE} or \code{as.row} is \code{TRUE}, labels are separate from
45		#' their inputs.
46		#' @seealso See \code{\link{input_select}} for a more standard select input, or \code{\link{input_text}}
47		#' for a free-form input.
48		#' @examples
49		#' \dontrun{
50		#' input_combobox("Options", c("a", "b"))
51		#' }
52		#' @return A character vector of the contents to be added.
53		#' @export
54
55		input_combobox <- function(label, options, default = -1, display = options, id = label, ...,
56		strict = TRUE, numeric = FALSE, search = TRUE, multi = FALSE, accordion = FALSE,
57		clearable = FALSE, note = NULL, group_feature = NULL, variable = NULL, dataset = NULL,
58		depends = NULL, dataview = NULL, subset = "filtered", selection_subset = "full_filter",
59		filters = NULL, reset_button = FALSE, button_class = NULL, as.row = FALSE,
60		floating_label = TRUE) {
61	4x	id <- gsub("\\s", "", id)
62	4x	a <- list(...)
63	!	if (as.row) floating_label <- FALSE
64	4x	r <- c(
65	4x	'<div class="wrapper combobox-wrapper">',
66	4x	if (!floating_label) paste0('<label id="', id, '-label" for="', id, '-input">', label, "</label>"),
67	4x	paste0('<div class="', paste(c(
68	4x	if (reset_button) "input-group", if (floating_label) "form-floating"
69	4x	), collapse = " "), '">'),
70	4x	paste0(
71	4x	'<div class="auto-input form-select combobox combobox-component" data-autoType="combobox"',
72	4x	' id="', id, '" ',
73	4x	if (is.character(options) && length(options) == 1) paste0('data-optionSource="', options, '"'),
74	4x	if (!is.null(default)) paste0(' data-default="', default, '"'),
75	4x	if (!is.null(note)) paste0(' aria-description="', note, '"'),
76	4x	if (!is.null(dataview)) paste0(' data-view="', dataview, '"'),
77	4x	if (!is.null(subset)) paste0(' data-subset="', subset, '"'),
78	4x	if (!is.null(selection_subset)) paste0(' data-selectionsubset="', selection_subset, '"'),
79	4x	if (!is.null(depends)) paste0(' data-depends="', depends, '"'),
80	4x	if (!is.null(dataset)) paste0(' data-dataset="', dataset, '"'),
81	4x	if (!is.null(variable)) paste0(' data-variable="', variable, '"'),
82	4x	if (length(a)) unlist(lapply(seq_along(a), function(i) paste0(" ", names(a)[i], '="', a[[i]], '"'))),
83	4x	'><div class="combobox-selection combobox-component">',
84	4x	'<span aria-live="assertive" aria-atomic="true" role="log" class="combobox-component"></span>',
85	4x	'<input class="combobox-input combobox-component" role="combobox" type="text" ',
86	4x	'aria-expanded="false" aria-autocomplete="list" aria-controls="', id,
87	4x	'-listbox" aria-controls="', id, '-listbox" id="', id, '-input" autocomplete="off"></div>',
88	4x	if (clearable) '<button type="button" class="btn-close" title="clear selection"></button>',
89	4x	"</div>"
90		),
91	4x	paste0(
92	4x	'<div class="combobox-options combobox-component', if (multi) " multi", '" role="listbox"',
93	4x	' id="', id, '-listbox" aria-labelledby="', id, '-label">'
94		),
95	4x	if (is.list(options)) {
96	1x	i <- 0
97	!	if (is.null(names(options))) names(options) <- seq_along(options)
98	1x	if (missing(accordion)) accordion <- TRUE
99	1x	unlist(lapply(names(options), function(g) {
100	2x	group <- paste0(
101	2x	'<div class="combobox-group combobox-component',
102	2x	if (accordion) " accordion-item",
103	2x	'" data-group="', g, '">'
104		)
105	2x	if (accordion) {
106	2x	gid <- paste0(id, "_", gsub("[\\s,/._-]+", "", g))
107	2x	group <- c(
108	2x	group,
109	2x	paste0('<div id="', gid, '-label" class="accordion-header combobox-component">'),
110	2x	paste0(
111	2x	'<button role="button" ',
112	2x	'data-bs-toggle="collapse" data-bs-target="#', gid,
113	2x	'" aria-expanded=false aria-controls="', gid,
114	2x	'" class="accordion-button combobox-component collapsed">',
115	2x	g, "</button></div>"
116		),
117	2x	paste0(
118	2x	'<div id="', gid, '" class="combobox-component accordion-collapse collapse" ',
119	2x	'data-group="', g, '" data-bs-parent="#', id,
120	2x	'-listbox"><div class="accordion-body combobox-component">'
121		)
122		)
123		}
124	2x	for (gi in seq_along(options[[g]])) {
125	4x	i <<- i + 1
126	4x	group <- c(group, paste0(
127	4x	'<div class="combobox-option combobox-component', if (i == default) " selected", '" role="option" tabindex="0"',
128	4x	' data-group="', g, '" id="', id, "-option", i, '" data-value="', options[[g]][[gi]], '" aria-selected="',
129	4x	if (i == default) "true" else "false", '">', display[[g]][[gi]], "</div>"
130		))
131		}
132	2x	c(group, "</div>", if (accordion) "</div></div>")
133	1x	}), use.names = FALSE)
134	4x	} else if (length(options) > 1 \|\| !options %in% c("datasets", "variables", "ids", "palettes")) {
135	3x	unlist(lapply(seq_along(options), function(i) {
136	9x	paste0(
137	9x	'<div class="combobox-component', if (i == default) " selected", '" role="option" tabindex="0"',
138	9x	' id="', id, "-option", i, '" data-value="', options[i], '" aria-selected="',
139	9x	if (i == default) "true" else "false", '">', display[i], "</div>"
140		)
141	3x	}), use.names = FALSE)
142		},
143	4x	"</div>",
144	4x	if (floating_label) paste0('<label id="', id, '-label" for="', id, '-input">', label, "</label>"),
145	4x	if (!missing(reset_button)) {
146	!	paste(c(
147	!	'<button type="button" class="btn btn-link', if (!is.null(button_class)) paste("", button_class), ' select-reset">',
148	!	if (is.character(reset_button)) reset_button else "Reset",
149	!	"</button>"
150	!	), collapse = "")
151		},
152	4x	"</div>",
153	4x	"</div>"
154		)
155	!	if (missing(accordion) && !is.null(group_feature)) accordion <- TRUE
156	!	if (as.row) r <- to_input_row(r)
157	4x	caller <- parent.frame()
158	4x	if (!is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts") {
159	1x	if (strict) caller$combobox[[id]]$strict <- strict
160	!	if (numeric) caller$combobox[[id]]$numeric <- numeric
161	1x	if (search) caller$combobox[[id]]$search <- search
162	!	if (multi) caller$combobox[[id]]$multi <- multi
163	!	if (accordion) caller$combobox[[id]]$accordion <- accordion && (is.list(options) \|\| !is.null(group_feature))
164	!	if (!is.null(group_feature)) caller$combobox[[id]]$group <- group_feature
165	!	if (!is.null(filters)) caller$combobox[[id]]$filters <- as.list(filters)
166	1x	caller$content <- c(caller$content, r)
167		}
168	4x	r
169		}

1		#' Add a tooltip-like display to a website
2		#'
3		#' Adds an output to display information about a hovered-over or selected data point.
4		#'
5		#' @param title Title text, or the source of title text.
6		#' @param body A list of entries in the info body section, which can be raw text or references to features or
7		#' data variables.
8		#' @param row_style A character specifying how rows should be displayed: \code{"table"} (default)
9		#' to place names and values in separate columns of a table row, or \code{"stack"} to place names over values.
10		#' Repeats over rows.
11		#' @param default A list with entries for \code{"title"} and \code{"body"}, which are treated as raw text.
12		#' @param dataview The ID of a dataview, used for the persistent display.
13		#' @param variable Name of the variable from which to display variable information and values. If not specified,
14		#' this will default to the coloring variable of maps and plots, or the y variable of a dataview.
15		#' @param subto A vector of output IDs to receive hover events from.
16		#' @param id Unique id of the element.
17		#' @param variable_info Logical; if \code{TRUE} (default), variable names can be clicked for more information.
18		#' @param floating Logical; if \code{TRUE}, the information pane will appear next to the cursor.
19		#' @examples
20		#' \dontrun{
21		#' output_info("Initial View", "Hover over plot elements for more information.")
22		#' }
23		#' @return A character vector of the content to be added.
24		#' @export
25
26		output_info <- function(title = NULL, body = NULL, row_style = "table", default = NULL, dataview = NULL,
27		variable = NULL, subto = NULL, id = NULL, variable_info = TRUE, floating = FALSE) {
28	4x	caller <- parent.frame()
29	4x	building <- !is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts"
30	4x	if (is.null(id)) id <- paste0("info", caller$uid)
31	4x	r <- paste0(
32	4x	'<div class="auto-output text-display',
33	4x	if (floating) ' floating"' else '"',
34	4x	if (!is.null(dataview)) paste0(' data-view="', dataview, '"'),
35	4x	' data-autoType="info" id="', id, '"></div>'
36		)
37	4x	row_style <- rep_len(row_style, length(body))
38	4x	if (building) {
39	2x	caller$content <- c(caller$content, r)
40	2x	caller$info[[id]] <- Filter(function(e) length(e) > 1 \|\| (length(e) && e != "" && !isFALSE(e)), list(
41	2x	title = if (is.null(title)) "" else title,
42	2x	body = lapply(seq_along(body), function(i) {
43	1x	list(name = if (is.null(names(body))) "" else names(body)[i], value = body[[i]], style = row_style[[i]])
44		}),
45	2x	default = as.list(default),
46	2x	floating = floating
47		))
48	!	if (!is.null(dataview)) caller$info[[id]]$dataview <- dataview
49	!	if (!is.null(variable)) caller$info[[id]]$variable <- variable
50	1x	if (!is.null(subto)) caller$info[[id]]$subto <- subto
51	2x	if (variable_info) caller$info[[id]]$variable_info <- variable_info
52	2x	caller$uid <- caller$uid + 1
53		}
54	4x	r
55		}

1		#' Makes a measurement metadata file
2		#'
3		#' Make a \code{measure_info.json} file, or add measure entries to an existing one.
4		#'
5		#' @param path Path to the \code{measure_info.json} file, existing or to be created.
6		#' @param ... Lists containing individual measure items. See the Measure Entries section.
7		#' @param info A list containing measurement information to be added.
8		#' @param references A list containing citation entries. See the Reference Entries section.
9		#' @param strict Logical; if \code{TRUE}, will only allow recognized entries and values.
10		#' @param include_empty Logical; if \code{FALSE}, will omit entries that have not been provided.
11		#' @param overwrite_entry Logical; if \code{TRUE}, will replace rather than add to an existing entry.
12		#' @param render Path to save a version of \code{path} to, with dynamic entries expanded. See the
13		#' Dynamic Entries section.
14		#' @param overwrite Logical; if \code{TRUE}, will overwrite rather than add to an existing \code{path}.
15		#' @param write Logical; if \code{FALSE}, will not write the build or rendered measure info.
16		#' @param verbose Logical; if \code{FALSE}, will not display status messages.
17		#' @param open_after Logical; if \code{FALSE}, will not open the measure file after writing/updating.
18		#' @section Measure Entries:
19		#' Measure entries are named by the full variable name with any of these entries (if \code{strict}):
20		#' \itemize{
21		#' \item \strong{\code{measure}}: Name of the measure.
22		#' \item \strong{\code{full_name}}: Full name of the measure, which is also the name of the entry.
23		#' \item \strong{\code{short_name}}: Shortest possible display name.
24		#' \item \strong{\code{long_name}}: Longer display name.
25		#' \item \strong{\code{category}}: Arbitrary category for the measure.
26		#' \item \strong{\code{short_description}}: Shortest possible description.
27		#' \item \strong{\code{long_description}}: Complete description. Either description can include
28		#' TeX-style equations, enclosed in escaped square brackets (e.g.,
29		#' \code{"The equation \\\\[a_{i} = b^\\\\frac{c}{d}\\\\] was used."}; or \code{$...$},
30		#' \code{\\\\(...\\\\)}, or \code{\\\\begin{math}...\\\\end{math}}). The final enclosing symbol must be
31		#' followed by a space or the end of the string. These are pre-render to MathML with
32		#' \code{\link[katex]{katex_mathml}}.
33		#' \item \strong{\code{statement}}: String with dynamic references to entity features
34		#' (e.g., \code{"measure value = {value}"}). References can include:
35		#' \itemize{
36		#' \item \code{value}: Value of a currently displaying variable at a current time.
37		#' \item \code{region_name}: Alias of \code{features.name}.
38		#' \item \code{features.<entry>}: An entity feature, coming from \code{entity_info.json} or GeoJSON properties.
39		#' All entities have at least \code{name} and \code{id} entries (e.g., \code{"{features.id}"}).
40		#' \item \code{variables.<entry>}: A variable feature such as \code{name} which is the same as
41		#' \code{full_name} (e.g., \code{"{variables.name}"}).
42		#' \item \code{data.<variable>}: The value of another variable at a current time (e.g., \code{"{data.variable_a}"}).
43		#' }
44		#' \item \strong{\code{measure_type}}: Type of the measure's value. Recognized types are displayed in a special way:
45		#' \itemize{
46		#' \item \code{year} or \code{integer} show as entered (usually as whole numbers). Other numeric
47		#' types are rounded to show a set number of digits.
48		#' \item \code{percent} shows as \code{{value}\%}.
49		#' \item \code{minutes} shows as \code{{value} minutes}.
50		#' \item \code{dollar} shows as \code{${value}}.
51		#' \item \code{internet speed} shows as \code{{value} Mbps}.
52		#' }
53		#' \item \strong{\code{unit}}: Prefix or suffix associated with the measure's type, such as \code{\%} for \code{percent},
54		#' or \code{Mbps} for \code{rate}.
55		#' \item \strong{\code{sources}}: A list or list of list containing source information, including any of these entries:
56		#' \itemize{
57		#' \item \code{name}: Name of the source (such as an organization name).
58		#' \item \code{url}: General URL of the source (such as an organization's website).
59		#' \item \code{location}: More specific description of the source (such as a the name of a particular data product).
60		#' \item \code{location_url}: More direct URL to the resource (such as a page listing data products).
61		#' \item \code{date_accessed}: Date of retrieval (arbitrary format).
62		#' }
63		#' \item \strong{\code{citations}}: A vector of reference ids (the names of \code{reference} entries; e.g., \code{c("ref1", "ref3")}).
64		#' \item \strong{\code{layer}}: A list specifying an \code{\link{output_map}} overlay:
65		#' \itemize{
66		#' \item \code{source} (required): A URL to a GeoJSON file, or a list with a \code{url} and \code{time} entry, where
67		#' \code{time} conditions the display of the layer on the current selected time. Alternative to a list that specifies time,
68		#' the URL can include a dynamic reference to time, if the time values correspond to a component of the URL
69		#' (e.g., \code{"https://example.com/{time}/points.geojson"}).
70		#' \item \code{filter}: A list or list of lists specifying how the elements of the layer should be filtered for this variable:
71		#' \itemize{
72		#' \item \code{feature}: Name of the layer's property to filter on.
73		#' \item \code{operator}: Operator to filter by (e.g., \code{"="} or \code{"!="}).
74		#' \item \code{value}: Value to filter by.
75		#' }
76		#' }
77		#' \item \strong{\code{categories}}: A named list of categories, with any of the other measure entries, or a
78		#' \code{default} entry giving a default category name. See the Dynamic Entries section.
79		#' \item \strong{\code{variants}}: A named list of variants, with any of the other measure entries, or a
80		#' \code{default} entry giving a default variant name. See the Dynamic Entries section.
81		#' }
82		#' @section Dynamic Entries:
83		#' You may have several closely related variables in a dataset, which share sections of metadata,
84		#' or have formulaic differences. In cases like this, the \code{categories} and/or \code{variants} entries
85		#' can be used along with dynamic notation to construct multiple entries from a single template.
86		#'
87		#' Though functionally the same, \code{categories} might include broken-out subsets of some total
88		#' (such as race groups, as categories of a total population), whereas \code{variants} may be different
89		#' transformations of the same variable (such as raw counts versus percentages).
90		#'
91		#' In dynamic entries, \code{{category}} or \code{{variant}} refers to entries in the \code{categories}
92		#' or \code{variants} lists. By default, these are replaced with the name of each entries in those lists
93		#' (e.g., \code{"variable_{category}"} where \code{categories = "a"} would become \code{"variable_a"}).
94		#' A \code{default} entry would change this behavior (e.g., with \code{categories = list(a = list(default = "b")}
95		#' that would become \code{"variable_b"}). Adding \code{.name} would force the original behavior (e.g.,
96		#' \code{"variable_{category.name}"} would be \code{"variable_a"}). A name of \code{"blank"} is treated as
97		#' an empty string.
98		#'
99		#' When notation appears in a measure info entry, they will first default to a matching name in the \code{categories}
100		#' or \code{variants} list; for example, \code{short_name} in \code{list(short_name = "variable {category}")} with
101		#' \code{categories = list(a = list(short_name = "(category a)"))} would become \code{"variable (category a)"}.
102		#' To force this behavior, the entry name can be included in the notation (e.g.,
103		#' \code{"{category.short_name}"} would be \code{"variable (category a)"} in any entry).
104		#'
105		#' Only string entries are processed dynamically -- any list-like entries (such as
106		#' \code{source}, \code{citations}, or \code{layer}) appearing in
107		#' \code{categories} or \code{variants} entries will fully replace the base entry.
108		#'
109		#' Dynamic entries can be kept dynamic when passed to a data site, but can be rendered for other uses,
110		#' where the rendered version will have each dynamic entry replaced with all unique combinations of
111		#' \code{categories} and \code{variants} entries, assuming both are used in the dynamic entry's name
112		#' (e.g., \code{"variable_{category}_{variant}"}). See Examples.
113		#' @section Reference Entries:
114		#' Reference entries can be included in a \code{_references} entry, and should have names corresponding to
115		#' those included in any of the measures' \code{citation} entries. These can include any of these entries:
116		#' \itemize{
117		#' \item \strong{\code{id}}: The reference id, same as the entry name.
118		#' \item \strong{\code{author}}: A list or list of lists specifying one or more authors. These can include
119		#' entries for \code{given} and \code{family} names.
120		#' \item \strong{\code{year}}: Year of the publication.
121		#' \item \strong{\code{title}}: Title of the publication.
122		#' \item \strong{\code{journal}}: Journal in which the publication appears.
123		#' \item \strong{\code{volume}}: Volume number of the journal.
124		#' \item \strong{\code{page}}: Page number of the journal.
125		#' \item \strong{\code{doi}}: Digital Object Identifier, from which a link is made (\code{https://doi.org/{doi}}).
126		#' \item \strong{\code{version}}: Version number of software.
127		#' \item \strong{\code{url}}: Link to the publication, alternative to a DOI.
128		#' }
129		#' @examples
130		#' path <- tempfile()
131		#'
132		#' # make an initial file
133		#' data_measure_info(path, "measure name" = list(
134		#' measure = "measure name",
135		#' full_name = "prefix:measure name",
136		#' short_description = "A measure.",
137		#' statement = "This entity has {value} measure units."
138		#' ), verbose = FALSE)
139		#'
140		#' # add another measure to that
141		#' measure_info <- data_measure_info(path, "measure two" = list(
142		#' measure = "measure two",
143		#' full_name = "prefix:measure two",
144		#' short_description = "Another measure.",
145		#' statement = "This entity has {value} measure units."
146		#' ), verbose = FALSE)
147		#' names(measure_info)
148		#'
149		#' # add a dynamic measure, and make a rendered version
150		#' measure_info_rendered <- data_measure_info(
151		#' path,
152		#' "measure {category} {variant.name}" = list(
153		#' measure = "measure {category}",
154		#' full_name = "{variant}:measure {category}",
155		#' short_description = "Another measure ({category}; {variant}).",
156		#' statement = "This entity has {value} {category} {variant}s.",
157		#' categories = c("a", "b"),
158		#' variants = list(u1 = list(default = "U1"), u2 = list(default = "U2"))
159		#' ),
160		#' render = TRUE, verbose = FALSE
161		#' )
162		#' names(measure_info_rendered)
163		#' measure_info_rendered[["measure a u1"]]$statement
164		#' @return An invisible list containing measurement metadata (the rendered version if made).
165		#' @export
166
167		data_measure_info <- function(path, ..., info = list(), references = list(), strict = FALSE, include_empty = TRUE,
168		overwrite_entry = FALSE, render = NULL, overwrite = FALSE, write = TRUE, verbose = TRUE,
169		open_after = interactive()) {
170	19x	if (write) {
171	!	if (missing(path) \|\| !is.character(path)) cli_abort("enter a path to the measure_info.json file as {.arg path}")
172	7x	dir.create(dirname(path), FALSE, TRUE)
173		}
174	19x	built <- list()
175	19x	if (!overwrite && is.character(path) && file.exists(path)) {
176	5x	if (verbose) cli_bullets(c(i = "updating existing file: {.path {basename(path)}}"))
177	18x	built <- jsonlite::read_json(path)
178	18x	if (all(c("measure", "measure_type") %in% names(built))) {
179	!	built <- list(built)
180	!	names(built) <- built[[1]]$measure
181		}
182		}
183	19x	if (length(references)) {
184	2x	references <- c(references, built$`_references`)
185	2x	references <- references[!duplicated(names(references))]
186	2x	built$`_references` <- references
187		} else {
188	17x	references <- built$`_references`
189		}
190	19x	defaults <- list(
191	19x	measure = "",
192	19x	full_name = "",
193	19x	short_name = "",
194	19x	long_name = "",
195	19x	category = "",
196	19x	short_description = "",
197	19x	long_description = "",
198	19x	statement = "",
199	19x	measure_type = "",
200	19x	unit = "",
201	19x	sources = list(),
202	19x	citations = list(),
203	19x	layer = list()
204		)
205	!	if (!is.list(info)) info <- sapply(info, function(name) list())
206	19x	info <- c(list(...), info)
207	!	if (length(info) && is.null(names(info))) cli_abort("supplied measure entries must be named")
208	19x	for (n in names(info)) {
209	10x	if (overwrite_entry \|\| is.null(built[[n]])) {
210	7x	l <- info[[n]]
211		} else {
212	3x	l <- c(info[[n]], built[[n]])
213	3x	l <- l[!duplicated(names(l))]
214		}
215	3x	if (is.null(l$full_name)) l$full_name <- n
216	10x	if (strict) {
217	1x	su <- names(l) %in% names(defaults)
218	1x	if (verbose && any(!su)) cli_warn(paste0("unrecognized {?entry/entries} in ", n, ": {names(l)[!su]}"))
219	1x	if (include_empty) {
220	!	for (e in names(l)) {
221	!	if (!is.null(defaults[[e]])) {
222	!	defaults[[e]] <- l[[e]]
223		}
224		}
225	!	l <- defaults
226		} else {
227	1x	l <- l[su]
228		}
229	9x	} else if (include_empty) {
230	8x	su <- !names(defaults) %in% names(l)
231	6x	if (any(su)) l <- c(l, defaults[su])
232		}
233	10x	if (!is.null(l$categories) && !is.list(l$categories)) {
234	1x	l$categories <- structure(lapply(l$categories, function(e) list(default = e)), names = l$categories)
235		}
236	10x	if (!is.null(l$variants) && !is.list(l$variants)) {
237	!	l$variants <- structure(lapply(l$variants, function(e) list(default = e)), names = l$categories)
238		}
239	10x	if (verbose && !is.null(l$citations)) {
240	8x	su <- !l$citations %in% names(references)
241	2x	if (any(su)) cli_warn("no matching reference entry for {.val {l$citations[su]}} in {.val {n}}")
242		}
243	10x	built[[n]] <- l
244		}
245	19x	built <- built[order(grepl("^_", names(built)))]
246	19x	if (write) {
247	6x	if (verbose) cli_bullets(c(i = "writing info to {.path {path}}"))
248	7x	jsonlite::write_json(built, path, auto_unbox = TRUE, pretty = TRUE)
249		}
250	19x	if (!is.null(render)) {
251	13x	expanded <- list()
252	13x	for (name in names(built)) {
253	35x	expanded <- c(
254	35x	expanded,
255	35x	if (grepl("{", name, fixed = TRUE)) {
256	11x	render_info(built[name])
257		} else {
258	24x	structure(list(built[[name]]), names = name)
259		}
260		)
261		}
262	13x	changed <- !identical(built, expanded)
263	13x	built <- expanded
264	13x	if (write && changed) {
265	1x	path <- if (is.character(render)) render else sub("\\.json", "_rendered.json", path, TRUE)
266	1x	if (verbose) cli_bullets(c(i = "writing rendered info to {.path {path}}"))
267	1x	jsonlite::write_json(built, path, auto_unbox = TRUE, pretty = TRUE)
268		}
269		}
270	!	if (open_after) navigateToFile(path)
271	19x	invisible(built)
272		}

1		#' Add a button to a website
2		#'
3		#' Adds a button to reset an input or trigger a predefined function (including data export) to a website.
4		#'
5		#' @param label Text in the button for the user.
6		#' @param target The ID of an input element to reset, a vector with IDs of input elements as names and values to set
7		#' those inputs to as values, or the name of a function to trigger (e.g., \code{c(input_a = 1)}). Available function
8		#' are \code{refresh} (to force a reprocessing of the current input state), \code{reset_selection} (to reset all input
9		#' elements that are not settings), \code{reset_storage} (to clear local storage, reset all settings, and reload),
10		#' \code{export} (to download data), \code{copy} (to save an API link to the clipboard), and
11		#' \code{filter} (to open a data filter menu).
12		#' This can also be a URL (including protocol) for a button-like link.
13		#' @param id Unique ID of the element to be created.
14		#' @param dataview Name of a data view to get selection and filter options from for export.
15		#' @param query A list of query parameters, if \code{target} is \code{"export"} or \code{"copy"}. See the API section.
16		#' @param from_api Logical; if \code{TRUE}, \code{target} is \code{"export"}, and an endpoint has been provided
17		#' in \code{\link{site_build}}, links to the API rather than exporting from the browser.
18		#' @param class Additional class names to add to the element.
19		#' @param ... Additional attributes to set on the element.
20		#' @param note Text to display as a tooltip for the button.
21		#' @seealso For buttons to select between a set of options, use \code{\link{input_buttongroup}}.
22		#' @section API Query:
23		#' The \code{query} argument can be used to specify export options for a download button.
24		#' These options can also be included as query parameters in a site API's URL:
25		#' \describe{
26		#' \item{Format}{
27		#' These options affect the format of the returned file:
28		#' \itemize{
29		#' \item \strong{\code{file_format}}: Specifies the separator between columns:
30		#' \code{'csv'} (default) for commas, or \code{'tsv'} for tabs.
31		#' \item \strong{\code{table_format}}: Specifies the layout of the data:
32		#' \code{'tall'} for a row for each value, with all values in the same column
33		#' (repeats over entities, times, and variables);
34		#' \code{'mixed'} (default) for a row for each time, with a column for each variable
35		#' (repeats over entities);
36		#' \code{'wide'} for a row for each entity, with a column for each variable at each time.
37		#' \item \strong{\code{features}}: Specifies which features to include in the
38		#' first columns of the file: A list with names for year column name, and value with the
39		#' feature name to include in that column. Currently not available through the URL.
40		#' \item \strong{\code{include}}: Specifies which variables to include:
41		#' a vector or variable names, or (for the URL interface) a string with variable
42		#' names separated by commas. By default, all variables are included.
43		#' \item \strong{\code{exclude}}: Specifies which variables to exclude:
44		#' a vector or variable names, or (for the URL interface) a string with variable
45		#' names separated by commas.
46		#' }
47		#' }
48		#' \item{Filters}{
49		#' These options can be used to subset data:
50		#' \itemize{
51		#' \item \strong{\code{dataset}}: The name of a dataset, or vector (comma separated string)
52		#' of dataset names. Includes all datasets by default.
53		#' \item \strong{\code{variable[component]=value}}: Sets conditions
54		#' on the summary of a variable. The summary of a variable is within each entity, which results in
55		#' a set of summary components: \code{"first"}, \code{"min"}, \code{"mean"}, \code{"sum"},
56		#' \code{"max"}, \code{"last"}. The \code{=} sign can be another operator:
57		#' \code{"!="}, \code{">="}, \code{"<="}. values can be comma-separated sets of values.
58		#' \item \strong{\code{feature=value}}: Sets conditions on a feature of each entity.
59		#' \item \strong{\code{time_range}}: Selects a time or time range to include:
60		#' \code{">="} or \code{"<="} with a single minimal or maximal time, or \code{"="}
61		#' with a single time, or comma-separated set of two times.
62		#' }
63		#' }
64		#' }
65		#' @examples
66		#' \dontrun{
67		#' # a selection reset button
68		#' input_button("Reset")
69		#'
70		#' # a button to export all data, plus some added features
71		#' input_button("Download All Data", "export", query = list(
72		#' features = list(ID = "id", Feature_A = "ft_a")
73		#' ))
74		#'
75		#' # a button to export a special subset
76		#' # from a URL:
77		#' # https://example.com/api?dataset=set_a&include=variable_a,variable_b&
78		#' # variable_a[min]>=10&feature_a=type_a,type_b
79		#' input_button("Download Subset", "export", query = list(
80		#' dataset = "set_a", include = c("variable_a", "variable_b"),
81		#' variable_a = list(component = "min", operator = ">", value = 10),
82		#' feature_a = c("type_a", "type_b")
83		#' ))
84		#' }
85		#' @return A character vector of the contents to be added.
86		#' @export
87
88		input_button <- function(label, target = "reset_selection", id = label, dataview = NULL,
89		query = list(), from_api = FALSE, class = "", ..., note = NULL) {
90	21x	id <- gsub("\\s", "", id)
91	21x	a <- list(...)
92	21x	if (missing(target) && !(missing(dataview) \|\| missing(query))) {
93	!	target <- "export"
94		}
95	21x	r <- c(
96	21x	'<div class="wrapper button-wrapper">',
97	21x	if (is.character(target) && length(target) == 1 && grepl("://", target, fixed = TRUE)) {
98	!	paste0(
99	!	'<a role="button" class="btn', if (class != "") paste("", class),
100	!	'" id="', id, '" target="_blank" rel="noreferrer" href="', target, '"',
101	!	if (length(a)) unlist(lapply(seq_along(a), function(i) paste0(" ", names(a)[i], '="', a[[i]], '"'))),
102	!	if (!is.null(note)) paste0(' aria-description="', note, '"'),
103	!	">", label, "</a>"
104		)
105		} else {
106	21x	paste0(
107	21x	'<button type="button" data-autoType="button" class="auto-input btn', if (class != "") paste("", class),
108	21x	'" id="', id, '"', if (length(target) == 1 && !is.list(target) && is.null(names(target))) paste0(' data-target="', target, '"'),
109	21x	if (length(a)) unlist(lapply(seq_along(a), function(i) paste0(" ", names(a)[i], '="', a[[i]], '"'))),
110	21x	if (!is.null(note)) paste0(' aria-description="', note, '"'),
111	21x	">", label, "</button>"
112		)
113		},
114	21x	"</div>"
115		)
116	21x	caller <- parent.frame()
117	21x	if (!is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts") {
118	1x	if (length(target) == 1 && target %in% c("export", "copy")) {
119	!	caller$button[[id]] <- Filter(function(e) length(e) > 1 \|\| (length(e) && (!is.logical(e) \|\| e)), list(
120	!	effects = target,
121	!	dataview = dataview,
122	!	query = query,
123	!	api = from_api
124		))
125	1x	} else if (!is.null(names(target))) caller$button[[id]] <- list(effects = target)
126	1x	caller$content <- c(caller$content, r)
127		}
128	21x	r
129		}

1		#' Adds documentation of a dataset to a datapackage
2		#'
3		#' Add information about variables in a dataset to a \code{datapackage.json} metadata file.
4		#'
5		#' @param filename A character vector of paths to plain-text tabular data files, relative to \code{dir}.
6		#' @param meta Information about each data file. A list with a list entry for each entry in
7		#' \code{filename}; see details. If a single list is provided for multiple data files, it will apply to all.
8		#' @param packagename Package to add the metadata to; path to the \code{.json} file relative to
9		#' \code{dir}, or a list with the read-in version.
10		#' @param dir Directory in which to look for \code{filename}, and write \code{packagename}.
11		#' @param write Logical; if \code{FALSE}, returns the \code{paths} metadata without reading or rewriting
12		#' \code{packagename}.
13		#' @param refresh Logical; if \code{FALSE}, will retain any existing dataset information.
14		#' @param sha A number specifying the Secure Hash Algorithm function,
15		#' if \code{openssl} is available (checked with \code{Sys.which('openssl')}).
16		#' @param clean Logical; if \code{TRUE}, strips special characters before saving.
17		#' @param open_after Logical; if \code{TRUE}, opens the written datapackage after saving.
18		#' @details
19		#' \code{meta} should be a list with unnamed entries for entry in \code{filename},
20		#' and each entry can include a named entry for any of these:
21		#' \describe{
22		#' \item{source}{
23		#' A list or list of lists with entries for at least \code{name}, and ideally for \code{url}.
24		#' }
25		#' \item{ids}{
26		#' A list or list of lists with entries for at least \code{variable} (the name of a variable in the dataset).
27		#' Might also include \code{map} with a list or path to a JSON file resulting in a list with an
28		#' entry for each ID, and additional information about that entity, to be read in a its features.
29		#' All files will be loaded to help with aggregation, but local files will be included in the datapackage,
30		#' whereas hosted files will be loaded client-side.
31		#' }
32		#' \item{time}{
33		#' A string giving the name of a variable in the dataset representing a repeated observation of the same entity.
34		#' }
35		#' \item{variables}{
36		#' A list with named entries providing more information about the variables in the dataset.
37		#' See \code{\link{data_measure_info}}.
38		#' }
39		#' }
40		#' @examples
41		#' \dontrun{
42		#' # write example data
43		#' write.csv(mtcars, "mtcars.csv")
44		#'
45		#' # add it to an existing datapackage.json file in the current working directory
46		#' data_add("mtcars.csv")
47		#' }
48		#' @return An invisible version of the updated datapackage, which is also written to
49		#' \code{datapackage.json} if \code{write = TRUE}.
50		#' @seealso Initialize the \code{datapackage.json} file with \code{\link{init_data}}.
51		#' @export
52
53		data_add <- function(filename, meta = list(), packagename = "datapackage.json", dir = ".", write = TRUE,
54		refresh = TRUE, sha = "512", clean = FALSE, open_after = FALSE) {
55	!	if (missing(filename)) cli_abort("{.arg filename} must be specified")
56	5x	setnames <- names(filename)
57	5x	if (file.exists(filename[[1]])) {
58	2x	if (dir == ".") dir <- dirname(filename[[1]])
59	2x	filename <- basename(filename)
60		}
61	5x	if (check_template("site", dir = dir)$status[["strict"]] &&
62	5x	all(file.exists(paste0(dir, "/docs/data/", filename)))) {
63	!	dir <- paste0(dir, "/docs/data")
64		}
65	5x	if (any(!file.exists(paste0(dir, "/", filename)))) {
66	!	filename <- filename[!file.exists(filename)]
67	!	cli_abort("{?a file/files} did not exist: {filename}")
68		}
69	5x	package <- if (is.character(packagename) && file.exists(paste0(dir, "/", packagename))) {
70	2x	paste0(dir, "/", packagename)
71		} else {
72	3x	packagename
73		}
74	5x	if (write) {
75	3x	if (is.character(package)) {
76	3x	package <- paste0(dir, "/", packagename)
77	3x	package <- if (file.exists(package)) {
78	2x	packagename <- package
79	2x	jsonlite::read_json(package)
80		} else {
81	1x	init_data(if (!is.null(setnames)) setnames[[1]] else filename[[1]], dir = dir)
82		}
83		}
84	3x	if (!is.list(package)) {
85	!	cli_abort(c(
86	!	"{.arg package} does not appear to be in the right format",
87	!	i = "this should be (or be read in from JSON as) a list with a {.code resource} entry"
88		))
89		}
90		}
91	2x	if (!is.list(package)) package <- list()
92	5x	collect_metadata <- function(file) {
93	5x	f <- paste0(dir, "/", filename[[file]])
94	5x	m <- if (single_meta) meta else metas[[file]]
95	5x	format <- if (grepl(".csv", f, fixed = TRUE)) "csv" else if (grepl(".rds", f, fixed = TRUE)) "rds" else "tsv"
96	!	if (is.na(format)) format <- "rds"
97	5x	info <- file.info(f)
98	5x	metas <- list()
99	5x	unpack_meta <- function(n) {
100	1x	if (!length(m[[n]])) list() else if (is.list(m[[n]][[1]])) m[[n]] else list(m[[n]])
101		}
102	5x	ids <- unpack_meta("ids")
103	5x	idvars <- NULL
104	5x	for (i in seq_along(ids)) {
105	1x	if (is.list(ids[[i]])) {
106	1x	if (length(ids[[i]]$map) == 1 && is.character(ids[[i]]$map) && file.exists(ids[[i]]$map)) {
107	!	ids[[i]]$map_content <- paste(readLines(ids[[i]]$map, warn = FALSE), collapse = "")
108		}
109		} else {
110	!	ids[[i]] <- list(variable = ids[[i]])
111		}
112	1x	if (!ids[[i]]$variable %in% idvars) idvars <- c(idvars, ids[[i]]$variable)
113		}
114	5x	data <- if (format == "rds") {
115	!	tryCatch(readRDS(f), error = function(e) NULL)
116		} else {
117	5x	attempt_read(f, if (length(idvars)) idvars[1] else "")
118		}
119	5x	if (is.null(data)) {
120	!	cli_abort(c(
121	!	paste0("failed to read in the data file ({.file {f}})"),
122	!	i = "check that it is in a compatible format"
123		))
124		}
125	!	if (!all(rownames(data) == seq_len(nrow(data)))) data <- cbind(`_row` = rownames(data), data)
126	5x	timevar <- unlist(unpack_meta("time"))
127	5x	times <- if (is.null(timevar)) rep(1, nrow(data)) else data[[timevar]]
128	5x	times_unique <- unique(times)
129	5x	if (!single_meta) {
130	3x	varinf <- unpack_meta("variables")
131	3x	if (length(varinf) == 1 && is.character(varinf[[1]])) {
132	!	if (!file.exists(varinf[[1]])) varinf[[1]] <- paste0(dir, "/", varinf[[1]])
133	!	if (file.exists(varinf[[1]])) {
134	!	if (varinf[[1]] %in% names(metas)) {
135	!	varinf <- metas[[varinf[[1]]]]
136		} else {
137	!	varinf <- metas[[varinf[[1]]]] <- data_measure_info(varinf[[1]], write = FALSE, render = TRUE)
138		}
139	!	varinf <- varinf[varinf != ""]
140		}
141		}
142	3x	varinf_full <- names(varinf)
143	3x	varinf_suf <- sub("^[^:]+:", "", varinf_full)
144		}
145	5x	res <- list(
146	5x	bytes = as.integer(info$size),
147	5x	encoding = stri_enc_detect(f)[[1]][1, 1],
148	5x	md5 = md5sum(f)[[1]],
149	5x	format = format,
150	5x	name = if (!is.null(setnames)) {
151	1x	setnames[file]
152	5x	} else if (!is.null(m$name)) {
153	!	m$name
154		} else {
155	4x	sub("\\.[^.]*$", "", basename(filename[[file]]))
156		},
157	5x	filename = filename[[file]],
158	5x	source = unpack_meta("source"),
159	5x	ids = ids,
160	5x	id_length = if (length(idvars)) {
161	1x	id_lengths <- nchar(data[[idvars[1]]])
162	1x	if (all(id_lengths == id_lengths[1])) id_lengths[1] else 0
163		} else {
164	4x	0
165		},
166	5x	time = timevar,
167	5x	profile = "data-resource",
168	5x	created = as.character(info$mtime),
169	5x	last_modified = as.character(info$ctime),
170	5x	row_count = nrow(data),
171	5x	entity_count = if (length(idvars)) length(unique(data[[idvars[1]]])) else nrow(data),
172	5x	schema = list(
173	5x	fields = lapply(colnames(data)[!colnames(data) %in% idvars], function(cn) {
174	59x	v <- data[[cn]]
175	59x	invalid <- !is.finite(v)
176	59x	r <- list(name = cn, duplicates = sum(duplicated(v)))
177	59x	if (!single_meta) {
178	36x	if (cn %in% varinf_full) {
179	!	r$info <- varinf[[cn]]
180	36x	} else if (cn %in% varinf_suf) {
181	!	r$info <- varinf[[which(varinf_suf == cn)]]
182		}
183	36x	r$info <- r$info[r$info != ""]
184		}
185	59x	su <- !is.na(v)
186	59x	if (any(su)) {
187	59x	r$time_range <- which(times_unique %in% range(times[su])) - 1
188	59x	r$time_range <- if (length(r$time_range)) r$time_range[c(1, length(r$time_range))] else c(-1, -1)
189		} else {
190	!	r$time_range <- c(-1, -1)
191		}
192	59x	if (!is.character(v) && all(invalid)) {
193	!	r$type <- "unknown"
194	!	r$missing <- length(v)
195	59x	} else if (is.numeric(v)) {
196	55x	r$type <- if (all(invalid \| as.integer(v) == v)) "integer" else "float"
197	55x	r$missing <- sum(invalid)
198	55x	r$mean <- round(mean(v, na.rm = TRUE), 6)
199	55x	r$sd <- round(sd(v, na.rm = TRUE), 6)
200	55x	r$min <- round(min(v, na.rm = TRUE), 6)
201	55x	r$max <- round(max(v, na.rm = TRUE), 6)
202		} else {
203	4x	r$type <- "string"
204	4x	if (!is.factor(v)) v <- as.factor(as.character(v))
205	4x	r$missing <- sum(is.na(v) \| is.nan(v) \| grepl("^[\\s.-]$", v))
206	4x	r$table <- structure(as.list(tabulate(v)), names = levels(v))
207		}
208	59x	r
209		})
210		)
211		)
212	!	if (!single_meta && "_references" %in% names(varinf)) res[["_references"]] <- varinf[["_references"]]
213	5x	if (Sys.which("openssl") != "") {
214	5x	res[[paste0("sha", sha)]] <- calculate_sha(f, sha)
215		}
216	5x	res
217		}
218	5x	single_meta <- FALSE
219	5x	metas <- if (!is.null(names(meta))) {
220	2x	if (!is.null(setnames) && all(setnames %in% names(meta))) {
221	!	meta[setnames]
222		} else {
223	2x	single_meta <- TRUE
224	2x	if (length(meta$variables) == 1 && is.character(meta$variables)) {
225	!	if (!file.exists(meta$variables)) meta$variables <- paste0(dir, "/", meta$variables)
226	!	if (file.exists(meta$variables)) meta$variables <- jsonlite::read_json(meta$variables)
227		}
228	2x	meta$variables <- replace_equations(meta$variables)
229	2x	meta
230		}
231		} else {
232	3x	meta[seq_along(filename)]
233		}
234	5x	if (!single_meta) {
235	3x	metas <- lapply(metas, function(m) {
236	3x	m$variables <- replace_equations(m$variables)
237	3x	m
238		})
239		}
240	5x	metadata <- lapply(seq_along(filename), collect_metadata)
241	2x	if (single_meta) package$measure_info <- lapply(meta$variables, function(e) e[e != ""])
242	5x	package$resources <- c(metadata, if (!refresh) package$resources)
243	5x	names <- vapply(package$resources, "[[", "", "filename")
244	5x	if (anyDuplicated(names)) {
245	!	package$resources <- package$resources[!duplicated(names)]
246		}
247	5x	if (clean) {
248	!	cf <- lma_dict("special", perl = TRUE, as.function = gsub)
249	!	package <- jsonlite::fromJSON(cf(jsonlite::toJSON(package, auto_unbox = TRUE)))
250		}
251	5x	if (write) {
252	3x	packagename <- if (is.character(packagename)) packagename else "datapackage.json"
253	3x	jsonlite::write_json(
254	3x	package, if (file.exists(packagename)) packagename else paste0(dir, "/", packagename),
255	3x	auto_unbox = TRUE, digits = 6
256		)
257	3x	if (interactive()) {
258	!	cli_bullets(c(v = paste(
259	!	if (refresh) "updated resource in" else "added resource to", "datapackage.json:"
260	!	), "*" = paste0("{.path ", packagename, "}")))
261	!	if (open_after) navigateToFile(packagename)
262		}
263		}
264	5x	invisible(package)
265		}

1		#' Create a datapackage.json template
2		#'
3		#' Initialize dataset documentation with a \code{datapackage.json} template, based on a
4		#' \href{https://specs.frictionlessdata.io/data-package}{Data Package} standard.
5		#'
6		#' @param name A unique name for the dataset; allowed characters are \code{[a-z._/-]}.
7		#' @param title A display name for the dataset; if not specified, will be a formatted version of \code{name}.
8		#' @param dir Directory in which to save the \code{datapackage.json} file.
9		#' @param ... passes arguments to \code{\link{data_add}}.
10		#' @param write Logical; if \code{FALSE}, the package object will not be written to a file.
11		#' @param overwrite Logical; if \code{TRUE} and \code{write} is \code{TRUE}, an existing
12		#' \code{datapackage.json} file will be overwritten.
13		#' @param quiet Logical; if \code{TRUE}, will not print messages or navigate to files.
14		#' @examples
15		#' \dontrun{
16		#' # make a template datapackage.json file in the current working directory
17		#' init_data("mtcars", "Motor Trend Car Road Tests")
18		#' }
19		#' @return An invisible list with the content written to the \code{datapackage.json} file.
20		#' @seealso Add basic information about a dataset with \code{\link{data_add}}.
21		#' @export
22
23		init_data <- function(name, title = name, dir = ".", ..., write = TRUE, overwrite = FALSE, quiet = !interactive()) {
24	!	if (missing(name)) cli_abort("{.arg name} must be specified")
25	5x	package <- list(
26	5x	name = name,
27	5x	title = if (title == name) gsub("\\b(\\w)", "\\U\\1", gsub("[._/-]", " ", name), perl = TRUE) else title,
28	5x	licence = list(
29	5x	url = "http://opendatacommons.org/licenses/pddl",
30	5x	name = "Open Data Commons Public Domain",
31	5x	version = "1.0",
32	5x	id = "odc-pddl"
33		),
34	5x	resources = list()
35		)
36	5x	package_path <- normalizePath(paste0(dir, "/datapackage.json"), "/", FALSE)
37	5x	if (write && !overwrite && file.exists(package_path)) {
38	!	cli_abort(c("datapackage ({.path {package_path}}) already exists", i = "add {.code overwrite = TRUE} to overwrite it"))
39		}
40	1x	if (length(list(...))) package$resources <- data_add(..., dir = dir, write = FALSE)
41	5x	if (write) {
42	!	if (!dir.exists(dir)) dir.create(dir, recursive = TRUE)
43	4x	jsonlite::write_json(package, package_path, auto_unbox = TRUE, digits = 6, pretty = TRUE)
44	4x	if (!quiet) {
45	!	cli_bullets(c(v = "created metadata template for {name}:", "*" = paste0("{.path ", package_path, "}")))
46	!	navigateToFile(package_path)
47		}
48		}
49	5x	invisible(package)
50		}

1		#' Add a navbar (header) section to a website
2		#'
3		#' Adds a bar at the top of the page, potentially with a title and logo image.
4		#'
5		#' @param ... Content to add to the navbar. Can be lists specifying submenus and their items.
6		#' Each list can have entries for \code{"name"} (the navbar button text), \code{"title"} (the menu title),
7		#' \code{"foot"} (the menu footer), \code{"id"} (the ID of the menu element),
8		#' \code{"class"} (class of the menu element), \code{"placement"} (start, top, end, or bottom),
9		#' \code{"backdrop"} (logical, where \code{FALSE} disables the backdrop and makes the menu shift
10		#' main content), and \code{items} (a list of menu items).
11		#' @param title A title to appear in the header.
12		#' @param logo URL of an image to appear in the header.
13		#' @param breakpoint Bootstrap breakpoint code specifying the width at which the menu collapses;
14		#' default is \code{"md"}.
15		#' @param logo.height Character or number setting the height of the logo.
16		#' @param logo.width Character or number setting the width of the logo.
17		#' @examples
18		#' page_navbar(
19		#' title = "Site Name",
20		#' list(
21		#' name = "menu",
22		#' title = "Menu",
23		#' items = list(input_select("menu select", c("a", "b")))
24		#' )
25		#' )
26		#' @return A character vector of the content to be added.
27		#' @export
28
29		page_navbar <- function(..., title = "", logo = "", breakpoint = "md", logo.height = "24px", logo.width = "24px") {
30	10x	caller <- parent.frame()
31	10x	building <- !is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts"
32	10x	parts <- new.env()
33	10x	attr(parts, "name") <- "community_site_parts"
34	10x	submenus <- substitute(...())
35	10x	n <- length(submenus)
36	10x	parts$uid <- caller$uid
37	10x	r <- c(
38	10x	paste0('<nav class="navbar navbar-dark navbar-expand-', breakpoint, '">'),
39	10x	'<div class="container-fluid">',
40	10x	if (!missing(logo)) {
41	3x	paste0(
42	3x	'<span class="navbar-brand"><img alt="site logo" height=', logo.height, " width=", logo.width, ' src="', logo, '">'
43		)
44		},
45	10x	if (!missing(title)) paste0("<span>", title, "</span>"),
46	10x	if (!missing(logo)) "</span>"
47		)
48	10x	menus <- NULL
49	10x	if (n) {
50	9x	r <- c(
51	9x	r,
52	9x	paste(
53	9x	'<button type="button" class="navbar-toggler" data-bs-toggle="collapse"',
54	9x	'data-bs-target="#navbar_menu"',
55	9x	'aria-controls="narbar_menu" aria-expanded="false" aria-label="toggle navbar menu">'
56		),
57	9x	'<span class="navbar-toggler-icon"></span>',
58	9x	"</button>",
59	9x	'<div class="collapse navbar-collapse" id="navbar_menu">',
60	9x	'<ul class="navbar-nav">'
61		)
62	9x	for (i in seq_len(n)) {
63	21x	if (submenus[[i]][[1]] == "list") {
64	!	if (is.null(names(submenus[[i]]))) submenus[[i]] <- list(items = submenus[[i]])
65	2x	id <- if (is.null(submenus[[i]]$id)) paste0("submenu", parts$uid, i) else submenus[[i]]$id
66	!	if (is.null(submenus[[i]]$name)) submenus[[i]]$name <- if (!is.null(names(submenus))) names(submenus)[i] else "Menu"
67	2x	r <- c(r, paste0(
68	2x	'<li class="nav-item">',
69	2x	'<button class="btn btn-link" type="button" data-bs-toggle="offcanvas" data-bs-target="#',
70	2x	id, '" aria-controls="', id, '">', submenus[[i]]$name, "</button>",
71	2x	"</li>"
72		))
73	2x	has_foot <- !is.null(submenus[[i]]$foot)
74	2x	menus <- c(
75	2x	menus,
76	2x	paste(c(
77	2x	'<div tabindex="-1" id="', id, '" aria-labelledby="', id, '_label" class="offcanvas offcanvas-',
78	2x	if (is.null(submenus[[i]]$placement)) "end" else submenus[[i]]$placement,
79	2x	if (!is.null(submenus[[i]]$class)) paste("", submenus[[i]]$class),
80	2x	if (!is.null(submenus[[i]]$backdrop)) c('" data-bs-backdrop="', submenus[[i]]$backdrop),
81		'">'
82	2x	), collapse = ""),
83	2x	'<div class="offcanvas-header">',
84	2x	paste0(
85	2x	'<h5 class="offcanvas-title" id="', id, '_label">',
86	2x	submenus[[i]][if (is.null(submenus[[i]]$title)) "name" else "title"],
87	2x	"</h5>"
88		),
89	2x	'<button class="btn-close text-reset" type="button" data-bs-dismiss="offcanvas" title="Close"></button>',
90	2x	"</div>",
91	2x	paste0('<div class="offcanvas-body"', if (has_foot) ' style="bottom: 46px"', ">"),
92	2x	unlist(lapply(submenus[[i]]$items[-1], eval, parts), use.names = FALSE),
93	2x	"</div>",
94	2x	if (has_foot) {
95	!	c(
96	!	'<div class="offcanvas-footer">',
97	!	unlist(lapply(submenus[[i]]$foot[-1], eval, parts), use.names = FALSE),
98	!	"</div>"
99		)
100		},
101	2x	"</div>"
102		)
103		} else {
104	19x	r <- c(r, paste0('<li class="nav-item">', paste(eval(submenus[[i]]), collapse = ""), "</li>"))
105		}
106		}
107		}
108	10x	r <- c(r, "</ul></div></div></nav>", menus)
109	10x	if (building) {
110	2x	caller$header <- r
111	!	for (n in names(parts)) if (n != "content" && n != "uid") caller[[n]] <- c(caller[[n]], parts[[n]])
112	2x	caller$uid <- parts$uid + 1
113		}
114	10x	r
115		}

1		#' Interact with a Data Commons View
2		#'
3		#' Add, edit, or refresh a view within a data commons project.
4		#'
5		#' @param commons Path to the data commons project.
6		#' @param name Name of the view (it's directory in the project's \code{"views"} directory).
7		#' Defaults to the first view.
8		#' @param output Path to a site project's main directory.
9		#' @param ... Passes arguments to \code{\link{data_reformat_sdad}} if the view is to be executed.
10		#' @param variables A vector of variables, to be added to the view's \code{view.json} file.
11		#' @param ids A vector of ids, to be added to the view's \code{view.json} file.
12		#' @param files A regular expression string used to filter files containing \code{variables}.
13		#' @param run_after Path to a script to be sourced after refreshing the view, or code to
14		#' be added to such a script (e.g., \code{"../data_site/build.R"}).
15		#' @param run_before Path to a script to be sourced before refreshing the view, or code to
16		#' be added to such a script.
17		#' @param measure_info A list of variable metadata to include in the \code{measure_info.json}
18		#' file created from such files in each data repository (such as general entries like
19		#' \code{"_references"}). These will supersede any entries of the same name found in data repositories.
20		#' @param remote Name of the view's GitHub repository (\code{"username/reponame"}).
21		#' @param url URL of the view's site; defaults to the GitHub Pages URL associated with \code{remote}
22		#' if provided (\code{"https://username.github.io/reponame"}).
23		#' @param children A list of child sites associated with the view. Each entry should contain at least a
24		#' \code{remote} entry (GitHub repository, including user name and repo name), and optionally \code{name}
25		#' and \code{url} (link to the served site), which will otherwise be derived from \code{remote}.
26		#' @param execute Logical; if \code{FALSE}, will create/update, but not run the view.
27		#' @param prefer_repo Logical; if \code{FALSE}, will prefer distribution files (such as from Dataverse)
28		#' over those in the repositories.
29		#' @param preselect_files Logical; if \code{TRUE}, will select files by ID coverage before processing them,
30		#' which can save time, but might miss data spread across multiple files.
31		#' @param refresh_map Logical; if \code{TRUE}, overwrites any existing map files.
32		#' @param overwrite Logical; if \code{TRUE}, reformatted files in \code{output}.
33		#' @param verbose Logical; if \code{FALSE}, will not show status messages.
34		#' @examples
35		#' \dontrun{
36		#' # create a view within a data commons project
37		#' datacommons_view(".", "view_name", variables = c("variable_a", "variable_b"))
38		#'
39		#' # refresh that view
40		#' datacommons_view(".", "view_name")
41		#' }
42		#' @return An invisible version of the view list (the view's \code{view.json} file).
43		#' @export
44
45		datacommons_view <- function(commons, name, output = NULL, ..., variables = NULL, ids = NULL,
46		files = NULL, run_after = NULL, run_before = NULL, measure_info = list(),
47		remote = NULL, url = NULL, children = list(), execute = TRUE, prefer_repo = TRUE,
48		preselect_files = FALSE, refresh_map = FALSE, overwrite = FALSE, verbose = TRUE) {
49	!	if (missing(commons)) cli_abort('{.arg commons} must be speficied (e.g., commons = ".")')
50	3x	if (missing(name)) {
51	!	name <- list.files(paste0(commons, "/views"))[1]
52	!	if (is.na(name)) cli_abort("{.arg name} must be specified since no views are present in {commons}")
53		}
54	3x	check <- check_template("datacommons", dir = commons)
55	3x	view_dir <- normalizePath(paste0(commons, "/views/", name), "/", FALSE)
56	3x	dir.create(view_dir, FALSE, TRUE)
57	3x	paths <- paste0(view_dir, "/", c("view.json", "manifest.json", "run_after.R", "run_before.R"))
58	3x	base_run_after <- run_after
59	3x	if (!is.null(run_after)) {
60	!	if (length(run_after) > 1 \|\| !grepl("\\w\\.\\w+$", run_after)) {
61	!	if (verbose) cli_alert_info("writting {.file run_after.R}")
62	!	writeLines(run_after, paths[3])
63	!	base_run_after <- run_after <- paths[3]
64	!	} else if (!file.exists(run_after)) {
65	!	base_run_after <- paste0(commons, "/", run_after)
66		}
67		}
68	3x	if (!is.null(run_before) && (length(run_before) > 1 \|\| !file.exists(run_before))) {
69	!	if (verbose) cli_alert_info("writting {.file run_before.R}")
70	!	writeLines(run_before, paths[4])
71	!	run_before <- paths[4]
72		}
73	3x	write_view <- FALSE
74	3x	if (!is.null(variables)) variables <- variables[!grepl("^_", variables)]
75	3x	if (!file.exists(paths[1])) {
76	!	if (verbose) cli_alert_info("writting new {.file view.json}")
77	2x	view <- list(
78	2x	name = name,
79	2x	remote = remote,
80	2x	url = url,
81	2x	output = output,
82	2x	run_after = run_after,
83	2x	run_before = run_before,
84	2x	variables = variables,
85	2x	ids = ids,
86	2x	files = files,
87	2x	children = children
88		)
89	2x	write_view <- TRUE
90		} else {
91	1x	view <- jsonlite::read_json(paths[1])
92	1x	if (!is.null(remote) && !identical(view$remote, remote)) {
93	!	view$remote <- remote
94	!	write_view <- TRUE
95		}
96	1x	if (!is.null(url) && !identical(view$url, url)) {
97	!	view$url <- url
98	!	write_view <- TRUE
99		}
100	1x	if (!is.null(output) && !identical(view$output, output)) {
101	!	view$output <- output
102	!	write_view <- TRUE
103		}
104	1x	if (!is.null(run_after) && !identical(view$run_after, run_after)) {
105	!	view$run_after <- run_after
106	!	write_view <- TRUE
107	1x	} else if (length(view$run_after)) {
108	!	base_run_after <- view$run_after
109	!	if (!file.exists(base_run_after)) base_run_after <- paste0(commons, "/", base_run_after)
110		}
111	1x	if (!is.null(run_before) && !identical(view$run_before, run_before)) {
112	!	view$run_before <- run_before
113	!	write_view <- TRUE
114		}
115	1x	if (!is.null(variables) && !identical(view$variables, variables)) {
116	1x	view$variables <- variables
117	1x	write_view <- TRUE
118		}
119	1x	if (!is.null(ids) && !identical(view$ids, ids)) {
120	1x	view$ids <- ids
121	1x	write_view <- TRUE
122		}
123	1x	if (!is.null(ids) && !identical(view$files, files)) {
124	1x	view$files <- files
125	1x	write_view <- TRUE
126		}
127	1x	if (!is.null(children) && !identical(view$children, children)) {
128	!	view$children <- children
129	!	write_view <- TRUE
130		}
131	!	if (verbose && write_view) cli_alert_info("updating existing {.file view.json}")
132		}
133	3x	outbase <- outdir <- view$output
134	3x	if (!is.null(outdir)) {
135	3x	if (!dir.exists(outdir)) {
136	1x	if (dir.exists(paste0(commons, "/", outdir))) {
137	!	outdir <- paste0(commons, "/", outdir)
138		} else {
139	1x	dir.create(outdir, FALSE, TRUE)
140		}
141		}
142	3x	outbase <- sub("/docs(?:/data)?$", "", outdir)
143		}
144	3x	if (length(view$remote)) {
145	!	remote_parts <- strsplit(sub("^(?:https?://)?(?:www\\.)?github\\.com/", "", view$remote), "/")[[1]]
146	!	if (is.null(view$url)) view$url <- paste0("https://", remote_parts[1], ".github.io/", remote_parts[2])
147	!	if (!is.null(outdir)) {
148	!	if (!dir.exists(outbase)) {
149	!	outbase <- dirname(outbase)
150	!	dir.create(outbase, FALSE, TRUE)
151	!	wdir <- getwd()
152	!	setwd(outbase)
153	!	if (verbose) cli_alert_info(paste0("cloning remote view: {.url https://github.com/", view$remote, "}"))
154	!	overwrite <- TRUE
155	!	tryCatch(
156	!	system2("git", c("clone", paste0("https://github.com/", view$remote, ".git")), stdout = TRUE),
157	!	error = function(e) warning("remote clone failed: ", e$message)
158		)
159	!	setwd(wdir)
160		}
161		}
162		}
163	3x	if (length(view$children)) {
164	!	if (!is.null(names(view$children))) view$children <- list(view$children)
165	!	view$children <- lapply(view$children, function(ch) {
166	!	if (is.null(ch$name)) {
167	!	ch$name <- sub("^.*/", "", ch$remote)
168		}
169	!	if (is.null(ch$url)) {
170	!	remote_parts <- strsplit(sub("^(?:https?://)?(?:www\\.)?github\\.com/", "", ch$remote), "/")[[1]]
171	!	ch$url <- paste0("https://", remote_parts[1], ".github.io/", remote_parts[2])
172		}
173	!	ch
174		})
175		}
176	3x	if (length(view$variables)) view$variables <- as.character(view$variables)
177	3x	if (length(view$ids)) view$ids <- as.character(view$ids)
178	!	if (!is.null(outbase) && !dir.exists(outbase)) init_site(outbase, view$name, quiet = TRUE)
179	!	if (is.null(view$output)) outdir <- view_dir
180	3x	if (write_view) jsonlite::write_json(view, paths[1], auto_unbox = TRUE)
181	3x	if (execute) {
182	3x	source_env <- new.env()
183	3x	source_env$datacommons_view <- function(...) {}
184	3x	if (length(view$run_before) && file.exists(view$run_before)) {
185	!	if (verbose) cli_alert_info("running pre-view script ({.file {view$run_before}})")
186	!	src <- parse(text = gsub("community::datacommons_view", "datacommons_view", readLines(view$run_before, warn = FALSE), fixed = TRUE))
187	!	source(local = source_env, exprs = src)
188		}
189	!	if (verbose) cli_alert_info("checking for file maps")
190	3x	map <- datacommons_map_files(commons, overwrite = refresh_map, verbose = verbose)
191	3x	files <- map$variables[
192	3x	(if (length(view$files)) grepl(view$files, map$variables$file) else TRUE) &
193	3x	(if (length(view$variables)) {
194	3x	map$variables$full_name %in% view$variables \| map$variables$dir_name %in% view$variables \| map$variables$variable %in% view$variables
195		} else {
196	!	TRUE
197		}) &
198	3x	(if (length(view$ids)) {
199	3x	sub("^[^/]+/[^/]+/", "", map$variables$file) %in% unique(unlist(
200	3x	lapply(map$ids[view$ids %in% names(map$ids)], "[[", "files"),
201	3x	use.names = FALSE
202		))
203		} else {
204	!	TRUE
205		}), ,
206	3x	drop = FALSE
207		]
208	3x	manifest <- NULL
209	3x	if (nrow(files)) {
210	3x	cfs <- paste0("/", files$file)
211	3x	files <- files[order(
212	3x	grepl(if (prefer_repo) "cache/" else "repos/", files$file) -
213	3x	Reduce("+", lapply(view$ids, function(id) cfs %in% map$ids[[id]]$file))
214		), ]
215	3x	files <- files[!duplicated(paste(files$dir_name, basename(files$file))), , drop = FALSE]
216	3x	if (preselect_files) {
217	!	sel_files <- unique(unlist(lapply(split(files, files$dir_name), function(fs) {
218	!	if (nrow(fs) == 1) {
219	!	fs$file
220		} else {
221	!	ccfs <- sub("^/", "", fs$file)
222	!	ifm <- vapply(map$ids[view$ids], function(im) ccfs %in% sub("^/", "", im$files), logical(length(ccfs)))
223	!	is <- colSums(ifm) != 0
224	!	sel <- NULL
225	!	for (i in seq_along(ccfs)) {
226	!	if (any(is[ifm[i, ]])) {
227	!	sel <- c(sel, fs$file[i])
228	!	is[ifm[i, ]] <- FALSE
229		}
230		}
231	!	sel
232		}
233	!	}), use.names = FALSE))
234	!	files <- files[files$file %in% sel_files, ]
235		}
236	3x	files <- files[order(file.mtime(paste0(commons, "/", files$file)), decreasing = TRUE), ]
237	!	if (verbose) cli_alert_info("updating manifest: {.file {paths[2]}}")
238	3x	repo_manifest <- jsonlite::read_json(paste0(commons, "/manifest/repos.json"))
239	3x	manifest <- lapply(split(files, files$repo), function(r) {
240	3x	hr <- repo_manifest[[r$repo[[1]]]]
241	3x	files <- paste0(commons, "/", unique(r$file))
242	3x	names(files) <- sub("^[^/]+/[^/]+/", "", unique(r$file))
243	3x	list(
244	3x	files = lapply(files, function(f) {
245	15x	name <- sub("^/[^/]+/[^/]+/", "", sub(commons, "", f, fixed = TRUE))
246	15x	if (grepl("repos/", f, fixed = TRUE)) {
247	15x	m <- hr$files[[name]]
248	15x	m$baseurl <- hr$url
249		} else {
250	!	m <- hr$distributions$dataverse$files[[name]]
251	!	m$baseurl <- hr$distributions$dataverse$server
252		}
253	15x	m
254		})
255		)
256		})
257	3x	if (is.character(measure_info)) {
258	!	measure_info <- if (length(measure_info) == 1 && file.exists(measure_info)) {
259	!	jsonlite::read_json(measure_info)
260		} else {
261	!	as.list(measure_info)
262		}
263		}
264	3x	base_vars <- sub("^[^:/]+[:/]", "", view$variables)
265	3x	for (r in unique(files$repo)) {
266	3x	measure_info_files <- sort(list.files(
267	3x	paste0(commons, "/repos/", sub("^.+/", "", r)), "^measure_info[^.]*\\.json$",
268	3x	full.names = TRUE, recursive = TRUE
269		))
270	3x	measure_info_files <- measure_info_files[
271	3x	!grepl("/docs/data/", measure_info_files, fixed = TRUE) &
272	3x	!duplicated(gsub("_rendered\|/code/\|/data/", "", measure_info_files))
273		]
274	3x	ri <- lapply(measure_info_files, function(f) {
275	15x	m <- tryCatch(jsonlite::read_json(f), error = function(e) {
276	!	cli_alert_warning("failed to read measure info: {.file {f}}")
277	!	NULL
278		})
279	15x	if (all(c("measure", "type", "short_description") %in% names(m))) {
280	!	m <- list(m)
281	!	names(m) <- m[[1]]$measure
282		}
283	15x	remote <- paste0(get_git_remote(sub("(^.+repos/[^/]+/).*$", "\\1.git/config", f)), "/")
284	15x	source_file <- sub("^/[^/]+/[^/]+/", remote, sub(commons, "", f, fixed = TRUE))
285	15x	for (mn in names(m)) {
286	36x	if (substring(mn, 1, 1) != "_") {
287	30x	m[[mn]]$source_file <- source_file
288		}
289		}
290	15x	m
291		})
292	3x	if (length(ri)) {
293	3x	ri <- unlist(ri, recursive = FALSE)
294	3x	nri <- names(ri)
295	!	if (any(nri == "")) for (mname in which(nri == "")) names(ri)[mname] <- ri[[mname]]$measure
296	3x	es <- nri[substring(nri, 1, 1) == "_" & !nri %in% view$variables]
297	3x	if (length(es)) {
298	3x	for (e in es) {
299	6x	if (!is.null(names(ri[[e]]))) {
300	3x	if (is.null(measure_info[[e]])) measure_info[[e]] <- list()
301	6x	su <- !names(ri[[e]]) %in% names(measure_info[[e]])
302	3x	if (any(su)) measure_info[[e]] <- c(measure_info[[e]], ri[[e]][su])
303		}
304		}
305		}
306	3x	if (length(view$variables) && any(!nri %in% view$variables)) {
307	3x	for (i in seq_along(nri)) {
308	36x	n <- nri[i]
309	36x	if (n %in% base_vars) {
310	12x	names(ri)[i] <- view$variables[which(base_vars == n)[1]]
311		} else {
312	24x	n <- sub("^[^:]*:", "", nri[i])
313	24x	if (n %in% view$variables) {
314	!	names(ri)[i] <- n
315		}
316		}
317		}
318	3x	nri <- names(ri)
319		}
320	3x	rendered_names <- render_info_names(ri)
321	3x	ri <- ri[(if (length(view$variables)) {
322	3x	nri %in% rendered_names[names(rendered_names) %in% view$variables]
323		} else {
324	!	TRUE
325	3x	}) & !nri %in% names(measure_info)]
326	3x	if (length(ri)) {
327	3x	measure_info[names(ri)] <- lapply(
328	3x	ri, function(e) if (is.null(names(e)) && !is.null(names(e[[1]]))) e[[1]] else e
329		)
330		}
331		}
332		}
333	3x	args <- list(...)
334	3x	if (length(measure_info)) args$measure_info <- measure_info
335	3x	args$files <- paste0(commons, "/", unique(files$file))
336	3x	args$out <- outdir
337	3x	args$variables <- view$variables
338	3x	args$ids <- view$ids
339	3x	args$overwrite <- overwrite
340	3x	args$verbose <- verbose
341	3x	do.call(data_reformat_sdad, args)
342		} else {
343	!	cli_warn("no files were found")
344		}
345	3x	if (length(base_run_after) && file.exists(base_run_after)) {
346	!	if (verbose) cli_alert_info("running post-view script ({.file {base_run_after}})")
347	!	src <- parse(text = gsub("community::datacommons_view", "datacommons_view", readLines(base_run_after, warn = FALSE), fixed = TRUE))
348	!	source(local = source_env, exprs = src)
349		}
350	3x	jsonlite::write_json(manifest, paste0(outdir, "/manifest.json"), auto_unbox = TRUE, pretty = TRUE)
351		}
352	3x	init_datacommons(commons, refresh_after = FALSE, verbose = FALSE)
353	3x	invisible(view)
354		}

1		#' Add a table to a webpage
2		#'
3		#' Adds a table to a webpage, based on specified or selected variables.
4		#'
5		#' @param variables The ID of a variable selecting input, or a list specifying columns (if \code{wide} is
6		#' \code{TRUE}) or included variables. Each entry should be a list with at least have a \code{name} entry with a
7		#' variable name. A \code{title} entry can be used to set a different display name for the variable. \code{name}
8		#' can also refer to feature names, which can be specified with a \code{source} entry set to \code{"features"}.
9		#' For example, \code{list(title = "Variable A", name = "a", source = "features")}. A vector can also be used
10		#' to specify variable names, with names setting titles (e.g., \code{c("Variable A" = "a")}). If not specified,
11		#' sources are attempted to be resolved automatically.
12		#' @param dataset The name of a dataset, or ID of a dataset selector, to find \code{variables} in;
13		#' used if \code{dataview} is not specified.
14		#' @param dataview The ID of an \code{\link{input_dataview}} component.
15		#' @param id Unique ID of the table.
16		#' @param click The ID of an input to set to a clicked row's entity ID.
17		#' @param subto A vector of output IDs to receive hover events from.
18		#' @param options A list of configuration options if \code{datatables} is \code{TRUE}, see
19		#' \href{https://datatables.net/reference/option}{DataTables Documentation}; otherwise,
20		#' only the \code{scrollY} option has an effect.
21		#' @param features A list of features columns to include if multiple variables are included and \code{wide} is
22		#' \code{TRUE}.
23		#' @param filters A list with names of \code{meta} entries (from \code{variable} entry in \code{\link{data_add}}'s
24		#' \code{meta} list), and values of target values for those entries, or the IDs of value selectors.
25		#' @param wide Logical; if \code{FALSE}, variables and years are spread across rows rather than columns.
26		#' If \code{variables} specifies a single variable, \code{wide = FALSE} will show the variable in a column, and
27		#' \code{wide = TRUE} will show the variable across time columns.
28		#' @param class Class names to add to the table.
29		#' @param datatables Logical; if \code{TRUE}, uses \href{https://datatables.net}{DataTables}.
30		#' @examples
31		#' output_table()
32		#' @return A character vector of the content to be added.
33		#' @export
34
35		output_table <- function(variables = NULL, dataset = NULL, dataview = NULL, id = NULL, click = NULL, subto = NULL,
36		options = NULL, features = NULL, filters = NULL, wide = TRUE, class = "compact", datatables = TRUE) {
37	5x	caller <- parent.frame()
38	5x	building <- !is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts"
39	4x	if (is.null(id)) id <- paste0("table", caller$uid)
40	5x	defaults <- list(
41	5x	paging = TRUE, scrollY = 500, scrollX = 500, scrollCollapse = TRUE,
42	5x	scroller = TRUE, deferRender = TRUE
43		)
44	5x	if (!is.null(options$height)) {
45	!	options$scrollY <- options$height
46	!	options$height <- NULL
47		}
48	5x	so <- names(options)
49	5x	if (!datatables && (!wide \|\| (length(so) && any(so != "scrollY")))) {
50	!	cli_warn(paste(
51	!	"because {.arg datatables} is disabled, the {.arg wide} argument is ignored,",
52	!	"and all {.arg options} except {.arg options$scrollY} are ignored"
53		))
54		}
55	5x	for (n in names(defaults)) if (!n %in% so) options[[n]] <- defaults[[n]]
56	5x	type <- if (datatables) "datatable" else "table"
57	5x	r <- paste(c(
58	5x	paste0(
59	5x	if (!datatables) {
60	1x	paste0(
61	1x	'<div class="table-wrapper" style="max-height: ', options$scrollY, if (is.numeric(options$scrollY)) "px", '">'
62		)
63		},
64	5x	'<table class="auto-output tables', if (is.null(class)) "" else paste("", class), '"'
65		),
66	5x	if (!is.null(dataview)) paste0('data-view="', dataview, '"'),
67	5x	if (!is.null(click)) paste0('data-click="', click, '"'),
68	5x	paste0('id="', id, '" data-autoType="', type, '"></table>', if (!datatables) "</div>")
69	5x	), collapse = " ")
70	5x	if (building) {
71	2x	if (!is.null(variables)) {
72	1x	if (!is.character(variables) \|\| length(variables) > 1) {
73	!	if (!is.list(variables)) {
74	!	variables <- as.list(variables)
75	!	} else if (!is.list(variables[[1]])) variables <- list(variables)
76	!	vnames <- names(variables)
77	!	for (i in seq_along(variables)) {
78	!	if (is.null(names(variables[[i]]))) variables[[i]] <- list(name = variables[[i]][[1]])
79	!	if (!is.null(vnames[i])) variables[[i]]$title <- vnames[i]
80		}
81		}
82	1x	options$variables <- variables
83		}
84	2x	if (!is.null(features)) {
85	!	if (!is.character(features) \|\| length(features) > 1) {
86	!	if (!is.list(features)) {
87	!	features <- as.list(features)
88	!	} else if (!is.list(features[[1]]) && "name" %in% names(features)) features <- list(features)
89	!	vnames <- names(features)
90	!	for (i in seq_along(features)) {
91	!	if (is.null(names(features[[i]]))) features[[i]] <- list(name = features[[i]][[1]])
92	!	if (!is.null(vnames[i])) features[[i]]$title <- vnames[i]
93		}
94		}
95	!	options$features <- unname(features)
96		}
97	2x	options$subto <- if (!is.null(subto) && length(subto) == 1) list(subto) else subto
98	2x	options$filters <- filters
99	2x	options$dataset <- dataset
100	2x	options$single_variable <- wide && length(variables) == 1
101	2x	options$wide <- if (!wide && length(variables) == 1) TRUE else wide
102	2x	if (datatables) {
103	2x	caller$dependencies$jquery <- list(
104	2x	type = "script",
105	2x	src = "https://cdn.jsdelivr.net/npm/jquery@3.7.0/dist/jquery.min.js",
106	2x	hash = "sha384-NXgwF8Kv9SSAr+jemKKcbvQsz+teULH/a5UNJvZc6kP47hZgl62M1vGnw6gHQhb1",
107	2x	loading = "defer"
108		)
109	2x	caller$dependencies$datatables_style <- list(
110	2x	type = "stylesheet",
111	2x	src = "https://cdn.datatables.net/1.13.6/css/jquery.dataTables.min.css",
112	2x	hash = "sha384-w9ufcIOKS67vY4KePhJtmWDp4+Ai5DMaHvqqF85VvjaGYSW2AhIbqorgKYqIJopv"
113		)
114	2x	caller$dependencies$datatables <- list(
115	2x	type = "script",
116	2x	src = "https://cdn.datatables.net/v/dt/dt-1.13.6/b-2.4.1/b-html5-2.4.1/sc-2.2.0/datatables.min.js",
117	2x	hash = "sha384-MKeoYlNiH9UNKbs4gwc9iEx9XxG7iq11nnfJSxm0keXixzRSsRiFR4qVdvHnmts1",
118	2x	loading = "defer"
119		)
120	2x	caller$credits$datatables <- list(
121	2x	name = "DataTables",
122	2x	url = "https://datatables.net",
123	2x	version = "1.13.6"
124		)
125		}
126	!	if (datatables) caller$datatable[[id]] <- options else caller$table[[id]] <- options
127	2x	caller$content <- c(caller$content, r)
128	2x	caller$uid <- caller$uid + 1
129		}
130	5x	r
131		}

1		#' Adds an organizational section to a website
2		#'
3		#' Adds a section (such as a row or column) to a website, optionally placing its elements within rows or columns.
4		#'
5		#' @param ... Elements to appear in the section.
6		#' @param type The class of the top-level section; usually either \code{"row"} or \code{"col"};
7		#' \code{NULL} for no class.
8		#' @param wraps The class of wrapper to place elements in; either \code{"row"}, \code{"col"}, or \code{""}
9		#' (to not wrap the element). Can specify 1 for every element, or a different class for each element.
10		#' @param sizes The relative size of each wrapper, between 1 and 12, or \code{"auto"}; default is equal size.
11		#' @param breakpoints Bootstrap breakpoint of each wrapper; one of \code{""} (extra small), \code{"sm"},
12		#' \code{"md"}, \code{"lg"}, \code{"xl"}, or \code{"xxl"}.
13		#' @param conditions A character for each element representing the conditions in which that should be showing
14		#' (e.g., \code{c("", "input_a == a", "")}); \code{""} means the element's display is not conditional.
15		#' Adding \code{"lock: "} before the condition will disable inputs rather than hide the element.
16		#' @param id Unique ID of the section.
17		#' @details See the \href{https://getbootstrap.com/docs/5.1/layout/grid}{Bootstrap grid documentation}.
18		#' @examples
19		#' \dontrun{
20		#' page_section(
21		#' "<p>column</p>",
22		#' "<p>row</p>",
23		#' type = "row",
24		#' wraps = c("col", "row")
25		#' )
26		#' }
27		#' @return A character vector of the content to be added.
28		#' @export
29
30		page_section <- function(..., type = "row", wraps = NA, sizes = NA, breakpoints = NA, conditions = "", id = NULL) {
31	4x	caller <- parent.frame()
32	4x	building <- !is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts"
33	4x	parts <- new.env()
34	4x	attr(parts, "name") <- "community_site_parts"
35	4x	parts$uid <- caller$uid
36	4x	elements <- substitute(...())
37	4x	n <- length(elements)
38	4x	wraps <- rep_len(wraps, n)
39	4x	sizes <- rep_len(sizes, n)
40	4x	breakpoints <- rep_len(breakpoints, n)
41	4x	conditions <- rep_len(conditions, n)
42	4x	ids <- paste0("sec", parts$uid, seq_len(n))
43	4x	r <- c(
44	4x	paste(c(
45	4x	"<div", if (!is.null(id)) c(' id="', id, '"'), if (!is.null(type)) c(' class="', type, '"'), ">"
46	4x	), collapse = ""),
47	4x	unlist(lapply(seq_len(n), function(i) {
48	5x	wrap <- !is.na(wraps[i]) \|\| conditions[i] != ""
49	5x	c(
50	5x	if (wrap) {
51	2x	paste(c(
52	2x	'<div class="', if (is.na(wraps[i])) "" else wraps[i],
53	2x	if (!is.na(breakpoints[i])) c("-", breakpoints[i]),
54	2x	if (!is.na(sizes[i])) c("-", sizes[i]),
55	2x	'"', if (conditions[i] != "") paste0(' id="', ids[i], '"'), ">"
56	2x	), collapse = "")
57		},
58	5x	eval(elements[[i]], parts, caller),
59	5x	if (wrap) "</div>"
60		)
61	4x	}), use.names = FALSE),
62	4x	"</div>"
63		)
64	4x	if (building) {
65	2x	caller$content <- c(caller$content, r)
66	2x	for (n in names(parts)) if (n != "content" && n != "uid") caller[[n]] <- c(caller[[n]], parts[[n]])
67	2x	process_conditions(conditions, ids, caller)
68	2x	caller$uid <- parts$uid + 1
69		}
70	4x	r
71		}

1		#' Add a plot to a webpage
2		#'
3		#' Adds a Plotly plot to a webpage, based on specified or selected variables.
4		#'
5		#' @param x The name of a variable, or ID of a variable selector to plot along the x-axis.
6		#' @param y The name of a variable, or ID of a variable selector to plot along the y-axis.
7		#' @param color The name of a variable, or ID of a variable selector to use to color lines.
8		#' @param color_time The ID of a selector to specify which timepoint of \code{color} to use.
9		#' @param dataview The ID of an \code{\link{input_dataview}} component.
10		#' @param id Unique ID for the plot.
11		#' @param click The ID of an input to set to a clicked line's ID.
12		#' @param subto A vector of output IDs to receive hover events from.
13		#' @param options A list of configuration options, with named entries for any of \code{data}, \code{layout},
14		#' or \code{options}, potentially extracted from a saved plotly object (see
15		#' \href{https://plotly.com/javascript/configuration-options}{Plotly documentation}), if \code{plotly} is \code{TRUE}.
16		#' @param plotly Logical; if \code{TRUE}, uses \href{https://plotly.com/javascript}{Plotly}.
17		#' @examples
18		#' # for mpg ~ wt * am in a site based on mtcars data
19		#' output_plot("wt", "mpg", "am")
20		#' @return A character vector of the content to be added.
21		#' @export
22
23		output_plot <- function(x = NULL, y = NULL, color = NULL, color_time = NULL, dataview = NULL,
24		id = NULL, click = NULL, subto = NULL, options = list(), plotly = TRUE) {
25	4x	caller <- parent.frame()
26	4x	building <- !is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts"
27	2x	if (is.null(id)) id <- paste0("plot", caller$uid)
28	4x	entries <- c("layout", "config", "data")
29	!	if (is.character(options)) options <- jsonlite::fromJSON(options)
30	!	if ("x" %in% names(options)) options <- options$x
31	4x	options <- options[entries[entries %in% names(options)]]
32	4x	defaults <- list(
33	4x	layout = list(hovermode = "closest", margin = list(t = 25, r = 10, b = 40, l = 60)),
34	4x	config = list(
35	4x	showSendToCloud = FALSE, responsive = TRUE, showTips = FALSE, displaylogo = FALSE,
36	4x	modeBarButtonsToAdd = c("hoverclosest", "hovercompare")
37		),
38	4x	data = data.frame(hoverinfo = "text", mode = "lines+markers", type = "scatter")
39		)
40	4x	so <- names(options)
41	4x	for (e in names(defaults)) {
42	12x	if (!e %in% so) {
43	12x	options[[e]] <- defaults[[e]]
44		} else {
45	!	soo <- names(options[[e]])
46	!	for (eo in names(defaults[[e]])) if (!eo %in% soo) options[[e]][[eo]] <- defaults[[e]][[eo]]
47		}
48		}
49	4x	options$subto <- if (!is.null(subto) && length(subto) == 1) list(subto) else subto
50	4x	type <- if (plotly) "plotly" else "echarts"
51	4x	r <- paste(c(
52	4x	'<div class="plotly-wrap"><div class="auto-output plotly"',
53	4x	if (!is.null(dataview)) paste0('data-view="', dataview, '"'),
54	4x	if (!is.null(click)) paste0('data-click="', click, '"'),
55	4x	if (!is.null(x)) paste0('data-x="', x, '"'),
56	4x	if (!is.null(y)) paste0('data-y="', y, '"'),
57	4x	if (!is.null(color)) paste0('data-color="', color, '"'),
58	4x	if (!is.null(color_time)) paste0('data-colorTime="', color_time, '"'),
59	4x	paste0('id="', id, '" data-autoType="', type, '"></table></div></div>')
60	4x	), collapse = " ")
61	4x	if (building) {
62	2x	caller$dependencies$plotly <- list(
63	2x	type = "script",
64	2x	src = "https://cdn.jsdelivr.net/npm/plotly.js@2.26.0/dist/plotly.min.js",
65	2x	hash = "sha384-xuh4dD2xC9BZ4qOrUrLt8psbgevXF2v+K+FrXxV4MlJHnWKgnaKoh74vd/6Ik8uF"
66		)
67	2x	caller$credits$plotly <- list(
68	2x	name = "Plotly",
69	2x	url = "https://plotly.com/javascript/getting-started",
70	2x	version = "2.26.0"
71		)
72	!	if (plotly) caller$plotly[[id]] <- options else caller$echarts[[id]] <- options
73	2x	caller$content <- c(caller$content, r)
74	2x	caller$uid <- caller$uid + 1
75		}
76	4x	r
77		}

1		#' Download Dataverse Dataset Files
2		#'
3		#' Download one or all files in a Dataverse dataset.
4		#'
5		#' @param id The dataset's persistent ID (e.g., \code{"doi:10.18130/V3/SWK71R"}), or a GitHub repository
6		#' (\code{"username/repo"}) with a \code{R/sysdata.rda} file containing a \code{dataset_doi}.
7		#' @param outdir Directory in which to save files; defaults to a temporary directory.
8		#' @param files Names (full or partial) of files to download, or a number or vector of numbers
9		#' identifying file by index as listed on Dataverse; downloads all files in a dataset if not specified.
10		#' @param version Version of the dataset to download. Specifying this will download all files,
11		#' even if only a selection is requested.
12		#' @param server Dataverse server; tries to get this from the DOI redirect, but falls back on
13		#' \code{Sys.getenv("DATAVERSE_SERVER")}, then \code{getOption("dataverse.server")}, then
14		#' \code{"dataverse.lib.virginia.edu"}.
15		#' @param key Dataverse API key; only needed if the requested dataset is not published. If not specified,
16		#' looks for the key in \code{Sys.getenv("DATAVERSE_KEY")} and \code{getOption("dataverse.key")}.
17		#' @param load Logical; if \code{FALSE}, files will be downloaded but not loaded.
18		#' @param decompress Logical; if \code{TRUE}, will attempt to decompress compressed files.
19		#' @param refresh Logical; if \code{TRUE}, downloads and replaces any existing files.
20		#' @param branch Name of the repository branch, if \code{id} is the name of a repository; uses the default branch
21		#' if not specified.
22		#' @param verbose Logical; if \code{TRUE}, prints status updates and warnings.
23		#' @examples
24		#' \dontrun{
25		#' metadata <- download_dataverse_info("doi:10.18130/V3/SWK71R", verbose = TRUE)
26		#' data <- download_dataverse_data("doi:10.18130/V3/SWK71R", verbose = TRUE)
27		#' }
28		#' @return \code{download_dataverse_data}: If \code{load} is \code{TRUE}, an invisible list with
29		#' an entry for each data file if there are multiple files, or the loaded data file if a single file
30		#' is requested. Tabular data files are loaded as \code{data.table}s. If \code{load} is \code{FALSE},
31		#' a list with the dataset's metadata.
32		#' @export
33
34		download_dataverse_data <- function(id, outdir = tempdir(), files = NULL, version = ":latest",
35		server = NULL, key = NULL, load = TRUE, decompress = FALSE,
36		refresh = FALSE, branch = NULL, verbose = FALSE) {
37	!	if (missing(id)) cli_abort("{.arg id} must be specified")
38	!	if (!is.character(outdir)) cli_abort("{.arg outdir} must be a character")
39	5x	meta <- download_dataverse_info(id, server = server, key = key, refresh = refresh, branch = branch)
40	4x	fs <- vapply(meta$latestVersion$files, function(m) m$dataFile$filename, "")
41	4x	which_files <- if (!is.null(files)) {
42	4x	if (is.numeric(files)) {
43	2x	files[files <= length(fs)]
44		} else {
45	2x	grep(paste0(
46	2x	"(?:", paste(gsub(".", "\\.", files, fixed = TRUE), collapse = "\|"), ")"
47	2x	), fs, TRUE)
48		}
49		} else {
50	!	seq_along(fs)
51		}
52	4x	if (!length(which_files)) {
53	!	cli_abort(cli_bullets(c(
54	!	x = "{.arg files} could not be matched to available files",
55	!	i = paste0("check {.url ", meta$persistentUrl, "}")
56		)))
57		}
58	4x	outdir <- paste0(normalizePath(outdir, "/", FALSE), "/")
59	4x	dir.create(outdir, FALSE, TRUE)
60	4x	data <- list()
61	4x	ffsx <- paste0(outdir, fs)
62	4x	ffs <- sub("\\.[gbx]z2?$", "", ffsx)
63	!	if (refresh) unlink(c(ffsx, ffs))
64	4x	if (is.null(key)) {
65	!	if (verbose) cli_alert_info("looking for API key in fall-backs")
66	4x	key <- Sys.getenv("DATAVERSE_KEY")
67	4x	if (key == "") {
68	!	key <- getOption("dataverse.key")
69		}
70		}
71	4x	if (length(which_files) == length(fs) \|\| !missing(version)) {
72	2x	zf <- paste0(outdir, gsub("\\W", "", meta$latestVersion$datasetPersistentId), ".zip")
73	!	if (verbose) cli_alert_info("downloading dataset: {meta$latestVersion$datasetPersistentId}")
74	2x	if (is.character(key)) {
75	!	if (verbose) cli_alert_info("trying with key")
76	2x	tryCatch(
77	2x	system2("curl", c(
78	2x	paste0("-H X-Dataverse-key:", key),
79	2x	"-o", zf,
80	2x	paste0(
81	2x	meta$server, "api/access/dataset/:persistentId/versions/", version, "?persistentId=",
82	2x	meta$latestVersion$datasetPersistentId
83		)
84	2x	), stdout = TRUE),
85	2x	error = function(e) NULL
86		)
87		} else {
88	!	if (verbose) cli_alert_info("trying without key")
89	!	tryCatch(
90	!	download.file(paste0(
91	!	meta$server, "api/access/dataset/:persistentId/versions/", version, "?persistentId=",
92	!	meta$latestVersion$datasetPersistentId
93	!	), zf, quiet = TRUE, mode = "wb"),
94	!	error = function(e) NULL
95		)
96		}
97	2x	if (file.exists(zf)) {
98	2x	unzip(zf, exdir = sub("/$", "", outdir))
99	2x	unlink(zf)
100	!	} else if (verbose) cli_alert_info("failed to download dataset {meta$id}; trying individual files...")
101		}
102	4x	for (i in which_files) {
103	4x	m <- meta$latestVersion$files[[i]]
104	4x	meta$latestVersion$files[[i]]$local <- ffs[i]
105	4x	if (!file.exists(ffs[i]) && !file.exists(ffsx[i])) {
106	!	if (verbose) cli_alert_info("downloading file: {.file {m$label}}")
107	1x	if (is.null(key)) {
108	!	if (verbose) cli_alert_info("trying without key")
109	!	tryCatch(
110	!	download.file(
111	!	paste0(meta$server, "api/access/datafile/", m$dataFile$id), ffsx[i],
112	!	quiet = TRUE, mode = "wb"
113		),
114	!	error = function(e) NULL
115		)
116		} else {
117	!	if (verbose) cli_alert_info("trying with key")
118	1x	tryCatch(
119	1x	system2("curl", c(
120	1x	paste0("-H X-Dataverse-key:", key),
121	1x	"-o", ffsx[i],
122	1x	paste0(meta$server, "api/access/datafile/", m$dataFile$id)
123	1x	), stdout = TRUE),
124	1x	error = function(e) NULL
125		)
126		}
127	!	if (verbose && !file.exists(ffsx[i])) cli_alert_info("failed to download file: {.file {m$label}}")
128		}
129	4x	if (file.exists(ffsx[i])) {
130	4x	if (verbose && m$dataFile$md5 != md5sum(ffsx[i])) {
131	!	cli_warn("file was downloaded but its checksum did not match: {.file {ffsx[i]}}")
132		}
133	4x	if (decompress && grepl("[gbx]z2?$", ffsx[i])) {
134	!	if (verbose) cli_alert_info("decompressing file: {.file {ffsx[i]}}")
135	!	system2(
136	!	c(xz = "xz", bz = "bunzip2", gz = "gzip")[substring(ffsx[i], nchar(ffsx[i]) - 1)],
137	!	c("-df", shQuote(ffsx[i]))
138		)
139		}
140		}
141	4x	if (load && file.exists(if (decompress) ffs[i] else ffsx[i])) {
142	!	if (verbose) cli_alert_info("loading file: {.file {ffs[i]}}")
143	4x	fn <- sub("\\..*", "", m$label)
144	4x	json <- grepl("\\.json$", ffs[i])
145	4x	data[[fn]] <- tryCatch(
146	4x	if (json) {
147	!	jsonlite::read_json(ffs[i], simplifyVector = TRUE)
148		} else {
149	4x	read_delim_arrow(gzfile(ffsx[i]), if (grepl("csv", format, fixed = TRUE)) "," else "\t")
150		},
151	4x	error = function(e) NULL
152		)
153	4x	if (verbose && is.null(data[[fn]])) {
154	!	cli_warn("file was downloaded but failed to load: {.file {ffs[i]}}")
155		}
156		}
157		}
158	4x	if (!decompress) ffs <- ffsx
159	4x	ffs <- ffs[which_files]
160	4x	if (verbose && any(!file.exists(ffs))) {
161	!	cli_warn("failed to download file{?s}: {.file {ffs[!file.exists(ffs)]}}")
162		}
163	4x	invisible(if (load) if (length(data) == 1) data[[1]] else data else meta)
164		}

1		#' Reformat an SDAD-formatted dataset
2		#'
3		#' Unify multiple files, which each contain a tall set of variables associated with regions.
4		#'
5		#' The basic assumption is that there are (a) entities which (b) exist in a hierarchy, and
6		#' (c1) have a static set of features and (c2) a set of variable features which
7		#' (d) are assessed at multiple time points.
8		#'
9		#' For example (and generally), entities are (a) regions, with (b) smaller regions making up larger regions,
10		#' and which (c1) have names, and (c2) population and demographic counts (d) between 2009 and 2019.
11		#'
12		#' @param files A character vector of file paths, or the path to a directory containing data files.
13		#' @param out Path to a directory to write files to; if not specified, files will not be written.
14		#' @param variables Vector of variable names (in the \code{value_name} column) to be included.
15		#' @param ids Vector of IDs (in the \code{id} column) to be included.
16		#' @param value Name of the column containing variable values.
17		#' @param value_name Name of the column containing variable names; assumed to be a single variable per file if
18		#' not present.
19		#' @param id Column name of IDs which uniquely identify entities.
20		#' @param time Column name of the variable representing time.
21		#' @param dataset Column name used to separate entity scales.
22		#' @param entity_info A list containing variable names to extract and create an ids map from (
23		#' \code{entity_info.json}, created in the output directory). Entries can be named to rename the
24		#' variables they refer to in entity features.
25		#' @param measure_info Measure info to add file information to (as \code{origin}) to, and write to \code{out}.
26		#' @param metadata A matrix-like object with additional information associated with entities,
27		#' (such as region types and names) to be merged by \code{id}.
28		#' @param formatters A list of functions to pass columns through, with names identifying those columns
29		#' (e.g., \code{list(region_name = function(x) sub(",.*$", "", x))} to strip text after a comma in the
30		#' "region_name" column).
31		#' @param compression A character specifying the type of compression to use on the created files,
32		#' between \code{"gzip"}, \code{"bzip2"}, and \code{"xz"}. Set to \code{FALSE} to disable compression.
33		#' @param read_existing Logical; if \code{FALSE}, will not read in existing sets.
34		#' @param overwrite Logical; if \code{TRUE}, will overwrite existing reformatted files, even if
35		#' the source files are older than it.
36		#' @param get_coverage Logical; if \code{FALSE}, will not calculate a summary of variable coverage (\code{coverage.csv}).
37		#' @param verbose Logical; if \code{FALSE}, will not print status messages.
38		#' @examples
39		#' dir <- paste0(tempdir(), "/reformat_example")
40		#' dir.create(dir, FALSE)
41		#'
42		#' # minimal example
43		#' data <- data.frame(
44		#' geoid = 1:10,
45		#' value = 1
46		#' )
47		#' write.csv(data, paste0(dir, "/data.csv"), row.names = FALSE)
48		#' (data_reformat_sdad(dir))
49		#'
50		#' # multiple variables
51		#' data <- data.frame(
52		#' geoid = 1:10,
53		#' value = 1,
54		#' measure = paste0("v", 1:2)
55		#' )
56		#' write.csv(data, paste0(dir, "/data.csv"), row.names = FALSE)
57		#' (data_reformat_sdad(dir))
58		#'
59		#' # multiple datasets
60		#' data <- data.frame(
61		#' geoid = 1:10,
62		#' value = 1,
63		#' measure = paste0("v", 1:2),
64		#' region_type = rep(c("a", "b"), each = 5)
65		#' )
66		#' write.csv(data, paste0(dir, "/data.csv"), row.names = FALSE)
67		#' (data_reformat_sdad(dir))
68		#' @return An invisible list of the unified variable datasets, split into datasets.
69		#' @export
70
71		data_reformat_sdad <- function(files, out = NULL, variables = NULL, ids = NULL, value = "value", value_name = "measure",
72		id = "geoid", time = "year", dataset = "region_type",
73		entity_info = c(type = "region_type", name = "region_name"), measure_info = list(),
74		metadata = NULL, formatters = NULL, compression = "xz", read_existing = TRUE,
75		overwrite = FALSE, get_coverage = TRUE, verbose = TRUE) {
76	4x	base_dir <- "./"
77	4x	if (length(files) == 1 && dir.exists(files)) {
78	!	base_dir <- files
79	!	files <- list.files(files, full.names = TRUE)
80		}
81	4x	if (any(!file.exists(files))) {
82	!	files <- files[!file.exists(files)]
83	!	cli_abort("file{? does/s do} not exist: {files}")
84		}
85	!	if (!is.null(metadata) && !id %in% colnames(metadata)) cli_abort("{.arg metadata} does not have an id ({id}) column")
86	4x	vars <- c(value, value_name, id, time, dataset)
87	4x	spec <- c(
88	4x	missing(value), missing(value_name), missing(id), missing(time), missing(dataset),
89	4x	rep(missing(entity_info), length(entity_info))
90		)
91	4x	data <- list()
92	4x	names <- list()
93	4x	i <- 0
94	1x	if (verbose) cli_progress_step("reading in {i}/{length(files)} original file{?s}", spinner = TRUE)
95	4x	max_age <- max(file.mtime(files))
96	4x	check_variables <- check_ids <- FALSE
97	4x	if (length(ids)) {
98	3x	check_ids <- TRUE
99	3x	ids <- unique(as.character(ids))
100		}
101	4x	for (f in files) {
102	17x	if (verbose) {
103	2x	i <- i + 1
104	2x	cli_progress_update()
105		}
106	17x	d <- attempt_read(f, id)
107	17x	if (is.null(d)) {
108	!	if (verbose) cli_warn("failed to read in file: {f}")
109	!	next
110		}
111	17x	if (!id %in% colnames(d)) {
112	!	if (verbose) cli_warn("file has no ID column: {f}")
113	!	next
114		}
115	!	if (anyNA(d[[id]])) d <- d[!is.na(d[[id]]), ]
116	17x	if (!nrow(d)) {
117	!	if (verbose) cli_warn("file has no observations: {f}")
118	!	next
119		}
120	17x	lcols <- tolower(colnames(d))
121	17x	if (any(!vars %in% colnames(d))) {
122	4x	l <- !colnames(d) %in% vars & lcols %in% vars
123	4x	colnames(d)[l] <- lcols[l]
124		}
125	17x	d[[id]] <- gsub("^\\s+\|\\s+$", "", d[[id]])
126	17x	if (check_ids) {
127	15x	su <- grepl("\\de[+-]\\d", d[[id]], perl = TRUE)
128	15x	if (any(su)) {
129	!	d[[id]][su] <- gsub("^\\s+\|\\s+$", "", format(as.numeric(d[[id]][su]), scientific = FALSE))
130		}
131	15x	su <- d[[id]] %in% ids
132	15x	if (!all(su)) d <- d[su, ]
133	15x	if (!nrow(d)) {
134	!	if (verbose) cli_warn("file has none of the requested IDs: {f}")
135	4x	next
136		}
137		}
138	13x	if (any(su <- !vars %in% colnames(d))) {
139	4x	if (all(su)) {
140	!	cli_warn("no variables found in file {f}")
141	!	next
142		}
143	4x	if (any(!spec[su])) {
144	!	cli_warn(
145	!	"table from {f} does not have {?a column name/column names} {.var {vars[su][!spec[su]]}}"
146		)
147	!	next
148		}
149	4x	vars <- vars[!su]
150	4x	spec <- spec[!su]
151		}
152	13x	names <- c(names, list(colnames(d)))
153	13x	if (grepl("repos/", f, fixed = TRUE)) {
154	11x	remote <- get_git_remote(sub("(^.+repos/[^/]+/).*$", "\\1.git/config", f))
155	11x	if (length(remote)) d$file <- paste0(remote, sub("^.+repos/[^/]+", "", f))
156	!	if (!"file" %in% colnames(d)) d$file <- sub("^.+repos/", "", f)
157		} else {
158	!	if (!grepl("/$", base_dir)) base_dir <- paste0(base_dir, "/")
159	2x	remote <- get_git_remote(paste0(base_dir, ".git/config"))
160	2x	d$file <- gsub("//+", "/", if (length(remote)) {
161	!	paste0(remote, "/", sub(base_dir, "", f, fixed = TRUE))
162		} else {
163	2x	sub(base_dir, "", f, fixed = TRUE)
164		})
165		}
166	13x	data <- c(data, list(d))
167		}
168	1x	if (verbose) cli_progress_done()
169	4x	common <- Reduce(intersect, names)
170	4x	if (!value %in% vars) {
171	1x	a <- common[!common %in% vars]
172	!	if (!length(a)) cli_abort("could not figure out which column might contain values")
173	!	if (length(a) > 1) a <- a[which(vapply(a, function(col) is.numeric(d[[col]]), TRUE))]
174	1x	if (!length(a)) {
175	!	cli_abort(c(
176	!	"no potential value columns were numeric",
177	!	i = "check variable classes, or specify {.arg value}"
178		))
179		}
180	1x	value <- a[1]
181	1x	vars <- c(value, vars)
182		}
183	4x	all <- unique(unlist(names))
184	4x	all <- all[all %in% vars & (all == id \| !all %in% colnames(metadata))]
185	4x	vars <- c(all, "file")
186	4x	if (length(variables)) {
187	3x	check_variables <- TRUE
188	3x	variables <- unique(as.character(variables))
189		}
190	4x	data <- do.call(rbind, lapply(seq_along(data), function(i) {
191	13x	d <- data[[i]]
192	13x	mv <- vars[!vars %in% colnames(d)]
193	!	if (length(mv)) d[, vars[!vars %in% colnames(d)]] <- ""
194	13x	d <- d[, vars]
195	4x	if (anyNA(d)) d <- d[rowSums(is.na(d)) == 0, ]
196	13x	if (check_variables) {
197	11x	ovars <- unique(d[[value_name]])
198	11x	su <- !ovars %in% variables
199	11x	if (any(su)) {
200	11x	names(ovars) <- ovars
201	11x	ovars[] <- make_full_name(d$file[[1]], ovars)
202	11x	su <- su & ovars %in% variables
203	41x	for (i in which(su)) d[[value_name]][d[[value_name]] == names(ovars)[i]] <- ovars[i]
204		}
205	11x	d <- d[d[[value_name]] %in% variables, ]
206		}
207	13x	d
208		}))
209	!	if (is.null(data) \|\| !nrow(data)) cli_abort("no datasets contained selected variables and/or IDs")
210	4x	cn <- colnames(data)
211	4x	if (!id %in% vars) {
212	!	id <- "id"
213	!	vars <- c(id, vars)
214	!	data <- cbind(id = unlist(lapply(table(data$file), seq_len), use.names = FALSE), data)
215		}
216	4x	data[[id]] <- as.character(data[[id]])
217	4x	if (!is.null(metadata)) {
218	!	su <- colnames(data) != id & colnames(data) %in% colnames(metadata)
219	!	if (any(su)) data <- data[, colnames(data) == id \| !su, drop = FALSE]
220	!	if (verbose) cli_progress_step("merging in metadata", msg_done = "merged in metadata")
221	!	metadata <- as.data.frame(metadata[!duplicated(metadata[[id]]) & metadata[[id]] %in% data[[id]], ])
222	!	if (!nrow(metadata)) cli_abort("{.arg metadata} had no ids in common with data")
223	!	rownames(metadata) <- metadata[[id]]
224	!	metadata[[id]] <- NULL
225	!	su <- data[[id]] %in% rownames(metadata)
226	!	if (!all(su)) {
227	!	if (verbose) cli_warn("{sum(!su)} rows contain IDs not in {.arg metadata} IDs, and will be dropped")
228	!	data <- data[su, ]
229		}
230	!	data <- cbind(data, metadata[data[[id]], , drop = FALSE])
231	!	cn <- colnames(data)
232	!	vars <- c(vars, colnames(metadata))
233	!	if (verbose) cli_progress_done()
234		}
235	4x	if (!is.null(formatters)) {
236	!	for (n in names(formatters)) {
237	!	if (n %in% cn) {
238	!	data[[n]] <- formatters[[n]](data[[n]])
239		}
240		}
241		}
242	4x	if (!dataset %in% vars) {
243	3x	dataset <- "dataset"
244	3x	vars <- c(vars, dataset)
245	3x	data$dataset <- dataset
246		}
247	4x	if (!time %in% vars) {
248	!	time <- "time"
249	!	vars <- c(vars, time)
250	!	data$time <- 1
251		}
252	4x	if (!any(value_name %in% vars)) {
253	!	vars <- c(vars, value_name)
254	!	data[[value_name]] <- sub("\\.[^.]+$", "", basename(data$file))
255		}
256	4x	data[[dataset]] <- gsub("\\s+", "_", data[[dataset]])
257	4x	datasets <- sort(unique(data[[dataset]]))
258	4x	present_vars <- unique(data[[value_name]])
259	4x	if (check_variables) {
260	3x	present_vars <- variables[variables %in% present_vars]
261	3x	if (verbose) {
262	!	absent_variables <- variables[!variables %in% present_vars]
263	!	if (length(absent_variables)) cli_warn("requested variable{?s} not found in datasets: {.val {absent_variables}}")
264		}
265		}
266	4x	times <- sort(unique(data[[time]]))
267	3x	if (all(nchar(times) == 4)) times <- seq(min(times), max(times))
268	4x	n <- length(times)
269	4x	files <- paste0(out, "/", gsub("\\s+", "_", tolower(datasets)), ".csv")
270	4x	if (is.character(compression) && grepl("^[gbx]", compression, FALSE)) {
271	4x	compression <- tolower(substr(compression, 1, 1))
272	4x	files <- paste0(files, ".", c(g = "gz", b = "bz2", x = "xz")[[compression]])
273		} else {
274	!	compression <- FALSE
275		}
276	4x	names(files) <- datasets
277	4x	write <- vapply(files, function(f) is.null(out) \|\| overwrite \|\| !file.exists(f) \|\| max_age > file.mtime(f), TRUE)
278	4x	if (!is.null(out) && (is.list(entity_info) \|\| is.character(entity_info))) {
279	4x	entity_info_file <- paste0(out, "/entity_info.json")
280	4x	if (overwrite \|\| !file.exists(entity_info_file) \|\| any(write)) {
281	4x	entity_info <- as.list(entity_info)
282	4x	entity_info <- entity_info[unlist(entity_info) %in% colnames(data)]
283	4x	if (length(entity_info)) {
284	1x	if (verbose) {
285	1x	cli_progress_step(
286	1x	"writing entity file",
287	1x	msg_done = paste0("wrote entity metadata file: {.file ", entity_info_file, "}")
288		)
289		}
290	1x	e <- data[, unique(c(id, dataset, unlist(entity_info))), drop = FALSE]
291	1x	if (!is.null(names(entity_info))) {
292	1x	for (en in names(entity_info)) {
293	1x	if (en != "" && entity_info[[en]] %in% colnames(e)) colnames(e)[colnames(e) == entity_info[[en]]] <- en
294		}
295		}
296	1x	jsonlite::write_json(
297	1x	lapply(split(e, e[, 2]), function(g) {
298	2x	lapply(
299	2x	split(g[, -(1:2), drop = FALSE], g[, 1]),
300	2x	function(l) lapply(l, function(r) r[which(r != "")[1]])
301		)
302		}),
303	1x	entity_info_file,
304	1x	auto_unbox = TRUE,
305	1x	digits = 6
306		)
307	1x	if (verbose) cli_progress_done()
308		}
309		}
310		}
311	4x	svars <- c(id, value, value_name, time, "file", dataset)
312	4x	data <- unique(data[, svars[svars %in% vars]])
313	4x	if (length(measure_info)) {
314	3x	dynamic_names <- render_info_names(measure_info)
315		}
316	4x	sets <- lapply(datasets, function(dn) {
317	5x	if (read_existing && !is.null(out) && file.exists(files[[dn]]) && !write[[dn]]) {
318	!	if (verbose) cli_progress_step("reading in existing {dn} dataset", msg_done = "read existing {dn} dataset")
319	2x	read.csv(gzfile(files[[dn]]), check.names = FALSE)
320		} else {
321	3x	d <- if (dataset %in% vars) data[data[[dataset]] == dn, ] else data
322	3x	dc <- list()
323	3x	ids <- unique(d[[id]])
324	3x	i <- 0
325	3x	if (verbose) {
326	2x	cli_progress_step(
327	2x	"creating {dn} dataset (ID {i}/{length(ids)})",
328	2x	msg_done = "created {dn} dataset ({length(ids)} IDs)", spinner = TRUE
329		)
330		}
331	3x	d <- d[!duplicated(paste(d[[id]], d[[value_name]], d[[time]])), ]
332	3x	if (length(measure_info)) {
333	1x	source <- unique(d[, c(value_name, "file")])
334	1x	source <- structure(source[[2]], names = source[[1]])
335	1x	for (measure in names(source)) {
336	18x	iname <- if (length(measure_info[[dynamic_names[measure]]])) dynamic_names[measure] else measure
337	18x	if (length(measure_info[[iname]])) {
338	4x	measure_info[[iname]]$origin <<- unique(c(
339	4x	measure_info[[iname]]$origin, source[[measure]]
340		))
341		}
342		}
343		}
344	3x	sd <- split(d, d[[id]])
345	3x	ssel <- c(time, value)
346	3x	for (i in seq_along(ids)) {
347	5x	if (verbose) cli_progress_update()
348	9x	e <- ids[[i]]
349	9x	ed <- sd[[e]]
350	9x	r <- data.frame(
351	9x	ID = rep(as.character(e), n), time = times, check.names = FALSE,
352	9x	matrix(NA, n, length(present_vars), dimnames = list(times, present_vars))
353		)
354	9x	if (all(c(value_name, value) %in% names(ed))) {
355	9x	ed <- ed[!is.na(ed[[value]]), ]
356	9x	ed <- split(ed[, ssel], ed[[value_name]])
357	9x	for (v in names(ed)) {
358	78x	vals <- ed[[v]]
359	78x	if (nrow(vals)) r[as.character(vals[[time]]), v] <- vals[[value]]
360		}
361		}
362	9x	rownames(r) <- NULL
363	9x	dc[[i]] <- r
364		}
365	3x	do.call(rbind, dc)
366		}
367		})
368	4x	names(sets) <- datasets
369	4x	if (length(measure_info)) {
370	3x	measure_info_file <- paste0(out, "/measure_info.json")
371	!	if (verbose) cli_alert_info("updating measure info: {.file {measure_info_file}}")
372	3x	jsonlite::write_json(measure_info[sort(names(measure_info))], measure_info_file, auto_unbox = TRUE, pretty = TRUE)
373		}
374	4x	if (!is.null(out)) {
375	4x	if (get_coverage && read_existing) {
376	1x	if (verbose) cli_progress_step("updating coverage report", msg_done = "updated coverage report")
377	4x	variables <- sort(if (length(variables)) variables else unique(unlist(lapply(sets, colnames), use.names = FALSE)))
378	4x	allcounts <- structure(numeric(length(variables)), names = variables)
379	4x	write.csv(vapply(sets, function(d) {
380	5x	counts <- colSums(!is.na(d))
381	5x	counts <- counts[names(counts) %in% variables]
382	5x	allcounts[names(counts)] <- counts
383	5x	allcounts
384	4x	}, numeric(length(variables))), paste0(out, "/coverage.csv"))
385	1x	if (verbose) cli_progress_done()
386		}
387	4x	if (any(write)) {
388	1x	if (verbose) cli_progress_step("writing data files", msg_done = "wrote reformatted datasets:")
389	2x	for (i in seq_along(sets)) {
390	3x	if (write[[i]]) {
391	3x	if (is.character(compression)) o <- do.call(paste0(compression, "zfile"), list(files[[i]]))
392	3x	write_csv_arrow(sets[[i]], o)
393		}
394		}
395	2x	if (verbose) {
396	1x	cli_progress_done()
397	1x	cli_bullets(structure(
398	1x	paste0("{.file ", files[write], "}"),
399	1x	names = rep("*", sum(write))
400		))
401		}
402	2x	} else if (verbose) {
403	!	cli_bullets(c(
404	!	v = "all files are already up to date:",
405	!	structure(paste0("{.file ", files, "}"), names = rep("*", length(files)))
406		))
407		}
408		}
409	4x	invisible(sets)
410		}

1		#' Refresh Data Commons Repositories
2		#'
3		#' Clone and/or pull repositories that are part of a data commons project.
4		#'
5		#' @param dir Directory of the data commons projects, as created by \code{\link{init_datacommons}}.
6		#' @param clone_method Means of cloning new repositories; either \code{"http"} (default) or \code{"ssh"}.
7		#' @param include_distributions Logical; if \code{TRUE}, will attempt to locate and cache copies of datasets
8		#' pointed to from the data repositories (so far just from Dataverse, implicitly from DOI files).
9		#' @param refresh_distributions Logical; if \code{TRUE}, will download fresh copies of the distribution metadata.
10		#' @param only_new Logical; if \code{TRUE}, only repositories that do not yet exist will be processed.
11		#' @param reset_repos Logical; if \code{TRUE}, will fetch and hard reset the repositories to remove any local changes.
12		#' @param reset_on_fail Logical; if \code{TRUE}, will reset only if a regular pull fails.
13		#' @param rescan_only Logical; if \code{TRUE}, will only read the files that are already in place, without checking for
14		#' updates from the remote repository.
15		#' @param run_checks Logical; if \code{FALSE}, will not run \code{\link{check_repository}} on each repository.
16		#' @param dataset_map A named vector of ID to dataset mappings to pass to \code{\link{check_repository}}
17		#' if \code{run_checks} is \code{TRUE}.
18		#' @param force_value_check Logical; if \code{TRUE}, will always intensively check values, even on large files.
19		#' @param verbose Logical; if \code{FALSE}, will not show updated repositories.
20		#' @examples
21		#' \dontrun{
22		#' # refresh from a data commons working directory
23		#' datacommons_refresh(".")
24		#' }
25		#' @return An invisible character vector of updated repositories.
26		#' @export
27
28		datacommons_refresh <- function(dir, clone_method = "http", include_distributions = FALSE, refresh_distributions = FALSE,
29		only_new = FALSE, reset_repos = FALSE, reset_on_fail = FALSE, rescan_only = FALSE,
30		run_checks = TRUE, dataset_map = "region_type", force_value_check = FALSE, verbose = TRUE) {
31	!	if (missing(dir)) cli_abort('{.arg dir} must be specified (e.g., as ".")')
32	1x	if (Sys.which("git") == "") {
33	!	cli_abort(c(
34	!	x = "the {.emph git} command could not be located",
35	!	i = "you might need to install git: {.url https://git-scm.com/downloads}"
36		))
37		}
38	1x	check <- check_template("datacommons", dir = dir)
39	1x	if (!check$exists) {
40	!	cli_abort(c(
41	!	x = "{.arg dir} does not appear to point to a data commons project",
42	!	i = paste0('initialize it with {.code init_datacommons("', dir, '")}')
43		))
44		}
45	1x	dir <- normalizePath(dir, "/", FALSE)
46	1x	commons <- jsonlite::read_json(paste0(dir, "/commons.json"))
47	1x	repos <- sort(unique(unlist(Filter(length, c(
48	1x	commons$repositories, readLines(paste0(dir, "/scripts/repos.txt"))
49		)))))
50	!	if (!length(repos)) cli_abort("no repositories are listed in {.file commons.json}.")
51	1x	repos <- gsub("^[\"']+\|['\"]+$\|^.*github\\.com/", "", repos)
52	1x	su <- !grepl("/", repos, fixed = TRUE)
53	1x	if (any(su)) {
54	!	repos <- repos[su]
55	!	cli_abort("repo{?s are/ is} missing a username prefix: {.files {repos}}")
56		}
57	1x	repos <- sub("^([^/]+/[^/#@]+)[^/]*$", "\\1", repos)
58	1x	if (!identical(unlist(commons$repositories, use.names = FALSE), repos)) {
59	!	commons$repositories <- repos
60	!	jsonlite::write_json(commons, paste0(dir, "/commons.json"), auto_unbox = TRUE, pretty = TRUE)
61		}
62	1x	writeLines(repos, paste0(dir, "/scripts/repos.txt"))
63	1x	if (only_new) {
64	!	repos <- repos[!file.exists(paste0(dir, "/repos/", sub("^.*/", "", repos)))]
65	!	if (!length(repos)) {
66	!	if (verbose) cli_alert_success("no new repositories")
67	!	return(invisible(repos))
68		}
69		}
70	1x	updated <- dist_updated <- failed <- logical(length(repos))
71	1x	wd <- getwd()
72	1x	on.exit(setwd(wd))
73	1x	repo_dir <- paste0(normalizePath(paste0(dir, "/repos/"), "/", FALSE), "/")
74	1x	dir.create(repo_dir, FALSE, TRUE)
75	1x	setwd(repo_dir)
76	1x	method <- if (clone_method == "ssh") "git@github.com:" else "https://github.com/"
77	!	if (include_distributions) dir.create(paste0(dir, "/cache"), FALSE)
78	1x	manifest_file <- paste0(dir, "/manifest/repos.json")
79	1x	repo_manifest <- list()
80	1x	for (i in seq_along(repos)) {
81	1x	r <- repos[[i]]
82	1x	rn <- sub("^.*/", "", r)
83	1x	cr <- paste0(repo_dir, rn, "/")
84	1x	if (!rescan_only) {
85	1x	change_dir <- dir.exists(rn)
86	!	if (verbose) cli_alert_info(paste(if (change_dir) "pulling" else "cloning", rn))
87	!	if (change_dir) setwd(cr)
88	1x	s <- tryCatch(if (change_dir) {
89	!	if (reset_repos \|\| reset_on_fail) {
90	!	attempt <- if (reset_on_fail) system2("git", "pull", stdout = TRUE) else NULL
91	!	if (!is.null(attr(attempt, "status"))) {
92	!	system2("git", "clean --f", stdout = TRUE)
93	!	system2("git", "fetch", stdout = TRUE)
94	!	system2("git", "reset --hard FETCH_HEAD", stdout = TRUE)
95		} else {
96	!	attempt
97		}
98		} else {
99	!	system2("git", "pull", stdout = TRUE)
100		}
101		} else {
102	1x	system2("git", c("clone", paste0(method, r, ".git")), stdout = TRUE)
103	1x	}, error = function(e) e$message)
104	!	if (change_dir) setwd(repo_dir)
105	1x	if (length(s) != 1 \|\| s != "Already up to date.") {
106	1x	if (!is.null(attr(s, "status"))) {
107	!	failed[i] <- TRUE
108	!	cli_alert_warning(c(
109	!	x = paste0("failed to retrieve ", r, ": ", paste(s, collapse = " "))
110		))
111		} else {
112	1x	updated[i] <- TRUE
113		}
114	!	} else if (!length(list.files(rn))) system2("rm", c("-rf", rn))
115		}
116	1x	repo_manifest[[r]]$base_url <- get_git_remote(paste0(cr, ".git/config"))
117	1x	files <- sort(list.files(
118	1x	cr, "\\.(?:csv\|tsv\|txt\|dat\|rda\|rdata)(?:\\.[gbx]z2?)?$",
119	1x	full.names = TRUE, recursive = TRUE, ignore.case = TRUE
120		))
121	1x	files <- normalizePath(files, "/")
122	1x	for (f in files) {
123	7x	repo_manifest[[r]]$files[[sub("^.*/repos/[^/]+/", "", f)]] <- list(
124	7x	size = file.size(f),
125	7x	sha = system2("git", c("hash-object", shQuote(f)), stdout = TRUE),
126	7x	md5 = md5sum(f)[[1]]
127		)
128		}
129	1x	doi <- repo_manifest[[r]]$distributions$dataverse$doi
130	1x	if (include_distributions && !is.null(doi)) {
131	!	if (verbose) {
132	!	ul <- cli_ul()
133	!	iul <- cli_ul()
134	!	cli_li("including Dataverse distribution for {.emph {doi}}")
135		}
136	!	meta_file <- paste0(dir, "/cache/", rn, "/dataverse_metadata.json")
137	!	meta <- if (!refresh_distributions && file.exists(meta_file)) {
138	!	jsonlite::read_json(meta_file, simplifyVector = TRUE)
139		} else {
140	!	tryCatch(download_dataverse_info(doi, refresh = refresh_distributions), error = function(e) NULL)
141		}
142	!	if (is.null(meta)) {
143	!	if (verbose) {
144	!	cli_li(col_red("failed to download Dataverse metadata for {.emph {doi}}"))
145	!	cli_end(iul)
146	!	cli_end(ul)
147		}
148		} else {
149	!	if (is.null(meta$latestVersion)) meta$latestVersion <- list(files = meta$files)
150	!	dir.create(paste0(dir, "/cache/", rn), FALSE)
151	!	jsonlite::write_json(meta, meta_file, auto_unbox = TRUE)
152	!	repo_manifest[[r]]$distributions$dataverse$id <- meta$datasetId
153	!	repo_manifest[[r]]$distributions$dataverse$server <- meta$server
154	!	repo_manifest[[r]]$distributions$dataverse$files <- list()
155	!	if (length(meta$latestVersion$files)) {
156	!	for (f in meta$latestVersion$files) {
157	!	existing <- paste0(dir, "/cache/", rn, "/", f$dataFile$filename)
158	!	if (file.exists(existing)) {
159	!	if (verbose) cli_li("checking existing version of {.file {f$dataFile$filename}}")
160	!	if (md5sum(existing) != f$dataFile$md5) unlink(existing)
161		}
162	!	if (!file.exists(existing)) {
163	!	if (verbose) cli_li("downloading {.file {f$dataFile$filename}}")
164	!	res <- tryCatch(download_dataverse_data(
165	!	doi, paste0(dir, "/cache/", rn),
166	!	files = f$label, load = FALSE, decompress = FALSE
167	!	), error = function(e) NULL)
168	!	if (is.null(res)) {
169	!	if (verbose) cli_li(col_red("failed to download {.file {f$dataFile$filename}}"))
170		} else {
171	!	dist_updated[i] <- TRUE
172		}
173		}
174	!	if (file.exists(existing)) {
175	!	repo_manifest[[r]]$distributions$dataverse$files[[sub("^.*/cache/[^/]+/", "", existing)]] <- list(
176	!	id = f$dataFile$id,
177	!	size = file.size(existing),
178	!	md5 = md5sum(existing)[[1]]
179		)
180		}
181		}
182		}
183		}
184	!	if (verbose) {
185	!	cli_end(iul)
186	!	cli_end(ul)
187		}
188		}
189	1x	if (run_checks) {
190	!	if (verbose) cli_progress_step("running checks...", msg_done = "ran checks:")
191	1x	repo_manifest[[r]]$repo_checks <- tryCatch(
192	1x	check_repository(cr, dataset = dataset_map, verbose = FALSE),
193	1x	error = function(e) NULL
194		)
195	1x	repo_manifest[[r]]$repo_checks <- lapply(repo_manifest[[r]]$repo_checks[
196	1x	grep("^summary\|^(?:info\|warn\|fail)_", names(repo_manifest[[r]]$repo_checks))
197	1x	], function(l) {
198	1x	if (is.character(l)) l <- sub("^.*/repos/[^/]+/", "", l)
199	3x	if (!is.null(names(l))) names(l) <- sub("^.*/repos/[^/]+/", "", names(l))
200	4x	l
201		})
202	1x	if (verbose) {
203	!	cli_progress_done()
204	!	if (length(repo_manifest[[r]]$repo_checks$summary)) {
205	!	print(repo_manifest[[r]]$repo_checks$summary)
206	!	cat("\n")
207		}
208		}
209		}
210		}
211	1x	if (verbose) {
212	!	if (any(updated)) {
213	!	updated_repos <- repos[updated]
214	!	cli_alert_success("updated data repositor{?ies/y}: {.file {updated_repos}}")
215		}
216	!	if (any(dist_updated)) {
217	!	updated_distributions <- repos[dist_updated]
218	!	cli_alert_success("updated distributed file{?s} in: {.file {updated_distributions}}")
219		}
220	!	if (any(failed)) {
221	!	failed_repos <- repos[failed]
222	!	cli_alert_danger("failed to retrieve repositor{?ies/y}: {.file {failed_repos}}")
223	!	} else if (!any(updated \| dist_updated)) {
224	!	cli_alert_success("all data repositories are up to date")
225		}
226		}
227	1x	if (length(repo_manifest)) {
228	1x	su <- names(repo_manifest) %in% repos
229	1x	if (any(su)) {
230	1x	jsonlite::write_json(repo_manifest[su], manifest_file, auto_unbox = TRUE)
231		} else {
232	!	cli_warn("no repos were found in the existing repo manifest")
233		}
234		}
235	1x	init_datacommons(dir, refresh_after = FALSE, verbose = FALSE)
236	1x	invisible(repos[updated \| dist_updated])
237		}

1		init_package <- function(name = "package", dir = ".") {
2	2x	dir.create(paste0(dir, "/", name, "/R"), FALSE, TRUE)
3	2x	dir.create(paste0(dir, "/", name, "/inst/specs"), FALSE, TRUE)
4	2x	dir.create(paste0(dir, "/", name, "/tests/testthat"), FALSE, TRUE)
5		}
6
7		parse_rule <- function(condition) {
8	11x	comb_type <- grepl("\|", condition, fixed = TRUE)
9	11x	conds <- strsplit(gsub("\\s([&\|><=]+\|!=+)\\s", " \\1 ", gsub("=+", "=", condition)), " [&\|]+ ")[[1]]
10	11x	lapply(conds, function(co) {
11	17x	co <- strsplit(co, "\\s")[[1]]
12	7x	if (length(co) == 1) co <- c(sub("^!+", "", co), if (grepl("^!\\w", co)) "!" else "", "")
13	17x	Filter(function(e) {
14	68x	length(e) != 1 \|\| if (is.logical(e)) e else TRUE
15	17x	}, if (tolower(co[2]) %in% c("true", "false")) {
16	!	list(
17	!	id = co[1],
18	!	type = if (tolower(co[2]) == "true") "" else "!",
19	!	value = ""
20		)
21		} else {
22	17x	list(
23	17x	id = co[1],
24	17x	type = co[2],
25	17x	value = if (grepl("^\\d+$", co[3])) {
26	9x	as.numeric(co[3])
27		} else {
28	8x	gsub("[\"']", "", co[3])
29		},
30	17x	any = comb_type
31		)
32		})
33		})
34		}
35
36		process_conditions <- function(conditions, ids, caller) {
37	6x	for (i in seq_along(conditions)) {
38	7x	if (conditions[i] != "") {
39	1x	display <- TRUE
40	1x	if (grepl("^[dl][^:]*:", conditions[i], TRUE)) {
41	1x	if (grepl("^l", conditions[i], TRUE)) display <- FALSE
42	1x	conditions[i] <- sub("^[dl][^:]:\\s", "", conditions[i], TRUE)
43		}
44	1x	caller$rules <- c(caller$rules, list(list(
45	1x	condition = parse_rule(conditions[i]),
46	1x	effects = if (display) list(display = ids[i]) else list(lock = ids[i])
47		)))
48		}
49		}
50		}
51
52		to_input_row <- function(e) {
53	!	c(
54	!	'<div class="col">', e[2], "</div>",
55	!	'<div class="col">', e[-c(1:2, length(e))], "</div>"
56		)
57		}
58
59		make_build_environment <- function() {
60	30x	e <- new.env()
61	30x	attr(e, "name") <- "community_site_parts"
62	30x	e$site_build <- function(...) {}
63	30x	e$uid <- 0
64	30x	e
65		}
66
67		calculate_sha <- function(file, level) {
68	5x	if (Sys.which("openssl") != "") {
69	5x	tryCatch(
70	5x	strsplit(
71	5x	system2("openssl", c("dgst", paste0("-sha", level), shQuote(file)), TRUE), " ",
72	5x	fixed = TRUE
73	5x	)[[1]][2],
74	5x	error = function(e) ""
75		)
76		} else {
77		""
78		}
79		}
80
81		head_import <- function(d, dir = ".") {
82	35x	if (!is.null(d$src) && (!d$src %in% c("script.js", "style.css") \|\| (file.exists(paste0(dir, "/docs/", d$src)) &&
83	35x	file.size(paste0(dir, "/docs/", d$src))))) {
84	33x	paste(c(
85	33x	"<", if (d$type == "script") 'script type="application/javascript" src="' else 'link href="', d$src, '"',
86	33x	if (!is.null(d$hash)) c(' integrity="', d$hash, '"', ' crossorigin="anonymous"'),
87	33x	if (d$type == "stylesheet") {
88	15x	c(
89	15x	' rel="', if (!is.null(d$loading)) d$loading else "preload", '" as="style" media="all"',
90	15x	' onload="this.onload=null;this.rel=\'stylesheet\'"'
91		)
92		},
93	33x	if (d$type == "script") {
94	18x	if (is.null(d$loading)) {
95	15x	" async"
96		} else {
97	2x	if (d$loading == "") "" else c(" ", d$loading)
98		}
99	33x	}, ">", if (d$type == "script") "</script>"
100	33x	), collapse = "")
101		}
102		}
103
104		make_full_name <- function(filename, variable) {
105	20x	sub("^:", "", paste0(sub(
106		"^.*[\\\\/]", "",
107	20x	gsub("^.\\d{4}(?:q\\d)?_\|\\.\\w{3,4}(?:\\.[gbx]z2?)?$\|\\..$", "", basename(filename))
108	20x	), ":", variable))
109		}
110
111		replace_equations <- function(info) {
112	5x	lapply(info, function(e) {
113	6x	descriptions <- grep("description", names(e), fixed = TRUE)
114	6x	if (length(descriptions)) {
115	6x	for (d in descriptions) {
116	6x	p <- gregexpr(
117	6x	"(?:\\$\|\\\\\\[\|\\\\\\(\|\\\\begin\\{math\\})(.+?)(?:\\$\|\\\\\\]\|\\\\\\)\|\\\\end\\{math\\})(?=\\s\|$)",
118	6x	e[[d]],
119	6x	perl = TRUE
120	6x	)[[1]]
121	6x	if (p[[1]] != -1) {
122	5x	re <- paste("", e[[d]], "")
123	5x	fm <- regmatches(e[[d]], p)
124	5x	for (i in seq_along(p)) {
125	5x	mp <- attr(p, "capture.start")[i, ]
126	5x	eq <- substring(e[[d]], mp, mp + attr(p, "capture.length")[i, ] - 1)
127	5x	parsed <- tryCatch(katex_mathml(eq), error = function(e) NULL)
128	5x	if (!is.null(parsed)) {
129	5x	re <- paste(
130	5x	strsplit(re, fm[[i]], fixed = TRUE)[[1]],
131	5x	collapse = sub("^<[^>]>", "", sub("<[^>]>$", "", parsed))
132		)
133		}
134		}
135	5x	e[[d]] <- gsub("^ \| $", "", re)
136		}
137		}
138		}
139	!	if (is.list(e$categories)) e$categories <- replace_equations(e$categories)
140	!	if (is.list(e$variants)) e$variants <- replace_equations(e$variants)
141	6x	e
142		})
143		}
144
145		preprocess <- function(l) {
146	25x	if (!is.list(l)) l <- sapply(l, function(n) list())
147	52x	ns <- names(l)
148	52x	for (i in seq_along(l)) {
149	79x	name <- if (ns[i] == "blank") "" else ns[i]
150	79x	l[[i]]$name <- name
151	21x	if (is.null(l[[i]]$default)) l[[i]]$default <- name
152		}
153	52x	l
154		}
155
156		replace_dynamic <- function(e, p, s, v = NULL, default = "default") {
157	735x	m <- gregexpr(p, e)
158	735x	if (m[[1]][[1]] != -1) {
159	249x	t <- regmatches(e, m)[[1]]
160	249x	tm <- structure(gsub("\\{[^.]+\\.?\|\\}", "", t), names = t)
161	249x	tm <- tm[!duplicated(names(tm))]
162	249x	tm[tm == ""] <- default
163	249x	for (tar in names(tm)) {
164	275x	us <- (if (is.null(v) \|\| substring(tar, 2, 2) == "c") s else v)
165	275x	entry <- tm[[tar]]
166	275x	if (is.null(us[[entry]]) && grepl("description", entry, fixed = TRUE)) {
167	52x	entry <- default <- "description"
168		}
169	112x	if (is.null(us[[entry]]) && entry == default) entry <- "default"
170	!	if (is.null(us[[entry]])) cli_abort("failed to render measure info from {tar}")
171	275x	e <- gsub(tar, us[[entry]], e, fixed = TRUE)
172		}
173		}
174	735x	e
175		}
176
177		prepare_source <- function(o, s, p) {
178	158x	if (length(o)) {
179	83x	lapply(o, function(e) {
180	57x	if (is.character(e) && length(e) == 1) replace_dynamic(e, p, s) else e
181		})
182		} else {
183	75x	list(name = "", default = "")
184		}
185		}
186
187		render_info_names <- function(infos) {
188	6x	r <- lapply(names(infos), function(n) render_info(infos[n], TRUE))
189	6x	structure(rep(names(infos), vapply(r, length, 0)), names = unlist(r))
190		}
191
192		render_info <- function(info, names_only = FALSE) {
193	62x	base_name <- names(info)
194	62x	base <- info[[1]]
195	62x	if (is.null(base$categories) && is.null(base$variants)) {
196	36x	return(if (names_only) base_name else info)
197		}
198	26x	categories <- preprocess(base$categories)
199	26x	variants <- preprocess(base$variants)
200	26x	base$categories <- NULL
201	26x	base$variants <- NULL
202	26x	expanded <- NULL
203	26x	vars <- strsplit(as.character(outer(
204	26x	if (is.null(names(categories))) "" else names(categories),
205	26x	if (is.null(names(variants))) "" else names(variants),
206	26x	paste,
207	26x	sep = "\|\|\|"
208	26x	)), "\|\|\|", fixed = TRUE)
209	26x	for (var in vars) {
210	79x	cs <- if (var[1] == "") list() else categories[[var[1]]]
211	79x	vs <- if (length(var) == 1 \|\| var[2] == "") list() else variants[[var[2]]]
212	79x	cs <- prepare_source(cs, vs, "\\{variants?(?:\\.[^}]+?)?\\}")
213	79x	vs <- prepare_source(vs, cs, "\\{categor(?:y\|ies)(?:\\.[^}]+?)?\\}")
214	79x	s <- c(cs, vs[!names(vs) %in% names(cs)])
215	79x	p <- "\\{(?:categor(?:y\|ies)\|variants?)(?:\\.[^}]+?)?\\}"
216	79x	key <- replace_dynamic(base_name, p, cs, vs)
217	79x	if (names_only) {
218	45x	expanded <- c(expanded, key)
219		} else {
220	34x	expanded[[key]] <- c(
221	34x	structure(lapply(names(base), function(n) {
222	396x	e <- base[[n]]
223	336x	if (is.character(e) && length(e) == 1) e <- replace_dynamic(e, p, cs, vs, n)
224	396x	e
225	34x	}), names = names(base)),
226	34x	s[!names(s) %in% c(
227	34x	"default",
228	34x	"name",
229	34x	if (any(base[c("long_description", "short_description")] != "")) "description",
230	34x	names(base)
231		)]
232		)
233		}
234		}
235	26x	expanded
236		}
237
238		get_git_remote <- function(config) {
239	29x	if (file.exists(config)) {
240	27x	conf <- readLines(config)
241	27x	branch <- grep("[branch", conf, fixed = TRUE, value = TRUE)
242	27x	url <- grep("url =", conf, fixed = TRUE, value = TRUE)
243	27x	if (length(branch) && length(url)) {
244	27x	paste0(
245	27x	gsub("^.+=\\s\|\\.git", "", url[[1]]), "/blob/",
246	27x	gsub('^[^"]+"\|"\\]', "", branch[[1]])
247		)
248		}
249		}
250		}
251
252		attempt_read <- function(file, id_col) {
253	29x	tryCatch(
254		{
255	29x	sep <- if (grepl(".csv", file, fixed = TRUE)) "," else "\t"
256	29x	cols <- scan(file, "", nlines = 1, sep = sep, quiet = TRUE)
257	29x	types <- rep("?", length(cols))
258	29x	types[cols == id_col] <- "c"
259	29x	read_delim_arrow(
260	29x	gzfile(file), sep,
261	29x	col_names = cols, col_types = paste(types, collapse = ""), skip = 1
262		)
263		},
264	29x	error = function(e) NULL
265		)
266		}

1		#' @rdname download_dataverse_data
2		#' @return \code{download_dataverse_info}: A list with the dataset's metadata.
3		#' @export
4
5		download_dataverse_info <- function(id, server = NULL, key = NULL, refresh = FALSE, branch = NULL,
6		version = ":latest", verbose = FALSE) {
7	!	if (missing(id)) cli_abort("an id must be specified")
8	9x	if (!grepl("doi", tolower(id), fixed = TRUE) && (grepl("github", id, fixed = TRUE) \|\| grepl("^[^/]+/[^/]+$", id))) {
9	1x	if (is.null(branch) && grepl("@\|/tree/", id)) {
10	!	branch <- regmatches(id, regexec("(?:@\|tree/)([^/]+)", id))[[1]][2]
11	!	if (is.na(branch)) branch <- NULL
12		}
13	1x	id <- regmatches(id, regexec("^(?:.*github\\.com/)?([^/]+/[^/@]+)", id))[[1]][2]
14	1x	repo <- tryCatch(jsonlite::read_json(
15	1x	paste0("https://api.github.com/repos/", id)
16	1x	), error = function(e) NULL)
17	1x	if (!is.null(repo$default_branch)) {
18	!	if (verbose) cli_alert_info("getting ID from Github repository {id}")
19	1x	dataset_doi <- NULL
20	1x	tryCatch(
21	1x	load(file(paste0(
22	1x	"https://raw.githubusercontent.com/", id, "/",
23	1x	if (is.null(branch)) repo$default_branch else branch, "/R/sysdata.rda"
24		))),
25	1x	error = function(e) NULL
26		)
27	1x	if (!is.null(dataset_doi)) {
28	1x	id <- dataset_doi[[1]]
29		} else {
30	!	cli_abort(paste0(
31	!	"{.arg id} points to a Github repository that does not have an appropriate",
32	!	"{.file /R/sysdata.rda} file"
33		))
34		}
35		}
36		}
37	9x	id <- sub("^(http\|doi)[^\\d]*", "", id, perl = TRUE)
38	9x	temp <- paste0(tempdir(), "/", gsub("\\W", "", id), ".json")
39	!	if (refresh) unlink(temp)
40	9x	if (!file.exists(temp)) {
41	6x	if (is.null(server)) {
42	3x	server <- if (Sys.which("curl") != "") {
43	!	if (verbose) cli_alert_info("getting server from DOI ({id}) redirect")
44	3x	tryCatch(
45		{
46	3x	url <- gsub("<[^>]*>", "", system2("curl", paste0("https://doi.org/", id), stdout = TRUE)[5])
47	!	if (grepl("^http", url)) gsub("^https?://\|/citation.*$", "", url) else NA
48		},
49	3x	error = function(e) {
50	!	if (verbose) cli_alert_info("failed to get server from DOI ({id}) redirect")
51	3x	NA
52		}
53		)
54		} else {
55	3x	NA
56		}
57	3x	if (is.na(server)) {
58	!	if (verbose) cli_alert_info("looking for server in fall-backs")
59	3x	server <- Sys.getenv("DATAVERSE_SERVER")
60	3x	if (server == "") {
61	!	server <- getOption("dataverse.server")
62	!	if (is.null(server)) server <- "dataverse.lib.virginia.edu"
63		}
64		}
65		}
66	6x	if (is.null(key)) {
67	!	if (verbose) cli_alert_info("looking for API key in fall-backs")
68	4x	key <- Sys.getenv("DATAVERSE_KEY", getOption("dataverse.key", ""))
69		}
70	6x	if (!grepl("://", server, fixed = TRUE)) server <- paste0("https://", server)
71	6x	server <- sub("/api/.*$", "/", gsub("//+$", "/", paste0(server, "/")))
72		}
73	9x	res <- tryCatch(
74		{
75	9x	if (!file.exists(temp)) {
76	!	if (verbose) cli_alert_info("downloading dataset metadata for {id} from {server}")
77	6x	if (is.character(key) && key != "") {
78	!	if (verbose) cli_alert_info("trying with key")
79	4x	download.file(
80	4x	paste0(server, "api/datasets/:persistentId/versions/", version, "?persistentId=doi:", id), temp,
81	4x	quiet = TRUE, headers = c("X-Dataverse-key" = key)
82		)
83	4x	if (file.exists(temp)) {
84	4x	res <- jsonlite::read_json(temp)
85	4x	if (is.null(res$data)) {
86	!	unlink(temp)
87	!	stop(res$message)
88		}
89	4x	res <- res$data
90		} else {
91	!	stop("download failed")
92		}
93		} else {
94	!	if (verbose) cli_alert_info("trying without key")
95	2x	res <- jsonlite::read_json(
96	2x	paste0(server, "api/datasets/:persistentId/versions/", version, "?persistentId=doi:", id)
97	2x	)$data
98		}
99	4x	res$server <- server
100	4x	jsonlite::write_json(res, temp, auto_unbox = TRUE)
101	4x	res
102		} else {
103	!	if (verbose) cli_alert_info("reading in existing metadata for {id}")
104	3x	jsonlite::read_json(temp)
105		}
106		},
107	9x	error = function(e) e$message
108		)
109	9x	if (is.character(res)) {
110	2x	if (file.exists(temp)) {
111	!	cli_abort(cli_bullets(c(
112	!	x = "downloaded the metadata, but failed to read it in: {res}",
113	!	i = paste0("check {.file ", temp, "}")
114		)))
115		} else {
116	2x	cli_abort(cli_bullets(c(
117	2x	x = "failed to retrive info",
118	2x	i = paste0(
119	2x	"tried for this dataset: {.url ", server, "dataset.xhtml?persistentId=doi:", id, "}"
120		),
121	2x	if (length(res)) c("!" = paste("got this error:", res))
122		)))
123		}
124		}
125	7x	if (is.null(res$latestVersion)) res$latestVersion <- res
126	7x	res
127		}

1		#' Create a new package function
2		#'
3		#' Create initial script and test files for a function that is to be added to a package.
4		#'
5		#' @param name Name of the function. Should start with the function's category, followed by a specific name,
6		#' separated by an underscore (\code{'_'}) (e.g., \code{'init_function'}).
7		#' @param dir Path to the package's development directory; default is the current working directory.
8		#' @param overwrite Logical; if \code{TRUE}, replaces existing files with templates.
9		#' @examples
10		#' \dontrun{
11		#'
12		#' # creates a skeleton for a `measure_new` function
13		#' init_function("measure_new")
14		#' }
15		#' @return Creates files in \code{dir/R} and \code{dir/tests/testthat}, attempts to navigate to the code file,
16		#' and returns a character vector to their paths.
17		#' @export
18
19		init_function <- function(name, dir = ".", overwrite = FALSE) {
20	!	if (missing(name)) cli_abort("{.arg name} must be specified")
21	2x	name <- sub("\\.[Rr]$", "", name[[1]])
22	2x	dir <- paste0(normalizePath(dir, "/"), "/")
23	2x	if (!check_template("package", dir = dir)$exists) {
24	!	cli_abort(paste(
25	!	"{.arg dir} must be a package directory,",
26	!	"but {.code check_template('package')} failed"
27		))
28		}
29	2x	paths <- paste0(dir, c("R/", "tests/testthat/test-"), name, ".R")
30	!	if (!overwrite && any(file.exists(paths))) cli_abort("files exist -- set overwrite to {.code TRUE} to overwrite them")
31	!	if (!grepl("_", name, fixed = TRUE)) cli_abort("name should be in a {.emph prefix_suffix} format")
32	2x	writeLines(paste0(
33	2x	"#' <template: Short, high-level description of function.>",
34	2x	"\n#'\n#' <template: Full description of function.>\n#'",
35	2x	"\n#' @param argument <template: Argument description.>",
36	2x	"\n#' @examples\n#' \\dontrun{",
37	2x	"\n#' <template: a working example for illustration; add outside of \\dontrun{} when possible>\n#' }",
38	2x	"\n#' @return <template: Description of what is returned.>",
39	2x	"\n#' @export",
40	2x	"\n\n", name, " <- function(argument){\n\n}"
41	2x	), paths[1])
42	2x	writeLines(paste0("test_that('a test has been written for ", name, "', {\n expect_true(FALSE)\n})"), paths[2])
43	2x	msg <- c("created files for function {name}:", paste0("{.file ", paths, "}"))
44	2x	names(msg) <- c("v", rep("*", length(paths)))
45	2x	if (interactive()) {
46	!	cli_bullets(msg)
47	!	navigateToFile(paths[1])
48		}
49	2x	invisible(paths)
50		}

1		#' Create a website
2		#'
3		#' Create a repository for a static website for data documentation and exploration.
4		#'
5		#' @param dir Directory in which to create the site's structure. Will be created if it does not exist.
6		#' @param title Title of the site.
7		#' @param template Name of a template to use, which are pre-constructed \code{site.R} and \code{build.R}
8		#' files. If \code{FALSE} or not found, no such files will be made.
9		#' @param with_data Logical; if \code{TRUE}, a data sub-directory and datapackage will be created.
10		#' @param node_project Logical; if \code{TRUE}, includes files used to run the site from a Node.js server.
11		#' @param include_api Logical; if \code{TRUE}, will make a \code{netlify.toml} config file to specify the
12		#' function directory for the API function, if included by \code{\link{site_build}}.
13		#' @param overwrite Logical; if \code{TRUE}, will overwrite existing site files in \code{dir}.
14		#' @param quiet Logical; if \code{TRUE}, suppresses messages and does not navigate to the file when finished.
15		#' @examples
16		#' \dontrun{
17		#' # initialize site in the current working directory
18		#' init_site(".")
19		#' }
20		#' @return Path to the created site directory.
21		#' @export
22
23		init_site <- function(dir, title = "app", template = "mtcars", with_data = FALSE, node_project = FALSE,
24		include_api = FALSE, overwrite = FALSE, quiet = !interactive()) {
25	!	if (missing(dir)) cli_abort('{.arg dir} must be speficied (e.g., dir = ".")')
26	7x	check <- check_template("site", dir = dir)
27	7x	if (!quiet && check$exists && !overwrite) {
28	!	cli_bullets(c(`!` = "site files already exist", i = "add {.code overwrite = TRUE} to overwrite them"))
29		}
30	7x	dir <- normalizePath(paste0(dir, "/", check$spec$dir), "/", FALSE)
31	7x	dir.create(dir, FALSE, TRUE)
32	7x	dir <- normalizePath(dir, "/", FALSE)
33	7x	paths <- paste0(dir, "/", c(
34	7x	"README.md", "site.R", "package.json", "server.js", ".gitignore", "build.R",
35	7x	"project.Rproj", "netlify.toml"
36		))
37	!	if (overwrite) unlink(paths, TRUE)
38	7x	if (!file.exists(paths[1])) {
39	4x	writeLines(c(
40	4x	paste("#", title),
41	4x	"<template: Describe the site>",
42	4x	"\n## Run",
43	4x	"```R",
44	4x	'# remotes::install_github("uva-bi-sdad/community")',
45	4x	"library(community)",
46	4x	"\n# from the site directory:",
47	4x	'site_build(".")',
48		"```"
49	4x	), paths[1])
50		}
51	7x	template <- paste0(path.package("community"), c("/inst", ""), "/templates/", template, "/")
52	7x	template <- template[which(file.exists(template))[1]]
53	7x	if (!is.na(template)) {
54	4x	if (!file.exists(paths[2])) file.copy(paste0(template, "site.R"), paths[2])
55	3x	if (!file.exists(paths[6])) file.copy(paste0(template, "build.R"), paths[6])
56		}
57	7x	if (node_project && !file.exists(paths[3])) {
58	!	jsonlite::write_json(list(
59	!	name = gsub("\\s+", "_", tolower(title)),
60	!	version = "1.0.0",
61	!	description = "",
62	!	main = "server.js",
63	!	directories = list(doc = "docs"),
64	!	scripts = list(start = "node server.js"),
65	!	dependencies = list(express = "latest"),
66	!	author = "",
67	!	license = "ISC"
68	!	), paths[3], auto_unbox = TRUE, pretty = TRUE)
69		}
70	7x	if (node_project && !file.exists(paths[4])) {
71	!	writeLines(c(
72	!	"'use strict'",
73	!	"const express = require('express'), app = express()",
74	!	"app.use(express.static('docs'))",
75	!	"app.listen(3000, function () {",
76	!	" console.log('listening on port 3000')",
77		"})"
78	!	), paths[4])
79		}
80	7x	if (!file.exists(paths[5])) {
81	4x	writeLines(c(
82	4x	".Rproj.user",
83	4x	".Rhistory",
84	4x	".Rdata",
85	4x	".httr-oauth",
86	4x	".DS_Store",
87	4x	".netlify",
88	4x	"*.Rproj",
89	4x	"node_modules",
90	4x	"package-lock.json",
91	4x	"docs/dist"
92	4x	), paths[5])
93		}
94	6x	if (!file.exists(paths[7]) && !any(grepl("\\.Rproj$", list.files(dir)))) writeLines("Version: 1.0\n", paths[7])
95	7x	if (include_api && !file.exists(paths[8])) {
96	!	writeLines(c(
97	!	"[build]",
98	!	" publish = 'docs'",
99	!	"[[redirects]]",
100	!	" from = '/api'",
101	!	" to = '/.netlify/functions/api'",
102	!	" status = 200",
103	!	"[functions]",
104	!	" directory = 'docs/functions'"
105	!	), paths[8])
106		}
107	7x	dir.create(paste0(dir, "/docs"), FALSE)
108	7x	dir.create(paste0(dir, "/docs/functions"), FALSE)
109	7x	docs <- grep("/docs/", check$files, fixed = TRUE, value = TRUE)
110	6x	if (any(!file.exists(docs))) file.create(docs[!file.exists(docs)])
111	7x	if (with_data && !file.exists(paste0(dir, "/docs/data/datapackage.json"))) {
112	2x	dir.create(paste0(dir, "/docs/data"), FALSE)
113	2x	init_data(title, dir = paste0(dir, "/docs/data"), quiet = TRUE)
114		}
115	7x	if (!quiet) {
116	!	cli_bullets(c(
117	!	v = "created a site skeleton for {title}:",
118	!	"*" = paste0("{.path ", normalizePath(dir, "/", FALSE), "}")
119		))
120	!	if (file.exists(paths[2])) navigateToFile(paths[2])
121		}
122	7x	invisible(dir)
123		}

1		#' Add a map to a webpage
2		#'
3		#' Adds a Leaflet map to a webpage, based on specified or selected inputs.
4		#'
5		#' @param shapes A list or list of lists specifying GeoJSON files. Each list should have at least
6		#' a \code{url} entry (the URL of the file), and will need a \code{name} entry (associating it
7		#' with one of the site's datasets) if the site has multiple datasets. The file's features
8		#' must each have a \code{properties} field containing an ID found in the data -- by default
9		#' this is assumed to be called \code{"geoid"}, but this can be specified with an \code{id_property}
10		#' entry in the list. For example \code{shapes = list(name = "data", }\code{
11		#' url = "https://example.com/shapes.geojson", id_property = "id")}. A \code{time} entry can also
12		#' specify different maps for the same dataset, based on the selected time, along with a \code{resolution}
13		#' entry to specify how to match the year; either \code{"decade"} (default) or \code{"exact"}.
14		#' @param overlays additional layers to add to the map, based on the selected variable; a list or list of
15		#' lists with entries at least for \code{variable} (name of the variable associated with the layer) and
16		#' \code{source} (path to the layer file, or a list with entries including \code{url} and
17		#' \code{time}). Entries can also include a \code{filter} entry, with a list or list of lists of conditions,
18		#' including entries for \code{feature} (name of the feature on which to condition entity inclusion),
19		#' \code{operator}, and \code{value}.
20		#' @param color The name of a variable, or id of a variable selector, to be used to color polygons.
21		#' @param color_time The ID of a selector to specify which timepoint of \code{color} to use.
22		#' @param dataview The ID of an \code{\link{input_dataview}} component.
23		#' @param id Unique ID for the map.
24		#' @param click The ID of an input to set to a clicked polygon's ID.
25		#' @param subto A vector of output IDs to receive hover events from.
26		#' @param background_shapes The name of a dataset (shapes) to show within a selection, regardless of
27		#' selected dataset. Useful to show lower-level regions within higher-level regions.
28		#' @param options A list of configuration options, potentially extracted from a saved leaflet object (see
29		#' \href{https://leafletjs.com/reference-1.7.1.html#map-example}{Leaflet documentation}).
30		#' @param overlays_from_measures Logical; if \code{TRUE}, will look for overlay information in
31		#' measurement information.
32		#' @param tiles A list or list of lists containing provider information (see
33		#' \href{https://leaflet-extras.github.io/leaflet-providers/preview/}{leaflet providers}; e.g.,
34		#' \code{list(}\code{url = "https://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png"}, \code{options = list(maxZoom = 19))}).
35		#' @param attribution A list with tile attribution information to be included in a credits section. To add
36		#' attributions to the map, include them in \code{tile}'s \code{options} list.
37		#' @examples
38		#' output_map()
39		#' @return A character vector of the content to be added.
40		#' @export
41
42		output_map <- function(shapes = NULL, overlays = NULL, color = NULL, color_time = NULL, dataview = NULL,
43		id = NULL, click = NULL, subto = NULL, background_shapes = NULL,
44		options = list(), overlays_from_measures = TRUE, tiles = list(
45		url = "https://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png",
46		options = list(maxZoom = 19)
47		), attribution = list(
48		name = "OpenStreetMap",
49		url = "https://www.openstreetmap.org/copyright"
50		)) {
51	3x	caller <- parent.frame()
52	3x	building <- !is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts"
53	2x	if (is.null(id)) id <- paste0("map", caller$uid)
54	3x	if (building) {
55	1x	caller$dependencies$leaflet_style <- list(
56	1x	type = "stylesheet",
57	1x	src = "https://cdn.jsdelivr.net/npm/leaflet@1.9.4/dist/leaflet.min.css",
58	1x	hash = "sha384-EdLG5Q0/L1OytQXhWSU1bWVqvLMxlmdSRaA09iy8FGYjlpP7vnB3MueQ6ZloG9oF"
59		)
60	1x	caller$dependencies$leaflet <- list(
61	1x	type = "script",
62	1x	src = "https://cdn.jsdelivr.net/npm/leaflet@1.9.4/dist/leaflet.min.js",
63	1x	hash = "sha384-u5N8qJeJOO2iqNjIKTdl6KeKsEikMAmCUBPc6sC6uGpgL34aPJ4VgNhuhumedpEk"
64		)
65	1x	options$overlays_from_measures <- overlays_from_measures
66	1x	options$subto <- if (!is.null(subto) && length(subto) == 1) list(subto) else subto
67	1x	if (is.null(options[["center"]])) options$center <- c(40, -95)
68	1x	if (is.null(options[["zoom"]])) options$zoom <- 4
69	1x	if (!is.null(background_shapes) && is.null(options[["background_shapes"]])) {
70	!	options$background_shapes <- background_shapes
71		}
72	!	if (is.character(shapes)) shapes <- lapply(shapes, function(s) list(url = s))
73	!	if (is.list(shapes) && !is.list(shapes[[1]])) shapes <- list(shapes)
74	1x	snames <- names(shapes)
75	1x	for (i in seq_along(shapes)) {
76	!	if (!is.null(snames[i])) shapes[[i]]$name <- snames[i]
77	!	if (is.null(shapes[[i]]$id_property)) shapes[[i]]$id_property <- "geoid"
78		}
79	1x	if (!is.null(overlays)) {
80	!	if (is.character(overlays)) overlays <- lapply(overlays, function(s) list(url = s))
81	!	if (is.list(overlays) && !is.list(overlays[[1]])) overlays <- list(overlays)
82	!	snames <- names(overlays)
83	!	for (i in seq_along(overlays)) {
84	!	if (!is.null(snames[i])) overlays[[i]]$name <- snames[i]
85		}
86		}
87	1x	caller$map[[id]] <- Filter(length, list(
88	1x	shapes = unname(shapes), overlays = unname(overlays), options = options, tiles = tiles
89		))
90		}
91	3x	r <- paste(c(
92	3x	'<div class="auto-output leaflet"',
93	3x	if (!is.null(dataview)) paste0('data-view="', dataview, '"'),
94	3x	if (!is.null(click)) paste0('data-click="', click, '"'),
95	3x	if (!is.null(color)) paste0('data-color="', color, '"'),
96	3x	if (!is.null(color_time)) paste0('data-colorTime="', color_time, '"'),
97	3x	paste0('id="', id, '"'),
98	3x	'data-autoType="map"></div>'
99	3x	), collapse = " ")
100	3x	if (building) {
101	1x	caller$content <- c(caller$content, r)
102	1x	caller$credits$leaflet <- list(
103	1x	name = "Leaflet",
104	1x	url = "https://leafletjs.com",
105	1x	version = "1.9.4",
106	1x	description = "A JS library for interactive maps"
107		)
108	1x	if (!missing(attribution) \|\| missing(tiles)) {
109	1x	if (!is.null(attribution$name)) {
110	1x	caller$credits[[attribution$name]] <- attribution
111	!	} else if (!is.null(attribution[[1]]$name)) {
112	!	for (a in attribution) caller$credits[[a$name]] <- a
113		}
114		}
115	1x	caller$uid <- caller$uid + 1
116		}
117	3x	r
118		}

1		#' Adds a menu to a website
2		#'
3		#' Adds a section to arrange inputs, that can optionally be collapsed, and positioned on any side.
4		#'
5		#' @param ... Elements to appear in the menu.
6		#' @param position A character indicating which side to place the menu on; one of
7		#' \code{"top"}, \code{"right"}, \code{"bottom"}, or \code{"left"}.
8		#' @param width Width of the menu, if \code{position} is \code{"left"} or \code{"right"}.
9		#' @param height Height of the menu, if \code{position} is \code{"top"} or \code{"bottom"}.
10		#' @param collapsible Logical; if \code{FALSE}, removes the button to open or close the menu.
11		#' @param default_open Logical; if \code{TRUE}, the menu will start open.
12		#' @param wraps Logical or character (\code{"row" or "col"}); if \code{FALSE},
13		#' elements of the menu will not be wrapped in row or column elements.
14		#' @param sizes The relative size of each wrapper, between 1 and 12, or \code{"auto"}; default is equal size.
15		#' @param breakpoints Bootstrap breakpoint of each wrapper; one of \code{""} (extra small), \code{"sm"},
16		#' @param conditions A character for each element representing the conditions in which that should be showing
17		#' (e.g., \code{c("", "input_a == a", "")}); \code{""} means the element's display is not conditional.
18		#' Adding \code{"lock: "} before the condition will disable inputs rather than hide the element.
19		#' @examples
20		#' \dontrun{
21		#' page_menu(
22		#' input_select("menu item", c("a", "b", "c"))
23		#' )
24		#' }
25		#' @return A character vector of the content to be added.
26		#' @export
27
28		page_menu <- function(..., position = "right", width = "300px", height = NULL, collapsible = TRUE,
29		default_open = FALSE, wraps = TRUE, sizes = NA, breakpoints = NA, conditions = "") {
30	4x	caller <- parent.frame()
31	4x	building <- !is.null(attr(caller, "name")) && attr(caller, "name") == "community_site_parts"
32	4x	parts <- new.env()
33	4x	attr(parts, "name") <- "community_site_parts"
34	4x	parts$uid <- caller$uid
35	4x	elements <- substitute(...(), environment())
36	4x	n <- length(elements)
37	4x	vertical <- position %in% c("left", "right")
38	4x	wraps <- rep_len(if (length(wraps) == 1 && !is.character(wraps) && wraps) {
39	1x	if (vertical) "row" else "col"
40		} else {
41	!	wraps
42	4x	}, n)
43	4x	sizes <- rep_len(sizes, n)
44	4x	breakpoints <- rep_len(breakpoints, n)
45	4x	conditions <- rep_len(conditions, n)
46	4x	ids <- paste0("menu", parts$uid, seq_len(n))
47	4x	parts$uid <- parts$uid + 1
48	!	if (is.numeric(width)) width <- paste0(width, "px")
49	!	if (is.numeric(height)) height <- paste0(height, "px")
50	4x	r <- c(
51	4x	paste0(c(
52	4x	'<div data-state="', if (default_open) "open" else "closed", '" class="menu-wrapper menu-', position, '"',
53	4x	c(
54	4x	' style="', position, ": ", if (default_open) 0 else paste0("-", width), "; ",
55	4x	if (!is.null(height)) c("; height: ", height),
56		'"'
57		),
58		">"
59	4x	), collapse = ""),
60	4x	paste0(
61	4x	'<div class="menu', if (vertical) " col" else " row",
62	4x	if (!default_open) " hidden", " menu-", position, '">'
63		),
64	4x	unlist(lapply(seq_len(n), function(i) {
65	4x	c(
66	4x	if (!is.na(wraps[i])) {
67	4x	paste(c(
68	4x	'<div class="', wraps[i],
69	4x	if (!is.na(breakpoints[i])) c("-", breakpoints[i]),
70	4x	if (!is.na(sizes[i])) c("-", sizes[i]),
71	4x	'"', if (conditions[i] != "") paste0(' id="', ids[i], '"'), ">"
72	4x	), collapse = "")
73		},
74	4x	eval(elements[[i]], parts),
75	4x	if (!is.na(wraps[i])) "</div>"
76		)
77	4x	}), use.names = FALSE),
78	4x	"</div>",
79	4x	if (collapsible) paste0('<button type="button" class="menu-toggle" title="', position, ' menu"></button>'),
80	4x	"</div>"
81		)
82	4x	if (building) {
83	2x	caller$body <- c(caller$body, r)
84	2x	for (n in names(parts)) if (n != "content") caller[[n]] <- c(caller[[n]], parts[[n]])
85	2x	caller$uid <- parts$uid
86	2x	process_conditions(conditions, ids, caller)
87		}
88	4x	r
89		}