community coverage - 76.03%

Files
Source

#' 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,
    fixedColumns = TRUE,
    fixedHeader = 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/v/dt/dt-2.2.2/b-3.2.2/b-html5-3.2.2/fc-5.0.4/fh-4.0.1/sc-2.4.3/datatables.min.css",
        hash = "sha384-qOKJwbsCzk6PnFc+V/zaBZOoXDHoZ/dB0Hn09YPxZsHGTAN8cl6D0hARDTib5Yr/"
      )
      caller$dependencies$datatables <- list(
        type = "script",
        src = "https://cdn.datatables.net/v/dt/dt-2.2.2/b-3.2.2/b-html5-3.2.2/fc-5.0.4/fh-4.0.1/sc-2.4.3/datatables.min.js",
        hash = "sha384-S7iVdep2ySxWDHxb4VCStvzYwG1eXVWOVAsXdYJejn+dHAYKFbiL0h1KyRku12NW",
        loading = "defer"
      )
      caller$credits$datatables <- list(
        name = "DataTables",
        url = "https://datatables.net",
        version = "2.2.2"
      )
    }
    if (datatables) caller$datatable[[id]] <- options else
      caller$table[[id]] <- options
    caller$content <- c(caller$content, r)
    caller$uid <- caller$uid + 1
  }
  r
}

#' 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("miserman/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)
}

#' 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
}

#' 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)
}

#' 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 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-b8ANgTJvdlAnWM5YGMpKn7Kodm+1k7NYNG9zdjTCcZcKatzYHwZ0RLdWarbJJVzU"
    )
    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
}

#' 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(
      system.file(package = "community"),
      if (file.exists(paste0(system.file(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
}

#' 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)
}

#' 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
}

#' 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)
}

#' 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
}

#' @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))
      )))
    }
  }
  res
}

#' 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 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 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
}

#' 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 pretty Logical; if \code{TRUE}, will pretty-print the datapackage.
#' @param summarize_ids: Logical; if \code{TRUE}, will include ID columns in schema field summaries.
#' @param open_after Logical; if \code{TRUE}, opens the written datapackage after saving.
#' @param verbose Logical; if \code{FALSE}, will not show status messages.
#' @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,
  pretty = FALSE,
  summarize_ids = FALSE,
  open_after = FALSE,
  verbose = interactive()
) {
  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(".parquet", f, fixed = TRUE)) {
      "parquet"
    } else 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 if (format == "parquet") {
      tryCatch(read_parquet(f), error = function(e) NULL)
    } else {
      attempt_read(f, c("geography", "time", idvars))
    }
    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]]])
        id_lengths <- id_lengths[!is.na(id_lengths)]
        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(
          if (summarize_ids) colnames(data) else
            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,
      pretty = pretty
    )
    if (verbose) {
      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)
}

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) {
    if (!is.list(e)) e <- list(default = 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_cols) {
  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 %in% id_cols] <- "c"
      read_delim_arrow(
        gzfile(file),
        sep,
        col_names = cols,
        col_types = paste(types, collapse = ""),
        skip = 1
      )
    },
    error = function(e) NULL
  )
}

#' 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 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
}

#' 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])
}

#' 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$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$datasetPersistentId), ".zip")
    if (verbose)
      cli_alert_info("downloading dataset: {meta$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$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$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$files[[i]]
    meta$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)
}

#' 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
}

#' 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
}

#' 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
}

#' 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
}

#' 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)
}

#' 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
}

#' 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)
}

#' 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("miserman/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(
    system.file(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://miserman.github.io/community/dist/css/datacommons.min.css"
              ),
              list(
                type = "script",
                src = "https://miserman.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 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
}

#' 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("miserman/community")',
        "library(community)",
        "\n# from the site directory:",
        'site_build(".")',
        "```"
      ),
      paths[1]
    )
  }
  template <- paste0(
    system.file(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)
}

#' 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
}

#' @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))
}

#' 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)
}

#' 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
}

#' 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 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
}

#' 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
}

#' 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 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@3.0.1/dist/plotly.min.js",
      hash = "sha384-8cEu0XVLh4s92OG4Ua4ZS75MN//b+0KqyCrhQqaXgHMVHnKC3DNVhwUyH5spa1J2"
    )
    caller$credits$plotly <- list(
      name = "Plotly",
      url = "https://plotly.com/javascript/getting-started",
      version = "3.0.1"
    )
    if (plotly) caller$plotly[[id]] <- options else
      caller$echarts[[id]] <- options
    caller$content <- c(caller$content, r)
    caller$uid <- caller$uid + 1
  }
  r
}

#' 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)
}

#' 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(
      system.file(package = "community"),
      c("/inst", ""),
      "/templates/",
      template,
      "/"
    )
    td <- td[which(file.exists(td))[1]]
    if (is.na(td))
      td <- paste0(
        system.file(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)
}

#' 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
}

#' 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
}

#' 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
}

#' 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
}

