dcf coverage - 84.65%

Files
Source

#' Adds documentation of a dataset to a datapackage
#'
#' Add information about variables in a dataset to a \code{datapackage.json} metadata file.
#'
#' @param filename A character vector of paths to plain-text tabular data files, relative to \code{dir}.
#' @param meta Information about each data file. A list with a list entry for each entry in
#' \code{filename}; see details. If a single list is provided for multiple data files, it will apply to all.
#' @param packagename Package to add the metadata to; path to the \code{.json} file relative to
#' \code{dir}, or a list with the read-in version.
#' @param dir Directory in which to look for \code{filename}, and write \code{packagename}.
#' @param write Logical; if \code{FALSE}, returns the \code{paths} metadata without reading or rewriting
#' \code{packagename}.
#' @param refresh Logical; if \code{FALSE}, will retain any existing dataset information.
#' @param sha A number specifying the Secure Hash Algorithm function,
#' if \code{openssl} is available (checked with \code{Sys.which('openssl')}).
#' @param pretty Logical; if \code{TRUE}, will pretty-print the datapackage.
#' @param summarize_ids Logical; if \code{TRUE}, will include ID columns in schema field summaries.
#' @param open_after Logical; if \code{TRUE}, opens the written datapackage after saving.
#' @param verbose Logical; if \code{FALSE}, will not show status messages.
#' @details
#' \code{meta} should be a list with unnamed entries for entry in \code{filename},
#' and each entry can include a named entry for any of these:
#' \describe{
#'   \item{source}{
#'   A list or list of lists with entries for at least \code{name}, and ideally for \code{url}.
#'   }
#'   \item{ids}{
#'   A list or list of lists with entries for at least \code{variable} (the name of a variable in the dataset).
#'   Might also include \code{map} with a list or path to a JSON file resulting in a list with an
#'   entry for each ID, and additional information about that entity, to be read in a its features.
#'   All files will be loaded to help with aggregation, but local files will be included in the datapackage,
#'   whereas hosted files will be loaded client-side.
#'   }
#'   \item{time}{
#'   A string giving the name of a variable in the dataset representing a repeated observation of the same entity.
#'   }
#'   \item{variables}{
#'   A list with named entries providing more information about the variables in the dataset.
#'   See \code{\link{dcf_measure_info}}.
#'   }
#' }
#' @examples
#' \dontrun{
#' # write example data
#' write.csv(mtcars, "mtcars.csv")
#'
#' # add it to an existing datapackage.json file in the current working directory
#' dcf_datapackage_add("mtcars.csv")
#' }
#' @return An invisible version of the updated datapackage, which is also written to
#' \code{datapackage.json} if \code{write = TRUE}.
#' @seealso Initialize the \code{datapackage.json} file with \code{\link{dcf_datapackage_init}}.
#' @export

