community coverage - 75.11%

Files
Source

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

#' 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 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) {
    dependencies <- jsonlite::read_json(system.file(
      "dependencies.json",
      package = "community"
    ))
    caller$dependencies$leaflet_style <- dependencies$leaflet$css
    caller$dependencies$leaflet <- dependencies$leaflet$js
    caller$credits$leaflet <- dependencies$leaflet$info
    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)
    if (!missing(attribution) || missing(tiles)) {
      if (!is.null(attribution$name)) {
        caller$credits[[attribution$name]] <- attribution
      } else if (!is.null(attribution[[1]]$name)) {
        for (a in attribution) {
          caller$credits[[a$name]] <- a
        }
      }
    }
    caller$uid <- caller$uid + 1
  }
  r
}

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

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

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

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

#' 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")
  dependencies <- jsonlite::read_json(system.file(
    "dependencies.json",
    package = "community"
  ))
  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 = dependencies$bootstrap$css,
            bootstrap = dependencies$bootstrap$js
          )
        ),
        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)
}

#' 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 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) {
    dependencies <- jsonlite::read_json(system.file(
      "dependencies.json",
      package = "community"
    ))
    caller$dependencies$plotly <- dependencies$plotly$js
    caller$credits$plotly <- dependencies$plotly$info
    if (plotly) {
      caller$plotly[[id]] <- options
    } else {
      caller$echarts[[id]] <- options
    }
    caller$content <- c(caller$content, r)
    caller$uid <- caller$uid + 1
  }
  r
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

#' 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 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) {
      dependencies <- jsonlite::read_json(system.file(
        "dependencies.json",
        package = "community"
      ))
      caller$dependencies$jquery <- dependencies$jquery$js
      caller$dependencies$datatables_style <- dependencies$datatable$css
      caller$dependencies$datatables <- dependencies$datatable$js
      caller$credits$datatables <- dependencies$datatable$info
    }
    if (datatables) {
      caller$datatable[[id]] <- options
    } else {
      caller$table[[id]] <- options
    }
    caller$content <- c(caller$content, r)
    caller$uid <- caller$uid + 1
  }
  r
}

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

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

#' Adds documentation of a dataset to a datapackage
#'
#' Add information about variables in a dataset to a \code{datapackage.json} metadata file.
#'
#' @param filename A character vector of paths to plain-text tabular data files, relative to \code{dir}.
#' @param meta Information about each data file. A list with a list entry for each entry in
#' \code{filename}; see details. If a single list is provided for multiple data files, it will apply to all.
#' @param packagename Package to add the metadata to; path to the \code{.json} file relative to
#' \code{dir}, or a list with the read-in version.
#' @param dir Directory in which to look for \code{filename}, and write \code{packagename}.
#' @param write Logical; if \code{FALSE}, returns the \code{paths} metadata without reading or rewriting
#' \code{packagename}.
#' @param refresh Logical; if \code{FALSE}, will retain any existing dataset information.
#' @param sha A number specifying the Secure Hash Algorithm function,
#' if \code{openssl} is available (checked with \code{Sys.which('openssl')}).
#' @param clean Logical; if \code{TRUE}, strips special characters before saving.
#' @param 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]],
      versions = get_versions(f),
      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 != ""])
  }
  names <- vapply(metadata, "[[", "", "filename")
  for (resource in package$resources) {
    if (length(resource$versions)) {
      su <- which(names %in% resource$filename)
      if (length(su)) {
        if (length(metadata[[su]]$versions)) {
          metadata[[su]]$versions <- rbind(
            metadata[[su]]$versions,
            if (is.data.frame(resource$versions)) {
              resource$versions
            } else {
              as.data.frame(do.call(cbind, resource$versions))
            }
          )
          metadata[[su]]$versions <- metadata[[su]]$versions[
            !duplicated(metadata[[su]]$versions),
          ]
        }
      }
    }
  }
  if (refresh) {
    package$resources <- metadata
  } else {
    package$resources <- c(
      metadata,
      package$resources[
        !(vapply(package$resources, "[[", "", "filename") %in% 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,
      dataframe = "columns",
      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)
}

get_versions <- function(file) {
  log <- suppressWarnings(system2(
    "git",
    c("log", "--", file),
    stdout = TRUE
  ))
  if (is.null(attr(log, "status"))) {
    log_entries <- strsplit(paste(log, collapse = "|"), "commit ")[[
      1
    ]]
    log_entries <- do.call(
      rbind,
      Filter(
        function(x) length(x) == 4L,
        strsplit(
          log_entries[log_entries != ""],
          "\\|+(?:[^:]+:)?\\s*"
        )
      )
    )
    if (length(log_entries)) {
      colnames(log_entries) <- c(
        "hash",
        "author",
        "date",
        "message"
      )
      as.data.frame(log_entries)
    }
  }
}

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

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

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

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

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

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

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

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

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

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

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

1		#' 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	3x	if (is.null(id)) {
67	2x	id <- paste0("map", caller$uid)
68		}
69	3x	if (building) {
70	1x	dependencies <- jsonlite::read_json(system.file(
71	1x	"dependencies.json",
72	1x	package = "community"
73		))
74	1x	caller$dependencies$leaflet_style <- dependencies$leaflet$css
75	1x	caller$dependencies$leaflet <- dependencies$leaflet$js
76	1x	caller$credits$leaflet <- dependencies$leaflet$info
77	1x	options$overlays_from_measures <- overlays_from_measures
78	1x	options$subto <- if (!is.null(subto) && length(subto) == 1) {
79	!	list(subto)
80		} else {
81	1x	subto
82		}
83	1x	if (is.null(options[["center"]])) {
84	1x	options$center <- c(40, -95)
85		}
86	1x	if (is.null(options[["zoom"]])) {
87	1x	options$zoom <- 4
88		}
89		if (
90	1x	!is.null(background_shapes) && is.null(options[["background_shapes"]])
91		) {
92	!	options$background_shapes <- background_shapes
93		}
94	1x	if (is.character(shapes)) {
95	!	shapes <- lapply(shapes, function(s) list(url = s))
96		}
97	1x	if (is.list(shapes) && !is.list(shapes[[1]])) {
98	!	shapes <- list(shapes)
99		}
100	1x	snames <- names(shapes)
101	1x	for (i in seq_along(shapes)) {
102	!	if (!is.null(snames[i])) {
103	!	shapes[[i]]$name <- snames[i]
104		}
105	!	if (is.null(shapes[[i]]$id_property)) shapes[[i]]$id_property <- "geoid"
106		}
107	1x	if (!is.null(overlays)) {
108	!	if (is.character(overlays)) {
109	!	overlays <- lapply(overlays, function(s) list(url = s))
110		}
111	!	if (is.list(overlays) && !is.list(overlays[[1]])) {
112	!	overlays <- list(overlays)
113		}
114	!	snames <- names(overlays)
115	!	for (i in seq_along(overlays)) {
116	!	if (!is.null(snames[i])) overlays[[i]]$name <- snames[i]
117		}
118		}
119	1x	caller$map[[id]] <- Filter(
120	1x	length,
121	1x	list(
122	1x	shapes = unname(shapes),
123	1x	overlays = unname(overlays),
124	1x	options = options,
125	1x	tiles = tiles
126		)
127		)
128		}
129	3x	r <- paste(
130	3x	c(
131	3x	'<div class="auto-output leaflet"',
132	3x	if (!is.null(dataview)) paste0('data-view="', dataview, '"'),
133	3x	if (!is.null(click)) paste0('data-click="', click, '"'),
134	3x	if (!is.null(color)) paste0('data-color="', color, '"'),
135	3x	if (!is.null(color_time)) paste0('data-colorTime="', color_time, '"'),
136	3x	paste0('id="', id, '"'),
137	3x	'data-autoType="map"></div>'
138		),
139	3x	collapse = " "
140		)
141	3x	if (building) {
142	1x	caller$content <- c(caller$content, r)
143	1x	if (!missing(attribution) \|\| missing(tiles)) {
144	1x	if (!is.null(attribution$name)) {
145	1x	caller$credits[[attribution$name]] <- attribution
146	!	} else if (!is.null(attribution[[1]]$name)) {
147	!	for (a in attribution) {
148	!	caller$credits[[a$name]] <- a
149		}
150		}
151		}
152	1x	caller$uid <- caller$uid + 1
153		}
154	3x	r
155		}

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	!	paste("", paste(names(a), paste0('"', unlist(a), '"'), sep = "="))
65		},
66		">"
67		),
68	3x	paste0("<legend>", label, "</legend>"),
69	3x	paste0(
70	3x	'<div class="auto-input" role="group" data-autoType="',
71	3x	type,
72	3x	'" id="',
73	3x	id,
74		'" ',
75	3x	if (is.character(options) && length(options) == 1) {
76	!	paste0('data-optionSource="', options, '"')
77		},
78	3x	if (!is.null(default)) {
79	3x	paste0(' data-default="', paste(default, collapse = ","), '"')
80		},
81	3x	if (!is.null(depends)) paste0(' data-depends="', depends, '"'),
82	3x	if (!is.null(note)) paste0(' aria-description="', note, '"'),
83	3x	if (!is.null(dataset)) paste0(' data-dataset="', dataset, '"'),
84	3x	if (!is.null(variable)) paste0(' data-variable="', variable, '"'),
85	3x	if (as.switch) paste0(' data-switch="', as.switch, '"'),
86	3x	if (length(a)) {
87	!	unlist(lapply(
88	!	seq_along(a),
89	!	function(i) paste0(" ", names(a)[i], '="', a[[i]], '"')
90		))
91		},
92		">"
93		),
94	3x	if (length(options) > 1) {
95	3x	unlist(
96	3x	lapply(seq_along(options), function(i) {
97	9x	c(
98	9x	paste0(
99	9x	'<div class="form-check',
100	9x	if (as.switch) " form-switch",
101		'">'
102		),
103	9x	paste0(
104	9x	'<input type="',
105	9x	type,
106	9x	'" autocomplete="off" class="form-check-input" name="',
107	9x	id,
108	9x	'_options" id="',
109	9x	id,
110	9x	"_option",
111	9x	i,
112	9x	if (as.switch) '" role="switch',
113	9x	'" value="',
114	9x	options[i],
115		'"',
116	9x	if ((multi && options[i] %in% default) \|\| i == default) {
117	9x	" checked"
118		},
119		">"
120		),
121	9x	paste0(
122	9x	'<label class="form-check-label" for="',
123	9x	id,
124	9x	"_option",
125	9x	i,
126		'">',
127	9x	display[i],
128	9x	"</label>"
129		),
130	9x	"</div>"
131		)
132		}),
133	3x	use.names = FALSE
134		)
135		},
136	3x	"</div>",
137	3x	"</fieldset>",
138	3x	"</div>"
139		)
140	3x	caller <- parent.frame()
141		if (
142	3x	!is.null(attr(caller, "name")) &&
143	3x	attr(caller, "name") == "community_site_parts"
144		) {
145	1x	caller$content <- c(caller$content, r)
146		}
147	3x	r
148		}

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

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

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

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

