dcf coverage - 84.62%

Files
Source

#' Run a Project's Build Process
#'
#' Build a Data Collection Framework project,
#' which involves processing and checking all data projects.
#'
#' @param project_dir Path to the Data Collection Framework project to be built.
#' @param is_auto Logical; if \code{FALSE}, will run \code{\link{dcf_process}} as if it were run
#' manually.
#' @param ... Passes arguments to \code{\link{dcf_process}}.
#' @param make_diagram Logical; if \code{FALSE}, will not make a \code{status.md} diagram.
#' @param make_file_log Logical; if \code{FALSE}, will not make a \code{file_log.json} output.
#' @returns A version of the project report, which is also written to
#' \code{project_dir/docs/report.json.gz}.
#' @examples
#' project_file <- "../../../pophive"
#' if (file.exists(project_file)) {
#'   report <- dcf_build(project_file)
#' }
#' @export

dcf_build <- function(
  project_dir = ".",
  is_auto = TRUE,
  ...,
  make_diagram = TRUE,
  make_file_log = TRUE
) {
  settings <- dcf_read_settings(project_dir)
  data_dir <- paste0(project_dir, "/", settings$data_dir)
  processes <- list.files(
    data_dir,
    "process\\.json",
    recursive = TRUE,
    full.names = TRUE
  )
  process_state <- tools::md5sum(processes)
  process <- dcf_process(project_dir = project_dir, is_auto = TRUE, ...)
  issues <- dcf_check(project_dir = project_dir)
  report_file <- paste0(project_dir, "/report.json.gz")
  if (
    !identical(
      process_state,
      tools::md5sum(list.files(
        data_dir,
        "process\\.json",
        recursive = TRUE,
        full.names = TRUE
      ))
    )
  ) {
    datapackages <- list.files(
      data_dir,
      "datapackage\\.json",
      recursive = TRUE,
      full.names = TRUE
    )
    names(datapackages) <- dirname(sub(
      "^/",
      "",
      sub(data_dir, "", datapackages, fixed = TRUE)
    ))
    names(processes) <- dirname(sub(
      "^/",
      "",
      sub(data_dir, "", processes, fixed = TRUE)
    ))
    report <- list(
      date = Sys.time(),
      settings = settings,
      source_times = process$timings,
      logs = process$logs,
      issues = issues,
      metadata = lapply(datapackages, jsonlite::read_json),
      processes = lapply(processes, jsonlite::read_json)
    )
    jsonlite::write_json(
      report,
      gzfile(report_file),
      auto_unbox = TRUE,
      dataframe = "columns"
    )
  } else {
    report <- jsonlite::read_json(report_file)
  }
  if (make_file_log) {
    file_log <- list()
    for (file_dir in names(report$metadata)) {
      if (grepl("/dist", file_dir, fixed = TRUE)) {
        p <- report$metadata[[file_dir]]
        for (p_file in p$resources) {
          file_log[[paste0(
            settings$data_dir,
            "/",
            file_dir,
            "/",
            p_file$filename
          )]] <- list(
            updated = p_file$last_modified,
            md5 = p_file$md5
          )
        }
      }
    }
    jsonlite::write_json(
      file_log,
      paste0(project_dir, "/file_log.json"),
      auto_unbox = TRUE
    )
  }
  if (make_diagram) {
    dcf_status_diagram(project_dir)
  }
  invisible(report)
}

#' Download CDC WISQARS Reports
#'
#' Download reports data from the CDC's
#' \href{https://wisqars.cdc.gov/reports}{Web-based Injury Statistics Query and Reporting System}.
#'
#' @param file File to save the report to (\code{csv} or \code{parquet}).
#' @param year_start Earliest year to include.
#' @param year_end Latest year to include.
#' @param geography State or region code.
#' @param intent Intent ID or name:
#' \tabular{lll}{
#'   \code{0} \tab \code{all} \tab All \cr
#'   \code{1} \tab \code{unintentional} \tab Unintentional \cr
#'   \code{2} \tab \code{suicide} \tab Suicide \cr
#'   \code{3} \tab \code{homicide} \tab Homicide \cr
#'   \code{4} \tab \code{homicide_legal} \tab Homicide and Legal Intervention \cr
#'   \code{5} \tab \code{undetermined} \tab Undetermined \cr
#'   \code{6} \tab \code{legal} \tab Legal Intervention \cr
#'   \code{8} \tab \code{violence} \tab Violence-related \cr
#' }
#' @param disposition Patient disposition given nonfatal: one or multiple of \code{all} (0),
#' \code{treated} (1; treated and released), \code{transfered} (2), \code{hospitalized} (3), or
#' \code{observed} (4; observed/left AMA/unknown).
#' @param mechanism Mechanism code; default to \code{20810} (all injury).
#' Other codes appear in the URL in the \code{m} parameter when submitting the filter.
#' @param group_ages Logical; if \code{FALSE}, will not group ages into 5-year bins.
#' @param age_min Youngest age to include.
#' @param age_max Oldest age to include.
#' @param sex Sex groups to include: one or multiple of \code{all} (0), \code{male} (1),
#' \code{female} (2), or \code{unknown} (3)..
#' @param race Race groups to include: one or multiple of \code{all} (0), \code{white} (1),
#' \code{black} (2), \code{aa} (3; American Indian or Alaska Native), \code{asian} (4),
#' \code{pi} (5; Hawaiian Native or Pacific Islander), \code{more} (6; more than one race).
#' These levels apply if \code{race_reporting} is \code{single} (default) -- provide
#' these by index for other \code{race_reporting} levels.
#' @param race_reporting How to group race groups, between \code{none} (0), \code{bridge} (1),
#' \code{single} (2), or \code{aapi} (3).
#' @param ethnicity Which ethnic groups to include: one or multiple of \code{all} (0),
#' \code{non_hispanic} (1), \code{hispanic} (2), or \code{unknown} (3).
#' @param YPLL Age to use when calculating Years of Potential Life Lost.
#' @param metro Region type filter: \code{TRUE} for only metropolitan / urban, or \code{FALSE}
#' for only non-metropolitan / rural. Will include all region types if \code{NULL} (default).
#' @param group_by One or more variables to group by. These are uppercased and sometimes
#' abbreviated or encoded; see the \code{r1} through \code{r4} URL parameters.
#' @param fatal_outcome Logical; if \code{FALSE}, will return non-fatal results.
#' @param brain_ingury_only Logical; if \code{TRUE}, will return only traumatic brain injury results.
#' @param include_total Logical; if \code{FALSE}, will not include totals.
#' @param verbose Logical; if \code{FALSE}, will not display status messages.
#' @returns A list containing the parameters of the request. The returned data are written to \code{file}.
#' @examples
#' file <- "../../../wisqars.csv.xz"
#' if (file.exists(file)) {
#'   dcf_download_wisqars(file, verbose = FALSE)
#'   vroom::vroom(file)
#' }
#' @export

dcf_download_wisqars <- function(
  file,
  fatal_outcome = TRUE,
  brain_injury_only = FALSE,
  year_start = 2018,
  year_end = year_start,
  geography = "00",
  intent = "all",
  disposition = "all",
  mechanism = if (fatal_outcome) 20810 else 3000,
  group_ages = NULL,
  age_min = 0,
  age_max = 199,
  sex = "all",
  race = "all",
  race_reporting = "single",
  ethnicity = "all",
  YPLL = 65,
  metro = NULL,
  group_by = NULL,
  include_total = FALSE,
  verbose = TRUE
) {
  intents <- list(
    all = 0,
    unintentional = 1,
    violence = 8,
    homicide_legal = 4,
    homicide = 3,
    legal = 6,
    suicide = 2,
    undetermined = 5
  )
  dispositions <- list(
    all = 0,
    treated = 1,
    transfered = 2,
    hospitalized = 3,
    observed = 4
  )
  sexes <- list(
    all = 0,
    male = 1,
    female = 2,
    unknown = 3
  )
  races <- list(
    all = 0,
    white = 1,
    black = 2,
    aa = 3,
    asian = 4,
    pi = 5,
    more = 6
  )
  race_reportings <- list(
    none = 0,
    bridge = 1,
    single = 2,
    aapi = 3
  )
  ethnicities <- list(
    all = 0,
    non_hispanic = 1,
    hispanic = 2,
    unknown = 3
  )
  if (missing(group_ages) && (!missing(age_min) || !missing(age_max))) {
    group_ages <- FALSE
  }
  params <- list(
    TotalLine = if (include_total) "YES" else "NO",
    intent = if (is.character(intent)) intents[[tolower(intent)]] else 0L,
    mech = mechanism,
    sex = paste(
      vapply(sex, function(l) if (is.character(l)) sexes[[l]] else l, 0),
      collapse = ","
    ),
    race = paste(
      vapply(race, function(l) if (is.character(l)) sexes[[l]] else l, 0),
      collapse = ","
    ),
    race_yr = if (is.character(race_reporting))
      race_reportings[[race_reporting]] else race_reporting,
    year1 = year_start,
    year2 = year_end,
    agebuttn = if (is.null(group_ages)) "ALL" else if (group_ages) "5Yr" else
      "custom",
    fiveyr1 = age_min,
    fiveyr2 = age_max,
    c_age1 = age_min,
    c_age2 = age_max,
    groupby1 = "NONE",
    groupby2 = "NONE",
    groupby3 = "NONE",
    groupby4 = "NONE",
    groupby5 = "NONE",
    groupby6 = "NONE"
  )
  if (fatal_outcome) {
    params$state <- geography
    params$ethnicty <- paste(
      vapply(
        ethnicity,
        function(l) if (is.character(l)) ethnicities[[l]] else l,
        0
      ),
      collapse = ","
    )
    params$ypllage <- YPLL
    params$urbrul <- if (is.null(metro)) 0 else if (metro) 1 else 2
    params$tbi <- if (brain_injury_only) 1L else 0L
  } else {
    params$groupby1 <- "NONE1"
    params$groupby2 <- "NONE2"
    params$groupby3 <- "NONE3"
    params$groupby4 <- "NONE4"
    params$groupby5 <- "NONE5"
    params$groupby6 <- "NONE6"
    params$outcome <- "NFI"
    params$racethn <- 0
    params$disp <- paste(
      vapply(
        disposition,
        function(l) if (is.character(l)) dispositions[[l]] else l,
        0
      ),
      collapse = ","
    )
  }
  for (group in seq_along(group_by)) {
    params[[paste0("groupby", group)]] <- toupper(group_by[[group]])
  }
  params <- lapply(params, as.character)
  if (fatal_outcome) {
    params$app_id <- 1002
    params$component_id <- 1000
  }

  if (verbose) {
    url <- paste0(
      "https://wisqars.cdc.gov/reports/?o=",
      if (fatal_outcome) "MORT" else "NFI"
    )
    if (!fatal_outcome) {
      url <- paste0(url, "&g=00&me=")
    }
    url_param_map <- list(
      year1 = "y1",
      year2 = "y2",
      tbi = "t",
      disp = "d",
      state = "g",
      ethnicty = "e",
      intent = "i",
      mech = "m",
      sex = "s",
      race = "r",
      agebuttn = "a",
      urbrul = "me",
      race_yr = "ry",
      ypllage = "yp",
      fiveyr1 = "g1",
      fiveyr2 = "g2",
      c_age1 = "a1",
      c_age2 = "a2",
      groupby1 = "r1",
      groupby2 = "r2",
      groupby3 = "r3",
      groupby4 = "r4",
      groupby5 = "r5",
      groupby6 = "r6"
    )
    for (k in names(params)) {
      url_key <- url_param_map[[k]]
      if (!is.null(url_key)) {
        for (value in params[[k]]) url <- paste0(url, "&", url_key, "=", value)
      }
    }
    cli::cli_alert_info("requesting report {.url {url}}")
  }

  handler <- curl::new_handle()
  curl::handle_setheaders(handler, "Content-Type" = "application/json")
  curl::handle_setopt(
    handler,
    copypostfields = jsonlite::toJSON(
      list(parameters = params),
      auto_unbox = TRUE
    )
  )
  req <- curl::curl_fetch_memory(
    paste0(
      "https://wisqars.cdc.gov/api/cost-",
      if (fatal_outcome) "fatal" else "nonfatal"
    ),
    handle = handler
  )
  if (req$status_code == 200) {
    dir.create(dirname(file), FALSE, TRUE)
    data <- jsonlite::fromJSON(rawToChar(req$content))
    if (!length(data)) {
      cli::cli_warn("no rows in data, so no file written")
    } else {
      if (grepl("parquet", file)) {
        arrow::write_parquet(data, file, compression = "gzip")
      } else {
        vroom::vroom_write(data, file, ",")
      }
    }
  } else {
    cli::cli_abort("request failed: {req$status_code}")
  }
  invisible(params)
}

#' Make a Status Diagram
#'
#' Make a Data Collection Project status diagram.
#'
#' @param project_dir Path to the Data Collection Framework project to be built.
#' @param out_file File name of the file to write within \code{project_dir}.
#' @returns A character vector of the status diagram, which is also written to
#' the \code{project_dir/status.md} file.
#' @examples
#' \dontrun{
#'   dcf_status_diagram("project_directory")
#' }
#' @export

dcf_status_diagram <- function(project_dir = ".", out_file = "status.md") {
  report_file <- paste0(project_dir, "/report.json.gz")
  if (!file.exists(report_file)) {
    cli::cli_abort("no report file found")
  }
  report <- jsonlite::read_json(report_file)
  data_dir <- if (is.null(report$settings$data_dir)) "data" else
    report$settings$data_dir
  branch <- if (is.null(report$settings$branch)) "main" else
    report$settings$branch
  repo <- if (report$settings$github_account == "") {
    NULL
  } else {
    paste0(report$settings$github_account, "/", report$settings$repo_name)
  }
  indent <- "    "
  d <- c(
    'classDef pass stroke:#66bb6a',
    'classDef warn stroke:#ffa726',
    'classDef fail stroke:#f44336'
  )
  sources <- NULL
  source_ids <- list()
  file_ids <- NULL
  relationships <- NULL
  projects <- NULL
  node_id <- 0L
  for (name in names(sort(vapply(
    report$processes,
    function(p) !is.null(p$type) && p$type == "bundle",
    TRUE
  )))) {
    timing <- report$source_times[[name]]
    issues <- report$issues[[name]]
    if (length(issues))
      names(issues) <- sub(
        paste0(data_dir, "/"),
        "",
        sub(
          paste0(project_dir, "/"),
          "",
          sub("^\\.*/", "", names(issues)),
          fixed = TRUE
        ),
        fixed = TRUE
      )
    metas <- report$metadata[grep(
      paste0("^", name, "/"),
      names(report$metadata)
    )]
    measures <- if (length(metas)) metas[[1L]]$measure_info else list()
    process <- report$processes[[name]]
    contents <- NULL
    if (!is.null(process$type) && process$type == "bundle") {
      dist_files <- grep(
        "measure_info",
        names(process$dist_state),
        value = TRUE,
        invert = TRUE
      )
      for (filename in sub(
        paste0("^[./]*", data_dir, "/", name, "/(?:dist|standard)/"),
        "",
        dist_files
      )) {
        node_id <- node_id + 1L
        contents <- c(
          contents,
          paste0(
            "n",
            node_id,
            '["`',
            if (is.null(repo)) filename else
              make_link(
                paste0(
                  "https://github.com/",
                  repo,
                  "/blob/",
                  branch,
                  "/",
                  data_dir,
                  "/",
                  name,
                  "/dist/",
                  filename
                ),
                filename
              ),
            '`"]'
          )
        )
      }
      file_nodes <- file_ids[unlist(process$source_files)]
      file_nodes <- file_nodes[!is.na(file_nodes)]
      if (length(file_nodes)) {
        relationships <- c(
          relationships,
          paste0("n", file_nodes, " --> ", name)
        )
      }
    } else {
      for (project_meta in metas) {
        for (r in project_meta$resources) {
          node_id <- node_id + 1L
          file_path <- paste0(
            name,
            "/standard/",
            r$filename
          )
          file_ids[paste0(name, "/standard/", r$filename)] <- node_id
          file_issues <- issues[[file_path]]
          measure_sources <- measures[["_sources"]]
          for (field in r$schema$fields) {
            field_source <- measures[[field$name]]$sources
            if (!is.null(names(field_source)))
              field_source <- list(field_source)
            for (s in field_source) {
              if (is.character(s)) s <- list(id = s)
              if (!is.null(s$id))
                s <- if (is.null(measure_sources[[s$id]]))
                  c(s, list(name = s$id)) else c(s, measure_sources[[s$id]])
              if (is.null(source_ids[[s$name]])) {
                source_id <- paste0("s", length(source_ids))
                source_ids[[s$name]] <- source_id
                sources[[source_id]] <- list(
                  id = source_id,
                  general = make_link(s$url, s$name),
                  specific = NULL
                )
                parent_id <- source_id
              } else {
                parent_id <- source_ids[[s$name]]
              }
              if (is.null(s$location_url)) {
                source_id <- source_ids[[s$name]]
              } else {
                if (is.null(source_ids[[s$location_url]])) {
                  source_id <- paste0("s", length(source_ids))
                  source_ids[[s$location_url]] <- source_id
                  relationships <- unique(c(
                    relationships,
                    paste0(
                      parent_id,
                      "---",
                      source_id,
                      '["',
                      make_link(s$location_url, s$location),
                      '"]'
                    )
                  ))
                  sources[[parent_id]]$specific <- c(
                    sources[[parent_id]]$specific,
                    source_id
                  )
                } else {
                  source_id <- source_ids[[s$location_url]]
                }
              }
              relationships <- unique(c(
                relationships,
                paste0(source_id, " --> n", node_id)
              ))
            }
          }
          failed <- is.null(report$source_times[[name]])
          contents <- c(
            contents,
            paste0(
              "n",
              node_id,
              '["`',
              if (is.null(repo)) r$filename else
                make_link(
                  paste0(
                    "https://github.com/",
                    repo,
                    "/blob/",
                    branch,
                    "/",
                    data_dir,
                    "/",
                    name,
                    "/standard/",
                    r$filename
                  ),
                  r$filename
                ),
              if (length(file_issues))
                paste0("<br/><br/>", make_list(unlist(file_issues))),
              if (failed)
                paste0(
                  if (length(file_issues)) "<br />" else "<br /><br />",
                  "Script Failed:<br />",
                  gsub(
                    '[`"]',
                    "'",
                    paste(report$logs[[name]], collapse = "<br />")
                  )
                ),
              paste0(
                '`"]:::',
                if (failed) "fail" else if (length(file_issues)) "warn" else
                  "pass"
              )
            )
          )
        }
      }
    }
    projects <- c(
      projects,
      c(
        paste0(
          "subgraph ",
          name,
          '["`',
          if (is.null(repo)) name else
            make_link(
              paste0(
                "https://github.com/",
                repo,
                "/tree/",
                branch,
                "/",
                data_dir,
                "/",
                name
              ),
              name
            ),
          '`"]'
        ),
        paste0(indent, c("direction LR", contents)),
        "end"
      )
    )
  }
  out <- c(
    "```mermaid",
    "flowchart LR",
    paste0(
      indent,
      c(
        d,
        vapply(
          sources,
          function(s) paste(c(s$id, '(("', s$general, '"))'), collapse = ""),
          ""
        ),
        projects,
        relationships
      )
    ),
    "```"
  )
  if (is.character(out_file) && out_file != "") {
    writeLines(out, paste0(project_dir, "/", out_file))
  }
  invisible(out)
}

make_link <- function(url, name = NULL) {
  paste0(
    '<strong><a href="',
    url,
    '" target="_blank" rel="noreferrer">',
    if (is.null(name)) sub("https?://(?:www\\.)?", "", url) else name,
    "</a></strong>"
  )
}

make_list <- function(items) {
  paste0(
    "<ul>",
    paste(
      vapply(
        items,
        function(i) paste0("<li><code>", i, "</code></li>"),
        ""
      ),
      collapse = ""
    ),
    "</ul>"
  )
}

#' Adds a Source Project
#'
#' Establishes a new data source project, used to collect and prepare data from a new source.
#'
#' @param name Name of the source.
#' @param project_dir Path to the Data Collection Framework project.
#' @param open_after Logical; if \code{FALSE}, will not open the project.
#' @returns Nothing; creates default files and directories.
#' @section Project:
#'
#' Within a source project, there are two files to edits:
#' \itemize{
#'   \item \strong{\code{ingest.R}}: This is the primary script, which is automatically rerun.
#'     It should store raw data and resources in \code{raw/} where possible,
#'     then use what's in \code{raw/} to produce standard-format files in \code{standard/}.
#'     This file is sourced from its location during processing, so any system paths
#'     must be relative to itself.
#'   \item \strong{\code{measure_info.json}}: This is where you can record information
#'     about the variables included in the standardized data files.
#'     See \code{\link{dcf_measure_info}}.
#' }
#'
#' @examples
#' project_dir <- paste0(tempdir(), "/temp_project")
#' dcf_init("temp_project", dirname(project_dir))
#' dcf_add_source("source_name", project_dir)
#' list.files(paste0(project_dir, "/data/source_name"))
#'
#' @export

dcf_add_source <- function(
  name,
  project_dir = ".",
  open_after = interactive()
) {
  if (missing(name)) {
    cli::cli_abort("specify a name")
  }
  name <- gsub("[^A-Za-z0-9]+", "_", name)
  settings <- dcf_read_settings(project_dir)
  base_dir <- paste0(project_dir, "/", settings$data_dir)
  base_path <- paste0(base_dir, "/", name, "/")
  dir.create(paste0(base_path, "raw"), showWarnings = FALSE, recursive = TRUE)
  dir.create(paste0(base_path, "standard"), showWarnings = FALSE)
  paths <- paste0(
    base_path,
    c(
      "measure_info.json",
      "ingest.R",
      "project.Rproj",
      "standard/datapackage.json",
      "process.json",
      "README.md"
    )
  )
  if (!file.exists(paths[[1L]])) {
    dcf_measure_info(
      paths[[1L]],
      example_variable = list(),
      verbose = FALSE,
      open_after = FALSE
    )
  }
  if (!file.exists(paths[[2L]])) {
    writeLines(
      paste0(
        c(
          "#",
          "# Download",
          "#",
          "",
          "# add files to the `raw` directory",
          "",
          "#",
          "# Reformat",
          "#",
          "",
          "# read from the `raw` directory, and write to the `standard` directory",
          ""
        ),
        collapse = "\n"
      ),
      paths[[2L]]
    )
  }
  if (!file.exists(paths[[3L]])) {
    writeLines("Version: 1.0\n", paths[[3L]])
  }
  if (!file.exists(paths[[4L]])) {
    dcf_datapackage_init(
      name,
      dir = paste0(base_path, "standard"),
      quiet = TRUE
    )
  }

  if (!file.exists(paths[[5L]])) {
    dcf_process_record(
      paths[[5L]],
      list(
        name = name,
        type = "source",
        scripts = list(
          list(
            path = "ingest.R",
            manual = FALSE,
            frequency = 0L,
            last_run = "",
            run_time = "",
            last_status = list(log = "", success = TRUE)
          )
        ),
        checked = "",
        check_results = list()
      )
    )
  }
  if (!file.exists(paths[[6L]])) {
    writeLines(
      paste0(
        c(
          paste("#", name),
          "",
          "This is a dcf data source project, initialized with `dcf::dcf_add_source`.",
          "",
          "You can us the `dcf` package to check the project:",
          "",
          "```R",
          paste0('dcf_check_source("', name, '", "..")'),
          "```",
          "",
          "And process it:",
          "",
          "```R",
          paste0('dcf_process("', name, '", "..")'),
          "```"
        ),
        collapse = "\n"
      ),
      paths[[6L]]
    )
  }
  if (open_after) rstudioapi::openProject(paths[[3L]], newSession = TRUE)
}

#' Adds a Bundle Project
#'
#' Establishes a new data bundle project, used to prepare outputs from standardized datasets.
#'
#' @param name Name of the bundle
#' @param project_dir Path to the Data Collection Framework project.
#' @param source_files Character vector of paths to standard files form source projects.
#' @param open_after Logical; if \code{FALSE}, will not open the project.
#' @returns Nothing; creates default files and directories.
#' @section Project:
#'
#' Within a bundle project, there are two files to edits:
#' \itemize{
#'   \item \strong{\code{build.R}}: This is the primary script, which is automatically rerun.
#'     It should read data from the \code{standard} directory of source projects,
#'     and write to it's own \code{dist} directory.
#'   \item \strong{\code{measure_info.json}}: This should list all non-ID variable names
#'     in the data files within \code{dist}. These will inherit the standard measure info
#'     if found in the source projects referred to in \code{source_files}.
#'     If the \code{dist} name is different, but should still inherit standard measure info,
#'     a \code{source_id} entry with the original measure ID will be used to identify the original
#'     measure info.
#'     See \code{\link{dcf_measure_info}}.
#' }
#'
#' @examples
#' project_dir <- paste0(tempdir(), "/temp_project")
#' dcf_init("temp_project", dirname(project_dir))
#' dcf_add_bundle("bundle_name", project_dir)
#' list.files(paste0(project_dir, "/data/bundle_name"))
#'
#' @export

dcf_add_bundle <- function(
  name,
  project_dir = ".",
  source_files = NULL,
  open_after = interactive()
) {
  if (missing(name)) {
    cli::cli_abort("specify a name")
  }
  name <- gsub("[^A-Za-z0-9]+", "_", name)
  settings <- dcf_read_settings(project_dir)
  if (!is.null(source_files)) {
    su <- !file.exists(paste0(settings$data_dir, "/", source_files))
    if (any(su)) {
      cli::cli_abort(
        "source file{? doesn't/s don't} exist: {settings$data_dir[su]}"
      )
    }
  }
  base_dir <- paste(c(project_dir, settings$data_dir, name), collapse = "/")
  dir.create(paste0(base_dir, "/dist"), showWarnings = FALSE, recursive = TRUE)
  paths <- paste0(
    base_dir,
    "/",
    c(
      "README.md",
      "project.Rproj",
      "process.json",
      "measure_info.json",
      "build.R"
    )
  )
  if (!file.exists(paths[[1L]])) {
    writeLines(
      paste0(
        c(
          paste("#", name),
          "",
          "This is a Data Collection Framework data bundle project, initialized with `dcf::dcf_add_bundle`.",
          "",
          "You can us the `dcf` package to rebuild the bundle:",
          "",
          "```R",
          paste0('dcf::dcf_process("', name, '", "..")'),
          "```"
        ),
        collapse = "\n"
      ),
      paths[[1L]]
    )
  }
  if (!file.exists(paths[[2L]])) {
    writeLines("Version: 1.0\n", paths[[2L]])
  }
  if (!file.exists(paths[[3L]])) {
    jsonlite::write_json(
      list(
        name = name,
        type = "bundle",
        scripts = list(
          list(
            path = "build.R",
            last_run = "",
            run_time = "",
            last_status = list(log = "", success = TRUE)
          )
        ),
        source_files = source_files
      ),
      paths[[3L]],
      auto_unbox = TRUE,
      pretty = TRUE
    )
  }
  if (!file.exists(paths[[4L]])) {
    writeLines("{}\n", paths[[4L]])
  }
  if (!file.exists(paths[[5L]])) {
    writeLines(
      paste0(
        c(
          "# read data from data source projects",
          "# and write to this project's `dist` directory",
          ""
        ),
        collapse = "\n"
      ),
      paths[[5L]]
    )
  }
  if (open_after) rstudioapi::openProject(paths[[2L]], newSession = TRUE)
}

#' Read Epic Cosmos Data
#'
#' Read in metadata and data from an Epic Cosmos file.
#'
#' @param path Path to the file.
#' @param path_root Directory containing \code{path}, if it is not full.
#' @returns A list with \code{data.frame} entries for \code{metadata} and \code{data}.
#'
#' @examples
#' # write an example file
#' path <- tempfile(fileext = ".csv")
#' raw_lines <- c(
#'   "metadata field,metadata value,",
#'   ",,",
#'   ",Measures,Value Name",
#'   "Year,Measure 1,",
#'   "2020,m1,1",
#'   ",m2,2",
#'   "2021,m1,3",
#'   ",m2,4"
#' )
#' writeLines(raw_lines, path)
#'
#' # read it in
#' dcf_read_epic(basename(path), dirname(path))
#'
#' @export