#' 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
}

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(
36		variables = NULL,
37		dataset = NULL,
38		dataview = NULL,
39		id = NULL,
40		click = NULL,
41		subto = NULL,
42		options = NULL,
43		features = NULL,
44		filters = NULL,
45		wide = TRUE,
46		class = "compact",
47		datatables = TRUE
48		) {
49	5x	caller <- parent.frame()
50	5x	building <- !is.null(attr(caller, "name")) &&
51	5x	attr(caller, "name") == "community_site_parts"
52	4x	if (is.null(id)) id <- paste0("table", caller$uid)
53	5x	defaults <- list(
54	5x	paging = TRUE,
55	5x	scrollY = 500,
56	5x	scrollX = 500,
57	5x	scrollCollapse = TRUE,
58	5x	scroller = TRUE,
59	5x	deferRender = TRUE,
60	5x	fixedColumns = TRUE,
61	5x	fixedHeader = TRUE
62		)
63	5x	if (!is.null(options$height)) {
64	!	options$scrollY <- options$height
65	!	options$height <- NULL
66		}
67	5x	so <- names(options)
68	5x	if (!datatables && (!wide \|\| (length(so) && any(so != "scrollY")))) {
69	!	cli_warn(paste(
70	!	"because {.arg datatables} is disabled, the {.arg wide} argument is ignored,",
71	!	"and all {.arg options} except {.arg options$scrollY} are ignored"
72		))
73		}
74	5x	for (n in names(defaults)) if (!n %in% so) options[[n]] <- defaults[[n]]
75	5x	type <- if (datatables) "datatable" else "table"
76	5x	r <- paste(
77	5x	c(
78	5x	paste0(
79	5x	if (!datatables) {
80	1x	paste0(
81	1x	'<div class="table-wrapper" style="max-height: ',
82	1x	options$scrollY,
83	1x	if (is.numeric(options$scrollY)) "px",
84		'">'
85		)
86		},
87	5x	'<table class="auto-output tables',
88	5x	if (is.null(class)) "" else paste("", class),
89		'"'
90		),
91	5x	if (!is.null(dataview)) paste0('data-view="', dataview, '"'),
92	5x	if (!is.null(click)) paste0('data-click="', click, '"'),
93	5x	paste0(
94	5x	'id="',
95	5x	id,
96	5x	'" data-autoType="',
97	5x	type,
98	5x	'"></table>',
99	5x	if (!datatables) "</div>"
100		)
101		),
102	5x	collapse = " "
103		)
104	5x	if (building) {
105	2x	if (!is.null(variables)) {
106	1x	if (!is.character(variables) \|\| length(variables) > 1) {
107	!	if (!is.list(variables)) {
108	!	variables <- as.list(variables)
109	!	} else if (!is.list(variables[[1]])) variables <- list(variables)
110	!	vnames <- names(variables)
111	!	for (i in seq_along(variables)) {
112	!	if (is.null(names(variables[[i]])))
113	!	variables[[i]] <- list(name = variables[[i]][[1]])
114	!	if (!is.null(vnames[i])) variables[[i]]$title <- vnames[i]
115		}
116		}
117	1x	options$variables <- variables
118		}
119	2x	if (!is.null(features)) {
120	!	if (!is.character(features) \|\| length(features) > 1) {
121	!	if (!is.list(features)) {
122	!	features <- as.list(features)
123	!	} else if (!is.list(features[[1]]) && "name" %in% names(features))
124	!	features <- list(features)
125	!	vnames <- names(features)
126	!	for (i in seq_along(features)) {
127	!	if (is.null(names(features[[i]])))
128	!	features[[i]] <- list(name = features[[i]][[1]])
129	!	if (!is.null(vnames[i])) features[[i]]$title <- vnames[i]
130		}
131		}
132	!	options$features <- unname(features)
133		}
134	2x	options$subto <- if (!is.null(subto) && length(subto) == 1) list(subto) else
135	2x	subto
136	2x	options$filters <- filters
137	2x	options$dataset <- dataset
138	2x	options$single_variable <- wide && length(variables) == 1
139	2x	options$wide <- if (!wide && length(variables) == 1) TRUE else wide
140	2x	if (datatables) {
141	2x	caller$dependencies$jquery <- list(
142	2x	type = "script",
143	2x	src = "https://cdn.jsdelivr.net/npm/jquery@3.7.0/dist/jquery.min.js",
144	2x	hash = "sha384-NXgwF8Kv9SSAr+jemKKcbvQsz+teULH/a5UNJvZc6kP47hZgl62M1vGnw6gHQhb1",
145	2x	loading = "defer"
146		)
147	2x	caller$dependencies$datatables_style <- list(
148	2x	type = "stylesheet",
149	2x	src = "https://cdn.datatables.net/v/dt/dt-2.2.2/b-3.2.2/b-html5-3.2.2/fc-5.0.4/fh-4.0.1/sc-2.4.3/datatables.min.css",
150	2x	hash = "sha384-qOKJwbsCzk6PnFc+V/zaBZOoXDHoZ/dB0Hn09YPxZsHGTAN8cl6D0hARDTib5Yr/"
151		)
152	2x	caller$dependencies$datatables <- list(
153	2x	type = "script",
154	2x	src = "https://cdn.datatables.net/v/dt/dt-2.2.2/b-3.2.2/b-html5-3.2.2/fc-5.0.4/fh-4.0.1/sc-2.4.3/datatables.min.js",
155	2x	hash = "sha384-S7iVdep2ySxWDHxb4VCStvzYwG1eXVWOVAsXdYJejn+dHAYKFbiL0h1KyRku12NW",
156	2x	loading = "defer"
157		)
158	2x	caller$credits$datatables <- list(
159	2x	name = "DataTables",
160	2x	url = "https://datatables.net",
161	2x	version = "2.2.2"
162		)
163		}
164	2x	if (datatables) caller$datatable[[id]] <- options else
165	!	caller$table[[id]] <- options
166	2x	caller$content <- c(caller$content, r)
167	2x	caller$uid <- caller$uid + 1
168		}
169	5x	r
170		}

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("miserman/community_example", "../community_example")
20		#' }
21		#' @return Invisible path to the child directory.
22		#' @export
23
24		site_make_child <- function(
25		parent,
26		dir,
27		update = FALSE,
28		overwrite = FALSE,
29		protect = "site.R",
30		include = NULL,
31		quiet = !interactive()
32		) {
33	1x	if (missing(dir))
34	!	cli_abort('{.arg dir} must be speficied (e.g., dir = "child_site")')
35	1x	check <- check_template("site", dir = dir)
36	1x	if (!quiet && any(file.exists(check$files)) && !overwrite) {
37	!	cli_bullets(c(
38	!	`!` = "site files already exist",
39	!	i = "add {.code overwrite = TRUE} to overwrite them"
40		))
41		}
42	1x	dir <- normalizePath(paste0(dir, "/", check$spec$dir), "/", FALSE)
43	1x	dir.create(dir, FALSE, TRUE)
44	1x	dir.create(paste0(dir, "/docs/data"), FALSE, TRUE)
45	1x	files <- unique(c(
46	1x	unlist(check$spec$files, use.names = FALSE),
47	1x	"docs/data/datapackage.json",
48	1x	include
49		))
50	1x	filled <- copied <- structure(
51	1x	!file.exists(paste0(dir, "/", files)),
52	1x	names = files
53		)
54	1x	copied[] <- FALSE
55	1x	if (!file.exists(paste0(dir, "/build.R"))) {
56	1x	copied["build.R"] <- TRUE
57	1x	args <- lapply(match.call()[-1], eval, parent.frame())
58	1x	writeLines(
59	1x	paste(
60	1x	c(
61	1x	paste0("# this is a child site spawned from ", parent, ":"),
62	1x	paste0(
63	1x	"site_make_child(\n ",
64	1x	paste(
65	1x	vapply(
66	1x	names(args),
67	1x	function(a) {
68	2x	if (a %in% c("parent", "dir")) {
69	2x	paste0(a, ' = "', normalizePath(args[[a]], "/", FALSE), '"')
70		} else {
71	!	paste(a, "=", args[[a]])
72		}
73		},
74		""
75		),
76	1x	collapse = ",\n "
77		),
78	1x	"\n)"
79		),
80		""
81		),
82	1x	collapse = "\n"
83		),
84	1x	paste0(dir, "/build.R")
85		)
86		}
87	1x	init_site(dir, with_data = FALSE, quiet = TRUE)
88	1x	never_update <- c("build.R", "README.rm", protect)
89	1x	always_update <- c("docs/data/datapackage.json", include)
90	1x	if (!dir.exists(parent)) {
91	1x	parent <- regmatches(
92	1x	parent,
93	1x	regexec("^(?:.*github\\.com/)?([^/]+/[^/@]+)", parent)
94	1x	)[[1]][2]
95	1x	repo <- tryCatch(
96	1x	jsonlite::read_json(
97	1x	paste0("https://api.github.com/repos/", parent, "/contents")
98		),
99	1x	error = function(e) e$message
100		)
101	1x	if (is.character(repo))
102	!	cli_abort(
103	!	"treated {.arg parent} as a GitHub repository, but failed to retrieve it: {repo}"
104		)
105	1x	if (missing(update)) update <- FALSE
106	1x	repo <- c(
107	1x	repo,
108	1x	tryCatch(
109	1x	jsonlite::read_json(
110	1x	paste0("https://api.github.com/repos/", parent, "/contents/docs")
111		),
112	1x	error = function(e) NULL
113		),
114	1x	tryCatch(
115	1x	jsonlite::read_json(
116	1x	paste0("https://api.github.com/repos/", parent, "/contents/docs/data")
117		),
118	1x	error = function(e) NULL
119		)
120		)
121	1x	for (f in repo) {
122	32x	if (f$path %in% files[!files %in% never_update]) {
123	7x	dest <- paste0(dir, "/", f$path)
124		if (
125	7x	f$path %in% always_update \|\| overwrite \|\| update \|\| filled[[f$path]]
126		) {
127	7x	unlink(dest)
128	7x	tryCatch(
129	7x	download.file(f$download_url, dest, quiet = TRUE),
130	7x	error = function(e) NULL
131		)
132	7x	copied[[f$path]] <- file.exists(dest)
133		}
134		}
135		}
136		} else {
137	!	for (f in files[!files %in% never_update]) {
138	!	pf <- paste0(parent, "/", f)
139	!	dest <- paste0(dir, "/", f)
140		if (
141	!	file.exists(pf) &&
142	!	(f %in%
143	!	always_update \|\|
144	!	overwrite \|\|
145	!	filled[[f]] \|\|
146	!	(update && file.mtime(pf) > file.mtime(dest)))
147		) {
148	!	unlink(dest)
149	!	file.copy(pf, dest)
150	!	copied[[f]] <- file.exists(dest)
151		}
152		}
153		}
154	1x	if (!quiet) {
155	!	if (any(copied)) {
156	!	cli_bullets(c(
157	!	v = "copied from {.path {parent}}:",
158	!	"*" = paste0("{.path ", names(which(copied)), "}")
159		))
160		}
161	!	if (any(filled & !copied)) {
162	!	cli_bullets(c(
163	!	v = "created from template:",
164	!	"*" = paste0("{.path ", names(which(filled & !copied)), "}")
165		))
166		}
167	!	if (!any(filled \| copied)) {
168	!	cli_alert_success("no site files were replaced")
169		}
170		}
171	1x	invisible(dir)
172		}

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	system.file(package = "community"),
44	45x	if (file.exists(paste0(system.file(package = "community"), "/inst")))
45	45x	"/inst",
46	45x	"/specs/",
47	45x	sub(".json", "", template, fixed = TRUE),
48	45x	".json"
49		)
50	45x	report$status["spec"] <- file.exists(path)
51	45x	if (!report$status["spec"]) {
52	!	report$status[] <- FALSE
53	!	return(report)
54		}
55	45x	spec <- jsonlite::read_json(path)
56		}
57	45x	report$spec <- spec
58	45x	if (missing(name)) {
59	39x	name <- spec$name
60		}
61	45x	strict <- vapply(
62	45x	spec$files,
63	45x	function(f) is.character(f) && length(f) == 1,
64	45x	TRUE
65		)
66	45x	dir <- paste0(normalizePath(paste0(dir, "/", spec$dir), "/", FALSE), "/")
67	45x	report$dir <- dir
68	45x	report$status["dir"] <- dir.exists(dir)
69	45x	if (spec$context != spec$name) {
70	2x	check_context <- check_template(spec$context, dir = dir)
71	2x	if (!check_context$exists)
72	!	cli_abort(c(
73	!	"context {spec$context} check failed for {name}:",
74	!	check_context$message
75		))
76		}
77	45x	if (!report$status["dir"]) {
78	6x	report$message <- c(
79	6x	x = paste0(
80	6x	"the required directory ({.path ",
81	6x	spec$dir,
82	6x	"}) is not present in {.path ",
83	6x	normalizePath(dir, "/", FALSE),
84		"}"
85		)
86		)
87		}
88	45x	if (any(strict)) {
89	45x	files <- gsub(
90	45x	"{name}",
91	45x	name,
92	45x	paste0(dir, unlist(spec$files[strict])),
93	45x	fixed = TRUE
94		)
95	45x	report$files <- files
96	45x	present <- file.exists(files)
97	45x	report$status["strict"] <- all(present)
98	45x	if (!report$status["strict"]) {
99	17x	report$message <- c(
100	17x	report$message,
101	17x	x = paste0(
102	17x	"required file",
103	17x	if (sum(!present) == 1) " is" else "s are",
104	17x	" not present: ",
105	17x	paste0("{.path ", files[!present], "}", collapse = ", ")
106		)
107		)
108		} else {
109	28x	for (f in files[present]) {
110		if (
111	173x	!dir.exists(f) &&
112	173x	grepl(
113	173x	"<template:",
114	173x	paste(readLines(f, warn = FALSE), collapse = ""),
115	173x	fixed = TRUE
116		)
117		) {
118	9x	report$incomplete <- c(report$incomplete, f)
119		}
120		}
121		}
122		}
123	45x	if (any(!strict)) {
124	!	file_set <- spec$files[!strict][[1]]
125	!	if (length(file_set) == 1) {
126	!	files <- gsub(
127	!	"{name}",
128	!	spec$name,
129	!	paste0(dir, file_set[[1]]),
130	!	fixed = TRUE
131		)
132	!	report$files <- c(report$files, files)
133	!	present <- file.exists(files)
134	!	report$status["set"] <- any(present)
135	!	if (!report$status["set"]) {
136	!	report$message <- c(
137	!	report$message,
138	!	x = paste(
139	!	"one of these files is required, but none were present:",
140	!	paste(files, collapse = ", ")
141		)
142		)
143		} else {
144	!	for (f in files[present]) {
145		if (
146	!	!dir.exists(f) &&
147	!	grepl(
148	!	"<template:",
149	!	paste(readLines(f, warn = FALSE), collapse = ""),
150	!	fixed = TRUE
151		)
152		) {
153	!	report$incomplete <- c(report$incomplete, f)
154		}
155		}
156		}
157		} else {
158	!	file_set <- lapply(
159	!	file_set,
160	!	function(fl) gsub("{name}", spec$name, paste0(dir, fl), fixed = TRUE)
161		)
162	!	report$files <- c(report$files, unlist(file_set))
163	!	present <- vapply(file_set, function(fl) all(file.exists(fl)), TRUE)
164	!	report$status["set"] <- any(present)
165	!	if (!report$status["set"]) {
166	!	report$message <- c(
167	!	report$message,
168	!	paste(
169	!	x = "none of the required file sets were complete:",
170	!	file_set
171		)
172		)
173		} else {
174	!	for (fl in file_set[present]) {
175	!	for (f in fl) {
176		if (
177	!	!dir.exists(f) &&
178	!	grepl(
179	!	"<template:",
180	!	paste(readLines(f, warn = FALSE), collapse = ""),
181	!	fixed = TRUE
182		)
183		) {
184	!	report$incomplete <- c(report$incomplete, f)
185		}
186		}
187		}
188		}
189		}
190		}
191	45x	if (report$status["dir"] && any(!report$status[c("strict", "set")])) {
192	11x	report$message <- c(
193	11x	report$message,
194	11x	i = "use {.fn template_{name}} to create required structure"
195		)
196		}
197	28x	if (all(report$status)) report$exists <- TRUE
198	45x	report
199		}

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(
35		colors,
36		continuous = length(colors) < 5,
37		divergent = length(colors) > 2,
38		polynomial = FALSE,
39		degrees = 6,
40		pad = 10,
41		name = "custom",
42		preview = TRUE,
43		print = TRUE
44		) {
45	7x	if (missing(polynomial) && (!missing(degrees) \|\| !missing(pad)))
46	!	polynomial <- TRUE
47	7x	if (polynomial) {
48	1x	if (missing(divergent)) divergent <- FALSE
49	1x	if (!missing(continuous) && !continuous) {
50	!	cli_alert_warning(
51	!	"{.arg polynomial} if {.val TRUE}, so {.arg continuous} will also be {.val TRUE}"
52		)
53		}
54	1x	continuous <- TRUE
55		}
56	7x	if (is.character(colors)) {
57	6x	cols <- col2rgb(colors)
58		} else {
59	1x	cols <- colors
60	1x	if (is.null(dim(cols))) {
61	1x	cols <- if (is.list(cols)) {
62	!	as.data.frame(cols)
63		} else {
64	1x	matrix(cols, 3, dimnames = list(c("red", "green", "blue")))
65		}
66	!	} else if (ncol(cols) == 3 && nrow(cols) != 3) cols <- t(cols)
67		}
68	7x	if (nrow(cols) != 3)
69	!	cli_abort("{.arg colors} could not be resolved to a matrix of RGB vectors")
70	7x	palette <- if (continuous) {
71	4x	if (polynomial) {
72	1x	rownames(cols) <- c("red", "green", "blue")
73	1x	colnames(cols) <- NULL
74	1x	x <- seq.int(0, 1, length.out = ncol(cols))
75	!	if (max(cols) <= 1) cols <- cols * 256
76	1x	ori <- list(x = x, cols = cols)
77	1x	if (is.numeric(pad) && pad > 0) {
78	1x	x <- c(numeric(pad), x, rep(1, pad))
79	1x	cols <- cbind(
80	1x	matrix(
81	1x	rep(as.numeric(cols[, 1]), pad),
82	1x	3,
83	1x	dimnames = list(rownames(cols))
84		),
85	1x	cols,
86	1x	matrix(
87	1x	rep(as.numeric(cols[, ncol(cols)]), pad),
88	1x	3,
89	1x	dimnames = list(rownames(cols))
90		)
91		)
92		}
93	1x	coefs <- vapply(
94	1x	1:3,
95	1x	function(ch) {
96	3x	as.numeric(
97	3x	lm(
98	3x	cols[ch, ] ~ poly(x, degree = degrees, raw = TRUE, simple = TRUE)
99	3x	)$coefficients
100		)
101		},
102	1x	numeric(degrees + 1)
103		)
104	1x	if (anyNA(coefs))
105	!	cli_abort(
106	!	"this combination of inputs resulted in missing coefficient estimates"
107		)
108	1x	if (preview) {
109	1x	mm <- cbind(1, poly(ori$x, degrees, raw = TRUE))
110	1x	plot(
111	1x	NA,
112	1x	xlim = c(0, 1),
113	1x	ylim = c(0, 1),
114	1x	axes = FALSE,
115	1x	pch = 15,
116	1x	cex = 2,
117	1x	main = "Palette Comparison",
118	1x	ylab = "Palette",
119	1x	xlab = "Value"
120		)
121	1x	mtext(paste0("Degrees: ", degrees, ", Padding: ", pad), 3)
122	1x	axis(1)
123	1x	axis(2, c(.70, .30), c("Original", "Derived"), lwd = 0)
124	1x	n <- length(ori$x)
125	1x	points(
126	1x	ori$x,
127	1x	rep(.70, n),
128	1x	pch = "\|",
129	1x	cex = 7,
130	1x	col = do.call(rgb, as.data.frame(t(ori$cols) / 256))
131		)
132	1x	points(
133	1x	ori$x,
134	1x	rep(.30, n),
135	1x	pch = "\|",
136	1x	cex = 7,
137	1x	col = do.call(
138	1x	rgb,
139	1x	lapply(1:3, function(ch) {
140	3x	cv <- (mm %*% coefs[, ch]) / 256
141	3x	cv[cv < 0] <- 0
142	3x	cv[cv > 1] <- 1
143	3x	cv
144		})
145		)
146		)
147		}
148	1x	list(
149	1x	name = name,
150	1x	type = paste0("continuous", "-polynomial"),
151	1x	colors = coefs
152		)
153		} else {
154	3x	if (length(colors) < 3) {
155	1x	if (length(colors) == 1) cols <- cbind(c(0, 0, 0), cols)
156	2x	cols <- cbind(cols[, 1], rowMeans(cols), cols[, 2])
157		} else {
158	1x	if (ncol(cols) != 3)
159	1x	cols <- cbind(cols[, 1], rowMeans(cols[, 2:3]), cols[, 4])
160		}
161	3x	cols <- t(cols)
162	3x	list(
163	3x	name = name,
164	3x	type = paste0("continuous", if (divergent) "-divergent"),
165	3x	colors = list(
166	3x	rbind(cols[3, ], cols[2, ] - cols[3, ]),
167	3x	cols[2, ],
168	3x	rbind(cols[1, ], cols[2, ] - cols[1, ])
169		)
170		)
171		}
172		} else {
173	3x	list(
174	3x	name = name,
175	3x	type = "discrete",
176	3x	colors = unlist(
177	3x	lapply(
178	3x	as.data.frame(cols / 255),
179	3x	function(col) do.call(rgb, as.list(col))
180		),
181	3x	use.names = FALSE
182		)
183		)
184		}
185	2x	if (print) cat(jsonlite::toJSON(palette, auto_unbox = TRUE, pretty = TRUE))
186	7x	invisible(palette)
187		}

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(
30		...,
31		title = "",
32		logo = "",
33		breakpoint = "md",
34		logo.height = "24px",
35		logo.width = "24px"
36		) {
37	10x	caller <- parent.frame()
38	10x	building <- !is.null(attr(caller, "name")) &&
39	10x	attr(caller, "name") == "community_site_parts"
40	10x	parts <- new.env()
41	10x	attr(parts, "name") <- "community_site_parts"
42	10x	submenus <- substitute(...())
43	10x	n <- length(submenus)
44	10x	parts$uid <- caller$uid
45	10x	r <- c(
46	10x	paste0('<nav class="navbar navbar-dark navbar-expand-', breakpoint, '">'),
47	10x	'<div class="container-fluid">',
48	10x	if (!missing(logo)) {
49	3x	paste0(
50	3x	'<span class="navbar-brand"><img alt="site logo" height=',
51	3x	logo.height,
52	3x	" width=",
53	3x	logo.width,
54	3x	' src="',
55	3x	logo,
56		'">'
57		)
58		},
59	10x	if (!missing(title)) paste0("<span>", title, "</span>"),
60	10x	if (!missing(logo)) "</span>"
61		)
62	10x	menus <- NULL
63	10x	if (n) {
64	9x	r <- c(
65	9x	r,
66	9x	paste(
67	9x	'<button type="button" class="navbar-toggler" data-bs-toggle="collapse"',
68	9x	'data-bs-target="#navbar_menu"',
69	9x	'aria-controls="narbar_menu" aria-expanded="false" aria-label="toggle navbar menu">'
70		),
71	9x	'<span class="navbar-toggler-icon"></span>',
72	9x	"</button>",
73	9x	'<div class="collapse navbar-collapse" id="navbar_menu">',
74	9x	'<ul class="navbar-nav">'
75		)
76	9x	for (i in seq_len(n)) {
77	21x	if (submenus[[i]][[1]] == "list") {
78	2x	if (is.null(names(submenus[[i]])))
79	!	submenus[[i]] <- list(items = submenus[[i]])
80	2x	id <- if (is.null(submenus[[i]]$id))
81	2x	paste0("submenu", parts$uid, i) else submenus[[i]]$id
82	2x	if (is.null(submenus[[i]]$name))
83	!	submenus[[i]]$name <- if (!is.null(names(submenus)))
84	!	names(submenus)[i] else "Menu"
85	2x	r <- c(
86	2x	r,
87	2x	paste0(
88	2x	'<li class="nav-item">',
89	2x	'<button class="btn btn-link" type="button" data-bs-toggle="offcanvas" data-bs-target="#',
90	2x	id,
91	2x	'" aria-controls="',
92	2x	id,
93		'">',
94	2x	submenus[[i]]$name,
95	2x	"</button>",
96	2x	"</li>"
97		)
98		)
99	2x	has_foot <- !is.null(submenus[[i]]$foot)
100	2x	menus <- c(
101	2x	menus,
102	2x	paste(
103	2x	c(
104	2x	'<div tabindex="-1" id="',
105	2x	id,
106	2x	'" aria-labelledby="',
107	2x	id,
108	2x	'_label" class="offcanvas offcanvas-',
109	2x	if (is.null(submenus[[i]]$placement)) "end" else
110	2x	submenus[[i]]$placement,
111	2x	if (!is.null(submenus[[i]]$class)) paste("", submenus[[i]]$class),
112	2x	if (!is.null(submenus[[i]]$backdrop))
113	2x	c('" data-bs-backdrop="', submenus[[i]]$backdrop),
114		'">'
115		),
116	2x	collapse = ""
117		),
118	2x	'<div class="offcanvas-header">',
119	2x	paste0(
120	2x	'<h5 class="offcanvas-title" id="',
121	2x	id,
122	2x	'_label">',
123	2x	submenus[[i]][
124	2x	if (is.null(submenus[[i]]$title)) "name" else "title"
125		],
126	2x	"</h5>"
127		),
128	2x	'<button class="btn-close text-reset" type="button" data-bs-dismiss="offcanvas" title="Close"></button>',
129	2x	"</div>",
130	2x	paste0(
131	2x	'<div class="offcanvas-body"',
132	2x	if (has_foot) ' style="bottom: 46px"',
133		">"
134		),
135	2x	unlist(
136	2x	lapply(submenus[[i]]$items[-1], eval, parts),
137	2x	use.names = FALSE
138		),
139	2x	"</div>",
140	2x	if (has_foot) {
141	!	c(
142	!	'<div class="offcanvas-footer">',
143	!	unlist(
144	!	lapply(submenus[[i]]$foot[-1], eval, parts),
145	!	use.names = FALSE
146		),
147	!	"</div>"
148		)
149		},
150	2x	"</div>"
151		)
152		} else {
153	19x	r <- c(
154	19x	r,
155	19x	paste0(
156	19x	'<li class="nav-item">',
157	19x	paste(eval(submenus[[i]]), collapse = ""),
158	19x	"</li>"
159		)
160		)
161		}
162		}
163		}
164	10x	r <- c(r, "</ul></div></div></nav>", menus)
165	10x	if (building) {
166	2x	caller$header <- r
167	2x	for (n in names(parts))
168	3x	if (n != "content" && n != "uid")
169	!	caller[[n]] <- c(caller[[n]], parts[[n]])
170	2x	caller$uid <- parts$uid + 1
171		}
172	10x	r
173		}

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(
31		...,
32		type = "row",
33		wraps = NA,
34		sizes = NA,
35		breakpoints = NA,
36		conditions = "",
37		id = NULL
38		) {
39	4x	caller <- parent.frame()
40	4x	building <- !is.null(attr(caller, "name")) &&
41	4x	attr(caller, "name") == "community_site_parts"
42	4x	parts <- new.env()
43	4x	attr(parts, "name") <- "community_site_parts"
44	4x	parts$uid <- caller$uid
45	4x	elements <- substitute(...())
46	4x	n <- length(elements)
47	4x	wraps <- rep_len(wraps, n)
48	4x	sizes <- rep_len(sizes, n)
49	4x	breakpoints <- rep_len(breakpoints, n)
50	4x	conditions <- rep_len(conditions, n)
51	4x	ids <- paste0("sec", parts$uid, seq_len(n))
52	4x	r <- c(
53	4x	paste(
54	4x	c(
55	4x	"<div",
56	4x	if (!is.null(id)) c(' id="', id, '"'),
57	4x	if (!is.null(type)) c(' class="', type, '"'),
58		">"
59		),
60	4x	collapse = ""
61		),
62	4x	unlist(
63	4x	lapply(seq_len(n), function(i) {
64	5x	wrap <- !is.na(wraps[i]) \|\| conditions[i] != ""
65	5x	c(
66	5x	if (wrap) {
67	2x	paste(
68	2x	c(
69	2x	'<div class="',
70	2x	if (is.na(wraps[i])) "" else wraps[i],
71	2x	if (!is.na(breakpoints[i])) c("-", breakpoints[i]),
72	2x	if (!is.na(sizes[i])) c("-", sizes[i]),
73		'"',
74	2x	if (conditions[i] != "") paste0(' id="', ids[i], '"'),
75		">"
76		),
77	2x	collapse = ""
78		)
79		},
80	5x	eval(elements[[i]], parts, caller),
81	5x	if (wrap) "</div>"
82		)
83		}),
84	4x	use.names = FALSE
85		),
86	4x	"</div>"
87		)
88	4x	if (building) {
89	2x	caller$content <- c(caller$content, r)
90	2x	for (n in names(parts))
91	8x	if (n != "content" && n != "uid")
92	4x	caller[[n]] <- c(caller[[n]], parts[[n]])
93	2x	process_conditions(conditions, ids, caller)
94	2x	caller$uid <- parts$uid + 1
95		}
96	4x	r
97		}

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(
56		label,
57		options,
58		default = -1,
59		display = options,
60		id = label,
61		...,
62		strict = TRUE,
63		numeric = FALSE,
64		search = TRUE,
65		multi = FALSE,
66		accordion = FALSE,
67		clearable = FALSE,
68		note = NULL,
69		group_feature = NULL,
70		variable = NULL,
71		dataset = NULL,
72		depends = NULL,
73		dataview = NULL,
74		subset = "filtered",
75		selection_subset = "full_filter",
76		filters = NULL,
77		reset_button = FALSE,
78		button_class = NULL,
79		as.row = FALSE,
80		floating_label = TRUE
81		) {
82	4x	id <- gsub("\\s", "", id)
83	4x	a <- list(...)
84	!	if (as.row) floating_label <- FALSE
85	4x	r <- c(
86	4x	'<div class="wrapper combobox-wrapper">',
87	4x	if (!floating_label)
88	4x	paste0(
89	4x	'<label id="',
90	4x	id,
91	4x	'-label" for="',
92	4x	id,
93	4x	'-input">',
94	4x	label,
95	4x	"</label>"
96		),
97	4x	paste0(
98	4x	'<div class="',
99	4x	paste(
100	4x	c(
101	4x	if (reset_button) "input-group",
102	4x	if (floating_label) "form-floating"
103		),
104	4x	collapse = " "
105		),
106		'">'
107		),
108	4x	paste0(
109	4x	'<div class="auto-input form-select combobox combobox-component" data-autoType="combobox"',
110	4x	' id="',
111	4x	id,
112		'" ',
113	4x	if (is.character(options) && length(options) == 1)
114	4x	paste0('data-optionSource="', options, '"'),
115	4x	if (!is.null(default)) paste0(' data-default="', default, '"'),
116	4x	if (!is.null(note)) paste0(' aria-description="', note, '"'),
117	4x	if (!is.null(dataview)) paste0(' data-view="', dataview, '"'),
118	4x	if (!is.null(subset)) paste0(' data-subset="', subset, '"'),
119	4x	if (!is.null(selection_subset))
120	4x	paste0(' data-selectionsubset="', selection_subset, '"'),
121	4x	if (!is.null(depends)) paste0(' data-depends="', depends, '"'),
122	4x	if (!is.null(dataset)) paste0(' data-dataset="', dataset, '"'),
123	4x	if (!is.null(variable)) paste0(' data-variable="', variable, '"'),
124	4x	if (length(a))
125	4x	unlist(lapply(
126	4x	seq_along(a),
127	4x	function(i) paste0(" ", names(a)[i], '="', a[[i]], '"')
128		)),
129	4x	'><div class="combobox-selection combobox-component">',
130	4x	'<span aria-live="assertive" aria-atomic="true" role="log" class="combobox-component"></span>',
131	4x	'<input class="combobox-input combobox-component" role="combobox" type="text" ',
132	4x	'aria-expanded="false" aria-autocomplete="list" aria-controls="',
133	4x	id,
134	4x	'-listbox" aria-controls="',
135	4x	id,
136	4x	'-listbox" id="',
137	4x	id,
138	4x	'-input" autocomplete="off"></div>',
139	4x	if (clearable)
140	4x	'<button type="button" class="btn-close" title="clear selection"></button>',
141	4x	"</div>"
142		),
143	4x	paste0(
144	4x	'<div class="combobox-options combobox-component',
145	4x	if (multi) " multi",
146	4x	'" role="listbox"',
147	4x	' id="',
148	4x	id,
149	4x	'-listbox" aria-labelledby="',
150	4x	id,
151	4x	'-label">'
152		),
153	4x	if (is.list(options)) {
154	1x	i <- 0
155	!	if (is.null(names(options))) names(options) <- seq_along(options)
156	1x	if (missing(accordion)) accordion <- TRUE
157	1x	unlist(
158	1x	lapply(names(options), function(g) {
159	2x	group <- paste0(
160	2x	'<div class="combobox-group combobox-component',
161	2x	if (accordion) " accordion-item",
162	2x	'" data-group="',
163	2x	g,
164		'">'
165		)
166	2x	if (accordion) {
167	2x	gid <- paste0(id, "_", gsub("[\\s,/._-]+", "", g))
168	2x	group <- c(
169	2x	group,
170	2x	paste0(
171	2x	'<div id="',
172	2x	gid,
173	2x	'-label" class="accordion-header combobox-component">'
174		),
175	2x	paste0(
176	2x	'<button role="button" ',
177	2x	'data-bs-toggle="collapse" data-bs-target="#',
178	2x	gid,
179	2x	'" aria-expanded=false aria-controls="',
180	2x	gid,
181	2x	'" class="accordion-button combobox-component collapsed">',
182	2x	g,
183	2x	"</button></div>"
184		),
185	2x	paste0(
186	2x	'<div id="',
187	2x	gid,
188	2x	'" class="combobox-component accordion-collapse collapse" ',
189	2x	'data-group="',
190	2x	g,
191	2x	'" data-bs-parent="#',
192	2x	id,
193	2x	'-listbox"><div class="accordion-body combobox-component">'
194		)
195		)
196		}
197	2x	for (gi in seq_along(options[[g]])) {
198	4x	i <<- i + 1
199	4x	group <- c(
200	4x	group,
201	4x	paste0(
202	4x	'<div class="combobox-option combobox-component',
203	4x	if (i == default) " selected",
204	4x	'" role="option" tabindex="0"',
205	4x	' data-group="',
206	4x	g,
207	4x	'" id="',
208	4x	id,
209	4x	"-option",
210	4x	i,
211	4x	'" data-value="',
212	4x	options[[g]][[gi]],
213	4x	'" aria-selected="',
214	4x	if (i == default) "true" else "false",
215		'">',
216	4x	display[[g]][[gi]],
217	4x	"</div>"
218		)
219		)
220		}
221	2x	c(group, "</div>", if (accordion) "</div></div>")
222		}),
223	1x	use.names = FALSE
224		)
225	4x	} else if (
226	4x	length(options) > 1 \|\|
227	4x	!options %in% c("datasets", "variables", "ids", "palettes")
228		) {
229	3x	unlist(
230	3x	lapply(seq_along(options), function(i) {
231	9x	paste0(
232	9x	'<div class="combobox-component',
233	9x	if (i == default) " selected",
234	9x	'" role="option" tabindex="0"',
235	9x	' id="',
236	9x	id,
237	9x	"-option",
238	9x	i,
239	9x	'" data-value="',
240	9x	options[i],
241	9x	'" aria-selected="',
242	9x	if (i == default) "true" else "false",
243		'">',
244	9x	display[i],
245	9x	"</div>"
246		)
247		}),
248	3x	use.names = FALSE
249		)
250		},
251	4x	"</div>",
252	4x	if (floating_label)
253	4x	paste0(
254	4x	'<label id="',
255	4x	id,
256	4x	'-label" for="',
257	4x	id,
258	4x	'-input">',
259	4x	label,
260	4x	"</label>"
261		),
262	4x	if (!missing(reset_button)) {
263	!	paste(
264	!	c(
265	!	'<button type="button" class="btn btn-link',
266	!	if (!is.null(button_class)) paste("", button_class),
267	!	' select-reset">',
268	!	if (is.character(reset_button)) reset_button else "Reset",
269	!	"</button>"
270		),
271	!	collapse = ""
272		)
273		},
274	4x	"</div>",
275	4x	"</div>"
276		)
277	!	if (missing(accordion) && !is.null(group_feature)) accordion <- TRUE
278	!	if (as.row) r <- to_input_row(r)
279	4x	caller <- parent.frame()
280		if (
281	4x	!is.null(attr(caller, "name")) &&
282	4x	attr(caller, "name") == "community_site_parts"
283		) {
284	1x	if (strict) caller$combobox[[id]]$strict <- strict
285	!	if (numeric) caller$combobox[[id]]$numeric <- numeric
286	1x	if (search) caller$combobox[[id]]$search <- search
287	!	if (multi) caller$combobox[[id]]$multi <- multi
288	1x	if (accordion)
289	!	caller$combobox[[id]]$accordion <- accordion &&
290	!	(is.list(options) \|\| !is.null(group_feature))
291	!	if (!is.null(group_feature)) caller$combobox[[id]]$group <- group_feature
292	!	if (!is.null(filters)) caller$combobox[[id]]$filters <- as.list(filters)
293	1x	caller$content <- c(caller$content, r)
294		}
295	4x	r
296		}

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(
43		shapes = NULL,
44		overlays = NULL,
45		color = NULL,
46		color_time = NULL,
47		dataview = NULL,
48		id = NULL,
49		click = NULL,
50		subto = NULL,
51		background_shapes = NULL,
52		options = list(),
53		overlays_from_measures = TRUE,
54		tiles = list(
55		url = "https://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png",
56		options = list(maxZoom = 19)
57		),
58		attribution = list(
59		name = "OpenStreetMap",
60		url = "https://www.openstreetmap.org/copyright"
61		)
62		) {
63	3x	caller <- parent.frame()
64	3x	building <- !is.null(attr(caller, "name")) &&
65	3x	attr(caller, "name") == "community_site_parts"
66	2x	if (is.null(id)) id <- paste0("map", caller$uid)
67	3x	if (building) {
68	1x	caller$dependencies$leaflet_style <- list(
69	1x	type = "stylesheet",
70	1x	src = "https://cdn.jsdelivr.net/npm/leaflet@1.9.4/dist/leaflet.min.css",
71	1x	hash = "sha384-b8ANgTJvdlAnWM5YGMpKn7Kodm+1k7NYNG9zdjTCcZcKatzYHwZ0RLdWarbJJVzU"
72		)
73	1x	caller$dependencies$leaflet <- list(
74	1x	type = "script",
75	1x	src = "https://cdn.jsdelivr.net/npm/leaflet@1.9.4/dist/leaflet.min.js",
76	1x	hash = "sha384-u5N8qJeJOO2iqNjIKTdl6KeKsEikMAmCUBPc6sC6uGpgL34aPJ4VgNhuhumedpEk"
77		)
78	1x	options$overlays_from_measures <- overlays_from_measures
79	1x	options$subto <- if (!is.null(subto) && length(subto) == 1) list(subto) else
80	1x	subto
81	1x	if (is.null(options[["center"]])) options$center <- c(40, -95)
82	1x	if (is.null(options[["zoom"]])) options$zoom <- 4
83		if (
84	1x	!is.null(background_shapes) && is.null(options[["background_shapes"]])
85		) {
86	!	options$background_shapes <- background_shapes
87		}
88	1x	if (is.character(shapes))
89	!	shapes <- lapply(shapes, function(s) list(url = s))
90	!	if (is.list(shapes) && !is.list(shapes[[1]])) shapes <- list(shapes)
91	1x	snames <- names(shapes)
92	1x	for (i in seq_along(shapes)) {
93	!	if (!is.null(snames[i])) shapes[[i]]$name <- snames[i]
94	!	if (is.null(shapes[[i]]$id_property)) shapes[[i]]$id_property <- "geoid"
95		}
96	1x	if (!is.null(overlays)) {
97	!	if (is.character(overlays))
98	!	overlays <- lapply(overlays, function(s) list(url = s))
99	!	if (is.list(overlays) && !is.list(overlays[[1]]))
100	!	overlays <- list(overlays)
101	!	snames <- names(overlays)
102	!	for (i in seq_along(overlays)) {
103	!	if (!is.null(snames[i])) overlays[[i]]$name <- snames[i]
104		}
105		}
106	1x	caller$map[[id]] <- Filter(
107	1x	length,
108	1x	list(
109	1x	shapes = unname(shapes),
110	1x	overlays = unname(overlays),
111	1x	options = options,
112	1x	tiles = tiles
113		)
114		)
115		}
116	3x	r <- paste(
117	3x	c(
118	3x	'<div class="auto-output leaflet"',
119	3x	if (!is.null(dataview)) paste0('data-view="', dataview, '"'),
120	3x	if (!is.null(click)) paste0('data-click="', click, '"'),
121	3x	if (!is.null(color)) paste0('data-color="', color, '"'),
122	3x	if (!is.null(color_time)) paste0('data-colorTime="', color_time, '"'),
123	3x	paste0('id="', id, '"'),
124	3x	'data-autoType="map"></div>'
125		),
126	3x	collapse = " "
127		)
128	3x	if (building) {
129	1x	caller$content <- c(caller$content, r)
130	1x	caller$credits$leaflet <- list(
131	1x	name = "Leaflet",
132	1x	url = "https://leafletjs.com",
133	1x	version = "1.9.4",
134	1x	description = "A JS library for interactive maps"
135		)
136	1x	if (!missing(attribution) \|\| missing(tiles)) {
137	1x	if (!is.null(attribution$name)) {
138	1x	caller$credits[[attribution$name]] <- attribution
139	!	} else if (!is.null(attribution[[1]]$name)) {
140	!	for (a in attribution) caller$credits[[a$name]] <- a
141		}
142		}
143	1x	caller$uid <- caller$uid + 1
144		}
145	3x	r
146		}

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(
46		commons,
47		name,
48		output = NULL,
49		...,
50		variables = NULL,
51		ids = NULL,
52		files = NULL,
53		run_after = NULL,
54		run_before = NULL,
55		measure_info = list(),
56		remote = NULL,
57		url = NULL,
58		children = list(),
59		execute = TRUE,
60		prefer_repo = TRUE,
61		preselect_files = FALSE,
62		refresh_map = FALSE,
63		overwrite = FALSE,
64		verbose = TRUE
65		) {
66	3x	if (missing(commons))
67	!	cli_abort('{.arg commons} must be speficied (e.g., commons = ".")')
68	3x	if (missing(name)) {
69	!	name <- list.files(paste0(commons, "/views"))[1]
70	!	if (is.na(name))
71	!	cli_abort(
72	!	"{.arg name} must be specified since no views are present in {commons}"
73		)
74		}
75	3x	check <- check_template("datacommons", dir = commons)
76	3x	view_dir <- normalizePath(paste0(commons, "/views/", name), "/", FALSE)
77	3x	dir.create(view_dir, FALSE, TRUE)
78	3x	paths <- paste0(
79	3x	view_dir,
80		"/",
81	3x	c("view.json", "manifest.json", "run_after.R", "run_before.R")
82		)
83	3x	base_run_after <- run_after
84	3x	if (!is.null(run_after)) {
85	!	if (length(run_after) > 1 \|\| !grepl("\\w\\.\\w+$", run_after)) {
86	!	if (verbose) cli_alert_info("writting {.file run_after.R}")
87	!	writeLines(run_after, paths[3])
88	!	base_run_after <- run_after <- paths[3]
89	!	} else if (!file.exists(run_after)) {
90	!	base_run_after <- paste0(commons, "/", run_after)
91		}
92		}
93		if (
94	3x	!is.null(run_before) && (length(run_before) > 1 \|\| !file.exists(run_before))
95		) {
96	!	if (verbose) cli_alert_info("writting {.file run_before.R}")
97	!	writeLines(run_before, paths[4])
98	!	run_before <- paths[4]
99		}
100	3x	write_view <- FALSE
101	3x	if (!is.null(variables)) variables <- variables[!grepl("^_", variables)]
102	3x	if (!file.exists(paths[1])) {
103	!	if (verbose) cli_alert_info("writting new {.file view.json}")
104	2x	view <- list(
105	2x	name = name,
106	2x	remote = remote,
107	2x	url = url,
108	2x	output = output,
109	2x	run_after = run_after,
110	2x	run_before = run_before,
111	2x	variables = variables,
112	2x	ids = ids,
113	2x	files = files,
114	2x	children = children
115		)
116	2x	write_view <- TRUE
117		} else {
118	1x	view <- jsonlite::read_json(paths[1])
119	1x	if (!is.null(remote) && !identical(view$remote, remote)) {
120	!	view$remote <- remote
121	!	write_view <- TRUE
122		}
123	1x	if (!is.null(url) && !identical(view$url, url)) {
124	!	view$url <- url
125	!	write_view <- TRUE
126		}
127	1x	if (!is.null(output) && !identical(view$output, output)) {
128	!	view$output <- output
129	!	write_view <- TRUE
130		}
131	1x	if (!is.null(run_after) && !identical(view$run_after, run_after)) {
132	!	view$run_after <- run_after
133	!	write_view <- TRUE
134	1x	} else if (length(view$run_after)) {
135	!	base_run_after <- view$run_after
136	!	if (!file.exists(base_run_after))
137	!	base_run_after <- paste0(commons, "/", base_run_after)
138		}
139	1x	if (!is.null(run_before) && !identical(view$run_before, run_before)) {
140	!	view$run_before <- run_before
141	!	write_view <- TRUE
142		}
143	1x	if (!is.null(variables) && !identical(view$variables, variables)) {
144	1x	view$variables <- variables
145	1x	write_view <- TRUE
146		}
147	1x	if (!is.null(ids) && !identical(view$ids, ids)) {
148	1x	view$ids <- ids
149	1x	write_view <- TRUE
150		}
151	1x	if (!is.null(ids) && !identical(view$files, files)) {
152	1x	view$files <- files
153	1x	write_view <- TRUE
154		}
155	1x	if (!is.null(children) && !identical(view$children, children)) {
156	!	view$children <- children
157	!	write_view <- TRUE
158		}
159	1x	if (verbose && write_view)
160	!	cli_alert_info("updating existing {.file view.json}")
161		}
162	3x	outbase <- outdir <- view$output
163	3x	if (!is.null(outdir)) {
164	3x	if (!dir.exists(outdir)) {
165	1x	if (dir.exists(paste0(commons, "/", outdir))) {
166	!	outdir <- paste0(commons, "/", outdir)
167		} else {
168	1x	dir.create(outdir, FALSE, TRUE)
169		}
170		}
171	3x	outbase <- sub("/docs(?:/data)?$", "", outdir)
172		}
173	3x	if (length(view$remote)) {
174	!	remote_parts <- strsplit(
175	!	sub("^(?:https?://)?(?:www\\.)?github\\.com/", "", view$remote),
176		"/"
177	!	)[[1]]
178	!	if (is.null(view$url))
179	!	view$url <- paste0(
180	!	"https://",
181	!	remote_parts[1],
182	!	".github.io/",
183	!	remote_parts[2]
184		)
185	!	if (!is.null(outdir)) {
186	!	if (!dir.exists(outbase)) {
187	!	outbase <- dirname(outbase)
188	!	dir.create(outbase, FALSE, TRUE)
189	!	wdir <- getwd()
190	!	setwd(outbase)
191	!	if (verbose)
192	!	cli_alert_info(paste0(
193	!	"cloning remote view: {.url https://github.com/",
194	!	view$remote,
195		"}"
196		))
197	!	overwrite <- TRUE
198	!	tryCatch(
199	!	system2(
200	!	"git",
201	!	c("clone", paste0("https://github.com/", view$remote, ".git")),
202	!	stdout = TRUE
203		),
204	!	error = function(e) warning("remote clone failed: ", e$message)
205		)
206	!	setwd(wdir)
207		}
208		}
209		}
210	3x	if (length(view$children)) {
211	!	if (!is.null(names(view$children))) view$children <- list(view$children)
212	!	view$children <- lapply(view$children, function(ch) {
213	!	if (is.null(ch$name)) {
214	!	ch$name <- sub("^.*/", "", ch$remote)
215		}
216	!	if (is.null(ch$url)) {
217	!	remote_parts <- strsplit(
218	!	sub("^(?:https?://)?(?:www\\.)?github\\.com/", "", ch$remote),
219		"/"
220	!	)[[1]]
221	!	ch$url <- paste0(
222	!	"https://",
223	!	remote_parts[1],
224	!	".github.io/",
225	!	remote_parts[2]
226		)
227		}
228	!	ch
229		})
230		}
231	3x	if (length(view$variables)) view$variables <- as.character(view$variables)
232	3x	if (length(view$ids)) view$ids <- as.character(view$ids)
233	3x	if (!is.null(outbase) && !dir.exists(outbase))
234	!	init_site(outbase, view$name, quiet = TRUE)
235	!	if (is.null(view$output)) outdir <- view_dir
236	3x	if (write_view) jsonlite::write_json(view, paths[1], auto_unbox = TRUE)
237	3x	if (execute) {
238	3x	source_env <- new.env()
239	3x	source_env$datacommons_view <- function(...) {
240		}
241	3x	if (length(view$run_before) && file.exists(view$run_before)) {
242	!	if (verbose)
243	!	cli_alert_info("running pre-view script ({.file {view$run_before}})")
244	!	src <- parse(
245	!	text = gsub(
246	!	"community::datacommons_view",
247	!	"datacommons_view",
248	!	readLines(view$run_before, warn = FALSE),
249	!	fixed = TRUE
250		)
251		)
252	!	source(local = source_env, exprs = src)
253		}
254	!	if (verbose) cli_alert_info("checking for file maps")
255	3x	map <- datacommons_map_files(
256	3x	commons,
257	3x	overwrite = refresh_map,
258	3x	verbose = verbose
259		)
260	3x	files <- map$variables[
261	3x	(if (length(view$files)) grepl(view$files, map$variables$file) else
262	3x	TRUE) &
263	3x	(if (length(view$variables)) {
264	3x	map$variables$full_name %in%
265	3x	view$variables \|
266	3x	map$variables$dir_name %in% view$variables \|
267	3x	map$variables$variable %in% view$variables
268		} else {
269	!	TRUE
270		}) &
271	3x	(if (length(view$ids)) {
272	3x	sub("^[^/]+/[^/]+/", "", map$variables$file) %in%
273	3x	unique(unlist(
274	3x	lapply(map$ids[view$ids %in% names(map$ids)], "[[", "files"),
275	3x	use.names = FALSE
276		))
277		} else {
278	!	TRUE
279		}),
280		,
281	3x	drop = FALSE
282		]
283	3x	manifest <- NULL
284	3x	if (nrow(files)) {
285	3x	cfs <- paste0("/", files$file)
286	3x	files <- files[
287	3x	order(
288	3x	grepl(if (prefer_repo) "cache/" else "repos/", files$file) -
289	3x	Reduce(
290		"+",
291	3x	lapply(view$ids, function(id) cfs %in% map$ids[[id]]$file)
292		)
293		),
294		]
295	3x	files <- files[
296	3x	!duplicated(paste(files$dir_name, basename(files$file))),
297		,
298	3x	drop = FALSE
299		]
300	3x	if (preselect_files) {
301	!	sel_files <- unique(unlist(
302	!	lapply(split(files, files$dir_name), function(fs) {
303	!	if (nrow(fs) == 1) {
304	!	fs$file
305		} else {
306	!	ccfs <- sub("^/", "", fs$file)
307	!	ifm <- vapply(
308	!	map$ids[view$ids],
309	!	function(im) ccfs %in% sub("^/", "", im$files),
310	!	logical(length(ccfs))
311		)
312	!	is <- colSums(ifm) != 0
313	!	sel <- NULL
314	!	for (i in seq_along(ccfs)) {
315	!	if (any(is[ifm[i, ]])) {
316	!	sel <- c(sel, fs$file[i])
317	!	is[ifm[i, ]] <- FALSE
318		}
319		}
320	!	sel
321		}
322		}),
323	!	use.names = FALSE
324		))
325	!	files <- files[files$file %in% sel_files, ]
326		}
327	3x	files <- files[
328	3x	order(file.mtime(paste0(commons, "/", files$file)), decreasing = TRUE),
329		]
330	!	if (verbose) cli_alert_info("updating manifest: {.file {paths[2]}}")
331	3x	repo_manifest <- jsonlite::read_json(paste0(
332	3x	commons,
333	3x	"/manifest/repos.json"
334		))
335	3x	manifest <- lapply(split(files, files$repo), function(r) {
336	3x	hr <- repo_manifest[[r$repo[[1]]]]
337	3x	files <- paste0(commons, "/", unique(r$file))
338	3x	names(files) <- sub("^[^/]+/[^/]+/", "", unique(r$file))
339	3x	list(
340	3x	files = lapply(files, function(f) {
341	13x	name <- sub("^/[^/]+/[^/]+/", "", sub(commons, "", f, fixed = TRUE))
342	13x	if (grepl("repos/", f, fixed = TRUE)) {
343	13x	m <- hr$files[[name]]
344	13x	m$baseurl <- hr$url
345		} else {
346	!	m <- hr$distributions$dataverse$files[[name]]
347	!	m$baseurl <- hr$distributions$dataverse$server
348		}
349	13x	m
350		})
351		)
352		})
353	3x	if (is.character(measure_info)) {
354	!	measure_info <- if (
355	!	length(measure_info) == 1 && file.exists(measure_info)
356		) {
357	!	jsonlite::read_json(measure_info)
358		} else {
359	!	as.list(measure_info)
360		}
361		}
362	3x	base_vars <- sub("^[^:/]+[:/]", "", view$variables)
363	3x	for (r in unique(files$repo)) {
364	3x	measure_info_files <- sort(list.files(
365	3x	paste0(commons, "/repos/", sub("^.+/", "", r)),
366	3x	"^measure_info[^.]*\\.json$",
367	3x	full.names = TRUE,
368	3x	recursive = TRUE
369		))
370	3x	measure_info_files <- measure_info_files[
371	3x	!grepl("/docs/data/", measure_info_files, fixed = TRUE) &
372	3x	!duplicated(gsub("_rendered\|/code/\|/data/", "", measure_info_files))
373		]
374	3x	ri <- lapply(measure_info_files, function(f) {
375	15x	m <- tryCatch(jsonlite::read_json(f), error = function(e) {
376	!	cli_alert_warning("failed to read measure info: {.file {f}}")
377	!	NULL
378		})
379	15x	if (all(c("measure", "type", "short_description") %in% names(m))) {
380	!	m <- list(m)
381	!	names(m) <- m[[1]]$measure
382		}
383	15x	remote <- paste0(
384	15x	get_git_remote(sub("(^.+repos/[^/]+/).*$", "\\1.git/config", f)),
385		"/"
386		)
387	15x	source_file <- sub(
388		"^/[^/]+/[^/]+/",
389	15x	remote,
390	15x	sub(commons, "", f, fixed = TRUE)
391		)
392	15x	for (mn in names(m)) {
393	39x	if (substring(mn, 1, 1) != "_") {
394	33x	m[[mn]]$source_file <- source_file
395		}
396		}
397	15x	m
398		})
399	3x	if (length(ri)) {
400	3x	ri <- unlist(ri, recursive = FALSE)
401	3x	nri <- names(ri)
402	3x	if (any(nri == ""))
403	!	for (mname in which(nri == ""))
404	!	names(ri)[mname] <- ri[[mname]]$measure
405	3x	es <- nri[substring(nri, 1, 1) == "_" & !nri %in% view$variables]
406	3x	if (length(es)) {
407	3x	for (e in es) {
408	6x	if (!is.null(names(ri[[e]]))) {
409	3x	if (is.null(measure_info[[e]])) measure_info[[e]] <- list()
410	6x	su <- !names(ri[[e]]) %in% names(measure_info[[e]])
411	6x	if (any(su))
412	3x	measure_info[[e]] <- c(measure_info[[e]], ri[[e]][su])
413		}
414		}
415		}
416	3x	if (length(view$variables) && any(!nri %in% view$variables)) {
417	3x	for (i in seq_along(nri)) {
418	39x	n <- nri[i]
419	39x	if (n %in% base_vars) {
420	12x	names(ri)[i] <- view$variables[which(base_vars == n)[1]]
421		} else {
422	27x	n <- sub("^[^:]*:", "", nri[i])
423	27x	if (n %in% view$variables) {
424	!	names(ri)[i] <- n
425		}
426		}
427		}
428	3x	nri <- names(ri)
429		}
430	3x	rendered_names <- render_info_names(ri)
431	3x	ri <- ri[
432	3x	(if (length(view$variables)) {
433	3x	nri %in% rendered_names[names(rendered_names) %in% view$variables]
434		} else {
435	!	TRUE
436		}) &
437	3x	!nri %in% names(measure_info)
438		]
439	3x	if (length(ri)) {
440	3x	measure_info[names(ri)] <- lapply(
441	3x	ri,
442	3x	function(e)
443	3x	if (is.null(names(e)) && !is.null(names(e[[1]]))) e[[1]] else e
444		)
445		}
446		}
447		}
448	3x	args <- list(...)
449	3x	if (length(measure_info)) args$measure_info <- measure_info
450	3x	args$files <- paste0(commons, "/", unique(files$file))
451	3x	args$out <- outdir
452	3x	args$variables <- view$variables
453	3x	args$ids <- view$ids
454	3x	args$overwrite <- overwrite
455	3x	args$verbose <- verbose
456	3x	do.call(data_reformat_sdad, args)
457		} else {
458	!	cli_warn("no files were found")
459		}
460	3x	if (length(base_run_after) && file.exists(base_run_after)) {
461	!	if (verbose)
462	!	cli_alert_info("running post-view script ({.file {base_run_after}})")
463	!	src <- parse(
464	!	text = gsub(
465	!	"community::datacommons_view",
466	!	"datacommons_view",
467	!	readLines(base_run_after, warn = FALSE),
468	!	fixed = TRUE
469		)
470		)
471	!	source(local = source_env, exprs = src)
472		}
473	3x	jsonlite::write_json(
474	3x	manifest,
475	3x	paste0(outdir, "/manifest.json"),
476	3x	auto_unbox = TRUE,
477	3x	pretty = TRUE
478		)
479		}
480	3x	init_datacommons(commons, refresh_after = FALSE, verbose = FALSE)
481	3x	invisible(view)
482		}

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(
27		missed,
28		map = ".",
29		sep = "[_:]",
30		top = 3,
31		metric = "cosine"
32		) {
33	!	if (missing(missed)) cli_abort("{.arg missed} must be provided")
34	1x	nm <- length(missed)
35	1x	variable_map <- NULL
36	1x	if (is.character(map)) {
37	1x	if (file.exists(map)) {
38	1x	variable_map <- if (dir.exists(map)) {
39	1x	if (nm == 1 && file.exists(paste0(map, "/views/", missed))) {
40	!	missed <- paste0(map, "/views/", missed)
41		}
42	1x	datacommons_map_files(map, verbose = FALSE)$variables
43		} else {
44	!	read.csv(map)
45		}
46		} else {
47	!	cli_abort("{.arg map} appears to be a path, but it does not exist")
48		}
49		} else {
50	!	variable_map <- map
51		}
52	1x	if (is.null(variable_map$full_name)) {
53	!	cli_abort(
54	!	"{.arg map} does not appear to be or point to a valid variable map"
55		)
56		}
57	1x	full_names <- unique(variable_map$full_name)
58	1x	if (nm == 1 && file.exists(missed)) {
59	!	missed <- jsonlite::read_json(
60	!	if (dir.exists(missed)) paste0(missed, "/view.json") else missed
61		)
62	!	missed <- as.character(missed$variables)
63	!	if (!length(missed))
64	!	cli_abort(
65	!	"did not find any variables in the {.arg missed} view definition"
66		)
67	!	missed <- missed[!missed %in% full_names]
68	!	if (!length(missed))
69	!	cli_abort("all variables in the {.arg missed} view definition were found")
70	!	nm <- length(missed)
71		}
72	1x	mi <- seq_len(nm)
73	1x	snames <- gsub(sep, " ", c(missed, full_names))
74	1x	dtm <- lma_dtm(snames, numbers = TRUE, punct = TRUE, to.lower = FALSE)
75	1x	sim <- lma_simets(dtm[mi, ], dtm[-mi, ], metric, pairwise = FALSE)
76	1x	if (is.null(dim(sim))) sim <- matrix(sim, nm)
77	1x	top <- seq_len(min(top, length(full_names)))
78	1x	res <- lapply(mi, function(i) {
79	1x	v <- missed[[i]]
80	1x	if (v %in% full_names) {
81	!	cbind(variable_map[variable_map$full_name == v, ], similarity = 1)
82		} else {
83	1x	do.call(
84	1x	rbind,
85	1x	lapply(order(sim[i, ], decreasing = TRUE)[top], function(o) {
86	3x	vr <- variable_map[
87	3x	variable_map$full_name == full_names[[o]],
88		,
89	3x	drop = FALSE
90		]
91	3x	vr$similarity <- sim[i, o]
92	3x	vr
93		})
94		)
95		}
96		})
97	1x	names(res) <- missed
98	1x	res
99		}

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(
72		files,
73		out = NULL,
74		variables = NULL,
75		ids = NULL,
76		value = "value",
77		value_name = "measure",
78		id = "geoid",
79		time = "year",
80		dataset = "region_type",
81		entity_info = c(type = "region_type", name = "region_name"),
82		measure_info = list(),
83		metadata = NULL,
84		formatters = NULL,
85		compression = "xz",
86		read_existing = TRUE,
87		overwrite = FALSE,
88		get_coverage = TRUE,
89		verbose = TRUE
90		) {
91	4x	base_dir <- "./"
92	4x	if (length(files) == 1 && dir.exists(files)) {
93	!	base_dir <- files
94	!	files <- list.files(files, full.names = TRUE)
95		}
96	4x	if (any(!file.exists(files))) {
97	!	files <- files[!file.exists(files)]
98	!	cli_abort("file{? does/s do} not exist: {files}")
99		}
100	4x	if (!is.null(metadata) && !id %in% colnames(metadata))
101	!	cli_abort("{.arg metadata} does not have an id ({id}) column")
102	4x	vars <- c(value, value_name, id, time, dataset)
103	4x	spec <- c(
104	4x	missing(value),
105	4x	missing(value_name),
106	4x	missing(id),
107	4x	missing(time),
108	4x	missing(dataset),
109	4x	rep(missing(entity_info), length(entity_info))
110		)
111	4x	data <- list()
112	4x	names <- list()
113	4x	i <- 0
114	4x	if (verbose)
115	1x	cli_progress_step(
116	1x	"reading in {i}/{length(files)} original file{?s}",
117	1x	spinner = TRUE
118		)
119	4x	max_age <- max(file.mtime(files))
120	4x	check_variables <- check_ids <- FALSE
121	4x	if (length(ids)) {
122	3x	check_ids <- TRUE
123	3x	ids <- unique(as.character(ids))
124		}
125	4x	for (f in files) {
126	15x	if (verbose) {
127	2x	i <- i + 1
128	2x	cli_progress_update()
129		}
130	15x	d <- attempt_read(f, id)
131	15x	if (is.null(d)) {
132	!	if (verbose) cli_warn("failed to read in file: {f}")
133	!	next
134		}
135	15x	if (!id %in% colnames(d)) {
136	!	if (verbose) cli_warn("file has no ID column: {f}")
137	!	next
138		}
139	!	if (anyNA(d[[id]])) d <- d[!is.na(d[[id]]), ]
140	15x	if (!nrow(d)) {
141	!	if (verbose) cli_warn("file has no observations: {f}")
142	!	next
143		}
144	15x	lcols <- tolower(colnames(d))
145	15x	if (any(!vars %in% colnames(d))) {
146	4x	l <- !colnames(d) %in% vars & lcols %in% vars
147	4x	colnames(d)[l] <- lcols[l]
148		}
149	15x	d[[id]] <- gsub("^\\s+\|\\s+$", "", d[[id]])
150	15x	if (check_ids) {
151	13x	su <- grepl("\\de[+-]\\d", d[[id]], perl = TRUE)
152	13x	if (any(su)) {
153	!	d[[id]][su] <- gsub(
154	!	"^\\s+\|\\s+$",
155		"",
156	!	format(as.numeric(d[[id]][su]), scientific = FALSE)
157		)
158		}
159	13x	su <- d[[id]] %in% ids
160	13x	if (!all(su)) d <- d[su, ]
161	13x	if (!nrow(d)) {
162	!	if (verbose) cli_warn("file has none of the requested IDs: {f}")
163	2x	next
164		}
165		}
166	13x	if (any(su <- !vars %in% colnames(d))) {
167	4x	if (all(su)) {
168	!	cli_warn("no variables found in file {f}")
169	!	next
170		}
171	4x	if (any(!spec[su])) {
172	!	cli_warn(
173	!	"table from {f} does not have {?a column name/column names} {.var {vars[su][!spec[su]]}}"
174		)
175	!	next
176		}
177	4x	vars <- vars[!su]
178	4x	spec <- spec[!su]
179		}
180	13x	names <- c(names, list(colnames(d)))
181	13x	if (grepl("repos/", f, fixed = TRUE)) {
182	11x	remote <- get_git_remote(sub("(^.+repos/[^/]+/).*$", "\\1.git/config", f))
183	11x	if (length(remote)) d$file <- paste0(remote, sub("^.+repos/[^/]+", "", f))
184	!	if (!"file" %in% colnames(d)) d$file <- sub("^.+repos/", "", f)
185		} else {
186	!	if (!grepl("/$", base_dir)) base_dir <- paste0(base_dir, "/")
187	2x	remote <- get_git_remote(paste0(base_dir, ".git/config"))
188	2x	d$file <- gsub(
189		"//+",
190		"/",
191	2x	if (length(remote)) {
192	!	paste0(remote, "/", sub(base_dir, "", f, fixed = TRUE))
193		} else {
194	2x	sub(base_dir, "", f, fixed = TRUE)
195		}
196		)
197		}
198	13x	data <- c(data, list(d))
199		}
200	1x	if (verbose) cli_progress_done()
201	4x	common <- Reduce(intersect, names)
202	4x	if (!value %in% vars) {
203	1x	a <- common[!common %in% vars]
204	1x	if (!length(a))
205	!	cli_abort("could not figure out which column might contain values")
206	1x	if (length(a) > 1)
207	!	a <- a[which(vapply(a, function(col) is.numeric(d[[col]]), TRUE))]
208	1x	if (!length(a)) {
209	!	cli_abort(c(
210	!	"no potential value columns were numeric",
211	!	i = "check variable classes, or specify {.arg value}"
212		))
213		}
214	1x	value <- a[1]
215	1x	vars <- c(value, vars)
216		}
217	4x	all <- unique(unlist(names))
218	4x	all <- all[all %in% vars & (all == id \| !all %in% colnames(metadata))]
219	4x	vars <- c(all, "file")
220	4x	if (length(variables)) {
221	3x	check_variables <- TRUE
222	3x	variables <- unique(as.character(variables))
223		}
224	4x	data <- do.call(
225	4x	rbind,
226	4x	lapply(seq_along(data), function(i) {
227	13x	d <- data[[i]]
228	13x	mv <- vars[!vars %in% colnames(d)]
229	!	if (length(mv)) d[, vars[!vars %in% colnames(d)]] <- ""
230	13x	d <- d[, vars]
231	!	if (anyNA(d)) d <- d[rowSums(is.na(d)) == 0, ]
232	13x	if (check_variables) {
233	11x	ovars <- unique(d[[value_name]])
234	11x	su <- !ovars %in% variables
235	11x	if (any(su)) {
236	11x	names(ovars) <- ovars
237	11x	ovars[] <- make_full_name(d$file[[1]], ovars)
238	11x	su <- su & ovars %in% variables
239	11x	for (i in which(su))
240	41x	d[[value_name]][d[[value_name]] == names(ovars)[i]] <- ovars[i]
241		}
242	11x	d <- d[d[[value_name]] %in% variables, ]
243		}
244	13x	d
245		})
246		)
247	4x	if (is.null(data) \|\| !nrow(data))
248	!	cli_abort("no datasets contained selected variables and/or IDs")
249	4x	cn <- colnames(data)
250	4x	if (!id %in% vars) {
251	!	id <- "id"
252	!	vars <- c(id, vars)
253	!	data <- cbind(
254	!	id = unlist(lapply(table(data$file), seq_len), use.names = FALSE),
255	!	data
256		)
257		}
258	4x	data[[id]] <- as.character(data[[id]])
259	4x	if (!is.null(metadata)) {
260	!	su <- colnames(data) != id & colnames(data) %in% colnames(metadata)
261	!	if (any(su)) data <- data[, colnames(data) == id \| !su, drop = FALSE]
262	!	if (verbose)
263	!	cli_progress_step("merging in metadata", msg_done = "merged in metadata")
264	!	metadata <- as.data.frame(metadata[
265	!	!duplicated(metadata[[id]]) & metadata[[id]] %in% data[[id]],
266		])
267	!	if (!nrow(metadata))
268	!	cli_abort("{.arg metadata} had no ids in common with data")
269	!	rownames(metadata) <- metadata[[id]]
270	!	metadata[[id]] <- NULL
271	!	su <- data[[id]] %in% rownames(metadata)
272	!	if (!all(su)) {
273	!	if (verbose)
274	!	cli_warn(
275	!	"{sum(!su)} rows contain IDs not in {.arg metadata} IDs, and will be dropped"
276		)
277	!	data <- data[su, ]
278		}
279	!	data <- cbind(data, metadata[data[[id]], , drop = FALSE])
280	!	cn <- colnames(data)
281	!	vars <- c(vars, colnames(metadata))
282	!	if (verbose) cli_progress_done()
283		}
284	4x	if (!is.null(formatters)) {
285	!	for (n in names(formatters)) {
286	!	if (n %in% cn) {
287	!	data[[n]] <- formatters[[n]](data[[n]])
288		}
289		}
290		}
291	4x	if (!dataset %in% vars) {
292	3x	dataset <- "dataset"
293	3x	vars <- c(vars, dataset)
294	3x	data$dataset <- dataset
295		}
296	4x	if (!time %in% vars) {
297	!	time <- "time"
298	!	vars <- c(vars, time)
299	!	data$time <- 1
300		}
301	4x	if (!any(value_name %in% vars)) {
302	!	vars <- c(vars, value_name)
303	!	data[[value_name]] <- sub("\\.[^.]+$", "", basename(data$file))
304		}
305	4x	data[[dataset]] <- gsub("\\s+", "_", data[[dataset]])
306	4x	datasets <- sort(unique(data[[dataset]]))
307	4x	present_vars <- unique(data[[value_name]])
308	4x	if (check_variables) {
309	3x	present_vars <- variables[variables %in% present_vars]
310	3x	if (verbose) {
311	!	absent_variables <- variables[!variables %in% present_vars]
312	!	if (length(absent_variables))
313	!	cli_warn(
314	!	"requested variable{?s} not found in datasets: {.val {absent_variables}}"
315		)
316		}
317		}
318	4x	times <- sort(unique(data[[time]]))
319	3x	if (all(nchar(times) == 4)) times <- seq(min(times), max(times))
320	4x	n <- length(times)
321	4x	files <- paste0(out, "/", gsub("\\s+", "_", tolower(datasets)), ".csv")
322	4x	if (is.character(compression) && grepl("^[gbx]", compression, FALSE)) {
323	4x	compression <- tolower(substr(compression, 1, 1))
324	4x	files <- paste0(files, ".", c(g = "gz", b = "bz2", x = "xz")[[compression]])
325		} else {
326	!	compression <- FALSE
327		}
328	4x	names(files) <- datasets
329	4x	write <- vapply(
330	4x	files,
331	4x	function(f)
332	4x	is.null(out) \|\| overwrite \|\| !file.exists(f) \|\| max_age > file.mtime(f),
333	4x	TRUE
334		)
335	4x	if (!is.null(out) && (is.list(entity_info) \|\| is.character(entity_info))) {
336	4x	entity_info_file <- paste0(out, "/entity_info.json")
337	4x	if (overwrite \|\| !file.exists(entity_info_file) \|\| any(write)) {
338	4x	entity_info <- as.list(entity_info)
339	4x	entity_info <- entity_info[unlist(entity_info) %in% colnames(data)]
340	4x	if (length(entity_info)) {
341	1x	if (verbose) {
342	1x	cli_progress_step(
343	1x	"writing entity file",
344	1x	msg_done = paste0(
345	1x	"wrote entity metadata file: {.file ",
346	1x	entity_info_file,
347		"}"
348		)
349		)
350		}
351	1x	e <- data[, unique(c(id, dataset, unlist(entity_info))), drop = FALSE]
352	1x	if (!is.null(names(entity_info))) {
353	1x	for (en in names(entity_info)) {
354	1x	if (en != "" && entity_info[[en]] %in% colnames(e))
355	1x	colnames(e)[colnames(e) == entity_info[[en]]] <- en
356		}
357		}
358	1x	jsonlite::write_json(
359	1x	lapply(split(e, e[, 2]), function(g) {
360	2x	lapply(
361	2x	split(g[, -(1:2), drop = FALSE], g[, 1]),
362	2x	function(l) lapply(l, function(r) r[which(r != "")[1]])
363		)
364		}),
365	1x	entity_info_file,
366	1x	auto_unbox = TRUE,
367	1x	digits = 6
368		)
369	1x	if (verbose) cli_progress_done()
370		}
371		}
372		}
373	4x	svars <- c(id, value, value_name, time, "file", dataset)
374	4x	data <- unique(data[, svars[svars %in% vars]])
375	4x	if (length(measure_info)) {
376	3x	dynamic_names <- render_info_names(measure_info)
377		}
378	4x	sets <- lapply(datasets, function(dn) {
379	4x	if (
380	5x	read_existing && !is.null(out) && file.exists(files[[dn]]) && !write[[dn]]
381		) {
382	2x	if (verbose)
383	!	cli_progress_step(
384	!	"reading in existing {dn} dataset",
385	!	msg_done = "read existing {dn} dataset"
386		)
387	2x	read.csv(gzfile(files[[dn]]), check.names = FALSE)
388		} else {
389	3x	d <- if (dataset %in% vars) data[data[[dataset]] == dn, ] else data
390	3x	dc <- list()
391	3x	ids <- unique(d[[id]])
392	3x	i <- 0
393	3x	if (verbose) {
394	2x	cli_progress_step(
395	2x	"creating {dn} dataset (ID {i}/{length(ids)})",
396	2x	msg_done = "created {dn} dataset ({length(ids)} IDs)",
397	2x	spinner = TRUE
398		)
399		}
400	3x	d <- d[!duplicated(paste(d[[id]], d[[value_name]], d[[time]])), ]
401	3x	if (length(measure_info)) {
402	1x	source <- unique(d[, c(value_name, "file")])
403	1x	source <- structure(source[[2]], names = source[[1]])
404	1x	for (measure in names(source)) {
405	18x	iname <- if (length(measure_info[[dynamic_names[measure]]]))
406	18x	dynamic_names[measure] else measure
407	18x	if (length(measure_info[[iname]])) {
408	4x	measure_info[[iname]]$origin <<- unique(c(
409	4x	measure_info[[iname]]$origin,
410	4x	source[[measure]]
411		))
412		}
413		}
414		}
415	3x	sd <- split(d, d[[id]])
416	3x	ssel <- c(time, value)
417	3x	for (i in seq_along(ids)) {
418	5x	if (verbose) cli_progress_update()
419	9x	e <- ids[[i]]
420	9x	ed <- sd[[e]]
421	9x	r <- data.frame(
422	9x	ID = rep(as.character(e), n),
423	9x	time = times,
424	9x	check.names = FALSE,
425	9x	matrix(
426	9x	NA,
427	9x	n,
428	9x	length(present_vars),
429	9x	dimnames = list(times, present_vars)
430		)
431		)
432	9x	if (all(c(value_name, value) %in% names(ed))) {
433	9x	ed <- ed[!is.na(ed[[value]]), ]
434	9x	ed <- split(ed[, ssel], ed[[value_name]])
435	9x	for (v in names(ed)) {
436	79x	vals <- ed[[v]]
437	79x	if (nrow(vals)) r[as.character(vals[[time]]), v] <- vals[[value]]
438		}
439		}
440	9x	rownames(r) <- NULL
441	9x	dc[[i]] <- r
442		}
443	3x	do.call(rbind, dc)
444		}
445		})
446	4x	names(sets) <- datasets
447	4x	if (length(measure_info)) {
448	3x	measure_info_file <- paste0(out, "/measure_info.json")
449	3x	if (verbose)
450	!	cli_alert_info("updating measure info: {.file {measure_info_file}}")
451	3x	jsonlite::write_json(
452	3x	measure_info[sort(names(measure_info))],
453	3x	measure_info_file,
454	3x	auto_unbox = TRUE,
455	3x	pretty = TRUE
456		)
457		}
458	4x	if (!is.null(out)) {
459	4x	if (get_coverage && read_existing) {
460	4x	if (verbose)
461	1x	cli_progress_step(
462	1x	"updating coverage report",
463	1x	msg_done = "updated coverage report"
464		)
465	4x	variables <- sort(
466	4x	if (length(variables)) variables else
467	4x	unique(unlist(lapply(sets, colnames), use.names = FALSE))
468		)
469	4x	allcounts <- structure(numeric(length(variables)), names = variables)
470	4x	write.csv(
471	4x	vapply(
472	4x	sets,
473	4x	function(d) {
474	5x	counts <- colSums(!is.na(d))
475	5x	counts <- counts[names(counts) %in% variables]
476	5x	allcounts[names(counts)] <- counts
477	5x	allcounts
478		},
479	4x	numeric(length(variables))
480		),
481	4x	paste0(out, "/coverage.csv")
482		)
483	1x	if (verbose) cli_progress_done()
484		}
485	4x	if (any(write)) {
486	2x	if (verbose)
487	1x	cli_progress_step(
488	1x	"writing data files",
489	1x	msg_done = "wrote reformatted datasets:"
490		)
491	2x	for (i in seq_along(sets)) {
492	3x	if (write[[i]]) {
493	3x	if (is.character(compression))
494	3x	o <- do.call(paste0(compression, "zfile"), list(files[[i]]))
495	3x	write_csv_arrow(sets[[i]], o)
496		}
497		}
498	2x	if (verbose) {
499	1x	cli_progress_done()
500	1x	cli_bullets(structure(
501	1x	paste0("{.file ", files[write], "}"),
502	1x	names = rep("*", sum(write))
503		))
504		}
505	2x	} else if (verbose) {
506	!	cli_bullets(c(
507	!	v = "all files are already up to date:",
508	!	structure(
509	!	paste0("{.file ", files, "}"),
510	!	names = rep("*", length(files))
511		)
512		))
513		}
514		}
515	4x	invisible(sets)
516		}

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(
27		title = NULL,
28		body = NULL,
29		row_style = "table",
30		default = NULL,
31		dataview = NULL,
32		variable = NULL,
33		subto = NULL,
34		id = NULL,
35		variable_info = TRUE,
36		floating = FALSE
37		) {
38	4x	caller <- parent.frame()
39	4x	building <- !is.null(attr(caller, "name")) &&
40	4x	attr(caller, "name") == "community_site_parts"
41	4x	if (is.null(id)) id <- paste0("info", caller$uid)
42	4x	r <- paste0(
43	4x	'<div class="auto-output text-display',
44	4x	if (floating) ' floating"' else '"',
45	4x	if (!is.null(dataview)) paste0(' data-view="', dataview, '"'),
46	4x	' data-autoType="info" id="',
47	4x	id,
48	4x	'"></div>'
49		)
50	4x	row_style <- rep_len(row_style, length(body))
51	4x	if (building) {
52	2x	caller$content <- c(caller$content, r)
53	2x	caller$info[[id]] <- Filter(
54	2x	function(e) length(e) > 1 \|\| (length(e) && e != "" && !isFALSE(e)),
55	2x	list(
56	2x	title = if (is.null(title)) "" else title,
57	2x	body = lapply(seq_along(body), function(i) {
58	1x	list(
59	1x	name = if (is.null(names(body))) "" else names(body)[i],
60	1x	value = body[[i]],
61	1x	style = row_style[[i]]
62		)
63		}),
64	2x	default = as.list(default),
65	2x	floating = floating
66		)
67		)
68	!	if (!is.null(dataview)) caller$info[[id]]$dataview <- dataview
69	!	if (!is.null(variable)) caller$info[[id]]$variable <- variable
70	1x	if (!is.null(subto)) caller$info[[id]]$subto <- subto
71	2x	if (variable_info) caller$info[[id]]$variable_info <- variable_info
72	2x	caller$uid <- caller$uid + 1
73		}
74	4x	r
75		}

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

