dcf coverage - 85.77%

Files
Source

#' 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_nas}: The file's \code{geography} column contains NAs.
#'   \item \code{geography_dropped}: The file's \code{geography} column has levels
#'     dropped from previous versions.
#'   \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}.
#'   \item \code{dropped_measure: {column_name}}: The file's indicated column is not present
#'     when it was previously.
#'   \item \code{type_changed: {column_name}}: The file's indicated column's type changed
#'     from the previous version.
#'   \item \code{levels_changed: {column_name}}: The file's indicated column's levels have
#'     all changed from the previous version.
#' }
#' @examples
#' \dontrun{
#'
#'   # run from within a project or sub-project
#'   dcf_check()
#'
#'   # run from within a project on a single sub-project
#'   dcf_check("gtrends")
#'
#'   # run outside of a project on a single sub-project
#'   dcf_check("gtrends", "../path/to/project")
#' }
#' @export

dcf_check <- function(
  names = NULL,
  project_dir = ".",
  verbose = TRUE
) {
  if (missing(project_dir) && length(names) == 1L && dir.exists(project_dir)) {
    project_dir <- names
    names <- NULL
  }
  if (
    is.null(names) && !file.exists(paste0(project_dir, "/", "settings.json"))
  ) {
    project_dir <- normalizePath(project_dir, "/", FALSE)
    if (file.exists(paste0(project_dir, "/", "process.json"))) {
      names <- basename(project_dir)
      project_dir <- dirname(project_dir)
    } else {
      names <- basename(project_dir)
      project_dir <- dirname(dirname(project_dir))
    }
  }

  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)
    names <- names[file.exists(paste0(base_dir, "/", names, "/process.json"))]
  }
  issues <- list()
  package_change_reports <- 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)
    if (is.null(process)) next
    if (is.null(process$scripts)) {
      cli::cli_warn("process file {process_file} has no defined scripts")
    } else {
      for (script in process$scripts) {
        script_file <- paste0(source_dir, script$path)
        if (!file.exists(script_file)) {
          cli::cli_warn("defined script {script_file} does not exist")
        }
      }
    }
    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
    )
    measure_ids <- unique(c(
      names(info),
      unlist(lapply(info, "[[", "source_id"))
    ))
    if (is.null(info)) {
      cli::cli_abort("{.file {info_file}} is malformed")
    }
    if (verbose) {
      cli::cli_bullets(c("", "Checking project {.strong {name}}"))
    }
    data_out_dir <- paste0(source_dir, if (is_bundle) "dist" else "standard")
    package_file <- paste0(data_out_dir, "/datapackage.json")
    if (!file.exists(package_file)) {
      cli::cli_warn(
        "project {name} has not been processed (missing {package_file})"
      )
    } else if (!(package_file %in% names(package_change_reports))) {
      package_change_reports[[package_file]] <- dcf_attempt_read_json(
        package_file,
        strict = FALSE
      )$change_report
    }
    change_reports <- package_change_reports[[package_file]]
    data_files <- list.files(
      data_out_dir,
      "\\.(?: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[[sub(
        paste0(project_dir, "/"),
        "",
        file,
        fixed = TRUE
      )]] <- list(
        data = "not_compressed"
      )
    }
    if (length(data_files)) {
      for (file in data_files) {
        change_report <- change_reports[[basename(file)]]$variables
        file_relative_path <- sub(
          paste0(project_dir, "/"),
          "",
          file,
          fixed = TRUE
        )
        file_id <- sub("^[^/]+/", "", file_relative_path)
        issue_messages <- NULL
        if (verbose) {
          cli::cli_progress_step("checking file {.file {file}}", spinner = TRUE)
        }
        data_issues <- NULL
        measure_issues <- NULL
        data <- attempt_read(file, c("geography", "time"))
        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)) {
            dropped_levels <- length(change_report$geography$dropped_levels)
            if (dropped_levels) {
              data_issues <- c(data_issues, "geography_dropped")
              if (verbose) {
                issue_messages <- c(
                  issue_messages,
                  "{.emph geography} {dropped_levels} levels were dropped from previous version"
                )
              }
            }
            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)) && 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)) {
            col_id <- paste0(file_id, "|", col)
            change <- change_report[[col]]
            if (identical(change$status, "removed")) {
              measure_issues <- c(
                measure_issues,
                paste("dropped_measure:", col)
              )
              if (verbose) {
                issue_messages <- c(
                  issue_messages,
                  paste0(
                    "{.emph ",
                    col,
                    "} column was dropped since the last version"
                  )
                )
              }
            } else if (isFALSE(change$same_type)) {
              measure_issues <- c(measure_issues, paste("type_changed:", col))
              if (verbose) {
                issue_messages <- c(
                  issue_messages,
                  paste0(
                    "{.emph ",
                    col,
                    "} column has a different type from the previous version"
                  )
                )
              }
            } else if (length(change$dropped_levels)) {
              n_added <- length(change$added_levels)
              if (n_added && (n_added == length(unique(data[[col]])))) {
                measure_issues <- c(
                  measure_issues,
                  paste("levels_changed:", col)
                )
                if (verbose) {
                  issue_messages <- c(
                    issue_messages,
                    paste0(
                      "{.emph ",
                      col,
                      "} column has all different levels than previous version"
                    )
                  )
                }
              }
            }
            if (
              !(col %in% c("geography", "time")) &&
                (!(col %in% measure_ids) && !(col_id %in% measure_ids))
            ) {
              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_relative_path]] <- 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)
}

#' Extract Older Files from Git History
#'
#' Extract a file from a data collection project's Git history,
#' or list the available 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/pophive_demo/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)) {
    wd <- getwd()
    on.exit(setwd(wd))
    setwd(dirname(path))
    commits <- sys::exec_internal("git", c("log", basename(path)))
    setwd(wd)
    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)
  }
  wd <- getwd()
  on.exit(setwd(wd), TRUE)
  setwd(dirname(path))
  status <- sys::exec_wait(
    "git",
    c("show", paste0(commit_hash, ":./", basename(path))),
    std_out = out_path
  )
  setwd(wd)
  if (status != 0L) {
    unlink(out_path)
    cli::cli_abort("failed to git show: {status}")
  }
  out_path
}

#' 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.
#' @param standard_names A character vector with standard dataset names as names, and
#' fixed patterns to search for in the metadata as values (in lowercase; e.g.,
#' \code{c(condition = "condition name")}).
#' These take precedence over the existing set of standard names, so make sure
#' the pattern is sufficiently specific to the target dataset.
#' @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 = ".", standard_names = NULL) {
  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(
    tolower(standard_names),
    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"
  )
  standard_names <- standard_names[!duplicated(standard_names)]
  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
  }
  if (!("year" %in% colnames(data))) {
    if (!is.null(meta[["Session Date Range"]])) {
      data$Year <- meta[["Session Date Range"]]
    } else {
      year <- gsub(
        "^_|\\.$",
        "",
        regmatches(
          basename(path),
          gregexpr("_\\d{4}\\.", basename(path))
        )[[1L]]
      )
      if (length(year)) {
        data$Year <- year
      }
    }
  }
  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, fixed = TRUE)] <- "bmi_30_49.8"
  cols[grep("hemoglobin_a1c_7", cols, fixed = TRUE)] <- "hemoglobin_a1c_7"
  cols[grep("mmr_receipt", cols, fixed = TRUE)] <- "mmr_receipt"
  cols[grep("opioid", cols, fixed = TRUE)] <- "ed_opioid"
  cols[grep("^rsv_tests", cols)] <- "rsv_tests"
  cols[grep("total:", cols, fixed = TRUE)] <- "total"
  cols
}

#' 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)) {
    base_dir <- normalizePath(base_dir, "/", FALSE)
    name <- basename(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()'),
          "```",
          "",
          "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 (use_git) {
    dcf_init_git(base_path)
    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)
}

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

#' 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 run_scripts Logical; if \code{FALSE}, will rebuild datapackages without running
#' scripts.
#' @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
#' and each bundle's `dist` directory.
#' @examples
#' \dontrun{
#'
#'   # run from a directory containing a `data` directory containing the source project
#'   dcf_process("source_name")
#'
#'   # run without executing the ingestion script
#'   dcf_process("source_name", run_scripts = FALSE)
#' }
#' @export

dcf_process <- function(
  name = NULL,
  project_dir = ".",
  run_scripts = TRUE,
  is_auto = FALSE,
  force = FALSE,
  clear_state = FALSE
) {
  if (!is.null(name) && missing(project_dir) && dir.exists(name)) {
    project_dir <- name
    name <- NULL
  }
  settings_file <- paste0(project_dir, "/settings.json")
  from_project <- file.exists(settings_file)
  if (from_project) {
    source_dir <- paste0(
      project_dir,
      "/",
      dcf_attempt_read_json(settings_file)$data_dir
    )
  } else if (file.exists(paste0(project_dir, "../../settings.json"))) {
    project_dir <- normalizePath(project_dir, "/", FALSE)
    source_dir <- dirname(project_dir)
    project_dir <- dirname(dirname(project_dir))
  } else if (is.null(name)) {
    project_dir <- normalizePath(project_dir, "/", FALSE)
    source_dir <- dirname(project_dir)
    name <- basename(project_dir)
    project_dir <- source_dir
  } else {
    source_dir <- project_dir
  }

  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")
    missing_process_files <- process_files[!file.exists(process_files)]
    if (length(missing_process_files)) {
      cli::cli_abort(
        "missing process file{?/s}: {.emph {missing_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
    if (is.null(name)) {
      name <- basename(dirname(process_file))
    }
    dcf_add_source(
      name,
      project_dir,
      open_after = FALSE,
      use_git = FALSE,
      use_workflow = FALSE
    )
    base_dir <- dirname(process_file)
    for (si in seq_along(process_def$scripts)) {
      st <- proc.time()[[3]]
      process_script <- process_def$scripts[[si]]
      run_current <- decide_to_run(process_script)
      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 (run_scripts) {
        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 if (
        length(process_def$scripts) >= si &&
          !is.null(process_def$scripts[[si]]$last_status)
      ) {
        process_def$scripts[[si]]$last_status
      } 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)
    ) {
      if (is.null(process_def_current$name)) {
        process_def_current$name <- basename(dirname(process_file))
      }
      process_def_current$scripts <- process_def$scripts
      dcf_process_record(process_file, process_def_current)
    }
    standard_dir <- paste0(base_dir, "/standard")
    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.list(s) &&
                !is.null(s$location) &&
                !(s$location %in% names(sources))
            ) {
              measure_sources[[s$location]] <- s
            }
          }
        }
        datapackage_path <- paste0(standard_dir, "/datapackage.json")
        if (!file.exists(datapackage_path)) {
          dcf_datapackage_init(name, dir = standard_dir, quiet = TRUE)
        }
        base_meta <- list(
          source = unname(measure_sources),
          base_dir = base_dir,
          ids = "geography",
          time = "time",
          variables = measure_info
        )
        dcf_datapackage_add(
          data_files,
          meta = if (length(process_def_current$vintages)) {
            vintages <- process_def_current$vintages
            lapply(structure(data_files, names = data_files), function(f) {
              base_meta$vintage <- vintages[[f]]
              base_meta
            })
          } else {
            base_meta
          },
          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 {standard_dir}}")
      )
    }
  }
  process_bundle <- function(process_file) {
    process_def <- dcf_process_record(process_file)
    source_files <- if (length(process_def$source_files)) {
      if (!is.null(names(process_def$source_files))) {
        names(process_def$source_files)
      } else {
        process_def$source_files
      }
    } else {
      NULL
    }
    if (clear_state) {
      process_def$source_state <- NULL
      process_def$dist_state <- NULL
      dcf_process_record(process_file, process_def)
    }
    name <- process_def$name
    if (is.null(name)) {
      name <- basename(dirname(process_file))
    }
    dcf_add_bundle(
      name,
      project_dir,
      open_after = FALSE,
      use_git = FALSE,
      use_workflow = FALSE
    )
    base_dir <- dirname(process_file)
    for (si in seq_along(process_def$scripts)) {
      st <- proc.time()[[3]]
      process_script <- process_def$scripts[[si]]
      script <- paste0(base_dir, "/", process_script$path)
      run_current <- TRUE
      standard_state <- NULL
      if (length(source_files)) {
        standard_files <- paste0(source_dir, "/", source_files)
        standard_state <- as.list(tools::md5sum(paste0(
          source_dir,
          "/",
          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 <- if (run_scripts) {
          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 if (
          length(process_def$scripts) >= si &&
            !is.null(process_def$scripts[[si]]$last_status)
        ) {
          process_def$scripts[[si]]$last_status
        } 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)
    source_packages <- as.list(unlist(Filter(
      length,
      lapply(
        unique(paste0(
          vapply(paste0(source_dir, "/", source_files), dirname, ""),
          "/datapackage.json"
        )),
        function(package_file) {
          if (file.exists(package_file)) {
            tools::md5sum(package_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 <- c(
        as.list(tools::md5sum(paste0(
          base_dir,
          "/dist/",
          dist_files
        ))),
        source_packages
      )
      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
        if (is.null(process_def_current$name)) {
          process_def_current$name <- basename(dirname(process_file))
        }
        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 (length(source_packages)) {
          source_resources <- lapply(
            names(source_packages),
            function(f) {
              dp <- dcf_attempt_read_json(f)
              list(
                name = dp$name,
                data_dir = dirname(f),
                resources = dp$resources,
                measure_info = dp$measure_info
              )
            }
          )
          fill_source_info <- function(id, info) {
            info$id <- id
            if (!is.null(info$levels)) {
              for (level_id in names(info$levels)) {
                info$levels[[level_id]] <- fill_source_info(
                  level_id,
                  info$levels[[level_id]]
                )
              }
              return(info)
            }
            source_id <- if (!is.null(info$source_id)) {
              info$source_id
            } else {
              id
            }
            source_info <- NULL
            for (package in source_resources) {
              has_package_info <- !is.null(package$measure_info)
              for (resource in package$resources) {
                has_resource_info <- !is.null(package$measure_info)
                for (field in resource$schema$fields) {
                  if (identical(source_id, field$name)) {
                    source_info <- field
                    source_info$info <- if (
                      has_resource_info &&
                        (source_id %in% names(resource$measure_info))
                    ) {
                      resource$measure_info[[source_id]]
                    } else if (
                      has_package_info &&
                        (source_id %in% names(package$measure_info))
                    ) {
                      package$measure_info[[source_id]]
                    } else {
                      list()
                    }
                    source_info$info$source_file <- list(
                      project = package$name,
                      data_dir = sub(
                        project_dir,
                        "",
                        package$data_dir,
                        fixed = TRUE
                      ),
                      file = resource$filename
                    )
                  }
                }
              }
            }
            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]]
                  ))
                }
              }
            }
            info
          }
          for (measure_id in names(measure_info)) {
            measure_info[[measure_id]] <- fill_source_info(
              measure_id,
              measure_info[[measure_id]]
            )
          }
        }
        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)
        }
        metas <- list(
          source = unname(measure_sources),
          base_dir = base_dir,
          ids = "geography",
          time = "time",
          variables = measure_info
        )
        if (!is.null(names(process_def_current$source_files))) {
          bundle_source_files <- names(process_def_current$source_files)
          package_files <- paste0(
            dirname(base_dir),
            "/",
            dirname(bundle_source_files),
            "/datapackage.json"
          )
          vintages <- process_def_current$vintages
          for (i in seq_along(bundle_source_files)) {
            package_file <- package_files[[i]]
            source_dist_files <- process_def_current$source_files[[bundle_source_files[[
              i
            ]]]]
            if (file.exists(package_file)) {
              package <- dcf_attempt_read_json(package_file)
              for (resource in package$resources) {
                if (length(resource$vintage)) {
                  for (dist_file in source_dist_files) {
                    vintages[[dist_file]] <- max(
                      vintages[[dist_file]],
                      resource$vintage
                    )
                  }
                }
              }
            }
          }
          if (length(names(vintages)) && any(names(vintages) %in% dist_files)) {
            metas <- lapply(
              structure(dist_files, names = dist_files),
              function(dist_file) {
                metas$vintage <- vintages[[dist_file]]
                metas
              }
            )
          }
        } else if (length(process_def_current$vintages)) {
          vintages <- process_def_current$vintages
          metas <- lapply(
            structure(dist_files, names = dist_files),
            function(f) {
              metas$vintage <- vintages[[f]]
              metas
            }
          )
        }
        dcf_datapackage_add(
          dist_files,
          meta = metas,
          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 <- dcf_attempt_read_json(f, strict = FALSE)$type
        is.null(type) || type != "bundle"
      },
      TRUE
    ),
    decreasing = TRUE
  )]) {
    process_def <- dcf_process_record(process_file)
    if (is.null(process_def)) {
      next
    }
    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))
}

#' Download Medicare Disparities Data
#'
#' Download data from the Centers for Medicare & Medicaid Services (CMS)
#' \href{https://data.cms.gov/tools/mapping-medicare-disparities-by-population}{Mapping Medicare Disparities by Population} (MMD) tool.
#'
#' @param measure Name or letter code of the measure to download.
#' @param population The population code; either \code{f} (Medicare Fee For Service) or
#' \code{m} (Medicare Advantage).
#' @param year Year(s) to download (e.g., \code{2015:2020}). If not specified, all available
#' years will be included.
#' @param geography Geography code(s) to include, between \code{n} (national), \code{s} (state),
#' and \code{c} (county). If not specified, all available geographies will be included.
#' @param adjust,condition,sex,age,race,dual_elig,medicare_elig One or more codes indicating
#' the variable levels to include (see \code{\link{dcf_standardize_cmsmmd}}).
#' If \code{"."}, values will be across all levels, whereas if \code{NULL}, all available levels
#' will be included (aggregated and disaggregated). See the Making Requests section.
#' @param refresh_codebook Logical; if \code{TRUE}, will re-download the codebook even if it
#' exists in the temporary location (which is cleared each R session).
#' @param codebook_only Logical; if \code{TRUE}, will return the codebook without downloading data.
#' @param row_limit Maximum number of rows to return in each request. The API limit appears to be 100,000.
#' @param out_file Path to the CSV or Parquet file to write data to.
#' @param state The codebook state (MD5 hash) recorded during 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.
#' @section Making Requests:
#' The API operates over several large files, partitioned by measure, year,
#' adjust, and dual and medicaid eligibility. These are identified with the codebook
#' (\code{dcf_download_cmsmmd(codebook_only = TRUE)}).
#'
#' The files are larger than the API's limit, so requests for each file have to be broken up
#' by the other variables within them (sex, age, race, and condition).
#'
#' For best performance, make requests as big as possible while staying under 100,000 rows
#' each (e.g., by setting \code{sex}, \code{age}, or \code{race} to \code{NULL}).
#' @returns \code{dcf_download_cmsmmd}: A list:
#' \itemize{
#'   \item \strong{\code{codebook}}: The codebook.
#'   \item \strong{\code{codebook_state}}: MD5 hash of the codebook.
#'   \item \strong{\code{data}}: The downloaded data.
#' }
#' @examples
#' # find the codes associated with menu values
#' variable_codes <- dcf_standardize_cmsmmd()
#' variable_codes[c(
#'   "sex", "age", "race",
#'   "adjust", "dual_elig", "medicare_elig"
#' )]
#'
#' # look at the codebook which defines source files
#' codebook <- dcf_download_cmsmmd(codebook_only = TRUE)
#' codebook
#'
#' \dontrun{
#'   # download data
#'   downloaded <- dcf_download_cmsmmd(
#'     "preventive care",
#'     population = "f",
#'     race = ".",
#'     sex = ".",
#'     age = NULL,
#'     condition = c(83, 85, 86, 88, 89, 95, 101, 102, 104, 105:107),
#'     adjust = 1
#'   )
#'
#'   # convert codes to levels
#'   data_standard <- dcf_standardize_cmsmmd(downloaded$data)
#' }
#' @export

