create-xmap.Rmd

---
title: "Creating the ``r params$package_name`` R package"
author: "Cynthia Huang"
date: 2022-12-21
output: 
  litr::litr_html_document:
    toc: true
params:
  package_name: "xmap" # <-- change this to your package name
  package_parent_dir: "." # <-- relative to this file's location
---

```{=html}
<!-- This Rmd file contains all the code needed to define an R package.  Press "Knit" in RStudio or more generally run `litr::render("name-of-this-file.Rmd")` to generate the R package.  Remember that when you want to modify anything about the R package, you should modify this document rather than the package that is outputted.
-->
```
## Package Setup

### DESCRIPTION file

```{r package-setup, message=FALSE, results='hide'}
usethis::create_package(
  path = ".",
  fields = list(
    Package = params$package_name,
    Version = "0.0.1.9004",
    Title = "A principled approach to recoding and redistributing data between nomenclature",
    Description = "Provides tools for creating and verifying classification, category and/or nomenclature mapping objects.",
    `Authors@R` = c(
      person(given = "Cynthia", family = "Huang", email = "cynthia@gmail.com", role = c("aut", "cre")),
      person(given = "Laura", family = "Puzzello", role = c("aut", "fnd"))
    ),
    `Config/testthat/edition` = 3,
    URL = "https://github.com/cynthiahqy/xmap"
  )
)
usethis::use_mit_license(copyright_holder = "C. Huang")
```

### Dependencies

```{r dependencies}
# Imports for Validation
usethis::use_package("R", type = "Depends", min_version = "4.1")
usethis::use_package("rlang", min_version = "1.0.0")
usethis::use_package("cli")

# Imports for Construction and verification helpers
usethis::use_package("tibble", min_version = "3.1.0")
usethis::use_package("pillar", min_version = "1.6.0")
usethis::use_package("vctrs", min_version = "0.6.0")
usethis::use_package("tidyr")
usethis::use_package("dplyr")
usethis::use_package("glue", "Imports")
usethis::use_package("tidyselect") ## for free with dplyr

# Suggests for xmap coercion to other classes
usethis::use_package("stats", type = "Suggests")
usethis::use_package("Matrix", type = "Suggests") ## for sparse matrices

# Suggests for Tests and Vignettes
usethis::use_package("ggplot2", type = "Imports")
usethis::use_package("ggraph", type = "Imports")
usethis::use_package("testthat", type = "Suggests")
usethis::use_package("matlib", type = "Suggests")
usethis::use_package("forcats", type = "Suggests")
usethis::use_package("stringr", type = "Suggests")
usethis::use_package("patchwork", type = "Suggests")
usethis::use_package("ggbump", type = "Suggests")
```

### Utilities

```{r}
## retain for interactive
library(rlang)
```

```{r send_to="R/utils.R"}
#' Defaults for NULL values
#' @name op-null-default
#' @keywords internal
`%||%` <- function(x, y) if (is.null(x)) y else x
```

### Package Level Documentation

``` {package-doc}
#' xmap: A principled approach to recoding and redistributing data between nomenclature
#'
#' @description
#' Provides tools for verifying classification, category and/or nomenclature
#' mapping objects such as named vectors or lists, and lookup tables.
#'
#' @keywords internal
#' @import rlang
"_PACKAGE"
```

## Package Design Notes

### Function Types and Naming conventions

This should correspond to `@keywords` and `send_to=` arguments.

#### Data Argument Names