1		#' Add a guided tour to a website
2		#'
3		#' Adds a set of instructions that will guide a user through a process.
4		#'
5		#' Tutorials take over control of the interface to walk the user through some process.
6		#'
7		#' @param ... Lists specifying each tutorial, or a single list of such lists:
8		#' \itemize{
9		#' \item \strong{\code{name}}: Short name used for reference (as in links). Taken from
10		#' the name of entries if omitted.
11		#' \item \strong{\code{title}}: Display title of the tutorial.
12		#' \item \strong{\code{description}}: A description of what the tutorial will do.
13		#' \item \strong{\code{steps}} (required): A list containing step specifications:
14		#' \itemize{
15		#' \item \strong{\code{description}}: Text description to accompany the step.
16		#' \item \strong{\code{focus}}: Query selector for the element to focus on (e.g., \code{"#input_a"}).
17		#' \item \strong{\code{option}}: Name (value) of an option in a dropdown menu to highlight.
18		#' \item \strong{\code{before}}: A vector of actions to perform before showing the step, where
19		#' names are of input elements, and values are either \code{"click"} to click on the element
20		#' (mainly for elements with toggleable menus -- elements that do not accept a value will always
21		#' be clicked), \code{"reset"} to reset the input, or a value to set the input to
22		#' (e.g., \code{c("input_a" = "a"}). An unnamed actions or values will apply to the \code{focus} element.
23		#' If \code{focus} or the named element has options and \code{option} is included, \code{"set"},
24		#' will set those options. If a dialogue-like element is open, \code{"close"} will close it.
25		#' \item \strong{\code{after}}: A vector of actions to perform after the step has advanced,
26		#' before the next step starts (if any).
27		#' \item \strong{\code{wait}}: Number of milliseconds to wait before starting the step. Useful
28		#' to add time to allow loads or animations to finish; defaults to \code{400}.
29		#' \item \strong{\code{time}}: Number of seconds to wait before auto-advancing. If omitted,
30		#' will not auto-advance.
31		#' \item \strong{\code{disable_continue}}: Logical; if \code{TRUE}, will disable the continue button.
32		#' }
33		#' \item \strong{\code{reset}}: Logical; if \code{TRUE}, will reset the interface
34		#' before starting the tutorial.
35		#' }
36		#' @param button Text to show a button to show the tutorials listing menu, or \code{FALSE}
37		#' to not create a button.
38		#' @param id Unique ID of the button element to be created.
39		#' @param class Additional class names to add to the button element.
40		#' @param note Text to display as a tooltip for the button.
41		#' @examples
42		#' page_tutorials(
43		#' use_menu = list(
44		#' title = "Use Settings Menu",
45		#' steps = list(
46		#' list(
47		#' description = "Click on the settings button.",
48		#' focus = "#navbar_menu .nav-item:nth-child(3)",
49		#' after = "click"
50		#' ),
51		#' list(
52		#' description = "Locate setting A.",
53		#' focus = "setting.a"
54		#' )
55		#' )
56		#' )
57		#' )
58		#' @return A character vector of the content to be added.
59		#' @export
60
61		page_tutorials <- function(
62		...,
63		button = "Tutorials",
64		id = NULL,
65		class = NULL,
66		note = NULL
67		) {
68	3x	caller <- parent.frame()
69	3x	building <- !is.null(attr(caller, "name")) &&
70	3x	attr(caller, "name") == "community_site_parts"
71	3x	parts <- new.env()
72	3x	attr(parts, "name") <- "community_site_parts"
73	3x	tutorials <- list(...)
74	3x	if (length(tutorials) == 1) {
75	2x	if ("name" %in% names(tutorials)) {
76	!	tutorials <- list(tutorials)
77	2x	} else if (is.null(names(tutorials))) {
78	!	tutorials <- unlist(tutorials, recursive = FALSE)
79		}
80		}
81	3x	for (i in seq_along(tutorials)) {
82	2x	if (is.null(tutorials[[i]]$name)) {
83	2x	tutorials[[i]]$name <- if (is.null(names(tutorials)[i]))
84	2x	paste("tutorial", i) else names(tutorials)[i]
85		}
86	2x	tutorials[[i]]$steps <- lapply(tutorials[[i]]$steps, function(s) {
87	!	if (!is.null(s$before)) s$before <- as.list(s$before)
88	!	if (!is.null(s$after)) s$after <- as.list(s$after)
89	4x	s
90		})
91		}
92	3x	names(tutorials) <- vapply(tutorials, "[[", "", "name")
93	3x	r <- c(
94	3x	'<div class="wrapper button-wrapper">',
95	3x	paste0(
96	3x	'<button type="button" data-bs-toggle="modal" data-bs-target="#community_tutorials_menu" class="btn',
97	3x	if (!is.null(class)) paste("", class),
98		'"',
99	3x	if (!is.null(id)) paste0(' id="', id, '"'),
100	3x	if (!is.null(note)) paste0(' aria-description="', note, '"'),
101		">",
102	3x	button,
103	3x	"</button>"
104		),
105	3x	"</div>"
106		)
107	3x	if (building) {
108	1x	if (is.character(button)) caller$content <- c(caller$content, r)
109	1x	caller$tutorials <- c(caller$tutorials, tutorials)
110		}
111	3x	r
112		}

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(
31		label,
32		options,
33		default = "all",
34		display = options,
35		id = label,
36		...,
37		note = NULL,
38		variable = NULL,
39		dataset = NULL,
40		depends = NULL,
41		multi = TRUE,
42		as.switch = FALSE
43		) {
44	3x	if (multi && length(default) == 1) {
45	3x	if ((is.logical(default) && default) \|\| default == "all") {
46	3x	default <- options
47	!	} else if ((is.logical(default) && !default) \|\| default == "none") {
48	!	default <- NULL
49		}
50	!	} else if (!multi && is.character(default)) {
51	!	default <- which(
52	!	(if (default %in% display) display else options) == default
53		)
54	!	if (!length(default)) default <- 1
55		}
56	3x	id <- gsub("\\s", "", id)
57	3x	a <- list(...)
58	3x	type <- if (multi) "checkbox" else "radio"
59	3x	r <- c(
60	3x	'<div class="wrapper checkbox-wrapper">',
61	3x	paste0(
62	3x	"<fieldset",
63	3x	if (length(a))
64	3x	paste("", paste(names(a), paste0('"', unlist(a), '"'), sep = "=")),
65		">"
66		),
67	3x	paste0("<legend>", label, "</legend>"),
68	3x	paste0(
69	3x	'<div class="auto-input" role="group" data-autoType="',
70	3x	type,
71	3x	'" id="',
72	3x	id,
73		'" ',
74	3x	if (is.character(options) && length(options) == 1)
75	3x	paste0('data-optionSource="', options, '"'),
76	3x	if (!is.null(default))
77	3x	paste0(' data-default="', paste(default, collapse = ","), '"'),
78	3x	if (!is.null(depends)) paste0(' data-depends="', depends, '"'),
79	3x	if (!is.null(note)) paste0(' aria-description="', note, '"'),
80	3x	if (!is.null(dataset)) paste0(' data-dataset="', dataset, '"'),
81	3x	if (!is.null(variable)) paste0(' data-variable="', variable, '"'),
82	3x	if (as.switch) paste0(' data-switch="', as.switch, '"'),
83	3x	if (length(a))
84	3x	unlist(lapply(
85	3x	seq_along(a),
86	3x	function(i) paste0(" ", names(a)[i], '="', a[[i]], '"')
87		)),
88		">"
89		),
90	3x	if (length(options) > 1) {
91	3x	unlist(
92	3x	lapply(seq_along(options), function(i) {
93	9x	c(
94	9x	paste0(
95	9x	'<div class="form-check',
96	9x	if (as.switch) " form-switch",
97		'">'
98		),
99	9x	paste0(
100	9x	'<input type="',
101	9x	type,
102	9x	'" autocomplete="off" class="form-check-input" name="',
103	9x	id,
104	9x	'_options" id="',
105	9x	id,
106	9x	"_option",
107	9x	i,
108	9x	if (as.switch) '" role="switch',
109	9x	'" value="',
110	9x	options[i],
111		'"',
112	9x	if ((multi && options[i] %in% default) \|\| i == default)
113	9x	" checked",
114		">"
115		),
116	9x	paste0(
117	9x	'<label class="form-check-label" for="',
118	9x	id,
119	9x	"_option",
120	9x	i,
121		'">',
122	9x	display[i],
123	9x	"</label>"
124		),
125	9x	"</div>"
126		)
127		}),
128	3x	use.names = FALSE
129		)
130		},
131	3x	"</div>",
132	3x	"</fieldset>",
133	3x	"</div>"
134		)
135	3x	caller <- parent.frame()
136		if (
137	3x	!is.null(attr(caller, "name")) &&
138	3x	attr(caller, "name") == "community_site_parts"
139		) {
140	1x	caller$content <- c(caller$content, r)
141		}
142	3x	r
143		}

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

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 pretty Logical; if \code{TRUE}, will pretty-print the datapackage.
18		#' @param summarize_ids: Logical; if \code{TRUE}, will include ID columns in schema field summaries.
19		#' @param open_after Logical; if \code{TRUE}, opens the written datapackage after saving.
20		#' @param verbose Logical; if \code{FALSE}, will not show status messages.
21		#' @details
22		#' \code{meta} should be a list with unnamed entries for entry in \code{filename},
23		#' and each entry can include a named entry for any of these:
24		#' \describe{
25		#' \item{source}{
26		#' A list or list of lists with entries for at least \code{name}, and ideally for \code{url}.
27		#' }
28		#' \item{ids}{
29		#' A list or list of lists with entries for at least \code{variable} (the name of a variable in the dataset).
30		#' Might also include \code{map} with a list or path to a JSON file resulting in a list with an
31		#' entry for each ID, and additional information about that entity, to be read in a its features.
32		#' All files will be loaded to help with aggregation, but local files will be included in the datapackage,
33		#' whereas hosted files will be loaded client-side.
34		#' }
35		#' \item{time}{
36		#' A string giving the name of a variable in the dataset representing a repeated observation of the same entity.
37		#' }
38		#' \item{variables}{
39		#' A list with named entries providing more information about the variables in the dataset.
40		#' See \code{\link{data_measure_info}}.
41		#' }
42		#' }
43		#' @examples
44		#' \dontrun{
45		#' # write example data
46		#' write.csv(mtcars, "mtcars.csv")
47		#'
48		#' # add it to an existing datapackage.json file in the current working directory
49		#' data_add("mtcars.csv")
50		#' }
51		#' @return An invisible version of the updated datapackage, which is also written to
52		#' \code{datapackage.json} if \code{write = TRUE}.
53		#' @seealso Initialize the \code{datapackage.json} file with \code{\link{init_data}}.
54		#' @export
55
56		data_add <- function(
57		filename,
58		meta = list(),
59		packagename = "datapackage.json",
60		dir = ".",
61		write = TRUE,
62		refresh = TRUE,
63		sha = "512",
64		clean = FALSE,
65		pretty = FALSE,
66		summarize_ids = FALSE,
67		open_after = FALSE,
68		verbose = interactive()
69		) {
70	!	if (missing(filename)) cli_abort("{.arg filename} must be specified")
71	5x	setnames <- names(filename)
72	5x	if (file.exists(filename[[1]])) {
73	2x	if (dir == ".") dir <- dirname(filename[[1]])
74	2x	filename <- basename(filename)
75		}
76		if (
77	5x	check_template("site", dir = dir)$status[["strict"]] &&
78	5x	all(file.exists(paste0(dir, "/docs/data/", filename)))
79		) {
80	!	dir <- paste0(dir, "/docs/data")
81		}
82	5x	if (any(!file.exists(paste0(dir, "/", filename)))) {
83	!	filename <- filename[!file.exists(filename)]
84	!	cli_abort("{?a file/files} did not exist: {filename}")
85		}
86	5x	package <- if (
87	5x	is.character(packagename) && file.exists(paste0(dir, "/", packagename))
88		) {
89	2x	paste0(dir, "/", packagename)
90		} else {
91	3x	packagename
92		}
93	5x	if (write) {
94	3x	if (is.character(package)) {
95	3x	package <- paste0(dir, "/", packagename)
96	3x	package <- if (file.exists(package)) {
97	2x	packagename <- package
98	2x	jsonlite::read_json(package)
99		} else {
100	1x	init_data(
101	1x	if (!is.null(setnames)) setnames[[1]] else filename[[1]],
102	1x	dir = dir
103		)
104		}
105		}
106	3x	if (!is.list(package)) {
107	!	cli_abort(c(
108	!	"{.arg package} does not appear to be in the right format",
109	!	i = "this should be (or be read in from JSON as) a list with a {.code resource} entry"
110		))
111		}
112		}
113	2x	if (!is.list(package)) package <- list()
114	5x	collect_metadata <- function(file) {
115	5x	f <- paste0(dir, "/", filename[[file]])
116	5x	m <- if (single_meta) meta else metas[[file]]
117	5x	format <- if (grepl(".parquet", f, fixed = TRUE)) {
118	!	"parquet"
119	5x	} else if (grepl(".csv", f, fixed = TRUE)) {
120	5x	"csv"
121	5x	} else if (grepl(".rds", f, fixed = TRUE)) {
122	!	"rds"
123		} else {
124	!	"tsv"
125		}
126	!	if (is.na(format)) format <- "rds"
127	5x	info <- file.info(f)
128	5x	metas <- list()
129	5x	unpack_meta <- function(n) {
130	18x	if (!length(m[[n]])) {
131	17x	list()
132	1x	} else if (is.list(m[[n]][[1]])) {
133	!	m[[n]]
134		} else {
135	1x	list(m[[n]])
136		}
137		}
138	5x	ids <- unpack_meta("ids")
139	5x	idvars <- NULL
140	5x	for (i in seq_along(ids)) {
141	1x	if (is.list(ids[[i]])) {
142	5x	if (
143	1x	length(ids[[i]]$map) == 1 &&
144	1x	is.character(ids[[i]]$map) &&
145	1x	file.exists(ids[[i]]$map)
146		) {
147	!	ids[[i]]$map_content <- paste(
148	!	readLines(ids[[i]]$map, warn = FALSE),
149	!	collapse = ""
150		)
151		}
152		} else {
153	!	ids[[i]] <- list(variable = ids[[i]])
154		}
155	1x	if (!ids[[i]]$variable %in% idvars) idvars <- c(idvars, ids[[i]]$variable)
156		}
157	5x	data <- if (format == "rds") {
158	!	tryCatch(readRDS(f), error = function(e) NULL)
159	5x	} else if (format == "parquet") {
160	!	tryCatch(read_parquet(f), error = function(e) NULL)
161		} else {
162	5x	attempt_read(f, c("geography", "time", idvars))
163		}
164	5x	if (is.null(data)) {
165	!	cli_abort(c(
166	!	paste0("failed to read in the data file ({.file {f}})"),
167	!	i = "check that it is in a compatible format"
168		))
169		}
170	5x	if (!all(rownames(data) == seq_len(nrow(data)))) {
171	!	data <- cbind(`_row` = rownames(data), data)
172		}
173	5x	timevar <- unlist(unpack_meta("time"))
174	5x	times <- if (is.null(timevar)) rep(1, nrow(data)) else data[[timevar]]
175	5x	times_unique <- unique(times)
176	5x	if (!single_meta) {
177	3x	varinf <- unpack_meta("variables")
178	3x	if (length(varinf) == 1 && is.character(varinf[[1]])) {
179	!	if (!file.exists(varinf[[1]])) {
180	!	varinf[[1]] <- paste0(dir, "/", varinf[[1]])
181		}
182	!	if (file.exists(varinf[[1]])) {
183	!	if (varinf[[1]] %in% names(metas)) {
184	!	varinf <- metas[[varinf[[1]]]]
185		} else {
186	!	varinf <- metas[[varinf[[1]]]] <- data_measure_info(
187	!	varinf[[1]],
188	!	write = FALSE,
189	!	render = TRUE
190		)
191		}
192	!	varinf <- varinf[varinf != ""]
193		}
194		}
195	3x	varinf_full <- names(varinf)
196	3x	varinf_suf <- sub("^[^:]+:", "", varinf_full)
197		}
198	5x	res <- list(
199	5x	bytes = as.integer(info$size),
200	5x	encoding = stri_enc_detect(f)[[1]][1, 1],
201	5x	md5 = md5sum(f)[[1]],
202	5x	format = format,
203	5x	name = if (!is.null(setnames)) {
204	1x	setnames[file]
205	5x	} else if (!is.null(m$name)) {
206	!	m$name
207		} else {
208	4x	sub("\\.[^.]*$", "", basename(filename[[file]]))
209		},
210	5x	filename = filename[[file]],
211	5x	source = unpack_meta("source"),
212	5x	ids = ids,
213	5x	id_length = if (length(idvars)) {
214	1x	id_lengths <- nchar(data[[idvars[1]]])
215	1x	id_lengths <- id_lengths[!is.na(id_lengths)]
216	1x	if (all(id_lengths == id_lengths[1])) id_lengths[1] else 0
217		} else {
218	4x	0
219		},
220	5x	time = timevar,
221	5x	profile = "data-resource",
222	5x	created = as.character(info$mtime),
223	5x	last_modified = as.character(info$ctime),
224	5x	row_count = nrow(data),
225	5x	entity_count = if (length(idvars)) {
226	1x	length(unique(data[[idvars[1]]]))
227		} else {
228	4x	nrow(data)
229		},
230	5x	schema = list(
231	5x	fields = lapply(
232	5x	if (summarize_ids) colnames(data) else
233	5x	colnames(data)[!colnames(data) %in% idvars],
234	5x	function(cn) {
235	59x	v <- data[[cn]]
236	59x	invalid <- !is.finite(v)
237	59x	r <- list(name = cn, duplicates = sum(duplicated(v)))
238	59x	if (!single_meta) {
239	36x	if (cn %in% varinf_full) {
240	!	r$info <- varinf[[cn]]
241	36x	} else if (cn %in% varinf_suf) {
242	!	r$info <- varinf[[which(varinf_suf == cn)]]
243		}
244	36x	r$info <- r$info[r$info != ""]
245		}
246	59x	su <- !is.na(v)
247	59x	if (any(su)) {
248	59x	r$time_range <- which(times_unique %in% range(times[su])) - 1
249	59x	r$time_range <- if (length(r$time_range)) {
250	59x	r$time_range[c(1, length(r$time_range))]
251		} else {
252	!	c(-1, -1)
253		}
254		} else {
255	!	r$time_range <- c(-1, -1)
256		}
257	59x	if (!is.character(v) && all(invalid)) {
258	!	r$type <- "unknown"
259	!	r$missing <- length(v)
260	59x	} else if (is.numeric(v)) {
261	55x	r$type <- if (all(invalid \| as.integer(v) == v)) {
262	30x	"integer"
263		} else {
264	25x	"float"
265		}
266	55x	r$missing <- sum(invalid)
267	55x	r$mean <- round(mean(v, na.rm = TRUE), 6)
268	55x	r$sd <- round(sd(v, na.rm = TRUE), 6)
269	55x	r$min <- round(min(v, na.rm = TRUE), 6)
270	55x	r$max <- round(max(v, na.rm = TRUE), 6)
271		} else {
272	4x	r$type <- "string"
273	4x	if (!is.factor(v)) v <- as.factor(as.character(v))
274	4x	r$missing <- sum(is.na(v) \| is.nan(v) \| grepl("^[\\s.-]$", v))
275	4x	r$table <- structure(as.list(tabulate(v)), names = levels(v))
276		}
277	59x	r
278		}
279		)
280		)
281		)
282	5x	if (!single_meta && "_references" %in% names(varinf)) {
283	!	res[["_references"]] <- varinf[["_references"]]
284		}
285	5x	if (Sys.which("openssl") != "") {
286	5x	res[[paste0("sha", sha)]] <- calculate_sha(f, sha)
287		}
288	5x	res
289		}
290	5x	single_meta <- FALSE
291	5x	metas <- if (!is.null(names(meta))) {
292	2x	if (!is.null(setnames) && all(setnames %in% names(meta))) {
293	!	meta[setnames]
294		} else {
295	2x	single_meta <- TRUE
296	2x	if (length(meta$variables) == 1 && is.character(meta$variables)) {
297	!	if (!file.exists(meta$variables)) {
298	!	meta$variables <- paste0(dir, "/", meta$variables)
299		}
300	!	if (file.exists(meta$variables)) {
301	!	meta$variables <- jsonlite::read_json(meta$variables)
302		}
303		}
304	2x	meta$variables <- replace_equations(meta$variables)
305	2x	meta
306		}
307		} else {
308	3x	meta[seq_along(filename)]
309		}
310	5x	if (!single_meta) {
311	3x	metas <- lapply(metas, function(m) {
312	3x	m$variables <- replace_equations(m$variables)
313	3x	m
314		})
315		}
316	5x	metadata <- lapply(seq_along(filename), collect_metadata)
317	5x	if (single_meta) {
318	2x	package$measure_info <- lapply(meta$variables, function(e) e[e != ""])
319		}
320	5x	package$resources <- c(metadata, if (!refresh) package$resources)
321	5x	names <- vapply(package$resources, "[[", "", "filename")
322	5x	if (anyDuplicated(names)) {
323	!	package$resources <- package$resources[!duplicated(names)]
324		}
325	5x	if (clean) {
326	!	cf <- lma_dict("special", perl = TRUE, as.function = gsub)
327	!	package <- jsonlite::fromJSON(cf(jsonlite::toJSON(
328	!	package,
329	!	auto_unbox = TRUE
330		)))
331		}
332	5x	if (write) {
333	3x	packagename <- if (is.character(packagename)) {
334	3x	packagename
335		} else {
336	!	"datapackage.json"
337		}
338	3x	jsonlite::write_json(
339	3x	package,
340	3x	if (file.exists(packagename)) {
341	2x	packagename
342		} else {
343	1x	paste0(dir, "/", packagename)
344		},
345	3x	auto_unbox = TRUE,
346	3x	digits = 6,
347	3x	pretty = pretty
348		)
349	3x	if (verbose) {
350	!	cli_bullets(c(
351	!	v = paste(
352	!	if (refresh) "updated resource in" else "added resource to",
353	!	"datapackage.json:"
354		),
355	!	"*" = paste0("{.path ", packagename, "}")
356		))
357	!	if (open_after) navigateToFile(packagename)
358		}
359		}
360	5x	invisible(package)
361		}

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

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(
27		dir,
28		search_pattern = "\\.csv(?:\\.[gbx]z2?)?$",
29		variable_location = "measure",
30		id_location = "geoid",
31		reader = read.csv,
32		overwrite = FALSE,
33		verbose = TRUE
34		) {
35	!	if (missing(dir)) cli_abort("{.arg dir} must be specified")
36	5x	dir <- paste0(normalizePath(dir, "/", FALSE), "/")
37	5x	check <- check_template("datacommons", dir = dir)
38	5x	if (!check$exists) {
39	!	cli_abort(c(
40	!	x = "{.arg dir} does not appear to point to a data commons project",
41	!	i = paste0('initialize it with {.code init_datacommons("', dir, '")}')
42		))
43		}
44	5x	if (!dir.exists(paste0(dir, "repos"))) {
45	!	cli_abort(c(
46	!	x = "no {.path repos} directory found in {.arg dir}",
47	!	i = paste0(
48	!	'use {.code datacommons_refresh("',
49	!	dir,
50	!	'")} to bring in remote data'
51		)
52		))
53		}
54	5x	commons <- jsonlite::read_json(paste0(dir, "commons.json"))
55	5x	all_files <- list.files(
56	5x	paste0(dir, c("cache", "repos")),
57	5x	search_pattern,
58	5x	full.names = TRUE,
59	5x	recursive = TRUE
60		)
61	5x	all_files <- sort(all_files[
62	5x	!grepl("[/\\](?:code\|docs\|working\|original)[/\\]\|variable_map", all_files)
63		])
64	!	if (!length(all_files)) cli_abort("no files were found")
65	5x	res <- paste0(dir, "cache/", c("variable_map.csv", "id_map.rds"))
66	1x	if (overwrite) unlink(res)
67		if (
68	5x	all(file.exists(res)) && all(file.mtime(res) > max(file.mtime(all_files)))
69		) {
70	!	if (verbose) cli_alert_success("the maps are up to date")
71	4x	return(invisible(list(variables = read.csv(res[1]), ids = readRDS(res[2]))))
72		}
73	1x	i <- 1
74	1x	map <- idmap <- list()
75	1x	noread <- novars <- noids <- empty <- NULL
76	1x	repos <- sort(unlist(commons$repositories))
77	1x	manifest <- measure_info <- list()
78	1x	if (verbose) {
79	1x	cli_progress_step(
80	1x	"scanning files in repos: {i}/{length(repos)}",
81	1x	msg_done = "created file maps: {.file {res}}",
82	1x	spinner = TRUE
83		)
84		}
85	1x	for (i in seq_along(repos)) {
86	1x	r <- repos[[i]]
87	1x	manifest[[r]] <- list()
88	1x	files <- sort(list.files(
89	1x	paste0(dir, c("repos", "cache"), "/", sub("^[^/]+/", "", r)),
90	1x	search_pattern,
91	1x	full.names = TRUE,
92	1x	recursive = TRUE,
93	1x	ignore.case = TRUE
94		))
95	1x	measure_info_files <- sort(list.files(
96	1x	paste0(dir, "repos/", sub("^.+/", "", r)),
97	1x	"^measure_info[^.]*\\.json$",
98	1x	full.names = TRUE,
99	1x	recursive = TRUE
100		))
101	1x	measure_info_files <- measure_info_files[
102	1x	!duplicated(gsub("_rendered\|/code/\|/data/", "", measure_info_files))
103		]
104	1x	if (length(measure_info_files)) {
105	1x	measure_info <- c(
106	1x	measure_info,
107	1x	lapply(
108	1x	structure(
109	1x	measure_info_files,
110	1x	names = sub(
111	1x	paste0(dir, "repos/"),
112	1x	paste0(sub("/.*$", "", r), "/"),
113	1x	measure_info_files,
114	1x	fixed = TRUE
115		)
116		),
117	1x	function(f) {
118	5x	tryCatch(
119	5x	data_measure_info(
120	5x	f,
121	5x	render = TRUE,
122	5x	write = FALSE,
123	5x	verbose = FALSE,
124	5x	open_after = FALSE,
125	5x	include_empty = FALSE
126		),
127	5x	error = function(e) {
128	!	cli_alert_warning("failed to read measure info: {.file {f}}")
129	!	NULL
130		}
131		)
132		}
133		)
134		)
135		}
136	1x	files <- files[files %in% all_files]
137	1x	for (f in files) {
138	7x	d <- attempt_read(f, id_location)
139	7x	if (!is.null(d)) {
140	7x	if (nrow(d)) {
141	7x	lcols <- tolower(colnames(d))
142	7x	vars <- c(id_location, variable_location)
143	7x	if (any(!vars %in% colnames(d))) {
144	1x	l <- !colnames(d) %in% vars & lcols %in% vars
145	1x	colnames(d)[l] <- lcols[l]
146		}
147		if (
148	7x	is.character(variable_location) &&
149	7x	!variable_location %in% colnames(d)
150		) {
151	1x	novars <- c(novars, f)
152	1x	next
153		}
154	6x	if (is.character(id_location) && !id_location %in% colnames(d)) {
155	!	noids <- c(noids, f)
156	!	next
157		}
158	6x	hash <- md5sum(f)[[1]]
159	6x	relf <- sub(
160	6x	paste0(dir, "repos/", sub("^.+/", "", r), "/"),
161		"",
162	6x	f,
163	6x	fixed = TRUE
164		)
165	6x	manifest[[r]][[hash]]$name <- relf
166	6x	manifest[[r]][[hash]]$providers <- c(
167	6x	manifest[[r]][[hash]]$provider,
168	6x	if (grepl("repos/", f, fixed = TRUE)) "github" else "dataverse"
169		)
170	6x	vars <- if (is.function(variable_location)) variable_location(d) else
171	6x	d[[variable_location]]
172	6x	if (length(vars)) {
173	6x	vars <- unique(vars[!is.na(vars)])
174	6x	map[[f]] <- data.frame(
175	6x	variable = vars,
176	6x	dir_name = paste0(
177	6x	gsub(
178	6x	paste0(dir, "\|cache/\|repos/\|data/\|distribution/"),
179		"",
180	6x	paste0(dirname(f), "/")
181		),
182	6x	vars
183		),
184	6x	full_name = make_full_name(f, vars),
185	6x	repo = r,
186	6x	file = sub(dir, "", f, fixed = TRUE)
187		)
188	6x	manifest[[r]][[hash]]$variables <- vars
189		} else {
190	!	novars <- c(novars, f)
191		}
192	6x	ids <- if (is.function(id_location)) id_location(d) else
193	6x	d[[id_location]]
194	6x	if (length(ids)) {
195	6x	ids <- gsub(
196	6x	"^\\s+\|\\s+$",
197		"",
198	6x	format(unique(ids), scientific = FALSE)
199		)
200	6x	idmap[[f]] <- data.frame(id = ids, repo = r, file = relf)
201	6x	manifest[[r]][[hash]]$ids <- ids
202		} else {
203	!	noids <- c(noids, f)
204		}
205		} else {
206	!	empty <- c(empty, f)
207		}
208		} else {
209	!	noread <- c(noread, f)
210		}
211		}
212	1x	if (verbose) cli_progress_update()
213		}
214	1x	if (verbose) cli_progress_done()
215	1x	if (length(measure_info)) {
216	1x	jsonlite::write_json(
217	1x	measure_info,
218	1x	paste0(dir, "cache/measure_info.json"),
219	1x	auto_unbox = TRUE
220		)
221		}
222	1x	map <- do.call(rbind, unname(map))
223	1x	idmap <- do.call(rbind, unname(idmap))
224	1x	if (verbose) {
225	!	if (length(noread)) cli_warn("file{?s} could not be read in: {noread}")
226	!	if (length(empty)) cli_warn("{?files have/file had} no rows: {empty}")
227	1x	if (length(novars))
228	1x	cli_warn(
229	1x	"{.arg {variable_location}} was not in {?some files'/a file's} column names: {novars}"
230		)
231	1x	if (length(noids))
232	!	cli_warn(
233	!	"{.arg {id_location}} was not in {?some files'/a file's} column names: {noids}"
234		)
235		}
236	!	if (!length(idmap)) cli_abort("no IDs were mapped")
237	1x	dir.create(paste0(dir, "manifest"), FALSE)
238	1x	jsonlite::write_json(
239	1x	manifest,
240	1x	paste0(dir, "manifest/files.json"),
241	1x	auto_unbox = TRUE,
242	1x	pretty = TRUE
243		)
244	1x	dir.create(paste0(dir, "cache"), FALSE)
245	1x	idmap <- lapply(
246	1x	split(idmap, idmap$id),
247	1x	function(d) list(repos = unique(d$repo), files = unique(d$file))
248		)
249	1x	saveRDS(idmap, res[2], compress = "xz")
250	1x	write.csv(map, res[1], row.names = FALSE)
251	1x	init_datacommons(dir, refresh_after = FALSE, verbose = FALSE)
252	1x	invisible(list(variables = map, ids = idmap))
253		}

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(
33		text,
34		tag = "p",
35		id = NULL,
36		class = NULL,
37		condition = NULL
38		) {
39	4x	caller <- parent.frame()
40	4x	building <- !is.null(attr(caller, "name")) &&
41	4x	attr(caller, "name") == "community_site_parts"
42	3x	if (is.null(id)) id <- paste0("text", caller$uid)
43	4x	parsed <- list()
44	!	if (!is.null(names(text))) text <- list(text)
45	4x	parse_text <- function(e) {
46	5x	res <- list()
47
48		# extracting expressions
49	5x	ex <- gsub("^\\{\|\\}$", "", regmatches(e, gregexpr("\\{.*?\\}", e))[[1]])
50
51		# extracting conditional expressions
52	5x	if (grepl("^\\?", e)) {
53	1x	if (grepl("^\\?\\{", e)) {
54	1x	res$condition <- parse_rule(ex[1])
55	1x	ex <- ex[-1]
56	1x	e <- sub("^\\?\\{.*?\\}", "", e)
57		} else {
58	!	res$condition <- parse_rule(paste(ex, collapse = " & "))
59	!	e <- gsub("?", "", e, fixed = TRUE)
60		}
61		}
62
63		# extracting buttons
64	5x	if (grepl("[", e, fixed = TRUE)) {
65	1x	m <- gregexpr("(?:\\([^)[]?\\)\|\\{[^}[]?\\}\|\\b\\w+?)?\\[.*?\\]", e)
66	1x	rb <- regmatches(e, m)[[1]]
67	1x	if (length(rb)) {
68	1x	res$button <- list()
69	1x	for (b in seq_along(rb)) {
70	1x	rbb <- rb[b]
71	1x	bid <- paste0("b", b)
72	1x	res$button[[bid]] <- list(
73	1x	text = as.list(sub(
74		"}",
75		"",
76	1x	strsplit(gsub("^\\(\|\\)?\\[.*$", "", rbb), "{", fixed = TRUE)[[
77	1x	1
78		]],
79	1x	fixed = TRUE
80		)),
81	1x	type = if (grepl("[r", rbb, fixed = TRUE)) "reset" else if (
82	1x	grepl("[n", rbb, fixed = TRUE)
83		)
84	1x	"note" else "update",
85	1x	target = strsplit(
86	1x	gsub("^[^[]*\\[[^\\s]+\\s?\|\\]$", "", rbb, perl = TRUE),
87		","
88	1x	)[[1]]
89		)
90	1x	if (!length(res$button[[bid]]$target)) {
91	!	res$button[[bid]]$target <- strsplit(
92	!	if (grepl("{", rbb, fixed = TRUE)) {
93	!	gsub("^[^{].\\{\|\\}.$", "", rbb)
94		} else {
95	!	sub("\\[.*$", "", rbb)
96		},
97		","
98	!	)[[1]]
99		}
100		}
101	1x	regmatches(e, m) <- as.list(paste0(
102	1x	"_SPLT_",
103	1x	paste0("b", seq_along(rb)),
104	1x	"_SPLT_"
105		))
106		}
107		}
108
109	5x	res$text <- Filter(nchar, strsplit(e, "[{}]\|_SPLT_")[[1]])
110	5x	res
111		}
112	4x	for (i in seq_along(text)) {
113	5x	e <- text[[i]]
114	5x	if (is.null(names(e))) {
115	5x	parsed[[i]] <- parse_text(e)
116		} else {
117	!	parsed[[i]] <- lapply(seq_along(e), function(i) {
118	!	r <- parse_text(e[[i]])
119	!	r$condition <- parse_rule(names(e)[i])
120	!	r
121		})
122		}
123		}
124	4x	r <- paste0(
125	4x	c(
126		"<",
127	4x	tag,
128	4x	' data-autoType="text" id="',
129	4x	id,
130		'"',
131	4x	' class="auto-output output-text',
132	4x	if (!is.null(class)) paste("", class),
133		'"',
134		"></",
135	4x	tag,
136		">"
137		),
138	4x	collapse = ""
139		)
140	4x	if (building) {
141	2x	caller$text[[id]] <- c(
142	2x	list(text = parsed),
143	2x	if (!is.null(condition)) condition <- parse_rule(condition)
144		)
145	2x	caller$content <- c(caller$content, r)
146	2x	caller$uid <- caller$uid + 1
147		}
148	4x	r
149		}

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(
29		dir,
30		clone_method = "http",
31		include_distributions = FALSE,
32		refresh_distributions = FALSE,
33		only_new = FALSE,
34		reset_repos = FALSE,
35		reset_on_fail = FALSE,
36		rescan_only = FALSE,
37		run_checks = TRUE,
38		dataset_map = "region_type",
39		force_value_check = FALSE,
40		verbose = TRUE
41		) {
42	!	if (missing(dir)) cli_abort('{.arg dir} must be specified (e.g., as ".")')
43	1x	if (Sys.which("git") == "") {
44	!	cli_abort(c(
45	!	x = "the {.emph git} command could not be located",
46	!	i = "you might need to install git: {.url https://git-scm.com/downloads}"
47		))
48		}
49	1x	check <- check_template("datacommons", dir = dir)
50	1x	if (!check$exists) {
51	!	cli_abort(c(
52	!	x = "{.arg dir} does not appear to point to a data commons project",
53	!	i = paste0('initialize it with {.code init_datacommons("', dir, '")}')
54		))
55		}
56	1x	dir <- normalizePath(dir, "/", FALSE)
57	1x	commons <- jsonlite::read_json(paste0(dir, "/commons.json"))
58	1x	repos <- sort(unique(unlist(Filter(
59	1x	length,
60	1x	c(
61	1x	commons$repositories,
62	1x	readLines(paste0(dir, "/scripts/repos.txt"))
63		)
64		))))
65	1x	if (!length(repos))
66	!	cli_abort("no repositories are listed in {.file commons.json}.")
67	1x	repos <- gsub("^[\"']+\|['\"]+$\|^.*github\\.com/", "", repos)
68	1x	su <- !grepl("/", repos, fixed = TRUE)
69	1x	if (any(su)) {
70	!	repos <- repos[su]
71	!	cli_abort("repo{?s are/ is} missing a username prefix: {.files {repos}}")
72		}
73	1x	repos <- sub("^([^/]+/[^/#@]+)[^/]*$", "\\1", repos)
74	1x	if (!identical(unlist(commons$repositories, use.names = FALSE), repos)) {
75	!	commons$repositories <- repos
76	!	jsonlite::write_json(
77	!	commons,
78	!	paste0(dir, "/commons.json"),
79	!	auto_unbox = TRUE,
80	!	pretty = TRUE
81		)
82		}
83	1x	writeLines(repos, paste0(dir, "/scripts/repos.txt"))
84	1x	if (only_new) {
85	!	repos <- repos[!file.exists(paste0(dir, "/repos/", sub("^.*/", "", repos)))]
86	!	if (!length(repos)) {
87	!	if (verbose) cli_alert_success("no new repositories")
88	!	return(invisible(repos))
89		}
90		}
91	1x	updated <- dist_updated <- failed <- logical(length(repos))
92	1x	wd <- getwd()
93	1x	on.exit(setwd(wd))
94	1x	repo_dir <- paste0(normalizePath(paste0(dir, "/repos/"), "/", FALSE), "/")
95	1x	dir.create(repo_dir, FALSE, TRUE)
96	1x	setwd(repo_dir)
97	1x	method <- if (clone_method == "ssh") "git@github.com:" else
98	1x	"https://github.com/"
99	!	if (include_distributions) dir.create(paste0(dir, "/cache"), FALSE)
100	1x	manifest_file <- paste0(dir, "/manifest/repos.json")
101	1x	repo_manifest <- list()
102	1x	for (i in seq_along(repos)) {
103	1x	r <- repos[[i]]
104	1x	rn <- sub("^.*/", "", r)
105	1x	cr <- paste0(repo_dir, rn, "/")
106	1x	if (!rescan_only) {
107	1x	change_dir <- dir.exists(rn)
108	1x	if (verbose)
109	!	cli_alert_info(paste(if (change_dir) "pulling" else "cloning", rn))
110	!	if (change_dir) setwd(cr)
111	1x	s <- tryCatch(
112	1x	if (change_dir) {
113	!	if (reset_repos \|\| reset_on_fail) {
114	!	attempt <- if (reset_on_fail)
115	!	system2("git", "pull", stdout = TRUE) else NULL
116	!	if (!is.null(attr(attempt, "status"))) {
117	!	system2("git", "clean --f", stdout = TRUE)
118	!	system2("git", "fetch", stdout = TRUE)
119	!	system2("git", "reset --hard FETCH_HEAD", stdout = TRUE)
120		} else {
121	!	attempt
122		}
123		} else {
124	!	system2("git", "pull", stdout = TRUE)
125		}
126		} else {
127	1x	system2("git", c("clone", paste0(method, r, ".git")), stdout = TRUE)
128		},
129	1x	error = function(e) e$message
130		)
131	!	if (change_dir) setwd(repo_dir)
132	1x	if (length(s) != 1 \|\| s != "Already up to date.") {
133	1x	if (!is.null(attr(s, "status"))) {
134	!	failed[i] <- TRUE
135	!	cli_alert_warning(c(
136	!	x = paste0("failed to retrieve ", r, ": ", paste(s, collapse = " "))
137		))
138		} else {
139	1x	updated[i] <- TRUE
140		}
141	!	} else if (!length(list.files(rn))) system2("rm", c("-rf", rn))
142		}
143	1x	repo_manifest[[r]]$base_url <- get_git_remote(paste0(cr, ".git/config"))
144	1x	files <- sort(list.files(
145	1x	cr,
146	1x	"\\.(?:csv\|tsv\|txt\|dat\|rda\|rdata)(?:\\.[gbx]z2?)?$",
147	1x	full.names = TRUE,
148	1x	recursive = TRUE,
149	1x	ignore.case = TRUE
150		))
151	1x	files <- normalizePath(files, "/")
152	1x	for (f in files) {
153	7x	repo_manifest[[r]]$files[[sub("^.*/repos/[^/]+/", "", f)]] <- list(
154	7x	size = file.size(f),
155	7x	sha = system2("git", c("hash-object", shQuote(f)), stdout = TRUE),
156	7x	md5 = md5sum(f)[[1]]
157		)
158		}
159	1x	doi <- repo_manifest[[r]]$distributions$dataverse$doi
160	1x	if (include_distributions && !is.null(doi)) {
161	!	if (verbose) {
162	!	ul <- cli_ul()
163	!	iul <- cli_ul()
164	!	cli_li("including Dataverse distribution for {.emph {doi}}")
165		}
166	!	meta_file <- paste0(dir, "/cache/", rn, "/dataverse_metadata.json")
167	!	meta <- if (!refresh_distributions && file.exists(meta_file)) {
168	!	jsonlite::read_json(meta_file, simplifyVector = TRUE)
169		} else {
170	!	tryCatch(
171	!	download_dataverse_info(doi, refresh = refresh_distributions),
172	!	error = function(e) NULL
173		)
174		}
175	!	if (is.null(meta)) {
176	!	if (verbose) {
177	!	cli_li(col_red(
178	!	"failed to download Dataverse metadata for {.emph {doi}}"
179		))
180	!	cli_end(iul)
181	!	cli_end(ul)
182		}
183		} else {
184	!	if (is.null(meta$latestVersion))
185	!	meta$latestVersion <- list(files = meta$files)
186	!	dir.create(paste0(dir, "/cache/", rn), FALSE)
187	!	jsonlite::write_json(meta, meta_file, auto_unbox = TRUE)
188	!	repo_manifest[[r]]$distributions$dataverse$id <- meta$datasetId
189	!	repo_manifest[[r]]$distributions$dataverse$server <- meta$server
190	!	repo_manifest[[r]]$distributions$dataverse$files <- list()
191	!	if (length(meta$latestVersion$files)) {
192	!	for (f in meta$latestVersion$files) {
193	!	existing <- paste0(dir, "/cache/", rn, "/", f$dataFile$filename)
194	!	if (file.exists(existing)) {
195	!	if (verbose)
196	!	cli_li(
197	!	"checking existing version of {.file {f$dataFile$filename}}"
198		)
199	!	if (md5sum(existing) != f$dataFile$md5) unlink(existing)
200		}
201	!	if (!file.exists(existing)) {
202	!	if (verbose) cli_li("downloading {.file {f$dataFile$filename}}")
203	!	res <- tryCatch(
204	!	download_dataverse_data(
205	!	doi,
206	!	paste0(dir, "/cache/", rn),
207	!	files = f$label,
208	!	load = FALSE,
209	!	decompress = FALSE
210		),
211	!	error = function(e) NULL
212		)
213	!	if (is.null(res)) {
214	!	if (verbose)
215	!	cli_li(col_red(
216	!	"failed to download {.file {f$dataFile$filename}}"
217		))
218		} else {
219	!	dist_updated[i] <- TRUE
220		}
221		}
222	!	if (file.exists(existing)) {
223	!	repo_manifest[[r]]$distributions$dataverse$files[[sub(
224	!	"^.*/cache/[^/]+/",
225		"",
226	!	existing
227	!	)]] <- list(
228	!	id = f$dataFile$id,
229	!	size = file.size(existing),
230	!	md5 = md5sum(existing)[[1]]
231		)
232		}
233		}
234		}
235		}
236	!	if (verbose) {
237	!	cli_end(iul)
238	!	cli_end(ul)
239		}
240		}
241	1x	if (run_checks) {
242	1x	if (verbose)
243	!	cli_progress_step("running checks...", msg_done = "ran checks:")
244	1x	repo_manifest[[r]]$repo_checks <- tryCatch(
245	1x	check_repository(cr, dataset = dataset_map, verbose = FALSE),
246	1x	error = function(e) NULL
247		)
248	1x	repo_manifest[[r]]$repo_checks <- lapply(
249	1x	repo_manifest[[r]]$repo_checks[
250	1x	grep(
251	1x	"^summary\|^(?:info\|warn\|fail)_",
252	1x	names(repo_manifest[[r]]$repo_checks)
253		)
254		],
255	1x	function(l) {
256	1x	if (is.character(l)) l <- sub("^.*/repos/[^/]+/", "", l)
257	5x	if (!is.null(names(l)))
258	4x	names(l) <- sub("^.*/repos/[^/]+/", "", names(l))
259	5x	l
260		}
261		)
262	1x	if (verbose) {
263	!	cli_progress_done()
264	!	if (length(repo_manifest[[r]]$repo_checks$summary)) {
265	!	print(repo_manifest[[r]]$repo_checks$summary)
266	!	cat("\n")
267		}
268		}
269		}
270		}
271	1x	if (verbose) {
272	!	if (any(updated)) {
273	!	updated_repos <- repos[updated]
274	!	cli_alert_success(
275	!	"updated data repositor{?ies/y}: {.file {updated_repos}}"
276		)
277		}
278	!	if (any(dist_updated)) {
279	!	updated_distributions <- repos[dist_updated]
280	!	cli_alert_success(
281	!	"updated distributed file{?s} in: {.file {updated_distributions}}"
282		)
283		}
284	!	if (any(failed)) {
285	!	failed_repos <- repos[failed]
286	!	cli_alert_danger(
287	!	"failed to retrieve repositor{?ies/y}: {.file {failed_repos}}"
288		)
289	!	} else if (!any(updated \| dist_updated)) {
290	!	cli_alert_success("all data repositories are up to date")
291		}
292		}
293	1x	if (length(repo_manifest)) {
294	1x	su <- names(repo_manifest) %in% repos
295	1x	if (any(su)) {
296	1x	jsonlite::write_json(repo_manifest[su], manifest_file, auto_unbox = TRUE)
297		} else {
298	!	cli_warn("no repos were found in the existing repo manifest")
299		}
300		}
301	1x	init_datacommons(dir, refresh_after = FALSE, verbose = FALSE)
302	1x	invisible(repos[updated \| dist_updated])
303		}

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(
35		id,
36		outdir = tempdir(),
37		files = NULL,
38		version = ":latest",
39		server = NULL,
40		key = NULL,
41		load = TRUE,
42		decompress = FALSE,
43		refresh = FALSE,
44		branch = NULL,
45		verbose = FALSE
46		) {
47	!	if (missing(id)) cli_abort("{.arg id} must be specified")
48	!	if (!is.character(outdir)) cli_abort("{.arg outdir} must be a character")
49	2x	meta <- download_dataverse_info(
50	2x	id,
51	2x	server = server,
52	2x	key = key,
53	2x	refresh = refresh,
54	2x	branch = branch
55		)
56	2x	fs <- vapply(meta$files, function(m) m$dataFile$filename, "")
57	2x	which_files <- if (!is.null(files)) {
58	2x	if (is.numeric(files)) {
59	1x	files[files <= length(fs)]
60		} else {
61	1x	grep(
62	1x	paste0(
63		"(?:",
64	1x	paste(gsub(".", "\\.", files, fixed = TRUE), collapse = "\|"),
65		")"
66		),
67	1x	fs,
68	1x	TRUE
69		)
70		}
71		} else {
72	!	seq_along(fs)
73		}
74	2x	if (!length(which_files)) {
75	!	cli_abort(cli_bullets(c(
76	!	x = "{.arg files} could not be matched to available files",
77	!	i = paste0("check {.url ", meta$persistentUrl, "}")
78		)))
79		}
80	2x	outdir <- paste0(normalizePath(outdir, "/", FALSE), "/")
81	2x	dir.create(outdir, FALSE, TRUE)
82	2x	data <- list()
83	2x	ffsx <- paste0(outdir, fs)
84	2x	ffs <- sub("\\.[gbx]z2?$", "", ffsx)
85	!	if (refresh) unlink(c(ffsx, ffs))
86	2x	if (is.null(key)) {
87	!	if (verbose) cli_alert_info("looking for API key in fall-backs")
88	2x	key <- Sys.getenv("DATAVERSE_KEY")
89	2x	if (key == "") {
90	2x	key <- getOption("dataverse.key")
91		}
92		}
93	2x	if (length(which_files) == length(fs) \|\| !missing(version)) {
94	!	zf <- paste0(outdir, gsub("\\W", "", meta$datasetPersistentId), ".zip")
95	!	if (verbose)
96	!	cli_alert_info("downloading dataset: {meta$datasetPersistentId}")
97	!	if (is.character(key)) {
98	!	if (verbose) cli_alert_info("trying with key")
99	!	tryCatch(
100	!	system2(
101	!	"curl",
102	!	c(
103	!	paste0("-H X-Dataverse-key:", key),
104	!	"-o",
105	!	zf,
106	!	paste0(
107	!	meta$server,
108	!	"api/access/dataset/:persistentId/versions/",
109	!	version,
110	!	"?persistentId=",
111	!	meta$datasetPersistentId
112		)
113		),
114	!	stdout = TRUE
115		),
116	!	error = function(e) NULL
117		)
118		} else {
119	!	if (verbose) cli_alert_info("trying without key")
120	!	tryCatch(
121	!	download.file(
122	!	paste0(
123	!	meta$server,
124	!	"api/access/dataset/:persistentId/versions/",
125	!	version,
126	!	"?persistentId=",
127	!	meta$datasetPersistentId
128		),
129	!	zf,
130	!	quiet = TRUE,
131	!	mode = "wb"
132		),
133	!	error = function(e) NULL
134		)
135		}
136	!	if (file.exists(zf)) {
137	!	unzip(zf, exdir = sub("/$", "", outdir))
138	!	unlink(zf)
139	!	} else if (verbose)
140	!	cli_alert_info(
141	!	"failed to download dataset {meta$id}; trying individual files..."
142		)
143		}
144	2x	for (i in which_files) {
145	2x	m <- meta$files[[i]]
146	2x	meta$files[[i]]$local <- ffs[i]
147	2x	if (!file.exists(ffs[i]) && !file.exists(ffsx[i])) {
148	!	if (verbose) cli_alert_info("downloading file: {.file {m$label}}")
149	2x	if (is.null(key)) {
150	!	if (verbose) cli_alert_info("trying without key")
151	2x	tryCatch(
152	2x	download.file(
153	2x	paste0(meta$server, "api/access/datafile/", m$dataFile$id),
154	2x	ffsx[i],
155	2x	quiet = TRUE,
156	2x	mode = "wb"
157		),
158	2x	error = function(e) NULL
159		)
160		} else {
161	!	if (verbose) cli_alert_info("trying with key")
162	!	tryCatch(
163	!	system2(
164	!	"curl",
165	!	c(
166	!	paste0("-H X-Dataverse-key:", key),
167	!	"-o",
168	!	ffsx[i],
169	!	paste0(meta$server, "api/access/datafile/", m$dataFile$id)
170		),
171	!	stdout = TRUE
172		),
173	!	error = function(e) NULL
174		)
175		}
176	2x	if (verbose && !file.exists(ffsx[i]))
177	!	cli_alert_info("failed to download file: {.file {m$label}}")
178		}
179	2x	if (file.exists(ffsx[i])) {
180	2x	if (verbose && m$dataFile$md5 != md5sum(ffsx[i])) {
181	!	cli_warn(
182	!	"file was downloaded but its checksum did not match: {.file {ffsx[i]}}"
183		)
184		}
185	2x	if (decompress && grepl("[gbx]z2?$", ffsx[i])) {
186	!	if (verbose) cli_alert_info("decompressing file: {.file {ffsx[i]}}")
187	!	system2(
188	!	c(xz = "xz", bz = "bunzip2", gz = "gzip")[substring(
189	!	ffsx[i],
190	!	nchar(ffsx[i]) - 1
191		)],
192	!	c("-df", shQuote(ffsx[i]))
193		)
194		}
195		}
196	2x	if (load && file.exists(if (decompress) ffs[i] else ffsx[i])) {
197	!	if (verbose) cli_alert_info("loading file: {.file {ffs[i]}}")
198	2x	fn <- sub("\\..*", "", m$label)
199	2x	json <- grepl("\\.json$", ffs[i])
200	2x	data[[fn]] <- tryCatch(
201	2x	if (json) {
202	!	jsonlite::read_json(ffs[i], simplifyVector = TRUE)
203		} else {
204	2x	read_delim_arrow(
205	2x	gzfile(ffsx[i]),
206	2x	if (grepl("csv", format, fixed = TRUE)) "," else "\t"
207		)
208		},
209	2x	error = function(e) NULL
210		)
211	2x	if (verbose && is.null(data[[fn]])) {
212	!	cli_warn("file was downloaded but failed to load: {.file {ffs[i]}}")
213		}
214		}
215		}
216	2x	if (!decompress) ffs <- ffsx
217	2x	ffs <- ffs[which_files]
218	2x	if (verbose && any(!file.exists(ffs))) {
219	!	cli_warn("failed to download file{?s}: {.file {ffs[!file.exists(ffs)]}}")
220		}
221	2x	invisible(if (load) if (length(data) == 1) data[[1]] else data else meta)
222		}

