🎉 add v0.0.1 files

from cynthiahqy/conformr-xmap-project#122

.Rbuildignore

@@ -0,0 +1,6 @@
+^LICENSE\.md$
+^data-raw$
+^README\.Rmd$
+^_pkgdown\.yml$
+^docs$
+^pkgdown$

DESCRIPTION

@@ -0,0 +1,41 @@
+Package: xmap
+Title: A principled approach to recoding and redistributing data between
+    nomenclature
+Version: 0.0.1
+Authors@R: c(
+    person("Cynthia", "Huang", , "cynthia@gmail.com", role = c("aut", "cre")),
+    person("Laura", "Puzzello", role = c("aut", "fnd"))
+  )
+Description: Provides tools for creating and verifying classification,
+    category and/or nomenclature mapping objects.
+License: MIT + file LICENSE
+URL: https://github.com/cynthiahqy/xmap
+Config/testthat/edition: 3
+Encoding: UTF-8
+Roxygen: list(markdown = TRUE)
+RoxygenNote: 7.2.2
+Depends: 
+    R (>= 4.1)
+Imports: 
+    cli,
+    dplyr,
+    glue,
+    rlang (>= 1.0.0),
+    tibble,
+    tidyr
+Suggests: 
+    forcats,
+    ggbump,
+    ggplot2,
+    knitr,
+    matlib,
+    Matrix,
+    patchwork,
+    rmarkdown,
+    stats,
+    stringr,
+    testthat (>= 3.0.0)
+LazyData: true
+VignetteBuilder: knitr
+LitrVersionUsed: 0.7.0
+LitrId: 63fe8913732cbd8d745656e34cc88010

LICENSE

@@ -0,0 +1,2 @@
+YEAR: 2023
+COPYRIGHT HOLDER: C. Huang

LICENSE.md

@@ -0,0 +1,21 @@
+# MIT License
+
+Copyright (c) 2023 C. Huang
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

NAMESPACE

@@ -0,0 +1,38 @@
+# Generated by roxygen2: do not edit by hand
+
+S3method(as_xmap_df,data.frame)
+S3method(print,xmap_df)
+S3method(xmap_reverse,xmap_df)
+S3method(xmap_to_matrix,xmap_df)
+export(add_weights_equal)
+export(add_weights_unit)
+export(as_pairs_from_named)
+export(as_xmap_df)
+export(is_xmap)
+export(is_xmap_df)
+export(msg_abort_frac_weights)
+export(msg_abort_named_matchset)
+export(pairs_to_named_list)
+export(pairs_to_named_vector)
+export(verify_links_as_xmap)
+export(verify_named_all_1to1)
+export(verify_named_all_names_unique)
+export(verify_named_all_unique)
+export(verify_named_all_values_unique)
+export(verify_named_as_recode_unique)
+export(verify_named_matchset_names_contain)
+export(verify_named_matchset_names_exact)
+export(verify_named_matchset_names_within)
+export(verify_named_matchset_values_contain)
+export(verify_named_matchset_values_exact)
+export(verify_named_matchset_values_within)
+export(verify_named_no_dup_names)
+export(verify_named_no_dup_values)
+export(verify_pairs_all_1to1)
+export(verify_pairs_all_unique)
+export(verify_pairs_as_recode_unique)
+export(xmap_drop_extra)
+export(xmap_reverse)
+export(xmap_to_matrix)
+export(xmap_to_named_list)
+export(xmap_to_named_vector)

R/abort.R