dcf_read_epic <- function(path, path_root = ".") {
  full_path <- if (file.exists(path)) {
    path
  } else {
    sub("//", "/", paste0(path_root, "/", path), fixed = TRUE)
  }
  lines <- readLines(full_path, n = 25L, skipNul = FALSE)
  metadata_break <- grep("^[, ]*$", lines)
  if (!length(metadata_break)) {
    cli::cli_abort(
      "path does not appear to point to a file in the Epic format (no metadata separation)"
    )
  }
  meta_end <- min(metadata_break) - 1L
  data_start <- (if (length(metadata_break) == 1L) {
    metadata_break
  } else {
    max(metadata_break[
      metadata_break == c(-1L, metadata_break[-1L])
    ])
  }) +
    1L
  meta <- c(
    list(
      file = path,
      md5 = unname(tools::md5sum(full_path)),
      date_processed = Sys.time(),
      standard_name = ""
    ),
    as.list(unlist(lapply(
      strsplit(sub(",+$", "", lines[seq_len(meta_end)]), ",", fixed = TRUE),
      function(r) {
        l <- list(paste(r[-1L], collapse = ","))
        if (l[[1]] == "") {
          r <- strsplit(r, ": ", fixed = TRUE)[[1L]]
          l <- list(paste(r[-1L], collapse = ","))
        }
        names(l) <- r[[1L]]
        l[[1L]] <- gsub('^"|"$', "", l[[1L]])
        l
      }
    )))
  )
  standard_names <- c(
    vaccine_mmr = "mmr receipt",
    rsv_tests = "rsv tests",
    flu = "influenza",
    self_harm = "self-harm",
    covid = "covid",
    rsv = "rsv",
    obesity = "bmi",
    obesity = "obesity",
    hba1c = "hba1c",
    ed_opioid = "opioid",
    ed_firearm = "firearm",
    ed_workplace = "workplace",
    ed_fall = "diagnoses: fall",
    ed_drowning = "drowning",
    all_encounters = "all ed encounters",
    all_patients = "all patients"
  )
  meta_string <- tolower(paste(unlist(meta), collapse = " "))
  for (i in seq_along(standard_names)) {
    if (grepl(standard_names[[i]], meta_string, fixed = TRUE)) {
      meta$standard_name = names(standard_names)[[i]]
      break
    }
  }
  header_rows <- data_start + c(0L, 1L)
  lines[header_rows] <- gsub(
    ',(?=[^",]+")',
    "",
    lines[header_rows],
    perl = TRUE
  )
  header <- strsplit(lines[header_rows[[2L]]], ",", fixed = TRUE)[[1L]]
  id_cols <- which(header != "")
  header <- c(
    header[id_cols],
    strsplit(lines[data_start], ",", fixed = TRUE)[[1L]][-id_cols]
  )
  data <- arrow::read_csv_arrow(
    full_path,
    col_names = header,
    col_types = paste(rep("c", length(header)), collapse = ""),
    na = c("", "-"),
    skip = data_start + 1L
  )
  percents <- grep("^(?:Percent|Base|RSV test)", header, ignore.case = TRUE)
  if (length(percents)) {
    for (col in percents) {
      data[[col]] <- sub("%", "", data[[col]], fixed = TRUE)
    }
  }
  number <- grep("Number", header, fixed = TRUE)
  if (length(number)) {
    for (col in number) {
      data[[col]][data[[col]] == "10 or fewer"] <- 5L
    }
  }
  for (col in id_cols) {
    data[[col]] <- vctrs::vec_fill_missing(data[[col]], "down")
  }
  if (all(c("Measures", "Base Patient") %in% colnames(data))) {
    data <- Reduce(
      merge,
      lapply(split(data, data$Measures), function(d) {
        measure <- d$Measures[[1L]]
        d[[measure]] <- d[["Base Patient"]]
        d[, !(colnames(d) %in% c("Measures", "Base Patient"))]
      })
    )
  }
  colnames(data) <- standard_columns(colnames(data))
  if (meta$standard_name == "obesity") {
    meta$standard_name <- paste0(
      meta$standard_name,
      "_",
      if ("state" %in% colnames(data)) "state" else "county"
    )
  } else if (
    meta$standard_name == "all_encounters" && "week" %in% colnames(data)
  ) {
    meta$standard_name = "all_encounters_weekly"
  }
  if ("age" %in% colnames(data)) {
    std_age <- standard_age(data$age)
    missed_ages <- (data$age != "No value") & is.na(std_age)
    if (any(missed_ages)) {
      std_age[missed_ages] <- data$age[missed_ages]
      missed_levels <- unique(data$age[missed_ages])
      cli::cli_warn("missed age levels: {.field {missed_levels}}")
    }
    data$age <- std_age
  }
  list(metadata = meta, data = data)
}

standard_age <- function(age) {
  c(
    `less than 1` = "<1 Years",
    `1 and < 2` = "1-2 Years",
    `2 and < 3` = "2-3 Years",
    `3 and < 4` = "3-4 Years",
    `1 and < 5` = "1-4 Years",
    `1 year or more and less than 5` = "1-4 Years",
    `4 and < 5` = "4-5 Years",
    `less than 5` = "<5 Years",
    `5 and < 6` = "5-6 Years",
    `5 and < 18` = "5-17 Years",
    `5 or more and less than 18 (1)` = "5-17 Years",
    `6 and < 7` = "6-7 Years",
    `6 or more` = "6+ Years",
    `7 and < 8` = "7-8 Years",
    `8 and < 9` = "8-9 Years",
    `9 or more` = "9+ Years",
    `less than 10` = "<10 Years",
    `10 and < 15` = "10-14 Years",
    `less than 15` = "<15 Years",
    `15 and < 20` = "15-19 Years",
    `15 and < 25` = "15-25 Years",
    `less than 18` = "<18 Years",
    `18 and < 25` = "18-24 Years",
    `18 and < 40` = "18-39 Years",
    `18 and < 45` = "18-44 Years",
    `18 and < 50` = "18-49 Years",
    `18 or more and less than 50` = "18-49 Years",
    `20 and < 40` = "20-39 Years",
    `25 and < 35` = "25-34 Years",
    `25 and < 45` = "25-45 Years",
    `35 and < 45` = "35-44 Years",
    `40 and < 65` = "40-64 Years",
    `45 and < 55` = "45-54 Years",
    `45 and < 65` = "45-64 Years",
    `45-64` = "45-64 Years",
    `45 and < 65` = "45-64 Years",
    `50 and < 65` = "50-64 Years",
    `50 or more and less than 64` = "50-64 Years",
    `55 and < 65` = "55-64 Years",
    `less than 65` = "<65 Years",
    `65 and < 110` = "65+ Years",
    `65 or more` = "65+ Years",
    `65+` = "65+ Years",
    `total` = "Total"
  )[
    sub(" [Yy]ears", "", sub("^[^a-z0-9]+|:.*$", "", tolower(age)))
  ]
}

standard_columns <- function(cols) {
  cols <- gsub(" ", "_", sub("number of ", "n_", tolower(cols)), fixed = TRUE)
  cols[grep("^age", cols)] <- "age"
  cols[grep("^state", cols)] <- "state"
  cols[grep("^county", cols)] <- "county"
  cols[grep("bmi_30", cols)] <- "bmi_30_49.8"
  cols[grep("hemoglobin_a1c_7", cols)] <- "hemoglobin_a1c_7"
  cols[grep("mmr_receipt", cols)] <- "mmr_receipt"
  cols[grep("opioid", cols)] <- "ed_opioid"
  cols[grep("^rsv_tests", cols)] <- "rsv_tests"
  cols
}

#' 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 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{dcf_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
#' dcf_datapackage_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{dcf_datapackage_init}}.
#' @export

dcf_datapackage_add <- function(
  filename,
  meta = list(),
  packagename = "datapackage.json",
  dir = ".",
  write = TRUE,
  refresh = TRUE,
  sha = "512",
  pretty = FALSE,
  summarize_ids = FALSE,
  open_after = FALSE,
  verbose = interactive()
) {
  if (missing(filename)) {
    cli::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 (any(!file.exists(paste0(dir, "/", filename)))) {
    filename <- filename[!file.exists(filename)]
    cli::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 {
        dcf_datapackage_init(
          if (!is.null(setnames)) setnames[[1]] else filename[[1]],
          dir = dir
        )
      }
    }
    if (!is.list(package)) {
      cli::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()
  }
  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
    })
  }
  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(".json", f, fixed = TRUE)) {
      "json"
    } 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(arrow::read_parquet(f), error = function(e) NULL)
    } else if (format == "json") {
      tryCatch(
        as.data.frame(jsonlite::read_json(f, simplifyVector = TRUE)),
        error = function(e) NULL
      )
    } else {
      attempt_read(f, c("geography", "time", idvars))
    }
    if (is.null(data)) {
      cli::cli_warn(c(
        paste0("failed to read in the data file ({.file {f}})"),
        i = "check that it is in a compatible format"
      ))
      return(NULL)
    }
    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]]]] <- dcf_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 = stringi::stri_enc_detect(f)[[1]][1, 1],
      md5 = tools::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(stats::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"
              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
  }
  metadata <- Filter(length, 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 (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::cli_bullets(c(
        v = paste(
          if (refresh) "updated resource in" else "added resource to",
          "datapackage.json:"
        ),
        "*" = paste0("{.path ", packagename, "}")
      ))
      if (open_after) rstudioapi::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)
    }
  }
}

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"
      arrow::read_delim_arrow(
        gzfile(file),
        sep,
        col_names = cols,
        col_types = paste(types, collapse = ""),
        skip = 1
      )
    },
    error = function(e) NULL
  )
}

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 {
    ""
  }
}

#' Download Data from the CDC
#'
#' Download data and metadata from the Centers for Disease Control and Prevention (CDC).
#'
#' @param id ID of the resource (e.g., \code{ijqb-a7ye}).
#' @param out_dir Directory in which to save the metadata and data files.
#' @param state The state ID of a previous download; if provided, will only download if the
#' new state does not match.
#' @param parquet Logical; if \code{TRUE}, will convert the downloaded CSV file to Parquet.
#' @param verbose Logical; if \code{FALSE}, will not display status messages.
#' @returns The state ID of the downloaded files;
#' downloads files (\code{<id>.json} and \code{<id>.csv.xz}) to \code{out_dir}
#' @section \code{data.cdc.gov} URLs:
#'
#' For each resource ID, there are 3 relevant CDC URLs:
#' \itemize{
#'   \item \strong{\code{resource/<id>}}: This redirects to the resource's main page,
#'     with displayed metadata and a data preview
#'     (e.g., \href{https://data.cdc.gov/resource/ijqb-a7ye}{data.cdc.gov/resource/ijqb-a7ye}).
#'   \item \strong{\code{api/views/<id>}}: This is a direct link to the underlying
#'     JSON metadata (e.g., \href{https://data.cdc.gov/api/views/ijqb-a7ye}{data.cdc.gov/api/views/ijqb-a7ye}).
#'   \item \strong{\code{api/views/<id>/rows.csv}}: This is a direct link to the full
#'     CSV dataset (e.g., \href{https://data.cdc.gov/api/views/ijqb-a7ye/rows.csv}{data.cdc.gov/api/views/ijqb-a7ye/rows.csv}).
#' }
#'
#' @examples
#' \dontrun{
#'   dcf_download_cdc("ijqb-a7ye")
#' }
#' @export

dcf_download_cdc <- function(
  id,
  out_dir = "raw",
  state = NULL,
  parquet = FALSE,
  verbose = TRUE
) {
  dir.create(out_dir, showWarnings = FALSE, recursive = TRUE)
  if (verbose) {
    resource_url <- paste0("https://data.cdc.gov/resource/", id)
    cli::cli_h1(
      "downloading resource {.url {resource_url}}"
    )
  }
  url <- paste0("https://data.cdc.gov/api/views/", id)
  initial_timeout <- options(timeout = 99999L)$timeout
  on.exit(options(timeout = initial_timeout))
  if (verbose) {
    cli::cli_progress_step("metadata: {.url {url}}")
  }
  metadata_file <- paste0(tempdir(), "/", id, ".json")
  status <- utils::download.file(url, metadata_file, quiet = TRUE)
  if (status != 0L) {
    cli::cli_abort("failed to download metadata")
  }
  metadata <- jsonlite::read_json(metadata_file)
  new_state <- if (is.null(metadata$rowsUpdatedAt)) {
    as.list(tools::md5sum(metadata_file))
  } else {
    metadata$rowsUpdatedAt
  }
  if (!identical(new_state, state)) {
    file.rename(metadata_file, paste0(out_dir, "/", id, ".json"))
    data_url <- paste0(url, "/rows.csv")
    out_path <- paste0(out_dir, "/", id, ".csv")
    if (verbose) {
      cli::cli_progress_step("data: {.url {data_url}}")
    }
    status <- utils::download.file(data_url, out_path, quiet = TRUE)
    if (status != 0L) {
      cli::cli_abort("failed to download data")
    }
    if (parquet) {
      if (verbose) {
        cli::cli_progress_step("writing to Parquet")
      }
      data <- arrow::read_csv_arrow(out_path)
      arrow::write_parquet(
        data,
        compression = "gzip",
        sub(".csv", ".parquet", out_path, fixed = TRUE)
      )
      unlink(out_path)
    } else {
      if (verbose) {
        cli::cli_progress_step("compressing data")
      }
      unlink(paste0(out_path, ".xz"))
      status <- system2("xz", c("-f", out_path))
      if (status != 0L) {
        cli::cli_abort("failed to compress data")
      }
    }
    if (verbose) {
      cli::cli_progress_done()
    }
    invisible(new_state)
  } else {
    unlink(metadata_file)
    invisible(state)
  }
}

#' Run Data Project Processes
#'
#' Operates over data source and bundle projects, optionally running the source
#' ingest scripts, then collecting metadata.
#'
#' @param name Name of a source project to process. Will default to the name of the
#' current working directory.
#' @param project_dir Path to the project directory. If not specified, and being called
#' from a source project, this will be assumed to be two steps back from the working directory.
#' @param ingest Logical; if \code{FALSE}, will re-process standardized data without running
#' ingestion scripts. Only applies to source projects.
#' @param is_auto Logical; if \code{TRUE}, will skip process scripts marked as manual.
#' @param force Logical; if \code{TRUE}, will ignore process frequencies
#' (will run scripts even if recently run).
#' @param clear_state Logical; if \code{TRUE}, will clear stored states before processing.
#' @returns A list with processing results:
#' \itemize{
#'   \item \code{timings}: How many seconds the scripts took to run.
#'   \item \code{logs}: The captured output of the scripts.
#' }
#' Each entry has an entry for each project.
#'
#' A `datapackage.json` file is also created / update in each source's `standard` directory.
#' @examples
#' \dontrun{
#'   # run from a directory containing a `data` directory containing the source
#'   dcf_process("source_name")
#'
#'   # run without executing the ingestion script
#'   dcf_process("source_name", ingest = FALSE)
#' }
#' @export

dcf_process <- function(
  name = NULL,
  project_dir = ".",
  ingest = TRUE,
  is_auto = FALSE,
  force = FALSE,
  clear_state = FALSE
) {
  settings_file <- paste0(project_dir, "/settings.json")
  from_project <- file.exists(settings_file)
  if (from_project) {
    source_dir <- paste0(
      project_dir,
      "/",
      jsonlite::read_json(settings_file)$data_dir
    )
  } else {
    project_dir <- "../.."
    source_dir <- ".."
    name <- basename(getwd())
  }

  sources <- if (is.null(name)) {
    list.files(
      source_dir,
      "process\\.json",
      recursive = TRUE,
      full.names = TRUE
    )
  } else {
    process_files <- paste0(source_dir, "/", name, "/process.json")
    if (any(!file.exists(process_files))) {
      cli::cli_abort(
        "missing process file{?/s}: {.emph {process_files[!file.exists(process_files)]}}"
      )
    }
    process_files
  }
  decide_to_run <- function(process_script) {
    if (is_auto && process_script$manual) {
      return(FALSE)
    }
    if (
      force || process_script$last_run == "" || process_script$frequency == 0L
    ) {
      return(TRUE)
    }
    if (
      difftime(Sys.time(), as.POSIXct(process_script$last_run), units = "day") >
        process_script$frequency
    ) {
      return(TRUE)
    }
    FALSE
  }
  collect_env <- new.env()
  collect_env$timings <- list()
  collect_env$logs <- list()
  process_source <- function(process_file) {
    process_def <- dcf_process_record(process_file)
    if (clear_state) {
      raw_states <- grep("raw_state", names(process_def), fixed = TRUE)
      if (length(raw_states)) {
        process_def[raw_states] <- NULL
      }
      process_def$standard_state <- NULL
      dcf_process_record(process_file, process_def)
    }
    name <- process_def$name
    dcf_add_source(name, project_dir, open_after = FALSE)
    for (si in seq_along(process_def$scripts)) {
      st <- proc.time()[[3]]
      process_script <- process_def$scripts[[si]]
      run_current <- ingest && decide_to_run(process_script)
      base_dir <- dirname(process_file)
      standard_dir <- paste0(base_dir, "/standard")
      script <- paste0(base_dir, "/", process_script$path)
      file_ref <- if (run_current) paste0(" ({.emph ", script, "})") else NULL
      cli::cli_progress_step(
        paste0("processing source {.strong ", name, "}", file_ref),
        spinner = TRUE
      )
      env <- new.env()
      env$dcf_process_continue <- TRUE
      status <- if (ingest) {
        tryCatch(
          list(
            log = utils::capture.output(
              source(script, env, chdir = TRUE),
              type = "message"
            ),
            success = TRUE
          ),
          error = function(e) {
            cli::cli_warn("scripts {.file {script}} failed: {e$message}")
            list(log = e$message, success = FALSE)
          }
        )
      } else {
        list(log = "", success = TRUE)
      }
      collect_env$logs[[name]] <- status$log
      if (run_current) {
        process_script$last_run <- Sys.time()
        process_script$run_time <- proc.time()[[3]] - st
        process_script$last_status <- status
        process_def$scripts[[si]] <- process_script
      }
      if (status$success) {
        collect_env$timings[[name]] <- process_script$run_time
      }
      if (!env$dcf_process_continue) break
    }
    process_def_current <- dcf_process_record(process_file)
    if (
      is.null(process_def_current$raw_state) ||
        !identical(process_def$raw_state, process_def_current$raw_state)
    ) {
      process_def_current$scripts <- process_def$scripts
      dcf_process_record(process_file, process_def_current)
    }
    data_files <- list.files(standard_dir, "\\.(?:csv|parquet|json)")
    data_files <- data_files[!grepl("datapackage", data_files, fixed = TRUE)]
    if (length(data_files)) {
      measure_info_file <- paste0(base_dir, "/measure_info.json")
      standard_state <- as.list(tools::md5sum(c(
        measure_info_file,
        paste0(standard_dir, "/", data_files)
      )))
      if (!identical(process_def_current$standard_state, standard_state)) {
        measure_info <- dcf_measure_info(
          measure_info_file,
          include_empty = FALSE,
          render = TRUE,
          write = FALSE,
          open_after = FALSE,
          verbose = FALSE
        )
        measure_sources <- list()
        for (measure_id in names(measure_info)) {
          measure_info[[measure_id]]$id <- measure_id
          info <- measure_info[[measure_id]]
          for (s in info$sources) {
            if (
              !is.null(s$location) &&
                !(s$location %in% names(sources))
            ) {
              measure_sources[[s$location]] <- s
            }
          }
        }
        if (!file.exists(paste0(standard_dir, "/datapackage.json"))) {
          dcf_datapackage_init(name, dir = standard_dir, quiet = TRUE)
        }
        dcf_datapackage_add(
          data_files,
          meta = list(
            source = unname(measure_sources),
            base_dir = base_dir,
            ids = "geography",
            time = "time",
            variables = measure_info
          ),
          dir = standard_dir,
          pretty = TRUE,
          summarize_ids = TRUE,
          verbose = FALSE
        )
        process_def_current$standard_state <- standard_state
        dcf_process_record(process_file, process_def_current)
      }
      cli::cli_progress_done(result = if (status$success) "done" else "failed")
    } else {
      cli::cli_progress_done(result = "failed")
      cli::cli_bullets(
        c(" " = "no standard data files found in {.path {process_file}}")
      )
    }
  }
  process_bundle <- function(process_file) {
    process_def <- dcf_process_record(process_file)
    any_source_files <- length(process_def$source_files) != 0L
    if (clear_state) {
      process_def$source_state <- NULL
      process_def$dist_state <- NULL
      dcf_process_record(process_file, process_def)
    }
    name <- process_def$name
    dcf_add_bundle(name, project_dir, open_after = FALSE)
    for (si in seq_along(process_def$scripts)) {
      st <- proc.time()[[3]]
      process_script <- process_def$scripts[[si]]
      base_dir <- dirname(process_file)
      script <- paste0(base_dir, "/", process_script$path)
      run_current <- TRUE
      standard_state <- NULL
      if (any_source_files) {
        standard_files <- paste0(source_dir, "/", process_def$source_files)
        standard_state <- as.list(tools::md5sum(paste0(
          source_dir,
          "/",
          process_def$source_files
        )))
        run_current <- !identical(standard_state, process_def$source_state)
      }
      if (run_current) {
        cli::cli_progress_step(
          paste0(
            "processing bundle {.strong ",
            name,
            "} ({.emph ",
            script,
            "})"
          ),
          spinner = TRUE
        )
        env <- new.env()
        env$dcf_process_continue <- TRUE
        status <- tryCatch(
          list(
            log = utils::capture.output(
              source(script, env, chdir = TRUE),
              type = "message"
            ),
            success = TRUE
          ),
          error = function(e) {
            cli::cli_warn("scripts {.file {script}} failed: {e$message}")
            list(log = e$message, success = FALSE)
          }
        )
        collect_env$logs[[name]] <- status$log
        if (run_current) {
          process_script$last_run <- Sys.time()
          process_script$run_time <- proc.time()[[3]] - st
          process_script$last_status <- status
          process_def$scripts[[si]] <- process_script
        }
        if (status$success) {
          collect_env$timings[[name]] <- process_script$run_time
        }
        if (!env$dcf_process_continue) break
      }
    }
    process_def_current <- dcf_process_record(process_file)
    dist_dir <- paste0(base_dir, "/dist")
    dist_files <- grep(
      "datapackage",
      list.files(dist_dir, recursive = TRUE),
      fixed = TRUE,
      invert = TRUE,
      value = TRUE
    )
    if (length(dist_files)) {
      dist_state <- as.list(tools::md5sum(paste0(
        base_dir,
        "/dist/",
        dist_files
      )))
      if (!identical(process_def_current$dist_state, dist_state)) {
        process_def_current$scripts <- process_def$scripts
        process_def_current$dist_state <- dist_state
        process_def_current$standard_state <- standard_state
        dcf_process_record(process_file, process_def_current)

        # merge with standard measure infos
        measure_info <- dcf_measure_info(
          paste0(base_dir, "/measure_info.json"),
          include_empty = FALSE,
          render = TRUE,
          write = FALSE,
          open_after = FALSE,
          verbose = FALSE
        )
        if (any_source_files) {
          source_measure_info_files <- list.files(
            sub("/.*$", "", NULL),
            "datapackage\\.json",
            recursive = TRUE
          )
          if (length(source_measure_info_files)) {
            source_measure_info <- Reduce(
              c,
              lapply(
                source_measure_info_files,
                function(f) jsonlite::read_json(f)$measure_info
              )
            )
            for (measure_id in names(measure_info)) {
              info <- measure_info[[measure_id]]
              info$id <- measure_id
              source_id <- if (!is.null(info$source_id)) {
                info$source_id
              } else {
                measure_id
              }
              source_info <- source_measure_info[[source_id]]
              if (!is.null(source_info)) {
                for (entry_name in names(source_info)) {
                  if (
                    is.null(info[[entry_name]]) ||
                      (is.character(info[[entry_name]]) &&
                        info[[entry_name]] == "")
                  ) {
                    info[[entry_name]] <- source_info[[entry_name]]
                  } else if (is.list(info[[entry_name]])) {
                    info[[entry_name]] <- unique(c(
                      info[[entry_name]],
                      source_info[[entry_name]]
                    ))
                  }
                }
              }
              measure_info[[measure_id]] <- info
            }
          }
        }
        measure_sources <- list()
        for (info in measure_info) {
          for (s in info$sources) {
            if (
              is.list(s) &&
                !is.null(s$location) &&
                !(s$location %in% names(sources))
            ) {
              measure_sources[[s$location]] <- s
            }
          }
        }
        if (!file.exists(paste0(dist_dir, "/datapackage.json"))) {
          dcf_datapackage_init(name, dir = dist_dir, quiet = TRUE)
        }
        dcf_datapackage_add(
          dist_files,
          meta = list(
            source = unname(measure_sources),
            base_dir = base_dir,
            ids = "geography",
            time = "time",
            variables = measure_info
          ),
          dir = dist_dir,
          pretty = TRUE,
          summarize_ids = TRUE,
          verbose = FALSE
        )
      }
      cli::cli_progress_done(result = if (status$success) "done" else "failed")
    } else {
      cli::cli_progress_done(result = "failed")
      cli::cli_bullets(
        c(" " = "no standard data files found in {.path {process_file}}")
      )
    }
  }
  for (process_file in sources[order(
    vapply(
      sources,
      function(f) {
        type <- jsonlite::read_json(f)$type
        is.null(type) || type != "bundle"
      },
      TRUE
    ),
    decreasing = TRUE
  )]) {
    process_def <- dcf_process_record(process_file)
    if (is.null(process_def$type) || process_def$type == "source") {
      process_source(process_file)
    } else {
      process_bundle(process_file)
    }
  }
  invisible(list(timings = collect_env$timings, logs = collect_env$logs))
}

#' Standardize Epic Data
#'
#' Standardize a raw Epic data table.
#'
#' @param raw_data Raw Epic data, such as returned from \link{dcf_read_epic}.
#' @returns A standardized form of \code{data}.
#' @section Standardization:
#' \itemize{
#'   \item Collapse location columns (\code{state} or \code{county}) to a single
#'     \code{geography} column, and region names to IDs.
#'   \item Collapse time columns (\code{year}, \code{month}, or \code{week}) to a single
#'     \code{time} column, and clean up value formatting.
#'   \item Drop rows with no values across value columns.
#' }
#' @examples
#' \dontrun{
#'   raw_data <- dcf_read_epic("data/epic/raw/flu.csv.xz")
#'   standard_data <- dcf_process_epic_raw(raw_data)
#' }
#'
#' @export

dcf_standardize_epic <- function(raw_data) {
  region_names <- epic_id_maps$regions
  names(region_names) <- gsub(
    " (?:CITY AND BOROUGH|BOROUGH|PARISH|MUNICIPALITY|MUNICIPIO)|[.']",
    "",
    toupper(names(region_names))
  )
  cols <- colnames(raw_data)
  time_col <- which(cols == "year")
  if (length(time_col)) {
    colnames(raw_data)[time_col] <- "time"
    raw_data$time <- as.integer(substring(
      raw_data$time,
      0L,
      4L
    ))
  }
  month_col <- which(cols == "month")
  if (length(month_col)) {
    raw_data$time <- paste0(
      raw_data$time,
      "-",
      epic_id_maps$months[raw_data$month]
    )
  }
  week_col <- which(cols == "week")
  if (length(week_col)) {
    raw_data$time <- paste0(
      raw_data$time,
      "-",
      vapply(
        strsplit(raw_data$week, "[^A-Za-z0-9]"),
        function(p) {
          paste0(
            epic_id_maps$months[[p[[1L]]]],
            "-",
            formatC(as.integer(p[[2L]]), width = 2L, flag = "0")
          )
        },
        ""
      )
    )
  }
  geo_col <- grep("^(?:state|county)", cols)
  if (length(geo_col)) {
    colnames(raw_data)[geo_col] <- "geography"
    raw_data$geography <- toupper(raw_data$geography)
    missing_geo <- !(raw_data$geography %in% names(region_names))
    if (any(missing_geo)) {
      geo <- sub(
        "LA ",
        "LA",
        sub("^SAINT", "ST", raw_data$geography[missing_geo]),
        fixed = TRUE
      )
      if (any(grepl(", VA", geo, fixed = TRUE))) {
        geo[geo == "SALEM, VA"] <- "SALEM CITY, VA"
        geo[geo == "RADFORD, VA"] <- "RADFORD CITY, VA"
        geo[geo == "DONA ANA, NM"] <- "DO\u00d1A ANA, NM"
        geo[geo == "MATANUSKA SUSITNA, AK"] <- "MATANUSKA-SUSITNA, AK"
      }
      raw_data$geography[missing_geo] <- geo
    }
    missing_regions <- raw_data$geography[
      !(raw_data$geography %in% names(region_names))
    ]
    if (length(missing_regions)) {
      cli::cli_warn(
        'unrecognized regions: {paste(unique(missing_regions), collapse = "; ")}'
      )
    }
    raw_data$geography <- region_names[raw_data$geography]
    raw_data <- raw_data[!is.na(raw_data$geography), ]
  }
  raw_data <- raw_data[,
    !(colnames(raw_data) %in% c("state", "county", "year", "month", "week"))
  ]
  raw_data[
    rowSums(
      !is.na(raw_data[,
        !(colnames(raw_data) %in% c("geography", "time", "age"))
      ])
    ) !=
      0L,
  ]
}