1		#' Add a range slider to a website
2		#'
3		#' Adds an input to select within the entered range.
4		#'
5		#' @param label Label of the input for the user.
6		#' @param id Unique id of the element to be created.
7		#' @param ... Additional attributes to set on the element.
8		#' @param min The smallest value in the range.
9		#' @param max The largest value in the range.
10		#' @param step How much moving the handle adjusts the selected value.
11		#' @param default Starting value of the slider handle.
12		#' @param note Text to display as a tooltip for the input.
13		#' @param dataset The name of an included dataset, where \code{variable} should be looked for; only applies when
14		#' there are multiple datasets with the same variable name.
15		#' @param depends The id of another input on which the options depend; this will take president over \code{dataset}
16		#' and \code{variable}, depending on this type of input \code{depends} points to.
17		#' @examples
18		#' \dontrun{
19		#' input_slider()
20		#' }
21		#' @return A character vector of the contents to be added.
22		#' @export
23
24		input_slider <- function(
25		label,
26		id = label,
27		...,
28		min = 0,
29		max = 1,
30		step = 1,
31		default = max,
32		note = NULL,
33		dataset = NULL,
34		depends = NULL
35		) {
36	3x	id <- gsub("\\s", "", id)
37	3x	a <- list(...)
38	3x	r <- c(
39	3x	'<div class="wrapper slider-wrapper">',
40	3x	paste0('<label class="form-label" for="', id, '">', label, "</label>"),
41	3x	paste0(
42	3x	'<input role="slider" type="range" class="auto-input form-range" data-autoType="number" id="',
43	3x	id,
44	3x	'" data-default=',
45	3x	default,
46	3x	" step=",
47	3x	step,
48	3x	" min=",
49	3x	min,
50	3x	" max=",
51	3x	max,
52	3x	if (!is.null(depends)) {
53	!	paste0(' data-depends="', depends, '"')
54	3x	} else if (!is.null(dataset)) paste0('data-dataset="', dataset, '"'),
55	3x	if (length(a))
56	3x	unlist(lapply(
57	3x	seq_along(a),
58	3x	function(i) paste0(" ", names(a)[i], '="', a[[i]], '"')
59		)),
60	3x	if (!is.null(note)) paste0(' aria-description="', note, '"'),
61		">"
62		),
63	3x	paste0('<div class="slider-display"><span>', default, "</span></div>"),
64	3x	"</div>"
65		)
66	3x	caller <- parent.frame()
67		if (
68	3x	!is.null(attr(caller, "name")) &&
69	3x	attr(caller, "name") == "community_site_parts"
70		) {
71	1x	caller$content <- c(caller$content, r)
72		}
73	3x	r
74		}

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(
22	4x	lapply(seq_len(n), function(i) {
23	4x	txt <- text[i]
24	4x	m <- regmatches(txt, gregexpr("\\[.?\\]\\(.?\\)", txt))[[1]]
25	4x	for (l in m) {
26	!	parts <- strsplit(substr(l, 2, nchar(l) - 1), "](", fixed = TRUE)[[1]]
27	!	txt <- sub(
28	!	l,
29	!	paste0(
30	!	'<a target="_blank" rel="noreferrer" href="',
31	!	parts[2],
32		'">',
33	!	parts[1],
34	!	"</a>"
35		),
36	!	txt,
37	!	fixed = TRUE
38		)
39		}
40	4x	paste0(
41		"<",
42	4x	tag[i],
43	4x	if (length(atr))
44	4x	paste(
45		"",
46	4x	paste(
47	4x	paste0(names(atr), '="', vapply(atr, "[[", "", i), '"'),
48	4x	collapse = " "
49		)
50		) else "",
51		">",
52	4x	txt,
53		"</",
54	4x	tag[i],
55		">"
56		)
57		}),
58	4x	use.names = FALSE
59		)
60	4x	caller <- parent.frame()
61		if (
62	4x	!is.null(attr(caller, "name")) &&
63	4x	attr(caller, "name") == "community_site_parts"
64		) {
65	2x	caller$content <- c(caller$content, r)
66		}
67	4x	r
68		}