@@ -0,0 +1,120 @@
+# Generated from create-xmap.Rmd: do not edit by hand
+
+#' @describeIn abort Abort if named columns can't be found in df
+#'
+abort_missing_cols <- function(df, cols) {
+  missing_cols <- setdiff(cols, names(df))
+  if (length(missing_cols) != 0) {
+    cli::cli_abort(
+      message = "The column{?s} {.var {missing_cols}} {?was/were} not found.",
+      class = "abort_missing_cols"
+    )
+  }
+  invisible(df)
+}
+
+#' @describeIn abort Abort if xmap_df has missing values
+#'
+abort_any_na <- function(df) {
+  if (base::anyNA(df)) {
+    cli::cli_abort(
+      message = "NA values found. Please enter missing `from` or `to` node labels and/or convert NA weights",
+      class = "abort_na"
+    )
+  }
+  invisible(df)
+}
+
+#' Validation functions and messages for xmap or candidate links (Internal)
+#'
+#' @description
+#' Checks issues with data.frame like objects containing validated `xmap` or candidate links.
+#'
+#' @param df a data.frame-like object containing links
+#' @param col_from,col_to,col_weights character vector or values naming columns from `df`
+#'
+#' @returns An error if the validation condition fails,
+#' and invisibly returns `df` otherwise.
+#'
+#' @name abort
+NULL
+
+#' @describeIn abort Abort if xmap_df has wrong column types
+#'
+abort_weights_col_type <- function(df, col_weights) {
+  if (!is.numeric(df[[col_weights]])) {
+    cli::cli_abort(
+      message = "The column `{col_weights}` should be of type numeric",
+      class = "abort_col_type"
+    )
+  }
+  invisible(df)
+}
+
+#' @describeIn abort Abort if duplicate source-target pairs are found
+#'
+abort_dup_pairs <- function(df, col_from, col_to) {
+  if (!vhas_no_dup_pairs(df[[col_from]], df[[col_to]])) {
+    cli::cli_abort(
+      message = "Duplicate `from`-`to` links were found.
+      Please remove or collapse duplicates.",
+      class = "abort_dup_pairs"
+    )
+  }
+  invisible(df)
+}
+
+#' @describeIn abort Abort for invalid mapping weights
+#'
+abort_bad_weights <- function(col_weights, call = rlang::caller_env()) {
+    cli::cli_abort(
+      message =  c(
+            "Incomplete mapping weights found",
+      "x" = "{.var {col_weights}} does not sum to 1",
+      "i" = "Modify weights or adjust `tol` and try again."),
+      class = "abort_bad_weights",
+      call = call
+    )
+}
+
+#' @describeIn abort Abort if xmap_df columns are not in order
+abort_col_order <- function(df, col_from, col_to, col_weights){
+  correct_order <- c(col_from, col_to, col_weights)
+  first_three <- names(df[1:3])
+  if(!identical(first_three, correct_order)){
+    rlang::abort(
+      message = "columns are not sorted in order `from`, `to`, `weights`",
+      class = "abort_col_order"
+    )
+  }
+  invisible(df)
+}
+
+#' @describeIn abort Abort if from_set attribute doesn't match xmap_df values
+#'
+abort_from_set <- function(df, col_from, from_set) {
+  col_from_set <- as.character(unique(df[[col_from]]))
+  stopifnot(identical(col_from_set, from_set))
+
+  invisible(df)
+}
+
+#' @describeIn abort Abort message for fractional weights
+#' @export
+msg_abort_frac_weights <- function(impact){
+  cli::format_error(c(
+            "`x` contains fractional weights. {impact}",
+      "x" = "You've supplied a xmap with weights not equal to 1")
+    )
+}
+
+#' @describeIn abort Abort if xmap_df is not reversible without new weights
+#'
+abort_not_reversible <- function(df, col_to) {
+  x_to <- df[[col_to]]
+  if (vhas_collapse(x_to)){
+    cli::cli_abort("Collapse links in {.var xmap_df} cannot be reversed. Please supply new weights and create a new xmap.")
+  }
+  invisible(df)
+}
+

R/add_weights_equal.R

@@ -0,0 +1,28 @@
+# Generated from create-xmap.Rmd: do not edit by hand
+
+#' Add equal fractional weights to groups of source-target node pairs
+#' 
+#' Attaches equal weights to every source-target link from a given source node.
+#' The resultant weighted links can be verified or coerced into an `xmap`.
+#' 
+#' @inheritParams verify_pairs
+#' @inheritParams add_weights_unit
+#' 
+#' @return `pairs` with additional column of weights
+#' @family {Helpers for adding weights to pairs}
+#' @export
+#' 
+#' @examples
+#' animal_pairs <- list(MAMM = c("elephant", "whale", "monkey"),
+#'                  REPT = c("lizard", "turtle"),
+#'                  CRUS = c("crab")) |>
+#'   as_pairs_from_named("class", "animal")
+#' animal_pairs |>
+#'   add_weights_equal(from = class, to = animal)
+add_weights_equal <- function(df, from, to, weights_into = "weights"){
+  ## TODO: validate_pairs_unique()
+  df |>
+    dplyr::group_by({{from}}) |>
+    dplyr::mutate("{weights_into}" := 1/dplyr::n_distinct({{to}})) |>
+    dplyr::ungroup()
+}

R/add_weights_unit.R