#' 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{dcf_datapackage_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
#' dcf_datapackage_init("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{dcf_datapackage_add}}.
#' @export

dcf_datapackage_init <- function(
  name,
  title = name,
  dir = ".",
  ...,
  write = TRUE,
  overwrite = FALSE,
  quiet = !interactive()
) {
  if (missing(name)) {
    cli::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::cli_abort(c(
      "datapackage ({.path {package_path}}) already exists",
      i = "add {.code overwrite = TRUE} to overwrite it"
    ))
  }
  if (length(list(...))) {
    package$resources <- dcf_datapackage_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::cli_bullets(c(
        v = "created metadata template for {name}:",
        "*" = paste0("{.path ", package_path, "}")
      ))
      rstudioapi::navigateToFile(package_path)
    }
  }
  invisible(package)
}

#' Check Data Projects
#'
#' Check the data files and measure info of subprojects.
#'
#' @param names Name or names of projects.
#' @param project_dir Path to the Data Collection Framework project.
#' @param verbose Logical; if \code{FALSE}, will not print status messages.
#' @returns A list with an entry for each source, containing a character vector
#'   including any issue codes:
#' \itemize{
#'   \item \code{not_compressed}: The file does not appear to be compressed.
#'   \item \code{cant_read}: Failed to read the file in.
#'   \item \code{geography_missing}: File does not contain a \code{geography} column.
#'   \item \code{geography_nas}: The file's \code{geography} column contains NAs.
#'   \item \code{time_missing}: File does not contain a \code{time} column.
#'   \item \code{time_nas}: The file's \code{time} column contains NAs.
#'   \item \code{missing_info: {column_name}}: The file's indicated column does not have
#'     a matching entry in \code{measure_info.json}.
#' }
#' @examples
#' \dontrun{
#'   dcf_check("gtrends")
#' }
#' @export

dcf_check <- function(
  names = NULL,
  project_dir = ".",
  verbose = TRUE
) {
  if (
    is.null(names) && !file.exists(paste0(project_dir, "/", "settings.json"))
  ) {
    project_dir <- "../.."
    names <- basename(getwd())
  }

  settings <- dcf_read_settings(project_dir)
  base_dir <- paste0(project_dir, "/", settings$data_dir)
  if (is.null(names)) {
    names <- list.dirs(base_dir, recursive = FALSE, full.names = FALSE)
  }
  issues <- list()
  for (name in names) {
    source_dir <- paste0(base_dir, "/", name, "/")
    if (!dir.exists(source_dir)) {
      cli::cli_abort("specify the name of an existing data project")
    }
    process_file <- paste0(source_dir, "process.json")
    if (!file.exists(process_file)) {
      cli::cli_abort("{name} does not appear to be a data project")
    }
    process <- dcf_process_record(process_file)
    is_bundle <- !is.null(process$type) && process$type == "bundle"
    info_file <- paste0(source_dir, "measure_info.json")
    info <- tryCatch(
      dcf_measure_info(
        info_file,
        render = TRUE,
        write = FALSE,
        verbose = FALSE,
        open_after = FALSE
      ),
      error = function(e) NULL
    )
    if (is.null(info)) {
      cli::cli_abort("{.file {info_file}} is malformed")
    }
    if (verbose) {
      cli::cli_bullets(c("", "Checking project {.strong {name}}"))
    }
    data_files <- list.files(
      paste0(source_dir, if (is_bundle) "dist" else "standard"),
      "\\.(?:csv|parquet|json)",
      full.names = TRUE
    )
    data_files <- data_files[!grepl("datapackage", data_files, fixed = TRUE)]
    source_issues <- list()
    for (file in list.files(
      paste0(source_dir, "raw"),
      "csv$",
      full.names = TRUE
    )) {
      source_issues[[file]] <- list(data = "not_compressed")
    }
    if (length(data_files)) {
      for (file in data_files) {
        issue_messages <- NULL
        if (verbose) {
          cli::cli_progress_step("checking file {.file {file}}", spinner = TRUE)
        }
        data_issues <- NULL
        measure_issues <- NULL
        data <- tryCatch(
          if (grepl(".parquet", file, fixed = TRUE)) {
            dplyr::collect(arrow::read_parquet(file))
          } else if (grepl(".json", file, fixed = TRUE)) {
            as.data.frame(jsonlite::read_json(file, simplifyVector = TRUE))
          } else {
            con <- gzfile(file)
            on.exit(con)
            vroom::vroom(con, show_col_types = FALSE)
          },
          error = function(e) NULL
        )
        if (is.null(data)) {
          data_issues <- c(data_issues, "cant_read")
        } else {
          if (grepl("csv$", file)) {
            data_issues <- c(data_issues, "not_compressed")
            if (verbose) {
              issue_messages <- c(
                issue_messages,
                "file is not compressed"
              )
            }
          }
          if (!("geography" %in% colnames(data))) {
            data_issues <- c(data_issues, "geography_missing")
            if (verbose) {
              issue_messages <- c(
                issue_messages,
                "missing {.emph geography} column"
              )
            }
          } else if (anyNA(data$geography)) {
            data_issues <- c(data_issues, "geography_nas")
            if (verbose) {
              issue_messages <- c(
                issue_messages,
                "{.emph geography} column contains NAs"
              )
            }
          }
          if (!("time" %in% colnames(data))) {
            data_issues <- c(data_issues, "time_missing")
            if (verbose) {
              issue_messages <- c(
                issue_messages,
                "missing {.emph time} column"
              )
            }
          } else if (anyNA(data$time)) {
            data_issues <- c(data_issues, "time_nas")
            if (verbose) {
              issue_messages <- c(
                issue_messages,
                "{.emph time} column contains NAs"
              )
            }
          }
          for (col in colnames(data)) {
            if (!(col %in% c("geography", "time")) && !(col %in% names(info))) {
              measure_issues <- c(measure_issues, paste("missing_info:", col))
              if (verbose) {
                issue_messages <- c(
                  issue_messages,
                  paste0(
                    "{.emph ",
                    col,
                    "} column does not have an entry in measure_info"
                  )
                )
              }
            }
          }
        }
        file_issues <- list()
        if (length(data_issues)) {
          file_issues$data <- data_issues
        }
        if (length(measure_issues)) {
          file_issues$measures <- measure_issues
        }
        source_issues[[file]] <- file_issues
        if (verbose) {
          if (length(issue_messages)) {
            cli::cli_progress_done(result = "failed")
            cli::cli_bullets(structure(
              issue_messages,
              names = rep(" ", length(issue_messages))
            ))
          } else {
            cli::cli_progress_done()
          }
        }
      }
    } else {
      if (verbose) cli::cli_alert_info("no standard data files found to check")
    }
    if (!identical(process$check_results, source_issues)) {
      process$checked <- Sys.time()
      process$check_results <- source_issues
      dcf_process_record(process_file, process)
    }
    issues[[name]] <- source_issues
  }

  invisible(issues)
}

#' Process Epic Stating Files
#'
#' Process Epic stating files, lightly standardizing them and moving them to raw.
#'
#' @param staging_dir Directory containing the staging files.
#' @param out_dir Directory to write new raw files to.
#' @param verbose Logical; if \code{FALSE}, will not show status messages.
#' @param cleanup Logical; if \code{FALSE}, will not remove staging files after being processed.
#' @returns \code{NULL} if no staging files are found.
#'   Otherwise, a list with entries for \code{data} and \code{metadata}.
#'   Each of these are lists with entries for each recognized standard name,
#'   with potentially combined outputs similar to \code{\link{dcf_read_epic}}
#'
#' @examples
#' \dontrun{
#'   # run from a source project
#'   dcf_process_epic_staging()
#' }
#'
#' @export

dcf_process_epic_staging <- function(
  staging_dir = "raw/staging",
  out_dir = "raw",
  verbose = TRUE,
  cleanup = TRUE
) {
  files <- sort(list.files(
    staging_dir,
    "csv",
    full.names = TRUE,
    recursive = TRUE
  ))
  files <- files[!grepl("census", files)]
  if (!length(files)) {
    if (verbose) {
      cli::cli_progress_message("no staging files found")
    }
    return(NULL)
  }
  id_cols <- c("state", "county", "age", "year", "month", "week")
  metadata <- list()
  data <- list()
  for (file in files) {
    if (verbose) {
      cli::cli_progress_step("processing file {.file {file}}", spinner = TRUE)
    }
    epic <- tryCatch(dcf_read_epic(file), error = function(e) NULL)
    if (is.null(epic)) {
      if (verbose) {
        cli::cli_progress_done(result = "failed")
      }
      next
    }
    if (epic$metadata$standard_name == "") {
      if (verbose) {
        cli::cli_warn("failed to identify standard type for {.file {file}}")
        cli::cli_progress_done(result = "failed")
      }
      next
    }
    name <- epic$metadata$standard_name
    metadata[[name]] <- c(list(epic$metadata), metadata[[name]])
    file_id_cols <- id_cols[id_cols %in% colnames(epic$data)]
    epic$data <- epic$data[
      rowMeans(is.na(epic$data[,
        !(colnames(epic$data) %in% file_id_cols),
        drop = FALSE
      ])) !=
        1,
    ]
    n_col <- grep("^n_", colnames(epic$data))
    if (length(n_col)) {
      colnames(epic$data)[[n_col]] <- paste0("n_", epic$metadata$standard_name)
    }
    if (!is.null(data[[name]])) {
      cols <- colnames(data[[name]])
      cols <- cols[!(cols %in% colnames(epic$data))]
      if (length(cols)) {
        epic$data[, cols] <- NA
      }
      epic$data <- epic$data[, colnames(data[[name]])]
      file_id_cols <- id_cols[id_cols %in% colnames(data[[name]])]
      data[[name]] <- data[[name]][
        !(do.call(paste, data[[name]][, file_id_cols]) %in%
          do.call(paste, epic$data[, file_id_cols])),
      ]
    }
    data[[name]] <- rbind(epic$data, data[[name]])
    if (verbose) cli::cli_progress_done()
  }
  for (name in names(metadata)) {
    if (verbose) {
      cli::cli_progress_step(
        "writing standard raw output for {.field {name}}",
        spinner = TRUE
      )
    }
    paths <- paste0(out_dir, "/", name, ".", c("json", "csv.xz"))
    jsonlite::write_json(
      metadata[[name]],
      paths[[1L]],
      auto_unbox = TRUE,
      pretty = TRUE
    )
    vroom::vroom_write(data[[name]], paths[[2L]])
    if (cleanup) {
      unlink(vapply(metadata[[name]], "[[", "", "file"))
    }
    if (verbose) cli::cli_process_done()
  }
  return(list(metadata = metadata, data = data))
}

#' Update renv.lock
#'
#' Updates the \code{renv.lock} file with dependencies found in project scripts.
#'
#' @param project_dir Directory of the Data Collection project.
#' @param refresh Logical; if \code{FALSE}, will update an existing
#' \code{renv.lock} file, rather than recreating it.
#' @returns Nothing; writes an \code{renv.lock} file.
#' @examples
#' \dontrun{
#'   dcf_update_lock()
#' }
#' @export

dcf_update_lock <- function(
  project_dir = ".",
  refresh = TRUE
) {
  settings <- dcf_read_settings(project_dir)
  extra <- unique(
    renv::dependencies(list.files(
      paste0(project_dir, "/", settings$data_dir),
      "\\.[Rr]$",
      recursive = TRUE,
      full.names = TRUE
    ))$Package
  )
  not_installed <- !(extra %in% rownames(utils::installed.packages()))
  if (any(not_installed)) utils::install.packages(extra[not_installed])
  if (refresh) unlink(paste0(project_dir, "/renv.lock"))
  renv::snapshot(packages = extra, lockfile = paste0(project_dir, "/renv.lock"))
}

#' Download Census Population Data
#'
#' Download American Community Survey population data from the U.S. Census Bureau.
#'
#' @param year Data year.
#' @param out_dir Directory to download the file to.
#' @param state_only Logical; if \code{TRUE}, will only load state data.
#'   Will still download county data.
#' @param age_groups A list mapping lower-level age groups to high-level ones
#' (e.g., \code{list(`<10 Years` = c("Under 5 years", "5 to 9 years"))}).
#' Or the name of a standard mapping (\code{"7"} or \code{"9"}).
#' If \code{FALSE}, will return the lowest-level age groups.
#' @param overwrite Logical; if \code{TRUE}, will re-download and overwrite existing data.
#' @param verbose Logical; if \code{FALSE}, will not display status messages.
#' @returns A \code{data.frame} including \code{GEOID} and \code{region_name}
#'   for states and counties, along with their population, in total and within
#'   age brackets.
#' @examples
#' if (file.exists("../../../pophive/census_population_2021.csv.xz")) {
#'   dcf_load_census(2021, "../../../pophive")[1:10, ]
#' }
#' @export

dcf_load_census <- function(
  year = 2021,
  out_dir = NULL,
  state_only = FALSE,
  age_groups = "9",
  overwrite = FALSE,
  verbose = TRUE
) {
  out_file <- paste0(out_dir, "/census_population_", year, ".csv.xz")
  write_out <- !is.null(out_dir)
  age_group_sets <- list(
    "7" = list(
      `<10 Years` = c("Under 5 years", "5 to 9 years"),
      `10-14 Years` = "10 to 14 years",
      `15-19 Years` = c("15 to 17 years", "18 and 19 years"),
      `20-39 Years` = c(
        "20 years",
        "21 years",
        "22 to 24 years",
        "25 to 29 years",
        "30 to 34 years",
        "35 to 39 years"
      ),
      `40-64 Years` = c(
        "40 to 44 years",
        "45 to 49 years",
        "50 to 54 years",
        "55 to 59 years",
        "60 and 61 years",
        "62 to 64 years"
      ),
      `65+ Years` = c(
        "65 and 66 years",
        "67 to 69 years",
        "70 to 74 years",
        "75 to 79 years",
        "80 to 84 years",
        "85 years and over"
      )
    ),
    "9" = list(
      `<10 Years` = c("Under 5 years", "5 to 9 years"),
      `10-18 Years` = c("10 to 14 years", "15 to 17 years"),
      `18-24 Years` = c(
        "18 and 19 years",
        "20 years",
        "21 years",
        "22 to 24 years"
      ),
      `25-34 Years` = c("25 to 29 years", "30 to 34 years"),
      `35-44 Years` = c("35 to 39 years", "40 to 44 years"),
      `45-54 Years` = c("45 to 49 years", "50 to 54 years"),
      `55-64 Years` = c(
        "55 to 59 years",
        "60 and 61 years",
        "62 to 64 years"
      ),
      `65+ Years` = c(
        "65 and 66 years",
        "67 to 69 years",
        "70 to 74 years",
        "75 to 79 years",
        "80 to 84 years",
        "85 years and over"
      )
    )
  )
  age_levels <- unlist(age_group_sets[[1L]])
  if (!overwrite && write_out && file.exists(out_file)) {
    if (verbose) {
      cli::cli_progress_step("reading in existing file")
    }
    pop <- as.data.frame(vroom::vroom(
      out_file,
      delim = ",",
      col_types = list(GEOID = "c", region_name = "c"),
      n_max = if (state_only) 52L else Inf
    ))
  } else {
    # GEOID to region name mapping
    id_url <- "https://www2.census.gov/geo/docs/reference/codes2020/national_"
    if (verbose) {
      cli::cli_progress_step("downloading state IDs map")
    }
    state_ids <- vroom::vroom(
      paste0(id_url, "state2020.txt"),
      delim = "|",
      col_types = list(
        STATE = "c",
        STATEFP = "c",
        STATENS = "c",
        STATE_NAME = "c"
      )
    )
    if (verbose) {
      cli::cli_progress_step("downloading county IDs map")
    }
    county_ids <- vroom::vroom(
      paste0(id_url, "county2020.txt"),
      delim = "|",
      col_types = list(
        STATE = "c",
        STATEFP = "c",
        COUNTYFP = "c",
        COUNTYNS = "c",
        COUNTYNAME = "c",
        CLASSFP = "c",
        FUNCSTAT = "c"
      )
    )
    region_name = structure(
      sub(
        " County",
        "",
        c(
          state_ids$STATE_NAME,
          paste0(county_ids$COUNTYNAME, ", ", county_ids$STATE)
        ),
        fixed = TRUE
      ),
      names = c(
        state_ids$STATEFP,
        paste0(county_ids$STATEFP, county_ids$COUNTYFP)
      )
    )

    # population data

    ## age group labels from IDs
    if (verbose) {
      cli::cli_progress_step("downloading ACS variable lables")
    }
    labels <- vroom::vroom(
      paste0(
        "https://www2.census.gov/programs-surveys/acs/summary_file/",
        min(2021L, year),
        "/sequence-based-SF/documentation/user_tools/ACS_5yr_Seq_Table_Number_Lookup.txt"
      ),
      delim = ",",
      col_types = list(
        `File ID` = "c",
        `Table ID` = "c",
        `Sequence Number` = "c",
        `Line Number` = "d",
        `Start Position` = "i",
        `Total Cells in Table` = "c",
        `Total Cells in Sequence` = "i",
        `Table Title` = "c",
        `Subject Area` = "c"
      )
    )
    variable_labels <- structure(
      labels$`Table Title`,
      names = paste0(
        labels$`Table ID`,
        "_E",
        formatC(labels$`Line Number`, width = 3L, flag = 0L)
      )
    )

    ## age group counts
    url <- paste0(
      "https://www2.census.gov/programs-surveys/acs/summary_file/",
      year,
      "/table-based-SF/data/5YRData/acsdt5y",
      year,
      "-b01001.dat"
    )
    if (verbose) {
      cli::cli_progress_step("downloading population data")
    }
    data <- vroom::vroom(url, delim = "|", col_types = list(GEO_ID = "c"))
    data <- data[
      grep("0[45]00000US", data$GEO_ID),
      grep("E", colnames(data), fixed = TRUE)
    ]
    colnames(data)[-1L] <- variable_labels[colnames(data)[-1L]]
    if (verbose) {
      cli::cli_progress_step("agregating across sex and fine age groups")
    }
    pop <- cbind(
      data.frame(
        GEOID = substring(data$GEO_ID, 10L),
        region_name = "",
        Total = data[["Total:"]]
      ),
      do.call(
        cbind,
        lapply(
          structure(age_levels, names = age_levels),
          function(l) rowSums(data[, colnames(data) == l])
        )
      )
    )
    pop$region_name = region_name[pop$GEOID]
    states <- pop[1L:52L, ]
    health_regions <- as.data.frame(do.call(
      rbind,
      lapply(
        split(
          states[, -(1L:2L)],
          dcf_to_health_region(states$GEOID, "hhs_")
        ),
        colSums
      )
    ))
    health_regions$GEOID <- rownames(health_regions)
    health_regions$region_name <- sub(
      "hhs_",
      "Health Region ",
      rownames(health_regions),
      fixed = TRUE
    )
    pop <- rbind(pop, health_regions[, colnames(pop)])

    if (write_out) {
      if (verbose) {
        cli::cli_progress_step("writing output")
      }
      dir.create(out_dir, recursive = TRUE, showWarnings = FALSE)
      vroom::vroom_write(pop, out_file, ",")
    }
  }
  if (is.numeric(age_groups)) age_groups <- as.character(age_groups)
  if (is.character(age_groups) && (age_groups %in% names(age_group_sets)))
    age_groups <- age_group_sets[[as.character(age_groups)]]
  if (is.list(age_groups)) {
    pop <- cbind(
      pop[, !(colnames(pop) %in% age_levels)],
      do.call(
        cbind,
        lapply(
          age_groups,
          function(l) rowSums(pop[, colnames(pop) %in% l, drop = FALSE])
        )
      )
    )
  }
  invisible(if (state_only) pop[1L:52L, ] else pop)
}

#' Initialize a Data Collection Project
#'
#' Establishes a new data collection framework project.
#'
#' @param name Name of the source. Defaults to the current directory name.
#' @param base_dir Path to the parent of the project directory (where the \code{name}
#' directory should be created). If \code{name} is not specified, will treat the current
#' directory as \code{name}, and \code{".."} as \code{base_dir}.
#' @param data_dir Name of the directory to store projects in, relative to \code{base_dir}.
#' @param github_account Name of the GitHub account that will host the repository.
#' @param branch Name of the repository's branch.
#' @param repo_name Name of the repository.
#' @param use_git Logical; if \code{TRUE}, will initialize a git repository.
#' @param open_after Logical; if \code{TRUE}, will open the project in a new RStudio instance.
#' @returns Nothing; creates default files and directories.
#' @section Data Collection Project:
#'
#' A data collection project starts with a \code{settings.json} file, which
#' specifies where source and bundle projects live (a \code{data} subdirectory by default).
#'
#' The bulk of the project will then be in the source and bundle projects, as created
#' by the \code{\link{dcf_add_source}} and \code{\link{dcf_add_bundle}}.
#'
#' Once these sub-projects are in place, they can be operated over by the
#' \code{\link{dcf_build}}, which processes each sub-project using
#' \code{\link{dcf_process}}, and checks them with \code{\link{dcf_check}},
#' resulting in a report.
#'
#' @examples
#' base_dir <- tempdir()
#' dcf_init("project_name", base_dir)
#' list.files(paste0(base_dir, "/project_name"))
#'
#' @export

dcf_init <- function(
  name,
  base_dir = ".",
  data_dir = "data",
  github_account = "",
  branch = "main",
  repo_name = name,
  use_git = TRUE,
  open_after = FALSE
) {
  if (missing(name)) {
    name <- basename(getwd())
    base_dir <- ".."
  } else {
    name <- gsub("[^A-Za-z0-9]+", "_", name)
  }
  base_path <- paste0(base_dir, "/", name, "/")
  dir.create(base_path, showWarnings = FALSE, recursive = TRUE)
  paths <- paste0(
    base_path,
    c(
      "project.Rproj",
      "settings.json",
      "README.md",
      "scripts/build.R",
      ".github/workflows/build.yaml",
      ".gitignore"
    )
  )
  if (
    !file.exists(paths[[1L]]) && !length(list.files(base_path, "\\.Rproj$"))
  ) {
    writeLines("Version: 1.0\n", paths[[1L]])
  }
  if (!file.exists(paths[[2L]])) {
    jsonlite::write_json(
      list(
        name = name,
        data_dir = data_dir,
        github_account = github_account,
        branch = "main",
        repo_name = repo_name
      ),
      paths[[2L]],
      auto_unbox = TRUE,
      pretty = TRUE
    )
  }
  if (!file.exists(paths[[3L]])) {
    writeLines(
      paste0(
        c(
          paste("#", name),
          "",
          "This is a Data Collection Framework project, initialized with `dcf::dcf_init`.",
          "",
          "You can us the `dcf` package to check the source projects:",
          "",
          "```R",
          paste0('dcf::dcf_check_source()'),
          "```",
          "",
          "And process them:",
          "",
          "```R",
          paste0('dcf::dcf_process()'),
          "```"
        ),
        collapse = "\n"
      ),
      paths[[3L]]
    )
  }
  if (!file.exists(paths[[4L]])) {
    dir.create(dirname(paths[[4L]]), showWarnings = FALSE)
    writeLines(
      paste(c("library(dcf)", "dcf_build()"), collapse = "\n"),
      paths[[4L]]
    )
  }
  if (!file.exists(paths[[5L]])) {
    dir.create(dirname(paths[[5L]]), recursive = TRUE, showWarnings = FALSE)
    file.copy(system.file("workflows/build.yaml", package = "dcf"), paths[[5L]])
  }
  if (!file.exists(paths[[6L]])) {
    writeLines(
      paste(
        c(
          "*.Rproj",
          ".Rproj.user",
          "*.Rprofile",
          "*.Rhistory",
          "*.Rdata",
          ".DS_Store",
          "renv"
        ),
        collapse = "\n"
      ),
      paths[[6L]]
    )
  }
  if (open_after) rstudioapi::openProject(paths[[1L]], newSession = TRUE)
}

#' Retrieve A Data File
#'
#' Load a data file from a source data project, or list versions of the file.
#'
#' @param path Path to the file.
#' @param date Date of the version to load; A \code{Date}, or \code{character} in the format
#'   \code{YYYY-MM-DD}. Will match to the nearest version.
#' @param commit_hash SHA signature of the committed version;
#'   can be the first 6 or so characters. Ignored if \code{date} is provided.
#' @param versions Logical; if \code{TRUE}, will return a list of available version,
#'   rather than a
#' @returns If \code{versions} is \code{TRUE}, a \code{data.frame} with columns for
#'   the \code{hash}, \code{author}, \code{date}, and \code{message} of each commit.
#'   Otherwise, the path to a temporary file, if one was extracted.
#'
#' @examples
#' path <- "../../../pophive/data/wastewater/raw/flua.csv.xz"
#' if (file.exists(path)) {
#'   # list versions
#'   versions <- dcf_get_file(path, versions = TRUE)
#'   print(versions[, c("date", "hash")])
#'
#'   # extract a version to a temporary file
#'   temp_path <- dcf_get_file(path, "2025-05")
#'   basename(temp_path)
#' }
#'
#' @export

dcf_get_file <- function(
  path,
  date = NULL,
  commit_hash = NULL,
  versions = FALSE
) {
  if (missing(path)) {
    cli::cli_abort("specify a path")
  }
  if (!file.exists(path)) {
    cli::cli_abort("path does not exist")
  }
  vs <- data.frame(
    hash = character(),
    author = character(),
    date = character(),
    message = character()
  )
  if (versions || !is.null(date)) {
    commits <- sys::exec_internal("git", c("log", path))
    if (commits$status == 0L) {
      commits <- do.call(
        rbind,
        Filter(
          function(e) length(e) == 4L,
          strsplit(
            strsplit(rawToChar(commits$stdout), "commit ", fixed = TRUE)[[1L]],
            "\\n+(?:[^:]+:)?\\s*"
          )
        )
      )
      colnames(commits) <- colnames(vs)
      vs <- as.data.frame(commits)
    } else {
      cli::cli_abort("failed to git log: {rawToChar(commits$stderr)}")
    }
  }
  if (versions) {
    return(vs)
  }
  if (!is.null(date)) {
    if (nrow(vs) == 0L) {
      return(path)
    }
    if (is.character(date)) {
      date <- as.POSIXct(
        date,
        tryFormats = c(
          "%Y-%m-%d %H:%M:%S",
          "%Y-%m-%d %H:%M",
          "%Y-%m-%d",
          "%Y-%m",
          "%Y"
        ),
        tz = "UTC"
      )
    }
    commit_hash <- vs$hash[which.min(abs(
      as.POSIXct(vs$date, "%a %b %d %H:%M:%S %Y", tz = "UTC") - date
    ))]
  }
  if (is.null(commit_hash)) {
    return(path)
  }
  name_parts <- strsplit(basename(path), ".", fixed = TRUE)[[1L]]
  out_path <- paste0(
    tempdir(),
    "/",
    name_parts[[1L]],
    "-",
    substring(commit_hash, 1L, 6L),
    ".",
    paste(name_parts[-1L], collapse = ".")
  )
  if (file.exists(out_path)) {
    return(out_path)
  }
  status <- sys::exec_wait(
    "git",
    c("show", paste0(commit_hash, ":", path)),
    std_out = out_path
  )
  if (status != 0L) {
    cli::cli_abort("failed to git show: {rawToChar(status$stderr)}")
  }
  out_path
}

#' Interact with a Source Process File
#'
#' Read or update the current source process file.
#'
#' @param path Path to the process JSON file.
#' @param updated An update version of the process definition. If specified, will
#' write this as the new process file, rather than reading any existing file.
#' @returns The process definition of the source project.
#' @examples
#' epic_process_file <- "../../data/epic/process.json"
#' if (file.exists(epic_process_file)) {
#'   dcf_process_record(path = epic_process_file)
#' }
#' @export

dcf_process_record <- function(path = "process.json", updated = NULL) {
  if (is.null(updated)) {
    if (!file.exists(path)) {
      cli::cli_abort("process file {path} does not exist")
    }
    jsonlite::read_json(path)
  } else {
    if (is.null(updated$type)) updated$type <- "source"
    jsonlite::write_json(updated, path, auto_unbox = TRUE, pretty = TRUE)
    updated
  }
}