dcf_datapackage_add <- function(
  filename,
  meta = list(),
  packagename = "datapackage.json",
  dir = ".",
  write = TRUE,
  refresh = TRUE,
  sha = "512",
  pretty = FALSE,
  summarize_ids = FALSE,
  open_after = FALSE,
  verbose = interactive()
) {
  if (missing(filename)) {
    cli::cli_abort("{.arg filename} must be specified")
  }
  setnames <- names(filename)
  if (file.exists(filename[[1]])) {
    if (dir == ".") {
      dir <- dirname(filename[[1]])
    }
    filename <- basename(filename)
  }
  if (any(!file.exists(paste0(dir, "/", filename)))) {
    filename <- filename[!file.exists(filename)]
    cli::cli_abort("{?a file/files} did not exist: {filename}")
  }
  package <- if (
    is.character(packagename) && file.exists(paste0(dir, "/", packagename))
  ) {
    paste0(dir, "/", packagename)
  } else {
    packagename
  }
  if (write) {
    if (is.character(package)) {
      package <- paste0(dir, "/", packagename)
      package <- if (file.exists(package)) {
        packagename <- package
        jsonlite::read_json(package)
      } else {
        dcf_datapackage_init(
          if (!is.null(setnames)) setnames[[1]] else filename[[1]],
          dir = dir
        )
      }
    }
    if (!is.list(package)) {
      cli::cli_abort(c(
        "{.arg package} does not appear to be in the right format",
        i = "this should be (or be read in from JSON as) a list with a {.code resource} entry"
      ))
    }
  }
  if (!is.list(package)) {
    package <- list()
  }
  single_meta <- FALSE
  metas <- if (!is.null(names(meta))) {
    if (!is.null(setnames) && all(setnames %in% names(meta))) {
      meta[setnames]
    } else {
      single_meta <- TRUE
      if (length(meta$variables) == 1 && is.character(meta$variables)) {
        if (!file.exists(meta$variables)) {
          meta$variables <- paste0(dir, "/", meta$variables)
        }
        if (file.exists(meta$variables)) {
          meta$variables <- jsonlite::read_json(meta$variables)
        }
      }
      meta$variables <- replace_equations(meta$variables)
      meta
    }
  } else {
    meta[seq_along(filename)]
  }
  if (!single_meta) {
    metas <- lapply(metas, function(m) {
      m$variables <- replace_equations(m$variables)
      m
    })
  }
  collect_metadata <- function(file) {
    f <- paste0(dir, "/", filename[[file]])
    m <- if (single_meta) meta else metas[[file]]
    format <- if (grepl(".parquet", f, fixed = TRUE)) {
      "parquet"
    } else if (grepl(".json", f, fixed = TRUE)) {
      "json"
    } else if (grepl(".csv", f, fixed = TRUE)) {
      "csv"
    } else if (grepl(".rds", f, fixed = TRUE)) {
      "rds"
    } else {
      "tsv"
    }
    if (is.na(format)) {
      format <- "rds"
    }
    info <- file.info(f)
    metas <- list()
    unpack_meta <- function(n) {
      if (!length(m[[n]])) {
        list()
      } else if (is.list(m[[n]][[1]])) {
        m[[n]]
      } else {
        list(m[[n]])
      }
    }
    ids <- unpack_meta("ids")
    idvars <- NULL
    for (i in seq_along(ids)) {
      if (is.list(ids[[i]])) {
        if (
          length(ids[[i]]$map) == 1 &&
            is.character(ids[[i]]$map) &&
            file.exists(ids[[i]]$map)
        ) {
          ids[[i]]$map_content <- paste(
            readLines(ids[[i]]$map, warn = FALSE),
            collapse = ""
          )
        }
      } else {
        ids[[i]] <- list(variable = ids[[i]])
      }
      if (!ids[[i]]$variable %in% idvars) idvars <- c(idvars, ids[[i]]$variable)
    }
    data <- if (format == "rds") {
      tryCatch(readRDS(f), error = function(e) NULL)
    } else if (format == "parquet") {
      tryCatch(arrow::read_parquet(f), error = function(e) NULL)
    } else if (format == "json") {
      tryCatch(
        as.data.frame(jsonlite::read_json(f, simplifyVector = TRUE)),
        error = function(e) NULL
      )
    } else {
      attempt_read(f, c("geography", "time", idvars))
    }
    if (is.null(data)) {
      cli::cli_warn(c(
        paste0("failed to read in the data file ({.file {f}})"),
        i = "check that it is in a compatible format"
      ))
      return(NULL)
    }
    if (!all(rownames(data) == seq_len(nrow(data)))) {
      data <- cbind(`_row` = rownames(data), data)
    }
    timevar <- unlist(unpack_meta("time"))
    times <- if (is.null(timevar)) rep(1, nrow(data)) else data[[timevar]]
    times_unique <- unique(times)
    if (!single_meta) {
      varinf <- unpack_meta("variables")
      if (length(varinf) == 1 && is.character(varinf[[1]])) {
        if (!file.exists(varinf[[1]])) {
          varinf[[1]] <- paste0(dir, "/", varinf[[1]])
        }
        if (file.exists(varinf[[1]])) {
          if (varinf[[1]] %in% names(metas)) {
            varinf <- metas[[varinf[[1]]]]
          } else {
            varinf <- metas[[varinf[[1]]]] <- dcf_measure_info(
              varinf[[1]],
              write = FALSE,
              render = TRUE
            )
          }
          varinf <- varinf[varinf != ""]
        }
      }
      varinf_full <- names(varinf)
      varinf_suf <- sub("^[^:]+:", "", varinf_full)
    }
    res <- list(
      bytes = as.integer(info$size),
      encoding = stringi::stri_enc_detect(f)[[1]][1, 1],
      md5 = tools::md5sum(f)[[1]],
      format = format,
      name = if (!is.null(setnames)) {
        setnames[file]
      } else if (!is.null(m$name)) {
        m$name
      } else {
        sub("\\.[^.]*$", "", basename(filename[[file]]))
      },
      filename = filename[[file]],
      versions = get_versions(f),
      source = unpack_meta("source"),
      ids = ids,
      id_length = if (length(idvars)) {
        id_lengths <- nchar(data[[idvars[1]]])
        id_lengths <- id_lengths[!is.na(id_lengths)]
        if (all(id_lengths == id_lengths[1])) id_lengths[1] else 0
      } else {
        0
      },
      time = timevar,
      profile = "data-resource",
      created = as.character(info$mtime),
      last_modified = as.character(info$ctime),
      row_count = nrow(data),
      entity_count = if (length(idvars)) {
        length(unique(data[[idvars[1]]]))
      } else {
        nrow(data)
      },
      schema = list(
        fields = lapply(
          if (summarize_ids) {
            colnames(data)
          } else {
            colnames(data)[!colnames(data) %in% idvars]
          },
          function(cn) {
            v <- data[[cn]]
            invalid <- !is.finite(v)
            r <- list(name = cn, duplicates = sum(duplicated(v)))
            if (!single_meta) {
              if (cn %in% varinf_full) {
                r$info <- varinf[[cn]]
              } else if (cn %in% varinf_suf) {
                r$info <- varinf[[which(varinf_suf == cn)]]
              }
              r$info <- r$info[r$info != ""]
            }
            su <- !is.na(v)
            if (any(su)) {
              r$time_range <- which(times_unique %in% range(times[su])) - 1
              r$time_range <- if (length(r$time_range)) {
                r$time_range[c(1, length(r$time_range))]
              } else {
                c(-1, -1)
              }
            } else {
              r$time_range <- c(-1, -1)
            }
            if (!is.character(v) && all(invalid)) {
              r$type <- "unknown"
              r$missing <- length(v)
            } else if (is.numeric(v)) {
              r$type <- if (all(invalid | as.integer(v) == v)) {
                "integer"
              } else {
                "float"
              }
              r$missing <- sum(invalid)
              r$mean <- round(mean(v, na.rm = TRUE), 6)
              r$sd <- round(stats::sd(v, na.rm = TRUE), 6)
              r$min <- round(min(v, na.rm = TRUE), 6)
              r$max <- round(max(v, na.rm = TRUE), 6)
            } else {
              r$type <- "string"
              v <- as.factor(as.character(v))
              r$missing <- sum(is.na(v) | is.nan(v) | grepl("^[\\s.-]$", v))
              r$table <- structure(as.list(tabulate(v)), names = levels(v))
            }
            r
          }
        )
      )
    )
    if (!single_meta && "_references" %in% names(varinf)) {
      res[["_references"]] <- varinf[["_references"]]
    }
    if (Sys.which("openssl") != "") {
      res[[paste0("sha", sha)]] <- calculate_sha(f, sha)
    }
    res
  }
  metadata <- Filter(length, lapply(seq_along(filename), collect_metadata))
  if (single_meta) {
    package$measure_info <- lapply(meta$variables, function(e) e[e != ""])
  }
  names <- vapply(metadata, "[[", "", "filename")
  for (resource in package$resources) {
    if (length(resource$versions)) {
      su <- which(names %in% resource$filename)
      if (length(su)) {
        if (length(metadata[[su]]$versions)) {
          metadata[[su]]$versions <- rbind(
            metadata[[su]]$versions,
            if (is.data.frame(resource$versions)) {
              resource$versions
            } else {
              as.data.frame(do.call(cbind, resource$versions))
            }
          )
          metadata[[su]]$versions <- metadata[[su]]$versions[
            !duplicated(metadata[[su]]$versions),
          ]
        }
      }
    }
  }
  if (refresh) {
    package$resources <- metadata
  } else {
    package$resources <- c(
      metadata,
      package$resources[
        !(vapply(package$resources, "[[", "", "filename") %in% names)
      ]
    )
  }
  if (write) {
    packagename <- if (is.character(packagename)) {
      packagename
    } else {
      "datapackage.json"
    }
    jsonlite::write_json(
      package,
      if (file.exists(packagename)) {
        packagename
      } else {
        paste0(dir, "/", packagename)
      },
      auto_unbox = TRUE,
      digits = 6,
      dataframe = "columns",
      pretty = pretty
    )
    if (verbose) {
      cli::cli_bullets(c(
        v = paste(
          if (refresh) "updated resource in" else "added resource to",
          "datapackage.json:"
        ),
        "*" = paste0("{.path ", packagename, "}")
      ))
      if (open_after) rstudioapi::navigateToFile(packagename)
    }
  }
  invisible(package)
}

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