dcf_download_cmsmmd <- function(
  measure,
  population = NULL,
  year = NULL,
  geography = NULL,
  adjust = NULL,
  condition = NULL,
  sex = c(1:2, "."),
  age = c(0:4, "."),
  race = c(1:6, "."),
  dual_elig = ".",
  medicare_elig = ".",
  refresh_codebook = FALSE,
  codebook_only = FALSE,
  row_limit = 9999999,
  out_file = NULL,
  state = NULL,
  parquet = FALSE,
  verbose = TRUE
) {
  # load codebook
  codebook_file <- paste0(tempdir(), "/codebook_crosswalk.csv")
  if (refresh_codebook || !file.exists(codebook_file)) {
    if (verbose) cli::cli_progress_step("retrieving codebook")
    codebook_req <- curl::curl_fetch_disk(
      "https://data.cms.gov/mmd-population/assets/codebook_crosswalk.csv",
      codebook_file
    )
    if (codebook_req$status_code != 200) {
      unlink(codebook_file)
      cli::cli_abort("failed to retrieve codebook: {codebook_req$status_code}")
    }
    if (verbose) cli::cli_progress_done()
  }
  new_state <- tools::md5sum(codebook_file)
  if (!is.null(state)) {
    if (state == new_state) {
      if (verbose) {
        cli::cli_alert_info("codebook has not changed since last download")
      }
      return(invisible(NULL))
    }
  }
  codebook <- vroom::vroom(
    codebook_file,
    col_types = list(
      elig = "c",
      race_code = "c",
      sex_code = "c",
      adjust = "c",
      dual = "c"
    ),
    na = " "
  )
  codebook$description <- tolower(codebook$description)

  if (codebook_only) return(codebook)

  # identify source(s)
  if (missing(measure)) {
    cli::cli_abort("specify a measure: {.value {unique(codebook$description)}}")
  }

  measure_descriptions <- unique(codebook$description)
  if (nchar(measure) == 1L) {
    codebook <- codebook[codebook$measure == tolower(measure), ]
  } else {
    codebook <- codebook[grepl(measure, codebook$description), ]
  }
  if (!nrow(codebook)) {
    cli::cli_abort(
      paste(
        'measure "{measure}" does not match the available measures:',
        "{.value {measure_descriptions}}"
      )
    )
  }

  if (is.null(population)) population <- codebook$population[[1L]]
  codebook <- codebook[
    filter_codebook(codebook$population, population, "population"),
  ]

  if (!is.null(year)) {
    if (is.numeric(year)) year <- as.character(year)
    if (any(nchar(year) > 2L)) {
      year <- substring(
        year,
        nchar(year) -
          as.integer(as.character(cut(
            as.numeric(year),
            c(
              -Inf,
              if (population == "m") 2014L else 2019L,
              Inf
            ),
            c(0L, 1L)
          )))
      )
    }
    codebook <- codebook[
      filter_codebook(codebook$year, year, "year"),
    ]
  }
  if (missing(dual_elig)) dual_elig <- codebook$dual[[1L]]
  if (!is.null(dual_elig)) {
    codebook <- codebook[
      filter_codebook(codebook$dual, dual_elig, "dual_elig"),
    ]
  }
  if (missing(medicare_elig)) medicare_elig <- codebook$elig[[1L]]
  if (!is.null(medicare_elig)) {
    codebook <- codebook[
      filter_codebook(codebook$elig, medicare_elig, "medicare_elig"),
    ]
  }

  # make requests
  param_sets <- expand.grid(
    Filter(
      length,
      list(
        fltr = adjust,
        agecat = age,
        sexcat = sex,
        racecat = race,
        condition = condition,
        "_source" = unique(codebook$url)
      )
    ),
    stringsAsFactors = FALSE
  )
  param_sets[param_sets == "." | param_sets == "all"] <- ".|IS NULL"
  data_url <- paste0(
    "https://data.cms.gov/data-api/v1/mmd-tool/?_size=",
    row_limit,
    "&"
  )
  n_requests <- nrow(param_sets)
  all_data <- list()
  if (verbose) cli::cli_h1("making requests to {data_url}")
  for (i in seq_len(n_requests)) {
    params <- as.list(param_sets[i, ])
    param_string <- paste0(names(params), "=", params, collapse = "&")
    req <- curl::curl_fetch_memory(utils::URLencode(paste0(
      data_url,
      param_string
    )))
    if (req$status_code != 200) {
      cli::cli_abort(
        "a request failed: ({req$status_code}) {rawToChar(req$content)}"
      )
    }
    all_data[[i]] <- jsonlite::fromJSON(rawToChar(req$content))
    if (verbose)
      cli::cli_progress_step(
        paste0(
          i,
          " of ",
          n_requests,
          " (",
          nrow(all_data[[i]]),
          " rows): ",
          param_string
        ),
        spinner = TRUE
      )
  }
  if (verbose) cli::cli_progress_done()

  all_data <- do.call(rbind, all_data)
  if (!is.null(out_file)) {
    dir.create(dirname(out_file), showWarnings = FALSE, recursive = TRUE)
    if (parquet || grepl(".parquet", out_file, fixed = TRUE)) {
      if (verbose) cli::cli_progress_step("writing to Parquet")
      arrow::write_parquet(
        all_data,
        compression = "gzip",
        sub(".csv", ".parquet", out_file, fixed = TRUE)
      )
    } else {
      if (verbose) cli::cli_progress_step("writing to CSV")
      vroom::vroom_write(all_data, out_file, ",")
    }
  }
  invisible(list(
    codebook_state = new_state,
    codebook = codebook,
    data = all_data
  ))
}

filter_codebook <- function(x, values, column) {
  su <- x %in% values
  if (!any(su)) {
    cli::cli_abort(
      paste(
        '{.arg {column}} does not contain specified values.',
        "Available values: {.value {unique(x)}}"
      )
    )
  }
  su
}

#' @rdname dcf_download_cmsmmd
#' @param raw_data The raw data as downloaded with \code{dcf_download_cmsmmd} to be standardized.
#' @returns \code{dcf_standardize_cmsmmd}: If \code{raw_data} is \code{NULL}, a list
#' with an entry for each API parameter, containing named vectors with level codes as names
#' mapping to level values (as they appear in the tool's menus).
#' Otherwise, a version of \code{raw_data} with coded values converted to labels.
#' @export

dcf_standardize_cmsmmd <- function(raw_data = NULL) {
  # extracted from https://data.cms.gov/mmd-population/js/menus.js
  menu <- jsonlite::read_json(
    system.file(
      "support_data/cms_mmd_levels.json.gz",
      package = "dcf"
    )
  )
  levels <- lapply(
    menu,
    function(e) {
      options <- Filter(
        length,
        lapply(e$options, function(o) {
          if (length(o$val)) {
            o$val <- as.character(o$val)
            o
          }
        })
      )
      c(
        structure(
          vapply(options, "[[", "", "disp"),
          names = vapply(options, "[[", "", "val")
        )
      )
    }
  )
  names(levels) <- vapply(menu, "[[", "", "id")
  levels$geography["n"] <- "National"
  levels$fltr <- levels$adjust
  levels$sex <- levels$sexcat <- levels$sex_code
  levels$race <- levels$racecat <- levels$race_code
  levels$age <- levels$agecat <- levels$age_group
  levels$eligcat <- levels$medicare_elig <- levels$eligibility
  levels$dual_elig <- levels$dual
  if (is.null(raw_data)) return(levels)
  for (col in colnames(raw_data)) {
    col_levels <- levels[[col]]
    if (!is.null(col_levels)) {
      values <- as.character(raw_data[[col]])
      values[values == ""] <- "."
      raw_data[[col]] <- c(col_levels, "." = "All")[values]
    }
  }
  raw_data
}

#' 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 compare_resources Logical; if \code{FALSE}, will not compare resource entries in
#' the previous datapackage version if it exists, and include a report of these in the
#' top-level \code{change_report} list.
#' @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 as map 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}}.
#'   }
#'   \item{vintage}{
#'   A string specifying the time and/or location at which the data were produced.
#'   }
#' }
#' @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,
  compare_resources = TRUE,
  open_after = FALSE,
  verbose = interactive()
) {
  if (missing(filename)) {
    cli::cli_abort("{.arg filename} must be specified")
  }
  setnames <- names(filename)
  if (file.exists(filename[[1L]])) {
    if (dir == ".") {
      dir <- dirname(filename[[1L]])
    }
    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 || compare_resources) {
    if (is.character(package)) {
      package <- paste0(dir, "/", packagename)
      if (file.exists(package)) {
        packagename <- package
        package <- dcf_attempt_read_json(package)
      } else {
        package <- dcf_datapackage_init(
          if (!is.null(setnames)) setnames[[1]] else filename[[1]],
          dir = dir
        )
      }
    }
  }
  if (!is.list(package)) {
    package <- list()
  }
  initial_package <- if (compare_resources) package else list()
  single_meta <- FALSE
  metas <- if (!is.null(names(meta))) {
    meta_names <- if (is.null(setnames)) filename else setnames
    if (all(meta_names %in% names(meta))) {
      meta[meta_names]
    } else {
      single_meta <- TRUE
      if (length(meta$variables) == 1L && is.character(meta$variables)) {
        if (!file.exists(meta$variables)) {
          meta$variables <- paste0(dir, "/", meta$variables)
        }
        if (file.exists(meta$variables)) {
          meta$variables <- dcf_attempt_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]][[1L]])) {
        m[[n]]
      } else {
        list(m[[n]])
      }
    }
    vintage <- unlist(unpack_meta("vintage"))
    ids <- unpack_meta("ids")
    idvars <- NULL
    for (i in seq_along(ids)) {
      if (is.list(ids[[i]])) {
        if (
          length(ids[[i]]$map) == 1L &&
            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 <- 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(1L, nrow(data)) else data[[timevar]]
    times_unique <- unique(times)
    varinf <- unpack_meta("variables")
    if (length(varinf) == 1L && is.character(varinf[[1L]])) {
      if (!file.exists(varinf[[1L]])) {
        varinf[[1L]] <- paste0(dir, "/", varinf[[1L]])
      }
      if (file.exists(varinf[[1L]])) {
        if (varinf[[1L]] %in% names(metas)) {
          varinf <- metas[[varinf[[1L]]]]
        } else {
          varinf <- metas[[varinf[[1L]]]] <- dcf_measure_info(
            varinf[[1L]],
            write = FALSE,
            render = TRUE
          )
        }
        varinf <- varinf[varinf != ""]
      }
    }
    varinf_full <- if (is.null(names(varinf))) "" else names(varinf)
    varinf_suf <- sub("^[^:]+:", "", varinf_full)
    created <- as.character(info$mtime)
    res <- list(
      bytes = as.integer(info$size),
      encoding = stringi::stri_enc_detect(f)[[1L]][1L, 1L],
      md5 = tools::md5sum(f)[[1L]],
      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"),
      data_format = if (
        any(vapply(
          m$variables,
          function(info) !is.null(info$levels),
          TRUE
        ))
      ) {
        "tall"
      } else {
        "wide"
      },
      ids = ids,
      id_length = if (length(idvars)) {
        id_lengths <- nchar(data[[idvars[1L]]])
        id_lengths <- id_lengths[!is.na(id_lengths)]
        if (all(id_lengths == id_lengths[1L])) id_lengths[1L] else 0L
      } else {
        0L
      },
      time = timevar,
      profile = "data-resource",
      created = as.character(info$mtime),
      last_modified = as.character(info$ctime),
      vintage = if (length(vintage)) vintage else NULL,
      row_count = nrow(data),
      entity_count = if (length(idvars)) {
        length(unique(data[[idvars[1L]]]))
      } 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 (cn %in% varinf_full) {
              r$info <- varinf[[cn]]
            } else if (cn %in% varinf_suf) {
              r$info <- varinf[[which(varinf_suf == cn)]]
            } else {
              scoped_name <- paste0(f, "|", cn)
              scoped_name <- substring(
                scoped_name,
                unique(nchar(scoped_name) - nchar(varinf_full) + 1L)
              )
              if (sum(scoped_name %in% varinf_full) == 1L) {
                r$info <- varinf[[scoped_name[
                  scoped_name %in% varinf_full
                ]]]
              }
            }
            if ("info" %in% names(r$info)) {
              r$info <- r$info$info
            }
            r$info <- Filter(
              length,
              lapply(
                r$info,
                function(e) {
                  if (!identical(e, "")) {
                    if (
                      is.character(e) &&
                        length(e) == 1L &&
                        grepl("|", e, fixed = TRUE)
                    ) {
                      scoped_id <- strsplit(e, "|", fixed = TRUE)[[1L]][[2L]]
                      if (scoped_id %in% colnames(data)) scoped_id else e
                    } else {
                      e
                    }
                  }
                }
              )
            )
            su <- !is.na(v)
            if (any(su) && !is.null(times)) {
              r$time_range <- which(times_unique %in% range(times[su])) - 1L
              r$time_range <- if (length(r$time_range)) {
                r$time_range[c(1L, length(r$time_range))]
              } else {
                c(-1L, -1L)
              }
            } else {
              r$time_range <- c(-1L, -1L)
            }
            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), 6L)
              r$sd <- round(stats::sd(v, na.rm = TRUE), 6L)
              r$min <- round(min(v, na.rm = TRUE), 6L)
              r$max <- round(max(v, na.rm = TRUE), 6L)
            } else {
              r$type <- "string"
              v <- as.factor(iconv(as.character(v), to = "UTF-8"))
              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) {
      res$measure_info <- lapply(m$variables, function(e) e[e != ""])
      if ("_references" %in% names(varinf)) {
        res[["_references"]] <- varinf[["_references"]]
      }
    }
    if (Sys.which("openssl") != "") {
      res[[paste0("sha", sha)]] <- dcf_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)
      ]
    )
  }
  package$change_report <- if (compare_resources) {
    dcf_compare_datapackages(initial_package, package)
  } else {
    NULL
  }
  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 = 6L,
      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 ")[[
      1L
    ]]
    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 = c("geography", "time")) {
  if (grepl("\\.rds", file, ignore.case = TRUE)) {
    tryCatch(readRDS(file), error = function(e) NULL)
  } else if (grepl("\\.parquet", file, ignore.case = TRUE)) {
    tryCatch(arrow::read_parquet(file), error = function(e) NULL)
  } else if (grepl("\\.json", file, ignore.case = TRUE)) {
    tryCatch(
      as.data.frame(jsonlite::read_json(file, simplifyVector = TRUE)),
      error = function(e) NULL
    )
  } else {
    tryCatch(
      {
        sep <- if (grepl("\\.csv", file, ignore.case = TRUE)) "," else "\t"
        cols <- scan(file, "", nlines = 1L, sep = sep, quiet = TRUE)
        if (length(cols) == 1L && grepl("\t", cols, fixed = TRUE)) {
          cli::cli_warn("{file} appears to be tab-delimited")
          sep <- "\t"
          cols <- scan(file, "", nlines = 1L, sep = sep, quiet = TRUE)
        }
        arrow::read_delim_arrow(
          gzfile(file),
          sep,
          col_names = cols,
          skip = 1L,
          convert_options = arrow::csv_convert_options(
            col_types = arrow::schema(structure(
              lapply(id_cols, function(x) arrow::string()),
              names = id_cols
            )),
            check_utf8 = FALSE
          )
        )
      },
      error = function(e) NULL
    )
  }
}

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

dcf_compare_datapackages <- function(original, updated) {
  changes <- list()
  original_resources <- list()
  for (resource in original$resources) {
    original_resources[[resource$filename]] <- resource
  }
  for (resource in updated$resources) {
    filename <- resource$filename
    original_resource <- original_resources[[filename]]
    resource_changes <- list(state = "new file")
    if (!is.null(original_resource)) {
      if (identical(original_resource$md5, resource$md5)) {
        resource_changes$state <- "unchanged"
      } else {
        resource_changes$state <- "changed"
        original_variables <- list()
        for (field in original_resource$schema$fields) {
          original_variables[[field$name]] <- field
        }
        variables <- list()
        for (field in resource$schema$fields) {
          if (field$name %in% names(original_variables)) {
            original_field <- original_variables[[field$name]]
            variable_report <- list(
              status = "present",
              same_type = identical(field$type, original_field$type)
            )
            if ("table" %in% names(field)) {
              if ("table" %in% names(original_field)) {
                variable_report$added_levels <- names(field$table)[
                  !(names(field$table) %in% names(original_field$table))
                ]
                variable_report$dropped_levels <- names(original_field$table)[
                  !(names(original_field$table) %in%
                    names(field$table))
                ]
              } else {
                variable_report$added_levels <- names(field$table)
              }
            }
            variables[[field$name]] <- variable_report
          } else {
            variables[[field$name]] <- list(status = "added")
          }
        }
        for (name in names(original_variables)[
          !(names(original_variables) %in% names(variables))
        ]) {
          variables[[name]] <- list(status = "removed")
        }
        resource_changes$variables <- variables
      }
    }
    changes[[filename]] <- resource_changes
  }
  for (filename in names(original_resources)[
    !(names(original_resources) %in% names(changes))
  ]) {
    changes[[filename]] <- list(state = "removed file")
  }
  changes
}

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

#' 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.
#' @param ... Passes additional arguments to \code{\link{dcf_read_epic}}.
#' @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))
}

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

#' Interact with a Process File
#'
#' Read or update the current process file.
#'
#' See the \href{https://dissc-yale.github.io/dcf/articles/standards.html#scripts}{script standards}
#' for examples of using this within a sub-project script.
#'
#' @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 <- "../../../pophive/pophive_demo/data/epic/process.json"
#' if (file.exists(epic_process_file)) {
#'   dcf_process_record(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")
    }
    spec <- dcf_attempt_read_json(path)
    if (is.null(spec$name)) {
      spec$name <- basename(dirname(path))
    }
    if (is.null(spec$type)) {
      spec$type <- "source"
    }
    spec
  } else {
    if (is.null(updated$type)) {
      updated$type <- "source"
    }
    jsonlite::write_json(updated, path, auto_unbox = TRUE, pretty = TRUE)
    updated
  }
}