1		#' Map States to Health Regions
2		#'
3		#' Maps state FIPS state numeric codes to Human Health Service regions.
4		#'
5		#' @param geoids Character vector of GEOIDs.
6		#' @param prefix A prefix to add to region IDs.
7		#' @returns A vector of Health Region names the same length as \code{geoids}.
8		#' @examples
9		#' dcf_to_health_region(c("01", "01001", "02", "02001"))
10		#' @export
11
12		dcf_to_health_region <- function(geoids, prefix = "Region ") {
13	1x	regions <- c(
14	1x	"01" = 4,
15	1x	"02" = 10,
16	1x	"04" = 9,
17	1x	"05" = 6,
18	1x	"06" = 9,
19	1x	"08" = 8,
20	1x	"09" = 1,
21	1x	"10" = 3,
22	1x	"11" = 3,
23	1x	"12" = 4,
24	1x	"13" = 4,
25	1x	"15" = 9,
26	1x	"16" = 10,
27	1x	"17" = 5,
28	1x	"18" = 5,
29	1x	"19" = 7,
30	1x	"20" = 7,
31	1x	"21" = 4,
32	1x	"22" = 6,
33	1x	"23" = 1,
34	1x	"24" = 3,
35	1x	"25" = 1,
36	1x	"26" = 5,
37	1x	"27" = 5,
38	1x	"28" = 4,
39	1x	"29" = 7,
40	1x	"30" = 8,
41	1x	"31" = 7,
42	1x	"32" = 9,
43	1x	"33" = 1,
44	1x	"34" = 2,
45	1x	"35" = 6,
46	1x	"36" = 2,
47	1x	"37" = 4,
48	1x	"38" = 8,
49	1x	"39" = 5,
50	1x	"40" = 6,
51	1x	"41" = 10,
52	1x	"42" = 3,
53	1x	"44" = 1,
54	1x	"45" = 4,
55	1x	"46" = 8,
56	1x	"47" = 4,
57	1x	"48" = 6,
58	1x	"49" = 8,
59	1x	"50" = 1,
60	1x	"51" = 3,
61	1x	"53" = 10,
62	1x	"54" = 3,
63	1x	"55" = 5,
64	1x	"56" = 8,
65	1x	"72" = 2,
66	1x	"66" = 6,
67	1x	"74" = 2
68		)
69	1x	regions[] <- paste0(prefix, regions)
70	1x	unname(regions[substring(geoids, 1L, 2L)])
71		}

1		dcf_read_settings <- function(project_dir = ".") {
2	13x	settings_file <- paste0(project_dir, "/settings.json")
3	13x	if (!file.exists(settings_file)) {
4	!	cli::cli_abort(
5	!	"{.arg project_dir} ({project_dir}) does not appear to be a Data Collection Framework project"
6		)
7		}
8	13x	jsonlite::read_json(settings_file)
9		}

1		#' Run a Project's Build Process
2		#'
3		#' Build a Data Collection Framework project,
4		#' which involves processing and checking all data projects.
5		#'
6		#' @param project_dir Path to the Data Collection Framework project to be built.
7		#' @param is_auto Logical; if \code{FALSE}, will run \code{\link{dcf_process}} as if it were run
8		#' manually.
9		#' @param ... Passes arguments to \code{\link{dcf_process}}.
10		#' @param make_diagram Logical; if \code{FALSE}, will not make a \code{status.md} diagram.
11		#' @param make_file_log Logical; if \code{FALSE}, will not make a \code{file_log.json} output.
12		#' @returns A version of the project report, which is also written to
13		#' \code{project_dir/docs/report.json.gz}.
14		#' @examples
15		#' project_file <- "../../../pophive"
16		#' if (file.exists(project_file)) {
17		#' report <- dcf_build(project_file)
18		#' }
19		#' @export
20
21		dcf_build <- function(
22		project_dir = ".",
23		is_auto = TRUE,
24		...,
25		make_diagram = TRUE,
26		make_file_log = TRUE
27		) {
28	2x	settings <- dcf_read_settings(project_dir)
29	2x	data_dir <- paste0(project_dir, "/", settings$data_dir)
30	2x	processes <- list.files(
31	2x	data_dir,
32	2x	"process\\.json",
33	2x	recursive = TRUE,
34	2x	full.names = TRUE
35		)
36	2x	process_state <- tools::md5sum(processes)
37	2x	process <- dcf_process(project_dir = project_dir, is_auto = TRUE, ...)
38	2x	issues <- dcf_check(project_dir = project_dir)
39	2x	report_file <- paste0(project_dir, "/report.json.gz")
40		if (
41	2x	!identical(
42	2x	process_state,
43	2x	tools::md5sum(list.files(
44	2x	data_dir,
45	2x	"process\\.json",
46	2x	recursive = TRUE,
47	2x	full.names = TRUE
48		))
49		)
50		) {
51	2x	datapackages <- list.files(
52	2x	data_dir,
53	2x	"datapackage\\.json",
54	2x	recursive = TRUE,
55	2x	full.names = TRUE
56		)
57	2x	names(datapackages) <- dirname(sub(
58		"^/",
59		"",
60	2x	sub(data_dir, "", datapackages, fixed = TRUE)
61		))
62	2x	names(processes) <- dirname(sub(
63		"^/",
64		"",
65	2x	sub(data_dir, "", processes, fixed = TRUE)
66		))
67	2x	report <- list(
68	2x	date = Sys.time(),
69	2x	settings = settings,
70	2x	source_times = process$timings,
71	2x	logs = process$logs,
72	2x	issues = issues,
73	2x	metadata = lapply(datapackages, jsonlite::read_json),
74	2x	processes = lapply(processes, jsonlite::read_json)
75		)
76	2x	jsonlite::write_json(
77	2x	report,
78	2x	gzfile(report_file),
79	2x	auto_unbox = TRUE,
80	2x	dataframe = "columns"
81		)
82		} else {
83	!	report <- jsonlite::read_json(report_file)
84		}
85	2x	if (make_file_log) {
86	2x	file_log <- list()
87	2x	for (file_dir in names(report$metadata)) {
88	3x	if (grepl("/dist", file_dir, fixed = TRUE)) {
89	1x	p <- report$metadata[[file_dir]]
90	1x	for (p_file in p$resources) {
91	1x	file_log[[paste0(
92	1x	settings$data_dir,
93		"/",
94	1x	file_dir,
95		"/",
96	1x	p_file$filename
97	1x	)]] <- list(
98	1x	updated = p_file$last_modified,
99	1x	md5 = p_file$md5
100		)
101		}
102		}
103		}
104	2x	jsonlite::write_json(
105	2x	file_log,
106	2x	paste0(project_dir, "/file_log.json"),
107	2x	auto_unbox = TRUE
108		)
109		}
110	2x	if (make_diagram) {
111	2x	dcf_status_diagram(project_dir)
112		}
113	2x	invisible(report)
114		}

1		#' Download CDC WISQARS Reports
2		#'
3		#' Download reports data from the CDC's
4		#' \href{https://wisqars.cdc.gov/reports}{Web-based Injury Statistics Query and Reporting System}.
5		#'
6		#' @param file File to save the report to (\code{csv} or \code{parquet}).
7		#' @param year_start Earliest year to include.
8		#' @param year_end Latest year to include.
9		#' @param geography State or region code.
10		#' @param intent Intent ID or name:
11		#' \tabular{lll}{
12		#' \code{0} \tab \code{all} \tab All \cr
13		#' \code{1} \tab \code{unintentional} \tab Unintentional \cr
14		#' \code{2} \tab \code{suicide} \tab Suicide \cr
15		#' \code{3} \tab \code{homicide} \tab Homicide \cr
16		#' \code{4} \tab \code{homicide_legal} \tab Homicide and Legal Intervention \cr
17		#' \code{5} \tab \code{undetermined} \tab Undetermined \cr
18		#' \code{6} \tab \code{legal} \tab Legal Intervention \cr
19		#' \code{8} \tab \code{violence} \tab Violence-related \cr
20		#' }
21		#' @param disposition Patient disposition given nonfatal: one or multiple of \code{all} (0),
22		#' \code{treated} (1; treated and released), \code{transfered} (2), \code{hospitalized} (3), or
23		#' \code{observed} (4; observed/left AMA/unknown).
24		#' @param mechanism Mechanism code; default to \code{20810} (all injury).
25		#' Other codes appear in the URL in the \code{m} parameter when submitting the filter.
26		#' @param group_ages Logical; if \code{FALSE}, will not group ages into 5-year bins.
27		#' @param age_min Youngest age to include.
28		#' @param age_max Oldest age to include.
29		#' @param sex Sex groups to include: one or multiple of \code{all} (0), \code{male} (1),
30		#' \code{female} (2), or \code{unknown} (3)..
31		#' @param race Race groups to include: one or multiple of \code{all} (0), \code{white} (1),
32		#' \code{black} (2), \code{aa} (3; American Indian or Alaska Native), \code{asian} (4),
33		#' \code{pi} (5; Hawaiian Native or Pacific Islander), \code{more} (6; more than one race).
34		#' These levels apply if \code{race_reporting} is \code{single} (default) -- provide
35		#' these by index for other \code{race_reporting} levels.
36		#' @param race_reporting How to group race groups, between \code{none} (0), \code{bridge} (1),
37		#' \code{single} (2), or \code{aapi} (3).
38		#' @param ethnicity Which ethnic groups to include: one or multiple of \code{all} (0),
39		#' \code{non_hispanic} (1), \code{hispanic} (2), or \code{unknown} (3).
40		#' @param YPLL Age to use when calculating Years of Potential Life Lost.
41		#' @param metro Region type filter: \code{TRUE} for only metropolitan / urban, or \code{FALSE}
42		#' for only non-metropolitan / rural. Will include all region types if \code{NULL} (default).
43		#' @param group_by One or more variables to group by. These are uppercased and sometimes
44		#' abbreviated or encoded; see the \code{r1} through \code{r4} URL parameters.
45		#' @param fatal_outcome Logical; if \code{FALSE}, will return non-fatal results.
46		#' @param brain_ingury_only Logical; if \code{TRUE}, will return only traumatic brain injury results.
47		#' @param include_total Logical; if \code{FALSE}, will not include totals.
48		#' @param verbose Logical; if \code{FALSE}, will not display status messages.
49		#' @returns A list containing the parameters of the request. The returned data are written to \code{file}.
50		#' @examples
51		#' file <- "../../../wisqars.csv.xz"
52		#' if (file.exists(file)) {
53		#' dcf_download_wisqars(file, verbose = FALSE)
54		#' vroom::vroom(file)
55		#' }
56		#' @export
57
58		dcf_download_wisqars <- function(
59		file,
60		fatal_outcome = TRUE,
61		brain_injury_only = FALSE,
62		year_start = 2018,
63		year_end = year_start,
64		geography = "00",
65		intent = "all",
66		disposition = "all",
67		mechanism = if (fatal_outcome) 20810 else 3000,
68		group_ages = NULL,
69		age_min = 0,
70		age_max = 199,
71		sex = "all",
72		race = "all",
73		race_reporting = "single",
74		ethnicity = "all",
75		YPLL = 65,
76		metro = NULL,
77		group_by = NULL,
78		include_total = FALSE,
79		verbose = TRUE
80		) {
81	2x	intents <- list(
82	2x	all = 0,
83	2x	unintentional = 1,
84	2x	violence = 8,
85	2x	homicide_legal = 4,
86	2x	homicide = 3,
87	2x	legal = 6,
88	2x	suicide = 2,
89	2x	undetermined = 5
90		)
91	2x	dispositions <- list(
92	2x	all = 0,
93	2x	treated = 1,
94	2x	transfered = 2,
95	2x	hospitalized = 3,
96	2x	observed = 4
97		)
98	2x	sexes <- list(
99	2x	all = 0,
100	2x	male = 1,
101	2x	female = 2,
102	2x	unknown = 3
103		)
104	2x	races <- list(
105	2x	all = 0,
106	2x	white = 1,
107	2x	black = 2,
108	2x	aa = 3,
109	2x	asian = 4,
110	2x	pi = 5,
111	2x	more = 6
112		)
113	2x	race_reportings <- list(
114	2x	none = 0,
115	2x	bridge = 1,
116	2x	single = 2,
117	2x	aapi = 3
118		)
119	2x	ethnicities <- list(
120	2x	all = 0,
121	2x	non_hispanic = 1,
122	2x	hispanic = 2,
123	2x	unknown = 3
124		)
125	2x	if (missing(group_ages) && (!missing(age_min) \|\| !missing(age_max))) {
126	!	group_ages <- FALSE
127		}
128	2x	params <- list(
129	2x	TotalLine = if (include_total) "YES" else "NO",
130	2x	intent = if (is.character(intent)) intents[[tolower(intent)]] else 0L,
131	2x	mech = mechanism,
132	2x	sex = paste(
133	2x	vapply(sex, function(l) if (is.character(l)) sexes[[l]] else l, 0),
134	2x	collapse = ","
135		),
136	2x	race = paste(
137	2x	vapply(race, function(l) if (is.character(l)) sexes[[l]] else l, 0),
138	2x	collapse = ","
139		),
140	2x	race_yr = if (is.character(race_reporting))
141	2x	race_reportings[[race_reporting]] else race_reporting,
142	2x	year1 = year_start,
143	2x	year2 = year_end,
144	2x	agebuttn = if (is.null(group_ages)) "ALL" else if (group_ages) "5Yr" else
145	2x	"custom",
146	2x	fiveyr1 = age_min,
147	2x	fiveyr2 = age_max,
148	2x	c_age1 = age_min,
149	2x	c_age2 = age_max,
150	2x	groupby1 = "NONE",
151	2x	groupby2 = "NONE",
152	2x	groupby3 = "NONE",
153	2x	groupby4 = "NONE",
154	2x	groupby5 = "NONE",
155	2x	groupby6 = "NONE"
156		)
157	2x	if (fatal_outcome) {
158	1x	params$state <- geography
159	1x	params$ethnicty <- paste(
160	1x	vapply(
161	1x	ethnicity,
162	1x	function(l) if (is.character(l)) ethnicities[[l]] else l,
163	1x	0
164		),
165	1x	collapse = ","
166		)
167	1x	params$ypllage <- YPLL
168	1x	params$urbrul <- if (is.null(metro)) 0 else if (metro) 1 else 2
169	1x	params$tbi <- if (brain_injury_only) 1L else 0L
170		} else {
171	1x	params$groupby1 <- "NONE1"
172	1x	params$groupby2 <- "NONE2"
173	1x	params$groupby3 <- "NONE3"
174	1x	params$groupby4 <- "NONE4"
175	1x	params$groupby5 <- "NONE5"
176	1x	params$groupby6 <- "NONE6"
177	1x	params$outcome <- "NFI"
178	1x	params$racethn <- 0
179	1x	params$disp <- paste(
180	1x	vapply(
181	1x	disposition,
182	1x	function(l) if (is.character(l)) dispositions[[l]] else l,
183	1x	0
184		),
185	1x	collapse = ","
186		)
187		}
188	2x	for (group in seq_along(group_by)) {
189	!	params[[paste0("groupby", group)]] <- toupper(group_by[[group]])
190		}
191	2x	params <- lapply(params, as.character)
192	2x	if (fatal_outcome) {
193	1x	params$app_id <- 1002
194	1x	params$component_id <- 1000
195		}
196
197	2x	if (verbose) {
198	2x	url <- paste0(
199	2x	"https://wisqars.cdc.gov/reports/?o=",
200	2x	if (fatal_outcome) "MORT" else "NFI"
201		)
202	2x	if (!fatal_outcome) {
203	1x	url <- paste0(url, "&g=00&me=")
204		}
205	2x	url_param_map <- list(
206	2x	year1 = "y1",
207	2x	year2 = "y2",
208	2x	tbi = "t",
209	2x	disp = "d",
210	2x	state = "g",
211	2x	ethnicty = "e",
212	2x	intent = "i",
213	2x	mech = "m",
214	2x	sex = "s",
215	2x	race = "r",
216	2x	agebuttn = "a",
217	2x	urbrul = "me",
218	2x	race_yr = "ry",
219	2x	ypllage = "yp",
220	2x	fiveyr1 = "g1",
221	2x	fiveyr2 = "g2",
222	2x	c_age1 = "a1",
223	2x	c_age2 = "a2",
224	2x	groupby1 = "r1",
225	2x	groupby2 = "r2",
226	2x	groupby3 = "r3",
227	2x	groupby4 = "r4",
228	2x	groupby5 = "r5",
229	2x	groupby6 = "r6"
230		)
231	2x	for (k in names(params)) {
232	48x	url_key <- url_param_map[[k]]
233	48x	if (!is.null(url_key)) {
234	42x	for (value in params[[k]]) url <- paste0(url, "&", url_key, "=", value)
235		}
236		}
237	2x	cli::cli_alert_info("requesting report {.url {url}}")
238		}
239
240	2x	handler <- curl::new_handle()
241	2x	curl::handle_setheaders(handler, "Content-Type" = "application/json")
242	2x	curl::handle_setopt(
243	2x	handler,
244	2x	copypostfields = jsonlite::toJSON(
245	2x	list(parameters = params),
246	2x	auto_unbox = TRUE
247		)
248		)
249	2x	req <- curl::curl_fetch_memory(
250	2x	paste0(
251	2x	"https://wisqars.cdc.gov/api/cost-",
252	2x	if (fatal_outcome) "fatal" else "nonfatal"
253		),
254	2x	handle = handler
255		)
256	2x	if (req$status_code == 200) {
257	2x	dir.create(dirname(file), FALSE, TRUE)
258	2x	data <- jsonlite::fromJSON(rawToChar(req$content))
259	2x	if (!length(data)) {
260	!	cli::cli_warn("no rows in data, so no file written")
261		} else {
262	2x	if (grepl("parquet", file)) {
263	!	arrow::write_parquet(data, file, compression = "gzip")
264		} else {
265	2x	vroom::vroom_write(data, file, ",")
266		}
267		}
268		} else {
269	!	cli::cli_abort("request failed: {req$status_code}")
270		}
271	2x	invisible(params)
272		}

1		#' Make a Status Diagram
2		#'
3		#' Make a Data Collection Project status diagram.
4		#'
5		#' @param project_dir Path to the Data Collection Framework project to be built.
6		#' @param out_file File name of the file to write within \code{project_dir}.
7		#' @returns A character vector of the status diagram, which is also written to
8		#' the \code{project_dir/status.md} file.
9		#' @examples
10		#' \dontrun{
11		#' dcf_status_diagram("project_directory")
12		#' }
13		#' @export
14
15		dcf_status_diagram <- function(project_dir = ".", out_file = "status.md") {
16	2x	report_file <- paste0(project_dir, "/report.json.gz")
17	2x	if (!file.exists(report_file)) {
18	!	cli::cli_abort("no report file found")
19		}
20	2x	report <- jsonlite::read_json(report_file)
21	2x	data_dir <- if (is.null(report$settings$data_dir)) "data" else
22	2x	report$settings$data_dir
23	2x	branch <- if (is.null(report$settings$branch)) "main" else
24	2x	report$settings$branch
25	2x	repo <- if (report$settings$github_account == "") {
26	2x	NULL
27		} else {
28	!	paste0(report$settings$github_account, "/", report$settings$repo_name)
29		}
30	2x	indent <- " "
31	2x	d <- c(
32	2x	'classDef pass stroke:#66bb6a',
33	2x	'classDef warn stroke:#ffa726',
34	2x	'classDef fail stroke:#f44336'
35		)
36	2x	sources <- NULL
37	2x	source_ids <- list()
38	2x	file_ids <- NULL
39	2x	relationships <- NULL
40	2x	projects <- NULL
41	2x	node_id <- 0L
42	2x	for (name in names(sort(vapply(
43	2x	report$processes,
44	2x	function(p) !is.null(p$type) && p$type == "bundle",
45	2x	TRUE
46		)))) {
47	3x	timing <- report$source_times[[name]]
48	3x	issues <- report$issues[[name]]
49	3x	if (length(issues))
50	3x	names(issues) <- sub(
51	3x	paste0(data_dir, "/"),
52		"",
53	3x	sub(
54	3x	paste0(project_dir, "/"),
55		"",
56	3x	sub("^\\.*/", "", names(issues)),
57	3x	fixed = TRUE
58		),
59	3x	fixed = TRUE
60		)
61	3x	metas <- report$metadata[grep(
62	3x	paste0("^", name, "/"),
63	3x	names(report$metadata)
64		)]
65	3x	measures <- if (length(metas)) metas[[1L]]$measure_info else list()
66	3x	process <- report$processes[[name]]
67	3x	contents <- NULL
68	3x	if (!is.null(process$type) && process$type == "bundle") {
69	1x	dist_files <- grep(
70	1x	"measure_info",
71	1x	names(process$dist_state),
72	1x	value = TRUE,
73	1x	invert = TRUE
74		)
75	1x	for (filename in sub(
76	1x	paste0("^[./]*", data_dir, "/", name, "/(?:dist\|standard)/"),
77		"",
78	1x	dist_files
79		)) {
80	1x	node_id <- node_id + 1L
81	1x	contents <- c(
82	1x	contents,
83	1x	paste0(
84	1x	"n",
85	1x	node_id,
86		'["`',
87	1x	if (is.null(repo)) filename else
88	1x	make_link(
89	1x	paste0(
90	1x	"https://github.com/",
91	1x	repo,
92	1x	"/blob/",
93	1x	branch,
94		"/",
95	1x	data_dir,
96		"/",
97	1x	name,
98	1x	"/dist/",
99	1x	filename
100		),
101	1x	filename
102		),
103		'`"]'
104		)
105		)
106		}
107	1x	file_nodes <- file_ids[unlist(process$source_files)]
108	1x	file_nodes <- file_nodes[!is.na(file_nodes)]
109	1x	if (length(file_nodes)) {
110	1x	relationships <- c(
111	1x	relationships,
112	1x	paste0("n", file_nodes, " --> ", name)
113		)
114		}
115		} else {
116	2x	for (project_meta in metas) {
117	2x	for (r in project_meta$resources) {
118	2x	node_id <- node_id + 1L
119	2x	file_path <- paste0(
120	2x	name,
121	2x	"/standard/",
122	2x	r$filename
123		)
124	2x	file_ids[paste0(name, "/standard/", r$filename)] <- node_id
125	2x	file_issues <- issues[[file_path]]
126	2x	measure_sources <- measures[["_sources"]]
127	2x	for (field in r$schema$fields) {
128	6x	field_source <- measures[[field$name]]$sources
129	6x	if (!is.null(names(field_source)))
130	!	field_source <- list(field_source)
131	6x	for (s in field_source) {
132	!	if (is.character(s)) s <- list(id = s)
133	!	if (!is.null(s$id))
134	!	s <- if (is.null(measure_sources[[s$id]]))
135	!	c(s, list(name = s$id)) else c(s, measure_sources[[s$id]])
136	!	if (is.null(source_ids[[s$name]])) {
137	!	source_id <- paste0("s", length(source_ids))
138	!	source_ids[[s$name]] <- source_id
139	!	sources[[source_id]] <- list(
140	!	id = source_id,
141	!	general = make_link(s$url, s$name),
142	!	specific = NULL
143		)
144	!	parent_id <- source_id
145		} else {
146	!	parent_id <- source_ids[[s$name]]
147		}
148	!	if (is.null(s$location_url)) {
149	!	source_id <- source_ids[[s$name]]
150		} else {
151	!	if (is.null(source_ids[[s$location_url]])) {
152	!	source_id <- paste0("s", length(source_ids))
153	!	source_ids[[s$location_url]] <- source_id
154	!	relationships <- unique(c(
155	!	relationships,
156	!	paste0(
157	!	parent_id,
158		"---",
159	!	source_id,
160		'["',
161	!	make_link(s$location_url, s$location),
162		'"]'
163		)
164		))
165	!	sources[[parent_id]]$specific <- c(
166	!	sources[[parent_id]]$specific,
167	!	source_id
168		)
169		} else {
170	!	source_id <- source_ids[[s$location_url]]
171		}
172		}
173	!	relationships <- unique(c(
174	!	relationships,
175	!	paste0(source_id, " --> n", node_id)
176		))
177		}
178		}
179	2x	failed <- is.null(report$source_times[[name]])
180	2x	contents <- c(
181	2x	contents,
182	2x	paste0(
183	2x	"n",
184	2x	node_id,
185		'["`',
186	2x	if (is.null(repo)) r$filename else
187	2x	make_link(
188	2x	paste0(
189	2x	"https://github.com/",
190	2x	repo,
191	2x	"/blob/",
192	2x	branch,
193		"/",
194	2x	data_dir,
195		"/",
196	2x	name,
197	2x	"/standard/",
198	2x	r$filename
199		),
200	2x	r$filename
201		),
202	2x	if (length(file_issues))
203	2x	paste0("<br/><br/>", make_list(unlist(file_issues))),
204	2x	if (failed)
205	2x	paste0(
206	2x	if (length(file_issues)) "<br />" else "<br /><br />",
207	2x	"Script Failed:<br />",
208	2x	gsub(
209		'[`"]',
210		"'",
211	2x	paste(report$logs[[name]], collapse = "<br />")
212		)
213		),
214	2x	paste0(
215		'`"]:::',
216	2x	if (failed) "fail" else if (length(file_issues)) "warn" else
217	2x	"pass"
218		)
219		)
220		)
221		}
222		}
223		}
224	3x	projects <- c(
225	3x	projects,
226	3x	c(
227	3x	paste0(
228	3x	"subgraph ",
229	3x	name,
230		'["`',
231	3x	if (is.null(repo)) name else
232	3x	make_link(
233	3x	paste0(
234	3x	"https://github.com/",
235	3x	repo,
236	3x	"/tree/",
237	3x	branch,
238		"/",
239	3x	data_dir,
240		"/",
241	3x	name
242		),
243	3x	name
244		),
245		'`"]'
246		),
247	3x	paste0(indent, c("direction LR", contents)),
248	3x	"end"
249		)
250		)
251		}
252	2x	out <- c(
253	2x	"```mermaid",
254	2x	"flowchart LR",
255	2x	paste0(
256	2x	indent,
257	2x	c(
258	2x	d,
259	2x	vapply(
260	2x	sources,
261	2x	function(s) paste(c(s$id, '(("', s$general, '"))'), collapse = ""),
262		""
263		),
264	2x	projects,
265	2x	relationships
266		)
267		),
268		"```"
269		)
270	2x	if (is.character(out_file) && out_file != "") {
271	2x	writeLines(out, paste0(project_dir, "/", out_file))
272		}
273	2x	invisible(out)
274		}
275
276		make_link <- function(url, name = NULL) {
277	!	paste0(
278	!	'<strong><a href="',
279	!	url,
280	!	'" target="_blank" rel="noreferrer">',
281	!	if (is.null(name)) sub("https?://(?:www\\.)?", "", url) else name,
282	!	"</a></strong>"
283		)
284		}
285
286		make_list <- function(items) {
287	!	paste0(
288	!	"<ul>",
289	!	paste(
290	!	vapply(
291	!	items,
292	!	function(i) paste0("<li><code>", i, "</code></li>"),
293		""
294		),
295	!	collapse = ""
296		),
297	!	"</ul>"
298		)
299		}