attempt_read <- function(file, id_cols) {
  tryCatch(
    {
      sep <- if (grepl(".csv", file, fixed = TRUE)) "," else "\t"
      cols <- scan(file, "", nlines = 1, sep = sep, quiet = TRUE)
      types <- rep("?", length(cols))
      types[cols %in% id_cols] <- "c"
      arrow::read_delim_arrow(
        gzfile(file),
        sep,
        col_names = cols,
        col_types = paste(types, collapse = ""),
        skip = 1
      )
    },
    error = function(e) NULL
  )
}

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

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

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

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

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

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

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

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

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

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

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

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

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

  invisible(issues)
}

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

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

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

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

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

dcf_read_epic <- function(path, path_root = ".") {
  full_path <- if (file.exists(path)) {
    path
  } else {
    sub("//", "/", paste0(path_root, "/", path), fixed = TRUE)
  }
  lines <- readLines(full_path, n = 25L, skipNul = FALSE)
  metadata_break <- grep("^[, ]*$", lines)
  if (!length(metadata_break)) {
    cli::cli_abort(
      "path does not appear to point to a file in the Epic format (no metadata separation)"
    )
  }
  meta_end <- min(metadata_break) - 1L
  data_start <- (if (length(metadata_break) == 1L) {
    metadata_break
  } else {
    max(metadata_break[
      metadata_break == c(-1L, metadata_break[-1L])
    ])
  }) +
    1L
  meta <- c(
    list(
      file = path,
      md5 = unname(tools::md5sum(full_path)),
      date_processed = Sys.time(),
      standard_name = ""
    ),
    as.list(unlist(lapply(
      strsplit(sub(",+$", "", lines[seq_len(meta_end)]), ",", fixed = TRUE),
      function(r) {
        l <- list(paste(r[-1L], collapse = ","))
        if (l[[1]] == "") {
          r <- strsplit(r, ": ", fixed = TRUE)[[1L]]
          l <- list(paste(r[-1L], collapse = ","))
        }
        names(l) <- r[[1L]]
        l[[1L]] <- gsub('^"|"$', "", l[[1L]])
        l
      }
    )))
  )
  standard_names <- c(
    vaccine_mmr = "MMR receipt",
    rsv_tests = "RSV tests",
    flu = "Influenza",
    self_harm = "self-harm",
    covid = "COVID",
    rsv = "RSV",
    obesity = "BMI",
    obesity = "obesity",
    all_encounters = "All ED Encounters"
  )
  meta_string <- 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
    }
  }
  id_cols <- seq_len(
    length(strsplit(lines[data_start], "^,|Measures,")[[1L]]) - 1L
  )
  header <- c(
    strsplit(lines[data_start + 1L], ",", fixed = TRUE)[[1L]][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)
  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"
    )
  }
  if ("age" %in% colnames(data)) {
    std_age <- standard_age(data$age)
    missed_ages <- (data$age != "No value") & is.na(std_age)
    if (any(missed_ages)) {
      std_age[missed_ages] <- data$age[missed_ages]
      missed_levels <- unique(data$age[missed_ages])
      cli::cli_warn("missed age levels: {.field {missed_levels}}")
    }
    data$age <- std_age
  }
  list(metadata = meta, data = data)
}

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

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

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

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

    # population data

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

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

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

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

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

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

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

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

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

