dcf coverage - 85.87%

Files
Source

#' 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 <- file.path(project_dir, "settings.json")
  from_project <- file.exists(settings_file)
  if (from_project) {
    source_dir <- file.path(
      project_dir,
      dcf_attempt_read_json(settings_file)$data_dir
    )
  } else if (file.exists(file.path(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 <- file.path(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)
    any_failed <- FALSE
    if (run_scripts) {
      for (si in seq_along(process_def$scripts)) {
        st <- proc.time()[[3]]
        process_script <- parse_process_script(process_def$scripts[[si]])
        if (decide_to_run(process_script)) {
          script <- file.path(base_dir, process_script$path)
          file_ref <- paste0(" ({.emph ", script, "})")
          cli::cli_progress_step(
            paste0("processing source {.strong ", name, "}", file_ref),
            spinner = TRUE
          )
          env <- new.env()
          env$dcf_process_continue <- TRUE
          status <- tryCatch(
            list(
              log = utils::capture.output(
                source(script, env, chdir = TRUE),
                type = "message"
              ),
              success = TRUE
            ),
            error = function(e) {
              cli::cli_warn("scripts {.file {script}} failed: {e$message}")
              list(log = e$message, success = FALSE)
            }
          )
          collect_env$logs[[name]] <- status$log
          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 (isTRUE(status$success)) {
            collect_env$timings[[name]] <- process_script$run_time
          } else {
            any_failed <- TRUE
          }
          if (!env$dcf_process_continue) break
        }
      }
    }
    process_def_current <- dcf_process_record(process_file)
    if (is.null(process_def_current$name)) {
      process_def_current$name <- basename(dirname(process_file))
    }
    if (run_scripts) {
      process_def_current$scripts <- process_def$scripts
    }
    if (
      is.null(process_def_current$raw_state) ||
        !identical(process_def$raw_state, process_def_current$raw_state)
    ) {
      dcf_process_record(process_file, process_def_current)
    }
    standard_dir <- file.path(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 <- file.path(base_dir, "measure_info.json")
      standard_state <- as.list(tools::md5sum(c(
        measure_info_file,
        file.path(standard_dir, data_files)
      )))
      if (!identical(process_def_current$standard_state, standard_state)) {
        datapackage_path <- file.path(standard_dir, "datapackage.json")
        if (!file.exists(datapackage_path)) {
          dcf_datapackage_init(name, dir = standard_dir, quiet = TRUE)
        }
        measure_info <- load_measure_info(measure_info_file)
        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(measure_sources))
            ) {
              measure_sources[[s$location]] <- s
            }
          }
        }
        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 (any_failed) "failed" else "done")
    } 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)
    if (run_scripts) {
      for (si in seq_along(process_def$scripts)) {
        st <- proc.time()[[3L]]
        process_script <- parse_process_script(process_def$scripts[[si]])
        script <- file.path(base_dir, process_script$path)
        run_current <- TRUE
        source_state <- NULL
        if (length(source_files)) {
          standard_files <- file.path(source_dir, source_files)
          source_state <- as.list(tools::md5sum(file.path(
            source_dir,
            source_files
          )))
          run_current <- !identical(source_state, process_def$source_state)
        }
        if (run_current) {
          cli::cli_progress_step(
            paste0(
              "processing bundle {.strong ",
              name,
              "} ({.emph ",
              script,
              "})"
            ),
            spinner = TRUE
          )
          env <- new.env()
          env$dcf_process_continue <- TRUE
          status <- tryCatch(
            list(
              log = utils::capture.output(
                source(script, env, chdir = TRUE),
                type = "message"
              ),
              success = TRUE
            ),
            error = function(e) {
              cli::cli_warn("scripts {.file {script}} failed: {e$message}")
              list(log = e$message, success = FALSE)
            }
          )
          collect_env$logs[[name]] <- status$log
          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(file.path(
          vapply(file.path(source_dir, source_files), dirname, ""),
          "datapackage.json"
        )),
        function(package_file) {
          if (file.exists(package_file)) {
            tools::md5sum(package_file)
          }
        }
      )
    )))
    dist_dir <- file.path(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(file.path(
          base_dir,
          "dist",
          dist_files
        ))),
        source_packages
      )
      if (!identical(process_def_current$dist_state, dist_state)) {
        if (run_scripts) {
          process_def_current$scripts <- process_def$scripts
        }
        process_def_current$source_state <- source_state
        process_def_current$dist_state <- dist_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 <- load_measure_info(
          file.path(base_dir, "measure_info.json")
        )
        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(measure_sources))
            ) {
              measure_sources[[s$location]] <- s
            }
          }
        }
        if (!file.exists(file.path(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 <- file.path(
            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))
}

parse_process_script <- function(partial) {
  if (!length(partial$path)) {
    cli::cli_abort("process script entry has no path")
  }
  list(
    path = partial$path,
    manual = isTRUE(partial$manual),
    last_run = if (length(partial$last_run)) partial$last_run else "",
    frequency = if (length(partial$frequency)) partial$frequency else 0L
  )
}

load_measure_info <- function(file) {
  base <- dcf_measure_info(
    file,
    include_empty = FALSE,
    render = TRUE,
    write = FALSE,
    open_after = FALSE,
    verbose = FALSE
  )
  parent_dir <- dirname(file)
  for (i in seq_len(2L)) {
    parent_dir <- dirname(parent_dir)
    parent_file <- file.path(parent_dir, "measure_info.json")
    if (file.exists(parent_file)) {
      parent_info <- dcf_measure_info(
        parent_file,
        include_empty = FALSE,
        render = TRUE,
        write = FALSE,
        open_after = FALSE,
        verbose = FALSE
      )
      for (entry in names(parent_info)) {
        if (!(entry %in% names(base))) {
          base[[entry]] <- parent_info[[entry]]
        }
      }
      for (entry in names(parent_info[["_sources"]])) {
        if (!(entry %in% names(base[["_sources"]]))) {
          base[["_sources"]][[entry]] <- parent_info[["_sources"]][[entry]]
        }
      }
    }
  }
  base
}

#' 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(file.path(dir, filename)))) {
    filename <- filename[!file.exists(file.path(dir, filename))]
    cli::cli_abort("{?a file/files} did not exist: {filename}")
  }
  package <- if (
    is.character(packagename) && file.exists(file.path(dir, packagename))
  ) {
    file.path(dir, packagename)
  } else {
    packagename
  }
  if (is.character(package)) {
    package <- file.path(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 <- package
  single_meta <- FALSE
  metas <- if (!is.null(names(meta))) {
    meta_names <- if (is.null(setnames)) filename else setnames
    if (any(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 <- file.path(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 <- file.path(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(
        "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]] <- file.path(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$ctime)
    previous <- if (length(initial_package$resources)) {
      previous_ind <- which(
        vapply(initial_package$resources, "[[", "", "filename") ==
          filename[[file]]
      )
      if (length(previous_ind)) {
        initial_package$resources[[previous_ind[[1L]]]]
      } else {
        list()
      }
    } else {
      list()
    }
    versions <- dcf_git_versions(basename(f), dir)
    if (length(previous$versions)) {
      versions <- rbind(
        versions,
        as.data.frame(do.call(cbind, previous$versions))
      )
      versions <- versions[!duplicated(versions$hash), ]
      versions <- versions[
        order(
          as.POSIXct(unlist(versions$date), format = "%a %b %e %H:%M:%S %Y %z"),
          decreasing = TRUE
        ),
      ]
    }
    res <- list(
      bytes = as.integer(info$size),
      encoding = stringi::stri_enc_detect(readBin(f, "raw", 100000))[[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 = versions,
      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$ctime),
      last_modified = as.character(info$mtime),
      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)) {
              v <- v[!invalid]
              r$type <- if (all(v %/% 1 == v)) {
                "integer"
              } else {
                "float"
              }
              r$missing <- sum(invalid)
              r$mean <- round(mean(v), 6L)
              r$sd <- round(stats::sd(v), 6L)
              r$min <- round(min(v), 6L)
              r$max <- round(max(v), 6L)
            } else {
              r$type <- "string"
              v <- iconv(as.character(v), to = "UTF-8")
              missing <- is.na(v) |
                is.nan(v) |
                grepl(
                  "^(?:[\\s.-]*|n/?an?|null)$",
                  v,
                  ignore.case = TRUE,
                  perl = TRUE
                )
              r$missing <- sum(missing)
              if (any(!missing)) {
                v <- as.factor(v[!missing])
                r$table <- structure(as.list(tabulate(v)), names = levels(v))
              } else {
                r$table <- list()
              }
            }
            r
          }
        )
      )
    )
    if (!single_meta) {
      res$measure_info <- lapply(
        m$variables[names(m$variables) %in% colnames(data)],
        function(e) e[e != ""]
      )
      if ("_sources" %in% names(m$variables)) {
        su <- names(m$variables[["_sources"]]) %in%
          unlist(lapply(res$measure_info, function(e) {
            e_source <- e$sources
            if (is.list(e_source)) {
              e_source <- vapply(
                e_source,
                function(e) if (is.character(e)) e else e$id,
                ""
              )
            }
            if (is.character(e_source)) e_source else NULL
          }))
        if (any(su)) {
          res$measure_info[["_sources"]] <- m$variables[["_sources"]][su]
        }
      }
      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$hash),
          ]
        }
      }
    }
  }
  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 {
        file.path(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::isAvailable()) {
        rstudioapi::navigateToFile(packagename)
      }
    }
  }
  invisible(package)
}

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
}