1		#' Adds a Source Project
2		#'
3		#' Establishes a new data source project, used to collect and prepare data from a new source.
4		#'
5		#' @param name Name of the source.
6		#' @param project_dir Path to the Data Collection Framework project.
7		#' @param open_after Logical; if \code{FALSE}, will not open the project.
8		#' @returns Nothing; creates default files and directories.
9		#' @section Project:
10		#'
11		#' Within a source project, there are two files to edits:
12		#' \itemize{
13		#' \item \strong{\code{ingest.R}}: This is the primary script, which is automatically rerun.
14		#' It should store raw data and resources in \code{raw/} where possible,
15		#' then use what's in \code{raw/} to produce standard-format files in \code{standard/}.
16		#' This file is sourced from its location during processing, so any system paths
17		#' must be relative to itself.
18		#' \item \strong{\code{measure_info.json}}: This is where you can record information
19		#' about the variables included in the standardized data files.
20		#' See \code{\link{dcf_measure_info}}.
21		#' }
22		#'
23		#' @examples
24		#' project_dir <- paste0(tempdir(), "/temp_project")
25		#' dcf_init("temp_project", dirname(project_dir))
26		#' dcf_add_source("source_name", project_dir)
27		#' list.files(paste0(project_dir, "/data/source_name"))
28		#'
29		#' @export
30
31		dcf_add_source <- function(
32		name,
33		project_dir = ".",
34		open_after = interactive()
35		) {
36	5x	if (missing(name)) {
37	!	cli::cli_abort("specify a name")
38		}
39	5x	name <- gsub("[^A-Za-z0-9]+", "_", name)
40	5x	settings <- dcf_read_settings(project_dir)
41	5x	base_dir <- paste0(project_dir, "/", settings$data_dir)
42	5x	base_path <- paste0(base_dir, "/", name, "/")
43	5x	dir.create(paste0(base_path, "raw"), showWarnings = FALSE, recursive = TRUE)
44	5x	dir.create(paste0(base_path, "standard"), showWarnings = FALSE)
45	5x	paths <- paste0(
46	5x	base_path,
47	5x	c(
48	5x	"measure_info.json",
49	5x	"ingest.R",
50	5x	"project.Rproj",
51	5x	"standard/datapackage.json",
52	5x	"process.json",
53	5x	"README.md"
54		)
55		)
56	5x	if (!file.exists(paths[[1L]])) {
57	1x	dcf_measure_info(
58	1x	paths[[1L]],
59	1x	example_variable = list(),
60	1x	verbose = FALSE,
61	1x	open_after = FALSE
62		)
63		}
64	5x	if (!file.exists(paths[[2L]])) {
65	1x	writeLines(
66	1x	paste0(
67	1x	c(
68		"#",
69	1x	"# Download",
70		"#",
71		"",
72	1x	"# add files to the `raw` directory",
73		"",
74		"#",
75	1x	"# Reformat",
76		"#",
77		"",
78	1x	"# read from the `raw` directory, and write to the `standard` directory",
79		""
80		),
81	1x	collapse = "\n"
82		),
83	1x	paths[[2L]]
84		)
85		}
86	5x	if (!file.exists(paths[[3L]])) {
87	1x	writeLines("Version: 1.0\n", paths[[3L]])
88		}
89	5x	if (!file.exists(paths[[4L]])) {
90	1x	dcf_datapackage_init(
91	1x	name,
92	1x	dir = paste0(base_path, "standard"),
93	1x	quiet = TRUE
94		)
95		}
96
97	5x	if (!file.exists(paths[[5L]])) {
98	1x	dcf_process_record(
99	1x	paths[[5L]],
100	1x	list(
101	1x	name = name,
102	1x	type = "source",
103	1x	scripts = list(
104	1x	list(
105	1x	path = "ingest.R",
106	1x	manual = FALSE,
107	1x	frequency = 0L,
108	1x	last_run = "",
109	1x	run_time = "",
110	1x	last_status = list(log = "", success = TRUE)
111		)
112		),
113	1x	checked = "",
114	1x	check_results = list()
115		)
116		)
117		}
118	5x	if (!file.exists(paths[[6L]])) {
119	1x	writeLines(
120	1x	paste0(
121	1x	c(
122	1x	paste("#", name),
123		"",
124	1x	"This is a dcf data source project, initialized with `dcf::dcf_add_source`.",
125		"",
126	1x	"You can us the `dcf` package to check the project:",
127		"",
128	1x	"```R",
129	1x	paste0('dcf_check_source("', name, '", "..")'),
130		"```",
131		"",
132	1x	"And process it:",
133		"",
134	1x	"```R",
135	1x	paste0('dcf_process("', name, '", "..")'),
136		"```"
137		),
138	1x	collapse = "\n"
139		),
140	1x	paths[[6L]]
141		)
142		}
143	!	if (open_after) rstudioapi::openProject(paths[[3L]], newSession = TRUE)
144		}

1		#' Make a measurement metadata file
2		#'
3		#' Make a \code{measure_info.json} file, or add measure entries to an existing one.
4		#'
5		#' @param path Path to the \code{measure_info.json} file, existing or to be created.
6		#' @param ... Lists containing individual measure items. See the Measure Entries section.
7		#' @param info A list containing measurement information to be added.
8		#' @param references A list containing citation entries. See the Reference Entries section.
9		#' @param references A list containing source entries. See the Sources Entries section.
10		#' @param strict Logical; if \code{TRUE}, will only allow recognized entries and values.
11		#' @param include_empty Logical; if \code{FALSE}, will omit entries that have not been provided.
12		#' @param overwrite_entry Logical; if \code{TRUE}, will replace rather than add to an existing entry.
13		#' @param render Path to save a version of \code{path} to, with dynamic entries expanded. See the
14		#' Dynamic Entries section.
15		#' @param overwrite Logical; if \code{TRUE}, will overwrite rather than add to an existing \code{path}.
16		#' @param write Logical; if \code{FALSE}, will not write the build or rendered measure info.
17		#' @param verbose Logical; if \code{FALSE}, will not display status messages.
18		#' @param open_after Logical; if \code{FALSE}, will not open the measure file after writing/updating.
19		#' @section Measure Entries:
20		#' Measure entries are named by the unique variable name with any of these entries (if \code{strict}):
21		#' \itemize{
22		#' \item \strong{\code{id}}: Unique identifier of the measure; same as the entry name.
23		#' This is meant to correspond to the column name containing the measure in data files.
24		#' It should be minimal in length while still being unique across all files within the project.
25		#' It should only contain the characters \code{a-z}, \code{0-9}, or \code{_}.
26		#' \item \strong{\code{short_name}}: Shortest possible display name.
27		#' \item \strong{\code{long_name}}: Longer display name.
28		#' \item \strong{\code{category}}: Arbitrary category for the measure.
29		#' \item \strong{\code{short_description}}: Shortest possible description.
30		#' \item \strong{\code{long_description}}: Complete description. Either description can include
31		#' TeX-style equations, enclosed in escaped square brackets (e.g.,
32		#' \code{"The equation \\\\[a_{i} = b^\\\\frac{c}{d}\\\\] was used."}; or \code{$...$},
33		#' \code{\\\\(...\\\\)}, or \code{\\\\begin{math}...\\\\end{math}}). The final enclosing symbol must be
34		#' followed by a space or the end of the string. These are pre-render to MathML with
35		#' \code{\link[katex]{katex_mathml}}.
36		#' \item \strong{\code{statement}}: String with dynamic references to entity features
37		#' (e.g., \code{"measure value = {value}"}). References can include:
38		#' \itemize{
39		#' \item \code{value}: Value of a currently displaying variable at a current time.
40		#' \item \code{region_name}: Alias of \code{features.name}.
41		#' \item \code{features.<entry>}: An entity feature, coming from \code{entity_info.json} or GeoJSON properties.
42		#' All entities have at least \code{name} and \code{id} entries (e.g., \code{"{features.id}"}).
43		#' \item \code{variables.<entry>}: A variable feature such as \code{name} which is the same as
44		#' \code{id} (e.g., \code{"{variables.name}"}).
45		#' \item \code{data.<variable>}: The value of another variable at a current time (e.g., \code{"{data.variable_a}"}).
46		#' }
47		#' \item \strong{\code{measure_type}}: Type of the measure's value. Recognized types are displayed in a special way:
48		#' \itemize{
49		#' \item \code{year} or \code{integer} show as entered (usually as whole numbers). Other numeric
50		#' types are rounded to show a set number of digits.
51		#' \item \code{percent} shows as \code{{value}\%}.
52		#' \item \code{minutes} shows as \code{{value} minutes}.
53		#' \item \code{dollar} shows as \code{${value}}.
54		#' \item \code{internet speed} shows as \code{{value} Mbps}.
55		#' }
56		#' \item \strong{\code{unit}}: Prefix or suffix associated with the measure's type, such as \code{\%} for \code{percent},
57		#' or \code{Mbps} for \code{rate}.
58		#' \item \strong{\code{time_resolution}}: Temporal resolution of the variable, such as \code{year} or \code{week}.
59		#' \item \strong{\code{restrictions}}: A license or description of restrictions that may apply to the measure.
60		#' \item \strong{\code{sources}}: A list or list of list containing source information, including any of these entries:
61		#' \itemize{
62		#' \item \code{id}: An ID found in the \code{_sources} entry, to inherit entries from.
63		#' \item \code{name}: Name of the source (such as an organization name).
64		#' \item \code{url}: General URL of the source (such as an organization's website).
65		#' \item \code{location}: More specific description of the source (such as a the name of a particular data product).
66		#' \item \code{location_url}: More direct URL to the resource (such as a page listing data products).
67		#' }
68		#' \item \strong{\code{citations}}: A vector of reference ids (the names of \code{reference} entries; e.g., \code{c("ref1", "ref3")}).
69		#' \item \strong{\code{categories}}: A named list of categories, with any of the other measure entries, or a
70		#' \code{default} entry giving a default category name. See the Dynamic Entries section.
71		#' \item \strong{\code{variants}}: A named list of variants, with any of the other measure entries, or a
72		#' \code{default} entry giving a default variant name. See the Dynamic Entries section.
73		#' }
74		#' @section Dynamic Entries:
75		#' You may have several closely related variables in a dataset, which share sections of metadata,
76		#' or have formulaic differences. In cases like this, the \code{categories} and/or \code{variants} entries
77		#' can be used along with dynamic notation to construct multiple entries from a single template.
78		#'
79		#' Though functionally the same, \code{categories} might include broken-out subsets of some total
80		#' (such as race groups, as categories of a total population), whereas \code{variants} may be different
81		#' transformations of the same variable (such as raw counts versus percentages).
82		#'
83		#' In dynamic entries, \code{{category}} or \code{{variant}} refers to entries in the \code{categories}
84		#' or \code{variants} lists. By default, these are replaced with the name of each entries in those lists
85		#' (e.g., \code{"variable_{category}"} where \code{categories = "a"} would become \code{"variable_a"}).
86		#' A \code{default} entry would change this behavior (e.g., with \code{categories = list(a = list(default = "b")}
87		#' that would become \code{"variable_b"}). Adding \code{.name} would force the original behavior (e.g.,
88		#' \code{"variable_{category.name}"} would be \code{"variable_a"}). A name of \code{"blank"} is treated as
89		#' an empty string.
90		#'
91		#' When notation appears in a measure info entry, they will first default to a matching name in the \code{categories}
92		#' or \code{variants} list; for example, \code{short_name} in \code{list(short_name = "variable {category}")} with
93		#' \code{categories = list(a = list(short_name = "(category a)"))} would become \code{"variable (category a)"}.
94		#' To force this behavior, the entry name can be included in the notation (e.g.,
95		#' \code{"{category.short_name}"} would be \code{"variable (category a)"} in any entry).
96		#'
97		#' Only string entries are processed dynamically -- any list-like entries (such as
98		#' \code{source}, \code{citations}, or \code{layer}) appearing in
99		#' \code{categories} or \code{variants} entries will fully replace the base entry.
100		#'
101		#' Dynamic entries can be kept dynamic when passed to a data site, but can be rendered for other uses,
102		#' where the rendered version will have each dynamic entry replaced with all unique combinations of
103		#' \code{categories} and \code{variants} entries, assuming both are used in the dynamic entry's name
104		#' (e.g., \code{"variable_{category}_{variant}"}). See Examples.
105		#' @section Reference Entries:
106		#' Reference entries can be included in a \code{_references} entry, and should have names corresponding to
107		#' those included in any of the measures' \code{citation} entries. These can include any of these entries:
108		#' \itemize{
109		#' \item \strong{\code{id}}: The reference id, same as the entry name.
110		#' \item \strong{\code{author}}: A list or list of lists specifying one or more authors. These can include
111		#' entries for \code{given} and \code{family} names.
112		#' \item \strong{\code{year}}: Year of the publication.
113		#' \item \strong{\code{title}}: Title of the publication.
114		#' \item \strong{\code{journal}}: Journal in which the publication appears.
115		#' \item \strong{\code{volume}}: Volume number of the journal.
116		#' \item \strong{\code{page}}: Page number of the journal.
117		#' \item \strong{\code{doi}}: Digital Object Identifier, from which a link is made (\code{https://doi.org/{doi}}).
118		#' \item \strong{\code{version}}: Version number of software.
119		#' \item \strong{\code{url}}: Link to the publication, alternative to a DOI.
120		#' }
121		#' @section Source Entries:
122		#' Source entries can be included in a \code{_sources} entry, and should have names corresponding to those
123		#' included in any of the measures' \code{sources} entry. These can include any of these entries:
124		#' \itemize{
125		#' \item \strong{\code{name}}: Name of the source.
126		#' \item \strong{\code{url}}: Link to the source's site.
127		#' \item \strong{\code{description}}: A description of the source.
128		#' \item \strong{\code{notes}}: A list of additional notes about the source.
129		#' \item \strong{\code{organization}}: Name of a higher-level organization that the source is a part of.
130		#' \item \strong{\code{organization_url}}: Link to the organization's site.
131		#' \item \strong{\code{category}}: A top-level category classification.
132		#' \item \strong{\code{subcategory}}: A lower-level category classification.
133		#' }
134		#' @examples
135		#' path <- tempfile()
136		#'
137		#' # make an initial file
138		#' dcf_measure_info(path, "measure_name" = list(
139		#' id = "measure_name",
140		#' short_description = "A measure.",
141		#' statement = "This entity has {value} measure units."
142		#' ), verbose = FALSE)
143		#'
144		#' # add another measure to that
145		#' measure_info <- dcf_measure_info(path, "measure_two" = list(
146		#' id = "measure_two",
147		#' short_description = "Another measure.",
148		#' statement = "This entity has {value} measure units."
149		#' ), verbose = FALSE)
150		#' names(measure_info)
151		#'
152		#' # add a dynamic measure, and make a rendered version
153		#' measure_info_rendered <- dcf_measure_info(
154		#' path,
155		#' "measure_{category}_{variant.name}" = list(
156		#' id = "measure_{category}_{variant.name}",
157		#' short_description = "Another measure ({category}; {variant}).",
158		#' statement = "This entity has {value} {category} {variant}s.",
159		#' categories = c("a", "b"),
160		#' variants = list(u1 = list(default = "U1"), u2 = list(default = "U2"))
161		#' ),
162		#' render = TRUE, verbose = FALSE
163		#' )
164		#' names(measure_info_rendered)
165		#' measure_info_rendered[["measure_a_u1"]]$statement
166		#' @return An invisible list containing measurement metadata (the rendered version if made).
167		#' @export
168
169		dcf_measure_info <- function(
170		path,
171		...,
172		info = list(),
173		references = list(),
174		sources = list(),
175		strict = FALSE,
176		include_empty = TRUE,
177		overwrite_entry = FALSE,
178		render = NULL,
179		overwrite = FALSE,
180		write = TRUE,
181		verbose = TRUE,
182		open_after = interactive()
183		) {
184	16x	if (write) {
185	8x	if (missing(path) \|\| !is.character(path)) {
186	!	cli::cli_abort(
187	!	"enter a path to the measure_info.json file as {.arg path}"
188		)
189		}
190	8x	dir.create(dirname(path), FALSE, TRUE)
191		}
192	16x	built <- list()
193	16x	if (!overwrite && is.character(path) && file.exists(path)) {
194	14x	if (verbose) {
195	5x	cli::cli_bullets(c(
196	5x	i = "updating existing file: {.path {basename(path)}}"
197		))
198		}
199	14x	built <- jsonlite::read_json(path)
200	14x	if (all(c("id", "measure_type") %in% names(built))) {
201	!	built <- list(built)
202	!	names(built) <- built[[1]]$id
203		}
204		}
205	16x	if (length(references)) {
206	1x	references <- c(references, built$`_references`)
207	1x	references <- references[!duplicated(names(references))]
208	1x	built$`_references` <- references
209		} else {
210	15x	references <- built$`_references`
211		}
212	16x	if (length(sources)) {
213	!	sources <- c(sources, built$`_sources`)
214	!	sources <- sources[!duplicated(names(sources))]
215	!	built$`_sources` <- sources
216		} else {
217	16x	sources <- built$`_sources`
218		}
219	16x	defaults <- list(
220	16x	id = "",
221	16x	short_name = "",
222	16x	long_name = "",
223	16x	category = "",
224	16x	short_description = "",
225	16x	long_description = "",
226	16x	statement = "",
227	16x	measure_type = "",
228	16x	unit = "",
229	16x	time_resolution = "",
230	16x	restrictions = "",
231	16x	sources = list(),
232	16x	citations = list()
233		)
234	16x	if (!is.list(info)) {
235	!	info <- sapply(info, function(name) list())
236		}
237	16x	info <- c(list(...), info)
238	16x	if (length(info) && is.null(names(info))) {
239	!	cli::cli_abort("supplied measure entries must be named")
240		}
241	16x	for (n in names(info)) {
242	8x	if (overwrite_entry \|\| is.null(built[[n]])) {
243	7x	l <- info[[n]]
244		} else {
245	1x	l <- c(info[[n]], built[[n]])
246	1x	l <- l[!duplicated(names(l))]
247		}
248	8x	if (is.null(l$id)) {
249	3x	l$id <- n
250		}
251	8x	if (strict) {
252	1x	su <- names(l) %in% names(defaults)
253	1x	if (verbose && any(!su)) {
254	1x	cli::cli_warn(paste0(
255	1x	"unrecognized {?entry/entries} in ",
256	1x	n,
257	1x	": {names(l)[!su]}"
258		))
259		}
260	1x	if (include_empty) {
261	!	for (e in names(l)) {
262	!	if (!is.null(defaults[[e]])) {
263	!	defaults[[e]] <- l[[e]]
264		}
265		}
266	!	l <- defaults
267		} else {
268	1x	l <- l[su]
269		}
270	7x	} else if (include_empty) {
271	6x	su <- !names(defaults) %in% names(l)
272	6x	if (any(su)) l <- c(l, defaults[su])
273		}
274	8x	if (!is.null(l$categories) && !is.list(l$categories)) {
275	1x	l$categories <- structure(
276	1x	lapply(l$categories, function(e) list(default = e)),
277	1x	names = l$categories
278		)
279		}
280	8x	if (!is.null(l$variants) && !is.list(l$variants)) {
281	!	l$variants <- structure(
282	!	lapply(l$variants, function(e) list(default = e)),
283	!	names = l$categories
284		)
285		}
286	8x	if (verbose && !is.null(l$citations)) {
287	6x	su <- !l$citations %in% names(references)
288	6x	if (any(su)) {
289	1x	cli::cli_warn(
290	1x	"no matching reference entry for {.val {l$citations[su]}} in {.val {n}}"
291		)
292		}
293		}
294	8x	if (verbose && !is.null(l$sources)) {
295	4x	l_sources <- if (!is.character(l$sources)) l$sources else
296	4x	Filter(
297	4x	nchar,
298	4x	vapply(
299	4x	l$sources,
300	4x	function(s)
301	4x	if (is.character(s)) s else if (is.null(s$id)) "" else s$id,
302		""
303		)
304		)
305	4x	if (length(l_sources)) {
306	!	su <- l_sources %in% names(sources)
307	!	if (any(su)) {
308	!	cli::cli_warn(
309	!	"no matching reference entry for {.val {l_sources[su]}} in {.val {n}}"
310		)
311		}
312		}
313		}
314	8x	built[[n]] <- l
315		}
316	16x	built <- built[order(grepl("^_", names(built)))]
317	16x	if (write) {
318	8x	if (verbose) {
319	6x	cli::cli_bullets(c(i = "writing info to {.path {path}}"))
320		}
321	8x	jsonlite::write_json(built, path, auto_unbox = TRUE, pretty = TRUE)
322		}
323	16x	if (!is.null(render)) {
324	9x	expanded <- list()
325	9x	for (name in names(built)) {
326	16x	expanded <- c(
327	16x	expanded,
328	16x	if (grepl("{", name, fixed = TRUE)) {
329	1x	render_info(built[name])
330		} else {
331	15x	structure(list(built[[name]]), names = name)
332		}
333		)
334		}
335	9x	changed <- !identical(built, expanded)
336	9x	built <- expanded
337	9x	if (write && changed) {
338	1x	path <- if (is.character(render)) {
339	!	render
340		} else {
341	1x	sub("\\.json", "_rendered.json", path, TRUE)
342		}
343	1x	if (verbose) {
344	1x	cli::cli_bullets(c(i = "writing rendered info to {.path {path}}"))
345		}
346	1x	jsonlite::write_json(built, path, auto_unbox = TRUE, pretty = TRUE)
347		}
348		}
349	16x	if (open_after) {
350	!	rstudioapi::navigateToFile(path)
351		}
352	16x	invisible(built)
353		}
354
355		replace_equations <- function(info) {
356	4x	lapply(info, function(e) {
357	!	if (!is.list(e)) e <- list(default = e)
358	5x	descriptions <- grep("description", names(e), fixed = TRUE)
359	5x	if (length(descriptions)) {
360	5x	for (d in descriptions) {
361	10x	p <- gregexpr(
362	10x	"(?:\\$\|\\\\\\[\|\\\\\\(\|\\\\begin\\{math\\})(.+?)(?:\\$\|\\\\\\]\|\\\\\\)\|\\\\end\\{math\\})(?=\\s\|$)",
363	10x	e[[d]],
364	10x	perl = TRUE
365	10x	)[[1]]
366	10x	if (p[[1]] != -1) {
367	!	re <- paste("", e[[d]], "")
368	!	fm <- regmatches(e[[d]], p)
369	!	for (i in seq_along(p)) {
370	!	mp <- attr(p, "capture.start")[i, ]
371	!	eq <- substring(e[[d]], mp, mp + attr(p, "capture.length")[i, ] - 1)
372	!	parsed <- tryCatch(
373	!	katex::katex_mathml(eq),
374	!	error = function(e) NULL
375		)
376	!	if (!is.null(parsed)) {
377	!	re <- paste(
378	!	strsplit(re, fm[[i]], fixed = TRUE)[[1]],
379	!	collapse = sub("^<[^>]>", "", sub("<[^>]>$", "", parsed))
380		)
381		}
382		}
383	!	e[[d]] <- gsub("^ \| $", "", re)
384		}
385		}
386		}
387	!	if (is.list(e$categories)) e$categories <- replace_equations(e$categories)
388	!	if (is.list(e$variants)) e$variants <- replace_equations(e$variants)
389	5x	e
390		})
391		}
392
393		preprocess <- function(l) {
394	!	if (!is.list(l)) l <- sapply(l, function(n) list())
395	2x	ns <- names(l)
396	2x	for (i in seq_along(l)) {
397	4x	name <- if (ns[i] == "blank") "" else ns[i]
398	4x	l[[i]]$name <- name
399	1x	if (is.null(l[[i]]$default)) l[[i]]$default <- name
400		}
401	2x	l
402		}
403
404		replace_dynamic <- function(e, p, s, v = NULL, default = "default") {
405	68x	m <- gregexpr(p, e)
406	68x	if (m[[1]][[1]] != -1) {
407	16x	t <- regmatches(e, m)[[1]]
408	16x	tm <- structure(gsub("\\{[^.]+\\.?\|\\}", "", t), names = t)
409	16x	tm <- tm[!duplicated(names(tm))]
410	16x	tm[tm == ""] <- default
411	16x	for (tar in names(tm)) {
412	32x	us <- (if (is.null(v) \|\| substring(tar, 2, 2) == "c") s else v)
413	32x	entry <- tm[[tar]]
414	32x	if (is.null(us[[entry]]) && grepl("description", entry, fixed = TRUE)) {
415	8x	entry <- default <- "description"
416		}
417	20x	if (is.null(us[[entry]]) && entry == default) entry <- "default"
418	32x	if (is.null(us[[entry]]))
419	!	cli::cli_abort("failed to render measure info from {tar}")
420	32x	e <- gsub(tar, us[[entry]], e, fixed = TRUE)
421		}
422		}
423	68x	e
424		}
425
426		prepare_source <- function(o, s, p) {
427	8x	if (length(o)) {
428	8x	lapply(o, function(e) {
429	2x	if (is.character(e) && length(e) == 1) replace_dynamic(e, p, s) else e
430		})
431		} else {
432	!	list(name = "", default = "")
433		}
434		}
435
436		render_info_names <- function(infos) {
437	!	r <- lapply(names(infos), function(n) render_info(infos[n], TRUE))
438	!	structure(rep(names(infos), vapply(r, length, 0)), names = unlist(r))
439		}
440
441		render_info <- function(info, names_only = FALSE) {
442	1x	base_name <- names(info)
443	1x	base <- info[[1]]
444	1x	if (is.null(base$categories) && is.null(base$variants)) {
445	!	return(if (names_only) base_name else info)
446		}
447	1x	categories <- preprocess(base$categories)
448	1x	variants <- preprocess(base$variants)
449	1x	base$categories <- NULL
450	1x	base$variants <- NULL
451	1x	expanded <- NULL
452	1x	vars <- strsplit(
453	1x	as.character(outer(
454	1x	if (is.null(names(categories))) "" else names(categories),
455	1x	if (is.null(names(variants))) "" else names(variants),
456	1x	paste,
457	1x	sep = "\|\|\|"
458		)),
459		"\|\|\|",
460	1x	fixed = TRUE
461		)
462	1x	for (var in vars) {
463	4x	cs <- if (var[1] == "") list() else categories[[var[1]]]
464	4x	vs <- if (length(var) == 1 \|\| var[2] == "") list() else variants[[var[2]]]
465	4x	cs <- prepare_source(cs, vs, "\\{variants?(?:\\.[^}]+?)?\\}")
466	4x	vs <- prepare_source(vs, cs, "\\{categor(?:y\|ies)(?:\\.[^}]+?)?\\}")
467	4x	s <- c(cs, vs[!names(vs) %in% names(cs)])
468	4x	p <- "\\{(?:categor(?:y\|ies)\|variants?)(?:\\.[^}]+?)?\\}"
469	4x	key <- replace_dynamic(base_name, p, cs, vs)
470	4x	if (names_only) {
471	!	expanded <- c(expanded, key)
472		} else {
473	4x	expanded[[key]] <- c(
474	4x	structure(
475	4x	lapply(names(base), function(n) {
476	52x	e <- base[[n]]
477	52x	if (is.character(e) && length(e) == 1)
478	44x	e <- replace_dynamic(e, p, cs, vs, n)
479	52x	e
480		}),
481	4x	names = names(base)
482		),
483	4x	s[
484	4x	!names(s) %in%
485	4x	c(
486	4x	"default",
487	4x	"name",
488	4x	if (any(base[c("long_description", "short_description")] != ""))
489	4x	"description",
490	4x	names(base)
491		)
492		]
493		)
494		}
495		}
496	1x	expanded
497		}

1		#' Adds a Bundle Project
2		#'
3		#' Establishes a new data bundle project, used to prepare outputs from standardized datasets.
4		#'
5		#' @param name Name of the bundle
6		#' @param project_dir Path to the Data Collection Framework project.
7		#' @param source_files Character vector of paths to standard files form source projects.
8		#' @param open_after Logical; if \code{FALSE}, will not open the project.
9		#' @returns Nothing; creates default files and directories.
10		#' @section Project:
11		#'
12		#' Within a bundle project, there are two files to edits:
13		#' \itemize{
14		#' \item \strong{\code{build.R}}: This is the primary script, which is automatically rerun.
15		#' It should read data from the \code{standard} directory of source projects,
16		#' and write to it's own \code{dist} directory.
17		#' \item \strong{\code{measure_info.json}}: This should list all non-ID variable names
18		#' in the data files within \code{dist}. These will inherit the standard measure info
19		#' if found in the source projects referred to in \code{source_files}.
20		#' If the \code{dist} name is different, but should still inherit standard measure info,
21		#' a \code{source_id} entry with the original measure ID will be used to identify the original
22		#' measure info.
23		#' See \code{\link{dcf_measure_info}}.
24		#' }
25		#'
26		#' @examples
27		#' project_dir <- paste0(tempdir(), "/temp_project")
28		#' dcf_init("temp_project", dirname(project_dir))
29		#' dcf_add_bundle("bundle_name", project_dir)
30		#' list.files(paste0(project_dir, "/data/bundle_name"))
31		#'
32		#' @export
33
34		dcf_add_bundle <- function(
35		name,
36		project_dir = ".",
37		source_files = NULL,
38		open_after = interactive()
39		) {
40	2x	if (missing(name)) {
41	!	cli::cli_abort("specify a name")
42		}
43	2x	name <- gsub("[^A-Za-z0-9]+", "_", name)
44	2x	settings <- dcf_read_settings(project_dir)
45	2x	if (!is.null(source_files)) {
46	1x	su <- !file.exists(paste0(settings$data_dir, "/", source_files))
47	1x	if (any(su)) {
48	!	cli::cli_abort(
49	!	"source file{? doesn't/s don't} exist: {settings$data_dir[su]}"
50		)
51		}
52		}
53	2x	base_dir <- paste(c(project_dir, settings$data_dir, name), collapse = "/")
54	2x	dir.create(paste0(base_dir, "/dist"), showWarnings = FALSE, recursive = TRUE)
55	2x	paths <- paste0(
56	2x	base_dir,
57		"/",
58	2x	c(
59	2x	"README.md",
60	2x	"project.Rproj",
61	2x	"process.json",
62	2x	"measure_info.json",
63	2x	"build.R"
64		)
65		)
66	2x	if (!file.exists(paths[[1L]])) {
67	1x	writeLines(
68	1x	paste0(
69	1x	c(
70	1x	paste("#", name),
71		"",
72	1x	"This is a Data Collection Framework data bundle project, initialized with `dcf::dcf_add_bundle`.",
73		"",
74	1x	"You can us the `dcf` package to rebuild the bundle:",
75		"",
76	1x	"```R",
77	1x	paste0('dcf::dcf_process("', name, '", "..")'),
78		"```"
79		),
80	1x	collapse = "\n"
81		),
82	1x	paths[[1L]]
83		)
84		}
85	2x	if (!file.exists(paths[[2L]])) {
86	1x	writeLines("Version: 1.0\n", paths[[2L]])
87		}
88	2x	if (!file.exists(paths[[3L]])) {
89	1x	jsonlite::write_json(
90	1x	list(
91	1x	name = name,
92	1x	type = "bundle",
93	1x	scripts = list(
94	1x	list(
95	1x	path = "build.R",
96	1x	last_run = "",
97	1x	run_time = "",
98	1x	last_status = list(log = "", success = TRUE)
99		)
100		),
101	1x	source_files = source_files
102		),
103	1x	paths[[3L]],
104	1x	auto_unbox = TRUE,
105	1x	pretty = TRUE
106		)
107		}
108	2x	if (!file.exists(paths[[4L]])) {
109	1x	writeLines("{}\n", paths[[4L]])
110		}
111	2x	if (!file.exists(paths[[5L]])) {
112	1x	writeLines(
113	1x	paste0(
114	1x	c(
115	1x	"# read data from data source projects",
116	1x	"# and write to this project's `dist` directory",
117		""
118		),
119	1x	collapse = "\n"
120		),
121	1x	paths[[5L]]
122		)
123		}
124	!	if (open_after) rstudioapi::openProject(paths[[2L]], newSession = TRUE)
125		}