1		#' Add a button toggle group to a website
2		#'
3		#' Adds a group of radio-like buttons, where only one can be selected at a time.
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 Which of the options to default to; either its index or value.
9		#' @param display A display version of the options.
10		#' @param id Unique id of the element to be created.
11		#' @param ... Additional attributes to set on the element.
12		#' @param button_class Class name to add to each label (which appears as the button).
13		#' @param variable The name of a variable from which to get levels (overwritten by \code{depends}).
14		#' @param dataset The name of an included dataset, where \code{variable} should be looked for; only applies when
15		#' there are multiple datasets with the same variable name.
16		#' @param depends The id of another input on which the options depend; this will take president over \code{dataset}
17		#' and \code{variable}, depending on this type of input \code{depends} points to.
18		#' @seealso For a button to set an input or trigger a function, see \code{\link{input_button}}.
19		#' @examples
20		#' \dontrun{
21		#' input_buttongroup()
22		#' }
23		#' @return A character vector of the contents to be added.
24		#' @export
25
26		input_buttongroup <- function(
27		label,
28		options,
29		default = 0,
30		display = options,
31		id = label,
32		...,
33		button_class = NULL,
34		variable = NULL,
35		dataset = NULL,
36		depends = NULL
37		) {
38	3x	if (!is.character(options) && is.character(default)) {
39	!	default <- which(
40	!	(if (default %in% display) display else options) == default
41		)
42		}
43	3x	id <- gsub("\\s", "", id)
44	3x	a <- list(...)
45	3x	r <- c(
46	3x	'<div class="wrapper buttongroup-wrapper">',
47	3x	paste0('<label for="', id, '">', label, "</label>"),
48	3x	paste0(
49	3x	'<div class="auto-input btn-group" role="group" data-autoType="buttongroup" id="',
50	3x	id,
51		'" ',
52	3x	if (is.character(options) && length(options) == 1) {
53	!	paste0('data-optionSource="', options, '"')
54		},
55	3x	if (!is.null(default)) paste0(' data-default="', default, '"'),
56	3x	if (!is.null(depends)) paste0(' data-depends="', depends, '"'),
57	3x	if (!is.null(dataset)) paste0(' data-dataset="', dataset, '"'),
58	3x	if (!is.null(variable)) paste0(' data-variable="', variable, '"'),
59	3x	if (length(a)) {
60	!	unlist(lapply(
61	!	seq_along(a),
62	!	function(i) paste0(" ", names(a)[i], '="', a[[i]], '"')
63		))
64		},
65		">"
66		),
67	3x	if (length(options) > 1) {
68	3x	unlist(
69	3x	lapply(seq_along(options), function(i) {
70	9x	c(
71	9x	paste0(
72	9x	'<input type="radio" class="btn-check" autocomplete="off" name="',
73	9x	id,
74	9x	'_options" id="',
75	9x	id,
76	9x	"_option",
77	9x	i,
78	9x	'" value="',
79	9x	options[i],
80		'"',
81	9x	if (i == default) " checked",
82		">"
83		),
84	9x	paste0(
85	9x	'<label class="btn',
86	9x	if (!is.null(button_class)) paste("", button_class),
87	9x	'" for="',
88	9x	id,
89	9x	"_option",
90	9x	i,
91		'">',
92	9x	display[i],
93	9x	"</label>"
94		)
95		)
96		}),
97	3x	use.names = FALSE
98		)
99		},
100	3x	"</div>",
101	3x	"</div>"
102		)
103	3x	caller <- parent.frame()
104		if (
105	3x	!is.null(attr(caller, "name")) &&
106	3x	attr(caller, "name") == "community_site_parts"
107		) {
108	1x	caller$content <- c(caller$content, r)
109		}
110	3x	r
111		}