#' Use Data from a Data Collection Project
#'
#' Load the standard or distribution data from a local or remote data collection project.
#'
#' @param variables A character vector of variable names to be loaded, or a selected
#' subset of a project data dictionary, as returned from \code{\link{dcf_variables}}.
#' @param project Path to a local project, or the GitHub account and repository name
#' (\code{"{account_name}/{repo_name}"}) of a remote project.
#' @param data_format The data format to select, between \code{tall} and \code{wide}.
#' Useful if there are duplicate measure names between files of different formats.
#' @param project_type Project type to select, between \code{bundle} and \code{source}.
#' @param ... Additional arguments passed to \code{\link{dcf_report}}.
#' @param unify Logical; if \code{FALSE}, will return \code{data} as a list with entries for each
#' file. Otherwise (by default), will attempt to combine the loaded data.
#' @param only_selected Logical; if \code{TRUE}, will drop columns that were not included in
#' \code{variables}, other than ID columns.
#' @param cache Path to a directory in which to store downloaded files. Within this directory,
#' the repository structure will be recreated within an account-named directory.
#' @param refresh Logical; if \code{TURE}, will download files even if they exist in the \code{cache}.
#' @param verbose Logical; if \code{FALSE}, will not show status messages.
#' @returns A list with entries for metadata (the datapackage resource entry for each file loaded)
#' and data (a tibble or list of tibbles of the unified or separately loaded files).
#' @family data user interface functions
#' @examples
#' # retrieve the full bundle file that includes the `epic_rsv` measure
#' bundle <- dcf_data(
#'   "epic_rsv",
#'   "dissc-yale/pophive_demo",
#'   data_format = "tall",
#'   verbose = FALSE
#' )
#' bundle$data
#'
#' if (require("ggplot2", quietly = TRUE)) {
#'   # extract short names from metadata
#'   labels <- vapply(
#'     bundle$metadata[[1L]]$schema$fields[[3L]]$info$levels,
#'     function(measure) measure$info$short_name,
#'     ""
#'   )
#'
#'   # show trends from different measures over time
#'   bundle$data |>
#'     dplyr::filter(
#'       time >= as.Date("2024-01-01"),
#'       measure != "epic_all_encounters"
#'     ) |>
#'     dplyr::mutate(measure = labels[measure]) |>
#'     ggplot(aes(x = time, y = value_scaled, color = measure)) +
#'     theme_dark() %+replace%
#'     theme(panel.background = element_rect(fill = FALSE, color = FALSE)) +
#'     geom_smooth(
#'       method = "gam",
#'       formula = y ~ s(x, bs = "cs", k = 50L)
#'     )
#' }
#' @export

dcf_data <- function(
  variables = NULL,
  project = ".",
  data_format = NULL,
  project_type = "bundle",
  ...,
  unify = TRUE,
  only_selected = FALSE,
  cache = tempdir(),
  refresh = FALSE,
  verbose = TRUE
) {
  report <- dcf_report(project, ..., refresh = refresh)
  if (is.null(variables) || is.character(variables)) {
    all_variables <- dcf_variables(report)
    selected <- all_variables[
      all_variables$project_type == project_type &
        grepl(
          paste0("^(?:", paste(variables, collapse = "|"), ")$"),
          all_variables$name
        ),
    ]
  } else {
    if (!all(c("name", "file") %in% colnames(variables))) {
      cli::cli_abort(
        "`variables` must include `name` and `file` columns if not a character vector"
      )
    }
    all_variables <- selected <- variables
    variables <- selected$name
  }
  if (!is.null(data_format)) {
    selected <- selected[selected$data_format == data_format, ]
  }
  if (nrow(selected) == 0L) {
    cli::cli_abort("no variables found")
  }
  not_found <- if (is.null(variables)) character() else
    variables[!(variables %in% selected$name)]
  if (length(not_found)) {
    cli::cli_abort("variable{?/s} not found: {not_found}")
  }
  data_dir <- report$settings$data_dir
  files <- unique(selected$file)
  project_outputs <- gsub("^[^/]+/|/[^/]+$", "", files)
  project_metadata <- report$metadata[
    names(report$metadata) %in% project_outputs
  ]
  file_metadata <- list()
  for (output in names(project_metadata)) {
    datapackage <- project_metadata[[output]]
    for (i in seq_along(datapackage$resources)) {
      resource_file <- paste(
        data_dir,
        output,
        datapackage$resources[[i]]$filename,
        sep = "/"
      )
      if (resource_file %in% files) {
        file_metadata[[resource_file]] <- datapackage$resources[[i]]
      }
    }
  }
  file_metadata <- file_metadata[files]

  # download files to cache if needed
  if (identical(report$settings$report_url, "")) {
    if (verbose) cli::cli_alert_info("loading files from local project")
    project_root <- paste0(project, "/")
  } else {
    project_root <- paste0(
      normalizePath(paste0(cache, "/", project), "/", FALSE),
      "/"
    )
    if (verbose)
      cli::cli_alert_info("downloading files to cache: {project_root}")
    base_url <- dirname(report$settings$report_url)
    for (file in files) {
      cached_file <- paste0(project_root, file)
      if (refresh || !file.exists(cached_file)) {
        file_url <- paste0(base_url, "/", file)
        dir.create(dirname(cached_file), FALSE, TRUE)
        req <- curl::curl_fetch_disk(file_url, cached_file)
        if (req$status_code != 200L) {
          unlink(cached_file)
          cli::cli_warn("failed to download {.url {file_url}}")
        }
      }
    }
    if (verbose) cli::cli_alert_info("loading files from cache project")
  }

  # load files
  n_files <- length(files)
  if (verbose)
    cli::cli_progress_bar("loading files", "download", total = n_files)
  data <- list()
  data_tall <- structure(logical(n_files), names = files)
  for (file in files) {
    data[[file]] <- attempt_read(paste0(project_root, file))
    data[[file]]$source_file <- file
    if (identical(file_metadata[[file]]$data_format, "tall")) {
      data_tall[[file]] <- TRUE
    }
    if (verbose) cli::cli_progress_update()
  }
  if (verbose) cli::cli_progress_done()

  if (unify) {
    if (length(data) > 1L) {
      all_cols <- unique(unlist(lapply(data, colnames)))
      if (!any(data_tall)) {
        id_cols <- c("geography", "time", "age")
        id_cols <- id_cols[id_cols %in% all_cols]
        if (only_selected)
          all_cols <- all_cols[all_cols %in% c(id_cols, selected$name)]
        data <- dplyr::as_tibble(Reduce(
          function(x, y) merge(x, y, id_cols, all = TRUE),
          lapply(
            data,
            function(d) {
              for (col in id_cols[!(id_cols %in% colnames(d))]) d[[col]] <- NA
              if (only_selected) d <- d[, all_cols[all_cols %in% colnames(d)]]
              d[, colnames(d) != "source_file"]
            }
          )
        ))
      } else if (all(data_tall)) {
        data <- do.call(
          dplyr::bind_rows,
          lapply(files, function(file) {
            d <- data[[file]]
            if (only_selected) {
              measure_col <- unlist(lapply(
                file_metadata[[file]]$schema$fields,
                function(field)
                  if ("levels" %in% names(field$info)) field$name else NULL
              ))
              d <- d[d[[measure_col]] %in% selected$name, ]
            }
            d[, all_cols]
          })
        )
      } else {
        cli::cli_warn(
          "datasets are in inconsistent formats, so will not be unified"
        )
      }
    } else {
      data <- data[[1L]]
    }
  }

  invisible(list(metadata = file_metadata, data = data))
}

#' 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 <- dcf_attempt_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 (identical(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) && identical(process$type, "bundle")) {
      dist_files <- grep(
        "measure_info|datapackage",
        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, '["`', filename, '`"]')
        )
      }
      file_nodes <- file_ids[
        if (!is.null(names(process$source_files))) {
          names(process$source_files)
        } else {
          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 {
      measure_sources <- measures[["_sources"]]
      if (is.null(measure_sources)) {
        measure_sources <- measures[["_source"]]
      }
      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]]
          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,
              '["`',
              r$filename,
              if (length(file_issues)) {
                if (!is.null(file_issues$measures)) {
                  measure_issues <- do.call(
                    rbind,
                    strsplit(unlist(file_issues$measures), ": ")
                  )
                  measure_issues <- tapply(
                    measure_issues[, 2],
                    measure_issues[, 1],
                    paste,
                    collapse = ", "
                  )
                  file_issues$measures <- paste0(
                    names(measure_issues),
                    ": ",
                    measure_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>"
  )
}

#' 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 <- dcf_attempt_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 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/pophive_demo"
#' 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)
  is_standalone <- isTRUE(settings$standalone)
  data_dir <- if (is_standalone) {
    dirname(project_dir)
  } else {
    paste0(project_dir, "/", settings$data_dir)
  }

  processes <- list.files(
    data_dir,
    "process\\.json",
    recursive = TRUE,
    full.names = TRUE
  )
  process_state <- tools::md5sum(processes)
  report_file <- paste0(project_dir, "/report.json.gz")
  process <- dcf_process(project_dir = project_dir, is_auto = TRUE, ...)
  issues <- dcf_check(project_dir = project_dir)
  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) <- sub(
      "^/",
      "",
      sub(
        data_dir,
        "",
        sub("/datapackage.json", "", datapackages, fixed = TRUE),
        fixed = TRUE
      )
    )
    names(processes) <- sub(
      "^/",
      "",
      sub(
        data_dir,
        "",
        sub("/process.json", "", processes, fixed = TRUE),
        fixed = TRUE
      )
    )
    report <- list(
      date = Sys.time(),
      settings = settings,
      source_times = process$timings,
      logs = process$logs,
      issues = issues,
      metadata = lapply(datapackages, dcf_attempt_read_json),
      processes = lapply(processes, dcf_attempt_read_json)
    )
    with_levels <- list()
    measures <- list()
    for (p in seq_along(report$metadata)) {
      for (r in seq_along(report$metadata[[p]]$resources)) {
        for (f in seq_along(
          report$metadata[[p]]$resources[[r]]$schema$fields
        )) {
          info <- report$metadata[[p]]$resources[[r]]$schema$fields[[f]]$info
          if (is.list(info) && !is.null(info$id)) {
            measures[[info$id]] <- list(
              project = report$metadata[[p]]$name,
              file = report$metadata[[p]]$resources[[r]]$filename,
              info = info
            )
            if (!is.null(info$levels)) {
              with_levels <- c(with_levels, list(c(p, r, f)))
            }
          }
        }
      }
    }
    for (cords in with_levels) {
      levels <- report$metadata[[cords[[1L]]]]$resources[[cords[[
        2L
      ]]]]$schema$fields[[cords[[3L]]]]$info$levels
      source_info <- list()
      for (level_id in names(levels)) {
        level <- levels[[level_id]]
        source_id <- if (!is.list(level) || is.null(level$source_id)) {
          level_id
        } else {
          level$source_id
        }
        source_info[[source_id]] <- measures[[source_id]]
      }
      report$metadata[[cords[[1L]]]]$resources[[cords[[
        2L
      ]]]]$schema$fields[[cords[[3L]]]]$info$source_info <- source_info
    }
    jsonlite::write_json(
      report,
      gzfile(report_file),
      auto_unbox = TRUE,
      dataframe = "columns"
    )
  } else {
    report <- dcf_attempt_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 = if (length(p_file$vintage)) {
              p_file$vintage
            } else {
              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)
}

#' View Project Variables
#'
#' Get a list of measures (a codebook) that are included in a data collection project.
#'
#' @param project Path to a local project, or the GitHub account and repository name
#' (\code{"{account_name}/{repo_name}"}) of a remote project.
#' Or a report as returned from \code{\link{dcf_report}}.
#' @param exclude A character vector of variable names to exclude from the list (usually ID columns).
#' @param ... Additional arguments passed to \code{\link{dcf_report}}.
#' @returns A tibble containing variables:
#' \tabular{ll}{
#'   \code{name} \tab Name of the variable, as it appears in the data file. \cr
#'   \code{type} \tab The value's storage type. \cr
#'   \code{n} \tab Number of non-missing observations within the file. \cr
#'   \code{duplicates} \tab Number of duplicated values within the file. \cr
#'   \code{missing} \tab Number of missing values within the file. \cr
#'   \code{project_type} \tab The project type, between \code{source} and \code{bundle}. \cr
#'   \code{data_format} \tab The orientation of the data, between \code{wide} and \code{tall}. \cr
#'   \code{file} \tab The file containing the variable; a path relative to the project root. \cr
#'   \code{short_name} \tab Short name, if included in measure info. \cr
#'   \code{long_name} \tab Long name, if included in measure info. \cr
#'   \code{short_decription} \tab Short description, if included in measure info. \cr
#'   \code{long_description} \tab Long description, if included in measure info. \cr
#'   \code{measure_type} \tab Higher-level description of type than storage type
#'     (e.g., \code{count} versus \code{integer}), if included in measure info. \cr
#'   \code{unit} \tab How a single value should be interpreted
#'     (e.g., \code{per 100k people} for a rate per 100k people), if included in measure info. \cr
#'   \code{time_resolution} \tab The measure's collection frequency, if included in measure info. \cr
#'   \code{category} \tab The measure's category, if included in measure info. \cr
#'   \code{subcategory} \tab The measure's subcategory, if included in measure info. \cr
#' }
#' @family data user interface functions
#' @examples
#' dcf_variables("dissc-yale/pophive_demo")
#' @export

dcf_variables <- function(
  project = ".",
  exclude = c("geography", "time", "age"),
  ...
) {
  report <- if (is.list(project)) project else dcf_report(project, ...)
  data_dir <- report$settings$data_dir
  dplyr::as_tibble(do.call(
    rbind,
    lapply(names(report$metadata), function(project_output) {
      datapackage <- report$metadata[[project_output]]
      measure_info <- datapackage$measure_info
      do.call(
        rbind,
        lapply(datapackage$resources, function(resource) {
          file <- paste(data_dir, project_output, resource$filename, sep = "/")
          project_type <- if (grepl("/dist/", file, fixed = TRUE)) "bundle" else
            "source"
          n_rows <- resource$row_count
          data_format <- if (is.null(resource$data_format)) "wide" else
            resource$data_format
          do.call(
            rbind,
            Filter(
              length,
              if (data_format == "tall") {
                lapply(resource$schema$fields, function(field) {
                  if ("levels" %in% names(field$info)) {
                    do.call(
                      rbind,
                      lapply(
                        field$info$levels,
                        function(level) {
                          n <- field$table[[level$id]]
                          level_row(
                            level,
                            if (is.null(n)) 0L else n,
                            file,
                            project_type
                          )
                        }
                      )
                    )
                  }
                })
              } else {
                lapply(resource$schema$fields, function(field) {
                  if (length(exclude) && field$name %in% exclude) return(NULL)
                  info <- field$info
                  if ("info" %in% names(info)) info <- info$info
                  if (is.null(info) && !is.null(measure_info)) {
                    info <- measure_info[[field$name]]
                  }
                  cbind(
                    data.frame(
                      name = field$name,
                      type = field$type,
                      n = n_rows - field$missing,
                      duplicates = field$duplicates,
                      missing = field$missing,
                      project_type = project_type,
                      data_format = "wide",
                      file = file
                    ),
                    unpack_info(info)
                  )
                })
              }
            )
          )
        })
      )
    })
  ))
}

unpack_info <- function(info) {
  unpacked <- data.frame(
    short_name = NA_character_,
    long_name = NA_character_,
    short_description = NA_character_,
    long_description = NA_character_,
    measure_type = NA_character_,
    unit = NA_character_,
    time_resolution = NA_character_,
    category = NA_character_,
    subcategory = NA_character_
  )
  info_names <- names(info)
  if ("name" %in% info_names && !("short_name" %in% info_names)) {
    info$short_name <- info$name
  }
  if ("description" %in% info_names && !("short_description" %in% info_names)) {
    info$short_description <- info$description
  }
  info_names <- names(info)
  for (name in colnames(unpacked)) {
    if (name %in% info_names) {
      unpacked[[name]] <- info[[name]]
    }
  }
  unpacked
}

level_row <- function(level, n, file, project_type) {
  cbind(
    data.frame(
      name = level$id,
      type = level$type,
      n = n,
      duplicates = NA,
      missing = NA,
      project_type = project_type,
      data_format = "tall",
      file = file
    ),
    unpack_info(level$info)
  )
}

#' 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.
#' @param use_git Logical; if \code{TRUE}, will initialize a git repository.
#' @param use_workflow Logical; if \code{TRUE}, will add a GitHub Actions workflow.
#' @returns Nothing; creates default files and directories.
#' @section Project Definition:
#'
#' The \strong{\code{process.json}} file defines the project with some initial attributes:
#' \itemize{
#'   \item \code{type} Always \code{source} to define this as a source project.
#'   \item \code{name} Name of the project.
#'   \item \code{scripts} List of script definitions.
#'   \item \code{checked} When the project was last checked with \code{\link{dcf_check}}.
#'   \item \code{check_results} Results of the last check.
#'   \item \code{standalone} Logical; \code{TRUE} if the source project does not exist
#'     within a broader collection project.
#'   \item \code{standard_state} State of the \code{standard} directory: A list
#'     with names as the file paths, relative to the overall project root, and values
#'     as the MD5 hash of those files.
#'   \item \code{raw_state} State of the \code{raw} directory, if
#'     set within a script.
#'   \item \code{vintages} A list with names as names of files found in the \code{standard}
#'     directory, and values as dates (of arbitrary format). This is a way to provide
#'     a date separate from the files dates (e.g., if you have some other source for when the
#'     data were actually collected), which will be included the named file's
#'     \code{datapackage.json}.
#' }
#'
#' Each \strong{\code{scripts}} entry points to a script to be run, with one default:
#' \itemize{
#'   \item \code{path} path to the script, relative to this project's root.
#'   \item \code{manual} Logical; if \code{TRUE}, will only run the script from
#'     \code{\link{dcf_process}} (not \code{\link{dcf_build}}).
#'   \item \code{frequency} How often to rerun the project, in days.
#'     This is checked against the last run timestamp when processed; it is a way
#'     to skip processing, but can only be as frequent as the overall process is run.
#'   \item \code{last_run} Timestamp of the last processing.
#'   \item \code{run_time} How long the script took to run last, in milliseconds.
#'   \item \code{last_status} Status of the last run; a list with entries for
#'     \code{success} (logical) and \code{log} (output of the script).
#' }
#'
#' See the \href{https://dissc-yale.github.io/dcf/articles/standards.html#scripts}{script standards}
#' for examples of using this within a sub-project script.
#'
#' @section Project Files :
#'
#' 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(),
  use_git = TRUE,
  use_workflow = FALSE
) {
  if (is.null(name)) {
    cli::cli_abort("provide a name")
  }
  name <- gsub("[^A-Za-z0-9]+", "_", name)
  is_standalone <- !file.exists(paste0(project_dir, "/settings.json"))
  data_dir <- dcf_read_settings(project_dir)$data_dir
  base_dir <- paste0(project_dir, "/", 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",
      ".gitignore",
      ".github/workflows/process.yaml"
    )
  )
  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(),
        standalone = is_standalone
      )
    )
  }
  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 use the `dcf` package to check the project:",
          "",
          "```R",
          "dcf_check()",
          "```",
          "",
          "And process it:",
          "",
          "```R",
          "dcf_process()",
          "```"
        ),
        collapse = "\n"
      ),
      paths[[6L]]
    )
  }
  if (is_standalone) {
    if (use_git) {
      dcf_init_git(base_path)
      if (!file.exists(paths[[7L]])) {
        writeLines(
          paste(
            c(
              "*.Rproj",
              ".Rproj.user",
              "*.Rprofile",
              "*.Rhistory",
              "*.Rdata",
              ".DS_Store",
              "renv"
            ),
            collapse = "\n"
          ),
          paths[[7L]]
        )
      }
    }
    if (use_workflow && !file.exists(paths[[8L]])) {
      dir.create(dirname(paths[[8L]]), recursive = TRUE, showWarnings = FALSE)
      file.copy(
        system.file("workflows/build.yaml", package = "dcf"),
        paths[[8L]]
      )
    }
  }
  if (open_after) rstudioapi::openProject(paths[[3L]], newSession = TRUE)
}