1		#' Read Epic Cosmos Data
2		#'
3		#' Read in metadata and data from an Epic Cosmos file.
4		#'
5		#' @param path Path to the file.
6		#' @param path_root Directory containing \code{path}, if it is not full.
7		#' @returns A list with \code{data.frame} entries for \code{metadata} and \code{data}.
8		#'
9		#' @examples
10		#' # write an example file
11		#' path <- tempfile(fileext = ".csv")
12		#' raw_lines <- c(
13		#' "metadata field,metadata value,",
14		#' ",,",
15		#' ",Measures,Value Name",
16		#' "Year,Measure 1,",
17		#' "2020,m1,1",
18		#' ",m2,2",
19		#' "2021,m1,3",
20		#' ",m2,4"
21		#' )
22		#' writeLines(raw_lines, path)
23		#'
24		#' # read it in
25		#' dcf_read_epic(basename(path), dirname(path))
26		#'
27		#' @export
28
29		dcf_read_epic <- function(path, path_root = ".") {
30	3x	full_path <- if (file.exists(path)) {
31	3x	path
32		} else {
33	!	sub("//", "/", paste0(path_root, "/", path), fixed = TRUE)
34		}
35	3x	lines <- readLines(full_path, n = 25L, skipNul = FALSE)
36	3x	metadata_break <- grep("^[, ]*$", lines)
37	3x	if (!length(metadata_break)) {
38	!	cli::cli_abort(
39	!	"path does not appear to point to a file in the Epic format (no metadata separation)"
40		)
41		}
42	3x	meta_end <- min(metadata_break) - 1L
43	3x	data_start <- (if (length(metadata_break) == 1L) {
44	3x	metadata_break
45		} else {
46	!	max(metadata_break[
47	!	metadata_break == c(-1L, metadata_break[-1L])
48		])
49		}) +
50	3x	1L
51	3x	meta <- c(
52	3x	list(
53	3x	file = path,
54	3x	md5 = unname(tools::md5sum(full_path)),
55	3x	date_processed = Sys.time(),
56	3x	standard_name = ""
57		),
58	3x	as.list(unlist(lapply(
59	3x	strsplit(sub(",+$", "", lines[seq_len(meta_end)]), ",", fixed = TRUE),
60	3x	function(r) {
61	3x	l <- list(paste(r[-1L], collapse = ","))
62	3x	if (l[[1]] == "") {
63	!	r <- strsplit(r, ": ", fixed = TRUE)[[1L]]
64	!	l <- list(paste(r[-1L], collapse = ","))
65		}
66	3x	names(l) <- r[[1L]]
67	3x	l[[1L]] <- gsub('^"\|"$', "", l[[1L]])
68	3x	l
69		}
70		)))
71		)
72	3x	standard_names <- c(
73	3x	vaccine_mmr = "mmr receipt",
74	3x	rsv_tests = "rsv tests",
75	3x	flu = "influenza",
76	3x	self_harm = "self-harm",
77	3x	covid = "covid",
78	3x	rsv = "rsv",
79	3x	obesity = "bmi",
80	3x	obesity = "obesity",
81	3x	hba1c = "hba1c",
82	3x	ed_opioid = "opioid",
83	3x	ed_firearm = "firearm",
84	3x	ed_workplace = "workplace",
85	3x	ed_fall = "diagnoses: fall",
86	3x	ed_drowning = "drowning",
87	3x	all_encounters = "all ed encounters",
88	3x	all_patients = "all patients"
89		)
90	3x	meta_string <- tolower(paste(unlist(meta), collapse = " "))
91	3x	for (i in seq_along(standard_names)) {
92	22x	if (grepl(standard_names[[i]], meta_string, fixed = TRUE)) {
93	3x	meta$standard_name = names(standard_names)[[i]]
94	3x	break
95		}
96		}
97	3x	header_rows <- data_start + c(0L, 1L)
98	3x	lines[header_rows] <- gsub(
99		',(?=[^",]+")',
100		"",
101	3x	lines[header_rows],
102	3x	perl = TRUE
103		)
104	3x	header <- strsplit(lines[header_rows[[2L]]], ",", fixed = TRUE)[[1L]]
105	3x	id_cols <- which(header != "")
106	3x	header <- c(
107	3x	header[id_cols],
108	3x	strsplit(lines[data_start], ",", fixed = TRUE)[[1L]][-id_cols]
109		)
110	3x	data <- arrow::read_csv_arrow(
111	3x	full_path,
112	3x	col_names = header,
113	3x	col_types = paste(rep("c", length(header)), collapse = ""),
114	3x	na = c("", "-"),
115	3x	skip = data_start + 1L
116		)
117	3x	percents <- grep("^(?:Percent\|Base\|RSV test)", header, ignore.case = TRUE)
118	3x	if (length(percents)) {
119	!	for (col in percents) {
120	!	data[[col]] <- sub("%", "", data[[col]], fixed = TRUE)
121		}
122		}
123	3x	number <- grep("Number", header, fixed = TRUE)
124	3x	if (length(number)) {
125	!	for (col in number) {
126	!	data[[col]][data[[col]] == "10 or fewer"] <- 5L
127		}
128		}
129	3x	for (col in id_cols) {
130	14x	data[[col]] <- vctrs::vec_fill_missing(data[[col]], "down")
131		}
132	3x	if (all(c("Measures", "Base Patient") %in% colnames(data))) {
133	!	data <- Reduce(
134	!	merge,
135	!	lapply(split(data, data$Measures), function(d) {
136	!	measure <- d$Measures[[1L]]
137	!	d[[measure]] <- d[["Base Patient"]]
138	!	d[, !(colnames(d) %in% c("Measures", "Base Patient"))]
139		})
140		)
141		}
142	3x	colnames(data) <- standard_columns(colnames(data))
143	3x	if (meta$standard_name == "obesity") {
144	!	meta$standard_name <- paste0(
145	!	meta$standard_name,
146		"_",
147	!	if ("state" %in% colnames(data)) "state" else "county"
148		)
149		} else if (
150	3x	meta$standard_name == "all_encounters" && "week" %in% colnames(data)
151		) {
152	!	meta$standard_name = "all_encounters_weekly"
153		}
154	3x	if ("age" %in% colnames(data)) {
155	3x	std_age <- standard_age(data$age)
156	3x	missed_ages <- (data$age != "No value") & is.na(std_age)
157	3x	if (any(missed_ages)) {
158	!	std_age[missed_ages] <- data$age[missed_ages]
159	!	missed_levels <- unique(data$age[missed_ages])
160	!	cli::cli_warn("missed age levels: {.field {missed_levels}}")
161		}
162	3x	data$age <- std_age
163		}
164	3x	list(metadata = meta, data = data)
165		}
166
167		standard_age <- function(age) {
168	3x	c(
169	3x	`less than 1` = "<1 Years",
170	3x	`1 and < 2` = "1-2 Years",
171	3x	`2 and < 3` = "2-3 Years",
172	3x	`3 and < 4` = "3-4 Years",
173	3x	`1 and < 5` = "1-4 Years",
174	3x	`1 year or more and less than 5` = "1-4 Years",
175	3x	`4 and < 5` = "4-5 Years",
176	3x	`less than 5` = "<5 Years",
177	3x	`5 and < 6` = "5-6 Years",
178	3x	`5 and < 18` = "5-17 Years",
179	3x	`5 or more and less than 18 (1)` = "5-17 Years",
180	3x	`6 and < 7` = "6-7 Years",
181	3x	`6 or more` = "6+ Years",
182	3x	`7 and < 8` = "7-8 Years",
183	3x	`8 and < 9` = "8-9 Years",
184	3x	`9 or more` = "9+ Years",
185	3x	`less than 10` = "<10 Years",
186	3x	`10 and < 15` = "10-14 Years",
187	3x	`less than 15` = "<15 Years",
188	3x	`15 and < 20` = "15-19 Years",
189	3x	`15 and < 25` = "15-25 Years",
190	3x	`less than 18` = "<18 Years",
191	3x	`18 and < 25` = "18-24 Years",
192	3x	`18 and < 40` = "18-39 Years",
193	3x	`18 and < 45` = "18-44 Years",
194	3x	`18 and < 50` = "18-49 Years",
195	3x	`18 or more and less than 50` = "18-49 Years",
196	3x	`20 and < 40` = "20-39 Years",
197	3x	`25 and < 35` = "25-34 Years",
198	3x	`25 and < 45` = "25-45 Years",
199	3x	`35 and < 45` = "35-44 Years",
200	3x	`40 and < 65` = "40-64 Years",
201	3x	`45 and < 55` = "45-54 Years",
202	3x	`45 and < 65` = "45-64 Years",
203	3x	`45-64` = "45-64 Years",
204	3x	`45 and < 65` = "45-64 Years",
205	3x	`50 and < 65` = "50-64 Years",
206	3x	`50 or more and less than 64` = "50-64 Years",
207	3x	`55 and < 65` = "55-64 Years",
208	3x	`less than 65` = "<65 Years",
209	3x	`65 and < 110` = "65+ Years",
210	3x	`65 or more` = "65+ Years",
211	3x	`65+` = "65+ Years",
212	3x	`total` = "Total"
213		)[
214	3x	sub(" [Yy]ears", "", sub("^[^a-z0-9]+\|:.*$", "", tolower(age)))
215		]
216		}
217
218		standard_columns <- function(cols) {
219	3x	cols <- gsub(" ", "_", sub("number of ", "n_", tolower(cols)), fixed = TRUE)
220	3x	cols[grep("^age", cols)] <- "age"
221	3x	cols[grep("^state", cols)] <- "state"
222	3x	cols[grep("^county", cols)] <- "county"
223	3x	cols[grep("bmi_30", cols)] <- "bmi_30_49.8"
224	3x	cols[grep("hemoglobin_a1c_7", cols)] <- "hemoglobin_a1c_7"
225	3x	cols[grep("mmr_receipt", cols)] <- "mmr_receipt"
226	3x	cols[grep("opioid", cols)] <- "ed_opioid"
227	3x	cols[grep("^rsv_tests", cols)] <- "rsv_tests"
228	3x	cols
229		}

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 pretty Logical; if \code{TRUE}, will pretty-print the datapackage.
17		#' @param summarize_ids Logical; if \code{TRUE}, will include ID columns in schema field summaries.
18		#' @param open_after Logical; if \code{TRUE}, opens the written datapackage after saving.
19		#' @param verbose Logical; if \code{FALSE}, will not show status messages.
20		#' @details
21		#' \code{meta} should be a list with unnamed entries for entry in \code{filename},
22		#' and each entry can include a named entry for any of these:
23		#' \describe{
24		#' \item{source}{
25		#' A list or list of lists with entries for at least \code{name}, and ideally for \code{url}.
26		#' }
27		#' \item{ids}{
28		#' A list or list of lists with entries for at least \code{variable} (the name of a variable in the dataset).
29		#' Might also include \code{map} with a list or path to a JSON file resulting in a list with an
30		#' entry for each ID, and additional information about that entity, to be read in a its features.
31		#' All files will be loaded to help with aggregation, but local files will be included in the datapackage,
32		#' whereas hosted files will be loaded client-side.
33		#' }
34		#' \item{time}{
35		#' A string giving the name of a variable in the dataset representing a repeated observation of the same entity.
36		#' }
37		#' \item{variables}{
38		#' A list with named entries providing more information about the variables in the dataset.
39		#' See \code{\link{dcf_measure_info}}.
40		#' }
41		#' }
42		#' @examples
43		#' \dontrun{
44		#' # write example data
45		#' write.csv(mtcars, "mtcars.csv")
46		#'
47		#' # add it to an existing datapackage.json file in the current working directory
48		#' dcf_datapackage_add("mtcars.csv")
49		#' }
50		#' @return An invisible version of the updated datapackage, which is also written to
51		#' \code{datapackage.json} if \code{write = TRUE}.
52		#' @seealso Initialize the \code{datapackage.json} file with \code{\link{dcf_datapackage_init}}.
53		#' @export
54
55		dcf_datapackage_add <- function(
56		filename,
57		meta = list(),
58		packagename = "datapackage.json",
59		dir = ".",
60		write = TRUE,
61		refresh = TRUE,
62		sha = "512",
63		pretty = FALSE,
64		summarize_ids = FALSE,
65		open_after = FALSE,
66		verbose = interactive()
67		) {
68	4x	if (missing(filename)) {
69	!	cli::cli_abort("{.arg filename} must be specified")
70		}
71	4x	setnames <- names(filename)
72	4x	if (file.exists(filename[[1]])) {
73	!	if (dir == ".") {
74	!	dir <- dirname(filename[[1]])
75		}
76	!	filename <- basename(filename)
77		}
78	4x	if (any(!file.exists(paste0(dir, "/", filename)))) {
79	!	filename <- filename[!file.exists(filename)]
80	!	cli::cli_abort("{?a file/files} did not exist: {filename}")
81		}
82	4x	package <- if (
83	4x	is.character(packagename) && file.exists(paste0(dir, "/", packagename))
84		) {
85	4x	paste0(dir, "/", packagename)
86		} else {
87	!	packagename
88		}
89	4x	if (write) {
90	4x	if (is.character(package)) {
91	4x	package <- paste0(dir, "/", packagename)
92	4x	package <- if (file.exists(package)) {
93	4x	packagename <- package
94	4x	jsonlite::read_json(package)
95		} else {
96	!	dcf_datapackage_init(
97	!	if (!is.null(setnames)) setnames[[1]] else filename[[1]],
98	!	dir = dir
99		)
100		}
101		}
102	4x	if (!is.list(package)) {
103	!	cli::cli_abort(c(
104	!	"{.arg package} does not appear to be in the right format",
105	!	i = "this should be (or be read in from JSON as) a list with a {.code resource} entry"
106		))
107		}
108		}
109	4x	if (!is.list(package)) {
110	!	package <- list()
111		}
112	4x	single_meta <- FALSE
113	4x	metas <- if (!is.null(names(meta))) {
114	4x	if (!is.null(setnames) && all(setnames %in% names(meta))) {
115	!	meta[setnames]
116		} else {
117	4x	single_meta <- TRUE
118	4x	if (length(meta$variables) == 1 && is.character(meta$variables)) {
119	!	if (!file.exists(meta$variables)) {
120	!	meta$variables <- paste0(dir, "/", meta$variables)
121		}
122	!	if (file.exists(meta$variables)) {
123	!	meta$variables <- jsonlite::read_json(meta$variables)
124		}
125		}
126	4x	meta$variables <- replace_equations(meta$variables)
127	4x	meta
128		}
129		} else {
130	!	meta[seq_along(filename)]
131		}
132	4x	if (!single_meta) {
133	!	metas <- lapply(metas, function(m) {
134	!	m$variables <- replace_equations(m$variables)
135	!	m
136		})
137		}
138	4x	collect_metadata <- function(file) {
139	4x	f <- paste0(dir, "/", filename[[file]])
140	4x	m <- if (single_meta) meta else metas[[file]]
141	4x	format <- if (grepl(".parquet", f, fixed = TRUE)) {
142	!	"parquet"
143	4x	} else if (grepl(".json", f, fixed = TRUE)) {
144	1x	"json"
145	4x	} else if (grepl(".csv", f, fixed = TRUE)) {
146	3x	"csv"
147	4x	} else if (grepl(".rds", f, fixed = TRUE)) {
148	!	"rds"
149		} else {
150	!	"tsv"
151		}
152	4x	if (is.na(format)) {
153	!	format <- "rds"
154		}
155	4x	info <- file.info(f)
156	4x	metas <- list()
157	4x	unpack_meta <- function(n) {
158	12x	if (!length(m[[n]])) {
159	4x	list()
160	8x	} else if (is.list(m[[n]][[1]])) {
161	!	m[[n]]
162		} else {
163	8x	list(m[[n]])
164		}
165		}
166	4x	ids <- unpack_meta("ids")
167	4x	idvars <- NULL
168	4x	for (i in seq_along(ids)) {
169	4x	if (is.list(ids[[i]])) {
170	4x	if (
171	!	length(ids[[i]]$map) == 1 &&
172	!	is.character(ids[[i]]$map) &&
173	!	file.exists(ids[[i]]$map)
174		) {
175	!	ids[[i]]$map_content <- paste(
176	!	readLines(ids[[i]]$map, warn = FALSE),
177	!	collapse = ""
178		)
179		}
180		} else {
181	4x	ids[[i]] <- list(variable = ids[[i]])
182		}
183	4x	if (!ids[[i]]$variable %in% idvars) idvars <- c(idvars, ids[[i]]$variable)
184		}
185	4x	data <- if (format == "rds") {
186	!	tryCatch(readRDS(f), error = function(e) NULL)
187	4x	} else if (format == "parquet") {
188	!	tryCatch(arrow::read_parquet(f), error = function(e) NULL)
189	4x	} else if (format == "json") {
190	1x	tryCatch(
191	1x	as.data.frame(jsonlite::read_json(f, simplifyVector = TRUE)),
192	1x	error = function(e) NULL
193		)
194		} else {
195	3x	attempt_read(f, c("geography", "time", idvars))
196		}
197	4x	if (is.null(data)) {
198	!	cli::cli_warn(c(
199	!	paste0("failed to read in the data file ({.file {f}})"),
200	!	i = "check that it is in a compatible format"
201		))
202	!	return(NULL)
203		}
204	4x	if (!all(rownames(data) == seq_len(nrow(data)))) {
205	!	data <- cbind(`_row` = rownames(data), data)
206		}
207	4x	timevar <- unlist(unpack_meta("time"))
208	4x	times <- if (is.null(timevar)) rep(1, nrow(data)) else data[[timevar]]
209	4x	times_unique <- unique(times)
210	4x	if (!single_meta) {
211	!	varinf <- unpack_meta("variables")
212	!	if (length(varinf) == 1 && is.character(varinf[[1]])) {
213	!	if (!file.exists(varinf[[1]])) {
214	!	varinf[[1]] <- paste0(dir, "/", varinf[[1]])
215		}
216	!	if (file.exists(varinf[[1]])) {
217	!	if (varinf[[1]] %in% names(metas)) {
218	!	varinf <- metas[[varinf[[1]]]]
219		} else {
220	!	varinf <- metas[[varinf[[1]]]] <- dcf_measure_info(
221	!	varinf[[1]],
222	!	write = FALSE,
223	!	render = TRUE
224		)
225		}
226	!	varinf <- varinf[varinf != ""]
227		}
228		}
229	!	varinf_full <- names(varinf)
230	!	varinf_suf <- sub("^[^:]+:", "", varinf_full)
231		}
232	4x	res <- list(
233	4x	bytes = as.integer(info$size),
234	4x	encoding = stringi::stri_enc_detect(f)[[1]][1, 1],
235	4x	md5 = tools::md5sum(f)[[1]],
236	4x	format = format,
237	4x	name = if (!is.null(setnames)) {
238	!	setnames[file]
239	4x	} else if (!is.null(m$name)) {
240	!	m$name
241		} else {
242	4x	sub("\\.[^.]*$", "", basename(filename[[file]]))
243		},
244	4x	filename = filename[[file]],
245	4x	versions = get_versions(f),
246	4x	source = unpack_meta("source"),
247	4x	ids = ids,
248	4x	id_length = if (length(idvars)) {
249	4x	id_lengths <- nchar(data[[idvars[1]]])
250	4x	id_lengths <- id_lengths[!is.na(id_lengths)]
251	!	if (all(id_lengths == id_lengths[1])) id_lengths[1] else 0
252		} else {
253	!	0
254		},
255	4x	time = timevar,
256	4x	profile = "data-resource",
257	4x	created = as.character(info$mtime),
258	4x	last_modified = as.character(info$ctime),
259	4x	row_count = nrow(data),
260	4x	entity_count = if (length(idvars)) {
261	4x	length(unique(data[[idvars[1]]]))
262		} else {
263	!	nrow(data)
264		},
265	4x	schema = list(
266	4x	fields = lapply(
267	4x	if (summarize_ids) {
268	4x	colnames(data)
269		} else {
270	!	colnames(data)[!colnames(data) %in% idvars]
271		},
272	4x	function(cn) {
273	12x	v <- data[[cn]]
274	12x	invalid <- !is.finite(v)
275	12x	r <- list(name = cn, duplicates = sum(duplicated(v)))
276	12x	if (!single_meta) {
277	!	if (cn %in% varinf_full) {
278	!	r$info <- varinf[[cn]]
279	!	} else if (cn %in% varinf_suf) {
280	!	r$info <- varinf[[which(varinf_suf == cn)]]
281		}
282	!	r$info <- r$info[r$info != ""]
283		}
284	12x	su <- !is.na(v)
285	12x	if (any(su)) {
286	12x	r$time_range <- which(times_unique %in% range(times[su])) - 1
287	12x	r$time_range <- if (length(r$time_range)) {
288	12x	r$time_range[c(1, length(r$time_range))]
289		} else {
290	!	c(-1, -1)
291		}
292		} else {
293	!	r$time_range <- c(-1, -1)
294		}
295	12x	if (!is.character(v) && all(invalid)) {
296	!	r$type <- "unknown"
297	!	r$missing <- length(v)
298	12x	} else if (is.numeric(v)) {
299	5x	r$type <- if (all(invalid \| as.integer(v) == v)) {
300	5x	"integer"
301		} else {
302	!	"float"
303		}
304	5x	r$missing <- sum(invalid)
305	5x	r$mean <- round(mean(v, na.rm = TRUE), 6)
306	5x	r$sd <- round(stats::sd(v, na.rm = TRUE), 6)
307	5x	r$min <- round(min(v, na.rm = TRUE), 6)
308	5x	r$max <- round(max(v, na.rm = TRUE), 6)
309		} else {
310	7x	r$type <- "string"
311	7x	v <- as.factor(as.character(v))
312	7x	r$missing <- sum(is.na(v) \| is.nan(v) \| grepl("^[\\s.-]$", v))
313	7x	r$table <- structure(as.list(tabulate(v)), names = levels(v))
314		}
315	12x	r
316		}
317		)
318		)
319		)
320	4x	if (!single_meta && "_references" %in% names(varinf)) {
321	!	res[["_references"]] <- varinf[["_references"]]
322		}
323	4x	if (Sys.which("openssl") != "") {
324	4x	res[[paste0("sha", sha)]] <- calculate_sha(f, sha)
325		}
326	4x	res
327		}
328	4x	metadata <- Filter(length, lapply(seq_along(filename), collect_metadata))
329	4x	if (single_meta) {
330	4x	package$measure_info <- lapply(meta$variables, function(e) e[e != ""])
331		}
332	4x	names <- vapply(metadata, "[[", "", "filename")
333	4x	for (resource in package$resources) {
334	2x	if (length(resource$versions)) {
335	!	su <- which(names %in% resource$filename)
336	!	if (length(su)) {
337	!	if (length(metadata[[su]]$versions)) {
338	!	metadata[[su]]$versions <- rbind(
339	!	metadata[[su]]$versions,
340	!	if (is.data.frame(resource$versions)) {
341	!	resource$versions
342		} else {
343	!	as.data.frame(do.call(cbind, resource$versions))
344		}
345		)
346	!	metadata[[su]]$versions <- metadata[[su]]$versions[
347	!	!duplicated(metadata[[su]]$versions),
348		]
349		}
350		}
351		}
352		}
353	4x	if (refresh) {
354	4x	package$resources <- metadata
355		} else {
356	!	package$resources <- c(
357	!	metadata,
358	!	package$resources[
359	!	!(vapply(package$resources, "[[", "", "filename") %in% names)
360		]
361		)
362		}
363	4x	if (write) {
364	4x	packagename <- if (is.character(packagename)) {
365	4x	packagename
366		} else {
367	!	"datapackage.json"
368		}
369	4x	jsonlite::write_json(
370	4x	package,
371	4x	if (file.exists(packagename)) {
372	4x	packagename
373		} else {
374	!	paste0(dir, "/", packagename)
375		},
376	4x	auto_unbox = TRUE,
377	4x	digits = 6,
378	4x	dataframe = "columns",
379	4x	pretty = pretty
380		)
381	4x	if (verbose) {
382	!	cli::cli_bullets(c(
383	!	v = paste(
384	!	if (refresh) "updated resource in" else "added resource to",
385	!	"datapackage.json:"
386		),
387	!	"*" = paste0("{.path ", packagename, "}")
388		))
389	!	if (open_after) rstudioapi::navigateToFile(packagename)
390		}
391		}
392	4x	invisible(package)
393		}
394
395		get_versions <- function(file) {
396	4x	log <- suppressWarnings(system2(
397	4x	"git",
398	4x	c("log", file),
399	4x	stdout = TRUE
400		))
401	4x	if (is.null(attr(log, "status"))) {
402	2x	log_entries <- strsplit(paste(log, collapse = "\|"), "commit ")[[
403	2x	1
404		]]
405	2x	log_entries <- do.call(
406	2x	rbind,
407	2x	Filter(
408	2x	function(x) length(x) == 4L,
409	2x	strsplit(
410	2x	log_entries[log_entries != ""],
411	2x	"\\\|+(?:[^:]+:)?\\s*"
412		)
413		)
414		)
415	2x	if (length(log_entries)) {
416	1x	colnames(log_entries) <- c(
417	1x	"hash",
418	1x	"author",
419	1x	"date",
420	1x	"message"
421		)
422	1x	as.data.frame(log_entries)
423		}
424		}
425		}
426
427		attempt_read <- function(file, id_cols) {
428	3x	tryCatch(
429		{
430	3x	sep <- if (grepl(".csv", file, fixed = TRUE)) "," else "\t"
431	3x	cols <- scan(file, "", nlines = 1, sep = sep, quiet = TRUE)
432	3x	types <- rep("?", length(cols))
433	3x	types[cols %in% id_cols] <- "c"
434	3x	arrow::read_delim_arrow(
435	3x	gzfile(file),
436	3x	sep,
437	3x	col_names = cols,
438	3x	col_types = paste(types, collapse = ""),
439	3x	skip = 1
440		)
441		},
442	3x	error = function(e) NULL
443		)
444		}
445
446		calculate_sha <- function(file, level) {
447	4x	if (Sys.which("openssl") != "") {
448	4x	tryCatch(
449	4x	strsplit(
450	4x	system2(
451	4x	"openssl",
452	4x	c("dgst", paste0("-sha", level), shQuote(file)),
453	4x	TRUE
454		),
455		" ",
456	4x	fixed = TRUE
457	4x	)[[1]][2],
458	4x	error = function(e) ""
459		)
460		} else {
461		""
462		}
463		}