#' 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("//", "/", file.path(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 + 1L == c(metadata_break[-1L], 0L)
    ])
  }) +
    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 <- gsub(
    '^"|"$',
    "",
    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 <- !is.na(data$age) & (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
}

#' 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}}")
  }
  id_file <- paste0(id, ".json")
  metadata_file <- file.path(tempdir(), id_file)
  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)) {
    unname(tools::md5sum(metadata_file))
  } else {
    metadata$rowsUpdatedAt
  }
  recorded_count <- jsonlite::read_json(metadata_file)$columns[[
    1L
  ]]$cachedContents$count
  if (!identical(paste0(new_state, ":", recorded_count), state)) {
    data_url <- paste0(sub("api/", "api/v3/", url, fixed = TRUE), "/export.csv")
    out_path <- file.path(out_dir, paste0(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)
      new_state <- paste0(new_state, ":", nrow(data))
      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"))
      con <- file(out_path, "rb")
      new_state <- paste0(
        new_state,
        ":",
        nrow(vroom::vroom(con, col_select = 1L, col_types = "c"))
      )
      close(con)
      status <- system2("xz", c("-f", shQuote(out_path)))
      if (status != 0L) {
        cli::cli_abort("failed to compress data")
      }
    }
    metadata_file_final <- file.path(out_dir, id_file)
    if (file.exists(metadata_file_final)) {
      unlink(metadata_file_final)
    }
    file.rename(metadata_file, metadata_file_final)
    if (!file.exists(metadata_file_final)) {
      cli::cli_abort(
        "failed to move temp file from temp location {.file {metadata_file}}"
      )
    }
    if (verbose) {
      cli::cli_progress_done()
    }
    invisible(new_state)
  } else {
    unlink(metadata_file)
    invisible(state)
  }
}

#' 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 <- file.path(out_dir, paste0("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)
}

#' 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_standardize_epic(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)) {
    month_numbers <- epic_id_maps$months[raw_data$month]
    if (anyNA(month_numbers)) {
      unrecognized_months <- unique(raw_data$month[is.na(month_numbers)])
      cli::cli_abort("unrecognized month{?s}: {unrecognized_months}")
    }
    raw_data$time <- paste0(
      raw_data$time,
      "-",
      month_numbers
    )
  }
  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("^county", cols)
  if (!length(geo_col)) {
    geo_col <- grep("^state", 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
      )
      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,
  ]
}

#' 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 <- file.path(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, file.path(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 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 <- file.path(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, ignore.case = TRUE),
    ]
  }
  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]]
  } else if (length(population) > 1L) {
    cli::cli_abort("can only download 1 population at a time")
  }
  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))
    n_returned <- nrow(all_data[[i]])
    if (!missing(row_limit) && row_limit > 1e5 && n_requests == 1e5) {
      cli::cli_warn(
        "some rows may have been lost, since 100K were returned for retuest {.code param_string}"
      )
    }
    if (verbose) {
      cli::cli_progress_step(
        paste0(
          i,
          " of ",
          n_requests,
          " (",
          n_returned,
          " 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
}

#' 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
  ) {
    if (file.exists(file.path(names, "settings.json"))) {
      project_dir <- names
      names <- NULL
    } else if (file.exists(file.path(names, "process.json"))) {
      process <- dcf_process_record(file.path(names, "process.json"))
      if (isTRUE(process$standalone)) {
        project_dir <- names
        names <- basename(names)
      } else {
        project_dir <- dirname(dirname(names))
        names <- basename(names)
      }
    }
  }
  if (is.null(names) && !file.exists(file.path(project_dir, "settings.json"))) {
    project_dir <- normalizePath(project_dir, "/", FALSE)
    if (file.exists(file.path(project_dir, "process.json"))) {
      process <- dcf_process_record(file.path(project_dir, "process.json"))
      if (isTRUE(process$standalone)) {
        names <- basename(project_dir)
        project_dir <- dirname(project_dir)
      } else {
        names <- basename(project_dir)
        project_dir <- dirname(dirname(project_dir))
      }
    } else {
      names <- basename(project_dir)
      project_dir <- dirname(project_dir)
    }
  }
  settings <- dcf_read_settings(project_dir)
  base_dir <- file.path(project_dir, settings$data_dir)
  if (is.null(names)) {
    names <- list.dirs(base_dir, recursive = FALSE, full.names = FALSE)
    names <- names[file.exists(file.path(base_dir, names, "process.json"))]
  }
  issues <- list()
  package_change_reports <- list()
  for (name in names) {
    source_dir <- file.path(base_dir, name)
    if (!dir.exists(source_dir)) {
      cli::cli_abort("specify the name of an existing data project")
    }
    process_file <- file.path(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 <- file.path(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 <- file.path(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 <- file.path(source_dir, if (is_bundle) "dist" else "standard")
    package_file <- file.path(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(
      file.path(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)
}

#' 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)) {
      intent <- tolower(intent)
      if (!(intent %in% names(intents))) {
        cli::cli_abort("intent {intent} not found")
      }
      intents[[intent]]
    } else {
      intent
    },
    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)) races[[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)
}

#' 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 &
        (if (is.null(variables)) {
          TRUE
        } else {
          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 <- project
  } else {
    project_root <- normalizePath(file.path(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 <- file.path(project_root, file)
      if (refresh || !file.exists(cached_file)) {
        file_url <- file.path(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(file.path(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, ]
            }
            for (col in all_cols[!(all_cols %in% colnames(d))]) {
              d[[col]] <- NA
            }
            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))
}

#' 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 = if (is.null(level$id)) NA_character_ else level$id,
      type = if (is.null(level$type)) NA_character_ else level$type,
      n = n,
      duplicates = NA_integer_,
      missing = NA_integer_,
      project_type = project_type,
      data_format = "tall",
      file = file
    ),
    unpack_info(level$info)
  )
}

#' 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)) {
    vs <- dcf_git_versions(basename(path), dirname(path))
  }
  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 <- file.path(
    tempdir(),
    paste0(
      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
}

#' Process Epic Staging Files
#'
#' Process Epic staging 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[[1L]]]] <- 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 <- file_id_cols[file_id_cols %in% colnames(data[[name]])]
      data[[name]] <- data[[name]][
        !(do.call(paste, data[[name]][, file_id_cols, drop = FALSE]) %in%
          do.call(paste, epic$data[, file_id_cols, drop = FALSE])),
      ]
    }
    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 <- file.path(out_dir, paste0(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))
}

#' 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(file.path(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)
    base_dir <- dirname(base_dir)
  } else {
    name <- gsub("[^A-Za-z0-9]+", "_", name)
  }
  base_path <- file.path(base_dir, name)
  dir.create(base_path, showWarnings = FALSE, recursive = TRUE)
  paths <- file.path(
    base_path,
    c(
      "project.Rproj",
      "settings.json",
      "README.md",
      "scripts/build.R",
      ".github/workflows/build.yaml",
      ".gitignore",
      "measure_info.json"
    )
  )
  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 = branch,
        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",
          "dcf::dcf_check()",
          "```",
          "",
          "And process them:",
          "",
          "```R",
          "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 (!file.exists(paths[[7L]])) {
    dcf_measure_info(
      paths[[7L]],
      info = list(
        geography = list(
          id = "geography",
          name = "Location",
          description = "Location ID.",
          measure_type = "id"
        ),
        time = list(
          id = "time",
          name = "Time",
          description = "Date and/or time.",
          measure_type = "time"
        )
      ),
      include_empty = FALSE,
      verbose = FALSE,
      open_after = FALSE
    )
  }
  if (open_after && rstudioapi::isAvailable()) {
    rstudioapi::openProject(paths[[1L]], newSession = TRUE)
  }
}

#' 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/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 {
    file.path(project_dir, settings$data_dir)
  }
  processes <- list.files(
    data_dir,
    "process\\.json",
    recursive = TRUE,
    full.names = TRUE
  )
  process_state <- tools::md5sum(processes)
  report_file <- file.path(project_dir, "report.json.gz")
  process <- dcf_process(project_dir = project_dir, is_auto = is_auto, ...)
  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[[file.path(
            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,
      file.path(project_dir, "file_log.json"),
      auto_unbox = TRUE
    )
  }
  if (make_diagram) {
    dcf_status_diagram(project_dir)
  }
  invisible(report)
}

#' 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 <- file.path(tempdir(), "temp_project")
#' dcf_init("temp_project", dirname(project_dir))
#' dcf_add_bundle("bundle_name", project_dir)
#' list.files(file.path(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(file.path(project_dir, "settings.json"))
  base_dir <- file.path(project_dir, dcf_read_settings(project_dir)$data_dir)
  base_path <- file.path(base_dir, name)
  if (!is.null(source_files)) {
    source_paths <- file.path(
      base_dir,
      if (is.null(names(source_files))) source_files else names(source_files)
    )
    su <- !file.exists(source_paths)
    if (any(su)) {
      missing_source_files <- source_paths[su]
      cli::cli_abort(
        "source file{? doesn't/s don't} exist: {missing_source_files}"
      )
    }
  }
  dir.create(
    file.path(base_path, "dist"),
    showWarnings = FALSE,
    recursive = TRUE
  )
  paths <- file.path(
    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)
}

#' 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 <- file.path(tempdir(), "temp_project")
#' dcf_init("temp_project", dirname(project_dir))
#' dcf_add_source("source_name", project_dir)
#' list.files(file.path(project_dir, "data/source_name"))
#' @export

dcf_add_source <- function(
  name,
  project_dir = ".",
  open_after = interactive(),
  use_git = TRUE,
  use_workflow = FALSE
) {
  if (missing(name) || is.null(name) || name == project_dir) {
    cli::cli_abort("provide a name")
  }
  name <- gsub("[^A-Za-z0-9]+", "_", name)
  is_standalone <- !file.exists(file.path(project_dir, "settings.json"))
  data_dir <- dcf_read_settings(project_dir)$data_dir
  base_dir <- file.path(project_dir, data_dir)
  base_path <- file.path(base_dir, name)
  dir.create(
    file.path(base_path, "raw"),
    showWarnings = FALSE,
    recursive = TRUE
  )
  dir.create(file.path(base_path, "standard"), showWarnings = FALSE)
  paths <- file.path(
    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 = file.path(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/process.yaml", package = "dcf"),
        paths[[8L]]
      )
    }
  }
  if (open_after) rstudioapi::openProject(paths[[3L]], newSession = TRUE)
}

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

#' 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(
      file.path(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 = file.path(project_dir, "renv.lock")
  )
}

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 <- file.path(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 {
      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(file.path(dir, ".git"))) {
    wd <- getwd()
    on.exit(setwd(wd))
    setwd(dir)
    system2("git", "init")
    setwd(wd)
  }
}