dcf_attempt_read_json <- function(path, ..., strict = TRUE) {
  contents <- tryCatch(jsonlite::read_json(path, ...), error = function(e) NULL)
  if (is.null(contents)) {
    (if (strict) cli::cli_abort else cli::cli_warn)(
      "failed to read {.file {path}}"
    )
  }
  contents
}
dcf_read_settings <- function(project_dir = ".", strict = FALSE) {
  settings_file <- paste0(project_dir, "/settings.json")
  if (!file.exists(settings_file)) {
    if (strict) {
      cli::cli_abort(
        "{.arg project_dir} ({project_dir}) does not appear to be a Data Collection Framework project"
      )
    } else {
      cli::cli_warn("settings file ({settings_file}) does not exist")
      return(list(
        name = basename(normalizePath(project_dir, "/", FALSE)),
        data_dir = ".",
        standalone = TRUE
      ))
    }
  }
  dcf_attempt_read_json(settings_file)
}
dcf_init_git <- function(dir) {
  if (!dir.exists(paste0(dir, ".git"))) {
    wd <- getwd()
    on.exit(setwd(wd))
    setwd(dir)
    system2("git", "init")
    setwd(wd)
  }
}

#' 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 licenses A list or list of lists with a license definition; see
#' \href{https://specs.frictionlessdata.io/data-package/#licenses}{Data Package Licenses}.
#' @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 = ".",
  licenses = list(),
  ...,
  write = TRUE,
  overwrite = FALSE,
  quiet = !interactive()
) {
  if (is.null(name)) {
    cli::cli_abort("{.arg name} must be provided")
  }
  package <- list(
    name = name,
    title = if (title == name) {
      gsub("\\b(\\w)", "\\U\\1", gsub("[._/-]", " ", name), perl = TRUE)
    } else {
      title
    },
    licenses = if (is.null(names(licenses))) licenses else list(licenses),
    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)
}