1		#' Download Data from the CDC
2		#'
3		#' Download data and metadata from the Centers for Disease Control and Prevention (CDC).
4		#'
5		#' @param id ID of the resource (e.g., \code{ijqb-a7ye}).
6		#' @param out_dir Directory in which to save the metadata and data files.
7		#' @param state The state ID of a previous download; if provided, will only download if the
8		#' new state does not match.
9		#' @param parquet Logical; if \code{TRUE}, will convert the downloaded CSV file to Parquet.
10		#' @param verbose Logical; if \code{FALSE}, will not display status messages.
11		#' @returns The state ID of the downloaded files;
12		#' downloads files (\code{<id>.json} and \code{<id>.csv.xz}) to \code{out_dir}
13		#' @section \code{data.cdc.gov} URLs:
14		#'
15		#' For each resource ID, there are 3 relevant CDC URLs:
16		#' \itemize{
17		#' \item \strong{\code{resource/<id>}}: This redirects to the resource's main page,
18		#' with displayed metadata and a data preview
19		#' (e.g., \href{https://data.cdc.gov/resource/ijqb-a7ye}{data.cdc.gov/resource/ijqb-a7ye}).
20		#' \item \strong{\code{api/views/<id>}}: This is a direct link to the underlying
21		#' JSON metadata (e.g., \href{https://data.cdc.gov/api/views/ijqb-a7ye}{data.cdc.gov/api/views/ijqb-a7ye}).
22		#' \item \strong{\code{api/views/<id>/rows.csv}}: This is a direct link to the full
23		#' CSV dataset (e.g., \href{https://data.cdc.gov/api/views/ijqb-a7ye/rows.csv}{data.cdc.gov/api/views/ijqb-a7ye/rows.csv}).
24		#' }
25		#'
26		#' @examples
27		#' \dontrun{
28		#' dcf_download_cdc("ijqb-a7ye")
29		#' }
30		#' @export
31
32		dcf_download_cdc <- function(
33		id,
34		out_dir = "raw",
35		state = NULL,
36		parquet = FALSE,
37		verbose = TRUE
38		) {
39	2x	dir.create(out_dir, showWarnings = FALSE, recursive = TRUE)
40	2x	if (verbose) {
41	2x	resource_url <- paste0("https://data.cdc.gov/resource/", id)
42	2x	cli::cli_h1(
43	2x	"downloading resource {.url {resource_url}}"
44		)
45		}
46	2x	url <- paste0("https://data.cdc.gov/api/views/", id)
47	2x	initial_timeout <- options(timeout = 99999L)$timeout
48	2x	on.exit(options(timeout = initial_timeout))
49	2x	if (verbose) {
50	2x	cli::cli_progress_step("metadata: {.url {url}}")
51		}
52	2x	metadata_file <- paste0(tempdir(), "/", id, ".json")
53	2x	status <- utils::download.file(url, metadata_file, quiet = TRUE)
54	2x	if (status != 0L) {
55	!	cli::cli_abort("failed to download metadata")
56		}
57	2x	metadata <- jsonlite::read_json(metadata_file)
58	2x	new_state <- if (is.null(metadata$rowsUpdatedAt)) {
59	!	as.list(tools::md5sum(metadata_file))
60		} else {
61	2x	metadata$rowsUpdatedAt
62		}
63	2x	if (!identical(new_state, state)) {
64	2x	file.rename(metadata_file, paste0(out_dir, "/", id, ".json"))
65	2x	data_url <- paste0(url, "/rows.csv")
66	2x	out_path <- paste0(out_dir, "/", id, ".csv")
67	2x	if (verbose) {
68	2x	cli::cli_progress_step("data: {.url {data_url}}")
69		}
70	2x	status <- utils::download.file(data_url, out_path, quiet = TRUE)
71	2x	if (status != 0L) {
72	!	cli::cli_abort("failed to download data")
73		}
74	2x	if (parquet) {
75	1x	if (verbose) {
76	1x	cli::cli_progress_step("writing to Parquet")
77		}
78	1x	data <- arrow::read_csv_arrow(out_path)
79	1x	arrow::write_parquet(
80	1x	data,
81	1x	compression = "gzip",
82	1x	sub(".csv", ".parquet", out_path, fixed = TRUE)
83		)
84	1x	unlink(out_path)
85		} else {
86	1x	if (verbose) {
87	1x	cli::cli_progress_step("compressing data")
88		}
89	1x	unlink(paste0(out_path, ".xz"))
90	1x	status <- system2("xz", c("-f", out_path))
91	1x	if (status != 0L) {
92	!	cli::cli_abort("failed to compress data")
93		}
94		}
95	2x	if (verbose) {
96	2x	cli::cli_progress_done()
97		}
98	2x	invisible(new_state)
99		} else {
100	!	unlink(metadata_file)
101	!	invisible(state)
102		}
103		}

1		#' Run Data Project Processes
2		#'
3		#' Operates over data source and bundle projects, optionally running the source
4		#' ingest scripts, then collecting metadata.
5		#'
6		#' @param name Name of a source project to process. Will default to the name of the
7		#' current working directory.
8		#' @param project_dir Path to the project directory. If not specified, and being called
9		#' from a source project, this will be assumed to be two steps back from the working directory.
10		#' @param ingest Logical; if \code{FALSE}, will re-process standardized data without running
11		#' ingestion scripts. Only applies to source projects.
12		#' @param is_auto Logical; if \code{TRUE}, will skip process scripts marked as manual.
13		#' @param force Logical; if \code{TRUE}, will ignore process frequencies
14		#' (will run scripts even if recently run).
15		#' @param clear_state Logical; if \code{TRUE}, will clear stored states before processing.
16		#' @returns A list with processing results:
17		#' \itemize{
18		#' \item \code{timings}: How many seconds the scripts took to run.
19		#' \item \code{logs}: The captured output of the scripts.
20		#' }
21		#' Each entry has an entry for each project.
22		#'
23		#' A `datapackage.json` file is also created / update in each source's `standard` directory.
24		#' @examples
25		#' \dontrun{
26		#' # run from a directory containing a `data` directory containing the source
27		#' dcf_process("source_name")
28		#'
29		#' # run without executing the ingestion script
30		#' dcf_process("source_name", ingest = FALSE)
31		#' }
32		#' @export
33
34		dcf_process <- function(
35		name = NULL,
36		project_dir = ".",
37		ingest = TRUE,
38		is_auto = FALSE,
39		force = FALSE,
40		clear_state = FALSE
41		) {
42	4x	settings_file <- paste0(project_dir, "/settings.json")
43	4x	from_project <- file.exists(settings_file)
44	4x	if (from_project) {
45	4x	source_dir <- paste0(
46	4x	project_dir,
47		"/",
48	4x	jsonlite::read_json(settings_file)$data_dir
49		)
50		} else {
51	!	project_dir <- "../.."
52	!	source_dir <- ".."
53	!	name <- basename(getwd())
54		}
55
56	4x	sources <- if (is.null(name)) {
57	2x	list.files(
58	2x	source_dir,
59	2x	"process\\.json",
60	2x	recursive = TRUE,
61	2x	full.names = TRUE
62		)
63		} else {
64	2x	process_files <- paste0(source_dir, "/", name, "/process.json")
65	2x	if (any(!file.exists(process_files))) {
66	!	cli::cli_abort(
67	!	"missing process file{?/s}: {.emph {process_files[!file.exists(process_files)]}}"
68		)
69		}
70	2x	process_files
71		}
72	4x	decide_to_run <- function(process_script) {
73	4x	if (is_auto && process_script$manual) {
74	!	return(FALSE)
75		}
76	4x	if (
77	4x	force \|\| process_script$last_run == "" \|\| process_script$frequency == 0L
78		) {
79	4x	return(TRUE)
80		}
81	4x	if (
82	!	difftime(Sys.time(), as.POSIXct(process_script$last_run), units = "day") >
83	!	process_script$frequency
84		) {
85	!	return(TRUE)
86		}
87	!	FALSE
88		}
89	4x	collect_env <- new.env()
90	4x	collect_env$timings <- list()
91	4x	collect_env$logs <- list()
92	4x	process_source <- function(process_file) {
93	4x	process_def <- dcf_process_record(process_file)
94	4x	if (clear_state) {
95	!	raw_states <- grep("raw_state", names(process_def), fixed = TRUE)
96	!	if (length(raw_states)) {
97	!	process_def[raw_states] <- NULL
98		}
99	!	process_def$standard_state <- NULL
100	!	dcf_process_record(process_file, process_def)
101		}
102	4x	name <- process_def$name
103	4x	dcf_add_source(name, project_dir, open_after = FALSE)
104	4x	for (si in seq_along(process_def$scripts)) {
105	4x	st <- proc.time()[[3]]
106	4x	process_script <- process_def$scripts[[si]]
107	4x	run_current <- ingest && decide_to_run(process_script)
108	4x	base_dir <- dirname(process_file)
109	4x	standard_dir <- paste0(base_dir, "/standard")
110	4x	script <- paste0(base_dir, "/", process_script$path)
111	4x	file_ref <- if (run_current) paste0(" ({.emph ", script, "})") else NULL
112	4x	cli::cli_progress_step(
113	4x	paste0("processing source {.strong ", name, "}", file_ref),
114	4x	spinner = TRUE
115		)
116	4x	env <- new.env()
117	4x	env$dcf_process_continue <- TRUE
118	4x	status <- if (ingest) {
119	4x	tryCatch(
120	4x	list(
121	4x	log = utils::capture.output(
122	4x	source(script, env, chdir = TRUE),
123	4x	type = "message"
124		),
125	4x	success = TRUE
126		),
127	4x	error = function(e) {
128	!	cli::cli_warn("scripts {.file {script}} failed: {e$message}")
129	!	list(log = e$message, success = FALSE)
130		}
131		)
132		} else {
133	!	list(log = "", success = TRUE)
134		}
135	4x	collect_env$logs[[name]] <- status$log
136	4x	if (run_current) {
137	4x	process_script$last_run <- Sys.time()
138	4x	process_script$run_time <- proc.time()[[3]] - st
139	4x	process_script$last_status <- status
140	4x	process_def$scripts[[si]] <- process_script
141		}
142	4x	if (status$success) {
143	4x	collect_env$timings[[name]] <- process_script$run_time
144		}
145	!	if (!env$dcf_process_continue) break
146		}
147	4x	process_def_current <- dcf_process_record(process_file)
148	4x	if (
149	4x	is.null(process_def_current$raw_state) \|\|
150	4x	!identical(process_def$raw_state, process_def_current$raw_state)
151		) {
152	4x	process_def_current$scripts <- process_def$scripts
153	4x	dcf_process_record(process_file, process_def_current)
154		}
155	4x	data_files <- list.files(standard_dir, "\\.(?:csv\|parquet\|json)")
156	4x	data_files <- data_files[!grepl("datapackage", data_files, fixed = TRUE)]
157	4x	if (length(data_files)) {
158	4x	measure_info_file <- paste0(base_dir, "/measure_info.json")
159	4x	standard_state <- as.list(tools::md5sum(c(
160	4x	measure_info_file,
161	4x	paste0(standard_dir, "/", data_files)
162		)))
163	4x	if (!identical(process_def_current$standard_state, standard_state)) {
164	3x	measure_info <- dcf_measure_info(
165	3x	measure_info_file,
166	3x	include_empty = FALSE,
167	3x	render = TRUE,
168	3x	write = FALSE,
169	3x	open_after = FALSE,
170	3x	verbose = FALSE
171		)
172	3x	measure_sources <- list()
173	3x	for (measure_id in names(measure_info)) {
174	4x	measure_info[[measure_id]]$id <- measure_id
175	4x	info <- measure_info[[measure_id]]
176	4x	for (s in info$sources) {
177	4x	if (
178	!	!is.null(s$location) &&
179	!	!(s$location %in% names(sources))
180		) {
181	!	measure_sources[[s$location]] <- s
182		}
183		}
184		}
185	3x	if (!file.exists(paste0(standard_dir, "/datapackage.json"))) {
186	!	dcf_datapackage_init(name, dir = standard_dir, quiet = TRUE)
187		}
188	3x	dcf_datapackage_add(
189	3x	data_files,
190	3x	meta = list(
191	3x	source = unname(measure_sources),
192	3x	base_dir = base_dir,
193	3x	ids = "geography",
194	3x	time = "time",
195	3x	variables = measure_info
196		),
197	3x	dir = standard_dir,
198	3x	pretty = TRUE,
199	3x	summarize_ids = TRUE,
200	3x	verbose = FALSE
201		)
202	3x	process_def_current$standard_state <- standard_state
203	3x	dcf_process_record(process_file, process_def_current)
204		}
205	4x	cli::cli_progress_done(result = if (status$success) "done" else "failed")
206		} else {
207	!	cli::cli_progress_done(result = "failed")
208	!	cli::cli_bullets(
209	!	c(" " = "no standard data files found in {.path {process_file}}")
210		)
211		}
212		}
213	4x	process_bundle <- function(process_file) {
214	1x	process_def <- dcf_process_record(process_file)
215	1x	any_source_files <- length(process_def$source_files) != 0L
216	1x	if (clear_state) {
217	!	process_def$source_state <- NULL
218	!	process_def$dist_state <- NULL
219	!	dcf_process_record(process_file, process_def)
220		}
221	1x	name <- process_def$name
222	1x	dcf_add_bundle(name, project_dir, open_after = FALSE)
223	1x	for (si in seq_along(process_def$scripts)) {
224	1x	st <- proc.time()[[3]]
225	1x	process_script <- process_def$scripts[[si]]
226	1x	base_dir <- dirname(process_file)
227	1x	script <- paste0(base_dir, "/", process_script$path)
228	1x	run_current <- TRUE
229	1x	standard_state <- NULL
230	1x	if (any_source_files) {
231	1x	standard_files <- paste0(source_dir, "/", process_def$source_files)
232	1x	standard_state <- as.list(tools::md5sum(paste0(
233	1x	source_dir,
234		"/",
235	1x	process_def$source_files
236		)))
237	1x	run_current <- !identical(standard_state, process_def$source_state)
238		}
239	1x	if (run_current) {
240	1x	cli::cli_progress_step(
241	1x	paste0(
242	1x	"processing bundle {.strong ",
243	1x	name,
244	1x	"} ({.emph ",
245	1x	script,
246		"})"
247		),
248	1x	spinner = TRUE
249		)
250	1x	env <- new.env()
251	1x	env$dcf_process_continue <- TRUE
252	1x	status <- tryCatch(
253	1x	list(
254	1x	log = utils::capture.output(
255	1x	source(script, env, chdir = TRUE),
256	1x	type = "message"
257		),
258	1x	success = TRUE
259		),
260	1x	error = function(e) {
261	!	cli::cli_warn("scripts {.file {script}} failed: {e$message}")
262	!	list(log = e$message, success = FALSE)
263		}
264		)
265	1x	collect_env$logs[[name]] <- status$log
266	1x	if (run_current) {
267	1x	process_script$last_run <- Sys.time()
268	1x	process_script$run_time <- proc.time()[[3]] - st
269	1x	process_script$last_status <- status
270	1x	process_def$scripts[[si]] <- process_script
271		}
272	1x	if (status$success) {
273	1x	collect_env$timings[[name]] <- process_script$run_time
274		}
275	!	if (!env$dcf_process_continue) break
276		}
277		}
278	1x	process_def_current <- dcf_process_record(process_file)
279	1x	dist_dir <- paste0(base_dir, "/dist")
280	1x	dist_files <- grep(
281	1x	"datapackage",
282	1x	list.files(dist_dir, recursive = TRUE),
283	1x	fixed = TRUE,
284	1x	invert = TRUE,
285	1x	value = TRUE
286		)
287	1x	if (length(dist_files)) {
288	1x	dist_state <- as.list(tools::md5sum(paste0(
289	1x	base_dir,
290	1x	"/dist/",
291	1x	dist_files
292		)))
293	1x	if (!identical(process_def_current$dist_state, dist_state)) {
294	1x	process_def_current$scripts <- process_def$scripts
295	1x	process_def_current$dist_state <- dist_state
296	1x	process_def_current$standard_state <- standard_state
297	1x	dcf_process_record(process_file, process_def_current)
298
299		# merge with standard measure infos
300	1x	measure_info <- dcf_measure_info(
301	1x	paste0(base_dir, "/measure_info.json"),
302	1x	include_empty = FALSE,
303	1x	render = TRUE,
304	1x	write = FALSE,
305	1x	open_after = FALSE,
306	1x	verbose = FALSE
307		)
308	1x	if (any_source_files) {
309	1x	source_measure_info_files <- list.files(
310	1x	sub("/.*$", "", NULL),
311	1x	"datapackage\\.json",
312	1x	recursive = TRUE
313		)
314	1x	if (length(source_measure_info_files)) {
315	!	source_measure_info <- Reduce(
316	!	c,
317	!	lapply(
318	!	source_measure_info_files,
319	!	function(f) jsonlite::read_json(f)$measure_info
320		)
321		)
322	!	for (measure_id in names(measure_info)) {
323	!	info <- measure_info[[measure_id]]
324	!	info$id <- measure_id
325	!	source_id <- if (!is.null(info$source_id)) {
326	!	info$source_id
327		} else {
328	!	measure_id
329		}
330	!	source_info <- source_measure_info[[source_id]]
331	!	if (!is.null(source_info)) {
332	!	for (entry_name in names(source_info)) {
333	4x	if (
334	!	is.null(info[[entry_name]]) \|\|
335	!	(is.character(info[[entry_name]]) &&
336	!	info[[entry_name]] == "")
337		) {
338	!	info[[entry_name]] <- source_info[[entry_name]]
339	!	} else if (is.list(info[[entry_name]])) {
340	!	info[[entry_name]] <- unique(c(
341	!	info[[entry_name]],
342	!	source_info[[entry_name]]
343		))
344		}
345		}
346		}
347	!	measure_info[[measure_id]] <- info
348		}
349		}
350		}
351	1x	measure_sources <- list()
352	1x	for (info in measure_info) {
353	1x	for (s in info$sources) {
354	4x	if (
355	!	is.list(s) &&
356	!	!is.null(s$location) &&
357	!	!(s$location %in% names(sources))
358		) {
359	!	measure_sources[[s$location]] <- s
360		}
361		}
362		}
363	1x	if (!file.exists(paste0(dist_dir, "/datapackage.json"))) {
364	1x	dcf_datapackage_init(name, dir = dist_dir, quiet = TRUE)
365		}
366	1x	dcf_datapackage_add(
367	1x	dist_files,
368	1x	meta = list(
369	1x	source = unname(measure_sources),
370	1x	base_dir = base_dir,
371	1x	ids = "geography",
372	1x	time = "time",
373	1x	variables = measure_info
374		),
375	1x	dir = dist_dir,
376	1x	pretty = TRUE,
377	1x	summarize_ids = TRUE,
378	1x	verbose = FALSE
379		)
380		}
381	1x	cli::cli_progress_done(result = if (status$success) "done" else "failed")
382		} else {
383	!	cli::cli_progress_done(result = "failed")
384	!	cli::cli_bullets(
385	!	c(" " = "no standard data files found in {.path {process_file}}")
386		)
387		}
388		}
389	4x	for (process_file in sources[order(
390	4x	vapply(
391	4x	sources,
392	4x	function(f) {
393	5x	type <- jsonlite::read_json(f)$type
394	5x	is.null(type) \|\| type != "bundle"
395		},
396	4x	TRUE
397		),
398	4x	decreasing = TRUE
399		)]) {
400	5x	process_def <- dcf_process_record(process_file)
401	5x	if (is.null(process_def$type) \|\| process_def$type == "source") {
402	4x	process_source(process_file)
403		} else {
404	1x	process_bundle(process_file)
405		}
406		}
407	4x	invisible(list(timings = collect_env$timings, logs = collect_env$logs))
408		}

1		#' Standardize Epic Data
2		#'
3		#' Standardize a raw Epic data table.
4		#'
5		#' @param raw_data Raw Epic data, such as returned from \link{dcf_read_epic}.
6		#' @returns A standardized form of \code{data}.
7		#' @section Standardization:
8		#' \itemize{
9		#' \item Collapse location columns (\code{state} or \code{county}) to a single
10		#' \code{geography} column, and region names to IDs.
11		#' \item Collapse time columns (\code{year}, \code{month}, or \code{week}) to a single
12		#' \code{time} column, and clean up value formatting.
13		#' \item Drop rows with no values across value columns.
14		#' }
15		#' @examples
16		#' \dontrun{
17		#' raw_data <- dcf_read_epic("data/epic/raw/flu.csv.xz")
18		#' standard_data <- dcf_process_epic_raw(raw_data)
19		#' }
20		#'
21		#' @export
22
23		dcf_standardize_epic <- function(raw_data) {
24	1x	region_names <- epic_id_maps$regions
25	1x	names(region_names) <- gsub(
26	1x	" (?:CITY AND BOROUGH\|BOROUGH\|PARISH\|MUNICIPALITY\|MUNICIPIO)\|[.']",
27		"",
28	1x	toupper(names(region_names))
29		)
30	1x	cols <- colnames(raw_data)
31	1x	time_col <- which(cols == "year")
32	1x	if (length(time_col)) {
33	1x	colnames(raw_data)[time_col] <- "time"
34	1x	raw_data$time <- as.integer(substring(
35	1x	raw_data$time,
36	1x	0L,
37	1x	4L
38		))
39		}
40	1x	month_col <- which(cols == "month")
41	1x	if (length(month_col)) {
42	!	raw_data$time <- paste0(
43	!	raw_data$time,
44		"-",
45	!	epic_id_maps$months[raw_data$month]
46		)
47		}
48	1x	week_col <- which(cols == "week")
49	1x	if (length(week_col)) {
50	1x	raw_data$time <- paste0(
51	1x	raw_data$time,
52		"-",
53	1x	vapply(
54	1x	strsplit(raw_data$week, "[^A-Za-z0-9]"),
55	1x	function(p) {
56	4x	paste0(
57	4x	epic_id_maps$months[[p[[1L]]]],
58		"-",
59	4x	formatC(as.integer(p[[2L]]), width = 2L, flag = "0")
60		)
61		},
62		""
63		)
64		)
65		}
66	1x	geo_col <- grep("^(?:state\|county)", cols)
67	1x	if (length(geo_col)) {
68	1x	colnames(raw_data)[geo_col] <- "geography"
69	1x	raw_data$geography <- toupper(raw_data$geography)
70	1x	missing_geo <- !(raw_data$geography %in% names(region_names))
71	1x	if (any(missing_geo)) {
72	1x	geo <- sub(
73	1x	"LA ",
74	1x	"LA",
75	1x	sub("^SAINT", "ST", raw_data$geography[missing_geo]),
76	1x	fixed = TRUE
77		)
78	1x	if (any(grepl(", VA", geo, fixed = TRUE))) {
79	1x	geo[geo == "SALEM, VA"] <- "SALEM CITY, VA"
80	1x	geo[geo == "RADFORD, VA"] <- "RADFORD CITY, VA"
81	1x	geo[geo == "DONA ANA, NM"] <- "DO\u00d1A ANA, NM"
82	1x	geo[geo == "MATANUSKA SUSITNA, AK"] <- "MATANUSKA-SUSITNA, AK"
83		}
84	1x	raw_data$geography[missing_geo] <- geo
85		}
86	1x	missing_regions <- raw_data$geography[
87	1x	!(raw_data$geography %in% names(region_names))
88		]
89	1x	if (length(missing_regions)) {
90	!	cli::cli_warn(
91	!	'unrecognized regions: {paste(unique(missing_regions), collapse = "; ")}'
92		)
93		}
94	1x	raw_data$geography <- region_names[raw_data$geography]
95	1x	raw_data <- raw_data[!is.na(raw_data$geography), ]
96		}
97	1x	raw_data <- raw_data[,
98	1x	!(colnames(raw_data) %in% c("state", "county", "year", "month", "week"))
99		]
100	1x	raw_data[
101	1x	rowSums(
102	1x	!is.na(raw_data[,
103	1x	!(colnames(raw_data) %in% c("geography", "time", "age"))
104		])
105		) !=
106	1x	0L,
107		]
108		}

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

1		#' Check Data Projects
2		#'
3		#' Check the data files and measure info of subprojects.
4		#'
5		#' @param names Name or names of projects.
6		#' @param project_dir Path to the Data Collection Framework project.
7		#' @param verbose Logical; if \code{FALSE}, will not print status messages.
8		#' @returns A list with an entry for each source, containing a character vector
9		#' including any issue codes:
10		#' \itemize{
11		#' \item \code{not_compressed}: The file does not appear to be compressed.
12		#' \item \code{cant_read}: Failed to read the file in.
13		#' \item \code{geography_missing}: File does not contain a \code{geography} column.
14		#' \item \code{geography_nas}: The file's \code{geography} column contains NAs.
15		#' \item \code{time_missing}: File does not contain a \code{time} column.
16		#' \item \code{time_nas}: The file's \code{time} column contains NAs.
17		#' \item \code{missing_info: {column_name}}: The file's indicated column does not have
18		#' a matching entry in \code{measure_info.json}.
19		#' }
20		#' @examples
21		#' \dontrun{
22		#' dcf_check("gtrends")
23		#' }
24		#' @export
25
26		dcf_check <- function(
27		names = NULL,
28		project_dir = ".",
29		verbose = TRUE
30		) {
31		if (
32	3x	is.null(names) && !file.exists(paste0(project_dir, "/", "settings.json"))
33		) {
34	!	project_dir <- "../.."
35	!	names <- basename(getwd())
36		}
37
38	3x	settings <- dcf_read_settings(project_dir)
39	3x	base_dir <- paste0(project_dir, "/", settings$data_dir)
40	3x	if (is.null(names)) {
41	2x	names <- list.dirs(base_dir, recursive = FALSE, full.names = FALSE)
42		}
43	3x	issues <- list()
44	3x	for (name in names) {
45	4x	source_dir <- paste0(base_dir, "/", name, "/")
46	4x	if (!dir.exists(source_dir)) {
47	!	cli::cli_abort("specify the name of an existing data project")
48		}
49	4x	process_file <- paste0(source_dir, "process.json")
50	4x	if (!file.exists(process_file)) {
51	!	cli::cli_abort("{name} does not appear to be a data project")
52		}
53	4x	process <- dcf_process_record(process_file)
54	4x	is_bundle <- !is.null(process$type) && process$type == "bundle"
55	4x	info_file <- paste0(source_dir, "measure_info.json")
56	4x	info <- tryCatch(
57	4x	dcf_measure_info(
58	4x	info_file,
59	4x	render = TRUE,
60	4x	write = FALSE,
61	4x	verbose = FALSE,
62	4x	open_after = FALSE
63		),
64	4x	error = function(e) NULL
65		)
66	4x	if (is.null(info)) {
67	!	cli::cli_abort("{.file {info_file}} is malformed")
68		}
69	4x	if (verbose) {
70	4x	cli::cli_bullets(c("", "Checking project {.strong {name}}"))
71		}
72	4x	data_files <- list.files(
73	4x	paste0(source_dir, if (is_bundle) "dist" else "standard"),
74	4x	"\\.(?:csv\|parquet\|json)",
75	4x	full.names = TRUE
76		)
77	4x	data_files <- data_files[!grepl("datapackage", data_files, fixed = TRUE)]
78	4x	source_issues <- list()
79	4x	for (file in list.files(
80	4x	paste0(source_dir, "raw"),
81	4x	"csv$",
82	4x	full.names = TRUE
83		)) {
84	1x	source_issues[[file]] <- list(data = "not_compressed")
85		}
86	4x	if (length(data_files)) {
87	4x	for (file in data_files) {
88	4x	issue_messages <- NULL
89	4x	if (verbose) {
90	4x	cli::cli_progress_step("checking file {.file {file}}", spinner = TRUE)
91		}
92	4x	data_issues <- NULL
93	4x	measure_issues <- NULL
94	4x	data <- tryCatch(
95	4x	if (grepl(".parquet", file, fixed = TRUE)) {
96	!	dplyr::collect(arrow::read_parquet(file))
97	4x	} else if (grepl(".json", file, fixed = TRUE)) {
98	1x	as.data.frame(jsonlite::read_json(file, simplifyVector = TRUE))
99		} else {
100	3x	con <- gzfile(file)
101	3x	on.exit(con)
102	3x	vroom::vroom(con, show_col_types = FALSE)
103		},
104	4x	error = function(e) NULL
105		)
106	4x	if (is.null(data)) {
107	!	data_issues <- c(data_issues, "cant_read")
108		} else {
109	4x	if (grepl("csv$", file)) {
110	1x	data_issues <- c(data_issues, "not_compressed")
111	1x	if (verbose) {
112	1x	issue_messages <- c(
113	1x	issue_messages,
114	1x	"file is not compressed"
115		)
116		}
117		}
118	4x	if (!("geography" %in% colnames(data))) {
119	!	data_issues <- c(data_issues, "geography_missing")
120	!	if (verbose) {
121	!	issue_messages <- c(
122	!	issue_messages,
123	!	"missing {.emph geography} column"
124		)
125		}
126	4x	} else if (anyNA(data$geography)) {
127	1x	data_issues <- c(data_issues, "geography_nas")
128	1x	if (verbose) {
129	1x	issue_messages <- c(
130	1x	issue_messages,
131	1x	"{.emph geography} column contains NAs"
132		)
133		}
134		}
135	4x	if (!("time" %in% colnames(data))) {
136	!	data_issues <- c(data_issues, "time_missing")
137	!	if (verbose) {
138	!	issue_messages <- c(
139	!	issue_messages,
140	!	"missing {.emph time} column"
141		)
142		}
143	4x	} else if (anyNA(data$time)) {
144	1x	data_issues <- c(data_issues, "time_nas")
145	1x	if (verbose) {
146	1x	issue_messages <- c(
147	1x	issue_messages,
148	1x	"{.emph time} column contains NAs"
149		)
150		}
151		}
152	4x	for (col in colnames(data)) {
153	12x	if (!(col %in% c("geography", "time")) && !(col %in% names(info))) {
154	1x	measure_issues <- c(measure_issues, paste("missing_info:", col))
155	1x	if (verbose) {
156	1x	issue_messages <- c(
157	1x	issue_messages,
158	1x	paste0(
159	1x	"{.emph ",
160	1x	col,
161	1x	"} column does not have an entry in measure_info"
162		)
163		)
164		}
165		}
166		}
167		}
168	4x	file_issues <- list()
169	4x	if (length(data_issues)) {
170	1x	file_issues$data <- data_issues
171		}
172	4x	if (length(measure_issues)) {
173	1x	file_issues$measures <- measure_issues
174		}
175	4x	source_issues[[file]] <- file_issues
176	4x	if (verbose) {
177	4x	if (length(issue_messages)) {
178	1x	cli::cli_progress_done(result = "failed")
179	1x	cli::cli_bullets(structure(
180	1x	issue_messages,
181	1x	names = rep(" ", length(issue_messages))
182		))
183		} else {
184	3x	cli::cli_progress_done()
185		}
186		}
187		}
188		} else {
189	!	if (verbose) cli::cli_alert_info("no standard data files found to check")
190		}
191	4x	if (!identical(process$check_results, source_issues)) {
192	3x	process$checked <- Sys.time()
193	3x	process$check_results <- source_issues
194	3x	dcf_process_record(process_file, process)
195		}
196	4x	issues[[name]] <- source_issues
197		}
198
199	3x	invisible(issues)
200		}