1		#' Adds a legend to a website
2		#'
3		#' Adds a legend based on a specified color palette.
4		#'
5		#' @param palette Name of an included color palette, or palette selection input;
6		#' for discrete scales, one of \code{"rdylbu7"}, \code{"orrd7"}, \code{"gnbu7"},
7		#' \code{"brbg7"}, \code{"puor7"}, \code{"prgn6"}, \code{"reds5"}, \code{"greens5"}, \code{"greys4"}, \code{"paired4"} (from
8		#' \href{https://colorbrewer2.org}{colorbrewer}); for continuous scales, one of \code{"grey"}, \code{"brown"}, \code{"purple"},
9		#' \code{"prgn"}, \code{"puor"}, \code{"rbbu"}, \code{"prgn"}, \code{"vik"} (default), or \code{"lajolla"}.
10		#' @param variable Name of a variable or ID of a variable selector to display values of. Defaults to
11		#' the \code{y} variable of \code{dataview} if one is specified.
12		#' @param dataview The ID of an \code{\link{input_dataview}} component.
13		#' @param id Unique ID of the legend element.
14		#' @param subto A vector of output IDs to receive hover events from.
15		#' @param click The ID of an input to set to an entity's ID near the current cursor location on the current scale.
16		#' @param class Class names to add to the legend element.
17		#' @param show_na Logical; if \code{FALSE}, does not add the separate section showing the color of missing values.
18		#' @examples
19		#' output_legend()
20		#' @return A character vector of the contents to be added.
21		#' @export
22
23		output_legend <- function(
24		palette = "",
25		variable = NULL,
26		dataview = NULL,
27		id = NULL,
28		click = NULL,
29		subto = NULL,
30		class = "",
31		show_na = TRUE
32		) {
33	3x	caller <- parent.frame()
34	3x	building <- !is.null(attr(caller, "name")) &&
35	3x	attr(caller, "name") == "community_site_parts"
36	3x	if (is.null(id)) {
37	3x	id <- paste0("legend", caller$uid)
38		}
39	3x	r <- c(
40	3x	if (show_na) {
41	3x	c(
42	3x	'<div class="legend-wrap">',
43	3x	'<div class="legend-na">',
44	3x	'<div class="legend-ticks"></div>',
45	3x	'<div class="legend-scale"><span class="na"></span></div>',
46	3x	'<div class="legend-summary"><p>NA</p></div>',
47	3x	"</div>"
48		)
49		},
50	3x	paste(
51	3x	c(
52	3x	'<div id="',
53	3x	id,
54	3x	'" data-autoType="legend" class="auto-output legend',
55	3x	if (class != "") c(" ", class),
56		'"',
57	3x	if (!is.null(variable)) paste0(' data-variable="', variable, '"'),
58	3x	if (!is.null(dataview)) paste0(' data-view="', dataview, '"'),
59	3x	if (!is.null(click)) paste0(' data-click="', click, '"'),
60		">"
61		),
62	3x	collapse = ""
63		),
64	3x	'<div class="legend-ticks"></div>',
65	3x	'<div class="legend-scale"></div>',
66	3x	'<div class="legend-summary"></div>',
67	3x	"</div>",
68	3x	if (show_na) "</div>"
69		)
70	3x	if (building) {
71	1x	caller$legend[[id]] <- list(palette = palette, subto = subto)
72	1x	caller$content <- c(caller$content, r)
73	1x	caller$uid <- caller$uid + 1
74		}
75	3x	r
76		}

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		#' 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	6x	if (missing(dir)) {
60	!	cli_abort('{.arg dir} must be speficied (e.g., dir = ".")')
61		}
62	6x	check <- check_template("datacommons", dir = dir)
63	6x	if (missing(refresh_after) && !check$exists) {
64	!	refresh_after <- TRUE
65		}
66	6x	odir <- substitute(dir)
67	6x	dir <- normalizePath(paste0(dir, "/", check$spec$dir), "/", FALSE)
68	6x	dir.create(paste0(dir, "/repos"), FALSE, TRUE)
69	6x	dir.create(paste0(dir, "/manifest"), FALSE)
70	6x	dir.create(paste0(dir, "/cache"), FALSE)
71	6x	dir.create(paste0(dir, "/views"), FALSE)
72	6x	dir.create(paste0(dir, "/docs"), FALSE)
73	6x	dir.create(paste0(dir, "/scripts"), FALSE)
74	6x	paths <- paste0(
75	6x	dir,
76		"/",
77	6x	c(
78	6x	"commons.json",
79	6x	"README.md",
80	6x	".gitignore",
81	6x	"project.Rproj",
82	6x	"scripts/repos.txt",
83	6x	"scripts/get_repos.sh",
84	6x	"scripts/update_repos.sh",
85	6x	"docs/index.html",
86	6x	"docs/request.js"
87		)
88		)
89	6x	if (overwrite) {
90	!	unlink(paths, TRUE)
91		}
92		if (
93	6x	file.exists(paths[5]) &&
94	6x	(!length(repos) \|\|
95	6x	(file.exists(paths[1]) && file.mtime(paths[5]) > file.mtime(paths[1])))
96		) {
97	5x	repos <- unique(c(repos, readLines(paths[5], warn = FALSE)))
98		}
99	6x	if (file.exists(paths[1])) {
100	5x	existing <- jsonlite::read_json(paths[1])
101	5x	if (missing(name)) {
102	5x	name <- existing$name
103		}
104	!	if (!length(repos)) repos <- existing$repositories
105		}
106	6x	if (length(repos)) {
107	6x	if (default_user != "") {
108	!	repos <- paste0(default_user, "/", repos)
109		}
110	6x	repos <- unlist(
111	6x	regmatches(repos, regexec("[^/]+/[^/#@]+$", repos)),
112	6x	use.names = FALSE
113		)
114		}
115	6x	jsonlite::write_json(
116	6x	list(name = name, repositories = repos),
117	6x	paths[1],
118	6x	auto_unbox = TRUE,
119	6x	pretty = TRUE
120		)
121	6x	if (!file.exists(paths[2])) {
122	1x	writeLines(
123	1x	c(
124	1x	paste("#", name),
125		"",
126	1x	"Consists of the repositories listed in [commons.json](commons.json).",
127		"",
128	1x	"You can clone this repository and run these commands to establish and work from local data:",
129	1x	"```R",
130	1x	'# remotes::install_github("miserman/community")',
131	1x	"library(community)",
132		"",
133	1x	"# clone and/or pull repositories and distributions:",
134	1x	'datacommons_refresh(".")',
135		"",
136	1x	"# map files:",
137	1x	'datacommons_map_files(".")',
138		"",
139	1x	"# refresh a view (rebuild a view's site data):",
140	1x	'datacommons_view(".", "view_name")',
141		"",
142	1x	"# run the monitor site locally:",
143	1x	'init_datacommons(".", serve = TRUE)',
144		"```",
145		""
146		),
147	1x	paths[2]
148		)
149		}
150	6x	if (!file.exists(paths[3])) {
151	1x	writeLines(
152	1x	c(
153	1x	".Rproj.user",
154	1x	".Rhistory",
155	1x	".Rdata",
156	1x	".httr-oauth",
157	1x	".DS_Store",
158	1x	"*.Rproj",
159	1x	"node_modules",
160	1x	"package-lock.json",
161	1x	"repos",
162	1x	"cache",
163	1x	"docs/dist",
164		""
165		),
166	1x	paths[3]
167		)
168		}
169	6x	if (!file.exists(paths[4]) && !any(grepl("\\.Rproj$", list.files(dir)))) {
170	1x	writeLines("Version: 1.0\n", paths[4])
171		}
172	6x	writeLines(if (length(repos)) Filter(nchar, repos) else "", paths[5])
173	6x	inst <- paste0(
174	6x	system.file(package = "community"),
175	6x	c("/inst", ""),
176	6x	"/templates/datacommons/"
177		)
178	6x	inst <- inst[which(file.exists(inst))[1]]
179	6x	file.copy(paste0(inst, "get_repos.sh"), paths[6], TRUE)
180	6x	file.copy(paste0(inst, "update_repos.sh"), paths[7], TRUE)
181	6x	manifest_files <- paste0(dir, "/manifest/", c("repos", "files"), ".json")
182	6x	measure_infos <- paste0(dir, "/cache/measure_info.json")
183	6x	dependencies <- jsonlite::read_json(system.file(
184	6x	"dependencies.json",
185	6x	package = "community"
186		))
187	6x	writeLines(
188	6x	c(
189	6x	"<!doctype html>",
190	6x	'<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">',
191	6x	"<head>",
192	6x	'<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />',
193	6x	'<meta http-equiv="X-UA-Compatible" content="IE=edge,chrome=1" />',
194	6x	'<meta name="viewport" content="width=device-width,initial-scale=1" />',
195	6x	"<title>Data Commons Monitor</title>",
196	6x	'<meta name="description" content="Data commons monitoring site.">',
197	6x	unlist(lapply(
198	6x	c(
199	6x	if (use_local) {
200	!	list(
201	!	list(type = "stylesheet", src = "dist/dev/datacommons.css"),
202	!	list(type = "script", src = "dist/dev/datacommons.js")
203		)
204		} else {
205	6x	list(
206	6x	list(
207	6x	type = "stylesheet",
208	6x	src = "https://miserman.github.io/community/dist/css/datacommons.min.css"
209		),
210	6x	list(
211	6x	type = "script",
212	6x	src = "https://miserman.github.io/community/dist/js/datacommons.min.js"
213		)
214		)
215		},
216	6x	list(
217	6x	bootstrap_style = dependencies$bootstrap$css,
218	6x	bootstrap = dependencies$bootstrap$js
219		)
220		),
221	6x	head_import,
222	6x	dir = dir
223		)),
224	6x	paste0(
225	6x	'<meta name="generator" content="community v',
226	6x	packageVersion("community"),
227		'" />'
228		),
229	6x	paste(
230	6x	c(
231	6x	'<script type="text/javascript">',
232	6x	"var commons",
233	6x	paste0(
234	6x	"window.onload = function(){commons = new DataCommons(",
235	6x	gsub(
236	6x	"\\s+",
237		"",
238	6x	paste0(readLines(paste0(dir, "/commons.json")), collapse = "")
239		),
240		", {",
241	6x	"repos:",
242	6x	if (file.exists(manifest_files[1])) {
243	5x	paste0(readLines(manifest_files[1]), collapse = "")
244		} else {
245		"{}"
246		},
247	6x	",files:",
248	6x	if (file.exists(manifest_files[2])) {
249	4x	paste0(readLines(manifest_files[2]), collapse = "")
250		} else {
251		"{}"
252		},
253	6x	",variables:",
254	6x	if (file.exists(measure_infos)) {
255	4x	paste0(readLines(measure_infos), collapse = "")
256		} else {
257		"{}"
258		},
259		"}, ",
260	6x	jsonlite::toJSON(
261	6x	Filter(
262	6x	length,
263	6x	lapply(
264	6x	list.dirs(paste0(dir, "/views"), FALSE)[-1],
265	6x	function(v) {
266	4x	f <- paste0(dir, "/views/", v, "/", "view.json")
267	4x	if (file.exists(f)) {
268	4x	list(name = v, view = jsonlite::read_json(f))
269		}
270		}
271		)
272		),
273	6x	auto_unbox = TRUE
274		),
275		")}"
276		),
277	6x	"</script>"
278		),
279	6x	collapse = "\n"
280		),
281	6x	"</head>",
282	6x	"<body>",
283	6x	'<div id="site_wrap" style="position: fixed; height: 100%; width: 100%">',
284	6x	page_navbar(
285	6x	title = paste(name, "Monitor"),
286	6x	input_button("variables", id = "variables_tab_button"),
287	6x	input_button("repos", id = "repos_tab_button"),
288	6x	input_button("views", id = "views_tab_button")
289		),
290	6x	'<div class="content container-fluid">',
291	6x	"</div>",
292	6x	"</div>",
293	6x	'<noscript style="width: 100%; text-align: center; padding: 5em">Please enable JavaScript to view this site.</noscript>',
294	6x	"</body>",
295	6x	"</html>"
296		),
297	6x	paths[8]
298		)
299	6x	file.copy(paste0(inst, "request.js"), paths[9], TRUE)
300	6x	if (verbose) {
301	!	cli_bullets(c(
302	!	v = paste(if (check$exists) "updated" else "created", "{name}:"),
303	!	"*" = paste0("{.path ", normalizePath(dir, "/", FALSE), "}"),
304	!	i = if (!length(repos)) {
305	!	paste0(
306	!	"add repository names to {.file {paste0(dir, '/commons.json')}} or {.file {paste0(dir, '/scripts/repos.txt')}},",
307	!	" then use {.code datacommons_refresh(",
308	!	odir,
309	!	")} to clone them"
310		)
311		}
312		))
313		}
314	6x	if (refresh_after && length(repos)) {
315	1x	datacommons_refresh(dir, verbose = verbose)
316		}
317	6x	if (serve) {
318	!	site_start_server(dir, host, port)
319		}
320	6x	invisible(dir)
321		}

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

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	1x	if (missing(name)) {
43	!	cli_abort("{.arg name} must be specified")
44		}
45	1x	if (missing(files)) {
46	!	cli_abort("{.arg files} must be specified")
47		}
48	1x	name <- sub("^init_", "", name)
49	1x	dir <- normalizePath(dir, "/", FALSE)
50	1x	spec <- list(
51	1x	name = name,
52	1x	context = context,
53	1x	dir = spec_dir,
54	1x	files = files
55		)
56	1x	test_path <- paste0(dir, "/tests/testthat/test-init_", name, ".R")
57	1x	template_test <- file.exists(test_path)
58	1x	init_function(paste0("init_", name), dir = dir, overwrite = overwrite)
59	1x	if (overwrite \|\| !template_test) {
60	1x	writeLines(
61	1x	paste0(
62	1x	"test_that(\"check_template passes\", {",
63	1x	"\n dir <- tempdir(TRUE)",
64	1x	"\n on.exit(unlink(dir, TRUE, TRUE))",
65	1x	if (spec$name != spec$context) {
66	!	paste0(
67	!	"\n init_",
68	!	spec$context,
69	!	"(\"test_context\", dir = dir)\n dir <- paste0(dir, \"/test_context\")"
70		)
71		},
72	1x	"\n init_",
73	1x	name,
74	1x	"(\"test_",
75	1x	name,
76	1x	"\", dir = dir)",
77	1x	"\n expect_true(check_template(\"",
78	1x	name,
79	1x	"\", \"test_",
80	1x	name,
81	1x	"\", dir = dir)$exists)",
82	1x	"\n})",
83	1x	sep = ""
84		),
85	1x	test_path
86		)
87		}
88	1x	path <- normalizePath(
89	1x	paste0(
90	1x	dir,
91	1x	if (file.exists(paste0(dir, "/inst"))) "/inst",
92	1x	"/specs/",
93	1x	name,
94	1x	".json"
95		),
96		"/",
97	1x	FALSE
98		)
99	1x	if (overwrite \|\| !file.exists(path)) {
100	1x	jsonlite::write_json(spec, path, auto_unbox = TRUE)
101		}
102	1x	if (interactive()) {
103	!	cli_bullets(c(
104	!	v = "created a spec file for {name}:",
105	!	"*" = paste0("{.file ", path, "}")
106		))
107		}
108	1x	invisible(path)
109		}

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	4x	if (is.numeric(width)) {
63	!	width <- paste0(width, "px")
64		}
65	4x	if (is.numeric(height)) {
66	!	height <- paste0(height, "px")
67		}
68	4x	r <- c(
69	4x	paste0(
70	4x	c(
71	4x	'<div data-state="',
72	4x	if (default_open) "open" else "closed",
73	4x	'" class="menu-wrapper menu-',
74	4x	position,
75		'"',
76	4x	c(
77	4x	' style="',
78	4x	position,
79		": ",
80	4x	if (default_open) 0 else paste0("-", width),
81		"; ",
82	4x	if (!is.null(height)) c("; height: ", height),
83		'"'
84		),
85		">"
86		),
87	4x	collapse = ""
88		),
89	4x	paste0(
90	4x	'<div class="menu',
91	4x	if (vertical) " col" else " row",
92	4x	if (!default_open) " hidden",
93	4x	" menu-",
94	4x	position,
95		'">'
96		),
97	4x	unlist(
98	4x	lapply(seq_len(n), function(i) {
99	4x	c(
100	4x	if (!is.na(wraps[i])) {
101	4x	paste(
102	4x	c(
103	4x	'<div class="',
104	4x	wraps[i],
105	4x	if (!is.na(breakpoints[i])) c("-", breakpoints[i]),
106	4x	if (!is.na(sizes[i])) c("-", sizes[i]),
107		'"',
108	4x	if (conditions[i] != "") paste0(' id="', ids[i], '"'),
109		">"
110		),
111	4x	collapse = ""
112		)
113		},
114	4x	eval(elements[[i]], parts),
115	4x	if (!is.na(wraps[i])) "</div>"
116		)
117		}),
118	4x	use.names = FALSE
119		),
120	4x	"</div>",
121	4x	if (collapsible) {
122	4x	paste0(
123	4x	'<button type="button" class="menu-toggle" title="',
124	4x	position,
125	4x	' menu"></button>'
126		)
127		},
128	4x	"</div>"
129		)
130	4x	if (building) {
131	2x	caller$body <- c(caller$body, r)
132	2x	for (n in names(parts)) {
133	2x	if (n != "content") caller[[n]] <- c(caller[[n]], parts[[n]])
134		}
135	2x	caller$uid <- parts$uid
136	2x	process_conditions(conditions, ids, caller)
137		}
138	4x	r
139		}

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		}
81	2x	id <- if (is.null(submenus[[i]]$id)) {
82	2x	paste0("submenu", parts$uid, i)
83		} else {
84	!	submenus[[i]]$id
85		}
86	2x	if (is.null(submenus[[i]]$name)) {
87	!	submenus[[i]]$name <- if (!is.null(names(submenus))) {
88	!	names(submenus)[i]
89		} else {
90	!	"Menu"
91		}
92		}
93	2x	r <- c(
94	2x	r,
95	2x	paste0(
96	2x	'<li class="nav-item">',
97	2x	'<button class="btn btn-link" type="button" data-bs-toggle="offcanvas" data-bs-target="#',
98	2x	id,
99	2x	'" aria-controls="',
100	2x	id,
101		'">',
102	2x	submenus[[i]]$name,
103	2x	"</button>",
104	2x	"</li>"
105		)
106		)
107	2x	has_foot <- !is.null(submenus[[i]]$foot)
108	2x	menus <- c(
109	2x	menus,
110	2x	paste(
111	2x	c(
112	2x	'<div tabindex="-1" id="',
113	2x	id,
114	2x	'" aria-labelledby="',
115	2x	id,
116	2x	'_label" class="offcanvas offcanvas-',
117	2x	if (is.null(submenus[[i]]$placement)) {
118	2x	"end"
119		} else {
120	!	submenus[[i]]$placement
121		},
122	2x	if (!is.null(submenus[[i]]$class)) paste("", submenus[[i]]$class),
123	2x	if (!is.null(submenus[[i]]$backdrop)) {
124	!	c('" data-bs-backdrop="', submenus[[i]]$backdrop)
125		},
126		'">'
127		),
128	2x	collapse = ""
129		),
130	2x	'<div class="offcanvas-header">',
131	2x	paste0(
132	2x	'<h5 class="offcanvas-title" id="',
133	2x	id,
134	2x	'_label">',
135	2x	submenus[[i]][
136	2x	if (is.null(submenus[[i]]$title)) "name" else "title"
137		],
138	2x	"</h5>"
139		),
140	2x	'<button class="btn-close text-reset" type="button" data-bs-dismiss="offcanvas" title="Close"></button>',
141	2x	"</div>",
142	2x	paste0(
143	2x	'<div class="offcanvas-body"',
144	2x	if (has_foot) ' style="bottom: 46px"',
145		">"
146		),
147	2x	unlist(
148	2x	lapply(submenus[[i]]$items[-1], eval, parts),
149	2x	use.names = FALSE
150		),
151	2x	"</div>",
152	2x	if (has_foot) {
153	!	c(
154	!	'<div class="offcanvas-footer">',
155	!	unlist(
156	!	lapply(submenus[[i]]$foot[-1], eval, parts),
157	!	use.names = FALSE
158		),
159	!	"</div>"
160		)
161		},
162	2x	"</div>"
163		)
164		} else {
165	19x	r <- c(
166	19x	r,
167	19x	paste0(
168	19x	'<li class="nav-item">',
169	19x	paste(eval(submenus[[i]]), collapse = ""),
170	19x	"</li>"
171		)
172		)
173		}
174		}
175		}
176	10x	r <- c(r, "</ul></div></div></nav>", menus)
177	10x	if (building) {
178	2x	caller$header <- r
179	2x	for (n in names(parts)) {
180	3x	if (n != "content" && n != "uid") {
181	!	caller[[n]] <- c(caller[[n]], parts[[n]])
182		}
183		}
184	2x	caller$uid <- parts$uid + 1
185		}
186	10x	r
187		}

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

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

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

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

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	21x	if (as.row) {
68	!	floating_label <- FALSE
69		}
70	21x	r <- c(
71	21x	'<div class="wrapper select-wrapper">',
72	21x	if (!floating_label) paste0('<label for="', id, '">', label, "</label>"),
73	21x	paste0(
74	21x	'<div class="',
75	21x	paste(
76	21x	c(
77	21x	if (reset_button) "input-group",
78	21x	if (floating_label) "form-floating"
79		),
80	21x	collapse = " "
81		),
82		'">'
83		),
84	21x	paste0(
85	21x	'<select class="auto-input form-select" data-autoType="select" id="',
86	21x	id,
87		'" ',
88	21x	if (is.character(options) && length(options) == 1) {
89	1x	paste0('data-optionSource="', options, '"')
90		},
91	21x	if (!is.null(default)) paste0(' data-default="', default, '"'),
92	21x	if (!is.null(note)) paste0(' aria-description="', note, '"'),
93	21x	if (!is.null(dataview)) paste0(' data-view="', dataview, '"'),
94	21x	if (!is.null(subset)) paste0(' data-subset="', subset, '"'),
95	21x	if (!is.null(selection_subset)) {
96	21x	paste0(' data-selectionSubset="', selection_subset, '"')
97		},
98	21x	if (!is.null(depends)) paste0(' data-depends="', depends, '"'),
99	21x	if (!is.null(dataset)) paste0(' data-dataset="', dataset, '"'),
100	21x	if (!is.null(variable)) paste0(' data-variable="', variable, '"'),
101	21x	if (length(a)) {
102	!	unlist(lapply(
103	!	seq_along(a),
104	!	function(i) paste0(" ", names(a)[i], '="', a[[i]], '"')
105		))
106		},
107		">"
108		),
109	21x	if (is.list(options)) {
110	1x	i <- 0
111	1x	if (is.null(names(options))) {
112	!	names(options) <- seq_along(options)
113		}
114	1x	unlist(
115	1x	lapply(names(options), function(g) {
116	2x	group <- paste0('<optgroup label="', g, '">')
117	2x	for (gi in seq_along(options[[g]])) {
118	4x	i <<- i + 1
119	4x	group <- c(
120	4x	group,
121	4x	paste0(
122	4x	'<option value="',
123	4x	options[[g]][[gi]],
124		'"',
125	4x	if (i == default) "selected",
126		">",
127	4x	display[[g]][[gi]],
128	4x	"</option>"
129		)
130		)
131		}
132	2x	c(group, "</optgroup>")
133		}),
134	1x	use.names = FALSE
135		)
136	21x	} else if (
137	21x	length(options) > 1 \|\|
138	21x	!options %in%
139	21x	c("datasets", "variables", "ids", "palettes", "overlay_properties")
140		) {
141	19x	unlist(
142	19x	lapply(seq_along(options), function(i) {
143	55x	paste0(
144	55x	'<option value="',
145	55x	options[i],
146		'"',
147	55x	if (i == default) "selected",
148		">",
149	55x	display[i],
150	55x	"</option>"
151		)
152		}),
153	19x	use.names = FALSE
154		)
155		},
156	21x	"</select>",
157	21x	if (floating_label) paste0('<label for="', id, '">', label, "</label>"),
158	21x	if (!missing(reset_button)) {
159	!	paste(
160	!	c(
161	!	'<button type="button" class="btn btn-link',
162	!	if (!is.null(button_class)) paste("", button_class),
163	!	' select-reset">',
164	!	if (is.character(reset_button)) reset_button else "Reset",
165	!	"</button>"
166		),
167	!	collapse = ""
168		)
169		},
170	21x	"</div>",
171	21x	"</div>"
172		)
173	21x	if (as.row) {
174	!	r <- to_input_row(r)
175		}
176	21x	caller <- parent.frame()
177		if (
178	21x	!is.null(attr(caller, "name")) &&
179	21x	attr(caller, "name") == "community_site_parts"
180		) {
181	17x	if (!is.null(group_feature)) {
182	!	caller$select[[id]]$group <- group_feature
183		}
184	17x	if (!is.null(filters)) {
185	!	caller$select[[id]]$filters <- as.list(filters)
186		}
187	17x	caller$content <- c(caller$content, r)
188		}
189	21x	r
190		}

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

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

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)) {
42	4x	id <- paste0("info", caller$uid)
43		}
44	4x	r <- paste0(
45	4x	'<div class="auto-output text-display',
46	4x	if (floating) ' floating"' else '"',
47	4x	if (!is.null(dataview)) paste0(' data-view="', dataview, '"'),
48	4x	' data-autoType="info" id="',
49	4x	id,
50	4x	'"></div>'
51		)
52	4x	row_style <- rep_len(row_style, length(body))
53	4x	if (building) {
54	2x	caller$content <- c(caller$content, r)
55	2x	caller$info[[id]] <- Filter(
56	2x	function(e) length(e) > 1 \|\| (length(e) && e != "" && !isFALSE(e)),
57	2x	list(
58	2x	title = if (is.null(title)) "" else title,
59	2x	body = lapply(seq_along(body), function(i) {
60	1x	list(
61	1x	name = if (is.null(names(body))) "" else names(body)[i],
62	1x	value = body[[i]],
63	1x	style = row_style[[i]]
64		)
65		}),
66	2x	default = as.list(default),
67	2x	floating = floating
68		)
69		)
70	2x	if (!is.null(dataview)) {
71	!	caller$info[[id]]$dataview <- dataview
72		}
73	2x	if (!is.null(variable)) {
74	!	caller$info[[id]]$variable <- variable
75		}
76	2x	if (!is.null(subto)) {
77	1x	caller$info[[id]]$subto <- subto
78		}
79	2x	if (variable_info) {
80	2x	caller$info[[id]]$variable_info <- variable_info
81		}
82	2x	caller$uid <- caller$uid + 1
83		}
84	4x	r
85		}