#' 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 A list or character vector, with names as paths to standard files
#' form source projects (relative to the project's data directory), and distribution file
#' names as entries. This associates input with output files, allowing for calculation of
#' a source state, and metadata inheritance from source files.
#' @param open_after Logical; if \code{FALSE}, will not open the project.
#' @param use_git Logical; if \code{TRUE}, will initialize a git repository.
#' @param use_workflow Logical; if \code{TRUE}, will add a GitHub Actions workflow.
#' @returns Nothing; creates default files and directories.
#' @section Project Definition:
#'
#' The \strong{\code{process.json}} file defines the project with some initial attributes:
#' \itemize{
#'   \item \code{type} Always \code{bundle} to define this as a bundle project.
#'   \item \code{name} Name of the project.
#'   \item \code{scripts} List of script definitions.
#'   \item \code{source_files} A character array of paths to other files
#'     used within the scripts, relative to the overall project's \code{data} directory.
#'   \item \code{standard_state} State of the \code{source_files}: A list
#'     with keys as the file paths, relative to the overall project root, and values
#'     as the MD5 hash of those files.
#'   \item \code{dist_state} State of the \code{dist} directory: A list
#'     with keys as the file paths, relative to the overall project root, and values
#'     as the MD5 hash of those files.
#'   \item \code{checked} Timestamp when the project was last checked with \code{\link{dcf_check}}.
#'   \item \code{check_results} Results of the last check.
#' }
#'
#' Each \strong{\code{scripts}} entry points to a script to be run, with one default:
#' \itemize{
#'   \item \code{path} path to the script, relative to this project's root.
#'   \item \code{last_run} Timestamp of the last processing.
#'   \item \code{run_time} How long the script took to run last, in milliseconds.
#'   \item \code{last_status} Status of the last run; a list with entries for
#'     \code{success} (logical) and \code{log} (output of the script).
#' }
#'
#' @section Project Files:
#'
#' 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(),
  use_git = TRUE,
  use_workflow = FALSE
) {
  if (missing(name)) {
    cli::cli_abort("specify a name")
  }
  name <- gsub("[^A-Za-z0-9]+", "_", name)
  is_standalone <- !file.exists(paste0(project_dir, "/settings.json"))
  data_dir <- dcf_read_settings(project_dir)$data_dir
  base_dir <- paste0(project_dir, "/", data_dir)
  base_path <- paste0(base_dir, "/", name, "/")
  if (!is.null(source_files)) {
    su <- !file.exists(paste0(
      data_dir,
      "/",
      if (is.null(names(source_files))) source_files else names(source_files)
    ))
    if (any(su)) {
      cli::cli_abort(
        "source file{? doesn't/s don't} exist: {settings$data_dir[su]}"
      )
    }
  }
  dir.create(paste0(base_path, "/dist"), showWarnings = FALSE, recursive = TRUE)
  paths <- paste0(
    base_path,
    "/",
    c(
      "README.md",
      "project.Rproj",
      "process.json",
      "measure_info.json",
      "build.R",
      "README.md",
      ".gitignore",
      ".github/workflows/process.yaml"
    )
  )
  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 = if (!is.null(names(source_files)))
          as.list(source_files) else 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 (!file.exists(paths[[6L]])) {
    writeLines(
      paste0(
        c(
          paste("#", name),
          "",
          "This is a dcf data bundle project, initialized with `dcf::dcf_add_bundle`.",
          "",
          "You can use the `dcf` package to check the project:",
          "",
          "```R",
          "dcf_check()",
          "```",
          "",
          "And process it:",
          "",
          "```R",
          "dcf_process()",
          "```"
        ),
        collapse = "\n"
      ),
      paths[[6L]]
    )
  }
  if (is_standalone) {
    if (use_git) {
      dcf_init_git(base_path)
      if (!file.exists(paths[[7L]])) {
        writeLines(
          paste(
            c(
              "*.Rproj",
              ".Rproj.user",
              "*.Rprofile",
              "*.Rhistory",
              "*.Rdata",
              ".DS_Store",
              "renv"
            ),
            collapse = "\n"
          ),
          paths[[7L]]
        )
      }
    }
    if (use_workflow && !file.exists(paths[[8L]])) {
      dir.create(dirname(paths[[8L]]), recursive = TRUE, showWarnings = FALSE)
      file.copy(
        system.file("workflows/build.yaml", package = "dcf"),
        paths[[8L]]
      )
    }
  }
  if (open_after) rstudioapi::openProject(paths[[2L]], newSession = TRUE)
}

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

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		#' 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_nas}: The file's \code{geography} column contains NAs.
14		#' \item \code{geography_dropped}: The file's \code{geography} column has levels
15		#' dropped from previous versions.
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		#' \item \code{dropped_measure: {column_name}}: The file's indicated column is not present
20		#' when it was previously.
21		#' \item \code{type_changed: {column_name}}: The file's indicated column's type changed
22		#' from the previous version.
23		#' \item \code{levels_changed: {column_name}}: The file's indicated column's levels have
24		#' all changed from the previous version.
25		#' }
26		#' @examples
27		#' \dontrun{
28		#'
29		#' # run from within a project or sub-project
30		#' dcf_check()
31		#'
32		#' # run from within a project on a single sub-project
33		#' dcf_check("gtrends")
34		#'
35		#' # run outside of a project on a single sub-project
36		#' dcf_check("gtrends", "../path/to/project")
37		#' }
38		#' @export
39
40		dcf_check <- function(
41		names = NULL,
42		project_dir = ".",
43		verbose = TRUE
44		) {
45	5x	if (missing(project_dir) && length(names) == 1L && dir.exists(project_dir)) {
46	!	project_dir <- names
47	!	names <- NULL
48		}
49		if (
50	5x	is.null(names) && !file.exists(paste0(project_dir, "/", "settings.json"))
51		) {
52	1x	project_dir <- normalizePath(project_dir, "/", FALSE)
53	1x	if (file.exists(paste0(project_dir, "/", "process.json"))) {
54	1x	names <- basename(project_dir)
55	1x	project_dir <- dirname(project_dir)
56		} else {
57	!	names <- basename(project_dir)
58	!	project_dir <- dirname(dirname(project_dir))
59		}
60		}
61
62	5x	settings <- dcf_read_settings(project_dir)
63	5x	base_dir <- paste0(project_dir, "/", settings$data_dir)
64	5x	if (is.null(names)) {
65	3x	names <- list.dirs(base_dir, recursive = FALSE, full.names = FALSE)
66	3x	names <- names[file.exists(paste0(base_dir, "/", names, "/process.json"))]
67		}
68	5x	issues <- list()
69	5x	package_change_reports <- list()
70	5x	for (name in names) {
71	7x	source_dir <- paste0(base_dir, "/", name, "/")
72	7x	if (!dir.exists(source_dir)) {
73	!	cli::cli_abort("specify the name of an existing data project")
74		}
75	7x	process_file <- paste0(source_dir, "process.json")
76	7x	if (!file.exists(process_file)) {
77	!	cli::cli_abort("{name} does not appear to be a data project")
78		}
79	7x	process <- dcf_process_record(process_file)
80	!	if (is.null(process)) next
81	7x	if (is.null(process$scripts)) {
82	!	cli::cli_warn("process file {process_file} has no defined scripts")
83		} else {
84	7x	for (script in process$scripts) {
85	7x	script_file <- paste0(source_dir, script$path)
86	7x	if (!file.exists(script_file)) {
87	!	cli::cli_warn("defined script {script_file} does not exist")
88		}
89		}
90		}
91	7x	is_bundle <- !is.null(process$type) && process$type == "bundle"
92	7x	info_file <- paste0(source_dir, "measure_info.json")
93	7x	info <- tryCatch(
94	7x	dcf_measure_info(
95	7x	info_file,
96	7x	render = TRUE,
97	7x	write = FALSE,
98	7x	verbose = FALSE,
99	7x	open_after = FALSE
100		),
101	7x	error = function(e) NULL
102		)
103	7x	measure_ids <- unique(c(
104	7x	names(info),
105	7x	unlist(lapply(info, "[[", "source_id"))
106		))
107	7x	if (is.null(info)) {
108	!	cli::cli_abort("{.file {info_file}} is malformed")
109		}
110	7x	if (verbose) {
111	7x	cli::cli_bullets(c("", "Checking project {.strong {name}}"))
112		}
113	7x	data_out_dir <- paste0(source_dir, if (is_bundle) "dist" else "standard")
114	7x	package_file <- paste0(data_out_dir, "/datapackage.json")
115	7x	if (!file.exists(package_file)) {
116	!	cli::cli_warn(
117	!	"project {name} has not been processed (missing {package_file})"
118		)
119	7x	} else if (!(package_file %in% names(package_change_reports))) {
120	7x	package_change_reports[[package_file]] <- dcf_attempt_read_json(
121	7x	package_file,
122	7x	strict = FALSE
123	7x	)$change_report
124		}
125	7x	change_reports <- package_change_reports[[package_file]]
126	7x	data_files <- list.files(
127	7x	data_out_dir,
128	7x	"\\.(?:csv\|parquet\|json)",
129	7x	full.names = TRUE
130		)
131	7x	data_files <- data_files[!grepl("datapackage", data_files, fixed = TRUE)]
132	7x	source_issues <- list()
133	7x	for (file in list.files(
134	7x	paste0(source_dir, "raw"),
135	7x	"csv$",
136	7x	full.names = TRUE
137		)) {
138	1x	source_issues[[sub(
139	1x	paste0(project_dir, "/"),
140		"",
141	1x	file,
142	1x	fixed = TRUE
143	1x	)]] <- list(
144	1x	data = "not_compressed"
145		)
146		}
147	7x	if (length(data_files)) {
148	7x	for (file in data_files) {
149	8x	change_report <- change_reports[[basename(file)]]$variables
150	8x	file_relative_path <- sub(
151	8x	paste0(project_dir, "/"),
152		"",
153	8x	file,
154	8x	fixed = TRUE
155		)
156	8x	file_id <- sub("^[^/]+/", "", file_relative_path)
157	8x	issue_messages <- NULL
158	8x	if (verbose) {
159	8x	cli::cli_progress_step("checking file {.file {file}}", spinner = TRUE)
160		}
161	8x	data_issues <- NULL
162	8x	measure_issues <- NULL
163	8x	data <- attempt_read(file, c("geography", "time"))
164	8x	if (is.null(data)) {
165	!	data_issues <- c(data_issues, "cant_read")
166		} else {
167	8x	if (grepl("csv$", file)) {
168	2x	data_issues <- c(data_issues, "not_compressed")
169	2x	if (verbose) {
170	2x	issue_messages <- c(
171	2x	issue_messages,
172	2x	"file is not compressed"
173		)
174		}
175		}
176	8x	if ("geography" %in% colnames(data)) {
177	7x	dropped_levels <- length(change_report$geography$dropped_levels)
178	7x	if (dropped_levels) {
179	!	data_issues <- c(data_issues, "geography_dropped")
180	!	if (verbose) {
181	!	issue_messages <- c(
182	!	issue_messages,
183	!	"{.emph geography} {dropped_levels} levels were dropped from previous version"
184		)
185		}
186		}
187	7x	if (anyNA(data$geography)) {
188	!	data_issues <- c(data_issues, "geography_nas")
189	!	if (verbose) {
190	!	issue_messages <- c(
191	!	issue_messages,
192	!	"{.emph geography} column contains NAs"
193		)
194		}
195		}
196		}
197	8x	if (("time" %in% colnames(data)) && anyNA(data$time)) {
198	!	data_issues <- c(data_issues, "time_nas")
199	!	if (verbose) {
200	!	issue_messages <- c(
201	!	issue_messages,
202	!	"{.emph time} column contains NAs"
203		)
204		}
205		}
206	8x	for (col in colnames(data)) {
207	34x	col_id <- paste0(file_id, "\|", col)
208	34x	change <- change_report[[col]]
209	34x	if (identical(change$status, "removed")) {
210	!	measure_issues <- c(
211	!	measure_issues,
212	!	paste("dropped_measure:", col)
213		)
214	!	if (verbose) {
215	!	issue_messages <- c(
216	!	issue_messages,
217	!	paste0(
218	!	"{.emph ",
219	!	col,
220	!	"} column was dropped since the last version"
221		)
222		)
223		}
224	34x	} else if (isFALSE(change$same_type)) {
225	1x	measure_issues <- c(measure_issues, paste("type_changed:", col))
226	1x	if (verbose) {
227	1x	issue_messages <- c(
228	1x	issue_messages,
229	1x	paste0(
230	1x	"{.emph ",
231	1x	col,
232	1x	"} column has a different type from the previous version"
233		)
234		)
235		}
236	33x	} else if (length(change$dropped_levels)) {
237	2x	n_added <- length(change$added_levels)
238	2x	if (n_added && (n_added == length(unique(data[[col]])))) {
239	2x	measure_issues <- c(
240	2x	measure_issues,
241	2x	paste("levels_changed:", col)
242		)
243	2x	if (verbose) {
244	2x	issue_messages <- c(
245	2x	issue_messages,
246	2x	paste0(
247	2x	"{.emph ",
248	2x	col,
249	2x	"} column has all different levels than previous version"
250		)
251		)
252		}
253		}
254		}
255		if (
256	34x	!(col %in% c("geography", "time")) &&
257	34x	(!(col %in% measure_ids) && !(col_id %in% measure_ids))
258		) {
259	4x	measure_issues <- c(measure_issues, paste("missing_info:", col))
260	4x	if (verbose) {
261	4x	issue_messages <- c(
262	4x	issue_messages,
263	4x	paste0(
264	4x	"{.emph ",
265	4x	col,
266	4x	"} column does not have an entry in measure_info"
267		)
268		)
269		}
270		}
271		}
272		}
273	8x	file_issues <- list()
274	8x	if (length(data_issues)) {
275	2x	file_issues$data <- data_issues
276		}
277	8x	if (length(measure_issues)) {
278	4x	file_issues$measures <- measure_issues
279		}
280	8x	source_issues[[file_relative_path]] <- file_issues
281	8x	if (verbose) {
282	8x	if (length(issue_messages)) {
283	4x	cli::cli_progress_done(result = "failed")
284	4x	cli::cli_bullets(structure(
285	4x	issue_messages,
286	4x	names = rep(" ", length(issue_messages))
287		))
288		} else {
289	4x	cli::cli_progress_done()
290		}
291		}
292		}
293		} else {
294	!	if (verbose) cli::cli_alert_info("no standard data files found to check")
295		}
296	7x	if (!identical(process$check_results, source_issues)) {
297	7x	process$checked <- Sys.time()
298	7x	process$check_results <- source_issues
299	7x	dcf_process_record(process_file, process)
300		}
301	7x	issues[[name]] <- source_issues
302		}
303
304	5x	invisible(issues)
305		}

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

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

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	!	base_dir <- normalizePath(base_dir, "/", FALSE)
48	!	name <- basename(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()'),
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 (use_git) {
121	1x	dcf_init_git(base_path)
122	1x	if (!file.exists(paths[[6L]])) {
123	1x	writeLines(
124	1x	paste(
125	1x	c(
126	1x	"*.Rproj",
127	1x	".Rproj.user",
128	1x	"*.Rprofile",
129	1x	"*.Rhistory",
130	1x	"*.Rdata",
131	1x	".DS_Store",
132	1x	"renv"
133		),
134	1x	collapse = "\n"
135		),
136	1x	paths[[6L]]
137		)
138		}
139		}
140	!	if (open_after) rstudioapi::openProject(paths[[1L]], newSession = TRUE)
141		}

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		#' 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 run_scripts Logical; if \code{FALSE}, will rebuild datapackages without running
11		#' scripts.
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		#' and each bundle's `dist` directory.
25		#' @examples
26		#' \dontrun{
27		#'
28		#' # run from a directory containing a `data` directory containing the source project
29		#' dcf_process("source_name")
30		#'
31		#' # run without executing the ingestion script
32		#' dcf_process("source_name", run_scripts = FALSE)
33		#' }
34		#' @export
35
36		dcf_process <- function(
37		name = NULL,
38		project_dir = ".",
39		run_scripts = TRUE,
40		is_auto = FALSE,
41		force = FALSE,
42		clear_state = FALSE
43		) {
44	6x	if (!is.null(name) && missing(project_dir) && dir.exists(name)) {
45	!	project_dir <- name
46	!	name <- NULL
47		}
48	6x	settings_file <- paste0(project_dir, "/settings.json")
49	6x	from_project <- file.exists(settings_file)
50	6x	if (from_project) {
51	5x	source_dir <- paste0(
52	5x	project_dir,
53		"/",
54	5x	dcf_attempt_read_json(settings_file)$data_dir
55		)
56	1x	} else if (file.exists(paste0(project_dir, "../../settings.json"))) {
57	!	project_dir <- normalizePath(project_dir, "/", FALSE)
58	!	source_dir <- dirname(project_dir)
59	!	project_dir <- dirname(dirname(project_dir))
60	1x	} else if (is.null(name)) {
61	1x	project_dir <- normalizePath(project_dir, "/", FALSE)
62	1x	source_dir <- dirname(project_dir)
63	1x	name <- basename(project_dir)
64	1x	project_dir <- source_dir
65		} else {
66	!	source_dir <- project_dir
67		}
68
69	6x	sources <- if (is.null(name)) {
70	3x	list.files(
71	3x	source_dir,
72	3x	"process\\.json",
73	3x	recursive = TRUE,
74	3x	full.names = TRUE
75		)
76		} else {
77	3x	process_files <- paste0(source_dir, "/", name, "/process.json")
78	3x	missing_process_files <- process_files[!file.exists(process_files)]
79	3x	if (length(missing_process_files)) {
80	!	cli::cli_abort(
81	!	"missing process file{?/s}: {.emph {missing_process_files}}"
82		)
83		}
84	3x	process_files
85		}
86	6x	decide_to_run <- function(process_script) {
87	6x	if (is_auto && process_script$manual) {
88	!	return(FALSE)
89		}
90	6x	if (
91	6x	force \|\| process_script$last_run == "" \|\| process_script$frequency == 0L
92		) {
93	6x	return(TRUE)
94		}
95	6x	if (
96	!	difftime(Sys.time(), as.POSIXct(process_script$last_run), units = "day") >
97	!	process_script$frequency
98		) {
99	!	return(TRUE)
100		}
101	!	FALSE
102		}
103	6x	collect_env <- new.env()
104	6x	collect_env$timings <- list()
105	6x	collect_env$logs <- list()
106	6x	process_source <- function(process_file) {
107	6x	process_def <- dcf_process_record(process_file)
108	6x	if (clear_state) {
109	3x	raw_states <- grep("raw_state", names(process_def), fixed = TRUE)
110	3x	if (length(raw_states)) {
111	!	process_def[raw_states] <- NULL
112		}
113	3x	process_def$standard_state <- NULL
114	3x	dcf_process_record(process_file, process_def)
115		}
116	6x	name <- process_def$name
117	6x	if (is.null(name)) {
118	!	name <- basename(dirname(process_file))
119		}
120	6x	dcf_add_source(
121	6x	name,
122	6x	project_dir,
123	6x	open_after = FALSE,
124	6x	use_git = FALSE,
125	6x	use_workflow = FALSE
126		)
127	6x	base_dir <- dirname(process_file)
128	6x	for (si in seq_along(process_def$scripts)) {
129	6x	st <- proc.time()[[3]]
130	6x	process_script <- process_def$scripts[[si]]
131	6x	run_current <- decide_to_run(process_script)
132	6x	script <- paste0(base_dir, "/", process_script$path)
133	6x	file_ref <- if (run_current) paste0(" ({.emph ", script, "})") else NULL
134	6x	cli::cli_progress_step(
135	6x	paste0("processing source {.strong ", name, "}", file_ref),
136	6x	spinner = TRUE
137		)
138	6x	env <- new.env()
139	6x	env$dcf_process_continue <- TRUE
140	6x	status <- if (run_scripts) {
141	6x	tryCatch(
142	6x	list(
143	6x	log = utils::capture.output(
144	6x	source(script, env, chdir = TRUE),
145	6x	type = "message"
146		),
147	6x	success = TRUE
148		),
149	6x	error = function(e) {
150	!	cli::cli_warn("scripts {.file {script}} failed: {e$message}")
151	!	list(log = e$message, success = FALSE)
152		}
153		)
154	6x	} else if (
155	6x	length(process_def$scripts) >= si &&
156	6x	!is.null(process_def$scripts[[si]]$last_status)
157		) {
158	!	process_def$scripts[[si]]$last_status
159		} else {
160	!	list(log = "", success = TRUE)
161		}
162	6x	collect_env$logs[[name]] <- status$log
163	6x	if (run_current) {
164	6x	process_script$last_run <- Sys.time()
165	6x	process_script$run_time <- proc.time()[[3]] - st
166	6x	process_script$last_status <- status
167	6x	process_def$scripts[[si]] <- process_script
168		}
169	6x	if (status$success) {
170	6x	collect_env$timings[[name]] <- process_script$run_time
171		}
172	!	if (!env$dcf_process_continue) break
173		}
174	6x	process_def_current <- dcf_process_record(process_file)
175	6x	if (
176	6x	is.null(process_def_current$raw_state) \|\|
177	6x	!identical(process_def$raw_state, process_def_current$raw_state)
178		) {
179	6x	if (is.null(process_def_current$name)) {
180	!	process_def_current$name <- basename(dirname(process_file))
181		}
182	6x	process_def_current$scripts <- process_def$scripts
183	6x	dcf_process_record(process_file, process_def_current)
184		}
185	6x	standard_dir <- paste0(base_dir, "/standard")
186	6x	data_files <- list.files(standard_dir, "\\.(?:csv\|parquet\|json)")
187	6x	data_files <- data_files[!grepl("datapackage", data_files, fixed = TRUE)]
188	6x	if (length(data_files)) {
189	6x	measure_info_file <- paste0(base_dir, "/measure_info.json")
190	6x	standard_state <- as.list(tools::md5sum(c(
191	6x	measure_info_file,
192	6x	paste0(standard_dir, "/", data_files)
193		)))
194	6x	if (!identical(process_def_current$standard_state, standard_state)) {
195	6x	measure_info <- dcf_measure_info(
196	6x	measure_info_file,
197	6x	include_empty = FALSE,
198	6x	render = TRUE,
199	6x	write = FALSE,
200	6x	open_after = FALSE,
201	6x	verbose = FALSE
202		)
203	6x	measure_sources <- list()
204	6x	for (measure_id in names(measure_info)) {
205	18x	measure_info[[measure_id]]$id <- measure_id
206	18x	info <- measure_info[[measure_id]]
207	18x	for (s in info$sources) {
208	6x	if (
209	6x	is.list(s) &&
210	6x	!is.null(s$location) &&
211	6x	!(s$location %in% names(sources))
212		) {
213	!	measure_sources[[s$location]] <- s
214		}
215		}
216		}
217	6x	datapackage_path <- paste0(standard_dir, "/datapackage.json")
218	6x	if (!file.exists(datapackage_path)) {
219	!	dcf_datapackage_init(name, dir = standard_dir, quiet = TRUE)
220		}
221	6x	base_meta <- list(
222	6x	source = unname(measure_sources),
223	6x	base_dir = base_dir,
224	6x	ids = "geography",
225	6x	time = "time",
226	6x	variables = measure_info
227		)
228	6x	dcf_datapackage_add(
229	6x	data_files,
230	6x	meta = if (length(process_def_current$vintages)) {
231	5x	vintages <- process_def_current$vintages
232	5x	lapply(structure(data_files, names = data_files), function(f) {
233	5x	base_meta$vintage <- vintages[[f]]
234	5x	base_meta
235		})
236		} else {
237	1x	base_meta
238		},
239	6x	dir = standard_dir,
240	6x	pretty = TRUE,
241	6x	summarize_ids = TRUE,
242	6x	verbose = FALSE
243		)
244	6x	process_def_current$standard_state <- standard_state
245	6x	dcf_process_record(process_file, process_def_current)
246		}
247	6x	cli::cli_progress_done(result = if (status$success) "done" else "failed")
248		} else {
249	!	cli::cli_progress_done(result = "failed")
250	!	cli::cli_bullets(
251	!	c(" " = "no standard data files found in {.path {standard_dir}}")
252		)
253		}
254		}
255	6x	process_bundle <- function(process_file) {
256	2x	process_def <- dcf_process_record(process_file)
257	2x	source_files <- if (length(process_def$source_files)) {
258	2x	if (!is.null(names(process_def$source_files))) {
259	2x	names(process_def$source_files)
260		} else {
261	!	process_def$source_files
262		}
263		} else {
264	!	NULL
265		}
266	2x	if (clear_state) {
267	2x	process_def$source_state <- NULL
268	2x	process_def$dist_state <- NULL
269	2x	dcf_process_record(process_file, process_def)
270		}
271	2x	name <- process_def$name
272	2x	if (is.null(name)) {
273	!	name <- basename(dirname(process_file))
274		}
275	2x	dcf_add_bundle(
276	2x	name,
277	2x	project_dir,
278	2x	open_after = FALSE,
279	2x	use_git = FALSE,
280	2x	use_workflow = FALSE
281		)
282	2x	base_dir <- dirname(process_file)
283	2x	for (si in seq_along(process_def$scripts)) {
284	2x	st <- proc.time()[[3]]
285	2x	process_script <- process_def$scripts[[si]]
286	2x	script <- paste0(base_dir, "/", process_script$path)
287	2x	run_current <- TRUE
288	2x	standard_state <- NULL
289	2x	if (length(source_files)) {
290	2x	standard_files <- paste0(source_dir, "/", source_files)
291	2x	standard_state <- as.list(tools::md5sum(paste0(
292	2x	source_dir,
293		"/",
294	2x	source_files
295		)))
296	2x	run_current <- !identical(standard_state, process_def$source_state)
297		}
298	2x	if (run_current) {
299	2x	cli::cli_progress_step(
300	2x	paste0(
301	2x	"processing bundle {.strong ",
302	2x	name,
303	2x	"} ({.emph ",
304	2x	script,
305		"})"
306		),
307	2x	spinner = TRUE
308		)
309	2x	env <- new.env()
310	2x	env$dcf_process_continue <- TRUE
311	2x	status <- if (run_scripts) {
312	2x	tryCatch(
313	2x	list(
314	2x	log = utils::capture.output(
315	2x	source(script, env, chdir = TRUE),
316	2x	type = "message"
317		),
318	2x	success = TRUE
319		),
320	2x	error = function(e) {
321	!	cli::cli_warn("scripts {.file {script}} failed: {e$message}")
322	!	list(log = e$message, success = FALSE)
323		}
324		)
325	2x	} else if (
326	2x	length(process_def$scripts) >= si &&
327	2x	!is.null(process_def$scripts[[si]]$last_status)
328		) {
329	!	process_def$scripts[[si]]$last_status
330		} else {
331	!	list(log = "", success = TRUE)
332		}
333	2x	collect_env$logs[[name]] <- status$log
334	2x	if (run_current) {
335	2x	process_script$last_run <- Sys.time()
336	2x	process_script$run_time <- proc.time()[[3]] - st
337	2x	process_script$last_status <- status
338	2x	process_def$scripts[[si]] <- process_script
339		}
340	2x	if (status$success) {
341	2x	collect_env$timings[[name]] <- process_script$run_time
342		}
343	!	if (!env$dcf_process_continue) break
344		}
345		}
346	2x	process_def_current <- dcf_process_record(process_file)
347	2x	source_packages <- as.list(unlist(Filter(
348	2x	length,
349	2x	lapply(
350	2x	unique(paste0(
351	2x	vapply(paste0(source_dir, "/", source_files), dirname, ""),
352	2x	"/datapackage.json"
353		)),
354	2x	function(package_file) {
355	2x	if (file.exists(package_file)) {
356	2x	tools::md5sum(package_file)
357		}
358		}
359		)
360		)))
361	2x	dist_dir <- paste0(base_dir, "/dist")
362	2x	dist_files <- grep(
363	2x	"datapackage",
364	2x	list.files(dist_dir, recursive = TRUE),
365	2x	fixed = TRUE,
366	2x	invert = TRUE,
367	2x	value = TRUE
368		)
369	2x	if (length(dist_files)) {
370	2x	dist_state <- c(
371	2x	as.list(tools::md5sum(paste0(
372	2x	base_dir,
373	2x	"/dist/",
374	2x	dist_files
375		))),
376	2x	source_packages
377		)
378	2x	if (!identical(process_def_current$dist_state, dist_state)) {
379	2x	process_def_current$scripts <- process_def$scripts
380	2x	process_def_current$dist_state <- dist_state
381	2x	process_def_current$standard_state <- standard_state
382	2x	if (is.null(process_def_current$name)) {
383	!	process_def_current$name <- basename(dirname(process_file))
384		}
385	2x	dcf_process_record(process_file, process_def_current)
386
387		# merge with standard measure infos
388	2x	measure_info <- dcf_measure_info(
389	2x	paste0(base_dir, "/measure_info.json"),
390	2x	include_empty = FALSE,
391	2x	render = TRUE,
392	2x	write = FALSE,
393	2x	open_after = FALSE,
394	2x	verbose = FALSE
395		)
396	2x	if (length(source_packages)) {
397	2x	source_resources <- lapply(
398	2x	names(source_packages),
399	2x	function(f) {
400	2x	dp <- dcf_attempt_read_json(f)
401	2x	list(
402	2x	name = dp$name,
403	2x	data_dir = dirname(f),
404	2x	resources = dp$resources,
405	2x	measure_info = dp$measure_info
406		)
407		}
408		)
409	2x	fill_source_info <- function(id, info) {
410	11x	info$id <- id
411	11x	if (!is.null(info$levels)) {
412	2x	for (level_id in names(info$levels)) {
413	4x	info$levels[[level_id]] <- fill_source_info(
414	4x	level_id,
415	4x	info$levels[[level_id]]
416		)
417		}
418	2x	return(info)
419		}
420	9x	source_id <- if (!is.null(info$source_id)) {
421	3x	info$source_id
422		} else {
423	6x	id
424		}
425	9x	source_info <- NULL
426	9x	for (package in source_resources) {
427	9x	has_package_info <- !is.null(package$measure_info)
428	9x	for (resource in package$resources) {
429	9x	has_resource_info <- !is.null(package$measure_info)
430	9x	for (field in resource$schema$fields) {
431	45x	if (identical(source_id, field$name)) {
432	7x	source_info <- field
433	7x	source_info$info <- if (
434	7x	has_resource_info &&
435	7x	(source_id %in% names(resource$measure_info))
436		) {
437	!	resource$measure_info[[source_id]]
438	7x	} else if (
439	7x	has_package_info &&
440	7x	(source_id %in% names(package$measure_info))
441		) {
442	!	package$measure_info[[source_id]]
443		} else {
444	7x	list()
445		}
446	7x	source_info$info$source_file <- list(
447	7x	project = package$name,
448	7x	data_dir = sub(
449	7x	project_dir,
450		"",
451	7x	package$data_dir,
452	7x	fixed = TRUE
453		),
454	7x	file = resource$filename
455		)
456		}
457		}
458		}
459		}
460	9x	if (!is.null(source_info)) {
461	7x	for (entry_name in names(source_info)) {
462	2x	if (
463	67x	is.null(info[[entry_name]]) \|\|
464	67x	(is.character(info[[entry_name]]) &&
465	67x	info[[entry_name]] == "")
466		) {
467	67x	info[[entry_name]] <- source_info[[entry_name]]
468	!	} else if (is.list(info[[entry_name]])) {
469	!	info[[entry_name]] <- unique(c(
470	!	info[[entry_name]],
471	!	source_info[[entry_name]]
472		))
473		}
474		}
475		}
476	9x	info
477		}
478	2x	for (measure_id in names(measure_info)) {
479	7x	measure_info[[measure_id]] <- fill_source_info(
480	7x	measure_id,
481	7x	measure_info[[measure_id]]
482		)
483		}
484		}
485	2x	measure_sources <- list()
486	2x	for (info in measure_info) {
487	7x	for (s in info$sources) {
488	6x	if (
489	!	is.list(s) &&
490	!	!is.null(s$location) &&
491	!	!(s$location %in% names(sources))
492		) {
493	!	measure_sources[[s$location]] <- s
494		}
495		}
496		}
497	2x	if (!file.exists(paste0(dist_dir, "/datapackage.json"))) {
498	2x	dcf_datapackage_init(name, dir = dist_dir, quiet = TRUE)
499		}
500	2x	metas <- list(
501	2x	source = unname(measure_sources),
502	2x	base_dir = base_dir,
503	2x	ids = "geography",
504	2x	time = "time",
505	2x	variables = measure_info
506		)
507	2x	if (!is.null(names(process_def_current$source_files))) {
508	2x	bundle_source_files <- names(process_def_current$source_files)
509	2x	package_files <- paste0(
510	2x	dirname(base_dir),
511		"/",
512	2x	dirname(bundle_source_files),
513	2x	"/datapackage.json"
514		)
515	2x	vintages <- process_def_current$vintages
516	2x	for (i in seq_along(bundle_source_files)) {
517	2x	package_file <- package_files[[i]]
518	2x	source_dist_files <- process_def_current$source_files[[bundle_source_files[[
519	2x	i
520		]]]]
521	2x	if (file.exists(package_file)) {
522	2x	package <- dcf_attempt_read_json(package_file)
523	2x	for (resource in package$resources) {
524	2x	if (length(resource$vintage)) {
525	2x	for (dist_file in source_dist_files) {
526	4x	vintages[[dist_file]] <- max(
527	4x	vintages[[dist_file]],
528	4x	resource$vintage
529		)
530		}
531		}
532		}
533		}
534		}
535	2x	if (length(names(vintages)) && any(names(vintages) %in% dist_files)) {
536	2x	metas <- lapply(
537	2x	structure(dist_files, names = dist_files),
538	2x	function(dist_file) {
539	3x	metas$vintage <- vintages[[dist_file]]
540	3x	metas
541		}
542		)
543		}
544	!	} else if (length(process_def_current$vintages)) {
545	!	vintages <- process_def_current$vintages
546	!	metas <- lapply(
547	!	structure(dist_files, names = dist_files),
548	!	function(f) {
549	!	metas$vintage <- vintages[[f]]
550	!	metas
551		}
552		)
553		}
554	2x	dcf_datapackage_add(
555	2x	dist_files,
556	2x	meta = metas,
557	2x	dir = dist_dir,
558	2x	pretty = TRUE,
559	2x	summarize_ids = TRUE,
560	2x	verbose = FALSE
561		)
562		}
563	2x	cli::cli_progress_done(result = if (status$success) "done" else "failed")
564		} else {
565	!	cli::cli_progress_done(result = "failed")
566	!	cli::cli_bullets(
567	!	c(" " = "no standard data files found in {.path {process_file}}")
568		)
569		}
570		}
571	6x	for (process_file in sources[order(
572	6x	vapply(
573	6x	sources,
574	6x	function(f) {
575	8x	type <- dcf_attempt_read_json(f, strict = FALSE)$type
576	8x	is.null(type) \|\| type != "bundle"
577		},
578	6x	TRUE
579		),
580	6x	decreasing = TRUE
581		)]) {
582	8x	process_def <- dcf_process_record(process_file)
583	8x	if (is.null(process_def)) {
584	!	next
585		}
586	8x	if (is.null(process_def$type) \|\| process_def$type == "source") {
587	6x	process_source(process_file)
588		} else {
589	2x	process_bundle(process_file)
590		}
591		}
592	6x	invisible(list(timings = collect_env$timings, logs = collect_env$logs))
593		}