dcf_git_versions <- function(file, dir = ".") {
  wd <- setwd(dir)
  on.exit(setwd(wd))
  log <- suppressWarnings(system2(
    "git",
    c("log", '--format="%H|||%an <%ae>|||%ad|||%s"', shQuote(file)),
    stdout = TRUE
  ))
  setwd(wd)
  if (is.null(attr(log, "status"))) {
    log_entries <- do.call(
      rbind,
      Filter(
        function(x) length(x) == 4L,
        strsplit(log, "|||", fixed = TRUE)
      )
    )
    if (length(log_entries)) {
      colnames(log_entries) <- c(
        "hash",
        "author",
        "date",
        "message"
      )
      as.data.frame(log_entries)
    }
  }
}

#' 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 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(file.path(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 (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, "}")
      ))
      if (rstudioapi::isAvailable()) rstudioapi::navigateToFile(package_path)
    }
  }
  invisible(package)
}

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	"52" = 2,
62	1x	"53" = 10,
63	1x	"54" = 3,
64	1x	"55" = 5,
65	1x	"56" = 8,
66	1x	"72" = 2,
67	1x	"60" = 9,
68	1x	"66" = 9,
69	1x	"69" = 9
70		)
71	1x	regions[] <- paste0(prefix, regions)
72	1x	unname(regions[substring(geoids, 1L, 2L)])
73		}

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

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

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("//", "/", file.path(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 + 1L == c(metadata_break[-1L], 0L)
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 <- gsub(
114		'^"\|"$',
115		"",
116	5x	c(
117	5x	header[id_cols],
118	5x	strsplit(lines[data_start], ",", fixed = TRUE)[[1L]][-id_cols]
119		)
120		)
121	5x	data <- arrow::read_csv_arrow(
122	5x	full_path,
123	5x	col_names = header,
124	5x	col_types = paste(rep("c", length(header)), collapse = ""),
125	5x	na = c("", "-"),
126	5x	skip = data_start + 1L
127		)
128	5x	percents <- grep("^(?:Percent\|Base\|RSV test)", header, ignore.case = TRUE)
129	5x	if (length(percents)) {
130	!	for (col in percents) {
131	!	data[[col]] <- sub("%", "", data[[col]], fixed = TRUE)
132		}
133		}
134	5x	number <- grep("Number", header, fixed = TRUE)
135	5x	if (length(number)) {
136	!	for (col in number) {
137	!	data[[col]][data[[col]] == "10 or fewer"] <- 5L
138		}
139		}
140	5x	for (col in id_cols) {
141	16x	data[[col]] <- vctrs::vec_fill_missing(data[[col]], "down")
142		}
143	5x	if (all(c("Measures", "Base Patient") %in% colnames(data))) {
144	!	data <- Reduce(
145	!	merge,
146	!	lapply(split(data, data$Measures), function(d) {
147	!	measure <- d$Measures[[1L]]
148	!	d[[measure]] <- d[["Base Patient"]]
149	!	d[, !(colnames(d) %in% c("Measures", "Base Patient"))]
150		})
151		)
152		}
153	5x	colnames(data) <- standard_columns(colnames(data))
154	5x	if (meta$standard_name == "obesity") {
155	!	meta$standard_name <- paste0(
156	!	meta$standard_name,
157		"_",
158	!	if ("state" %in% colnames(data)) "state" else "county"
159		)
160		} else if (
161	5x	meta$standard_name == "all_encounters" && "week" %in% colnames(data)
162		) {
163	!	meta$standard_name <- "all_encounters_weekly"
164		}
165	5x	if ("age" %in% colnames(data)) {
166	3x	std_age <- standard_age(data$age)
167	3x	missed_ages <- !is.na(data$age) & (data$age != "No value") & is.na(std_age)
168	3x	if (any(missed_ages)) {
169	!	std_age[missed_ages] <- data$age[missed_ages]
170	!	missed_levels <- unique(data$age[missed_ages])
171	!	cli::cli_warn("missed age levels: {.field {missed_levels}}")
172		}
173	3x	data$age <- std_age
174		}
175	5x	if (!("year" %in% colnames(data))) {
176	2x	if (!is.null(meta[["Session Date Range"]])) {
177	1x	data$year <- meta[["Session Date Range"]]
178		} else {
179	1x	year <- gsub(
180		"^_\|\\.$",
181		"",
182	1x	regmatches(
183	1x	basename(path),
184	1x	gregexpr("_\\d{4}\\.", basename(path))
185	1x	)[[1L]]
186		)
187	1x	if (length(year)) {
188	1x	data$year <- year
189		}
190		}
191		}
192	5x	list(metadata = meta, data = data)
193		}
194
195		standard_age <- function(age) {
196	3x	c(
197	3x	`less than 1` = "<1 Years",
198	3x	`1 and < 2` = "1-2 Years",
199	3x	`2 and < 3` = "2-3 Years",
200	3x	`3 and < 4` = "3-4 Years",
201	3x	`1 and < 5` = "1-4 Years",
202	3x	`1 year or more and less than 5` = "1-4 Years",
203	3x	`4 and < 5` = "4-5 Years",
204	3x	`less than 5` = "<5 Years",
205	3x	`5 and < 6` = "5-6 Years",
206	3x	`5 and < 18` = "5-17 Years",
207	3x	`5 or more and less than 18 (1)` = "5-17 Years",
208	3x	`6 and < 7` = "6-7 Years",
209	3x	`6 or more` = "6+ Years",
210	3x	`7 and < 8` = "7-8 Years",
211	3x	`8 and < 9` = "8-9 Years",
212	3x	`9 or more` = "9+ Years",
213	3x	`less than 10` = "<10 Years",
214	3x	`10 and < 15` = "10-14 Years",
215	3x	`less than 15` = "<15 Years",
216	3x	`15 and < 20` = "15-19 Years",
217	3x	`15 and < 25` = "15-25 Years",
218	3x	`less than 18` = "<18 Years",
219	3x	`18 and < 25` = "18-24 Years",
220	3x	`18 and < 40` = "18-39 Years",
221	3x	`18 and < 45` = "18-44 Years",
222	3x	`18 and < 50` = "18-49 Years",
223	3x	`18 or more and less than 50` = "18-49 Years",
224	3x	`20 and < 40` = "20-39 Years",
225	3x	`25 and < 35` = "25-34 Years",
226	3x	`25 and < 45` = "25-45 Years",
227	3x	`35 and < 45` = "35-44 Years",
228	3x	`40 and < 65` = "40-64 Years",
229	3x	`45 and < 55` = "45-54 Years",
230	3x	`45 and < 65` = "45-64 Years",
231	3x	`45-64` = "45-64 Years",
232	3x	`45 and < 65` = "45-64 Years",
233	3x	`50 and < 65` = "50-64 Years",
234	3x	`50 or more and less than 64` = "50-64 Years",
235	3x	`55 and < 65` = "55-64 Years",
236	3x	`less than 65` = "<65 Years",
237	3x	`65 and < 110` = "65+ Years",
238	3x	`65 or more` = "65+ Years",
239	3x	`65+` = "65+ Years",
240	3x	`total` = "Total"
241		)[
242	3x	sub(" [Yy]ears", "", sub("^[^a-z0-9]+\|:.*$", "", tolower(age)))
243		]
244		}
245
246		standard_columns <- function(cols) {
247	5x	cols <- gsub(" ", "_", sub("number of ", "n_", tolower(cols)), fixed = TRUE)
248	5x	cols[grep("^age", cols)] <- "age"
249	5x	cols[grep("^state", cols)] <- "state"
250	5x	cols[grep("^county", cols)] <- "county"
251	5x	cols[grep("bmi_30", cols, fixed = TRUE)] <- "bmi_30_49.8"
252	5x	cols[grep("hemoglobin_a1c_7", cols, fixed = TRUE)] <- "hemoglobin_a1c_7"
253	5x	cols[grep("mmr_receipt", cols, fixed = TRUE)] <- "mmr_receipt"
254	5x	cols[grep("opioid", cols, fixed = TRUE)] <- "ed_opioid"
255	5x	cols[grep("^rsv_tests", cols)] <- "rsv_tests"
256	5x	cols[grep("total:", cols, fixed = TRUE)] <- "total"
257	5x	cols
258		}

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	id_file <- paste0(id, ".json")
53	2x	metadata_file <- file.path(tempdir(), id_file)
54	2x	status <- utils::download.file(url, metadata_file, quiet = TRUE)
55	2x	if (status != 0L) {
56	!	cli::cli_abort("failed to download metadata")
57		}
58	2x	metadata <- dcf_attempt_read_json(metadata_file)
59	2x	new_state <- if (is.null(metadata$rowsUpdatedAt)) {
60	!	unname(tools::md5sum(metadata_file))
61		} else {
62	2x	metadata$rowsUpdatedAt
63		}
64	2x	recorded_count <- jsonlite::read_json(metadata_file)$columns[[
65	2x	1L
66	2x	]]$cachedContents$count
67	2x	if (!identical(paste0(new_state, ":", recorded_count), state)) {
68	2x	data_url <- paste0(sub("api/", "api/v3/", url, fixed = TRUE), "/export.csv")
69	2x	out_path <- file.path(out_dir, paste0(id, ".csv"))
70	2x	if (verbose) {
71	2x	cli::cli_progress_step("data: {.url {data_url}}")
72		}
73	2x	status <- utils::download.file(data_url, out_path, quiet = TRUE)
74	2x	if (status != 0L) {
75	!	cli::cli_abort("failed to download data")
76		}
77	2x	if (parquet) {
78	1x	if (verbose) {
79	1x	cli::cli_progress_step("writing to Parquet")
80		}
81	1x	data <- arrow::read_csv_arrow(out_path)
82	1x	new_state <- paste0(new_state, ":", nrow(data))
83	1x	arrow::write_parquet(
84	1x	data,
85	1x	compression = "gzip",
86	1x	sub(".csv", ".parquet", out_path, fixed = TRUE)
87		)
88	1x	unlink(out_path)
89		} else {
90	1x	if (verbose) {
91	1x	cli::cli_progress_step("compressing data")
92		}
93	1x	unlink(paste0(out_path, ".xz"))
94	1x	con <- file(out_path, "rb")
95	1x	new_state <- paste0(
96	1x	new_state,
97		":",
98	1x	nrow(vroom::vroom(con, col_select = 1L, col_types = "c"))
99		)
100	1x	close(con)
101	1x	status <- system2("xz", c("-f", shQuote(out_path)))
102	1x	if (status != 0L) {
103	!	cli::cli_abort("failed to compress data")
104		}
105		}
106	2x	metadata_file_final <- file.path(out_dir, id_file)
107	2x	if (file.exists(metadata_file_final)) {
108	1x	unlink(metadata_file_final)
109		}
110	2x	file.rename(metadata_file, metadata_file_final)
111	2x	if (!file.exists(metadata_file_final)) {
112	!	cli::cli_abort(
113	!	"failed to move temp file from temp location {.file {metadata_file}}"
114		)
115		}
116	2x	if (verbose) {
117	2x	cli::cli_progress_done()
118		}
119	2x	invisible(new_state)
120		} else {
121	!	unlink(metadata_file)
122	!	invisible(state)
123		}
124		}

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 <- file.path(out_dir, paste0("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	2x	if (is.numeric(age_groups)) {
248	!	age_groups <- as.character(age_groups)
249		}
250	2x	if (is.character(age_groups) && (age_groups %in% names(age_group_sets))) {
251	1x	age_groups <- age_group_sets[[as.character(age_groups)]]
252		}
253	2x	if (is.list(age_groups)) {
254	1x	pop <- cbind(
255	1x	pop[, !(colnames(pop) %in% age_levels)],
256	1x	do.call(
257	1x	cbind,
258	1x	lapply(
259	1x	age_groups,
260	1x	function(l) rowSums(pop[, colnames(pop) %in% l, drop = FALSE])
261		)
262		)
263		)
264		}
265	2x	invisible(if (state_only) pop[1L:52L, ] else pop)
266		}

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_standardize_epic(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	!	month_numbers <- epic_id_maps$months[raw_data$month]
43	!	if (anyNA(month_numbers)) {
44	!	unrecognized_months <- unique(raw_data$month[is.na(month_numbers)])
45	!	cli::cli_abort("unrecognized month{?s}: {unrecognized_months}")
46		}
47	!	raw_data$time <- paste0(
48	!	raw_data$time,
49		"-",
50	!	month_numbers
51		)
52		}
53	1x	week_col <- which(cols == "week")
54	1x	if (length(week_col)) {
55	1x	raw_data$time <- paste0(
56	1x	raw_data$time,
57		"-",
58	1x	vapply(
59	1x	strsplit(raw_data$week, "[^A-Za-z0-9]"),
60	1x	function(p) {
61	4x	paste0(
62	4x	epic_id_maps$months[[p[[1L]]]],
63		"-",
64	4x	formatC(as.integer(p[[2L]]), width = 2L, flag = "0")
65		)
66		},
67		""
68		)
69		)
70		}
71	1x	geo_col <- grep("^county", cols)
72	1x	if (!length(geo_col)) {
73	!	geo_col <- grep("^state", cols)
74		}
75	1x	if (length(geo_col)) {
76	1x	colnames(raw_data)[geo_col] <- "geography"
77	1x	raw_data$geography <- toupper(raw_data$geography)
78	1x	missing_geo <- !(raw_data$geography %in% names(region_names))
79	1x	if (any(missing_geo)) {
80	1x	geo <- sub(
81	1x	"LA ",
82	1x	"LA",
83	1x	sub("^SAINT", "ST", raw_data$geography[missing_geo]),
84	1x	fixed = TRUE
85		)
86	1x	geo[geo == "SALEM, VA"] <- "SALEM CITY, VA"
87	1x	geo[geo == "RADFORD, VA"] <- "RADFORD CITY, VA"
88	1x	geo[geo == "DONA ANA, NM"] <- "DO\u00d1A ANA, NM"
89	1x	geo[geo == "MATANUSKA SUSITNA, AK"] <- "MATANUSKA-SUSITNA, AK"
90	1x	raw_data$geography[missing_geo] <- geo
91		}
92	1x	missing_regions <- raw_data$geography[
93	1x	!(raw_data$geography %in% names(region_names))
94		]
95	1x	if (length(missing_regions)) {
96	!	cli::cli_warn(
97	!	'unrecognized regions: {paste(unique(missing_regions), collapse = "; ")}'
98		)
99		}
100	1x	raw_data$geography <- region_names[raw_data$geography]
101	1x	raw_data <- raw_data[!is.na(raw_data$geography), ]
102		}
103	1x	raw_data <- raw_data[,
104	1x	!(colnames(raw_data) %in% c("state", "county", "year", "month", "week"))
105		]
106	1x	raw_data[
107	1x	rowSums(
108	1x	!is.na(raw_data[,
109	1x	!(colnames(raw_data) %in% c("geography", "time", "age"))
110		])
111		) !=
112	1x	0L,
113		]
114		}

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 <- file.path(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, file.path(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 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 <- file.path(tempdir(), "codebook_crosswalk.csv")
93	3x	if (refresh_codebook \|\| !file.exists(codebook_file)) {
94	1x	if (verbose) {
95	1x	cli::cli_progress_step("retrieving codebook")
96		}
97	1x	codebook_req <- curl::curl_fetch_disk(
98	1x	"https://data.cms.gov/mmd-population/assets/codebook_crosswalk.csv",
99	1x	codebook_file
100		)
101	1x	if (codebook_req$status_code != 200) {
102	!	unlink(codebook_file)
103	!	cli::cli_abort("failed to retrieve codebook: {codebook_req$status_code}")
104		}
105	1x	if (verbose) cli::cli_progress_done()
106		}
107	3x	new_state <- tools::md5sum(codebook_file)
108	3x	if (!is.null(state)) {
109	1x	if (state == new_state) {
110	1x	if (verbose) {
111	1x	cli::cli_alert_info("codebook has not changed since last download")
112		}
113	1x	return(invisible(NULL))
114		}
115		}
116	2x	codebook <- vroom::vroom(
117	2x	codebook_file,
118	2x	col_types = list(
119	2x	elig = "c",
120	2x	race_code = "c",
121	2x	sex_code = "c",
122	2x	adjust = "c",
123	2x	dual = "c"
124		),
125	2x	na = " "
126		)
127	2x	codebook$description <- tolower(codebook$description)
128
129	2x	if (codebook_only) {
130	1x	return(codebook)
131		}
132
133		# identify source(s)
134	1x	if (missing(measure)) {
135	!	cli::cli_abort("specify a measure: {.value {unique(codebook$description)}}")
136		}
137
138	1x	measure_descriptions <- unique(codebook$description)
139	1x	if (nchar(measure) == 1L) {
140	!	codebook <- codebook[codebook$measure == tolower(measure), ]
141		} else {
142	1x	codebook <- codebook[
143	1x	grepl(measure, codebook$description, ignore.case = TRUE),
144		]
145		}
146	1x	if (!nrow(codebook)) {
147	!	cli::cli_abort(
148	!	paste(
149	!	'measure "{measure}" does not match the available measures:',
150	!	"{.value {measure_descriptions}}"
151		)
152		)
153		}
154
155	1x	if (is.null(population)) {
156	1x	population <- codebook$population[[1L]]
157	!	} else if (length(population) > 1L) {
158	!	cli::cli_abort("can only download 1 population at a time")
159		}
160	1x	codebook <- codebook[
161	1x	filter_codebook(codebook$population, population, "population"),
162		]
163
164	1x	if (!is.null(year)) {
165	1x	if (is.numeric(year)) {
166	1x	year <- as.character(year)
167		}
168	1x	if (any(nchar(year) > 2L)) {
169	1x	year <- substring(
170	1x	year,
171	1x	nchar(year) -
172	1x	as.integer(as.character(cut(
173	1x	as.numeric(year),
174	1x	c(
175	1x	-Inf,
176	1x	if (population == "m") 2014L else 2019L,
177	1x	Inf
178		),
179	1x	c(0L, 1L)
180		)))
181		)
182		}
183	1x	codebook <- codebook[
184	1x	filter_codebook(codebook$year, year, "year"),
185		]
186		}
187	1x	if (missing(dual_elig)) {
188	1x	dual_elig <- codebook$dual[[1L]]
189		}
190	1x	if (!is.null(dual_elig)) {
191	1x	codebook <- codebook[
192	1x	filter_codebook(codebook$dual, dual_elig, "dual_elig"),
193		]
194		}
195	1x	if (missing(medicare_elig)) {
196	1x	medicare_elig <- codebook$elig[[1L]]
197		}
198	1x	if (!is.null(medicare_elig)) {
199	1x	codebook <- codebook[
200	1x	filter_codebook(codebook$elig, medicare_elig, "medicare_elig"),
201		]
202		}
203
204		# make requests
205	1x	param_sets <- expand.grid(
206	1x	Filter(
207	1x	length,
208	1x	list(
209	1x	fltr = adjust,
210	1x	agecat = age,
211	1x	sexcat = sex,
212	1x	racecat = race,
213	1x	condition = condition,
214	1x	"_source" = unique(codebook$url)
215		)
216		),
217	1x	stringsAsFactors = FALSE
218		)
219	1x	param_sets[param_sets == "." \| param_sets == "all"] <- ".\|IS NULL"
220	1x	data_url <- paste0(
221	1x	"https://data.cms.gov/data-api/v1/mmd-tool/?_size=",
222	1x	row_limit,
223		"&"
224		)
225	1x	n_requests <- nrow(param_sets)
226	1x	all_data <- list()
227	1x	if (verbose) {
228	1x	cli::cli_h1("making requests to {data_url}")
229		}
230	1x	for (i in seq_len(n_requests)) {
231	2x	params <- as.list(param_sets[i, ])
232	2x	param_string <- paste0(names(params), "=", params, collapse = "&")
233	2x	req <- curl::curl_fetch_memory(utils::URLencode(paste0(
234	2x	data_url,
235	2x	param_string
236		)))
237	2x	if (req$status_code != 200) {
238	!	cli::cli_abort(
239	!	"a request failed: ({req$status_code}) {rawToChar(req$content)}"
240		)
241		}
242	2x	all_data[[i]] <- jsonlite::fromJSON(rawToChar(req$content))
243	2x	n_returned <- nrow(all_data[[i]])
244	2x	if (!missing(row_limit) && row_limit > 1e5 && n_requests == 1e5) {
245	!	cli::cli_warn(
246	!	"some rows may have been lost, since 100K were returned for retuest {.code param_string}"
247		)
248		}
249	2x	if (verbose) {
250	2x	cli::cli_progress_step(
251	2x	paste0(
252	2x	i,
253	2x	" of ",
254	2x	n_requests,
255		" (",
256	2x	n_returned,
257	2x	" rows): ",
258	2x	param_string
259		),
260	2x	spinner = TRUE
261		)
262		}
263		}
264	1x	if (verbose) {
265	1x	cli::cli_progress_done()
266		}
267
268	1x	all_data <- do.call(rbind, all_data)
269	1x	if (!is.null(out_file)) {
270	1x	dir.create(dirname(out_file), showWarnings = FALSE, recursive = TRUE)
271	1x	if (parquet \|\| grepl(".parquet", out_file, fixed = TRUE)) {
272	1x	if (verbose) {
273	1x	cli::cli_progress_step("writing to Parquet")
274		}
275	1x	arrow::write_parquet(
276	1x	all_data,
277	1x	compression = "gzip",
278	1x	sub(".csv", ".parquet", out_file, fixed = TRUE)
279		)
280		} else {
281	!	if (verbose) {
282	!	cli::cli_progress_step("writing to CSV")
283		}
284	!	vroom::vroom_write(all_data, out_file, ",")
285		}
286		}
287	1x	invisible(list(
288	1x	codebook_state = new_state,
289	1x	codebook = codebook,
290	1x	data = all_data
291		))
292		}
293
294		filter_codebook <- function(x, values, column) {
295	4x	su <- x %in% values
296	4x	if (!any(su)) {
297	!	cli::cli_abort(
298	!	paste(
299	!	'{.arg {column}} does not contain specified values.',
300	!	"Available values: {.value {unique(x)}}"
301		)
302		)
303		}
304	4x	su
305		}
306
307		#' @rdname dcf_download_cmsmmd
308		#' @param raw_data The raw data as downloaded with \code{dcf_download_cmsmmd} to be standardized.
309		#' @returns \code{dcf_standardize_cmsmmd}: If \code{raw_data} is \code{NULL}, a list
310		#' with an entry for each API parameter, containing named vectors with level codes as names
311		#' mapping to level values (as they appear in the tool's menus).
312		#' Otherwise, a version of \code{raw_data} with coded values converted to labels.
313		#' @export
314
315		dcf_standardize_cmsmmd <- function(raw_data = NULL) {
316		# extracted from https://data.cms.gov/mmd-population/js/menus.js
317	1x	menu <- jsonlite::read_json(
318	1x	system.file(
319	1x	"support_data/cms_mmd_levels.json.gz",
320	1x	package = "dcf"
321		)
322		)
323	1x	levels <- lapply(
324	1x	menu,
325	1x	function(e) {
326	18x	options <- Filter(
327	18x	length,
328	18x	lapply(e$options, function(o) {
329	269x	if (length(o$val)) {
330	255x	o$val <- as.character(o$val)
331	255x	o
332		}
333		})
334		)
335	18x	c(
336	18x	structure(
337	18x	vapply(options, "[[", "", "disp"),
338	18x	names = vapply(options, "[[", "", "val")
339		)
340		)
341		}
342		)
343	1x	names(levels) <- vapply(menu, "[[", "", "id")
344	1x	levels$geography["n"] <- "National"
345	1x	levels$fltr <- levels$adjust
346	1x	levels$sex <- levels$sexcat <- levels$sex_code
347	1x	levels$race <- levels$racecat <- levels$race_code
348	1x	levels$age <- levels$agecat <- levels$age_group
349	1x	levels$eligcat <- levels$medicare_elig <- levels$eligibility
350	1x	levels$dual_elig <- levels$dual
351	1x	if (is.null(raw_data)) {
352	!	return(levels)
353		}
354	1x	for (col in colnames(raw_data)) {
355	12x	col_levels <- levels[[col]]
356	12x	if (!is.null(col_levels)) {
357	10x	values <- as.character(raw_data[[col]])
358	10x	values[values == ""] <- "."
359	10x	raw_data[[col]] <- c(col_levels, "." = "All")[values]
360		}
361		}
362	1x	raw_data
363		}

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

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)) {
131	2x	intent <- tolower(intent)
132	2x	if (!(intent %in% names(intents))) {
133	!	cli::cli_abort("intent {intent} not found")
134		}
135	2x	intents[[intent]]
136		} else {
137	!	intent
138		},
139	2x	mech = mechanism,
140	2x	sex = paste(
141	2x	vapply(sex, function(l) if (is.character(l)) sexes[[l]] else l, 0),
142	2x	collapse = ","
143		),
144	2x	race = paste(
145	2x	vapply(race, function(l) if (is.character(l)) races[[l]] else l, 0),
146	2x	collapse = ","
147		),
148	2x	race_yr = if (is.character(race_reporting)) {
149	2x	race_reportings[[race_reporting]]
150		} else {
151	!	race_reporting
152		},
153	2x	year1 = year_start,
154	2x	year2 = year_end,
155	2x	agebuttn = if (is.null(group_ages)) {
156	2x	"ALL"
157	2x	} else if (group_ages) {
158	!	"5Yr"
159		} else {
160	!	"custom"
161		},
162	2x	fiveyr1 = age_min,
163	2x	fiveyr2 = age_max,
164	2x	c_age1 = age_min,
165	2x	c_age2 = age_max,
166	2x	groupby1 = "NONE",
167	2x	groupby2 = "NONE",
168	2x	groupby3 = "NONE",
169	2x	groupby4 = "NONE",
170	2x	groupby5 = "NONE",
171	2x	groupby6 = "NONE"
172		)
173	2x	if (fatal_outcome) {
174	1x	params$state <- geography
175	1x	params$ethnicty <- paste(
176	1x	vapply(
177	1x	ethnicity,
178	1x	function(l) if (is.character(l)) ethnicities[[l]] else l,
179	1x	0
180		),
181	1x	collapse = ","
182		)
183	1x	params$ypllage <- YPLL
184	1x	params$urbrul <- if (is.null(metro)) {
185	1x	0
186	1x	} else if (metro) {
187	!	1
188		} else {
189	!	2
190		}
191	1x	params$tbi <- if (brain_injury_only) 1L else 0L
192		} else {
193	1x	params$groupby1 <- "NONE1"
194	1x	params$groupby2 <- "NONE2"
195	1x	params$groupby3 <- "NONE3"
196	1x	params$groupby4 <- "NONE4"
197	1x	params$groupby5 <- "NONE5"
198	1x	params$groupby6 <- "NONE6"
199	1x	params$outcome <- "NFI"
200	1x	params$racethn <- 0
201	1x	params$disp <- paste(
202	1x	vapply(
203	1x	disposition,
204	1x	function(l) if (is.character(l)) dispositions[[l]] else l,
205	1x	0
206		),
207	1x	collapse = ","
208		)
209		}
210	2x	for (group in seq_along(group_by)) {
211	!	params[[paste0("groupby", group)]] <- toupper(group_by[[group]])
212		}
213	2x	params <- lapply(params, as.character)
214	2x	if (fatal_outcome) {
215	1x	params$app_id <- 1002
216	1x	params$component_id <- 1000
217		}
218
219	2x	if (verbose) {
220	2x	url <- paste0(
221	2x	"https://wisqars.cdc.gov/reports/?o=",
222	2x	if (fatal_outcome) "MORT" else "NFI"
223		)
224	2x	if (!fatal_outcome) {
225	1x	url <- paste0(url, "&g=00&me=")
226		}
227	2x	url_param_map <- list(
228	2x	year1 = "y1",
229	2x	year2 = "y2",
230	2x	tbi = "t",
231	2x	disp = "d",
232	2x	state = "g",
233	2x	ethnicty = "e",
234	2x	intent = "i",
235	2x	mech = "m",
236	2x	sex = "s",
237	2x	race = "r",
238	2x	agebuttn = "a",
239	2x	urbrul = "me",
240	2x	race_yr = "ry",
241	2x	ypllage = "yp",
242	2x	fiveyr1 = "g1",
243	2x	fiveyr2 = "g2",
244	2x	c_age1 = "a1",
245	2x	c_age2 = "a2",
246	2x	groupby1 = "r1",
247	2x	groupby2 = "r2",
248	2x	groupby3 = "r3",
249	2x	groupby4 = "r4",
250	2x	groupby5 = "r5",
251	2x	groupby6 = "r6"
252		)
253	2x	for (k in names(params)) {
254	48x	url_key <- url_param_map[[k]]
255	48x	if (!is.null(url_key)) {
256	42x	for (value in params[[k]]) {
257	42x	url <- paste0(url, "&", url_key, "=", value)
258		}
259		}
260		}
261	2x	cli::cli_alert_info("requesting report {.url {url}}")
262		}
263
264	2x	handler <- curl::new_handle()
265	2x	curl::handle_setheaders(handler, "Content-Type" = "application/json")
266	2x	curl::handle_setopt(
267	2x	handler,
268	2x	copypostfields = jsonlite::toJSON(
269	2x	list(parameters = params),
270	2x	auto_unbox = TRUE
271		)
272		)
273	2x	req <- curl::curl_fetch_memory(
274	2x	paste0(
275	2x	"https://wisqars.cdc.gov/api/cost-",
276	2x	if (fatal_outcome) "fatal" else "nonfatal"
277		),
278	2x	handle = handler
279		)
280	2x	if (req$status_code == 200) {
281	2x	dir.create(dirname(file), FALSE, TRUE)
282	2x	data <- jsonlite::fromJSON(rawToChar(req$content))
283	2x	if (!length(data)) {
284	!	cli::cli_warn("no rows in data, so no file written")
285		} else {
286	2x	if (grepl("parquet", file)) {
287	!	arrow::write_parquet(data, file, compression = "gzip")
288		} else {
289	2x	vroom::vroom_write(data, file, ",")
290		}
291		}
292		} else {
293	!	cli::cli_abort("request failed: {req$status_code}")
294		}
295	2x	invisible(params)
296		}

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	(if (is.null(variables)) {
77	!	TRUE
78		} else {
79	3x	grepl(
80	3x	paste0("^(?:", paste(variables, collapse = "\|"), ")$"),
81	3x	all_variables$name
82		)
83		}),
84		]
85		} else {
86	1x	if (!all(c("name", "file") %in% colnames(variables))) {
87	!	cli::cli_abort(
88	!	"`variables` must include `name` and `file` columns if not a character vector"
89		)
90		}
91	1x	all_variables <- selected <- variables
92	1x	variables <- selected$name
93		}
94	4x	if (!is.null(data_format)) {
95	2x	selected <- selected[selected$data_format == data_format, ]
96		}
97	4x	if (nrow(selected) == 0L) {
98	!	cli::cli_abort("no variables found")
99		}
100	4x	not_found <- if (is.null(variables)) {
101	!	character()
102		} else {
103	4x	variables[!(variables %in% selected$name)]
104		}
105	4x	if (length(not_found)) {
106	!	cli::cli_abort("variable{?/s} not found: {not_found}")
107		}
108	4x	data_dir <- report$settings$data_dir
109	4x	files <- unique(selected$file)
110	4x	project_outputs <- gsub("^[^/]+/\|/[^/]+$", "", files)
111	4x	project_metadata <- report$metadata[
112	4x	names(report$metadata) %in% project_outputs
113		]
114	4x	file_metadata <- list()
115	4x	for (output in names(project_metadata)) {
116	6x	datapackage <- project_metadata[[output]]
117	6x	for (i in seq_along(datapackage$resources)) {
118	15x	resource_file <- paste(
119	15x	data_dir,
120	15x	output,
121	15x	datapackage$resources[[i]]$filename,
122	15x	sep = "/"
123		)
124	15x	if (resource_file %in% files) {
125	6x	file_metadata[[resource_file]] <- datapackage$resources[[i]]
126		}
127		}
128		}
129	4x	file_metadata <- file_metadata[files]
130
131		# download files to cache if needed
132	4x	if (identical(report$settings$report_url, "")) {
133	2x	if (verbose) {
134	2x	cli::cli_alert_info("loading files from local project")
135		}
136	2x	project_root <- project
137		} else {
138	2x	project_root <- normalizePath(file.path(cache, project), "/", FALSE)
139	2x	if (verbose) {
140	2x	cli::cli_alert_info("downloading files to cache: {project_root}")
141		}
142	2x	base_url <- dirname(report$settings$report_url)
143	2x	for (file in files) {
144	4x	cached_file <- file.path(project_root, file)
145	4x	if (refresh \|\| !file.exists(cached_file)) {
146	2x	file_url <- file.path(base_url, file)
147	2x	dir.create(dirname(cached_file), FALSE, TRUE)
148	2x	req <- curl::curl_fetch_disk(file_url, cached_file)
149	2x	if (req$status_code != 200L) {
150	!	unlink(cached_file)
151	!	cli::cli_warn("failed to download {.url {file_url}}")
152		}
153		}
154		}
155	2x	if (verbose) cli::cli_alert_info("loading files from cache project")
156		}
157
158		# load files
159	4x	n_files <- length(files)
160	4x	if (verbose) {
161	4x	cli::cli_progress_bar("loading files", "download", total = n_files)
162		}
163	4x	data <- list()
164	4x	data_tall <- structure(logical(n_files), names = files)
165	4x	for (file in files) {
166	6x	data[[file]] <- attempt_read(file.path(project_root, file))
167	6x	data[[file]]$source_file <- file
168	6x	if (identical(file_metadata[[file]]$data_format, "tall")) {
169	1x	data_tall[[file]] <- TRUE
170		}
171	6x	if (verbose) cli::cli_progress_update()
172		}
173	4x	if (verbose) {
174	4x	cli::cli_progress_done()
175		}
176
177	4x	if (unify) {
178	4x	if (length(data) > 1L) {
179	2x	all_cols <- unique(unlist(lapply(data, colnames)))
180	2x	if (!any(data_tall)) {
181	2x	id_cols <- c("geography", "time", "age")
182	2x	id_cols <- id_cols[id_cols %in% all_cols]
183	2x	if (only_selected) {
184	!	all_cols <- all_cols[all_cols %in% c(id_cols, selected$name)]
185		}
186	2x	data <- dplyr::as_tibble(Reduce(
187	2x	function(x, y) merge(x, y, id_cols, all = TRUE),
188	2x	lapply(
189	2x	data,
190	2x	function(d) {
191	4x	for (col in id_cols[!(id_cols %in% colnames(d))]) {
192	2x	d[[col]] <- NA
193		}
194	4x	if (only_selected) {
195	!	d <- d[, all_cols[all_cols %in% colnames(d)]]
196		}
197	4x	d[, colnames(d) != "source_file"]
198		}
199		)
200		))
201	!	} else if (all(data_tall)) {
202	!	data <- do.call(
203	!	dplyr::bind_rows,
204	!	lapply(files, function(file) {
205	!	d <- data[[file]]
206	!	if (only_selected) {
207	!	measure_col <- unlist(lapply(
208	!	file_metadata[[file]]$schema$fields,
209	!	function(field) {
210	!	if ("levels" %in% names(field$info)) field$name else NULL
211		}
212		))
213	!	d <- d[d[[measure_col]] %in% selected$name, ]
214		}
215	!	for (col in all_cols[!(all_cols %in% colnames(d))]) {
216	!	d[[col]] <- NA
217		}
218	!	d[, all_cols]
219		})
220		)
221		} else {
222	!	cli::cli_warn(
223	!	"datasets are in inconsistent formats, so will not be unified"
224		)
225		}
226		} else {
227	2x	data <- data[[1L]]
228		}
229		}
230
231	4x	invisible(list(metadata = file_metadata, data = data))
232		}

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)) {
54	15x	"bundle"
55		} else {
56	21x	"source"
57		}
58	36x	n_rows <- resource$row_count
59	36x	data_format <- if (is.null(resource$data_format)) {
60	!	"wide"
61		} else {
62	36x	resource$data_format
63		}
64	36x	do.call(
65	36x	rbind,
66	36x	Filter(
67	36x	length,
68	36x	if (data_format == "tall") {
69	10x	lapply(resource$schema$fields, function(field) {
70	44x	if ("levels" %in% names(field$info)) {
71	10x	do.call(
72	10x	rbind,
73	10x	lapply(
74	10x	field$info$levels,
75	10x	function(level) {
76	28x	n <- field$table[[level$id]]
77	28x	level_row(
78	28x	level,
79	28x	if (is.null(n)) 0L else n,
80	28x	file,
81	28x	project_type
82		)
83		}
84		)
85		)
86		}
87		})
88		} else {
89	26x	lapply(resource$schema$fields, function(field) {
90	156x	if (length(exclude) && field$name %in% exclude) {
91	56x	return(NULL)
92		}
93	100x	info <- field$info
94	100x	if ("info" %in% names(info)) {
95	!	info <- info$info
96		}
97	100x	if (is.null(info) && !is.null(measure_info)) {
98	!	info <- measure_info[[field$name]]
99		}
100	100x	cbind(
101	100x	data.frame(
102	100x	name = field$name,
103	100x	type = field$type,
104	100x	n = n_rows - field$missing,
105	100x	duplicates = field$duplicates,
106	100x	missing = field$missing,
107	100x	project_type = project_type,
108	100x	data_format = "wide",
109	100x	file = file
110		),
111	100x	unpack_info(info)
112		)
113		})
114		}
115		)
116		)
117		})
118		)
119		})
120		))
121		}
122
123		unpack_info <- function(info) {
124	128x	unpacked <- data.frame(
125	128x	short_name = NA_character_,
126	128x	long_name = NA_character_,
127	128x	short_description = NA_character_,
128	128x	long_description = NA_character_,
129	128x	measure_type = NA_character_,
130	128x	unit = NA_character_,
131	128x	time_resolution = NA_character_,
132	128x	category = NA_character_,
133	128x	subcategory = NA_character_
134		)
135	128x	info_names <- names(info)
136	128x	if ("name" %in% info_names && !("short_name" %in% info_names)) {
137	!	info$short_name <- info$name
138		}
139	128x	if ("description" %in% info_names && !("short_description" %in% info_names)) {
140	!	info$short_description <- info$description
141		}
142	128x	info_names <- names(info)
143	128x	for (name in colnames(unpacked)) {
144	1152x	if (name %in% info_names) {
145	826x	unpacked[[name]] <- info[[name]]
146		}
147		}
148	128x	unpacked
149		}
150
151		level_row <- function(level, n, file, project_type) {
152	28x	cbind(
153	28x	data.frame(
154	28x	name = if (is.null(level$id)) NA_character_ else level$id,
155	28x	type = if (is.null(level$type)) NA_character_ else level$type,
156	28x	n = n,
157	28x	duplicates = NA_integer_,
158	28x	missing = NA_integer_,
159	28x	project_type = project_type,
160	28x	data_format = "tall",
161	28x	file = file
162		),
163	28x	unpack_info(level$info)
164		)
165		}

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	vs <- dcf_git_versions(basename(path), dirname(path))
51		}
52	3x	if (versions) {
53	1x	return(vs)
54		}
55	2x	if (!is.null(date)) {
56	1x	if (nrow(vs) == 0L) {
57	!	return(path)
58		}
59	1x	if (is.character(date)) {
60	1x	date <- as.POSIXct(
61	1x	date,
62	1x	tryFormats = c(
63	1x	"%Y-%m-%d %H:%M:%S",
64	1x	"%Y-%m-%d %H:%M",
65	1x	"%Y-%m-%d",
66	1x	"%Y-%m",
67	1x	"%Y"
68		),
69	1x	tz = "UTC"
70		)
71		}
72	1x	commit_hash <- vs$hash[which.min(abs(
73	1x	as.POSIXct(vs$date, "%a %b %d %H:%M:%S %Y", tz = "UTC") - date
74		))]
75		}
76	2x	if (is.null(commit_hash)) {
77	!	return(path)
78		}
79	2x	name_parts <- strsplit(basename(path), ".", fixed = TRUE)[[1L]]
80	2x	out_path <- file.path(
81	2x	tempdir(),
82	2x	paste0(
83	2x	name_parts[[1L]],
84		"-",
85	2x	substring(commit_hash, 1L, 6L),
86		".",
87	2x	paste(name_parts[-1L], collapse = ".")
88		)
89		)
90	2x	if (file.exists(out_path)) {
91	!	return(out_path)
92		}
93	2x	wd <- getwd()
94	2x	on.exit(setwd(wd), TRUE)
95	2x	setwd(dirname(path))
96	2x	status <- sys::exec_wait(
97	2x	"git",
98	2x	c("show", paste0(commit_hash, ":./", basename(path))),
99	2x	std_out = out_path
100		)
101	2x	setwd(wd)
102	2x	if (status != 0L) {
103	!	unlink(out_path)
104	!	cli::cli_abort("failed to git show: {status}")
105		}
106	2x	out_path
107		}