@@ -0,0 +1,24 @@
+# Generated from create-xmap.Rmd: do not edit by hand
+
+#' Add unit weights to node pairs table
+#'
+#' Attaches column of unit weights to pairs of source-target nodes.
+#' The resultant weighted links can be verified or coerced into `xmap`.
+#'
+#' @inheritParams verify_pairs
+#' @param weights_into character string naming new column to store link weights in
+#'
+#' @return `pairs` with additional column of ones
+#' @family {Helpers for adding weights to pairs}
+#' @export
+#'
+#' @examples
+#' AUS_pairs <- list(AUS = c("NSW", "QLD", "SA", "TAS", "VIC", "WA", "ACT", "NT")) |>
+#'   as_pairs_from_named(names_to = "ctr", values_to = "state")
+#' AUS_pairs |>
+#'   add_weights_unit(weights_into = "weights")
+add_weights_unit <- function(df, weights_into = "weights"){
+  ## TODO: validate_pairs_unique()
+  df[,weights_into] <- 1
+  return(df)
+}

R/as_xmap.R

@@ -0,0 +1,80 @@
+# Generated from create-xmap.Rmd: do not edit by hand
+
+#' Coerce objects to xmap_df
+#' 
+#' Validates and creates a valid crossmap `xmap_df` object.
+#' 
+#' @param x
+#'  * For `as_xmap_df()`: An object to coerce
+#'  * For `is_xmap_df()`: An object to test.
+#' @param from,to Columns in `x` specifying the source and target nodes
+#' @param weights Column in `x` specifying the weight applied to data passed along the directed link between source and target node
+#' @inheritParams vhas_complete_weights
+#' @param subclass Which xmap subclass to return. Defaults to `xmap_df` for `data.frame` and `tibble`
+#' @param .drop_extra Drop columns other than `from`, `to` and `weights`. Defaults to `TRUE`
+#' 
+#' @return A validated `xmap` object.
+#' @name as_xmap
+#' @export
+as_xmap_df <- function(x, from, to, weights, tol = .Machine$double.eps^0.5, subclass = c("xmap_df"), ...) {
+  UseMethod("as_xmap_df")
+}
+
+#' @describeIn as_xmap Coerce a `data.frame` to `xmap`
+#'
+#' @export
+#' @examples
+#' # For a well formed crossmap:
+#' links <- data.frame(
+#'   a = "AUS",
+#'   b = c("VIC", "NSW", "WA", "OTHER"),
+#'   w = c(0.1, 0.15, 0.25, 0.5)
+#' )
+#' as_xmap_df(links, from = a, to = b, weights = w)
+#'
+#' # extra columns are dropped,
+#' links$extra <- c(2, 4, 5, 6)
+#' as_xmap_df(links, from = a, to = b, weights = w)
+as_xmap_df.data.frame <- function(x, from, to, weights, tol = .Machine$double.eps^0.5, subclass = "xmap_df", .drop_extra = TRUE) {
+  ## coercion & checks
+  stopifnot(is.data.frame(x))
+
+  # get string names for columns
+  col_from <- deparse(substitute(from))
+  col_to <- deparse(substitute(to))
+  col_weights <- deparse(substitute(weights))
+  col_strings <- c(col_from, col_to, col_weights)
+  ## check columns exist
+  abort_missing_cols(x, col_strings)
+
+  ## drop additional columns
+  if (.drop_extra) {
+    df <- x[col_strings]
+  } else {
+    df <- x
+  }
+  if (ncol(df) < ncol(x)) {
+    cli::cli_inform("Dropped additional columns in {.arg {deparse(substitute(x))}}")
+  }
+
+  ## rearrange columns
+  col_order <- c(col_strings, setdiff(names(df), col_strings))
+  df <- df[col_order]
+
+  ## construction
+  xmap <- switch(subclass,
+                 xmap_df = new_xmap_df(df, col_from, col_to, col_weights),
+                 stop("Unknown xmap subclass"))
+
+  ## validation
+  ## ---- xmap graph properties ----
+  abort_weights_col_type(df, col_weights)
+  abort_dup_pairs(df, col_from, col_to)
+  stop_bad_weights <- !vhas_complete_weights(df[[col_from]], df[[col_weights]], tol)
+  if (stop_bad_weights) { abort_bad_weights(col_weights) }
+
+  ## ---- xmap_df attributes ----
+  validate_xmap_df(xmap)
+
+  return(xmap)
+}

R/calc.R

@@ -0,0 +1,12 @@
+# Generated from create-xmap.Rmd: do not edit by hand
+
+#'
+.calc_unique_sets.xmap_df <- function(x){
+  stopifnot(is_xmap_df(x))
+  df <- data.frame(x)
+  x_attrs <- attributes(x)
+  uniq_sets <- list()
+  uniq_sets$from_set <- as.character(unique(df[[x_attrs$col_from]]))
+  uniq_sets$to_set <- as.character(unique(df[[x_attrs$col_to]]))
+  return(uniq_sets)
+}