1		#' Download Medicare Disparities Data
2		#'
3		#' Download data from the Centers for Medicare & Medicaid Services (CMS)
4		#' \href{https://data.cms.gov/tools/mapping-medicare-disparities-by-population}{Mapping Medicare Disparities by Population} (MMD) tool.
5		#'
6		#' @param measure Name or letter code of the measure to download.
7		#' @param population The population code; either \code{f} (Medicare Fee For Service) or
8		#' \code{m} (Medicare Advantage).
9		#' @param year Year(s) to download (e.g., \code{2015:2020}). If not specified, all available
10		#' years will be included.
11		#' @param geography Geography code(s) to include, between \code{n} (national), \code{s} (state),
12		#' and \code{c} (county). If not specified, all available geographies will be included.
13		#' @param adjust,condition,sex,age,race,dual_elig,medicare_elig One or more codes indicating
14		#' the variable levels to include (see \code{\link{dcf_standardize_cmsmmd}}).
15		#' If \code{"."}, values will be across all levels, whereas if \code{NULL}, all available levels
16		#' will be included (aggregated and disaggregated). See the Making Requests section.
17		#' @param refresh_codebook Logical; if \code{TRUE}, will re-download the codebook even if it
18		#' exists in the temporary location (which is cleared each R session).
19		#' @param codebook_only Logical; if \code{TRUE}, will return the codebook without downloading data.
20		#' @param row_limit Maximum number of rows to return in each request. The API limit appears to be 100,000.
21		#' @param out_file Path to the CSV or Parquet file to write data to.
22		#' @param state The codebook state (MD5 hash) recorded during a previous download;
23		#' if provided, will only download if the new state does not match.
24		#' @param parquet Logical; if \code{TRUE}, will convert the downloaded CSV file to Parquet.
25		#' @param verbose Logical; if \code{FALSE}, will not display status messages.
26		#' @section Making Requests:
27		#' The API operates over several large files, partitioned by measure, year,
28		#' adjust, and dual and medicaid eligibility. These are identified with the codebook
29		#' (\code{dcf_download_cmsmmd(codebook_only = TRUE)}).
30		#'
31		#' The files are larger than the API's limit, so requests for each file have to be broken up
32		#' by the other variables within them (sex, age, race, and condition).
33		#'
34		#' For best performance, make requests as big as possible while staying under 100,000 rows
35		#' each (e.g., by setting \code{sex}, \code{age}, or \code{race} to \code{NULL}).
36		#' @returns \code{dcf_download_cmsmmd}: A list:
37		#' \itemize{
38		#' \item \strong{\code{codebook}}: The codebook.
39		#' \item \strong{\code{codebook_state}}: MD5 hash of the codebook.
40		#' \item \strong{\code{data}}: The downloaded data.
41		#' }
42		#' @examples
43		#' # find the codes associated with menu values
44		#' variable_codes <- dcf_standardize_cmsmmd()
45		#' variable_codes[c(
46		#' "sex", "age", "race",
47		#' "adjust", "dual_elig", "medicare_elig"
48		#' )]
49		#'
50		#' # look at the codebook which defines source files
51		#' codebook <- dcf_download_cmsmmd(codebook_only = TRUE)
52		#' codebook
53		#'
54		#' \dontrun{
55		#' # download data
56		#' downloaded <- dcf_download_cmsmmd(
57		#' "preventive care",
58		#' population = "f",
59		#' race = ".",
60		#' sex = ".",
61		#' age = NULL,
62		#' condition = c(83, 85, 86, 88, 89, 95, 101, 102, 104, 105:107),
63		#' adjust = 1
64		#' )
65		#'
66		#' # convert codes to levels
67		#' data_standard <- dcf_standardize_cmsmmd(downloaded$data)
68		#' }
69		#' @export
70
71		dcf_download_cmsmmd <- function(
72		measure,
73		population = NULL,
74		year = NULL,
75		geography = NULL,
76		adjust = NULL,
77		condition = NULL,
78		sex = c(1:2, "."),
79		age = c(0:4, "."),
80		race = c(1:6, "."),
81		dual_elig = ".",
82		medicare_elig = ".",
83		refresh_codebook = FALSE,
84		codebook_only = FALSE,
85		row_limit = 9999999,
86		out_file = NULL,
87		state = NULL,
88		parquet = FALSE,
89		verbose = TRUE
90		) {
91		# load codebook
92	3x	codebook_file <- paste0(tempdir(), "/codebook_crosswalk.csv")
93	3x	if (refresh_codebook \|\| !file.exists(codebook_file)) {
94	1x	if (verbose) cli::cli_progress_step("retrieving codebook")
95	1x	codebook_req <- curl::curl_fetch_disk(
96	1x	"https://data.cms.gov/mmd-population/assets/codebook_crosswalk.csv",
97	1x	codebook_file
98		)
99	1x	if (codebook_req$status_code != 200) {
100	!	unlink(codebook_file)
101	!	cli::cli_abort("failed to retrieve codebook: {codebook_req$status_code}")
102		}
103	1x	if (verbose) cli::cli_progress_done()
104		}
105	3x	new_state <- tools::md5sum(codebook_file)
106	3x	if (!is.null(state)) {
107	1x	if (state == new_state) {
108	1x	if (verbose) {
109	1x	cli::cli_alert_info("codebook has not changed since last download")
110		}
111	1x	return(invisible(NULL))
112		}
113		}
114	2x	codebook <- vroom::vroom(
115	2x	codebook_file,
116	2x	col_types = list(
117	2x	elig = "c",
118	2x	race_code = "c",
119	2x	sex_code = "c",
120	2x	adjust = "c",
121	2x	dual = "c"
122		),
123	2x	na = " "
124		)
125	2x	codebook$description <- tolower(codebook$description)
126
127	1x	if (codebook_only) return(codebook)
128
129		# identify source(s)
130	1x	if (missing(measure)) {
131	!	cli::cli_abort("specify a measure: {.value {unique(codebook$description)}}")
132		}
133
134	1x	measure_descriptions <- unique(codebook$description)
135	1x	if (nchar(measure) == 1L) {
136	!	codebook <- codebook[codebook$measure == tolower(measure), ]
137		} else {
138	1x	codebook <- codebook[grepl(measure, codebook$description), ]
139		}
140	1x	if (!nrow(codebook)) {
141	!	cli::cli_abort(
142	!	paste(
143	!	'measure "{measure}" does not match the available measures:',
144	!	"{.value {measure_descriptions}}"
145		)
146		)
147		}
148
149	1x	if (is.null(population)) population <- codebook$population[[1L]]
150	1x	codebook <- codebook[
151	1x	filter_codebook(codebook$population, population, "population"),
152		]
153
154	1x	if (!is.null(year)) {
155	1x	if (is.numeric(year)) year <- as.character(year)
156	1x	if (any(nchar(year) > 2L)) {
157	1x	year <- substring(
158	1x	year,
159	1x	nchar(year) -
160	1x	as.integer(as.character(cut(
161	1x	as.numeric(year),
162	1x	c(
163	1x	-Inf,
164	1x	if (population == "m") 2014L else 2019L,
165	1x	Inf
166		),
167	1x	c(0L, 1L)
168		)))
169		)
170		}
171	1x	codebook <- codebook[
172	1x	filter_codebook(codebook$year, year, "year"),
173		]
174		}
175	1x	if (missing(dual_elig)) dual_elig <- codebook$dual[[1L]]
176	1x	if (!is.null(dual_elig)) {
177	1x	codebook <- codebook[
178	1x	filter_codebook(codebook$dual, dual_elig, "dual_elig"),
179		]
180		}
181	1x	if (missing(medicare_elig)) medicare_elig <- codebook$elig[[1L]]
182	1x	if (!is.null(medicare_elig)) {
183	1x	codebook <- codebook[
184	1x	filter_codebook(codebook$elig, medicare_elig, "medicare_elig"),
185		]
186		}
187
188		# make requests
189	1x	param_sets <- expand.grid(
190	1x	Filter(
191	1x	length,
192	1x	list(
193	1x	fltr = adjust,
194	1x	agecat = age,
195	1x	sexcat = sex,
196	1x	racecat = race,
197	1x	condition = condition,
198	1x	"_source" = unique(codebook$url)
199		)
200		),
201	1x	stringsAsFactors = FALSE
202		)
203	1x	param_sets[param_sets == "." \| param_sets == "all"] <- ".\|IS NULL"
204	1x	data_url <- paste0(
205	1x	"https://data.cms.gov/data-api/v1/mmd-tool/?_size=",
206	1x	row_limit,
207		"&"
208		)
209	1x	n_requests <- nrow(param_sets)
210	1x	all_data <- list()
211	1x	if (verbose) cli::cli_h1("making requests to {data_url}")
212	1x	for (i in seq_len(n_requests)) {
213	2x	params <- as.list(param_sets[i, ])
214	2x	param_string <- paste0(names(params), "=", params, collapse = "&")
215	2x	req <- curl::curl_fetch_memory(utils::URLencode(paste0(
216	2x	data_url,
217	2x	param_string
218		)))
219	2x	if (req$status_code != 200) {
220	!	cli::cli_abort(
221	!	"a request failed: ({req$status_code}) {rawToChar(req$content)}"
222		)
223		}
224	2x	all_data[[i]] <- jsonlite::fromJSON(rawToChar(req$content))
225	2x	if (verbose)
226	2x	cli::cli_progress_step(
227	2x	paste0(
228	2x	i,
229	2x	" of ",
230	2x	n_requests,
231		" (",
232	2x	nrow(all_data[[i]]),
233	2x	" rows): ",
234	2x	param_string
235		),
236	2x	spinner = TRUE
237		)
238		}
239	1x	if (verbose) cli::cli_progress_done()
240
241	1x	all_data <- do.call(rbind, all_data)
242	1x	if (!is.null(out_file)) {
243	1x	dir.create(dirname(out_file), showWarnings = FALSE, recursive = TRUE)
244	1x	if (parquet \|\| grepl(".parquet", out_file, fixed = TRUE)) {
245	1x	if (verbose) cli::cli_progress_step("writing to Parquet")
246	1x	arrow::write_parquet(
247	1x	all_data,
248	1x	compression = "gzip",
249	1x	sub(".csv", ".parquet", out_file, fixed = TRUE)
250		)
251		} else {
252	!	if (verbose) cli::cli_progress_step("writing to CSV")
253	!	vroom::vroom_write(all_data, out_file, ",")
254		}
255		}
256	1x	invisible(list(
257	1x	codebook_state = new_state,
258	1x	codebook = codebook,
259	1x	data = all_data
260		))
261		}
262
263		filter_codebook <- function(x, values, column) {
264	4x	su <- x %in% values
265	4x	if (!any(su)) {
266	!	cli::cli_abort(
267	!	paste(
268	!	'{.arg {column}} does not contain specified values.',
269	!	"Available values: {.value {unique(x)}}"
270		)
271		)
272		}
273	4x	su
274		}
275
276		#' @rdname dcf_download_cmsmmd
277		#' @param raw_data The raw data as downloaded with \code{dcf_download_cmsmmd} to be standardized.
278		#' @returns \code{dcf_standardize_cmsmmd}: If \code{raw_data} is \code{NULL}, a list
279		#' with an entry for each API parameter, containing named vectors with level codes as names
280		#' mapping to level values (as they appear in the tool's menus).
281		#' Otherwise, a version of \code{raw_data} with coded values converted to labels.
282		#' @export
283
284		dcf_standardize_cmsmmd <- function(raw_data = NULL) {
285		# extracted from https://data.cms.gov/mmd-population/js/menus.js
286	1x	menu <- jsonlite::read_json(
287	1x	system.file(
288	1x	"support_data/cms_mmd_levels.json.gz",
289	1x	package = "dcf"
290		)
291		)
292	1x	levels <- lapply(
293	1x	menu,
294	1x	function(e) {
295	18x	options <- Filter(
296	18x	length,
297	18x	lapply(e$options, function(o) {
298	269x	if (length(o$val)) {
299	255x	o$val <- as.character(o$val)
300	255x	o
301		}
302		})
303		)
304	18x	c(
305	18x	structure(
306	18x	vapply(options, "[[", "", "disp"),
307	18x	names = vapply(options, "[[", "", "val")
308		)
309		)
310		}
311		)
312	1x	names(levels) <- vapply(menu, "[[", "", "id")
313	1x	levels$geography["n"] <- "National"
314	1x	levels$fltr <- levels$adjust
315	1x	levels$sex <- levels$sexcat <- levels$sex_code
316	1x	levels$race <- levels$racecat <- levels$race_code
317	1x	levels$age <- levels$agecat <- levels$age_group
318	1x	levels$eligcat <- levels$medicare_elig <- levels$eligibility
319	1x	levels$dual_elig <- levels$dual
320	!	if (is.null(raw_data)) return(levels)
321	1x	for (col in colnames(raw_data)) {
322	12x	col_levels <- levels[[col]]
323	12x	if (!is.null(col_levels)) {
324	10x	values <- as.character(raw_data[[col]])
325	10x	values[values == ""] <- "."
326	10x	raw_data[[col]] <- c(col_levels, "." = "All")[values]
327		}
328		}
329	1x	raw_data
330		}

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

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

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_injury_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		#' Interact with a Process File
2		#'
3		#' Read or update the current process file.
4		#'
5		#' See the \href{https://dissc-yale.github.io/dcf/articles/standards.html#scripts}{script standards}
6		#' for examples of using this within a sub-project script.
7		#'
8		#' @param path Path to the process JSON file.
9		#' @param updated An update version of the process definition. If specified, will
10		#' write this as the new process file, rather than reading any existing file.
11		#' @returns The process definition of the source project.
12		#' @examples
13		#' epic_process_file <- "../../../pophive/pophive_demo/data/epic/process.json"
14		#' if (file.exists(epic_process_file)) {
15		#' dcf_process_record(epic_process_file)
16		#' }
17		#' @export
18
19		dcf_process_record <- function(path = "process.json", updated = NULL) {
20	61x	if (is.null(updated)) {
21	32x	if (!file.exists(path)) {
22	!	cli::cli_abort("process file {path} does not exist")
23		}
24	32x	spec <- dcf_attempt_read_json(path)
25	32x	if (is.null(spec$name)) {
26	!	spec$name <- basename(dirname(path))
27		}
28	32x	if (is.null(spec$type)) {
29	!	spec$type <- "source"
30		}
31	32x	spec
32		} else {
33	29x	if (is.null(updated$type)) {
34	!	updated$type <- "source"
35		}
36	29x	jsonlite::write_json(updated, path, auto_unbox = TRUE, pretty = TRUE)
37	29x	updated
38		}
39		}