1		#' Add an internal variable to a website
2		#'
3		#' Creates an internal variable (virtual input), which can be used for display logic.
4		#'
5		#' @param id Name of the variable, which can be referred to by other inputs of outputs.
6		#' @param cases A list of conditions with names specifying conditions, and values to set the variable to
7		#' in that condition (e.g., \code{list("input_a == 1" = 1)}).
8		#' These can also be specified separately with an \code{\link{input_rule}}.
9		#' @param default The value to set if no condition is \code{TRUE}.
10		#' @param display A list mapping cases names to display names (e.g., \code{list(value = "Value")}).
11		#' @examples
12		#' \dontrun{
13		#' input_select("input_a", c("a", "b", "c"))
14		#' input_variable("vinput_a", list("input_a == c" = "b"), "a")
15		#'
16		#' # vinput_a will be "a" unless input_a is "c"
17		#' }
18		#' @return A version of the resulting variable object.
19		#' @export
20
21		input_variable <- function(id, cases, default = "", display = list()) {
22	3x	r <- Filter(
23	3x	length,
24	3x	list(
25	3x	id = id,
26	3x	states = lapply(seq_along(cases), function(i) {
27	6x	list(
28	6x	condition = parse_rule(names(cases[i])),
29	6x	value = cases[[i]]
30		)
31		}),
32	3x	default = default,
33	3x	display = display
34		)
35		)
36	3x	caller <- parent.frame()
37		if (
38	3x	!is.null(attr(caller, "name")) &&
39	3x	attr(caller, "name") == "community_site_parts"
40		) {
41	1x	caller$variables <- c(caller$variables, list(r))
42		}
43	3x	r
44		}

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(
29		...,
30		position = "right",
31		width = "300px",
32		height = NULL,
33		collapsible = TRUE,
34		default_open = FALSE,
35		wraps = TRUE,
36		sizes = NA,
37		breakpoints = NA,
38		conditions = ""
39		) {
40	4x	caller <- parent.frame()
41	4x	building <- !is.null(attr(caller, "name")) &&
42	4x	attr(caller, "name") == "community_site_parts"
43	4x	parts <- new.env()
44	4x	attr(parts, "name") <- "community_site_parts"
45	4x	parts$uid <- caller$uid
46	4x	elements <- substitute(...(), environment())
47	4x	n <- length(elements)
48	4x	vertical <- position %in% c("left", "right")
49	4x	wraps <- rep_len(
50	4x	if (length(wraps) == 1 && !is.character(wraps) && wraps) {
51	1x	if (vertical) "row" else "col"
52		} else {
53	!	wraps
54		},
55	4x	n
56		)
57	4x	sizes <- rep_len(sizes, n)
58	4x	breakpoints <- rep_len(breakpoints, n)
59	4x	conditions <- rep_len(conditions, n)
60	4x	ids <- paste0("menu", parts$uid, seq_len(n))
61	4x	parts$uid <- parts$uid + 1
62	!	if (is.numeric(width)) width <- paste0(width, "px")
63	!	if (is.numeric(height)) height <- paste0(height, "px")
64	4x	r <- c(
65	4x	paste0(
66	4x	c(
67	4x	'<div data-state="',
68	4x	if (default_open) "open" else "closed",
69	4x	'" class="menu-wrapper menu-',
70	4x	position,
71		'"',
72	4x	c(
73	4x	' style="',
74	4x	position,
75		": ",
76	4x	if (default_open) 0 else paste0("-", width),
77		"; ",
78	4x	if (!is.null(height)) c("; height: ", height),
79		'"'
80		),
81		">"
82		),
83	4x	collapse = ""
84		),
85	4x	paste0(
86	4x	'<div class="menu',
87	4x	if (vertical) " col" else " row",
88	4x	if (!default_open) " hidden",
89	4x	" menu-",
90	4x	position,
91		'">'
92		),
93	4x	unlist(
94	4x	lapply(seq_len(n), function(i) {
95	4x	c(
96	4x	if (!is.na(wraps[i])) {
97	4x	paste(
98	4x	c(
99	4x	'<div class="',
100	4x	wraps[i],
101	4x	if (!is.na(breakpoints[i])) c("-", breakpoints[i]),
102	4x	if (!is.na(sizes[i])) c("-", sizes[i]),
103		'"',
104	4x	if (conditions[i] != "") paste0(' id="', ids[i], '"'),
105		">"
106		),
107	4x	collapse = ""
108		)
109		},
110	4x	eval(elements[[i]], parts),
111	4x	if (!is.na(wraps[i])) "</div>"
112		)
113		}),
114	4x	use.names = FALSE
115		),
116	4x	"</div>",
117	4x	if (collapsible)
118	4x	paste0(
119	4x	'<button type="button" class="menu-toggle" title="',
120	4x	position,
121	4x	' menu"></button>'
122		),
123	4x	"</div>"
124		)
125	4x	if (building) {
126	2x	caller$body <- c(caller$body, r)
127	2x	for (n in names(parts))
128	2x	if (n != "content") caller[[n]] <- c(caller[[n]], parts[[n]])
129	2x	caller$uid <- parts$uid
130	2x	process_conditions(conditions, ids, caller)
131		}
132	4x	r
133		}

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(
89		label,
90		target = "reset_selection",
91		id = label,
92		dataview = NULL,
93		query = list(),
94		from_api = FALSE,
95		class = "",
96		...,
97		note = NULL
98		) {
99	21x	id <- gsub("\\s", "", id)
100	21x	a <- list(...)
101	21x	if (missing(target) && !(missing(dataview) \|\| missing(query))) {
102	!	target <- "export"
103		}
104	21x	r <- c(
105	21x	'<div class="wrapper button-wrapper">',
106	21x	if (
107	21x	is.character(target) &&
108	21x	length(target) == 1 &&
109	21x	grepl("://", target, fixed = TRUE)
110		) {
111	!	paste0(
112	!	'<a role="button" class="btn',
113	!	if (class != "") paste("", class),
114	!	'" id="',
115	!	id,
116	!	'" target="_blank" rel="noreferrer" href="',
117	!	target,
118		'"',
119	!	if (length(a))
120	!	unlist(lapply(
121	!	seq_along(a),
122	!	function(i) paste0(" ", names(a)[i], '="', a[[i]], '"')
123		)),
124	!	if (!is.null(note)) paste0(' aria-description="', note, '"'),
125		">",
126	!	label,
127	!	"</a>"
128		)
129		} else {
130	21x	paste0(
131	21x	'<button type="button" data-autoType="button" class="auto-input btn',
132	21x	if (class != "") paste("", class),
133	21x	'" id="',
134	21x	id,
135		'"',
136	21x	if (length(target) == 1 && !is.list(target) && is.null(names(target)))
137	21x	paste0(' data-target="', target, '"'),
138	21x	if (length(a))
139	21x	unlist(lapply(
140	21x	seq_along(a),
141	21x	function(i) paste0(" ", names(a)[i], '="', a[[i]], '"')
142		)),
143	21x	if (!is.null(note)) paste0(' aria-description="', note, '"'),
144		">",
145	21x	label,
146	21x	"</button>"
147		)
148		},
149	21x	"</div>"
150		)
151	21x	caller <- parent.frame()
152		if (
153	21x	!is.null(attr(caller, "name")) &&
154	21x	attr(caller, "name") == "community_site_parts"
155		) {
156	1x	if (length(target) == 1 && target %in% c("export", "copy")) {
157	!	caller$button[[id]] <- Filter(
158	!	function(e) length(e) > 1 \|\| (length(e) && (!is.logical(e) \|\| e)),
159	!	list(
160	!	effects = target,
161	!	dataview = dataview,
162	!	query = query,
163	!	api = from_api
164		)
165		)
166	1x	} else if (!is.null(names(target)))
167	1x	caller$button[[id]] <- list(effects = target)
168	1x	caller$content <- c(caller$content, r)
169		}
170	21x	r
171		}