1		#' Adds a group of tabs to a website
2		#'
3		#' Adds a group of tabs, each of which contains input and/or output components.
4		#'
5		#' @param ... A separately entered list for each tab and its content. Named entries in each tab entry can be
6		#' \code{"name"} (for the text appearing in the navigation tab), \code{"id"}, \code{"class"}, and \code{"condition"}.
7		#' Unnamed entries in each list entry are considered the content to be added to the tab's pane. See examples.
8		#' @param id Unique ID of the tabgroup.
9		#' @param class A class name to add to the tabgroup.
10		#' @param condition A string representing the display condition of the entire tabgroup.
11		#' @details See the \href{https://getbootstrap.com/docs/5.1/layout/grid}{Bootstrap grid documentation}.
12		#' @examples
13		#' \dontrun{
14		#' page_tabgroup(
15		#' "Map" = list(id = "map_tab", output_map()),
16		#' "Data" = list(output_table()),
17		#' )
18		#' }
19		#' @return A character vector of the content to be added.
20		#' @export
21
22		page_tabgroup <- function(..., id = NULL, class = NULL, condition = NULL) {
23	3x	caller <- parent.frame()
24	3x	building <- !is.null(attr(caller, "name")) &&
25	3x	attr(caller, "name") == "community_site_parts"
26	3x	parts <- new.env()
27	3x	attr(parts, "name") <- "community_site_parts"
28	3x	parts$uid <- caller$uid
29	3x	elements <- substitute(...())
30	3x	n <- length(elements)
31	3x	pre <- if (!is.null(id)) id else paste0("tg", parts$uid)
32	3x	ids <- paste0(pre, seq_len(n))
33	3x	head <- rep(
34	3x	'<button type="button" data-bs-toggle="tab" aria-controls="',
35	3x	n
36		)
37	3x	body <- rep('<div role="tabpanel" aria-labelledby="', n)
38	3x	for (i in seq_along(elements)) {
39	1x	e <- elements[[i]]
40	1x	ns <- names(e)
41	1x	if (!"name" %in% ns) {
42	1x	e$name <- names(elements)[i]
43		}
44	1x	if (!"id" %in% ns) {
45	1x	e$id <- ids[i]
46		}
47	1x	if (!"class" %in% ns) {
48	1x	e$class <- ""
49		}
50	1x	if (!"condition" %in% ns) {
51	1x	e$condition <- ""
52		}
53	1x	head[i] <- paste(
54	1x	c(
55	1x	head[i],
56	1x	e$id,
57	1x	'" class="nav-link',
58	1x	if (i == 1) " active",
59	1x	if (i == 1) '" aria-current="page',
60	1x	'" data-bs-target="#',
61	1x	e$id,
62	1x	'" id="',
63	1x	e$id,
64	1x	'-tab">',
65	1x	e$name,
66	1x	"</button>"
67		),
68	1x	collapse = ""
69		)
70	1x	body[i] <- paste0(
71	1x	c(
72	1x	body[i],
73	1x	e$id,
74	1x	'-tab" class="tab-pane fade',
75	1x	if (i == 1) " show active",
76	1x	if (e$class != "") c(" ", e$class),
77	1x	'" id="',
78	1x	e$id,
79		'"',
80	1x	if (e$condition != "") c(' condition="', e$condition, '"'),
81		">",
82	1x	unlist(eval(e[names(e) == ""], parts), use.names = FALSE),
83	1x	"</div>"
84		),
85	1x	collapse = ""
86		)
87		}
88	3x	r <- c(
89	3x	"<nav>",
90	3x	paste(
91	3x	c(
92	3x	"<div",
93	3x	if (!is.null(id)) c(' id="', id, '"'),
94	3x	' class="nav nav-tabs',
95	3x	if (!is.null(class)) c(" ", class),
96		'"',
97	3x	if (!is.null(condition)) c(' condition="', condition, '"'),
98		">"
99		),
100	3x	collapse = ""
101		),
102	3x	head,
103	3x	"</div>",
104	3x	"</nav>",
105	3x	'<div class="tab-content">',
106	3x	body,
107	3x	"</div>"
108		)
109	3x	if (building) {
110	1x	caller$content <- c(caller$content, r)
111	1x	for (n in names(parts)) {
112	1x	if (n != "content" && n != "uid") {
113	!	caller[[n]] <- c(caller[[n]], parts[[n]])
114		}
115		}
116	1x	caller$uid <- parts$uid + 1
117		}
118	3x	r
119		}

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

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		}
111		}
112	1x	process_conditions(conditions, ids, caller)
113	1x	caller$uid <- parts$uid + 1
114		}
115	3x	r
116		}