1		#' Use Data from a Data Collection Project
2		#'
3		#' Load the standard or distribution data from a local or remote data collection project.
4		#'
5		#' @param variables A character vector of variable names to be loaded, or a selected
6		#' subset of a project data dictionary, as returned from \code{\link{dcf_variables}}.
7		#' @param project Path to a local project, or the GitHub account and repository name
8		#' (\code{"{account_name}/{repo_name}"}) of a remote project.
9		#' @param data_format The data format to select, between \code{tall} and \code{wide}.
10		#' Useful if there are duplicate measure names between files of different formats.
11		#' @param project_type Project type to select, between \code{bundle} and \code{source}.
12		#' @param ... Additional arguments passed to \code{\link{dcf_report}}.
13		#' @param unify Logical; if \code{FALSE}, will return \code{data} as a list with entries for each
14		#' file. Otherwise (by default), will attempt to combine the loaded data.
15		#' @param only_selected Logical; if \code{TRUE}, will drop columns that were not included in
16		#' \code{variables}, other than ID columns.
17		#' @param cache Path to a directory in which to store downloaded files. Within this directory,
18		#' the repository structure will be recreated within an account-named directory.
19		#' @param refresh Logical; if \code{TURE}, will download files even if they exist in the \code{cache}.
20		#' @param verbose Logical; if \code{FALSE}, will not show status messages.
21		#' @returns A list with entries for metadata (the datapackage resource entry for each file loaded)
22		#' and data (a tibble or list of tibbles of the unified or separately loaded files).
23		#' @family data user interface functions
24		#' @examples
25		#' # retrieve the full bundle file that includes the `epic_rsv` measure
26		#' bundle <- dcf_data(
27		#' "epic_rsv",
28		#' "dissc-yale/pophive_demo",
29		#' data_format = "tall",
30		#' verbose = FALSE
31		#' )
32		#' bundle$data
33		#'
34		#' if (require("ggplot2", quietly = TRUE)) {
35		#' # extract short names from metadata
36		#' labels <- vapply(
37		#' bundle$metadata[[1L]]$schema$fields[[3L]]$info$levels,
38		#' function(measure) measure$info$short_name,
39		#' ""
40		#' )
41		#'
42		#' # show trends from different measures over time
43		#' bundle$data \|>
44		#' dplyr::filter(
45		#' time >= as.Date("2024-01-01"),
46		#' measure != "epic_all_encounters"
47		#' ) \|>
48		#' dplyr::mutate(measure = labels[measure]) \|>
49		#' ggplot(aes(x = time, y = value_scaled, color = measure)) +
50		#' theme_dark() %+replace%
51		#' theme(panel.background = element_rect(fill = FALSE, color = FALSE)) +
52		#' geom_smooth(
53		#' method = "gam",
54		#' formula = y ~ s(x, bs = "cs", k = 50L)
55		#' )
56		#' }
57		#' @export
58
59		dcf_data <- function(
60		variables = NULL,
61		project = ".",
62		data_format = NULL,
63		project_type = "bundle",
64		...,
65		unify = TRUE,
66		only_selected = FALSE,
67		cache = tempdir(),
68		refresh = FALSE,
69		verbose = TRUE
70		) {
71	4x	report <- dcf_report(project, ..., refresh = refresh)
72	4x	if (is.null(variables) \|\| is.character(variables)) {
73	3x	all_variables <- dcf_variables(report)
74	3x	selected <- all_variables[
75	3x	all_variables$project_type == project_type &
76	3x	grepl(
77	3x	paste0("^(?:", paste(variables, collapse = "\|"), ")$"),
78	3x	all_variables$name
79		),
80		]
81		} else {
82	1x	if (!all(c("name", "file") %in% colnames(variables))) {
83	!	cli::cli_abort(
84	!	"`variables` must include `name` and `file` columns if not a character vector"
85		)
86		}
87	1x	all_variables <- selected <- variables
88	1x	variables <- selected$name
89		}
90	4x	if (!is.null(data_format)) {
91	2x	selected <- selected[selected$data_format == data_format, ]
92		}
93	4x	if (nrow(selected) == 0L) {
94	!	cli::cli_abort("no variables found")
95		}
96	4x	not_found <- if (is.null(variables)) character() else
97	4x	variables[!(variables %in% selected$name)]
98	4x	if (length(not_found)) {
99	!	cli::cli_abort("variable{?/s} not found: {not_found}")
100		}
101	4x	data_dir <- report$settings$data_dir
102	4x	files <- unique(selected$file)
103	4x	project_outputs <- gsub("^[^/]+/\|/[^/]+$", "", files)
104	4x	project_metadata <- report$metadata[
105	4x	names(report$metadata) %in% project_outputs
106		]
107	4x	file_metadata <- list()
108	4x	for (output in names(project_metadata)) {
109	6x	datapackage <- project_metadata[[output]]
110	6x	for (i in seq_along(datapackage$resources)) {
111	15x	resource_file <- paste(
112	15x	data_dir,
113	15x	output,
114	15x	datapackage$resources[[i]]$filename,
115	15x	sep = "/"
116		)
117	15x	if (resource_file %in% files) {
118	6x	file_metadata[[resource_file]] <- datapackage$resources[[i]]
119		}
120		}
121		}
122	4x	file_metadata <- file_metadata[files]
123
124		# download files to cache if needed
125	4x	if (identical(report$settings$report_url, "")) {
126	2x	if (verbose) cli::cli_alert_info("loading files from local project")
127	2x	project_root <- paste0(project, "/")
128		} else {
129	2x	project_root <- paste0(
130	2x	normalizePath(paste0(cache, "/", project), "/", FALSE),
131		"/"
132		)
133	2x	if (verbose)
134	2x	cli::cli_alert_info("downloading files to cache: {project_root}")
135	2x	base_url <- dirname(report$settings$report_url)
136	2x	for (file in files) {
137	4x	cached_file <- paste0(project_root, file)
138	4x	if (refresh \|\| !file.exists(cached_file)) {
139	2x	file_url <- paste0(base_url, "/", file)
140	2x	dir.create(dirname(cached_file), FALSE, TRUE)
141	2x	req <- curl::curl_fetch_disk(file_url, cached_file)
142	2x	if (req$status_code != 200L) {
143	!	unlink(cached_file)
144	!	cli::cli_warn("failed to download {.url {file_url}}")
145		}
146		}
147		}
148	2x	if (verbose) cli::cli_alert_info("loading files from cache project")
149		}
150
151		# load files
152	4x	n_files <- length(files)
153	4x	if (verbose)
154	4x	cli::cli_progress_bar("loading files", "download", total = n_files)
155	4x	data <- list()
156	4x	data_tall <- structure(logical(n_files), names = files)
157	4x	for (file in files) {
158	6x	data[[file]] <- attempt_read(paste0(project_root, file))
159	6x	data[[file]]$source_file <- file
160	6x	if (identical(file_metadata[[file]]$data_format, "tall")) {
161	1x	data_tall[[file]] <- TRUE
162		}
163	6x	if (verbose) cli::cli_progress_update()
164		}
165	4x	if (verbose) cli::cli_progress_done()
166
167	4x	if (unify) {
168	4x	if (length(data) > 1L) {
169	2x	all_cols <- unique(unlist(lapply(data, colnames)))
170	2x	if (!any(data_tall)) {
171	2x	id_cols <- c("geography", "time", "age")
172	2x	id_cols <- id_cols[id_cols %in% all_cols]
173	2x	if (only_selected)
174	!	all_cols <- all_cols[all_cols %in% c(id_cols, selected$name)]
175	2x	data <- dplyr::as_tibble(Reduce(
176	2x	function(x, y) merge(x, y, id_cols, all = TRUE),
177	2x	lapply(
178	2x	data,
179	2x	function(d) {
180	2x	for (col in id_cols[!(id_cols %in% colnames(d))]) d[[col]] <- NA
181	!	if (only_selected) d <- d[, all_cols[all_cols %in% colnames(d)]]
182	4x	d[, colnames(d) != "source_file"]
183		}
184		)
185		))
186	!	} else if (all(data_tall)) {
187	!	data <- do.call(
188	!	dplyr::bind_rows,
189	!	lapply(files, function(file) {
190	!	d <- data[[file]]
191	!	if (only_selected) {
192	!	measure_col <- unlist(lapply(
193	!	file_metadata[[file]]$schema$fields,
194	!	function(field)
195	!	if ("levels" %in% names(field$info)) field$name else NULL
196		))
197	!	d <- d[d[[measure_col]] %in% selected$name, ]
198		}
199	!	d[, all_cols]
200		})
201		)
202		} else {
203	!	cli::cli_warn(
204	!	"datasets are in inconsistent formats, so will not be unified"
205		)
206		}
207		} else {
208	2x	data <- data[[1L]]
209		}
210		}
211
212	4x	invisible(list(metadata = file_metadata, data = data))
213		}

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

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 <- dcf_attempt_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 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/pophive_demo"
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	4x	settings <- dcf_read_settings(project_dir)
29	4x	is_standalone <- isTRUE(settings$standalone)
30	4x	data_dir <- if (is_standalone) {
31	1x	dirname(project_dir)
32		} else {
33	3x	paste0(project_dir, "/", settings$data_dir)
34		}
35
36	4x	processes <- list.files(
37	4x	data_dir,
38	4x	"process\\.json",
39	4x	recursive = TRUE,
40	4x	full.names = TRUE
41		)
42	4x	process_state <- tools::md5sum(processes)
43	4x	report_file <- paste0(project_dir, "/report.json.gz")
44	4x	process <- dcf_process(project_dir = project_dir, is_auto = TRUE, ...)
45	4x	issues <- dcf_check(project_dir = project_dir)
46		if (
47	4x	!identical(
48	4x	process_state,
49	4x	tools::md5sum(list.files(
50	4x	data_dir,
51	4x	"process\\.json",
52	4x	recursive = TRUE,
53	4x	full.names = TRUE
54		))
55		)
56		) {
57	4x	datapackages <- list.files(
58	4x	data_dir,
59	4x	"datapackage\\.json",
60	4x	recursive = TRUE,
61	4x	full.names = TRUE
62		)
63	4x	names(datapackages) <- sub(
64		"^/",
65		"",
66	4x	sub(
67	4x	data_dir,
68		"",
69	4x	sub("/datapackage.json", "", datapackages, fixed = TRUE),
70	4x	fixed = TRUE
71		)
72		)
73	4x	names(processes) <- sub(
74		"^/",
75		"",
76	4x	sub(
77	4x	data_dir,
78		"",
79	4x	sub("/process.json", "", processes, fixed = TRUE),
80	4x	fixed = TRUE
81		)
82		)
83	4x	report <- list(
84	4x	date = Sys.time(),
85	4x	settings = settings,
86	4x	source_times = process$timings,
87	4x	logs = process$logs,
88	4x	issues = issues,
89	4x	metadata = lapply(datapackages, dcf_attempt_read_json),
90	4x	processes = lapply(processes, dcf_attempt_read_json)
91		)
92	4x	with_levels <- list()
93	4x	measures <- list()
94	4x	for (p in seq_along(report$metadata)) {
95	6x	for (r in seq_along(report$metadata[[p]]$resources)) {
96	7x	for (f in seq_along(
97	7x	report$metadata[[p]]$resources[[r]]$schema$fields
98		)) {
99	30x	info <- report$metadata[[p]]$resources[[r]]$schema$fields[[f]]$info
100	30x	if (is.list(info) && !is.null(info$id)) {
101	13x	measures[[info$id]] <- list(
102	13x	project = report$metadata[[p]]$name,
103	13x	file = report$metadata[[p]]$resources[[r]]$filename,
104	13x	info = info
105		)
106	13x	if (!is.null(info$levels)) {
107	2x	with_levels <- c(with_levels, list(c(p, r, f)))
108		}
109		}
110		}
111		}
112		}
113	4x	for (cords in with_levels) {
114	2x	levels <- report$metadata[[cords[[1L]]]]$resources[[cords[[
115	2x	2L
116	2x	]]]]$schema$fields[[cords[[3L]]]]$info$levels
117	2x	source_info <- list()
118	2x	for (level_id in names(levels)) {
119	4x	level <- levels[[level_id]]
120	4x	source_id <- if (!is.list(level) \|\| is.null(level$source_id)) {
121	2x	level_id
122		} else {
123	2x	level$source_id
124		}
125	4x	source_info[[source_id]] <- measures[[source_id]]
126		}
127	2x	report$metadata[[cords[[1L]]]]$resources[[cords[[
128	2x	2L
129	2x	]]]]$schema$fields[[cords[[3L]]]]$info$source_info <- source_info
130		}
131	4x	jsonlite::write_json(
132	4x	report,
133	4x	gzfile(report_file),
134	4x	auto_unbox = TRUE,
135	4x	dataframe = "columns"
136		)
137		} else {
138	!	report <- dcf_attempt_read_json(report_file)
139		}
140	4x	if (make_file_log) {
141	4x	file_log <- list()
142	4x	for (file_dir in names(report$metadata)) {
143	6x	if (grepl("/dist", file_dir, fixed = TRUE)) {
144	2x	p <- report$metadata[[file_dir]]
145	2x	for (p_file in p$resources) {
146	3x	file_log[[paste0(
147	3x	settings$data_dir,
148		"/",
149	3x	file_dir,
150		"/",
151	3x	p_file$filename
152	3x	)]] <- list(
153	3x	updated = if (length(p_file$vintage)) {
154	3x	p_file$vintage
155		} else {
156	!	p_file$last_modified
157		},
158	3x	md5 = p_file$md5
159		)
160		}
161		}
162		}
163	4x	jsonlite::write_json(
164	4x	file_log,
165	4x	paste0(project_dir, "/file_log.json"),
166	4x	auto_unbox = TRUE
167		)
168		}
169	4x	if (make_diagram) {
170	4x	dcf_status_diagram(project_dir)
171		}
172	4x	invisible(report)
173		}

1		#' View Project Variables
2		#'
3		#' Get a list of measures (a codebook) that are included in a data collection project.
4		#'
5		#' @param project Path to a local project, or the GitHub account and repository name
6		#' (\code{"{account_name}/{repo_name}"}) of a remote project.
7		#' Or a report as returned from \code{\link{dcf_report}}.
8		#' @param exclude A character vector of variable names to exclude from the list (usually ID columns).
9		#' @param ... Additional arguments passed to \code{\link{dcf_report}}.
10		#' @returns A tibble containing variables:
11		#' \tabular{ll}{
12		#' \code{name} \tab Name of the variable, as it appears in the data file. \cr
13		#' \code{type} \tab The value's storage type. \cr
14		#' \code{n} \tab Number of non-missing observations within the file. \cr
15		#' \code{duplicates} \tab Number of duplicated values within the file. \cr
16		#' \code{missing} \tab Number of missing values within the file. \cr
17		#' \code{project_type} \tab The project type, between \code{source} and \code{bundle}. \cr
18		#' \code{data_format} \tab The orientation of the data, between \code{wide} and \code{tall}. \cr
19		#' \code{file} \tab The file containing the variable; a path relative to the project root. \cr
20		#' \code{short_name} \tab Short name, if included in measure info. \cr
21		#' \code{long_name} \tab Long name, if included in measure info. \cr
22		#' \code{short_decription} \tab Short description, if included in measure info. \cr
23		#' \code{long_description} \tab Long description, if included in measure info. \cr
24		#' \code{measure_type} \tab Higher-level description of type than storage type
25		#' (e.g., \code{count} versus \code{integer}), if included in measure info. \cr
26		#' \code{unit} \tab How a single value should be interpreted
27		#' (e.g., \code{per 100k people} for a rate per 100k people), if included in measure info. \cr
28		#' \code{time_resolution} \tab The measure's collection frequency, if included in measure info. \cr
29		#' \code{category} \tab The measure's category, if included in measure info. \cr
30		#' \code{subcategory} \tab The measure's subcategory, if included in measure info. \cr
31		#' }
32		#' @family data user interface functions
33		#' @examples
34		#' dcf_variables("dissc-yale/pophive_demo")
35		#' @export
36
37		dcf_variables <- function(
38		project = ".",
39		exclude = c("geography", "time", "age"),
40		...
41		) {
42	5x	report <- if (is.list(project)) project else dcf_report(project, ...)
43	5x	data_dir <- report$settings$data_dir
44	5x	dplyr::as_tibble(do.call(
45	5x	rbind,
46	5x	lapply(names(report$metadata), function(project_output) {
47	23x	datapackage <- report$metadata[[project_output]]
48	23x	measure_info <- datapackage$measure_info
49	23x	do.call(
50	23x	rbind,
51	23x	lapply(datapackage$resources, function(resource) {
52	36x	file <- paste(data_dir, project_output, resource$filename, sep = "/")
53	36x	project_type <- if (grepl("/dist/", file, fixed = TRUE)) "bundle" else
54	36x	"source"
55	36x	n_rows <- resource$row_count
56	36x	data_format <- if (is.null(resource$data_format)) "wide" else
57	36x	resource$data_format
58	36x	do.call(
59	36x	rbind,
60	36x	Filter(
61	36x	length,
62	36x	if (data_format == "tall") {
63	10x	lapply(resource$schema$fields, function(field) {
64	44x	if ("levels" %in% names(field$info)) {
65	10x	do.call(
66	10x	rbind,
67	10x	lapply(
68	10x	field$info$levels,
69	10x	function(level) {
70	28x	n <- field$table[[level$id]]
71	28x	level_row(
72	28x	level,
73	28x	if (is.null(n)) 0L else n,
74	28x	file,
75	28x	project_type
76		)
77		}
78		)
79		)
80		}
81		})
82		} else {
83	26x	lapply(resource$schema$fields, function(field) {
84	56x	if (length(exclude) && field$name %in% exclude) return(NULL)
85	100x	info <- field$info
86	!	if ("info" %in% names(info)) info <- info$info
87	100x	if (is.null(info) && !is.null(measure_info)) {
88	!	info <- measure_info[[field$name]]
89		}
90	100x	cbind(
91	100x	data.frame(
92	100x	name = field$name,
93	100x	type = field$type,
94	100x	n = n_rows - field$missing,
95	100x	duplicates = field$duplicates,
96	100x	missing = field$missing,
97	100x	project_type = project_type,
98	100x	data_format = "wide",
99	100x	file = file
100		),
101	100x	unpack_info(info)
102		)
103		})
104		}
105		)
106		)
107		})
108		)
109		})
110		))
111		}
112
113		unpack_info <- function(info) {
114	128x	unpacked <- data.frame(
115	128x	short_name = NA_character_,
116	128x	long_name = NA_character_,
117	128x	short_description = NA_character_,
118	128x	long_description = NA_character_,
119	128x	measure_type = NA_character_,
120	128x	unit = NA_character_,
121	128x	time_resolution = NA_character_,
122	128x	category = NA_character_,
123	128x	subcategory = NA_character_
124		)
125	128x	info_names <- names(info)
126	128x	if ("name" %in% info_names && !("short_name" %in% info_names)) {
127	!	info$short_name <- info$name
128		}
129	128x	if ("description" %in% info_names && !("short_description" %in% info_names)) {
130	!	info$short_description <- info$description
131		}
132	128x	info_names <- names(info)
133	128x	for (name in colnames(unpacked)) {
134	1152x	if (name %in% info_names) {
135	826x	unpacked[[name]] <- info[[name]]
136		}
137		}
138	128x	unpacked
139		}
140
141		level_row <- function(level, n, file, project_type) {
142	28x	cbind(
143	28x	data.frame(
144	28x	name = level$id,
145	28x	type = level$type,
146	28x	n = n,
147	28x	duplicates = NA,
148	28x	missing = NA,
149	28x	project_type = project_type,
150	28x	data_format = "tall",
151	28x	file = file
152		),
153	28x	unpack_info(level$info)
154		)
155		}

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		#' @param use_git Logical; if \code{TRUE}, will initialize a git repository.
9		#' @param use_workflow Logical; if \code{TRUE}, will add a GitHub Actions workflow.
10		#' @returns Nothing; creates default files and directories.
11		#' @section Project Definition:
12		#'
13		#' The \strong{\code{process.json}} file defines the project with some initial attributes:
14		#' \itemize{
15		#' \item \code{type} Always \code{source} to define this as a source project.
16		#' \item \code{name} Name of the project.
17		#' \item \code{scripts} List of script definitions.
18		#' \item \code{checked} When the project was last checked with \code{\link{dcf_check}}.
19		#' \item \code{check_results} Results of the last check.
20		#' \item \code{standalone} Logical; \code{TRUE} if the source project does not exist
21		#' within a broader collection project.
22		#' \item \code{standard_state} State of the \code{standard} directory: A list
23		#' with names as the file paths, relative to the overall project root, and values
24		#' as the MD5 hash of those files.
25		#' \item \code{raw_state} State of the \code{raw} directory, if
26		#' set within a script.
27		#' \item \code{vintages} A list with names as names of files found in the \code{standard}
28		#' directory, and values as dates (of arbitrary format). This is a way to provide
29		#' a date separate from the files dates (e.g., if you have some other source for when the
30		#' data were actually collected), which will be included the named file's
31		#' \code{datapackage.json}.
32		#' }
33		#'
34		#' Each \strong{\code{scripts}} entry points to a script to be run, with one default:
35		#' \itemize{
36		#' \item \code{path} path to the script, relative to this project's root.
37		#' \item \code{manual} Logical; if \code{TRUE}, will only run the script from
38		#' \code{\link{dcf_process}} (not \code{\link{dcf_build}}).
39		#' \item \code{frequency} How often to rerun the project, in days.
40		#' This is checked against the last run timestamp when processed; it is a way
41		#' to skip processing, but can only be as frequent as the overall process is run.
42		#' \item \code{last_run} Timestamp of the last processing.
43		#' \item \code{run_time} How long the script took to run last, in milliseconds.
44		#' \item \code{last_status} Status of the last run; a list with entries for
45		#' \code{success} (logical) and \code{log} (output of the script).
46		#' }
47		#'
48		#' See the \href{https://dissc-yale.github.io/dcf/articles/standards.html#scripts}{script standards}
49		#' for examples of using this within a sub-project script.
50		#'
51		#' @section Project Files :
52		#'
53		#' Within a source project, there are two files to edits:
54		#' \itemize{
55		#' \item \strong{\code{ingest.R}}: This is the primary script, which is automatically rerun.
56		#' It should store raw data and resources in \code{raw/} where possible,
57		#' then use what's in \code{raw/} to produce standard-format files in \code{standard/}.
58		#' This file is sourced from its location during processing, so any system paths
59		#' must be relative to itself.
60		#' \item \strong{\code{measure_info.json}}: This is where you can record information
61		#' about the variables included in the standardized data files.
62		#' See \code{\link{dcf_measure_info}}.
63		#' }
64		#'
65		#' @examples
66		#' project_dir <- paste0(tempdir(), "/temp_project")
67		#' dcf_init("temp_project", dirname(project_dir))
68		#' dcf_add_source("source_name", project_dir)
69		#' list.files(paste0(project_dir, "/data/source_name"))
70		#' @export
71
72		dcf_add_source <- function(
73		name,
74		project_dir = ".",
75		open_after = interactive(),
76		use_git = TRUE,
77		use_workflow = FALSE
78		) {
79	8x	if (is.null(name)) {
80	!	cli::cli_abort("provide a name")
81		}
82	8x	name <- gsub("[^A-Za-z0-9]+", "_", name)
83	8x	is_standalone <- !file.exists(paste0(project_dir, "/settings.json"))
84	8x	data_dir <- dcf_read_settings(project_dir)$data_dir
85	8x	base_dir <- paste0(project_dir, "/", data_dir)
86	8x	base_path <- paste0(base_dir, "/", name, "/")
87	8x	dir.create(paste0(base_path, "raw"), showWarnings = FALSE, recursive = TRUE)
88	8x	dir.create(paste0(base_path, "standard"), showWarnings = FALSE)
89	8x	paths <- paste0(
90	8x	base_path,
91	8x	c(
92	8x	"measure_info.json",
93	8x	"ingest.R",
94	8x	"project.Rproj",
95	8x	"standard/datapackage.json",
96	8x	"process.json",
97	8x	"README.md",
98	8x	".gitignore",
99	8x	".github/workflows/process.yaml"
100		)
101		)
102	8x	if (!file.exists(paths[[1L]])) {
103	2x	dcf_measure_info(
104	2x	paths[[1L]],
105	2x	example_variable = list(),
106	2x	verbose = FALSE,
107	2x	open_after = FALSE
108		)
109		}
110	8x	if (!file.exists(paths[[2L]])) {
111	2x	writeLines(
112	2x	paste0(
113	2x	c(
114		"#",
115	2x	"# Download",
116		"#",
117		"",
118	2x	"# add files to the `raw` directory",
119		"",
120		"#",
121	2x	"# Reformat",
122		"#",
123		"",
124	2x	"# read from the `raw` directory, and write to the `standard` directory",
125		""
126		),
127	2x	collapse = "\n"
128		),
129	2x	paths[[2L]]
130		)
131		}
132	8x	if (!file.exists(paths[[3L]])) {
133	2x	writeLines("Version: 1.0\n", paths[[3L]])
134		}
135	8x	if (!file.exists(paths[[4L]])) {
136	2x	dcf_datapackage_init(
137	2x	name,
138	2x	dir = paste0(base_path, "standard"),
139	2x	quiet = TRUE
140		)
141		}
142
143	8x	if (!file.exists(paths[[5L]])) {
144	2x	dcf_process_record(
145	2x	paths[[5L]],
146	2x	list(
147	2x	name = name,
148	2x	type = "source",
149	2x	scripts = list(
150	2x	list(
151	2x	path = "ingest.R",
152	2x	manual = FALSE,
153	2x	frequency = 0L,
154	2x	last_run = "",
155	2x	run_time = "",
156	2x	last_status = list(log = "", success = TRUE)
157		)
158		),
159	2x	checked = "",
160	2x	check_results = list(),
161	2x	standalone = is_standalone
162		)
163		)
164		}
165	8x	if (!file.exists(paths[[6L]])) {
166	2x	writeLines(
167	2x	paste0(
168	2x	c(
169	2x	paste("#", name),
170		"",
171	2x	"This is a dcf data source project, initialized with `dcf::dcf_add_source`.",
172		"",
173	2x	"You can use the `dcf` package to check the project:",
174		"",
175	2x	"```R",
176	2x	"dcf_check()",
177		"```",
178		"",
179	2x	"And process it:",
180		"",
181	2x	"```R",
182	2x	"dcf_process()",
183		"```"
184		),
185	2x	collapse = "\n"
186		),
187	2x	paths[[6L]]
188		)
189		}
190	8x	if (is_standalone) {
191	2x	if (use_git) {
192	1x	dcf_init_git(base_path)
193	1x	if (!file.exists(paths[[7L]])) {
194	1x	writeLines(
195	1x	paste(
196	1x	c(
197	1x	"*.Rproj",
198	1x	".Rproj.user",
199	1x	"*.Rprofile",
200	1x	"*.Rhistory",
201	1x	"*.Rdata",
202	1x	".DS_Store",
203	1x	"renv"
204		),
205	1x	collapse = "\n"
206		),
207	1x	paths[[7L]]
208		)
209		}
210		}
211	2x	if (use_workflow && !file.exists(paths[[8L]])) {
212	!	dir.create(dirname(paths[[8L]]), recursive = TRUE, showWarnings = FALSE)
213	!	file.copy(
214	!	system.file("workflows/build.yaml", package = "dcf"),
215	!	paths[[8L]]
216		)
217		}
218		}
219	!	if (open_after) rstudioapi::openProject(paths[[3L]], newSession = TRUE)
220		}