1		#' Process Epic Staging Files
2		#'
3		#' Process Epic staging 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[[1L]]]] <- paste0(
77	!	"n_",
78	!	epic$metadata$standard_name
79		)
80		}
81	2x	if (!is.null(data[[name]])) {
82	1x	cols <- colnames(data[[name]])
83	1x	cols <- cols[!(cols %in% colnames(epic$data))]
84	1x	if (length(cols)) {
85	!	epic$data[, cols] <- NA
86		}
87	1x	epic$data <- epic$data[, colnames(data[[name]])]
88	1x	file_id_cols <- file_id_cols[file_id_cols %in% colnames(data[[name]])]
89	1x	data[[name]] <- data[[name]][
90	1x	!(do.call(paste, data[[name]][, file_id_cols, drop = FALSE]) %in%
91	1x	do.call(paste, epic$data[, file_id_cols, drop = FALSE])),
92		]
93		}
94	2x	data[[name]] <- rbind(epic$data, data[[name]])
95	2x	if (verbose) cli::cli_progress_done()
96		}
97	1x	for (name in names(metadata)) {
98	1x	if (verbose) {
99	1x	cli::cli_progress_step(
100	1x	"writing standard raw output for {.field {name}}",
101	1x	spinner = TRUE
102		)
103		}
104	1x	paths <- file.path(out_dir, paste0(name, ".", c("json", "csv.xz")))
105	1x	jsonlite::write_json(
106	1x	metadata[[name]],
107	1x	paths[[1L]],
108	1x	auto_unbox = TRUE,
109	1x	pretty = TRUE
110		)
111	1x	vroom::vroom_write(data[[name]], paths[[2L]], ",")
112	1x	if (cleanup) {
113	1x	unlink(vapply(metadata[[name]], "[[", "", "file"))
114		}
115	1x	if (verbose) cli::cli_process_done()
116		}
117	1x	return(list(metadata = metadata, data = data))
118		}

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(file.path(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	!	base_dir <- dirname(base_dir)
50		} else {
51	1x	name <- gsub("[^A-Za-z0-9]+", "_", name)
52		}
53	1x	base_path <- file.path(base_dir, name)
54	1x	dir.create(base_path, showWarnings = FALSE, recursive = TRUE)
55	1x	paths <- file.path(
56	1x	base_path,
57	1x	c(
58	1x	"project.Rproj",
59	1x	"settings.json",
60	1x	"README.md",
61	1x	"scripts/build.R",
62	1x	".github/workflows/build.yaml",
63	1x	".gitignore",
64	1x	"measure_info.json"
65		)
66		)
67		if (
68	1x	!file.exists(paths[[1L]]) && !length(list.files(base_path, "\\.Rproj$"))
69		) {
70	1x	writeLines("Version: 1.0\n", paths[[1L]])
71		}
72	1x	if (!file.exists(paths[[2L]])) {
73	1x	jsonlite::write_json(
74	1x	list(
75	1x	name = name,
76	1x	data_dir = data_dir,
77	1x	github_account = github_account,
78	1x	branch = branch,
79	1x	repo_name = repo_name
80		),
81	1x	paths[[2L]],
82	1x	auto_unbox = TRUE,
83	1x	pretty = TRUE
84		)
85		}
86	1x	if (!file.exists(paths[[3L]])) {
87	1x	writeLines(
88	1x	paste0(
89	1x	c(
90	1x	paste("#", name),
91		"",
92	1x	"This is a Data Collection Framework project, initialized with `dcf::dcf_init`.",
93		"",
94	1x	"You can us the `dcf` package to check the source projects:",
95		"",
96	1x	"```R",
97	1x	"dcf::dcf_check()",
98		"```",
99		"",
100	1x	"And process them:",
101		"",
102	1x	"```R",
103	1x	"dcf::dcf_process()",
104		"```"
105		),
106	1x	collapse = "\n"
107		),
108	1x	paths[[3L]]
109		)
110		}
111	1x	if (!file.exists(paths[[4L]])) {
112	1x	dir.create(dirname(paths[[4L]]), showWarnings = FALSE)
113	1x	writeLines(
114	1x	paste(c("library(dcf)", "dcf_build()"), collapse = "\n"),
115	1x	paths[[4L]]
116		)
117		}
118	1x	if (!file.exists(paths[[5L]])) {
119	1x	dir.create(dirname(paths[[5L]]), recursive = TRUE, showWarnings = FALSE)
120	1x	file.copy(system.file("workflows/build.yaml", package = "dcf"), paths[[5L]])
121		}
122	1x	if (use_git) {
123	1x	dcf_init_git(base_path)
124	1x	if (!file.exists(paths[[6L]])) {
125	1x	writeLines(
126	1x	paste(
127	1x	c(
128	1x	"*.Rproj",
129	1x	".Rproj.user",
130	1x	"*.Rprofile",
131	1x	"*.Rhistory",
132	1x	"*.Rdata",
133	1x	".DS_Store",
134	1x	"renv"
135		),
136	1x	collapse = "\n"
137		),
138	1x	paths[[6L]]
139		)
140		}
141		}
142	1x	if (!file.exists(paths[[7L]])) {
143	1x	dcf_measure_info(
144	1x	paths[[7L]],
145	1x	info = list(
146	1x	geography = list(
147	1x	id = "geography",
148	1x	name = "Location",
149	1x	description = "Location ID.",
150	1x	measure_type = "id"
151		),
152	1x	time = list(
153	1x	id = "time",
154	1x	name = "Time",
155	1x	description = "Date and/or time.",
156	1x	measure_type = "time"
157		)
158		),
159	1x	include_empty = FALSE,
160	1x	verbose = FALSE,
161	1x	open_after = FALSE
162		)
163		}
164	1x	if (open_after && rstudioapi::isAvailable()) {
165	!	rstudioapi::openProject(paths[[1L]], newSession = TRUE)
166		}
167		}

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

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 <- file.path(tempdir(), "temp_project")
61		#' dcf_init("temp_project", dirname(project_dir))
62		#' dcf_add_bundle("bundle_name", project_dir)
63		#' list.files(file.path(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(file.path(project_dir, "settings.json"))
80	4x	base_dir <- file.path(project_dir, dcf_read_settings(project_dir)$data_dir)
81	4x	base_path <- file.path(base_dir, name)
82	4x	if (!is.null(source_files)) {
83	2x	source_paths <- file.path(
84	2x	base_dir,
85	2x	if (is.null(names(source_files))) source_files else names(source_files)
86		)
87	2x	su <- !file.exists(source_paths)
88	2x	if (any(su)) {
89	!	missing_source_files <- source_paths[su]
90	!	cli::cli_abort(
91	!	"source file{? doesn't/s don't} exist: {missing_source_files}"
92		)
93		}
94		}
95	4x	dir.create(
96	4x	file.path(base_path, "dist"),
97	4x	showWarnings = FALSE,
98	4x	recursive = TRUE
99		)
100	4x	paths <- file.path(
101	4x	base_path,
102	4x	c(
103	4x	"README.md",
104	4x	"project.Rproj",
105	4x	"process.json",
106	4x	"measure_info.json",
107	4x	"build.R",
108	4x	"README.md",
109	4x	".gitignore",
110	4x	".github/workflows/process.yaml"
111		)
112		)
113	4x	if (!file.exists(paths[[1L]])) {
114	2x	writeLines(
115	2x	paste0(
116	2x	c(
117	2x	paste("#", name),
118		"",
119	2x	"This is a Data Collection Framework data bundle project, initialized with `dcf::dcf_add_bundle`.",
120		"",
121	2x	"You can us the `dcf` package to rebuild the bundle:",
122		"",
123	2x	"```R",
124	2x	paste0('dcf::dcf_process("', name, '", "..")'),
125		"```"
126		),
127	2x	collapse = "\n"
128		),
129	2x	paths[[1L]]
130		)
131		}
132	4x	if (!file.exists(paths[[2L]])) {
133	2x	writeLines("Version: 1.0\n", paths[[2L]])
134		}
135	4x	if (!file.exists(paths[[3L]])) {
136	2x	jsonlite::write_json(
137	2x	list(
138	2x	name = name,
139	2x	type = "bundle",
140	2x	scripts = list(
141	2x	list(
142	2x	path = "build.R",
143	2x	last_run = "",
144	2x	run_time = "",
145	2x	last_status = list(log = "", success = TRUE)
146		)
147		),
148	2x	source_files = if (!is.null(names(source_files))) {
149	2x	as.list(source_files)
150		} else {
151	!	source_files
152		}
153		),
154	2x	paths[[3L]],
155	2x	auto_unbox = TRUE,
156	2x	pretty = TRUE
157		)
158		}
159	4x	if (!file.exists(paths[[4L]])) {
160	2x	writeLines("{}\n", paths[[4L]])
161		}
162	4x	if (!file.exists(paths[[5L]])) {
163	2x	writeLines(
164	2x	paste0(
165	2x	c(
166	2x	"# read data from data source projects",
167	2x	"# and write to this project's `dist` directory",
168		""
169		),
170	2x	collapse = "\n"
171		),
172	2x	paths[[5L]]
173		)
174		}
175	4x	if (!file.exists(paths[[6L]])) {
176	!	writeLines(
177	!	paste0(
178	!	c(
179	!	paste("#", name),
180		"",
181	!	"This is a dcf data bundle project, initialized with `dcf::dcf_add_bundle`.",
182		"",
183	!	"You can use the `dcf` package to check the project:",
184		"",
185	!	"```R",
186	!	"dcf_check()",
187		"```",
188		"",
189	!	"And process it:",
190		"",
191	!	"```R",
192	!	"dcf_process()",
193		"```"
194		),
195	!	collapse = "\n"
196		),
197	!	paths[[6L]]
198		)
199		}
200	4x	if (is_standalone) {
201	!	if (use_git) {
202	!	dcf_init_git(base_path)
203	!	if (!file.exists(paths[[7L]])) {
204	!	writeLines(
205	!	paste(
206	!	c(
207	!	"*.Rproj",
208	!	".Rproj.user",
209	!	"*.Rprofile",
210	!	"*.Rhistory",
211	!	"*.Rdata",
212	!	".DS_Store",
213	!	"renv"
214		),
215	!	collapse = "\n"
216		),
217	!	paths[[7L]]
218		)
219		}
220		}
221	!	if (use_workflow && !file.exists(paths[[8L]])) {
222	!	dir.create(dirname(paths[[8L]]), recursive = TRUE, showWarnings = FALSE)
223	!	file.copy(
224	!	system.file("workflows/build.yaml", package = "dcf"),
225	!	paths[[8L]]
226		)
227		}
228		}
229	!	if (open_after) rstudioapi::openProject(paths[[2L]], newSession = TRUE)
230		}

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 <- file.path(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 <- file.path(
56	3x	cache,
57	3x	project,
58	3x	paste0(
59	3x	"report-",
60	3x	branch,
61	3x	if (length(commit)) paste0("-", commit),
62	3x	".json.gz"
63		)
64		)
65	3x	report_url <- paste0(
66	3x	provider,
67		"/",
68	3x	project,
69	3x	"/raw/",
70	3x	if (is.null(commit)) paste0("refs/heads/", branch) else commit,
71	3x	"/report.json.gz"
72		)
73	3x	if (refresh \|\| !file.exists(report_file)) {
74	1x	dir.create(dirname(report_file), FALSE, TRUE)
75	1x	req <- curl::curl_fetch_disk(report_url, report_file)
76	1x	if (req$status_code != 200L) {
77	!	unlink(report_file)
78	!	cli::cli_abort(
79	!	"failed to retrieve report at {report_url}: {req$status_code}, {req$content}"
80		)
81		}
82		}
83		}
84	7x	report <- dcf_attempt_read_json(report_file)
85	7x	report$settings$report_url <- report_url
86	7x	invisible(report)
87		}

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 <- file.path(tempdir(), "temp_project")
67		#' dcf_init("temp_project", dirname(project_dir))
68		#' dcf_add_source("source_name", project_dir)
69		#' list.files(file.path(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 (missing(name) \|\| is.null(name) \|\| name == project_dir) {
80	!	cli::cli_abort("provide a name")
81		}
82	8x	name <- gsub("[^A-Za-z0-9]+", "_", name)
83	8x	is_standalone <- !file.exists(file.path(project_dir, "settings.json"))
84	8x	data_dir <- dcf_read_settings(project_dir)$data_dir
85	8x	base_dir <- file.path(project_dir, data_dir)
86	8x	base_path <- file.path(base_dir, name)
87	8x	dir.create(
88	8x	file.path(base_path, "raw"),
89	8x	showWarnings = FALSE,
90	8x	recursive = TRUE
91		)
92	8x	dir.create(file.path(base_path, "standard"), showWarnings = FALSE)
93	8x	paths <- file.path(
94	8x	base_path,
95	8x	c(
96	8x	"measure_info.json",
97	8x	"ingest.R",
98	8x	"project.Rproj",
99	8x	"standard/datapackage.json",
100	8x	"process.json",
101	8x	"README.md",
102	8x	".gitignore",
103	8x	".github/workflows/process.yaml"
104		)
105		)
106	8x	if (!file.exists(paths[[1L]])) {
107	2x	dcf_measure_info(
108	2x	paths[[1L]],
109	2x	example_variable = list(),
110	2x	verbose = FALSE,
111	2x	open_after = FALSE
112		)
113		}
114	8x	if (!file.exists(paths[[2L]])) {
115	2x	writeLines(
116	2x	paste0(
117	2x	c(
118		"#",
119	2x	"# Download",
120		"#",
121		"",
122	2x	"# add files to the `raw` directory",
123		"",
124		"#",
125	2x	"# Reformat",
126		"#",
127		"",
128	2x	"# read from the `raw` directory, and write to the `standard` directory",
129		""
130		),
131	2x	collapse = "\n"
132		),
133	2x	paths[[2L]]
134		)
135		}
136	8x	if (!file.exists(paths[[3L]])) {
137	2x	writeLines("Version: 1.0\n", paths[[3L]])
138		}
139	8x	if (!file.exists(paths[[4L]])) {
140	2x	dcf_datapackage_init(
141	2x	name,
142	2x	dir = file.path(base_path, "standard"),
143	2x	quiet = TRUE
144		)
145		}
146
147	8x	if (!file.exists(paths[[5L]])) {
148	2x	dcf_process_record(
149	2x	paths[[5L]],
150	2x	list(
151	2x	name = name,
152	2x	type = "source",
153	2x	scripts = list(
154	2x	list(
155	2x	path = "ingest.R",
156	2x	manual = FALSE,
157	2x	frequency = 0L,
158	2x	last_run = "",
159	2x	run_time = "",
160	2x	last_status = list(log = "", success = TRUE)
161		)
162		),
163	2x	checked = "",
164	2x	check_results = list(),
165	2x	standalone = is_standalone
166		)
167		)
168		}
169	8x	if (!file.exists(paths[[6L]])) {
170	2x	writeLines(
171	2x	paste0(
172	2x	c(
173	2x	paste("#", name),
174		"",
175	2x	"This is a dcf data source project, initialized with `dcf::dcf_add_source`.",
176		"",
177	2x	"You can use the `dcf` package to check the project:",
178		"",
179	2x	"```R",
180	2x	"dcf_check()",
181		"```",
182		"",
183	2x	"And process it:",
184		"",
185	2x	"```R",
186	2x	"dcf_process()",
187		"```"
188		),
189	2x	collapse = "\n"
190		),
191	2x	paths[[6L]]
192		)
193		}
194	8x	if (is_standalone) {
195	2x	if (use_git) {
196	1x	dcf_init_git(base_path)
197	1x	if (!file.exists(paths[[7L]])) {
198	1x	writeLines(
199	1x	paste(
200	1x	c(
201	1x	"*.Rproj",
202	1x	".Rproj.user",
203	1x	"*.Rprofile",
204	1x	"*.Rhistory",
205	1x	"*.Rdata",
206	1x	".DS_Store",
207	1x	"renv"
208		),
209	1x	collapse = "\n"
210		),
211	1x	paths[[7L]]
212		)
213		}
214		}
215	2x	if (use_workflow && !file.exists(paths[[8L]])) {
216	!	dir.create(dirname(paths[[8L]]), recursive = TRUE, showWarnings = FALSE)
217	!	file.copy(
218	!	system.file("workflows/process.yaml", package = "dcf"),
219	!	paths[[8L]]
220		)
221		}
222		}
223	!	if (open_after) rstudioapi::openProject(paths[[3L]], newSession = TRUE)
224		}

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	68x	if (is.null(updated)) {
21	37x	if (!file.exists(path)) {
22	!	cli::cli_abort("process file {path} does not exist")
23		}
24	37x	spec <- dcf_attempt_read_json(path)
25	37x	if (is.null(spec$name)) {
26	!	spec$name <- basename(dirname(path))
27		}
28	37x	if (is.null(spec$type)) {
29	!	spec$type <- "source"
30		}
31	37x	spec
32		} else {
33	31x	if (is.null(updated$type)) {
34	!	updated$type <- "source"
35		}
36	31x	jsonlite::write_json(updated, path, auto_unbox = TRUE, pretty = TRUE)
37	31x	updated
38		}
39		}

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	file.path(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	1x	if (any(not_installed)) {
30	!	utils::install.packages(extra[not_installed])
31		}
32	1x	if (refresh) {
33	1x	unlink(paste0(project_dir, "/renv.lock"))
34		}
35	1x	renv::snapshot(
36	1x	packages = extra,
37	1x	lockfile = file.path(project_dir, "renv.lock")
38		)
39		}