#' 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.
#' @returns A version of the project report, which is also written to
#' \code{project_dir/docs/report.json.gz}.
#' @examples
#' project_file <- "../../../pophive"
#' if (file.exists(project_file)) {
#'   report <- dcf_build(project_file)
#' }
#' @export

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

1		#' 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		#' @returns A version of the project report, which is also written to
12		#' \code{project_dir/docs/report.json.gz}.
13		#' @examples
14		#' project_file <- "../../../pophive"
15		#' if (file.exists(project_file)) {
16		#' report <- dcf_build(project_file)
17		#' }
18		#' @export
19
20		dcf_build <- function(
21		project_dir = ".",
22		is_auto = TRUE,
23		...,
24		make_diagram = TRUE
25		) {
26	2x	settings <- dcf_read_settings(project_dir)
27	2x	data_dir <- paste0(project_dir, "/", settings$data_dir)
28	2x	processes <- list.files(
29	2x	data_dir,
30	2x	"process\\.json",
31	2x	recursive = TRUE,
32	2x	full.names = TRUE
33		)
34	2x	process_state <- tools::md5sum(processes)
35	2x	process <- dcf_process(project_dir = project_dir, is_auto = TRUE, ...)
36	2x	issues <- dcf_check(project_dir = project_dir)
37	2x	report_file <- paste0(project_dir, "/report.json.gz")
38		if (
39	2x	!identical(
40	2x	process_state,
41	2x	tools::md5sum(list.files(
42	2x	data_dir,
43	2x	"process\\.json",
44	2x	recursive = TRUE,
45	2x	full.names = TRUE
46		))
47		)
48		) {
49	2x	datapackages <- list.files(
50	2x	data_dir,
51	2x	"datapackage\\.json",
52	2x	recursive = TRUE,
53	2x	full.names = TRUE
54		)
55	2x	names(datapackages) <- dirname(sub(
56		"^/",
57		"",
58	2x	sub(data_dir, "", datapackages, fixed = TRUE)
59		))
60	2x	names(processes) <- dirname(sub(
61		"^/",
62		"",
63	2x	sub(data_dir, "", processes, fixed = TRUE)
64		))
65	2x	report <- list(
66	2x	date = Sys.time(),
67	2x	settings = settings,
68	2x	source_times = process$timings,
69	2x	logs = process$logs,
70	2x	issues = issues,
71	2x	metadata = lapply(datapackages, jsonlite::read_json),
72	2x	processes = lapply(processes, jsonlite::read_json)
73		)
74	2x	jsonlite::write_json(
75	2x	report,
76	2x	gzfile(report_file),
77	2x	auto_unbox = TRUE,
78	2x	dataframe = "columns"
79		)
80		} else {
81	!	report <- invisible(jsonlite::read_json(report_file))
82		}
83	2x	if (make_diagram) {
84	2x	dcf_status_diagram(project_dir)
85		}
86	2x	invisible(report)
87		}

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

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

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

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