1		#' Create new template initializer
2		#'
3		#' Create a new initializer function, and a spec file against which initialized templates can be checked.
4		#'
5		#' @param name Name of the template to be checked.
6		#' @param files List of paths to required files, relative to dir.
7		#' \code{"{name}"} included in a path string will be replaced with \code{name} during checks.
8		#' A list within the main list is treated as either alternatives files (when there is a single character vector),
9		#' or alternative strict sets of files (must contain all of at least one list;
10		#' when there are multiple character vectors).
11		#' @param dir Package directory.
12		#' @param spec_dir Parent directory of the \code{files}.
13		#' @param context name of the template's context: itself, or another templated structure.
14		#' @param overwrite logical; if \code{TRUE}, new files will replace existing ones.
15		#' @examples
16		#' \dontrun{
17		#'
18		#' # creates a version of the function spec.
19		#' init_template("function", list("R/{name}.R", "tests/testthat/text-{name}.R"))
20		#'
21		#' # creates a version of the shiny function, showing alternative sets
22		#' init_template("shiny", list(
23		#' list(
24		#' c("ui.R", "server.R"),
25		#' "app.R"
26		#' ),
27		#' "README.md"
28		#' ), spec_dir = "app")
29		#' }
30		#' @return Creates a name.json file (in \code{dir/inst/specs} if it exists, or the current working directory),
31		#' and invisibly returns its path.
32		#' @export
33
34		init_template <- function(
35		name,
36		files,
37		dir = ".",
38		spec_dir = ".",
39		context = name,
40		overwrite = FALSE
41		) {
42	!	if (missing(name)) cli_abort("{.arg name} must be specified")
43	!	if (missing(files)) cli_abort("{.arg files} must be specified")
44	1x	name <- sub("^init_", "", name)
45	1x	dir <- normalizePath(dir, "/", FALSE)
46	1x	spec <- list(
47	1x	name = name,
48	1x	context = context,
49	1x	dir = spec_dir,
50	1x	files = files
51		)
52	1x	test_path <- paste0(dir, "/tests/testthat/test-init_", name, ".R")
53	1x	template_test <- file.exists(test_path)
54	1x	init_function(paste0("init_", name), dir = dir, overwrite = overwrite)
55	1x	if (overwrite \|\| !template_test) {
56	1x	writeLines(
57	1x	paste0(
58	1x	"test_that(\"check_template passes\", {",
59	1x	"\n dir <- tempdir(TRUE)",
60	1x	"\n on.exit(unlink(dir, TRUE, TRUE))",
61	1x	if (spec$name != spec$context) {
62	!	paste0(
63	!	"\n init_",
64	!	spec$context,
65	!	"(\"test_context\", dir = dir)\n dir <- paste0(dir, \"/test_context\")"
66		)
67		},
68	1x	"\n init_",
69	1x	name,
70	1x	"(\"test_",
71	1x	name,
72	1x	"\", dir = dir)",
73	1x	"\n expect_true(check_template(\"",
74	1x	name,
75	1x	"\", \"test_",
76	1x	name,
77	1x	"\", dir = dir)$exists)",
78	1x	"\n})",
79	1x	sep = ""
80		),
81	1x	test_path
82		)
83		}
84	1x	path <- normalizePath(
85	1x	paste0(
86	1x	dir,
87	1x	if (file.exists(paste0(dir, "/inst"))) "/inst",
88	1x	"/specs/",
89	1x	name,
90	1x	".json"
91		),
92		"/",
93	1x	FALSE
94		)
95	1x	if (overwrite \|\| !file.exists(path))
96	1x	jsonlite::write_json(spec, path, auto_unbox = TRUE)
97	1x	if (interactive()) {
98	!	cli_bullets(c(
99	!	v = "created a spec file for {name}:",
100	!	"*" = paste0("{.file ", path, "}")
101		))
102		}
103	1x	invisible(path)
104		}

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{time_resolution}}: Temporal resolution of the variable, such as \code{year} or \code{week},
56		#' \item \strong{\code{sources}}: A list or list of list containing source information, including any of these entries:
57		#' \itemize{
58		#' \item \code{name}: Name of the source (such as an organization name).
59		#' \item \code{url}: General URL of the source (such as an organization's website).
60		#' \item \code{location}: More specific description of the source (such as a the name of a particular data product).
61		#' \item \code{location_url}: More direct URL to the resource (such as a page listing data products).
62		#' \item \code{date_accessed}: Date of retrieval (arbitrary format).
63		#' }
64		#' \item \strong{\code{citations}}: A vector of reference ids (the names of \code{reference} entries; e.g., \code{c("ref1", "ref3")}).
65		#' \item \strong{\code{layer}}: A list specifying an \code{\link{output_map}} overlay:
66		#' \itemize{
67		#' \item \code{source} (required): A URL to a GeoJSON file, or a list with a \code{url} and \code{time} entry, where
68		#' \code{time} conditions the display of the layer on the current selected time. Alternative to a list that specifies time,
69		#' the URL can include a dynamic reference to time, if the time values correspond to a component of the URL
70		#' (e.g., \code{"https://example.com/{time}/points.geojson"}).
71		#' \item \code{filter}: A list or list of lists specifying how the elements of the layer should be filtered for this variable:
72		#' \itemize{
73		#' \item \code{feature}: Name of the layer's property to filter on.
74		#' \item \code{operator}: Operator to filter by (e.g., \code{"="} or \code{"!="}).
75		#' \item \code{value}: Value to filter by.
76		#' }
77		#' }
78		#' \item \strong{\code{categories}}: A named list of categories, with any of the other measure entries, or a
79		#' \code{default} entry giving a default category name. See the Dynamic Entries section.
80		#' \item \strong{\code{variants}}: A named list of variants, with any of the other measure entries, or a
81		#' \code{default} entry giving a default variant name. See the Dynamic Entries section.
82		#' }
83		#' @section Dynamic Entries:
84		#' You may have several closely related variables in a dataset, which share sections of metadata,
85		#' or have formulaic differences. In cases like this, the \code{categories} and/or \code{variants} entries
86		#' can be used along with dynamic notation to construct multiple entries from a single template.
87		#'
88		#' Though functionally the same, \code{categories} might include broken-out subsets of some total
89		#' (such as race groups, as categories of a total population), whereas \code{variants} may be different
90		#' transformations of the same variable (such as raw counts versus percentages).
91		#'
92		#' In dynamic entries, \code{{category}} or \code{{variant}} refers to entries in the \code{categories}
93		#' or \code{variants} lists. By default, these are replaced with the name of each entries in those lists
94		#' (e.g., \code{"variable_{category}"} where \code{categories = "a"} would become \code{"variable_a"}).
95		#' A \code{default} entry would change this behavior (e.g., with \code{categories = list(a = list(default = "b")}
96		#' that would become \code{"variable_b"}). Adding \code{.name} would force the original behavior (e.g.,
97		#' \code{"variable_{category.name}"} would be \code{"variable_a"}). A name of \code{"blank"} is treated as
98		#' an empty string.
99		#'
100		#' When notation appears in a measure info entry, they will first default to a matching name in the \code{categories}
101		#' or \code{variants} list; for example, \code{short_name} in \code{list(short_name = "variable {category}")} with
102		#' \code{categories = list(a = list(short_name = "(category a)"))} would become \code{"variable (category a)"}.
103		#' To force this behavior, the entry name can be included in the notation (e.g.,
104		#' \code{"{category.short_name}"} would be \code{"variable (category a)"} in any entry).
105		#'
106		#' Only string entries are processed dynamically -- any list-like entries (such as
107		#' \code{source}, \code{citations}, or \code{layer}) appearing in
108		#' \code{categories} or \code{variants} entries will fully replace the base entry.
109		#'
110		#' Dynamic entries can be kept dynamic when passed to a data site, but can be rendered for other uses,
111		#' where the rendered version will have each dynamic entry replaced with all unique combinations of
112		#' \code{categories} and \code{variants} entries, assuming both are used in the dynamic entry's name
113		#' (e.g., \code{"variable_{category}_{variant}"}). See Examples.
114		#' @section Reference Entries:
115		#' Reference entries can be included in a \code{_references} entry, and should have names corresponding to
116		#' those included in any of the measures' \code{citation} entries. These can include any of these entries:
117		#' \itemize{
118		#' \item \strong{\code{id}}: The reference id, same as the entry name.
119		#' \item \strong{\code{author}}: A list or list of lists specifying one or more authors. These can include
120		#' entries for \code{given} and \code{family} names.
121		#' \item \strong{\code{year}}: Year of the publication.
122		#' \item \strong{\code{title}}: Title of the publication.
123		#' \item \strong{\code{journal}}: Journal in which the publication appears.
124		#' \item \strong{\code{volume}}: Volume number of the journal.
125		#' \item \strong{\code{page}}: Page number of the journal.
126		#' \item \strong{\code{doi}}: Digital Object Identifier, from which a link is made (\code{https://doi.org/{doi}}).
127		#' \item \strong{\code{version}}: Version number of software.
128		#' \item \strong{\code{url}}: Link to the publication, alternative to a DOI.
129		#' }
130		#' @examples
131		#' path <- tempfile()
132		#'
133		#' # make an initial file
134		#' data_measure_info(path, "measure name" = list(
135		#' measure = "measure name",
136		#' full_name = "prefix:measure name",
137		#' short_description = "A measure.",
138		#' statement = "This entity has {value} measure units."
139		#' ), verbose = FALSE)
140		#'
141		#' # add another measure to that
142		#' measure_info <- data_measure_info(path, "measure two" = list(
143		#' measure = "measure two",
144		#' full_name = "prefix:measure two",
145		#' short_description = "Another measure.",
146		#' statement = "This entity has {value} measure units."
147		#' ), verbose = FALSE)
148		#' names(measure_info)
149		#'
150		#' # add a dynamic measure, and make a rendered version
151		#' measure_info_rendered <- data_measure_info(
152		#' path,
153		#' "measure {category} {variant.name}" = list(
154		#' measure = "measure {category}",
155		#' full_name = "{variant}:measure {category}",
156		#' short_description = "Another measure ({category}; {variant}).",
157		#' statement = "This entity has {value} {category} {variant}s.",
158		#' categories = c("a", "b"),
159		#' variants = list(u1 = list(default = "U1"), u2 = list(default = "U2"))
160		#' ),
161		#' render = TRUE, verbose = FALSE
162		#' )
163		#' names(measure_info_rendered)
164		#' measure_info_rendered[["measure a u1"]]$statement
165		#' @return An invisible list containing measurement metadata (the rendered version if made).
166		#' @export
167
168		data_measure_info <- function(
169		path,
170		...,
171		info = list(),
172		references = list(),
173		strict = FALSE,
174		include_empty = TRUE,
175		overwrite_entry = FALSE,
176		render = NULL,
177		overwrite = FALSE,
178		write = TRUE,
179		verbose = TRUE,
180		open_after = interactive()
181		) {
182	19x	if (write) {
183	7x	if (missing(path) \|\| !is.character(path)) {
184	!	cli_abort("enter a path to the measure_info.json file as {.arg path}")
185		}
186	7x	dir.create(dirname(path), FALSE, TRUE)
187		}
188	19x	built <- list()
189	19x	if (!overwrite && is.character(path) && file.exists(path)) {
190	18x	if (verbose) {
191	5x	cli_bullets(c(i = "updating existing file: {.path {basename(path)}}"))
192		}
193	18x	built <- jsonlite::read_json(path)
194	18x	if (all(c("measure", "measure_type") %in% names(built))) {
195	!	built <- list(built)
196	!	names(built) <- built[[1]]$measure
197		}
198		}
199	19x	if (length(references)) {
200	2x	references <- c(references, built$`_references`)
201	2x	references <- references[!duplicated(names(references))]
202	2x	built$`_references` <- references
203		} else {
204	17x	references <- built$`_references`
205		}
206	19x	defaults <- list(
207	19x	measure = "",
208	19x	full_name = "",
209	19x	short_name = "",
210	19x	long_name = "",
211	19x	category = "",
212	19x	short_description = "",
213	19x	long_description = "",
214	19x	statement = "",
215	19x	measure_type = "",
216	19x	unit = "",
217	19x	time_resolution = "",
218	19x	sources = list(),
219	19x	citations = list(),
220	19x	layer = list()
221		)
222	!	if (!is.list(info)) info <- sapply(info, function(name) list())
223	19x	info <- c(list(...), info)
224	19x	if (length(info) && is.null(names(info))) {
225	!	cli_abort("supplied measure entries must be named")
226		}
227	19x	for (n in names(info)) {
228	10x	if (overwrite_entry \|\| is.null(built[[n]])) {
229	7x	l <- info[[n]]
230		} else {
231	3x	l <- c(info[[n]], built[[n]])
232	3x	l <- l[!duplicated(names(l))]
233		}
234	3x	if (is.null(l$full_name)) l$full_name <- n
235	10x	if (strict) {
236	1x	su <- names(l) %in% names(defaults)
237	1x	if (verbose && any(!su)) {
238	1x	cli_warn(paste0(
239	1x	"unrecognized {?entry/entries} in ",
240	1x	n,
241	1x	": {names(l)[!su]}"
242		))
243		}
244	1x	if (include_empty) {
245	!	for (e in names(l)) {
246	!	if (!is.null(defaults[[e]])) {
247	!	defaults[[e]] <- l[[e]]
248		}
249		}
250	!	l <- defaults
251		} else {
252	1x	l <- l[su]
253		}
254	9x	} else if (include_empty) {
255	8x	su <- !names(defaults) %in% names(l)
256	6x	if (any(su)) l <- c(l, defaults[su])
257		}
258	10x	if (!is.null(l$categories) && !is.list(l$categories)) {
259	1x	l$categories <- structure(
260	1x	lapply(l$categories, function(e) list(default = e)),
261	1x	names = l$categories
262		)
263		}
264	10x	if (!is.null(l$variants) && !is.list(l$variants)) {
265	!	l$variants <- structure(
266	!	lapply(l$variants, function(e) list(default = e)),
267	!	names = l$categories
268		)
269		}
270	10x	if (verbose && !is.null(l$citations)) {
271	8x	su <- !l$citations %in% names(references)
272	8x	if (any(su)) {
273	2x	cli_warn(
274	2x	"no matching reference entry for {.val {l$citations[su]}} in {.val {n}}"
275		)
276		}
277		}
278	10x	built[[n]] <- l
279		}
280	19x	built <- built[order(grepl("^_", names(built)))]
281	19x	if (write) {
282	6x	if (verbose) cli_bullets(c(i = "writing info to {.path {path}}"))
283	7x	jsonlite::write_json(built, path, auto_unbox = TRUE, pretty = TRUE)
284		}
285	19x	if (!is.null(render)) {
286	13x	expanded <- list()
287	13x	for (name in names(built)) {
288	37x	expanded <- c(
289	37x	expanded,
290	37x	if (grepl("{", name, fixed = TRUE)) {
291	11x	render_info(built[name])
292		} else {
293	26x	structure(list(built[[name]]), names = name)
294		}
295		)
296		}
297	13x	changed <- !identical(built, expanded)
298	13x	built <- expanded
299	13x	if (write && changed) {
300	1x	path <- if (is.character(render)) {
301	!	render
302		} else {
303	1x	sub("\\.json", "_rendered.json", path, TRUE)
304		}
305	1x	if (verbose) cli_bullets(c(i = "writing rendered info to {.path {path}}"))
306	1x	jsonlite::write_json(built, path, auto_unbox = TRUE, pretty = TRUE)
307		}
308		}
309	!	if (open_after) navigateToFile(path)
310	19x	invisible(built)
311		}