-   `x` for ambiguous inputs (e.g. named vector OR named list), or generic methods
-   `df` for data frames (e.g. pairs and links)
-   `.xmap` for xmap objects, following the [Dot prefix tidyverse design pattern](https://design.tidyverse.org/dots-prefix.html) since `xmap_to` and other fncs will eventually have passthrough `...`

#### Internal Helpers

Errors and Messages:

-   `abort_*`: should raise a `cli::cli_abort()` message, and pass through calls.
-   See [#59](https://github.com/cynthiahqy/conformr-xmap-project/issues/59) for references on how to construct and format errors.

Properties:

-   `.get_<attrs>`: should always retrieve attributes (usually of `xmap_df`)
-   `.calc_<property>`: calculates something based on object and/or its attributes (usually of `xmap_df`)
-   `vhas_`: takes in vectors, returns boolean

Construction:

-   `*_xmap_df()`: class construction functions
-   `new_xmap_df()`
-   `validate_xmap_df()` -- internal, quick!
-   `as_xmap_df()`

#### Data

-   `mock_` are input objects:
    -   `mock$named_`
    -   `mock$df_`
    -   `mock$xmap_`
-   See [#177](https://github.com/cynthiahqy/conformr-xmap-project/issues/117) for references on documenting datasets

#### Non-`xmap_df` inputs

Candidate Pairs:

-   `as_pairs()` to generate crosswalks

    -   `as_pairs_from_list()`
    -   `as_pairs_from_named_vector()`

-   `add_weights_*` to attach weights and return links

-   `verify_named` functions:

    -   `verify_named_all_pairs` for pairwise checks
    -   `verify_named_all_names/values` for node set checks
    -   `verify_named_matchset_names/values_<filter>` for node set element checks

Candidate Links:

-   `as_links()`: could be a generic that calls different (internal?) methods and adds/extracts weights like:

    -   `as_links_from_matrix()`
    -   `as_links_from_igraph()`

-   `verify_links_as_xmap()`, takes tidyselect?

Coerce:

-   `as_xmap()` wraps construction functions, takes tidyselect
-   `is_xmap()`

#### `xmap_df` inputs

Describe:

-   `xmap_has`
    -   single input variants of `vhas` fncs
-   `verify_xmap_as_*` special types of xmaps;

Modify:

-   `xmap_<verb>` returns an `xmap_df`

Convert:

-   `xmap_to`: returns non-`xmap` outputs

#### ARCHIVED: `xmap` subclasses

-   functions specific to subclass end with the `_<subclass>` suffix, and/or named as S3 dispatch method (i.e. `<generic>.<subclass>`). For example `validate_xmap_df()` and `xmap_validate.xmap_df()`

-   "internal" construction and validation functions take string arguments for column selection

-   user helpers take expression arguments (NSE) for column selection

-   functions should probably never end in `_xmap()` because it's not clear which subclass they act on.

For functions accepting `xmap` as inputs:

-   any function that accepts any subclass of `xmap` should be named using the `xmap_` prefix convention -- e.g. `xmap_validate()`

-   generics that will form part of a user workflow should follow the `xmap_` prefix convention (e.g. `xmap_validate()`). This makes reduces ambiguity when using these functions in a conformr workflow.

For functions return `xmap` subclasses as output:

-   any function that returns a specific subclass of `xmap` should end with the suffice `_<subclass>`. For example `as_xmap_df()` and `new_xmap_df()`

### Reference Index

Draft [pkgdown function reference](https://pkgdown.r-lib.org/articles/pkgdown.html#reference) to be placed in `_pkgdown.yml`

``` yml
reference:
- title: "Overview"
  - "xmap-package"
  - "xmap_df-class"
- title: "Creation and Coercion"
  desc: >
    Functions for constructing a `xmap_df`.
  - xmap
  - as_xmap_df
- title: "Helpers and Validation"
  - new_xmap
  - validate_xmap
  - starts_with("has", internal = TRUE)
```

### Graph & Matrix concepts

-   graph notation reference: <http://www-student.cse.buffalo.edu/~atri/cse331/support/notation/graphs.html>; <https://www3.nd.edu/~dgalvin1/60610/60610_S09/60610graphnotation.pdf>

### Toy Examples

```{r ideal-xmap}
## define some test data here

input_df <- tibble::tribble(
  ~from, ~to, ~weights,
  "A1", "B01", 1,
  "A2", "B02", 1,
  "A3", "B02", 1,
  "A4", "B03", 0.25,
  "A4", "B04", 0.75
)

int_dat <- list("input_df" = input_df)

usethis::use_data(int_dat, internal = TRUE, overwrite = TRUE)
```

```{r simple-xmap}
simple_xmap <- tibble::tribble(
  ~f, ~t, ~w,
  "x1111", "A1", 1,
  "x2222", "B2", 0.5,
  "x2222", "B3", 0.5,
  "x3333", "C5", 1,
  "x4444", "C5", 1,
  "x5555", "D6", 0.4,
  "x5555", "D7", 0.6,
  "x6666", "D6", 0.3,
  "x6666", "D7", 0.7,
  "x7777", "D6", 1
)
```

### API Design & Functionality

[Issue #67 Comment](https://github.com/cynthiahqy/conformr-project/issues/67#issuecomment-1436365643):

I'm not sure offering helpers for modifying crossmaps is necessary or even desirable.

-   Lists of maps make more sense from a "using xmaps" perspective,
-   Combining multiple crossmaps into a single table add a flexible quality to xmaps that goes against the purpose of the structure as a data-provenance object.
-   Users can still manipulate and store multiple sets of weights or other xmap variants in a "parent table", from which they create multiple xmap.
-   Manipulation of xmaps creates risk around invalidating the map -- i.e. modifying values in the weights column is technically possible for an xmap (since it is just a data.frame column), but not desirable since the map is not revalidated after the manipulation -- i.e. `xmap |> dplyr::mutate()` should probably return a tibble rather than an xmap.

[Issue #93: 14 Apr 2023](https://github.com/cynthiahqy/conformr-project/issues/93#issuecomment-1508073958)

-   Rather than classes, I think it makes the most sense to have a single xmap class (i.e. xmap_df), and everything else be "candidate links" -- which can be input into the as_xmap() generic.
-   Candidate links can also be validated as crossmaps, without coercion, allowing users to validate transformation objects in existing workflows. Coercion into xmap classes should be reserved for facilitating "advanced" or "extension" tasks --- i.e. visualisation, perturbation, multi-map transformations.
-   Some xmap class variants could include:
    -   "long" or "short" formats for ggplot;
    -   recode/collapse variants which drop the weights columns (since it is implied);
    -   igraph objects for spatial aggregation/transformation -- noting the similarity between spatial weighting matrices and crossmaps (see this Vignette from [SpatialReg](https://r-spatial.github.io/spatialreg/articles/nb_igraph.html).

## Mock Objects

```{r}
usethis::use_data_raw("mock", open = FALSE)
```

```{r mock-objects, send_to="data-raw/mock.R"}
mock <- list()

mock$named_ctr_iso3c <- countrycode::codelist |>
  dplyr::select(iso3c, iso.name.en) |>
  tidyr::drop_na() |>
  tibble::deframe()

# mock_named$collapse_list <- list(MAMM = c("elephant", "whale", "monkey"),
#                       REPT = c("lizard", "turtle"),
#                       CRUS = c("crab"))

mock$df_anzsco21 <- strayr::anzsco2021 |>
  dplyr::select(tidyselect::starts_with(c("anzsco_major", "anzsco_submajor"))) |>
  dplyr::distinct() |>
  dplyr::select(tidyselect::ends_with("_code"), tidyselect::everything())

mock$xmap_abc <- tibble::tribble(
  ~lower, ~upper, ~share,
  "a", "AA", 1, # one-to-one
  "b", "BB", 1, # one-FROM-many
  "c", "BB", 1,
  "d", "CC", 0.3, # one-to-many
  "d", "DD", 0.6,
  "d", "EE", 0.1
) |>
  xmap::as_xmap_df(from = lower, to = upper, weights = share)

mock$named_aus <- list(AUS = c("AU-NSW", "AU-QLD", "AU-SA", "AU-TAS", "AU-VIC", "AU-WA", "AU-ACT", "AU-NT"))
mock$df_aus_pop <- tibble::tribble(
  ~state_name, ~state, ~pop,
  "New South Wales", "AU-NSW", 8153600,
  "Victoria", "AU-VIC", 6613700,
  "Queensland", "AU-QLD", 5322100,
  "South Australia", "AU-SA", 1820500,
  "Western Australia", "AU-WA", 2785300,
  "Tasmania", "AU-TAS", 571500,
  "Northern Territory", "AU-NT", 250600,
  "Australian Capital Territory", "AU-ACT", 456700
) |>
  dplyr::mutate(ctr = "AUS")
usethis::use_data(mock)
```

```{r document-mock-objects, send_to="R/data.R"}
#' Mock input objects for the `xmap` package
#'
#' A collection of mock inputs for experimenting with functions
#' in the `xmap` package.
#' `named_` objects are either named vectors or nested lists.
#' `df_` objects may contain source-target *pairs* (no weights),
#' or weighted source-target *links*.
#'
#' @format ## `mock`
#' A list with:
#' \describe{
#'  \item{named_ctr_iso3c}{named vector with 249 elements. Names are ISO-3 country codes, values are ISO English country names. Retrieved from `countrycode` package:
#'    \url{https://github.com/vincentarelbundock/countrycode}}
#'  \item{df_anzsco21}{tibble with 51 rows and 4 columns. Contains major and submajor occupation codes and descriptions for ANZSCO21. Retrieved from `strayr` package:
#'    \url{https://github.com/runapp-aus/strayr}}
#'  \item{xmap_abc}{xmap_df: lower -> upper BY share. Mock crossmap with 6 links including one-to-one, one-to-many and many-to-one relations.}
#'  \item{named_aus}{named list with 1 element named "AUS" containing codes for the Australian states}
#'  \item{df_aus_pop}{tibble containing 2022 population figures for Australia by state. Retrieved from:
#'    \url{https://www.abs.gov.au/statistics/people/population/national-state-and-territory-population/jun-2022}}
#'  }
#' @examples
#' links_aus_agg <- mock$named_aus |>
#'   as_pairs_from_named(names_to = "ctr", values_to = "state") |>
#'   add_weights_unit() |>
#'   dplyr::select(ctr, state, weights) |>
#'   verify_links_as_xmap(from = state, to = ctr, weights)
#' links_aus_agg
#'
#' links_aus_split_equal <- links_aus_agg |>
#'   add_weights_equal(from = ctr, to = state) |>
#'   dplyr::select(ctr, state, weights) |>
#'   verify_links_as_xmap(from = ctr, to = state, weights)
#' links_aus_split_equal
#'
#' links_aus_split_pop <- mock$df_aus_pop |>
#'   add_weights_prop(from = ctr, to = state, prop = pop)
#' links_aus_split_pop
"mock"
```

## Candidate Links

### Convert: List to Links Data Frame

One-to-one and many-to-one mappings could easily be encoded as list objects, where each element of the list is a member of the target set, and contains a vector of all the source nodes that link to it. For instance:

```{r}
link_list <- list(
  AA = c("x3", "x4", "x6"),
  BB = c("x1", "x5"),
  CC = c("x2")
)
```

Convert to tibble:

```{r}
col_from <- "source"
col_to <- "target"
col_weights <- "weights"

link_list |>
  tibble::enframe(name = col_to, value = col_from) |>
  tidyr::unnest_longer(col = c(col_from)) |>
  dplyr::mutate("{col_weights}" := 1)
```

Convert to dataframe: -- how to unnest???

```{r}
# convert list to data.frame
links <- as.matrix(link_list) |>
  as.data.frame()

# convert row names to column
from_name <- "source"
to_name <- "target"
links[[to_name]] <- row.names(links)
names(links)[1] <- from_name
```

``` r
xmap::pairs_from_named(list = link_list,
                      col_from = "source",
                      col_to = "target",
                      col_weights = "weights")
```

#### Helper: Node pairs from Named List or Vector

`tibble::enframe` is:

``` r
tibble(
    name = names(islands),
    size = islands
  )
```

```{r fnc-pairs-from-named, send_to="R/pairs_named.R"}
#' Convert between column pairs and named vector or lists
#'
#' @description
#' Convert named vectors or nested lists into a two-column table of node pairs and vice versa.
#' `as_pairs_from_named` extracts the vector or list element names and the values, unnesting where necessary.
#' `pairs_to_named_vector` extracts name-value pairs from column pairs as is,
#' whilst `pairs_to_named_list()` nests the values first.
#'
#' @inheritParams verify_named
#' @inheritParams verify_pairs
#' @param names_to,values_to character vector specify the new columns to pass the information in `x` into.
#' @param names_from,values_from two columns in `x` to convert to names and values
#'
#' @return
#'   * For `as_pairs_from_named()`: a two-column tibble
#'   * For `pairs_to_named` fncs: named vector or list
#'
#' @name as_pairs
#' @examples
#' # Coerce named vectors and list to column pairs
#'
#' veg_vec <- c(eggplant = "aubergine", zucchini = "courgette")
#' as_pairs_from_named(veg_vec, "au_eng", "uk_eng")
#'
#' animal_list <- list(
#'   MAMM = c("elephant", "whale", "monkey"),
#'   REPT = c("lizard", "turtle"),
#'   CRUS = c("crab")
#' )
#' as_pairs_from_named(animal_list, "class", "animal")
#'
#' # Convert pairs back to named vector and lists
#' veg_from_pairs <- as_pairs_from_named(veg_vec) |>
#'   pairs_to_named_vector(names_from = name, values_from = value)
#' identical(veg_vec, veg_from_pairs)
#'
#' animal_from_pairs <- as_pairs_from_named(animal_list, "class", "animal") |>
#'   pairs_to_named_list(names_from = class, values_from = animal)
#' identical(animal_list, animal_from_pairs)
NULL

#' @describeIn as_pairs Convert named vector or nested list into column pairs
#' @export
as_pairs_from_named <- function(x, names_to = "name", values_to = "value") {
  stopifnot(is.vector(x))
  node_pairs <- x |>
    tibble::enframe(name = names_to, value = values_to) |>
    tidyr::unnest_longer(col = tidyr::all_of(values_to))
  return(node_pairs)
}
```

#### Helper: Named list from pairs `pairs_to_named()`

```{r send_to="R/pairs_named.R"}
#' @describeIn as_pairs Convert column pairs to named vector
#' @export
pairs_to_named_vector <- function(df, names_from = name, values_from = value) {
  ordered_cols <- dplyr::select(df, {{ names_from }}, {{ values_from }})
  tibble::deframe(ordered_cols)
}

#' @describeIn as_pairs Convert column pairs to nested named list
#' @export
pairs_to_named_list <- function(df, names_from = name, values_from = value) {
  nested_cols <- dplyr::select(df, {{ names_from }}, {{ values_from }}) |>
    tidyr::nest(values = {{ values_from }})
  ordered_cols <- dplyr::select(nested_cols, {{ names_from }}, values)
  tibble::deframe(ordered_cols) |>
    sapply(as.matrix) |>
    sapply(as.vector) |>
    as.list()
}
```

#### Helper: Add weights to pairs

```{r fnc-add-weights-unit, send_to="R/add_weights.R"}
#' Add weights to unweighted links
#'
#' Attach column of weights to a table of unweighted source-target links.
#' If calculating equal fractional weights, uses distinct `from`-`to` pairs.
#' The resultant weighted links can be verified or coerced into `xmap`.
#'
#' @inheritParams verify_pairs
#' @param prop numeric column containing reference values to calculate fractional weights from.
#' Weights are calculated as `prop/sum(prop)` where the sum is calculated separately for each set of links coming out of a given `from` node.
#' @param weights_into character string naming new column to store link weights in
#'
#' @return `df` with additional column of weights
#' @name add_weights
NULL

#' @describeIn add_weights Attach column of unit weights (i.e. ones)
#' @export
#' @examples
#' # simple unit weights
#' 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") {
  df[, weights_into] <- 1
  return(df)
}
```

```{r}
testthat::test_that("add_weights_unit() works as expected", {
  # unit
  abc_pairs <- data.frame(lower = letters[1:5], upper = LETTERS[1:5])
  abc_links <- data.frame(lower = letters[1:5], upper = LETTERS[1:5], weights = 1)
  testthat::expect_equal(add_weights_unit(abc_pairs), abc_links)
})
```

### Link Properties: `vhas_*(x_)`

`vhas_*(v_)` functions take in vector arguments only, and are designed to be able to validate the graph features of non-data.frame xmaps (so long as the links can be decomposed into from,to,weight vectors).

```{r send_to="R/vhas.R"}
#' Boolean flags for properties of candidate and validated xmap links (internal)
#'
#' @description
#' `vhas_*()` functions check properties of xmap links and/or candidate links.
#' The functions only accepts equal length vector inputs to support multiple link formats,
#' but does not check if the inputs are from the same xmap.
#' @param v_from,v_to,v_weights equal length vectors containing the source-target node pairs
#'
#' @return TRUE or FALSE
#'
#' @name vhas
NULL
```

#### Crossmap Property Flags

A valid Crossmap satisfies the following conditions:

1.  There is at most one link between each distinct source and target node (`has_dup_pairs()`)
2.  For each source node, the sum of weights attached to all outgoing links sums to one. (`has_complete_weights()`)

```{r send_to="R/vhas.R"}
#' @describeIn vhas Returns TRUE if xmap does not have
#' duplicate pairs of source-target nodes (irrespective of weights)
#'
vhas_no_dup_pairs <- function(v_from, v_to) {
  stopifnot(is.vector(v_from))
  stopifnot(is.vector(v_to))
  stopifnot(identical(length(v_from), length(v_to)))
  links <- data.frame(v_from, v_to)
  dup_idx <- anyDuplicated(links)
  !as.logical(dup_idx)
}
```

```{r send_to="R/vhas.R"}
#' @describeIn vhas Returns TRUE if all weights for a given `from` label
#' sum to one (approximately)
#' @param tol numeric \eqn{\ge 0}. Ignore differences smaller than `tol`.
#' Passed through to the `tolerance` arg of `base::all.equal()`.
vhas_complete_weights <- function(v_from, v_weights, tol = .Machine$double.eps^0.5) {
  stopifnot(is.vector(v_from))
  stopifnot(is.vector(v_weights))
  stopifnot(identical(length(v_from), length(v_weights)))
  sum_w <- tapply(
    X = v_weights,
    INDEX = v_from,
    FUN = sum,
    simplify = TRUE
  ) |> as.vector()
  names(sum_w) <- NULL
  ones <- rep(1, length(sum_w))
  all(isTRUE(all.equal(sum_w, ones, tolerance = tol)))
}
```

```{r send_to="R/vhas.R"}
.calc_vector_lens <- function(...) {
  v_list <- list(...)
  v_lens <- sapply(v_list, length)
  return(v_lens)
}
```

```{r send_to="R/vhas.R"}
#' @describeIn vhas Returns TRUE if links have no duplicate pairs and complete weights
vhas_xmap_props <- function(v_from, v_to, v_weights) {
  ## check vectors are equal length
  v_lengths <- .calc_vector_lens(v_from, v_to, v_weights)
  stopifnot(length(unique(v_lengths)) == 1)

  ## check properties
  v_props <- c(
    pairs = vhas_no_dup_pairs(v_from, v_to),
    weights = vhas_complete_weights(v_from, v_weights)
  )
  all(v_props)
}
```

```{r test-has-flags}
testthat::test_that(
  "vhas_* xmap validation helpers work as expected on valid df",
  {
    df <- tibble::tribble(
      ~from, ~to, ~weights,
      "A1", "B01", 1,
      "A2", "B02", 1,
      "A3", "B02", 1,
      "A4", "B03", 0.67,
      "A4", "B04", 0.33
    )
    testthat::expect_true(vhas_no_dup_pairs(df$from, df$to))
    testthat::expect_true(vhas_complete_weights(df$from, df$weights))
    testthat::expect_true(vhas_xmap_props(df$from, df$to, df$weights))
  }
)

testthat::test_that(
  "vhas_* xmap validation helpers catch invalid df",
  {
    df <- tibble::tribble(
      ~from, ~to, ~weights,
      "A1", "B01", 1,
      "A2", "B02", 0.3,
      "A2", "B02", 0.5
    )
    testthat::expect_false(vhas_complete_weights(df$from, df$weights))
    testthat::expect_false(vhas_no_dup_pairs(df$from, df$to))
  }
)

testthat::test_that(
  "vhas_complete_weights() works on recurring fractional weights",
  {
    df <- data.frame(
      key1 = rep("A1", 3),
      key2 = c("B01", "B02", "B03"),
      share = rep(1 / 3, 3)
    )

    testthat::expect_true(vhas_complete_weights(df$key1, df$share))
  }
)
```

#### Relation Type Flags

-   used for print methods, reverse

```{r print-helpers, send_to="R/vhas.R"}
#' @describeIn vhas Return TRUE if xmap recodes labels between `from` and `to`
vhas_1to1 <- function(v_weights) {
  stopifnot(is.vector(v_weights))
  any(v_weights == 1)
}
#'
vhas_recode <- vhas_1to1

#' @describeIn vhas Return TRUE if xmap has splitting links between `from` and `to`
vhas_1toM <- function(v_weights) {
  stopifnot(is.vector(v_weights))
  any(v_weights < 1)
}
#'
vhas_split <- vhas_1toM

#' @describeIn vhas Return TRUE if xmap has collapsing links between `from` and `to`
vhas_1fromM <- function(v_to) {
  stopifnot(is.vector(v_to))
  as.logical(anyDuplicated(v_to))
}
#'
vhas_collapse <- vhas_1fromM
```

```{r}
testthat::test_that(
  "vhas_* relation type flag functions work as expected",
  {
    w_1to1 <- rep(1, 10)
    w_1toM <- rep(1 / 6, 6)
    to_1fromM <- rep("country", 4)
    testthat::expect_true(vhas_recode(w_1to1))
    testthat::expect_false(vhas_recode(w_1toM))
    testthat::expect_true(vhas_split(w_1toM))
    testthat::expect_false(vhas_split(w_1to1))
    testthat::expect_true(vhas_collapse(to_1fromM))
  }
)
```

### Helper: df property checks

#### Abort Missing Columns

```{r send_to="R/abort.R"}
#' @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)
}
```

#### Abort Missing Values

```{r send_to="R/abort.R"}
#' @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)
}
```

### Verify: Named

-   note that `list(fruit = c("apple", "banana"))` and `c(fruit = c("apple", "banana"))` return different `names()`. `c()` generates unique names: `fruit1` and `fruit2`:

``` r
# > c(fruit = c("apple", "banana"))
#   fruit1   fruit2
#  "apple" "banana"
```

```{r send_to="R/verify_named.R"}
#' Verify crossmap properties of named vectors or lists
#'
#' @param x a Named vector or list. Lists values are flattened via `unlist()`.
#'
#' @return `x` or throws an error
#' @name verify_named
#' @examples
#' ## check each fruit has a unique color
#' fruit_color <- c(apple = "green", strawberry = "red", banana = "yellow")
#' verify_named_all_1to1(fruit_color)
#'
#' ## check no student is assigned to multiple groups
#' student_groups <- list(
#'   GRP1 = c("kate", "jane", "peter"),
#'   GRP2 = c("terry", "ben", "grace"),
#'   GRP3 = c("cindy", "lucy", "alex")
#' )
#' verify_named_no_dup_names(student_groups)
#'
#' ## check
NULL
```

Verify pairwise properties:

```{r send_to="R/verify_named.R"}
#' @describeIn verify_named Verify named vector or list has only one-to-one relations
#' @export
#'
verify_named_all_1to1 <- function(x) {
  stopifnot(is.vector(x))
  unique_names <- unique(names(x))
  unique_values <- unique(unlist(unname(x)))
  stop <- !(length(unique_names) == length(unique_values))
  if (stop) {
    cli::cli_abort("Not all relations in `x` are 1-to-1.",
      class = "abort_not_1to1"
    )
  }
  invisible(x)
}

#' @describeIn verify_named Verify name-value pairs of named vector or list are not duplicated
#' @export
verify_named_all_unique <- function(x) {
  stopifnot(is.vector(x))
  pairs <- as_pairs_from_named(x)
  dup_idx <- anyDuplicated(pairs)
  stop <- as.logical(dup_idx)
  if (stop) {
    cli::cli_abort(
      c(
        "Duplicated pairs found in `x`.",
        "i" = "Use `as_pairs_from_named(x) |> base::duplicated()` to identify duplicates."
      ),
      class = "abort_not_unique"
    )
  }
  invisible(x)
}

#' @describeIn verify_named Verify names of named vector or list are not duplicated
#' @export
verify_named_all_names_unique <- function(x) {
  stopifnot(is.vector(x))
  dup_idx <- anyDuplicated(names(x))
  stop <- as.logical(dup_idx)
  if (stop) {
    cli::cli_abort(
      c(
        "Duplicated names found in `x`.",
        "i" = "Use `base::duplicated(names(x))` to identify duplicates."
      ),
      class = "abort_not_unique"
    )
  }
  invisible(x)
}

#' @describeIn verify_named Verify values in named vector or list are not duplicated (after unnesting)
#' @export
verify_named_all_values_unique <- function(x) {
  stopifnot(is.vector(x))
  dup_idx <- anyDuplicated(unlist(unname(x)))
  stop <- as.logical(dup_idx)
  if (stop) {
    cli::cli_abort(
      c(
        "Duplicated values found in `x`.",
        "i" = "Use `base::duplicated(unlist(unname(x)))` to identify duplicates."
      ),
      class = "abort_not_unique"
    )
  }
  # stopifnot(unlist(unname(x)) == unique(unlist(unname(student_groups))))
  invisible(x)
}
```

```{r}
testthat::test_that("verify_named_all_1to1() works as expected", {
  v1toM <- c(fruit = "apple", fruit = "banana")
  v1to1 <- c(A = 1, B = 2, C = 3)
  l1toM <- list(fruit = c("apple", "banana"))
  testthat::expect_error(verify_named_all_1to1(v1toM), class = "abort_not_1to1")
  testthat::expect_error(verify_named_all_1to1(l1toM), class = "abort_not_1to1")
  testthat::expect_equal(verify_named_all_1to1(v1to1), v1to1)
})

testthat::test_that("verify_named_*_unique() work as expected", {
  vdup_pairs <- c(fruit = "apple", fruit = "apple")
  ldup_pairs <- list(fruit = c("apple", "apple"))
  testthat::expect_error(verify_named_all_unique(vdup_pairs), class = "abort_not_unique")
  testthat::expect_error(verify_named_all_unique(ldup_pairs), class = "abort_not_unique")
  vdup_names <- c(fruit = "apple", fruit = "banana")
  ldup_names <- list(fruit = c("apple", "banana"), fruit = "pear")
  testthat::expect_error(verify_named_all_names_unique(vdup_names), class = "abort_not_unique")
  testthat::expect_error(verify_named_all_names_unique(ldup_names), class = "abort_not_unique")
  vdup_values <- c(fruit = "apple", veg = "apple")
  ldup_values <- list(fruit = c("apple", "banana"), veg = "apple")
  testthat::expect_error(verify_named_all_values_unique(vdup_values), class = "abort_not_unique")
  testthat::expect_error(verify_named_all_values_unique(ldup_values), class = "abort_not_unique")
})
```

```{r send_to="R/verify_named.R"}
#' @describeIn abort Abort message for verify_named_matchset_* functions
#' @export
msg_abort_named_matchset <- function(set_type = c("names", "values"),
                                     match_type = c("exact", "within", "contain")) {
  match_text <- switch(match_type,
    exact = "do not exactly match",
    within = "are not all within",
    contain = "do not contain all elements of"
  )

  cli::format_error("The {set_type} of {.var x} {match_text} {.var ref_set}")
}

#' Verify unique names or values of named vector or list match expected set
#'
#' @name verify_named_matchset
#' @inheritParams verify_named
#' @param ref_set a vector of character strings
#'
#' @return `x` or throw an error
#' @examples
#' fruit_color <- c(apple = "green", strawberry = "red", banana = "yellow")
#' fruit_set <- c("apple", "strawberry", "banana", "pear")
#' fruit_color |>
#'   verify_named_matchset_names_within(ref_set = fruit_set)
NULL

#' @describeIn verify_named_matchset Names of `x` **exactly** match `ref_set`
#' @export
verify_named_matchset_names_exact <- function(x, ref_set) {
  stopifnot(is.vector(x))
  unique_names <- unique(names(x))
  stop <- !setequal(ref_set, unique_names)
  if (stop) {
    cli::cli_abort(msg_abort_named_matchset("names", "exact"),
      class = "abort_matchset"
    )
  }
  invisible(x)
}

#' @describeIn verify_named_matchset Values of `x` **exactly** match `ref_set`
#' @export
verify_named_matchset_values_exact <- function(x, ref_set) {
  stopifnot(is.vector(x))
  unique_values <- unique(unlist(unname(x)))
  stop <- !setequal(ref_set, unique_values)
  if (stop) {
    cli::cli_abort(msg_abort_named_matchset("values", "exact"),
      class = "abort_matchset"
    )
  }
  invisible(x)
}

#' @describeIn verify_named_matchset Names of `x` **contain** all of `ref_set`
#' @export
verify_named_matchset_names_contain <- function(x, ref_set) {
  stopifnot(is.vector(x))
  unique_names <- unique(names(x))
  stop <- !all(ref_set %in% unique_names)
  if (stop) {
    cli::cli_abort(msg_abort_named_matchset("names", "contain"),
      class = "abort_matchset"
    )
  }
  invisible(x)
}

#' @describeIn verify_named_matchset Values of `x` **contain** all of `ref_set`
#' @export
verify_named_matchset_values_contain <- function(x, ref_set) {
  stopifnot(is.vector(x))
  unique_values <- unique(unlist(unname(x)))
  stop <- !all(ref_set %in% unique_values)
  if (stop) {
    cli::cli_abort(msg_abort_named_matchset("values", "contain"),
      class = "abort_matchset"
    )
  }
  invisible(x)
}

#' @describeIn verify_named_matchset Names of `x` are all **within** `ref_set`
#' @export
verify_named_matchset_names_within <- function(x, ref_set) {
  stopifnot(is.vector(x))
  unique_x <- unique(names(x))
  stop <- !all(unique_x %in% ref_set)
  if (stop) {
    cli::cli_abort(msg_abort_named_matchset("names", "within"),
      class = "abort_matchset"
    )
  }
  invisible(x)
}

#' @describeIn verify_named_matchset Values of `x` are all **within** `ref_set`
#' @export
verify_named_matchset_values_within <- function(x, ref_set) {
  stopifnot(is.vector(x))
  unique_x <- unique(unlist(unname(x)))
  stop <- !all(unique_x %in% ref_set)
  if (stop) {
    cli::cli_abort(msg_abort_named_matchset("values", "within"),
      class = "abort_matchset"
    )
  }
  invisible(x)
}
```

Tests:

```{r}
testthat::test_that("verify_named_matchset fncs work as expected", {
  v_1to1 <- c(x1 = 1, x2 = 2, x3 = 3)
  refn_exact_1to1 <- c("x1", "x2", "x3")
  refn_subset_1to1 <- c("x1", "x2")
  refn_superset_1to1 <- c("x1", "x2", "x3", "x4")
  testthat::expect_equal(verify_named_matchset_names_exact(v_1to1, refn_exact_1to1), v_1to1)
  testthat::expect_error(verify_named_matchset_names_exact(v_1to1, c("not", "right")),
    class = "abort_matchset"
  )
  testthat::expect_equal(verify_named_matchset_names_contain(v_1to1, refn_subset_1to1), v_1to1)
  testthat::expect_equal(verify_named_matchset_names_contain(v_1to1, refn_exact_1to1), v_1to1)
  testthat::expect_error(verify_named_matchset_names_contain(v_1to1, refn_superset_1to1),
    class = "abort_matchset"
  )
  testthat::expect_equal(verify_named_matchset_names_within(v_1to1, refn_superset_1to1), v_1to1)
  testthat::expect_equal(verify_named_matchset_names_within(v_1to1, refn_exact_1to1), v_1to1)
  testthat::expect_error(verify_named_matchset_names_within(v_1to1, refn_subset_1to1),
    class = "abort_matchset"
  )
  refv_exact_1to1 <- c(1, 2, 3)
  refv_subset_1to1 <- c(1, 2)
  refv_superset_1to1 <- c(1, 2, 3, 4)
  testthat::expect_equal(verify_named_matchset_values_exact(v_1to1, refv_exact_1to1), v_1to1)
  testthat::expect_error(verify_named_matchset_values_exact(v_1to1, c("not", "right")),
    class = "abort_matchset"
  )
  testthat::expect_equal(verify_named_matchset_values_contain(v_1to1, refv_subset_1to1), v_1to1)
  testthat::expect_equal(verify_named_matchset_values_contain(v_1to1, refv_exact_1to1), v_1to1)
  testthat::expect_error(verify_named_matchset_values_contain(v_1to1, refv_superset_1to1),
    class = "abort_matchset"
  )
  testthat::expect_equal(verify_named_matchset_values_within(v_1to1, refv_superset_1to1), v_1to1)
  testthat::expect_equal(verify_named_matchset_values_within(v_1to1, refv_exact_1to1), v_1to1)
  testthat::expect_error(verify_named_matchset_values_within(v_1to1, refv_subset_1to1),
    class = "abort_matchset"
  )
})
```

Aliases:

``` r
#{r verify-named-aliases, send_to="R/verify_named.R"}
#' @describeIn verify_named Alias of `verify_named_all_1to1()`
#' @export
verify_named_as_recode_unique <- verify_named_all_1to1

#' @describeIn verify_named Alias of `verify_named_all_values_unique()`
#' @export
verify_named_no_dup_values <- verify_named_all_values_unique

#' @describeIn verify_named Alias of `verify_named_all_names_unique()`
#' @export
verify_named_no_dup_names <- verify_named_all_names_unique
```

### Verify: Pairs

```{r send_to="R/verify_pairs.R"}
#' Verify crossmap properties of column pairs
#'
#' @param df a data frame-like object with at least two columns
#' @inheritParams verify_links_as_xmap
#'
#' @return `df` or error
#' @name verify_pairs
NULL

#' @describeIn verify_pairs Verify column pairs have only one-to-one relations
#' @export
verify_pairs_all_1to1 <- function(df, from, to) {
  stopifnot(is.data.frame(df))
  set_from <- unique(df[[rlang::englue("{{from}}")]])
  set_to <- unique(df[[rlang::englue("{{to}}")]])
  stopifnot(length(set_from) == length(set_to))
  invisible(df)
}

#' @describeIn verify_pairs Verify column pairs are all unique
#' @export
verify_pairs_all_unique <- function(df, from, to) {
  stopifnot(is.data.frame(df))
  pairs <- dplyr::select(df, {{ from }}, {{ to }})
  stopifnot(!as.logical(anyDuplicated(pairs)))
  invisible(df)
}

#' @describeIn verify_pairs Alias of `verify_pairs_all_1to1`
#' @export
verify_pairs_as_recode_unique <- verify_pairs_all_1to1
```

```{r send_to="R/verify_pairs.R"}
# @describeIn verify_pairs Verify column pairs outgoing link degree
verify_pairs_out <- function(x, from, to, max_out, min_out) {
  # TODO: FINISH THIS!
  dplyr::group_by(x, {{ from }}) |>
    dplyr::summarise()
}
```

```{r}
testthat::test_that("verify_pairs_* work as expected", {
  v_1to1 <- c(x1 = 1, x2 = 2, x3 = 3)
  pairs_1to1 <- tibble::enframe(v_1to1, "f", "t")
  testthat::expect_identical(verify_pairs_all_1to1(pairs_1to1, f, t), pairs_1to1)
  testthat::expect_identical(verify_pairs_all_unique(pairs_1to1, f, t), pairs_1to1)
})
```

### Verify: Links

`abort_*(df,...)` all take an data.frame for first argument, and character values or vectors for the remaining arguments. They throw an error if the validation condition does not pass, and `NULL` otherwise.

```{r send_to="R/abort.R"}
#' 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
```

#### Column Type Check

```{r send_to="R/abort.R"}
#' @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)
}
```

#### No Duplicate Node Pairs (links)

```{r send_to="R/abort.R"}
#' @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)
}
```

#### Complete Mapping Weights

```{r fnc-check-weights, send_to="R/abort.R"}
#' @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
  )
}
```

### Helper: Add fractional weights

```{r fnc-add-weights-frac, send_to="R/add_weights.R"}
#' @describeIn add_weights Attach equal fractional weights by `from` group
#' @export
#' @examples
#' # fractional weights
#' 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") {
  abort_dup_pairs(df, rlang::englue("{{from}}"), rlang::englue("{{to}}"))
  df |>
    dplyr::group_by({{ from }}) |>
    dplyr::mutate("{weights_into}" := 1 / dplyr::n_distinct({{ to }})) |>
    dplyr::ungroup()
}

#' @describeIn add_weights Attach weights by `from` group using proportion reference `prop`
#' @export
#' @examples
#' # proportional weights
#' data.frame(
#'   recipe = c(rep("cake", 4), rep("pasta", 2)),
#'   ingredients = c(c("flour", "sugar", "eggs", "milk"), c("flour", "water")),
#'   grams = c(c(500, 250, 200, 250), c(250, 150))
#' ) |>
#'   add_weights_prop(recipe, ingredients, grams)
add_weights_prop <- function(df, from, to, prop, weights_into = "weights") {
  abort_dup_pairs(df, rlang::englue("{{from}}"), rlang::englue("{{to}}"))
  abort_any_na(df)
  df |>
    dplyr::group_by({{ from }}) |>
    dplyr::mutate("{weights_into}" := {{ prop }} / sum({{ prop }})) |>
    dplyr::ungroup()
}
```

```{r}
testthat::test_that("add_weights_*() work as expected", {
  # equal
  animal_pairs <- list(
    MAMM = c("elephant", "whale", "monkey"),
    REPT = c("lizard", "turtle"),
    CRUS = c("crab")
  ) |>
    as_pairs_from_named("class", "animal")
  animal_links <- animal_pairs |>
    dplyr::group_by(class) |>
    dplyr::mutate(weights = 1 / dplyr::n_distinct(animal)) |>
    dplyr::ungroup()
  animal_add <- animal_pairs |>
    add_weights_equal(from = class, to = animal, weights_into = "weights")
  testthat::expect_equal(animal_links, animal_add)
  # prop
  recipe_df <- data.frame(
    recipe = c(rep("cake", 4), rep("pasta", 2)),
    ingredients = c(c("flour", "sugar", "eggs", "milk"), c("flour", "water")),
    grams = c(c(500, 250, 200, 250), c(250, 150))
  )
  recipe_links <- recipe_df |>
    dplyr::group_by(recipe) |>
    dplyr::mutate(weights = grams / sum(grams)) |>
    dplyr::ungroup()
  recipe_add <- recipe_df |>
    add_weights_prop(recipe, ingredients, grams)
  testthat::expect_equal(recipe_links, recipe_add)
})
```

### `verify_links_as_xmap()`

```{r fnc-verify-links-as-xmap}
#' Check if candidate links meet crossmap properties
#'
#' The links must satisfy:
#'  - no missing values
#'  - at most one link between each unique source and target node
#'  - the weights on links coming out of each source node sum to 1
#'
#' @param df data.frame like object containing candidate links
#' @inheritParams vhas_complete_weights
#' @inheritParams as_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)
#' )
#' verify_links_as_xmap(links, from = a, to = b, weights = w)
verify_links_as_xmap <- function(df, from, to, weights, tol = .Machine$double.eps^0.5) {
  col_from <- deparse(substitute(from))
  col_to <- deparse(substitute(to))
  col_weights <- deparse(substitute(weights))
  col_attrs <- c(col_from, col_to, col_weights)
  abort_missing_cols(df, col_attrs)
  abort_any_na(df)
  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)
  }

  invisible(df)
}
```

## `xmap` Class Structure

The package uses the class `xmap` as the superclass for all representations of a crossmaps, and subclasses: `xmap_df`

### `xmap` parent class properties

`xmap` is a virtual parent class indicating the object is a "crossmap", and satisfies the mathematical properties of a "crossmap" shared by all representations.

Let `g` be an object of class `xmap`. Then `g`:

-   has only one weighted link between each source-target pair of form:
-   `{source: "A1", target: "B01", weight: 1}`
-   for every source node, the weights on all (outgoing) links sum to 1 (subject to some floating point tolerance?)

### `xmap_df` subclass properties

`xmap_df` is a concrete subclass for encoding crossmaps as lists of graph edges with attributes indicating the node sets and direction of the map.

Let `X` be an **validated** object of class `xmap_df`. Then:

-   `X` inherits from the class `xmap_df`
-   `X` is a data.frame-like object and:
    -   contains the columns named in the `col_from`, `col_to`, `col_weights` attributes
    -   has no missing values - the character vector of all unique values in the `col_from` variable exactly match the `from_set` attribute - the `col_weights` column is a numeric vector - `X` inherits from the class `xmap`
    -   (each row represents a single weighted link)

### `xmap_df` column vector types

- `pct` print as percentage

## Vctrs definitions

### `xmap_to` and `xmap_from` character vectors

- use factor as base type?

### `xmap_percent` double class for weights

```{r send_to="R/vctrs.R"}
# --- xmap_percent -----------------------------------------------------------

## constructor
new_percent <- function(x = double()) {
  if (!is_double(x)) {
    abort("`x` must be a double vector.")
  }
  vctrs::new_vctr(x, class = "xmap_percent")
}

## helpers
percent <- function(x = double()) {
  x <- vctrs::vec_cast(x, double())
  new_percent(x)
}

is_percent <- function(x) {
  inherits(x, "xmap_percent")
}

## printing
format.xmap_percent <- function(x, ...) {
  out <- formatC(signif(vctrs::vec_data(x) * 100, 3))
  out[is.na(x)] <- NA
  out[!is.na(x)] <- paste0(out[!is.na(x)], "%")
  out
}

vec_ptype_abbr.xmap_percent <- function(x, ...) {
  "pct"
}

## casting and coercion
vec_ptype2.xmap_percent.double <- function(x, y, ...) double()
vec_ptype2.double.xmap_percent <- function(x, y, ...) double()

vec_cast.xmap_percent.xmap_percent <- function(x, to, ...) x
vec_cast.xmap_percent.double <- function(x, to, ...) percent(x)
vec_cast.double.xmap_percent <- function(x, to, ...) vec_data(x)
```

```{r}
x <- new_percent(c(seq(0, 1, length.out = 4), NA))

tibble::tibble(x)

str(x)
```

## Data Frame Construction

The naming convention for constructors is: `new_<subclass>()`. For example: `new_xmap_df()`

### Helper for subclass attributes

Eventually support matrix, graph, and data.frame?

```{r send_to="R/new_xmap.R"}
#'
.calc_xmap_subclass_attr <- function(subclass = c("xmap_df")) {
  subclass <- rlang::arg_match(subclass)

  class_attr <- switch(subclass,
    xmap_df = c("xmap_df", "xmap", "data.frame"),
    stop("Unknown xmap subclass")
  )

  return(class_attr)
}
```

```{r}
testthat::test_that(".calc_xmap_subclass_attr() rejects unknown subclass", {
  testthat::expect_error(.calc_xmap_subclass_attr("unknown"))
})
```

### Construct From Links Data Frame

The low-level constructor takes in:

-   one data argument (`x`), accepts base objects of type data.frames (and subclasses)
-   three required descriptor arguments (`from`, `to`, `weights`) which are stored as attributes, and must be character strings only.
-   one optional descriptor argument (`from_set`) which is stored as an attribute, and must be a character vector.

The constructor does the following:

-   checks base object and attribute types.
-   checks the descriptor argument types.
-   if `from_set` is not provided, naively generates the `from_set` of unique `from` values
-   appends the class attributes: `xmap_df` and `xmap`

It assumed, but not checked that:

-   (`x` contains the column named in `from`, `to`, `weights` arguments?)
-   (the `from_set` vector attributes contains all unique values of `from` column in `x`)
-   (the `weights` column contains numeric weights)

The constructor returns an object of class `xmap_df` which:

-   inherits from classes: `data.frame`, `xmap_df`, `xmap`
-   has additional attributes named using graph terminology:
    -   `col_from`: source nodes
    -   `col_to`: target nodes
    -   `col_weights`: link weights
    -   `from_set`: source node set

```{r xmap-constructor, send_to="R/xmap_df.R"}
#' Low Level Constructors for xmap subclasses
#' @param x data-frame object containing candidate links.
#' @param col_from,col_to,col_weights character strings naming columns containing source nodes, target nodes and numeric weights.
#' @return xmap_df object. Note that this function unclasses tibbles.
#' @name new_xmap
NULL

#' @describeIn new_xmap Construct xmap_df from data.frame
new_xmap_df <- function(x, col_from, col_to, col_weights, from_set = NULL) {
  #' checks argument types
  stopifnot(is.data.frame(x))
  stopifnot(length(col_from) == 1 && is.character(col_from))
  stopifnot(length(col_to) == 1 && is.character(col_to))
  stopifnot(length(col_weights) == 1 && is.character(col_weights))

  #' naively generates `from_set` if it is missing
  from_set <- from_set %||% as.character(unique(x[[col_from]]))
  stopifnot(is.vector(from_set, mode = "character"))

  #' @return `x` with additional subclasses `xmap_df` and `xmap`

  class(x) <- .calc_xmap_subclass_attr("xmap_df")
  structure(x,
    col_from = col_from,
    col_to = col_to,
    col_weights = col_weights,
    from_set = from_set
  )
}
```

Tests:

```{r test-constructor-success}
testthat::test_that(
  "new_xmap_df() accepts arbitrary data.frames with correct from argument",
  {
    df <- data.frame(
      x = letters[1:5],
      y = 1:5,
      z = runif(5)
    )
    xmap <- new_xmap_df(x = df, "x", "y", "z")
    xmap_attrs <- attributes(xmap)
    testthat::expect_s3_class(xmap, .calc_xmap_subclass_attr("xmap_df"))
    testthat::expect_identical(xmap_attrs$col_from, "x")
    testthat::expect_identical(xmap_attrs$col_to, "y")
    testthat::expect_identical(xmap_attrs$col_weights, "z")
    testthat::expect_identical(xmap_attrs$from_set, unique(df$x))
  }
)
```

Snapshot tests don't work in litr

``` r
testthat::test_that(
  "new_xmap_df() rejects incorrect object types",
  {
    testthat::local_edition(3)
    testthat::expect_snapshot(error = TRUE, new_xmap_df(x = "not a data.frame"))
    testthat::expect_snapshot(error = TRUE, new_xmap_df(from = 33))
    testthat::expect_snapshot(error = TRUE, new_xmap_df(from = "chr", to = expression(5 + 9)))
    testthat::expect_snapshot(error = TRUE, new_xmap_df(from = "chr", to = "char", weights = c("dsf", "3925")))
  }
)
```

### Class Tests

```{r send_to="R/is_xmap.R"}
#' Test if object is a crossmap
#'
#' This function returns `TRUE` for crossmaps `xmap` or subclasses thereof (`xmap_df`), and `FALSE` for all other objects, including regular data.frames or tibbles.
#' @export
#' @rdname as_xmap
is_xmap <- function(x) {
  base::inherits(x, "xmap")
}

#' Test if object is `xmap_df`
#' @export
#' @rdname as_xmap
is_xmap_df <- function(x) {
  rlang::inherits_all(x, c("xmap_df", "xmap"))
}
```

## Validation: `xmap_df`

### Diagnostic Helpers (`validate-helpers.R`)

The conventions for validation helpers:

#### Column Order Check

```{r send_to="R/abort.R"}
#' @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)
}
```

```{r}
testthat::test_that("abort_col_order() works as expected", {
  df <- data.frame(a = 1, b = 2, c = 3)
  testthat::expect_invisible(abort_col_order(df, "a", "b", "c"))
  testthat::expect_identical(abort_col_order(df, "a", "b", "c"), df)
  testthat::expect_error(abort_col_order(df, "b", "a", "c"),
    class = "abort_col_order"
  )
})
```

#### From Set Check

```{r send_to="R/calc.R"}
#'
.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)
}

#'
.calc_all_nodes.xmap_df <- function(x) {
  uniq_sets <- .calc_unique_sets.xmap_df(x)
  nodes <- unname(unlist(uniq_sets))
}
```

```{r send_to="R/abort.R"}
#' @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)
}
```

#### Tests

`df_check*` fncs are currently checked as part of the master validator `validate_xmap_df()`.

### Internal: `validate_xmap_df()`

-   order checks from cheapest to most expensive
-   validates data.frame properties:
    -   contains columns named in attributes
        -   (implies df has at least `3` columns) -- ncol3 check removed as discussed in [conformr-project #57](https://github.com/cynthiahqy/conformr-project/issues/57#issuecomment-1401239494)
    -   has no missing values in ANY column
    -   from_set attributes matches unique values in `from` column
    -   weights column is `numeric`
-   does not check graph properties:
    -   A: duplicate source-target rows (weights should be collapsed into a single row)
    -   B: no missing weights (checked above with missing values)
    -   C: `sum()` of values in weights column by source-code is `1` (or subject to floating point tolerance)
        -   C will also fail if B fails, but not if A fails.

```{r send_to="R/get-helpers.R"}
#'
.get_col_attrs.xmap_df <- function(x) {
  stopifnot(is_xmap_df(x))
  x_attrs <- attributes(x)
  col_attrs <- x_attrs[startsWith(names(x_attrs), "col")]
  return(col_attrs)
}
```

```{r xmap-validator}
#' Validator for `xmap_df` class (INTERNAL)
#'
#' Only checks class attributes, not crossmap graph properties.
#' Use `verify_links_as_xmap()` or `as_xmap()` to verify graph
#' properties
validate_xmap_df <- function(x) {
  stopifnot(is_xmap_df(x))

  df <- data.frame(x) # unclass(x)
  x_attrs <- attributes(x)
  col_attrs <- c(x_attrs$col_from, x_attrs$col_to, x_attrs$col_weights)

  ## ---- df attributes ----
  abort_missing_cols(df, col_attrs)
  abort_any_na(df)

  ## ---- xmap_df attributes ---
  abort_col_order(df, x_attrs$col_from, x_attrs$col_to, x_attrs$col_weights)
  abort_from_set(df, x_attrs$col_from, x_attrs$from_set)

  ## return original object
  invisible(x)
}
```

#### Tests for `validate & verify()`

```{r test-validator-success}
testthat::test_that(
  "validate & verify xmap fncs accept well-formed xmaps",
  {
    df <- tibble::tribble(
      ~node_A, ~node_B, ~w_AB,
      "A1", "B01", 1,
      "A2", "B02", 1,
      "A3", "B02", 1,
      "A4", "B03", 0.25,
      "A4", "B04", 0.75
    )
    x <- new_xmap_df(df, "node_A", "node_B", "w_AB")
    out <- testthat::expect_invisible(validate_xmap_df(x))
    testthat::expect_identical(out, x)
    testthat::expect_identical(df, verify_links_as_xmap(df, node_A, node_B, w_AB))
  }
)
```

```{r test-validator-malformed}
## columns present
testthat::test_that(
  "validate & verify fncs reject missing columns",
  {
    df <- tibble::tribble(
      ~from, ~to, ~weights,
      "A1", "B01", 1
    )
    x <- new_xmap_df(df, "from", "missing_col", "weights")
    testthat::expect_error(abort_missing_cols(df, c("from", "missing_col", "weights")),
      class = "abort_missing_cols"
    )
    testthat::expect_error(validate_xmap_df(x),
      class = "abort_missing_cols"
    )
    testthat::expect_error(verify_links_as_xmap(df, node_A, node_B, w_AB),
      class = "abort_missing_cols"
    )
  }
)

## any NA values
testthat::test_that(
  "validate & verify xmap fncs reject missing values",
  {
    df <- tibble::tribble(
      ~from, ~to, ~weights,
      "A1", "B2", NA,
      NA, "B2", NA,
      "A3", "B1", 1
    )
    x <- new_xmap_df(df, "from", "to", "weights")
    testthat::expect_error(validate_xmap_df(x), class = "abort_na")
    testthat::expect_error(verify_links_as_xmap(df, from, to, weights),
      class = "abort_na"
    )
  }
)


## column type
testthat::test_that(
  "validate & verify xmap fncs reject non-numeric weight columns",
  {
    df <- tibble::tribble(
      ~f, ~t, ~w,
      "A1", "B01", 1,
      "A4", "B03", 0.25,
      "A4", "B04", 0.75
    ) |>
      dplyr::mutate(w = as.character(w))
    testthat::expect_error(abort_weights_col_type(df, "weights"),
      class = "abort_col_type"
    )
    x <- new_xmap_df(df, "f", "t", "w")
    testthat::expect_error(verify_links_as_xmap(df, f, t, w),
      class = "abort_col_type"
    )
  }
)

## from set check
testthat::test_that(
  "validate_xmap_df() rejects mismatching from_set",
  {
    df <- tibble::tribble(
      ~from, ~to, ~weights,
      "A1", "B01", 1,
      "A4", "B03", 0.25,
      "A4", "B04", 0.75
    )
    bad_set <- c("bad set", "of", "nodes")
    testthat::expect_error(abort_from_set(df, "from", bad_set))
    x <- new_xmap_df(df, "from", "to", "weights", from_set = bad_set)
    testthat::expect_error(validate_xmap_df(x))
  }
)

## duplicate links
testthat::test_that(
  "validate and verify xmap fncs reject duplicate from-to links",
  {
    df <- tibble::tribble(
      ~f, ~t, ~w,
      "A1", "B02", 0.3,
      "A1", "B02", 1
    )
    testthat::expect_error(abort_dup_pairs(df, "f", "t"), class = "abort_dup_pairs")
    x <- new_xmap_df(df, "f", "t", "w")
    testthat::expect_error(verify_links_as_xmap(df, f, t, w),
      class = "abort_dup_pairs"
    )
  }
)

## complete weights
testthat::test_that(
  "validate & verify xmap fncs rejects invalid weights",
  {
    df <- tibble::tribble(
      ~f, ~t, ~w,
      "A1", "B01", 0.4,
      "A1", "B02", 0.59
    )
    x <- new_xmap_df(df, "f", "t", "w")
    testthat::expect_error(verify_links_as_xmap(df, f, t, w),
      class = "abort_bad_weights"
    )
  }
)
```

## Coercion

### Generic: `as_xmap_df()`

```{r send_to="R/as_xmap.R"}
#' 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")
}
```

### `as_xmap_df.data.frame()`

-   checks for:
    -   [x] existence of columns via `validate_xmap_df()`
-   warns for:
    -   [x] dropping extra columns (anything other than `from`, `to`, `weights`) as controlled by `.drop` argument
-   throws errors for:
    -   [x] any validation failures via `validate_xmap_df()`

```{r send_to="R/as_xmap.R"}
#' @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 = NULL) {
  ## 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 extra columns
  if (is.null(.drop_extra)) {
    cli::cli_inform(c(
      "Dropping any additional columns in {.arg {deparse(substitute(x))}}",
      "i" = "To silence set `.drop_extra = TRUE`"
    ))
  }

  .drop_extra <- .drop_extra %||% TRUE

  if (.drop_extra) {
    df <- x[col_strings]
  } else {
    df <- 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}
testthat::test_that(
  "as_xmap() is returns expected xmap subclasses",
  {
    tbl_links <- tibble::tribble(
      ~f, ~t, ~w,
      "A1", "B01", 1,
      "A2", "B02", 1,
      "A3", "B02", 1,
      "A4", "B03", 0.67,
      "A4", "B04", 0.33
    )
    df_links <- as.data.frame(tbl_links)

    ## default subclasses work as expected
    testthat::expect_s3_class(
      as_xmap_df(df_links, f, t, w),
      .calc_xmap_subclass_attr("xmap_df")
    )

    ## override subclass works as well
    testthat::expect_s3_class(
      as_xmap_df(tbl_links, f, t, w, subclass = "xmap_df"),
      .calc_xmap_subclass_attr("xmap_df")
    )
  }
)
```

## Conversion

### to Matrix

#### Generic: `xmap_to_matrix()`

```{r send_to="R/xmap_to.R"}
#' Extract incidence matrix from xmap objects
#'
#' Transforms `xmap` objects into incidence matrix where the rows are indexed by the `from` values
#' and the columns are indexed by `to` values. Drops any additional variables.
#'
#' @param .xmap an xmap object
#' @param sparse logical specifying if the result should be a sparse matrix. Defaults to TRUE.
#' @param ... Reversed for passing arguments to `stats::xtabs`
#'
#' @return A matrix or sparse matrix object
#' @family {xmap coercion}
#'
#' @export
xmap_to_matrix <- function(.xmap, sparse, ...) {
  UseMethod("xmap_to_matrix")
}
```

#### Method: `xmap_to_matrix.xmap_df()`

```{r xmap-matrix, send_to="R/xmap_to.R"}
#' @describeIn xmap_to_matrix Coerce a `xmap_df` to a Matrix
#'
#' @export
#' @examples
#' abc_xmap <- data.frame(
#'   stringsAsFactors = FALSE,
#'   origin = c(
#'     "a", "b", "c", "d", "e",
#'     "f", "g", "h", "i", "i", "j", "j", "j"
#'   ),
#'   dest = c(
#'     "AA", "AA", "AA", "AA",
#'     "BB", "BB", "CC", "DD", "EE", "FF", "GG", "HH", "II"
#'   ),
#'   link = c(1, 1, 1, 1, 1, 1, 1, 1, 0.5, 0.5, 0.3, 0.3, 0.4)
#' ) |>
#'   as_xmap_df(origin, dest, link)
#' xmap_to_matrix(abc_xmap)
xmap_to_matrix.xmap_df <- function(.xmap, sparse = TRUE, ...) {
  x_attrs <- attributes(.xmap)
  df <- .xmap |> as.data.frame(stringsAsFactors = TRUE)
  fm <- paste(x_attrs$col_weights, "~", x_attrs$col_from, "+", x_attrs$col_to,
    collapse = ""
  )

  if (sparse) {
    x_mtx <- stats::xtabs(stats::as.formula(fm), df, sparse = TRUE)
  } else {
    x_mtx <- stats::xtabs(stats::as.formula(fm), df, sparse = FALSE)
    attr(x_mtx, "call") <- NULL
    unclass(x_mtx)
  }
  return(x_mtx)
}
```

```{r test-xmap-to-matrix}
testthat::test_that("xmap_to_matrix handles xmaps with different column counts", {
  links <- tibble::tribble(
    ~f, ~t, ~w,
    "A1", "B01", 1,
    "A2", "B02", 1,
    "A3", "B02", 1,
    "A4", "B03", 0.25,
    "A4", "B04", 0.75
  )
  xmap_small <- new_xmap_df(links, "f", "t", "w")

  links_extra <- links |>
    dplyr::mutate(ex = "extra")
  xmap_extra <- new_xmap_df(links_extra, "f", "t", "w")

  xmap_matrix_small <- xmap_small |> xmap_to_matrix()
  xmap_matrix_extra <- xmap_extra |> xmap_to_matrix()

  testthat::expect_identical(xmap_matrix_small, xmap_matrix_extra)
})
```

### to List:

```{r send_to="R/abort.R"}
#' @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"
  ))
}
```

#### `xmap_to_named()`

```{r send_to="R/xmap_to.R"}
#' Coerce a unit weight `xmap_df` to a named vector or list
#'
#' Checks that an `xmap` has unit weights, and converts the
#'   `from` values into:
#'   * a vector for `xmap_to_named_vector()`
#'   * a nested list for `xmap_to_named_list()`
#'
#' Names are the unique target nodes in `to`,
#'   and each element contains the source node(s) in `from`.
#'
#' @param .xmap xmap with only unit weights
#'
#' @return Named vector or list.
#' @export
#' @rdname xmap_to_named
#' @family {xmap coercion}
#'
#' @examples
#' iso_vector <- c(AF = "004", AL = "008", DZ = "012", AS = "016", AD = "020")
#' iso_xmap <- iso_vector |>
#'   as_pairs_from_named(names_to = "iso2c", values_to = "iso3n") |>
#'   add_weights_unit() |>
#'   as_xmap_df(from = iso3n, to = iso2c, weights)
#' identical(iso_vector, xmap_to_named_vector(iso_xmap))
xmap_to_named_vector <- function(.xmap) {
  stopifnot(is_xmap(.xmap))
  x_attrs <- attributes(.xmap)
  df <- as.data.frame(.xmap)
  # check only unit weights
  w <- df[[x_attrs$col_weights]]
  stop <- !all(w == 1)
  if (stop) {
    cli::cli_abort(msg_abort_frac_weights("Cannot convert to named vector"),
      class = "abort_frac_weights"
    )
  }

  # convert
  df |>
    subset(select = c(x_attrs$col_to, x_attrs$col_from)) |>
    tibble::deframe() |>
    sapply(as.matrix) |>
    sapply(as.vector)
}

#' @rdname xmap_to_named
#' @export
#'
#' @examples
#' animal_list <- list(
#'   MAMM = c("elephant", "whale", "monkey"),
#'   REPT = c("lizard", "turtle"),
#'   CRUS = c("crab")
#' )
#' animal_xmap <- animal_list |>
#'   as_pairs_from_named(names_to = "class", values_to = "animals") |>
#'   add_weights_unit() |>
#'   as_xmap_df(from = animals, to = class, weights = weights)
#' identical(xmap_to_named_list(animal_xmap), animal_list)
xmap_to_named_list <- function(.xmap) {
  stopifnot(is_xmap(.xmap))
  x_attrs <- attributes(.xmap)
  df <- as.data.frame(.xmap)
  # check only unit weights
  w <- df[[x_attrs$col_weights]]

  stop <- !all(w == 1)
  if (stop) {
    cli::cli_abort(msg_abort_frac_weights("Cannot convert to named list"),
      class = "abort_frac_weights"
    )
  }

  # convert
  df |>
    subset(select = c(x_attrs$col_to, x_attrs$col_from)) |>
    tidyr::nest(source = c(x_attrs$col_from)) |>
    tibble::deframe() |>
    sapply(as.matrix) |>
    sapply(as.vector) |>
    as.list()
}
```

```{r test-xmap-to-list}
testthat::test_that("xmap_to_named works as expected", {
  links <- tibble::tribble(
    ~f, ~t, ~w,
    "A1", "B01", 1,
    "A2", "B02", 1,
    "A3", "B02", 1,
    "A4", "B03", 0.25,
    "A4", "B04", 0.75
  )
  ## works for collapse relations
  xmap_unit <- new_xmap_df(links[1:3, ], "f", "t", "w")
  unit_list <- list(B01 = c("A1"), B02 = c("A2", "A3"))
  unit_vector <- tibble::deframe(xmap_unit[, c("t", "f")])
  testthat::expect_identical(unit_list, xmap_to_named_list(xmap_unit))
  testthat::expect_identical(unit_vector, xmap_to_named_vector(xmap_unit))
  ## rejects split relations
  xmap_mixed <- new_xmap_df(links, "f", "t", "w")
  testthat::expect_error(xmap_to_named_list(xmap_mixed),
    class = "abort_frac_weights"
  )
})
```

```{r}
testthat::test_that("xmap_to_named_list() reverses as_pairs_from_named()", {
  link_list <- list(
    AA = c("x3", "x4", "x6"),
    BB = c("x1", "x5"),
    CC = c("x2")
  )
  link_xmap <-
    as_pairs_from_named(
      link_list,
      "capital", "xvars"
    ) |>
    add_weights_unit(weights_into = "w") |>
    new_xmap_df("xvars", "capital", "w")
  testthat::expect_identical(xmap_to_named_list(link_xmap), link_list)
})
```

with dplyr:

```{r}
pairs_df <-
  as_pairs_from_named(
    link_list,
    "capital", "xvars"
  )

pairs_df |>
  dplyr::group_by(capital) |>
  dplyr::summarise(source = list(xvars)) |>
  tibble::deframe()
```

without dplyr:

```{r}
pairs_df |>
  subset(select = c("capital", "xvars")) |>
  tidyr::nest(source = c("xvars")) |>
  tibble::deframe() |>
  sapply(as.matrix) |>
  sapply(as.vector)
```

### to Tidygraph

#### COERCE: xmap_df to tbl_graph

Should I standardise the names?

```{r}
pull_from <- function(.xmap) {
  x_attrs <- attributes(.xmap)
  .xmap |> pull(x_attrs$col_from)
}
```

```{r send_to="R/autoplot.R"}
#'
as_tbl_graph.xmap_df <- function(x, ...) {
  x <- xmap_drop_extra(x)
  x_attrs <- attributes(x)
  x_nodes <- data.frame(name = c(.calc_all_nodes.xmap_df(x)))
  ## first two columns are assumed to be from & to, weights are third column.
  x_edges <- data.frame(x)
  tidygraph::tbl_graph(x_nodes, x_edges)
}
```

``` r
testthat::test_that("as_tbl_graph.xmap_df works as expected",{
  x <- mock$xmap_abc
  x_attrs <- attrs(x)
  x_nodes <- data.frame(name = c(.calc_all_nodes.xmap_df(mock$xmap_abc)))
  x_edges <- data.frame(x)
})
```

## Description Tools

See [conformr-project #63](https://github.com/cynthiahqy/conformr-project/issues/63)

### Helper: xmap is reversible

```{r send_to="R/abort.R"}
#' @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)
}
```

## Modification

See [conformr-project #67](https://github.com/cynthiahqy/conformr-project/issues/67)

### Generic: `xmap_reverse()`

```{r xmap-reverse, send_to="R/xmap_reverse.R"}
#' Reverse xmap direction
#'
#' @param .xmap xmap object to be reversed
#' @param weights_into A string specifying the name of a new or existing column to store reverse weights in.
#'
#' @return xmap object of same class as `x`, or throws an error if `x` is not reversible
#' @export
xmap_reverse <- function(.xmap, weights_into) {
  UseMethod("xmap_reverse")
}

#' @describeIn xmap_reverse Reverse a `xmap_df`
#'
#' @export
xmap_reverse.xmap_df <- function(.xmap, weights_into = "r_weights") {
  stopifnot(inherits(.xmap, "xmap_df"))
  x_attrs <- attributes(.xmap)
  df <- as.data.frame(.xmap)

  ## check xmap can be reversed
  abort_not_reversible(df, x_attrs$col_to)

  ## make new xmap
  df[[weights_into]] <- 1
  new_from <- x_attrs$col_to
  new_to <- x_attrs$col_from
  new_weights <- weights_into
  new_cols <- c(new_from, new_to, new_weights)
  ## rearrange columns
  # col_order <- c(new_cols, setdiff(names(df), new_cols))
  df <- df[new_cols]

  ## construction
  xmap <- new_xmap_df(df, new_from, new_to, new_weights)

  ## validation
  validate_xmap_df(xmap)

  return(xmap)
}
```

```{r}
testthat::test_that("xmap_reverse.xmap_df() works as expected", {
  df_x <- tibble::tribble(
    ~from, ~to, ~weights,
    "A1", "B01", 1,
    "A4", "B03", 0.25,
    "A4", "B04", 0.75
  ) |>
    as.data.frame() |>
    new_xmap_df("from", "to", "weights")

  df_x_rev <- data.frame(
    to = df_x$to,
    from = df_x$from,
    r_weights = 1
  ) |>
    new_xmap_df("to", "from", "r_weights")

  # class checks
  testthat::expect_s3_class(xmap_reverse.xmap_df(df_x), class(df_x_rev))
  testthat::expect_s3_class(xmap_reverse(df_x), class(df_x_rev))

  # output checks
  testthat::expect_identical(xmap_reverse.xmap_df(df_x), df_x_rev)
  testthat::expect_identical(abort_not_reversible(df_x, "to"), df_x)
})
```

### Helper: `xmap_drop_extra()`

```{r}
#' Drop extra columns from `xmap` objects
#'
#' @param .xmap an xmap object
#'
#' @export
xmap_drop_extra <- function(.xmap) {
  stopifnot(is_xmap_df(.xmap))
  # get col names
  col_strings <- simplify2array(.get_col_attrs.xmap_df(.xmap))
  # construct new xmap with only necessary columns
  z_attrs <- attributes(.xmap)
  z_attrs$names <- unname(col_strings)
  z <- as.data.frame(.xmap)
  z <- z[, col_strings]
  attributes(z) <- z_attrs

  return(z)
}
```

```{r test-drop-extra, render='as-is'}
testthat::test_that("xmap_drop_extra works as expected", {
  links <- tibble::tribble(
    ~f, ~t, ~w,
    "A1", "B01", 1,
    "A2", "B02", 1,
    "A3", "B02", 1,
    "A4", "B03", 0.25,
    "A4", "B04", 0.75
  )
  xmap_small <- new_xmap_df(links, "f", "t", "w")

  links_extra <- links |>
    dplyr::mutate(ex = "extra")
  xmap_extra <- new_xmap_df(links_extra, "f", "t", "w")

  xmap_drop <- xmap_extra |> xmap_drop_extra()

  testthat::expect_identical(xmap_small, xmap_drop)
})
```

## Summarise

### Experiments

#### Reactable (WIP)

```{r}
library(dplyr)
library(xmap)
from_degree <- mock$xmap_abc |>
  group_by(lower) |>
  mutate(out_degree = n()) |>
  ungroup() |>
  # group_by(upper) |>
  # mutate(to_degree = n()) |>
  # ungroup() |>
  arrange(desc(out_degree))

from_degree |>
  dplyr::select(lower, upper, share) |>
  reactable::reactable(groupBy = "upper")
```

```{r}
summary_reactable <- function(.xmap) {
  col_attrs <- .get_col_attrs.xmap_df(.xmap)
  .xmap |>
    dplyr::group_by(col_attrs$col_from) |>
    dplyr::mutate(out_degree = n()) |>
    ungroup() |>
    arrange(desc(out_degree))
}
```

#### Tidygraph

Attempt using tidygraph -- key issue is how do you convert back?

```{r}
library(tidygraph)
library(dplyr)

disjoint_abc <- mock$xmap_abc |> .calc_unique_sets.xmap_df()

mock$xmap_abc |>
  as_tbl_graph() |>
  activate(nodes) |>
  mutate(
    layer = case_when(
      name %in% disjoint_abc$from_set ~ 1,
      name %in% disjoint_abc$to_set ~ 2
    ),
    out_degree = centrality_degree(mode = "out"),
    out_split = ifelse(out_degree > 1, TRUE, FALSE)
  ) |>
  activate(edges) |>
  mutate(frac_weight = ifelse(share < 1, TRUE, FALSE)) |>
  convert(to_subgraph, !frac_weight)
```

#### Glue Collapse

```{r}
out_split <- mock$xmap_abc |>
  as_tibble() |>
  mutate(frac_weight = ifelse(share < 1, TRUE, FALSE)) |>
  group_by(frac_weight) |>
  tidyr::nest()

out_split |>
  filter(frac_weight == TRUE) |>
  pull(data)
```

concatenation hack?

```{r}
library(dplyr)
mock$xmap_abc |>
  as_tibble() |>
  mutate(to_share = glue::glue("{upper} [{share}]")) |>
  arrange(lower, desc(share)) |>
  summarise(collapse_to = glue::glue_collapse(to_share, "+"), .by = lower)
```

```{r}
mock$xmap_abc |>
  as_tibble() |>
  group_by(upper) |>
  mutate(share_char = case_when(
    share == 1 ~ "",
    TRUE ~ paste0("*", as.character(share))
  )) |>
  mutate(from_share = glue::glue("{lower}{share_char}")) |>
  summarise(composition = glue::glue_collapse(from_share, "+"))
```

### Helper: `add_placeholder_weights()`

```{r}
#' Add weights placeholder column to a data frame
#'
#' This function adds a column of character placeholders to a data frame based on
#' the values of `from` and `to` columns. 1-to-1 links are given unit weight placeholders,
#' and 1-to-many links are given fractional weight placeholders.
#'
#' @param df A data frame.
#' @param from The name of the column containing source category values.
#' @param to The name of the column containing target category values.
#' @param weights_into The name to use for the column containing the weights
#'   placeholders. Default is "weights_{{from}}".
#'
#' @return A data frame with a new numeric column containing the weights placeholders.
#'
#' @importFrom dplyr group_by mutate ungroup n_distinct case_when
#' @importFrom rlang englue
#' @importFrom cli cli_inform
#'
#' @seealso [add_weights] to generate valid crossmap weights.
#'
#' @export
#' @examples
#' mock$xmap_abc |>
#'   as.data.frame() |>
#'   add_placeholder_weights(from = upper, to = lower)
add_placeholder_weights <- function(df, from, to, weights_into = "weights_{{from}}") {
  abort_dup_pairs(df, rlang::englue("{{from}}"), rlang::englue("{{to}}"))

  ## set up
  weights_into <- rlang::englue(weights_into)
  frac_symbol <- NA
  unit_symbol <- 1
  ## equal weights
  df |>
    dplyr::group_by({{ from }}) |>
    dplyr::mutate("{weights_into}" := 1 / dplyr::n_distinct({{ to }})) |>
    dplyr::ungroup() -> w_df

  if (all(w_df[[weights_into]] == 1)) {
    # cli::cli_inform("No split relations found. Returning `df` with unit weights attached.")
    return(w_df)
  } else {
    w_df |>
      dplyr::mutate("{weights_into}" := case_when(
        .data[[weights_into]] == 1 ~ unit_symbol,
        .data[[weights_into]] < 1 ~ frac_symbol,
        TRUE ~ frac_symbol
      ))
  }
}
```

```{r}
mock$xmap_abc |>
  tibble::as_tibble() |>
  dplyr::select(lower, upper) |>
  add_placeholder_weights(from = lower, to = upper)
```

```{r}

```

### Mock-Up: Summarise

```{r}
summarise_target0.data.frame <- function(df, from, to, weights,
                                         frac_formula = "{from}*{weights}",
                                         collapse = "+",
                                         mask_ones = TRUE) {
  ## rename
  r_df <- df |>
    dplyr::rename(
      from = {{ from }},
      to = {{ to }},
      weights = {{ weights }}
    )

  r_df |>
    mutate(part = dplyr::case_when(
      weights == 1 ~ paste0(from, ifelse(mask_ones, "", "1")),
      weights < 1 ~ glue::glue(frac_formula)
    )) |>
    group_by(to) |>
    summarise(composition = glue::glue_collapse(part, collapse))
}
```

```{r}
mock$xmap_abc |>
  as_tibble() |>
  summarise_target0.data.frame(from = lower, to = upper, weights = share)
```

Switch `mask_ones` to `unit_formula`

```{r}
summarise_target.data.frame <- function(df, from, to, weights,
                                        frac_formula = "{from}*{weights}",
                                        unit_formula = "{from}",
                                        collapse = "+") {
  ## rename
  r_df <- df |>
    dplyr::rename(
      from = {{ from }},
      to = {{ to }},
      weights = {{ weights }}
    )

  r_df |>
    mutate(part = dplyr::case_when(
      weights == 1 ~ glue::glue(unit_formula),
      weights < 1 ~ glue::glue(frac_formula)
    )) |>
    group_by(to) |>
    summarise(composition = glue::glue_collapse(part, collapse))
}
```

```{r}
mock$xmap_abc |>
  as_tibble() |>
  summarise_target0.data.frame(
    from = lower, to = upper, weights = share,
    frac_formula = "{from} [{weights}]",
    collapse = ","
  )
```

### S3: `summary_by_target()`

```{r send_to="R/rename-helpers.R"}
#'
.rename_xmap <- function(.xmap, new_col_from, new_col_to, new_col_weights) {
  old_cols <- .get_col_attrs.xmap_df(.xmap)
  new_cols <- c(new_col_from, new_col_to, new_col_weights)
  df <- as.data.frame(.xmap)
  names(df)[names(df) %in% old_cols] <- new_cols
  new_xmap_df(df, new_col_from, new_col_to, new_col_weights)
}
```

```{r}
#' Summarize the composition of target categories.
#'
#' This function summarizes the composition of each target `to` category
#' in a set of `from`, `to`, `weight` links.
#' If a data.frame of links is provided, crossmap properties are not checked.
#' This can be useful when combined with `add_placeholder_weights()` to highlight
#' where weights must be chosen.
#'
#' @param links A data frame or `xmap_df`.
#' @inheritParams as_xmap
#' @param parts_into A string specifying the new column to pass the summarised composition into. Default is "parts".
#' @param na_placeholder. A string character to replace NA weights with.
#' @param frac_formula A glue formula specifying how to calculate the fraction of each
#'   target value using the weighting variable. Default is "\{from\}*\{weights\}".
#' @param unit_formula A glue formula specifying how to calculate the unit of each
#'   target value using the weighting variable. Default is "\{from\}".
#' @param collapse A string specifying the separator to use when collapsing the
#'   unit values. Default is "+".
#'
#' @return A tibble summarizing the composition of each target value based on
#'   the weighting variable.
#'
#' @export
summary_by_target <- function(links, ...) {
  UseMethod("summary_by_target")
}

#' @export
#' @rdname summary_by_target
#' @examples
#'
#' mock$xmap_abc |>
#'   summary_by_target()
#'
#' df <- data.frame(
#'   parent = c("A", "A", "A", "B", "B", "B", "C"),
#'   child = c("x", "y", "z", "x", "y", "z", "k")
#' )
#' df |>
#'   add_placeholder_weights(from = parent, to = child, weights_into = "weights") |>
#'   summary_by_target(
#'     from = parent, to = child, weights = weights,
#'     frac_formula = "{from}*{weights}"
#'   )
#' @importFrom dplyr mutate group_by summarise rename case_when
#' @importFrom glue glue_collapse
summary_by_target.data.frame <- function(links, from, to, weights,
                                         parts_into = "parts",
                                         collapse = "+",
                                         na_placeholder = "___",
                                         frac_formula = "{from}*{weights}",
                                         unit_formula = "{from}",
                                         warn = TRUE) {
  if (warn) {
    cli::cli_warn(c(
      "Summary completed without verifying crossmap properties.",
      "i" = "To silence set `warn = FALSE`"
    ))
  }

  ## evaluate glue formulas
  englue_xmap <- function(string_f, col_from, col_to, col_weights) {
    string_f |>
      gsub("from", col_from, x = _) |>
      gsub("to", col_to, x = _) |>
      gsub("weights", col_weights, x = _)
  }
  col_from <- rlang::englue("{{from}}")
  col_to <- rlang::englue("{{to}}")
  col_weights <- rlang::englue("{{weights}}")
  frac_formula <- englue_xmap(frac_formula, col_from, col_to, col_weights)
  unit_formula <- englue_xmap(unit_formula, col_from, col_to, col_weights)

  ## summarise
  links |>
    dplyr::mutate("{col_weights}" := dplyr::coalesce(as.character(.data[[col_weights]]), na_placeholder)) |>
    dplyr::mutate(part = dplyr::case_when(
      {{ weights }} == 1 ~ glue::glue(unit_formula),
      {{ weights }} < 1 ~ glue::glue(frac_formula),
      TRUE ~ glue::glue(frac_formula)
    )) |>
    dplyr::group_by({{ to }}) |>
    dplyr::summarise("{parts_into}" := glue::glue_collapse(part, collapse))
}

#' @export
#' @rdname summary_by_target
summary_by_target.xmap_df <- function(links,
                                      parts_into = "parts",
                                      collapse = "+",
                                      frac_formula = "{from}*{weights}",
                                      unit_formula = "{from}") {
  df <- links |>
    xmap_drop_extra() |>
    .rename_xmap("from", "to", "weights") |>
    as.data.frame()

  sum_df <- summary_by_target.data.frame(
    df, from, to, weights,
    parts_into, collapse,
    frac_formula, unit_formula,
    warn = FALSE
  )

  names(sum_df)[names(sum_df) == "to"] <- .get_col_attrs.xmap_df(links)$col_to
  return(sum_df)
}
```

```{r}
mock$xmap_abc |>
  as.data.frame() |>
  summary_by_target.data.frame(from = lower, to = upper, weights = share)
```

## Visualisation

### bigraph `autoplot()` and `plot()`

Adding in more dependencies

```{r vis-depend}
usethis::use_package("ggplot2")
usethis::use_package("ggraph", type = "Suggests")
usethis::use_package("tidygraph", type = "Suggests")
```

Now make an `autoplot()` and `plot()` methods for `xmap_df` using:

-   [ggplot2 docs: Using ggplot2 to visualize an object](https://ggplot2.tidyverse.org/articles/ggplot2-in-packages.html#best-practices-for-common-tasks)
-   [`ggplot::autoplot()`](https://ggplot2.tidyverse.org/reference/autoplot.html)
-   <https://www.cynthiahqy.com/posts/xmap-ggraph-bipartite/> mockup

```{r send_to="R/plot.R"}
#' @rdname autoplot.xmap
#' @importFrom graphics plot
#' @export
plot.xmap_df <- function(x, ...) {
  print(autoplot(x, ...))
}
```

```{r send_to="R/autoplot.R"}
# Generated from create-xmap.Rmd: do not edit by hand

#' Autoplot function for xmap_df objects
#'
#' This function generates a plot of an xmap_df object using the ggraph and ggplot2
#' packages. It visualizes the relationships between nodes and edges in the xmap_df
#' object, with different styles for unit weight and fractional weight links, and
#' prints fractional weights on edges.
#'
#' @param object An xmap_df object.
#' @param ... Additional arguments (currently unused).
#'
#' @importFrom ggplot2 autoplot aes
#' @importFrom rlang sym
#'
#' @return ggplot2 object
#' @name autoplot.xmap
#'
#' @examples
#' library(ggplot2)
#' library(ggraph)
#' library(tidygraph)
#' library(xmap)
#' df <- data.frame(
#'   from = c("A", "A", "B", "B", "B"),
#'   to = c("X", "Y", "X", "Y", "Z"),
#'   weights = c(0.6, 0.4, 0.2, 0.7, 0.1)
#' )
#' xmap <- as_xmap_df(df, from, to, weights)
#' autoplot(xmap)
NULL

#' @rdname autoplot.xmap
#' @export
autoplot.xmap_df <- function(object, ...) {
  if (!requireNamespace("ggraph", quietly = TRUE)) {
    cli::cli_abort('Please `install.package("ggraph")`')
  }

  x_attrs <- attributes(object)

  tidygraph_data <-
    tidygraph::as_tbl_graph(object) |>
    ## calculating edge properties
    tidygraph::activate(edges) |>
    tidygraph::mutate(frac_weight = ifelse(!!sym(x_attrs$col_weights) < 1, TRUE, FALSE)) |>
    tidygraph::mutate(edge_linetype = ifelse(frac_weight, "dashed", "solid")) |>
    tidygraph::mutate(edge_label_pos = ifelse(frac_weight, 0.8, 0.2)) |>
    ## calculating node properties
    tidygraph::activate(nodes) |>
    tidygraph::mutate(
      n_from = tidygraph::centrality_degree(mode = "in"),
      in_from = n_from == 0,
      collapse = n_from > 1
    )

  tidygraph_data |>
    ## now we plot...
    ggraph::ggraph(layout = "sugiyama") +
    ## unit weight links,
    ggraph::geom_edge_diagonal(
      aes(
        edge_linetype = I(edge_linetype),
        edge_alpha = !!sym(x_attrs$col_weights),
        filter = !frac_weight
      ),
      end_cap = circle(6, "mm"),
      show.legend = FALSE
    ) +
    ## frac weight links,
    ggraph::geom_edge_diagonal(
      aes(
        edge_linetype = I(edge_linetype),
        edge_alpha = !!sym(x_attrs$col_weights),
        filter = frac_weight,
        label = round(!!sym(x_attrs$col_weights), digits = 3),
        label_pos = edge_label_pos,
      ),
      end_cap = circle(6, "mm"),
      show.legend = FALSE,
      angle_calc = "along",
      label_dodge = grid::unit(2, "mm")
    ) +
    ## from nodes,
    ggraph::geom_node_label(aes(
      label = name,
      filter = in_from
    ), ) +
    ## to nodes,
    ggraph::geom_node_label(
      aes(
        label = name,
        fill = collapse,
        filter = !in_from
      ),
      show.legend = FALSE,
    ) +
    ggplot2::scale_fill_brewer(palette = "Greys") +
    ## and finally modify coordinates, scale and theme
    ggplot2::coord_flip() +
    ggplot2::scale_y_reverse() +
    ggplot2::theme_minimal() +
    ggraph::th_no_axes()
}
```

This test probably doesnt work because snapshot testing doesnt work.. nevertheless, here are details of how `vdiffr` should work:

-   <https://www.tidyverse.org/blog/2021/06/vdiffr-1-0-0/>

``` r
usethis::use_package("vdiffr", type = "Suggests")
testthat::test_that("autoplot() has known output",{
  library(dplyr)
  library(ggplot2)
  library(xmap)
  
  man_plot <- mock$xmap_abc |>
    as_tbl_graph() |>
  ## calculating edge properties
    activate(edges) |>
    mutate(frac_weight = ifelse(share < 1, TRUE, FALSE)) |>
    mutate(edge_linetype = ifelse(frac_weight, "dashed", "solid")) |>
    mutate(edge_label_pos = ifelse(frac_weight, 0.8, 0.2)) |>
  ## calculating node properties
    activate(nodes) |>
    mutate(n_from = centrality_degree(mode = "in"),
         in_from = n_from == 0,
         collapse = n_from > 1) |>
  ## now we plot...
  ggraph::ggraph(layout = "sugiyama") +
  ## unit weight links,
  ggraph::geom_edge_diagonal(
    aes(edge_linetype = I(edge_linetype),
        edge_alpha = share,
        filter = !frac_weight),
    end_cap = circle(6, 'mm'),
    show.legend = FALSE
    ) +
  ## frac weight links,
  ggraph::geom_edge_diagonal(
    aes(edge_linetype = I(edge_linetype),
        edge_alpha = share,
        filter = frac_weight,
        label = share,
        label_pos = edge_label_pos,
        ),
    end_cap = circle(6, 'mm'),
    show.legend = FALSE,
    angle_calc = "along",
    label_dodge = grid::unit(2, "mm")
    ) +
  ## from nodes,
  ggraph::geom_node_label(aes(label = name,
                              filter=in_from),
                          ) +
  ## to nodes,
  ggraph::geom_node_label(aes(label = name,
                              fill = collapse,
                              filter=!in_from
                              ),
                          show.legend = FALSE,
                          ) +
  scale_fill_brewer() +
  ## and finally modify coordinates, scale and theme
  coord_flip() +
  scale_y_reverse() +
  theme_minimal() +
  ggraph::th_no_axes()

  vdiffr::expect_doppelganger("xmap_bigraph_manual", man_plot)

  aut_plot <- autoplot(mock$xmap_abc)
  vdiffr::expect_doppelganger("xmap_bigraph_auto", aut_plot)
}
)
```

### Experiments with ggraph & igraph layouts via tidygraphs

#### Icicle plot

-   doesn't work for non-tree! (i.e. where you have collapse nodes)

```{r}
library(ggraph)
mock$xmap_abc |>
  as_tbl_graph() |>
  ggraph(layout = "partition") +
  geom_node_tile(aes(fill = centrality_degree())) +
  geom_node_label(aes(label = name))
```

### Planned Generic: `xmap_viz_*()`

This section is left in for future reference, when I get around to properly developing visualisation functions for crossmaps.

#### `xmap_viz_bigraph()`

Doc-string for future reference

``` r
#' Visualise `xmap` as bigraph
#' 
#' Plot crossmap as bigraph using sigmoid curves from ggbump.
#'
#' @param x object to plot
#' @param ... reserved for future plot customisation options
#'
#' @return ggplot2 object
#' @export
#'
#' @examples
#' library(ggplot2)
#' library(dplyr)
#' simple_xmap <- tibble::tribble(~f, ~t, ~w,
#'                              "x1111", "A1", 1,
#'                              "x2222", "B2", 0.5,
#'                              "x2222", "B3", 0.5,
#'                              "x3333", "C5", 1,
#'                              "x4444", "C5", 1,
#'                              "x5555", "D6", 0.4,
#'                              "x5555", "D7", 0.6,
#'                              "x6666", "D6", 0.3,
#'                              "x6666", "D7", 0.7,
#'                              "x7777", "D6", 1)  |> 
#'                 as_xmap_df(from = f, to = t, weights = w)
#' xmap_viz_bigraph(simple_xmap)
xmap_viz_bigraph <- function(x, ...){
  UseMethod("xmap_viz_bigraph")
}

#' @describeIn xmap_viz_bigraph Plot `xmap_df` as sigmoid bigraph
#' @export
#'
#' xmap_viz_bigraph.xmap_df <- function(x, ...) {
```

#### `xmap_viz_matrix()`

```{r xmap-viz-matrix}

```

### Example Plots

See `vis-xmaps.Rmd` vignette

## S3 Enhancements

See discussion [here](https://github.com/cynthiahqy/conformr-project/issues/43#issuecomment-1396445724)

### Printing

[conformr-project #60](https://github.com/cynthiahqy/conformr-project/issues/60)

#### Method: `xmap_df`

```{r print-xmap-df, send_to="R/print.R", results='asis', paged.print=FALSE}
#'
.calc_link_types.xmap_df <- function(xmap_df) {
  x_attrs <- attributes(xmap_df)
  x_weights <- xmap_df[[x_attrs$col_weights]]
  x_to <- xmap_df[[x_attrs$col_to]]

  flags <- c(
    "recode" = vhas_recode(x_weights),
    "split" = vhas_split(x_weights),
    "collapse" = vhas_collapse(x_to)
  )
  types <- names(flags[flags == TRUE])
  type <- cli::pluralize("{types} {? }")

  return(type)
}

#'
.calc_link_direction.xmap_df <- function(xmap_df) {
  x_attrs <- attributes(xmap_df)
  direction <- paste0(
    "(", x_attrs$col_from, " -> ", x_attrs$col_to, ") ",
    "BY ", x_attrs$col_weights
  )
  return(direction)
}

#' Print an `xmap` object
#'
#' @name print.xmap
NULL

#' @describeIn print.xmap Print an `xmap_df`
#'
#' @export
print.xmap_df <- function(x) {
  x_direction <- .calc_link_direction.xmap_df(x)
  x_type <- .calc_link_types.xmap_df(x)
  x_links <- as.data.frame(x)

  ## print headers and links
  cat(paste0("xmap_df:\n", x_type, "\n", x_direction, "\n"))
  print(x_links)
}
```

Test Prints:

```{r paged.print=FALSE}
valid_xmap_df <-
  tibble::tribble(
    ~new_sec, ~sector, ~weight,
    "mining", "MINE", 1,
    "agri", "AGRI", 1,
    "agri", "FISH", 1,
    "text", "MANU", 0.25,
    "food", "MANU", 0.25,
    "chem", "MANU", 0.25,
    "elec", "MANU", 0.25,
    "build", "CONS", 1 / 3,
    "roads", "CONS", 1 / 3,
    "civil", "CONS", 1 / 3,
  ) |>
  dplyr::mutate(extra_col = "stuff") |>
  as_xmap_df(from = sector, to = new_sec, weight)

print(valid_xmap_df)
```

### Read / Write Methods

Discussed here: [conformr-project #62](https://github.com/cynthiahqy/conformr-project/issues/62)

### Plot Method

Suggested in [confomr-project #43](https://github.com/cynthiahqy/conformr-project/issues/43#issuecomment-1396445724)

## Package Creation

### Add Vignettes

``` r
## doesn't work???
vignette_images <- paste0("../",
                          list.files("xmap-source-files", pattern = "plot", full.names = TRUE))
add_vignettes(vignette_images)
```

```{r}
litr::add_readme("../xmap-source-files/README.Rmd")
litr::add_vignettes("../xmap-source-files/xmap.Rmd")
litr::add_vignettes(c(
  "../xmap-source-files/making-xmaps.Rmd",
  "../xmap-source-files/plot-anzsco-isco-bigraph.png"
))
litr::add_vignettes(c(
  "../xmap-source-files/vis-xmaps.Rmd",
  "../xmap-source-files/plot-weight-sum-matrix.png"
))
rm(list = ls())
litr::document()
```

``` r
litr::add_vignettes(c("../xmap-source-files/using-xmaps.Rmd",
                      "../xmap-source-files/using-xmaps.bib",
                      "../xmap-source-files/plot-coverage-matrix.png",
                      "../xmap-source-files/plot-missing-val-bigraph.png"
                    ))
```

### Render package

To debug without having to re-render the litr file every time use the `pkg = "."` argument in devtools functions:

``` r
devtools::run_examples('xmap')
devtools::test('xmap')
devtools::build('xmap')
devtools::install('xmap')
devtools::check('xmap', document = FALSE)
```

We finish by running commands that will document, build, and install the package. It may also be a good idea to check the package from within this file.

```{r}
# litr::add_pkgdown()
pkgdown_yml <- file.path("..", "xmap-source-files", "_pkgdown.yml")
litr::add_pkgdown(pkgdown_yml)
# devtools::run_examples()
# devtools::build()
# devtools::install()
# devtools::install('xmap', build_vignettes = TRUE)
# devtools::check(document = FALSE)
```