1		#' Process Epic Stating Files
2		#'
3		#' Process Epic stating files, lightly standardizing them and moving them to raw.
4		#'
5		#' @param staging_dir Directory containing the staging files.
6		#' @param out_dir Directory to write new raw files to.
7		#' @param verbose Logical; if \code{FALSE}, will not show status messages.
8		#' @param cleanup Logical; if \code{FALSE}, will not remove staging files after being processed.
9		#' @returns \code{NULL} if no staging files are found.
10		#' Otherwise, a list with entries for \code{data} and \code{metadata}.
11		#' Each of these are lists with entries for each recognized standard name,
12		#' with potentially combined outputs similar to \code{\link{dcf_read_epic}}
13		#'
14		#' @examples
15		#' \dontrun{
16		#' # run from a source project
17		#' dcf_process_epic_staging()
18		#' }
19		#'
20		#' @export
21
22		dcf_process_epic_staging <- function(
23		staging_dir = "raw/staging",
24		out_dir = "raw",
25		verbose = TRUE,
26		cleanup = TRUE
27		) {
28	1x	files <- sort(list.files(
29	1x	staging_dir,
30	1x	"csv",
31	1x	full.names = TRUE,
32	1x	recursive = TRUE
33		))
34	1x	files <- files[!grepl("census", files)]
35	1x	if (!length(files)) {
36	!	if (verbose) {
37	!	cli::cli_progress_message("no staging files found")
38		}
39	!	return(NULL)
40		}
41	1x	id_cols <- c("state", "county", "age", "year", "month", "week")
42	1x	metadata <- list()
43	1x	data <- list()
44	1x	for (file in files) {
45	2x	if (verbose) {
46	2x	cli::cli_progress_step("processing file {.file {file}}", spinner = TRUE)
47		}
48	2x	epic <- tryCatch(dcf_read_epic(file), error = function(e) NULL)
49	2x	if (is.null(epic)) {
50	!	if (verbose) {
51	!	cli::cli_progress_done(result = "failed")
52		}
53	!	next
54		}
55	2x	if (epic$metadata$standard_name == "") {
56	!	if (verbose) {
57	!	cli::cli_warn("failed to identify standard type for {.file {file}}")
58	!	cli::cli_progress_done(result = "failed")
59		}
60	!	next
61		}
62	2x	name <- epic$metadata$standard_name
63	2x	metadata[[name]] <- c(list(epic$metadata), metadata[[name]])
64	2x	file_id_cols <- id_cols[id_cols %in% colnames(epic$data)]
65	2x	epic$data <- epic$data[
66	2x	rowMeans(is.na(epic$data[,
67	2x	!(colnames(epic$data) %in% file_id_cols),
68	2x	drop = FALSE
69		])) !=
70	2x	1,
71		]
72	2x	n_col <- grep("^n_", colnames(epic$data))
73	2x	if (length(n_col)) {
74	!	colnames(epic$data)[[n_col]] <- paste0("n_", epic$metadata$standard_name)
75		}
76	2x	if (!is.null(data[[name]])) {
77	1x	cols <- colnames(data[[name]])
78	1x	cols <- cols[!(cols %in% colnames(epic$data))]
79	1x	if (length(cols)) {
80	!	epic$data[, cols] <- NA
81		}
82	1x	epic$data <- epic$data[, colnames(data[[name]])]
83	1x	file_id_cols <- id_cols[id_cols %in% colnames(data[[name]])]
84	1x	data[[name]] <- data[[name]][
85	1x	!(do.call(paste, data[[name]][, file_id_cols]) %in%
86	1x	do.call(paste, epic$data[, file_id_cols])),
87		]
88		}
89	2x	data[[name]] <- rbind(epic$data, data[[name]])
90	2x	if (verbose) cli::cli_progress_done()
91		}
92	1x	for (name in names(metadata)) {
93	1x	if (verbose) {
94	1x	cli::cli_progress_step(
95	1x	"writing standard raw output for {.field {name}}",
96	1x	spinner = TRUE
97		)
98		}
99	1x	paths <- paste0(out_dir, "/", name, ".", c("json", "csv.xz"))
100	1x	jsonlite::write_json(
101	1x	metadata[[name]],
102	1x	paths[[1L]],
103	1x	auto_unbox = TRUE,
104	1x	pretty = TRUE
105		)
106	1x	vroom::vroom_write(data[[name]], paths[[2L]])
107	1x	if (cleanup) {
108	1x	unlink(vapply(metadata[[name]], "[[", "", "file"))
109		}
110	1x	if (verbose) cli::cli_process_done()
111		}
112	1x	return(list(metadata = metadata, data = data))
113		}

1		#' Update renv.lock
2		#'
3		#' Updates the \code{renv.lock} file with dependencies found in project scripts.
4		#'
5		#' @param project_dir Directory of the Data Collection project.
6		#' @param refresh Logical; if \code{FALSE}, will update an existing
7		#' \code{renv.lock} file, rather than recreating it.
8		#' @returns Nothing; writes an \code{renv.lock} file.
9		#' @examples
10		#' \dontrun{
11		#' dcf_update_lock()
12		#' }
13		#' @export
14
15		dcf_update_lock <- function(
16		project_dir = ".",
17		refresh = TRUE
18		) {
19	1x	settings <- dcf_read_settings(project_dir)
20	1x	extra <- unique(
21	1x	renv::dependencies(list.files(
22	1x	paste0(project_dir, "/", settings$data_dir),
23	1x	"\\.[Rr]$",
24	1x	recursive = TRUE,
25	1x	full.names = TRUE
26	1x	))$Package
27		)
28	1x	not_installed <- !(extra %in% rownames(utils::installed.packages()))
29	!	if (any(not_installed)) utils::install.packages(extra[not_installed])
30	1x	if (refresh) unlink(paste0(project_dir, "/renv.lock"))
31	1x	renv::snapshot(packages = extra, lockfile = paste0(project_dir, "/renv.lock"))
32		}

1		#' Download Census Population Data
2		#'
3		#' Download American Community Survey population data from the U.S. Census Bureau.
4		#'
5		#' @param year Data year.
6		#' @param out_dir Directory to download the file to.
7		#' @param state_only Logical; if \code{TRUE}, will only load state data.
8		#' Will still download county data.
9		#' @param age_groups A list mapping lower-level age groups to high-level ones
10		#' (e.g., \code{list(`<10 Years` = c("Under 5 years", "5 to 9 years"))}).
11		#' Or the name of a standard mapping (\code{"7"} or \code{"9"}).
12		#' If \code{FALSE}, will return the lowest-level age groups.
13		#' @param overwrite Logical; if \code{TRUE}, will re-download and overwrite existing data.
14		#' @param verbose Logical; if \code{FALSE}, will not display status messages.
15		#' @returns A \code{data.frame} including \code{GEOID} and \code{region_name}
16		#' for states and counties, along with their population, in total and within
17		#' age brackets.
18		#' @examples
19		#' if (file.exists("../../../pophive/census_population_2021.csv.xz")) {
20		#' dcf_load_census(2021, "../../../pophive")[1:10, ]
21		#' }
22		#' @export
23
24		dcf_load_census <- function(
25		year = 2021,
26		out_dir = NULL,
27		state_only = FALSE,
28		age_groups = "9",
29		overwrite = FALSE,
30		verbose = TRUE
31		) {
32	2x	out_file <- paste0(out_dir, "/census_population_", year, ".csv.xz")
33	2x	write_out <- !is.null(out_dir)
34	2x	age_group_sets <- list(
35	2x	"7" = list(
36	2x	`<10 Years` = c("Under 5 years", "5 to 9 years"),
37	2x	`10-14 Years` = "10 to 14 years",
38	2x	`15-19 Years` = c("15 to 17 years", "18 and 19 years"),
39	2x	`20-39 Years` = c(
40	2x	"20 years",
41	2x	"21 years",
42	2x	"22 to 24 years",
43	2x	"25 to 29 years",
44	2x	"30 to 34 years",
45	2x	"35 to 39 years"
46		),
47	2x	`40-64 Years` = c(
48	2x	"40 to 44 years",
49	2x	"45 to 49 years",
50	2x	"50 to 54 years",
51	2x	"55 to 59 years",
52	2x	"60 and 61 years",
53	2x	"62 to 64 years"
54		),
55	2x	`65+ Years` = c(
56	2x	"65 and 66 years",
57	2x	"67 to 69 years",
58	2x	"70 to 74 years",
59	2x	"75 to 79 years",
60	2x	"80 to 84 years",
61	2x	"85 years and over"
62		)
63		),
64	2x	"9" = list(
65	2x	`<10 Years` = c("Under 5 years", "5 to 9 years"),
66	2x	`10-18 Years` = c("10 to 14 years", "15 to 17 years"),
67	2x	`18-24 Years` = c(
68	2x	"18 and 19 years",
69	2x	"20 years",
70	2x	"21 years",
71	2x	"22 to 24 years"
72		),
73	2x	`25-34 Years` = c("25 to 29 years", "30 to 34 years"),
74	2x	`35-44 Years` = c("35 to 39 years", "40 to 44 years"),
75	2x	`45-54 Years` = c("45 to 49 years", "50 to 54 years"),
76	2x	`55-64 Years` = c(
77	2x	"55 to 59 years",
78	2x	"60 and 61 years",
79	2x	"62 to 64 years"
80		),
81	2x	`65+ Years` = c(
82	2x	"65 and 66 years",
83	2x	"67 to 69 years",
84	2x	"70 to 74 years",
85	2x	"75 to 79 years",
86	2x	"80 to 84 years",
87	2x	"85 years and over"
88		)
89		)
90		)
91	2x	age_levels <- unlist(age_group_sets[[1L]])
92	2x	if (!overwrite && write_out && file.exists(out_file)) {
93	1x	if (verbose) {
94	1x	cli::cli_progress_step("reading in existing file")
95		}
96	1x	pop <- as.data.frame(vroom::vroom(
97	1x	out_file,
98	1x	delim = ",",
99	1x	col_types = list(GEOID = "c", region_name = "c"),
100	1x	n_max = if (state_only) 52L else Inf
101		))
102		} else {
103		# GEOID to region name mapping
104	1x	id_url <- "https://www2.census.gov/geo/docs/reference/codes2020/national_"
105	1x	if (verbose) {
106	1x	cli::cli_progress_step("downloading state IDs map")
107		}
108	1x	state_ids <- vroom::vroom(
109	1x	paste0(id_url, "state2020.txt"),
110	1x	delim = "\|",
111	1x	col_types = list(
112	1x	STATE = "c",
113	1x	STATEFP = "c",
114	1x	STATENS = "c",
115	1x	STATE_NAME = "c"
116		)
117		)
118	1x	if (verbose) {
119	1x	cli::cli_progress_step("downloading county IDs map")
120		}
121	1x	county_ids <- vroom::vroom(
122	1x	paste0(id_url, "county2020.txt"),
123	1x	delim = "\|",
124	1x	col_types = list(
125	1x	STATE = "c",
126	1x	STATEFP = "c",
127	1x	COUNTYFP = "c",
128	1x	COUNTYNS = "c",
129	1x	COUNTYNAME = "c",
130	1x	CLASSFP = "c",
131	1x	FUNCSTAT = "c"
132		)
133		)
134	1x	region_name = structure(
135	1x	sub(
136	1x	" County",
137		"",
138	1x	c(
139	1x	state_ids$STATE_NAME,
140	1x	paste0(county_ids$COUNTYNAME, ", ", county_ids$STATE)
141		),
142	1x	fixed = TRUE
143		),
144	1x	names = c(
145	1x	state_ids$STATEFP,
146	1x	paste0(county_ids$STATEFP, county_ids$COUNTYFP)
147		)
148		)
149
150		# population data
151
152		## age group labels from IDs
153	1x	if (verbose) {
154	1x	cli::cli_progress_step("downloading ACS variable lables")
155		}
156	1x	labels <- vroom::vroom(
157	1x	paste0(
158	1x	"https://www2.census.gov/programs-surveys/acs/summary_file/",
159	1x	min(2021L, year),
160	1x	"/sequence-based-SF/documentation/user_tools/ACS_5yr_Seq_Table_Number_Lookup.txt"
161		),
162	1x	delim = ",",
163	1x	col_types = list(
164	1x	`File ID` = "c",
165	1x	`Table ID` = "c",
166	1x	`Sequence Number` = "c",
167	1x	`Line Number` = "d",
168	1x	`Start Position` = "i",
169	1x	`Total Cells in Table` = "c",
170	1x	`Total Cells in Sequence` = "i",
171	1x	`Table Title` = "c",
172	1x	`Subject Area` = "c"
173		)
174		)
175	1x	variable_labels <- structure(
176	1x	labels$`Table Title`,
177	1x	names = paste0(
178	1x	labels$`Table ID`,
179	1x	"_E",
180	1x	formatC(labels$`Line Number`, width = 3L, flag = 0L)
181		)
182		)
183
184		## age group counts
185	1x	url <- paste0(
186	1x	"https://www2.census.gov/programs-surveys/acs/summary_file/",
187	1x	year,
188	1x	"/table-based-SF/data/5YRData/acsdt5y",
189	1x	year,
190	1x	"-b01001.dat"
191		)
192	1x	if (verbose) {
193	1x	cli::cli_progress_step("downloading population data")
194		}
195	1x	data <- vroom::vroom(url, delim = "\|", col_types = list(GEO_ID = "c"))
196	1x	data <- data[
197	1x	grep("0[45]00000US", data$GEO_ID),
198	1x	grep("E", colnames(data), fixed = TRUE)
199		]
200	1x	colnames(data)[-1L] <- variable_labels[colnames(data)[-1L]]
201	1x	if (verbose) {
202	1x	cli::cli_progress_step("agregating across sex and fine age groups")
203		}
204	1x	pop <- cbind(
205	1x	data.frame(
206	1x	GEOID = substring(data$GEO_ID, 10L),
207	1x	region_name = "",
208	1x	Total = data[["Total:"]]
209		),
210	1x	do.call(
211	1x	cbind,
212	1x	lapply(
213	1x	structure(age_levels, names = age_levels),
214	1x	function(l) rowSums(data[, colnames(data) == l])
215		)
216		)
217		)
218	1x	pop$region_name = region_name[pop$GEOID]
219	1x	states <- pop[1L:52L, ]
220	1x	health_regions <- as.data.frame(do.call(
221	1x	rbind,
222	1x	lapply(
223	1x	split(
224	1x	states[, -(1L:2L)],
225	1x	dcf_to_health_region(states$GEOID, "hhs_")
226		),
227	1x	colSums
228		)
229		))
230	1x	health_regions$GEOID <- rownames(health_regions)
231	1x	health_regions$region_name <- sub(
232	1x	"hhs_",
233	1x	"Health Region ",
234	1x	rownames(health_regions),
235	1x	fixed = TRUE
236		)
237	1x	pop <- rbind(pop, health_regions[, colnames(pop)])
238
239	1x	if (write_out) {
240	1x	if (verbose) {
241	1x	cli::cli_progress_step("writing output")
242		}
243	1x	dir.create(out_dir, recursive = TRUE, showWarnings = FALSE)
244	1x	vroom::vroom_write(pop, out_file, ",")
245		}
246		}
247	!	if (is.numeric(age_groups)) age_groups <- as.character(age_groups)
248	2x	if (is.character(age_groups) && (age_groups %in% names(age_group_sets)))
249	1x	age_groups <- age_group_sets[[as.character(age_groups)]]
250	2x	if (is.list(age_groups)) {
251	1x	pop <- cbind(
252	1x	pop[, !(colnames(pop) %in% age_levels)],
253	1x	do.call(
254	1x	cbind,
255	1x	lapply(
256	1x	age_groups,
257	1x	function(l) rowSums(pop[, colnames(pop) %in% l, drop = FALSE])
258		)
259		)
260		)
261		}
262	2x	invisible(if (state_only) pop[1L:52L, ] else pop)
263		}

1		#' Initialize a Data Collection Project
2		#'
3		#' Establishes a new data collection framework project.
4		#'
5		#' @param name Name of the source. Defaults to the current directory name.
6		#' @param base_dir Path to the parent of the project directory (where the \code{name}
7		#' directory should be created). If \code{name} is not specified, will treat the current
8		#' directory as \code{name}, and \code{".."} as \code{base_dir}.
9		#' @param data_dir Name of the directory to store projects in, relative to \code{base_dir}.
10		#' @param github_account Name of the GitHub account that will host the repository.
11		#' @param branch Name of the repository's branch.
12		#' @param repo_name Name of the repository.
13		#' @param use_git Logical; if \code{TRUE}, will initialize a git repository.
14		#' @param open_after Logical; if \code{TRUE}, will open the project in a new RStudio instance.
15		#' @returns Nothing; creates default files and directories.
16		#' @section Data Collection Project:
17		#'
18		#' A data collection project starts with a \code{settings.json} file, which
19		#' specifies where source and bundle projects live (a \code{data} subdirectory by default).
20		#'
21		#' The bulk of the project will then be in the source and bundle projects, as created
22		#' by the \code{\link{dcf_add_source}} and \code{\link{dcf_add_bundle}}.
23		#'
24		#' Once these sub-projects are in place, they can be operated over by the
25		#' \code{\link{dcf_build}}, which processes each sub-project using
26		#' \code{\link{dcf_process}}, and checks them with \code{\link{dcf_check}},
27		#' resulting in a report.
28		#'
29		#' @examples
30		#' base_dir <- tempdir()
31		#' dcf_init("project_name", base_dir)
32		#' list.files(paste0(base_dir, "/project_name"))
33		#'
34		#' @export
35
36		dcf_init <- function(
37		name,
38		base_dir = ".",
39		data_dir = "data",
40		github_account = "",
41		branch = "main",
42		repo_name = name,
43		use_git = TRUE,
44		open_after = FALSE
45		) {
46	1x	if (missing(name)) {
47	!	name <- basename(getwd())
48	!	base_dir <- ".."
49		} else {
50	1x	name <- gsub("[^A-Za-z0-9]+", "_", name)
51		}
52	1x	base_path <- paste0(base_dir, "/", name, "/")
53	1x	dir.create(base_path, showWarnings = FALSE, recursive = TRUE)
54	1x	paths <- paste0(
55	1x	base_path,
56	1x	c(
57	1x	"project.Rproj",
58	1x	"settings.json",
59	1x	"README.md",
60	1x	"scripts/build.R",
61	1x	".github/workflows/build.yaml",
62	1x	".gitignore"
63		)
64		)
65		if (
66	1x	!file.exists(paths[[1L]]) && !length(list.files(base_path, "\\.Rproj$"))
67		) {
68	1x	writeLines("Version: 1.0\n", paths[[1L]])
69		}
70	1x	if (!file.exists(paths[[2L]])) {
71	1x	jsonlite::write_json(
72	1x	list(
73	1x	name = name,
74	1x	data_dir = data_dir,
75	1x	github_account = github_account,
76	1x	branch = "main",
77	1x	repo_name = repo_name
78		),
79	1x	paths[[2L]],
80	1x	auto_unbox = TRUE,
81	1x	pretty = TRUE
82		)
83		}
84	1x	if (!file.exists(paths[[3L]])) {
85	1x	writeLines(
86	1x	paste0(
87	1x	c(
88	1x	paste("#", name),
89		"",
90	1x	"This is a Data Collection Framework project, initialized with `dcf::dcf_init`.",
91		"",
92	1x	"You can us the `dcf` package to check the source projects:",
93		"",
94	1x	"```R",
95	1x	paste0('dcf::dcf_check_source()'),
96		"```",
97		"",
98	1x	"And process them:",
99		"",
100	1x	"```R",
101	1x	paste0('dcf::dcf_process()'),
102		"```"
103		),
104	1x	collapse = "\n"
105		),
106	1x	paths[[3L]]
107		)
108		}
109	1x	if (!file.exists(paths[[4L]])) {
110	1x	dir.create(dirname(paths[[4L]]), showWarnings = FALSE)
111	1x	writeLines(
112	1x	paste(c("library(dcf)", "dcf_build()"), collapse = "\n"),
113	1x	paths[[4L]]
114		)
115		}
116	1x	if (!file.exists(paths[[5L]])) {
117	1x	dir.create(dirname(paths[[5L]]), recursive = TRUE, showWarnings = FALSE)
118	1x	file.copy(system.file("workflows/build.yaml", package = "dcf"), paths[[5L]])
119		}
120	1x	if (!file.exists(paths[[6L]])) {
121	1x	writeLines(
122	1x	paste(
123	1x	c(
124	1x	"*.Rproj",
125	1x	".Rproj.user",
126	1x	"*.Rprofile",
127	1x	"*.Rhistory",
128	1x	"*.Rdata",
129	1x	".DS_Store",
130	1x	"renv"
131		),
132	1x	collapse = "\n"
133		),
134	1x	paths[[6L]]
135		)
136		}
137	!	if (open_after) rstudioapi::openProject(paths[[1L]], newSession = TRUE)
138		}

1		#' Retrieve A Data File
2		#'
3		#' Load a data file from a source data project, or list versions of the file.
4		#'
5		#' @param path Path to the file.
6		#' @param date Date of the version to load; A \code{Date}, or \code{character} in the format
7		#' \code{YYYY-MM-DD}. Will match to the nearest version.
8		#' @param commit_hash SHA signature of the committed version;
9		#' can be the first 6 or so characters. Ignored if \code{date} is provided.
10		#' @param versions Logical; if \code{TRUE}, will return a list of available version,
11		#' rather than a
12		#' @returns If \code{versions} is \code{TRUE}, a \code{data.frame} with columns for
13		#' the \code{hash}, \code{author}, \code{date}, and \code{message} of each commit.
14		#' Otherwise, the path to a temporary file, if one was extracted.
15		#'
16		#' @examples
17		#' path <- "../../../pophive/data/wastewater/raw/flua.csv.xz"
18		#' if (file.exists(path)) {
19		#' # list versions
20		#' versions <- dcf_get_file(path, versions = TRUE)
21		#' print(versions[, c("date", "hash")])
22		#'
23		#' # extract a version to a temporary file
24		#' temp_path <- dcf_get_file(path, "2025-05")
25		#' basename(temp_path)
26		#' }
27		#'
28		#' @export
29
30		dcf_get_file <- function(
31		path,
32		date = NULL,
33		commit_hash = NULL,
34		versions = FALSE
35		) {
36	3x	if (missing(path)) {
37	!	cli::cli_abort("specify a path")
38		}
39	3x	if (!file.exists(path)) {
40	!	cli::cli_abort("path does not exist")
41		}
42	3x	vs <- data.frame(
43	3x	hash = character(),
44	3x	author = character(),
45	3x	date = character(),
46	3x	message = character()
47		)
48	3x	if (versions \|\| !is.null(date)) {
49	2x	commits <- sys::exec_internal("git", c("log", path))
50	2x	if (commits$status == 0L) {
51	2x	commits <- do.call(
52	2x	rbind,
53	2x	Filter(
54	2x	function(e) length(e) == 4L,
55	2x	strsplit(
56	2x	strsplit(rawToChar(commits$stdout), "commit ", fixed = TRUE)[[1L]],
57	2x	"\\n+(?:[^:]+:)?\\s*"
58		)
59		)
60		)
61	2x	colnames(commits) <- colnames(vs)
62	2x	vs <- as.data.frame(commits)
63		} else {
64	!	cli::cli_abort("failed to git log: {rawToChar(commits$stderr)}")
65		}
66		}
67	3x	if (versions) {
68	1x	return(vs)
69		}
70	2x	if (!is.null(date)) {
71	1x	if (nrow(vs) == 0L) {
72	!	return(path)
73		}
74	1x	if (is.character(date)) {
75	1x	date <- as.POSIXct(
76	1x	date,
77	1x	tryFormats = c(
78	1x	"%Y-%m-%d %H:%M:%S",
79	1x	"%Y-%m-%d %H:%M",
80	1x	"%Y-%m-%d",
81	1x	"%Y-%m",
82	1x	"%Y"
83		),
84	1x	tz = "UTC"
85		)
86		}
87	1x	commit_hash <- vs$hash[which.min(abs(
88	1x	as.POSIXct(vs$date, "%a %b %d %H:%M:%S %Y", tz = "UTC") - date
89		))]
90		}
91	2x	if (is.null(commit_hash)) {
92	!	return(path)
93		}
94	2x	name_parts <- strsplit(basename(path), ".", fixed = TRUE)[[1L]]
95	2x	out_path <- paste0(
96	2x	tempdir(),
97		"/",
98	2x	name_parts[[1L]],
99		"-",
100	2x	substring(commit_hash, 1L, 6L),
101		".",
102	2x	paste(name_parts[-1L], collapse = ".")
103		)
104	2x	if (file.exists(out_path)) {
105	!	return(out_path)
106		}
107	2x	status <- sys::exec_wait(
108	2x	"git",
109	2x	c("show", paste0(commit_hash, ":", path)),
110	2x	std_out = out_path
111		)
112	2x	if (status != 0L) {
113	!	cli::cli_abort("failed to git show: {rawToChar(status$stderr)}")
114		}
115	2x	out_path
116		}

1		#' Interact with a Source Process File
2		#'
3		#' Read or update the current source process file.
4		#'
5		#' @param path Path to the process JSON file.
6		#' @param updated An update version of the process definition. If specified, will
7		#' write this as the new process file, rather than reading any existing file.
8		#' @returns The process definition of the source project.
9		#' @examples
10		#' epic_process_file <- "../../data/epic/process.json"
11		#' if (file.exists(epic_process_file)) {
12		#' dcf_process_record(path = epic_process_file)
13		#' }
14		#' @export
15
16		dcf_process_record <- function(path = "process.json", updated = NULL) {
17	31x	if (is.null(updated)) {
18	19x	if (!file.exists(path)) {
19	!	cli::cli_abort("process file {path} does not exist")
20		}
21	19x	jsonlite::read_json(path)
22		} else {
23	!	if (is.null(updated$type)) updated$type <- "source"
24	12x	jsonlite::write_json(updated, path, auto_unbox = TRUE, pretty = TRUE)
25	12x	updated
26		}
27		}