1		dcf_attempt_read_json <- function(path, ..., strict = TRUE) {
2	130x	contents <- tryCatch(jsonlite::read_json(path, ...), error = function(e) NULL)
3	130x	if (is.null(contents)) {
4	!	(if (strict) cli::cli_abort else cli::cli_warn)(
5	!	"failed to read {.file {path}}"
6		)
7		}
8	130x	contents
9		}
10		dcf_read_settings <- function(project_dir = ".", strict = FALSE) {
11	22x	settings_file <- paste0(project_dir, "/settings.json")
12	22x	if (!file.exists(settings_file)) {
13	4x	if (strict) {
14	!	cli::cli_abort(
15	!	"{.arg project_dir} ({project_dir}) does not appear to be a Data Collection Framework project"
16		)
17		} else {
18	4x	cli::cli_warn("settings file ({settings_file}) does not exist")
19	4x	return(list(
20	4x	name = basename(normalizePath(project_dir, "/", FALSE)),
21	4x	data_dir = ".",
22	4x	standalone = TRUE
23		))
24		}
25		}
26	18x	dcf_attempt_read_json(settings_file)
27		}
28		dcf_init_git <- function(dir) {
29	2x	if (!dir.exists(paste0(dir, ".git"))) {
30	2x	wd <- getwd()
31	2x	on.exit(setwd(wd))
32	2x	setwd(dir)
33	2x	system2("git", "init")
34	2x	setwd(wd)
35		}
36		}

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

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 A list or character vector, with names as paths to standard files
8		#' form source projects (relative to the project's data directory), and distribution file
9		#' names as entries. This associates input with output files, allowing for calculation of
10		#' a source state, and metadata inheritance from source files.
11		#' @param open_after Logical; if \code{FALSE}, will not open the project.
12		#' @param use_git Logical; if \code{TRUE}, will initialize a git repository.
13		#' @param use_workflow Logical; if \code{TRUE}, will add a GitHub Actions workflow.
14		#' @returns Nothing; creates default files and directories.
15		#' @section Project Definition:
16		#'
17		#' The \strong{\code{process.json}} file defines the project with some initial attributes:
18		#' \itemize{
19		#' \item \code{type} Always \code{bundle} to define this as a bundle project.
20		#' \item \code{name} Name of the project.
21		#' \item \code{scripts} List of script definitions.
22		#' \item \code{source_files} A character array of paths to other files
23		#' used within the scripts, relative to the overall project's \code{data} directory.
24		#' \item \code{standard_state} State of the \code{source_files}: A list
25		#' with keys as the file paths, relative to the overall project root, and values
26		#' as the MD5 hash of those files.
27		#' \item \code{dist_state} State of the \code{dist} directory: A list
28		#' with keys as the file paths, relative to the overall project root, and values
29		#' as the MD5 hash of those files.
30		#' \item \code{checked} Timestamp when the project was last checked with \code{\link{dcf_check}}.
31		#' \item \code{check_results} Results of the last check.
32		#' }
33		#'
34		#' Each \strong{\code{scripts}} entry points to a script to be run, with one default:
35		#' \itemize{
36		#' \item \code{path} path to the script, relative to this project's root.
37		#' \item \code{last_run} Timestamp of the last processing.
38		#' \item \code{run_time} How long the script took to run last, in milliseconds.
39		#' \item \code{last_status} Status of the last run; a list with entries for
40		#' \code{success} (logical) and \code{log} (output of the script).
41		#' }
42		#'
43		#' @section Project Files:
44		#'
45		#' Within a bundle project, there are two files to edits:
46		#' \itemize{
47		#' \item \strong{\code{build.R}}: This is the primary script, which is automatically rerun.
48		#' It should read data from the \code{standard} directory of source projects,
49		#' and write to it's own \code{dist} directory.
50		#' \item \strong{\code{measure_info.json}}: This should list all non-ID variable names
51		#' in the data files within \code{dist}. These will inherit the standard measure info
52		#' if found in the source projects referred to in \code{source_files}.
53		#' If the \code{dist} name is different, but should still inherit standard measure info,
54		#' a \code{source_id} entry with the original measure ID will be used to identify the original
55		#' measure info.
56		#' See \code{\link{dcf_measure_info}}.
57		#' }
58		#'
59		#' @examples
60		#' project_dir <- paste0(tempdir(), "/temp_project")
61		#' dcf_init("temp_project", dirname(project_dir))
62		#' dcf_add_bundle("bundle_name", project_dir)
63		#' list.files(paste0(project_dir, "/data/bundle_name"))
64		#'
65		#' @export
66
67		dcf_add_bundle <- function(
68		name,
69		project_dir = ".",
70		source_files = NULL,
71		open_after = interactive(),
72		use_git = TRUE,
73		use_workflow = FALSE
74		) {
75	4x	if (missing(name)) {
76	!	cli::cli_abort("specify a name")
77		}
78	4x	name <- gsub("[^A-Za-z0-9]+", "_", name)
79	4x	is_standalone <- !file.exists(paste0(project_dir, "/settings.json"))
80	4x	data_dir <- dcf_read_settings(project_dir)$data_dir
81	4x	base_dir <- paste0(project_dir, "/", data_dir)
82	4x	base_path <- paste0(base_dir, "/", name, "/")
83	4x	if (!is.null(source_files)) {
84	2x	su <- !file.exists(paste0(
85	2x	data_dir,
86		"/",
87	2x	if (is.null(names(source_files))) source_files else names(source_files)
88		))
89	2x	if (any(su)) {
90	!	cli::cli_abort(
91	!	"source file{? doesn't/s don't} exist: {settings$data_dir[su]}"
92		)
93		}
94		}
95	4x	dir.create(paste0(base_path, "/dist"), showWarnings = FALSE, recursive = TRUE)
96	4x	paths <- paste0(
97	4x	base_path,
98		"/",
99	4x	c(
100	4x	"README.md",
101	4x	"project.Rproj",
102	4x	"process.json",
103	4x	"measure_info.json",
104	4x	"build.R",
105	4x	"README.md",
106	4x	".gitignore",
107	4x	".github/workflows/process.yaml"
108		)
109		)
110	4x	if (!file.exists(paths[[1L]])) {
111	2x	writeLines(
112	2x	paste0(
113	2x	c(
114	2x	paste("#", name),
115		"",
116	2x	"This is a Data Collection Framework data bundle project, initialized with `dcf::dcf_add_bundle`.",
117		"",
118	2x	"You can us the `dcf` package to rebuild the bundle:",
119		"",
120	2x	"```R",
121	2x	paste0('dcf::dcf_process("', name, '", "..")'),
122		"```"
123		),
124	2x	collapse = "\n"
125		),
126	2x	paths[[1L]]
127		)
128		}
129	4x	if (!file.exists(paths[[2L]])) {
130	2x	writeLines("Version: 1.0\n", paths[[2L]])
131		}
132	4x	if (!file.exists(paths[[3L]])) {
133	2x	jsonlite::write_json(
134	2x	list(
135	2x	name = name,
136	2x	type = "bundle",
137	2x	scripts = list(
138	2x	list(
139	2x	path = "build.R",
140	2x	last_run = "",
141	2x	run_time = "",
142	2x	last_status = list(log = "", success = TRUE)
143		)
144		),
145	2x	source_files = if (!is.null(names(source_files)))
146	2x	as.list(source_files) else source_files
147		),
148	2x	paths[[3L]],
149	2x	auto_unbox = TRUE,
150	2x	pretty = TRUE
151		)
152		}
153	4x	if (!file.exists(paths[[4L]])) {
154	2x	writeLines("{}\n", paths[[4L]])
155		}
156	4x	if (!file.exists(paths[[5L]])) {
157	2x	writeLines(
158	2x	paste0(
159	2x	c(
160	2x	"# read data from data source projects",
161	2x	"# and write to this project's `dist` directory",
162		""
163		),
164	2x	collapse = "\n"
165		),
166	2x	paths[[5L]]
167		)
168		}
169	4x	if (!file.exists(paths[[6L]])) {
170	!	writeLines(
171	!	paste0(
172	!	c(
173	!	paste("#", name),
174		"",
175	!	"This is a dcf data bundle project, initialized with `dcf::dcf_add_bundle`.",
176		"",
177	!	"You can use the `dcf` package to check the project:",
178		"",
179	!	"```R",
180	!	"dcf_check()",
181		"```",
182		"",
183	!	"And process it:",
184		"",
185	!	"```R",
186	!	"dcf_process()",
187		"```"
188		),
189	!	collapse = "\n"
190		),
191	!	paths[[6L]]
192		)
193		}
194	4x	if (is_standalone) {
195	!	if (use_git) {
196	!	dcf_init_git(base_path)
197	!	if (!file.exists(paths[[7L]])) {
198	!	writeLines(
199	!	paste(
200	!	c(
201	!	"*.Rproj",
202	!	".Rproj.user",
203	!	"*.Rprofile",
204	!	"*.Rhistory",
205	!	"*.Rdata",
206	!	".DS_Store",
207	!	"renv"
208		),
209	!	collapse = "\n"
210		),
211	!	paths[[7L]]
212		)
213		}
214		}
215	!	if (use_workflow && !file.exists(paths[[8L]])) {
216	!	dir.create(dirname(paths[[8L]]), recursive = TRUE, showWarnings = FALSE)
217	!	file.copy(
218	!	system.file("workflows/build.yaml", package = "dcf"),
219	!	paths[[8L]]
220		)
221		}
222		}
223	!	if (open_after) rstudioapi::openProject(paths[[2L]], newSession = TRUE)
224		}

1		#' Retrieve Project Report
2		#'
3		#' Retrieve the report file from a local or remote project.
4		#'
5		#' @param project Path to a local project, or the GitHub account and repository name
6		#' (\code{"{account_name}/{repo_name}"}) of a remote project.
7		#' @param branch Name of the remote repository branch.
8		#' @param commit Commit hash; overrides \code{branch}.
9		#' @param provider Base URL of the remote repository provider.
10		#' @param cache Directory to store retrieved report in (at \code{{cache}/{project}/report.json.gz}).
11		#' @param refresh Logical; if \code{TRUE}, will always retrieve a fresh copy of the report,
12		#' even if a copy exists in \code{cache}.
13		#' @returns A data collection project report:
14		#' \tabular{ll}{
15		#' \code{date} \tab Timestamp when the report was created. \cr
16		#' \code{settings} \tab The project's settings file. \cr
17		#' \code{source_times} \tab
18		#' A list with entries for each subproject, containing the number of seconds
19		#' it took to run the project's scripts. \cr
20		#' \code{issues} \tab
21		#' A list with entries for each subproject, containing issues flagged by
22		#' \code{\link{dcf_check}}, within a list with \code{data} and/or \code{measure} entries,
23		#' containing character vectors of issue labels. \cr
24		#' \code{logs} \tab
25		#' A list with entries for each subproject, containing the logged output of their scripts. \cr
26		#' \code{metadata} \tab
27		#' A list with entries for each subproject, containing the datapackage of their output,
28		#' as created by \code{\link{dcf_measure_info}}. \cr
29		#' \code{processes} \tab
30		#' A list with entries for each subproject, containing their process definitions
31		#' (see \code{\link{dcf_add_source}} and/or \code{\link{dcf_add_bundle}}). \cr
32		#' }
33		#' @family data user interface functions
34		#' @examples
35		#' report <- dcf_report("dissc-yale/pophive_demo")
36		#' report$date
37		#' jsonlite::toJSON(report$settings, auto_unbox = TRUE, pretty = TRUE)
38		#' @export
39
40		dcf_report <- function(
41		project = "dissc-yale/pophive_demo",
42		branch = "main",
43		commit = NULL,
44		provider = "https://github.com",
45		cache = tempdir(),
46		refresh = FALSE
47		) {
48	7x	if (dir.exists(project)) {
49	4x	report_file <- paste0(project, "/report.json.gz")
50	4x	if (!file.exists(report_file)) {
51	!	cli::cli_abort("report does not exist at {report_file}")
52		}
53	4x	report_url <- ""
54		} else {
55	3x	report_file <- paste0(cache, "/", project, "/report.json.gz")
56	3x	report_url <- paste0(
57	3x	provider,
58		"/",
59	3x	project,
60	3x	"/raw/",
61	3x	if (is.null(commit)) paste0("refs/heads/", branch) else commit,
62	3x	"/report.json.gz"
63		)
64	3x	if (refresh \|\| !file.exists(report_file)) {
65	1x	dir.create(dirname(report_file), FALSE, TRUE)
66	1x	req <- curl::curl_fetch_disk(report_url, report_file)
67	1x	if (req$status_code != 200L) {
68	!	unlink(report_file)
69	!	cli::cli_abort(
70	!	"failed to retrieve report at {report_url}: {req$status_code}, {req$content}"
71		)
72		}
73		}
74		}
75	7x	report <- dcf_attempt_read_json(report_file)
76	7x	report$settings$report_url <- report_url
77	7x	invisible(report)
78		}

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		}