1		#' Add a single switch or checkbox to a website
2		#'
3		#' Adds a single toggle, displayed as a switch or checkbox to a website.
4		#'
5		#' @param label Label of the input for the user.
6		#' @param id Unique id of the element to be created.
7		#' @param ... Additional attributes to set on the element.
8		#' @param note Text to display as a tooltip for the input.
9		#' @param default_on Logical; if \code{TRUE}, the switch will start on.
10		#' @param as.checkbox Logical; if \code{TRUE}, display the switch as a checkbox.
11		#' @examples
12		#' \dontrun{
13		#' input_switch("Label")
14		#' }
15		#' @return A character vector of the contents to be added.
16		#' @seealso For a group of switches, checkboxes, or radio buttons, use \code{\link{input_checkbox}}.
17		#' @export
18
19		input_switch <- function(
20		label,
21		id = label,
22		...,
23		note = NULL,
24		default_on = FALSE,
25		as.checkbox = FALSE
26		) {
27	3x	id <- gsub("\\s", "", id)
28	3x	a <- list(...)
29	3x	r <- c(
30	3x	paste0(
31	3x	'<div class="wrapper switch-wrapper"',
32	3x	if (length(a)) {
33	!	unlist(lapply(
34	!	seq_along(a),
35	!	function(i) paste0(" ", names(a)[i], '="', a[[i]], '"')
36		))
37		},
38		">"
39		),
40	3x	paste0('<div class="form-check', if (!as.checkbox) " form-switch", '">'),
41	3x	paste0(
42	3x	'<label class="form-check-label" for="',
43	3x	id,
44		'">',
45	3x	label,
46	3x	"</label>"
47		),
48	3x	paste0(
49	3x	'<input data-autoType="switch" type="checkbox" autocomplete="off"',
50	3x	' class="auto-input form-check-input"',
51	3x	if (!as.checkbox) ' role="switch"',
52	3x	' id="',
53	3x	id,
54		'"',
55	3x	if (!is.null(note)) paste0(' aria-description="', note, '"'),
56	3x	if (default_on) " checked",
57		">"
58		),
59	3x	"</div>",
60	3x	"</div>"
61		)
62	3x	caller <- parent.frame()
63		if (
64	3x	!is.null(attr(caller, "name")) &&
65	3x	attr(caller, "name") == "community_site_parts"
66		) {
67	1x	caller$content <- c(caller$content, r)
68		}
69	3x	r
70		}

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

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		}
94		}
95	2x	process_conditions(conditions, ids, caller)
96	2x	caller$uid <- parts$uid + 1
97		}
98	4x	r
99		}

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

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

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	5x	if (is.null(id)) {
53	4x	id <- paste0("table", caller$uid)
54		}
55	5x	defaults <- list(
56	5x	paging = TRUE,
57	5x	scrollY = 500,
58	5x	scrollX = 500,
59	5x	scrollCollapse = TRUE,
60	5x	scroller = TRUE,
61	5x	deferRender = TRUE,
62	5x	fixedColumns = TRUE,
63	5x	fixedHeader = TRUE
64		)
65	5x	if (!is.null(options$height)) {
66	!	options$scrollY <- options$height
67	!	options$height <- NULL
68		}
69	5x	so <- names(options)
70	5x	if (!datatables && (!wide \|\| (length(so) && any(so != "scrollY")))) {
71	!	cli_warn(paste(
72	!	"because {.arg datatables} is disabled, the {.arg wide} argument is ignored,",
73	!	"and all {.arg options} except {.arg options$scrollY} are ignored"
74		))
75		}
76	5x	for (n in names(defaults)) {
77	40x	if (!n %in% so) options[[n]] <- defaults[[n]]
78		}
79	5x	type <- if (datatables) "datatable" else "table"
80	5x	r <- paste(
81	5x	c(
82	5x	paste0(
83	5x	if (!datatables) {
84	1x	paste0(
85	1x	'<div class="table-wrapper" style="max-height: ',
86	1x	options$scrollY,
87	1x	if (is.numeric(options$scrollY)) "px",
88		'">'
89		)
90		},
91	5x	'<table class="auto-output tables',
92	5x	if (is.null(class)) "" else paste("", class),
93		'"'
94		),
95	5x	if (!is.null(dataview)) paste0('data-view="', dataview, '"'),
96	5x	if (!is.null(click)) paste0('data-click="', click, '"'),
97	5x	paste0(
98	5x	'id="',
99	5x	id,
100	5x	'" data-autoType="',
101	5x	type,
102	5x	'"></table>',
103	5x	if (!datatables) "</div>"
104		)
105		),
106	5x	collapse = " "
107		)
108	5x	if (building) {
109	2x	if (!is.null(variables)) {
110	1x	if (!is.character(variables) \|\| length(variables) > 1) {
111	!	if (!is.list(variables)) {
112	!	variables <- as.list(variables)
113	!	} else if (!is.list(variables[[1]])) {
114	!	variables <- list(variables)
115		}
116	!	vnames <- names(variables)
117	!	for (i in seq_along(variables)) {
118	!	if (is.null(names(variables[[i]]))) {
119	!	variables[[i]] <- list(name = variables[[i]][[1]])
120		}
121	!	if (!is.null(vnames[i])) variables[[i]]$title <- vnames[i]
122		}
123		}
124	1x	options$variables <- variables
125		}
126	2x	if (!is.null(features)) {
127	!	if (!is.character(features) \|\| length(features) > 1) {
128	!	if (!is.list(features)) {
129	!	features <- as.list(features)
130	!	} else if (!is.list(features[[1]]) && "name" %in% names(features)) {
131	!	features <- list(features)
132		}
133	!	vnames <- names(features)
134	!	for (i in seq_along(features)) {
135	!	if (is.null(names(features[[i]]))) {
136	!	features[[i]] <- list(name = features[[i]][[1]])
137		}
138	!	if (!is.null(vnames[i])) features[[i]]$title <- vnames[i]
139		}
140		}
141	!	options$features <- unname(features)
142		}
143	2x	options$subto <- if (!is.null(subto) && length(subto) == 1) {
144	!	list(subto)
145		} else {
146	2x	subto
147		}
148	2x	options$filters <- filters
149	2x	options$dataset <- dataset
150	2x	options$single_variable <- wide && length(variables) == 1
151	2x	options$wide <- if (!wide && length(variables) == 1) TRUE else wide
152	2x	if (datatables) {
153	2x	dependencies <- jsonlite::read_json(system.file(
154	2x	"dependencies.json",
155	2x	package = "community"
156		))
157	2x	caller$dependencies$jquery <- dependencies$jquery$js
158	2x	caller$dependencies$datatables_style <- dependencies$datatable$css
159	2x	caller$dependencies$datatables <- dependencies$datatable$js
160	2x	caller$credits$datatables <- dependencies$datatable$info
161		}
162	2x	if (datatables) {
163	2x	caller$datatable[[id]] <- options
164		} else {
165	!	caller$table[[id]] <- options
166		}
167	2x	caller$content <- c(caller$content, r)
168	2x	caller$uid <- caller$uid + 1
169		}
170	5x	r
171		}

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		},
125	!	if (!is.null(note)) paste0(' aria-description="', note, '"'),
126		">",
127	!	label,
128	!	"</a>"
129		)
130		} else {
131	21x	paste0(
132	21x	'<button type="button" data-autoType="button" class="auto-input btn',
133	21x	if (class != "") paste("", class),
134	21x	'" id="',
135	21x	id,
136		'"',
137	21x	if (length(target) == 1 && !is.list(target) && is.null(names(target))) {
138	19x	paste0(' data-target="', target, '"')
139		},
140	21x	if (length(a)) {
141	!	unlist(lapply(
142	!	seq_along(a),
143	!	function(i) paste0(" ", names(a)[i], '="', a[[i]], '"')
144		))
145		},
146	21x	if (!is.null(note)) paste0(' aria-description="', note, '"'),
147		">",
148	21x	label,
149	21x	"</button>"
150		)
151		},
152	21x	"</div>"
153		)
154	21x	caller <- parent.frame()
155		if (
156	21x	!is.null(attr(caller, "name")) &&
157	21x	attr(caller, "name") == "community_site_parts"
158		) {
159	1x	if (length(target) == 1 && target %in% c("export", "copy")) {
160	!	caller$button[[id]] <- Filter(
161	!	function(e) length(e) > 1 \|\| (length(e) && (!is.logical(e) \|\| e)),
162	!	list(
163	!	effects = target,
164	!	dataview = dataview,
165	!	query = query,
166	!	api = from_api
167		)
168		)
169	1x	} else if (!is.null(names(target))) {
170	1x	caller$button[[id]] <- list(effects = target)
171		}
172	1x	caller$content <- c(caller$content, r)
173		}
174	21x	r
175		}

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	5x	if (missing(filename)) {
71	!	cli_abort("{.arg filename} must be specified")
72		}
73	5x	setnames <- names(filename)
74	5x	if (file.exists(filename[[1]])) {
75	2x	if (dir == ".") {
76	2x	dir <- dirname(filename[[1]])
77		}
78	2x	filename <- basename(filename)
79		}
80		if (
81	5x	check_template("site", dir = dir)$status[["strict"]] &&
82	5x	all(file.exists(paste0(dir, "/docs/data/", filename)))
83		) {
84	!	dir <- paste0(dir, "/docs/data")
85		}
86	5x	if (any(!file.exists(paste0(dir, "/", filename)))) {
87	!	filename <- filename[!file.exists(filename)]
88	!	cli_abort("{?a file/files} did not exist: {filename}")
89		}
90	5x	package <- if (
91	5x	is.character(packagename) && file.exists(paste0(dir, "/", packagename))
92		) {
93	2x	paste0(dir, "/", packagename)
94		} else {
95	3x	packagename
96		}
97	5x	if (write) {
98	3x	if (is.character(package)) {
99	3x	package <- paste0(dir, "/", packagename)
100	3x	package <- if (file.exists(package)) {
101	2x	packagename <- package
102	2x	jsonlite::read_json(package)
103		} else {
104	1x	init_data(
105	1x	if (!is.null(setnames)) setnames[[1]] else filename[[1]],
106	1x	dir = dir
107		)
108		}
109		}
110	3x	if (!is.list(package)) {
111	!	cli_abort(c(
112	!	"{.arg package} does not appear to be in the right format",
113	!	i = "this should be (or be read in from JSON as) a list with a {.code resource} entry"
114		))
115		}
116		}
117	5x	if (!is.list(package)) {
118	2x	package <- list()
119		}
120	5x	collect_metadata <- function(file) {
121	5x	f <- paste0(dir, "/", filename[[file]])
122	5x	m <- if (single_meta) meta else metas[[file]]
123	5x	format <- if (grepl(".parquet", f, fixed = TRUE)) {
124	!	"parquet"
125	5x	} else if (grepl(".csv", f, fixed = TRUE)) {
126	5x	"csv"
127	5x	} else if (grepl(".rds", f, fixed = TRUE)) {
128	!	"rds"
129		} else {
130	!	"tsv"
131		}
132	5x	if (is.na(format)) {
133	!	format <- "rds"
134		}
135	5x	info <- file.info(f)
136	5x	metas <- list()
137	5x	unpack_meta <- function(n) {
138	18x	if (!length(m[[n]])) {
139	17x	list()
140	1x	} else if (is.list(m[[n]][[1]])) {
141	!	m[[n]]
142		} else {
143	1x	list(m[[n]])
144		}
145		}
146	5x	ids <- unpack_meta("ids")
147	5x	idvars <- NULL
148	5x	for (i in seq_along(ids)) {
149	1x	if (is.list(ids[[i]])) {
150	5x	if (
151	1x	length(ids[[i]]$map) == 1 &&
152	1x	is.character(ids[[i]]$map) &&
153	1x	file.exists(ids[[i]]$map)
154		) {
155	!	ids[[i]]$map_content <- paste(
156	!	readLines(ids[[i]]$map, warn = FALSE),
157	!	collapse = ""
158		)
159		}
160		} else {
161	!	ids[[i]] <- list(variable = ids[[i]])
162		}
163	1x	if (!ids[[i]]$variable %in% idvars) idvars <- c(idvars, ids[[i]]$variable)
164		}
165	5x	data <- if (format == "rds") {
166	!	tryCatch(readRDS(f), error = function(e) NULL)
167	5x	} else if (format == "parquet") {
168	!	tryCatch(read_parquet(f), error = function(e) NULL)
169		} else {
170	5x	attempt_read(f, c("geography", "time", idvars))
171		}
172	5x	if (is.null(data)) {
173	!	cli_abort(c(
174	!	paste0("failed to read in the data file ({.file {f}})"),
175	!	i = "check that it is in a compatible format"
176		))
177		}
178	5x	if (!all(rownames(data) == seq_len(nrow(data)))) {
179	!	data <- cbind(`_row` = rownames(data), data)
180		}
181	5x	timevar <- unlist(unpack_meta("time"))
182	5x	times <- if (is.null(timevar)) rep(1, nrow(data)) else data[[timevar]]
183	5x	times_unique <- unique(times)
184	5x	if (!single_meta) {
185	3x	varinf <- unpack_meta("variables")
186	3x	if (length(varinf) == 1 && is.character(varinf[[1]])) {
187	!	if (!file.exists(varinf[[1]])) {
188	!	varinf[[1]] <- paste0(dir, "/", varinf[[1]])
189		}
190	!	if (file.exists(varinf[[1]])) {
191	!	if (varinf[[1]] %in% names(metas)) {
192	!	varinf <- metas[[varinf[[1]]]]
193		} else {
194	!	varinf <- metas[[varinf[[1]]]] <- data_measure_info(
195	!	varinf[[1]],
196	!	write = FALSE,
197	!	render = TRUE
198		)
199		}
200	!	varinf <- varinf[varinf != ""]
201		}
202		}
203	3x	varinf_full <- names(varinf)
204	3x	varinf_suf <- sub("^[^:]+:", "", varinf_full)
205		}
206	5x	res <- list(
207	5x	bytes = as.integer(info$size),
208	5x	encoding = stri_enc_detect(f)[[1]][1, 1],
209	5x	md5 = md5sum(f)[[1]],
210	5x	format = format,
211	5x	name = if (!is.null(setnames)) {
212	1x	setnames[file]
213	5x	} else if (!is.null(m$name)) {
214	!	m$name
215		} else {
216	4x	sub("\\.[^.]*$", "", basename(filename[[file]]))
217		},
218	5x	filename = filename[[file]],
219	5x	versions = get_versions(f),
220	5x	source = unpack_meta("source"),
221	5x	ids = ids,
222	5x	id_length = if (length(idvars)) {
223	1x	id_lengths <- nchar(data[[idvars[1]]])
224	1x	id_lengths <- id_lengths[!is.na(id_lengths)]
225	1x	if (all(id_lengths == id_lengths[1])) id_lengths[1] else 0
226		} else {
227	4x	0
228		},
229	5x	time = timevar,
230	5x	profile = "data-resource",
231	5x	created = as.character(info$mtime),
232	5x	last_modified = as.character(info$ctime),
233	5x	row_count = nrow(data),
234	5x	entity_count = if (length(idvars)) {
235	1x	length(unique(data[[idvars[1]]]))
236		} else {
237	4x	nrow(data)
238		},
239	5x	schema = list(
240	5x	fields = lapply(
241	5x	if (summarize_ids) {
242	!	colnames(data)
243		} else {
244	5x	colnames(data)[!colnames(data) %in% idvars]
245		},
246	5x	function(cn) {
247	59x	v <- data[[cn]]
248	59x	invalid <- !is.finite(v)
249	59x	r <- list(name = cn, duplicates = sum(duplicated(v)))
250	59x	if (!single_meta) {
251	36x	if (cn %in% varinf_full) {
252	!	r$info <- varinf[[cn]]
253	36x	} else if (cn %in% varinf_suf) {
254	!	r$info <- varinf[[which(varinf_suf == cn)]]
255		}
256	36x	r$info <- r$info[r$info != ""]
257		}
258	59x	su <- !is.na(v)
259	59x	if (any(su)) {
260	59x	r$time_range <- which(times_unique %in% range(times[su])) - 1
261	59x	r$time_range <- if (length(r$time_range)) {
262	59x	r$time_range[c(1, length(r$time_range))]
263		} else {
264	!	c(-1, -1)
265		}
266		} else {
267	!	r$time_range <- c(-1, -1)
268		}
269	59x	if (!is.character(v) && all(invalid)) {
270	!	r$type <- "unknown"
271	!	r$missing <- length(v)
272	59x	} else if (is.numeric(v)) {
273	55x	r$type <- if (all(invalid \| as.integer(v) == v)) {
274	30x	"integer"
275		} else {
276	25x	"float"
277		}
278	55x	r$missing <- sum(invalid)
279	55x	r$mean <- round(mean(v, na.rm = TRUE), 6)
280	55x	r$sd <- round(sd(v, na.rm = TRUE), 6)
281	55x	r$min <- round(min(v, na.rm = TRUE), 6)
282	55x	r$max <- round(max(v, na.rm = TRUE), 6)
283		} else {
284	4x	r$type <- "string"
285	4x	if (!is.factor(v)) {
286	4x	v <- as.factor(as.character(v))
287		}
288	4x	r$missing <- sum(is.na(v) \| is.nan(v) \| grepl("^[\\s.-]$", v))
289	4x	r$table <- structure(as.list(tabulate(v)), names = levels(v))
290		}
291	59x	r
292		}
293		)
294		)
295		)
296	5x	if (!single_meta && "_references" %in% names(varinf)) {
297	!	res[["_references"]] <- varinf[["_references"]]
298		}
299	5x	if (Sys.which("openssl") != "") {
300	5x	res[[paste0("sha", sha)]] <- calculate_sha(f, sha)
301		}
302	5x	res
303		}
304	5x	single_meta <- FALSE
305	5x	metas <- if (!is.null(names(meta))) {
306	2x	if (!is.null(setnames) && all(setnames %in% names(meta))) {
307	!	meta[setnames]
308		} else {
309	2x	single_meta <- TRUE
310	2x	if (length(meta$variables) == 1 && is.character(meta$variables)) {
311	!	if (!file.exists(meta$variables)) {
312	!	meta$variables <- paste0(dir, "/", meta$variables)
313		}
314	!	if (file.exists(meta$variables)) {
315	!	meta$variables <- jsonlite::read_json(meta$variables)
316		}
317		}
318	2x	meta$variables <- replace_equations(meta$variables)
319	2x	meta
320		}
321		} else {
322	3x	meta[seq_along(filename)]
323		}
324	5x	if (!single_meta) {
325	3x	metas <- lapply(metas, function(m) {
326	3x	m$variables <- replace_equations(m$variables)
327	3x	m
328		})
329		}
330	5x	metadata <- lapply(seq_along(filename), collect_metadata)
331	5x	if (single_meta) {
332	2x	package$measure_info <- lapply(meta$variables, function(e) e[e != ""])
333		}
334	5x	names <- vapply(metadata, "[[", "", "filename")
335	5x	for (resource in package$resources) {
336	1x	if (length(resource$versions)) {
337	!	su <- which(names %in% resource$filename)
338	!	if (length(su)) {
339	!	if (length(metadata[[su]]$versions)) {
340	!	metadata[[su]]$versions <- rbind(
341	!	metadata[[su]]$versions,
342	!	if (is.data.frame(resource$versions)) {
343	!	resource$versions
344		} else {
345	!	as.data.frame(do.call(cbind, resource$versions))
346		}
347		)
348	!	metadata[[su]]$versions <- metadata[[su]]$versions[
349	!	!duplicated(metadata[[su]]$versions),
350		]
351		}
352		}
353		}
354		}
355	5x	if (refresh) {
356	5x	package$resources <- metadata
357		} else {
358	!	package$resources <- c(
359	!	metadata,
360	!	package$resources[
361	!	!(vapply(package$resources, "[[", "", "filename") %in% names)
362		]
363		)
364		}
365	5x	if (clean) {
366	!	cf <- lma_dict("special", perl = TRUE, as.function = gsub)
367	!	package <- jsonlite::fromJSON(cf(jsonlite::toJSON(
368	!	package,
369	!	auto_unbox = TRUE
370		)))
371		}
372	5x	if (write) {
373	3x	packagename <- if (is.character(packagename)) {
374	3x	packagename
375		} else {
376	!	"datapackage.json"
377		}
378	3x	jsonlite::write_json(
379	3x	package,
380	3x	if (file.exists(packagename)) {
381	2x	packagename
382		} else {
383	1x	paste0(dir, "/", packagename)
384		},
385	3x	auto_unbox = TRUE,
386	3x	digits = 6,
387	3x	dataframe = "columns",
388	3x	pretty = pretty
389		)
390	3x	if (verbose) {
391	!	cli_bullets(c(
392	!	v = paste(
393	!	if (refresh) "updated resource in" else "added resource to",
394	!	"datapackage.json:"
395		),
396	!	"*" = paste0("{.path ", packagename, "}")
397		))
398	!	if (open_after) navigateToFile(packagename)
399		}
400		}
401	5x	invisible(package)
402		}
403
404		get_versions <- function(file) {
405	5x	log <- suppressWarnings(system2(
406	5x	"git",
407	5x	c("log", "--", file),
408	5x	stdout = TRUE
409		))
410	5x	if (is.null(attr(log, "status"))) {
411	!	log_entries <- strsplit(paste(log, collapse = "\|"), "commit ")[[
412	!	1
413		]]
414	!	log_entries <- do.call(
415	!	rbind,
416	!	Filter(
417	!	function(x) length(x) == 4L,
418	!	strsplit(
419	!	log_entries[log_entries != ""],
420	!	"\\\|+(?:[^:]+:)?\\s*"
421		)
422		)
423		)
424	!	if (length(log_entries)) {
425	!	colnames(log_entries) <- c(
426	!	"hash",
427	!	"author",
428	!	"date",
429	!	"message"
430		)
431	!	as.data.frame(log_entries)
432		}
433		}
434		}

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

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