1		dcf_attempt_read_json <- function(path, ..., strict = TRUE) {
2	151x	contents <- tryCatch(jsonlite::read_json(path, ...), error = function(e) NULL)
3	151x	if (is.null(contents)) {
4	!	(if (strict) cli::cli_abort else cli::cli_warn)(
5	!	"failed to read {.file {path}}"
6		)
7		}
8	151x	contents
9		}
10		dcf_read_settings <- function(project_dir = ".", strict = FALSE) {
11	24x	settings_file <- file.path(project_dir, "settings.json")
12	24x	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	return(list(
19	4x	name = basename(normalizePath(project_dir, "/", FALSE)),
20	4x	data_dir = ".",
21	4x	standalone = TRUE
22		))
23		}
24		}
25	20x	dcf_attempt_read_json(settings_file)
26		}
27		dcf_init_git <- function(dir) {
28	2x	if (!dir.exists(file.path(dir, ".git"))) {
29	2x	wd <- getwd()
30	2x	on.exit(setwd(wd))
31	2x	setwd(dir)
32	2x	system2("git", "init")
33	2x	setwd(wd)
34		}
35		}
36
37		dcf_git_versions <- function(file, dir = ".") {
38	12x	wd <- setwd(dir)
39	12x	on.exit(setwd(wd))
40	12x	log <- suppressWarnings(system2(
41	12x	"git",
42	12x	c("log", '--format="%H\|\|\|%an <%ae>\|\|\|%ad\|\|\|%s"', shQuote(file)),
43	12x	stdout = TRUE
44		))
45	12x	setwd(wd)
46	12x	if (is.null(attr(log, "status"))) {
47	3x	log_entries <- do.call(
48	3x	rbind,
49	3x	Filter(
50	3x	function(x) length(x) == 4L,
51	3x	strsplit(log, "\|\|\|", fixed = TRUE)
52		)
53		)
54	3x	if (length(log_entries)) {
55	3x	colnames(log_entries) <- c(
56	3x	"hash",
57	3x	"author",
58	3x	"date",
59	3x	"message"
60		)
61	3x	as.data.frame(log_entries)
62		}
63		}
64		}

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