1		#' Initialize a Data Commons
2		#'
3		#' Initialize a project to keep track of separate dataset repositories and distributions.
4		#'
5		#' @param dir Path to the desired data commons directory.
6		#' @param name Name of the data commons.
7		#' @param repos A vector of repository names to add to \code{commons.json}.
8		#' @param default_user GitHub username to prepend to repository names if needed.
9		#' @param remote Name of the data commons' GitHub repository (\code{"username/reponame"}).
10		#' @param url URL of the data commons' monitor site; defaults to the GitHub Pages URL associated with \code{remote}
11		#' if provided (\code{"https://username.github.io/reponame"}).
12		#' @param refresh_after Logical; if \code{FALSE}, will not run \code{\link{datacommons_refresh}}
13		#' after initiating the project. Defaults to \code{TRUE} when first creating a data commons project.
14		#' @param overwrite Logical; if \code{TRUE}, will overwrite existing datacommons files in \code{dir}.
15		#' The included \code{.js} and \code{.sh} files are always rewritten, and if \code{name},
16		#' \code{repos}, or \code{default_user} is specified, \code{commons.json} will also be rewritten
17		#' regardless of \code{overwrite}.
18		#' @param serve Logical; if \code{TRUE}, will serve the \code{docs} directory.
19		#' @param host The IPv4 address to listen to if \code{serve} is \code{TRUE}; defaults to \code{"127.0.0.1"}.
20		#' @param port The port to listen on if \code{serve} is \code{TRUE}; defaults to 3000.
21		#' @param use_local Logical; if \code{TRUE}, will use a \code{datacommons.js} script located in
22		#' a local \code{dist/docs/dev} directory, relative to \code{dir}.
23		#' @param verbose Logical; if \code{FALSE}, suppresses messages.
24		#' @details
25		#' The shell scripts included in the project's \code{scripts} directory can be used to retrieve
26		#' and update repositories over SSH.
27		#'
28		#' This will clone or pull repositories listed in \code{scripts/repos.txt}:
29		#' \code{sh scripts/get_repos.sh}
30		#'
31		#' This will add, commit, and push all changes in all repositories:
32		#' \code{sh scripts/update_repos.sh "commit message"}
33		#' @examples
34		#' \dontrun{
35		#' init_datacommons(
36		#' "../datacommons",
37		#' name = "Data Commons",
38		#' remote = ""
39		#' )
40		#' }
41		#' @return Path to the datacommons directory.
42		#' @export
43
44		init_datacommons <- function(
45		dir,
46		name = "Data Commons",
47		repos = NULL,
48		default_user = "",
49		remote = NULL,
50		url = NULL,
51		refresh_after = FALSE,
52		overwrite = FALSE,
53		serve = FALSE,
54		host = "127.0.0.1",
55		port = 3000,
56		use_local = FALSE,
57		verbose = interactive()
58		) {
59	!	if (missing(dir)) cli_abort('{.arg dir} must be speficied (e.g., dir = ".")')
60	6x	check <- check_template("datacommons", dir = dir)
61	!	if (missing(refresh_after) && !check$exists) refresh_after <- TRUE
62	6x	odir <- substitute(dir)
63	6x	dir <- normalizePath(paste0(dir, "/", check$spec$dir), "/", FALSE)
64	6x	dir.create(paste0(dir, "/repos"), FALSE, TRUE)
65	6x	dir.create(paste0(dir, "/manifest"), FALSE)
66	6x	dir.create(paste0(dir, "/cache"), FALSE)
67	6x	dir.create(paste0(dir, "/views"), FALSE)
68	6x	dir.create(paste0(dir, "/docs"), FALSE)
69	6x	dir.create(paste0(dir, "/scripts"), FALSE)
70	6x	paths <- paste0(
71	6x	dir,
72		"/",
73	6x	c(
74	6x	"commons.json",
75	6x	"README.md",
76	6x	".gitignore",
77	6x	"project.Rproj",
78	6x	"scripts/repos.txt",
79	6x	"scripts/get_repos.sh",
80	6x	"scripts/update_repos.sh",
81	6x	"docs/index.html",
82	6x	"docs/request.js"
83		)
84		)
85	!	if (overwrite) unlink(paths, TRUE)
86		if (
87	6x	file.exists(paths[5]) &&
88	6x	(!length(repos) \|\|
89	6x	(file.exists(paths[1]) && file.mtime(paths[5]) > file.mtime(paths[1])))
90		) {
91	5x	repos <- unique(c(repos, readLines(paths[5], warn = FALSE)))
92		}
93	6x	if (file.exists(paths[1])) {
94	5x	existing <- jsonlite::read_json(paths[1])
95	5x	if (missing(name)) name <- existing$name
96	!	if (!length(repos)) repos <- existing$repositories
97		}
98	6x	if (length(repos)) {
99	!	if (default_user != "") repos <- paste0(default_user, "/", repos)
100	6x	repos <- unlist(
101	6x	regmatches(repos, regexec("[^/]+/[^/#@]+$", repos)),
102	6x	use.names = FALSE
103		)
104		}
105	6x	jsonlite::write_json(
106	6x	list(name = name, repositories = repos),
107	6x	paths[1],
108	6x	auto_unbox = TRUE,
109	6x	pretty = TRUE
110		)
111	6x	if (!file.exists(paths[2])) {
112	1x	writeLines(
113	1x	c(
114	1x	paste("#", name),
115		"",
116	1x	"Consists of the repositories listed in [commons.json](commons.json).",
117		"",
118	1x	"You can clone this repository and run these commands to establish and work from local data:",
119	1x	"```R",
120	1x	'# remotes::install_github("miserman/community")',
121	1x	"library(community)",
122		"",
123	1x	"# clone and/or pull repositories and distributions:",
124	1x	'datacommons_refresh(".")',
125		"",
126	1x	"# map files:",
127	1x	'datacommons_map_files(".")',
128		"",
129	1x	"# refresh a view (rebuild a view's site data):",
130	1x	'datacommons_view(".", "view_name")',
131		"",
132	1x	"# run the monitor site locally:",
133	1x	'init_datacommons(".", serve = TRUE)',
134		"```",
135		""
136		),
137	1x	paths[2]
138		)
139		}
140	6x	if (!file.exists(paths[3])) {
141	1x	writeLines(
142	1x	c(
143	1x	".Rproj.user",
144	1x	".Rhistory",
145	1x	".Rdata",
146	1x	".httr-oauth",
147	1x	".DS_Store",
148	1x	"*.Rproj",
149	1x	"node_modules",
150	1x	"package-lock.json",
151	1x	"repos",
152	1x	"cache",
153	1x	"docs/dist",
154		""
155		),
156	1x	paths[3]
157		)
158		}
159	6x	if (!file.exists(paths[4]) && !any(grepl("\\.Rproj$", list.files(dir)))) {
160	1x	writeLines("Version: 1.0\n", paths[4])
161		}
162	6x	writeLines(if (length(repos)) Filter(nchar, repos) else "", paths[5])
163	6x	inst <- paste0(
164	6x	system.file(package = "community"),
165	6x	c("/inst", ""),
166	6x	"/templates/datacommons/"
167		)
168	6x	inst <- inst[which(file.exists(inst))[1]]
169	6x	file.copy(paste0(inst, "get_repos.sh"), paths[6], TRUE)
170	6x	file.copy(paste0(inst, "update_repos.sh"), paths[7], TRUE)
171	6x	manifest_files <- paste0(dir, "/manifest/", c("repos", "files"), ".json")
172	6x	measure_infos <- paste0(dir, "/cache/measure_info.json")
173	6x	writeLines(
174	6x	c(
175	6x	"<!doctype html>",
176	6x	'<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">',
177	6x	"<head>",
178	6x	'<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />',
179	6x	'<meta http-equiv="X-UA-Compatible" content="IE=edge,chrome=1" />',
180	6x	'<meta name="viewport" content="width=device-width,initial-scale=1" />',
181	6x	"<title>Data Commons Monitor</title>",
182	6x	'<meta name="description" content="Data commons monitoring site.">',
183	6x	unlist(lapply(
184	6x	c(
185	6x	if (use_local) {
186	!	list(
187	!	list(type = "stylesheet", src = "dist/dev/datacommons.css"),
188	!	list(type = "script", src = "dist/dev/datacommons.js")
189		)
190		} else {
191	6x	list(
192	6x	list(
193	6x	type = "stylesheet",
194	6x	src = "https://miserman.github.io/community/dist/css/datacommons.min.css"
195		),
196	6x	list(
197	6x	type = "script",
198	6x	src = "https://miserman.github.io/community/dist/js/datacommons.min.js"
199		)
200		)
201		},
202	6x	list(
203	6x	bootstrap_style = list(
204	6x	type = "stylesheet",
205	6x	src = "https://cdn.jsdelivr.net/npm/bootstrap@5.3.2/dist/css/bootstrap.min.css",
206	6x	hash = "sha384-T3c6CoIi6uLrA9TneNEoa7RxnatzjcDSCmG1MXxSR1GAsXEV/Dwwykc2MPK8M2HN"
207		),
208	6x	bootstrap = list(
209	6x	type = "script",
210	6x	src = "https://cdn.jsdelivr.net/npm/bootstrap@5.3.2/dist/js/bootstrap.bundle.min.js",
211	6x	hash = "sha384-C6RzsynM9kWDrMNeT87bh95OGNyZPhcTNXj1NW7RuBCsyN/o0jlpcV8Qyq46cDfL"
212		)
213		)
214		),
215	6x	head_import,
216	6x	dir = dir
217		)),
218	6x	paste0(
219	6x	'<meta name="generator" content="community v',
220	6x	packageVersion("community"),
221		'" />'
222		),
223	6x	paste(
224	6x	c(
225	6x	'<script type="text/javascript">',
226	6x	"var commons",
227	6x	paste0(
228	6x	"window.onload = function(){commons = new DataCommons(",
229	6x	gsub(
230	6x	"\\s+",
231		"",
232	6x	paste0(readLines(paste0(dir, "/commons.json")), collapse = "")
233		),
234		", {",
235	6x	"repos:",
236	6x	if (file.exists(manifest_files[1]))
237	6x	paste0(readLines(manifest_files[1]), collapse = "") else "{}",
238	6x	",files:",
239	6x	if (file.exists(manifest_files[2]))
240	6x	paste0(readLines(manifest_files[2]), collapse = "") else "{}",
241	6x	",variables:",
242	6x	if (file.exists(measure_infos))
243	6x	paste0(readLines(measure_infos), collapse = "") else "{}",
244		"}, ",
245	6x	jsonlite::toJSON(
246	6x	Filter(
247	6x	length,
248	6x	lapply(
249	6x	list.dirs(paste0(dir, "/views"), FALSE)[-1],
250	6x	function(v) {
251	4x	f <- paste0(dir, "/views/", v, "/", "view.json")
252	4x	if (file.exists(f))
253	4x	list(name = v, view = jsonlite::read_json(f))
254		}
255		)
256		),
257	6x	auto_unbox = TRUE
258		),
259		")}"
260		),
261	6x	"</script>"
262		),
263	6x	collapse = "\n"
264		),
265	6x	"</head>",
266	6x	"<body>",
267	6x	'<div id="site_wrap" style="position: fixed; height: 100%; width: 100%">',
268	6x	page_navbar(
269	6x	title = paste(name, "Monitor"),
270	6x	input_button("variables", id = "variables_tab_button"),
271	6x	input_button("repos", id = "repos_tab_button"),
272	6x	input_button("views", id = "views_tab_button")
273		),
274	6x	'<div class="content container-fluid">',
275	6x	"</div>",
276	6x	"</div>",
277	6x	'<noscript style="width: 100%; text-align: center; padding: 5em">Please enable JavaScript to view this site.</noscript>',
278	6x	"</body>",
279	6x	"</html>"
280		),
281	6x	paths[8]
282		)
283	6x	file.copy(paste0(inst, "request.js"), paths[9], TRUE)
284	6x	if (verbose) {
285	!	cli_bullets(c(
286	!	v = paste(if (check$exists) "updated" else "created", "{name}:"),
287	!	"*" = paste0("{.path ", normalizePath(dir, "/", FALSE), "}"),
288	!	i = if (!length(repos)) {
289	!	paste0(
290	!	"add repository names to {.file {paste0(dir, '/commons.json')}} or {.file {paste0(dir, '/scripts/repos.txt')}},",
291	!	" then use {.code datacommons_refresh(",
292	!	odir,
293	!	")} to clone them"
294		)
295		}
296		))
297		}
298	6x	if (refresh_after && length(repos))
299	1x	datacommons_refresh(dir, verbose = verbose)
300	!	if (serve) site_start_server(dir, host, port)
301	6x	invisible(dir)
302		}

1		#' Add an input rule to a website
2		#'
3		#' Specifies if-then conditions for inputs; that is, when one input is changed, change another based on
4		#' the entered conditions.
5		#'
6		#' @param condition A string representing the condition (e.g., "input_a == 'a'"), with multiple conditions
7		#' separated by \code{"&"}. If all conditions are \code{TRUE}, all \code{effects} will be set.
8		#' @param effects A list with names corresponding to input IDs, and values of what they should be set to.
9		#' @examples
10		#' \dontrun{
11		#' input_select("input_a", c("a", "b", "c"))
12		#' input_slider("input_b", c(0, 10))
13		#' input_rule("input_a == 'a' && input_b != 0", list(input_b = 10))
14		#' }
15		#' @return The entered condition and effects.
16		#' @export
17
18		input_rule <- function(condition, effects) {
19	3x	conditions <- substitute(condition)
20	!	if (!is.character(condition)) condition <- deparse(condition)
21	3x	r <- list(condition = parse_rule(condition), effects = as.list(effects))
22	3x	caller <- parent.frame()
23		if (
24	3x	!is.null(attr(caller, "name")) &&
25	3x	attr(caller, "name") == "community_site_parts"
26		) {
27	1x	caller$rules <- c(caller$rules, list(r))
28		}
29	3x	r
30		}

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(
24		dir,
25		title = "app",
26		template = "mtcars",
27		with_data = FALSE,
28		node_project = FALSE,
29		include_api = FALSE,
30		overwrite = FALSE,
31		quiet = !interactive()
32		) {
33	!	if (missing(dir)) cli_abort('{.arg dir} must be speficied (e.g., dir = ".")')
34	7x	check <- check_template("site", dir = dir)
35	7x	if (!quiet && check$exists && !overwrite) {
36	!	cli_bullets(c(
37	!	`!` = "site files already exist",
38	!	i = "add {.code overwrite = TRUE} to overwrite them"
39		))
40		}
41	7x	dir <- normalizePath(paste0(dir, "/", check$spec$dir), "/", FALSE)
42	7x	dir.create(dir, FALSE, TRUE)
43	7x	dir <- normalizePath(dir, "/", FALSE)
44	7x	paths <- paste0(
45	7x	dir,
46		"/",
47	7x	c(
48	7x	"README.md",
49	7x	"site.R",
50	7x	"package.json",
51	7x	"server.js",
52	7x	".gitignore",
53	7x	"build.R",
54	7x	"project.Rproj",
55	7x	"netlify.toml"
56		)
57		)
58	!	if (overwrite) unlink(paths, TRUE)
59	7x	if (!file.exists(paths[1])) {
60	4x	writeLines(
61	4x	c(
62	4x	paste("#", title),
63	4x	"<template: Describe the site>",
64	4x	"\n## Run",
65	4x	"```R",
66	4x	'# remotes::install_github("miserman/community")',
67	4x	"library(community)",
68	4x	"\n# from the site directory:",
69	4x	'site_build(".")',
70		"```"
71		),
72	4x	paths[1]
73		)
74		}
75	7x	template <- paste0(
76	7x	system.file(package = "community"),
77	7x	c("/inst", ""),
78	7x	"/templates/",
79	7x	template,
80		"/"
81		)
82	7x	template <- template[which(file.exists(template))[1]]
83	7x	if (!is.na(template)) {
84	4x	if (!file.exists(paths[2])) file.copy(paste0(template, "site.R"), paths[2])
85	3x	if (!file.exists(paths[6])) file.copy(paste0(template, "build.R"), paths[6])
86		}
87	7x	if (node_project && !file.exists(paths[3])) {
88	!	jsonlite::write_json(
89	!	list(
90	!	name = gsub("\\s+", "_", tolower(title)),
91	!	version = "1.0.0",
92	!	description = "",
93	!	main = "server.js",
94	!	directories = list(doc = "docs"),
95	!	scripts = list(start = "node server.js"),
96	!	dependencies = list(express = "latest"),
97	!	author = "",
98	!	license = "ISC"
99		),
100	!	paths[3],
101	!	auto_unbox = TRUE,
102	!	pretty = TRUE
103		)
104		}
105	7x	if (node_project && !file.exists(paths[4])) {
106	!	writeLines(
107	!	c(
108	!	"'use strict'",
109	!	"const express = require('express'), app = express()",
110	!	"app.use(express.static('docs'))",
111	!	"app.listen(3000, function () {",
112	!	" console.log('listening on port 3000')",
113		"})"
114		),
115	!	paths[4]
116		)
117		}
118	7x	if (!file.exists(paths[5])) {
119	4x	writeLines(
120	4x	c(
121	4x	".Rproj.user",
122	4x	".Rhistory",
123	4x	".Rdata",
124	4x	".httr-oauth",
125	4x	".DS_Store",
126	4x	".netlify",
127	4x	"*.Rproj",
128	4x	"node_modules",
129	4x	"package-lock.json",
130	4x	"docs/dist"
131		),
132	4x	paths[5]
133		)
134		}
135	7x	if (!file.exists(paths[7]) && !any(grepl("\\.Rproj$", list.files(dir))))
136	6x	writeLines("Version: 1.0\n", paths[7])
137	7x	if (include_api && !file.exists(paths[8])) {
138	!	writeLines(
139	!	c(
140	!	"[build]",
141	!	" publish = 'docs'",
142	!	"[[redirects]]",
143	!	" from = '/api'",
144	!	" to = '/.netlify/functions/api'",
145	!	" status = 200",
146	!	"[functions]",
147	!	" directory = 'docs/functions'"
148		),
149	!	paths[8]
150		)
151		}
152	7x	dir.create(paste0(dir, "/docs"), FALSE)
153	7x	dir.create(paste0(dir, "/docs/functions"), FALSE)
154	7x	docs <- grep("/docs/", check$files, fixed = TRUE, value = TRUE)
155	6x	if (any(!file.exists(docs))) file.create(docs[!file.exists(docs)])
156	7x	if (with_data && !file.exists(paste0(dir, "/docs/data/datapackage.json"))) {
157	2x	dir.create(paste0(dir, "/docs/data"), FALSE)
158	2x	init_data(title, dir = paste0(dir, "/docs/data"), quiet = TRUE)
159		}
160	7x	if (!quiet) {
161	!	cli_bullets(c(
162	!	v = "created a site skeleton for {title}:",
163	!	"*" = paste0("{.path ", normalizePath(dir, "/", FALSE), "}")
164		))
165	!	if (file.exists(paths[2])) navigateToFile(paths[2])
166		}
167	7x	invisible(dir)
168		}

1		#' Adds an organizational panel to a website
2		#'
3		#' Adds a panel to a website outside of the main content area.
4		#'
5		#' @param title Text to appear in the panel's header area.
6		#' @param ... Elements to appear in the panel's body area.
7		#' @param foot Content to appear in the panel's footer area.
8		#' @param position The side of the screen on which the panel appears; \code{"left"} (default) or \code{"right"}.
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_panel(
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_panel <- function(
30		title = "Side Panel",
31		...,
32		foot = NULL,
33		position = "left",
34		wraps = NA,
35		sizes = NA,
36		breakpoints = NA,
37		conditions = "",
38		id = NULL
39		) {
40	3x	caller <- parent.frame()
41	3x	building <- !is.null(attr(caller, "name")) &&
42	3x	attr(caller, "name") == "community_site_parts"
43	3x	parts <- new.env()
44	3x	attr(parts, "name") <- "community_site_parts"
45	3x	parts$uid <- caller$uid
46	3x	pid <- paste0("panel", parts$uid)
47	3x	elements <- substitute(...())
48	3x	footer <- if (missing(foot)) NULL else substitute(foot)
49	3x	n <- length(elements)
50	3x	wraps <- rep_len(wraps, n)
51	3x	sizes <- rep_len(sizes, n)
52	3x	breakpoints <- rep_len(breakpoints, n)
53	3x	conditions <- rep_len(conditions, n)
54	3x	ids <- paste0("panel", parts$uid, seq_len(n))
55	3x	title <- substitute(title)
56	3x	r <- c(
57	3x	paste0('<div class="card panel panel-', position, '" id="', pid, '">'),
58	3x	paste0(
59	3x	c('<div class="card-header">', eval(title, parts, caller), "</div>"),
60	3x	collapse = ""
61		),
62	3x	'<div class="card-body">',
63	3x	unlist(
64	3x	lapply(seq_len(n), function(i) {
65	3x	wrap <- !is.na(wraps[i]) \|\| conditions[i] != ""
66	3x	c(
67	3x	if (wrap) {
68	!	paste(
69	!	c(
70	!	'<div class="',
71	!	if (is.na(wraps[i])) "" else wraps[i],
72	!	if (!is.na(breakpoints[i])) c("-", breakpoints[i]),
73	!	if (!is.na(sizes[i])) c("-", sizes[i]),
74		'"',
75	!	if (conditions[i] != "") c(' id="', ids[i], '"'),
76		">"
77		),
78	!	collapse = ""
79		)
80		},
81	3x	eval(elements[[i]], parts, caller),
82	3x	if (wrap) "</div>"
83		)
84		}),
85	3x	use.names = FALSE
86		),
87	3x	"</div>",
88	3x	if (length(footer)) {
89	!	c(
90	!	'<div class="card-footer">',
91	!	unlist(
92	!	lapply(if (is.list(footer)) footer else list(footer), eval, parts),
93	!	use.names = FALSE
94		),
95	!	"</div>"
96		)
97		},
98	3x	paste0(
99	3x	'<button type="button" title="toggle panel" aria-controls="',
100	3x	pid,
101	3x	'" aria-expanded="true" class="btn panel-toggle">&Verbar;</button>'
102		),
103	3x	"</div>"
104		)
105	3x	if (building) {
106	1x	caller$body <- c(caller$body, r)
107	1x	for (n in names(parts))
108	2x	if (n != "content" && n != "uid")
109	!	caller[[n]] <- c(caller[[n]], parts[[n]])
110	1x	process_conditions(conditions, ids, caller)
111	1x	caller$uid <- parts$uid + 1
112		}
113	3x	r
114		}

1		#' @rdname site_build
2		#' @examples
3		#' \dontrun{
4		#' # serve a site that has already been built
5		#' # from the parent directory of a "docs" directory to be served
6		#' site_start_server(".")
7		#' }
8		#' @export
9
10		site_start_server <- function(dir, host = "127.0.0.1", port = 3000) {
11	1x	static_path <- list("/" = staticPath(paste0(dir, "/docs"), TRUE))
12	1x	server_exists <- FALSE
13	1x	for (s in listServers()) {
14	!	if (s$getHost() == host && s$getPort() == port) {
15	!	if (!identical(s$getStaticPaths(), static_path)) {
16	!	stopServer(s)
17		} else {
18	!	server_exists <- TRUE
19		}
20	!	break
21		}
22		}
23	1x	if (!server_exists) {
24	1x	s <- tryCatch(
25	1x	startServer(host, port, list(staticPaths = static_path)),
26	1x	error = function(e) NULL
27		)
28	1x	if (is.null(s)) {
29	!	cli_warn(paste0("failed to create server on ", host, ":", port))
30		}
31		}
32	1x	cli_alert_info(paste0("listening on ", host, ":", port))
33		}

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	2x	if (!overwrite && any(file.exists(paths)))
31	!	cli_abort("files exist -- set overwrite to {.code TRUE} to overwrite them")
32	2x	if (!grepl("_", name, fixed = TRUE))
33	!	cli_abort("name should be in a {.emph prefix_suffix} format")
34	2x	writeLines(
35	2x	paste0(
36	2x	"#' <template: Short, high-level description of function.>",
37	2x	"\n#'\n#' <template: Full description of function.>\n#'",
38	2x	"\n#' @param argument <template: Argument description.>",
39	2x	"\n#' @examples\n#' \\dontrun{",
40	2x	"\n#' <template: a working example for illustration; add outside of \\dontrun{} when possible>\n#' }",
41	2x	"\n#' @return <template: Description of what is returned.>",
42	2x	"\n#' @export",
43	2x	"\n\n",
44	2x	name,
45	2x	" <- function(argument){\n\n}"
46		),
47	2x	paths[1]
48		)
49	2x	writeLines(
50	2x	paste0(
51	2x	"test_that('a test has been written for ",
52	2x	name,
53	2x	"', {\n expect_true(FALSE)\n})"
54		),
55	2x	paths[2]
56		)
57	2x	msg <- c("created files for function {name}:", paste0("{.file ", paths, "}"))
58	2x	names(msg) <- c("v", rep("*", length(paths)))
59	2x	if (interactive()) {
60	!	cli_bullets(msg)
61	!	navigateToFile(paths[1])
62		}
63	2x	invisible(paths)
64		}