diff --git a/.Rbuildignore b/.Rbuildignore index 3c179b0c..4f574309 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -22,3 +22,6 @@ vignettes/precompile\.R ^\.positai$ ^\.claude$ ^CLAUDE\.md$ +^man-roxygen$ +^inst/autograph_old\.png$ +^Rplots\.pdf$ diff --git a/.github/CONTRIBUTING.md b/.github/CONTRIBUTING.md index 400adf95..61c646a4 100644 --- a/.github/CONTRIBUTING.md +++ b/.github/CONTRIBUTING.md @@ -29,12 +29,14 @@ You can also access the documents in the repository, although this won't be necessary after you have cloned it on your computer via Fork. ### Cloning + Once you have downloaded Fork, the first thing you have to do is to clone the remote repository on your computer. Before cloning, you will be able to choose on which `branch` you want to work: develop or main. ### Pull + This command allows you to `pull` changes from the remote repository to your local repository on Sourcetree. Make sure you do that before starting working on your files so you have the newest versions. When pulling, make sure you choose master or develop, @@ -116,9 +118,107 @@ see the comment in [R/autograph_utilities.R](../R/autograph_utilities.R)). `grapht()` ([R/grapht.R](../R/grapht.R)) animates a longitudinal/dynamic network over time using `{gganimate}`/`{gifski}`. +### Layout names and files + Custom layout algorithms not provided by igraph/ggraph/graphlayouts live in their own `layout_*.R` files -(`layout_configurational.R`, `layout_grid.R`, `layout_layered.R`, `layout_matching.R`, -`layout_partition.R`, `layout_valence.R`) and follow the `layout_tbl_graph_*()` naming convention. +and follow the `layout_tbl_graph_*()` naming convention. +There is one file for each *family*: `layout_layered.R` (`layered`, `lineage`, `railway`, `ladder`), +`layout_concentric.R`, `layout_levels.R`, `layout_configurational.R`, `layout_valence.R` +and `layout_matching.R`. + +**One family, one file, one man page, one `@name`.** +A file named `layout_*.R` registers at least one `layout_tbl_graph_*`. +A file that registers none is not a layout file: put the helper beside its only caller. +This rule exists because two files broke it — `layout_grid.R` held the grid-snapping engine +(now [R/graph_snap.R](../R/graph_snap.R)), and `layout_engine.R` held only the layered engine +(now the second half of [R/layout_layered.R](../R/layout_layered.R)). + +**Each layout file is self-contained** — its exports, its `layout_tbl_graph_*` aliases, +and the private engine those exports share. +A private helper used by exactly one family lives in that family's file; +one used by two or more goes to [R/autograph_utilities.R](../R/autograph_utilities.R). +`.rescale()` was copied into two files instead, and drifted out of sight of both. + +#### Choosing a name + +**Reserved names, never usable.** +`ggraph:::layout_to_table.character()` tests `is.igraphlayout()` *before* it looks for a +`layout_tbl_graph_*` function, so a layout named with any of these is unreachable +through `layout =`, and nothing warns: + +> `bipartite`, `star`, `tree`, `circle`, `nicely`, `dh`, `drl`, `gem`, `graphopt`, +> `grid`, `mds`, `sugiyama`, `sphere`, `randomly`, `fr`, `kk`, `lgl` + +**Taken names** — `ggraph`'s own `layout_tbl_graph_*`: + +> `auto`, `backbone`, `cactustree`, `centrality`, `circlepack`, `dendrogram`, `eigen`, +> `fabric`, `focus`, `hive`, `htree`, `igraph`, `linear`, `manual`, `matrix`, `metro`, +> `partition`, `pmds`, `sf`, `sparse_stress`, `stress`, `treemap`, `unrooted` + +**Reserved in waiting** — in `graphlayouts` but not yet wrapped by `ggraph`. +A name here resolves to autograph today and would be silently shadowed the day ggraph wraps it, +because ggraph's namespace is searched first. Treat them as taken: + +> `multilevel`, `umap`, `dynamic`, `stress3D`, `constrained_stress`, `fixed_coords`, +> `centrality_group`, `focus_group`, `metromap`, `tree_unrooted` + +This is what retired `multilevel` in favour of `levels`. + +**Reserved by us** — `alluvial` is held for a plot of changing membership composition over time, +not for a layout. + +Check a candidate against all three namespaces before committing to it: + +```r +Rscript -e 'nm <- "yourname"; print(nm %in% c(sub("^layout_tbl_graph_", "", grep("^layout_tbl_graph_", ls(asNamespace("ggraph")), value = TRUE)), sub("^layout_(as|with|in|on)_", "", grep("^layout_", getNamespaceExports("graphlayouts"), value = TRUE)), sub("^layout_(as|with|in|on)_", "", grep("^layout_", getNamespaceExports("igraph"), value = TRUE))))' +``` + +**Name the shape, not the meaning or the algorithm.** +A layout name is a single lowercase English noun for what the drawing looks like: +`layered`, `lineage`, `railway`, `ladder`, `concentric`, `valence`. +Never the algorithm or its author (`sugiyama`), and not a claim the data may not support — +`hierarchy` was retired because a two-mode network has two layers and no hierarchy between them. +Where a layout takes the attribute it is named for, keep the two in agreement +(`layout = "levels"` takes `level = "lvl"`). + +**A name is for the drawing; an argument is for the variation — but a common drawing earns a name.** +`railway` and `ladder` are `alignment = "rungs"` applied to `layered` and `lineage`, +and they keep their names: making a user learn an argument to reach a common figure +defeats the point of an *auto*-graph. +Add a name when a user would look for that word; do not add one for every argument value. +The counter-example is `dyad`…`hexad`, which were retired because `configuration` +already picks the one matching the number of nodes, so no user had a reason to type them. + +**Prefer overloading an argument to adding one.** +An argument that takes a keyword should also take a node attribute name or vector where that +makes sense, as `ranks=` and `node_size=` do. +That is how `lineage` absorbed a layout of its own that only differed in where the layers came from. + +#### Adding a layout + +1. Export `layout_()` and alias `layout_tbl_graph_ <- layout_`. +2. Tag it `@family mapping` and `@template param_ggraphlayouts` + ([man-roxygen/param_ggraphlayouts.R](../man-roxygen/param_ggraphlayouts.R) holds + `.data`, `circular`, `times` and the return value, which every layout shares). +3. Declare what it needs in `.layout_requirements()` ([R/graph_checks.R](../R/graph_checks.R)), + so `graphr()` can substitute and say why instead of failing downstream. + Declare nothing where an argument could rescue the layout — `.abort_layout_arg()` asks for it. +4. Add it to `.layered_layouts()` if its coordinates carry meaning along an axis + that grid snapping would collapse. +5. Add a mirroring `test-layout_.R`. The functional audit in + `test-functional_layouts.R` enumerates from the namespace, so it picks the layout up + with no further change. + +#### Retiring a layout name + +1. Add a shim to [R/autograph-defunct.R](../R/autograph-defunct.R) under `@rdname layout_deprecated`, + forwarding to the replacement after `manynet::snet_warn()`. +2. Add the name to `.deprecated_layouts()` and its replacement to `.rename_layout()`. + `.rename_layout()` swaps the name once, where the layout is checked, so that every step + after it — applicability, node sizes, tie alpha, labels — knows only the current name. +3. Keep its `.layout_requirements()` entry, so the string is still validated before the swap. +4. Nothing else needs updating: `.deprecated_layouts()` is what keeps the name out of the + RStudio completions and out of the functional audit. ### Plot-method dispatch (`plot_*.R`) @@ -132,25 +232,142 @@ Methods are grouped by the *kind of result object*, not by source package: | `plot_analysis.R` | node/tie/network measures, motifs, memberships (`node_measure`, `tie_measure`, `network_measures`, `node_member`, `node_motif`, `network_motif`, `matrix`) | | `plot_summaries.R` | diffusion/learning model summaries (`diff_model`, `diffs_model`, `learn_model`, `mnet`) | | `plot_gof.R` | goodness-of-fit objects (`gof.ergm`, `sienaGOF`, `gof.stats.monan`, autograph's own `ag_gof`) | -| `plot_convergence.R`, `plot_diagnostics.R`, `plot_tests.R`, `plot_interp.R` | model diagnostics, convergence traces, statistical tests, and interpretation plots for `netlm`/`netlogit`/`ergm` etc. | -| `plot_manydata.R` | goldfish `changepoints`/`outliers` and other longitudinal data objects | +| `plot_diagnostics.R` | adequacy diagnostics and model fits, currently goldfish's (`goldfishOutliers`, `goldfishChangepoints`, `goldfishOnset`, `goldfishMargins`, `goldfishGOF`, `goldfishTimeTest`, `goldfishFit`) | +| `plot_convergence.R`, `plot_tests.R`, `plot_interp.R` | convergence traces, statistical tests, and interpretation plots for `netlm`/`netlogit`/`ergm` etc. | +| `plot_manydata.R` | 'many' data plots; the whole file is commented out at present | New `plot.*` methods must be registered in NAMESPACE via roxygen `@method`/`@export` tags — run `devtools::document()` after adding one. Suggestions for new plot methods are welcome. +### Class names across the stocnet ecosystem + +S3 dispatch matches exact class strings, so two packages that emit the same class string +collide: `autograph` cannot tell the objects apart, and neither can a user's `inherits()` check. +A name such as `test_gof` or `margin_table` is the name any sibling package would pick for the +same idea, so it is not safe. + +The rule for every stocnet package is: **name a class after the package plus a noun, in camelCase** +(``), following RSiena's `sienaFit`, `sienaGOF` and `sienaAlgorithm`. +camelCase keeps a class visually distinct from the snake_case user-facing functions. + +Two things the convention does not use: + +- **No dot suffix.** A dot in a class string creates no inheritance. R dispatches on exact class + strings, and all S3 inheritance comes from the class vector, so `foo.goldfish` does not match an + object of class `"diagnose_outliers.goldfish"`. A suffix such as `.goldfish` is convention only. +- **No shared parent class.** `autograph` draws a different figure for each diagnostic, so a + fallback method would have nothing to do. `autograph` standardises by coercion instead, as it + already does for other objects. + +The goldfish diagnostic classes follow this rule. +Five older class names remain in [R/autograph-defunct.R](../R/autograph-defunct.R) as aliases +forwarding to the renamed methods, so that an object classed the way an earlier autograph +expected still plots: +`diagnose_outliers` and `diagnose_changepoints` (the names goldfish 1.9.21 stamps), +`outliers.goldfish` and `changepoints.goldfish` (the two the draft methods were written against), +and `result.goldfish` (the fit class every goldfish stamps, back to the version on CRAN). +An alias restores dispatch, not the old column contract: each forwards to a method that reads the +current columns. +Delete each alias once the oldest supported goldfish is past the rename. + +### Function names + +Two naming families, and they do not mix: + +- **User-facing functions are snake_case, and usually `verb_noun`**: `graphr()`, `match_color()`, + `is_dark()`, `simulate_colorblind()`, `check_separation()`, `list_fonts()`, `stocnet_theme()`. + This is the convention across the stocnet suite, so a user meets one style everywhere. +- **The `ag_` prefix is for the theme accessors only**: `ag_base()`, `ag_ink()`, `ag_highlight()`, + `ag_positive()`, `ag_negative()`, `ag_qualitative(n)`, `ag_sequential(n)`, `ag_divergent(n)`, + `ag_font()`. Each returns the autograph-specific value the current theme holds for one role, + and each reads an `snet_*` option. Do not give `ag_` to a function that does something else, + even a small one: a new verb belongs in the snake_case family. + Internal helpers may take `ag_` where they build such a value (`ag_ground()`, `ag_theme_*()`). +- **`check_*` scores, `.check_*` guards**: the exported `check_span()`, `check_offset()`, + `check_contrast()` and `check_separation()` each measure a drawing and return the score, so that + a user can compare one layout or palette with another. The private `.check_layout()`, + `.check_layout_applies()`, `.layout_applies()` and `.check_dup()` validate an argument and + abort or substitute, reading the tables `.layout_requirements()` and `.deprecated_layouts()`. + The two do different jobs, so keep the dot: it is what tells them apart. + ### Theming -[R/theme_set.R](../R/theme_set.R) implements `stocnet_theme()` (alias `set_stocnet_theme()`), +[R/theme_palette_set.R](../R/theme_palette_set.R) implements `stocnet_theme()` (alias `set_stocnet_theme()`), which sets an R option (`stocnet_theme`, default `"default"`) read by every plotting function in the package. -Institutional and stylistic palettes (`default`, `bw`, `crisp`, `neon`, `iheid`, `ethz`, `uzh`, `rug`, -`unibe`, `oxf`, `unige`, `cmu`, `iast`, `hwu`, `rainbow`) are defined in [R/theme_palettes.R](../R/theme_palettes.R) -and exposed via consistent accessor functions -(`ag_base()`, `ag_highlight()`, `ag_positive()`, `ag_negative()`, `ag_qualitative(n)`, -`ag_sequential(n)`, `ag_divergent(n)`, `ag_font()`) documented together under `ag_call`. +Institutional and stylistic palettes (`default`, `bw`, `crisp`, `neon`, `clay`, `iheid`, `ethz`, `uzh`, `rug`, +`unibe`, `oxf`, `unige`, `cmu`, `iast`, `hwu`, `rainbow`) are defined in [R/theme_palette_set.R](../R/theme_palette_set.R) +and exposed via the `ag_` accessors listed above, documented together under `ag_call`. Users can override individual palette colours via `options()` (e.g. `options(snet_highlight = ...)`) rather than editing theme code. [R/theme_match.R](../R/theme_match.R) maps a plot/result object to its appropriate theme treatment. +Three roles, kept separate, because they pull in different directions: +the **base** is an unhighlighted mark, and may be light where that is what separates it from a +dark brand highlight; the **ink** (`ag_ink()`) is what a plot writes with, and must stay legible; +the **highlight** is the brand colour. +Reference lines, axis text, and other chrome take `ag_ink()`, never `ag_base()`. + +Every plot is drawn on the theme's ground. Build plot themes with the `ag_theme_*()` wrappers in +[R/theme_palette_set.R](../R/theme_palette_set.R) (`ag_theme_minimal()`, `ag_theme_void()`, and so on) rather than +calling `ggplot2::theme_minimal()` directly, so that a theme with a background other than white +reaches every plot and not only the graphs. + +[R/theme_colorblind.R](../R/theme_colorblind.R) holds the colour-checking tools: `simulate_colorblind()`, +`check_separation()`, `check_contrast()`, and the internal `colorblind_sort()` that each theme's +categorical palette passes through when the theme is set. +The three answer three different questions and none substitutes for another: +`check_separation()` asks whether two marks can be told apart (CIELAB distance, worst case across +normal and colour-blind vision), `check_contrast()` asks whether text can be read on what it sits on +(WCAG 2.1 relative luminance), and `simulate_colorblind(type = "grey")` asks whether either survives +a photocopier. +Greyscale is reported beside `check_separation()`'s score rather than folded into it: two colours that +differ only in hue collapse in greyscale however well they serve a colour-blind reader, so a worst +case that included it would condemn nearly every institutional palette. +A palette added to a theme therefore does not need hand-ordering, but it does need to survive the +audit in `tests/testthat/test-functional_themes.R`, which requires the first few colours to stay +apart under each type of colour blindness. +A palette whose own order carries meaning is exempted by adding it to `colorblind_unsorted`; +`"rainbow"` is the only member, and is sampled across its length instead of taken from the front. + +The **medium** is separate from the theme, and lives in +[R/theme_medium.R](../R/theme_medium.R): `stocnet_medium()` says where a plot will be seen +(`"screen"`, `"presentation"`, `"mobile"`, `"print"`), not how it should look. +It scales text through `ag_size()` and `ag_text_size()`, and `"print"` overrides the ground to white. +Text set on a geom or on a theme element directly does not pass through `base_size`, so wrap it in +`ag_text_size()`; marks are deliberately left unscaled, since a node's size is relative to its layout. + +#### Adding a theme or palette + +1. Add the name to `theme_opts` in [R/theme_palette_set.R](../R/theme_palette_set.R). +2. Give it a branch in each `set_*_theme()` it needs: background, ink, highlight, divergent, + categorical, font. Omitting one leaves the theme on that setter's default, which is usually right. + `set_missing_theme()` needs nothing: it derives `ag_missing()` from the ground and the palette. +3. Store the categorical palette in the order `colorblind_sort()` gives it, not the order the brand + guide lists it in. The test suite asserts that the stored palette is already a fixed point of the + sort, so a hand-ordered palette will fail. +4. Run `tests/testthat/test-functional_themes.R`. It holds every theme to: the first few categorical + colours staying apart under each type of colour blindness, divergent poles that are not a + red-green pair, a highlight pair that every viewer can separate, and ink that clears WCAG's 4.5:1 + on the theme's own ground. + +Reorder a palette; do not repaint it. An institution's colours are that institution's, and the point +of `colorblind_sort()` is that the order is ours to choose while the colours are not. Where a brand +colour genuinely cannot meet a floor — the `"clay"` and `"oxf"` highlights fall just under WCAG's +3:1 — name the exception in the test rather than adjusting the colour or dropping the assertion. + +Tools worth checking a candidate palette with before it is added: + +- [ColorBrewer](https://colorbrewer2.org) for whether a scheme should be qualitative, sequential or + diverging, and for its colour-blind safe, print-friendly and photocopy-safe filters. +- [Viz Palette](https://projects.susielu.com/viz-palette) for seeing a set of hexcodes at once under + each type of colour vision deficiency. +- Datawrapper's [notes on colour in a data-vis style guide](https://www.datawrapper.de/blog/colors-for-data-vis-style-guides) + for why a palette needs to vary in lightness and not only in hue, and for the case for a + de-emphasis colour (`ag_missing()` here). +- The [`{GGenemy}`](https://cran.r-project.org/package=GGenemy) and + [`{colorify}`](https://cran.r-project.org/package=colorify) packages, for auditing a finished + `ggplot2` figure and for generating candidate palettes respectively. Neither is a dependency. + Because `autograph` re-exports several `ggplot2` symbols (see [R/reexports_ggplot2.R](../R/reexports_ggplot2.R)), loading `autograph` last in a session is recommended so its `plot()` methods take precedence over other packages'. @@ -174,13 +391,24 @@ so code paths depending on them should guard with `requireNamespace()` (see the `thisRequires()` helper in [R/autograph_utilities.R](../R/autograph_utilities.R)) or be skipped gracefully when unavailable. +The declared minimum of each `stocnet` dependency is the version on CRAN, so that CI can install it. +Where `autograph` needs something that only a newer, unreleased version has, +reach it through a shim in [R/autograph_utilities.R](../R/autograph_utilities.R) +rather than by raising the minimum. +Test for the function with `.ag_has_manynet()` rather than for the version string, +because a pre-release development build can carry the version without yet exporting the function. +Call the function with `getExportedValue()` and not `::`, +because `R CMD check` resolves a `::` call against the installed package +and reports the newer name as missing even where the call is never reached. +Delete each shim once the minimum is raised past the version that added the function. + ### Tests `tests/testthat/` uses testthat edition 3 with parallel execution (`Config/testthat/parallel: true` in DESCRIPTION). `tests/testthat.R` sets `stocnet_theme("default")` before running the suite so theme state doesn't leak between runs. Test files are organised by the same grouping as the `R/` source files -(e.g. `test-graphr.R`, `test-layout_partition.R`, `test-theme_match.R`). +(e.g. `test-graphr.R`, `test-layout_layered.R`, `test-theme_match.R`). In addition, the `test-functional_*.R` files implement *functional* (family-enumerating) testing, mirroring the approach in `{manynet}`: layout algorithms, `plot.` methods, palette accessors, @@ -194,6 +422,97 @@ CI sets `AUTOGRAPH_STRICT_AUDIT: true` so the same cases fail there instead. code chunks of the learnr tutorials in `inst/tutorials/`, so tutorial code that errors or raises a deprecation warning fails the suite (rendering the tutorials themselves is deliberately not tested). +### Tutorials and articles + +The learnr tutorials in `inst/tutorials/` are the source. +`vignettes/articles/*.Rmd` are their static pkgdown twins, and are *generated* +from them by [data-raw/build_tutorial_articles.R](../data-raw/build_tutorial_articles.R). +Never edit an article by hand: the next regeneration discards the edit, +and [prchecks.yml](workflows/prchecks.yml) fails the PR for drift meanwhile. + +After adding or changing functionality, ask whether a reader learning the +package would meet it, and if so: + +1. Edit the tutorial in `inst/tutorials//*.Rmd`. + Add the new function to the topic it belongs to, in an `exercise=TRUE` + chunk, with a sentence saying what it is for. + New sections need an entry in that topic's page-toc, + and are worth a line in its closing "In brief" callout. +2. Re-render the tutorial HTML in place + (`rmarkdown::render()` on the tutorial `.Rmd`), and commit it. +3. Re-run `Rscript data-raw/build_tutorial_articles.R`, and commit the + regenerated article. +4. Run `testthat::test_file("tests/testthat/test-tutorials_autograph.R")`, + which purls and evaluates every chunk, so new tutorial code is tested. + +Where the change is worth showing off rather than only teaching, +it also belongs in `README.Rmd` — which is knit to `README.md` with +`devtools::build_readme()`, never edited directly — and its figures land in +`man/figures/`, from where the website serves them. + +### Website + +The site is built by `{pkgdown}` from [pkgdown/_pkgdown.yml](../pkgdown/_pkgdown.yml) +and deployed from [pushrelease.yml](workflows/pushrelease.yml) on a merge to `main`. + +**Every exported function must appear in the `reference:` index.** +A topic left out of it fails the build, so the site stops updating. +Add a new function to the section it belongs to, +or add a new section where it starts a family, +and prefer naming the topic (`theme_colorblind`) over widening a `starts_with()` pattern. +A helper that users are not meant to call takes `@keywords internal` instead. +The `reference:` titles are also the headings used in `NEWS.md` (see below), +so keep the two in step. + +Check before opening a PR: + +```r +pkgdown::check_pkgdown() # every topic is in the index +pkgdown::build_site(preview = FALSE) # everything else +``` + +[prchecks.yml](workflows/prchecks.yml) runs both in the `website-builds` job, +so a PR reports whether the site *can* be built without deploying it. + +### README figures + +`README.md` is knitted from [README.Rmd](../README.Rmd), and **its figures are +hosted on jameshollway.com rather than committed to `man/figures`.** +R installs `man/figures` into the installed package's `help` directory, +so a README figure left there is shipped to every user and counted by +`R CMD check`'s installed size note. The figures once held 3.3Mb of a +5.2Mb installed package. + +The published figures live at `https://www.jameshollway.com/post/autograph/`, +which is served from `content/post/autograph` in that site's own repository. +Point `AUTOGRAPH_SITE_DIR` at your checkout of that directory: + +```sh +export AUTOGRAPH_SITE_DIR=~/path/to/jameshollway.com/content/post/autograph +``` + +The setup chunk reads that variable, and sets `have_site` from whether the +directory exists. Where it does not, as on CI and on CRAN, the figure chunks +do not run, and `README.md` keeps pointing at the published copies. +The knit is still correct; the figures are simply not refreshed. + +A new figure needs three things: + +1. Write the figure into the site directory rather than into `man/figures`. + A chunk whose code is hidden calls `ggsave(site_figure("README--1.png"), ...)` + and takes `echo = FALSE, eval = have_site`. + A chunk whose code is shown instead takes + `fig.path = site_prefix, fig.show = "hide", eval = have_site`, + which lets knitr write the file but suppresses the local link. +2. Write the `` tag into the prose by hand, with the published URL and an + `alt` text. `fig.alt` cannot do this, since the chunk emits no link. +3. Copy the figure into the site repository, then commit and deploy it there. + **The image 404s on GitHub until that deploy lands.** + +Knit with `devtools::build_readme()`, and check that +`grep 'man/figures/README' README.md` finds nothing. +Only `man/figures/logo.png` belongs in `man/figures`. + ### `NEWS.md` conventions `NEWS.md` groups each version's changes under `##` headings that mirror the website @@ -212,10 +531,35 @@ Start each bullet with a verb matching the change type: - `Improved ...` — functional updates to existing behaviour - `Updated ...` — documentation changes +Any of these verbs can also lead a sub-bullet. + +Keep every bullet to one line of fewer than 81 characters ideally +(a few more or less is fine). +If a bullet wraps, it holds too much: +shorten it, or split it into a lead bullet and sub-bullets. +Each bullet stands on its own, and states what changed, +not why or how unless there is space for context. +Explanation belongs in the function documentation or the vignettes. + +Where several bullets describe parallel changes, reuse the sentence structure, +so that a reader sees the parallelism at a glance. +Use one word for one thing throughout a version's entries, +rather than varying the wording for effect. + If a cited GitHub issue was **not** authored by @jhollway, thank the author with an `@`-tag in the bullet. Cluster related changes (e.g. several fixes to the same function, or sub-points of one feature) as indented sub-bullets under a lead bullet, to improve readability. +Where several changes concern one function, lead with an `Improved ...` bullet that +names the function, and put the individual `Fixed ...`/`Added ...` points beneath it, +so the cluster groups by function rather than by change type. +Under an `Improved ...` lead bullet, do not name the function again in the +sub-bullets, since the lead bullet already carries it. +Sub-bullets indent by two spaces, and nest at most one level further (four spaces). +A sub-bullet does not need a verb: it can state the consequence, the previous +behaviour, or an example call. +The more entries a version holds, the more this structure matters, +so group first and only then write the bullets. diff --git a/.github/workflows/prchecks.yml b/.github/workflows/prchecks.yml index 4c5d410e..00fef5f2 100644 --- a/.github/workflows/prchecks.yml +++ b/.github/workflows/prchecks.yml @@ -83,6 +83,41 @@ jobs: run: spelling::spell_check_package() shell: Rscript {0} + website-builds: + name: Website builds + runs-on: ubuntu-latest + + steps: + - uses: actions/checkout@v7 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + # rsconnect is not a package dependency, but pkgdown::build_site() + # calls build_tutorials() for inst/tutorials/, and that step reads + # rsconnect deployment records. Without it the site build errors out + # and the website is never checked. pushrelease.yml installs it too. + extra-packages: | + any::pkgdown + any::rsconnect + local::. + needs: website + + # The site itself is deployed from pushrelease.yml, but a missing index + # entry or a broken cross-reference only surfaces at build time, which is + # too late. check_pkgdown() catches a topic left out of the reference + # index; the build catches everything else, and its output is discarded. + - name: Check reference index covers every topic + run: pkgdown::check_pkgdown() + shell: Rscript {0} + + - name: Build site + run: pkgdown::build_site(preview = FALSE, install = FALSE, new_process = FALSE) + shell: Rscript {0} + articles-in-sync: name: Tutorial articles are in sync runs-on: ubuntu-latest diff --git a/.github/workflows/pushrelease.yml b/.github/workflows/pushrelease.yml index 9ff81f24..1b3a45c8 100644 --- a/.github/workflows/pushrelease.yml +++ b/.github/workflows/pushrelease.yml @@ -116,12 +116,26 @@ jobs: echo "Renamed files" ls autograph_* + - name: Extract release notes from NEWS.md + shell: bash + run: | + # Take the NEWS.md section for this version, else the topmost section. + awk -v ver="${{ env.PACKAGE_NAME }} ${{ env.PACKAGE_VERSION }}" ' + /^# / { if (found) exit; if (substr($0, 3) == ver) { found = 1; next } } + found { print } + ' NEWS.md > RELEASE_NOTES.md + if [ ! -s RELEASE_NOTES.md ]; then + awk 'NR > 1 && /^# / { exit } NR > 1 { print }' NEWS.md > RELEASE_NOTES.md + fi + cat RELEASE_NOTES.md + - name: Create Release and Upload Assets id: create_release uses: softprops/action-gh-release@v2 with: tag_name: ${{ steps.newtag.outputs.tag }} name: Release ${{ steps.newtag.outputs.tag }} + body_path: RELEASE_NOTES.md draft: false prerelease: false fail_on_unmatched_files: true diff --git a/.gitignore b/.gitignore index be8a82dc..4c646e7e 100644 --- a/.gitignore +++ b/.gitignore @@ -19,3 +19,4 @@ toadd/* cache/* .positai CLAUDE.md +Rplots.pdf diff --git a/DESCRIPTION b/DESCRIPTION index 64913b86..d38ccf14 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: autograph Title: Automatic Plotting and Theming of Many Graphs -Version: 1.1.2 +Version: 1.2.0 Description: Visual exploration and presentation of networks should not be difficult. This package includes functions for plotting networks and network-related metrics with sensible and pretty defaults. It includes 'ggplot2'-based plot methods for many popular network package classes. @@ -13,7 +13,7 @@ Encoding: UTF-8 LazyData: true Depends: R (>= 4.1.0), - manynet (>= 2.2.1) + manynet (>= 2.2.3) Imports: dplyr (>= 1.1.0), ggraph (>= 2.2.0), @@ -27,10 +27,12 @@ Suggests: gifski, methods, migraph, - netrics, + netrics (>= 0.4.0), + systemfonts, testthat (>= 3.0.0) Enhances: ergm, + goldfish, RSiena Authors@R: c(person(given = "James", @@ -55,4 +57,4 @@ Config/Needs/website: pkgdown Config/testthat/parallel: true Config/testthat/edition: 3 -Config/roxygen2/version: 8.0.0 +Config/roxygen2/version: 8.1.0 diff --git a/NAMESPACE b/NAMESPACE index 18284e53..a10fa48d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,11 +3,20 @@ S3method(plot,ag_conv) S3method(plot,ag_gof) S3method(plot,changepoints.goldfish) +S3method(plot,diagnose_changepoints) +S3method(plot,diagnose_outliers) S3method(plot,diff_model) S3method(plot,diffs_model) S3method(plot,ergm) S3method(plot,gof.ergm) S3method(plot,gof.stats.monan) +S3method(plot,goldfishChangepoints) +S3method(plot,goldfishFit) +S3method(plot,goldfishGOF) +S3method(plot,goldfishMargins) +S3method(plot,goldfishOnset) +S3method(plot,goldfishOutliers) +S3method(plot,goldfishTimeTest) S3method(plot,influenceTable) S3method(plot,learn_model) S3method(plot,matrix) @@ -21,10 +30,12 @@ S3method(plot,node_measure) S3method(plot,node_member) S3method(plot,node_motif) S3method(plot,outliers.goldfish) +S3method(plot,result.goldfish) S3method(plot,selectionTable) S3method(plot,sienaGOF) S3method(plot,tie_measure) S3method(plot,traces.monan) +S3method(print,check_separation) S3method(print,grapht) export("%>%") export(aes) @@ -32,10 +43,19 @@ export(ag_base) export(ag_divergent) export(ag_font) export(ag_highlight) +export(ag_ink) +export(ag_missing) export(ag_negative) export(ag_positive) export(ag_qualitative) export(ag_sequential) +export(ag_size) +export(check_contrast) +export(check_offset) +export(check_separation) +export(check_span) +export(check_stress) +export(count_pages) export(element_blank) export(element_text) export(geom_point) @@ -52,110 +72,135 @@ export(labs) export(layout_alluvial) export(layout_concentric) export(layout_configuration) +export(layout_correspondence) export(layout_dyad) export(layout_hexad) export(layout_hierarchy) export(layout_ladder) +export(layout_layered) +export(layout_levels) export(layout_lineage) +export(layout_matching) export(layout_multilevel) export(layout_pentad) export(layout_railway) +export(layout_scaling) export(layout_tbl_graph_alluvial) export(layout_tbl_graph_concentric) export(layout_tbl_graph_configuration) +export(layout_tbl_graph_correspondence) export(layout_tbl_graph_dyad) export(layout_tbl_graph_hexad) export(layout_tbl_graph_hierarchy) export(layout_tbl_graph_ladder) export(layout_tbl_graph_layered) +export(layout_tbl_graph_levels) export(layout_tbl_graph_lineage) export(layout_tbl_graph_matching) export(layout_tbl_graph_multilevel) export(layout_tbl_graph_pentad) export(layout_tbl_graph_railway) +export(layout_tbl_graph_scaling) export(layout_tbl_graph_tetrad) export(layout_tbl_graph_triad) export(layout_tbl_graph_valence) export(layout_tetrad) export(layout_triad) export(layout_valence) +export(list_fonts) export(load_ergm_res) export(match_color) export(scale_colour_hue) export(scale_size) export(scale_x_continuous) +export(set_completion) +export(set_stocnet_medium) export(set_stocnet_theme) +export(simulate_colorblind) +export(stocnet_completion) +export(stocnet_medium) export(stocnet_theme) export(theme) export(theme_grey) export(unit) export(xlab) export(ylab) -importFrom(dplyr,"%>%") -importFrom(dplyr,distinct) -importFrom(dplyr,left_join) -importFrom(dplyr,mutate) -importFrom(dplyr,select) -importFrom(ggplot2,.data) -importFrom(ggplot2,aes) -importFrom(ggplot2,arrow) -importFrom(ggplot2,coord_fixed) -importFrom(ggplot2,element_blank) -importFrom(ggplot2,element_text) -importFrom(ggplot2,geom_histogram) -importFrom(ggplot2,geom_hline) -importFrom(ggplot2,geom_line) -importFrom(ggplot2,geom_point) -importFrom(ggplot2,geom_segment) -importFrom(ggplot2,geom_smooth) -importFrom(ggplot2,geom_text) -importFrom(ggplot2,geom_tile) -importFrom(ggplot2,geom_vline) -importFrom(ggplot2,ggplot) -importFrom(ggplot2,ggsave) -importFrom(ggplot2,ggtitle) -importFrom(ggplot2,guides) -importFrom(ggplot2,labs) -importFrom(ggplot2,scale_alpha_identity) -importFrom(ggplot2,scale_color_brewer) -importFrom(ggplot2,scale_colour_hue) -importFrom(ggplot2,scale_fill_brewer) -importFrom(ggplot2,scale_fill_gradient) -importFrom(ggplot2,scale_linetype_identity) -importFrom(ggplot2,scale_size) -importFrom(ggplot2,scale_x_continuous) -importFrom(ggplot2,scale_x_discrete) -importFrom(ggplot2,scale_y_discrete) -importFrom(ggplot2,theme) -importFrom(ggplot2,theme_bw) -importFrom(ggplot2,theme_grey) -importFrom(ggplot2,theme_void) -importFrom(ggplot2,unit) -importFrom(ggplot2,xlab) -importFrom(ggplot2,ylab) -importFrom(ggraph,geom_edge_bundle_force) -importFrom(ggraph,geom_edge_bundle_minimal) -importFrom(ggraph,geom_edge_bundle_path) -importFrom(ggraph,geom_edge_link) -importFrom(ggraph,geom_node_label) -importFrom(ggraph,geom_node_point) -importFrom(ggraph,geom_node_text) -importFrom(ggraph,scale_edge_width_continuous) +importFrom(dplyr, + "%>%", + distinct, + left_join, + mutate, + select +) +importFrom(ggplot2, + .data, + aes, + arrow, + coord_fixed, + element_blank, + element_text, + geom_histogram, + geom_hline, + geom_line, + geom_point, + geom_segment, + geom_smooth, + geom_text, + geom_tile, + geom_vline, + ggplot, + ggsave, + ggtitle, + guides, + labs, + scale_alpha_identity, + scale_color_brewer, + scale_colour_hue, + scale_fill_brewer, + scale_fill_gradient, + scale_linetype_identity, + scale_size, + scale_x_continuous, + scale_x_discrete, + scale_y_discrete, + theme, + theme_bw, + theme_grey, + theme_void, + unit, + xlab, + ylab +) +importFrom(ggraph, + geom_edge_bundle_force, + geom_edge_bundle_minimal, + geom_edge_bundle_path, + geom_edge_link, + geom_node_label, + geom_node_point, + geom_node_text, + scale_edge_width_continuous +) importFrom(grDevices,colorRampPalette) -importFrom(igraph,add_vertices) -importFrom(igraph,as_data_frame) -importFrom(igraph,degree) -importFrom(igraph,delete_edge_attr) -importFrom(igraph,delete_graph_attr) -importFrom(igraph,delete_vertex_attr) -importFrom(igraph,graph_from_data_frame) -importFrom(igraph,permute) -importFrom(igraph,set_vertex_attr) -importFrom(igraph,vcount) -importFrom(igraph,vertex_attr_names) -importFrom(manynet,is_twomode) -importFrom(manynet,snet_info) -importFrom(manynet,snet_success) +importFrom(igraph, + add_vertices, + as_data_frame, + delete_edge_attr, + delete_graph_attr, + delete_vertex_attr, + graph_from_data_frame, + permute, + set_vertex_attr, + vcount, + vertex_attr_names +) +importFrom(manynet, + is_twomode, + snet_info, + snet_success +) importFrom(patchwork,plot_layout) -importFrom(stats,cutree) -importFrom(stats,setNames) +importFrom(stats, + cutree, + setNames +) diff --git a/NEWS.md b/NEWS.md index 9125b050..2b8a3f9b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,205 @@ +# autograph 1.2.0 + +## Package + +- Removed the CRAN version check from `.onAttach()`, making `library(autograph)` faster to attach + - Fixed `.onAttach()` not applying the ink of a persisted theme +- Added `{goldfish}` to `Enhances` +- Added `{systemfonts}` to `Suggests` +- Added a `website-builds` job to `prchecks.yml`, reporting whether the site builds + - `count_pages()` was missing from the reference index, which stopped it +- Updated CONTRIBUTING with conventions for function names, `NEWS.md` bullets, + the website reference index, and keeping tutorials and articles in step +- Added `stocnet_completion()` to offer values an argument accepts as RStudio completions + - `graphr(fict_lotr, node_color =` Tab lists the node variables `fict_lotr` holds + - Covers node and tie variables, layouts, label criteria, themes, and defaults such as `isolates` + - Off unless asked for, since it replaces/encapsulates one of RStudio's internal functions; `stocnet_completion(FALSE)` restores it + - A `persist` argument remembers the choice, as `stocnet_theme()` does + - Values labelled with its class and its categories or range; a layout with the package that draws it + +## Layouts + +- Improved layered layouts + - Consolidated layered layouts onto one engine + - "layered" is now default layout for directed acyclic networks + - Deprecating "hierarchy" as "layered" is more consistent for two-mode networks + - "lineage" is now exactly "layered" with the axes exchanged + - Deprecating "alluvial" to free name for plot of changing membership composition + - "railway" and "ladder" unchanged, but are `alignment = "rungs"` + - Checks whether layout is appropriate for the network, and reverts to default if not + - Minimises two costs: tie length (`check_span()`) and nodal offset (`check_offset()`) + - Added `ranks=` to choose the layers: + - "compact" asks `igraph::layout_with_sugiyama()` + - "generation" ranks each node by its distance from a root + - "tight" (default) minimises total tie length while every tie points down at least one layer + - a numeric node attribute lays the layers out by its values, spaced in proportion to them, which is what "lineage" used to take a `rank` for + - Added `alignment=` to choose how a layer is spread out: + - "straight" (default) draws ties as close to straight as ordering allows + - "rungs" gives every layer same integer spacing + - Each weakly connected component now laid out on its own and packed beside others + - Fixed `layout_layered()` centring on a second mode node yet reading first mode labels + - Fixed the direction of layers given as values to `ranks=` + - Fixed layered layout labels to ignore `label_repel` +- Improved multilevel layout + - Renamed "multilevel" layout to "levels" to avoid potential future collisions + - Fixed `layout_levels()` to identify modes without having to name a `level` + - Exposed `method`, `alpha`, `beta`, `FUN1` and `FUN2` arguments +- Deprecated "dyad", "triad", "tetrad", "pentad" and "hexad" layout names + - "configuration" already picks the one matching the number of nodes + - The `layout_dyad()` to `layout_hexad()` functions themselves are unchanged +- Fixed three broken paths in `layout_concentric()` + - Fixed drawing each node of an unlabelled network on a circle of its own + - Fixed erroring where a membership holds `NA`, now gathers `NA` nodes onto own circle + - Fixed `order.by=`, which errored on every network; now orders nodes around each circle by that attribute, decreasing +- Fixed `graphr(snap = TRUE)` to use rotation and other improvements +- Added a "scaling" layout for multidimensional scaling + - Scales classically up to a hundred nodes, and by pivots above that + - Scales unweighted path distances, so it can handle signed/weighted networks + - Lays each component out separately, where "pmds" refuses disconnected networks outright + - Drawn with labelled axes at a fixed ratio, since these coordinates can be read + - Captioned with `check_stress()` for Kruskal's stress-1, and console-reported where poor, + as well as the share of distance variance two dimensions hold +- Added a "correspondence" layout for correspondence analysis + - Places nodes by the similarity of their tie profiles + - Reads directed networks symmetrically by default, but "out" or "in" possible + - Refuses signed network, but `double=TRUE` an option + - Console-reports low broomstick ratio dimensions and low cos2 nodes +- Added a `layout_matching()` alias so every layout has a short name +- Removed unreachable `getNNvec()` + +## Graphing + +- Fixed `graphr()` clipping nodes at panel edges + - Nodes were drawn at absolute sizes, but scales are expanded by a share of data range, + so `ggplot2`'s 5% left less room than the radius of a node in a small network + - Room is now taken from node size, so small networks are given more space +- Added `backbone=` to `graphr()` for drawing dense, hairball "stress", "fr", "drl", "kk" networks + - By default, networks with 50+ nodes and a mean degree ≥8 use backbones + - `TRUE`/`FALSE` force, or specify filter/threshold (see `manynet::tie_is_backbone()`) +- Improved `graphr()` to draw multilevel networks of interlocking one-mode and two-mode layers by default + - Fixed tie opacity so that those between levels fade behind those within them + - Fixed default node size in multilevel layout, which is now taken from how many nodes there are at each level rather than in the whole network + - Fixed labelling to be plain text nudged away instead of white-boxed labels +- Fixed arcs drawn on layout that places two nodes at one point, + e.g. `graphr(ison_networkers, layout = "scaling")` +- Fixed `graphr()` to draw parallel ties as a fan instead of one on top of another +- Fixed tie colouring in multiplex networks to color layers not signs by default + - Signs are still drawn as linetypes + - Added a legend for the tie linetype wherever it is the only thing showing the signs, and is titled by whatever color is showing +- Improved node shape legend to name modes where two-mode network records them instead of default "One" and "Two" +- Fixed size of self-loops to draw as a fraction of how far the layout spreads rather than at a fixed diameter of one coordinate unit +- Improved `node_group` to draw overlapping hulls (closes #51) + - e.g. `graphr(ison_adolescents, node_group = netrics::node_x_clique())` +- Improved `graphr()` to note when a colour/shape legend grows past about 7 keys +- Fixed `graphs()` to collect guides even where panels held different ranges or categories (closes #15) + +## Theming + +- Added `persist=` to `stocnet_theme()` + - `persist = TRUE` writes it to `tools::R_user_dir("autograph", "config")` + - Nothing written to disk unless passed explicitly + - Setting a theme without it clears any choice persisted earlier +- Improved font detection in `stocnet_theme()` via `{systemfonts}` + - Added `list_fonts()` for listing the font families R can see +- Added `stocnet_medium()` for standardising output to the expected medium: + - "screen" (default), "presentation", "mobile", and "print" + - `ag_size()` scales text, not node size or anything else + - "print" draws on white irrespective of theme grounding +- Improved theme backgrounds to reach every plot, not only the graphs + - Plot themes are now built with the `ag_theme_*()` wrappers + - Blanked elements stay blank, so a graph keeps no axis text or coordinates + - Ties, nodes, and labels with no colour take `ag_ink()` and the ground +- Added `simulate_colorblind()`, `check_separation()` and `check_contrast()` for checking palettes + - Simulates deuteranopia, protanopia, and tritanopia (Machado et al. 2009) + - Scores a pair by its worst case across those and normal vision + - Added `severity=` to view anomalous trichromacy (deuteranomaly, protanomaly) + - Added "grey" type to show a palette as print and photocopy may render it +- Added `check_span()` for scoring how far each tie travels down the page +- Added `check_offset()` for scoring how far each tie is from its ideal straight line +- Added `ag_ink()` for the colour a theme writes with + - Used by axis text and reference lines, clearing 4.5:1 from the ground + - Frees `ag_base()` to be light where that sets it off from the highlight +- Added `ag_missing()` for the neutral that data recedes into: + - missing values, isolates, and any "other" remainder +- Improved `ag_qualitative()` to note when a palette is asked for more colours than it holds +- Improved every theme's categorical palette for colour-blind viewers + - `ag_qualitative()` uses most distinct, own colors first not mixtures + - Samples across the palette only where it holds too few colours + - Kept "rainbow" in its own order, since fidelity to a spectrum is its point +- Improved some highlight pairs + - Fixed "neon" highlight pair, a cyan and a green 12.7 apart + - Fixed "ethz" and "cmu" highlight pairs by lightening their greys +- Fixed divergent palettes pairing a red pole with a green or teal one, such as in "ethz" +- Added a "clay" theme inspired by palette and fonts of Anthropic's Claude + +## Plotting + +- Added `plot.goldfishFit()` for the four diagnostic panels a fit can supply + - Deviance trace, Schoenfeld smooths, score processes, and waiting times + - Draws only from what the fit stores, leaving a missing panel out + - Draws the waiting-time panel for exact-time models only + - Draws the compact term strings the test itself carries, which do not + repeat where an effect appears over two networks + - Reports how many terms the Schoenfeld panel dropped + - Fixed the Schoenfeld panel to select terms by column position + - The labels it matched on intersect the effect names on the intercept + alone, so it drew one term where four were asked for +- Added `plot.goldfishGOF()` for each effect's cumulative score process + - Draws the Brownian-bridge bands the effect's p-value was read from + - Draws x on the object's own process time, named for the clock it records + - Inverts the distribution the event-clock p-value comes from +- Added `plot.goldfishTimeTest()` for the scaled Schoenfeld residuals + - Draws a smooth per effect, with the fitted estimate as the reference + - Colours the scatter by period under `method = "periods"` +- Added `plot.goldfishOnset()` for the parameter path and information accrual + - Windows both panels on the excursion, so each coefficient gets its scales + - Draws the proportional diagonal, the departure from which is the finding + - Added `view = c("both", "path", "accrual")` to select a single panel +- Added `plot.goldfishMargins()` for observed against expected activity + - Draws martingale residuals where the model class defines a compensator + - Draws the calibration ratio where it does not, from the recorded scales + - Draws the `top` actors furthest from the reference, and counts the rest + - Draws level against shape where goldfish supplies `dispersion` + - Names both omissions: under two completed spans, and beyond `top` +- Added a `page` argument to `plot()` on the per-term diagnostics + - Applies to `goldfishGOF`, `goldfishTimeTest`, and `goldfishOnset` + - Added `count_pages()`, reporting the count without rendering + - Renamed from `ag_pages()`, since `ag_` is for the theme accessors + - Errors with the page count where `page` is past the last + - Leaves each figure as it was where `page` is omitted +- Renamed the goldfish classes to a package prefix and a camelCase noun + - `goldfishOutliers`, `goldfishChangepoints`, `goldfishOnset`, + `goldfishMargins`, `goldfishGOF`, `goldfishTimeTest`, `goldfishScoreTest`, + and `goldfishFit` + - A name such as `test_gof` is what a sibling package would pick too, and + two packages emitting one class string cannot be told apart by dispatch + - Renamed the dispatch methods and the precooked fixtures to match + - Kept the older class names as aliases, so such objects plot as before + - Documented the convention in CONTRIBUTING, for the whole ecosystem +- Improved `plot.goldfishOutliers()` and `plot.goldfishChangepoints()` + - Renamed from `plot.outliers.goldfish()` and `plot.changepoints.goldfish()` + - Read the metadata each object carries rather than inferring it + - Plot the `.series` column, so a diagnostic called with `effect =` is + drawn as that term's series rather than as a log-likelihood trace + - Fixed both to facet on process, so no line crosses a process boundary + - Fixed `plot.goldfishChangepoints()` to draw each process's own breaks + - Fixed `plot.goldfishOutliers()` to read the now-logical `outlier` column + - Rewrote `plot.goldfishChangepoints()` for the tibble with a `cpt` column + - Labels the axis with break times only where they are numbers, + so a dated event stream keeps its date scale +- Added precooked `goldfish_margins`, `goldfish_gof`, `goldfish_time`, + and `goldfish_onset`, and refreshed the two older fixtures + - Each is stamped with the goldfish version that produced it, 1.9.21 + - `goldfish_outliers` comes from a receiver-choice model of the calls + - The others come from event models of the `fisheries_treaties` layer +- Replaced `cli::cli_abort()` in `gf_facet_paged()` with `snet_abort()` +- Replaced em dashes in `R/plot_diagnostics.R` since only ASCII is portable +- Fixed signed branch of `plot.matrix()` hard-coding its poles + +## Tutorials + +- Moved the decorative gifs in the visualisation tutorial into quiz answer feedback + # autograph 1.1.2 ## Package @@ -29,6 +231,13 @@ ## Graphing +- Improved `graphr()`'s `labels` argument to label a *selection* of the nodes, where previously the only alternative to labelling every node was labelling none + - `labels` now also accepts a depth of ranks (`labels = 5`), a measure to rank by (`labels = "betweenness"`, or `labels = c(betweenness = 5)` for both), the name of a logical node attribute, or a logical/name/position vector of the nodes to label + - Selection is by rank rather than by headcount, so nodes tied at the cut are labelled together, using `netrics::node_is_max()`; a two-mode or multilevel network is ranked within each mode or level, so a dense level cannot crowd the others out of the labelling + - Networks of more than 30 nodes now label only their most central nodes by default, reporting how many; `labels = TRUE` still labels every node. `manynet::fict_marvel` went from 194 overlapping labels to 10 + - Labels are drawn from the selected rows rather than by blanking the rest, so no space is reserved (and nothing is repelled away from) labels that are not drawn + - `grapht()` resolves the selection once across all waves, so the same nodes stay labelled from frame to frame, and `graphs()` resolves it once for all its panels; `grapht()`'s own default above 30 nodes remains no labels at all + - `{netrics}` is only suggested, so an automatic selection falls back to a random sample when it is not installed, and a measure asked for by name says what to install - Fixed `graphs()`/`grapht()` erroring ("Can't combine `..1` and `..2` ") on a longitudinal network whose changing node attributes are stored as non-character vectors (e.g. the logical `active` flag and numeric height/mass in `fict_starwars`) - Such networks now split into waves via a guarded `to_waves()` that coerces the offending attributes when `{manynet}`'s splitter cannot combine them - Fixed `graphr(..., snap = TRUE)` erroring ("'-' only defined for equally-sized data frames") whenever a node sat exactly on a grid point @@ -72,7 +281,15 @@ ## Tutorials +- Added a colour blindness section to the visualisation tutorial + - Covers `simulate_colorblind()`, `check_separation()`, and how palettes are ordered + - Notes that the "rainbow" theme is not a colour-blind safe scheme +- Added a note on installing a theme's fonts to the visualisation tutorial +- Updated the README with the case for colour-blind readable palettes - Updated visualization tutorial to use colour/color consistently +- Updated the Labels section of the visualisation tutorial to cover selecting which nodes to label, replacing the `mutate(name = ifelse(...))` workaround it used to recommend + - `fict_lotr`, the tutorial's running example, has 36 nodes, so its graphs now name only its most central characters; the surrounding prose says so and shows how to choose otherwise + - Regenerated `vignettes/articles/visualising-networks.Rmd` and the pre-rendered tutorial HTML to match # autograph 1.1.1 diff --git a/R/autograph-defunct.R b/R/autograph-defunct.R new file mode 100644 index 00000000..7be78b49 --- /dev/null +++ b/R/autograph-defunct.R @@ -0,0 +1,243 @@ +# Compatibility with older {manynet} ------------------------------------------ + +# autograph declares the oldest {manynet} it works with, which is the version +# on CRAN. Two functions it uses arrived in manynet 2.3.0, so each is reached +# through a shim that calls manynet where the function is there and does the +# same thing itself where it is not. Each shim tests for the function rather +# than for the version string, because a pre-release dev build can carry the +# version without yet exporting the function. Delete a shim once its minimum +# is raised past 2.3.0. Both branches reach the function through +# `getExportedValue()` rather than `::`, since `R CMD check` resolves a `::` +# call against the installed manynet and reports the newer name as missing +# even where the call is never reached. + +# `manynet::delete_isolates()` is manynet 2.3.0's name for `to_no_isolates()`, +# which it otherwise leaves unchanged. +.ag_delete_isolates <- function(.data) { + fn <- if (.ag_has_manynet("delete_isolates")) "delete_isolates" else + "to_no_isolates" + getExportedValue("manynet", fn)(.data) +} + +# `manynet::is_multilevel()` marks TRUE a network whose nodes fall into two or +# more levels that are tied both within and between. The fallback repeats +# manynet's own igraph method: levels are read from the 'lvl' attribute that +# `to_multilevel()` writes, and otherwise from the modes of a two-mode +# network. A 'stocnet' is coerced to an 'igraph' first, as manynet's default +# method does, so a network of three or more levels is read as two. +.ag_is_multilevel <- function(.data) { + if (.ag_has_manynet("is_multilevel")) + return(getExportedValue("manynet", "is_multilevel")(.data)) + .data <- manynet::as_igraph(.data) + if ("lvl" %in% igraph::vertex_attr_names(.data)) + return(length(unique(igraph::vertex_attr(.data, "lvl"))) > 1) + if (!manynet::is_twomode(.data)) return(FALSE) + # A tie-less network is neither, and is returned before `tie_is_twomode()`, + # which cannot name an empty measure. + if (manynet::net_ties(.data) == 0) return(FALSE) + between <- manynet::tie_is_twomode(.data) + any(between) && any(!between) +} + +.ag_has_manynet <- function(fn) { + fn %in% getNamespaceExports("manynet") +} + +# Compatibility with older {goldfish} ----------------------------------------- + +# The goldfish overview draws each panel from a goldfish diagnostic, several of +# which arrived after the version on CRAN. Reaching them through +# `getExportedValue()` rather than `::` keeps `R CMD check` from resolving the +# call against whichever goldfish is installed and reporting the newer names as +# missing. Where the function really is missing the error this raises is caught +# by `gf_overview_try()`, which leaves that panel out, exactly as it does for a +# fit that stores no such primitive. +.ag_goldfish <- function(fn) { + getExportedValue("goldfish", fn) +} + +# The goldfish classes were renamed to a package prefix plus a noun, in +# camelCase (see the class naming rule in .github/CONTRIBUTING.md). Five old +# names keep an alias that forwards to the renamed method, so an object classed +# the way an earlier autograph expected still plots. `diagnose_outliers` and +# `diagnose_changepoints` are the names goldfish 1.9.21 stamps; +# `outliers.goldfish` and `changepoints.goldfish` are the two the draft methods +# were written against before that; `result.goldfish` is the fit class every +# goldfish stamps, back to the version on CRAN, so it is the alias that reaches +# the most users. Nothing is aliased for the classes only the renamed goldfish +# emits, since nothing ever stamped those. +# +# An alias restores dispatch, not the old column contract: each forwards to a +# method that reads the current columns (`.series`, and a logical `outlier` or +# `cpt`), so an object carrying the pre-1.9.21 shape still fails on its columns. +# Delete each alias once the oldest goldfish autograph works with is past the +# rename. + +#' @rdname plot_adequacy +#' @details +#' `plot.diagnose_outliers()`, `plot.outliers.goldfish()`, +#' `plot.diagnose_changepoints()` and `plot.changepoints.goldfish()` are +#' aliases for `plot.goldfishOutliers()` and `plot.goldfishChangepoints()`, +#' kept so that an object carrying one of the older class names plots as +#' before. Each reads the columns the current methods read. They will be +#' removed. +#' @method plot diagnose_outliers +#' @export +plot.diagnose_outliers <- function(x, ...) { + plot.goldfishOutliers(x, ...) +} + +#' @rdname plot_adequacy +#' @method plot outliers.goldfish +#' @export +plot.outliers.goldfish <- function(x, ...) { + plot.goldfishOutliers(x, ...) +} + +#' @rdname plot_adequacy +#' @method plot diagnose_changepoints +#' @export +plot.diagnose_changepoints <- function(x, ...) { + plot.goldfishChangepoints(x, ...) +} + +#' @rdname plot_adequacy +#' @method plot changepoints.goldfish +#' @export +plot.changepoints.goldfish <- function(x, ...) { + plot.goldfishChangepoints(x, ...) +} + +#' @rdname plot_goldfish_fit +#' @details +#' `plot.result.goldfish()` is an alias for `plot.goldfishFit()`, kept so that +#' a fit from a goldfish that still stamps the old class name plots as before. +#' It will be removed. +#' @method plot result.goldfish +#' @export +plot.result.goldfish <- function(x, ..., effects = 4) { + plot.goldfishFit(x, ..., effects = effects) +} + + +# Layouts ----------------------------------------------------------------- + +#' Deprecated layout names +#' +#' @description +#' Each of these draws what its replacement draws, after saying so. +#' They are kept so that a call naming the older layout still draws, +#' and will be removed. +#' +#' - "hierarchy" is now "layered", which is what the layout does to a +#' two-mode network, where the two modes are two layers and neither is +#' above the other in any hierarchy. +#' - "alluvial" is now "lineage". The name is held for a plot of changing +#' membership composition over time. +#' - "multilevel" is now "levels", which `{graphlayouts}` does not also use. +#' - "dyad", "triad", "tetrad", "pentad" and "hexad" are now all +#' "configuration", which already picks the one matching the number of +#' nodes. The functions of those names are not deprecated. +#' +#' Note that `.deprecated_layouts()` lists these, so that neither the +#' completions nor the functional audit offers a retired name. +#' @name layout_deprecated +#' @param .data Some `{manynet}` compatible network data. +#' @param ... Arguments passed on to the replacement layout. +#' @returns Returns a table of nodes' x and y coordinates. +#' @keywords internal +NULL + +#' @rdname layout_deprecated +#' @export +layout_hierarchy <- function(.data, ...) { + manynet::snet_warn( + "The {.val hierarchy} layout is deprecated.", + "Please use {.code layout = \"layered\"} instead, which draws the same networks the same way.") + layout_layered(.data, ...) +} + +#' @rdname layout_deprecated +#' @export +layout_tbl_graph_hierarchy <- layout_hierarchy + +#' @rdname layout_deprecated +#' @export +layout_alluvial <- function(.data, ...) { + manynet::snet_warn( + "The {.val alluvial} layout is deprecated.", + "Please use {.code layout = \"lineage\"} instead, which draws the same networks the same way.") + layout_lineage(.data, ...) +} + +#' @rdname layout_deprecated +#' @export +layout_tbl_graph_alluvial <- layout_alluvial + +#' @rdname layout_deprecated +#' @export +layout_multilevel <- function(.data, ...) { + manynet::snet_warn( + "The {.val multilevel} layout is deprecated.", + "Please use {.code layout = \"levels\"} instead, which takes the same {.arg level} argument.") + layout_levels(.data, ...) +} + +#' @rdname layout_deprecated +#' @export +layout_tbl_graph_multilevel <- layout_multilevel + +#' @rdname layout_deprecated +#' @export +layout_tbl_graph_dyad <- function(.data, ...) { + manynet::snet_warn( + "The {.val dyad} layout is deprecated.", + "Please use {.code layout = \"configuration\"} instead,", + "which draws whichever configuration the network has nodes for.", + "The {.fn layout_dyad} function itself is not deprecated.") + layout_configuration(.data, ...) +} + +#' @rdname layout_deprecated +#' @export +layout_tbl_graph_triad <- function(.data, ...) { + manynet::snet_warn( + "The {.val triad} layout is deprecated.", + "Please use {.code layout = \"configuration\"} instead,", + "which draws whichever configuration the network has nodes for.", + "The {.fn layout_triad} function itself is not deprecated.") + layout_configuration(.data, ...) +} + +#' @rdname layout_deprecated +#' @export +layout_tbl_graph_tetrad <- function(.data, ...) { + manynet::snet_warn( + "The {.val tetrad} layout is deprecated.", + "Please use {.code layout = \"configuration\"} instead,", + "which draws whichever configuration the network has nodes for.", + "The {.fn layout_tetrad} function itself is not deprecated.") + layout_configuration(.data, ...) +} + +#' @rdname layout_deprecated +#' @export +layout_tbl_graph_pentad <- function(.data, ...) { + manynet::snet_warn( + "The {.val pentad} layout is deprecated.", + "Please use {.code layout = \"configuration\"} instead,", + "which draws whichever configuration the network has nodes for.", + "The {.fn layout_pentad} function itself is not deprecated.") + layout_configuration(.data, ...) +} + +#' @rdname layout_deprecated +#' @export +layout_tbl_graph_hexad <- function(.data, ...) { + manynet::snet_warn( + "The {.val hexad} layout is deprecated.", + "Please use {.code layout = \"configuration\"} instead,", + "which draws whichever configuration the network has nodes for.", + "The {.fn layout_hexad} function itself is not deprecated.") + layout_configuration(.data, ...) +} diff --git a/R/autograph_utilities.R b/R/autograph_utilities.R index fbbbf7c9..cfdc1066 100644 --- a/R/autograph_utilities.R +++ b/R/autograph_utilities.R @@ -23,3 +23,59 @@ add_spaces <- function(CamelString) { # and # https://cran.r-project.org/web/packages/patchwork/vignettes/patchwork.html + +# Remembered preferences ---- + +# A preference the user asked to keep, such as a theme or whether argument +# values are completed, is written to the user's configuration directory. Only +# ever called with `persist = TRUE`, i.e. at the user's explicit request. +# Failure is not worth an error: the choice still holds for this session. +pref_file <- function(name) { + file.path(tools::R_user_dir("autograph", which = "config"), + paste0(name, ".rds")) +} + +write_pref <- function(name, value) { + f <- pref_file(name) + tryCatch({ + dir.create(dirname(f), recursive = TRUE, showWarnings = FALSE) + saveRDS(value, f) + TRUE + }, error = function(e) FALSE, warning = function(w) FALSE) +} + +read_pref <- function(name) { + f <- pref_file(name) + if (!file.exists(f)) return(NULL) + tryCatch(readRDS(f), error = function(e) NULL) +} + +forget_pref <- function(name) { + f <- pref_file(name) + if (file.exists(f)) tryCatch(unlink(f), error = function(e) NULL) + invisible(NULL) +} + +# Squash a vector into the unit interval. Shared by the layouts, which place +# their coordinates there, and by the grid snapping, which reads them back. +.rescale <- function(vector){ + (vector - min(vector)) / (max(vector) - min(vector)) +} + +# A plot has one caption, and more than one step may have something to say in +# it: a scaled layout reports its fit, and a plot that sets its isolates aside +# names them. Each is added rather than assigned, so that the second does not +# replace the first. +.add_caption <- function(p, text) { + old <- p[["labels"]][["caption"]] + if (!is.null(old) && !is.na(old) && nzchar(old)) + text <- paste(old, text, sep = " | ") + p + ggplot2::labs(caption = text) +} + +# Every layout returns its coordinates as a two-column data frame named x and y. +.to_lo <- function(mat) { + res <- as.data.frame(mat) + names(res) <- c("x","y") + res +} diff --git a/R/data_precooked.R b/R/data_precooked.R index 6890c2f7..a9756ad7 100644 --- a/R/data_precooked.R +++ b/R/data_precooked.R @@ -1,10 +1,15 @@ #' Precooked results for demonstrating plotting +#' @name made_earlier #' @description #' These are all pre-cooked results objects, saved here to save time in #' testing and demonstrating how autograph plots look. +NULL + +# migraph objects #### + #' @docType data #' @keywords datasets -#' @name made_earlier +#' @rdname made_earlier #' @usage data(res_migraph_reg) "res_migraph_reg" @@ -20,6 +25,8 @@ #' @usage data(res_migraph_diff) "res_migraph_diff" +# manynet objects #### + #' @docType data #' @keywords datasets #' @rdname made_earlier @@ -60,7 +67,7 @@ #' @usage data(monan_gof) "monan_gof" -# ERGM objects #### +# ergm objects #### #' @docType data #' @keywords datasets @@ -68,7 +75,7 @@ #' @usage data(ergm_gof) "ergm_gof" -# Goldfish objects #### +# goldfish objects #### #' @docType data #' @keywords datasets @@ -81,3 +88,34 @@ #' @rdname made_earlier #' @usage data(goldfish_changepoints) "goldfish_changepoints" + +#' @docType data +#' @keywords datasets +#' @rdname made_earlier +#' @usage data(goldfish_margins) +"goldfish_margins" + +#' @docType data +#' @keywords datasets +#' @rdname made_earlier +#' @usage data(goldfish_gof) +"goldfish_gof" + +#' @docType data +#' @keywords datasets +#' @rdname made_earlier +#' @usage data(goldfish_time) +"goldfish_time" + +#' @docType data +#' @keywords datasets +#' @rdname made_earlier +#' @usage data(goldfish_onset) +"goldfish_onset" + +#' @docType data +#' @keywords datasets +#' @rdname made_earlier +#' @usage data(goldfish_fit) +"goldfish_fit" + diff --git a/R/graph_aes.R b/R/graph_aes.R index e75010e5..f3afdeb1 100644 --- a/R/graph_aes.R +++ b/R/graph_aes.R @@ -16,7 +16,7 @@ # Node aesthetics ---- -.infer_nsize <- function(g, node_size) { +.infer_nsize <- function(g, node_size, layout = NULL) { if (!is.null(node_size)) { if (is.character(node_size)) { out <- manynet::node_attribute(g, node_size) @@ -27,11 +27,81 @@ # at face value: `node_size = 0.5` means 0.5. if (length(out) > 1 && all(out <= 1 & out >= 0, na.rm = TRUE)) out <- out * 10 } else { - out <- min(20, (250 / manynet::net_nodes(g)) / 2) + out <- .default_nsize(manynet::net_nodes(g)) + # The default size shrinks with how crowded the plot is, but a multilevel + # layout draws each level in a plane of its own, so each is only as crowded + # as itself. Sizing them from the whole network instead would draw the + # smaller level -- 53 of `fict_marvel`'s 194 nodes -- as if it held all of + # them, which is where the one-mode structure of such networks is. + lvl <- .node_level(g, layout) + if (!is.null(lvl)) + out <- vapply(lvl, function(l) .default_nsize(sum(lvl == l)), numeric(1)) } as.numeric(out) } +.default_nsize <- function(n) min(20, (250 / n) / 2) + +# Room at the panel edge for the nodes drawn there. +# +# A node is drawn at an absolute size, in millimetres, but a scale is expanded +# by a share of its data range. The two never meet, so a node on the edge of +# the layout hangs over the panel edge and is clipped. `ggplot2`'s default +# expansion of 5% is under half the radius of a node in a small network drawn +# on a short panel: `ison_adolescents` draws its 8 nodes about 16mm across, and +# 5% of a 3-inch panel is under 4mm against a radius of nearly 8mm. +# +# The room is therefore taken from the node size rather than left at a +# constant. Dividing by 100 holds the radius of a node on a panel of about +# 4 inches, which is the short side of a figure at the sizes these are drawn +# at, and a large network needs nothing, since its nodes are already small. +.node_padding <- function(nsize) { + nsize <- suppressWarnings(max(as.numeric(nsize), na.rm = TRUE)) + if (!is.finite(nsize)) return(0.05) + max(0.05, nsize / 100) +} + +# Widens whichever expansion a scale already carries, rather than replacing it. +# A layered or lineage layout sets its own expansion, to leave room for labels +# on one side, and that room must survive. +.widen_expand <- function(expand, mult) { + if (is.null(expand) || inherits(expand, "waiver")) + return(ggplot2::expansion(mult = mult)) + if (length(expand) == 2L) expand <- c(expand, expand) + expand[c(1L, 3L)] <- pmax(expand[c(1L, 3L)], mult) + expand +} + +# Gives the nodes at the edge of the layout room to be drawn whole. +# Called once the layout, the nodes and the labels are all in place, so that a +# scale one of them set is widened rather than replaced; replacing it would +# both warn and drop the room that scale was set to keep. +.pad_for_nodes <- function(p, nsize) { + mult <- .node_padding(nsize) + for (axis in c("x", "y")) { + sc <- p[["scales"]]$get_scales(axis) + if (is.null(sc)) { + p <- p + if (axis == "x") + ggplot2::scale_x_continuous(expand = ggplot2::expansion(mult = mult)) + else ggplot2::scale_y_continuous(expand = ggplot2::expansion(mult = mult)) + } else sc[["expand"]] <- .widen_expand(sc[["expand"]], mult) + } + p +} + +# The level each node is drawn at by a multilevel layout, or NULL where the +# network is not being drawn that way. Only how the nodes are grouped matters +# here, not which group ends up at which level, so unlike `.infer_level()` in +# R/layout_levels.R there is no need to work out which mode holds the ties +# within itself. +.node_level <- function(g, layout) { + if (!identical(layout, "levels")) return(NULL) + if ("lvl" %in% igraph::vertex_attr_names(g)) + return(as.integer(as.factor(igraph::vertex_attr(g, "lvl")))) + if (!manynet::is_twomode(g)) return(NULL) + as.integer(manynet::node_is_mode(g)) + 1L +} + # A value mapped to an aesthetic has to be either a single value or one per # node/tie; ggplot2 would otherwise report the mismatch in terms of its own # internal data frame ("Aesthetics must be either length 1 or the same as the @@ -44,75 +114,174 @@ "{n} {what}s in the network, but {len} value{?s} {?was/were} given.") } -.infer_nshape <- function(g, node_shape) { +# The categories the node shape shows, or NULL where every node is drawn with +# the same shape. Read as in `.infer_nshape()`. +.nshape_values <- function(g, node_shape) { + if (!is.null(node_shape)) { + if (!node_shape %in% manynet::net_node_attributes(g)) return(NULL) + return(as.factor(as.character(manynet::node_attribute(g, node_shape)))) + } + if (!is_twomode(g)) return(NULL) + modes <- .mode_labels(g) + factor(ifelse(igraph::V(g)$type, modes[2], modes[1]), levels = modes) +} + +.infer_nshape <- function(g, node_shape, levels = NULL) { if (!is.null(node_shape)) { - if (node_shape %in% names(manynet::node_attribute(g))) { + if (node_shape %in% manynet::net_node_attributes(g)) { out <- as.factor(as.character(manynet::node_attribute(g, node_shape))) + if (!is.null(levels)) out <- factor(as.character(out), levels = levels) } else out <- node_shape } else if (is_twomode(g) & is.null(node_shape)) { # igraph convention: type FALSE is the first mode, TRUE the second. - # "One" sorts before "Two", so the first mode takes the first shape in - # the scale (a circle) and the second mode the second (a square). - out <- ifelse(igraph::V(g)$type, "Two", "One") + # A factor rather than a character vector, so that the first mode takes + # the first shape in the scale (a circle) and the second mode the second + # (a square). Relying on the labels sorting into that order only held + # while they were "One" and "Two": mode names need not be alphabetical, + # and `ison_southern_women`'s "social events" sort before its "women". + modes <- .mode_labels(g) + out <- factor(ifelse(igraph::V(g)$type, modes[2], modes[1]), levels = modes) } else { out <- 21 # Use fillable circle shape (was "circle") } out } -.infer_ncolor <- function(g, node_color) { - if (!is.null(node_color)) { - if (node_color %in% names(manynet::node_attribute(g))) { - if ("node_mark" %in% class(manynet::node_attribute(g, node_color))) { - out <- factor(as.character(manynet::node_attribute(g, node_color)), - levels = c("FALSE", "TRUE")) - } else out <- as.factor(as.character(manynet::node_attribute(g, node_color))) - if (length(unique(out)) == 1) { - out <- rep("black", manynet::net_nodes(g)) - .inform_constant_color("node_color", node_color, "node") - } - } else out <- node_color - } else { - out <- "black" +# What to call each of a two-mode network's modes in the shape legend. Where +# the network records them, "characters" and "teams" say far more than "One" +# and "Two"; `mode_names()` returns NULL where it does not, and a single name +# for a one-mode network, so both modes have to be there to be used. +.mode_labels <- function(g) { + modes <- tryCatch(manynet::mode_names(g), error = function(e) NULL) + if (length(modes) != 2 || anyNA(modes) || any(!nzchar(modes))) + return(c("One", "Two")) + as.character(modes) +} + +# The categories the node colour shows, before anything is decided about how to +# draw them, or NULL where the colour is one colour rather than a mapping. +# Separated from `.infer_ncolor()` so that `.shared_aes()` can read the +# categories of every network in a `graphs()` list, including those of a network +# that holds only one of them. +.ncolor_values <- function(g, node_color) { + if (is.null(node_color)) return(NULL) + if (!node_color %in% manynet::net_node_attributes(g)) return(NULL) + vals <- manynet::node_attribute(g, node_color) + if ("node_mark" %in% class(vals)) + factor(as.character(vals), levels = c("FALSE", "TRUE")) else + as.factor(as.character(vals)) +} + +# `levels` holds the categories that `graphs()` found across all of its panels. +# Where it is given, a network holding only one of them keeps that category +# rather than collapsing to plain black, so that a category is drawn in the same +# colour in every panel. +.infer_ncolor <- function(g, node_color, levels = NULL) { + vals <- .ncolor_values(g, node_color) + if (is.null(vals)) return(if (!is.null(node_color)) node_color else ag_ink()) + if (!is.null(levels)) return(factor(as.character(vals), levels = levels)) + if (length(unique(vals)) == 1) { + .inform_constant_color("node_color", node_color, "node") + return(rep(ag_ink(), manynet::net_nodes(g))) } - out + vals } # Edge aesthetics ---- -.infer_ecolor <- function(g, edge_color){ +# The categories the edge colour shows, before anything is decided about how to +# draw them: the attribute the user named, else the layer each tie belongs to, +# else its sign. NULL where the colour is one colour rather than a mapping. +# Separated from `.infer_ecolor()` for the same reason as `.ncolor_values()`. +.ecolor_values <- function(g, edge_color) { if (!is.null(edge_color)) { - if (edge_color %in% names(manynet::tie_attribute(g))) { - if ("tie_mark" %in% class(manynet::tie_attribute(g, edge_color))) { - out <- factor(as.character(manynet::tie_attribute(g, edge_color)), - levels = c("FALSE", "TRUE")) - } else out <- as.factor(as.character(manynet::tie_attribute(g, edge_color))) - if (length(unique(out)) == 1) { - out <- rep("black", manynet::net_ties(g)) - .inform_constant_color("edge_color", edge_color, "tie") - } - } else { - out <- edge_color - } - } else if (is.null(edge_color) & manynet::is_signed(g)) { - # Multiplex/complex signed networks carry a sign only on the signed layer; - # ties on other layers have `NA` sign. Treat those (and any NA) as positive - # so the resulting factor never contains NA, which grid rejects at draw time. - signs <- igraph::E(g)$sign - out <- factor(ifelse(!is.na(signs) & signs >= 0, "Positive", "Negative"), - levels = c("Positive", "Negative")) - if (length(unique(out)) == 1) { - out <- "black" + if (!edge_color %in% manynet::net_tie_attributes(g)) return(NULL) + vals <- manynet::tie_attribute(g, edge_color) + return(if ("tie_mark" %in% class(vals)) + factor(as.character(vals), levels = c("FALSE", "TRUE")) else + as.factor(as.character(vals))) + } + # Which layer a tie belongs to says more about a multiplex network than + # its sign does, and only some of its ties have a sign to show: a sign is + # still drawn, as the linetype, but every tie belongs to a layer. + # Ordered alphabetically, as every other attribute mapped to a colour is. + # Taking the order from `manynet::layer_names()` instead was tried and + # dropped: with the two-value highlight palette it decides which layer is + # drawn in the emphasis colour, and `fict_marvel` names its layers in an + # order that greys out the very layer the plot is about. + if (.has_layers(g)) + return(as.factor(as.character( + manynet::tie_attribute(g, .layer_attribute(g))))) + # Signed networks that are not layered can still carry a sign on only + # some of their ties. Treat those (and any NA) as positive, as the + # linetype does, so that the factor never contains NA, which grid rejects + # at draw time, and so that colour and linetype agree about which ties + # are negative. + if (manynet::is_signed(g)) { + signs <- as.numeric(manynet::tie_signs(g)) + return(factor(ifelse(is.na(signs) | signs >= 0, "Positive", "Negative"), + levels = c("Positive", "Negative"))) + } + NULL +} + +# `levels` is read as in `.infer_ncolor()`. +.infer_ecolor <- function(g, edge_color, levels = NULL){ + vals <- .ecolor_values(g, edge_color) + if (is.null(vals)) return(if (!is.null(edge_color)) edge_color else ag_ink()) + if (!is.null(levels)) return(factor(as.character(vals), levels = levels)) + if (length(unique(vals)) == 1) { + # An attribute the user named is reported when it cannot distinguish + # anything; a default the package chose itself is not. + if (!is.null(edge_color)) { + .inform_constant_color("edge_color", edge_color, "tie") + return(rep(ag_ink(), manynet::net_ties(g))) } - } else { - out <- "black" + return(ag_ink()) } - out + vals +} + +# Which tie attribute records the layer each tie belongs to, or NA where none +# does. manynet spells this attribute "type" through 2.2.3 and "layer" from +# 2.3.0, and both spellings appear in the networks 2.3.0 ships, so the +# attribute the network carries decides rather than the manynet version. +# `manynet::net_layers()` reads only the "type" spelling from an igraph, and +# so counts one layer for a network whose ties record a "layer", which is why +# the layers are counted here instead. +.layer_attribute <- function(g) { + atts <- manynet::net_tie_attributes(g) + out <- intersect(c("type", "layer"), atts) + if (length(out) == 0) NA_character_ else out[1] +} + +# Whether the ties are divided between layers to tell apart. This is not +# `is_multiplex()`, which is TRUE for any network carrying a non-reserved tie +# attribute or parallel ties, whether or not those distinguish layers. A +# single test covers both that the layers are recorded per tie -- which naming +# them, as `layer_names()` does, need not imply -- and that there are at least +# two of them to tell apart. +.has_layers <- function(g) { + att <- .layer_attribute(g) + if (is.na(att)) return(FALSE) + length(unique(manynet::tie_attribute(g, att))) > 1 +} + +# What the edge colour legend is titled. `edge_color` names the attribute when +# the user gave one; otherwise the colour carries whatever the default chose, +# so this is decided here alongside `.infer_ecolor()` rather than separately +# by each caller, which is how the legend came to say "Sign" over colours that +# were showing layers. +.infer_ecolor_title <- function(g, edge_color) { + if (!is.null(edge_color)) return(edge_color) + if (.has_layers(g)) return("Layer") + if (manynet::is_signed(g)) return("Sign") + "Color" } .infer_esize <- function(g, edge_size){ if (!is.null(edge_size)) { - if (any(edge_size %in% names(manynet::tie_attribute(g)))) { + if (any(edge_size %in% manynet::net_tie_attributes(g))) { # strip measure classes (e.g. tie_measure) so scales can rescale out <- as.numeric(manynet::tie_attribute(g, edge_size)) } else { @@ -151,3 +320,73 @@ } else out <- "solid" out } + +# Shared aesthetics across a list of networks ---- + +# `graphs()` draws each network as a plot of its own and lets `{patchwork}` +# collect the guides. A guide can only be collected when it is identical to the +# one beside it, and a scale takes its limits from the data of its own plot, so +# two networks holding different values of the same attribute produce two +# guides. Worse, the palette and the value each category is drawn in are chosen +# from the categories of that network alone, so the same category can be drawn +# in a different colour in each panel. +# +# This resolves each aesthetic over the whole list, so that every panel is drawn +# and labelled against the same scale. It reads the same helpers the panels +# themselves use, so the categories and the sizes cannot disagree. +# +# An entry is NULL where the aesthetic does not vary across the list, which +# leaves the panel to decide as it does for a single plot. +.shared_aes <- function(netlist, node_color = NULL, node_shape = NULL, + node_size = NULL, edge_color = NULL, edge_size = NULL, + layout = NULL) { + nets <- lapply(netlist, function(x) + tryCatch(manynet::as_tidygraph(x), error = function(e) NULL)) + nets <- Filter(Negate(is.null), nets) + if (length(nets) < 2) return(NULL) + gather <- function(f) lapply(nets, function(g) + tryCatch(f(g), error = function(e) NULL)) + out <- list( + esize = .shared_range(gather(function(g) .infer_esize(g, edge_size))), + nsize = if (is.null(node_size)) NULL else + .shared_range(gather(function(g) .infer_nsize(g, node_size, layout))), + ecolor = .shared_levels(gather(function(g) .ecolor_values(g, edge_color))), + ncolor = .shared_levels(gather(function(g) .ncolor_values(g, node_color))), + nshape = .shared_levels(gather(function(g) .nshape_values(g, node_shape))), + diffusion = .shared_levels(gather(.diffusion_states)), + nadopt = .shared_range(gather(.finite_adoption_time))) + if (all(vapply(out, is.null, logical(1)))) NULL else out +} + +# The union of the categories a mapping takes across the list, in the order they +# are first met, or NULL where there is nothing to tell apart. +.shared_levels <- function(vals) { + vals <- Filter(function(x) is.factor(x) || is.character(x), vals) + if (!length(vals)) return(NULL) + levs <- unique(unlist(lapply(vals, function(x) + if (is.factor(x)) levels(x) else unique(as.character(x))))) + levs <- levs[!is.na(levs)] + if (length(levs) < 2) NULL else levs +} + +# The range a continuous mapping covers across the list, or NULL where every +# network holds the same single value and so needs no scale to tell them apart. +.shared_range <- function(vals) { + vals <- unlist(Filter(is.numeric, vals)) + vals <- vals[is.finite(vals)] + if (length(unique(vals)) < 2) NULL else range(vals) +} + +# The categories the two diffusion mappings in R/graph_nodes.R show, read the +# same way there. +.diffusion_states <- function(g) { + if (!"diffusion" %in% manynet::net_node_attributes(g)) return(NULL) + states <- c("Susceptible", "Exposed", "Infected", "Recovered") + out <- .recode_diffusion(manynet::node_attribute(g, "diffusion")) + factor(out, levels = states[states %in% out]) +} + +.finite_adoption_time <- function(g) { + out <- .node_adoption_time(g) + out[is.finite(out)] +} diff --git a/R/graph_backbone.R b/R/graph_backbone.R new file mode 100644 index 00000000..3afce9d7 --- /dev/null +++ b/R/graph_backbone.R @@ -0,0 +1,208 @@ +# The backbone behind `graphr(backbone = )`, which answers the hairball: a +# network dense enough that every tie covers another one, and dense enough that +# a force layout has no room to pull its groups apart. +# +# {manynet} 2.3.0 marks the ties a local null model keeps -- the ties that carry +# more weight, or sit in more triangles, than chance alone would put there. +# Those ties are what this uses, in two places at once. The layout is computed +# from them, so the groups they hold together separate. Every tie is still +# drawn, but the ties the filter does not keep are faded well back, so that the +# reader can see both the shape of the network and what made it. +# +# `{graphlayouts}` draws a backbone layout of its own, but its Simmelian +# counts need `{oaqc}`, and it replaces the layout rather than informing it. +# manynet's filters need no further package, and leave the choice of layout +# where the user made it. + +# The filters manynet offers. Named here so that a wrong name is caught with a +# suggestion before manynet sees it, and so that the names can be offered as +# completions (see R/graph_completion.R). +.backbone_filters <- function() { + c("disparity", "lans", "noise", "mlf", "simmelian") +} + +# Resolves the `backbone` argument to one of three things: NULL where it is +# switched off, the string "auto" where the decision is left to the network +# itself, or a list naming the filter and the threshold to run. +.check_backbone <- function(backbone) { + if (is.null(backbone)) return("auto") + if (isFALSE(backbone)) return(NULL) + if (isTRUE(backbone)) return(list(filter = NULL, threshold = NULL)) + if (is.character(backbone) && length(backbone) == 1L) + return(list(filter = .check_choice(backbone, .backbone_filters(), + "backbone"), + threshold = NULL)) + # A number is read as a threshold, since that is the only number the filters + # take: the significance level under which a tie is kept. + if (is.numeric(backbone) && length(backbone) == 1L && !is.na(backbone) && + backbone > 0 && backbone <= 1) + return(list(filter = NULL, threshold = backbone)) + # The vector is named here rather than inside the message, since cli reads a + # brace expression that starts with a dot as one of its own styles. + filters <- .backbone_filters() + manynet::snet_abort( + "{.arg backbone} should be {.code TRUE} or {.code FALSE}, one of", + "{.or {.val {filters}}}, or a threshold between 0 and 1.") +} + +# A network dense enough to draw as a hairball. Read as a mean degree of at +# least eight across at least fifty nodes: below either of those a force layout +# still has the room to separate what there is to separate, and fading half the +# ties of a network the reader can already follow only takes it away from them. +.is_hairball <- function(g) { + n <- as.numeric(manynet::net_nodes(g)) + m <- as.numeric(manynet::net_ties(g)) + n >= 50 && m >= 4 * n +} + +# Which of the filters manynet runs where it is given none. Resolved here, +# rather than left to manynet, so that the message below can name the filter +# the reader is looking at. Kept in step with `manynet:::.backbone_spec()`. +.backbone_filter <- function(g, filter) { + if (!is.null(filter)) return(filter) + if (manynet::is_weighted(g)) "lans" else "simmelian" +} + +# One logical for each tie of `g`, TRUE where the filter keeps it, or NULL +# where no filter applies. NULL is the answer wherever the drawing would not +# change: a network with no ties, a filter that keeps every tie or none, an +# older manynet, or a signed network, whose negative weights have no place in +# these null models. +.infer_backbone <- function(g, spec, layout = NULL, edge_bundle = FALSE, + manual = FALSE) { + if (is.null(spec)) return(NULL) + auto <- identical(spec, "auto") + if (auto) { + if (!.is_hairball(g)) return(NULL) + spec <- list(filter = NULL, threshold = NULL) + } + if (!.ag_has_manynet("tie_is_backbone")) { + if (!auto) manynet::snet_info( + "Drawing every tie alike: {.arg backbone} needs {.pkg manynet} 2.3.0.") + return(NULL) + } + if (manynet::net_ties(g) == 0) return(NULL) + if (manynet::is_signed(g)) { + if (!auto) manynet::snet_info( + "Drawing every tie alike: a signed network has no backbone,", + "since a negative weight has no place in these null models.") + return(NULL) + } + filter <- .backbone_filter(g, spec[["filter"]]) + mark <- .backbone_mark(g, filter, spec[["threshold"]], auto) + if (is.null(mark)) return(NULL) + # A filter that keeps everything says nothing, and one that keeps nothing + # leaves a drawing of nothing but faded ties. + if (all(mark) || !any(mark)) { + if (!auto) manynet::snet_info( + "Drawing every tie alike: the {.val {filter}} filter keeps", + "{ifelse(all(mark), 'every tie', 'no tie')} of this network.") + return(NULL) + } + # A layout given coordinates of its own, as each panel of a `graphs()` set + # is, reads no tie lengths either, whatever layout it is named after. + .note_backbone(mark, filter, auto, + !manual && .backbone_moves_layout(layout), edge_bundle) + mark +} + +# manynet reports the filter and the threshold it settled on, which is said +# again below alongside what it did to the drawing, so its own note is stilled +# here. A filter the user named is left to fail in manynet's own words, since +# that is where the reason is known; one chosen automatically is stepped over +# instead, so that a filter that cannot run never stops a plot. +.backbone_mark <- function(g, filter, threshold, auto) { + call_it <- function() suppressMessages( + getExportedValue("manynet", "tie_is_backbone")(g, filter = filter, + threshold = threshold)) + mark <- if (auto) tryCatch(call_it(), error = function(e) NULL) else call_it() + if (is.null(mark)) return(NULL) + # `tie_is_backbone()` returns a named 'tie_mark', and a name or a class of + # its own would travel into the plot's data as one. + unname(as.logical(mark)) +} + +.note_backbone <- function(mark, filter, auto, moves, edge_bundle) { + kept <- sum(mark) + total <- length(mark) + share <- round(100 * kept / total) + # A layout that keeps its own coordinates, or that has no room for a tie + # length, fades its ties and no more. + what <- if (moves) + paste("Drawing the {kept} of {total} ties ({share}%) that the", + "{.val {filter}} filter keeps as the shortest, and fading the rest.") + else + paste("Fading every tie but the {kept} of {total} ({share}%) that the", + "{.val {filter}} filter keeps.") + if (auto) { + manynet::snet_info( + what, "Use {.code backbone = FALSE} to draw every tie alike.") + } else manynet::snet_info(what) + if (!isFALSE(edge_bundle) && !is.null(edge_bundle)) + manynet::snet_info( + "Bundled ties are drawn alike: bundling merges ties into shared paths,", + "which cannot each carry a fading of their own.") +} + +# Whether a layout already carries meaning in its coordinates, in which case +# neither snapping (see R/graph_snap.R) nor a backbone may move them. +.is_fixed_layout <- function(layout) { + is.character(layout) && length(layout) == 1L && layout %in% .fixed_layouts() +} + +# The tie lengths the layout is given: a tie the filter keeps is drawn short, +# and a tie it does not is left long, so that the groups the backbone holds +# together are what the algorithm draws together. Every tie is still there, so +# the network is laid out as whole as it was. This is what a backbone layout +# does, and it does more for a hairball than deleting the other ties does: a +# filter is severe enough on an unweighted network to leave dozens of loose +# fragments, which a layout then packs side by side rather than reading. +# +# Which way a weight points is the layout's own business, and the two families +# point opposite ways. A larger weight draws two nodes together in "stress", +# "fr" and "drl" -- ggraph inverts the weights it hands to the first of those +# -- and holds them apart in "kk". Every other layout either takes no weights +# or does nothing with them, and is left as it is. +.backbone_pulls <- function() c("stress", "fr", "drl") +.backbone_pushes <- function() c("kk") + +# Whether a layout reads tie lengths at all, which is what decides between +# laying the network out from the backbone and only fading the rest. +.backbone_moves_layout <- function(layout) { + if (.is_fixed_layout(layout)) return(FALSE) + is.character(layout) && length(layout) == 1L && + layout %in% c(.backbone_pulls(), .backbone_pushes()) +} + +# How much shorter a kept tie is drawn. Four holds the groups of a modular +# network apart without drawing the ties the filter dropped so long that they +# push the network into a spindle. +.backbone_ratio <- 4 + +.backbone_layout_weights <- function(g, layout, mark) { + if (!.backbone_moves_layout(layout)) return(NULL) + short <- .backbone_anchored(g, mark) + if (layout %in% .backbone_pulls()) + ifelse(short, .backbone_ratio, 1) else ifelse(short, 1, .backbone_ratio) +} + +# A node that the filter left no tie of has nothing drawing it in, and a layout +# then throws it clear of the network and squeezes everything else into the +# corner it leaves. So the strongest tie of such a node is drawn short as well, +# which holds the node beside its neighbour without saying that the filter kept +# the tie: the fading still reports what the filter did. +.backbone_anchored <- function(g, mark) { + gi <- manynet::as_igraph(g) + el <- igraph::as_edgelist(gi, names = FALSE) + held <- tabulate(as.vector(el[mark, , drop = FALSE]), + nbins = igraph::vcount(gi)) + loose <- which(held == 0) + if (!length(loose)) return(mark) + weight <- if (manynet::is_weighted(gi)) igraph::edge_attr(gi, "weight") else + rep(1, nrow(el)) + for (v in loose) { + inc <- which(el[, 1] == v | el[, 2] == v) + if (length(inc)) mark[inc[which.max(weight[inc])]] <- TRUE + } + mark +} diff --git a/R/graph_checks.R b/R/graph_checks.R index 29a74a80..a530076a 100644 --- a/R/graph_checks.R +++ b/R/graph_checks.R @@ -172,6 +172,118 @@ what = "node attribute") } +# Labels ---- + +# `labels` is more than a switch: it can also select *which* nodes to label, +# by rank on a measure, by a mark or logical attribute, or by naming nodes +# outright. This resolves any of those into one of four normalised forms -- +# FALSE, TRUE, a rank depth carrying the criterion to rank by, or a character +# vector of node names -- which .infer_labels() then turns into a selection. +# Node names are the normal form for an explicit selection because graphr() +# drops isolates after this check, which would shift every node's position. + +.label_criteria <- function() c("degree", "betweenness", "cutpoints", "random") + +.label_desc <- paste( + "A number of ranks to label, such as {.code labels = 5},", + "a measure to rank nodes by ({.val degree}, {.val betweenness},", + "{.val cutpoints} or {.val random}), or the names of the nodes to label,", + "can also be given here.") + +.check_labels <- function(g, labels, arg = "labels") { + # Without node names there is nothing to draw, whatever was asked for. + if (!manynet::is_labelled(g)) return(FALSE) + if (is.null(labels)) return(FALSE) + n <- as.numeric(manynet::net_nodes(g)) + nms <- manynet::node_names(g) + len <- length(labels) + if (is.logical(labels)) { + if (len == 1L) { + if (is.na(labels)) .abort_labels_type(labels, arg) + return(labels) + } + if (len != n) + manynet::snet_abort( + "{.arg {arg}} should be a single value or one value for each of the", + "{n} nodes in the network, but {len} value{?s} {?was/were} given.") + return(nms[!is.na(labels) & labels]) + } + if (is.numeric(labels)) { + if (len == 1L) { + if (is.na(labels) || labels <= 0 || labels != round(labels)) + manynet::snet_abort( + "{.arg {arg}} should be a positive whole number of ranks to label,", + "as in {.code {arg} = 5}, but {.val {labels}} was given.") + # Asking for more ranks than there are nodes asks for all of them. + if (labels >= n) return(TRUE) + crit <- names(labels) + crit <- if (is.null(crit) || !nzchar(crit)) "degree" else + .check_choice(crit, .label_criteria(), arg) + return(structure(as.integer(labels), criterion = crit)) + } + bad <- labels[is.na(labels) | labels < 1 | labels > n | + labels != round(labels)] + n_bad <- length(bad) + if (n_bad) + manynet::snet_abort( + "{.arg {arg}} should be the positions of the nodes to label, between", + "1 and {n}, the number of nodes in the network,", + "but {n_bad} of the values given {?is/are} not: {.val {bad}}.") + return(nms[unique(labels)]) + } + if (is.character(labels)) { + if (len == 1L) { + # A node attribute takes precedence over a criterion, and a criterion over + # a node name, as .check_node_color() prefers an attribute to a colour. + value <- .match_name(labels, igraph::vertex_attr_names(g), arg, + what = "node attribute", + extra = unique(c(.label_criteria(), nms)), + show = igraph::vertex_attr_names(g), + extra_desc = .label_desc) + if (value %in% igraph::vertex_attr_names(g)) + return(.labels_from_attribute(g, value, arg)) + if (value %in% .label_criteria()) + # Every criterion but "random" has a maximum to take, so one rank is + # enough; a random selection has to be given a size instead. + return(structure(if (value == "random") min(10L, as.integer(n)) else 1L, + criterion = value)) + return(value) + } + unknown <- setdiff(labels, nms) + n_unknown <- length(unknown) + if (n_unknown) { + suggestion <- .suggest_name(unknown[1], nms) + msg <- paste("{.arg {arg}} should name nodes in the network, but", + "{n_unknown} of the names given {?was/were} not found", + "among them: {.val {unknown}}.") + if (!is.null(suggestion)) + msg <- paste(msg, "Did you mean {.val {suggestion}}?") + manynet::snet_abort(msg) + } + return(labels) + } + .abort_labels_type(labels, arg) +} + +.labels_from_attribute <- function(g, attribute, arg) { + vals <- manynet::node_attribute(g, attribute) + if (!is.logical(vals)) + manynet::snet_abort( + "{.arg {arg}} can name a node attribute marking which nodes to label,", + "but {.val {attribute}} holds {.cls {class(vals)}} values rather than", + "{.cls logical} ones.", + "A measure can be given instead, as in {.code {arg} = \"degree\"}.") + manynet::node_names(g)[!is.na(vals) & vals] +} + +.abort_labels_type <- function(labels, arg) { + manynet::snet_abort( + "{.arg {arg}} should be {.code TRUE} or {.code FALSE}, a number of ranks", + "to label, the name of a node attribute or measure, or a vector selecting", + "which nodes to label, but a value of class {.cls {class(labels)}}", + "was given.") +} + # Layout arguments ---- # Several of autograph's layouts need one value per node -- a membership, a @@ -215,8 +327,10 @@ } igraph_layouts <- sub("^layout_", "", grep("^layout_(as|in|with|on)_|^layout_(nicely|randomly|components)$", getNamespaceExports("igraph"), value = TRUE)) - sort(unique(c(from_ns("ggraph"), .autograph_layouts(), igraph_layouts, - sub("^(as|in|with|on)_", "", igraph_layouts)))) + # The retired names are still valid to give: `.rename_layout()` swaps each + # for its replacement below, rather than letting it fail as unknown. + sort(unique(c(from_ns("ggraph"), .autograph_layouts(), .deprecated_layouts(), + igraph_layouts, sub("^(as|in|with|on)_", "", igraph_layouts)))) } .check_layout <- function(layout) { @@ -237,16 +351,157 @@ # counted, which is too many to list. Only autograph's own layouts are named, # since those are the ones not documented elsewhere, and the rest are pointed # to by package. - .match_name(layout, .valid_layouts(), "layout", what = "layout", - show = .autograph_layouts(), - extra_desc = paste("Layouts provided by {.pkg ggraph},", - "{.pkg graphlayouts} and {.pkg igraph},", - "such as {.val stress} or {.val fr},", - "can also be named here.")) + layout <- .match_name(layout, .valid_layouts(), "layout", what = "layout", + show = .autograph_layouts(), + extra_desc = paste("Layouts provided by {.pkg ggraph},", + "{.pkg graphlayouts} and {.pkg igraph},", + "such as {.val stress} or {.val fr},", + "can also be named here.")) + .rename_layout(layout) +} + +# A retired layout name is swapped for its replacement here, once, rather than +# where it is drawn. Every step after this one -- the applicability check, the +# node sizes, the tie alpha, the labels -- compares the layout by name, and a +# name each of them had to know two spellings of is a name each of them would +# eventually be updated for only once. +.rename_layout <- function(layout) { + renamed <- c(hierarchy = "layered", alluvial = "lineage", + multilevel = "levels", dyad = "configuration", + triad = "configuration", tetrad = "configuration", + pentad = "configuration", hexad = "configuration") + if (!layout %in% names(renamed)) return(layout) + manynet::snet_warn( + "The {.val {layout}} layout is deprecated.", + "Please use {.code layout = \"{renamed[[layout]]}\"} instead.") + unname(renamed[[layout]]) } .autograph_layouts <- function() { nms <- tryCatch(ls(asNamespace("autograph"), all.names = TRUE), error = function(e) character()) - sub("^layout_tbl_graph_", "", grep("^layout_tbl_graph_", nms, value = TRUE)) + setdiff(sub("^layout_tbl_graph_", "", grep("^layout_tbl_graph_", nms, value = TRUE)), + .deprecated_layouts()) +} + +# The layout names that still draw but should no longer be offered or audited. +# Declared here rather than inferred from the shims, because a shim is an +# ordinary function and nothing in its body reliably marks it as retired. +# Every name here keeps its `.layout_requirements()` entry, so that the string +# is still validated before it reaches the shim. +.deprecated_layouts <- function() { + c("hierarchy", "alluvial", "multilevel", + "dyad", "triad", "tetrad", "pentad", "hexad") +} + +# Layouts whose coordinates carry meaning -- a layer, a mode, a generation, a +# date along one axis, or a scaled distance along both -- which snapping to a +# square grid would collapse. +.fixed_layouts <- function() { + c("layered", "lineage", "railway", "ladder", "levels", "scaling", + "correspondence", "hierarchy", "alluvial", "multilevel") +} + +# Layout applicability ---- + +# Several layouts only make sense for particular kinds of network: the +# configurational layouts place an exact number of nodes at fixed coordinates, +# the valence layout needs signs to read, and a layered layout assigns nodes to +# layers by path depth. Given anything else they used to either draw a +# meaningless plot (the layered family on one-mode input) or fail somewhere +# downstream with a message about the internals ("replacement has 5 rows, data +# has 8"). Declaring the requirement here means graphr() can say what it needs +# and fall back to a layout that works, and the test suite can read the same +# table rather than keeping its own copy of this knowledge. +# +# `check` is a predicate over manynet's marks; `need` completes the sentence +# "The {layout} layout needs ...". Layouts with no entry are unconstrained. +# `need` is plain text: it is substituted into the message as a value, and cli +# does not read markup a second time, so a `{.arg x}` here would print as +# written. +.layout_requirements <- function() { + n_nodes <- function(g) as.integer(manynet::net_nodes(g)) + exactly <- function(n) list(check = function(g, ...) n_nodes(g) == n, + need = paste("a network of exactly", n, "nodes")) + # The four layered layouts are one engine drawn four ways, and all assign + # layers to the nodes of a directed acyclic network as readily as they take + # the modes of a two-mode one, so all four carry the same requirement. + # Layers can also simply be given, as `ranks` values, in which case any + # network has them and there is nothing left to require. + layered <- list( + check = function(g, ranks = NULL, ...) .ranks_given(ranks) || + manynet::is_twomode(g) || + (manynet::is_directed(g) && manynet::is_acyclic(g)), + need = paste("a two-mode or a directed acyclic network,", + "or a `ranks` attribute to lay the layers out by")) + list( + layered = layered, + lineage = layered, + railway = layered, + ladder = layered, + # Deprecated names, kept so that the string is still validated before it + # reaches the shim that forwards it. See `.deprecated_layouts()`. + hierarchy = layered, + alluvial = layered, + # Being two-mode is not sufficient: manynet::to_matching() cannot pair off + # every two-mode network, and where it fails it does so with a message + # about differing numbers of rows. Probing it is cheap for the sizes these + # layouts are used at, and a plot beats that error. Note the network need + # not have a *perfect* matching -- ison_southern_women has none but lays + # out fine -- so is_perfect_matching() is not the test. + matching = list( + check = function(g, ...) manynet::is_twomode(g) && + !inherits(tryCatch(manynet::to_matching(g), error = function(e) e), + "error"), + need = "a two-mode network that a matching can be found for"), + valence = list( + check = function(g, ...) manynet::is_signed(g), + need = "a signed network"), + # Correspondence analysis divides by the mass of each node, so a negative + # tie has no reading. `double` splits the signs into two nonnegative + # halves, and the layout then applies after all, which is why the + # predicate reads the layout's own argument. + correspondence = list( + check = function(g, double = FALSE, ...) isTRUE(double) || + !manynet::is_signed(g), + need = paste("an unsigned network,", + "or `double = TRUE` to split the signs")), + # `concentric` and `levels` are deliberately absent. They also need + # more than a bare one-mode network, but unlike the layouts above the user + # can supply what is missing -- a `membership` or a `level` -- and + # .abort_layout_arg() already says exactly how. Substituting would replace + # that instruction with a worse message. Substitute only where no argument + # could rescue the layout; where one could, ask for it. + configuration = list( + check = function(g, ...) n_nodes(g) >= 2L && n_nodes(g) <= 6L, + need = "a network of between 2 and 6 nodes"), + dyad = exactly(2), triad = exactly(3), tetrad = exactly(4), + pentad = exactly(5), hexad = exactly(6) + ) +} + +# Does `layout` apply to `g`? TRUE when nothing is declared for it. +.layout_applies <- function(g, layout, ...) { + req <- .layout_requirements()[[layout]] + if (is.null(req)) return(TRUE) + isTRUE(tryCatch(req$check(g, ...), error = function(e) FALSE)) +} + +# Return the layout to actually use. Where the requested one does not apply, +# fall back to whatever graphr() would have chosen unasked, and say so, rather +# than failing downstream or drawing something meaningless. +.check_layout_applies <- function(g, layout, ...) { + if (is.null(layout) || !is.character(layout) || length(layout) != 1L) + return(layout) + if (.layout_applies(g, layout, ...)) return(layout) + need <- .layout_requirements()[[layout]]$need + alt <- .infer_layout(g, NULL) + # The inferred fallback has its own requirement (e.g. "layered" needs two + # modes), so guard against substituting one unusable layout for another. + if (identical(alt, layout) || !.layout_applies(g, alt, ...)) alt <- "stress" + manynet::snet_info( + "The {.val {layout}} layout needs {need}, so {.val {alt}} is used instead.", + "Use {.code layout = \"{alt}\"} to choose this explicitly,", + "or see {.fn graphr} for the other layouts available.") + alt } diff --git a/R/graph_completion.R b/R/graph_completion.R new file mode 100644 index 00000000..24f06b33 --- /dev/null +++ b/R/graph_completion.R @@ -0,0 +1,526 @@ +# Tab-completion of argument *values* for graphr(), graphs(), grapht() and +# stocnet_theme(), in RStudio. +# +# `graphr(fict_lotr, node_color = ` gives the user no way to see which node +# variables the network holds. graph_checks.R already knows every set of values +# these arguments accept, and .abort_no_match() lists them once a wrong value is +# given; this offers the same sets *before* a value is typed. +# +# R has no supported hook for completing argument values. `.DollarNames` covers +# `$` only, and `utils::rc.options("custom.completer")` is a single global slot +# that RStudio honours by handing the whole session over to R's own completion +# engine, which is weaker than RStudio's. So this wraps one RStudio function +# instead, as the polars package does, and delegates every line it does not +# recognise. That is a private API, so activation is at the user's request +# (see stocnet_completion()), every path falls back to the original on error, +# and deactivation restores what was there before. +# +# The parsing and candidate functions below know nothing about RStudio, and are +# tested directly; only .completion_wrap() touches the IDE. + +# Candidates ---- + +# The functions whose arguments are completed. Anything else is left to RStudio. +.completion_funs <- function() c("graphr", "graphs", "grapht", "stocnet_theme", + "set_stocnet_theme") + +# Values for `arg` in a call to `fun` on the network `g`, as a data frame of +# the value itself, the label RStudio shows in brackets beside it, and a line of +# detail after that. No rows where there is nothing to offer. +# +# Attributes come first: they are the values that cannot be looked up in the +# documentation. Colour names are deliberately not offered for `node_color`: +# six hundred of them would bury the handful of attributes that are the point. +.completion_values <- function(arg, g = NULL, fun = "graphr") { + if (is.null(arg) || !nzchar(arg)) return(.completion_frame()) + nodes <- .completion_attr_values(g, "node") + ties <- .completion_attr_values(g, "tie") + out <- switch( + arg, + "node_color" = , + "node_colour" = nodes, + "node_size" = nodes, + "node_group" = nodes, + "membership" = nodes, + "level" = nodes, + "rank" = nodes, + "node_shape" = rbind(nodes, .completion_frame(.shape_names, "shape")), + "edge_color" = , + "edge_colour" = ties, + "edge_size" = ties, + "center" = rbind(nodes, .completion_frame(c("events", "actors"), "mode")), + "labels" = rbind( + .completion_attr_values(g, "node", logical_only = TRUE), + .completion_frame(.label_criteria(), "measure"), + .completion_frame( + if (!is.null(g) && manynet::is_labelled(g)) manynet::node_labels(g), + "node")), + "backbone" = .completion_frame(.backbone_filters(), "filter"), + "layout" = .completion_layout_values(), + "theme" = .completion_frame(theme_opts, "theme"), + # An argument whose default is a vector of choices, as `isolates` and + # `based_on` are, carries its own candidates. Reading them from the formals + # means a new choice needs no change here. + .completion_frame(.completion_choices(fun, arg), "option")) + out[!duplicated(out$value) & !is.na(out$value), , drop = FALSE] +} + +.completion_frame <- function(value = character(), label = "", meta = "") { + value <- as.character(value) + data.frame(value = value, + label = rep_len(if (length(value)) label else character(), length(value)), + meta = rep_len(if (length(value)) meta else character(), length(value)), + stringsAsFactors = FALSE) +} + +# Node or tie attributes, labelled with the kind of variable each one holds, so +# that a variable worth colouring by can be told from one that is not. +.completion_attr_values <- function(g, what = c("node", "tie"), + logical_only = FALSE) { + what <- match.arg(what) + nms <- .completion_attrs(g, what) + if (!length(nms)) return(.completion_frame()) + vals <- lapply(nms, function(nm) tryCatch( + if (what == "node") igraph::vertex_attr(g, nm) else igraph::edge_attr(g, nm), + error = function(e) NULL)) + if (logical_only) { + keep <- vapply(vals, is.logical, logical(1)) + nms <- nms[keep] + vals <- vals[keep] + if (!length(nms)) return(.completion_frame()) + } + .completion_frame(nms, + vapply(vals, .completion_kind, character(1)), + vapply(vals, .completion_detail, character(1))) +} + +.completion_attrs <- function(g, what = c("node", "tie")) { + what <- match.arg(what) + if (is.null(g)) return(character()) + nms <- tryCatch( + if (what == "node") igraph::vertex_attr_names(g) else igraph::edge_attr_names(g), + error = function(e) character()) + # `name` holds the node labels rather than a variable to map an aesthetic to. + setdiff(nms, if (what == "node") "name" else character()) +} + +# What kind of variable this is, in the words graphr()'s documentation uses. +.completion_kind <- function(x) { + if (is.null(x)) return("") + if (inherits(x, "node_mark") || inherits(x, "tie_mark") || is.logical(x)) return("mark") + if (is.factor(x)) return("factor") + if (is.character(x)) return("character") + if (is.numeric(x)) return("numeric") + class(x)[[1L]] +} + +# A line about the values themselves, since which variable to map an aesthetic +# to depends on how many categories it has, or over what range it runs. +.completion_detail <- function(x) { + if (is.null(x) || !length(x)) return("") + if (is.logical(x)) return(paste(sum(x, na.rm = TRUE), "of", length(x))) + if (is.numeric(x)) { + rng <- suppressWarnings(range(x, na.rm = TRUE)) + if (any(!is.finite(rng))) return("") + return(paste(format(rng[[1L]], trim = TRUE, digits = 3), "to", + format(rng[[2L]], trim = TRUE, digits = 3))) + } + vals <- as.character(x) + lvls <- unique(vals[!is.na(vals)]) + # Few enough categories to read at a glance are worth naming outright. + listed <- paste(lvls, collapse = ", ") + if (length(lvls) <= 4L && nchar(listed) <= 32L) return(listed) + paste(length(lvls), "categories") +} + +# Layouts, labelled with the package that draws them, since which ones suit a +# network is documented package by package. +.completion_layout_values <- function() { + own <- .autograph_layouts() + # `.valid_layouts()` keeps the retired autograph names, so that giving one is + # still valid and gets renamed rather than refused. They are not offered, + # here or as `own`, so subtract them rather than let them fall through to + # `rest` and be labelled as somebody else's layouts. + rest <- setdiff(.valid_layouts(), c(own, .deprecated_layouts())) + ggraph <- sub("^layout_tbl_graph_", "", + grep("^layout_tbl_graph_", + tryCatch(ls(asNamespace("ggraph"), all.names = TRUE), + error = function(e) character()), value = TRUE)) + rbind(.completion_frame(own, "autograph"), + .completion_frame(rest, ifelse(rest %in% ggraph, "ggraph", "igraph"))) +} + +# Logical node attributes, which `labels` accepts as a selection of nodes. +.completion_marks <- function(g) { + .completion_attr_values(g, "node", logical_only = TRUE)$value +} + +.completion_choices <- function(fun, arg) { + fmls <- .completion_formals(fun) + if (!arg %in% names(fmls)) return(character()) + default <- fmls[[arg]] + if (!is.call(default) || !identical(default[[1L]], quote(c))) return(character()) + vals <- tryCatch(eval(default), error = function(e) NULL) + if (!is.character(vals) || length(vals) < 2L) return(character()) + vals +} + +.completion_formals <- function(fun) { + fn <- tryCatch(get(fun, envir = asNamespace("autograph")), error = function(e) NULL) + if (!is.function(fn)) return(NULL) + formals(fn) +} + +# Parsing the line ---- + +# Where the cursor sits in `line`: which function is being called, which of its +# arguments is being given a value, how much of that value is typed, and whether +# the cursor is inside a string. Returns NULL when the line is not a call to one +# of .completion_funs(). +# +# The line is scanned character by character rather than parsed, because a line +# that is still being typed does not parse: `graphr(fict_lotr, node_color = "` +# has an open bracket and an unterminated string. +.completion_context <- function(line) { + if (!is.character(line) || length(line) != 1L || !nzchar(line)) return(NULL) + frames <- .completion_scan(line) + if (!length(frames)) return(NULL) + # The value being typed always belongs to the innermost frame. The call it + # belongs to may be one frame further out, since `labels = c("Alice", "Be` is + # a documented way of writing a selection. + inner <- frames[[length(frames)]] + value <- .completion_value_text(.completion_last_chunk(line, inner)) + fun <- NULL + for (i in rev(seq_along(frames))) { + callee <- .completion_callee(substr(line, 1L, frames[[i]]$open - 1L)) + if (is.null(callee)) return(NULL) + if (callee %in% .completion_funs()) { fun <- callee; frame <- frames[[i]]; break } + if (!identical(callee, "c")) return(NULL) + } + if (is.null(fun)) return(NULL) + chunks <- .completion_chunks(line, frame) + arg <- .completion_argname(fun, chunks) + if (is.null(arg)) return(NULL) + list(fun = fun, arg = arg, token = value$token, quoted = value$quoted, + data = .completion_data_text(fun, chunks)) +} + +# The brackets still open at the end of the line, outermost first, each with the +# positions of the commas directly inside it. A comma inside a nested call, a +# string or a bracketed index belongs to that frame, not to this one. +.completion_scan <- function(line) { + chars <- strsplit(line, "", fixed = TRUE)[[1L]] + stack <- integer() # positions of the brackets still open + kinds <- character() # which bracket each one is + commas <- list() # top-level comma positions, one entry per open bracket + quoting <- "" + escaped <- FALSE + for (i in seq_along(chars)) { + ch <- chars[[i]] + if (escaped) { escaped <- FALSE; next } + if (nzchar(quoting)) { + if (ch == "\\") escaped <- TRUE else if (ch == quoting) quoting <- "" + next + } + if (ch %in% c("\"", "'", "`")) { quoting <- ch; next } + if (ch %in% c("(", "[", "{")) { + stack <- c(stack, i); kinds <- c(kinds, ch); commas <- c(commas, list(integer())) + next + } + if (ch %in% c(")", "]", "}")) { + n <- length(stack) + if (n) { stack <- stack[-n]; kinds <- kinds[-n]; commas <- commas[-n] } + next + } + if (ch == "," && length(stack)) { + n <- length(stack) + commas[[n]] <- c(commas[[n]], i) + } + } + n <- length(stack) + if (!n || kinds[[n]] != "(") return(list()) + keep <- which(kinds == "(") + lapply(keep, function(i) list(open = stack[[i]], commas = commas[[i]])) +} + +.completion_last_chunk <- function(line, frame) { + chunks <- .completion_chunks(line, frame) + chunks[[length(chunks)]] +} + +# The function being called: the identifier before the open bracket, with any +# `pkg::` prefix dropped. +.completion_callee <- function(before) { + m <- regmatches(before, regexpr("[A-Za-z._][A-Za-z0-9._]*\\s*$", before)) + if (!length(m) || !nzchar(trimws(m))) return(NULL) + trimws(m) +} + +# The arguments given so far, as written, split on the top-level commas. +.completion_chunks <- function(line, scan) { + starts <- c(scan$open, scan$commas) + 1L + ends <- c(scan$commas - 1L, nchar(line)) + mapply(substr, list(line), starts, ends, USE.NAMES = FALSE) +} + +.completion_named <- function(chunk) { + # `(?!=)` so that a comparison, `x == 1`, is not read as naming an argument. + m <- regexpr("^\\s*[A-Za-z._][A-Za-z0-9._]*\\s*=(?!=)", chunk, perl = TRUE) + if (m == -1L) return(NULL) + trimws(sub("=$", "", regmatches(chunk, m))) +} + +# Which argument the last chunk fills. A named chunk says so itself; an unnamed +# one takes the next formal that no chunk has claimed by name, as R's own +# argument matching does. +.completion_argname <- function(fun, chunks) { + last <- chunks[[length(chunks)]] + named <- .completion_named(last) + if (!is.null(named)) return(named) + fmls <- names(.completion_formals(fun)) + if (is.null(fmls)) return(NULL) + claimed <- unlist(lapply(chunks, .completion_named)) + free <- setdiff(fmls, c(claimed, "...")) + rank <- sum(vapply(chunks, function(x) is.null(.completion_named(x)), logical(1))) + if (rank > length(free)) return(NULL) + free[[rank]] +} + +# How much of the value is typed, and whether it is inside quotes. +.completion_value_text <- function(chunk) { + rest <- sub("^\\s*[A-Za-z._][A-Za-z0-9._]*\\s*=(?![=])", "", chunk, perl = TRUE) + rest <- sub("^\\s+", "", rest) + q <- regmatches(rest, regexpr("^[\"']", rest)) + if (length(q) && nzchar(q)) { + list(token = substring(rest, 2L), quoted = TRUE) + } else list(token = rest, quoted = FALSE) +} + +# The expression given as the network, as written. +.completion_data_text <- function(fun, chunks) { + fmls <- names(.completion_formals(fun)) + if (is.null(fmls) || !length(fmls)) return(NULL) + first <- fmls[[1L]] + for (chunk in chunks) { + named <- .completion_named(chunk) + if (identical(named, first)) + return(trimws(sub("^\\s*[A-Za-z._][A-Za-z0-9._]*\\s*=", "", chunk))) + } + if (!is.null(.completion_named(chunks[[1L]]))) return(NULL) + trimws(chunks[[1L]]) +} + +# The network the call names, or NULL. Only a symbol is looked up: evaluating +# `graphr(to_undirected(net), ...)` would run code every time Tab is pressed. +.completion_object <- function(text, envir = parent.frame()) { + if (is.null(text) || !nzchar(text)) return(NULL) + if (!grepl("^[A-Za-z._][A-Za-z0-9._]*$", text)) return(NULL) + obj <- tryCatch(get0(text, envir = envir), error = function(e) NULL) + if (is.null(obj)) return(NULL) + tryCatch(manynet::as_igraph(obj), error = function(e) NULL) +} + +# What to offer for `line`, or NULL where there is nothing to add. The token is +# returned alongside the values because RStudio replaces it with the choice. +.completion_suggest <- function(line, envir = parent.frame()) { + ctx <- .completion_context(line) + if (is.null(ctx)) return(NULL) + g <- .completion_object(ctx$data, envir) + vals <- tryCatch(.completion_values(ctx$arg, g, ctx$fun), + error = function(e) .completion_frame()) + vals <- .completion_matches(vals, ctx$token) + if (!nrow(vals)) return(NULL) + list(token = ctx$token, values = vals, quoted = ctx$quoted) +} + +# Values the typed token could grow into: those starting with it, then those +# merely containing it, as RStudio's own fuzzy matching does. +.completion_matches <- function(values, token) { + if (!nrow(values)) return(values) + if (is.null(token) || !nzchar(token)) return(values) + starts <- startsWith(tolower(values$value), tolower(token)) + if (any(starts)) return(values[starts, , drop = FALSE]) + values[grepl(tolower(token), tolower(values$value), fixed = TRUE), , drop = FALSE] +} + +# The RStudio hook ---- + +# RStudio answers every completion request through one function in its +# `tools:rstudio` environment, which receives the line as typed. Wrapping that +# function, rather than one of the `.rs.getCompletions*` helpers, is what makes +# a value inside quotes reachable: by the time the helpers are called RStudio +# has already decided the string is a file path, and no longer knows which +# function or argument it belongs to. +.completion_rpc <- ".rs.rpc.get_completions" +.completion_saved <- ".rs.rpc.get_completions.autograph" + +.completion_env <- function() { + tryCatch(as.environment("tools:rstudio"), error = function(e) NULL) +} + +.completion_active <- function() { + env <- .completion_env() + !is.null(env) && exists(.completion_saved, envir = env, inherits = FALSE) +} + +.completion_activate <- function() { + env <- .completion_env() + if (is.null(env)) return(FALSE) + if (.completion_active()) return(TRUE) + original <- tryCatch(get(.completion_rpc, envir = env, inherits = FALSE), + error = function(e) NULL) + if (!is.function(original)) return(FALSE) + wrapper <- .completion_wrap(original, env) + if (is.null(wrapper)) return(FALSE) + tryCatch({ + assign(.completion_saved, original, envir = env) + assign(.completion_rpc, wrapper, envir = env) + TRUE + }, error = function(e) FALSE) +} + +.completion_deactivate <- function() { + env <- .completion_env() + if (is.null(env) || !.completion_active()) return(FALSE) + tryCatch({ + assign(.completion_rpc, get(.completion_saved, envir = env, inherits = FALSE), + envir = env) + rm(list = .completion_saved, envir = env) + TRUE + }, error = function(e) FALSE) +} + +# A replacement for RStudio's function, with the same formals as the version +# installed, so that however many arguments this RStudio passes, and in whatever +# order, they reach the original untouched. The call is forwarded as written +# rather than argument by argument, so an argument RStudio did not supply is +# never forced. +.completion_wrap <- function(original, env) { + wrapper <- function() { + completions <- tryCatch(.completion_rstudio(environment(), env), + error = function(e) NULL) + if (!is.null(completions)) return(completions) + call <- sys.call() + call[[1L]] <- original + eval(call, parent.frame()) + } + formals(wrapper) <- formals(original) + environment(wrapper) <- list2env(list(original = original, env = env, + .completion_rstudio = .completion_rstudio), + parent = asNamespace("autograph")) + wrapper +} + +# Completions in RStudio's own shape, or NULL to let RStudio answer. `frame` +# holds the arguments RStudio was called with; only `line` is read from it, so +# no other argument is forced. +.completion_rstudio <- function(frame, env) { + line <- get0("line", envir = frame, ifnotfound = NULL) + if (!is.character(line) || length(line) != 1L) return(NULL) + suggestion <- .completion_suggest(line, globalenv()) + if (is.null(suggestion)) return(NULL) + make <- tryCatch(get(".rs.makeCompletions", envir = env), error = function(e) NULL) + if (!is.function(make)) return(NULL) + types <- tryCatch(get(".rs.acCompletionTypes", envir = env), + error = function(e) list()) + # RStudio shows `packages` in brackets beside a COLUMN completion, and `meta` + # after that, so the kind of variable and a line about its values are visible + # without leaving the popup. + make(token = suggestion$token, + results = suggestion$values$value, + packages = suggestion$values$label, + meta = suggestion$values$meta, + # Values given without quotes are inserted with them, since every one of + # these arguments takes its value as a string. + quote = !suggestion$quoted, + type = if (is.null(types$COLUMN)) types$STRING else types$COLUMN, + excludeOtherCompletions = TRUE) +} + +# The user-facing switch ---- + +#' Completing argument values as you type +#' +#' @description +#' `graphr()` and its relatives take the names of node and tie variables, +#' layouts, and themes as strings, which means remembering what a network +#' holds. This offers those names to RStudio's completion system, so that +#' writing `graphr(fict_lotr, node_color = "` and pressing Tab lists the +#' variables `fict_lotr` holds, `layout = "` lists the layouts available, +#' and so on for every argument with a known set of values. +#' +#' This is off until it is asked for, because it works by replacing one of +#' RStudio's internal functions. That function is not part of a public +#' interface, so a future version of RStudio can change it. Nothing else about +#' completion changes: any line that is not one of these calls is passed to +#' RStudio untouched, as is any line this cannot make sense of. +#' +#' `stocnet_completion(FALSE)` puts RStudio's function back. +#' @param activate Logical, by default TRUE. +#' If TRUE, completion of argument values is switched on. +#' If FALSE, RStudio's own completions are restored. +#' If missing, the current state is reported and nothing changes. +#' @param persist Logical, by default FALSE. +#' If TRUE, the choice is remembered across sessions, +#' by writing it to the user's configuration directory +#' (see `tools::R_user_dir()`). +#' Nothing is written to disk unless this is set explicitly. +#' Use `stocnet_completion(persist = FALSE)` when activating +#' to forget a previously persisted choice. +#' @returns Invisibly, TRUE where completion is now active and FALSE otherwise. +#' Called for the effect it has on the IDE. +#' @family mapping +#' @name completion +#' @examples +#' \dontrun{ +#' # In RStudio, switch completion on for this session: +#' stocnet_completion() +#' # Then type graphr(fict_lotr, node_color = " and press Tab. +#' # To switch it off again: +#' stocnet_completion(FALSE) +#' } +#' @export +stocnet_completion <- function(activate, persist = FALSE) { + if (missing(activate)) { + if (.completion_active()) { + manynet::snet_info("Completion of argument values is {.emph on}.") + } else if (is.null(.completion_env())) { + manynet::snet_info( + "Completion of argument values is available in {.emph RStudio} only.") + } else { + manynet::snet_info(c( + "Completion of argument values is {.emph off}.", + "i" = "Use {.fn stocnet_completion} to switch it on.")) + } + return(invisible(.completion_active())) + } + if (!is.logical(activate) || length(activate) != 1L || is.na(activate)) + manynet::snet_abort("{.arg activate} should be either TRUE or FALSE.") + if (activate) { + if (is.null(.completion_env())) { + manynet::snet_info(c( + "Completion of argument values works in {.emph RStudio} only.", + "i" = "Nothing has been changed.")) + return(invisible(FALSE)) + } + if (!.completion_activate()) { + manynet::snet_warn(c( + "Completion of argument values could not be switched on.", + "i" = "This version of RStudio may complete arguments differently.")) + return(invisible(FALSE)) + } + manynet::snet_success("Completion of argument values is on.") + } else { + .completion_deactivate() + manynet::snet_success("Completion of argument values is off.") + } + if (persist) { + if (write_pref("completion", activate)) + manynet::snet_success("This will be remembered in future sessions.") + } else forget_pref("completion") + invisible(.completion_active()) +} + +#' @rdname completion +#' @export +set_completion <- stocnet_completion diff --git a/R/graph_costs.R b/R/graph_costs.R new file mode 100644 index 00000000..74150140 --- /dev/null +++ b/R/graph_costs.R @@ -0,0 +1,180 @@ +#' Checking how well a layout draws its ties +#' @description +#' These functions score a drawing rather than the network it draws, +#' so that a layout can be compared with another on the same network. +#' +#' `check_span()` reports how many rows of nodes each tie crosses. +#' A layered layout should send most ties to the next row down, +#' and a long tie is one that skips rows to get where it is going. +#' +#' `check_offset()` reports how far each tie travels sideways, +#' as a share of the width of the whole drawing. +#' A tie that drops straight down scores zero. +#' +#' `check_stress()` reports how far the distances drawn +#' depart from the distances through the network. +#' A layout that draws two nodes twice as far apart as two others +#' should be drawing a path twice as long. +#' @details +#' `check_span()` and `check_offset()` answer different questions, +#' and a layered layout needs both answered. +#' `check_span()` asks whether the rows were well chosen, +#' and `check_offset()` asks whether the nodes were well placed within them. +#' The "layered" layout minimises each in turn, and its `ranks` and +#' `alignment` arguments choose how. +#' +#' Which axis holds the rows is read from the plot, +#' as the axis on which the nodes take fewer distinct positions. +#' This is the y axis for "layered" and the x axis for "lineage", +#' so the same score can be compared across the two. +#' For a layout with no rows at all, such as "stress", +#' `check_span()` reports the distance in that axis' ranks, +#' which is not meaningful; the function is for layered layouts. +#' +#' `check_stress()` applies to any layout, since every layout draws its +#' nodes some distance apart, and the score is the share of the path +#' distances that the drawn distances get wrong. +#' It is Kruskal's stress-1, so 0 is a perfect drawing, +#' and Kruskal read 20% as poor, 10% as fair, 5% as good, +#' and 2.5% as excellent. +#' Those figures were set for psychometric data rather than for networks, +#' which are harder: most pairs of nodes in a small-world network sit +#' two or three steps apart, and a plane holds few such distances at once, +#' so a score near 30% is ordinary and one near 5% is rare. +#' A layout that never set out to draw path distances, +#' such as "layered", "circle" or "configuration", +#' scores poorly by design. +#' +#' The score belongs to the drawing rather than to the network, +#' which is what separates it from the share of distance variance +#' that `graphr()` reports beside it. +#' Draw one network two ways and the stress changes, since one drawing +#' holds its distances better than the other; +#' the share of variance does not, since two dimensions can hold +#' just as much of that network either way. +#' A network whose variance is held poorly sets a floor +#' that no layout gets under. +#' +#' The drawn distances are scaled to the path distances before they are +#' compared, since a layout may place its nodes on any scale it likes, +#' and the ties are counted unweighted, as `layout_scaling()` counts them. +#' Where a network is disconnected, the pairs with no path between them +#' are left out of the score. +#' @name check_layout +#' @family mapping +#' @source +#' Kruskal, Joseph B. 1964. +#' "Multidimensional scaling by optimizing goodness of fit to a nonmetric +#' hypothesis", _Psychometrika_ 29(1): 1-27. +#' \doi{10.1007/BF02289565} +#' @param x A plot, as `graphr()` returns. +#' @returns +#' `check_span()` returns one whole number for each tie, +#' with `total` and `mean` attributes holding the sum and the average. +#' +#' `check_offset()` returns one number between 0 and 1 for each tie, +#' with a `mean` attribute. +#' +#' `check_stress()` returns a single number of 0 or more, +#' with a `scale` attribute holding the factor the drawn distances were +#' scaled by, and a `pairs` attribute holding how many pairs were scored. +#' @examples +#' thrones <- manynet::to_uniplex(manynet::fict_thrones, "parent") +#' # The default graph is drawn once here, since each check reads the same plot. +#' drawn <- graphr(thrones) +#' # How long are the ties of the default layout? +#' attr(check_span(drawn), "total") +#' # How straight are they? +#' attr(check_offset(drawn), "mean") +#' # Compare with the layers igraph would have chosen: +#' # attr(check_span(graphr(thrones, ranks = "compact")), "total") +#' # Which layout draws the path distances best? +#' check_stress(graphr(manynet::ison_southern_women, layout = "scaling")) +#' check_stress(graphr(manynet::ison_southern_women, layout = "circle")) +NULL + +#' @rdname check_layout +#' @export +check_span <- function(x) { + lo <- .plot_coords(x) + # The rows are the axis the nodes take fewer distinct positions on, so that + # the score reads the same whether the layout runs downwards or rightwards. + rows <- if (length(unique(lo$y)) <= length(unique(lo$x))) lo$y else lo$x + rank <- match(rows, sort(unique(rows))) + el <- .plot_ties(x) + out <- abs(rank[el[, 2]] - rank[el[, 1]]) + structure(out, total = sum(out), mean = mean(out)) +} + +#' @rdname check_layout +#' @export +check_offset <- function(x) { + lo <- .plot_coords(x) + across <- if (length(unique(lo$y)) <= length(unique(lo$x))) lo$x else lo$y + width <- diff(range(across)) + el <- .plot_ties(x) + out <- abs(across[el[, 2]] - across[el[, 1]]) + if (width > 0) out <- out / width + structure(out, mean = mean(out)) +} + +#' @rdname check_layout +#' @export +check_stress <- function(x) { + crd <- as.matrix(.plot_coords(x)) + g <- manynet::as_igraph(.plot_graph(x)) + src <- .stress_sources(igraph::vcount(g)) + .stress1(igraph::distances(g, v = src, weights = NA), crd, src) +} + +# Kruskal's stress-1, between the path distances from a set of source nodes to +# every node, and the distances the layout draws between the same pairs. +# Shared with layout_scaling(), which reports the same number for the layout it +# has just computed. +.stress1 <- function(dis, crd, sources) { + drawn <- vapply(sources, function(i) + sqrt(rowSums((crd - rep(crd[i, ], each = nrow(crd)))^2)), + numeric(nrow(crd))) + drawn <- t(drawn) + keep <- is.finite(dis) & dis > 0 + d <- drawn[keep] + target <- dis[keep] + # A layout may place its nodes on any scale, so the drawn distances are + # scaled to the path distances before they are compared. Without this a + # pivot scaling of ison_southern_women, whose coordinates run much larger, + # scores 8.53 where it should score 0.32. + if (!length(d) || sum(d^2) == 0 || sum(target^2) == 0) + return(structure(NA_real_, scale = NA_real_, pairs = length(d))) + b <- sum(d * target) / sum(d^2) + structure(sqrt(sum((b * d - target)^2) / sum(target^2)), + scale = b, pairs = length(d)) +} + +# The nodes the distances are measured from. Every node where the network is +# small enough, and an evenly spaced sample of them otherwise, since a full +# distance matrix holds n^2 numbers and is soon larger than the network it +# measures. The sample is taken by position rather than at random, so that the +# same drawing scores the same on every call. +.stress_sources <- function(n, max_full = 500L) { + if (n <= max_full) return(seq_len(n)) + unique(round(seq(1, n, length.out = max_full))) +} + +.plot_coords <- function(x) { + if (!all(c("x", "y") %in% names(x[["data"]]))) manynet::snet_abort( + "{.arg x} should be a plot with node coordinates,", + "such as one {.fn graphr} returns.") + x[["data"]][, c("x", "y")] +} + +.plot_ties <- function(x) { + igraph::as_edgelist(manynet::as_igraph(.plot_graph(x)), names = FALSE) +} + +.plot_graph <- function(x) { + g <- attr(x[["data"]], "graph") + if (is.null(g)) manynet::snet_abort( + "{.arg x} should be a plot that carries the network it draws,", + "such as one {.fn graphr} returns.") + g +} diff --git a/R/graph_edges.R b/R/graph_edges.R index b505ef16..f5afb13e 100644 --- a/R/graph_edges.R +++ b/R/graph_edges.R @@ -1,76 +1,146 @@ graph_edges <- function(p, g, edge_color, edge_size, node_size, - edge_bundle = FALSE) { + edge_bundle = FALSE, layout = NULL, shared = NULL, + backbone = NULL) { bundle_geom <- .infer_bundle_geom(edge_bundle) + fan <- .has_parallel_ties(g) if (manynet::is_directed(g)) { - out <- .infer_directed_edge_mapping(g, edge_color, edge_size, node_size) - if (is.null(bundle_geom)) { - p <- .map_directed_edges(p, g, out) - } else { + out <- .infer_directed_edge_mapping(g, edge_color, edge_size, node_size, + layout, shared, backbone) + if (!is.null(bundle_geom)) { p <- .map_bundled_edges(p, g, out, bundle_geom, directed = TRUE) + } else if (fan) { + p <- .map_fanned_edges(p, g, out, directed = TRUE) + } else { + p <- .map_directed_edges(p, g, out) } } else { - out <- .infer_edge_mapping(g, edge_color, edge_size) - if (is.null(bundle_geom)) { - p <- .map_edges(p, g, out) - } else { + out <- .infer_edge_mapping(g, edge_color, edge_size, layout, shared, + backbone) + if (!is.null(bundle_geom)) { p <- .map_bundled_edges(p, g, out, bundle_geom, directed = FALSE) + } else if (fan) { + p <- .map_fanned_edges(p, g, out, directed = FALSE) + } else { + p <- .map_edges(p, g, out) } } if (manynet::is_complex(g)) { - p <- p + ggraph::geom_edge_loop0(edge_alpha = 0.4) + # Resolved here rather than inside aes(), which would evaluate it lazily + # against whatever `p` held by the time the plot was built. + loop_strength <- .infer_loop_strength(p) + p <- p + ggraph::geom_edge_loop0(ggplot2::aes(strength = loop_strength), + edge_alpha = 0.4) } # Check legends - if (length(unique(out[["esize"]])) == 1) { + # A `graphs()` panel is scaled against every network beside it rather than + # against its own ties alone (see `.shared_aes()`), so that the guides can be + # collected and a weight is drawn at the same width in each panel. + if (is.null(shared[["esize"]]) && length(unique(out[["esize"]])) == 1) { p <- p + ggplot2::guides(edge_width = "none") } else p <- p + ggraph::scale_edge_width_continuous(range = c(0.3, 3), + limits = shared[["esize"]], guide = ggplot2::guide_legend( ifelse(is.null(edge_size) & manynet::is_weighted(g), "Weight", "Width"))) - if (length(unique(out[["ecolor"]])) == 1) { + ecolor_title <- .infer_ecolor_title(g, edge_color) + elevels <- shared[["ecolor"]] + if (is.null(elevels)) elevels <- unique(as.character(out[["ecolor"]])) + if (length(elevels) == 1) { p <- p + ggplot2::guides(edge_colour = "none") - } else if (length(unique(out[["ecolor"]])) == 2){ - p <- p + ggraph::scale_edge_colour_manual(values = getOption("snet_highlight", default = c("grey","black")), - guide = ggplot2::guide_legend( - ifelse(is.null(edge_color) & - manynet::is_signed(g), - "Sign", edge_color))) - } else p <- p + ggraph::scale_edge_colour_manual(values = ag_qualitative(length(unique(out[["ecolor"]]))), - guide = ggplot2::guide_legend( - ifelse(is.null(edge_color) & - manynet::is_signed(g), - "Sign", edge_color))) + } else { + # The values are named by the categories, and the scale given those + # categories as its limits, so that a category keeps its colour and its key + # even in a panel whose ties do not include it. + evalues <- if (length(elevels) == 2) + getOption("snet_highlight", default = c("grey","black")) else + ag_qualitative(length(elevels)) + p <- p + ggraph::scale_edge_colour_manual( + values = stats::setNames(evalues, elevels), limits = elevels, + drop = FALSE, guide = ggplot2::guide_legend(ecolor_title)) + } # When linetype varies across ties (signed networks) it is mapped through # aes() as literal "solid"/"dashed" strings, so an identity scale is needed to - # use them verbatim. Sign is already labelled by the colour legend, so no - # separate linetype legend is drawn. + # use them verbatim. Such a scale draws no legend by default, which was right + # while the colours said "Sign" too, but leaves the dashes unexplained now + # that they may be the only thing showing the sign. if (length(unique(out[["line_type"]])) > 1) { - p <- p + ggraph::scale_edge_linetype_identity() + if (identical(ecolor_title, "Sign")) { + p <- p + ggraph::scale_edge_linetype_identity() + } else { + p <- p + ggraph::scale_edge_linetype_identity( + name = "Sign", guide = "legend", + breaks = c("solid", "dashed"), labels = c("Positive", "Negative")) + } } p } # Helper functions for .graph_edges() -.infer_directed_edge_mapping <- function(g, edge_color, edge_size, node_size) { - list("ecolor" = .infer_ecolor(g, edge_color), +.infer_directed_edge_mapping <- function(g, edge_color, edge_size, node_size, + layout = NULL, shared = NULL, + backbone = NULL) { + list("ecolor" = .infer_ecolor(g, edge_color, shared[["ecolor"]]), "esize" = .infer_esize(g, edge_size), "line_type" = .infer_line_type(g), - "end_cap" = .infer_end_cap(g, node_size)) + "ealpha" = .infer_ealpha(g, layout, backbone), + "end_cap" = .infer_end_cap(g, node_size, layout)) } -.infer_edge_mapping <- function(g, edge_color, edge_size) { - list("ecolor" = .infer_ecolor(g, edge_color), +.infer_edge_mapping <- function(g, edge_color, edge_size, layout = NULL, + shared = NULL, backbone = NULL) { + list("ecolor" = .infer_ecolor(g, edge_color, shared[["ecolor"]]), "esize" = .infer_esize(g, edge_size), - "line_type" = .infer_line_type(g)) + "line_type" = .infer_line_type(g), + "ealpha" = .infer_ealpha(g, layout, backbone)) } # .infer_ecolor/.infer_esize/.infer_arrow/.infer_line_type live in # R/graph_aes.R, shared with grapht(). These arguments have already been checked # against the network's attributes by graphr()/grapht() (see R/graph_checks.R). -.infer_end_cap <- function(g, node_size) { - nsize <- .infer_nsize(g, node_size)/2 +# A self-loop's `strength` is its diameter, measured in the same units as the +# layout's coordinates, and `geom_edge_loop0()` defaults it to 1. Since layouts +# differ by orders of magnitude in how far their coordinates spread, that one +# number draws a loop that is either invisible or, as for the "levels" +# layout whose coordinates span about one unit in each direction, a circle +# wider than the network it belongs to -- which then stretches the panel to +# fit, leaving the plot squeezed against its legend. Sized as a fraction of +# the layout instead, a loop reads as a loop whatever the layout. +# +# Note that `strength` is an aesthetic of the loop geoms rather than a layer +# parameter: passed as a parameter it is silently dropped ("Ignoring unknown +# parameters"), so it has to be mapped through `aes()`. +.infer_loop_strength <- function(p) { + spread <- max(diff(range(p[["data"]][["x"]], na.rm = TRUE)), + diff(range(p[["data"]][["y"]], na.rm = TRUE))) + # A network drawn at a single point has no spread to take a fraction of. + if (!is.finite(spread) || spread <= 0) return(1) + spread * 0.06 +} + +# A multilevel layout draws each level as a plane, and in an interlocking +# network the ties running between those planes typically outnumber the ties +# within them: `fict_marvel` has 683 against 558. Drawn at the same strength +# they curtain over both planes, so they are faded well back, and the ties +# within each level brought forward, so that the structure of each level and +# the shape of the interlock can both be seen. +# +# A backbone works the same way and is applied on top: a tie the filter does +# not keep is drawn at a fifth of whatever it would have been drawn at, which +# takes the usual 0.4 down to the same 0.08. A tie the filter keeps is left +# alone, so that a backbone changes what is faded rather than what is normal. +.infer_ealpha <- function(g, layout = NULL, backbone = NULL) { + out <- if (identical(layout, "levels") && manynet::is_twomode(g) && + manynet::net_ties(g) > 0) + ifelse(manynet::tie_is_twomode(g), 0.08, 0.5) else 0.4 + if (is.null(backbone)) return(out) + out * ifelse(backbone, 1, 0.2) +} + +.infer_end_cap <- function(g, node_size, layout = NULL) { + nsize <- .infer_nsize(g, node_size, layout)/2 # Accounts for rescaling if (length(unique(nsize)) == 1) { out <- rep(unique(nsize), manynet::net_ties(g)) @@ -85,22 +155,25 @@ graph_edges <- function(p, g, edge_color, edge_size, node_size, out } -# Route the three vectorisable edge aesthetics (colour, width, linetype) either -# through aes() -- when they vary across ties, so ggraph's edge stats expand and -# subset them alongside the geometry (point expansion in geom_edge_arc, loop -# removal, faceting) -- or as a constant layer parameter when they are a single -# value. Passing a per-tie vector as a constant parameter is what breaks signed -# multiplex/longitudinal networks: it recycles against the wrong length or feeds -# NA/malformed values straight to grid ("invalid hex digit in 'color' or 'lty'"). +# Route the four vectorisable edge aesthetics (colour, width, linetype, alpha) +# either through aes() -- when they vary across ties, so ggraph's edge stats +# expand and subset them alongside the geometry (point expansion in +# geom_edge_arc, loop removal, faceting) -- or as a constant layer parameter +# when they are a single value. Passing a per-tie vector as a constant parameter +# is what breaks signed multiplex/longitudinal networks: it recycles against the +# wrong length or feeds NA/malformed values straight to grid ("invalid hex digit +# in 'color' or 'lty'"). .split_edge_aes <- function(out) { # `mapping` holds unevaluated expressions (not the vectors themselves) so that # do.call(aes, mapping) captures them as quosures resolved lazily against # `out` in the caller's environment -- the same way the aesthetics were # written literally before -- rather than as pre-evaluated constants. - keys <- c(ecolor = "edge_colour", esize = "edge_width", line_type = "edge_linetype") + keys <- c(ecolor = "edge_colour", esize = "edge_width", + line_type = "edge_linetype", ealpha = "edge_alpha") exprs <- list(ecolor = quote(out[["ecolor"]]), esize = quote(out[["esize"]]), - line_type = quote(out[["line_type"]])) + line_type = quote(out[["line_type"]]), + ealpha = quote(out[["ealpha"]])) mapping <- list(); params <- list() for (nm in names(keys)) { if (length(out[[nm]]) > 1) mapping[[keys[[nm]]]] <- exprs[[nm]] @@ -109,26 +182,88 @@ graph_edges <- function(p, g, edge_color, edge_size, node_size, list(mapping = mapping, params = params) } +# A varying alpha is mapped through aes() as the literal values themselves, so +# an identity scale is needed to use them verbatim. They distinguish the levels +# of a multilevel layout, which the layout already makes plain, so no alpha +# legend is drawn. +.scale_edge_aes <- function(p, parts) { + if ("edge_alpha" %in% names(parts$mapping)) + p <- p + ggraph::scale_edge_alpha_identity() + p +} + .map_directed_edges <- function(p, g, out) { parts <- .split_edge_aes(out) parts$mapping$end_cap <- quote(ggraph::circle(c(out[["end_cap"]]), 'mm')) args <- c(list(mapping = do.call(ggplot2::aes, parts$mapping), - edge_alpha = 0.4, - strength = .infer_arc_strength(g), + strength = .infer_arc_strength(g, p), arrow = .infer_arrow(out[["esize"]])), parts$params) - p + do.call(ggraph::geom_edge_arc, args) + .scale_edge_aes(p + do.call(ggraph::geom_edge_arc, args), parts) } -.infer_arc_strength <- function(g) { +.infer_arc_strength <- function(g, p) { # `geom_edge_arc()` reciprocated dyads apart (0.2) and draws single ties - # straight (0). Its stat removes self-loops before drawing (loops are drawn - # separately by `geom_edge_loop0()`), but `strength` is a length-preserving - # parameter rather than an aesthetic, so it must exclude loop edges. Otherwise - # a full-length (net_ties) vector recycles against the loop-free edge set and - # emits "longer object length is not a multiple" warnings on complex networks. + # straight (0). Its stat removes every tie whose two ends sit at the same + # point before drawing, but `strength` is a length-preserving parameter + # rather than an aesthetic, so it must leave the same ties out. Otherwise a + # full-length (net_ties) vector recycles against the shorter edge set and + # emits "longer object length is not a multiple" warnings. strength <- ifelse(igraph::which_mutual(g), 0.2, 0) - strength[!igraph::which_loop(g)] + strength[!.tie_is_coincident(g, p)] +} + +# Which ties `ggraph:::remove_loop()` drops, tested the way it tests them: +# on the coordinates rather than on the network. That is every self-loop, which +# `geom_edge_loop0()` draws instead, and also every tie between two nodes that +# the layout placed at one point, as the "scaling" layout does where two nodes +# hold the same distances to every other node. +.tie_is_coincident <- function(g, p) { + el <- igraph::as_edgelist(manynet::as_igraph(g), names = FALSE) + xy <- p[["data"]] + out <- xy[["x"]][el[, 1]] == xy[["x"]][el[, 2]] & + xy[["y"]][el[, 1]] == xy[["y"]][el[, 2]] + # A node without coordinates is not a node drawn on top of another one, and + # `remove_loop()` keeps its ties too. + out[is.na(out)] <- FALSE + out +} + +# Whether any two ties join the same pair of nodes in the same way, so that a +# straight line or a single arc would draw one on top of the other. This is not +# `is_multiplex()`, which is TRUE for a network that only carries a non-reserved +# tie attribute (see `.has_layers()` in R/graph_aes.R), and it is not +# `which_mutual()`, which flags the two ties of a reciprocated dyad that +# `geom_edge_arc()` already draws apart. `which_multiple()` respects direction: +# it flags a repeated undirected pair, and a repeated directed pair, but not a +# reciprocated dyad. +.has_parallel_ties <- function(g) { + any(igraph::which_multiple(manynet::as_igraph(g))) +} + +# `geom_edge_fan()` groups the ties by the unordered node pair, gives each tie in +# a group its own side of the pair, and draws a group of one straight. Its +# `strength` is a scalar layer parameter, so the length-preserving problem that +# `.infer_arc_strength()` solves does not arise here: the fan stat drops the same +# ties (self-loops, and a tie whose two ends sit at one point) without a vector +# to keep in step with. +# +# The constant is calibrated against the arcs drawn for a reciprocated dyad. For +# a chord of length one, `geom_edge_arc(strength = 0.2)` bends 0.1159 away from +# the chord, and a two-tie fan at `strength = 1` bends 0.0625, so 1.85 draws two +# parallel ties about as far apart as two reciprocated ties. +.fan_strength <- function() 1.85 + +.map_fanned_edges <- function(p, g, out, directed = FALSE) { + parts <- .split_edge_aes(out) + args <- c(list(strength = .fan_strength()), parts$params) + if (directed) { + parts$mapping$end_cap <- quote(ggraph::circle(c(out[["end_cap"]]), 'mm')) + args$arrow <- .infer_arrow(out[["esize"]]) + } + if (length(parts$mapping)) + args$mapping <- do.call(ggplot2::aes, parts$mapping) + .scale_edge_aes(p + do.call(ggraph::geom_edge_fan, args), parts) } .infer_bundle_geom <- function(edge_bundle) { @@ -156,15 +291,21 @@ graph_edges <- function(p, g, edge_color, edge_size, node_size, # break points, so a per-tie linetype cannot be represented (the NAs reach # grid as invalid linetypes). Drop a varying linetype and draw bundles solid; # a linetype shared by every tie is already in `parts$params` and is kept. + # A per-tie alpha cannot survive that merging either, so bundles are drawn at + # the usual constant instead. parts$mapping[["edge_linetype"]] <- NULL - args <- c(list(edge_alpha = 0.4, arrow = arrow), parts$params) + if ("edge_alpha" %in% names(parts$mapping)) { + parts$mapping[["edge_alpha"]] <- NULL + parts$params[["edge_alpha"]] <- 0.4 + } + args <- c(list(arrow = arrow), parts$params) if (length(parts$mapping)) args$mapping <- do.call(ggplot2::aes, parts$mapping) p + do.call(bundle_geom, args) } .map_edges <- function(p, g, out) { parts <- .split_edge_aes(out) - args <- c(list(edge_alpha = 0.4), parts$params) + args <- parts$params if (length(parts$mapping)) args$mapping <- do.call(ggplot2::aes, parts$mapping) - p + do.call(ggraph::geom_edge_link0, args) + .scale_edge_aes(p + do.call(ggraph::geom_edge_link0, args), parts) } diff --git a/R/graph_labels.R b/R/graph_labels.R index d2cc6cd1..30453d8f 100644 --- a/R/graph_labels.R +++ b/R/graph_labels.R @@ -1,5 +1,22 @@ graph_labels <- function(p, g, layout, label_dist = NULL, label_repel = TRUE, - node_size = NULL) { + node_size = NULL, labels = TRUE) { + # Labelling every node of a dense network hides the network behind its own + # labels, so `labels` can also select which nodes to label. The selection is + # resolved once here and the chosen rows handed to the geoms as their `data`, + # rather than blanking the others' labels, so that no space is reserved for + # labels that are not drawn (and, with `label_repel`, nothing is repelled + # away from them either). + sel <- .infer_labels(g, labels) + if (!any(sel)) return(p) + # These layouts put every node in a place that means something: a layer, a + # ring, a rank. A repelled label leaves that place, and the reader has to + # work out which node it belongs to. Each label is offset by a fixed amount + # instead, so that where a label sits says which node it labels. + if (.is_structured(layout)) label_repel <- FALSE + ldata <- p[["data"]][sel, , drop = FALSE] + # `node_size` arrives with one value per node when it was mapped from an + # attribute, and has to be cut down to the labelled nodes alongside the data. + if (length(node_size) > 1) node_size <- node_size[sel] # `point.size` tells ggrepel the actual rendered diameter (in points) of # each node, so the repel algorithm keeps labels clear of the node's true # border rather than just its (x, y) centre -- ggrepel otherwise assumes a @@ -31,11 +48,11 @@ graph_labels <- function(p, g, layout, label_dist = NULL, label_repel = TRUE, is_radial <- is.character(layout) && length(layout) == 1L && layout %in% c("circle", "concentric") if (is_radial) { - angles <- as.data.frame(.cart2pol(as.matrix(p[["data"]][,1:2]))) + angles <- as.data.frame(.cart2pol(as.matrix(ldata[,1:2]))) angles$degree <- angles$phi * 180/pi # Extract x and y as vectors for case_when - x_coord <- p[["data"]][[1]] - y_coord <- p[["data"]][[2]] + x_coord <- ldata[[1]] + y_coord <- ldata[[2]] angles_deg <- dplyr::case_when(y_coord == 0 & x_coord == 0 ~ 0.1, y_coord >= 0 & x_coord > 0 ~ angles$degree, y_coord < 0 & x_coord > 0 ~ angles$degree, @@ -48,9 +65,9 @@ graph_labels <- function(p, g, layout, label_dist = NULL, label_repel = TRUE, } else { hj <- ifelse(x_coord >= 0, -0.2, 1.2) } - args <- list(mapping = label_aes, + args <- list(mapping = label_aes, data = ldata, repel = label_repel, - family = ag_font(), size = 3, hjust = hj, angle = angles_deg) + family = ag_font(), size = ag_text_size(3), hjust = hj, angle = angles_deg) if (label_repel) { args$point.padding <- padding } else { @@ -60,43 +77,85 @@ graph_labels <- function(p, g, layout, label_dist = NULL, label_repel = TRUE, } p <- p + do.call(ggraph::geom_node_text, args) + ggplot2::coord_cartesian(xlim=c(-1.3,1.3), ylim=c(-1.3,1.3)) - } else if (layout %in% c("bipartite", "railway") | layout == "hierarchy" & + } else if (layout %in% c("bipartite", "railway") | layout == "layered" & length(unique(p[["data"]][["y"]])) <= 2) { - args <- list(mapping = label_aes, + args <- list(mapping = label_aes, data = ldata, angle = 90, - family = ag_font(), size = 3, hjust = "outward", + family = ag_font(), size = ag_text_size(3), hjust = "outward", repel = label_repel, - nudge_y = ifelse(p[["data"]][,2] == 1, + nudge_y = ifelse(ldata[,2] == 1, nudge_unit, -nudge_unit)) if (label_repel) args$point.padding <- padding p <- p + do.call(ggraph::geom_node_text, args) + ggplot2::coord_cartesian(ylim=c(-0.2, 1.2)) - } else if (layout == "hierarchy" & length(unique(p[["data"]][["y"]])) > 2) { - args <- list(mapping = label_aes, - family = ag_font(), - size = 3, hjust = "inward", repel = label_repel) + } else if (layout == "layered" & length(unique(p[["data"]][["y"]])) > 2) { + # As for "lineage" below: the label goes immediately to the right of its + # own node, rather than anywhere the layers leave room. + args <- list(mapping = label_aes, data = ldata, + family = ag_font(), size = ag_text_size(3), + repel = label_repel, + hjust = 0, nudge_x = .axis_nudge(radius_pt + gap_pt, + p[["data"]][["x"]])) + if (label_repel) args$point.padding <- padding + p <- p + do.call(ggraph::geom_node_text, args) + + ggplot2::scale_x_continuous( + expand = ggplot2::expansion(mult = c(0.05, 0.25))) + } else if (layout == "levels") { + # `geom_node_label()`, used below, boxes each label in white, which at the + # density these networks tend to have would paper over the plot entirely. + # Plain text instead, nudged away from the plane the node sits in: down + # from the lower level and up from the upper, so that labels fall into the + # empty space beyond each plane rather than over the ties between them. + # Which plane a node sits in is a property of the whole layout, so the + # median is taken over every node, not just the labelled ones. + midline <- stats::median(p[["data"]][["y"]]) + y_coord <- ldata[["y"]] + args <- list(mapping = label_aes, data = ldata, + family = ag_font(), size = ag_text_size(2), colour = ag_ink(), + repel = label_repel, + nudge_y = ifelse(y_coord <= midline, + -nudge_unit, nudge_unit)) if (label_repel) { args$point.padding <- padding - } else { - args$nudge_y <- -nudge_unit + args$seed <- 1234 + # These layouts leave a lot of empty space above and below each plane + # for ggrepel to push labels into, far enough that which node a label + # belongs to stops being obvious. Pull each label back hard towards its + # own node, and let labels sit closer to each other so that there is + # less pushing to begin with. + args$force_pull <- 4 + args$box.padding <- 0.1 + # Wherever a label still ends up away from its node, draw a leader line + # to it however short the move, rather than only beyond ggrepel's + # default half a line of text. + args$min.segment.length <- 0 + args$segment.size <- 0.2 + args$segment.colour <- "grey70" } p <- p + do.call(ggraph::geom_node_text, args) - } else if (layout %in% c("alluvial", "lineage")) { - # `fill = "white"` matches ggrepel's own hardcoded label background + } else if (layout %in% c("lineage", "ladder")) { + # An opaque fill matches ggrepel's own hardcoded label background # (`GeomLabelRepel$default_aes$fill`); without it, plain `GeomLabel` # resolves fill via the active theme and renders fully transparent here, - # making labels invisible wherever they sit over a node. - args <- list(mapping = label_aes, - size = 3, fill = "white", + # making labels invisible wherever they sit over a node. The fill is the + # theme's own ground rather than white, so that a dark theme does not + # scatter white cards over its graph. + # The layers run left to right, so every label goes immediately to the + # right of its own node, where it reads as a name follows a thing named. + args <- list(mapping = label_aes, data = ldata, + size = ag_text_size(3), fill = ag_ground_fill(), colour = ag_ink(), family = ag_font(), repel = label_repel, - nudge_x = ifelse(p[["data"]][,1] == 1, - nudge_unit, -nudge_unit)) + hjust = 0, nudge_x = .axis_nudge(radius_pt + gap_pt, + p[["data"]][["x"]])) if (label_repel) args$point.padding <- padding - p <- p + do.call(ggraph::geom_node_label, args) + p <- p + do.call(ggraph::geom_node_label, args) + + # Room on the right for the labels of the last layer. + ggplot2::scale_x_continuous( + expand = ggplot2::expansion(mult = c(0.05, 0.25))) } else { - args <- list(mapping = label_aes, - family = ag_font(), fill = "white", - repel = label_repel, size = 3) + args <- list(mapping = label_aes, data = ldata, + family = ag_font(), fill = ag_ground_fill(), + colour = ag_ink(), repel = label_repel, size = ag_text_size(3)) if (label_repel) { args$point.padding <- padding args$seed <- 1234 @@ -109,6 +168,125 @@ graph_labels <- function(p, g, layout, label_dist = NULL, label_repel = TRUE, p } +# The layered family places each node in a layer, which is where a reader looks +# for it, so a label that moves is a label that misleads. `layout` may be a +# matrix of coordinates rather than a name, which would make the comparison +# error rather than simply not match. +.is_structured <- function(layout) { + is.character(layout) && length(layout) == 1L && + layout %in% c("layered", "lineage", "railway", "ladder") +} + +# A nudge given in points, as `label_dist` and the node sizes are, has to reach +# the geoms as a distance along an axis. The panel is not measured until the +# plot is drawn, so the conversion takes a nominal panel of 500pt, about a +# seven inch plot, and scales the offset with the span the axis covers. +.axis_nudge <- function(pt, values) { + span <- diff(range(values, na.rm = TRUE)) + if (!is.finite(span) || span == 0) span <- 1 + pt / 500 * span +} + +# Label selection ---- + +# Turns the value normalised by .check_labels() into one logical per node, in +# the network's node order, which is the order of ggraph's layout data. +.infer_labels <- function(g, labels) { + n <- as.numeric(manynet::net_nodes(g)) + if (isFALSE(labels)) return(rep(FALSE, n)) + if (isTRUE(labels)) return(rep(TRUE, n)) + if (is.character(labels)) return(manynet::node_names(g) %in% labels) + .select_labels(g, as.integer(labels), attr(labels, "criterion"), + automatic = isTRUE(attr(labels, "automatic"))) +} + +# Which nodes a measure singles out. `ranks` is a depth rather than a headcount: +# every node within the top `ranks` scores is labelled, so nodes tied at the cut +# are kept together instead of being separated arbitrarily. That is the rule +# netrics::node_is_max() applies, and for two-mode networks it applies it within +# each mode, so both modes are labelled rather than only the denser one. +.select_labels <- function(g, ranks, criterion, automatic = FALSE) { + n <- as.numeric(manynet::net_nodes(g)) + # Ranking nodes needs {netrics}, which is only suggested. thisRequires() asks + # to install it when interactive but does nothing otherwise, and labelling is + # too incidental to a plot to stop it: an automatic selection falls back to + # the random sample, which needs nothing, while a selection the user asked + # for by name says what is missing. + if (criterion != "random" && !.has_netrics()) { + if (!automatic) + manynet::snet_abort( + "The {.pkg netrics} package is needed to rank nodes by", + "{.val {criterion}}. Please install it from CRAN, or choose which", + "nodes to label directly, as in {.code labels = c(\"Alice\", \"Bob\")}", + "or {.code labels = \"random\"}.") + manynet::snet_info( + "Labelling a random selection of nodes, since the {.pkg netrics}", + "package is not installed to rank them by centrality.", + "Please install it from CRAN to label the most central nodes instead.") + criterion <- "random" + ranks <- min(10L, as.integer(n)) + } + if (criterion == "random") return(.sample_labels(g, ranks)) + # A mark rather than a ranking: label every node it flags, however many. + if (criterion == "cutpoints") return(as.logical(netrics::node_is_cutpoint(g))) + measure <- switch(criterion, + degree = netrics::node_by_degree(g, normalized = FALSE), + betweenness = netrics::node_by_betweenness(g)) + strata <- .label_strata(g) + if (is.null(strata)) + return(as.logical(netrics::node_is_max(measure, ranks = ranks))) + out <- rep(FALSE, n) + for (lvl in unique(strata)) { + at <- which(strata == lvl) + out[at] <- .top_ranks(as.numeric(measure)[at], ranks) + } + out +} + +# Its own function so that the fallback below can be tested with the package +# installed, which .libPaths() makes it awkward to arrange any other way. +.has_netrics <- function() requireNamespace("netrics", quietly = TRUE) + +# node_is_max()'s own rule for a single mode, reused so the two cannot drift. +.top_ranks <- function(x, ranks) { + x %in% x[order(x, decreasing = TRUE)[seq_len(min(ranks, length(x)))]] +} + +# netrics::node_is_max() splits two-mode networks by mode itself. Multilevel +# networks that are not two-mode record their levels in the `lvl` attribute +# instead (see layout_levels()), which it knows nothing about, so +# those are the only strata worth handling here. +.label_strata <- function(g) { + if (manynet::is_twomode(g)) return(NULL) + if (!"lvl" %in% igraph::vertex_attr_names(g)) return(NULL) + as.character(manynet::node_attribute(g, "lvl")) +} + +# A plot should look the same when drawn twice, so the sample is taken under a +# fixed seed and the session's RNG left as it was found -- the same reason a +# fixed `seed` is passed to ggrepel above. +.sample_labels <- function(g, size) { + n <- as.numeric(manynet::net_nodes(g)) + if (exists(".Random.seed", envir = globalenv(), inherits = FALSE)) { + old_seed <- get(".Random.seed", envir = globalenv(), inherits = FALSE) + on.exit(assign(".Random.seed", old_seed, envir = globalenv()), add = TRUE) + } + set.seed(1234) + strata <- .label_strata(g) + if (is.null(strata) && manynet::is_twomode(g)) + strata <- as.character(igraph::V(g)$type) + out <- rep(FALSE, n) + if (is.null(strata)) { + out[sample.int(n, min(size, n))] <- TRUE + } else { + for (lvl in unique(strata)) { + at <- which(strata == lvl) + out[at[sample.int(length(at), min(size, length(at)))]] <- TRUE + } + } + out +} + # Helper functions for .graph_labels() .cart2pol <- function(xyz){ diff --git a/R/graph_layout.R b/R/graph_layout.R index 20db8a5a..21254d6a 100644 --- a/R/graph_layout.R +++ b/R/graph_layout.R @@ -1,10 +1,33 @@ -graph_layout <- function(g, layout, labels, node_group, snap, ...) { +# The name of a drawn dimension. A layout that reports how much of the +# network's inertia the dimension holds says so here, since an axis is where +# a reader looks for the scale it is reading against. +.dim_label <- function(k, fit) { + base <- paste("Dimension", k) + share <- fit[["inertia"]][k] + if (is.null(share) || !is.finite(share)) return(base) + paste0(base, " (", round(share * 100), "% of inertia)") +} + +graph_layout <- function(g, layout, labels, node_group, snap, backbone = NULL, + ...) { name <- NULL dots <- list(...) if ("x" %in% names(dots) & "y" %in% names(dots)) { lo <- ggraph::create_layout(g, layout = "manual", x = dots[["x"]], y = dots[["y"]]) - } else lo <- suppressWarnings(ggraph::create_layout(g, layout, ...)) + } else { + args <- c(list(graph = g, layout = layout), dots) + # The backbone ties are given the length that draws them shortest, so that + # the groups they hold together are what the layout pulls apart. A layout + # that carries meaning in its coordinates, or that reads no tie lengths, is + # left as it is, and its ties are only faded. A length the user gave + # themselves is theirs. See `.backbone_layout_weights()`. + if (!is.null(backbone) && !"weights" %in% names(dots)) { + weights <- .backbone_layout_weights(g, layout, backbone) + if (!is.null(weights)) args[["weights"]] <- weights + } + lo <- suppressWarnings(do.call(ggraph::create_layout, args)) + } if ("graph" %in% names(attributes(lo))) { if (!setequal(names(as.data.frame(attr(lo, "graph"))), names(lo))) { for (n in setdiff(names(as.data.frame(attr(lo, "graph"))), names(lo))) { @@ -12,74 +35,62 @@ graph_layout <- function(g, layout, labels, node_group, snap, ...) { } } } - p <- ggraph::ggraph(lo) + ggplot2::theme_void() + p <- ggraph::ggraph(lo) + ag_theme_void() + # A graph has no use for axes, save where its coordinates can be read. The + # "scaling" layout draws distances that mean something, so it keeps its axes, + # and keeps them on one scale: a distance read off two axes of different + # scales is not the distance the layout placed there. + # The "correspondence" layout draws distances that can be read in the same + # way, and names the share of inertia each of its dimensions holds. + if (is.character(layout) && length(layout) == 1L && + layout %in% c("scaling", "correspondence")) { + fit <- attr(lo, "fit") + p <- p + ag_theme_minimal() + + ggplot2::labs(x = .dim_label(1, fit), y = .dim_label(2, fit)) + # ggraph has already set a coordinate system, and ggplot2 announces the + # replacement, which is not news to anyone here. + p <- suppressMessages(p + ggplot2::coord_fixed()) + } if (!is.null(node_group)) { # thisRequires("ggforce") + # A membership matrix repeats a node's coordinates once for each group it + # belongs to, so a node in several groups is inside several hulls and the + # hulls overlap. One long data frame draws them all: ggforce draws one hull + # for each level of the fill. + if (is.matrix(node_group)) { + idx <- which(node_group, arr.ind = TRUE) + hulls <- data.frame( + x = lo[["x"]][idx[, 1]], y = lo[["y"]][idx[, 1]], + node_group = factor(colnames(node_group)[idx[, 2]], + levels = colnames(node_group))) + ngroups <- ncol(node_group) + } else { + hulls <- lo + ngroups <- length(unique(p$data[[node_group]])) + } p <- p + ggforce::geom_mark_hull(ggplot2::aes(x, y, fill = node_group, - label = node_group), data = lo) + - ggplot2::scale_fill_manual(values = ag_qualitative(length(unique(p$data[[node_group]]))), + label = node_group), data = hulls) + + ggplot2::scale_fill_manual(values = ag_qualitative(ngroups), guide = ggplot2::guide_legend("Group")) } if(snap){ - # Layered layouts already encode meaning in their coordinates -- rank, - # mode, or generation along one axis -- which square-grid snapping would - # collapse. Skip snapping for those and keep the layout as computed. - layered_layouts <- c("hierarchy", "railway", "ladder", "alluvial", - "multilevel", "lineage", "layered") - is_layered <- is.character(layout) && length(layout) == 1L && - layout %in% layered_layouts - if (is_layered) { + # Some layouts already encode meaning in their coordinates -- a layer, a + # mode, a generation, or a date along one axis, a scaled distance along + # both -- which square-grid snapping would collapse. Skip snapping for + # those and keep the layout as computed. + if (.is_fixed_layout(layout)) { manynet::snet_info(paste0("Skipping snapping: the '", layout, - "' layout is layered, so its coordinates ", - "are kept as computed.")) + "' layout carries meaning in its coordinates, ", + "so they are kept as computed.")) } else { manynet::snet_info("Snapping layout coordinates to grid.") - if(grepl("lattice", manynet::net_name(g), ignore.case = TRUE)){ - - angles <- seq(0, pi/2, length.out = 180) - scores <- sapply(angles, function(a) { - lay2 <- .rotate_layout(lo, a) - .edge_angle_deviation(lay2, g) - }) - - best_angle <- angles[which.min(scores)] - rotated_coords <- .rotate_layout(lo, best_angle) - # Make sure that the coordinates, if rounded to integers, are still unique - p$data[,c("x","y")] <- round(rotated_coords[,c("x","y")]) - } else p$data[,c("x","y")] <- depth_first_recursive_search(p) + # Where the network repeats a structure -- a lattice, or anything else + # whose ties take a few steps over and over -- those steps map onto the + # axes and every node lands on its own grid point. Where it does not, each + # node moves to the nearest vacant point instead. + p$data[,c("x","y")] <- .snap_layout(p$data, g) } } - # Add background ---- - if(getOption("snet_background", default = "#FFFFFF")!="#FFFFFF") - p <- p + ggplot2::theme(panel.background = ggplot2::element_rect(fill = getOption("snet_background", - default = "#FFFFFF"))) p } - -# Helper functions ---- - -.rotate_layout <- function(layout, angle) { - rot <- matrix(c(cos(angle), -sin(angle), - sin(angle), cos(angle)), ncol = 2) - coords <- as.matrix(layout[, c("x", "y")]) - newcoords <- coords %*% rot - layout$x <- newcoords[,1] - layout$y <- newcoords[,2] - layout -} - -.edge_angle_deviation <- function(layout, graph) { - ed <- igraph::as_edgelist(graph) - dx <- layout$x[ed[,2]] - layout$x[ed[,1]] - dy <- layout$y[ed[,2]] - layout$y[ed[,1]] - ang <- atan2(dy, dx) - - # deviation from nearest multiple of 90° - dev <- abs((ang %% (pi/2)) - pi/4) - mean(dev) -} - - - - diff --git a/R/graph_legends.R b/R/graph_legends.R index 3b0c220b..8a7f1d06 100644 --- a/R/graph_legends.R +++ b/R/graph_legends.R @@ -2,6 +2,7 @@ graph_legends <- function(p, g, node_color = NULL, node_shape = NULL, node_size = NULL, edge_color = NULL, edge_size = NULL) { + .check_legend_size(g, node_color, node_shape, edge_color) p + ggplot2::guides(fill = ggplot2::guide_legend(order = 1, title = ifelse(is.null(node_color), @@ -16,14 +17,44 @@ graph_legends <- function(p, g, title = ifelse(is.null(node_size), "Size", node_size)), linetype = ggplot2::guide_legend(order = 5), - edge_colour = ggplot2::guide_legend(order = 6, - title = ifelse(is.null(edge_color), - ifelse(manynet::is_signed(g), "Sign", "Color"), - edge_color)), + # `.infer_ecolor_title()` decides this alongside the colours + # themselves in R/graph_aes.R, so that the two cannot + # disagree about what the colour is showing, as they did + # when this said "Sign" over colours that showed layers. + edge_colour = ggplot2::guide_legend( + order = 6, title = .infer_ecolor_title(g, edge_color)), edge_size = ggplot2::guide_legend(order = 7, title = ifelse(is.null(edge_size), ifelse(manynet::is_weighted(g), "Weight", "Size"), edge_size)), alpha = ggplot2::guide_legend(order = 99, override.aes = list( alpha = 0, size = 0, shape = NA ))) -} \ No newline at end of file +} + +# A legend is read by matching a key against a mark, and a reader cannot hold +# many keys in mind while doing it: colours in particular are not recalled +# reliably. Beyond about seven the legend stops helping, and on a small or +# projected figure it stops fitting. Said once for the whole plot, from the +# widest of the categorical mappings, rather than once for each of them. +.legend_max_keys <- 7L + +.check_legend_size <- function(g, node_color = NULL, node_shape = NULL, + edge_color = NULL){ + levels_of <- function(name, attrs, values){ + if(is.null(name) || length(name) != 1L || !is.character(name)) return(0L) + if(!name %in% attrs) return(0L) + vals <- values(g, name) + if(is.numeric(vals) && !is.factor(vals)) return(0L) + length(unique(vals[!is.na(vals)])) + } + n <- max( + levels_of(node_color, igraph::vertex_attr_names(g), manynet::node_attribute), + levels_of(node_shape, igraph::vertex_attr_names(g), manynet::node_attribute), + levels_of(edge_color, igraph::edge_attr_names(g), manynet::tie_attribute)) + if(n <= .legend_max_keys) return(invisible(NULL)) + manynet::snet_info( + "The legend will hold {n} keys, which is more than most readers can match", + "against the graph. Consider grouping the smaller categories together,", + "or showing them with {.arg node_group} instead.") + invisible(NULL) +} diff --git a/R/graph_nodes.R b/R/graph_nodes.R index 77c80916..473c115d 100644 --- a/R/graph_nodes.R +++ b/R/graph_nodes.R @@ -1,45 +1,59 @@ -graph_nodes <- function(p, g, node_color, node_shape, node_size) { - out <- .infer_node_mapping(g, node_color, node_size, node_shape) +graph_nodes <- function(p, g, node_color, node_shape, node_size, + layout = NULL, shared = NULL) { + out <- .infer_node_mapping(g, node_color, node_size, node_shape, layout, + shared) # A changing network is only treated as a diffusion when nodes actually # adopt; otherwise (e.g. `fict_potter`) it is rendered as a standard # changing network. TODO: revisit once diffusion is reworked in manynet. if(is.null(node_color) && manynet::is_changing(g) && any(is.finite(.node_adoption_time(g)))){ - p <- .map_diff_model_nodes(p, g, out) - } else if(is.null(node_color) && "diffusion" %in% names(manynet::node_attribute(g))){ - p <- .map_infected_nodes(p, g, out) + p <- .map_diff_model_nodes(p, g, out, shared) + } else if(is.null(node_color) && + "diffusion" %in% manynet::net_node_attributes(g)){ + p <- .map_infected_nodes(p, g, out, shared) } else { - p <- .map_nodes(p, out) + p <- .map_nodes(p, out, shared) # Check legends - if (length(unique(out[["nsize"]])) > 1) + if (length(unique(out[["nsize"]])) > 1 && !out[["nsize_default"]]) p <- p + ggplot2::guides(size = ggplot2::guide_legend(title = node_size)) if (length(unique(out[["nshape"]])) > 1) p <- p + ggplot2::guides(shape = ggplot2::guide_legend( title = ifelse(manynet::is_twomode(g) & is.null(node_shape), "Mode", node_shape))) - if (length(unique(out[["ncolor"]])) > 1){ - if(length(unique(out[["ncolor"]])) == 2){ - p <- p + ggplot2::scale_fill_manual(values = getOption("snet_highlight", - default = c("grey","black")), - guide = ggplot2::guide_legend(node_color)) - } else { - p <- p + ggplot2::scale_fill_manual(values = ag_qualitative(length(unique(out[["ncolor"]]))), - guide = ggplot2::guide_legend(node_color)) - } + # Named values, shared limits and `drop = FALSE` for the same reason as the + # edge colours in R/graph_edges.R: a category keeps its colour and its key + # in every panel of a `graphs()` plot. + nlevels <- shared[["ncolor"]] + if (is.null(nlevels)) nlevels <- unique(as.character(out[["ncolor"]])) + if (length(nlevels) > 1){ + nvalues <- if (length(nlevels) == 2) + getOption("snet_highlight", default = c("grey","black")) else + ag_qualitative(length(nlevels)) + p <- p + ggplot2::scale_fill_manual( + values = stats::setNames(nvalues, nlevels), limits = nlevels, + drop = FALSE, guide = ggplot2::guide_legend(node_color)) } } # Consider rescaling nodes p <- p + ggplot2::scale_size(range = c(1/manynet::net_nodes(g)*50, - 1/manynet::net_nodes(g)*100)) + 1/manynet::net_nodes(g)*100), + limits = shared[["nsize"]]) p } # Helper functions for .graph_nodes() -.infer_node_mapping <- function(g, node_color, node_size, node_shape) { - list("nshape" = .infer_nshape(g, node_shape), - "nsize" = .infer_nsize(g, node_size), - "ncolor" = .infer_ncolor(g, node_color)) +.infer_node_mapping <- function(g, node_color, node_size, node_shape, + layout = NULL, shared = NULL) { + list("nshape" = .infer_nshape(g, node_shape, shared[["nshape"]]), + "nsize" = .infer_nsize(g, node_size, layout), + # A size the user asked for is mapped through aes(), so that it is + # rescaled and given a legend naming the attribute it came from. A + # default size is not: it varies only with how crowded the plot is, + # which is not something to put in a legend, and rescaling it would + # undo the very sizing it was calculated to give. + "nsize_default" = is.null(node_size), + "ncolor" = .infer_ncolor(g, node_color, shared[["ncolor"]])) } # .infer_nsize/.infer_nshape/.infer_ncolor live in R/graph_aes.R, shared with @@ -47,27 +61,42 @@ graph_nodes <- function(p, g, node_color, node_shape, node_size) { # attributes by graphr()/grapht() (see R/graph_checks.R), so by this point they # are known to be either an attribute name or a usable literal. -.map_infected_nodes<- function(p, g, out) { +# The four states a diffusion puts a node in, named and ordered the same way +# wherever they are drawn. +.diffusion_levels <- c("Susceptible", "Exposed", "Infected", "Recovered") + +.recode_diffusion <- function(x) { + dplyr::recode_values(x, + "E" ~ "Exposed", + "I" ~ "Infected", + "R" ~ "Recovered", + "S" ~ "Susceptible") +} + +.map_infected_nodes<- function(p, g, out, shared = NULL) { # node_color <- as.factor(ifelse(manynet::node_attribute(g, "Exposed"), "Exposed", # ifelse(manynet::node_attribute(g, "Infected"),"Infected", # ifelse(manynet::node_attribute(g, "Recovered"), "Recovered", # "Susceptible")))) - node_color <- dplyr::recode_values(manynet::node_attribute(g, "diffusion"), - "E" ~ "Exposed", - "I" ~ "Infected", - "R" ~ "Recovered", - "S" ~ "Susceptible") + node_color <- .recode_diffusion(manynet::node_attribute(g, "diffusion")) cols <- match_color(c("#d73027", "#4575b4", "#E6AB02", "#66A61E")) + # A wave in which every node has been infected shows one state, and the wave + # beside it two, so without shared limits the two legends differ and only one + # of them is collected. Kept in the order the states are passed through. + limits <- shared[["diffusion"]] + if (!is.null(limits)) + limits <- .diffusion_levels[.diffusion_levels %in% limits] p + ggraph::geom_node_point(ggplot2::aes(fill = node_color), size = out[["nsize"]], shape = out[["nshape"]]) + ggplot2::scale_fill_manual(name = NULL, guide = ggplot2::guide_legend(""), + limits = limits, drop = FALSE, values = c("Infected" = cols[1], "Susceptible" = cols[2], "Exposed" = cols[3], "Recovered" = cols[4])) } -.map_diff_model_nodes <- function(p, g, out) { +.map_diff_model_nodes <- function(p, g, out, shared = NULL) { dm <- manynet::as_diffusion(g) node_adopts <- .node_adoption_time(g) nshape <- ifelse(node_adopts == min(node_adopts), "Seed(s)", @@ -75,13 +104,17 @@ graph_nodes <- function(p, g, node_color, node_shape, node_size) { node_color <- ifelse(is.infinite(node_adopts), max(node_adopts[!is.infinite(node_adopts)]) + 1, node_adopts) + # Read from every panel beside this one where there is one, so that a time of + # adoption is drawn in the same colour throughout. + span <- shared[["nadopt"]] + if (is.null(span)) span <- range(node_color[is.finite(node_color)]) + early <- span[1] + 1 + late <- if (any(nshape == "Non-Adopter")) span[2] - 1 else span[2] p + ggraph::geom_node_point(ggplot2::aes(shape = nshape, fill = node_color), size = out[["nsize"]]) + ggplot2::scale_fill_gradient(low = match_color("#d73027"), high = match_color("#4575b4"), - breaks=c(min(node_color)+1, - ifelse(any(nshape=="Non-Adopter"), - max(node_color)-1, - max(node_color))), + limits = range(c(span, node_color)), + breaks=c(early, late), labels=c("Early\nadoption", "Late\nadoption"), name = "Time of\nAdoption\n") + ggplot2::scale_shape_manual(name = "", @@ -93,56 +126,47 @@ graph_nodes <- function(p, g, node_color, node_shape, node_size) { shape = ggplot2::guide_legend(order = 2)) } -.map_nodes <- function(p, out) { - if (length(out[["ncolor"]]) == 1 & length(out[["nsize"]]) == 1 & - length(out[["nshape"]]) == 1) { - p <- p + ggraph::geom_node_point(fill = out[["ncolor"]], size = out[["nsize"]], - shape = out[["nshape"]]) - } else if (length(out[["ncolor"]]) > 1 & length(out[["nsize"]]) == 1 & - length(out[["nshape"]]) == 1) { - p <- p + ggraph::geom_node_point(ggplot2::aes(fill = out[["ncolor"]]), - size = out[["nsize"]], shape = out[["nshape"]]) - } else if (length(out[["ncolor"]]) == 1 & length(out[["nsize"]]) > 1 & - length(out[["nshape"]]) == 1) { - p <- p + ggraph::geom_node_point(ggplot2::aes(size = out[["nsize"]]), - fill = out[["ncolor"]], shape = out[["nshape"]]) - } else if (length(out[["ncolor"]]) == 1 & length(out[["nsize"]]) == 1 & - length(out[["nshape"]]) > 1) { - p <- p + ggraph::geom_node_point(ggplot2::aes(shape = out[["nshape"]]), - fill = out[["ncolor"]], size = out[["nsize"]]) - } else if (length(out[["ncolor"]]) > 1 & length(out[["nsize"]]) > 1 & - length(out[["nshape"]]) == 1) { - p <- p + ggraph::geom_node_point(ggplot2::aes(fill = out[["ncolor"]], - size = out[["nsize"]]), - shape = out[["nshape"]]) - } else if (length(out[["ncolor"]]) > 1 & length(out[["nsize"]]) == 1 & - length(out[["nshape"]]) > 1) { - p <- p + ggraph::geom_node_point(ggplot2::aes(fill = out[["ncolor"]], - shape = out[["nshape"]]), - size = out[["nsize"]]) - } else if (length(out[["ncolor"]]) == 1 & length(out[["nsize"]]) > 1 & - length(out[["nshape"]]) > 1) { - p <- p + ggraph::geom_node_point(ggplot2::aes(size = out[["nsize"]], - shape = out[["nshape"]]), - fill = out[["ncolor"]]) - } else { - p <- p + ggraph::geom_node_point(ggplot2::aes(fill = out[["ncolor"]], - shape = out[["nshape"]], - size = out[["nsize"]])) +# Each of the three node aesthetics is mapped through aes() when it varies +# across nodes, so that ggplot2 scales it and gives it a legend, and passed as +# a constant layer parameter when it does not. A default size is the exception: +# it varies with how crowded each part of the plot is rather than with anything +# about the nodes themselves, so it is passed as a parameter even when it +# varies, which also keeps it clear of the rescaling in graph_nodes(). +.map_nodes <- function(p, out, shared = NULL) { + # The expressions are quoted rather than evaluated so that + # do.call(aes, mapping) captures them as quosures resolved lazily against + # `out`, exactly as writing them literally here would. + keys <- c(ncolor = "fill", nshape = "shape", nsize = "size") + exprs <- list(ncolor = quote(out[["ncolor"]]), + nshape = quote(out[["nshape"]]), + nsize = quote(out[["nsize"]])) + mapping <- list(); params <- list() + for (nm in names(keys)) { + varies <- length(out[[nm]]) > 1 && + !(nm == "nsize" && isTRUE(out[["nsize_default"]])) + if (varies) mapping[[keys[[nm]]]] <- exprs[[nm]] else + params[[keys[[nm]]]] <- out[[nm]] } - p <- p + ggplot2::scale_shape_manual(values = c(21, 22, 24, 23, 25, - 3, 4, 8, - 10, 12, 9, - 13, 7, 11, 14)) - p + args <- params + if (length(mapping)) args$mapping <- do.call(ggplot2::aes, mapping) + # Naming the shapes by the categories they stand for, where `graphs()` has + # worked out what those are across its panels, stops a panel that is missing + # one of them from giving the rest each other's shapes. + shapes <- c(21, 22, 24, 23, 25, 3, 4, 8, 10, 12, 9, 13, 7, 11, 14) + slevels <- shared[["nshape"]] + if (!is.null(slevels) && length(slevels) <= length(shapes)) + shapes <- stats::setNames(shapes[seq_along(slevels)], slevels) + p + do.call(ggraph::geom_node_point, args) + + ggplot2::scale_shape_manual(values = shapes, limits = slevels, + drop = is.null(slevels)) } .node_adoption_time <- function(.data){ if(inherits(.data, "diff_model")){ net <- attr(.data, "network") - out <- summary(.data) %>% dplyr::filter(event == "I") %>% - dplyr::distinct(nodes, .keep_all = TRUE) %>% + out <- summary(.data) |> dplyr::filter(event == "I") |> + dplyr::distinct(nodes, .keep_all = TRUE) |> dplyr::select(nodes,t) if(!manynet::is_labelled(net)) out <- dplyr::arrange(out, nodes) else if (is.numeric(out$nodes)) @@ -158,8 +182,8 @@ graph_nodes <- function(p, g, node_color, node_shape, node_size) { } } else { net <- .data - out <- manynet::as_changelist(.data) %>% dplyr::filter(value == "I") %>% - dplyr::distinct(node, .keep_all = TRUE) %>% + out <- manynet::as_changelist(.data) |> dplyr::filter(value == "I") |> + dplyr::distinct(node, .keep_all = TRUE) |> dplyr::select(node,time) if(!manynet::is_labelled(net)) out <- dplyr::arrange(out, node) else if (is.numeric(out$node)) diff --git a/R/graph_snap.R b/R/graph_snap.R new file mode 100644 index 00000000..4caf2b34 --- /dev/null +++ b/R/graph_snap.R @@ -0,0 +1,321 @@ +# The grid-snapping step behind `graphr(snap = TRUE)`. +# +# Nothing here is a layout: these functions take the coordinates a layout has +# already produced and move them onto a square grid. Two routes lead there. +# `.snap_basis()` looks for a repeating structure in the tie vectors -- the two +# steps a lattice repeats -- and maps those two steps onto the axes, which puts +# every node on its own integer point. `depth_first_recursive_search()` handles +# every other network, by matching each node to the nearest vacant grid point. + +#' Layouts for snapping layouts to a grid +#' +#' @description The function uses approximate pattern matching +#' to redistribute coarse layouts on square grid points, while +#' preserving the topological relationships among the nodes (see Inoue et al. 2012). +#' @references +#' Inoue, Kentaro, Shinichi Shimozono, Hideaki Yoshida, and Hiroyuki Kurata. 2012. +#' “Application of Approximate Pattern Matching in Two Dimensional Spaces to Grid Layout for Biochemical Network Maps” edited by J. Bourdon. +#' _PLoS ONE_ 7(6):e37739. +#' \doi{https://doi.org/10.1371/journal.pone.0037739}. +#' @keywords internal +depth_first_recursive_search <- function(layout) { + if("ggraph" %in% class(layout)) layout <- layout$data[,c("x","y")] + layout <- as.data.frame(layout) + dims <- ceiling(2 * sqrt(nrow(layout))) + # evens <- 0:dims[0:dims %% 2 == 0] + vacant_points <- expand.grid(seq.int(0, dims, 1), seq.int(0, dims, 1)) # create options + vacant_points <- vacant_points - floor(dims / 2) # centre options + names(vacant_points) <- c("x", "y") + gridout <- layout[order(abs(layout[,1]) + abs(layout[,2])), ] # sort centroid distance + nodes <- seq_len(nrow(gridout)) + for (i in nodes) { + # Drop the first row (the node's distance to itself, always 0) before + # picking the nearest vacant point. Comparing against the undropped vector + # matched row 1 whenever a grid point coincided exactly with the node, + # giving mindist 0 and a zero-row vacpoint. Two-mode layouts hit this on the + # very first node, since their coordinates are exactly 0 or 1. + dists <- as.matrix(stats::dist(rbind(gridout[i, 1:2], vacant_points), + method = "manhattan"))[-1, 1] + mindist <- which.min(dists) + vacpoint <- vacant_points[mindist, ] + changes <- vacpoint - gridout[i, 1:2] + gridout[nodes >= i, 1] <- gridout[nodes >= i, 1] + + changes[[1]] + gridout[nodes >= i, 2] <- gridout[nodes >= i, 2] + + changes[[2]] + vacant_points <- vacant_points[-mindist, ] + } + gridout[order(as.integer(row.names(gridout))), ] # reorder from centroid + # gridout + # plot(gridout[order(row.names(gridout)),]) +} + +# Snapping ---- + +# The one entry point graph_layout() calls. It returns a two column data frame +# of integer coordinates, one row for each node, in the order the layout holds +# them. +.snap_layout <- function(layout, graph) { + out <- .snap_basis(layout, graph) + if (is.null(out)) { + coords <- as.data.frame(layout)[, c("x", "y")] + out <- depth_first_recursive_search(.snap_rotate(coords, graph)) + names(out) <- c("x", "y") + } + out +} + +# The tie vectors the layout draws: one row for each tie, holding the step from +# its first node to its second. Loops and ties whose ends coincide say nothing +# about direction, so they are dropped. `names = FALSE` keeps the ends as row +# numbers: a named network otherwise indexes the coordinates by name and gets +# NA for every tie. +.snap_edges <- function(layout, graph) { + ed <- igraph::as_edgelist(graph, names = FALSE) + if (is.null(ed) || nrow(ed) == 0L) return(NULL) + v <- cbind(layout$x[ed[,2]] - layout$x[ed[,1]], + layout$y[ed[,2]] - layout$y[ed[,1]]) + keep <- ed[,1] != ed[,2] & rowSums(v^2) > 1e-12 + if (sum(keep) < 2L) return(NULL) + list(ed = ed[keep, , drop = FALSE], v = v[keep, , drop = FALSE]) +} + +# A tie and the same tie read backwards run in one direction, not two, so every +# vector is folded into the upper half plane before directions are counted. +.snap_fold <- function(v) { + neg <- v[,1] < 0 | (abs(v[,1]) < 1e-9 & v[,2] < 0) + v[neg, ] <- -v[neg, , drop = FALSE] + v +} + +# The directions the ties repeat, largest group first. Each group returns one +# vector: its mean direction, at the length of its shorter ties, since a group +# holds one step of the lattice and, where the layout stretched it, some longer +# ones. +.snap_directions <- function(v, tol = pi/18) { + ang <- atan2(v[,2], v[,1]) %% pi + o <- order(ang) + ang <- ang[o] + v <- v[o, , drop = FALSE] + cl <- cumsum(c(TRUE, diff(ang) > tol)) + # The first and last groups sit either side of the fold, so they are one + # group where the gap across it is small enough. + if (max(cl) > 1L && (ang[1] + pi - ang[length(ang)]) < tol) cl[cl == max(cl)] <- 1L + ks <- as.integer(names(sort(table(cl), decreasing = TRUE))) + lapply(ks, function(k) { + vv <- v[cl == k, , drop = FALSE] + len <- sqrt(rowSums(vv^2)) + u <- colMeans(vv / len) + u <- u / sqrt(sum(u^2)) + list(v = u * unname(stats::quantile(len, 0.25)), + share = nrow(vv) / nrow(v)) + }) +} + +# The share of ties that the basis maps onto an integer step. +.snap_fit <- function(v, basis, tol = 0.2) { + tv <- v %*% t(solve(basis)) + mean(apply(abs(tv - round(tv)), 1, max) < tol) +} + +# A basis read off one group of ties carries that group's error, so a tie can +# map to 1.5 and round to 2, which opens a gap in the grid. Rounding each +# mapped tie to its integer step and refitting the basis on all of them by +# least squares closes the gap. Two or three rounds settle it. +.snap_refit <- function(basis, v, rounds = 10L) { + targ <- NULL + for (i in seq_len(rounds)) { + tv <- v %*% t(solve(basis)) + new <- round(tv) + if (!is.null(targ) && identical(new, targ)) break + targ <- new + keep <- rowSums(abs(targ)) > 0 & apply(abs(tv - targ), 1, max) < 0.45 + if (sum(keep) < 2L) break + cf <- stats::lsfit(targ[keep, , drop = FALSE], v[keep, , drop = FALSE], + intercept = FALSE)$coefficients + cand <- t(matrix(cf, nrow = 2L)) + if (any(!is.finite(cand)) || abs(det(cand)) < 1e-8) break + basis <- cand + } + basis +} + +# A basis can be read in eight ways: either vector first, each with either +# sign. They draw the same grid mirrored or turned, so the one that agrees most +# with the layout is the one to keep. A reader who runs graphr() and then +# graphr(snap = TRUE) then sees the same drawing, tidied. +.snap_orient <- function(basis, layout) { + co0 <- as.matrix(layout[, c("x", "y")]) + best <- NULL + for (swap in c(FALSE, TRUE)) for (s1 in c(1, -1)) for (s2 in c(1, -1)) { + cand <- basis[, if (swap) c(2L, 1L) else c(1L, 2L), drop = FALSE] + cand[,1] <- cand[,1] * s1 + cand[,2] <- cand[,2] * s2 + if (det(cand) <= 0) next # a reflection reads as a different drawing + score <- .snap_agree(co0, co0 %*% t(solve(cand))) + if (is.null(best) || score > best$score) best <- list(score = score, basis = cand) + } + if (is.null(best)) basis else best$basis +} + +.snap_agree <- function(a, b) { + score <- 0 + for (k in 1:2) { + if (stats::sd(a[,k]) > 0 && stats::sd(b[,k]) > 0) { + score <- score + stats::cor(a[,k], b[,k]) + } + } + score +} + +# Rounding a mapped layout bends a row where the layout stretched it, and can +# put two nodes on one point. This sweep repairs both. Each node first takes a +# free point, nearest to where rounding put it. Then, over and over, each node +# moves to the free point, within two units, that best matches its ties to the +# steps they should take. It stops when a sweep moves nothing. +.snap_repair <- function(points, ed, targ, sweeps = 20L, radius = 2L) { + n <- nrow(points) + inc_from <- split(seq_len(nrow(ed)), factor(ed[,1], levels = seq_len(n))) + inc_to <- split(seq_len(nrow(ed)), factor(ed[,2], levels = seq_len(n))) + taken <- new.env(hash = TRUE, parent = emptyenv()) + key <- function(p) paste(p[1], p[2], sep = ",") + holder <- function(p) mget(key(p), envir = taken, ifnotfound = list(NA))[[1]] + # One node to one point, starting from the middle outwards. + for (i in order(rowSums(abs(points)))) { + here <- points[i, ] + r <- 0L + while (!is.na(holder(here))) { + r <- r + 1L + ring <- .snap_ring(r) + free <- which(vapply(seq_len(nrow(ring)), function(k) + is.na(holder(points[i, ] + ring[k, ])), logical(1))) + if (length(free)) here <- points[i, ] + ring[free[1], ] + } + points[i, ] <- here + assign(key(here), i, envir = taken) + } + offsets <- as.matrix(expand.grid(dx = -radius:radius, dy = -radius:radius)) + offsets <- offsets[order(rowSums(abs(offsets))), , drop = FALSE] + cost <- function(i, p) { + out <- 0 + for (k in inc_from[[i]]) out <- out + sum((points[ed[k,2], ] - p - targ[k, ])^2) + for (k in inc_to[[i]]) out <- out + sum((p - points[ed[k,1], ] - targ[k, ])^2) + out + } + for (s in seq_len(sweeps)) { + moved <- FALSE + for (i in seq_len(n)) { + here <- points[i, ] + best <- here + bestcost <- cost(i, here) + for (r in seq_len(nrow(offsets))) { + cand <- here + offsets[r, ] + held <- holder(cand) + if (!is.na(held) && held != i) next + candcost <- cost(i, cand) + if (candcost < bestcost - 1e-9) { + bestcost <- candcost + best <- cand + } + } + if (any(best != here)) { + rm(list = key(here), envir = taken) + assign(key(best), i, envir = taken) + points[i, ] <- best + moved <- TRUE + } + } + if (!moved) break + } + points +} + +# How far a set of coordinates sits, as a whole, from the whole steps of the +# grid. Reading the coordinates as angles and taking their mean direction gives +# the shift that brings them nearest. +.snap_offset <- function(u) { + a <- mean(exp(complex(imaginary = 2 * pi * u))) + if (abs(a) < 1e-9) return(0) + Arg(a) / (2 * pi) +} + +# The points exactly r steps away, nearest first. +.snap_ring <- function(r) { + grid <- as.matrix(expand.grid(dx = -r:r, dy = -r:r)) + ring <- grid[abs(grid[,1]) == r | abs(grid[,2]) == r, , drop = FALSE] + ring[order(rowSums(ring^2)), , drop = FALSE] +} + +# Snap by mapping the two steps the network repeats onto the axes. This draws a +# square lattice as a square grid, and a triangular lattice as a square grid +# with its third family of ties running diagonally. Returns NULL where the +# layout holds no such repeating structure, which leaves the network to +# depth_first_recursive_search(). +.snap_basis <- function(layout, graph, threshold = 0.95, share = 0.2) { + e <- .snap_edges(layout, graph) + if (is.null(e)) return(NULL) + # A structure repeats itself only where there are more ties than nodes. A + # ring, or a tree, has about as many ties as nodes and no repeating steps, + # however well two directions happen to fit it. + if (nrow(e$ed) < 1.2 * nrow(layout)) return(NULL) + folded <- .snap_fold(e$v) + dirs <- .snap_directions(folded) + if (length(dirs) < 2L) return(NULL) + best <- NULL + for (i in seq_len(length(dirs) - 1L)) for (j in seq(i + 1L, length(dirs))) { + # A direction that only a few ties take says little about the structure, + # and two of them can fit any layout by accident. + if (min(dirs[[i]]$share, dirs[[j]]$share) < share) next + basis <- cbind(dirs[[i]]$v, dirs[[j]]$v) + if (abs(det(basis)) < 1e-8) next + basis <- .snap_refit(basis, folded) + fit <- .snap_fit(folded, basis) + if (is.null(best) || fit > best$fit) best <- list(fit = fit, basis = basis) + } + if (is.null(best) || best$fit < threshold) return(NULL) + basis <- .snap_orient(best$basis, layout) + co <- as.matrix(layout[, c("x", "y")]) %*% t(solve(basis)) + co <- co - matrix(colMeans(co), nrow(co), 2L, byrow = TRUE) + # Centring can leave a whole column of nodes at half a step, where rounding + # sends one node up and its neighbour down and breaks the column. Sliding + # each axis to where the nodes sit nearest to whole steps avoids that. + for (k in 1:2) co[, k] <- co[, k] - .snap_offset(co[, k]) + targ <- round(co[e$ed[,2], , drop = FALSE] - co[e$ed[,1], , drop = FALSE]) + points <- .snap_repair(round(co), e$ed, targ) + out <- as.data.frame(points) + names(out) <- c("x", "y") + rownames(out) <- NULL + out +} + +# Helper functions ---- + +.rotate_layout <- function(layout, angle) { + rot <- matrix(c(cos(angle), -sin(angle), + sin(angle), cos(angle)), ncol = 2) + coords <- as.matrix(layout[, c("x", "y")]) + newcoords <- coords %*% rot + layout$x <- newcoords[,1] + layout$y <- newcoords[,2] + layout +} + +# How far the ties sit, on average, from the nearest cardinal direction. A +# layout whose ties run up and down and across scores 0, and one whose ties all +# run at 45 degrees scores pi/4. +.edge_angle_deviation <- function(layout, graph) { + e <- .snap_edges(layout, graph) + if (is.null(e)) return(0) + ang <- atan2(e$v[,2], e$v[,1]) %% (pi/2) + mean(pmin(ang, pi/2 - ang)) +} + +# Turn the layout to the angle at which its ties run most nearly up and down +# and across, which is the angle at which a square grid loses least. +.snap_rotate <- function(layout, graph) { + angles <- seq(0, pi/2, length.out = 181) + scores <- vapply(angles, function(a) { + .edge_angle_deviation(.rotate_layout(layout, a), graph) + }, numeric(1)) + .rotate_layout(layout, angles[which.min(scores)]) +} diff --git a/R/graphr.R b/R/graphr.R index 2dc45276..d9e2466b 100644 --- a/R/graphr.R +++ b/R/graphr.R @@ -27,30 +27,77 @@ #' @family mapping #' @param .data A manynet-consistent object. #' @param layout An igraph, ggraph, or manynet layout algorithm. -#' If not declared, defaults to "triad" for networks with 3 nodes, -#' "quad" for networks with 4 nodes, -#' "stress" for all other one mode networks, -#' or "hierarchy" for two mode networks. -#' For "hierarchy" layout, one can further split graph by +#' If not declared, defaults to "configuration" for networks of up to +#' six nodes, "levels" for connected multilevel networks, +#' "layered" for other two mode networks, +#' and "stress" for all other networks. +#' For "layered" layout, one can further split graph by #' declaring the "center" argument as the "events", "actors", #' or by declaring a node name. #' For "concentric" layout algorithm please declare the "membership" as an #' extra argument. #' The "membership" argument expects either a quoted node attribute present #' in data or vector with the same length as nodes to draw concentric circles. -#' For "multilevel" layout algorithm please declare the "level" +#' For "levels" layout algorithm one may declare the "level" #' as extra argument. #' The "level" argument expects either a quoted node attribute present #' in data or vector with the same length as nodes to hierarchically #' order categories. -#' If "level" is missing, function will look for 'lvl' node attribute in data. -#' The "lineage" layout ranks nodes in Y axis according to values. -#' For "lineage" layout algorithm please declare the "rank" -#' as extra argument. -#' The "rank" argument expects either a quoted node attribute present -#' in data or vector with the same length as nodes. -#' @param labels Logical, whether to print node names -#' as labels if present. +#' If "level" is missing, the levels are taken from a 'lvl' node attribute +#' where there is one, or else from the two modes of a two mode network. +#' The layered layouts ("layered", "lineage", "railway" and "ladder") +#' accept a "ranks" argument, which takes either one of the methods named +#' at `?layout_layered` or a numeric node attribute to lay the layers out by, +#' as a quoted attribute name or a vector with one value for each node. +#' The "scaling" layout places the nodes by multidimensional scaling, +#' so that the distance between two nodes approximates the number of steps +#' between them. Since those coordinates can be read, this layout is drawn +#' with labelled axes on one scale, and captioned with how well two +#' dimensions hold the distances; see `?layout_scaling` and `check_stress()`. +#' Note that those axes carry distances rather than named dimensions: +#' the drawing can be turned or mirrored without fitting the network +#' any better or any worse. +#' The "correspondence" layout places the nodes by correspondence analysis, +#' so that two nodes with similar ties are drawn together, +#' whether or not they are tied to each other. +#' It is the usual way to draw a two mode network, since it places both +#' modes against the same pair of axes, and it accepts a "direction" +#' argument for a directed network and a "double" argument for a signed +#' one; see `?layout_correspondence`. +#' Each axis names the share of the network's inertia that it holds. +#' @param labels Which nodes to label, if the network is labelled. +#' `TRUE` (the default) labels every node and `FALSE` none of them, +#' but a label for every node of a large network hides the network behind +#' them, so a *selection* of the nodes can be given instead: +#' +#' - a number, e.g. `labels = 5`, labels the nodes within the top five ranks +#' by degree. Note that this is a depth of ranks rather than a count of +#' nodes: nodes tied at the cut are labelled together, so more than five +#' labels may appear. +#' - a measure to rank by, e.g. `labels = "betweenness"`, labels just the +#' node or nodes that measure singles out. `"degree"`, `"betweenness"`, +#' `"cutpoints"` (every node the mark flags) and `"random"` +#' (a small random sample) are available. +#' The two can be combined by naming the number, +#' as in `labels = c(betweenness = 5)`. +#' - the name of a logical node attribute, e.g. `labels = "is_broker"`, +#' labels the nodes it marks. +#' - a logical vector, one value per node, e.g. +#' `labels = netrics::node_is_cutpoint(net)`; +#' or the names or positions of the nodes to label, +#' e.g. `labels = c("Alice", "Betty")`. +#' +#' Where a length-one string could mean more than one of these, +#' a node attribute is preferred to a measure, and a measure to a node name. +#' A single number is always read as a depth of ranks rather than as one +#' node's position, so a lone node is best named, as in `labels = "Alice"`. +#' For networks of more than 30 nodes, `labels` defaults to a selection +#' rather than to every node; pass `labels = TRUE` for all of them. +#' Ranking nodes uses the `{netrics}` package, which is suggested rather than +#' required: without it installed, an automatic selection falls back to a +#' random sample. +#' Two-mode and multilevel networks are ranked within each mode or level, +#' so that every level is labelled and not just the densest. #' @param node_shape Node variable to be used for shaping the nodes. #' It is easiest if this is added as a node attribute to #' the graph before plotting. @@ -71,6 +118,15 @@ #' Group variables should have a minimum of 3 nodes, #' if less, number groups will be reduced by #' merging categories with lower counts into one called "other". +#' A membership vector can also be given here. +#' Where nodes belong to several groups at once, as they can to several +#' cliques, give a membership matrix instead: one row for each node, +#' one column for each group, and a one wherever the node belongs to +#' the group. One hull is then drawn for each column, and the hulls +#' overlap where the groups do. +#' A measure that returns such a matrix, such as +#' `netrics::node_x_clique()`, can be named without its network, +#' which is taken to be the network being drawn. #' @param edge_color,edge_colour Tie variable to be used for coloring the nodes. #' It is easiest if this is added as an edge or tie attribute #' to the graph before plotting. @@ -99,14 +155,23 @@ #' Only used when `labels = TRUE` and `label_repel = TRUE` #' (as the padding passed to the repel algorithm) or `label_repel = FALSE` #' (as a fixed nudge away from the node, in the layouts where this makes -#' sense, e.g. "circle"/"concentric", "bipartite"/"railway", "alluvial"). +#' sense, e.g. "circle"/"concentric", "railway", "lineage"). #' @param label_repel Logical scalar, whether labels should be repelled away #' from each other and from nodes using `ggrepel` #' (via `ggraph`'s `repel` argument). Defaults to `TRUE`. #' Set to `FALSE` to place labels at a fixed offset (see `label_dist`) #' without the (sometimes slow, and non-deterministic between runs for #' some layouts) repelling algorithm. +#' The layered layouts ("layered", "lineage", "railway" and "ladder") +#' place each node in a layer, which is where the reader looks for it, +#' so a repelled label there would say less about which node it labels +#' than a fixed offset does. They ignore this argument and always offset. #' @param snap Logical scalar, whether the layout should be snapped to a grid. +#' Where the network repeats a structure, as a lattice does, the two steps it +#' repeats are mapped onto the axes, which draws it as a rectangle of rows and +#' columns. Where it does not, each node moves to the nearest vacant grid +#' point. Layouts that already carry meaning in their coordinates, such as +#' "layered" or "scaling", are left as they are. #' @param edge_bundle Edge bundling, off by default (`FALSE`). When `TRUE` (or #' equivalently `"force"`), edges are bundled together using ggraph's #' force-directed edge bundling (`geom_edge_bundle_force()`), which pulls @@ -117,6 +182,31 @@ #' when a network has enough edges; for directed networks arrowheads are #' retained, but the slight reciprocal-tie curvature used for unbundled edges #' does not apply. +#' @param backbone How to treat the network's backbone: the ties that a local +#' null model keeps, because they carry more weight, or sit in more +#' triangles, than chance alone would put there. +#' Where a backbone is used, those ties are drawn as the shortest, so that +#' the layout pulls apart the groups they hold together, and every tie is +#' still drawn, with the ties the filter does not keep faded well back. +#' This is what to reach for when a network is dense enough to draw as a +#' hairball. +#' By default (`NULL`) this is decided by the network: a network of at least +#' 50 nodes and a mean degree of at least 8 is drawn this way, and reported. +#' `FALSE` draws every tie alike, and `TRUE` asks for a backbone whatever the +#' network's size. +#' One of `manynet`'s filters can be named instead: "disparity", "lans", +#' "noise", "mlf", or "simmelian". Where none is named, `manynet` uses "lans" +#' for a weighted network and "simmelian" for an unweighted one. +#' A number between 0 and 1 sets the threshold instead of the filter: +#' a smaller number keeps fewer ties. +#' Only the layouts that read tie lengths -- "stress" (the default), "fr", +#' "drl" and "kk" -- are laid out this way. Every other layout, including +#' those that already carry meaning in their coordinates such as "layered" +#' or "scaling", keeps its coordinates and only fades its ties. +#' Requires `manynet` 2.3.0 or later, and does not apply to signed networks. +#' @param .shared Internal. A list of the aesthetic ranges and categories found +#' across a list of networks, which `graphs()` uses to draw and label each of +#' its panels against the same scales. Not intended to be set by hand. #' @param ... Extra arguments to pass on to the layout algorithm, if necessary. #' @return A `ggplot2::ggplot()` object. #' The last plot can be saved to the file system using `ggplot2::ggsave()`. @@ -127,22 +217,28 @@ #' @importFrom ggplot2 aes arrow unit scale_color_brewer scale_fill_brewer #' @examples #' graphr(ison_adolescents) -#' ison_adolescents %>% +#' ison_adolescents |> #' mutate(color = rep(c("introvert","extrovert"), times = 4), -#' size = ifelse(netrics::node_is_cutpoint(ison_adolescents), 6, 3)) %>% -#' mutate_ties(ecolor = rep(c("friends", "acquaintances"), times = 5)) %>% +#' size = ifelse(netrics::node_is_cutpoint(ison_adolescents), 6, 3)) |> +#' mutate_ties(ecolor = rep(c("friends", "acquaintances"), times = 5)) |> #' graphr(node_color = "color", node_size = "size", #' edge_size = 1.5, edge_color = "ecolor") #' graphr(ison_southern_women, labels = TRUE, label_dist = 10) #' graphr(ison_southern_women, labels = TRUE, label_repel = FALSE) +#' # Label a selection of the nodes rather than all of them +#' graphr(ison_southern_women, labels = 2) +#' graphr(ison_southern_women, labels = "betweenness") +#' graphr(ison_adolescents, labels = c("Alice", "Betty")) #' graphr(manynet::generate_random(40, 0.1), edge_bundle = TRUE) +#' graphr(manynet::generate_random(80, 0.2), backbone = TRUE) #' @export graphr <- function(.data, layout = NULL, labels = TRUE, node_color, node_shape, node_size, node_group, edge_color, edge_size, isolates = c("legend","caption","keep"), snap = FALSE, label_dist = NULL, label_repel = TRUE, edge_bundle = FALSE, - ..., node_colour, edge_colour) { + backbone = NULL, .shared = NULL, ..., + node_colour, edge_colour) { # A list of networks is handed to graphs(). The call is forwarded as written, # rather than argument by argument, because the aesthetic arguments have no # defaults: naming them here would force promises that are still missing. @@ -155,7 +251,12 @@ graphr <- function(.data, layout = NULL, labels = TRUE, names(cl)[names(cl) == ".data"] <- "netlist" return(eval(cl, parent.frame())) } + labels_missing <- missing(labels) g <- .check_network(.data) + # Checked here, before isolates are dropped below, so that a vector selecting + # which nodes to label is measured against the network as the user gave it. + # It comes back as node names, which survive that change of node positions. + labels <- .check_labels(g, labels) # Separate isolates ---- # `isolates` is checked on its own line rather than inside .infer_isolates(), @@ -170,10 +271,27 @@ graphr <- function(.data, layout = NULL, labels = TRUE, } else { isos <- which(.node_is_isolate(g)) } - g <- manynet::to_no_isolates(g) - } - + g <- .ag_delete_isolates(g) + } + # A label for every node of a large network hides the network behind them, + # so unless labelling was asked for outright, fall back to labelling the + # nodes that stand out. Decided here rather than above so that the count + # reflects the nodes actually drawn, once any isolates have been dropped. + n <- as.numeric(manynet::net_nodes(g)) + if (labels_missing && isTRUE(labels) && n > 30) { + labels <- structure(5L, criterion = "degree", automatic = TRUE) + n_lab <- sum(.infer_labels(g, labels)) + manynet::snet_info( + "Labelling the {n_lab} most central of {n} nodes.", + "Use {.code labels = TRUE} to label all of them,", + "{.code labels = 25} to label more, or {.code labels = FALSE} for none.") + } + layout <- .infer_layout(g, .check_layout(layout)) + # Substituted here rather than in graph_layout(), since `layout` is also + # passed to graph_edges(), graph_nodes() and graph_labels(), which would + # otherwise style the plot for a layout that was not the one drawn. + layout <- .check_layout_applies(g, layout, ...) if (missing(node_color) && missing(node_colour)) { node_color <- NULL } else if (missing(node_color)) { @@ -188,9 +306,19 @@ graphr <- function(.data, layout = NULL, labels = TRUE, node_size <- .check_node_size(g, as.character(substitute(node_size))) } if (missing(node_group)) node_group <- NULL else { - node_group <- .check_node_group(g, as.character(substitute(node_group))) - g <- manynet::mutate_nodes(g, - node_group = .reduce_categories(g, node_group)) + node_group <- .infer_node_group(g, substitute(node_group), parent.frame()) + if (!is.matrix(node_group)) { + if (is.character(node_group) && length(node_group) == 1L) { + node_group <- .check_node_group(g, node_group) + } else { + # A membership vector is held on the network, so that it is treated as + # any other node attribute from here on. + g <- manynet::mutate_nodes(g, .group = node_group) + node_group <- ".group" + } + g <- manynet::mutate_nodes(g, + node_group = .reduce_categories(g, node_group)) + } } if (missing(edge_color) && missing(edge_colour)) { edge_color <- NULL @@ -203,18 +331,34 @@ graphr <- function(.data, layout = NULL, labels = TRUE, if (missing(edge_size)) edge_size <- NULL else if (!is.numeric(edge_size)) { edge_size <- .check_edge_size(g, as.character(substitute(edge_size))) } + # Find the backbone ---- + # After the layout is settled, since a layout that carries meaning in its + # coordinates keeps them and fades its ties only, and after the isolates are + # dropped, so that the filter reads the network that is drawn. + backbone <- .infer_backbone(g, .check_backbone(backbone), layout, edge_bundle, + manual = all(c("x", "y") %in% names(list(...)))) # Add layout ---- - p <- graph_layout(g, layout, labels, node_group, snap, ...) + p <- graph_layout(g, layout, labels, node_group, snap, backbone, ...) + # Read where the layout left it, since the later steps have no use for it + # and no reason to carry it. See `layout_scaling()`. + fit <- attr(p[["data"]], "fit") # Add edges ---- - p <- graph_edges(p, g, edge_color, edge_size, node_size, edge_bundle) + p <- graph_edges(p, g, edge_color, edge_size, node_size, edge_bundle, layout, + .shared, backbone) # Add nodes ---- - p <- graph_nodes(p, g, node_color, node_shape, node_size) + p <- graph_nodes(p, g, node_color, node_shape, node_size, layout, .shared) # Add labels ---- - if (isTRUE(labels) & manynet::is_labelled(g)) { + if (!isFALSE(labels) && manynet::is_labelled(g)) { p <- graph_labels(p, g, layout, label_dist, label_repel, - node_size = .infer_nsize(g, node_size)) + node_size = .infer_nsize(g, node_size, layout), + labels = labels) } + # Give the edge nodes room ---- + # After the labels, since a layered or lineage layout sets its own expansion + # there and this widens that rather than replacing it. + p <- .pad_for_nodes(p, .infer_nsize(g, node_size, layout)) + # Note isolates ---- if(isolates == "legend"){ if (length(isos) > 3) label_text <- paste(c(utils::head(isos, 3),"..."), collapse = "\n") else @@ -226,8 +370,14 @@ graphr <- function(.data, layout = NULL, labels = TRUE, values = c("Isolates" = 0.5), labels = label_text) } else if(isolates == "caption"){ - p <- p + ggplot2::labs(caption = paste("Isolates:", paste(isos, collapse = ", "))) + p <- .add_caption(p, paste("Isolates:", paste(isos, collapse = ", "))) } + + # Note the fit ---- + # A scaled layout draws distances that can be read, so how well two + # dimensions hold those distances is part of the drawing rather than an + # aside. See `check_stress()` for how to read the score. + p <- .note_fit(p, fit) # Add legends ---- p <- graph_legends(p, g, @@ -238,6 +388,81 @@ graphr <- function(.data, layout = NULL, labels = TRUE, p } +# A scaled layout draws distances that can be read, so how well two dimensions +# hold what the layout scaled is part of the drawing rather than an aside. +# Each layout that reports a fit says so in its own terms. See +# `layout_scaling()` and `layout_correspondence()`. +.note_fit <- function(p, fit) { + if (is.null(fit)) return(p) + switch(fit[["type"]] %||% "scaling", + scaling = .note_scaling_fit(p, fit), + correspondence = .note_corresp_fit(p, fit), + p) +} + +.note_scaling_fit <- function(p, fit) { + if (!is.finite(fit[["stress"]])) return(p) + txt <- paste0("Stress: ", round(fit[["stress"]] * 100), "%.") + if (!is.na(fit[["variance"]])) txt <- paste0( + txt, " Two dimensions hold ", round(fit[["variance"]] * 100), + "% of the distance variance.") + p <- .add_caption(p, txt) + # Kruskal read a stress of 20% as poor, but that figure was set for + # psychometric data: most pairs of nodes in a network sit two or three + # steps apart, which no plane holds well, so most networks would be + # reported on at 20% and the message would say nothing. + if (fit[["stress"]] > 0.3) manynet::snet_info( + "Two dimensions hold these path distances poorly", + "(stress: {round(fit[['stress']] * 100)}%),", + "so read the clusters rather than the distances.", + "See {.fn check_stress}.") + p +} + +# The share of inertia each dimension holds is already named on its axis, so +# nothing is added to the caption here. What the axes cannot say is which +# nodes those two dimensions place badly, and those are exactly the nodes a +# reader would otherwise read too much into. +.note_corresp_fit <- function(p, fit) { + .note_corresp_inertia(fit) + .note_corresp_cos2(fit) + p +} + +# The axes name the share of inertia, but a share means nothing without the +# number of dimensions it was won from, and an axis has no room for that. Two +# dimensions of a small table hold a good deal whatever the network, so the +# share is checked against what the same two dimensions would hold if the +# inertia were divided at random. See `.broken_stick()`. +.note_corresp_inertia <- function(fit) { + drawn <- sum(fit[["inertia"]]) + k <- length(fit[["scree"]]) + if (!is.finite(drawn) || k < 3L) return(invisible(NULL)) + if (drawn > .broken_stick(k)) return(invisible(NULL)) + manynet::snet_info( + "These two dimensions hold no more of the inertia than dividing it at", + "random would give them ({round(drawn * 100)}% of {k} dimensions),", + "so read the clusters rather than the positions.") +} + +# The broken stick model: the share the first two of `k` dimensions would hold +# if the inertia were broken at random into `k` pieces. A far harder baseline +# than an even share, since inertia is never spread evenly, and the one worth +# warning against (Jackson 1993, \doi{10.2307/1939574}). +.broken_stick <- function(k) sum(vapply(1:2, function(i) mean(1 / (i:k)), 1)) + +.note_corresp_cos2 <- function(fit) { + cos2 <- fit[["cos2"]] + poor <- names(cos2)[!is.na(cos2) & cos2 < 0.3] + # Only where more than one node is placed badly: a single one is as likely + # to be a node with few ties as a sign that the drawing is not to be read. + if (length(poor) < 2L) return(invisible(NULL)) + shown <- if (length(poor) > 5) c(utils::head(poor, 5), "...") else poor + manynet::snet_info( + "{length(poor)} nodes sit far off the plane drawn", + "({.val {shown}}), so read their positions with care.") +} + # Helper functions for graphr() ---- .node_is_isolate <- function(g) { if (manynet::is_directed(g)) { @@ -264,13 +489,115 @@ graphr <- function(.data, layout = NULL, labels = TRUE, g <- g[[1]] if (manynet::net_nodes(g) <= 6) { layout <- "configuration" + } else if (.ag_is_multilevel(g) && manynet::is_connected(g)) { + # Checked before `is_twomode()`, which is also TRUE for these networks. + # A "layered" layout would place each level along a single row, which + # collapses the within-level ties that make the network multilevel. + # Only where the network is connected, since the levels layout + # orients its levels by the distances between them and so cannot place + # components that have no distance to each other. + layout <- "levels" } else if (manynet::is_twomode(g)) { - layout <- "hierarchy" + layout <- "layered" + } else if (manynet::is_directed(g) && manynet::is_acyclic(g)) { + # A directed acyclic network ranks its nodes: every tie points from an + # earlier layer to a later one. A force-directed layout throws that + # away, so a parent can be drawn below its own child. + layout <- "layered" } else layout <- "stress" } layout } +# `node_group` names one node attribute, which can put each node in one group +# only. A node can belong to several groups at once, though, as it can to +# several cliques, and a single attribute cannot record that. A membership +# matrix can: one row for each node, one column for each group, and a one +# wherever the node belongs to the group. `netrics::node_x_clique()` returns +# such a matrix, and graph_layout() draws one hull for each of its columns, +# so that the hulls overlap where the groups do. + +# Resolves what the user gave to `node_group` into either the name of a node +# attribute, as before, or a membership matrix. A call such as +# `node_x_clique()` is evaluated on the network being drawn, so that the user +# does not need to name the network twice. +.infer_node_group <- function(g, expr, env) { + # A name or a string is a node attribute, as it has always been. Only where + # it names no attribute is it evaluated, which is how a matrix held in a + # variable reaches the branch below. + if (is.character(expr) || is.name(expr)) { + value <- as.character(expr) + if (length(value) != 1L || value %in% igraph::vertex_attr_names(g)) + return(value) + out <- tryCatch(eval(expr, env), error = function(e) NULL) + # Nothing of that name to evaluate, so the mismatch is reported against + # the node attributes. A single string is a node attribute name too, + # whether it was written out or held in a variable. + if (is.null(out)) return(value) + if (is.character(out) && length(out) == 1L) return(out) + } else out <- eval(.add_data_arg(expr, g, env), env) + if (is.matrix(out) || is.array(out) || inherits(out, "data.frame")) + return(.as_group_matrix(g, out)) + # A vector of memberships is returned as it is, for graphr() to hold on the + # network and treat as any other node attribute. + if (length(out) == as.numeric(manynet::net_nodes(g))) return(out) + manynet::snet_abort( + "{.arg node_group} should name a node attribute, or give a membership", + "vector or matrix with one row for each of the {manynet::net_nodes(g)} nodes.") +} + +# Adds the network as the `.data` argument of a call that does not give one, +# e.g. `node_x_clique()` or `node_x_clique(min_clique_size = 4)`. A call that +# names its own network, e.g. `node_x_clique(ison_adolescents)`, is left alone. +.add_data_arg <- function(expr, g, env) { + if (!is.call(expr)) return(expr) + fun <- tryCatch(eval(expr[[1L]], env), error = function(e) NULL) + if (!is.function(fun) || !".data" %in% names(formals(fun))) return(expr) + args <- as.list(expr)[-1] + given <- names(args) + if (".data" %in% given) return(expr) + # An unnamed argument would be matched to `.data` positionally. + if (length(args) && (is.null(given) || !all(nzchar(given)))) return(expr) + expr[[".data"]] <- g + expr +} + +# Normalises a membership matrix onto the nodes of `g`: one row for each node, +# in the order the network holds them, and one named column for each group. +.as_group_matrix <- function(g, value) { + if (inherits(value, "data.frame")) { + ischr <- vapply(value, function(x) is.character(x) || is.factor(x), + logical(1)) + labels <- if (any(ischr)) as.character(value[[which(ischr)[1]]]) else NULL + value <- as.matrix(value[!ischr]) + if (!is.null(labels)) rownames(value) <- labels + } else value <- as.matrix(unclass(value)) + n <- as.numeric(manynet::net_nodes(g)) + # Isolates are dropped before this point, so a matrix calculated on the + # network as the user holds it can have more rows than there are nodes to + # draw. Node names say which rows those are. + if (!is.null(rownames(value)) && manynet::is_labelled(g)) { + nms <- manynet::node_names(g) + if (all(nms %in% rownames(value))) value <- value[nms, , drop = FALSE] + } + if (nrow(value) != n) + manynet::snet_abort( + "{.arg node_group} was given a membership matrix with {nrow(value)} rows,", + "but the network has {n} nodes.") + if (is.null(colnames(value))) + colnames(value) <- paste0("G", seq_len(ncol(value))) + value <- value > 0 + # A group no node belongs to has no hull to draw. + value <- value[, colSums(value) > 0, drop = FALSE] + if (ncol(value) == 0) + manynet::snet_abort("{.arg node_group} was given no groups to draw.") + if (any(colSums(value) <= 2)) + manynet::snet_info( + "Groups of two nodes or fewer can be difficult to draw a hull around,", + "so this plot may look uneven.") + value +} + .reduce_categories <- function(g, node_group) { limit <- toCondense <- NULL if (sum(table(manynet::node_attribute(g, node_group)) <= 2) > 2 & diff --git a/R/graphs.R b/R/graphs.R index d692d840..80da7886 100644 --- a/R/graphs.R +++ b/R/graphs.R @@ -88,11 +88,40 @@ graphs <- function(netlist, waves, netlist <- netlist[waves] } if (is.null(names(netlist))) names(netlist) <- rep("", length(netlist)) + # Each panel is a plot of its own, so each would otherwise scale its + # aesthetics against its own network alone. The ranges and categories found + # across the whole list are worked out once here and passed down to every + # panel, so that `patchwork` can collect the guides into one legend and the + # same value is drawn the same way in each panel. See `.shared_aes()`. + shared <- .shared_aes_from_dots(netlist, list(...)) if (length(unique(lapply(netlist, length))) == 1) { # Sharing a layout requires every panel to draw every node, so isolates # are kept unless the user explicitly asks otherwise dots <- list(...) + dots$.shared <- shared if (!"isolates" %in% names(dots)) dots$isolates <- "keep" + # Every panel draws the same nodes, so which of them to label is settled + # once here, against the network the layout is based on, and passed down as + # names. Left to each panel, `graphr()` would rank the nodes of each network + # separately and the labels would jump from panel to panel. + ref <- manynet::as_tidygraph( + netlist[[if (based_on == "last") length(netlist) else 1]]) + if (manynet::is_labelled(ref)) { + labels_given <- "labels" %in% names(dots) + lab <- .check_labels(ref, if (labels_given) dots$labels else TRUE) + n_ref <- as.numeric(manynet::net_nodes(ref)) + if (isTRUE(lab) && !labels_given && n_ref > 30) + lab <- structure(5L, criterion = "degree", automatic = TRUE) + if (!isTRUE(lab) && !isFALSE(lab)) { + dots$labels <- manynet::node_names(ref)[.infer_labels(ref, lab)] + n_lab <- length(dots$labels) + if (!labels_given) manynet::snet_info( + "Labelling the {n_lab} most central of {n_ref} nodes in each panel.", + "Use {.code labels = TRUE} to label all of them,", + "{.code labels = 25} to label more,", + "or {.code labels = FALSE} for none.") + } + } shared_graphr <- function(net, extra = NULL) do.call(graphr, c(list(net), dots, extra)) if (based_on == "first") { @@ -118,23 +147,49 @@ graphs <- function(netlist, waves, thisRequires("methods") if (!methods::hasArg("layout") & is_ego_network(netlist)) { gs <- lapply(1:length(netlist), function(i) - graphr(netlist[[i]], layout = "star", center = names(netlist)[[i]], ...) + + graphr(netlist[[i]], layout = "star", center = names(netlist)[[i]], + .shared = shared, ...) + ggtitle(names(netlist)[i])) } else { manynet::snet_info( "Giving each network its own layout, since not all nodes appear in", "every one of them, so a shared layout would place them differently.") gs <- lapply(1:length(netlist), function(i) - graphr(netlist[[i]], ...) + ggtitle(names(netlist)[i])) + graphr(netlist[[i]], .shared = shared, ...) + ggtitle(names(netlist)[i])) } } - # if (all(c("Infected", "Exposed", "Recovered") %in% names(gs[[1]]$data))) { - # gs <- .collapse_guides(gs) - # } do.call(patchwork::wrap_plots, c(gs, list(guides = "collect"))) } # `graphs()` helper functions + +# The aesthetic arguments reach `graphs()` through `...`, where they are values +# rather than the expressions `graphr()` reads with `substitute()`, and either +# spelling of the two colour arguments may be used. Pulled out here so that +# `.shared_aes()` is given the same argument each panel will be drawn with. +.shared_aes_from_dots <- function(netlist, dots) { + pick <- function(...) { + nms <- c(...) + for (nm in nms) if (nm %in% names(dots)) { + out <- dots[[nm]] + # A colour or a size given outright ("red", 3) maps nothing, and only an + # attribute name can be resolved against every network in the list. + if (is.character(out) && length(out) == 1) return(out) + return(NULL) + } + NULL + } + tryCatch( + .shared_aes(netlist, + node_color = pick("node_color", "node_colour"), + node_shape = pick("node_shape"), + node_size = pick("node_size"), + edge_color = pick("edge_color", "edge_colour"), + edge_size = pick("edge_size"), + layout = if (is.character(dots[["layout"]])) dots[["layout"]]), + error = function(e) NULL) +} + is_ego_network <- function(nlist) { if (all(unique(names(nlist)) != "")) { all_names <- unique(unlist(unname(lapply(nlist, manynet::node_names)))) diff --git a/R/grapht.R b/R/grapht.R index 9ea63a3c..8e294b29 100644 --- a/R/grapht.R +++ b/R/grapht.R @@ -27,7 +27,7 @@ #' a single static layout is computed on the aggregate #' (union of waves) network instead, so that positions remain constant. #' Unlike `graphr()`, `grapht()` uses this dynamic stress layout by default -#' even for two-mode networks (rather than a hierarchy layout, which would +#' even for two-mode networks (rather than a layered layout, which would #' collapse many nodes onto a line); the two modes remain distinguishable #' by node shape. #' For networks with more than 30 nodes, node labels are suppressed by @@ -86,16 +86,26 @@ #' offset nudging labels away from their nodes, and `label_dist` scales the #' size of that nudge rather than being used as repel padding. #' +#' `labels` can select which nodes to label here too, and the selection is +#' resolved once over all the waves so that the same nodes stay labelled from +#' frame to frame. Unlike `graphr()`, though, animations of more than 30 nodes +#' default to no labels at all rather than to a selection of them. +#' #' Some further `graphr()` features are not available in animations: #' `node_group` hulls, edge bundling, curved arcs for reciprocated ties, #' and self-loops (loops are not drawn; a note is printed if present). +#' Note too that, where no `layout` is named, `grapht()` defaults to +#' the "stress" layout for every network rather than choosing one by +#' the network's shape as `graphr()` does, +#' so that nodes move smoothly from one wave to the next. +#' A layout named explicitly is still used, computed on the aggregate network. #' @inheritParams plot_graphr #' @importFrom igraph as_data_frame vcount add_vertices permute #' @importFrom igraph vertex_attr_names delete_vertex_attr delete_edge_attr #' @importFrom igraph set_vertex_attr graph_from_data_frame delete_graph_attr #' @importFrom ggplot2 ggplot geom_segment geom_point geom_text coord_fixed .data #' @importFrom ggplot2 scale_alpha_identity scale_linetype_identity theme_void -#' @importFrom dplyr mutate select distinct left_join %>% +#' @importFrom dplyr mutate select distinct left_join #' @source https://blog.schochastics.net/posts/2021-09-15_animating-network-evolutions-with-gganimate/ #' @return A `{ggplot2}`-compatible object with `{gganimate}` animation layers. #' This object can be extended with additional `{ggplot2}` layers @@ -168,6 +178,12 @@ grapht <- function(tlist, layout = NULL, labels = TRUE, labels <- FALSE manynet::snet_info("Suppressing node labels for a network with more than 30 nodes; set `labels = TRUE` to show them.") } + # Resolved once, against the reference wave, so that the same nodes stay + # labelled from frame to frame rather than the selection shifting as ties + # come and go. Kept as node names, which is what the frame data is keyed by. + labels <- .check_labels(g_ref, labels) + if (!isFALSE(labels)) + labels <- manynet::node_names(g_ref)[.infer_labels(g_ref, labels)] # Checked against the reference wave, which spans the union of nodes and ties, # so an attribute present in only some waves still resolves. node_color <- .check_node_color(g_ref, node_color) @@ -181,7 +197,7 @@ grapht <- function(tlist, layout = NULL, labels = TRUE, # Layout #### # Default to the smooth dynamic stress layout regardless of mode or size: # grapht()'s purpose is seamless transitions, so unlike graphr() it does - # not fall back to a static hierarchy for two-mode networks (which collapses + # not fall back to a static layered layout for two-mode networks (which collapses # many nodes onto a line). The two modes remain distinguishable by shape. # An explicitly requested layout is still honoured (via a static fallback). layout <- .check_layout(layout) @@ -259,7 +275,7 @@ print.grapht <- function(x, ...) { tlist <- lapply(tlist, manynet::as_tidygraph) frames <- if (is.null(names(tlist))) as.character(seq_along(tlist)) else names(tlist) # Ensure nodes are named so they can be matched across waves - has_names <- "name" %in% names(manynet::node_attribute(tlist[[1]])) + has_names <- "name" %in% manynet::net_node_attributes(tlist[[1]]) if (!has_names) { for (i in seq_along(tlist)) { tlist[[i]] <- manynet::add_node_attribute(tlist[[i]], "name", @@ -314,34 +330,69 @@ print.grapht <- function(x, ...) { } # Splits a changing/longitudinal network into waves via `manynet::to_waves()`, -# guarding against a bug present through at least manynet 2.2.2 whereby a node +# guarding against two bugs, each of which loses every wave rather than part of +# one, and each of which is met by retrying the split another way. autograph +# has an unversioned dependency on manynet, so `to_waves()` is always tried +# unchanged first -- behaviour then tracks manynet once each bug is fixed +# upstream -- and each guard is a response to the error actually raised. +# +# The first bug, present through at least manynet 2.2.2, is that a node # attribute that *changes* over time but is stored as a non-character vector # (e.g. the logical `active` flag, or numeric `height`/`mass`, in # `manynet::fict_starwars`) cannot be split. Internally `to_waves()` coalesces # each attribute against a character update vector built from the (always # character) changelist values; when the stored attribute is logical or numeric # this aborts with a vctrs "Can't combine and <...>" error before -# any wave is produced. autograph has an unversioned dependency on manynet, so -# this must also work against the CRAN build that lacks any fix. We therefore -# try `to_waves()` unchanged first -- so behaviour tracks manynet once it is -# fixed upstream -- and only on that specific combine error coerce the changing -# non-character node attributes to character (which is the type those columns -# already take in the split output regardless) and retry. +# any wave is produced. Those attributes are coerced to character (the type +# those columns already take in the split output regardless) and the split +# retried. +# +# The second bug, in manynet 2.3.0, is that `to_waves()` splits neither a panel +# whose waves are recorded as a "time" tie attribute (as `ison_monks` now +# records them, aborting with "object 'wave' not found") nor a changing network +# with no tie attributes at all (as a diffusion result has, aborting with +# "`name` must be a single string, not a character `NA`"). Both are met by +# `to_times()`, which 2.3.0 added and which reads whichever way the network +# records its moments. It is a fallback rather than the first choice because it +# returns each moment with only the nodes present at it, where `to_waves()` +# gives every wave the whole node set. .to_waves_safe <- function(x) { - tryCatch( - manynet::to_waves(x), - error = function(e) { - if (!grepl("Can't combine", conditionMessage(e), fixed = TRUE) || - !manynet::is_changing(x)) stop(e) - changing <- tryCatch(unique(manynet::as_changelist(x)$var), - error = function(...) character(0)) - for (a in intersect(changing, names(manynet::node_attribute(x)))) { - old <- manynet::node_attribute(x, a) - if (!is.character(old)) - x <- manynet::add_node_attribute(x, a, as.character(unclass(old))) - } - manynet::to_waves(x) - }) + out <- tryCatch(manynet::to_waves(x), error = function(e) e) + if (inherits(out, "error") && manynet::is_changing(x) && + grepl("Can't combine", conditionMessage(out), fixed = TRUE)) { + changing <- tryCatch(unique(manynet::as_changelist(x)$var), + error = function(...) character(0)) + for (a in intersect(changing, manynet::net_node_attributes(x))) { + old <- manynet::node_attribute(x, a) + if (!is.character(old)) + x <- manynet::add_node_attribute(x, a, as.character(unclass(old))) + } + out <- tryCatch(manynet::to_waves(x), error = function(e) e) + } + if (inherits(out, "error")) { + if (.manynet_has("to_times")) { + alt <- tryCatch(.manynet_fn("to_times")(x), error = function(e) NULL) + if (manynet::is_list(alt) && length(alt) > 1) return(alt) + } + stop(out) + } + out +} + +# Whether the installed manynet exports a function, so that a newer manynet is +# used where it offers something an older one does not, without autograph +# requiring that version. Tests for the function rather than for the version, +# since a development build can carry a version string without the function. +.manynet_has <- function(fn) { + isTRUE(fn %in% getNamespaceExports("manynet")) +} + +# The function itself, fetched from the manynet namespace at run time. A +# `manynet::to_times()` written out in full is a hard reference, which R CMD +# check reports as a missing object against a manynet that does not export it +# yet. Always guard a call to this with `.manynet_has()`. +.manynet_fn <- function(fn) { + get(fn, envir = asNamespace("manynet")) } # A spell (interval) network records each tie's lifespan as `begin`/`end` tie @@ -349,7 +400,7 @@ print.grapht <- function(x, ...) { # `manynet::is_dynamic()` is TRUE for both, but only the event form can be split # by `to_slices()`, so spell networks are detected and sliced separately here. .grapht_is_spell <- function(net) { - atts <- names(manynet::tie_attribute(net)) + atts <- manynet::net_tie_attributes(net) "begin" %in% atts && "end" %in% atts && !("time" %in% atts) } @@ -357,13 +408,19 @@ print.grapht <- function(x, ...) { # which some tie begins or ends), keeping the ties active during that spell # (begin <= t < end). Unlike the cumulative slices of an event network, these # show the network as it stood at each moment, so ties that dissolve disappear -# again. `manynet::to_time()` gained this behaviour in manynet 2.2.2, so it is -# used when available and reimplemented equivalently for older manynet. The -# version guard is paired with a check that to_time() actually accepts a missing -# `time` (its 2.2.2 signature), because a pre-release 2.2.2 dev build can carry -# the version string without yet exposing the feature; the fallback is -# behaviourally identical either way. +# again. manynet splits this three ways depending on its version, so each is +# tested for rather than assumed: `to_times()` from 2.3.0 returns one network +# per moment (2.3.0 having made `to_time()` require the moment to scope to); +# `to_time()` without a `time` did the same from 2.2.2; and older manynet is +# reimplemented equivalently below. The version test is paired with a test of +# the function itself, because a development build can carry a version string +# without yet exposing the feature. All three are behaviourally identical. .grapht_spell_slices <- function(net) { + if (.manynet_has("to_times")) { + out <- .manynet_fn("to_times")(net) + if (!manynet::is_list(out)) out <- list(out) + return(out) + } if (utils::packageVersion("manynet") >= "2.2.2" && !identical(formals(manynet::to_time)[["time"]], quote(expr = ))) { out <- manynet::to_time(net) @@ -467,7 +524,7 @@ print.grapht <- function(x, ...) { # levels consistent across frames. .grapht_ncolor <- function(waves, node_color) { diffusion <- is.null(node_color) && - "diffusion" %in% names(manynet::node_attribute(waves[[1]])) + "diffusion" %in% manynet::net_node_attributes(waves[[1]]) if (diffusion) { vals <- vapply(waves, function(w) dplyr::recode_values(as.character(manynet::node_attribute(w, "diffusion")), @@ -477,18 +534,18 @@ print.grapht <- function(x, ...) { return(list(mapped = TRUE, diffusion = TRUE, values = vals)) } if (!is.null(node_color) && - node_color %in% names(manynet::node_attribute(waves[[1]]))) { + node_color %in% manynet::net_node_attributes(waves[[1]])) { vals <- vapply(waves, function(w) as.character(manynet::node_attribute(w, node_color)), character(igraph::vcount(waves[[1]]))) if (length(unique(stats::na.omit(as.vector(vals)))) == 1) { .inform_constant_color("node_color", node_color, "node") - return(list(mapped = FALSE, diffusion = FALSE, literal = "black")) + return(list(mapped = FALSE, diffusion = FALSE, literal = ag_ink())) } return(list(mapped = TRUE, diffusion = FALSE, values = vals)) } list(mapped = FALSE, diffusion = FALSE, - literal = if (!is.null(node_color)) node_color else "black") + literal = if (!is.null(node_color)) node_color else ag_ink()) } # One row per union node per frame, with stable coordinates, presence and @@ -524,7 +581,7 @@ print.grapht <- function(x, ...) { .grapht_ecolor <- function(waves, edge_color) { g1 <- waves[[1]] attr_mapped <- !is.null(edge_color) && - edge_color %in% names(manynet::tie_attribute(g1)) + edge_color %in% manynet::net_tie_attributes(g1) signed <- is.null(edge_color) && manynet::is_signed(g1) if (attr_mapped) { raw <- lapply(waves, function(w) @@ -534,12 +591,12 @@ print.grapht <- function(x, ...) { ifelse(as.numeric(manynet::tie_signs(w)) >= 0, "Positive", "Negative")) } else { return(list(mapped = FALSE, - literal = if (!is.null(edge_color)) edge_color else "black")) + literal = if (!is.null(edge_color)) edge_color else ag_ink())) } if (length(unique(stats::na.omit(unlist(raw)))) <= 1) { if (attr_mapped) .inform_constant_color("edge_color", edge_color, "tie") - return(list(mapped = FALSE, literal = "black")) + return(list(mapped = FALSE, literal = ag_ink())) } list(mapped = TRUE, signed = signed, raw = raw) } @@ -746,7 +803,9 @@ print.grapht <- function(x, ...) { 1 / n_union * 100)) # --- Labels (drawn above nodes, as in graphr) ---- - if (isTRUE(labels)) { + # `labels` arrives as the names of the nodes to label (or FALSE for none), + # already resolved against the reference wave by grapht(). + if (!isFALSE(labels) && length(labels) > 0) { # No ggrepel-based repelling here (see @details in grapht()'s docs); # `label_repel` toggles a fixed offset instead, scaled by `label_dist` # when supplied (calibrated so graphr()'s default `label_dist` of 10 @@ -761,7 +820,8 @@ print.grapht <- function(x, ...) { p <- p + ggplot2::geom_text( ggplot2::aes(x = .data$x, y = .data$y, label = .data$name, group = .data$name, alpha = .data$nalpha), - data = nodes_out, colour = ag_base(), family = ag_font(), + data = nodes_out[nodes_out$name %in% labels, , drop = FALSE], + colour = ag_base(), family = ag_font(), nudge_y = nudge, show.legend = FALSE) } @@ -770,12 +830,8 @@ print.grapht <- function(x, ...) { # --- Legends and theme (consistent with graphr) ---- p <- graph_legends(p, g_ref, node_color, node_shape, node_size, edge_color, edge_size) - p <- p + ggplot2::theme_void() + + p <- p + ag_theme_void() + ggplot2::theme(legend.position = "bottom") if (directed) p <- p + ggplot2::coord_fixed() - if (getOption("snet_background", default = "#FFFFFF") != "#FFFFFF") - p <- p + ggplot2::theme( - panel.background = ggplot2::element_rect( - fill = getOption("snet_background", default = "#FFFFFF"))) p } diff --git a/R/layout_concentric.R b/R/layout_concentric.R new file mode 100644 index 00000000..888f42c3 --- /dev/null +++ b/R/layout_concentric.R @@ -0,0 +1,151 @@ +#' Concentric layout +#' +#' @description +#' The "concentric" layout places the nodes on one or more circles, +#' with each group of nodes on a circle of its own, +#' and the groups ordered around those circles +#' so that adjacent nodes are drawn close together. +#' Where one group holds a single node, that node occupies the centre. +#' @name layout_concentric +#' @template param_ggraphlayouts +#' @param membership A node attribute or a vector to draw concentric circles. +#' By default this is the two modes of a two-mode network. +#' @param radius A vector of radii at which the concentric circles +#' should be located. +#' By default this is equal placement around an empty centre, +#' unless one (the core) is a single node, +#' in which case this node occupies the centre of the graph. +#' @param order.by An attribute label indicating the (decreasing) order +#' for the nodes around the circles. +#' By default ordering is given by a bipartite placement that reduces +#' the number of edge crossings. +#' @family mapping +#' @source +#' Diego Diez, Andrew P. Hutchins and Diego Miranda-Saavedra. 2014. +#' "Systematic identification of transcriptional regulatory modules from +#' protein-protein interaction networks". +#' _Nucleic Acids Research_, 42 (1) e6. +#' @examples +#' #graphr(ison_southern_women, layout = "concentric", membership = "type", +#' # node_color = "type", node_size = 3) +#' @export +layout_concentric <- function(.data, membership, radius = NULL, + order.by = NULL, + circular = FALSE, times = 1000) { + .data <- manynet::as_igraph(.data) + # An unlabelled network is given the names `manynet::node_names()` invents + # for it, so that the groups, the ordering and the coordinates all name a + # node the same way. Without this the groups are named while + # `manynet::is_labelled()` says they are not, and the two disagree: every + # node falls out of its own group and is drawn on a circle of its own. + # Only the coordinates are returned, so the invented names go no further. + if (!manynet::is_labelled(.data)) + .data <- igraph::set_vertex_attr(.data, "name", + value = manynet::node_names(.data)) + if (any(igraph::vertex_attr(.data, "name") == "")) { + ll <- unlist(lapply(seq_len(length(.data)), function(x) { + ifelse(igraph::vertex_attr(.data, "name")[x] == "", + paste0("ramdom", x), igraph::vertex_attr(.data, "name")[x]) + })) + .data <- igraph::set_vertex_attr(.data, "name", value = ll) + } + if (missing(membership)) { + if (manynet::is_twomode(.data)) membership <- manynet::node_is_mode(.data) else + .abort_layout_arg("membership", "concentric", length(.data)) + } else { + if (length(membership) > 1 & length(membership) != length(.data)) { + .abort_layout_arg("membership", "concentric", length(.data)) + } else if (length(membership) != length(.data)) { + membership <- .match_name(membership, igraph::vertex_attr_names(.data), + "membership", what = "node attribute") + membership <- manynet::node_attribute(.data, membership) + } + } + names(membership) <- manynet::node_names(.data) + membership <- .to_list(membership) + all_c <- unlist(membership, use.names = FALSE) + if (any(table(all_c) > 1)) { + duplicated_nodes <- names(which(table(all_c) > 1)) + manynet::snet_abort( + "The {.val concentric} layout draws each node in one circle only,", + "but {.val {duplicated_nodes}} appear{?s} in more than one.", + "Please check that {.arg membership} gives each node a single group.") + } + if (manynet::is_labelled(.data)) all_n <- manynet::node_names(.data) else + all_n <- 1:manynet::net_nodes(.data) + sel_other <- all_n[!all_n %in% all_c] + if (length(sel_other) > 0) membership[[length(membership) + 1]] <- sel_other + if (is.null(radius)) { + radius <- seq(0, 1, 1/(length(membership))) + if (length(membership[[1]]) == 1) + radius <- radius[-length(radius)] else radius <- radius[-1] + } + if (!is.null(order.by)) { + order.by <- .match_name(order.by, igraph::vertex_attr_names(.data), + "order.by", what = "node attribute") + values <- manynet::node_attribute(.data, order.by) + names(values) <- manynet::node_names(.data) + # `order.by` orders the nodes within each circle, not the circles + # themselves, so the circles are still taken smallest first, as they are + # by default. This keeps `radius` meaning the same either way. + order.values <- lapply(membership[order(sapply(membership, length))], + function(g) g[order(values[g], decreasing = TRUE)]) + } else { + if (manynet::is_twomode(.data) & length(membership) == 2) { + xnet <- manynet::as_matrix(manynet::to_multilevel(.data))[membership[[2-1]], + membership[[2]]] + lo <- layout_tbl_graph_layered(manynet::as_igraph(xnet, twomode = TRUE)) + lo$names <- manynet::node_names(.data) + if (ncol(lo) == 2) lo[,1] <- seq_len(dim(lo)[1]) + order.values <- lapply(1:0, function(x) + if(ncol(lo) >= 3) sort(lo[lo[,2] == x,])[,3] + else sort(lo[lo[,2] == x,1])) + } else order.values <- membership[order(sapply(membership, length))] + } + res <- matrix(NA, nrow = length(all_n), ncol = 2) + for (k in seq_along(membership)) { + r <- radius[k] + l <- order.values[[k]] + if(manynet::is_labelled(.data)) + l <- match(l, manynet::node_names(.data)) + res[l, ] <- .get_coordinates(l, r) + } + .to_lo(res) +} + +#' @rdname layout_concentric +#' @export +layout_tbl_graph_concentric <- layout_concentric + +# Helper functions -------------------------------------------------------- + +# Turn a vector of memberships into a list of the nodes in each group. +# A node whose membership is NA belongs to no group: `sort()` drops NA, so +# such a node reaches none of the groups, and `layout_concentric()` gathers +# whatever is left over onto a circle of its own. The groups are named from +# the same values they are built from, which also keeps each name on its own +# group where the values do not arrive in sorted order. +.to_list <- function(members) { + groups <- sort(unique(members)) + out <- lapply(groups, function(x){ + y <- which(members==x) + if(!is.null(names(y))) names(y) else y + }) + names(out) <- groups + out +} + +# Space the nodes `x` evenly around a circle of radius `r`. +.get_coordinates <- function(x, r) { + l <- length(x) + d <- 360/l + c1 <- seq(0, 360, d) + c1 <- c1[1:(length(c1) - 1)] + tmp <- t(vapply(c1, + function(cc) c(cos(cc * pi/180) * + r, sin(cc * + pi/180) * r), + FUN.VALUE = numeric(2))) + rownames(tmp) <- x + tmp +} diff --git a/R/layout_configurational.R b/R/layout_configurational.R index 5547ec6a..6324c057 100644 --- a/R/layout_configurational.R +++ b/R/layout_configurational.R @@ -9,16 +9,11 @@ #' #' @name layout_configuration #' @family mapping -#' @inheritParams layout_partition -#' @param circular Logical, required for `{ggraph}` compatibility, default TRUE. -#' @param times Integer, how many times to run the algorithm. -#' Required by for `{ggraph}` compatibility, but not used here, so default = 1. +#' @template param_ggraphlayouts #' @examples #' # "configuration" picks the layout matching the number of nodes #' graphr(manynet::create_ring(4), layout = "configuration") -#' # or a specific configuration can be named -#' graphr(manynet::create_ring(3), layout = "triad") -#' # the layout functions can also be called directly for their coordinates +#' # the specific configurations are also available as functions #' layout_tetrad(manynet::create_ring(4)) NULL @@ -27,15 +22,15 @@ NULL layout_configuration <- function(.data, circular = TRUE, times = 1){ if (manynet::net_nodes(.data) == 2) { - layout_tbl_graph_dyad(.data, circular = circular, times = times) + layout_dyad(.data, circular = circular, times = times) } else if (manynet::net_nodes(.data) == 3) { - layout_tbl_graph_triad(.data, circular = circular, times = times) + layout_triad(.data, circular = circular, times = times) } else if (manynet::net_nodes(.data) == 4) { - layout_tbl_graph_tetrad(.data, circular = circular, times = times) + layout_tetrad(.data, circular = circular, times = times) } else if (manynet::net_nodes(.data) == 5) { - layout_tbl_graph_pentad(.data, circular = circular, times = times) + layout_pentad(.data, circular = circular, times = times) } else if (manynet::net_nodes(.data) == 6) { - layout_tbl_graph_hexad(.data, circular = circular, times = times) + layout_hexad(.data, circular = circular, times = times) } } @@ -52,10 +47,6 @@ layout_dyad <- function(.data, .to_lo(res) } -#' @rdname layout_configuration -#' @export -layout_tbl_graph_dyad <- layout_dyad - #' @rdname layout_configuration #' @export layout_triad <- function(.data, @@ -66,10 +57,6 @@ layout_triad <- function(.data, .to_lo(res) } -#' @rdname layout_configuration -#' @export -layout_tbl_graph_triad <- layout_triad - #' @rdname layout_configuration #' @export layout_tetrad <- function(.data, @@ -81,10 +68,6 @@ layout_tetrad <- function(.data, .to_lo(res) } -#' @rdname layout_configuration -#' @export -layout_tbl_graph_tetrad <- layout_tetrad - #' @rdname layout_configuration #' @export layout_pentad <- function(.data, @@ -97,10 +80,6 @@ layout_pentad <- function(.data, .to_lo(res) } -#' @rdname layout_configuration -#' @export -layout_tbl_graph_pentad <- layout_pentad - #' @rdname layout_configuration #' @export layout_hexad <- function(.data, @@ -114,6 +93,3 @@ layout_hexad <- function(.data, .to_lo(res) } -#' @rdname layout_configuration -#' @export -layout_tbl_graph_hexad <- layout_hexad diff --git a/R/layout_correspondence.R b/R/layout_correspondence.R new file mode 100644 index 00000000..733e6e5c --- /dev/null +++ b/R/layout_correspondence.R @@ -0,0 +1,265 @@ +#' Correspondence layout +#' +#' @description +#' The "correspondence" layout places nodes by correspondence analysis, +#' so that two nodes are drawn together where they have similar ties. +#' Where the "scaling" layout reads the paths between nodes, +#' this one reads the profile of each node's ties, +#' and so two nodes with no tie between them can still be drawn together +#' if they are tied to the same others. +#' +#' This is the usual way to draw a two-mode network, +#' since correspondence analysis takes a rectangular table +#' and places its rows and its columns in one space. +#' Both modes are therefore drawn on one pair of axes. +#' +#' Like the "scaling" layout, the coordinates can be read, +#' and so this layout draws labelled axes at a fixed ratio. +#' Each axis is labelled with the share of the network's inertia +#' that the dimension holds. +#' @name layout_correspondence +#' @template param_ggraphlayouts +#' @param direction Which ties to read for a directed network, +#' as one of "all", "out", or "in". +#' By default this is "all", which reads a tie in either direction, +#' so that each node has one position. +#' "out" places each node by the ties it sends, +#' and "in" by the ties it receives. +#' This is ignored where the network is undirected or two-mode. +#' @param double Whether to split each tie into a positive and a negative part, +#' so that a signed network can be drawn. +#' By default this is `FALSE`, and a signed network is not drawn, +#' since correspondence analysis is not defined for a negative tie. +#' @details +#' Correspondence analysis divides the ties of each node by how many ties +#' that node has, and so places nodes by the shape of their ties +#' rather than by how many they have. +#' The distance drawn is the chi-square distance between two such profiles. +#' +#' A two-mode network is read as its incidence matrix, +#' one row for each node of the first mode and one column for each of the +#' second. A one-mode network is read as its adjacency matrix instead, +#' as is a multimodal network that has ties within its modes as well as +#' between them, so that no tie is dropped. +#' +#' Tie weights are read as they are, since correspondence analysis was built +#' for counts and a weight counts in the same way. +#' A negative weight has no such reading, which is why a signed network +#' needs `double = TRUE`. That stacks the positive network and the negative +#' network side by side, doubling the width of the table, +#' so that a node is placed by both who it is tied to positively +#' and who it is tied to negatively. +#' A pair of nodes with no tie between them counts in neither half. +#' @section Reading the plot: +#' Two nodes of the same mode drawn together have similar ties. +#' A node drawn near the origin has a profile close to the average, +#' or is held poorly by the two dimensions drawn: these are not the same +#' thing, and `graphr()` names the nodes for which it is the second. +#' +#' A node of one mode drawn near a node of the other mode is *not* +#' necessarily tied to it. +#' Only the distances within a mode can be read this way. +#' +#' Where a network runs along one strong gradient, +#' correspondence analysis draws it as an arch rather than as a line. +#' This is expected of the method, and the second dimension then repeats +#' the first rather than adding to it. +#' +#' Where a network is disconnected, the first dimensions merely separate its +#' components, and say little about the nodes within them. +#' @section Reading the inertia: +#' The share of inertia a dimension holds is not a share of variance +#' explained, and does not have a fixed ceiling to be read against. +#' It is a share of however many dimensions the table has, +#' which `attr(x, "fit")$scree` reports in full. +#' Two dimensions of a table that has twelve start from a base of a sixth; +#' two of a table that has thirty start from a base of a fifteenth. +#' Compare the share drawn against that base rather than against 100%, +#' and note that this can reverse the ranking the raw shares suggest. +#' Bear in mind that an even share is a lenient base, since inertia is +#' never spread evenly; the broken stick model asks what the dimensions +#' would hold if the inertia were divided at random, and is the harder test. +#' Neither is a standard statistic, and neither carries a threshold, +#' so read them as a check on the raw share rather than as a verdict. +#' `graphr()` says so at the console where two dimensions hold no more +#' than a random division of the inertia would give them. +#' To choose a number of dimensions properly, see Lorenzo-Seva (2011). +#' +#' These shares need no correction. +#' The Benzécri correction, and Greenacre's adjusted version of it, +#' exist because the indicator matrix that *multiple* correspondence +#' analysis is run on invents dimensions that deflate every share. +#' This layout runs simple correspondence analysis on one two-way table, +#' which invents nothing, so the shares reported are already exact. +#' @family mapping +#' @source +#' Greenacre, Michael. 2017. +#' _Correspondence Analysis in Practice_, 3rd ed. +#' Boca Raton: Chapman and Hall. +#' \doi{10.1201/9781315369983} +#' +#' Lorenzo-Seva, Urbano. 2011. +#' "Horn's parallel analysis for selecting the number of dimensions in +#' correspondence analysis", +#' _Methodology_ 7(3): 96-105. +#' \doi{10.1027/1614-2241/a000027} +#' +#' Constantine, A.G., and John C. Gower. 1978. +#' "Graphical representation of asymmetric matrices", +#' _Journal of the Royal Statistical Society C_ 27(3): 297-304. +#' \doi{10.2307/2347234} +#' @examples +#' graphr(manynet::ison_southern_women, layout = "correspondence") +#' @export +layout_correspondence <- function(.data, direction = c("all", "out", "in"), + double = FALSE, circular = FALSE, times = 1) { + direction <- .check_choice(direction, c("all", "out", "in"), "direction") + .data <- manynet::as_igraph(.data) + n <- igraph::vcount(.data) + # A network with no ties has no profiles to compare, and one with fewer than + # three nodes has no shape a plane could hold. + if (n < 3L || igraph::ecount(.data) == 0L) return(.to_lo(.trivial_coords(n))) + tab <- .corresp_table(.data, direction, double) + crd <- .corresp_coords(tab) + res <- .to_lo(crd[["xy"]]) + # Carried on the coordinates rather than recomputed later, as the "scaling" + # layout carries its own fit: the attribute survives create_layout(), so + # graphr() can label the axes of the layout it actually drew. + attr(res, "fit") <- list( + type = "correspondence", + inertia = crd[["inertia"]], + total = crd[["total"]], + # Every dimension, not only the two drawn. A share of inertia means little + # on its own: what it is worth depends on how many dimensions it was won + # against, and on how fast the rest fall away. See `?layout_correspondence`. + scree = crd[["scree"]], + cos2 = stats::setNames(crd[["cos2"]], manynet::node_names(.data))) + res +} + +#' @rdname layout_correspondence +#' @export +layout_tbl_graph_correspondence <- layout_correspondence + +# The two-way table the analysis is run on, and whether its columns are nodes +# as well as its rows. Only a two-mode network read from its incidence matrix +# has nodes down both sides of the table; for every other network the columns +# are the same nodes read a second way, or the halves a doubled tie is split +# into, and only the rows are drawn. +.corresp_table <- function(g, direction, double) { + # Only a network whose ties all run between the modes has an incidence + # matrix that keeps every tie. A multilevel network is two-mode as well, but + # also has ties within its modes, and manynet::as_matrix() would drop those, + # so it is read as a square matrix like any one-mode network. + bipartite <- manynet::is_twomode(g) && !.ag_is_multilevel(g) + if (bipartite) { + # manynet orders the nodes of the first mode before those of the second, + # which is the order the rows and then the columns of the incidence matrix + # are in, and so the order the coordinates are returned in. + return(list(N = as.matrix(manynet::as_matrix(g)), bipartite = TRUE)) + } + N <- as.matrix(manynet::as_matrix(g)) + if (manynet::is_directed(g)) { + # "all" reads a tie in either direction, so that a node has one position + # rather than the two an asymmetric table would give it. There is no + # agreed way to place both at once. See Constantine and Gower (1978). + N <- switch(direction, all = N + t(N), out = N, `in` = t(N)) + } + if (double) { + # The positive and the negative network, stacked side by side, so that the + # table has no negative cell left in it and a node is placed by both. + # + # This is not Greenacre's doubling, though it is named for the doubled + # width. Doubling maps a value on a scale to a pair that sums to a + # constant, which here would turn every pair of nodes with no tie between + # them into a neutral pair carrying as much mass as a real tie. A network + # is mostly non-ties, so that would place the nodes by what they are not + # tied to. Splitting rather than doubling leaves a non-tie counting in + # neither half, as it should. + N <- cbind(pmax(N, 0), pmax(-N, 0)) + } + list(N = N, bipartite = FALSE) +} + +# Correspondence analysis of a table, returning the coordinates of the nodes +# in it, the share of inertia each of the first two dimensions holds, and how +# well those two dimensions hold each node. +.corresp_coords <- function(tab) { + N <- tab[["N"]] + if (any(N < 0)) { + manynet::snet_abort( + "Correspondence analysis is not defined for a negative tie.", + "Use {.code double = TRUE} to split the signs.") + } + # A node with no tie at all has no profile to place, and a mass of zero + # would divide the analysis by zero, so it is set aside and returned to the + # origin afterwards. graphr() drops isolates before the layout sees them, so + # this is reached by a direct call, or by `isolates = "keep"`. + keep_r <- rowSums(N) > 0 + keep_c <- colSums(N) > 0 + ca <- .corresp(N[keep_r, keep_c, drop = FALSE]) + rows <- .corresp_place(ca[["rows"]], keep_r) + # Where the columns are nodes too, they follow the rows, as the second mode + # follows the first. Where they are not, they are the doubled halves of the + # ties, and are not drawn. + if (tab[["bipartite"]]) { + cols <- .corresp_place(ca[["cols"]], keep_c) + crd <- rbind(rows[["xy"]], cols[["xy"]]) + cos2 <- c(rows[["cos2"]], cols[["cos2"]]) + } else { + crd <- rows[["xy"]] + cos2 <- rows[["cos2"]] + } + eig <- ca[["d"]]^2 + total <- sum(eig) + # A table of I rows and J columns has min(I, J) - 1 dimensions at most, and + # the decomposition returns a zero for each one the table does not support. + # Those are dropped, so that the count is the number of dimensions the + # network actually has to spread its inertia over. + shares <- if (total > 0) eig[eig > total * 1e-12] / total else numeric() + list(xy = crd, cos2 = cos2, total = total, scree = shares, + inertia = if (total > 0) eig[1:2] / total else c(NA_real_, NA_real_)) +} + +# The standardised residuals of a table, decomposed. The principal coordinates +# put the rows and the columns on the same scale, which is what lets a +# two-mode network be drawn on one pair of axes. +.corresp <- function(N) { + P <- N / sum(N) + r <- rowSums(P) + cm <- colSums(P) + # Subtracting the outer product of the masses removes the trivial first + # dimension, so every dimension the decomposition returns is one to read. + S <- (P - outer(r, cm)) / outer(sqrt(r), sqrt(cm)) + sv <- svd(S) + # The decomposition fixes the axes but not their direction, so the same + # network could be drawn mirrored from one call to the next. Pointing each + # dimension so that its largest coordinate is positive settles that. + flip <- apply(sv$u, 2, function(x) if (x[which.max(abs(x))] < 0) -1 else 1) + list(rows = .corresp_dims(sweep(sv$u, 2, sv$d * flip, "*") / sqrt(r)), + cols = .corresp_dims(sweep(sv$v, 2, sv$d * flip, "*") / sqrt(cm)), + d = sv$d) +} + +# A table with only two columns yields a single dimension, which is still +# drawn, along a second axis of zeroes. +.corresp_dims <- function(X) { + if (ncol(X) >= 2L) return(X) + cbind(X, matrix(0, nrow = nrow(X), ncol = 2L - ncol(X))) +} + +# Returns the first two coordinates of each node, and how much of each node's +# distance from the origin those two hold. Nodes set aside for having no ties +# are returned at the origin, with no fit to report. +.corresp_place <- function(X, keep) { + xy <- matrix(0, nrow = length(keep), ncol = 2L) + xy[keep, ] <- X[, 1:2, drop = FALSE] + # The squared cosine of the angle between where a node sits in full and + # where it is drawn: 1 where the plane holds it exactly, 0 where the node is + # somewhere the plane cannot show. + full <- rowSums(X^2) + q <- rep(NA_real_, length(keep)) + q[keep] <- ifelse(full > 0, rowSums(X[, 1:2, drop = FALSE]^2) / full, + NA_real_) + list(xy = xy, cos2 = q) +} diff --git a/R/layout_grid.R b/R/layout_grid.R deleted file mode 100644 index e9185e9a..00000000 --- a/R/layout_grid.R +++ /dev/null @@ -1,105 +0,0 @@ -#' Layouts for snapping layouts to a grid -#' -#' @description The function uses approximate pattern matching -#' to redistribute coarse layouts on square grid points, while -#' preserving the topological relationships among the nodes (see Inoue et al. 2012). -#' @references -#' Inoue, Kentaro, Shinichi Shimozono, Hideaki Yoshida, and Hiroyuki Kurata. 2012. -#' “Application of Approximate Pattern Matching in Two Dimensional Spaces to Grid Layout for Biochemical Network Maps” edited by J. Bourdon. -#' _PLoS ONE_ 7(6):e37739. -#' \doi{https://doi.org/10.1371/journal.pone.0037739}. -#' @keywords internal -depth_first_recursive_search <- function(layout) { - if("ggraph" %in% class(layout)) layout <- layout$data[,c("x","y")] - layout <- as.data.frame(layout) - dims <- ceiling(2 * sqrt(nrow(layout))) - # evens <- 0:dims[0:dims %% 2 == 0] - vacant_points <- expand.grid(seq.int(0, dims, 1), seq.int(0, dims, 1)) # create options - vacant_points <- vacant_points - floor(dims / 2) # centre options - names(vacant_points) <- c("x", "y") - gridout <- layout[order(abs(layout[,1]) + abs(layout[,2])), ] # sort centroid distance - nodes <- seq_len(nrow(gridout)) - for (i in nodes) { - # Drop the first row (the node's distance to itself, always 0) before - # picking the nearest vacant point. Comparing against the undropped vector - # matched row 1 whenever a grid point coincided exactly with the node, - # giving mindist 0 and a zero-row vacpoint. Two-mode layouts hit this on the - # very first node, since their coordinates are exactly 0 or 1. - dists <- as.matrix(stats::dist(rbind(gridout[i, 1:2], vacant_points), - method = "manhattan"))[-1, 1] - mindist <- which.min(dists) - vacpoint <- vacant_points[mindist, ] - changes <- vacpoint - gridout[i, 1:2] - gridout[nodes >= i, 1] <- gridout[nodes >= i, 1] + - changes[[1]] - gridout[nodes >= i, 2] <- gridout[nodes >= i, 2] + - changes[[2]] - vacant_points <- vacant_points[-mindist, ] - } - gridout[order(row.names(gridout)),] # reorder from centroid - # gridout - # plot(gridout[order(row.names(gridout)),]) -} - -# localmin <- function(layout, graph) { -# repeat { -# f0 <- sum(cost_function(layout, graph)) -# L <- get_vacant_points(layout) -# for (a in seq_len(nrow(layout))) { -# out <- t(apply(L, 1, function(y) { -# layout_new <- layout -# layout_new[a, 1:2] <- y -# c(a, y, sum(cost_function(layout_new, graph))) -# })) -# } -# if (out[which.min(out[, 4]), 4] < f0) { -# layout[out[which.min(out[, 4]), 1], 1:2] <- out[which.min(out[, 4]), 2:3] -# } else{ -# break -# } -# } -# layout -# } -# -# get_vacant_points <- function(layout) { -# all_points <- expand.grid(min(layout$x):max(layout$x), -# min(layout$y):max(layout$y)) -# names(all_points) <- c("x", "y") -# vacant_points <- rbind(all_points, -# layout[, c("x", "y")]) -# vacant_points <- subset(vacant_points, -# !(duplicated(vacant_points) | -# duplicated(vacant_points, fromLast = TRUE))) -# vacant_points -# } -# -# cost_function <- function(layout, graph, max_repulse_distance = max(layout[, 1]) * .75) { -# d <- as.matrix(dist(layout[, 1:2], method = "manhattan")) -# a <- as_matrix(graph) -# i <- diag(nrow(a)) -# m <- a + i -# w <- ifelse(m > 0, 3, -# ifelse(m == 0 & m %*% t(m) > 0, 0, -2)) # only three levels here -# # see Li and Kurata (2005: 2037) for more granulated option -# ifelse(w >= 0, w * d, w * min(d, max_repulse_distance)) -# } -# -# plot_gl <- function(x, tmax, tmin, rmin, fmin, ne, rc, p) { -# l <- index <- a <- NULL # initialize variables to avoid CMD check notes -# x <- as_tidygraph(x) -# lo <- ggraph::create_layout(x, layout = "igraph", algorithm = "randomly") -# lo[, 1] <- round(lo[, 1] * 1000) -# lo[, 2] <- round(lo[, 2] * 1000) -# dists <- as.matrix(dist(lo[, 1:2], method = "manhattan")) -# colMax <- function(data) apply(data, MARGIN = 1, FUN = max, na.rm = TRUE) -# diag(dists) <- NA -# rsep <- l * sum(ifelse(colMax(a / dists - 1) > 0, colMax(a / dists - 1), 0)) -# ggraph::ggraph(x, graph = lo) + -# ggraph::geom_edge_link(ggplot2::aes(alpha = ggplot2::stat(index)), -# show.legend = FALSE) + -# ggraph::geom_node_point() -# } - -.rescale <- function(vector){ - (vector - min(vector)) / (max(vector) - min(vector)) -} diff --git a/R/layout_layered.R b/R/layout_layered.R index 1de5f4be..99e6f0c0 100644 --- a/R/layout_layered.R +++ b/R/layout_layered.R @@ -1,101 +1,624 @@ -#' Layered layout +#' Layered layouts +#' +#' @description +#' These algorithms assign each node to a layer, which becomes one axis, +#' and a position within that layer, which becomes the other. +#' They are recommended for use with `graphr()` or `{ggraph}`, +#' and suit two-mode networks and directed acyclic networks. +#' +#' The four layouts are one engine drawn four ways, +#' and differ only in which axis carries the layers +#' and in how each layer is spread out: +#' +#' | | Layers stacked flat | Layers standing up | +#' |------------------------|---------------------|--------------------| +#' | `alignment = "straight"` | "layered" | "lineage" | +#' | `alignment = "rungs"` | "railway" | "ladder" | +#' +#' That is, the "layered" layout places the first node set along the bottom +#' and the second node set along the top, +#' sequenced and spaced as necessary to minimise tie overlap. +#' The "lineage" layout is the same layout with the axes exchanged, +#' so that successive layers run left to right rather than bottom to top. +#' The "railway" and "ladder" layouts are "layered" and "lineage" +#' with every layer given the same spacing, +#' so that the nodes line up across the layers +#' like the rails and rungs the names describe. #' @name layout_layered -#' @inheritParams layout_matching -#' @param center,circular Extra parameters required for `{tidygraph}` -#' compatibility. -#' @param times Integer of sweeps that the algorithm will pass through. -#' By default 4. -#' @returns Returns a table of coordinates. +#' @template param_ggraphlayouts +#' @param ranks How the layers are assigned: +#' "tight" (the default) chooses the layers that make the total tie length +#' as short as possible, while still pointing every tie down at least one +#' layer; +#' "generation" ranks each node by its distance from a root, so that a layer +#' is a generation, at the cost of some longer ties; +#' "compact" asks `igraph::layout_with_sugiyama()` for the layers. +#' The first two need an acyclic network, and fall back to "compact" where +#' the network is not. +#' Ignored for a two-mode network, whose layers are its modes. +#' +#' A node attribute can be given here instead, either as the name of a +#' numeric node attribute or as a numeric vector as long as the network has +#' nodes. Then the layers are those values, and nodes are placed along that +#' axis in proportion to them rather than at even steps, so that a network +#' of dated nodes is drawn as a timeline. +#' The values run in the same direction as the layers the engine works out: +#' down the page in a "layered" or "railway" layout, and left to right in a +#' "lineage" or "ladder" layout, so that the smallest value comes first. +#' @param alignment How each layer is spread out: +#' "straight" (the default) draws the ties as close to straight as the +#' ordering allows, which groups the nodes that belong together; +#' "rungs" gives every layer the same integer spacing, so that the nodes +#' line up across the layers. +#' @param center Further split a "layered" layout by +#' declaring the "center" argument as the "events", "actors", +#' or by declaring a node name. +#' Defaults to NULL. +#' @param rank Deprecated. Use `ranks` instead, which now takes a node +#' attribute as well as a method. +#' @family mapping +NULL + +#' @rdname layout_layered #' @examples -#' ties <- data.frame( -#' from = c("A", "A", "B", "C", "D", "F", "F", "E"), -#' to = c("B", "C", "D", "E", "E", "E", "G", "G"), -#' stringsAsFactors = FALSE) -#' -#' coords <- layout_tbl_graph_layered(ties, times = 6) -#' coords +#' #graphr(ison_southern_women, layout = "layered", center = "events", +#' # node_color = "type", node_size = 3) #' @export -layout_tbl_graph_layered <- function(.data, - center = NULL, - circular = FALSE, - times = 4) { - ties <- manynet::as_edgelist(.data) - nodes <- unique(c(ties$from, ties$to)) - node_idx <- setNames(seq_along(nodes), nodes) - - # Adjacency and reverse adjacency - adj <- lapply(nodes, function(x) character(0)) - radj <- lapply(nodes, function(x) character(0)) - names(adj) <- names(radj) <- nodes - - for (i in seq_len(nrow(ties))) { - from <- ties$from[i] - to <- ties$to[i] - adj[[from]] <- c(adj[[from]], to) - radj[[to]] <- c(radj[[to]], from) - } - - # Topological sort for layer assignment - in_deg <- sapply(radj, length) - queue <- names(in_deg[in_deg == 0]) - layer <- setNames(rep(NA, length(nodes)), nodes) - current_layer <- 0 - - while (length(queue) > 0) { - next_queue <- character(0) - for (v in queue) { - layer[v] <- current_layer - for (w in adj[[v]]) { - in_deg[w] <- in_deg[w] - 1 - if (in_deg[w] == 0) { - next_queue <- c(next_queue, w) +layout_layered <- function(.data, center = NULL, + ranks = c("tight", "generation", "compact"), + alignment = c("straight", "rungs"), + circular = FALSE, times = 1000) { + if (is.null(center)) { + out <- .to_lo(.layer_axes(.data, ranks = ranks, alignment = alignment, + times = times)) + } else { + if (!manynet::is_twomode(.data)) manynet::snet_abort( + "The {.val layered} layout can only centre on a mode of a two-mode", + "network, but a one-mode network was given.", + "Either drop the {.arg center} argument, or use a two-mode network.") + net <- manynet::as_matrix(.data) + nn <- dim(net)[1] + mm <- dim(net)[2] + if (center == "actors") { + Act <- cbind(rep(1, nrow(net)), .nrm(.rng(nn))) + Evt1 <- cbind(rep(0, ceiling(ncol(net)/2)), .nrm(.rng(ceiling(mm/2)))) + Evt2 <- cbind(rep(2, floor(ncol(net)/2)), .nrm(.rng(floor(mm/2)))) + crd <- rbind(Act, Evt1, Evt2) + crd[which(is.nan(crd))] <- 0.5 + rownames(crd) <- c(dimnames(net)[[1]], dimnames(net)[[2]]) + } else if (center == "events") { + Act1 <- cbind(rep(0, ceiling(nrow(net)/2)), .nrm(.rng(ceiling(nn/2)))) + Act2 <- cbind(rep(2, floor(nrow(net)/2)), .nrm(.rng(floor(nn/2)))) + Evt <- cbind(rep(1, ncol(net)), .nrm(.rng(mm))) + crd <- rbind(Act1, Act2, Evt) + crd[which(is.nan(crd))] <- 0.5 + rownames(crd) <- c(dimnames(net)[[1]], dimnames(net)[[2]]) + } else { + if (center %in% manynet::node_names(.data)) { + side1 <- suppressWarnings(cbind(rep(0, nrow(net)), .nrm(.rng(nn)))) + side2 <- suppressWarnings(cbind(rep(2, ncol(net)), .nrm(.rng(mm)))) + if (any(rownames(net) == center)) { + side1[,1] <- ifelse(rownames(net) == center, 1, side1[,1]) + side1[,2] <- ifelse(rownames(net) == center, 0.5, side1[,2]) + } else { + # The centred node is in the second mode, which `net` holds in its + # columns: comparing the row names here would test the wrong mode + # and recycle a vector of the wrong length into `side2`. + side2[,1] <- ifelse(colnames(net) == center, 1, side2[,1]) + side2[,2] <- ifelse(colnames(net) == center, 0.5, side2[,2]) } + crd <- rbind(side1, side2) + crd[which(is.nan(crd))] <- 0.5 + rownames(crd) <- c(dimnames(net)[[1]], dimnames(net)[[2]]) + } else .abort_no_match(center, manynet::node_names(.data), "center", + what = "node name", + extra_desc = paste("{.val actors} or {.val events}", + "can also be given here,", + "to centre on a whole mode.")) + } + out <- .to_lo(crd) + } + out +} + +#' @rdname layout_layered +#' @export +layout_tbl_graph_layered <- layout_layered + +#' @rdname layout_layered +#' @examples +#' #graphr(ison_southern_women, layout = "lineage") +#' # ison_adolescents |> +#' # mutate(year = rep(c(1985, 1990, 1995, 2000), times = 2)) |> +#' # graphr(layout = "lineage", ranks = "year") +#' @export +layout_lineage <- function(.data, + ranks = c("tight", "generation", "compact"), + alignment = c("straight", "rungs"), + circular = FALSE, times = 1000, rank = NULL){ + ranks <- .absorb_rank(ranks, rank) + # The same coordinates as "layered", with the axes exchanged, so that the + # layers run left to right rather than bottom to top. + lo <- .layer_axes(.data, ranks = ranks, alignment = alignment, times = times) + # The layer axis is negated so that the layers run left to right, as they run + # top to bottom in "layered". + out <- .to_lo(cbind(-lo[, 2], lo[, 1])) + # Nodes the caller gave the same value land on the same coordinate, so they + # need nudging apart. + if (.ranks_given(ranks)) .check_dup(out) else out +} + +#' @rdname layout_layered +#' @export +layout_tbl_graph_lineage <- layout_lineage + +#' @rdname layout_layered +#' @export +layout_railway <- function(.data, + ranks = c("tight", "generation", "compact"), + circular = FALSE, times = 1000) { + # "railway" is "layered" with every layer given the same integer spacing, + # so that the nodes line up across the layers like the rungs of a ladder. + layout_layered(.data, ranks = ranks, alignment = "rungs", times = times) +} + +#' @rdname layout_layered +#' @export +layout_tbl_graph_railway <- layout_railway + +#' @rdname layout_layered +#' @export +layout_ladder <- function(.data, + ranks = c("tight", "generation", "compact"), + circular = FALSE, times = 1000){ + layout_lineage(.data, ranks = ranks, alignment = "rungs", times = times) +} + +#' @rdname layout_layered +#' @export +layout_tbl_graph_ladder <- layout_ladder + +# Axes -------------------------------------------------------------------- + +# The three ways the engine can work the layers out for itself. Anything else +# given to `ranks` is a node attribute holding the layers already. +.rank_methods <- function() c("tight", "generation", "compact") + +# Has the caller given values rather than named a method? The default is the +# full vector of methods, which `match.arg()` would take the first of, so a +# character vector every element of which is a method is a method. +.ranks_given <- function(ranks) { + if (is.null(ranks)) return(FALSE) + !(is.character(ranks) && all(ranks %in% .rank_methods())) +} + +# `rank` named the attribute before `ranks` could take one. Accept it for a +# release, so that a call written against the older argument still draws. +.absorb_rank <- function(ranks, rank) { + if (is.null(rank)) return(ranks) + manynet::snet_warn( + "The {.arg rank} argument is deprecated.", + "Please use {.code ranks} instead, which takes a node attribute", + "as well as one of {.val tight}, {.val generation} or {.val compact}.") + rank +} + +# Turn `ranks` into a method the engine understands and, where the caller gave +# values instead, the numeric layer of each node in the order `.data` holds +# them. +.resolve_ranks <- function(.data, ranks) { + if (!.ranks_given(ranks)) + return(list(method = if (is.null(ranks)) "tight" else ranks[1], + values = NULL)) + n <- as.integer(manynet::net_nodes(.data)) + if (is.character(ranks) && length(ranks) == 1L) { + nm <- .match_name(ranks, igraph::vertex_attr_names(manynet::as_igraph(.data)), + "ranks", what = "node attribute") + values <- as.numeric(manynet::node_attribute(.data, nm)) + } else if (is.numeric(ranks) && length(ranks) == n) { + values <- as.numeric(ranks) + } else .abort_layout_arg("ranks", "lineage", n) + if (anyNA(values)) manynet::snet_abort( + "The {.arg ranks} attribute must be numeric and complete,", + "but it holds missing values.") + # The engine still orders the nodes within each layer, so it is given the + # layers these values imply; the values themselves become the axis below. + list(method = "compact", values = values) +} + +# Map the engine's layer and position onto a pair of axes. A two-mode network +# has no direction to its layers, and its first mode has always been drawn +# along the bottom, so its layers ascend with y. A one-mode network's layers do +# have a direction -- a tie points from the earlier layer to the later -- so +# they descend with y, putting parents above their children. +.layer_axes <- function(.data, ranks, alignment, times) { + g <- manynet::as_igraph(.data) + twomode <- manynet::is_twomode(.data) + spec <- .resolve_ranks(.data, ranks) + layers <- if (!is.null(spec$values)) .compact_ranks(spec$values) + 1L else + if (twomode) ifelse(igraph::V(g)$type, 2, 1) else NULL + lo <- .layer_coords(g, layers = layers, ranks = spec$method, + alignment = alignment, times = times, + pack = !twomode) + x <- lo$pos + y <- if (twomode) lo$rank else -lo$rank + # `as_igraph()` can reorder the nodes of a two-mode network, so the + # coordinates are put back into the order the caller's network holds them in. + if (twomode && "name" %in% igraph::vertex_attr_names(.data)) { + ord <- order(match(igraph::vertex_attr(g, "name"), + igraph::vertex_attr(.data, "name"))) + x <- x[ord] + y <- y[ord] + } + # Values the caller gave are already in that order, and are placed in + # proportion to themselves rather than at even steps. They descend the page + # like the layers the engine works out, so that the smallest value -- the + # earliest date, the first generation -- is at the top. + if (!is.null(spec$values)) y <- -spec$values + if (length(unique(x)) > 1) x <- .rescale(x) + if (length(unique(y)) > 1) y <- .rescale(y) + cbind(x, y) +} + +# Nodes sharing a layer value land on the same coordinate, so nudge them apart. +.check_dup <- function(mat) { + mat$y <- ifelse(duplicated(mat[c('x','y')]), mat$y*0.95, mat$y) + mat +} + +.rng <- function(r) { + if (r == 1L) return(0) + if (r > 1L) { + x <- vector() + x <- append(x, (-1)) + for (i in 1:(r - 1)) x <- append(x, ((-1) + (2L/(r - 1L)) * i)) + return(x * (r/50L)) + } else manynet::snet_abort( + "A layout cannot be built for a negative number of nodes, but {r} was given.") +} + +.nrm <- function(x, digits = 3) { + if (isTRUE(length(x) == 1L) == TRUE) return(x) + if (is.array(x) == TRUE) { + xnorm <- (x[, 1] - min(x[, 1]))/(max(x[, 1]) - min(x[, 1])) + rat <- (max(x[, 1]) - min(x[, 1]))/(max(x[, 2]) - min(x[, 2])) + ynorm <- ((x[, 2] - min(x[, 2]))/(max(x[, 2]) - min(x[, 2]))) * (rat) + ifelse(isTRUE(rat > 0) == FALSE, + ynorm <- ((x[, 2] - min(x[, 2]))/(max(x[, 2]) - + min(x[, 2]))) * (1L/rat), NA) + return(round(data.frame(X = xnorm, Y = ynorm), digits)) + } + else if (is.vector(x) == TRUE) { + return(round((x - min(x))/(max(x) - min(x)), digits)) + } +} + +# Engine ------------------------------------------------------------------ +# +# "layered", "lineage", "railway" and "ladder" are one layout drawn four +# ways. Each node gets a rank, which becomes one axis, and a +# position within its rank, which becomes the other. The members differ only +# in which axis carries the rank and in how a rank is aligned, so the work +# lives here once and each layout is a wrapper over it. +# +# Two costs are minimised, and they are separate problems. +# `.tighten_layers()` shortens the ties by choosing the ranks; +# `.straighten()` shortens them sideways by choosing the positions. + +# Rank each node by its distance from a root, so that a rank is a generation. +# A node is ranked only once every node pointing at it has been, which is what +# makes each tie point down at least one rank. +.rank_layers <- function(g) { + n <- igraph::vcount(g) + rank <- rep(NA_integer_, n) + indeg <- igraph::degree(g, mode = "in") + adj <- lapply(igraph::adjacent_vertices(g, igraph::V(g), mode = "out"), + as.integer) + queue <- which(indeg == 0) + current <- 0L + while (length(queue)) { + rank[queue] <- current + nxt <- integer(0) + for (v in queue) for (w in adj[[v]]) { + indeg[w] <- indeg[w] - 1L + if (indeg[w] == 0L) nxt <- c(nxt, w) + } + queue <- nxt + current <- current + 1L + } + # A node caught in a cycle never has its in-degree fall to zero, so it keeps + # the NA it started with. Give those a rank of their own below the rest, + # rather than letting an NA coordinate reach the drawing. + if (anyNA(rank)) rank[is.na(rank)] <- current + rank +} + +# Shorten the ties by moving nodes down the ranks. `.rank_layers()` puts every +# node as high as it can go, which pins a parent whose only child is several +# generations down to the top rank and manufactures a long tie to reach it. +# Each node moves instead to the median of its neighbours' ranks, clamped to +# the range its own ties leave it, until nothing moves. The clamp keeps every +# intermediate state feasible, so the loop can stop at any point. +.tighten_layers <- function(g, rank = NULL, times = 50) { + if (is.null(rank)) rank <- .rank_layers(g) + n <- igraph::vcount(g) + if (n == 0L) return(rank) + parents <- lapply(igraph::adjacent_vertices(g, igraph::V(g), mode = "in"), + as.integer) + children <- lapply(igraph::adjacent_vertices(g, igraph::V(g), mode = "out"), + as.integer) + for (i in seq_len(times)) { + moved <- FALSE + for (v in seq_len(n)) { + up <- parents[[v]] + down <- children[[v]] + if (!length(up) && !length(down)) next + lower <- if (length(up)) max(rank[up]) + 1L else -Inf + upper <- if (length(down)) min(rank[down]) - 1L else Inf + if (lower > upper) next + want <- stats::median(rank[c(up, down)]) + new <- round(min(max(want, lower), upper)) + if (is.finite(new) && new != rank[v]) { + rank[v] <- as.integer(new) + moved <- TRUE } } - queue <- next_queue - current_layer <- current_layer + 1 - } - - coords <- data.frame(name = names(layer), layer = layer, stringsAsFactors = FALSE) - layer_map <- split(coords$name, coords$layer) - - # Initialize x positions - x_pos <- lapply(layer_map, function(n) setNames(seq_along(n), n)) - - # Sweep function - barycenter_sort <- function(layer_nodes, neighbors_pos) { - bc <- sapply(layer_nodes, function(n) { - neighbors <- neighbors_pos[[n]] - if (length(neighbors) == 0) return(Inf) - mean(unlist(neighbors)) - }) - sorted <- layer_nodes[order(bc)] - setNames(seq_along(sorted), sorted) - } - - for (s in seq_len(times)) { - # Forward sweep (top-down), sorting by the positions (not names) of - # each node's neighbours in the adjacent layer - for (l in 2:length(layer_map)) { - prev <- x_pos[[l - 1]] - cur <- layer_map[[l]] - rev_pos <- lapply(cur, function(n) - unname(prev[radj[[n]][radj[[n]] %in% names(prev)]])) - x_pos[[l]] <- barycenter_sort(cur, setNames(rev_pos, cur)) + if (!moved) break + } + .compact_ranks(rank) +} + +# `igraph::layout_with_sugiyama()` numbers its layers the other way up from +# `.rank_layers()`, giving a source the highest layer rather than the lowest. +# Turn the ranks over where the ties mostly point up them, so that whichever +# rule assigned them, rank 0 is where the ties start. +.orient_ranks <- function(g, rank) { + el <- igraph::as_edgelist(g, names = FALSE) + if (!nrow(el)) return(rank) + if (mean(rank[el[, 2]] - rank[el[, 1]]) < 0) rank <- max(rank) - rank + rank +} + +# Ranks are used as indices further on, so close any gaps the tightening left. +.compact_ranks <- function(rank) as.integer(match(rank, sort(unique(rank))) - 1L) + +# Place one rank as close as it can get to where its nodes want to be, given +# the order they are already in and a minimum separation between neighbours. +# Subtracting `k * sep` turns the separation constraints into a plain +# monotonicity constraint, and isotonic regression solves that exactly, so +# there is no iteration to tune and no drift towards either side. +.place_layer <- function(want, sep = 1) { + if (length(want) < 2L) return(want) + k <- seq_along(want) + stats::isoreg(k, want - k * sep)$yf + k * sep +} + +# Straighten the ties. Each node is pulled towards the median position of its +# neighbours in the rank above or below, alternately, and each rank is then +# placed by `.place_layer()`, which keeps the order the crossing-minimisation +# sweeps found. A node with no neighbours in the direction being swept stays +# where it is, so it is not dragged out of its family. +.straighten <- function(g, pos, rank, sweeps = 20, sep = 1) { + ranks <- sort(unique(rank)) + if (length(ranks) < 2L) return(pos) + parents <- lapply(igraph::adjacent_vertices(g, igraph::V(g), mode = "in"), + as.integer) + children <- lapply(igraph::adjacent_vertices(g, igraph::V(g), mode = "out"), + as.integer) + for (s in seq_len(sweeps)) { + downwards <- s %% 2L == 1L + order_r <- if (downwards) ranks[-1] else rev(ranks)[-1] + look <- if (downwards) parents else children + for (r in order_r) { + idx <- which(rank == r) + if (!length(idx)) next + idx <- idx[order(pos[idx])] + want <- vapply(idx, function(v) { + nb <- look[[v]] + if (!length(nb)) pos[v] else stats::median(pos[nb]) + }, numeric(1)) + pos[idx] <- .place_layer(want, sep) + } + } + pos +} + +# Give every rank the same integer spacing, so that the ranks line up like the +# rungs of a ladder. This is what "railway" and "ladder" ask for, and it is not +# what `snap = TRUE` does: that snaps the whole plot to a square grid. +.align_rungs <- function(pos, rank) { + for (r in unique(rank)) { + idx <- which(rank == r) + pos[idx] <- rank(pos[idx], ties.method = "first") + } + pos +} + +# Lay each weakly connected component out on its own and pack the results side +# by side, largest first. Ranks stay on one shared scale, so the components +# share their rows rather than floating; only the positions are offset. This is +# what keeps one family from being drawn through another. +.pack_components <- function(g, FUN, gap = 0.05) { + memb <- igraph::components(g, mode = "weak")$membership + if (length(unique(memb)) < 2L) return(FUN(g, seq_len(igraph::vcount(g)))) + n <- igraph::vcount(g) + out <- data.frame(pos = numeric(n), rank = numeric(n)) + parts <- list() + total <- 0 + for (cc in names(sort(table(memb), decreasing = TRUE))) { + idx <- which(memb == as.integer(cc)) + co <- FUN(igraph::induced_subgraph(g, idx), idx) + parts[[cc]] <- list(idx = idx, co = co) + total <- total + diff(range(co$pos)) + 1 + } + offset <- 0 + for (part in parts) { + out$pos[part$idx] <- part$co$pos - min(part$co$pos) + offset + out$rank[part$idx] <- part$co$rank + offset <- offset + diff(range(part$co$pos)) + 1 + gap * total + } + out +} + +# Rank and position every node, in node order. `ranks` chooses how the ranks +# are assigned and `alignment` how a rank is spread out; the caller decides +# which axis each becomes. +.layer_coords <- function(.data, layers = NULL, + ranks = c("tight", "generation", "compact"), + alignment = c("straight", "rungs"), + times = 1000, sweeps = 20, pack = TRUE, ...) { + ranks <- match.arg(ranks) + alignment <- match.arg(alignment) + g <- manynet::as_igraph(.data) + if (is.null(layers) && ranks != "compact" && !manynet::is_acyclic(g)) { + manynet::snet_info( + "The {.val {ranks}} ranks need an acyclic network,", + "so {.val compact} ranks are used instead.", ...) + ranks <- "compact" + } + one <- function(sub, idx) { + # `layers`, where given, is indexed over the whole network, so it is cut + # down to the component being laid out. + lo <- .sugiyama_layout(sub, layers = .layers_for(sub, layers[idx], ranks), + times = times) + rank <- .compact_ranks(lo[, 2]) + # Layers the caller gave are used as they are; ones we derived are turned + # the right way up first. + if (is.null(layers)) rank <- .orient_ranks(sub, rank) + coords <- data.frame(pos = as.numeric(lo[, 1]), rank = rank) + coords$pos <- if (alignment == "rungs") { + .align_rungs(coords$pos, coords$rank) + } else .straighten(sub, coords$pos, coords$rank, sweeps = sweeps) + # Centre the component as a whole. Centring each rank separately would + # shift the ranks against each other and undo the straightening. + coords$pos <- coords$pos - mean(range(coords$pos)) + coords + } + out <- if (pack) .pack_components(g, one) else + one(g, seq_len(igraph::vcount(g))) + out$pos <- out$pos - mean(range(out$pos)) + out +} + +# Where the layers are given -- the two modes of a two-mode network, say -- +# they are used as they are, and the ranking rules do not apply. +.layers_for <- function(g, layers, ranks) { + if (!is.null(layers)) return(layers) + switch(ranks, + tight = .tighten_layers(g), + generation = .rank_layers(g), + compact = NULL) +} + +# Sugiyama-style layout with dummy nodes and barycenter heuristic +# for better edge crossing minimization +.sugiyama_layout <- function(g, layers = NULL, times = 100) { + n <- igraph::vcount(g) + el <- igraph::as_edgelist(g, names = FALSE) + # Layer assignment + if (is.null(layers)) { + lo <- igraph::layout_with_sugiyama(g, maxiter = times) + node_layer <- lo$layout[, 2] + } else { + node_layer <- layers + } + layer_vals <- sort(unique(node_layer)) + n_layers <- length(layer_vals) + if (n_layers < 2) { + return(cbind(seq_len(n), node_layer)) + } + # Map layers to 0-based indices (used as list keys offset by 1) + layer_idx <- match(node_layer, layer_vals) - 1L + # Build adjacency between original nodes + adj <- vector("list", n) + radj <- vector("list", n) + for (i in seq_len(n)) { adj[[i]] <- integer(0); radj[[i]] <- integer(0) } + if (nrow(el) > 0) { + for (i in seq_len(nrow(el))) { + u <- el[i, 1]; v <- el[i, 2] + adj[[u]] <- c(adj[[u]], v) + radj[[v]] <- c(radj[[v]], u) + } + } + # Insert dummy nodes for edges spanning multiple layers + dummy_id <- n + # For barycenter, we need per-layer node lists and inter-layer edges + all_layer <- layer_idx # will grow with dummies + # Build inter-layer edges (only between adjacent layers) + inter_edges <- list() + if (nrow(el) > 0) { + for (i in seq_len(nrow(el))) { + u <- el[i, 1]; v <- el[i, 2] + lu <- layer_idx[u]; lv <- layer_idx[v] + if (lu == lv) next + # Ensure direction goes from lower layer to higher + if (lu > lv) { tmp <- u; u <- v; v <- tmp; tmp <- lu; lu <- lv; lv <- tmp } + if (lv - lu == 1) { + inter_edges[[length(inter_edges) + 1]] <- c(u, v) + } else { + # Insert dummy nodes + prev <- u + for (k in (lu + 1):(lv - 1)) { + dummy_id <- dummy_id + 1 + all_layer <- c(all_layer, k) + inter_edges[[length(inter_edges) + 1]] <- c(prev, dummy_id) + prev <- dummy_id + } + inter_edges[[length(inter_edges) + 1]] <- c(prev, v) + } + } + } + total_nodes <- length(all_layer) + if (length(inter_edges) == 0) { + return(cbind(seq_len(n), node_layer)) + } + inter_edges_mat <- do.call(rbind, inter_edges) + # Build per-layer node lists + layer_nodes <- lapply(0:(n_layers - 1), function(k) which(all_layer == k)) + # Initialize x positions: sequential within each layer + x_pos <- rep(0, total_nodes) + for (k in seq_along(layer_nodes)) { + nodes_in_layer <- layer_nodes[[k]] + x_pos[nodes_in_layer] <- seq_along(nodes_in_layer) + } + # Build forward/backward adjacency for the expanded graph + fwd_adj <- vector("list", total_nodes) + bwd_adj <- vector("list", total_nodes) + for (i in seq_len(total_nodes)) { fwd_adj[[i]] <- integer(0); bwd_adj[[i]] <- integer(0) } + if (!is.null(inter_edges_mat) && nrow(inter_edges_mat) > 0) { + for (i in seq_len(nrow(inter_edges_mat))) { + u <- inter_edges_mat[i, 1]; v <- inter_edges_mat[i, 2] + fwd_adj[[u]] <- c(fwd_adj[[u]], v) + bwd_adj[[v]] <- c(bwd_adj[[v]], u) + } + } + # Barycenter crossing minimization sweeps + for (iter in seq_len(times)) { + # Forward sweep: layer 1 to n_layers-1 + for (k in 2:n_layers) { + nodes_k <- layer_nodes[[k]] + if (length(nodes_k) <= 1) next + bc <- sapply(nodes_k, function(nd) { + neighbors <- bwd_adj[[nd]] + if (length(neighbors) == 0) return(x_pos[nd]) + mean(x_pos[neighbors]) + }) + ord <- order(bc) + x_pos[nodes_k[ord]] <- seq_along(nodes_k) } - # Backward sweep (bottom-up) - for (l in (length(layer_map) - 1):1) { - next_ <- x_pos[[l + 1]] - cur <- layer_map[[l]] - fwd_pos <- lapply(cur, function(n) - unname(next_[adj[[n]][adj[[n]] %in% names(next_)]])) - x_pos[[l]] <- barycenter_sort(cur, setNames(fwd_pos, cur)) + # Backward sweep: layer n_layers-2 to 0 + for (k in (n_layers - 1):1) { + nodes_k <- layer_nodes[[k]] + if (length(nodes_k) <= 1) next + bc <- sapply(nodes_k, function(nd) { + neighbors <- fwd_adj[[nd]] + if (length(neighbors) == 0) return(x_pos[nd]) + mean(x_pos[neighbors]) + }) + ord <- order(bc) + x_pos[nodes_k[ord]] <- seq_along(nodes_k) } } - - # Convert x_pos list into flat x-coordinates - coords$x <- unlist(unname(x_pos))[coords$name] - coords$y <- max(coords$layer) - coords$layer - rownames(coords) <- coords$name - coords[ , c("x", "y")] -} \ No newline at end of file + # Extract coordinates for original nodes only + cbind(x_pos[seq_len(n)], node_layer) +} diff --git a/R/layout_levels.R b/R/layout_levels.R new file mode 100644 index 00000000..20a87538 --- /dev/null +++ b/R/layout_levels.R @@ -0,0 +1,159 @@ +#' Levels layout +#' +#' @description +#' The "levels" layout draws each level of a multilevel network +#' as a plane of its own, projected at an angle, +#' with the ties within each level drawn on its plane +#' and the ties between levels drawn between them. +#' +#' Note that `{graphlayouts}` offers a layout of the same idea under the +#' name "multilevel". This one is named for its `level` argument. +#' @name layout_levels +#' @template param_ggraphlayouts +#' @param level A node attribute or a vector to hierarchically order levels. +#' By default the levels are those already recorded in a "lvl" node attribute, +#' as `manynet::to_multilevel()` writes, or, for a two-mode network, +#' the two modes, with whichever mode holds the ties within itself +#' placed at the first level. +#' @param method How the levels should be laid out: +#' "all" (the default) lays every level out at once, +#' "separate" lays each level out independently, +#' and "fix1" and "fix2" lay out the first or second level respectively +#' and derive the other from it. +#' Note that all but "all" require ties within the levels they lay out. +#' @param FUN1,FUN2 The layout functions used for the first and second levels +#' respectively by the "separate", "fix1" and "fix2" methods. +#' By default both are `graphlayouts::layout_with_stress()`. +#' @param alpha,beta The angles, in degrees, at which the levels +#' are projected onto the plane. +#' @family mapping +#' @examples +#' # fict_marvel interlocks a one-mode layer of ties among its characters +#' # with a two-mode layer of their affiliations, so it is laid out this way +#' # by default; the levels need not be named. +#' graphr(manynet::fict_marvel, labels = FALSE) +#' @export +layout_levels <- function(.data, level, + method = c("all", "separate", "fix1", "fix2"), + circular = FALSE, times = 1, alpha = 25, beta = 45, + FUN1 = graphlayouts::layout_with_stress, + FUN2 = graphlayouts::layout_with_stress) { + method <- .check_choice(method, c("all", "separate", "fix1", "fix2"), "method") + # Coerced up front, as the other layouts do, so that a network given in + # another form -- such as the list-based class manynet 2.3.0 introduced -- + # reaches the igraph functions below as a graph, and `length()` counts its + # nodes rather than the parts the object is built from. + .data <- manynet::as_igraph(.data) + if (missing(level)) { + level <- .infer_level(.data) + } else { + if (length(level) > 1 & length(level) != length(.data)) { + .abort_layout_arg("level", "levels", length(.data)) + } else if (length(level) != length(.data)) { + level <- .match_name(level, igraph::vertex_attr_names(.data), + "level", what = "node attribute") + level <- manynet::node_attribute(.data, level) + } + } + level <- .as_level(level) + # `layout_as_multilevel()` lays each of its "separate", "fix1" and "fix2" + # variants out level by level, dropping isolates from each level's subgraph. + # A level whose nodes are tied only to the other level therefore leaves an + # empty subgraph, which it reports as an obscure indexing error. + if (method != "all") .check_level_ties(.data, level, method) + .check_level_reach(.data) + out <- .drop_unusable_weights(.data) + out <- igraph::set_vertex_attr(out, "lvl", value = level) + out <- graphlayouts::layout_as_multilevel(out, type = method, + FUN1 = FUN1, FUN2 = FUN2, + alpha = alpha, beta = beta) + .to_lo(out) +} + +# `graphlayouts::layout_as_multilevel()` reads levels from a 'lvl' node +# attribute holding consecutive integers from 1. Anything else -- a factor, a +# character vector, the logical 'type' of a two-mode network -- has to be coded +# into one. A numeric attribute keeps its own ordering rather than being +# re-coded, so that levels given as e.g. c(3, 1, 2) are not silently reordered. +.as_level <- function(level) { + if (is.numeric(level)) as.integer(level) else as.integer(as.factor(level)) +} + +# Levels for `layout_levels()` when none were given. A network already +# converted by `manynet::to_multilevel()` carries them in 'lvl'; a two-mode +# network has them implied by its modes. +.infer_level <- function(.data) { + if ("lvl" %in% igraph::vertex_attr_names(.data)) { + manynet::snet_info("Using the levels found in the {.val lvl} node attribute.") + return(igraph::vertex_attr(.data, "lvl")) + } + if (!manynet::is_twomode(.data)) + .abort_layout_arg("level", "levels", length(.data)) + mode <- manynet::node_is_mode(.data) + within <- !manynet::tie_is_twomode(.data) + # The mode holding the within-mode ties is placed at the first level, so that + # whichever level has a structure of its own is the one laid out in the plane + # rather than fanned out from the other. Which mode that is varies by network, + # so it is read off the ties rather than assumed to be the first. + base <- FALSE + if (any(within)) { + el <- igraph::as_edgelist(.data, names = FALSE) + base <- as.logical(names(sort(table(mode[el[within, 1]]), + decreasing = TRUE))[1]) + } + ifelse(mode == base, 1L, 2L) +} + +# `layout_as_multilevel()` orients its levels by the shortest paths between +# them, and those are infinite between components, which leaves it minimising +# a stress that is never less than any other. It fails part way through, with +# R's own "missing value where TRUE/FALSE needed". +.check_level_reach <- function(.data) { + if (manynet::is_connected(.data)) return(invisible(NULL)) + manynet::snet_abort( + "The {.val levels} layout places the levels by the distances between", + "them, so it can only be used on a connected network,", + "but this network has {igraph::count_components(.data)} components.", + "Please use {.code manynet::to_giant()} to keep only the largest,", + "or choose another layout.") +} + +# Those same shortest paths come from `igraph::distances()`, which reads any +# 'weight' tie attribute and rejects one holding negative values outright +# ("Negative cycle detected while calculating shortest paths"). Weights that +# cannot be read as distances are dropped, so that the levels are placed by +# structure alone rather than the layout failing. +.drop_unusable_weights <- function(.data) { + if (!"weight" %in% igraph::edge_attr_names(.data)) return(.data) + weights <- igraph::edge_attr(.data, "weight") + if (all(weights > 0, na.rm = TRUE)) return(.data) + manynet::snet_info( + "Ignoring the tie weights, because the {.val levels} layout places", + "the levels by the distances between them and some weights are not", + "positive.") + igraph::delete_edge_attr(.data, "weight") +} + +.check_level_ties <- function(.data, level, method) { + # "separate" lays out both levels independently and so needs ties within + # each; "fix1" derives level 2 from level 1 and so needs only level 1's. + needed <- switch(method, separate = c(1L, 2L), fix1 = 1L, fix2 = 2L) + el <- igraph::as_edgelist(.data, names = FALSE) + within <- level[el[, 1]] == level[el[, 2]] + empty <- needed[!vapply(needed, function(l) + any(within & level[el[, 1]] == l), logical(1))] + if (!length(empty)) return(invisible(NULL)) + # Written out rather than pluralised, since the quantity that matters is how + # many levels are empty while the value reported is which they are. + which_levels <- paste(empty, collapse = " and ") + manynet::snet_abort( + "The {.val {method}} method for the {.val levels} layout lays out", + "each level on its own, but there are no ties within level", + "{which_levels} of this network to lay out.", + "Please use {.code method = \"all\"} to lay every level out together.") +} + + +#' @rdname layout_levels +#' @export +layout_tbl_graph_levels <- layout_levels diff --git a/R/layout_matching.R b/R/layout_matching.R index ef793ba9..6e1024ca 100644 --- a/R/layout_matching.R +++ b/R/layout_matching.R @@ -3,17 +3,18 @@ #' @description #' This layout works to position nodes opposite their matching nodes. #' See `manynet::to_matching()` for more details on the matching procedure. -#' @param .data Some `{manynet}` compatible network data. -#' @param center,circular,times Extra parameters required for `{tidygraph}` -#' compatibility. -#' @returns Returns a table of nodes' x and y coordinates. +#' @template param_ggraphlayouts +#' @param center Required for `{ggraph}` compatibility, and not used here. +#' @family mapping #' @export -layout_tbl_graph_matching <- function(.data, - center = NULL, - circular = FALSE, - times = 1) { - hlay <- layout_tbl_graph_hierarchy(.data) +layout_matching <- function(.data, center = NULL, + circular = FALSE, times = 1) { + hlay <- layout_tbl_graph_layered(.data) matchd <- manynet::as_edgelist(manynet::to_unnamed(manynet::to_matching(.data))) hlay[matchd$to,"x"] <- hlay[matchd$from,"x"] hlay -} \ No newline at end of file +} + +#' @rdname layout_matching +#' @export +layout_tbl_graph_matching <- layout_matching diff --git a/R/layout_partition.R b/R/layout_partition.R deleted file mode 100644 index 7000cd6f..00000000 --- a/R/layout_partition.R +++ /dev/null @@ -1,532 +0,0 @@ -#' Layout algorithms based on bi- or other partitions -#' -#' @description -#' These algorithms layout networks based on two or more partitions, -#' and are recommended for use with `graphr()` or `{ggraph}`. -#' -#' The "hierarchy" layout layers the first node set along the bottom, -#' and the second node set along the top, -#' sequenced and spaced as necessary to minimise edge overlap. -#' The "alluvial" layout is similar to "hierarchy", -#' but places successive layers horizontally rather than vertically. -#' The "railway" layout is similar to "hierarchy", -#' but nodes are aligned across the layers. -#' The "ladder" layout is similar to "railway", -#' but places successive layers horizontally rather than vertically. -#' The "concentric" layout places a "hierarchy" layout -#' around a circle, with successive layers appearing as concentric circles. -#' The "multilevel" layout places successive layers as multiple levels. -#' The "lineage" layout ranks nodes in Y axis according to values. -#' @name layout_partition -#' @inheritParams layout_layered -#' @param circular Should the layout be transformed into a radial representation. -#' Only possible for some layouts. Defaults to FALSE. -#' @param times Maximum number of iterations, where appropriate -#' @param radius A vector of radii at which the concentric circles -#' should be located for "concentric" layout. -#' By default this is equal placement around an empty centre, -#' unless one (the core) is a single node, -#' in which case this node occupies the centre of the graph. -#' @param order.by An attribute label indicating the (decreasing) order -#' for the nodes around the circles for "concentric" layout. -#' By default ordering is given by a bipartite placement that reduces -#' the number of edge crossings. -#' @param membership A node attribute or a vector to draw concentric circles -#' for "concentric" layout. -#' @param center Further split "hierarchical" layouts by -#' declaring the "center" argument as the "events", "actors", -#' or by declaring a node name in hierarchy layout. -#' Defaults to NULL. -#' @param level A node attribute or a vector to hierarchically order levels for -#' "multilevel" layout. -#' @param rank A numerical node attribute to place nodes in Y axis -#' according to values for "lineage" layout. -#' @family mapping -#' @source -#' Diego Diez, Andrew P. Hutchins and Diego Miranda-Saavedra. 2014. -#' "Systematic identification of transcriptional regulatory modules from -#' protein-protein interaction networks". -#' _Nucleic Acids Research_, 42 (1) e6. -NULL - -#' @rdname layout_partition -#' @examples -#' #graphr(ison_southern_women, layout = "concentric", membership = "type", -#' # node_color = "type", node_size = 3) -#' @export -layout_concentric <- function(.data, membership, - radius = NULL, - order.by = NULL, - circular = FALSE, times = 1000) { - if (any(igraph::vertex_attr(.data, "name") == "")) { - ll <- unlist(lapply(seq_len(length(.data)), function(x) { - ifelse(igraph::vertex_attr(.data, "name")[x] == "", - paste0("ramdom", x), igraph::vertex_attr(.data, "name")[x]) - })) - .data <- igraph::set_vertex_attr(.data, "name", value = ll) - } - if (missing(membership)) { - if (manynet::is_twomode(.data)) membership <- manynet::node_is_mode(.data) else - .abort_layout_arg("membership", "concentric", length(.data)) - } else { - if (length(membership) > 1 & length(membership) != length(.data)) { - .abort_layout_arg("membership", "concentric", length(.data)) - } else if (length(membership) != length(.data)) { - membership <- .match_name(membership, igraph::vertex_attr_names(.data), - "membership", what = "node attribute") - membership <- manynet::node_attribute(.data, membership) - } - } - names(membership) <- manynet::node_names(.data) - membership <- to_list(membership) - all_c <- unlist(membership, use.names = FALSE) - if (any(table(all_c) > 1)) { - duplicated_nodes <- names(which(table(all_c) > 1)) - manynet::snet_abort( - "The {.val concentric} layout draws each node in one circle only,", - "but {.val {duplicated_nodes}} appear{?s} in more than one.", - "Please check that {.arg membership} gives each node a single group.") - } - if (manynet::is_labelled(.data)) all_n <- manynet::node_names(.data) else - all_n <- 1:manynet::net_nodes(.data) - sel_other <- all_n[!all_n %in% all_c] - if (length(sel_other) > 0) membership[[length(membership) + 1]] <- sel_other - if (is.null(radius)) { - radius <- seq(0, 1, 1/(length(membership))) - if (length(membership[[1]]) == 1) - radius <- radius[-length(radius)] else radius <- radius[-1] - } - if (!is.null(order.by)) { - order.values <- lapply(order.by, - function(b) manynet::node_attribute(.data, b)) - } else { - if (manynet::is_twomode(.data) & length(membership) == 2) { - xnet <- manynet::as_matrix(manynet::to_multilevel(.data))[membership[[2-1]], - membership[[2]]] - lo <- layout_tbl_graph_hierarchy(manynet::as_igraph(xnet, twomode = TRUE)) - lo$names <- manynet::node_names(.data) - if (ncol(lo) == 2) lo[,1] <- seq_len(dim(lo)[1]) - order.values <- lapply(1:0, function(x) - if(ncol(lo) >= 3) sort(lo[lo[,2] == x,])[,3] - else sort(lo[lo[,2] == x,1])) - } else order.values <- membership[order(sapply(membership, length))] - # order.values <- getNNvec(.data, members) - } - res <- matrix(NA, nrow = length(all_n), ncol = 2) - for (k in seq_along(membership)) { - r <- radius[k] - l <- order.values[[k]] - if(manynet::is_labelled(.data)) - l <- match(l, manynet::node_names(.data)) - res[l, ] <- getCoordinates(l, r) - } - .to_lo(res) -} - -#' @rdname layout_partition -#' @export -layout_tbl_graph_concentric <- layout_concentric - -#' @rdname layout_partition -#' @examples -#' #graphr(ison_lotr, layout = "multilevel", -#' # node_color = "Race", level = "Race", node_size = 3) -#' @export -layout_multilevel <- function(.data, level, circular = FALSE) { - if (missing(level)) { - if (any(grepl("lvl", names(manynet::node_attribute(.data))))) { - manynet::snet_info("Level attribute 'lvl' found in data.") - } else { - .abort_layout_arg("level", "multilevel", length(.data)) - } - } else { - if (length(level) > 1 & length(level) != length(.data)) { - .abort_layout_arg("level", "multilevel", length(.data)) - } else if (length(level) != length(.data)) { - level <- .match_name(level, igraph::vertex_attr_names(.data), - "level", what = "node attribute") - level <- as.factor(manynet::node_attribute(.data, level)) - } - } - out <- igraph::set_vertex_attr(.data, "lvl", value = level) - out <- graphlayouts::layout_as_multilevel(out, alpha = 25) - .to_lo(out) -} - -#' @rdname layout_partition -#' @export -layout_tbl_graph_multilevel <- layout_multilevel - -#' @rdname layout_partition -#' @examples -#' # ison_adolescents %>% -#' # mutate(year = rep(c(1985, 1990, 1995, 2000), times = 2), -#' # cut = node_is_cutpoint(ison_adolescents)) %>% -#' # graphr(layout = "lineage", rank = "year", node_color = "cut", -#' # node_size = migraph::node_degree(ison_adolescents)*10) -#' @export -layout_lineage <- function(.data, rank, circular = FALSE) { - # Without this the missing argument surfaces further down as R's own - # "argument "rank" is missing, with no default". - if (missing(rank)) .abort_layout_arg("rank", "lineage", length(.data)) - if (length(rank) > 1 & length(rank) != length(.data)) { - .abort_layout_arg("rank", "lineage", length(.data)) - } else if (length(rank) != length(.data)) { - rank <- .match_name(rank, igraph::vertex_attr_names(.data), - "rank", what = "node attribute") - rank <- as.numeric(manynet::node_attribute(.data, rank)) - } - out <- layout_tbl_graph_alluvial( - manynet::as_igraph(mutate(.data, type = ifelse( - rank > mean(rank), TRUE, FALSE)), twomode = TRUE)) - out$x <- .rescale(rank) - .check_dup(out) -} - -#' @rdname layout_partition -#' @export -layout_tbl_graph_lineage <- layout_lineage - -.rescale <- function(vector){ - (vector - min(vector)) / (max(vector) - min(vector)) -} - -# Sugiyama-style layout with dummy nodes and barycenter heuristic -# for better edge crossing minimization -.sugiyama_layout <- function(g, layers = NULL, times = 100) { - n <- igraph::vcount(g) - el <- igraph::as_edgelist(g, names = FALSE) - # Layer assignment - if (is.null(layers)) { - lo <- igraph::layout_with_sugiyama(g, maxiter = times) - node_layer <- lo$layout[, 2] - } else { - node_layer <- layers - } - layer_vals <- sort(unique(node_layer)) - n_layers <- length(layer_vals) - if (n_layers < 2) { - return(cbind(seq_len(n), node_layer)) - } - # Map layers to 0-based indices (used as list keys offset by 1) - layer_idx <- match(node_layer, layer_vals) - 1L - # Build adjacency between original nodes - adj <- vector("list", n) - radj <- vector("list", n) - for (i in seq_len(n)) { adj[[i]] <- integer(0); radj[[i]] <- integer(0) } - if (nrow(el) > 0) { - for (i in seq_len(nrow(el))) { - u <- el[i, 1]; v <- el[i, 2] - adj[[u]] <- c(adj[[u]], v) - radj[[v]] <- c(radj[[v]], u) - } - } - # Insert dummy nodes for edges spanning multiple layers - dummy_id <- n - # For barycenter, we need per-layer node lists and inter-layer edges - all_layer <- layer_idx # will grow with dummies - # Build inter-layer edges (only between adjacent layers) - inter_edges <- list() - if (nrow(el) > 0) { - for (i in seq_len(nrow(el))) { - u <- el[i, 1]; v <- el[i, 2] - lu <- layer_idx[u]; lv <- layer_idx[v] - if (lu == lv) next - # Ensure direction goes from lower layer to higher - if (lu > lv) { tmp <- u; u <- v; v <- tmp; tmp <- lu; lu <- lv; lv <- tmp } - if (lv - lu == 1) { - inter_edges[[length(inter_edges) + 1]] <- c(u, v) - } else { - # Insert dummy nodes - prev <- u - for (k in (lu + 1):(lv - 1)) { - dummy_id <- dummy_id + 1 - all_layer <- c(all_layer, k) - inter_edges[[length(inter_edges) + 1]] <- c(prev, dummy_id) - prev <- dummy_id - } - inter_edges[[length(inter_edges) + 1]] <- c(prev, v) - } - } - } - total_nodes <- length(all_layer) - if (length(inter_edges) == 0) { - return(cbind(seq_len(n), node_layer)) - } - inter_edges_mat <- do.call(rbind, inter_edges) - # Build per-layer node lists - layer_nodes <- lapply(0:(n_layers - 1), function(k) which(all_layer == k)) - # Initialize x positions: sequential within each layer - x_pos <- rep(0, total_nodes) - for (k in seq_along(layer_nodes)) { - nodes_in_layer <- layer_nodes[[k]] - x_pos[nodes_in_layer] <- seq_along(nodes_in_layer) - } - # Build forward/backward adjacency for the expanded graph - fwd_adj <- vector("list", total_nodes) - bwd_adj <- vector("list", total_nodes) - for (i in seq_len(total_nodes)) { fwd_adj[[i]] <- integer(0); bwd_adj[[i]] <- integer(0) } - if (!is.null(inter_edges_mat) && nrow(inter_edges_mat) > 0) { - for (i in seq_len(nrow(inter_edges_mat))) { - u <- inter_edges_mat[i, 1]; v <- inter_edges_mat[i, 2] - fwd_adj[[u]] <- c(fwd_adj[[u]], v) - bwd_adj[[v]] <- c(bwd_adj[[v]], u) - } - } - # Barycenter crossing minimization sweeps - for (iter in seq_len(times)) { - # Forward sweep: layer 1 to n_layers-1 - for (k in 2:n_layers) { - nodes_k <- layer_nodes[[k]] - if (length(nodes_k) <= 1) next - bc <- sapply(nodes_k, function(nd) { - neighbors <- bwd_adj[[nd]] - if (length(neighbors) == 0) return(x_pos[nd]) - mean(x_pos[neighbors]) - }) - ord <- order(bc) - x_pos[nodes_k[ord]] <- seq_along(nodes_k) - } - # Backward sweep: layer n_layers-2 to 0 - for (k in (n_layers - 1):1) { - nodes_k <- layer_nodes[[k]] - if (length(nodes_k) <= 1) next - bc <- sapply(nodes_k, function(nd) { - neighbors <- fwd_adj[[nd]] - if (length(neighbors) == 0) return(x_pos[nd]) - mean(x_pos[neighbors]) - }) - ord <- order(bc) - x_pos[nodes_k[ord]] <- seq_along(nodes_k) - } - } - # Extract coordinates for original nodes only - cbind(x_pos[seq_len(n)], node_layer) -} - -#' @rdname layout_partition -#' @examples -#' #graphr(ison_southern_women, layout = "hierarchy", center = "events", -#' # node_color = "type", node_size = 3) -#' @export -layout_hierarchy <- function(.data, center = NULL, - circular = FALSE, times = 1000) { - if (is.null(center)) { - g <- manynet::as_igraph(.data) - if (manynet::is_twomode(.data)) { - layers <- ifelse(igraph::V(g)$type, 2, 1) - } else { - layers <- NULL - } - lo <- .sugiyama_layout(g, layers = layers, times = times) - nodeX <- lo[, 1] - nodeY <- lo[, 2] - if (length(unique(nodeX)) > 1) nodeX <- .rescale(nodeX) - if (length(unique(nodeY)) > 1) nodeY <- .rescale(nodeY) - if (manynet::is_twomode(.data) & "name" %in% igraph::vertex_attr_names(.data)) { - names <- igraph::vertex_attr(.data, "name") - names(nodeX) <- igraph::vertex_attr(g, "name") - names(nodeY) <- igraph::vertex_attr(g, "name") - nodeX <- nodeX[order(match(names(nodeX), names))] - nodeY <- nodeY[order(match(names(nodeY), names))] - } - out <- .to_lo(cbind(nodeX, nodeY)) - } else { - if (!manynet::is_twomode(.data)) manynet::snet_abort( - "The {.val hierarchy} layout can only centre on a mode of a two-mode", - "network, but a one-mode network was given.", - "Either drop the {.arg center} argument, or use a two-mode network.") - net <- manynet::as_matrix(.data) - nn <- dim(net)[1] - mm <- dim(net)[2] - if (center == "actors") { - Act <- cbind(rep(1, nrow(net)), nrm(rng(nn))) - Evt1 <- cbind(rep(0, ceiling(ncol(net)/2)), nrm(rng(ceiling(mm/2)))) - Evt2 <- cbind(rep(2, floor(ncol(net)/2)), nrm(rng(floor(mm/2)))) - crd <- rbind(Act, Evt1, Evt2) - crd[which(is.nan(crd))] <- 0.5 - rownames(crd) <- c(dimnames(net)[[1]], dimnames(net)[[2]]) - } else if (center == "events") { - Act1 <- cbind(rep(0, ceiling(nrow(net)/2)), nrm(rng(ceiling(nn/2)))) - Act2 <- cbind(rep(2, floor(nrow(net)/2)), nrm(rng(floor(nn/2)))) - Evt <- cbind(rep(1, ncol(net)), nrm(rng(mm))) - crd <- rbind(Act1, Act2, Evt) - crd[which(is.nan(crd))] <- 0.5 - rownames(crd) <- c(dimnames(net)[[1]], dimnames(net)[[2]]) - } else { - if (center %in% manynet::node_names(.data)) { - side1 <- suppressWarnings(cbind(rep(0, nrow(net)), nrm(rng(nn)))) - side2 <- suppressWarnings(cbind(rep(2, ncol(net)), nrm(rng(mm)))) - if (any(rownames(net) == center)) { - side1[,1] <- ifelse(rownames(net) == center, 1, side1[,1]) - side1[,2] <- ifelse(rownames(net) == center, 0.5, side1[,2]) - } else { - side2[,1] <- ifelse(rownames(net) == center, 1, side2[,1]) - side2[,2] <- ifelse(rownames(net) == center, 0.5, side2[,2]) - } - crd <- rbind(side1, side2) - crd[which(is.nan(crd))] <- 0.5 - rownames(crd) <- c(dimnames(net)[[1]], dimnames(net)[[2]]) - } else .abort_no_match(center, manynet::node_names(.data), "center", - what = "node name", - extra_desc = paste("{.val actors} or {.val events}", - "can also be given here,", - "to centre on a whole mode.")) - } - out <- .to_lo(crd) - } - out -} - -#' @rdname layout_partition -#' @export -layout_tbl_graph_hierarchy <- layout_hierarchy - -#' @rdname layout_partition -#' @examples -#' #graphr(ison_southern_women, layout = "alluvial") -#' @export -layout_alluvial <- function(.data, - circular = FALSE, times = 1000){ - g <- manynet::as_igraph(.data) - if (manynet::is_twomode(.data)) { - layers <- ifelse(igraph::V(g)$type, 2, 1) - } else { - layers <- NULL - } - lo <- .sugiyama_layout(g, layers = layers, times = times) - nodeX <- lo[, 1] - nodeY <- lo[, 2] - # Swap x and y for left-to-right layout (alluvial) - if (length(unique(nodeY)) > 1) nodeY <- .rescale(nodeY) - if (length(unique(nodeX)) > 1) nodeX <- .rescale(nodeX) - .to_lo(cbind(nodeY, nodeX)) -} - -#' @rdname layout_partition -#' @export -layout_tbl_graph_alluvial <- layout_alluvial - -#' @rdname layout_partition -#' @export -layout_railway <- function(.data, - circular = FALSE, times = 1000) { - res <- layout_tbl_graph_hierarchy(manynet::as_igraph(.data)) - res$x <- c(match(res[res[,2]==0,1], sort(res[res[,2]==0,1])), - match(res[res[,2]==1,1], sort(res[res[,2]==1,1]))) - res -} - -#' @rdname layout_partition -#' @export -layout_tbl_graph_railway <- layout_railway - -#' @rdname layout_partition -#' @export -layout_ladder <- function(.data, - circular = FALSE, times = 1000){ - res <- layout_tbl_graph_alluvial(manynet::as_igraph(.data)) - res$y <- c(match(res[res[,2]==1,1], sort(res[res[,2]==1,1])), - match(res[res[,2]==0,1], sort(res[res[,2]==0,1]))) - res -} - -#' @rdname layout_partition -#' @export -layout_tbl_graph_ladder <- layout_ladder - -.to_lo <- function(mat) { - res <- as.data.frame(mat) - names(res) <- c("x","y") - res -} - -to_list <- function(members) { - out <- lapply(sort(unique(members)), function(x){ - y <- which(members==x) - if(!is.null(names(y))) names(y) else y - }) - names(out) <- unique(members) - out -} - -.check_dup <- function(mat) { - mat$y <- ifelse(duplicated(mat[c('x','y')]), mat$y*0.95, mat$y) - mat -} - -#' @importFrom igraph degree -getNNvec <- function(.data, members){ - lapply(members, function(circle){ - diss <- 1 - stats::cor(manynet::to_multilevel(manynet::as_matrix(.data))[, circle]) - diag(diss) <- NA - if(manynet::is_labelled(.data)) - starts <- names(sort(igraph::degree(.data)[circle], decreasing = TRUE)[1]) - else starts <- paste0("V",1:manynet::net_nodes(.data))[sort(igraph::degree(.data)[circle], - decreasing = TRUE)[1]] - if(length(circle)>1) - starts <- c(starts, names(which.min(diss[starts,]))) - out <- starts - if(length(circle)>2){ - for(i in 1:(length(circle)-2)){ - diss <- diss[,!colnames(diss) %in% starts] - if(is.matrix(diss)){ - side <- names(which.min(apply(diss[starts,], 1, min, na.rm = TRUE))) - new <- names(which.min(diss[side,])) - } else { - side <- names(which.min(diss[starts])) - new <- setdiff(circle,out) - } - if(side == out[1]){ - out <- c(new, out) - starts <- c(new, starts[2]) - } else { - out <- c(out, new) - starts <- c(starts[1], new) - } - } - } - out - }) -} - -getCoordinates <- function(x, r) { - l <- length(x) - d <- 360/l - c1 <- seq(0, 360, d) - c1 <- c1[1:(length(c1) - 1)] - tmp <- t(vapply(c1, - function(cc) c(cos(cc * pi/180) * - r, sin(cc * - pi/180) * r), - FUN.VALUE = numeric(2))) - rownames(tmp) <- x - tmp -} - -rng <- function(r) { - if (r == 1L) return(0) - if (r > 1L) { - x <- vector() - x <- append(x, (-1)) - for (i in 1:(r - 1)) x <- append(x, ((-1) + (2L/(r - 1L)) * i)) - return(x * (r/50L)) - } else manynet::snet_abort( - "A layout cannot be built for a negative number of nodes, but {r} was given.") -} - -nrm <- function(x, digits = 3) { - if (isTRUE(length(x) == 1L) == TRUE) return(x) - if (is.array(x) == TRUE) { - xnorm <- (x[, 1] - min(x[, 1]))/(max(x[, 1]) - min(x[, 1])) - rat <- (max(x[, 1]) - min(x[, 1]))/(max(x[, 2]) - min(x[, 2])) - ynorm <- ((x[, 2] - min(x[, 2]))/(max(x[, 2]) - min(x[, 2]))) * (rat) - ifelse(isTRUE(rat > 0) == FALSE, - ynorm <- ((x[, 2] - min(x[, 2]))/(max(x[, 2]) - - min(x[, 2]))) * (1L/rat), NA) - return(round(data.frame(X = xnorm, Y = ynorm), digits)) - } - else if (is.vector(x) == TRUE) { - return(round((x - min(x))/(max(x) - min(x)), digits)) - } -} diff --git a/R/layout_scaling.R b/R/layout_scaling.R new file mode 100644 index 00000000..353e3c71 --- /dev/null +++ b/R/layout_scaling.R @@ -0,0 +1,147 @@ +#' Scaling layout +#' +#' @description +#' The "scaling" layout places nodes by multidimensional scaling, +#' so that the distance drawn between two nodes approximates +#' the number of steps of the shortest path between them. +#' Unlike a force-directed layout, then, the coordinates can be read, +#' and so this layout draws labelled axes, +#' at a fixed ratio so that the two axes share one scale. +#' +#' Which algorithm is used depends on the size of the network. +#' Up to a hundred nodes, classical multidimensional scaling is used, +#' as `igraph::layout_with_mds()` offers it. +#' Above that, or where `pivots` is given, +#' pivot multidimensional scaling is used instead, +#' as `graphlayouts::layout_with_pmds()` offers it, +#' which approximates the same solution from a sample of the nodes +#' and is much the faster for a large network. +#' Note that "mds" and "pmds" remain available as layouts in their own right, +#' though "pmds" then requires its own `pivots`. +#' +#' Two dimensions rarely hold every path distance of a network at once, +#' so `graphr()` captions the plot with how well this one does: +#' see `check_stress()` for how to read the score. +#' @name layout_scaling +#' @template param_ggraphlayouts +#' @param pivots The number of nodes to approximate the scaling from. +#' By default this is `NULL`, which uses every node where the network has +#' no more than a hundred, and samples the nodes otherwise. +#' Giving a number selects the pivot algorithm whatever the size of network. +#' @details +#' The distances scaled are those of the unweighted network, +#' that is, the number of ties on the shortest path between two nodes. +#' Tie weights are ignored, since the interpretation of a drawn distance +#' is then the same whatever the network, +#' and since a signed network has no shortest paths to speak of. +#' +#' Where a network is disconnected, there is no path between its components, +#' and so no distance to scale. Each component is laid out and the components +#' are then placed beside one another, and the fit is reported over +#' the pairs of nodes that a path does connect. +#' @family mapping +#' @source +#' Kruskal, Joseph B. 1964. +#' "Multidimensional scaling by optimizing goodness of fit to a nonmetric +#' hypothesis", _Psychometrika_ 29(1): 1-27. +#' \doi{10.1007/BF02289565} +#' +#' Brandes, Ulrik, and Christian Pich. 2007. +#' "Eigensolver methods for progressive multidimensional scaling of large +#' data", in _Graph Drawing_, 42-53. +#' \doi{10.1007/978-3-540-70904-6_6} +#' @examples +#' graphr(manynet::ison_southern_women, layout = "scaling") +#' @export +layout_scaling <- function(.data, pivots = NULL, + circular = FALSE, times = 1) { + .data <- manynet::as_igraph(.data) + n <- igraph::vcount(.data) + if (n < 3L) return(.to_lo(.trivial_coords(n))) + if (!is.null(pivots)) { + if (!is.numeric(pivots) || length(pivots) != 1L || pivots < 2) { + manynet::snet_abort( + "{.arg pivots} should be a single number of at least 2,", + "or {.val NULL} to let the number be chosen.") + } + pivots <- min(as.integer(pivots), n - 1L) + } + # `weights = NA` counts ties rather than summing their weights: a signed + # network otherwise aborts on a negative cycle, and a weighted one would be + # scaled in units the caption could not name. + if (is.null(pivots) && n <= 100L) { + # The distances are computed here rather than left to igraph, so that the + # layout and the fit reported for it scale the same dissimilarities. + dis <- igraph::distances(.data, weights = NA) + crd <- igraph::layout_with_mds(.data, dist = dis) + src <- seq_len(n) + } else { + if (is.null(pivots)) pivots <- min(n - 1L, max(50L, ceiling(sqrt(n)))) + crd <- .pivot_scaling(.data, pivots) + # A network large enough for the pivot algorithm is large enough that a + # full distance matrix is the expensive part, so the fit is measured from + # a sample of the nodes. See `.stress_sources()`. + src <- .stress_sources(n) + dis <- igraph::distances(.data, v = src, weights = NA) + } + res <- .to_lo(crd) + # Carried on the coordinates rather than recomputed later: the attribute + # survives ggraph::create_layout(), so graphr() can read the fit of the + # layout it actually drew. + attr(res, "fit") <- .scaling_fit(dis, crd, src, pivots) + res +} + +#' @rdname layout_scaling +#' @export +layout_tbl_graph_scaling <- layout_scaling + +# `graphlayouts::layout_with_pmds()` aborts where the network is disconnected, +# so each component is laid out on its own and the components are then packed +# together. A component with fewer nodes than pivots, or too few nodes to +# sample at all, is scaled in full instead, which for a component that small +# costs nothing. +.pivot_scaling <- function(g, pivots) { + igraph::layout_components(g, layout = function(part) { + m <- igraph::vcount(part) + # A component of one or two nodes has no distances worth scaling, and + # igraph refuses to scale fewer nodes than dimensions. + if (m < 3L) return(.trivial_coords(m)) + if (m < 4L || m - 1L <= pivots) { + igraph::layout_with_mds(part, + dist = igraph::distances(part, weights = NA)) + } else graphlayouts::layout_with_pmds(part, pivots = pivots, weights = NA) + }) +} + +# Coordinates for a network too small to scale: a node, or two side by side. +.trivial_coords <- function(n) { + cbind(seq_len(n) - 1, rep(0, n)) +} + +# How well the two dimensions drawn hold the path distances, carried on the +# layout so that graphr() can caption the plot with it rather than compute the +# scaling a second time. `pivots` is NA where every node was scaled. +.scaling_fit <- function(dis, crd, src, pivots) { + # `type` names which fit this is, since graphr() reports each in its own + # terms. See `.note_fit()`. + list(type = "scaling", + stress = .stress1(dis, crd, src), + # The decomposition the share of variance is read from is the very work + # the pivot algorithm is used to avoid, so it is only reported where + # every node was scaled in full. + variance = if (is.null(pivots)) .scaling_variance(dis) else NA_real_, + pivots = if (is.null(pivots)) NA_integer_ else as.integer(pivots)) +} + +# The share of the distance variance the first two dimensions hold, from the +# eigenvalues classical scaling decomposes the distances into. This is only +# defined where every pair of nodes has a distance, so a disconnected network +# has no such share and reports none. +.scaling_variance <- function(dis) { + if (any(!is.finite(dis))) return(NA_real_) + eig <- tryCatch(stats::cmdscale(stats::as.dist(dis), k = 2, eig = TRUE)$eig, + error = function(e) NULL) + if (is.null(eig) || sum(abs(eig)) == 0) return(NA_real_) + sum(eig[1:2]) / sum(abs(eig)) +} diff --git a/R/layout_valence.R b/R/layout_valence.R index 0970ff80..b06b7e24 100644 --- a/R/layout_valence.R +++ b/R/layout_valence.R @@ -1,5 +1,11 @@ -#' Valence-based layout -#' @inheritParams layout_layered +#' Valence layout +#' +#' @description +#' The "valence" layout places the nodes of a signed network so that +#' positively tied nodes are drawn together and negatively tied nodes apart. +#' @name layout_valence +#' @template param_ggraphlayouts +#' @param center Required for `{ggraph}` compatibility, and not used here. #' @param repulsion_coef Coefficient for global repulsion force. #' Default is 1. #' @param attraction_coef Coefficient for edge-based attraction/repulsion force. @@ -12,12 +18,28 @@ #' sign = c(1, -1, 1, -1) # 1 = positive, -1 = negative #' ) #' graphr(as_igraph(edges), layout="valence") +#' @family mapping #' @export layout_valence <- function(.data, times = 500, center = NULL, circular = FALSE, repulsion_coef = 1, attraction_coef = 0.05) { graph <- manynet::as_tidygraph(.data) n <- manynet::net_nodes(graph) + # A sign is read through manynet rather than from a "sign" tie attribute, + # since manynet 2.3.0 records the sign of a tie in its weight instead. A tie + # with no sign attracts as a positive tie does, and a network with no weights + # weighs every tie the same. + signs <- if (manynet::is_signed(graph)) + as.numeric(manynet::tie_signs(graph)) else + rep(1, manynet::net_ties(graph)) + signs[is.na(signs)] <- 1 + # The magnitude of the weight, since manynet 2.3.0 carries the sign in the + # weight itself; multiplying a negative weight by a negative sign would make + # a negative tie attract. + weights <- if (manynet::is_weighted(graph)) + abs(as.numeric(manynet::tie_attribute(graph, "weight"))) else + rep(1, manynet::net_ties(graph)) + weights[is.na(weights)] <- 1 coords <- matrix(stats::runif(n * 2, min = -1, max = 1), ncol = 2) @@ -47,7 +69,7 @@ layout_valence <- function(.data, times = 500, center = NULL, circular = FALSE, vec <- coords[t_id, ] - coords[s_id, ] dist <- sqrt(sum(vec^2)) + 1e-4 dir <- vec / dist - force <- attraction_coef * igraph::E(graph)$weight[e] * igraph::E(graph)$sign[e] + force <- attraction_coef * weights[e] * signs[e] delta[s_id, ] <- delta[s_id, ] + force * dir delta[t_id, ] <- delta[t_id, ] - force * dir diff --git a/R/plot_analysis.R b/R/plot_analysis.R index 25271480..092d4b37 100644 --- a/R/plot_analysis.R +++ b/R/plot_analysis.R @@ -51,7 +51,7 @@ plot.node_measure <- function(x, type = c("h", "d"), ...) { ggplot2::ylab("Density") } p + - ggplot2::theme_classic(base_family = ag_font()) + + ag_theme_classic() + ggplot2::theme(panel.grid.major = ggplot2::element_line(colour = "grey90")) } @@ -88,7 +88,7 @@ plot.tie_measure <- function(x, type = c("h", "d"), ...) { linewidth = 1.5) + ggplot2::ylab("Density") } - p + ggplot2::theme_classic(base_family = ag_font()) + + p + ag_theme_classic() + ggplot2::theme(panel.grid.major = ggplot2::element_line(colour = "grey90")) } @@ -99,7 +99,7 @@ plot.tie_measure <- function(x, type = c("h", "d"), ...) { plot.network_measures <- function(x, ...) { ggplot2::ggplot(data = x, ggplot2::aes(x = .data$time, y = .data$value)) + ggplot2::geom_line(colour = ag_highlight()) + - ggplot2::theme_minimal(base_family = ag_font()) + + ag_theme_minimal() + ggplot2::xlab("Time") + ggplot2::ylab("Value") } @@ -139,32 +139,32 @@ plot.node_member <- function(x, ...) { ggraph::geom_node_text( ggplot2::aes(filter = .data$leaf, label = .data$label, colour = .data$label), - hjust = 1, nudge_y = -max(hc$height) / 60, size = 3.5, + hjust = 1, nudge_y = -max(hc$height) / 60, size = ag_text_size(3.5), family = ag_font(), show.legend = FALSE) + ggplot2::scale_colour_manual( values = stats::setNames(colors, hc$labels[hc$order])) + ggplot2::scale_y_continuous( expand = ggplot2::expansion(mult = c(0.22, 0.02))) + ggplot2::coord_flip() + - ggplot2::theme_minimal(base_family = ag_font()) + + ag_theme_minimal() + ggplot2::theme(axis.title = ggplot2::element_blank(), axis.text.y = ggplot2::element_blank(), - axis.text.x = ggplot2::element_text(colour = ag_base()), + axis.text.x = ggplot2::element_text(colour = ag_ink()), panel.grid = ggplot2::element_blank()) } # #' @export # plot.node_members <- function(x, ...) { -# df <- x %>% dplyr::mutate(wave = dplyr::row_number()) -# df_long <- df %>% +# df <- x |> dplyr::mutate(wave = dplyr::row_number()) +# df_long <- df |> # tidyr::pivot_longer(-wave, names_to = "person", values_to = "group") -# group_counts <- df_long %>% -# dplyr::group_by(wave, group) %>% +# group_counts <- df_long |> +# dplyr::group_by(wave, group) |> # dplyr::summarise(n = dplyr::n(), .groups = "drop") # # # Step 1: Reshape to wide format: one row per person, one column per wave -# df_wide <- df_long %>% -# dplyr::mutate(wave = paste0("wave", wave)) %>% +# df_wide <- df_long |> +# dplyr::mutate(wave = paste0("wave", wave)) |> # tidyr::pivot_wider(names_from = wave, values_from = group) # # # Step 2: Create a vector of wave columns for use as axes @@ -182,7 +182,7 @@ plot.node_member <- function(x, ...) { # ggplot2::geom_text(stat = "stratum", # ggplot2::aes(label = ggplot2::after_stat(stratum))) + # ggplot2::scale_x_discrete(labels = paste("Wave", seq_along(wave_cols))) + -# ggplot2::theme_minimal() +# ag_theme_minimal() # # Step 1: Reshape to wide format with one row per person # df_wide <- df_long |> @@ -208,7 +208,7 @@ plot.node_member <- function(x, ...) { # size = 3 # ) + # ggplot2::scale_x_discrete(labels = paste("Wave", seq_along(wave_cols))) + -# ggplot2::theme_minimal() +# ag_theme_minimal() # # } @@ -258,20 +258,20 @@ plot.matrix <- function(x, ..., membership = NULL) { manynet::node_names(blocked_data)) all_nodes <- data.frame(from = all_nodes$Var1, to = all_nodes$Var2, weight = 0) - plot_data <- rbind(plot_data, all_nodes) %>% + plot_data <- rbind(plot_data, all_nodes) |> dplyr::distinct(from, to, .keep_all = TRUE) g <- ggplot2::ggplot(plot_data, ggplot2::aes(to, from)) + - ggplot2::theme_grey(base_size = 9) + + ag_theme_grey(base_size = 9) + ggplot2::labs(x = "", y = "") + ggplot2::theme( legend.position = "none", axis.ticks = ggplot2::element_blank(), axis.text.y = ggplot2::element_text( - size = 9 * 0.8, + size = ag_text_size(9 * 0.8), colour = ag_base() ), axis.text.x = ggplot2::element_text( - size = 9 * 0.8, + size = ag_text_size(9 * 0.8), angle = 30, hjust = 0, colour = ag_base() ) @@ -284,9 +284,12 @@ plot.matrix <- function(x, ..., membership = NULL) { # Color for signed networks if (manynet::is_signed(x)) { g <- g + - ggplot2::scale_fill_gradient2(high = "#003049", - mid = "white", - low = "#d62828") + # These poles were hard-coded, so this was the one signed plot that + # ignored the theme -- and the one that missed the repair of the + # red-green divergent pairs. See ?ag_call. + ggplot2::scale_fill_gradient2(high = ag_positive(), + mid = ag_ground_fill(), + low = ag_negative()) } else { g <- g + ggplot2::scale_fill_gradient( diff --git a/R/plot_convergence.R b/R/plot_convergence.R index 346314e3..eba8d754 100644 --- a/R/plot_convergence.R +++ b/R/plot_convergence.R @@ -24,14 +24,14 @@ plot.ag_conv <- function(x, ...){ ggplot2::facet_grid(name ~ ., scales = "free", switch = "y") + ggplot2::geom_smooth(formula = y ~ x, method = "loess", se = FALSE, color = ag_highlight(), linewidth = 0.5) + - ggplot2::theme_minimal(base_family = ag_font()) + + ag_theme_minimal() + ggplot2::theme(axis.text.y = element_blank(), strip.text.y.left = element_text(angle = 0)) + ggplot2::labs(x = "Simulation step", y = "") density_plot <- ggplot2::ggplot(dat, aes(y = value)) + ggplot2::geom_density(fill = ag_base(), alpha = 0.6) + ggplot2::facet_grid(name ~ ., scales = "free", switch = "y") + - ggplot2::theme_void() + + ag_theme_void() + ggplot2::theme(strip.text.y = element_blank()) patchwork::wrap_plots(trace_plot, density_plot, ncol = 2, widths = c(5, 1)) @@ -45,18 +45,18 @@ plot.ag_conv <- function(x, ...){ plot.traces.monan <- function(x, ...) { nParams <- length(x[[1]]) nSims <- length(x[[2]][, 1]) - dat <- x[[2]] %>% dplyr::as_tibble() %>% dplyr::mutate(sim = 1:dplyr::n()) %>% - as.data.frame() %>% dplyr::select(sim, dplyr::everything()) + dat <- x[[2]] |> dplyr::as_tibble() |> dplyr::mutate(sim = 1:dplyr::n()) |> + as.data.frame() |> dplyr::select(sim, dplyr::everything()) dat <- stats::reshape(data = dat, # tidyr::pivot_longer replacement direction = "long", varying = list(colnames(dat)[-1]), v.names = "value", timevar = "name", times = colnames(dat)[-1], - idvar = "sim") %>% - dplyr::tibble() %>% dplyr::arrange(sim) - # dat <- dat %>% dplyr::mutate(name = gsub("_","\n",name, fixed = TRUE)) - # dat <- dat %>% dplyr::mutate(name = gsub(" ","\n",name, fixed = TRUE)) + idvar = "sim") |> + dplyr::tibble() |> dplyr::arrange(sim) + # dat <- dat |> dplyr::mutate(name = gsub("_","\n",name, fixed = TRUE)) + # dat <- dat |> dplyr::mutate(name = gsub(" ","\n",name, fixed = TRUE)) class(dat) <- c("ag_conv", class(dat)) plot.ag_conv(dat) } @@ -68,7 +68,7 @@ plot.traces.monan <- function(x, ...) { #' plot(ergm_res) #' @export plot.ergm <- function(x, ...) { - dat <- x$sample[[1]] %>% dplyr::as_tibble() %>% dplyr::mutate(sim = 1:dplyr::n()) %>% + dat <- x$sample[[1]] |> dplyr::as_tibble() |> dplyr::mutate(sim = 1:dplyr::n()) |> as.data.frame() dat <- stats::reshape(data = dat, # tidyr::pivot_longer replacement direction = "long", @@ -76,8 +76,8 @@ plot.ergm <- function(x, ...) { v.names = "value", timevar = "name", times = colnames(dat)[-ncol(dat)], - idvar = "sim") %>% - dplyr::tibble() %>% dplyr::arrange(sim) + idvar = "sim") |> + dplyr::tibble() |> dplyr::arrange(sim) class(dat) <- c("ag_conv", class(dat)) plot.ag_conv(dat) } diff --git a/R/plot_diagnostics.R b/R/plot_diagnostics.R index bf799dd1..cef39cf8 100644 --- a/R/plot_diagnostics.R +++ b/R/plot_diagnostics.R @@ -1,71 +1,1013 @@ #' Plotting adequacy diagnostics #' @description -#' These plotting methods are for diagnosing the adequacy of model specification, -#' such as those used in goldfish. +#' These plotting methods are for diagnosing the adequacy of model +#' specification, such as those used in goldfish. #' These plots are useful for identifying whether there might be significant -#' outliers affecting the results or significant time heterogeneity. +#' outliers affecting the results, whether there is significant time +#' heterogeneity, and which actors' activity the model does not reproduce. +#' @details +#' goldfish emits these objects plot-ready. Each is a tibble carrying the +#' diagnostic metadata contract --- which function produced it, which model +#' and sub-model it came from, and the arguments that shape how it is read +#' --- so these methods take their series, their labels and their reference +#' lines from the object rather than inferring them from the columns that +#' happen to be present. +#' +#' The `.series` column is the series the diagnostic actually analysed: the +#' per-interval log-likelihood by default, and the selected term's own +#' series when the diagnostic was called with `effect =`. It is `NA` on the +#' intervals that took no part, which on a rate or REM fit are the +#' right-censored ones. #' @name plot_adequacy -#' @importFrom patchwork plot_layout -#' @param x An object of class "outliers.goldfish" or "changepoints.goldfish". +#' @param x An object of class `goldfishOutliers`, `goldfishChangepoints`, +#' `goldfishMargins`, `goldfishGOF`, `goldfishTimeTest` or `goldfishOnset`, +#' as returned by `diagnose_outliers()`, `diagnose_changepoints()`, +#' `margin_table()`, `test_gof()`, `test_time()` and `diagnose_onset()` in +#' goldfish. #' @param ... Additional plotting parameters, currently unused. -#' @return The function shows a line plot tracing the statistics obtained at -#' each simulation step, as well as a density plot showing the distribution -#' of the statistics over the entire simulation. +#' @param page Which page to draw, for the per-term figures. `NULL` (the +#' default) draws every panel in one figure, exactly as before. A number +#' draws that page alone; a number past the last is an error naming the +#' count. Use [count_pages()] to learn the count without rendering, so a loop +#' can write every page with nobody at a screen. +#' @param nrow,ncol Panels per page when `page` is given. +#' @return A ggplot object. NULL +# The goldfish diagnostic metadata contract: every object these methods +# receive carries `diagnostic`, `context`, `params` and `version` attributes. +gf_meta <- function(x, which) { + out <- attr(x, which) + if (is.null(out)) list() else out +} + +# What the y axis is measuring, named by the producer rather than guessed +# here: with `effect =` the analysed series is that term's own, and the two +# diagnostics choose different ones. +gf_series_label <- function(params) { + label <- params$series + if (is.null(label)) "Interval log likelihood" else label +} + +gf_term_subtitle <- function(params) { + if (is.null(params$effect)) NULL else paste("Term:", params$effect) +} + #' @rdname plot_adequacy #' @examples #' plot(goldfish_outliers) #' @export -plot.outliers.goldfish <- function(x, ...) { - if (!"YES" %in% x$outlier) { +plot.goldfishOutliers <- function(x, ...) { + params <- gf_meta(x, "params") + flagged <- !is.na(x$outlier) & x$outlier + if (!any(flagged)) { cat("No outliers found.\n") return(invisible(NULL)) } - - ggplot2::ggplot(x, ggplot2::aes(x = .data$time, y = .data$intervalLogL)) + - ggplot2::geom_line() + - ggplot2::geom_point(ggplot2::aes(color = .data$outlier)) + - ggplot2::geom_text(ggplot2::aes(label = .data$label), - angle = 300, size = 4, - hjust = "outward", color = ag_highlight() + + p <- ggplot2::ggplot(x, ggplot2::aes(x = .data$time, y = .data$.series)) + + ggplot2::geom_line(na.rm = TRUE) + + ggplot2::geom_point(ggplot2::aes(colour = .data$outlier), na.rm = TRUE) + + ggplot2::geom_text( + ggplot2::aes(label = .data$label), + angle = 300, + size = 4, + na.rm = TRUE, + hjust = "outward", + colour = ag_highlight() ) + - ggplot2::theme_minimal() + + ag_theme_minimal() + ggplot2::scale_colour_manual( - values = c(ag_base(), ag_highlight()), + values = c("FALSE" = ag_base(), "TRUE" = ag_highlight()), guide = "none" ) + - ggplot2::xlab("") + - ggplot2::ylab("Interval log likelihood") + ggplot2::labs( + x = "", + y = gf_series_label(params), + subtitle = gf_term_subtitle(params) + ) + gf_facet_processes(p, x) +} + +# Split a row-bound flavoured table into one panel per process. +# +# Not cosmetic on these two plots: the series is drawn with `geom_line()`, and a +# flavoured table arrives as several processes' series stacked, so without the +# split the line is drawn straight across the boundary between one process's +# last event and the next process's first. The panels are what make it a series +# per process rather than one line through all of them. +gf_facet_processes <- function(p, data) { + facets <- intersect(c("flavor", "family"), names(data)) + if (length(facets) == 0) { + return(p) + } + p + + ggplot2::facet_wrap( + stats::as.formula(paste("~", paste(facets, collapse = " + "))), + scales = "free" + ) } #' @rdname plot_adequacy #' @examples #' plot(goldfish_changepoints) #' @export -plot.changepoints.goldfish <- function(x, ...) { - data <- x$data - cpt.pts <- x$cpt_points - - if (is.null(cpt.pts) || length(cpt.pts) == 0) { +plot.goldfishChangepoints <- function(x, ...) { + params <- gf_meta(x, "params") + breaks <- x$time[!is.na(x$cpt) & x$cpt] + if (length(breaks) == 0) { cat("No regime changes found.\n") return(invisible(NULL)) } - - ggplot2::ggplot(data, - ggplot2::aes(x = .data$time, y = .data$intervalLogL)) + - ggplot2::geom_line() + - ggplot2::geom_point() + + + # Carried as a data frame rather than a bare `xintercept` vector: on a + # flavoured table the breaks belong to the process they were detected in, and + # a plain vector would draw every process's breaks onto every panel. + marked <- x[!is.na(x$cpt) & x$cpt, , drop = FALSE] + + p <- ggplot2::ggplot(x, ggplot2::aes(x = .data$time, y = .data$.series)) + + ggplot2::geom_line(na.rm = TRUE) + + ggplot2::geom_point(na.rm = TRUE) + ggplot2::geom_vline( - xintercept = stats::na.exclude(data$time[cpt.pts]), - color = ag_highlight() + data = marked, + mapping = ggplot2::aes(xintercept = .data$time), + colour = ag_highlight() ) + - ggplot2::theme_minimal() + - ggplot2::xlab("") + - ggplot2::ylab("Interval log likelihood") + - ggplot2::scale_x_continuous( - breaks = data$time[cpt.pts], - labels = data$time[cpt.pts] + ag_theme_minimal() + + ggplot2::labs( + x = "", + y = gf_series_label(params), + subtitle = gf_term_subtitle(params) ) + ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1)) -} \ No newline at end of file + # Labelling the axis with the break times themselves only works where they + # are numbers; a goldfish event stream may just as well be dated, and there + # the default date scale already reads well beside the marked breaks. + if (is.numeric(x$time)) { + p <- p + ggplot2::scale_x_continuous(breaks = breaks, labels = breaks) + } + gf_facet_processes(p, x) +} + +#' @rdname plot_adequacy +#' @details +#' `plot.goldfishMargins()` shows each actor's observed activity against what +#' the model expected of them. Which comparison it draws follows the scales +#' the fit's model class defines, which the object records: where a +#' compensator is defined (the exact-time sub-models) the difference +#' `observed - expected_count` is the per-actor martingale residual, read +#' against zero; on the multinomial sub-models, which have no exposure-time +#' term and so no compensator, the ratio `observed / expected_probability` +#' is a calibration ratio, read against one. +#' +#' These are descriptives rather than per-actor tests: the differences are +#' plug-in quantities and are negatively correlated across actors. Read the +#' plot as a map screening for unmodelled actor heterogeneity. +#' +#' A node set large enough to make one row per actor unreadable is the +#' ordinary case, so only the `top` actors furthest from the reference are +#' drawn, and the subtitle says how many were left out. Actors are ranked by +#' their largest deviation over the roles they appear in, so an actor kept +#' for one margin keeps the other beside it. Pass `top = Inf` for all of +#' them. +#' @param top The number of actors to draw, those furthest from the reference. +#' @examples +#' plot(goldfish_margins) +#' @export +plot.goldfishMargins <- function(x, ..., top = 25) { + scales <- gf_meta(x, "context")$defined_scales + martingale <- "expected_count" %in% scales + data <- as.data.frame(x) + # `margin_table(dispersion = TRUE)` carries a second reading, and where both + # are present the informative figure is the two against each other rather + # than either alone: level says whether an actor acted often enough, shape + # whether its events were spaced the way the model implies, and an actor can + # fail one while passing the other. + if ("dispersion" %in% names(data) && !all(is.na(data$dispersion))) { + return(gf_margin_scatter(data, martingale, top)) + } + data$value <- if (martingale) { + data$observed - data$expected_count + } else { + data$observed / data$expected_probability + } + reference <- if (martingale) 0 else 1 + data$side <- ifelse(data$value >= reference, "above", "below") + + deviation <- abs(data$value - reference) + ranked <- names(sort( + tapply(deviation, data$actor, max, na.rm = TRUE), + decreasing = TRUE + )) + omitted <- max(0, length(ranked) - top) + if (omitted > 0) { + data <- data[data$actor %in% ranked[seq_len(top)], ] + } + data$actor <- stats::reorder(factor(data$actor), data$value) + + p <- ggplot2::ggplot(data, ggplot2::aes(x = .data$value, y = .data$actor)) + + ggplot2::geom_vline(xintercept = reference, colour = ag_ink()) + + ggplot2::geom_segment( + ggplot2::aes( + x = reference, + xend = .data$value, + y = .data$actor, + yend = .data$actor, + colour = .data$side + ) + ) + + ggplot2::geom_point(ggplot2::aes(colour = .data$side)) + + ggplot2::scale_colour_manual( + values = c(above = ag_positive(), below = ag_negative()), + guide = "none" + ) + + ag_theme_minimal() + + ggplot2::labs( + x = if (martingale) { + "Observed minus expected events" + } else { + "Observed over expected events" + }, + y = "", + subtitle = if (omitted > 0) { + paste(omitted, "further actors not shown") + } + ) + + # A tie-oriented fit contributes both margins per actor, and a flavoured fit + # arrives row-bound with the columns naming its process, so the facets are + # whichever of those the table carries. + facets <- intersect(c("flavor", "family", "role"), names(data)) + if (length(facets) > 0) { + p <- p + + ggplot2::facet_wrap( + stats::as.formula(paste("~", paste(facets, collapse = " + "))), + scales = "free_y" + ) + } + p +} + +#' @rdname plot_adequacy +#' @details +#' `plot.goldfishGOF()` draws each effect's standardized cumulative score +#' process against the Brownian-bridge bands its p-value was read from. At +#' the maximum the per-event scores sum to zero, so every path starts and +#' ends at zero; under a correctly specified model it is a bridge, and a path +#' that wanders outside the bands is an effect whose contribution is +#' concentrated somewhere in the sequence. +#' +#' The x axis is the object's own process-time axis, taken from its `u` +#' column and labelled by the `clock` it records. This is not a +#' presentational detail: the bands are valid on whichever clock produced the +#' process, and re-deriving an event-index axis here would draw the path on +#' one clock and the reference on another. On the information clock the +#' spacing of the steps is itself the diagnostic --- a path that crosses most +#' of the axis in a few steps is an effect whose information arrives late. +#' @param level The confidence level of the reference bands, defaulting to +#' 0.95. The band is the two-sided Kolmogorov quantile of the supremum of a +#' Brownian bridge, which is the reference the event-clock p-value uses. +#' @examples +#' plot(goldfish_gof) +#' @export +plot.goldfishGOF <- function( + x, + ..., + level = 0.95, + page = NULL, + nrow = 2, + ncol = 2 +) { + process <- as.data.frame(x$process) + clock <- gf_meta(x, "params")$clock + + p <- ggplot2::ggplot( + process, + ggplot2::aes(x = .data$u, y = .data$process) + ) + + ggplot2::geom_hline(yintercept = 0, colour = ag_ink()) + + ggplot2::geom_hline( + yintercept = c(-1, 1) * gf_bridge_quantile(level), + colour = ag_highlight(), + linetype = "dashed" + ) + + ggplot2::geom_step(na.rm = TRUE) + + ag_theme_minimal() + + ggplot2::labs( + x = gf_clock_label(clock), + y = "Standardized cumulative score", + subtitle = paste0( + "Brownian-bridge band at ", + format(100 * level), + "%" + ) + ) + gf_facet_paged( + p, + gf_block_facets(process), + page, + nrow, + ncol, + count_pages(x, nrow, ncol), + scales = "fixed" + ) +} + +#' @rdname plot_adequacy +#' @details +#' `plot.goldfishTimeTest()` draws the scaled Schoenfeld residuals of each +#' tested effect against time, with a smooth and the fitted estimate as the +#' reference. A residual scatter is centred on the coefficient the model +#' estimated; a smooth that drifts away from that line over the sequence is +#' the coefficient failing to be constant, which is what the test's p-value +#' states formally. +#' +#' Under `method = "periods"` the intervals are coloured by their period, so +#' the regimes the test compared are visible against the same scatter. +#' @examples +#' plot(goldfish_time) +#' @export +plot.goldfishTimeTest <- function(x, ..., page = NULL, nrow = 2, ncol = 2) { + residuals <- as.data.frame(x$residuals) + params <- gf_meta(x, "params") + # `period` is all-NA under the trend method, which has no periods; colouring + # by a constant would put a one-level legend on every trend plot. + by_period <- !all(is.na(residuals$period)) + + p <- ggplot2::ggplot( + residuals, + ggplot2::aes(x = .data$clock, y = .data$residual) + ) + + ggplot2::geom_hline( + ggplot2::aes(yintercept = .data$reference), + colour = ag_base() + ) + p <- if (by_period) { + p + + ggplot2::geom_point( + ggplot2::aes(colour = .data$period), + alpha = 0.4, + na.rm = TRUE + ) + } else { + p + ggplot2::geom_point(alpha = 0.4, na.rm = TRUE, colour = ag_base()) + } + p <- p + + ggplot2::geom_smooth( + method = "loess", + formula = y ~ x, + se = FALSE, + colour = ag_highlight(), + na.rm = TRUE + ) + + ag_theme_minimal() + + ggplot2::labs( + x = "Model time", + y = "Scaled Schoenfeld residual", + subtitle = gf_time_subtitle(params) + ) + gf_facet_paged( + p, + gf_block_facets(residuals), + page, + nrow, + ncol, + count_pages(x, nrow, ncol), + scales = "free_y" + ) +} + +# The panels a test object facets on: the term always, plus the two identity +# columns a flavoured (multi-process) result appends. Taking them from the +# table rather than from the object's class is what lets one method serve both +# shapes, as `plot.goldfishMargins()` already does. +gf_block_facets <- function(data) { + facets <- c("term", intersect(c("flavor", "family"), names(data))) + stats::as.formula(paste("~", paste(facets, collapse = " + "))) +} + +# The two-sided Kolmogorov quantile: the level `q` with +# P(sup|B| <= q) = level for a Brownian bridge B. Solved by bisection on the +# series 1 - 2 sum (-1)^{j-1} exp(-2 j^2 q^2), which is the same distribution +# the event-clock p-value inverts, so band and p-value cannot disagree. +gf_bridge_quantile <- function(level) { + cdf <- function(q) { + j <- seq_len(100) + 1 - 2 * sum((-1)^(j - 1) * exp(-2 * j^2 * q^2)) + } + # `uniroot`'s default tolerance is about 1e-4, which is invisible in a drawn + # band but would make the band and the p-value disagree in the last digits. + # They invert the same distribution, so solve it to machine precision. + stats::uniroot( + function(q) cdf(q) - level, + interval = c(0.1, 10), + tol = .Machine$double.eps^0.75 + )$root +} + +# The axis label names the clock the process was built on, because the two are +# different quantities: event-clock steps are equally spaced by construction, +# information-clock steps are spaced by how much each event contributed. +gf_clock_label <- function(clock) { + if (identical(clock, "information")) { + return("Cumulative share of information") + } + "Share of events" +} + +gf_time_subtitle <- function(params) { + if (identical(params$method, "periods")) { + return("Score test of a coefficient difference across periods") + } + transform <- params$transform + if (is.null(transform) || is.na(transform)) { + transform <- "identity" + } + paste0("Score test of a ", transform, " time trend") +} + +#' @rdname plot_adequacy +#' @details +#' `plot.goldfishOnset()` composes two panels: each coefficient's +#' leave-the-first-`m`-events-out path, and the share of the model's +#' information those events delivered. +#' +#' Both panels are **windowed on the excursion rather than the sequence**, +#' because the full range is mostly bridge tail --- the path returns to the +#' estimate by construction, so drawing all of it squashes the part being +#' read into a few percent of the axis. Each coefficient gets its own window +#' and its own x scale, since coefficients settle at very different points +#' and a window shared across facets re-creates the squashing it exists to +#' prevent. A coefficient whose path never left its band takes the full +#' range, there being no excursion to window on. +#' +#' The accrual panel is drawn full-range with the onset window shaded, and +#' carries the proportional diagonal `y = x / n`. Without the diagonal a +#' monotone curve from 0 to 1 says nothing: the signal is the *departure* +#' from proportional, which is what makes an opening segment that carries +#' little information visible. +#' +#' Coefficients held fixed through `offset()` are not drawn. Their path is a +#' flat line at the imposed value by construction. +#' @param view Which panels to draw: `"both"` (default), or `"path"` or +#' `"accrual"` alone, which is the escape hatch when a model has too many +#' coefficients for a composed figure to stay readable. +#' @param tolerance_band Whether to draw each coefficient's stabilization +#' band, the `+/- tolerance * std_error` corridor the path had to re-enter. +#' @examples +#' plot(goldfish_onset) +#' @export +plot.goldfishOnset <- function( + x, + ..., + view = c("both", "path", "accrual"), + tolerance_band = TRUE, + page = NULL, + nrow = 2, + ncol = 2 +) { + view <- match.arg(view) + context <- gf_meta(x, "context") + params <- gf_meta(x, "params") + summary <- as.data.frame(x$summary) + # An offset never moves, so its path is its imposed value repeated. + summary <- summary[!summary$fixed, , drop = FALSE] + if (nrow(summary) == 0) { + cat("No estimated coefficient to trace.\n") + return(invisible(NULL)) + } + + path <- gf_onset_path_panel( + x, + summary, + params, + tolerance_band, + page = page, + nrow = nrow, + ncol = ncol, + n_pages = count_pages(x, nrow, ncol) + ) + if (identical(view, "path")) { + return(path) + } + accrual <- gf_onset_accrual_panel(x, summary, context) + if (identical(view, "accrual")) { + return(accrual) + } + patchwork::wrap_plots(path, accrual, ncol = 1, heights = c(2, 1)) +} + +# The path panel, windowed per coefficient on its own excursion. The window is +# `1.15 * stabilized_at`, floored at 10: a proportional floor squashes the +# coefficients that settle in a handful of events, and an absolute margin +# (`+ 20`) overshoots the ones whose whole excursion is shorter than that. +gf_onset_path_panel <- function( + x, + summary, + params, + tolerance_band, + page = NULL, + nrow = 2, + ncol = 2, + n_pages = 1L +) { + path <- as.data.frame(x$path) + path <- path[path$index %in% summary$index, , drop = FALSE] + n_events <- max(path$dropped_events) + windows <- stats::setNames( + vapply( + summary$stabilized_at, + function(at) { + if (at == 0) n_events else min(n_events, max(ceiling(1.15 * at), 10)) + }, + numeric(1) + ), + summary$term + ) + path <- path[path$dropped_events <= windows[path$term], , drop = FALSE] + # The marker joins `summary` onto `path` by term, which the plot-data + # contract permits: the two tables of one object may be read together. + markers <- summary[summary$stabilized_at > 0, , drop = FALSE] + + p <- ggplot2::ggplot( + path, + ggplot2::aes(x = .data$dropped_events, y = .data$estimate) + ) + if (tolerance_band) { + tolerance <- params$tolerance + if (is.null(tolerance)) { + tolerance <- 0.1 + } + p <- p + + ggplot2::geom_ribbon( + ggplot2::aes( + ymin = .data$reference - tolerance * .data$std_error, + ymax = .data$reference + tolerance * .data$std_error + ), + fill = ag_base(), + alpha = 0.2 + ) + } + p <- p + + ggplot2::geom_hline( + ggplot2::aes(yintercept = .data$reference), + colour = ag_base() + ) + + ggplot2::geom_line(colour = ag_base(), na.rm = TRUE) + if (nrow(markers) > 0) { + p <- p + + ggplot2::geom_vline( + data = markers, + ggplot2::aes(xintercept = .data$stabilized_at), + colour = ag_highlight(), + linetype = "dashed" + ) + } + p <- p + + ag_theme_minimal() + + ggplot2::labs( + x = "Initial events dropped", + y = "Estimate", + subtitle = "Path with the stabilization point marked" + ) + gf_facet_paged( + p, + stats::as.formula("~ term"), + page, + nrow, + ncol, + n_pages, + scales = "free" + ) +} + +# The accrual panel: full range with the onset window shaded, and the +# proportional diagonal drawn. The diagonal is what makes the curve readable -- +# the departure from it is the finding, not the curve's monotonicity. +gf_onset_accrual_panel <- function(x, summary, context) { + accrual <- as.data.frame(x$accrual) + onset <- max(summary$stabilized_at) + n_events <- context$n_events + if (is.null(n_events)) { + n_events <- max(accrual$dropped_events) + } + + p <- ggplot2::ggplot( + accrual, + ggplot2::aes(x = .data$dropped_events, y = .data$share) + ) + if (onset > 0) { + p <- p + + ggplot2::annotate( + "rect", + xmin = 0, + xmax = onset, + ymin = 0, + ymax = 1, + fill = ag_highlight(), + alpha = 0.15 + ) + } + p + + ggplot2::geom_abline( + slope = 1 / n_events, + intercept = 0, + colour = ag_base(), + linetype = "dashed" + ) + + ggplot2::geom_line(colour = ag_base(), na.rm = TRUE) + + ag_theme_minimal() + + ggplot2::labs( + x = "Initial events dropped", + y = "Share of information", + subtitle = "Accrual against proportional, onset window shaded" + ) +} + +#' Plotting a goldfish model fit at a glance +#' +#' @description +#' One call, four diagnostic panels: whether any interval is badly fitted, +#' whether any coefficient drifts, whether each effect's contribution is +#' spread over the sequence, and whether the waiting times are what the model +#' says they are. +#' +#' @details +#' Everything is drawn from what the **fit already stores** --- no evaluation +#' pass and no preprocessed statistics --- so the figure costs a plot and not +#' a re-fit. The consequence is that a panel needing a primitive the fit did +#' not store is **left out** rather than erroring: which panels appear is +#' itself a readout of what was requested at estimation. +#' +#' \describe{ +#' \item{deviance}{the per-interval log-likelihood with outlying intervals +#' marked. Needs the `"loglik"` primitive.} +#' \item{scaled Schoenfeld}{a smooth per effect against the fitted estimate, +#' flat under a constant coefficient. Needs `"scores"` on a multinomial +#' sub-model, and `"conditional_scores"` on an exact-time one, where the +#' score carries an exposure term the Schoenfeld residual does not.} +#' \item{cumulative score}{each effect's standardized process against its +#' Brownian-bridge band. Needs `"scores"`.} +#' \item{waiting times}{the Cox-Snell residuals against the unit +#' exponential they follow under the model. Exact-time sub-models only: +#' an ordinal likelihood conditions the timing away, so there is no +#' waiting time to check.} +#' } +#' +#' The Schoenfeld panel is capped at the `effects` most worth looking at, +#' ranked by their cumulative-score statistic, since a model with a dozen +#' terms makes a facet grid unreadable at overview size. +#' +#' @param x A fitted model of class `goldfishFit`. +#' @param ... Additional plotting parameters, currently unused. +#' @param effects The number of effects to draw in the Schoenfeld panel. +#' @return A patchwork composition of the available panels. +#' @name plot_goldfish_fit +#' @examples +#' plot(goldfish_fit) +#' @export +plot.goldfishFit <- function(x, ..., effects = 4) { + thisRequires("goldfish") + panels <- list( + gf_overview_deviance(x), + gf_overview_schoenfeld(x, effects), + gf_overview_gof(x), + gf_overview_waiting(x) + ) + panels <- Filter(Negate(is.null), panels) + if (length(panels) == 0) { + cat("This fit stores no diagnostic primitive to plot.\n") + return(invisible(NULL)) + } + patchwork::wrap_plots(panels, ncol = min(2, length(panels))) +} + +# Each panel is attempted and dropped on failure rather than pre-checked +# against a primitive list: goldfish already raises a named error when a +# primitive is missing, and duplicating its availability rules here is how the +# two would drift apart. +gf_overview_try <- function(expr) { + tryCatch(expr, error = function(e) NULL) +} + +gf_overview_deviance <- function(x) { + outliers <- gf_overview_try(.ag_goldfish("diagnose_outliers")(x)) + if (is.null(outliers)) { + return(NULL) + } + data <- as.data.frame(outliers) + # Unlike the standalone method this draws the trace even with nothing + # flagged: in a composed figure a clean panel is a finding, and a panel that + # vanished would read as a missing primitive instead. + ggplot2::ggplot(data, ggplot2::aes(x = .data$time, y = .data$.series)) + + ggplot2::geom_line(colour = ag_base(), na.rm = TRUE) + + ggplot2::geom_point( + data = data[!is.na(data$outlier) & data$outlier, , drop = FALSE], + colour = ag_highlight(), + na.rm = TRUE + ) + + ag_theme_minimal() + + ggplot2::labs(x = "", y = "Interval log likelihood", subtitle = "Deviance") +} + +gf_overview_schoenfeld <- function(x, effects) { + rows <- gf_overview_try( + stats::residuals(x, type = "scaled_schoenfeld") + ) + if (is.null(rows)) { + return(NULL) + } + available <- colnames(rows) + keep <- gf_overview_rank(x, available, effects) + omitted <- length(available) - length(keep) + labels <- gf_overview_labels(x, keep, available) + long <- data.frame( + interval = rep(seq_len(nrow(rows)), times = length(keep)), + term = rep(labels, each = nrow(rows)), + value = as.numeric(rows[, keep, drop = FALSE]) + ) + estimates <- stats::coef(x)[keep] + reference <- data.frame(term = labels, estimate = as.numeric(estimates)) + + ggplot2::ggplot(long, ggplot2::aes(x = .data$interval, y = .data$value)) + + ggplot2::geom_hline( + data = reference, + ggplot2::aes(yintercept = .data$estimate), + colour = ag_base() + ) + + ggplot2::geom_smooth( + method = "loess", + formula = y ~ x, + se = FALSE, + colour = ag_highlight(), + na.rm = TRUE + ) + + ggplot2::facet_wrap(~ .data$term, scales = "free_y") + + ag_theme_minimal() + + ggplot2::labs( + x = "", + y = "", + # A reduced figure says so. Drawing four of fifty-six without a word is + # the same failure as a diagnostic reporting nothing because it could not + # see anything: the output looks like an answer about the whole model. + subtitle = if (omitted > 0) { + paste0( + "Scaled Schoenfeld \u2014 ", + length(keep), + " of ", + length(available), + " terms, ranked; ", + omitted, + " not shown" + ) + } else { + "Scaled Schoenfeld" + } + ) +} + +# Which effects the Schoenfeld panel draws. Ranked by the cumulative-score +# statistic where it is available, so the panel shows what is worth looking at +# rather than whichever terms the formula happened to name first. +gf_overview_rank <- function(x, terms, effects) { + if (length(terms) <= effects) { + return(seq_along(terms)) + } + gof <- gf_overview_try(.ag_goldfish("test_gof")(x)) + if (is.null(gof)) { + return(seq_len(effects)) + } + # Selected by COLUMN POSITION, not by name. The residual matrix is named by + # effect (`indeg`, `outdeg`), which repeats when one effect appears over two + # networks, while the test names coefficients (`ideg_cal`, `ideg_fri`). The + # two vocabularies intersect only on the intercept, so matching them by name + # silently kept one term where several were asked for -- and with duplicated + # names, `rows[, "indeg"]` would have drawn the first of them either way. + ranked <- gof$effects$index[order(gof$effects$statistic, decreasing = TRUE)] + ranked <- ranked[ranked >= 1 & ranked <= length(terms)] + if (length(ranked) == 0) { + seq_len(effects) + } else { + utils::head(ranked, effects) + } +} + +# Panel labels for the selected columns. The test's own compact term strings +# where they are available, since those distinguish an effect appearing over +# two networks; otherwise the residual names made unique, which is ugly but +# never ambiguous. +gf_overview_labels <- function(x, keep, terms) { + gof <- gf_overview_try(.ag_goldfish("test_gof")(x)) + labels <- make.unique(terms)[keep] + if (!is.null(gof)) { + matched <- match(keep, gof$effects$index) + labels <- ifelse(is.na(matched), labels, gof$effects$term[matched]) + } + labels +} + +gf_overview_gof <- function(x) { + gof <- gf_overview_try(.ag_goldfish("test_gof")(x)) + if (is.null(gof)) { + return(NULL) + } + plot(gof) + + ggplot2::labs(subtitle = "Cumulative score", x = "", y = "") + + ggplot2::theme(strip.text = ggplot2::element_text(size = ag_text_size(7))) +} + +gf_overview_waiting <- function(x) { + # Exact-time only, and the error goldfish raises on an ordinal fit is what + # decides that -- the panel does not re-derive which families have a + # compensator. + residuals <- gf_overview_try(stats::residuals(x, type = "cox_snell")) + if (is.null(residuals)) { + return(NULL) + } + observed <- sort(as.numeric(residuals)) + data <- data.frame( + theoretical = stats::qexp(stats::ppoints(length(observed))), + observed = observed + ) + ggplot2::ggplot( + data, + ggplot2::aes(x = .data$theoretical, y = .data$observed) + ) + + ggplot2::geom_abline(slope = 1, intercept = 0, colour = ag_ink()) + + ggplot2::geom_point(colour = ag_highlight(), alpha = 0.5) + + ag_theme_minimal() + + ggplot2::labs( + x = "Unit exponential", + y = "Cox-Snell residual", + subtitle = "Waiting times" + ) +} + +# Pagination -------------------------------------------------------------- + +#' How many pages a paged diagnostic figure has +#' +#' @description +#' The page count of [plot()] on a per-term diagnostic, derivable **without +#' rendering** so a loop can write every page. +#' +#' A method that only discovers it is on the last page once it gets there +#' cannot be scripted, and scripting is the case this exists for: fits go to a +#' cluster, so a figure has to be producible with nobody at a screen to press +#' return. +#' +#' @param x a diagnostic object with one panel per term -- as returned by +#' `test_gof()`, `test_time()`, `diagnose_onset()`, or a fitted goldfish +#' model. +#' @param nrow,ncol panels per page, matching what will be passed to `plot()`. +#' +#' @return A single integer, at least 1. +#' @examples +#' count_pages(goldfish_gof) +#' @export +count_pages <- function(x, nrow = 2, ncol = 2) { + panels <- gf_panel_count(x) + if (is.na(panels) || panels < 1) { + return(1L) + } + as.integer(max(1L, ceiling(panels / (nrow * ncol)))) +} + +# How many panels a per-term figure would draw. Read off the same component and +# the same facet columns the plot method facets by, so the two cannot disagree +# about what a page holds. +gf_panel_count <- function(x) { + data <- gf_panel_data(x) + if (is.null(data)) { + return(NA_integer_) + } + keys <- intersect(c("term", "flavor", "family"), names(data)) + if (length(keys) == 0) { + return(NA_integer_) + } + nrow(unique(data[keys])) +} + +gf_panel_data <- function(x) { + if (inherits(x, "goldfishGOF")) { + return(as.data.frame(x$process)) + } + if (inherits(x, "goldfishTimeTest")) { + return(as.data.frame(x$residuals)) + } + if (inherits(x, "goldfishOnset")) { + return(as.data.frame(x$path)) + } + if (inherits(x, "goldfishFit")) { + return(NULL) + } + NULL +} + +# One page of a faceted figure, or all of it. +# +# `page = NULL` keeps the ordinary `facet_wrap()`, so nothing about the +# unpaged figure changes. A page beyond the last is an error naming the count +# rather than an empty panel, which is what a loop with an off-by-one would +# otherwise produce and not notice. +gf_facet_paged <- function(p, facets, page, nrow, ncol, n_pages, scales) { + if (is.null(page)) { + return(p + ggplot2::facet_wrap(facets, scales = scales)) + } + if (!is.numeric(page) || length(page) != 1L || is.na(page) || page < 1) { + manynet::snet_abort("{.arg page} must be a single positive number.") + } + page <- as.integer(page) + if (page > n_pages) { + manynet::snet_abort( + "{.arg page} {.val {page}} is past the last page.", + "This figure has {n_pages} page{?s} at", + "{.code nrow = {nrow}, ncol = {ncol}}.", + "{.fn count_pages} reports the count without rendering.") + } + p + + ggforce::facet_wrap_paginate( + facets, + nrow = nrow, + ncol = ncol, + page = page, + scales = scales + ) +} + +# Level against shape, one point per actor. +# +# The quadrants are the reading. An actor is calibrated on level near the +# vertical reference and on shape near a dispersion of one, so the four corners +# are four distinct misfits: too many events and bursty, too few and bursty, +# and so on. Sized by the event count because the shape reading is undefined +# below two completed spans and noisy just above it -- a large point is one +# worth believing. +gf_margin_scatter <- function(data, martingale, top) { + data$value <- if (martingale) { + data$observed - data$expected_count + } else { + data$observed / data$expected_probability + } + reference <- if (martingale) 0 else 1 + usable <- data[!is.na(data$dispersion), , drop = FALSE] + omitted_shape <- nrow(data) - nrow(usable) + + deviation <- abs(usable$value - reference) + ranked <- names(sort( + tapply(deviation, usable$actor, max, na.rm = TRUE), + decreasing = TRUE + )) + omitted_top <- max(0, length(ranked) - top) + if (omitted_top > 0) { + usable <- usable[usable$actor %in% ranked[seq_len(top)], ] + } + + p <- ggplot2::ggplot( + usable, + ggplot2::aes(x = .data$value, y = .data$dispersion) + ) + + ggplot2::geom_vline(xintercept = reference, colour = ag_ink()) + + # One is the dispersion of a unit exponential, which each span is under a + # correct model -- the same reference the level axis reads against. + ggplot2::geom_hline(yintercept = 1, colour = ag_ink()) + + ggplot2::geom_point( + ggplot2::aes(size = .data$observed), + alpha = 0.6, + colour = ag_highlight(), + na.rm = TRUE + ) + + ggplot2::scale_size_continuous(name = "Events") + + ag_theme_minimal() + + ggplot2::labs( + x = if (martingale) { + "Observed minus expected events" + } else { + "Observed over expected events" + }, + y = "Dispersion of the actor's own spans", + subtitle = gf_scatter_subtitle(omitted_shape, omitted_top) + ) + facets <- intersect(c("flavor", "family", "role"), names(usable)) + if (length(facets) > 0) { + p <- p + + ggplot2::facet_wrap( + stats::as.formula(paste("~", paste(facets, collapse = " + "))) + ) + } + p +} + +# Both kinds of omission are named. An actor can be missing because it has too +# few events for a shape reading, or because it is not among the `top` furthest +# from the reference, and a figure that drew a subset without saying which +# would look like the whole node set. +gf_scatter_subtitle <- function(omitted_shape, omitted_top) { + parts <- c( + if (omitted_shape > 0) { + paste(omitted_shape, "actors below two completed spans") + }, + if (omitted_top > 0) paste(omitted_top, "further actors not shown") + ) + if (length(parts) == 0) NULL else paste(parts, collapse = "; ") +} diff --git a/R/plot_gof.R b/R/plot_gof.R index f1169aed..c76a8c37 100644 --- a/R/plot_gof.R +++ b/R/plot_gof.R @@ -68,23 +68,23 @@ plot.ag_gof <- function(x, ...){ obs <- x[[1]] sims <- x[[2]] if(all(!is.na(suppressWarnings(as.numeric(sims$name))))){ - obs <- obs %>% dplyr::mutate(name = .to_factor(name)) - sims <- sims %>% dplyr::mutate(name = .to_factor(name)) + obs <- obs |> dplyr::mutate(name = .to_factor(name)) + sims <- sims |> dplyr::mutate(name = .to_factor(name)) } main <- x[[3]] p_value <- x[[4]] # Compute quantiles for each x if("ego" %in% names(obs)) { - bounds <- sims %>% - dplyr::group_by(name, ego) %>% + bounds <- sims |> + dplyr::group_by(name, ego) |> dplyr::summarise( q05 = stats::quantile(value, 0.05), q95 = stats::quantile(value, 0.95), .groups = "drop") } else { - bounds <- sims %>% - dplyr::group_by(name) %>% + bounds <- sims |> + dplyr::group_by(name) |> dplyr::summarise( q05 = stats::quantile(value, 0.05), q95 = stats::quantile(value, 0.95), @@ -107,7 +107,7 @@ plot.ag_gof <- function(x, ...){ ggplot2::geom_line(data = obs, aes(x = name, y = value), group = 1, color = ag_highlight()) + - ggplot2::theme_minimal(base_family = ag_font()) + + ag_theme_minimal() + ggplot2::labs(y = "Statistic", title = main, x = if(is.null(p_value)) "" else paste("p:", round(p_value, 3), collapse = " ")) @@ -157,10 +157,10 @@ plot.gof.stats.monan <- function(x, cumulative = FALSE, ...) { p_value <- NULL if(cumulative){ - sims <- sims %>% dplyr::group_by(sim) %>% - dplyr::mutate(value = cumsum(.data$value)) %>% + sims <- sims |> dplyr::group_by(sim) |> + dplyr::mutate(value = cumsum(.data$value)) |> dplyr::ungroup() - obs <- obs %>% + obs <- obs |> mutate(value = cumsum(.data$value)) } @@ -210,19 +210,19 @@ plot.sienaGOF <- function(x, cumulative = FALSE, ...){ itns <- nrow(sims) n.obs <- nrow(obs) sims <- sims[,!no_vary] - sims <- as.data.frame(sims) %>% dplyr::mutate(sim = 1:nrow(sims)) + sims <- as.data.frame(sims) |> dplyr::mutate(sim = 1:nrow(sims)) sims <- stats::reshape(sims, varying = list(colnames(sims)[-ncol(sims)]), v.names = "value", timevar = "name", times = colnames(sims)[-ncol(sims)], - idvar = "sim", direction = "long") %>% - dplyr::tibble() %>% dplyr::arrange(sim) + idvar = "sim", direction = "long") |> + dplyr::tibble() |> dplyr::arrange(sim) obs <- obs[!no_vary] obs <- data.frame(name = sims$name[!duplicated(sims$name)], value = obs) # if(!cumulative){ - # sims <- sims %>% dplyr::group_by(sim) %>% - # dplyr::mutate(value = c(.data$value[1], diff(.data$value))) %>% + # sims <- sims |> dplyr::group_by(sim) |> + # dplyr::mutate(value = c(.data$value[1], diff(.data$value))) |> # dplyr::ungroup() - # obs <- obs %>% + # obs <- obs |> # mutate(value = c(.data$value[1], diff(.data$value))) # } @@ -230,11 +230,11 @@ plot.sienaGOF <- function(x, cumulative = FALSE, ...){ if(!all(nchar(obs[,"name"])==2)) manynet::snet_abort("Ego-alter GOF statistic names should be two characters long,", " but some are not. Please check the number or names in the GOF object.") - obs <- obs %>% dplyr::mutate(ego = paste("Ego", substr(name, 1, 1)), - name = substr(name, 2, 2)) %>% + obs <- obs |> dplyr::mutate(ego = paste("Ego", substr(name, 1, 1)), + name = substr(name, 2, 2)) |> dplyr::mutate(ego = .to_factor(ego), name = .to_factor(name)) - sims <- sims %>% dplyr::mutate(ego = paste("Ego", substr(name, 1, 1)), - name = substr(name, 2, 2)) %>% + sims <- sims |> dplyr::mutate(ego = paste("Ego", substr(name, 1, 1)), + name = substr(name, 2, 2)) |> dplyr::mutate(ego = .to_factor(ego), name = .to_factor(name)) } @@ -298,7 +298,7 @@ plot.gof.ergm <- function(x, cumulative = FALSE, obs <- data.frame(name = names(x[[paste0("obs.",statistic)]]), value = x[[paste0("obs.",statistic)]], - stringsAsFactors = FALSE) %>% + stringsAsFactors = FALSE) |> dplyr::tibble() if(nrow(obs) == 0){ manynet::snet_abort("Note: {statdescription} {.code {statistic}} is not available in this GOF object.") @@ -313,7 +313,7 @@ plot.gof.ergm <- function(x, cumulative = FALSE, obs <- obs[!no_vary, ] .inform_no_variance(statkeys) } - obs <- obs %>% dplyr::mutate(name = .to_factor(name)) + obs <- obs |> dplyr::mutate(name = .to_factor(name)) sims <- as.data.frame(simsMat, check.names = FALSE) sims$sim <- 1:nrow(sims) sims <- stats::reshape(sims, @@ -322,18 +322,18 @@ plot.gof.ergm <- function(x, cumulative = FALSE, v.names = "value", timevar = "name", times = colnames(sims)[-ncol(sims)], - idvar = "sim") %>% - dplyr::tibble() %>% - dplyr::mutate(name = .to_factor(name)) %>% + idvar = "sim") |> + dplyr::tibble() |> + dplyr::mutate(name = .to_factor(name)) |> dplyr::arrange(sim) p_value <- NULL if(cumulative){ - sims <- sims %>% dplyr::group_by(sim) %>% - dplyr::mutate(value = cumsum(.data$value)) %>% + sims <- sims |> dplyr::group_by(sim) |> + dplyr::mutate(value = cumsum(.data$value)) |> dplyr::ungroup() - obs <- obs %>% + obs <- obs |> mutate(value = cumsum(.data$value)) } diff --git a/R/plot_interp.R b/R/plot_interp.R index 14a7f473..06b08c1c 100644 --- a/R/plot_interp.R +++ b/R/plot_interp.R @@ -70,7 +70,7 @@ plot.selectionTable <- function(x, quad = TRUE, separation = 0, ...){ # ggplot2::scale_linetype_manual( # values= c('solid', 'longdash','dashed', # 'twodash', 'dotdash', 'dotted'), labels=labels) + - ggplot2::theme_minimal(base_size=8, base_family=ag_font()) + ag_theme_minimal(base_size=8) # + ggplot2::theme(panel.grid.major = ggplot2::element_blank(), # panel.grid.minor = ggplot2::element_blank()) } else { @@ -78,7 +78,7 @@ plot.selectionTable <- function(x, quad = TRUE, separation = 0, ...){ gs + ggplot2::scale_colour_manual(values = setNames(ag_sequential(length(labs)), labs)) + - ggplot2::theme_minimal(base_size=8, base_family=ag_font()) + ag_theme_minimal(base_size=8) } nametext <- attr(x, "name") @@ -120,7 +120,7 @@ plot.influenceTable <- function(x, separation=0, ...){ sp <- ggplot2::ggplot(zselect, ggplot2::aes(zego, select, group=alter, colour=alter)) + - ggplot2::theme_bw() + ag_theme_bw() if (quad) { gs <- ggplot2::geom_smooth(linewidth=1.2, span=3, @@ -144,7 +144,7 @@ plot.influenceTable <- function(x, separation=0, ...){ ggplot2::labs(x=paste(beh.label,'ego value'), y=ylabel, title=title, # linetype=paste(beh.label,'\nalter\nvalue'), colour=paste(beh.label,'\nalter\nvalue')) + - # ggplot2::theme_grey(base_size=14, base_family="") + + # ag_theme_grey(base_size=14, base_family="") + ggplot2::theme(legend.key.width = ggplot2::unit(1, "cm")) + ggplot2::theme(text = element_text(family = ag_font()), plot.title = element_text(hjust=0.5, diff --git a/R/plot_manydata.R b/R/plot_manydata.R index 51ba1c05..7cd0c078 100644 --- a/R/plot_manydata.R +++ b/R/plot_manydata.R @@ -17,7 +17,7 @@ #' NULL #' #' #' @rdname plot_ -#' #' @importFrom dplyr %>% select mutate distinct rename +#' #' @importFrom dplyr select mutate distinct rename #' #' @return A network of agreements' relations. #' #' @examples #' #' \donttest{ @@ -30,12 +30,12 @@ #' layout = "circle") { #' manyID <- treatyID <- name <- NULL #' if (key == "manyID") { -#' out <- dplyr::select(dataset, manyID) %>% -#' dplyr::rename(key = manyID) %>% +#' out <- dplyr::select(dataset, manyID) |> +#' dplyr::rename(key = manyID) |> #' dplyr::distinct() #' } else if (key == "treatyID") { -#' out <- dplyr::select(dataset, treatyID) %>% -#' dplyr::rename(key == treatyID) %>% +#' out <- dplyr::select(dataset, treatyID) |> +#' dplyr::rename(key == treatyID) |> #' dplyr::distinct() #' } else snet_abort("Please declare either 'manyID' or 'treatyID'.") #' if (!is.null(treaty_type)) { @@ -49,14 +49,14 @@ #' dplyr::mutate(out, #' link = ifelse(grepl(":", key), sapply(strsplit(key, ":"), #' "[", 2), "NA"), -#' key = gsub("\\:.*", "", key)) %>% -#' as_tidygraph() %>% -#' dplyr::filter(name != "NA") %>% +#' key = gsub("\\:.*", "", key)) |> +#' as_tidygraph() |> +#' dplyr::filter(name != "NA") |> #' graphr(layout = layout) #' } #' #' #' @rdname plot_ -#' #' @importFrom dplyr %>% select distinct all_of rename +#' #' @importFrom dplyr select distinct all_of rename #' #' @return A network of agreements' memberships. #' #' @examples #' #' \donttest{ @@ -69,12 +69,12 @@ #' key = "manyID", layout = "bipartite") { #' manyID <- treatyID <- name <- NULL #' if (key == "manyID") { -#' out <- dplyr::select(dataset, manyID, dplyr::all_of(actor)) %>% -#' dplyr::rename(key = manyID) %>% +#' out <- dplyr::select(dataset, manyID, dplyr::all_of(actor)) |> +#' dplyr::rename(key = manyID) |> #' dplyr::distinct() #' } else if (key == "treatyID") { -#' out <- dplyr::select(dataset, treatyID, dplyr::all_of(actor)) %>% -#' dplyr::rename(key == treatyID) %>% +#' out <- dplyr::select(dataset, treatyID, dplyr::all_of(actor)) |> +#' dplyr::rename(key == treatyID) |> #' dplyr::distinct() #' } else snet_abort("Please declare either 'manyID' or 'treatyID'.") #' if (!is.null(treaty_type)) { @@ -85,15 +85,15 @@ #' out <- out[grep("-", out$key, invert = TRUE),] #' } #' } -#' stats::na.omit(out) %>% -#' as_tidygraph() %>% +#' stats::na.omit(out) |> +#' as_tidygraph() |> #' mutate(type = ifelse(grepl("[0-9][0-9][0-9][0-9][A-Za-z]", -#' name), TRUE, FALSE)) %>% +#' name), TRUE, FALSE)) |> #' graphr(layout = layout) #' } #' #' #' @rdname plot_ -#' #' @importFrom dplyr %>% select mutate distinct filter rename +#' #' @importFrom dplyr select mutate distinct filter rename #' #' @return A plot of agreements' lineages. #' #' @examples #' #' \donttest{ @@ -106,12 +106,12 @@ #' layout = "nicely") { #' manyID <- treatyID <- name <- NULL #' if (key == "manyID") { -#' out <- dplyr::select(dataset, manyID) %>% -#' dplyr::rename(key = manyID) %>% +#' out <- dplyr::select(dataset, manyID) |> +#' dplyr::rename(key = manyID) |> #' dplyr::distinct() #' } else if (key == "treatyID") { -#' out <- dplyr::select(dataset, treatyID) %>% -#' dplyr::rename(key == treatyID) %>% +#' out <- dplyr::select(dataset, treatyID) |> +#' dplyr::rename(key == treatyID) |> #' dplyr::distinct() #' } else snet_abort("Please declare either 'manyID' or 'treatyID'.") #' if (!is.null(treaty_type)) { @@ -122,12 +122,12 @@ #' out <- out[grep("-", out$key, invert = TRUE),] #' } #' } -#' out %>% -#' dplyr::filter(grepl(":", key)) %>% +#' out |> +#' dplyr::filter(grepl(":", key)) |> #' dplyr::mutate(key1 = gsub(".*\\:", "", key), -#' key = gsub("\\:.*", "", key)) %>% -#' dplyr::distinct() %>% -#' as_tidygraph() %>% +#' key = gsub("\\:.*", "", key)) |> +#' dplyr::distinct() |> +#' as_tidygraph() |> #' graphr(layout = "nicely") #' } #' @@ -201,10 +201,10 @@ #' ab[ab == ""] <- NA #' cshapes <- dplyr::mutate(cshapes, stateID = unname(ab)) #' # Step 6: create edges with from/to lat/long -#' edges <- out %>% -#' dplyr::inner_join(cshapes, by = c("from" = "stateID")) %>% -#' dplyr::rename(x = .data$caplong, y = .data$caplat) %>% -#' dplyr::inner_join(cshapes, by = c("to" = "stateID")) %>% +#' edges <- out |> +#' dplyr::inner_join(cshapes, by = c("from" = "stateID")) |> +#' dplyr::rename(x = .data$caplong, y = .data$caplat) |> +#' dplyr::inner_join(cshapes, by = c("to" = "stateID")) |> #' dplyr::rename(xend = .data$caplong, yend = .data$caplat) #' # Step 7: Create plotted network from computed edges #' g <- as_tidygraph(edges) @@ -212,8 +212,8 @@ #' country_shapes <- ggplot2::geom_sf(data = cshapes$geometry, #' fill = countrycolor) #' # Step 9: generate the point coordinates for capitals -#' cshapes_pos <- cshapes %>% -#' dplyr::filter(.data$stateID %in% node_names(g)) %>% +#' cshapes_pos <- cshapes |> +#' dplyr::filter(.data$stateID %in% node_names(g)) |> #' dplyr::rename(x = .data$caplong, y = .data$caplat) #' # Reorder things according to nodes in plotted network g #' cshapes_pos <- cshapes_pos[match(node_names(g), diff --git a/R/plot_summaries.R b/R/plot_summaries.R index 8c75827d..d794fd6a 100644 --- a/R/plot_summaries.R +++ b/R/plot_summaries.R @@ -23,7 +23,7 @@ plot.diff_model <- function(x, ..., all_steps = TRUE){ "Check the {.arg seeds} given to {.fn manynet::play_diffusion},", "and that the network has ties.") else { data <- x - if(!all_steps) data <- data %>% + if(!all_steps) data <- data |> dplyr::filter(!(data$I==data$I[length(data$I)] * duplicated(data$I==data$I[length(data$I)]))) p <- ggplot2::ggplot(data) + @@ -33,7 +33,7 @@ plot.diff_model <- function(x, ..., all_steps = TRUE){ linewidth = 1.25) + ggplot2::geom_col(ggplot2::aes(x = time, y = I_new/n), alpha = 0.4) + - ggplot2::theme_minimal() + + ag_theme_minimal() + # using coord_cartesian to avoid printing warnings ggplot2::coord_cartesian(ylim = c(0,1)) + ggplot2::scale_x_continuous(breaks = function(x) pretty(x, n=6)) + @@ -85,7 +85,7 @@ plot.diffs_model <- function(x, ...){ method = "loess", se=TRUE, level = .95, formula = 'y~x') + ggplot2::geom_smooth(ggplot2::aes(x = time, y = I/n, color = "C"), method = "loess", se=TRUE, level = .95, formula = 'y~x') + - ggplot2::theme_minimal() + + ag_theme_minimal() + ggplot2::coord_cartesian(ylim = c(0,1)) + # using coord_cartesion to avoid printing warnings ggplot2::scale_x_continuous(breaks = function(x) pretty(x, n=6)) + ggplot2::ylab("Proportion") + ggplot2::xlab("Steps") @@ -121,7 +121,7 @@ plot.learn_model <- function(x, ...){ y <- as.data.frame.table(y) y$Step <- as.numeric(gsub("t", "", y$Var2)) ggplot2::ggplot(y, ggplot2::aes(x = Step, y = Freq, color = Var1)) + - ggplot2::geom_line(show.legend = FALSE) + ggplot2::theme_minimal() + + ggplot2::geom_line(show.legend = FALSE) + ag_theme_minimal() + ggplot2::scale_color_manual(values = ag_qualitative(ncol(x))) + ggplot2::ylab("Belief") } @@ -145,7 +145,7 @@ plot.learn_model <- function(x, ...){ #' NULL #' #' #' @rdname plot_ -#' #' @importFrom dplyr %>% select mutate distinct rename +#' #' @importFrom dplyr select mutate distinct rename #' #' @return A network of agreements' relations. #' #' @examples #' #' \donttest{ @@ -158,12 +158,12 @@ plot.learn_model <- function(x, ...){ #' layout = "circle") { #' manyID <- treatyID <- name <- NULL #' if (key == "manyID") { -#' out <- dplyr::select(dataset, manyID) %>% -#' dplyr::rename(key = manyID) %>% +#' out <- dplyr::select(dataset, manyID) |> +#' dplyr::rename(key = manyID) |> #' dplyr::distinct() #' } else if (key == "treatyID") { -#' out <- dplyr::select(dataset, treatyID) %>% -#' dplyr::rename(key == treatyID) %>% +#' out <- dplyr::select(dataset, treatyID) |> +#' dplyr::rename(key == treatyID) |> #' dplyr::distinct() #' } else cli::cli_abort("Please declare either 'manyID' or 'treatyID'.") #' if (!is.null(treaty_type)) { @@ -177,14 +177,14 @@ plot.learn_model <- function(x, ...){ #' dplyr::mutate(out, #' link = ifelse(grepl(":", key), sapply(strsplit(key, ":"), #' "[", 2), "NA"), -#' key = gsub("\\:.*", "", key)) %>% -#' as_tidygraph() %>% -#' dplyr::filter(name != "NA") %>% +#' key = gsub("\\:.*", "", key)) |> +#' as_tidygraph() |> +#' dplyr::filter(name != "NA") |> #' graphr(layout = layout) #' } #' #' #' @rdname plot_ -#' #' @importFrom dplyr %>% select distinct all_of rename +#' #' @importFrom dplyr select distinct all_of rename #' #' @return A network of agreements' memberships. #' #' @examples #' #' \donttest{ @@ -197,12 +197,12 @@ plot.learn_model <- function(x, ...){ #' key = "manyID", layout = "bipartite") { #' manyID <- treatyID <- name <- NULL #' if (key == "manyID") { -#' out <- dplyr::select(dataset, manyID, dplyr::all_of(actor)) %>% -#' dplyr::rename(key = manyID) %>% +#' out <- dplyr::select(dataset, manyID, dplyr::all_of(actor)) |> +#' dplyr::rename(key = manyID) |> #' dplyr::distinct() #' } else if (key == "treatyID") { -#' out <- dplyr::select(dataset, treatyID, dplyr::all_of(actor)) %>% -#' dplyr::rename(key == treatyID) %>% +#' out <- dplyr::select(dataset, treatyID, dplyr::all_of(actor)) |> +#' dplyr::rename(key == treatyID) |> #' dplyr::distinct() #' } else cli::cli_abort("Please declare either 'manyID' or 'treatyID'.") #' if (!is.null(treaty_type)) { @@ -213,15 +213,15 @@ plot.learn_model <- function(x, ...){ #' out <- out[grep("-", out$key, invert = TRUE),] #' } #' } -#' stats::na.omit(out) %>% -#' as_tidygraph() %>% +#' stats::na.omit(out) |> +#' as_tidygraph() |> #' mutate(type = ifelse(grepl("[0-9][0-9][0-9][0-9][A-Za-z]", -#' name), TRUE, FALSE)) %>% +#' name), TRUE, FALSE)) |> #' graphr(layout = layout) #' } #' #' #' @rdname plot_ -#' #' @importFrom dplyr %>% select mutate distinct filter rename +#' #' @importFrom dplyr select mutate distinct filter rename #' #' @return A plot of agreements' lineages. #' #' @examples #' #' \donttest{ @@ -234,12 +234,12 @@ plot.learn_model <- function(x, ...){ #' layout = "nicely") { #' manyID <- treatyID <- name <- NULL #' if (key == "manyID") { -#' out <- dplyr::select(dataset, manyID) %>% -#' dplyr::rename(key = manyID) %>% +#' out <- dplyr::select(dataset, manyID) |> +#' dplyr::rename(key = manyID) |> #' dplyr::distinct() #' } else if (key == "treatyID") { -#' out <- dplyr::select(dataset, treatyID) %>% -#' dplyr::rename(key == treatyID) %>% +#' out <- dplyr::select(dataset, treatyID) |> +#' dplyr::rename(key == treatyID) |> #' dplyr::distinct() #' } else cli::cli_abort("Please declare either 'manyID' or 'treatyID'.") #' if (!is.null(treaty_type)) { @@ -250,12 +250,12 @@ plot.learn_model <- function(x, ...){ #' out <- out[grep("-", out$key, invert = TRUE),] #' } #' } -#' out %>% -#' dplyr::filter(grepl(":", key)) %>% +#' out |> +#' dplyr::filter(grepl(":", key)) |> #' dplyr::mutate(key1 = gsub(".*\\:", "", key), -#' key = gsub("\\:.*", "", key)) %>% -#' dplyr::distinct() %>% -#' as_tidygraph() %>% +#' key = gsub("\\:.*", "", key)) |> +#' dplyr::distinct() |> +#' as_tidygraph() |> #' graphr(layout = "nicely") #' } #' @@ -329,10 +329,10 @@ plot.learn_model <- function(x, ...){ #' ab[ab == ""] <- NA #' cshapes <- dplyr::mutate(cshapes, stateID = unname(ab)) #' # Step 6: create edges with from/to lat/long -#' edges <- out %>% -#' dplyr::inner_join(cshapes, by = c("from" = "stateID")) %>% -#' dplyr::rename(x = .data$caplong, y = .data$caplat) %>% -#' dplyr::inner_join(cshapes, by = c("to" = "stateID")) %>% +#' edges <- out |> +#' dplyr::inner_join(cshapes, by = c("from" = "stateID")) |> +#' dplyr::rename(x = .data$caplong, y = .data$caplat) |> +#' dplyr::inner_join(cshapes, by = c("to" = "stateID")) |> #' dplyr::rename(xend = .data$caplong, yend = .data$caplat) #' # Step 7: Create plotted network from computed edges #' g <- as_tidygraph(edges) @@ -340,8 +340,8 @@ plot.learn_model <- function(x, ...){ #' country_shapes <- ggplot2::geom_sf(data = cshapes$geometry, #' fill = countrycolor) #' # Step 9: generate the point coordinates for capitals -#' cshapes_pos <- cshapes %>% -#' dplyr::filter(.data$stateID %in% node_names(g)) %>% +#' cshapes_pos <- cshapes |> +#' dplyr::filter(.data$stateID %in% node_names(g)) |> #' dplyr::rename(x = .data$caplong, y = .data$caplat) #' # Reorder things according to nodes in plotted network g #' cshapes_pos <- cshapes_pos[match(node_names(g), diff --git a/R/plot_tests.R b/R/plot_tests.R index 0e4cfb18..c40a12a2 100644 --- a/R/plot_tests.R +++ b/R/plot_tests.R @@ -54,7 +54,7 @@ plot.network_test <- function(x, ..., ggplot2::geom_area(data = subset(d, x > thresh[2]), aes(x = x, y = .data$y), fill = "lightgrey") } - p + ggplot2::theme_classic(base_family = ag_font()) + ggplot2::geom_density() + + p + ag_theme_classic() + ggplot2::geom_density() + ggplot2::geom_vline(ggplot2::aes(xintercept = x$testval), color = utils::tail(getOption("snet_highlight", default = "red"), n = 1), @@ -100,7 +100,7 @@ plot.netlm <- function(x, ...){ ggplot2::geom_violin(quantile.color = ag_base(), quantile.linetype = "solid", quantiles = c(0.025, 0.975)) + - ggplot2::theme_minimal(base_family = ag_font()) + + ag_theme_minimal() + ylab("") + xlab("Statistic") + ggplot2::geom_point(aes(x = .data$tstat), size = 2, colour = utils::tail(getOption("snet_highlight", @@ -131,7 +131,7 @@ plot.netlogit <- function(x, ...){ ggplot2::geom_violin(quantile.color = ag_base(), quantile.linetype = "solid", quantiles = c(0.025, 0.975)) + - ggplot2::theme_minimal(base_family = ag_font()) + + ag_theme_minimal() + ylab("") + xlab("Statistic") + ggplot2::geom_point(aes(x = .data$tstat), size = 2, colour = utils::tail(getOption("snet_highlight", diff --git a/R/theme_colorblind.R b/R/theme_colorblind.R new file mode 100644 index 00000000..bdad6bac --- /dev/null +++ b/R/theme_colorblind.R @@ -0,0 +1,245 @@ +#' Checking colours for colour blindness, print, and legibility +#' @description +#' These functions report how a set of colours holds up for viewers with +#' colour vision deficiency (CVD), which affects about 8% of men and 0.5% +#' of women, and for readers who see the plot in greyscale or at a distance. +#' +#' `simulate_colorblind()` returns what a set of colours looks like to a viewer with +#' a given type of colour blindness, or in greyscale. +#' `check_separation()` scores how far apart colours are, taking the worst case +#' over normal vision and each type of colour blindness, +#' so that a palette is only credited for a difference that every viewer +#' can see. +#' `check_contrast()` scores whether text can be read on a ground. +#' @details +#' The three functions answer three different questions, +#' and a palette needs all three answered. +#' `check_separation()` asks whether two marks can be told apart, +#' `check_contrast()` asks whether text can be read on what it sits on, +#' and the "grey" simulation asks whether either survives a photocopier. +#' +#' Simulation uses the matrices of Machado, Oliveira and Fernandes (2009), +#' applied in linear RGB. +#' Those matrices are published for each severity of colour blindness; +#' `severity` interpolates between the identity and the full-severity matrix, +#' which approximates the published steps closely enough for a check. +#' Full severity is dichromacy (deuteranopia, protanopia, tritanopia); +#' a lower severity is anomalous trichromacy (deuteranomaly, protanomaly), +#' which is the more common condition. +#' Greyscale conversion takes the relative luminance of the colour, +#' the same quantity `check_contrast()` scores with. +#' +#' Distances are Euclidean distances in CIELAB space, the same measure +#' [match_color()] uses. +#' As a rule of thumb, a distance below 10 means two colours are easily +#' confused, 10 to 25 means they are separable but close, +#' and above 25 means they are comfortably distinct. +#' Ratios are those of WCAG 2.1, which asks for at least 4.5 for body text +#' and at least 3 for large text and for graphical objects. +#' @name theme_colorblind +#' @family themes +#' @param colors One or more colours, given as hexcodes or as names R knows. +#' @param type The type of colour blindness to simulate: +#' "deutan" (green-blind, the most common), "protan" (red-blind), +#' "tritan" (blue-blind), "grey" for greyscale, as a photocopier renders it, +#' or "normal" for unaffected vision. +#' @param severity How severe the colour blindness is, between 0 and 1. +#' By default 1, which is dichromacy. +#' A value between 0 and 1 is anomalous trichromacy. +#' Ignored for the "grey" and "normal" types. +#' @references +#' Machado, Gustavo M., Manuel M. Oliveira, and Leandro A. F. Fernandes. 2009. +#' "A Physiologically-Based Model for Simulation of Color Vision Deficiency". +#' _IEEE Transactions on Visualization and Computer Graphics_ 15(6): 1291-98. +#' \doi{10.1109/TVCG.2009.113} +#' +#' World Wide Web Consortium. 2018. +#' _Web Content Accessibility Guidelines (WCAG) 2.1_. +#' \url{https://www.w3.org/TR/WCAG21/} +#' @returns +#' `simulate_colorblind()` returns a vector of hexcodes as long as `colors`. +#' +#' `check_separation()` returns a square matrix of worst-case distances, +#' with the colours as its dimnames and a missing diagonal, +#' so that `min(x, na.rm = TRUE)` gives the closest pair. +#' A "grey" attribute holds the same matrix as seen in greyscale. +#' +#' `check_contrast()` returns a square matrix of WCAG contrast ratios, +#' shaped the same way. +#' @examples +#' simulate_colorblind(c("#d73027", "#4575b4"), "deutan") +#' # A milder deuteranomaly, and the same colours in greyscale +#' simulate_colorblind(c("#d73027", "#4575b4"), "deutan", severity = 0.5) +#' simulate_colorblind(c("#d73027", "#4575b4"), "grey") +#' # How well does the current theme's palette separate five categories? +#' check_separation(ag_qualitative(5)) +#' # The closest pair in it +#' min(check_separation(ag_qualitative(5)), na.rm = TRUE) +#' # And the closest pair once it is printed in greyscale +#' min(attr(check_separation(ag_qualitative(5)), "grey"), na.rm = TRUE) +#' # A red and a green that only look different to some viewers +#' check_separation(c("#B7352D", "#627313"))[1, 2] +#' # Can the current theme's ink be read on its ground? +#' check_contrast(ag_ink())[1, 2] +#' @export +simulate_colorblind <- function(colors, + type = c("deutan", "protan", "tritan", "grey", "normal"), + severity = 1){ + type <- match.arg(type) + if(!is.numeric(severity) || length(severity) != 1L || + is.na(severity) || severity < 0 || severity > 1) + manynet::snet_abort( + "{.arg severity} should be a single number between 0 and 1,", + "but {.val {severity}} was given.") + rgb <- t(grDevices::col2rgb(colors))/255 + rgb[] <- srgb_to_linear(rgb) + if(type == "grey"){ + # A greyscale device keeps the luminance of a colour and discards the rest, + # which is why two colours of the same lightness merge in print however + # different their hues. + lum <- as.vector(rgb %*% luminance_weights) + sim <- cbind(lum, lum, lum) + } else { + sim <- rgb %*% t(colorblind_matrix(type, severity)) + } + sim[sim < 0] <- 0 + sim[sim > 1] <- 1 + sim[] <- linear_to_srgb(sim) + grDevices::rgb(sim[,1], sim[,2], sim[,3]) +} + +#' @rdname theme_colorblind +#' @param background Optionally, a colour to include in the comparison, +#' so that a colour too pale or too dark to be seen against it is not +#' counted as distinct. +#' By default the current theme's background is used. +#' @export +check_separation <- function(colors, background = NULL){ + if(!is.null(background)) colors <- c(background, colors) + types <- names(colorblind_matrices) + dists <- lapply(types, + function(ty) as.matrix(stats::dist(colorblind_lab(colors, ty)))) + # A pair is only as distinguishable as its worst view of it. + out <- Reduce(pmin, dists) + # The diagonal is left missing rather than zero, so that the obvious way to + # ask how well a palette separates -- min() over the matrix -- reports the + # closest pair of different colours, and not the zero distance from each + # colour to itself. + diag(out) <- NA_real_ + dimnames(out) <- list(colors, colors) + # Greyscale is reported beside the score rather than folded into it. Two + # colours that differ only in hue collapse in greyscale however well they + # serve a colour-blind reader, so a worst case that included it would + # condemn nearly every institutional palette and leave only lightness to + # design with. Whether a figure has to survive a photocopier is the user's + # question to answer, so the number is offered, not imposed. + grey <- as.matrix(stats::dist(colorblind_lab(colors, "grey"))) + diag(grey) <- NA_real_ + dimnames(grey) <- dimnames(out) + attr(out, "grey") <- grey + class(out) <- c("check_separation", class(out)) + out +} + +#' @export +print.check_separation <- function(x, ...){ + grey <- attr(x, "grey") + out <- unclass(x) + attr(out, "grey") <- NULL + print(out, ...) + # The greyscale matrix is summarised rather than printed. Its interest is + # almost always the one number -- whether anything collapses in print -- + # and a second matrix of the same size would bury the first. + if(!is.null(grey) && any(!is.na(grey))) + cat("\nClosest pair in greyscale: ", + round(min(grey, na.rm = TRUE), 1), "\n", sep = "") + invisible(x) +} + +#' @rdname theme_colorblind +#' @export +check_contrast <- function(colors, background = NULL){ + # Unlike check_separation(), where a background is one more colour to keep + # away from, here it is what the others are read *on*, so it belongs in the + # comparison whether or not the user names one. + if(is.null(background)) background <- ag_ground_fill() + colors <- c(background, colors) + lum <- relative_luminance(colors) + lighter <- outer(lum, lum, pmax) + darker <- outer(lum, lum, pmin) + out <- (lighter + 0.05)/(darker + 0.05) + diag(out) <- NA_real_ + dimnames(out) <- list(colors, colors) + out +} + +# Machado, Oliveira and Fernandes (2009), severity 1.0, for linear RGB. +colorblind_matrices <- list( + normal = diag(3), + protan = matrix(c( 0.152286, 1.052583, -0.204868, + 0.114503, 0.786281, 0.099216, + -0.003882, -0.048116, 1.051998), 3, 3, byrow = TRUE), + deutan = matrix(c( 0.367322, 0.860646, -0.227968, + 0.280085, 0.672501, 0.047413, + -0.011820, 0.042940, 0.968881), 3, 3, byrow = TRUE), + tritan = matrix(c( 1.255528, -0.076749, -0.178779, + -0.078411, 0.930809, 0.147602, + 0.004733, 0.691367, 0.303900), 3, 3, byrow = TRUE)) + +# The published matrices run from the identity at severity 0 to those above at +# severity 1, so a partial severity is read off the line between the two. +colorblind_matrix <- function(type, severity = 1){ + full <- colorblind_matrices[[type]] + if(severity == 1) return(full) + (1 - severity) * diag(3) + severity * full +} + +# Rec. 709 luminance weights, which both WCAG and greyscale conversion use. +luminance_weights <- c(0.2126, 0.7152, 0.0722) + +relative_luminance <- function(colors){ + rgb <- t(grDevices::col2rgb(colors))/255 + rgb[] <- srgb_to_linear(rgb) + as.vector(rgb %*% luminance_weights) +} + +srgb_to_linear <- function(u){ + ifelse(u <= 0.04045, u/12.92, ((u + 0.055)/1.055)^2.4) +} + +linear_to_srgb <- function(u){ + ifelse(u <= 0.0031308, u*12.92, 1.055*u^(1/2.4) - 0.055) +} + +colorblind_lab <- function(colors, type){ + sim <- if(type == "normal") colors else simulate_colorblind(colors, type) + lab <- grDevices::convertColor(t(grDevices::col2rgb(sim))/255, + from = "sRGB", to = "Lab") + if(is.null(dim(lab))) lab <- matrix(lab, nrow = 1) + lab +} + +# Reorders a palette so that, for every number of categories a user might ask +# for, the colours they get are as distinguishable as a greedy pass can make +# them. The colours themselves are left alone, since an institutional palette +# is not ours to change; only their order is chosen. The background counts as +# an already-taken colour, so a colour too faint to see against it is not +# mistaken for a distant one. The first colour kept is the first in the given +# palette that stands out from the background, which keeps a brand's primary +# colour primary. +colorblind_sort <- function(colors, background = "#FFFFFF", floor = 30){ + n <- length(colors) + if(n < 3) return(colors) + dists <- check_separation(colors, background = background) + from_bg <- dists[1, -1] + dists <- dists[-1, -1, drop = FALSE] + ord <- which(from_bg >= floor)[1] + if(is.na(ord)) ord <- which.max(from_bg) + while(length(ord) < n){ + rest <- setdiff(seq_len(n), ord) + gaps <- vapply(rest, function(i) min(c(dists[i, ord], from_bg[i])), + numeric(1)) + ord <- c(ord, rest[which.max(gaps)]) + } + unname(colors[ord]) +} diff --git a/R/theme_fonts.R b/R/theme_fonts.R new file mode 100644 index 00000000..bfd59fa3 --- /dev/null +++ b/R/theme_fonts.R @@ -0,0 +1,83 @@ +# The font lists that grDevices reports name only a handful of device aliases +# ("sans", "Helvetica", "Arial", and a few more), so a font that a user +# installs for a theme stays invisible to them. Ask the system font registry +# first, where {systemfonts} is installed, and fall back to the device aliases +# otherwise. Fonts registered by extrafont::loadfonts() arrive through those +# same device lists, so no second package is needed to see them. +available_fonts <- function(){ + fonts <- character(0) + if(requireNamespace("systemfonts", quietly = TRUE)) + fonts <- c(fonts, systemfonts::system_fonts()$family) + if(.Platform$OS.type == "windows"){ + fonts <- c(fonts, names(grDevices::windowsFonts())) + } else { + fonts <- c(fonts, names(grDevices::X11Fonts())) + } + fonts <- c(fonts, names(grDevices::postscriptFonts())) + sort(unique(fonts)) +} + +set_font_theme <- function(theme){ + + candidates <- theme_fonts(theme) + if(is.null(candidates)){ + options(snet_font = "sans") + return(invisible(NULL)) + } + + installed <- available_fonts() + + # Find first match + if(any(candidates %in% installed)){ + font_match <- candidates[candidates %in% installed] + snet_info("Setting font to {font_match[1]}.") + } else { + snet_info("None of the preferred fonts for theme {.emph {theme}},", + "{candidates}, are available.", + "See {.fn autograph::list_fonts} for the fonts R can see,", + "and {.help autograph::theme_set} for how to install more.", + "Using default sans-serif font instead.") + font_match <- "sans" + } + options(snet_font = font_match[1]) +} + +theme_fonts <- function(theme){ + switch(theme, + "iheid" = c("Helvetica", "Arial", "Verdana"), + "ethz" = c("DIN Next","Arial"), + "uzh" = c("Source Sans", "TheSans", "Palatino"), + "rug" = c("Arial","Parry","Georgia","Open Sans"), + "oxf" = c("Roboto","Noto Serif","Aktiv Grotesk"), + "cmu" = c("Open Sans","Source Serif Pro","Helvetica","Times"), + "iast" = c("Gogh","Monserrat","Playfair","Roboto","tse"), + "hwu" = c("Univers LT Pro","Baskerville BT","Arial"), + "neon" = "Comic Sans MS", + "clay" = c("Styrene B", "Styrene A", "Tiempos Text", + "Copernicus", "Helvetica Neue", "Arial") + ) +} + +#' Listing the fonts available to R +#' @description +#' `list_fonts()` reports the font families that R can currently see, +#' which is what a theme's preferred fonts are matched against. +#' A font that is installed on the system but missing from this list is not +#' available to R yet; +#' see the Fonts section of [theme_set] for how to make it so. +#' @name list_fonts +#' @family themes +#' @param pattern Optionally, a string with which to filter the font families +#' returned, matched without regard to case. +#' For example, `list_fonts("sans")` returns every family whose name includes +#' "sans". +#' @returns A vector of font family names. +#' @examples +#' head(list_fonts()) +#' @export +list_fonts <- function(pattern = NULL){ + fonts <- available_fonts() + if(!is.null(pattern)) fonts <- grep(pattern, fonts, ignore.case = TRUE, + value = TRUE) + fonts +} diff --git a/R/theme_medium.R b/R/theme_medium.R new file mode 100644 index 00000000..f1e3a918 --- /dev/null +++ b/R/theme_medium.R @@ -0,0 +1,122 @@ +#' Setting the medium a plot is made for +#' @description +#' A theme says how a plot should look. +#' A medium says where it will be seen, which is a separate question: +#' the same institutional theme serves a figure worked on at a desk, +#' projected in a lecture theatre, printed in an article, +#' and read on a phone, but each of those wants a different size of text +#' and, in one case, a different ground. +#' `stocnet_medium()` sets the medium for all subsequent plots, +#' as `stocnet_theme()` sets the theme, and leaves the theme alone. +#' +#' If no medium is specified (i.e. the function is called without argument), +#' the current medium is reported. +#' The default medium is "screen". +#' @details +#' The media available are: +#' +#' - "screen", the default, which draws as `{autograph}` always has. +#' - "presentation", which enlarges text by half, for a figure read from +#' the back of a room. +#' - "mobile", which enlarges text further, for a figure read in a narrow +#' column on a handheld screen. +#' Keep such a figure to one point, with few categories: +#' a legend of more than about seven keys, or more than about three panels +#' from `graphs()`, will not survive the width. +#' - "print", which leaves text at its usual size but draws on white, +#' whatever ground the theme prefers. +#' A dark or tinted ground costs ink and is often not reproduced. +#' +#' The medium scales text, not marks. +#' Node sizes are relative to the layout they sit in, +#' so enlarging them without enlarging the layout would crowd it. +#' Where a figure needs larger nodes as well, set `node_size` in [graphr()]. +#' +#' The medium does not set the size of the file written. +#' Give `ggplot2::ggsave()` the width, height and resolution the medium +#' calls for as well. +#' @name theme_medium +#' @family themes +#' @param medium String naming a medium. +#' By default "screen". +#' The following media are currently available: +#' `r autograph:::medium_opts`. +#' This string can be capitalised or not. +#' @param persist Logical, by default FALSE. +#' If TRUE, the medium is remembered across sessions, +#' by writing it to the user's configuration directory +#' (see `tools::R_user_dir()`). +#' Nothing is written to disk unless this is set explicitly. +#' Use `stocnet_medium(persist = FALSE)` when setting a medium +#' to forget a previously persisted choice. +#' @returns `stocnet_medium()` sets the medium to be used across all +#' stocnet packages. The medium is written to an option and held there. +#' `ag_size()` returns the multiplier the current medium applies to text +#' sizes, which is 1 unless the medium says otherwise. +#' @examples +#' stocnet_medium("presentation") +#' ag_size() +#' stocnet_medium("screen") +#' @export +stocnet_medium <- function(medium = NULL, persist = FALSE){ + if(is.null(medium)){ + medium <- getOption("stocnet_medium", default = "screen") + snet_info("Medium is currently set to {.emph {medium}}.", + "The following media are available: {.emph {medium_opts}}.") + } else { + if(!is.character(medium) || length(medium) != 1L) + manynet::snet_abort( + "{.arg medium} should be the name of a single medium, given as a string.", + "The media available are {.val {medium_opts}}.") + medium <- .match_name(tolower(medium), medium_opts, "medium", + what = "medium") + options(stocnet_medium = medium) + snet_success("Medium set to {.emph {medium}}.") + if(persist){ + if(write_medium_pref(medium)) + snet_success("Medium will be remembered in future sessions.") + } else forget_medium_pref() + } +} + +#' @rdname theme_medium +#' @export +set_stocnet_medium <- stocnet_medium + +medium_opts <- c("screen", "presentation", "mobile", "print") + +# How much larger the text is in each medium. "print" is left at 1: a printed +# figure is held at reading distance like any other page, so what it needs is +# not larger text but a ground that reproduces. +medium_sizes <- c(screen = 1, presentation = 1.5, mobile = 1.8, print = 1) + +#' @rdname theme_medium +#' @export +ag_size <- function(){ + unname(medium_sizes[getOption("stocnet_medium", default = "screen")]) +} + +# Text drawn by a geom, or set on a theme element directly, does not pass +# through the base_size that ag_themer() scales, so it is scaled here. Marks +# are deliberately left alone: a node's size is relative to the layout it sits +# in, and enlarging nodes without enlarging the layout would crowd it. +ag_text_size <- function(size) size * ag_size() + +# The medium overrides the theme's ground only for print, and only in that +# direction: the ink and the palettes are the theme's own in every medium. +medium_background <- function(){ + if(getOption("stocnet_medium", default = "screen") == "print") "#FFFFFF" + else NULL +} + +# See write_pref() in autograph_utilities.R. +write_medium_pref <- function(medium) write_pref("medium", medium) + +forget_medium_pref <- function() forget_pref("medium") + +read_medium_pref <- function(){ + medium <- read_pref("medium") + if(is.null(medium) || !is.character(medium) || length(medium) != 1L || + !medium %in% medium_opts) return(NULL) + medium +} diff --git a/R/theme_palette_get.R b/R/theme_palette_get.R new file mode 100644 index 00000000..6e4561b9 --- /dev/null +++ b/R/theme_palette_get.R @@ -0,0 +1,236 @@ +#' Consistent palette calls +#' @description +#' These functions assist in calling particular parts of a theme's palette. +#' For example, `ag_base()` will return the current theme's base or background +#' color, and `ag_highlight()` will return the color used in that theme to +#' highlight one or more nodes, lines, or such. +#' `ag_ink()` returns the darker colour that theme writes with: +#' axis text, reference lines, and other chrome. +#' `ag_missing()` returns the neutral that theme sets aside for data that +#' should recede: missing values, isolates counted out of a drawing, +#' and any "other" remainder left when small categories are grouped down. +#' Keeping one colour for all three means a reader learns it once. +#' Keeping the two apart lets the base be light enough to stand away from +#' the highlight while the ink stays dark enough to read. +#' Where the ground changes under a theme -- the "print" medium forces +#' white, whatever the theme prefers -- `ag_ink()` falls back to black or +#' white rather than return an ink that cannot be read on it. +#' See [check_contrast()] and [stocnet_medium()]. +#' +#' Using palettes that are high contrast, aesthetically pleasing, and +#' institutionally or thematically consistent is not without its challenges. +#' @section Colour blindness: +#' The default palettes are designed to be colour-blind friendly. +#' There are different types of colour-blindness. +#' The most common type, red-green colour-blindness, +#' finds it difficult to distinguish between the red and green hues used +#' in the [rainbow palette](https://colorspace.r-forge.r-project.org/articles/endrainbow.html), +#' for instance. +#' Fortunately there are a range of palettes that function fairly well for +#' those who are color-blind. +#' These include the [viridis](https://CRAN.R-project.org/package=viridis) +#' palette, +#' and the ColorBrewer palettes (included in the RColorBrewer package). +#' +#' An institutional palette is not ours to change, but its order is. +#' Each theme's categorical palette is therefore reordered when the theme is +#' set, so that the first colours a plot draws on are those that stay +#' distinct under each type of colour blindness, and `ag_qualitative()` +#' takes those colours in order rather than interpolating between them. +#' Divergent palettes pair a warm pole with a cool one for the same reason. +#' Use [check_separation()] to check how your own colours fare, +#' and [simulate_colorblind()] to see them as a colour-blind viewer would. +#' +#' Two further questions are worth asking of a palette. +#' Whether its text can be read on what it sits on is a matter of contrast +#' rather than of hue, and [check_contrast()] scores it against the +#' thresholds of WCAG 2.1. +#' Whether it survives print is a matter of lightness alone, since a +#' greyscale device keeps the luminance of a colour and discards the rest; +#' `simulate_colorblind(type = "grey")` shows that view, and +#' [check_separation()] reports the greyscale distances beside its own score. +#' Most institutional palettes separate by hue and so collapse in greyscale. +#' Where a figure has to print in black and white, use the "bw" theme, or +#' add a second channel such as `node_shape`. +#' +#' The "rainbow" theme is the exception, and is left in its own order. +#' Its point is fidelity to the spectrum of an observed rainbow, +#' which reordering would destroy, +#' so `ag_qualitative()` samples across its whole length instead. +#' A spectrum is not a colour-blind safe scheme: +#' its reds and greens are exactly the pair that red-green colour blindness +#' cannot separate. +#' Choose it where the order of the categories is itself meaningful, +#' and check the result with [check_separation()]; +#' for categories with no order, another theme serves more readers. +#' @name ag_call +#' @param number Integer of how many category colours to return. +#' @returns One or more hexcodes as strings. +#' @examples +#' # Single colours from the currently active theme +#' ag_base() +#' ag_ink() +#' ag_highlight() +#' ag_missing() +#' ag_positive() +#' ag_negative() +#' # Palettes of a requested length +#' ag_qualitative(3) +#' ag_sequential(5) +#' ag_divergent(5) +#' # The accessors follow whichever theme is set +#' ag_font() +#' @importFrom grDevices colorRampPalette +#' @export +ag_base <- function(){ + utils::head(getOption("snet_highlight", default = "black"), n = 1) +} + +#' @rdname ag_call +#' @export +ag_ink <- function(){ + ink <- getOption("snet_ink", default = "#121212") + ground <- ag_ground_fill() + # A theme's ink is chosen for that theme's own ground, but the ground can + # change under it: the "print" medium forces white, and a session that + # restores a persisted theme may not have applied the ink yet. Rather than + # write text that cannot be read, fall back to whichever of black and white + # reads better on whatever ground is actually there. WCAG asks 4.5 of body + # text; see check_contrast(). + if(check_contrast(ink, ground)[1, 2] >= 4.5) return(ink) + alts <- c("#121212", "#FFFFFF") + ratios <- vapply(alts, function(a) check_contrast(a, ground)[1, 2], + numeric(1)) + unname(alts[which.max(ratios)]) +} + +#' @rdname ag_call +#' @export +ag_missing <- function(){ + getOption("snet_missing", default = "#8C8C8C") +} + +#' @rdname ag_call +#' @export +ag_highlight <- function(){ + utils::tail(getOption("snet_highlight", default = "red"), n = 1) +} + +#' @rdname ag_call +#' @export +ag_positive <- function(){ + utils::tail(getOption("snet_div", default = "#4575b4"), n = 1) +} + +#' @rdname ag_call +#' @export +ag_negative <- function(){ + utils::head(getOption("snet_div", default = "#d73027"), n = 1) +} + +#' @rdname ag_call +#' @export +ag_qualitative <- function(number){ + # The fallback is the default theme's palette in the order colorblind_sort() gives + # it, so that a session that has not called stocnet_theme() yet draws the + # same colours, in the same order, as one that has. + snet_colors <- getOption("snet_cat", default = c("#1B9E77","#E6AB02","#7570B3", + "#d73027","#666666","#D95F02", + "#66A61E","#E7298A","#A6761D", + "#4575b4")) + if(missing(number)) number <- length(snet_colors) + # Take the palette's own colours while they last. Interpolating between them + # returned mixtures that no longer belonged to the palette, and that sat much + # closer together than the colours they were mixed from: five categories from + # the "clay" palette used to come back only 3 apart under simulation, where + # anything under 10 reads as the same colour. Palettes are ordered so that + # the first `number` of them are the ones that separate best. + if(number <= length(snet_colors) && + !isTRUE(getOption("snet_cat_spread", default = FALSE))) + return(snet_colors[seq_len(number)]) + # Past the end of the palette there are only mixtures left, and they sit + # closer together than the colours they were mixed from. Say so rather than + # returning colours that quietly fail a check the palette itself would pass. + # No alternative theme is suggested: an institutional palette is chosen + # because it is that institution's, so swapping it is not an answer. + if(number > length(snet_colors)) + snet_info("This palette holds {length(snet_colors)} colours,", + "so the {number} asked for include mixtures of them,", + "which sit closer together than the palette's own colours.", + "Consider fewer categories,", + "or choose the colours yourself with", + "{.fn ggplot2::scale_fill_manual}.") + colorRampPalette(snet_colors)(number) +} + +#' @rdname ag_call +#' @export +ag_sequential <- function(number){ + snet_colors <- getOption("snet_highlight", default = "#d73027") + if(length(snet_colors)==1) snet_colors <- c(ag_base(), snet_colors[1]) + colorRampPalette(snet_colors)(number) +} + +#' @rdname ag_call +#' @export +ag_divergent <- function(number){ + # The default must be a real pair of colours, matching ag_negative()'s and + # ag_positive()'s defaults (which read the head and tail of this same + # option). It was the literal string "default", so ag_divergent() errored + # with "invalid color name 'default'" in any session where stocnet_theme() + # had not yet been called -- which the test suite never saw, because + # tests/testthat.R sets the theme before running. + snet_colors <- getOption("snet_div", default = c("#d73027", "#4575b4")) + if(length(snet_colors)==2) + snet_colors <- c(snet_colors[1], "white", snet_colors[2]) + colorRampPalette(snet_colors)(number) +} + +#' @rdname ag_call +#' @export +ag_font <- function(){ + getOption("snet_font", default = "sans") +} + +# nocov start +# Interactive helper for displaying palettes; not called by any package code +ggpizza <- function(colors, init.angle = 105, cex = 4, labcol = NULL) { + n <- length(colors) + angles <- seq(0, 2*pi, length.out = n + 1) + init.angle * pi/180 + + # Data for slices + slices <- lapply(seq_len(n), function(i) { + theta <- seq(angles[i], angles[i+1], length.out = 100) + data.frame( + x = c(0, cos(theta)), + y = c(0, sin(theta)), + color = colors[i], + group = i + ) + }) |> dplyr::bind_rows() + + # Label positions + mids <- (angles[-1] + angles[-(n+1)]) / 2 + labels <- data.frame( + x = 1.1 * cos(mids), + y = 1.1 * sin(mids), + label = colors + ) + + # The labels sit outside the wheel, on the plot's ground, so they take the + # colour the theme writes with rather than the colour of an unhighlighted + # mark: ag_base() is light in several themes and vanished against white. + labels$labcol <- ag_ink() + + ggplot2::ggplot() + + ggplot2::geom_polygon(data = slices, aes(x, y, group = group, fill = color), + color = "white") + + ggplot2::geom_text(data = labels, aes(x, y, label = label, color = labcol), + size = cex) + + ggplot2::scale_fill_identity() + + ggplot2::scale_color_identity() + + ggplot2::coord_equal() + + ggplot2::theme_void() +} +# nocov end + diff --git a/R/theme_palette_set.R b/R/theme_palette_set.R new file mode 100644 index 00000000..1ca716fb --- /dev/null +++ b/R/theme_palette_set.R @@ -0,0 +1,453 @@ +#' Setting a consistent theme for all plots +#' @description +#' This function enables plots to be quickly, easily and consistently themed. +#' This is achieved by setting a theme option, usually at the start of an R +#' session, that enables the palette to be used for +#' all autograph-consistent plotting methods. +#' This includes thematic colours for backgrounds, highlights, +#' sequential, divergent and categorical colour schemes. +#' The function sets these palettes to options that are then +#' used by the various plotting functions. +#' +#' If no theme is specified (i.e. the function is called without argument), +#' the current theme is reported. +#' The default theme is "default". +#' This theme uses a white background, blue and red for +#' highlighting, and a blue-white-red divergent palette. +#' The themes can be changed at any time by calling `stocnet_theme()` +#' or its alias `set_stocnet_theme()` with a different theme name. +#' +#' Other themes include those based on the colour schemes of various +#' universities, including ETH Zurich, UZH, UNIBE, RUG, and Oxford. +#' Other themes include "bw" for black and white, "crisp" for a +#' high-contrast black and white theme, "neon" for a dark theme +#' with neon highlights, and "rainbow" for a colourful theme. +#' The "clay" theme follows the palette and fonts used in the slides and +#' documents that Anthropic's Claude produces: an ivory background, +#' a slate ink base, and a clay orange highlight. +#' Most themes are designed to be colour-blind safe. +#' +#' @name theme_set +#' @family themes +#' @section Fonts: +#' Some themes also set a preferred font for use in plots, +#' if available on the system (a check is performed). +#' In some cases, this includes a vector of options to try in sequence. +#' If none of the preferred fonts are available, a sans-serif font is used. +#' Themes then look much more alike than they should, +#' since the typeface carries a good deal of an institution\'s identity. +#' Call `list_fonts()` to see which font families R can currently see, +#' and `ag_font()` to see which one the current theme settled on. +#' +#' To make more fonts available, there are two steps. +#' +#' 1. Install the font on your computer. +#' Many of the fonts these themes prefer are free: +#' Google Fonts () offers Roboto, Open Sans, +#' Source Sans 3, Source Serif 4, Noto Serif, Montserrat, and Playfair +#' Display, among others. +#' Download the family, then install it as you would any other font: +#' double-click the files and choose "Install" on Windows, +#' open them in Font Book on macOS, +#' or copy them into `~/.local/share/fonts` and run `fc-cache -f` on Linux. +#' Some fonts are licensed and are only available to members of the +#' institution concerned, or for purchase; +#' the theme falls back to a near relative where it can. +#' 2. Make the font available to R. +#' Install the `{systemfonts}` package and the fonts installed on your system +#' are found directly, with no further step. +#' Otherwise, use `extrafont::font_import()` once and +#' `extrafont::loadfonts()` in each session. +#' Restart R after installing a font, then call `list_fonts()` to check that +#' the family is now listed, and set the theme again. +#' +#' Note that a font is only used where the graphics device can draw it. +#' The `{ragg}` devices (for example `ragg::agg_png()`) and `{svglite}` are +#' the most reliable; +#' the default PDF device needs the font embedded, +#' for which `extrafont::embed_fonts()` is available. +#' @section Custom: +#' If you have specific needs or preferences, you can +#' set your own palettes or overwrite part of an existing one using `options()`. +#' For example, to set a custom base color, you can use: +#' `options(snet_highlight = c("#1b9e77", "#d95f02", "#7570b3"))`. +#' This will set a custom highlight color palette. +#' Similarly, you can set `snet_div` for divergent palettes +#' and `snet_cat` for categorical palettes. +#' @returns This function sets the theme and palette(s) to be used across all +#' stocnet packages. The palettes are written to options and held there. +#' @examples +#' stocnet_theme("default") +#' plot(netrics::node_by_degree(ison_karateka)) +#' stocnet_theme("uzh") +#' plot(netrics::node_by_degree(ison_karateka)) +NULL + +# Themes whose palette order carries meaning of its own, and so is not +# reordered for colour blindness. See the Colour blindness section of ?ag_call. +colorblind_unsorted <- "rainbow" + +theme_opts <- c("default", "bw", "crisp", "neon", "clay", + "iheid", "ethz", "uzh", "rug", "unibe", + "oxf", "unige", "cmu", "iast", "hwu", + "rainbow") + +#' @rdname theme_set +#' @param theme String naming a theme. +#' By default "default". +#' The following themes are currently available: +#' `r autograph:::theme_opts`. +#' This string can be capitalised or not. +#' @param persist Logical, by default FALSE. +#' If TRUE, the theme is remembered across sessions, +#' by writing it to the user's configuration directory +#' (see `tools::R_user_dir()`). +#' Nothing is written to disk unless this is set explicitly. +#' Use `stocnet_theme(persist = FALSE)` when setting a theme +#' to forget a previously persisted choice. +#' @importFrom manynet snet_info snet_success +#' @export +stocnet_theme <- function(theme = NULL, persist = FALSE){ + if(is.null(theme)){ + theme <- getOption("stocnet_theme", default = "default") + snet_info("Theme is currently set to {.emph {theme}}.", + "The following themes are available: {.emph {theme_opts}}.") + } else { + if(!is.character(theme) || length(theme) != 1L) + manynet::snet_abort( + "{.arg theme} should be the name of a single theme, given as a string.", + "The themes available are {.val {theme_opts}}.") + # An unrecognised theme used to warn and leave the theme unchanged, which + # was easy to miss and left plots looking wrong for no visible reason. + theme <- .match_name(tolower(theme), theme_opts, "theme", what = "theme") + options(stocnet_theme = theme) + set_highlight_theme(theme) + set_ink_theme(theme) + set_divergent_theme(theme) + set_background_theme(theme) + set_categorical_theme(theme) + set_missing_theme(theme) + set_font_theme(theme) + snet_success("Theme set to {.emph {theme}}.") + if(persist){ + if(write_theme_pref(theme)) + snet_success("Theme will be remembered in future sessions.") + } else forget_theme_pref() + } +} + +# The reading and writing itself is shared with any other remembered +# preference; see write_pref() in autograph_utilities.R. +theme_pref_file <- function() pref_file("theme") + +write_theme_pref <- function(theme) write_pref("theme", theme) + +forget_theme_pref <- function() forget_pref("theme") + +read_theme_pref <- function(){ + theme <- read_pref("theme") + # Guard against a stale file naming a theme this version no longer ships. + if(is.null(theme) || !is.character(theme) || length(theme) != 1L || + !theme %in% theme_opts) return(NULL) + theme +} + +#' @rdname theme_set +#' @export +set_stocnet_theme <- stocnet_theme + +set_background_theme <- function(theme){ + if(theme == "neon"){ + options(snet_background = "#070f23") + } else if(theme == "cmu"){ + options(snet_background = "#E4DAC4") + } else if(theme == "clay"){ + options(snet_background = "#F0EEE6") + } else { + options(snet_background = "#FFFFFF") + } +} + +# The ink is the dark colour a plot writes with: axis text, reference lines, +# and other chrome. It is kept apart from the base, which is the colour of an +# unhighlighted mark, because the two roles pull in opposite directions. A +# base must stand away from the highlight, which for a dark brand colour means +# a lighter grey; ink must stay legible, which means a dark one. +set_ink_theme <- function(theme){ + options(snet_ink = switch(theme, + "neon" = "#EDEDF4", + "iheid" = "#000010", + "oxf" = "#002147", + "hwu" = "#0A3E65", + "clay" = "#3D3D3A", + "crisp" = "#101314", + "cmu" = "#1A1A1A", + "bw" = "#000000", + "rug" = "#000000", + "#121212")) +} + +# The neutral that data recedes into: missing values, isolates counted out of +# a drawing, and any "other" remainder. It has two jobs at once, and they pull +# apart: it must clear the theme's ground by enough to be seen at all (WCAG +# asks 3:1 of a graphical object), while staying far enough from every +# categorical colour not to be read as one of them. Several palettes hold a +# grey of their own, so which neutral is free depends on the theme, and +# hand-picking sixteen of them would go stale the moment a palette changed. +# It is chosen the way colorblind_sort() chooses an order instead: from a +# ladder of neutrals, take the one that clears the ground and sits furthest +# from anything the palette already uses. +missing_candidates <- c("#4D4D4D", "#595959", "#666666", "#737373", "#808080", + "#8C8C8C", "#999999", "#A6A6A6", "#B3B3B3", + # A warm and a cool neutral for the tinted grounds. + "#6B665C", "#7E766A", "#8A8378", "#96907F", + "#5C6270", "#6E7482", "#7F87A0", "#919AAE") + +set_missing_theme <- function(theme){ + bg <- getOption("snet_background", default = "#FFFFFF") + pal <- getOption("snet_cat", default = "#4576B5") + seen <- vapply(missing_candidates, + function(x) check_contrast(x, bg)[1, 2], numeric(1)) + keep <- seen >= 3 + if(!any(keep)) keep <- seq_along(seen) == which.max(seen) + ok <- missing_candidates[keep] + seen <- seen[keep] + apart <- vapply(ok, function(x) min(check_separation(c(x, pal))[1, -1]), + numeric(1)) + free <- ok[apart >= 10] + # Among the neutrals that are both visible and unmistakable, take the one + # nearest the ground. The point of this colour is to recede, so the least + # contrast that still clears the floor is the right amount, not the most. + if(length(free)){ + options(snet_missing = unname(free[which.min(seen[apart >= 10])])) + return(invisible(NULL)) + } + options(snet_missing = unname(ok[which.max(apart)])) +} + +set_highlight_theme <- function(theme){ + hl <- switch(theme, + "iheid" = c("#000010","#E20020"), + "unige" = c("#A3A3A3","#CF0063"), + "rug" = c("#000000", "#dc002d"), + "uzh" = c("#a3adb7", "#dc6027"), + "unibe" = c("#121212", "#e4003c"), + "oxf" = c("#002147", "#c09725"), + # The ETH grey and blue used to sit 28 apart under + # simulation, both being mid-dark; the lighter grey separates + # them by lightness, which every viewer keeps. + "ethz" = c("#919191", "#0028a5"), + "cmu" = c("#8F9194", "#C41230"), + "iast" = c("#555", "#e54a37"), + "hwu" = c("#0A3E65", "#0095DB"), + "crisp" = c("#bfbfbf", "#101314"), + "bw" = c("#CCCCCC", "#000000"), + # The neon cyan and green scored 12.7 apart under simulation, + # so the highlight is now a yellow that keeps the same voltage. + "neon" = c("#5aeafd", "#fdfd54"), + "clay" = c("#3D3D3A", "#D97757"), + "rainbow" = c('#1965B0', '#DC050C'), + c("#4576B5", "#D83127")) + options(snet_highlight = hl) +} + +# "#E20020" - IHEID red +# "#215CAF" - ETH blue +# "#EDEDF4" - ghost white +# "#071013" - rich black +# "#EDAE49" - hunyadi yellow +# "#3C493F" - field green +# "#679289" - viridian + +set_divergent_theme <- function(theme){ + # Each triplet runs warm pole, light middle, cool pole, so that a reader + # meets the same convention in every theme, and so that the poles differ in + # lightness as well as in hue. Several of these used to pair a red pole with + # a green or teal one, drawn from the same institutional palette, which is + # the one pairing that red-green colour blindness cannot resolve: the ETH + # red and olive poles scored 3.8 apart under simulation, where 10 is already + # confusable. The poles below are still each theme's own colours, chosen for + # the widest separation the palette allows. See [check_separation()]. + dv <- switch(theme, + "iheid" = c("#820C2B","white","#006EAA"), + "unige" = c("#F42941","white","#0067C5"), + "ethz" = c("#B7352D","white","#0028a5"), + "uzh" = c("#FC4C02","white","#0028A5"), + "unibe" = c("#8a1e22","white","#4767af"), + "oxf" = c('#FB5607', 'white', '#002147'), + "cmu" = c("#C41230","#E4DAC4","#007BC0"), + "iast" = c("#e62117","#999","#3b5998"), + "hwu" = c("#E38C33","white","#0A3E65"), + "bw" = c("black","grey","white"), + "clay" = c("#D97757","#F0EEE6","#6B5B95"), + "rainbow" = c('#DC050C','#CAE0AB','#882E72'), + c("#d73027","white","#4575b4")) + options(snet_div = dv) +} + +set_categorical_theme <- function(theme){ + if(theme == "bw"){ + pal <- c("#CCCCCC", "#000000") + } else if(theme == "iheid"){ + pal <- c("#006564","#0094D8","#622550", + "#268D2B","#3E2682","#820C2B", + "#008F92","#006EAA","#A8086E") + } else if(theme == "unige"){ + pal <- c("#F42941","#0067C5","#96004B", + "#007E64","#465F7F","#F1AB00", + "#00B1AE","#4B0B71","#FF5C00") + } else if(theme == "ethz"){ + pal <- c("#215CAF","#007894","#627313", + "#8E6713","#B7352D","#A7117A","#6F6F6F") + } else if(theme == "cmu"){ + pal <- c("#EF3A47","#FDB515","#009647", + "#008F91","#043673","#007BC0", + "#1F4C4C","#719F94") + } else if(theme == "iast"){ + pal <- c("#fbda26","#0a0","#9c1a1a", + "#1b870b","#3d86d8","#50e3c2", + "#7ad03d","#fe0087","#e62117", + "#1db6d6","#3b5998","#f58b4c", + "#e9711c","#ff2b46","#d9372f", + "#2fa7d5","#f0c020","#47c965") + } else if(theme == "hwu"){ + pal <- c("#342B20","#6A5B49","#947F68","#F7D6A8", + "#1A4323","#2C642C","#BBC33E","#D3E3BE", + "#5C1F0A","#B25A22","#E38C33","#F5D1A7", + "#921E3F","#D32D5C","#DD7488","#E59CBB", + "#490C3B","#782066","#B84E8F","#D9AACA", + "#031B39","#0A3E65","#0095DB","#C4CEDE") + } else if(theme == "uzh"){ + pal <- c("#0028A5","#4AC9E3","#A4D233", + "#FFC845","#FC4C02","#BF0D3E", + "#BDC9E8","#DBF4F9","#ECF6D6", + "#FFF4DA","#FFDBCC","#FBC6D4", + "#7596FF","#B7E9F4","#DBEDAD", + "#FFE9B5","#FEB799","#F78CAA", + "#3062FF","#92DFEE","#C8E485", + "#FFDE8F","#FE9367","#F3537F", + "#001E7C","#1EA7C4","#7CA023", + "#F3AB00","#BD3902","#8F0A2E", + "#001452","#147082","#536B18", + "#A27200","#7E2601","#60061F") + + } else if(theme == "unibe"){ + pal <- c("#466553","#668271","#8aa092","#afbfb5","#d6ded9", + "#007ea2","#5294b4","#85adc6","#b0c7d9","#d8e2ec", + "#203a5d","#4a5575","#757792","#a1a0b4","#d0ced9", + "#8a1e22","#a14540","#b86f65","#d19d93","#e8cdc6", + "#5a3217","#754e31","#927157","#b49b87","#d7cac0", + "#36b5b6","#75c4c5","#a0d3d4","#c4e3e3","#e2f1f2", + "#ec627d","#f08797","#f4a9b1","#f8c8cc","#fce4e7", + "#4767af","#6e82c0","#949fd1","#b9bee1","#dcdef1", + "#c2b600","#cfc43c","#dcd274","#e8e1a4","#f4f0d3", + "#ee7402","#f3923e","#f7af70","#fbcba1","#fde6d1") + + } else if(theme == "clay"){ + pal <- c("#D97757","#5B6E8F","#788C5D", + "#D4A27F","#6B5B95","#B1ADA1", + "#A8563C","#8CA3B0","#3D3D3A") + } else if(theme == "rainbow"){ + pal <- c('#E8ECFB', '#D9CCE3', '#D1BBD7', + '#CAACCB', '#BA8DB4', '#AE76A3', + '#AA6F9E', '#994F88', '#882E72', + '#1965B0', '#437DBF', '#5289C7', + '#6195CF', '#7BAFDE', + '#4EB265', '#90C987', '#CAE0AB', + '#F7F056', '#F7CB45', '#F6C141', + '#F4A736', '#F1932D', '#EE8026', + '#E8601C', '#E65518', '#DC050C', + '#A5170E', '#72190E', '#42150A') + } else if(theme == "oxf"){ + pal <- c("#776885", '#E08D79', '#ED9390', + '#C4A29E', '#D1BDD5', '#994636', + '#AA1A2D', '#7F055F', '#FE615A', + '#D4CDF4', '#FB5607', '#E6007E', + '#426A5A', '#789E9E', + '#E2C044', '#E4F0EF', '#B9D6F2', + '#A0AF84', '#15616D', '#1D42A6', + '#00AAB4', '#65E5AE', '#95C11F', + '#49B6FF', '#F7EF66') + } else { + pal <- c("#1B9E77","#4575b4","#d73027", + "#66A61E","#E6AB02","#D95F02","#7570B3", + "#A6761D","#E7298A","#666666") + } + # The palettes are written above in whatever order their source gives them, + # which is often a brand's own listing, or families of tints. Neither order + # separates the first few colours a plot actually uses, so reorder for that. + # The "rainbow" theme is the exception: its order is the palette, so it is + # left as the observed spectrum runs. + spread <- theme %in% colorblind_unsorted + if(!spread) + pal <- colorblind_sort(pal, getOption("snet_background", default = "#FFFFFF")) + # A spectrum is only a spectrum if a plot draws from the whole of it, so a + # palette left in its own order is sampled across its length instead of + # taken from the front. + options(snet_cat = pal, snet_cat_spread = spread) +} + +# Every autograph plot is drawn on the theme's own ground, not only the graphs +# that graphr() and grapht() draw. A theme with a dark background used to give +# a dark network plot and white-backed panels for everything else, which left +# the "neon" highlights unreadable on the plots that missed out. +ag_ground <- function(base){ + bg <- ag_ground_fill() + if(bg == "#FFFFFF") return(base) + out <- base + ggplot2::theme( + plot.background = ggplot2::element_rect(fill = bg, colour = NA), + panel.background = ggplot2::element_rect(fill = bg, colour = NA), + legend.background = ggplot2::element_rect(fill = bg, colour = NA), + legend.key = ggplot2::element_rect(fill = bg, colour = NA)) + # Only recolour text the base theme actually draws. Handing an element_text() + # to a theme that had blanked it puts the element back: colouring the axis + # text of ag_theme_void() drew axis ticks and coordinates onto graphs, which + # a graph has no use for, and which the white-backed themes never showed. + for(part in c("text", "axis.text", "strip.text", "legend.text", + "plot.title", "plot.subtitle", "plot.caption")){ + if(inherits(out[[part]], "element_blank")) next + inked <- list(ggplot2::element_text(colour = ag_ink())) + names(inked) <- part + out <- out + do.call(ggplot2::theme, inked) + } + # A theme that blanks its strips has no strip background to fill either. + if(!inherits(out[["strip.text"]], "element_blank")) + out <- out + ggplot2::theme( + strip.background = ggplot2::element_rect(fill = bg, colour = NA)) + out +} + +# The colour a plot is drawn on, which is white unless the theme says +# otherwise -- and white again where the medium is print, whatever the theme +# says, since a tinted ground costs ink and is often not reproduced. +ag_ground_fill <- function(){ + medium_background() %||% getOption("snet_background", default = "#FFFFFF") +} + +`%||%` <- function(x, y) if(is.null(x)) y else x + +# Every ag_theme_*() wrapper wants the same two things of its base theme: the +# theme's typeface, and a text size scaled to the medium the plot is made for. +# Building them from one factory means neither has to be remembered at each of +# the several dozen call sites, and a caller that gives its own base_size -- +# a small inset, say -- still has it scaled rather than overridden. +ag_themer <- function(fun){ + function(...){ + args <- list(...) + if(is.null(args$base_family)) args$base_family <- ag_font() + if(is.null(args$base_size)) args$base_size <- 11 + args$base_size <- args$base_size * ag_size() + ag_ground(do.call(fun, args)) + } +} + +ag_theme_minimal <- ag_themer(ggplot2::theme_minimal) + +ag_theme_classic <- ag_themer(ggplot2::theme_classic) + +ag_theme_grey <- ag_themer(ggplot2::theme_grey) + +ag_theme_bw <- ag_themer(ggplot2::theme_bw) + +ag_theme_void <- ag_themer(ggplot2::theme_void) + diff --git a/R/theme_palettes.R b/R/theme_palettes.R deleted file mode 100644 index fbf03688..00000000 --- a/R/theme_palettes.R +++ /dev/null @@ -1,142 +0,0 @@ -#' Consistent palette calls -#' @description -#' These functions assist in calling particular parts of a theme's palette. -#' For example, `ag_base()` will return the current theme's base or background -#' color, and `ag_highlight()` will return the color used in that theme to -#' highlight one or more nodes, lines, or such. -#' -#' Using palettes that are high contrast, aesthetically pleasing, and -#' institutionally or thematically consistent is not without its challenges. -#' @section Colour blindness: -#' The default palettes are designed to be colour-blind friendly. -#' There are different types of colour-blindness. -#' The most common type, red-green colour-blindness, -#' finds it difficult to distinguish between the red and green hues used -#' in the [rainbow palette](https://colorspace.r-forge.r-project.org/articles/endrainbow.html), -#' for instance. -#' Fortunately there are a range of palettes that function fairly well for -#' those who are color-blind. -#' These include the [viridis](https://CRAN.R-project.org/package=viridis) -#' palette, -#' and the ColorBrewer palettes (included in the RColorBrewer package). -#' The default palettes in `{autograph}` are designed to be colour-blind -#' friendly, but users should always check that their visualisations serve -#' their intended audience. -#' @name ag_call -#' @param number Integer of how many category colours to return. -#' @returns One or more hexcodes as strings. -#' @examples -#' # Single colours from the currently active theme -#' ag_base() -#' ag_highlight() -#' ag_positive() -#' ag_negative() -#' # Palettes of a requested length -#' ag_qualitative(3) -#' ag_sequential(5) -#' ag_divergent(5) -#' # The accessors follow whichever theme is set -#' ag_font() -#' @importFrom grDevices colorRampPalette -#' @export -ag_base <- function(){ - utils::head(getOption("snet_highlight", default = "black"), n = 1) -} - -#' @rdname ag_call -#' @export -ag_highlight <- function(){ - utils::tail(getOption("snet_highlight", default = "red"), n = 1) -} - -#' @rdname ag_call -#' @export -ag_positive <- function(){ - utils::tail(getOption("snet_div", default = "#4575b4"), n = 1) -} - -#' @rdname ag_call -#' @export -ag_negative <- function(){ - utils::head(getOption("snet_div", default = "#d73027"), n = 1) -} - -#' @rdname ag_call -#' @export -ag_qualitative <- function(number){ - snet_colors <- getOption("snet_cat", default = c("#1B9E77","#4575b4","#d73027", - "#66A61E","#E6AB02","#D95F02","#7570B3", - "#A6761D","#E7298A","#666666")) - if(missing(number)) number <- length(snet_colors) - colorRampPalette(snet_colors)(number) -} - -#' @rdname ag_call -#' @export -ag_sequential <- function(number){ - snet_colors <- getOption("snet_highlight", default = "#d73027") - if(length(snet_colors)==1) snet_colors <- c(ag_base(), snet_colors[1]) - colorRampPalette(snet_colors)(number) -} - -#' @rdname ag_call -#' @export -ag_divergent <- function(number){ - # The default must be a real pair of colours, matching ag_negative()'s and - # ag_positive()'s defaults (which read the head and tail of this same - # option). It was the literal string "default", so ag_divergent() errored - # with "invalid color name 'default'" in any session where stocnet_theme() - # had not yet been called -- which the test suite never saw, because - # tests/testthat.R sets the theme before running. - snet_colors <- getOption("snet_div", default = c("#d73027", "#4575b4")) - if(length(snet_colors)==2) - snet_colors <- c(snet_colors[1], "white", snet_colors[2]) - colorRampPalette(snet_colors)(number) -} - -#' @rdname ag_call -#' @export -ag_font <- function(){ - getOption("snet_font", default = "sans") -} - -# nocov start -# Interactive helper for displaying palettes; not called by any package code -ggpizza <- function(colors, init.angle = 105, cex = 4, labcol = NULL) { - n <- length(colors) - angles <- seq(0, 2*pi, length.out = n + 1) + init.angle * pi/180 - - # Data for slices - slices <- lapply(seq_len(n), function(i) { - theta <- seq(angles[i], angles[i+1], length.out = 100) - data.frame( - x = c(0, cos(theta)), - y = c(0, sin(theta)), - color = colors[i], - group = i - ) - }) %>% dplyr::bind_rows() - - # Label positions - mids <- (angles[-1] + angles[-(n+1)]) / 2 - labels <- data.frame( - x = 1.1 * cos(mids), - y = 1.1 * sin(mids), - label = colors - ) - - # Label color choice - labels$labcol <- ag_base() - - ggplot2::ggplot() + - ggplot2::geom_polygon(data = slices, aes(x, y, group = group, fill = color), - color = "white") + - ggplot2::geom_text(data = labels, aes(x, y, label = label, color = labcol), - size = cex) + - ggplot2::scale_fill_identity() + - ggplot2::scale_color_identity() + - ggplot2::coord_equal() + - ggplot2::theme_void() -} -# nocov end - diff --git a/R/theme_set.R b/R/theme_set.R deleted file mode 100644 index f20271fd..00000000 --- a/R/theme_set.R +++ /dev/null @@ -1,270 +0,0 @@ -#' Setting a consistent theme for all plots -#' @description -#' This function enables plots to be quickly, easily and consistently themed. -#' This is achieved by setting a theme option, usually at the start of an R -#' session, that enables the palette to be used for -#' all autograph-consistent plotting methods. -#' This includes thematic colours for backgrounds, highlights, -#' sequential, divergent and categorical colour schemes. -#' The function sets these palettes to options that are then -#' used by the various plotting functions. -#' -#' If no theme is specified (i.e. the function is called without argument), -#' the current theme is reported. -#' The default theme is "default". -#' This theme uses a white background, blue and red for -#' highlighting, and a blue-white-red divergent palette. -#' The themes can be changed at any time by calling `stocnet_theme()` -#' or its alias `set_stocnet_theme()` with a different theme name. -#' -#' Other themes include those based on the colour schemes of various -#' universities, including ETH Zurich, UZH, UNIBE, RUG, and Oxford. -#' Other themes include "bw" for black and white, "crisp" for a -#' high-contrast black and white theme, "neon" for a dark theme -#' with neon highlights, and "rainbow" for a colourful theme. -#' Most themes are designed to be colour-blind safe. -#' -#' @name theme_set -#' @family themes -#' @section Fonts: -#' Some themes also set a preferred font for use in plots, -#' if available on the system (a check is performed). -#' In some cases, this includes a vector of options to try in sequence. -#' If none of the preferred fonts are available, a sans-serif font is used. -#' If you receive a warning about a missing font when setting a theme, -#' try installing one of the preferred fonts or make sure that the font is -#' available to R using `extrafont::font_import()` and `extrafont::loadfont()` -#' @section Custom: -#' If you have specific needs or preferences, you can -#' set your own palettes or overwrite part of an existing one using `options()`. -#' For example, to set a custom base color, you can use: -#' `options(snet_highlight = c("#1b9e77", "#d95f02", "#7570b3"))`. -#' This will set a custom highlight color palette. -#' Similarly, you can set `snet_div` for divergent palettes -#' and `snet_cat` for categorical palettes. -#' @returns This function sets the theme and palette(s) to be used across all -#' stocnet packages. The palettes are written to options and held there. -#' @examples -#' stocnet_theme("default") -#' plot(netrics::node_by_degree(ison_karateka)) -#' stocnet_theme("uzh") -#' plot(netrics::node_by_degree(ison_karateka)) -NULL - -theme_opts <- c("default", "bw", "crisp", "neon", - "iheid", "ethz", "uzh", "rug", "unibe", - "oxf", "unige", "cmu", "iast", "hwu", - "rainbow") - -#' @rdname theme_set -#' @param theme String naming a theme. -#' By default "default". -#' The following themes are currently available: -#' `r autograph:::theme_opts`. -#' This string can be capitalised or not. -#' @importFrom manynet snet_info snet_success -#' @export -stocnet_theme <- function(theme = NULL){ - if(is.null(theme)){ - theme <- getOption("stocnet_theme", default = "default") - snet_info("Theme is currently set to {.emph {theme}}.", - "The following themes are available: {.emph {theme_opts}}.") - } else { - if(!is.character(theme) || length(theme) != 1L) - manynet::snet_abort( - "{.arg theme} should be the name of a single theme, given as a string.", - "The themes available are {.val {theme_opts}}.") - # An unrecognised theme used to warn and leave the theme unchanged, which - # was easy to miss and left plots looking wrong for no visible reason. - theme <- .match_name(tolower(theme), theme_opts, "theme", what = "theme") - options(stocnet_theme = theme) - set_highlight_theme(theme) - set_divergent_theme(theme) - set_background_theme(theme) - set_categorical_theme(theme) - set_font_theme(theme) - snet_success("Theme set to {.emph {theme}}.") - } -} - -#' @rdname theme_set -#' @export -set_stocnet_theme <- stocnet_theme - -set_background_theme <- function(theme){ - if(theme == "neon"){ - options(snet_background = "#070f23") - } else if(theme == "cmu"){ - options(snet_background = "#E4DAC4") - } else { - options(snet_background = "#FFFFFF") - } -} - -set_highlight_theme <- function(theme){ - hl <- switch(theme, - "iheid" = c("#000010","#E20020"), - "unige" = c("#A3A3A3","#CF0063"), - "rug" = c("#000000", "#dc002d"), - "uzh" = c("#a3adb7", "#dc6027"), - "unibe" = c("#121212", "#e4003c"), - "oxf" = c("#002147", "#c09725"), - "ethz" = c("#6F6F6F", "#0028a5"), - "cmu" = c("#6D6E71", "#C41230"), - "iast" = c("#555", "#e54a37"), - "hwu" = c("#0A3E65", "#0095DB"), - "crisp" = c("#bfbfbf", "#101314"), - "bw" = c("#CCCCCC", "#000000"), - "neon" = c("#5aeafd", "#54fe4b"), - "rainbow" = c('#1965B0', '#DC050C'), - c("#4576B5", "#D83127")) - options(snet_highlight = hl) -} - -# "#E20020" - IHEID red -# "#215CAF" - ETH blue -# "#EDEDF4" - ghost white -# "#071013" - rich black -# "#EDAE49" - hunyadi yellow -# "#3C493F" - field green -# "#679289" - viridian - -set_divergent_theme <- function(theme){ - dv <- switch(theme, - "iheid" = c("#820C2B","#006EAA","#006564"), - "unige" = c("#0067C5","white","#F42941"), - "ethz" = c("#B7352D","#007894","#627313"), - "uzh" = c("#FC4C02","#4AC9E3","#A4D233"), - "unibe" = c("#8a1e22","#007ea2","#466553"), - "oxf" = c('#426A5A', 'white', '#ED9390'), - "cmu" = c("#941120","#BCB49E","#182C4B"), - "iast" = c("#e62117","#999","#3b5998"), - "hwu" = c("#D32D5C","#6A5B49","#0A3E65"), - "bw" = c("black","grey","white"), - "rainbow" = c('#DC050C','#CAE0AB','#882E72'), - c("#d73027","white","#4575b4")) - options(snet_div = dv) -} - -set_categorical_theme <- function(theme){ - if(theme == "bw"){ - options(snet_cat = c("#CCCCCC", "#000000")) - } else if(theme == "iheid"){ - options(snet_cat = c("#006564","#0094D8","#622550", - "#268D2B","#3E2682","#820C2B", - "#008F92","#006EAA","#A8086E")) - } else if(theme == "unige"){ - options(snet_cat = c("#F42941","#0067C5","#96004B", - "#007E64","#465F7F","#F1AB00", - "#00B1AE","#4B0B71","#FF5C00")) - } else if(theme == "ethz"){ - options(snet_cat = c("#215CAF","#007894","#627313", - "#8E6713","#B7352D","#A7117A","#6F6F6F")) - } else if(theme == "cmu"){ - options(snet_cat = c("#EF3A47","#FDB515","#009647", - "#008F91","#043673","#007BC0", - "#1F4C4C","#719F94")) - } else if(theme == "iast"){ - options(snet_cat = c("#fbda26","#0a0","#9c1a1a", - "#1b870b","#3d86d8","#50e3c2", - "#7ad03d","#fe0087","#e62117", - "#1db6d6","#3b5998","#f58b4c", - "#e9711c","#ff2b46","#d9372f", - "#2fa7d5","#f0c020","#47c965")) - } else if(theme == "hwu"){ - options(snet_cat = c("#342B20","#6A5B49","#947F68","#F7D6A8", - "#1A4323","#2C642C","#BBC33E","#D3E3BE", - "#5C1F0A","#B25A22","#E38C33","#F5D1A7", - "#921E3F","#D32D5C","#DD7488","#E59CBB", - "#490C3B","#782066","#B84E8F","#D9AACA", - "#031B39","#0A3E65","#0095DB","#C4CEDE")) - } else if(theme == "uzh"){ - options(snet_cat = c("#0028A5","#4AC9E3","#A4D233", - "#FFC845","#FC4C02","#BF0D3E", - "#BDC9E8","#DBF4F9","#ECF6D6", - "#FFF4DA","#FFDBCC","#FBC6D4", - "#7596FF","#B7E9F4","#DBEDAD", - "#FFE9B5","#FEB799","#F78CAA", - "#3062FF","#92DFEE","#C8E485", - "#FFDE8F","#FE9367","#F3537F", - "#001E7C","#1EA7C4","#7CA023", - "#F3AB00","#BD3902","#8F0A2E", - "#001452","#147082","#536B18", - "#A27200","#7E2601","#60061F")) - - } else if(theme == "unibe"){ - options(snet_cat = c("#466553","#668271","#8aa092","#afbfb5","#d6ded9", - "#007ea2","#5294b4","#85adc6","#b0c7d9","#d8e2ec", - "#203a5d","#4a5575","#757792","#a1a0b4","#d0ced9", - "#8a1e22","#a14540","#b86f65","#d19d93","#e8cdc6", - "#5a3217","#754e31","#927157","#b49b87","#d7cac0", - "#36b5b6","#75c4c5","#a0d3d4","#c4e3e3","#e2f1f2", - "#ec627d","#f08797","#f4a9b1","#f8c8cc","#fce4e7", - "#4767af","#6e82c0","#949fd1","#b9bee1","#dcdef1", - "#c2b600","#cfc43c","#dcd274","#e8e1a4","#f4f0d3", - "#ee7402","#f3923e","#f7af70","#fbcba1","#fde6d1")) - - } else if(theme == "rainbow"){ - options(snet_cat = c('#E8ECFB', '#D9CCE3', '#D1BBD7', - '#CAACCB', '#BA8DB4', '#AE76A3', - '#AA6F9E', '#994F88', '#882E72', - '#1965B0', '#437DBF', '#5289C7', - '#6195CF', '#7BAFDE', - '#4EB265', '#90C987', '#CAE0AB', - '#F7F056', '#F7CB45', '#F6C141', - '#F4A736', '#F1932D', '#EE8026', - '#E8601C', '#E65518', '#DC050C', - '#A5170E', '#72190E', '#42150A')) - } else if(theme == "oxf"){ - options(snet_cat = c("#776885", '#E08D79', '#ED9390', - '#C4A29E', '#D1BDD5', '#994636', - '#AA1A2D', '#7F055F', '#FE615A', - '#D4CDF4', '#FB5607', '#E6007E', - '#426A5A', '#789E9E', - '#E2C044', '#E4F0EF', '#B9D6F2', - '#A0AF84', '#15616D', '#1D42A6', - '#00AAB4', '#65E5AE', '#95C11F', - '#49B6FF', '#F7EF66')) - } else { - options(snet_cat = c("#1B9E77","#4575b4","#d73027", - "#66A61E","#E6AB02","#D95F02","#7570B3", - "#A6761D","#E7298A","#666666")) - } -} - -set_font_theme <- function(theme){ - - # Get available fonts depending on OS - if (.Platform$OS.type == "windows") { - available_fonts <- c(names(grDevices::windowsFonts()), - names(grDevices::postscriptFonts())) - } else { - available_fonts <- c(names(grDevices::X11Fonts()), - names(grDevices::postscriptFonts())) - } - - candidates <- switch(theme, - "iheid" = c("Helvetica", "Arial", "Verdana"), - "ethz" = c("DIN Next","Arial"), - "uzh" = c("Source Sans", "TheSans", "Palatino"), - "rug" = c("Arial","Parry","Georgia","Open Sans"), - "oxf" = c("Roboto","Noto Serif","Aktiv Grotesk"), - "cmu" = c("Open Sans","Source Serif Pro","Helvetica","Times"), - "iast" = c("Gogh","Monserrat","Playfair","Roboto","tse"), - "hwu" = c("Univers LT Pro","Baskerville BT","Arial"), - "neon" = "Comic Sans MS" - ) - - # Find first match - if(any(candidates %in% available_fonts)){ - font_match <- candidates[candidates %in% available_fonts] - snet_info("Setting font to {font_match[1]}.") - } else { - snet_info("None of the preferred fonts for theme {.emph {theme}},", - "{candidates}, are available.", - "Try using {.pkg extrafont} to import and load fonts.", - "Using default sans-serif font instead.") - font_match <- "sans" - } - options(snet_font = font_match[1]) -} diff --git a/R/zzz.R b/R/zzz.R index 0808e363..518db6ff 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -2,48 +2,42 @@ .onAttach <- function(...) { # suppressMessages(suppressPackageStartupMessages(library("manynet", warn.conflicts = FALSE))) - if (!interactive()) return() - - # options(manynet_verbosity = getOption("manynet_verbosity", "verbose")) - options(stocnet_theme = getOption("stocnet_theme", "default")) - # options(cli.theme = manynet_console_theme()) - # options(cli.progress_clear = TRUE) - # pkgs <- as.data.frame(utils::available.packages(utils::contrib.url(getOption("repos")))) - # - # cran_version <- pkgs[pkgs$Package == "manynet","Version"] + # A theme the user chose with `stocnet_theme(persist = TRUE)` becomes the + # default, but an option set in this session still wins. + saved_theme <- read_theme_pref() + options(stocnet_theme = getOption("stocnet_theme", + if (is.null(saved_theme)) "default" else saved_theme)) + # Apply the palettes too, so a persisted theme takes effect on the first plot + # rather than only after `stocnet_theme()` is called again. + if (!is.null(saved_theme)) { + set_highlight_theme(saved_theme) + # The ink was missing here, so a persisted dark theme -- "neon" above all + # -- came back with its near-black ground and the default dark ink. + set_ink_theme(saved_theme) + set_divergent_theme(saved_theme) + set_background_theme(saved_theme) + set_categorical_theme(saved_theme) + set_missing_theme(saved_theme) + set_font_theme(saved_theme) + } + + # The medium is remembered separately from the theme, and says where the + # plot will be seen rather than how it should look. See ?stocnet_medium. + saved_medium <- read_medium_pref() + options(stocnet_medium = getOption("stocnet_medium", + if (is.null(saved_medium)) "screen" else saved_medium)) + + if (!interactive()) return() local_version <- utils::packageVersion("autograph") snet_info("You are using {.auto autograph} version {.version {local_version}}.") - old.list <- as.data.frame(utils::old.packages()) - behind_cran <- "autograph" %in% old.list$Package - curr_theme <- getOption('stocnet_theme') - - greet_startup_cli <- function() { - tips <- c( - # "i" = "Theming graphs and plots is straightforward with `stocnet_theme()`", - "i" = "Theme set to {.code {getOption('stocnet_theme')}}. Use {.fn stocnet_theme} to change the theme." - # "i" = "Please share bugs, issues, or feature requests at {.url https://github.com/stocnet/autograph/issues}.", - # "i" = "To eliminate package startup messages, use: `suppressPackageStartupMessages(library({.pkg autograph}))`.", - # "i" = "If there are too many messages in the console, run `options(manynet_verbosity = 'quiet')`", - # "i" = "Visit the website to learn more: {.url https://stocnet.github.io/autograph/}." - # "i" = "We recommend the 'Function Overview' page online to discover new analytic opportunities: {.url https://stocnet.github.io/autograph/reference/index.html}.", - ) - snet_info(sample(tips, 1)) - } - - if (interactive()) { - if (behind_cran) { - msg <- "A new version of autograph is available with bug fixes and new features." - packageStartupMessage(msg, "\nWould you like to install it?") - if (utils::menu(c("Yes", "No")) == 1) { - utils::update.packages("autograph") - } - } else { - greet_startup_cli() - } - } + snet_info(c("i" = "Theme set to {.code {getOption('stocnet_theme')}}. Use {.fn stocnet_theme} to change the theme.")) + # Only after the interactive() guard above: a script or a check run should + # never reach into the IDE, whatever is remembered. + if (isTRUE(read_pref("completion")) && .completion_activate()) + snet_info("Completion of argument values is on. Use {.fn stocnet_completion} to switch it off.") } # nocov end diff --git a/README.Rmd b/README.Rmd index 053b0e21..59dde706 100644 --- a/README.Rmd +++ b/README.Rmd @@ -1,5 +1,7 @@ --- -output: github_document +output: + github_document: + html_preview: false --- @@ -22,9 +24,44 @@ list_data <- function(string){ # Several README figures are hosted on jameshollway.com rather than in man/figures, # to keep the package tarball small. The chunks below regenerate them in place, # but only where that site's checkout is present (i.e. not on CI or CRAN). -site_dir <- path.expand("~/Library/CloudStorage/Dropbox/Sites/jameshollway.com/content/post/manynet") +# Set AUTOGRAPH_SITE_DIR to point at your own checkout of that site. +site_dir <- Sys.getenv( + "AUTOGRAPH_SITE_DIR", + unset = path.expand("~/Library/CloudStorage/Dropbox/Sites/jameshollway.com/content/post/autograph")) site_figure <- function(name) file.path(site_dir, name) +# Chunks that show their code write their figures to the site directory through +# knitr itself, by setting `fig.path` to this prefix and hiding the local link. +site_prefix <- paste0(site_dir, "/README-") have_site <- dir.exists(site_dir) +if (!have_site) { + # written straight to stderr, since this chunk's messages are not shown + cat("NOTE: no jameshollway.com checkout at ", site_dir, ".\n", + " Hosted figures were not regenerated, and README.md keeps pointing at\n", + " the published copies, so the knit is still correct. Set AUTOGRAPH_SITE_DIR\n", + " or knit from a machine with that checkout to refresh them, and to see\n", + " whether the defaults have drifted.\n", sep = "", file = stderr()) +} +# Comparison figures pair a base-graphics call against a ggplot, so they are +# written with an explicit device rather than ggsave(). Both plots are passed +# unevaluated and forced inside, once the device and viewport are set up. +# Knitting regenerates each figure from the current defaults, so that drift +# shows up in the published image even though the chunks themselves are hidden. +library(igraph) +library(gridBase) +library(grid) +compare_figure <- function(name, base_plot, gg_plot, + mai = c(0, 0, 0.5, 0), + width = 12, height = 4, res = 250) { + grDevices::png(site_figure(name), + width = width, height = height, units = "in", res = res) + on.exit(grDevices::dev.off(), add = TRUE) + par(mfrow = c(1, 2), mai = mai) + base_plot # forced here, into the left panel + plot.new() # the ggplot is drawn over the right panel + pushViewport(baseViewports()$figure) + print(gg_plot, vp = plotViewport(c(1.8, 1, 0, 1))) + invisible(name) +} ``` # autograph autograph logo @@ -92,29 +129,15 @@ Second, it includes sensible defaults so that researchers can view their network or distribution quickly with a minimum of fuss. Compare the output from `{autograph}` with a similar default from `{igraph}`: -Example illustrating differences in default igraph and autograph graphs +Example illustrating differences in default igraph and autograph graphs -```{r layout-comparison, echo = FALSE, message=FALSE, eval = have_site, fig.show="hide"} -library(autograph) -library(igraph) -library(gridBase) -library(grid) - -# base graphics, so written with an explicit device rather than ggsave() -png(site_figure("README-layout-comparison-1.png"), - width = 12, height = 4, units = "in", res = 250) - -par(mfrow=c(1, 2), mai = c(0,0,0.5,0)) -plot(as_igraph(ison_southern_women), layout = layout_as_bipartite, main = "{igraph} bipartite") -## the last one is the current plot -plot.new() ## suggested by @Josh -vps <- baseViewports() -pushViewport(vps$figure) ## I am in the space of the autocorrelation plot -vp1 <-plotViewport(c(1.8,1,0,1)) ## create new vp with margins, you play with this values -p <- graphr(ison_southern_women) + ggtitle("{autograph} twomode") + guides(shape = "none") -print(p,vp = vp1) - -dev.off() +```{r layout-comparison, echo = FALSE, message=FALSE, warning=FALSE, results="hide", eval = have_site, fig.show="hide"} +compare_figure( + "README-layout-comparison-1.png", + plot(as_igraph(ison_southern_women), layout = layout_as_bipartite, + main = "{igraph} bipartite"), + graphr(ison_southern_women) + ggtitle("{autograph} twomode") + + guides(shape = "none")) ``` `{igraph}` requires the bipartite layout to be specified, @@ -127,6 +150,30 @@ It also recognises that the network contains names for the nodes and prints them vertically so that they are legible in this layout. Other 'clever' features include automatic node sizing and more. +This inference matters for more than tidiness. +Where a default does not recognise a property of the network, +that property is usually dropped silently. +Compare the same signed network drawn by each package: + +Example illustrating that igraph's default draws positive and negative ties identically + +```{r signed-comparison, echo = FALSE, message=FALSE, warning=FALSE, results="hide", eval = have_site, fig.show="hide"} +compare_figure( + "README-signed-comparison-1.png", + plot(as_igraph(irps_tribes), main = "{igraph} default"), + graphr(irps_tribes) + ggtitle("{autograph} signed")) +``` + +`irps_tribes` records both alliance and antagonism between sixteen tribes, +in equal number. +`{igraph}` draws all of these ties identically, +so the distinction that motivates the data is not visible. +`graphr()` recognises the network as signed and +maps the sign to both colour and linetype, with a legend. +The same applies to weights, to self-ties, and to direction: +`graphr()` reads these from the network rather than +requiring you to know to ask for them. + ### More options All of `graphr()`'s adjustments can be overridden, however... @@ -136,7 +183,7 @@ e.g. `node_color = "darkblue"` or `node_size = 6`, or indicating from which attribute it should inherit this information, e.g. `node_color = "Office"` or `node_size = "Seniority"`. -Graph illustrating automatic and manual use of node color and size +Graph illustrating automatic and manual use of node color and size ```{r more-options, echo = FALSE, message=FALSE, eval = have_site} p <- graphr(ison_lawfirm, node_color = "darkblue", node_size = 6) + @@ -158,16 +205,16 @@ or other elements (e.g. font size) can be tweaked for a particular output. `graphr()` can use all the layout algorithms offered by packages such as `{igraph}`, `{ggraph}`, and `{graphlayouts}`. `{autograph}` also offers some additional layout algorithms for -visualising partitions horizontally, vertically, or concentrically, +visualising layers horizontally, vertically, or concentrically, conforming to configurational coordinates, or for snapping these layouts to a grid. -Graphs illustrating different layouts +Graphs illustrating different layouts ```{r more-layouts, echo = FALSE, message=FALSE, eval = have_site} p <- (graphr(ison_southern_women, layout = "concentric") + ggtitle("Concentric layout")) / - ((graphr(to_unnamed(create_explicit(A-+B-+C, A-+C))) + ggtitle("Triad layout")) | - (graphr(to_unnamed(create_explicit(A-+C, A-+D, B-+C, B-+D))) + ggtitle("Quad layout"))) + ((graphr(to_unnamed(create_explicit(A-+B-+C, A-+C))) + ggtitle("Triad configuration")) | + (graphr(to_unnamed(create_explicit(A-+C, A-+D, B-+C, B-+D))) + ggtitle("Tetrad configuration"))) ggsave(site_figure("README-more-layouts-1.png"), p, width = 7, height = 5, dpi = 250) ``` @@ -179,12 +226,20 @@ This can be useful for ego networks or network panels. `{patchwork}` is used to help arrange individual plots together, and is used throughout the package to help arrange plots together informatively. -Example of graphs() used on longitudinal data +`graphs()` computes one layout and holds it across every panel. +Plotting each network separately gives each panel its own layout, +so a node can appear in a different position in each panel +even where nothing about that node has changed. +Holding the layout constant makes the panels comparable, +so that what moves on the page is what changed in the data. +`graphs()` also collects a single legend for the whole set. + +Example of graphs() used on longitudinal data ```{r autographs, echo = FALSE, eval = have_site} -p <- ison_adolescents %>% - mutate_ties(wave = c(rep(1995, 5), rep(1998, 5))) %>% - to_waves(attribute = "wave", panels = c(1995, 1998)) %>% +p <- ison_adolescents |> + mutate_ties(wave = c(rep(1995, 5), rep(1998, 5))) |> + to_waves(attribute = "wave", panels = c(1995, 1998)) |> graphs() ggsave(site_figure("README-autographs-1.png"), p, width = 7, height = 3, dpi = 250) ``` @@ -199,11 +254,11 @@ with node positions transitioning smoothly between waves and nodes fading in and out as they enter and exit the network. It really couldn't be easier. -Example of grapht() on longitudinal data +Example of grapht() on longitudinal data ```{r autographd, echo = FALSE, eval = have_site} -p <- ison_adolescents %>% - mutate_ties(wave = sample(1995:1998, 10, replace = TRUE)) %>% +p <- ison_adolescents |> + mutate_ties(wave = sample(1995:1998, 10, replace = TRUE)) |> grapht() # a gif, so rendered with gganimate rather than ggsave(); the animate() arguments # mirror those in print.grapht() so the saved file matches what users see @@ -235,12 +290,36 @@ To keep things simple, all users need to remember is a single, generic function: `plot()`. Method dispatching takes care of the rest, so you can concentrate on exploring and interpreting your results. -Here are some examples, using goodness-of-fit results from fitting a SAOM + +Dispatching works because the results carry a class. +`igraph::degree()` and `sna::degree()` each return a bare numeric vector, +so `plot()` falls back to a scatterplot of the values against their index, +and that index is not meaningful. +`netrics::node_by_degree()` returns a `node_measure`, +which `{autograph}` plots as a themed distribution: + +Example illustrating that plotting a bare vector of degree scores gives an index scatterplot, where plotting a node_measure gives a distribution + +```{r result-comparison, echo = FALSE, message=FALSE, warning=FALSE, results="hide", eval = have_site, fig.show="hide"} +compare_figure( + "README-result-comparison-1.png", + plot(igraph::degree(as_igraph(ison_karateka)), + ylab = "igraph::degree(ison_karateka)", + main = "plot() of a numeric vector"), + plot(netrics::node_by_degree(ison_karateka)) + + ggtitle("plot() of a node_measure"), + mai = c(0.8, 0.8, 0.5, 0.2)) +``` + +The same holds for the other result classes. +Here are some further examples, using goodness-of-fit results from fitting a SAOM in `{RSiena}` and an ERGM in `{ergm}`. (Note that neither the data nor the model are similar; this is just for illustrative purposes.) -```{r siena-ergm-gof, echo = FALSE, dpi = 250, fig.height=2.5, message=FALSE, fig.alt="Goodness-of-fit plots for a SAOM fitted in RSiena and an ERGM fitted in ergm"} +Goodness-of-fit plots for a SAOM fitted in RSiena and an ERGM fitted in ergmGoodness-of-fit plots for a SAOM fitted in RSiena and an ERGM fitted in ergm + +```{r siena-ergm-gof, echo = FALSE, dpi = 250, fig.height=2.5, message=FALSE, fig.path = site_prefix, fig.show = "hide", eval = have_site} plot(siena_gof) + ggtitle("SAOM goodness-of-fit") plot(ergm_gof) + ggtitle("ERGM goodness-of-fit") ``` @@ -257,7 +336,7 @@ Then enter the chosen theme name in the function to set it. All plots created using `{autograph}` functions will then use this theme, until you change it again. -```{r themeset, dpi = 300, fig.height=5, fig.alt="Themed figures"} +```{r themeset, dpi = 300, fig.height=5, fig.path = site_prefix, fig.show = "hide", eval = have_site} stocnet_theme() (plot(netrics::node_by_degree(ison_karateka)) + plot(netrics::tie_by_betweenness(ison_karateka)))/ @@ -272,11 +351,15 @@ plot(as_matrix(ison_southern_women), membership = netrics::node_in_regular(ison_southern_women, "e"))) ``` +Themed figuresThemed figures + There are a range of institutional and topical themes available, including `r autograph:::theme_opts`, with more on the way. -```{r theme-opts, echo=FALSE, dpi = 300, fig.height=3, fig.width=8, fig.alt="Institutional themes"} +Institutional themesInstitutional themes + +```{r theme-opts, echo=FALSE, dpi = 300, fig.height=3, fig.width=8, fig.path = site_prefix, fig.show = "hide", eval = have_site} set_stocnet_theme("iheid") ai <- autograph:::ggpizza(ag_qualitative()) + ggtitle("IHEID") + theme(plot.title = ggplot2::element_text(colour = ag_highlight())) @@ -299,6 +382,111 @@ ai | au | ae ar | as | ac ``` +### Colours everyone can read + +About one man in twelve, and one woman in two hundred, sees colour differently. +A palette that separates its categories for most readers can collapse for them, +and the classic offender is the red-green pair that so many palettes hold. + +`{autograph}` does something about this without asking you to give up a palette. +Every theme's categorical palette is reordered when the theme is set, +so that the colours a graph reaches for first are those that stay distinct +under each type of colour blindness, +and each divergent palette pairs a warm pole with a cool one. + +`simulate_colorblind()` shows a set of colours as another viewer sees them, +so mapping the simulated colours back onto a graph shows you their view of it. +Here is the same network four times: +in `{autograph}`'s default palette as most readers see it, +then as a reader with deuteranopia does, +then as a photocopier renders it, +and then in the palette `{ggraph}` falls back on when `{autograph}` is not +setting the colours, as that same reader with deuteranopia sees it. + +```{r cvd, message=FALSE, warning=FALSE, dpi = 300, fig.height=3, fig.width=12, fig.path = site_prefix, fig.show = "hide", eval = have_site} +set_stocnet_theme("default") +as_seen <- function(colours, type, title){ + graphr(fict_lotr, node_colour = "Race", node_size = 3, labels = FALSE) + + ggplot2::scale_fill_manual(values = simulate_colorblind(colours, type)) + + ggtitle(title) +} +as_seen(ag_qualitative(6), "normal", "autograph") | + as_seen(ag_qualitative(6), "deutan", "autograph, deuteranopia") | + as_seen(ag_qualitative(6), "grey", "autograph, greyscale") | + as_seen(scales::hue_pal()(6), "deutan", "ggraph default, deuteranopia") +``` + +The same network seen with normal vision, with deuteranopia, and in greyscale, in autograph's palette, and with deuteranopia in ggraph's + +The six races remain tellable apart in the second panel, +its closest pair being Hobbits and Maiar. +In the right-hand one, Elves and Ents have become the same olive. +The third panel is the harder case, and it is not one reordering can fix: +a greyscale device keeps only the luminance of a colour, +so two colours of the same lightness merge however different their hues. +`check_separation()` reports that view beside its own score; +where a figure has to print in black and white, +use the `"bw"` theme or add a second channel such as `node_shape`. +`check_separation()` puts a number on it, +scoring how far apart colours are at their worst +across normal vision and each type of colour blindness: + +```{r cvdscore} +round(min(check_separation(ag_qualitative(6)), na.rm = TRUE), 1) # autograph +round(min(check_separation(scales::hue_pal()(6)), na.rm = TRUE), 1) # ggraph +round(min(check_separation(igraph::categorical_pal(6)), na.rm = TRUE), 1) # igraph +``` + +Below 10 two colours are easily confused, above 25 they are comfortably distinct. +`{igraph}`'s categorical palette is the Okabe-Ito scheme, +which was designed for this and scores accordingly: +where you are free to choose any colours at all, such a scheme is hard to beat, +and `graphr()` will happily take it. +The harder case is the one `{autograph}` is built for — +colours chosen by somebody else, for reasons that were not legibility — +and there the ordering is what stands between a brand palette and an +unreadable graph. +A palette with more colours to draw on has more room to gain: +six categories score 29 under the `"hwu"` theme and 26 under `"oxf"`. + +Marks are only half of it. +Text has to be read rather than told apart, +which is a matter of contrast rather than of hue, +and `check_contrast()` scores it against the thresholds of WCAG 2.1: +4.5 for body text, 3 for large text and for graphical objects. +Every theme's ink clears 4.5 on that theme's own ground, +and the test suite holds it there. + +Each theme's name written in that theme's ink on that theme's ground, annotated with its WCAG contrast ratio + +```{r wcag, echo=FALSE, dpi = 300, fig.height=2.2, fig.width=9, fig.path = site_prefix, fig.show = "hide", eval = have_site} +inks <- do.call(rbind, lapply(autograph:::theme_opts, function(t){ + set_stocnet_theme(t) + bg <- getOption("snet_background") + data.frame(theme = t, ink = ag_ink(), ground = bg, + ratio = round(check_contrast(ag_ink(), bg)[1, 2], 1)) +})) +set_stocnet_theme("default") +inks$x <- (seq_len(nrow(inks)) - 1) %% 8 +inks$y <- -((seq_len(nrow(inks)) - 1) %/% 8) +ggplot(inks, aes(x, y)) + + ggplot2::geom_tile(aes(fill = ground), width = 0.96, height = 0.9, + colour = "grey80") + + ggplot2::geom_text(aes(label = theme, colour = ink), nudge_y = 0.13, size = 4) + + ggplot2::geom_text(aes(label = paste0(ratio, ":1"), colour = ink), + nudge_y = -0.17, size = 3) + + ggplot2::scale_fill_identity() + ggplot2::scale_colour_identity() + + ggplot2::coord_equal() + ggplot2::theme_void() +``` + +The medium is a separate question again. +`stocnet_medium()` sizes the text for where the figure will be seen — +`"screen"`, `"presentation"`, `"mobile"` — and `"print"` draws on white +whatever ground the theme prefers, since a tinted ground costs ink +and is often not reproduced. +The theme is untouched by it, so one institutional palette carries +from the desk to the slide to the page. + If your institution or organisation is not included and you would like it to be, please just raise an issue on Github, along with a link to your corporate branding or style guide if available, diff --git a/README.md b/README.md index 9900d625..aaa4f883 100644 --- a/README.md +++ b/README.md @@ -73,10 +73,7 @@ network’s structure or distribution quickly with a minimum of fuss. Compare the output from `{autograph}` with a similar default from `{igraph}`: -Example illustrating differences in default igraph and autograph graphs - - #> quartz_off_screen - #> 2 +Example illustrating differences in default igraph and autograph graphs `{igraph}` requires the bipartite layout to be specified, has cumbersome node size defaults for all but the smallest graphs, and labels also very @@ -88,6 +85,20 @@ contains names for the nodes and prints them vertically so that they are legible in this layout. Other ‘clever’ features include automatic node sizing and more. +This inference matters for more than tidiness. Where a default does not +recognise a property of the network, that property is usually dropped +silently. Compare the same signed network drawn by each package: + +Example illustrating that igraph's default draws positive and negative ties identically + +`irps_tribes` records both alliance and antagonism between sixteen +tribes, in equal number. `{igraph}` draws all of these ties identically, +so the distinction that motivates the data is not visible. `graphr()` +recognises the network as signed and maps the sign to both colour and +linetype, with a legend. The same applies to weights, to self-ties, and +to direction: `graphr()` reads these from the network rather than +requiring you to know to ask for them. + ### More options All of `graphr()`’s adjustments can be overridden, however… Changing the @@ -97,7 +108,7 @@ e.g. `node_color = "darkblue"` or `node_size = 6`, or indicating from which attribute it should inherit this information, e.g. `node_color = "Office"` or `node_size = "Seniority"`. -Graph illustrating automatic and manual use of node color and size +Graph illustrating automatic and manual use of node color and size Legends are added by default when node or tie aesthetics are mapped to attributes, but can be removed with `show_legend = FALSE`. Since the @@ -109,11 +120,11 @@ plotting, axis labels can all be added on easily, or other elements `graphr()` can use all the layout algorithms offered by packages such as `{igraph}`, `{ggraph}`, and `{graphlayouts}`. `{autograph}` also offers -some additional layout algorithms for visualising partitions -horizontally, vertically, or concentrically, conforming to -configurational coordinates, or for snapping these layouts to a grid. +some additional layout algorithms for visualising layers horizontally, +vertically, or concentrically, conforming to configurational +coordinates, or for snapping these layouts to a grid. -Graphs illustrating different layouts +Graphs illustrating different layouts ### More networks @@ -123,7 +134,14 @@ network panels. `{patchwork}` is used to help arrange individual plots together, and is used throughout the package to help arrange plots together informatively. -Example of graphs() used on longitudinal data +`graphs()` computes one layout and holds it across every panel. Plotting +each network separately gives each panel its own layout, so a node can +appear in a different position in each panel even where nothing about +that node has changed. Holding the layout constant makes the panels +comparable, so that what moves on the page is what changed in the data. +`graphs()` also collects a single legend for the whole set. + +Example of graphs() used on longitudinal data ### More time @@ -133,7 +151,7 @@ that visualises network changes over time, with node positions transitioning smoothly between waves and nodes fading in and out as they enter and exit the network. It really couldn’t be easier. -Example of grapht() on longitudinal data +Example of grapht() on longitudinal data @@ -162,12 +180,22 @@ also provides a function for plotting results from the analysis or modelling of those networks. To keep things simple, all users need to remember is a single, generic function: `plot()`. Method dispatching takes care of the rest, so you can concentrate on exploring and -interpreting your results. Here are some examples, using goodness-of-fit -results from fitting a SAOM in `{RSiena}` and an ERGM in `{ergm}`. (Note -that neither the data nor the model are similar; this is just for -illustrative purposes.) +interpreting your results. + +Dispatching works because the results carry a class. `igraph::degree()` +and `sna::degree()` each return a bare numeric vector, so `plot()` falls +back to a scatterplot of the values against their index, and that index +is not meaningful. `netrics::node_by_degree()` returns a `node_measure`, +which `{autograph}` plots as a themed distribution: + +Example illustrating that plotting a bare vector of degree scores gives an index scatterplot, where plotting a node_measure gives a distribution -Goodness-of-fit plots for a SAOM fitted in RSiena and an ERGM fitted in ergmGoodness-of-fit plots for a SAOM fitted in RSiena and an ERGM fitted in ergm +The same holds for the other result classes. Here are some further +examples, using goodness-of-fit results from fitting a SAOM in +`{RSiena}` and an ERGM in `{ergm}`. (Note that neither the data nor the +model are similar; this is just for illustrative purposes.) + +Goodness-of-fit plots for a SAOM fitted in RSiena and an ERGM fitted in ergmGoodness-of-fit plots for a SAOM fitted in RSiena and an ERGM fitted in ergm ### Setting a theme @@ -187,11 +215,6 @@ plot(netrics::tie_by_betweenness(ison_karateka)))/ (plot(netrics::node_in_regular(ison_southern_women, "e")) + plot(as_matrix(ison_southern_women), membership = netrics::node_in_regular(ison_southern_women, "e"))) -``` - -Themed figures - -``` r stocnet_theme("ethz") (plot(netrics::node_by_degree(ison_karateka)) + plot(netrics::tie_by_betweenness(ison_karateka)))/ @@ -200,13 +223,95 @@ plot(as_matrix(ison_southern_women), membership = netrics::node_in_regular(ison_southern_women, "e"))) ``` -Themed figures +Themed figuresThemed figures There are a range of institutional and topical themes available, -including default, bw, crisp, neon, iheid, ethz, uzh, rug, unibe, oxf, -unige, cmu, iast, hwu, rainbow, with more on the way. +including default, bw, crisp, neon, clay, iheid, ethz, uzh, rug, unibe, +oxf, unige, cmu, iast, hwu, rainbow, with more on the way. + +Institutional themesInstitutional themes + +### Colours everyone can read + +About one man in twelve, and one woman in two hundred, sees colour +differently. A palette that separates its categories for most readers +can collapse for them, and the classic offender is the red-green pair +that so many palettes hold. + +`{autograph}` does something about this without asking you to give up a +palette. Every theme’s categorical palette is reordered when the theme +is set, so that the colours a graph reaches for first are those that +stay distinct under each type of colour blindness, and each divergent +palette pairs a warm pole with a cool one. + +`simulate_colorblind()` shows a set of colours as another viewer sees +them, so mapping the simulated colours back onto a graph shows you their +view of it. Here is the same network four times: in `{autograph}`’s +default palette as most readers see it, then as a reader with +deuteranopia does, then as a photocopier renders it, and then in the +palette `{ggraph}` falls back on when `{autograph}` is not setting the +colours, as that same reader with deuteranopia sees it. + +``` r +set_stocnet_theme("default") +as_seen <- function(colours, type, title){ + graphr(fict_lotr, node_colour = "Race", node_size = 3, labels = FALSE) + + ggplot2::scale_fill_manual(values = simulate_colorblind(colours, type)) + + ggtitle(title) +} +as_seen(ag_qualitative(6), "normal", "autograph") | + as_seen(ag_qualitative(6), "deutan", "autograph, deuteranopia") | + as_seen(ag_qualitative(6), "grey", "autograph, greyscale") | + as_seen(scales::hue_pal()(6), "deutan", "ggraph default, deuteranopia") +``` + +The same network seen with normal vision, with deuteranopia, and in greyscale, in autograph's palette, and with deuteranopia in ggraph's + +The six races remain tellable apart in the second panel, its closest +pair being Hobbits and Maiar. In the right-hand one, Elves and Ents have +become the same olive. The third panel is the harder case, and it is not +one reordering can fix: a greyscale device keeps only the luminance of a +colour, so two colours of the same lightness merge however different +their hues. `check_separation()` reports that view beside its own score; +where a figure has to print in black and white, use the `"bw"` theme or +add a second channel such as `node_shape`. `check_separation()` puts a +number on it, scoring how far apart colours are at their worst across +normal vision and each type of colour blindness: + +``` r +round(min(check_separation(ag_qualitative(6)), na.rm = TRUE), 1) # autograph +#> [1] 13.5 +round(min(check_separation(scales::hue_pal()(6)), na.rm = TRUE), 1) # ggraph +#> [1] 5.5 +round(min(check_separation(igraph::categorical_pal(6)), na.rm = TRUE), 1) # igraph +#> [1] 16.2 +``` -Institutional themesInstitutional themes +Below 10 two colours are easily confused, above 25 they are comfortably +distinct. `{igraph}`’s categorical palette is the Okabe-Ito scheme, +which was designed for this and scores accordingly: where you are free +to choose any colours at all, such a scheme is hard to beat, and +`graphr()` will happily take it. The harder case is the one +`{autograph}` is built for — colours chosen by somebody else, for +reasons that were not legibility — and there the ordering is what stands +between a brand palette and an unreadable graph. A palette with more +colours to draw on has more room to gain: six categories score 29 under +the `"hwu"` theme and 26 under `"oxf"`. + +Marks are only half of it. Text has to be read rather than told apart, +which is a matter of contrast rather than of hue, and `check_contrast()` +scores it against the thresholds of WCAG 2.1: 4.5 for body text, 3 for +large text and for graphical objects. Every theme’s ink clears 4.5 on +that theme’s own ground, and the test suite holds it there. + +Each theme's name written in that theme's ink on that theme's ground, annotated with its WCAG contrast ratio + +The medium is a separate question again. `stocnet_medium()` sizes the +text for where the figure will be seen — `"screen"`, `"presentation"`, +`"mobile"` — and `"print"` draws on white whatever ground the theme +prefers, since a tinted ground costs ink and is often not reproduced. +The theme is untouched by it, so one institutional palette carries from +the desk to the slide to the page. If your institution or organisation is not included and you would like it to be, please just raise an issue on Github, along with a link to diff --git a/cran-comments.md b/cran-comments.md index 590e5946..10a33d8a 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -8,3 +8,31 @@ ## R CMD check results 0 errors | 0 warnings | 0 notes + +## User filespace + +This version adds an optional `persist` argument to `stocnet_theme()`. When, and only when, a user +passes `persist = TRUE`, the chosen theme is written to `tools::R_user_dir("autograph", "config")`. +Nothing is written on load, on attach, or by any default code path, and the package is fully +functional if the directory is absent or unwritable. No other location is written to. + +## Backward/forward compatibility + +This version works and tests alongside both manynet 2.2.3 and 2.3.0. +manynet 2.3.0 ships several networks in a list-based class, +and spells a layer as the tie attribute "layer" rather than "type" and +a sign as a negative weight rather than as a "sign". +Which tie attribute records the layer is now read from the network, +so a multiplex network is still coloured by layer under either spelling. +Signs are read through `manynet::tie_signs()`, in `graphr()` and in `layout_valence()`, +rather than from a "sign" tie attribute. +Attribute names are read through `manynet::net_node_attributes()`/`net_tie_attributes()`, +which accept a network in either class. +`layout_concentric()`, `layout_multilevel()` and `layout_lineage()` coerce what they are given, +as the other layouts already did. +`grapht()` and `graphs()` fall back to `manynet::to_times()` where `to_waves()` +cannot split a network, which covers a panel recording its waves as "time" +(e.g. `ison_monks`) and a diffusion result. +Each guard tests for the function or attribute rather than for the manynet version, +so a development build is treated by what it offers. + diff --git a/data/goldfish_changepoints.rda b/data/goldfish_changepoints.rda index 4f807281..dbedbe9a 100644 Binary files a/data/goldfish_changepoints.rda and b/data/goldfish_changepoints.rda differ diff --git a/data/goldfish_fit.rda b/data/goldfish_fit.rda new file mode 100644 index 00000000..d184a2d0 Binary files /dev/null and b/data/goldfish_fit.rda differ diff --git a/data/goldfish_gof.rda b/data/goldfish_gof.rda new file mode 100644 index 00000000..5d0fd666 Binary files /dev/null and b/data/goldfish_gof.rda differ diff --git a/data/goldfish_margins.rda b/data/goldfish_margins.rda new file mode 100644 index 00000000..477151f9 Binary files /dev/null and b/data/goldfish_margins.rda differ diff --git a/data/goldfish_onset.rda b/data/goldfish_onset.rda new file mode 100644 index 00000000..edf75015 Binary files /dev/null and b/data/goldfish_onset.rda differ diff --git a/data/goldfish_outliers.rda b/data/goldfish_outliers.rda index 507e0cb1..11464d37 100644 Binary files a/data/goldfish_outliers.rda and b/data/goldfish_outliers.rda differ diff --git a/data/goldfish_time.rda b/data/goldfish_time.rda new file mode 100644 index 00000000..0b6fd220 Binary files /dev/null and b/data/goldfish_time.rda differ diff --git a/inst/tutorials/autograph1/visualisation.Rmd b/inst/tutorials/autograph1/visualisation.Rmd index 61e9ef87..37a67fa1 100644 --- a/inst/tutorials/autograph1/visualisation.Rmd +++ b/inst/tutorials/autograph1/visualisation.Rmd @@ -126,7 +126,21 @@ Remember the three flavours of bundled data as a rough difficulty ladder — **Real-world** (`irps_*`, larger & realistic) — and that you can browse the full list with `table_data()`. -gif of Bob Ross painting a happy little landscape +```{r data-flavours-Q, echo=FALSE, purl = FALSE} +question("Which prefix marks the larger, more realistic networks bundled with the stocnet packages?", + answer("irps_", + correct = TRUE, + message = "Right — the irps_ datasets are the real-world ones, so they are the most demanding to graph. No mistakes here, just happy little accidents. gif of Bob Ross painting a happy little landscape"), + answer("ison_", + message = "The ison_ datasets are the classics: small, tidy, and a good place to start."), + answer("fict_", + message = "The fict_ datasets are fictional networks, mid-sized and fun, but not the largest."), + answer("net_", + message = "There is no net_ prefix for data — net_* are measures of whole networks."), + random_answer_order = TRUE, + allow_retry = TRUE +) +``` ## Getting started @@ -270,7 +284,9 @@ graphr(fict_lotr) Note everything that happened without being asked: `graphr()` recognised that the network is `r gloss("labelled","label")` -and printed the node labels, +and printed node labels — but only for the most central characters, +since 36 labels at once would hide the network behind them +(the Labels section below shows how to choose differently), chose a deterministic layout (so you get the same picture every time), sized and spaced the labels to minimise overlap, and dropped the axes and grey background that mean nothing for networks. @@ -308,7 +324,8 @@ Click 'Next Topic' to continue. ::: {.callout} **In brief**: `graphr()` graphs any manynet-compatible network object with sensible defaults inferred from the data: -labels where the network is labelled, arrowheads where it is directed, +labels where the network is labelled (and, where it is large, +only for the nodes that stand out), arrowheads where it is directed, a deterministic layout, and no chart junk. It returns a `{ggplot2}` object, so anything you can do to a ggplot — adding layers, titles, scales with `+` — you can do to a graph. @@ -420,8 +437,6 @@ graphr(ison_southern_women) ### Colouring nodes {#colouring-nodes} -gif of an artist swirling paint colours together on a palette - Let's try instead colouring the nodes by this "Race" variable. It is very similar to the shape example above. **Can you complete the code yourself?** @@ -505,7 +520,7 @@ Who turns out to be the most connected character in the fellowship? question("Which aesthetic is generally most appropriate for a *continuous* node attribute, such as degree or age?", answer("Size", correct = TRUE, - message = "Yes — our eyes read graded sizes as graded quantities. Colour gradients can also work, but are harder to compare precisely."), + message = "Yes — our eyes read graded sizes as graded quantities. Colour gradients can also work, but are harder to compare precisely. gif of an artist swirling paint colours together on a palette"), answer("Shape", message = "Shapes are categorical: there is no natural ordering from circle to triangle to square."), answer("Group shading (node_group)", @@ -566,23 +581,70 @@ setting `edge_size` yourself resizes both together. ### Taming dense or disconnected networks {#taming-networks} -Two arguments help when a network is too dense, or too sparse, to read at a -glance. +Sometimes networks are just a dense hairball. +This is a technical term to describe networks with many high-degree nodes and many ties, +where the sheer number of ties obscures the structure of the network. +Autograph includes three arguments that can help with this. + +#### Bundling ties {#bundling} -Larger, denser networks can turn into a 'hairball', where the sheer number of -ties obscures everything. `edge_bundle` pulls ties that travel in similar -directions into shared paths — like cabling them together — so that the main -'highways' of the network stand out. It is off by default; set -`edge_bundle = TRUE` (or name a specific algorithm: `"force"`, `"path"`, or -`"minimal"`) to switch it on. **Compare a dense random network with and -without bundling.** +The first option is to draw all of the ties 'bundled' together, +which can reveal where the most common paths through the network are. +`edge_bundle` pulls ties that travel in similar +directions into shared paths — like cabling them together — +so that the main 'highways' of the network stand out. +It is off by default; set `edge_bundle = TRUE` +(or name a specific algorithm: `"force"`, `"path"`, or `"minimal"`) to switch it on. +**`ison_lawfirm` records 71 lawyers and 2571 +ties between them, which is about as thick a hairball as a network this small +can be. Compare it drawn with and without bundling (turn backbone off too for clearest comparison results).** ```{r bundle, exercise=TRUE, fig.width=9} -rand <- manynet::generate_random(40, 0.1) -(graphr(rand) + ggtitle("Unbundled") | - graphr(rand, edge_bundle = TRUE) + ggtitle("Bundled")) +graphr(ison_lawfirm, backbone = FALSE) + ggtitle("Unbundled") | + graphr(ison_lawfirm, backbone = FALSE, edge_bundle = "path") + ggtitle("Bundled") +``` + +I find this works best with networks that are at least moderately dense, +and sometimes requires a little bit of playing around to get a good result. + +#### Backbones {#backbone} + +By contrast, `r gloss("backbone")` changes which ties the picture is built around. +Ties that carry more weight/structure than expected by a null model local to their endpoints +are in essence what the network would be if it were stripped back to its skeleton. +`graphr()` then draws the layout according to this skeleton and +fades other ties into the background to further emphasise the main structure. + +Most of the time you will not have to ask for this. +Networks of 50+ nodes with 8 ties each on average is drawn this way by default. +But you can specify `backbone = FALSE` to turns it off, `backbone = TRUE` to force it on, +or you can name a filter — `"disparity"`, `"lans"`, `"noise"`, `"mlf"`, or `"simmelian"` — or threshold. +**Compare `ison_lawfirm` drawn with and without its backbone.** + +```{r backbone, exercise=TRUE, fig.width=9} +(graphr(ison_lawfirm, node_colour = "office", backbone = FALSE) + + ggtitle("Every tie alike") | + graphr(ison_lawfirm, node_colour = "office", backbone = TRUE) + + ggtitle("Backbone")) ``` +The offices are hardly visible on the left. On the right they separate, because +the ties that hold each office together are the ties the filter keeps. + +Only the layouts that read tie lengths are laid out this way: `"stress"` (the +default), `"fr"`, `"drl"` and `"kk"`. Every other layout, including those whose +coordinates already mean something such as `"layered"` or `"scaling"`, keeps +its coordinates and only fades its ties. Signed networks have no backbone, +since these null models have no place for a negative weight, and are drawn as +they were. + +Bundling and backbones answer the same problem from different ends, so try one +before reaching for both. A bundled tie cannot carry a fading of its own — +bundling merges ties into shared paths — so where both are asked for, the +backbone still shapes the layout but every tie is drawn alike. + +#### Isolates {#isolates} + At the other extreme, many networks contain `r gloss("isolates","isolate")` — unconnected nodes — which, under a force-directed layout, drift to the margins and squeeze the connected core into a clump. The `isolates` argument decides @@ -598,10 +660,11 @@ lotr_iso <- fict_lotr |> graphr(lotr_iso, isolates = "legend") + ggtitle("legend")) ``` -For very large real-world networks such as `irps_blogs`, the two work well -together: `edge_bundle = TRUE` untangles the connected core while -`isolates = "legend"` keeps its several hundred unconnected blogs from -crowding that core out. +For very large real-world networks such as `irps_blogs`, these work well +together: a backbone picks out the ties that hold the connected core together +(or `edge_bundle = TRUE`, if you would rather see the paths the ties take than +which of them matter most), while `isolates = "legend"` keeps its several +hundred unconnected blogs from crowding that core out. ### Free play {#illustrating-free-play} @@ -627,7 +690,7 @@ for nodes, `edge_colour` and `edge_size` for ties. Use colour or shape for categorical attributes (colour scales better), size for continuous ones, and `node_group` to shade spatially clustered memberships. -For dense or disconnected networks, `edge_bundle` and `isolates` +For dense or disconnected networks, `edge_bundle`, `backbone` and `isolates` (see _Taming dense or disconnected networks_ above) keep the picture legible. ::: @@ -636,8 +699,10 @@ For dense or disconnected networks, `edge_bundle` and `isolates` On this page: Setting a theme · Hues · +Colour blindness · Greyscale · -Manual override +Manual override · +Medium ### Setting a theme {#setting-a-theme} @@ -664,13 +729,45 @@ Currently available themes include a number of institutional themes (`"iheid"`, `"ethz"`, `"uzh"`, `"rug"`, `"unibe"`, `"oxf"`, `"unige"`, `"cmu"`, `"iast"`, `"hwu"`) as well as stylistic ones (`"default"`, `"bw"`, `"crisp"`, `"neon"`, -`"rainbow"`). +`"clay"`, `"rainbow"`). Run `stocnet_theme()` without arguments to see which theme is currently set. More institutional scales and themes can be implemented upon pull request. -### Who's hue? {#whos-hue} +A theme lasts for the session in which you set it, +and a new session starts on the default again. +Where a theme is your usual one, `persist = TRUE` remembers it, +by writing the name to your user configuration directory: + +```{r persist, exercise=TRUE} +# stocnet_theme("iheid", persist = TRUE) # remembered next session too +stocnet_theme() +``` -gif from The Devil Wears Prada: that is not just blue, that is cerulean +Nothing is written to disk unless you ask for it. +Setting any theme with `persist = FALSE`, the default, +forgets a choice you persisted earlier, +so `stocnet_theme("default", persist = FALSE)` puts you back where you began. + +A theme sets a typeface as well as a palette, +but only where that typeface is installed and R can see it. +`list_fonts()` lists the families R can see, +and `ag_font()` reports the one the current theme settled on. + +```{r fonts, exercise=TRUE} +ag_font() +head(list_fonts("sans")) +``` + +If `ag_font()` returns `"sans"`, +the theme found none of the fonts it prefers, +and your graphs will look more generic than they should. +Install the missing family — many are free from +[Google Fonts](https://fonts.google.com) — +then install the `{systemfonts}` package so that R can see the fonts on your +system, and set the theme again. +`?stocnet_theme` sets out the steps for each operating system. + +### Who's hue? {#whos-hue} By default, `graphr()` will use a colour palette that offers fairly good contrast and better accessibility. @@ -698,7 +795,7 @@ graphr(fict_lotr, question("Why does changing node colours use scale_fill_*() functions rather than scale_color_*()?", answer("Because nodes are drawn as filled shapes, so their interior colour is the 'fill' aesthetic", correct = TRUE, - message = "Correct, 'color' in ggplot2 refers to outlines and lines, while the interior of a filled shape is its 'fill'."), + message = "Correct, 'color' in ggplot2 refers to outlines and lines, while the interior of a filled shape is its 'fill'. That is not just blue, it is cerulean. gif from The Devil Wears Prada: that is not just blue, that is cerulean"), answer("Because scale_color_*() functions do not exist in ggplot2", message = "They do exist — they control the colour aesthetic, used e.g. for lines and outlines."), answer("It is an arbitrary choice and either would work", @@ -719,11 +816,103 @@ The old trope is that males are less sensitive to colour distinctions:^[Though s comic strip about perceived colour vocabulary differences +### Seeing what others see {#seeing-what-others-see} + +About one man in twelve, and one woman in two hundred, +sees colour differently from the palette designer. +The most common form, deuteranopia, confuses reds with greens — +which is precisely the pairing a "stop/go" palette relies on. + +`{autograph}` gives you two functions for checking this. +`simulate_colorblind()` shows you a set of colours as such a viewer sees them, +and `check_separation()` scores how far apart colours are, +taking the worst case across normal vision and each type of colour blindness. +A score below 10 means two colours are easily confused, +10 to 25 that they are separable but close, +and above 25 that they are comfortably distinct. + +```{r cvdcheck, exercise=TRUE} +# A red and a green that look quite different to most viewers +check_separation(c("#B7352D", "#627313")) +# But not to everyone +simulate_colorblind(c("#B7352D", "#627313"), "deutan") +``` + +**Run the code, then try `"protan"` or `"tritan"` instead of `"deutan"`.** + +How far the simulation goes is set by `severity`. +Full severity, the default, is dichromacy: +deuteranopia, protanopia, tritanopia. +A lower severity is anomalous trichromacy — +deuteranomaly, protanomaly — which is the more common condition, +and which the paragraph above named without being able to show you. + +```{r cvdseverity, exercise=TRUE} +simulate_colorblind(c("#B7352D", "#627313"), "deutan", severity = 1) +simulate_colorblind(c("#B7352D", "#627313"), "deutan", severity = 0.4) +``` + +You can also look at a whole graph the way another viewer would, +by mapping the simulated colours back onto it. + +```{r cvdgraph, exercise=TRUE, fig.width=9} +graphr(fict_lotr, node_colour = "Race") +graphr(fict_lotr, node_colour = "Race") + + ggplot2::scale_fill_manual(values = simulate_colorblind(ag_qualitative(6), "deutan")) +``` + +Much of this work is already done for you. +Each theme's palette is reordered when the theme is set, +so that the colours a graph uses first are the ones that stay distinct +for every viewer, +and each divergent palette pairs a warm pole with a cool one +rather than a red with a green. + +```{r cvdpalette, exercise=TRUE} +stocnet_theme("iheid") +round(check_separation(ag_qualitative(4))) +# The closest pair among those four colours +min(check_separation(ag_qualitative(4)), na.rm = TRUE) +stocnet_theme("default") +``` + +::: {.callout} +**Going further**: +The `"rainbow"` theme is the exception, and is left in the order of the +spectrum, since that fidelity is its point. +A spectrum is not a colour-blind safe scheme: +its reds and greens are the pair that red-green colour blindness cannot +separate. +Choose it where the order of your categories is itself meaningful, +and check the result with `check_separation()`. +Where you need particular colours in an institutional palette, +`match_color()` finds the closest the palette has to those you ask for. +::: + ### Greyscale {#greyscale} Other times colour may not be desired. -Some publications require greyscale images. -To use a greyscale colour palette, +Some publications require greyscale images, +and a figure may be photocopied whether or not you meant it to be. +A greyscale device keeps the luminance of a colour and throws the rest away, +so two colours of the same lightness merge, however different their hues. +This is why ColorBrewer marks a palette print-safe and photocopy-safe +separately from marking it colour-blind safe: +they are different questions, and a palette can pass one and fail the other. + +`simulate_colorblind()` answers the second with `type = "grey"`, +and `check_separation()` reports the greyscale distances beside its own score. + +```{r greysim, exercise=TRUE} +check_separation(ag_qualitative(4)) +``` + +The matrix is what every viewer can see. +The line beneath it is what survives a photocopier. +Most institutional palettes separate their categories by hue, +so most of them collapse in greyscale. + +To draw in greyscale from the start, replace `_hue` from above with `_grey` (note the 'e' spelling): ```{r greyscale, exercise=TRUE, fig.width=9} @@ -737,6 +926,8 @@ or for very few discrete categories than for the six categories used here. If you need to distinguish several categories in print, consider combining greyscale with `node_shape`, or use the `"bw"` theme, which is designed for this purpose. +`stocnet_medium("print")` is the companion to this; +see _Where will it be seen?_ below. ### Manual override {#manual-override} @@ -759,14 +950,65 @@ graphr(fict_lotr, labs(fill = "Colour") ``` +### Where will it be seen? {#where-will-it-be-seen} + +A theme says how a plot should look. +Where it will be seen is a separate question, +and the answer changes more often than the theme does. +The same institutional theme has to serve a figure worked on at a desk, +projected in a lecture theatre, printed in an article, +and read on a phone in a narrow column. +Each of those wants a different size of text, +and one of them wants a different background. + +`stocnet_medium()` sets this, and leaves the theme alone. + +```{r medium, exercise=TRUE, fig.width=9} +stocnet_medium() +stocnet_medium("presentation") +graphr(fict_lotr, node_colour = "Race") +stocnet_medium("screen") +``` + +The media are `"screen"` (the default), `"presentation"`, `"mobile"`, +and `"print"`. +The first three differ in the size of their text; +`ag_size()` reports the multiplier in force. +`"print"` leaves the text alone and draws on white, +whatever ground the theme prefers, +since a dark or tinted ground costs ink and is often not reproduced. +As with `stocnet_theme()`, `persist = TRUE` remembers your choice. + +The medium scales text, not marks. +A node's size is relative to the layout it sits in, +so enlarging the nodes without enlarging the layout would only crowd it. +Use `node_size` in `graphr()` where a figure needs larger nodes too. + +Nor does the medium set the size of the file you write. +Give `ggsave()` the width, height, and resolution to match; +see _Exporting plots_ below. + +::: {.callout} +**Going further**: +A small figure limits how much it can carry, not just how large the type is. +Keep a legend to about seven keys, and `graphs()` to about three panels. +`graphr()` says so when a colour or shape legend grows past that, +because past it a reader stops matching keys to marks and starts guessing. +Splitting one crowded figure into two that each make a single point +is almost always better than shrinking the type until it fits. +::: + ::: {.callout} **In brief**: `stocnet_theme()` sets a theme once for all subsequent -graphs and plots, with institutional and stylistic palettes included. +graphs and plots, with institutional and stylistic palettes included, +and `persist = TRUE` keeps it for future sessions. Individual graphs can still be adjusted by appending `ggplot2::scale_fill_*()` functions — `_hue()` for a different palette, `_grey()` for print, `_manual()` for hand-picked colours — -and it is worth checking your palette is colour-blind accessible. +and `simulate_colorblind()`, `check_separation()` and `check_contrast()` check +that your palette works for colour-blind viewers, in greyscale, and as text. +`stocnet_medium()` then sizes the result for where it will be seen. ::: ## Titles, labels, and legends @@ -784,8 +1026,8 @@ In this section, we will learn how to add titles, labels, and legends to graphs. ### Labels {#labels} With our `fict_lotr` example above, because the network is itself labelled, -`graphr()` automatically adds the node labels. -If you do not want these labels, you can remove them from the network before +`graphr()` adds node labels. +If you do not want any labels, you can remove the names from the network before passing it on to `graphr()`, or more simply use the argument `labels = FALSE`. ```{r nodelab, exercise=TRUE, fig.width=9} @@ -797,6 +1039,46 @@ interpret, though we lose the information about which node is which character. Which you prefer depends on what the graph is _for_: exploring who-is-who, or communicating overall structure. +But this is not really a choice between all and nothing. +`fict_lotr` has 36 nodes, and 36 labels would cover the very network they +describe, so `graphr()` labelled only the handful of most central characters +and told you so. +**Ask for all of them with `labels = TRUE` and compare.** + +```{r nodelaball, exercise=TRUE, fig.width=9} +graphr(fict_lotr, labels = TRUE) +``` + +You can decide how many to label by passing a number. +This is a depth of _ranks_ rather than a count of nodes, +so characters tied at the cut are labelled together — +ask for the top three and you may get four names. + +```{r nodelabn, exercise=TRUE, fig.width=9} +graphr(fict_lotr, labels = 3) +``` + +`r gloss("Degree","degree")` is only one reason a node might be worth naming. +Passing the name of a measure labels whichever node or nodes it singles out: +`"betweenness"` for the characters who sit between others, +`"cutpoints"` for those holding the network together, +or `"random"` for a small unbiased sample. + +```{r nodelabmeasure, exercise=TRUE, fig.width=9} +graphr(fict_lotr, labels = "betweenness") +``` + +To combine the two, name the number: `labels = c(betweenness = 5)`. +And when you know exactly who matters to your argument, +you can just say so — by name, or with any logical vector of the nodes. + +```{r nodelabwho, exercise=TRUE, fig.width=9} +graphr(fict_lotr, labels = c("Frodo", "Gandalf")) + + ggtitle("Named outright") | + graphr(fict_lotr, labels = node_is_cutpoint(fict_lotr)) + + ggtitle("Every cutpoint") +``` + ::: {.callout} **Going further**: By default `graphr()` repels labels away from each other and from nodes @@ -804,8 +1086,9 @@ so that they do not overlap. Two further arguments offer finer control: `label_repel = FALSE` places labels at a fixed offset instead, and `label_dist` controls how far labels sit from their nodes (in points). -For crowded graphs, also consider labelling only some nodes, -e.g. `mutate(name = ifelse(node_is_max(node_by_deg(.)), name, ""))`. +On a `r gloss("two-mode","twomode")` or multilevel network, a selection is ranked +within each mode or level, so that a dense level cannot crowd the others +out of the labelling. ::: ### Titles {#titles} @@ -840,6 +1123,15 @@ for _x_ and _y_ axes, and legends (see below). ### Legends {#legends} +A legend asks a reader to hold a colour in mind while they hunt for it in the +graph, and people are poor at that: +colour is not recalled reliably, even over a couple of seconds. +Labelling nodes directly asks less of them, +which is why `graphr()` labels nodes where it can, +and why, above thirty nodes, it labels the most central ones +rather than none at all (see _Labels_ above). +Keep a legend for what cannot be written onto the graph itself, and keep it short. + While `{autograph}` attempts to provide legends where necessary, in some cases the legends offer insufficient detail, or are absent, such as in the following figure, @@ -877,7 +1169,8 @@ or removed using "none". ::: {.callout} **In brief**: `labs()` adds titles, subtitles, and legend titles; `guides()` forces or removes legends; -`labels = FALSE` hides node labels, +`labels` chooses which nodes to name — all of them, none, +the top few by a measure, or the ones you name yourself — and `label_repel`/`label_dist` fine-tune their placement. A graph that leaves your hands should be readable without you standing next to it explaining. @@ -927,8 +1220,6 @@ In the following sections, we review some of the most common types of layouts. ### Force-directed layouts {#force-directed-layouts} -gif of yoda moving things with the force - Force-directed layouts update some initial placement of vertices through the operation of some system of metaphorically-physical forces. These might include attractive and repulsive forces. @@ -962,7 +1253,7 @@ on the same network. question("Can we interpret the distance between two nodes in a force-directed layout as a precise measure of how closely they are related?", answer("No", correct = TRUE, - message = "That's right — force-directed layouts are illustrative. Nearby nodes are often closely connected, but distances are a by-product of the algorithm, not a measurement to cite."), + message = "That's right — force-directed layouts are illustrative. Nearby nodes are often closely connected, but distances are a by-product of the algorithm, not a measurement to cite. The force moves the nodes, but it does not measure them. gif of yoda moving things with the force"), answer("Yes", message = "Careful — two nodes can end up near each other simply because the algorithm ran out of better places to put them. Use spectral or MDS layouts if you need interpretable distances. No mistakes here though, just a happy little accident. gif of Bob Ross smiling in front of a painting"), allow_retry = TRUE @@ -978,37 +1269,116 @@ Other force-directed layouts available include: ### Layered layouts {#layered-layouts} -Layered layouts arrange nodes into horizontal (or vertical) layers, +Layered layouts arrange nodes into layers, positioning them so that they reduce crossings. These layouts are best suited for directed acyclic graphs, two-mode networks, -or other data with a natural hierarchy or ordering. +or other data with a natural ordering. + +`{autograph}` offers four, and they are one layout drawn four ways. +Two things vary: which axis the layers run along, and whether the nodes +line up across them. The names say which is which — a railway lies flat, +a ladder stands up: + +| | Layers stacked flat | Layers standing up | +|--------------------------|---------------------|--------------------| +| Nodes spaced by their ties | `"layered"` | `"lineage"` | +| Nodes lined up across layers | `"railway"` | `"ladder"` | ```{r bipartite, exercise=TRUE, fig.width=9} graphr(ison_southern_women, layout = "bipartite") + ggtitle("Bipartite") -graphr(ison_southern_women, layout = "hierarchy") + ggtitle("Hierarchy") +graphr(ison_southern_women, layout = "layered") + ggtitle("Layered") graphr(ison_southern_women, layout = "railway") + ggtitle("Railway") ``` -Note that `"hierarchy"` and `"railway"` use a different algorithm to +Note that `"layered"` and `"railway"` use a different algorithm to `{igraph}`'s `"bipartite"`, and generally perform better, especially where there are multiple layers. -Whereas `"hierarchy"` tries to position nodes to minimise overlaps, +Whereas `"layered"` tries to position nodes to minimise overlaps, `"railway"` sequences the nodes in each layer to a grid so that nodes are matched as far as possible. -For the `"hierarchy"` layout you can also steer which set sits where by +For the `"layered"` layout you can also steer which set sits where by passing a `center` argument — `"events"` or `"actors"` for a two-mode network, or the name of a particular node — which helps when the default places the less interesting set on top. -```{r hierarchy-center, exercise=TRUE, fig.width=9} -graphr(ison_southern_women, layout = "hierarchy", center = "events") +```{r layered-center, exercise=TRUE, fig.width=9} +graphr(ison_southern_women, layout = "layered", center = "events") ``` If you want to flip the horizontal and vertical, -you could flip the coordinates, or use something like the following layout. +you could flip the coordinates, or use `"lineage"`, +which is the same layout with the axes exchanged. -```{r alluvial, exercise=TRUE, fig.align='center'} -graphr(ison_southern_women, layout = "alluvial") + ggtitle("Alluvial") +```{r lineage, exercise=TRUE, fig.align='center'} +graphr(ison_southern_women, layout = "lineage") + ggtitle("Lineage") +``` + +These layouts serve both multimodal and directed acyclic networks. +A genealogical network offers the clearest case: +every tie points from an earlier generation to a later one. +Where a force-directed layout obscures this ordering, +`graphr()` uses the `"layered"` layout to make it clear. +**Draw the parent ties among the characters of Westeros.** + +```{r thrones-default, exercise=TRUE, fig.width=9, fig.height=6} +thrones <- to_uniplex(fict_thrones, "parent") +graphr(thrones) +``` + +This layout tries to minimise two costs. +The first is which layer each node goes in. Ranking each node +by its distance from a root sounds right — a row is then a generation — but it +pins a parent whose only child is born several generations later to the top +row, and manufactures a long tie to reach them. +The `ranks` argument chooses the rule, +and `check_span()` reports how many rows each tie crosses, +so you can measure the difference. + +```{r thrones-ranks, exercise=TRUE} +thrones <- to_uniplex(fict_thrones, "parent") +spans <- sapply(c("generation", "compact", "tight"), function(r) { + span <- check_span(graphr(thrones, ranks = r)) + c(total = attr(span, "total"), `over one row` = mean(span > 1), max = max(span)) +}) +round(t(spans), 3) +``` + +`"generation"` is the distance-from-a-root rule and +`"compact"` is the one `{igraph}` uses in its Sugiyama layout. +`"tight"`, the default, minimises total tie length while +still pointing every tie down at least one row. +Note that the longest tie is the same under all three. + +The second cost is where each node sits within its row. +`check_offset()` reports how far each tie travels sideways, +as a share of the width of the drawing, +so a tie that drops straight down scores zero. +Again, you are wanting to minimise this, +and the `alignment` argument chooses the rule. +**Compare the two alignments.** + +```{r thrones-alignment, exercise=TRUE} +thrones <- to_uniplex(fict_thrones, "parent") +c(straight = attr(check_offset(graphr(thrones)), "mean"), + rungs = attr(check_offset(graphr(thrones, alignment = "rungs")), "mean")) +``` + +`alignment = "rungs"` gives every row the same spacing, +which is what `"railway"` and `"ladder"` are for. +The default, `"straight"`, pulls each node towards its parents and children instead, +which is what makes the families read as families. + +`ranks` also accepts a node attribute, instead of one of those three rules. +Then the layers are that attribute's values, and nodes are placed along the +axis in proportion to them rather than at even steps, +so a network of dated nodes is drawn as a timeline. +**Rank the adolescents by a year of your choosing.** + +```{r lineage-ranks, exercise=TRUE, fig.align='center'} +ison_adolescents |> as_stocnet() |> + mutate_nodes(year = rep(c(1985, 1990, 1995, 2000), times = 2), + label = paste0(label, " (", year, ")")) |> + graphr(layout = "lineage", ranks = "year") ``` Other layered layouts include: @@ -1046,39 +1416,280 @@ Other such layouts include: Spectral layouts arrange nodes according to the eigenvalues of the Laplacian matrix of a graph. -These layouts tend to exaggerate the clustering of like-nodes and the -separation of less similar nodes in two-dimensional space. +These layouts exaggerate the clustering of similarly located nodes and +separate less similar nodes in two-dimensional space. ```{r eigen, exercise=TRUE, fig.align='center'} graphr(ison_southern_women, layout = "eigen") + ggtitle("Eigenvector") ``` -Somewhat similar are multidimensional scaling (MDS) techniques, +#### Multidimensional scaling {#scaling} + +Of similar purpose are multidimensional scaling (MDS) techniques, which visualise the similarity between nodes in terms of their proximity in a two-dimensional (or more) space. +The `"scaling"` layout places the nodes so that the distance drawn between them +stands for the number of steps between them in the network. -```{r mds, exercise=TRUE, fig.align='center'} -graphr(ison_southern_women, layout = "mds") + ggtitle("Multidimensional Scaling") +```{r scaling, exercise=TRUE, fig.align='center'} +graphr(ison_southern_women, layout = "scaling") + ggtitle("Multidimensional Scaling") ``` -Other such layouts include: +Note that this layout is drawn with the axes labelled, +whereas you may have noticed that the other graphs are not. +That is because here the coordinates can be read: +two nodes drawn twice as far apart are, more or less, twice as far apart. +The axes are drawn on one scale for the same reason. +The layout scales the whole network where it is small enough for that, +using `"mds"` from `{igraph}`, +and otherwise approximates the scaling from a sample of the nodes +using `"pmds"` (or pivot MDS) from `{graphlayouts}`. +You can still call each of these directly, but since they are both used in `"scaling"`, +dispatch can be automatic, based on the size and structure of the network. + +"More or less" is doing some work in that sentence. +A network usually has more structure than two dimensions alone can hold, +so some of the distances drawn won't capture the real distances in the network. +In some cases, the dimensionality is so high that the drawing is misleading. +We can check how much disagreement there is between scaled distances and +the network distances as a *stress* score. +This is printed as a caption under the plot as a percentage of the network distances, +such that zero would represent a perfect drawing. + +How low is low? Kruskal ([1964](https://doi.org/10.1007/BF02289565)), +who introduced the score, recommends 20% as poor, 10% as fair, 5% as good, +and 2.5% as excellent. +Those figures were established for psychometric data though. +Networks typically contain a lot more structure, +which is hard to capture in just two dimensions, +so a 20% threshold is often too demanding. + +For networks, a score near 30% is quite common, +and means the clustering can be interpreted though perhaps the distances should not be interpreted as exact. +Above 40% and the plot does not really show any interpretable structure; +`graphr()` will alert you in the console where the score is above 30%. +By contrast, a stress score near 5% is rare and worth trusting. + +Note that this stress score is not only for this layout. +`check_stress()` measures any drawing the same way, +so layouts can be compared on the same network +(Brandes and Pich [2007](https://doi.org/10.1007/978-3-540-70904-6_6)): + +```{r checkstress, exercise=TRUE, fig.align='center'} +sapply(c("scaling", "stress", "fr", "circle"), + function(x) check_stress(graphr(ison_southern_women, layout = x))) +``` -- Pivot multidimensional scaling: `"pmds"` +The default `"stress"` layout scores a little better here, +which is no accident: it minimises a related criterion directly. +What `"scaling"` adds is the axes and the score, +so that the distances can be read and the reading can be checked. + +In addition to stress, the scaling layout also reports +how much of the variance in the network's distances the two dimensions drawn hold. +The two numbers answer different questions, +and the comparison above shows how. +Stress belongs to the drawing: +draw this one network four ways and you get four different scores. +The variance explained belongs to the network: +it is the same 31% whichever of the four you draw, +because it asks how much of the structure two dimensions could hold at all. + +So read them together. +A low variance explained sets a floor that no layout gets under. +Where two dimensions can hold only a third of the structure, +no arrangement of the nodes will draw the distances faithfully, +and stress tells you how close to that floor this particular drawing gets. ```{r spectralinterp-Q, echo=FALSE, purl = FALSE} question("Can we interpret the distance between nodes in spectral and MDS layouts?", answer("Yes", correct = TRUE, - message = "That's right — in these layouts proximity reflects measured (dis)similarity, though it is not always easy to do..."), + message = "That's right — in these layouts proximity reflects measured (dis)similarity, though how far to trust it is another question. The stress score reported under a \"scaling\" layout is what answers that one."), answer("No", message = "Unlike force-directed layouts, spectral and MDS layouts place nodes according to calculated similarities, so distances do carry meaning here."), allow_retry = TRUE ) ``` -### Grid layouts {#grid-layouts} +```{r stressvariance-Q, echo=FALSE, purl = FALSE} +question("A `\"scaling\"` layout reports two numbers: a stress score and a share of the distance variance. One of them would be the same for any other layout of the same network. Which one?", + answer("The variance explained", + correct = TRUE, + message = "That's right — it asks how much of this network's structure two dimensions could hold at all, which no choice of layout changes."), + answer("The stress", + message = "Stress scores the drawing rather than the network, so it does change: `check_stress()` reports 31% for `\"scaling\"` and 52% for `\"circle\"` on `ison_southern_women`."), + answer("Both of them, since both describe the network", + message = "Only the variance explained describes the network. Stress measures how far one particular drawing gets the distances wrong, so redrawing the network changes it."), + answer("Neither of them, since both describe the drawing", + message = "Only stress describes the drawing. The variance explained is read from the network's distances, before any nodes are placed."), + allow_retry = TRUE +) +``` + +#### Correspondence analysis {#correspondence} + +Whereas scaling lays out nodes by their distances from each other, +correspondence analysis (CA) lays them out by the similarity of their ties. +This is useful where nodes may not be tied to each other at all, +but can be tied to the same others, such as in a two-mode network. +Correspondence analysis takes a rectangular table --- +here the incidence matrix of the Southern Women dataset, +one row for each woman and one column for each event --- +and places its rows and its columns in one space. + +```{r correspondence, exercise=TRUE, fig.align='center'} +graphr(ison_southern_women, layout = "correspondence") + ggtitle("Correspondence Analysis") +``` + +We can see the similarity to the eigenvector layout above, +but the axes are labelled with the share of the network's `r gloss("inertia")` they hold. +Inertia is the CA analogue of variance in PCA. +It measures the total dispersion of points (rows and columns) in the cloud around the centroid, +computed as the chi-square statistic of the table divided by the total sample size (N). +In other words, inertia tell us how far the ties depart from what one would expect +if every woman attended events in the same proportion as every other. +A network whose nodes all had much the same ties would have almost none. + +Each dimension extracted captures a share of this total inertia. +Because it is a share of variance explained, +and not a measure of fit like regression's R-squared, +the scores depend on the number of dimensions. +`ison_southern_women` has 12 dimensions, +and a total inertia of `r round(attr(layout_correspondence(ison_southern_women), "fit")$total, 2)`. +The top two dimensions (in terms of variance explained) together account for 57% of this total inertia. + +Is this good? I.e. is this a presentation of the data that is worth interpreting? +Well, if the inertia were spread evenly across these 12 dimensions, +(any) 2 dimensions would jointly account for about 17% of the variance. +57% is about 3.4 times better than this. +But this flatters because inertia is never spread evenly (Jackson [1993](https://doi.org/10.2307/1939574)). +The *broken stick* model offers a more demanding baseline, +asking what two dimensions would hold if the inertia were divided randomly rather than evenly (here 1.3 times better): + +```{r inertiacompare, exercise=FALSE, fig.align='center'} +bstick <- function(K) sum(sapply(1:2, function(k) mean(1 / (k:K)))) +sapply(c("ison_southern_women", "ison_adolescents", "ison_networkers"), + function(x) { + fit <- attr(layout_correspondence(get(x)), "fit") + K <- length(fit$scree) + c(dimensions = K, + inertia_drawn = round(sum(fit$inertia), 2), + vs_even = round(sum(fit$inertia) / (2 / K), 1), + vs_random = round(sum(fit$inertia) / bstick(K), 1)) + }) +``` + +`ison_adolescents` looks the best summarised by two dimensions of three datasets considered at 60%. +However, it is a small network with only seven dimensions to spread across, +so two of them were always going to hold a good deal. +Against the harder baseline it scores below 1, +which is to say two dimensions hold *less* than dividing the inertia +at random would have given them. +By comparison, `ison_networkers` looks the worst at 36% and yet summarises best: +it has 31 dimensions, and the top two beat either baseline. +Note that these scores are not verdicts, +but help gauge whether the two dimensions presented are worth interpreting further. +`graphr()` applies the stricter of the two baselines for you, +noting at the console where two dimensions hold no more inertia +than a random division would have given them. + +Since the two dimensions have different percentages here, +we can see where we should put the emphasis of our interpretation. +Because the first dimension holds twice as much, +it suggests that what distinguishes nodes most runs along the x-axis rather than the y-axis. + +Two more things to note about correspondence analysis. +First, while the distances among nodes of the same mode are interpretable, +distances between nodes from different modes are not necessarily interpretable. +That is, a woman drawn near an event is **not** necessarily an attendee of it. +Only the distances *within* a mode can be read this way: +two women drawn together attended similar events, +and two events drawn together were attended by similar women. +These plots are often misread this way. + +Second, some nodes are better represented by the top two dimensions than others. +A plot can hold most of the network's inertia +and still put one particular node nowhere near where it belongs. +This representation is captured by a measure called `r gloss("cos2")`: +how much of its position the two dimensions drawn actually hold, from 0 to 1, +where lower is worse. +A node the plane captures badly may be located near the centre of the plot, +not because it is average, but because there is nowhere else to put it. +`graphr()` names these nodes in the console when it draws the layout, +but you can recover the scores like so: + +```{r cos2, exercise=TRUE, fig.align='center'} +fit <- attr(layout_correspondence(ison_southern_women), "fit") +round(sort(fit$cos2), 2) +``` + +For a directed network, each node has two profiles: +who it sends ties to, and who it receives them from. +By default the layout reads a tie in either direction, +so that each node has one position; +`direction = "out"` and `direction = "in"` read one profile or the other. +For a signed network there is no correspondence analysis at all, +since the method divides by the mass of each node +and a negative tie has no such reading. +`double = TRUE` splits each tie into a positive and a negative part, +so that a node is placed by both who it likes and who it dislikes. + +```{r corresp-Q, echo=FALSE, purl = FALSE} +question("In a `\"correspondence\"` layout of `ison_southern_women`, Helen is drawn closer to event E9 than to any other event. What does that tell us?", + answer("Less than it appears: only distances within a mode can be read", + correct = TRUE, + message = "That's right — a row point near a column point is not a claim about the two of them. Helen did not attend E9 at all. Compare women with women, and events with events."), + answer("That Helen attended E9", + message = "Not necessarily. The two modes share a pair of axes, but the distance between a woman and an event is not a distance you can read. Compare women with women instead."), + answer("That Helen was the only woman not to attend E9", + message = "The plot says nothing of the kind. A distance between the two modes carries no reading at all; only distances within a mode do."), + allow_retry = TRUE +) +``` + +```{r inertia-Q, echo=FALSE, purl = FALSE} +question("Two `\"correspondence\"` plots: one holds 60% of its network's inertia in the two dimensions drawn, the other 36%. Which is the better two-dimensional summary?", + answer("It depends how many dimensions each network had to begin with", + correct = TRUE, + message = "That's right — 60% of seven dimensions is less than dividing the inertia at random would have given, while 36% of thirty-one beats every baseline. Compare each share against its own, not against 100%."), + answer("The one holding 60%", + message = "Not necessarily. A share of inertia is measured against however many dimensions the table has. A small network has few, so two of them will hold a good deal whatever its structure."), + answer("The one holding 36%, since a lower share is harder to achieve", + message = "Closer, but for the wrong reason — a lower share is not a virtue in itself. What matters is the share compared against what an even spread across the available dimensions would give."), + answer("Neither, since inertia cannot be compared across networks", + message = "The raw shares cannot, which is the point. But dividing each by its own even-spread baseline does give you a comparison."), + allow_retry = TRUE +) +``` + +```{r benzecri-Q, echo=FALSE, purl = FALSE} +question("Should the inertia percentages a `\"correspondence\"` layout reports be adjusted by the Benzécri correction?", + answer("No — that correction is for multiple correspondence analysis", + correct = TRUE, + message = "That's right. An indicator matrix invents dimensions that deflate every percentage, which is what Benzécri (and Greenacre's adjusted version) put back. A single two-way table invents nothing, so these percentages are already exact."), + answer("Yes, correspondence analysis always understates its percentages", + message = "Only multiple correspondence analysis does, and only because of the indicator matrix it is run on. This layout analyses a single two-way table, where the percentages are exact."), + answer("Yes, but only for two-mode networks", + message = "The number of modes has nothing to do with it. What would call for a correction is an indicator or Burt matrix, which this layout never builds."), + allow_retry = TRUE +) +``` + +```{r cos2-Q, echo=FALSE, purl = FALSE} +question("A node in a `\"correspondence\"` layout is drawn near the origin. What are the two things that could mean?", + answer("Its ties are close to average, or the two dimensions hold it badly", + correct = TRUE, + message = "That's right — and the cos2 is what tells the two apart. A low cos2 means the node sits somewhere this plane cannot show."), + answer("It has few ties, or it has many", + message = "Correspondence analysis divides each node's ties by how many it has, so how many a node has is not what places it. Look at the cos2 instead."), + answer("Only that its ties are close to average", + message = "That is one of the two. The other is that the two dimensions drawn hold the node badly, so the origin is simply where it lands. The cos2 separates the cases."), + allow_retry = TRUE +) +``` -gif of a cartoon character energetically rearranging the living room furniture +### Grid layouts {#grid-layouts} Grid layouts arrange nodes based on some Cartesian coordinates. These can be useful for making sure all nodes' labels are visible, @@ -1105,6 +1716,22 @@ snapped version.** graphr(fict_lotr, snap = TRUE) + ggtitle("stress + snap")) ``` +```{r snap-Q, echo=FALSE, purl = FALSE} +question("What does snap = TRUE do to the layout you asked for?", + answer("It keeps that layout, but moves each node onto the nearest grid coordinate", + correct = TRUE, + message = "Exactly — the arrangement stays recognisable, and the nodes just shuffle onto tidier positions. gif of a cartoon character energetically rearranging the living room furniture"), + answer("It replaces that layout with the grid layout", + message = "That is layout = 'grid'. With snap = TRUE the chosen layout is computed first, and only then rounded onto a grid."), + answer("It fixes the layout so that it is the same each time it is run", + message = "Some layouts, such as 'stress', are already deterministic. Snapping is about grid coordinates, not repeatability."), + answer("It removes overlapping labels", + message = "Snapping often helps label legibility, but it moves nodes rather than labels. Use label_repel and label_dist for labels."), + random_answer_order = TRUE, + allow_retry = TRUE +) +``` + ### Manual layouts {#manual-layouts} Whatever their differences, all these layout algorithms do the same job: @@ -1134,24 +1761,26 @@ useful when readers need to compare them. ::: {.callout} **Going further**: `{autograph}` also provides its own special-purpose layouts — -`"configuration"`, `"lineage"`, `"multilevel"`, `"triad"`/`"quad"`, -and layouts that align nodes by partition — -documented at `?layout_partition` and friends. +`"configuration"`, `"correspondence"`, `"levels"`, `"matching"`, +`"scaling"`, `"valence"`, +and the layered family — +documented at `?layout_layered` and friends. Several layouts take a layout-specific extra argument (passed through `...`) to control how nodes are ordered: `"concentric"` a `membership`, -`"multilevel"` a `level`, and `"lineage"` a `rank` — each a node attribute +`"levels"` a `level`, and the layered layouts `ranks` — each a node attribute name or a vector. See `?graphr` for the full list. ::: ::: {.callout} **In brief**: Pass `layout =` to `graphr()` to choose among force-directed (`"stress"`, `"fr"`, `"kk"`), -layered (`"hierarchy"`, `"railway"`, `"alluvial"`), +layered (`"layered"`, `"railway"`, `"lineage"`), circular (`"concentric"`, `"circle"`), -spectral (`"eigen"`, `"mds"`), +spectral (`"eigen"`, `"scaling"`, `"correspondence"`), and grid layouts. Force-directed layouts are illustrative — do not over-interpret distances; -spectral/MDS layouts place nodes by measured similarity; +spectral/MDS layouts place nodes by measured similarity, +and `"scaling"` captions the plot with how far that reading can be trusted; layered layouts suit two-mode or hierarchical data. And since every layout is just a table of coordinates, you can always compute one with `ggraph::create_layout()`, @@ -1228,8 +1857,6 @@ every node, so in that case isolates are kept in place. ### Dynamics {#dynamics} -gif of a hand flipping through a flipbook of animated stick figures - `grapht()` is another alternative to `graphr()`, this time rendering network changes over time as an animated gif. Longitudinal networks (with discrete waves) @@ -1258,6 +1885,22 @@ will split it without being told which attribute to use. From `{manynet}` 2.2.2, any other name (say, `year`) works just as well — it only needs declaring via `to_waves()`'s `attribute` argument. +```{r grapht-Q, echo=FALSE, purl = FALSE} +question("A tie attribute named what marks a network as longitudinal for {manynet}, so that to_waves() and grapht() split it without being told?", + answer("wave", + correct = TRUE, + message = "Yes — name it wave and the waves are found for you, like the pages of a flipbook. Any other name works too, but must be declared via to_waves()'s attribute argument. gif of a hand flipping through a flipbook of animated stick figures"), + answer("time", + message = "Close in spirit, but it is wave that is recognised automatically."), + answer("year", + message = "year is a perfectly good name, but you have to declare it via to_waves()'s attribute argument."), + answer("frame", + message = "Frames are what the animation renders, not what the network attribute is called."), + random_answer_order = TRUE, + allow_retry = TRUE +) +``` + ::: {.callout} **Going further**: Animation constrains a few things that a static graph allows. @@ -1269,7 +1912,8 @@ And because they do not translate cleanly from frame to frame, and self-loops are not drawn in animations. Labels, too, are placed at a fixed offset rather than repelled, and are hidden by default once a network has more than 30 nodes -(pass `labels = TRUE` to force them). +(pass `labels = TRUE` to force them, or select a few as in `graphr()`, +which is resolved once so the same nodes stay named in every frame). ::: ::: {.callout} @@ -1281,8 +1925,6 @@ and animate longitudinal or dynamic networks with `grapht()`. ## Going further with ggraph -gif of Mr Bean taking the restoration of a painting into his own hands - For more flexibility with visualisations, `{autograph}` users are encouraged to use the excellent `{ggraph}` package. `{ggraph}` is built upon the venerable `{ggplot2}` package @@ -1352,6 +1994,22 @@ and padding between the arrowhead and the node can also be specified. For more see David Schoch's [excellent resources on this](http://mr.schochastics.net/netVizR.html). +```{r ggraph-Q, echo=FALSE, purl = FALSE} +question("What is the main trade-off in building a graph directly in {ggraph} rather than with graphr()?", + answer("You control every layer yourself, but you have to specify each one", + correct = TRUE, + message = "Just so — nothing is drawn until you ask for it, so a plain graph takes more typing. Take the restoration into your own hands only when you need that control. gif of Mr Bean taking the restoration of a painting into his own hands"), + answer("You cannot use {ggplot2} layers with {ggraph}", + message = "{ggraph} is built on {ggplot2}, so the usual layers, scales, and themes all apply."), + answer("{ggraph} accepts fewer network classes, so graphr() is always faster to run", + message = "{ggraph} does expect tbl_graph or igraph objects, but the trade-off here is about control, not speed."), + answer("Graphs built in {ggraph} cannot be saved with ggsave()", + message = "They can — both graphr() and ggraph() return ggplot objects, which ggsave() handles alike."), + random_answer_order = TRUE, + allow_retry = TRUE +) +``` + ::: {.callout} **In brief**: Because `graphr()` returns a ggplot object, you can go a long way just appending `{ggplot2}`/`{ggraph}` layers to it. @@ -1400,8 +2058,6 @@ of the packages that produce those results. ## Exporting plots -gif of a maker declaring that the masterpiece is done and it is time to show the world - We can save the plots we have made by point-and-click by selecting 'Save as PDF...' from under the 'Export' dropdown menu in the plots panel tab of RStudio. @@ -1431,9 +2087,23 @@ Animations made with `grapht()` are saved slightly differently: use `gganimate::anim_save("my_animation.gif")`, which works just like `ggsave()` but for the last animation rendered. -## Summary +```{r export-Q, echo=FALSE, purl = FALSE} +question("Which file format should you prefer when a publisher asks for a figure that stays sharp at any size?", + answer(".pdf", + correct = TRUE, + message = "Yes — .pdf and .svg are vector formats, so they scale without going blurry. The masterpiece is done: show the world. gif of a maker declaring that the masterpiece is done and it is time to show the world"), + answer(".png", + message = "A .png is a raster format. It is fine for the web, and for print at a high dpi, but it does not scale freely."), + answer(".jpeg", + message = "A .jpeg is raster too, and its compression blurs lines and text. Avoid it for graphs."), + answer(".gif", + message = "Save a .gif for animations from grapht(), via gganimate::anim_save()."), + random_answer_order = TRUE, + allow_retry = TRUE +) +``` -gif of an enthusiastic standing ovation and cries of bravo +## Summary Well done — you have completed the tutorial on visualising networks! Along the way, you have learned to use these functions: @@ -1443,11 +2113,11 @@ Along the way, you have learned to use these functions: | `graphr()` | graphs any manynet-compatible network with sensible defaults | | `graphr(..., node_colour/node_shape/node_size/node_group)` | maps node attributes to aesthetics | | `graphr(..., edge_colour/edge_size)` | maps tie attributes to aesthetics | -| `graphr(..., labels, label_repel, label_dist)` | controls node labelling | +| `graphr(..., labels, label_repel, label_dist)` | chooses which nodes to label, and places the labels | | `graphr(..., layout, snap)` | chooses and adjusts the layout algorithm | | `graphr(..., x, y)` | places nodes at manually supplied coordinates | | `ggraph::create_layout()` | returns a layout's table of node coordinates for tweaking | -| `graphr(..., edge_bundle, isolates)` | tames large, dense, or disconnected networks | +| `graphr(..., edge_bundle, backbone, isolates)` | tames large, dense, or disconnected networks | | `stocnet_theme()` | sets a consistent theme for all graphs and plots | | `ggplot2::scale_fill_hue()`, `_grey()`, `_manual()` | overrides node colour palettes | | `labs()`, `ggtitle()`, `guides()` | adds titles, axis and legend labels | @@ -1456,6 +2126,22 @@ Along the way, you have learned to use these functions: | `plot()` | plots measures, motifs, and model results consistently | | `ggsave()` | exports the last plot at publication quality | +```{r summary-Q, echo=FALSE, purl = FALSE} +question("One last one: which function graphs a list of related networks as comparable panels?", + answer("graphs()", + correct = TRUE, + message = "Correct — graphs() for panels, grapht() for animations, graphr() for a single graph. Take a bow. gif of an enthusiastic standing ovation and cries of bravo"), + answer("grapht()", + message = "grapht() animates change over time instead, rendering the waves as frames."), + answer("graphr()", + message = "graphr() draws one network. You can combine several graphr() calls with {patchwork} operators, though."), + answer("plot()", + message = "The plot() methods are for measures, motifs, and model results, not for lists of networks."), + random_answer_order = TRUE, + allow_retry = TRUE +) +``` + When you are ready, continue with the tutorials in the other `{stocnet}` packages — on network structure and centrality in `{netrics}`, and on diffusion and regression in `{migraph}` — diff --git a/inst/tutorials/autograph1/visualisation.html b/inst/tutorials/autograph1/visualisation.html index c3e68a5b..38325161 100644 --- a/inst/tutorials/autograph1/visualisation.html +++ b/inst/tutorials/autograph1/visualisation.html @@ -225,7 +225,14 @@

Aims

& fun), Real-world (irps_*, larger & realistic) — and that you can browse the full list with table_data().

-

gif of Bob Ross painting a happy little landscape

+
+
+
+
+
+ +
+
@@ -340,12 +347,12 @@

Graphing approaches

fairly basic way, straight to the plotting device (window). By default, it uses a force-directed layout (see the Layouts section below),4 colors the nodes orange, and prints -node labels if they have them. However, the layout is not optimised for -the size of the plotting window, the node labels are regularly -overlapping, and the orange color with black borders is not particularly -appealing or helpful for label legibility. It only works with ‘igraph’ -objects.

+id="section-fnref4">4 colours the nodes orange, and +prints node labels if they have them. However, the layout is not +optimised for the size of the plotting window, the node labels are +regularly overlapping, and the orange colour with black borders is not +particularly appealing or helpful for label legibility. It only works +with ‘igraph’ objects.

In contrast, {ggraph} offers the trademark flexibility of the grammar of graphics approach. However, it requires the user to build up a plot from the ground up, which can be daunting for new users @@ -401,10 +408,13 @@

Your first graph

Note everything that happened without being asked: graphr() recognised that the network is -labelled and printed the node labels, chose a -deterministic layout (so you get the same picture every time), sized and -spaced the labels to minimise overlap, and dropped the axes and grey -background that mean nothing for networks. Because the network is +labelled and printed node labels — but only for the most +central characters, since 36 labels at once would hide the network +behind them (the Labels section below shows how to choose differently), +chose a deterministic layout (so you get the same picture every time), +sized and spaced the labels to minimise overlap, and dropped the axes +and grey background that mean nothing for networks. Because the network +is undirected , there are no arrowheads; for a @@ -434,10 +444,11 @@

Your first graph

In brief: graphr() graphs any manynet-compatible network object with sensible defaults inferred from the data: labels where the network is -labelled, arrowheads where it is directed, a deterministic layout, and -no chart junk. It returns a {ggplot2} object, so anything -you can do to a ggplot — adding layers, titles, scales with -+ — you can do to a graph.

+labelled (and, where it is large, only for the nodes that stand out), +arrowheads where it is directed, a deterministic layout, and no chart +junk. It returns a {ggplot2} object, so anything you can do +to a ggplot — adding layers, titles, scales with + — you +can do to a graph.

@@ -509,13 +520,25 @@

Illustrating graphs

edge_size= -Color -node_color=/node_colour= -Color -edge_color=/edge_colour= +Colour +node_colour=/node_color= +Colour +edge_colour=/edge_color= +
+

Beginner note: As +the table shows, both spellings work: node_colour= and +node_color= are the same argument, as are +edge_colour= and edge_color=, and the same +goes for {ggplot2}‘s colour/color +aesthetics and +scale_colour_*()/scale_color_*() functions. +This tutorial is written in British English and so says ’colour’ +throughout, but you should use whichever spelling comes naturally to +you.

+

The named arguments in the table above cover the aesthetics you will reach for most often. Several other visual features are not arguments at all: graphr() reads them off the data and sets them for @@ -550,7 +573,7 @@

Illustrating graphs

Each of the mapping arguments can be given either a literal value (e.g. node_size = 6) or, more interestingly, the name of a node or tie attribute in the data -(e.g. node_color = "Race"), in which case +(e.g. node_colour = "Race"), in which case graphr() maps the attribute to that aesthetic and adds a legend where appropriate. Let’s go through some of these options in more detail.

@@ -604,7 +627,6 @@

Shaping nodes

Colouring nodes

-

gif of an artist swirling paint colours together on a palette

Let’s try instead colouring the nodes by this “Race” variable. It is very similar to the shape example above. Can you complete the code yourself?

@@ -616,13 +638,13 @@

Colouring nodes

-
# Use the same syntax as with node_shape, but with the node_color argument.
+
# Use the same syntax as with node_shape, but with the node_colour argument.
 # Remember to name the attribute in quotation marks.
-
graphr(fict_lotr, node_color = "Race")
+
graphr(fict_lotr, node_colour = "Race")

That’s much easier to read. Note how a legend has been added automatically, using the colours of whatever theme is currently set @@ -649,7 +671,7 @@

Colouring nodes

graphr(fict_lotr, node_group = "Race")
-

Note that node_color and node_group can be +

Note that node_colour and node_group can be used together, either to highlight different groupings, or to emphasise group assignment where the groups interpenetrate, as described above.

@@ -699,7 +721,7 @@

Sizing nodes

Tying up loose ends

All this works similarly with ties/edges. Just replace node_ with edge_ in the arguments above, and -you can control edges’ size and color. In the following example, we add +you can control edges’ size and colour. In the following example, we add two tie attributes: a continuous variable measuring how ‘close’ each tie is to others, and a binary variable indicating whether the tie is part of a triangle @@ -712,7 +734,7 @@

Tying up loose ends

fict_lotr |>
   mutate_ties(weight = tie_by_closeness(fict_lotr),
               is_tri = tie_is_triangular(fict_lotr)) |>
-  graphr(edge_color = "is_tri")
+ graphr(edge_colour = "is_tri")

Note also that some tie attributes are recognised automatically: if a @@ -749,24 +771,80 @@

Pointing arrows

Taming dense or disconnected networks

-

Two arguments help when a network is too dense, or too sparse, to -read at a glance.

-

Larger, denser networks can turn into a ‘hairball’, where the sheer -number of ties obscures everything. edge_bundle pulls ties -that travel in similar directions into shared paths — like cabling them -together — so that the main ‘highways’ of the network stand out. It is -off by default; set edge_bundle = TRUE (or name a specific -algorithm: "force", "path", or -"minimal") to switch it on. Compare a dense random -network with and without bundling.

+

Sometimes networks are just a dense hairball. This is a technical +term to describe networks with many high-degree nodes and many ties, +where the sheer number of ties obscures the structure of the network. +Autograph includes three arguments that can help with this.

+
+

Bundling ties

+

The first option is to draw all of the ties ‘bundled’ together, which +can reveal where the most common paths through the network are. +edge_bundle pulls ties that travel in similar directions +into shared paths — like cabling them together — so that the main +‘highways’ of the network stand out. It is off by default; set +edge_bundle = TRUE (or name a specific algorithm: +"force", "path", or "minimal") to +switch it on. ison_lawfirm records 71 lawyers and +2571 ties between them, which is about as thick a hairball as a network +this small can be. Compare it drawn with and without bundling (turn +backbone off too for clearest comparison results).

-
rand <- manynet::generate_random(40, 0.1)
-(graphr(rand) + ggtitle("Unbundled") |
-   graphr(rand, edge_bundle = TRUE) + ggtitle("Bundled"))
+
graphr(ison_lawfirm, backbone = FALSE) + ggtitle("Unbundled") | 
+  graphr(ison_lawfirm, backbone = FALSE, edge_bundle = "path") + ggtitle("Bundled")
+ +
+

I find this works best with networks that are at least moderately +dense, and sometimes requires a little bit of playing around to get a +good result.

+
+
+

Backbones

+

By contrast, + +backbone changes which ties the picture is built around. +Ties that carry more weight/structure than expected by a null model +local to their endpoints are in essence what the network would be if it +were stripped back to its skeleton. graphr() then draws the +layout according to this skeleton and fades other ties into the +background to further emphasise the main structure.

+

Most of the time you will not have to ask for this. Networks of 50+ +nodes with 8 ties each on average is drawn this way by default. But you +can specify backbone = FALSE to turns it off, +backbone = TRUE to force it on, or you can name a filter — +"disparity", "lans", "noise", +"mlf", or "simmelian" — or threshold. +Compare ison_lawfirm drawn with and without its +backbone.

+
+
(graphr(ison_lawfirm, node_colour = "office", backbone = FALSE) +
+   ggtitle("Every tie alike") |
+   graphr(ison_lawfirm, node_colour = "office", backbone = TRUE) +
+   ggtitle("Backbone"))
+

The offices are hardly visible on the left. On the right they +separate, because the ties that hold each office together are the ties +the filter keeps.

+

Only the layouts that read tie lengths are laid out this way: +"stress" (the default), "fr", +"drl" and "kk". Every other layout, including +those whose coordinates already mean something such as +"layered" or "scaling", keeps its coordinates +and only fades its ties. Signed networks have no backbone, since these +null models have no place for a negative weight, and are drawn as they +were.

+

Bundling and backbones answer the same problem from different ends, +so try one before reaching for both. A bundled tie cannot carry a fading +of its own — bundling merges ties into shared paths — so where both are +asked for, the backbone still shapes the layout but every tie is drawn +alike.

+
+
+

Isolates

At the other extreme, many networks contain isolates — unconnected nodes — which, under a @@ -788,9 +866,12 @@

Taming dense or disconnected networks

For very large real-world networks such as irps_blogs, -the two work well together: edge_bundle = TRUE untangles -the connected core while isolates = "legend" keeps its -several hundred unconnected blogs from crowding that core out.

+these work well together: a backbone picks out the ties that hold the +connected core together (or edge_bundle = TRUE, if you +would rather see the paths the ties take than which of them matter +most), while isolates = "legend" keeps its several hundred +unconnected blogs from crowding that core out.

+

Free play

@@ -828,14 +909,15 @@

Free play

In brief: graphr() maps node and tie attributes to visual aesthetics -by name: node_color, node_shape, +by name: node_colour, node_shape, node_size, and node_group for nodes, -edge_color and edge_size for ties. Use colour +edge_colour and edge_size for ties. Use colour or shape for categorical attributes (colour scales better), size for continuous ones, and node_group to shade spatially clustered memberships. For dense or disconnected networks, -edge_bundle and isolates (see Taming dense -or disconnected networks above) keep the picture legible.

+edge_bundle, backbone and +isolates (see Taming dense or disconnected +networks above) keep the picture legible.

@@ -846,15 +928,18 @@

Theming

a theme · Hues · Grayscale +onclick="document.getElementById('section-seeing-what-others-see').scrollIntoView({behavior:'auto',block:'start'});">Colour +blindness · Greyscale · Manual -override

+override · Medium

Setting a theme

Perhaps you are preparing a presentation, representing your institution, department, or research centre at home or abroad. In this -case, you may wish to theme the whole network with institutional colors +case, you may wish to theme the whole network with institutional colours and fonts. Indeed, you may even want to set a theme that is then reused across all your graphs and plots. {autograph} offers a number of themes that can be set using the stocnet_theme() @@ -864,9 +949,9 @@

Setting a theme

data-diagnostics="1" data-startover="1" data-lines="0" data-pipe="|>"> 
stocnet_theme("default")
-graphr(fict_lotr, node_color = "Race")
+graphr(fict_lotr, node_colour = "Race")
 stocnet_theme("iheid")
-graphr(fict_lotr, node_color = "Race")
+graphr(fict_lotr, node_colour = "Race")
 stocnet_theme("default")
@@ -876,31 +961,65 @@

Setting a theme

"unige", "cmu", "iast", "hwu") as well as stylistic ones ("default", "bw", "crisp", "neon", -"rainbow"). Run stocnet_theme() without -arguments to see which theme is currently set. More institutional scales -and themes can be implemented upon pull request.

+"clay", "rainbow"). Run +stocnet_theme() without arguments to see which theme is +currently set. More institutional scales and themes can be implemented +upon pull request.

+

A theme lasts for the session in which you set it, and a new session +starts on the default again. Where a theme is your usual one, +persist = TRUE remembers it, by writing the name to your +user configuration directory:

+
+
# stocnet_theme("iheid", persist = TRUE)   # remembered next session too
+stocnet_theme()
+ +
+

Nothing is written to disk unless you ask for it. Setting any theme +with persist = FALSE, the default, forgets a choice you +persisted earlier, so +stocnet_theme("default", persist = FALSE) puts you back +where you began.

+

A theme sets a typeface as well as a palette, but only where that +typeface is installed and R can see it. list_fonts() lists +the families R can see, and ag_font() reports the one the +current theme settled on.

+
+
ag_font()
+head(list_fonts("sans"))
+ +
+

If ag_font() returns "sans", the theme +found none of the fonts it prefers, and your graphs will look more +generic than they should. Install the missing family — many are free +from Google Fonts — then install +the {systemfonts} package so that R can see the fonts on +your system, and set the theme again. ?stocnet_theme sets +out the steps for each operating system.

Who’s hue?

-

gif from The Devil Wears Prada: that is not just blue, that is cerulean

-

By default, graphr() will use a color palette that +

By default, graphr() will use a colour palette that offers fairly good contrast and better accessibility. However, a different hue might offer a better aesthetic or identifiability for some nodes. Because the graphr() function is based on the grammar of graphics, it’s easy to extend or alter aesthetic aspects. -Here let’s try and change the colors assigned to the different races in +Here let’s try and change the colours assigned to the different races in the fict_lotr dataset. Note that despite the argument being -node_color, when overwriting the colors please use +node_colour, when overwriting the colours please use functions of the type ggplot2::scale_fill_*(), as it is the “fill” aesthetic that is being mapped to the variable in this case.

-
graphr(fict_lotr,
-           node_color = "Race")
+           node_colour = "Race")
 
 graphr(fict_lotr,
-           node_color = "Race") +
+           node_colour = "Race") +
   ggplot2::scale_fill_hue()
@@ -939,38 +1058,131 @@

Who’s hue?

-
-

Grayscale

-

Other times color may not be desired. Some publications require -grayscale images. To use a grayscale color palette, replace -_hue from above with _grey (note the ‘e’ -spelling):

+
+

Seeing what others see

+

About one man in twelve, and one woman in two hundred, sees colour +differently from the palette designer. The most common form, +deuteranopia, confuses reds with greens — which is precisely the pairing +a “stop/go” palette relies on.

+

{autograph} gives you two functions for checking this. +simulate_colorblind() shows you a set of colours as such a +viewer sees them, and check_separation() scores how far +apart colours are, taking the worst case across normal vision and each +type of colour blindness. A score below 10 means two colours are easily +confused, 10 to 25 that they are separable but close, and above 25 that +they are comfortably distinct.

+
+
# A red and a green that look quite different to most viewers
+check_separation(c("#B7352D", "#627313"))
+# But not to everyone
+simulate_colorblind(c("#B7352D", "#627313"), "deutan")
+ +
+

Run the code, then try "protan" or +"tritan" instead of "deutan".

+

How far the simulation goes is set by severity. Full +severity, the default, is dichromacy: deuteranopia, protanopia, +tritanopia. A lower severity is anomalous trichromacy — deuteranomaly, +protanomaly — which is the more common condition, and which the +paragraph above named without being able to show you.

+
+
simulate_colorblind(c("#B7352D", "#627313"), "deutan", severity = 1)
+simulate_colorblind(c("#B7352D", "#627313"), "deutan", severity = 0.4)
+ +
+

You can also look at a whole graph the way another viewer would, by +mapping the simulated colours back onto it.

+
+
graphr(fict_lotr, node_colour = "Race")
+graphr(fict_lotr, node_colour = "Race") +
+  ggplot2::scale_fill_manual(values = simulate_colorblind(ag_qualitative(6), "deutan"))
+ +
+

Much of this work is already done for you. Each theme’s palette is +reordered when the theme is set, so that the colours a graph uses first +are the ones that stay distinct for every viewer, and each divergent +palette pairs a warm pole with a cool one rather than a red with a +green.

+
+
stocnet_theme("iheid")
+round(check_separation(ag_qualitative(4)))
+# The closest pair among those four colours
+min(check_separation(ag_qualitative(4)), na.rm = TRUE)
+stocnet_theme("default")
+ +
+
+

Going further: +The "rainbow" theme is the exception, and is left in the +order of the spectrum, since that fidelity is its point. A spectrum is +not a colour-blind safe scheme: its reds and greens are the pair that +red-green colour blindness cannot separate. Choose it where the order of +your categories is itself meaningful, and check the result with +check_separation(). Where you need particular colours in an +institutional palette, match_color() finds the closest the +palette has to those you ask for.

+
+
+
+

Greyscale

+

Other times colour may not be desired. Some publications require +greyscale images, and a figure may be photocopied whether or not you +meant it to be. A greyscale device keeps the luminance of a colour and +throws the rest away, so two colours of the same lightness merge, +however different their hues. This is why ColorBrewer marks a palette +print-safe and photocopy-safe separately from marking it colour-blind +safe: they are different questions, and a palette can pass one and fail +the other.

+

simulate_colorblind() answers the second with +type = "grey", and check_separation() reports +the greyscale distances beside its own score.

+
+
check_separation(ag_qualitative(4))
+ +
+

The matrix is what every viewer can see. The line beneath it is what +survives a photocopier. Most institutional palettes separate their +categories by hue, so most of them collapse in greyscale.

+

To draw in greyscale from the start, replace _hue from +above with _grey (note the ‘e’ spelling):

graphr(fict_lotr,
-           node_color = "Race") +
+           node_colour = "Race") +
   ggplot2::scale_fill_grey()
-

As you can see, grayscale is more effective for continuous variables +

As you can see, greyscale is more effective for continuous variables or for very few discrete categories than for the six categories used here. If you need to distinguish several categories in print, consider -combining grayscale with node_shape, or use the -"bw" theme, which is designed for this purpose.

+combining greyscale with node_shape, or use the +"bw" theme, which is designed for this purpose. +stocnet_medium("print") is the companion to this; see +Where will it be seen? below.

Manual override

-

Or we may want to choose particular colors for each category. This is -pretty straightforward to do with -ggplot2::scale_fill_manual(). Some common color names are -available, but otherwise hex color codes can be used for more specific -colors. Unspecified categories are coloured (dark) grey.

-
+

Or we may want to choose particular colours for each category. This +is pretty straightforward to do with +ggplot2::scale_fill_manual(). Some common colour names are +available, but otherwise hex colour codes can be used for more specific +colours. Unspecified categories are coloured (dark) grey.

+
graphr(fict_lotr,
-           node_color = "Race") +
+           node_colour = "Race") +
   ggplot2::scale_fill_manual(
     values = c("Dwarf" = "red",
                "Hobbit" = "orange",
@@ -978,18 +1190,68 @@ 
Manual override

                "Human" = "lightblue",
                "Elf" = "lightgreen",
                "Ent" = "darkgreen")) +
-  labs(fill = "Color")
+ labs(fill = "Colour") + +
+
+
+

Where will it be seen?

+

A theme says how a plot should look. Where it will be seen is a +separate question, and the answer changes more often than the theme +does. The same institutional theme has to serve a figure worked on at a +desk, projected in a lecture theatre, printed in an article, and read on +a phone in a narrow column. Each of those wants a different size of +text, and one of them wants a different background.

+

stocnet_medium() sets this, and leaves the theme +alone.

+
+
stocnet_medium()
+stocnet_medium("presentation")
+graphr(fict_lotr, node_colour = "Race")
+stocnet_medium("screen")
+

The media are "screen" (the default), +"presentation", "mobile", and +"print". The first three differ in the size of their text; +ag_size() reports the multiplier in force. +"print" leaves the text alone and draws on white, whatever +ground the theme prefers, since a dark or tinted ground costs ink and is +often not reproduced. As with stocnet_theme(), +persist = TRUE remembers your choice.

+

The medium scales text, not marks. A node’s size is relative to the +layout it sits in, so enlarging the nodes without enlarging the layout +would only crowd it. Use node_size in graphr() +where a figure needs larger nodes too.

+

Nor does the medium set the size of the file you write. Give +ggsave() the width, height, and resolution to match; see +Exporting plots below.

+
+

Going further: A +small figure limits how much it can carry, not just how large the type +is. Keep a legend to about seven keys, and graphs() to +about three panels. graphr() says so when a colour or shape +legend grows past that, because past it a reader stops matching keys to +marks and starts guessing. Splitting one crowded figure into two that +each make a single point is almost always better than shrinking the type +until it fits.

+

In brief: stocnet_theme() sets a theme once for all subsequent graphs -and plots, with institutional and stylistic palettes included. -Individual graphs can still be adjusted by appending +and plots, with institutional and stylistic palettes included, and +persist = TRUE keeps it for future sessions. Individual +graphs can still be adjusted by appending ggplot2::scale_fill_*() functions — _hue() for a different palette, _grey() for print, -_manual() for hand-picked colours — and it is worth -checking your palette is colour-blind accessible.

+_manual() for hand-picked colours — and +simulate_colorblind(), check_separation() and +check_contrast() check that your palette works for +colour-blind viewers, in greyscale, and as text. +stocnet_medium() then sizes the result for where it will be +seen.

@@ -1008,10 +1270,10 @@

Titles, labels, and legends

Labels

With our fict_lotr example above, because the network is -itself labelled, graphr() automatically adds the node -labels. If you do not want these labels, you can remove them from the -network before passing it on to graphr(), or more simply -use the argument labels = FALSE.

+itself labelled, graphr() adds node labels. If you do not +want any labels, you can remove the names from the network before +passing it on to graphr(), or more simply use the argument +labels = FALSE.

@@ -1023,15 +1285,63 @@

Labels

which character. Which you prefer depends on what the graph is for: exploring who-is-who, or communicating overall structure.

+

But this is not really a choice between all and nothing. +fict_lotr has 36 nodes, and 36 labels would cover the very +network they describe, so graphr() labelled only the +handful of most central characters and told you so. Ask for all +of them with labels = TRUE and compare.

+
+
graphr(fict_lotr, labels = TRUE)
+ +
+

You can decide how many to label by passing a number. This is a depth +of ranks rather than a count of nodes, so characters tied at +the cut are labelled together — ask for the top three and you may get +four names.

+
+
graphr(fict_lotr, labels = 3)
+ +
+

+Degree is only one reason a node might be worth naming. +Passing the name of a measure labels whichever node or nodes it singles +out: "betweenness" for the characters who sit between +others, "cutpoints" for those holding the network together, +or "random" for a small unbiased sample.

+
+
graphr(fict_lotr, labels = "betweenness")
+ +
+

To combine the two, name the number: +labels = c(betweenness = 5). And when you know exactly who +matters to your argument, you can just say so — by name, or with any +logical vector of the nodes.

+
+
graphr(fict_lotr, labels = c("Frodo", "Gandalf")) +
+  ggtitle("Named outright") |
+  graphr(fict_lotr, labels = node_is_cutpoint(fict_lotr)) +
+  ggtitle("Every cutpoint")
+ +

Going further: By default graphr() repels labels away from each other and from nodes so that they do not overlap. Two further arguments offer finer control: label_repel = FALSE places labels at a fixed offset instead, and label_dist controls how far labels sit -from their nodes (in points). For crowded graphs, also consider -labelling only some nodes, -e.g. mutate(name = ifelse(node_is_max(node_by_deg(.)), name, "")).

+from their nodes (in points). On a + +two-mode or multilevel network, a selection is ranked +within each mode or level, so that a dense level cannot crowd the others +out of the labelling.

@@ -1070,6 +1380,13 @@

Titles

Legends

+

A legend asks a reader to hold a colour in mind while they hunt for +it in the graph, and people are poor at that: colour is not recalled +reliably, even over a couple of seconds. Labelling nodes directly asks +less of them, which is why graphr() labels nodes where it +can, and why, above thirty nodes, it labels the most central ones rather +than none at all (see Labels above). Keep a legend for what +cannot be written onto the graph itself, and keep it short.

While {autograph} attempts to provide legends where necessary, in some cases the legends offer insufficient detail, or are absent, such as in the following figure, where we highlight the node @@ -1081,7 +1398,7 @@

Legends

data-pipe="|>"> 
fict_lotr |>
   mutate(maxbet = node_is_max(node_by_betweenness(fict_lotr))) |>
-  graphr(node_color = "maxbet")
+ graphr(node_colour = "maxbet")

Which node is highlighted here, and why might that be? Without a @@ -1097,9 +1414,9 @@

Legends

data-pipe="|>"> 
fict_lotr |>
   mutate(maxbet = node_is_max(node_by_betweenness(fict_lotr))) |>
-  graphr(node_color = "maxbet") +
-  guides(color = "legend") +
-  labs(color = "Maximum\nBetweenness")
+ graphr(node_colour = "maxbet") + + guides(colour = "legend") + + labs(colour = "Maximum\nBetweenness")

To change the position of the legend, add the theme() @@ -1108,8 +1425,9 @@

Legends

In brief: labs() adds titles, subtitles, and legend titles; -guides() forces or removes legends; -labels = FALSE hides node labels, and +guides() forces or removes legends; labels +chooses which nodes to name — all of them, none, the top few by a +measure, or the ones you name yourself — and label_repel/label_dist fine-tune their placement. A graph that leaves your hands should be readable without you standing next to it explaining.

@@ -1169,7 +1487,6 @@

Layouts

types of layouts.

Force-directed layouts

-

gif of yoda moving things with the force

Force-directed layouts update some initial placement of vertices through the operation of some system of metaphorically-physical forces. These might include attractive and repulsive forces.

@@ -1218,41 +1535,136 @@

Force-directed layouts

Layered layouts

-

Layered layouts arrange nodes into horizontal (or vertical) layers, -positioning them so that they reduce crossings. These layouts are best -suited for directed acyclic graphs, two-mode networks, or other data -with a natural hierarchy or ordering.

+

Layered layouts arrange nodes into layers, positioning them so that +they reduce crossings. These layouts are best suited for directed +acyclic graphs, two-mode networks, or other data with a natural +ordering.

+

{autograph} offers four, and they are one layout drawn +four ways. Two things vary: which axis the layers run along, and whether +the nodes line up across them. The names say which is which — a railway +lies flat, a ladder stands up:

+ + + + + + + + + + + + + + + + + + + + +
Layers stacked flatLayers standing up
Nodes spaced by their ties"layered""lineage"
Nodes lined up across layers"railway""ladder"
graphr(ison_southern_women, layout = "bipartite") + ggtitle("Bipartite")
-graphr(ison_southern_women, layout = "hierarchy") + ggtitle("Hierarchy")
+graphr(ison_southern_women, layout = "layered") + ggtitle("Layered")
 graphr(ison_southern_women, layout = "railway") + ggtitle("Railway")
-

Note that "hierarchy" and "railway" use a +

Note that "layered" and "railway" use a different algorithm to {igraph}’s "bipartite", and generally perform better, especially where there are multiple -layers. Whereas "hierarchy" tries to position nodes to +layers. Whereas "layered" tries to position nodes to minimise overlaps, "railway" sequences the nodes in each layer to a grid so that nodes are matched as far as possible. For the -"hierarchy" layout you can also steer which set sits where -by passing a center argument — "events" or +"layered" layout you can also steer which set sits where by +passing a center argument — "events" or "actors" for a two-mode network, or the name of a particular node — which helps when the default places the less interesting set on top.

-
-
graphr(ison_southern_women, layout = "hierarchy", center = "events")
+
graphr(ison_southern_women, layout = "layered", center = "events")

If you want to flip the horizontal and vertical, you could flip the -coordinates, or use something like the following layout.

-
"lineage", which is the same layout +with the axes exchanged.

+
-
graphr(ison_southern_women, layout = "alluvial") + ggtitle("Alluvial")
+
graphr(ison_southern_women, layout = "lineage") + ggtitle("Lineage")
+ +
+

These layouts serve both multimodal and directed acyclic networks. A +genealogical network offers the clearest case: every tie points from an +earlier generation to a later one. Where a force-directed layout +obscures this ordering, graphr() uses the +"layered" layout to make it clear. Draw the parent +ties among the characters of Westeros.

+
+
thrones <- to_uniplex(fict_thrones, "parent")
+graphr(thrones)
+ +
+

This layout tries to minimise two costs. The first is which layer +each node goes in. Ranking each node by its distance from a root sounds +right — a row is then a generation — but it pins a parent whose only +child is born several generations later to the top row, and manufactures +a long tie to reach them. The ranks argument chooses the +rule, and check_span() reports how many rows each tie +crosses, so you can measure the difference.

+
+
thrones <- to_uniplex(fict_thrones, "parent")
+spans <- sapply(c("generation", "compact", "tight"), function(r) {
+  span <- check_span(graphr(thrones, ranks = r))
+  c(total = attr(span, "total"), `over one row` = mean(span > 1), max = max(span))
+})
+round(t(spans), 3)
+ +
+

"generation" is the distance-from-a-root rule and +"compact" is the one {igraph} uses in its +Sugiyama layout. "tight", the default, minimises total tie +length while still pointing every tie down at least one row. Note that +the longest tie is the same under all three.

+

The second cost is where each node sits within its row. +check_offset() reports how far each tie travels sideways, +as a share of the width of the drawing, so a tie that drops straight +down scores zero. Again, you are wanting to minimise this, and the +alignment argument chooses the rule. Compare the +two alignments.

+
+
thrones <- to_uniplex(fict_thrones, "parent")
+c(straight = attr(check_offset(graphr(thrones)), "mean"),
+  rungs = attr(check_offset(graphr(thrones, alignment = "rungs")), "mean"))
+ +
+

alignment = "rungs" gives every row the same spacing, +which is what "railway" and "ladder" are for. +The default, "straight", pulls each node towards its +parents and children instead, which is what makes the families read as +families.

+

ranks also accepts a node attribute, instead of one of +those three rules. Then the layers are that attribute’s values, and +nodes are placed along the axis in proportion to them rather than at +even steps, so a network of dated nodes is drawn as a timeline. +Rank the adolescents by a year of your choosing.

+
+
ison_adolescents |> as_stocnet() |> 
+  mutate_nodes(year = rep(c(1985, 1990, 1995, 2000), times = 2),
+               label = paste0(label, " (", year, ")")) |>
+  graphr(layout = "lineage", ranks = "year")

Other layered layouts include:

@@ -1295,8 +1707,8 @@

Circular layouts

Spectral layouts

Spectral layouts arrange nodes according to the eigenvalues of the -Laplacian matrix of a graph. These layouts tend to exaggerate the -clustering of like-nodes and the separation of less similar nodes in +Laplacian matrix of a graph. These layouts exaggerate the clustering of +similarly located nodes and separate less similar nodes in two-dimensional space.

Spectral layouts 
graphr(ison_southern_women, layout = "eigen") + ggtitle("Eigenvector")
-

Somewhat similar are multidimensional scaling (MDS) techniques, which -visualise the similarity between nodes in terms of their proximity in a -two-dimensional (or more) space.

-
+

Multidimensional scaling

+

Of similar purpose are multidimensional scaling (MDS) techniques, +which visualise the similarity between nodes in terms of their proximity +in a two-dimensional (or more) space. The "scaling" layout +places the nodes so that the distance drawn between them stands for the +number of steps between them in the network.

+
-
graphr(ison_southern_women, layout = "mds") + ggtitle("Multidimensional Scaling")
+
graphr(ison_southern_women, layout = "scaling") + ggtitle("Multidimensional Scaling")
-

Other such layouts include:

-
    -
  • Pivot multidimensional scaling: "pmds"
    • -
+

Note that this layout is drawn with the axes labelled, whereas you +may have noticed that the other graphs are not. That is because here the +coordinates can be read: two nodes drawn twice as far apart are, more or +less, twice as far apart. The axes are drawn on one scale for the same +reason. The layout scales the whole network where it is small enough for +that, using "mds" from {igraph}, and otherwise +approximates the scaling from a sample of the nodes using +"pmds" (or pivot MDS) from {graphlayouts}. You +can still call each of these directly, but since they are both used in +"scaling", dispatch can be automatic, based on the size and +structure of the network.

+

“More or less” is doing some work in that sentence. A network usually +has more structure than two dimensions alone can hold, so some of the +distances drawn won’t capture the real distances in the network. In some +cases, the dimensionality is so high that the drawing is misleading. We +can check how much disagreement there is between scaled distances and +the network distances as a stress score. This is printed as a +caption under the plot as a percentage of the network distances, such +that zero would represent a perfect drawing.

+

How low is low? Kruskal (1964), who introduced the +score, recommends 20% as poor, 10% as fair, 5% as good, and 2.5% as +excellent. Those figures were established for psychometric data though. +Networks typically contain a lot more structure, which is hard to +capture in just two dimensions, so a 20% threshold is often too +demanding.

+

For networks, a score near 30% is quite common, and means the +clustering can be interpreted though perhaps the distances should not be +interpreted as exact. Above 40% and the plot does not really show any +interpretable structure; graphr() will alert you in the +console where the score is above 30%. By contrast, a stress score near +5% is rare and worth trusting.

+

Note that this stress score is not only for this layout. +check_stress() measures any drawing the same way, so +layouts can be compared on the same network (Brandes and Pich 2007):

+
+
sapply(c("scaling", "stress", "fr", "circle"),
+       function(x) check_stress(graphr(ison_southern_women, layout = x)))
+ +
+

The default "stress" layout scores a little better here, +which is no accident: it minimises a related criterion directly. What +"scaling" adds is the axes and the score, so that the +distances can be read and the reading can be checked.

+

In addition to stress, the scaling layout also reports how much of +the variance in the network’s distances the two dimensions drawn hold. +The two numbers answer different questions, and the comparison above +shows how. Stress belongs to the drawing: draw this one network four +ways and you get four different scores. The variance explained belongs +to the network: it is the same 31% whichever of the four you draw, +because it asks how much of the structure two dimensions could hold at +all.

+

So read them together. A low variance explained sets a floor that no +layout gets under. Where two dimensions can hold only a third of the +structure, no arrangement of the nodes will draw the distances +faithfully, and stress tells you how close to that floor this particular +drawing gets.

@@ -1325,10 +1797,147 @@

Spectral layouts

+
+
+
+
+
+ +
+
+
+
+

Correspondence analysis

+

Whereas scaling lays out nodes by their distances from each other, +correspondence analysis (CA) lays them out by the similarity of their +ties. This is useful where nodes may not be tied to each other at all, +but can be tied to the same others, such as in a two-mode network. +Correspondence analysis takes a rectangular table — here the incidence +matrix of the Southern Women dataset, one row for each woman and one +column for each event — and places its rows and its columns in one +space.

+
+
graphr(ison_southern_women, layout = "correspondence") + ggtitle("Correspondence Analysis")
+ +
+

We can see the similarity to the eigenvector layout above, but the +axes are labelled with the share of the network’s inertia they +hold. Inertia is the CA analogue of variance in PCA. It measures the +total dispersion of points (rows and columns) in the cloud around the +centroid, computed as the chi-square statistic of the table divided by +the total sample size (N). In other words, inertia tell us how far the +ties depart from what one would expect if every woman attended events in +the same proportion as every other. A network whose nodes all had much +the same ties would have almost none.

+

Each dimension extracted captures a share of this total inertia. +Because it is a share of variance explained, and not a measure of fit +like regression’s R-squared, the scores depend on the number of +dimensions. ison_southern_women has 12 dimensions, and a +total inertia of 1.65. The top two dimensions (in terms of variance +explained) together account for 57% of this total inertia.

+

Is this good? I.e. is this a presentation of the data that is worth +interpreting? Well, if the inertia were spread evenly across these 12 +dimensions, (any) 2 dimensions would jointly account for about 17% of +the variance. 57% is about 3.4 times better than this. But this flatters +because inertia is never spread evenly (Jackson 1993). The broken +stick model offers a more demanding baseline, asking what two +dimensions would hold if the inertia were divided randomly rather than +evenly (here 1.3 times better):

+
##               ison_southern_women ison_adolescents ison_networkers
+## dimensions                  12.00              7.0           31.00
+## inertia_drawn                0.57              0.6            0.36
+## vs_even                      3.40              2.1            5.60
+## vs_random                    1.30              0.9            1.60
+

ison_adolescents looks the best summarised by two +dimensions of three datasets considered at 60%. However, it is a small +network with only seven dimensions to spread across, so two of them were +always going to hold a good deal. Against the harder baseline it scores +below 1, which is to say two dimensions hold less than dividing +the inertia at random would have given them. By comparison, +ison_networkers looks the worst at 36% and yet summarises +best: it has 31 dimensions, and the top two beat either baseline. Note +that these scores are not verdicts, but help gauge whether the two +dimensions presented are worth interpreting further. +graphr() applies the stricter of the two baselines for you, +noting at the console where two dimensions hold no more inertia than a +random division would have given them.

+

Since the two dimensions have different percentages here, we can see +where we should put the emphasis of our interpretation. Because the +first dimension holds twice as much, it suggests that what distinguishes +nodes most runs along the x-axis rather than the y-axis.

+

Two more things to note about correspondence analysis. First, while +the distances among nodes of the same mode are interpretable, distances +between nodes from different modes are not necessarily interpretable. +That is, a woman drawn near an event is not necessarily +an attendee of it. Only the distances within a mode can be read +this way: two women drawn together attended similar events, and two +events drawn together were attended by similar women. These plots are +often misread this way.

+

Second, some nodes are better represented by the top two dimensions +than others. A plot can hold most of the network’s inertia and still put +one particular node nowhere near where it belongs. This representation +is captured by a measure called cos2: how much of its position +the two dimensions drawn actually hold, from 0 to 1, where lower is +worse. A node the plane captures badly may be located near the centre of +the plot, not because it is average, but because there is nowhere else +to put it. graphr() names these nodes in the console when +it draws the layout, but you can recover the scores like so:

+
+
fit <- attr(layout_correspondence(ison_southern_women), "fit")
+round(sort(fit$cos2), 2)
+ +
+

For a directed network, each node has two profiles: who it sends ties +to, and who it receives them from. By default the layout reads a tie in +either direction, so that each node has one position; +direction = "out" and direction = "in" read +one profile or the other. For a signed network there is no +correspondence analysis at all, since the method divides by the mass of +each node and a negative tie has no such reading. +double = TRUE splits each tie into a positive and a +negative part, so that a node is placed by both who it likes and who it +dislikes.

+
+
+
+
+
+ +
+
+
+
+
+
+
+ +
+
+
+
+
+
+
+ +
+
+
+
+
+
+
+ +
+
+

Grid layouts

-

gif of a cartoon character energetically rearranging the living room furniture

Grid layouts arrange nodes based on some Cartesian coordinates. These can be useful for making sure all nodes’ labels are visible, but horizontal and vertical lines can overlap, making it difficult to @@ -1357,6 +1966,14 @@

Grid layouts

graphr(fict_lotr, snap = TRUE) + ggtitle("stress + snap"))
+
+
+
+
+
+ +
+

Manual layouts

@@ -1387,28 +2004,30 @@

Manual layouts

Going further: {autograph} also provides its own special-purpose layouts — -"configuration", "lineage", -"multilevel", "triad"/"quad", and -layouts that align nodes by partition — documented at -?layout_partition and friends. Several layouts take a +"configuration", "correspondence", +"levels", "matching", "scaling", +"valence", and the layered family — documented at +?layout_layered and friends. Several layouts take a layout-specific extra argument (passed through ...) to control how nodes are ordered: "concentric" a -membership, "multilevel" a level, -and "lineage" a rank — each a node attribute -name or a vector. See ?graphr for the full list.

+membership, "levels" a level, and +the layered layouts ranks — each a node attribute name or a +vector. See ?graphr for the full list.

In brief: Pass layout = to graphr() to choose among force-directed ("stress", "fr", -"kk"), layered ("hierarchy", -"railway", "alluvial"), circular +"kk"), layered ("layered", +"railway", "lineage"), circular ("concentric", "circle"), spectral -("eigen", "mds"), and grid layouts. -Force-directed layouts are illustrative — do not over-interpret -distances; spectral/MDS layouts place nodes by measured similarity; -layered layouts suit two-mode or hierarchical data. And since every -layout is just a table of coordinates, you can always compute one with +("eigen", "scaling", +"correspondence"), and grid layouts. Force-directed layouts +are illustrative — do not over-interpret distances; spectral/MDS layouts +place nodes by measured similarity, and "scaling" captions +the plot with how far that reading can be trusted; layered layouts suit +two-mode or hierarchical data. And since every layout is just a table of +coordinates, you can always compute one with ggraph::create_layout(), adjust it, and pass it back via graphr()’s x and y arguments.

@@ -1489,7 +2108,6 @@

Sets

Dynamics

-

gif of a hand flipping through a flipbook of animated stick figures

grapht() is another alternative to graphr(), this time rendering network changes over time as an animated gif. Longitudinal networks (with discrete waves) and dynamic @@ -1518,6 +2136,14 @@

Dynamics

{manynet} 2.2.2, any other name (say, year) works just as well — it only needs declaring via to_waves()’s attribute argument.

+
+
+
+
+
+ +
+

Going further: Animation constrains a few things that a static graph allows. @@ -1530,7 +2156,9 @@

Dynamics

curve on reciprocated ties, and self-loops are not drawn in animations. Labels, too, are placed at a fixed offset rather than repelled, and are hidden by default once a network has more than 30 nodes (pass -labels = TRUE to force them).

+labels = TRUE to force them, or select a few as in +graphr(), which is resolved once so the same nodes stay +named in every frame).

In brief: Combine @@ -1544,7 +2172,6 @@

Dynamics

Going further with ggraph

-

gif of Mr Bean taking the restoration of a painting into his own hands

For more flexibility with visualisations, {autograph} users are encouraged to use the excellent {ggraph} package. {ggraph} is built upon the venerable {ggplot2} @@ -1613,6 +2240,14 @@

Going further with ggraph

For more see David Schoch’s excellent resources on this.

+
+
+
+
+
+ +
+

In brief: Because graphr() returns a ggplot object, you can go a long way @@ -1665,7 +2300,6 @@

Plotting results

Exporting plots

-

gif of a maker declaring that the masterpiece is done and it is time to show the world

We can save the plots we have made by point-and-click by selecting ‘Save as PDF…’ from under the ‘Export’ dropdown menu in the plots panel tab of RStudio.

@@ -1674,7 +2308,7 @@

Exporting plots

the parameters at some point, this is also not too difficult. After running the (gg-based) plot you want to save, use ggsave() to save it to disk:

-
graphr(fict_lotr, node_color = "Race")
+
graphr(fict_lotr, node_colour = "Race")
 ggsave("lotr_race.pdf")
 ggsave("lotr_race.png", width = 9, height = 6, dpi = 300)

 
ggsave() infers the file type from the extension
@@ -1689,10 +2323,17 @@ 
Exporting plots

 differently: use gganimate::anim_save("my_animation.gif"),
 which works just like ggsave() but for the last animation
 rendered.

+

+

+

+

+

+
+

+

Summary

-

gif of an enthusiastic standing ovation and cries of bravo

Well done — you have completed the tutorial on visualising networks! Along the way, you have learned to use these functions:

@@ -1712,16 +2353,16 @@

Summary

- + - + - + @@ -1736,7 +2377,7 @@

Summary

- + @@ -1771,6 +2412,14 @@

Summary

graphs any manynet-compatible network with sensible defaults
graphr(..., node_color/node_shape/node_size/node_group)graphr(..., node_colour/node_shape/node_size/node_group) maps node attributes to aesthetics
graphr(..., edge_color/edge_size)graphr(..., edge_colour/edge_size) maps tie attributes to aesthetics
graphr(..., labels, label_repel, label_dist)controls node labellingchooses which nodes to label, and places the labels
graphr(..., layout, snap) returns a layout’s table of node coordinates for tweaking
graphr(..., edge_bundle, isolates)graphr(..., edge_bundle, backbone, isolates) tames large, dense, or disconnected networks
+
+
+
+
+
+ +
+

When you are ready, continue with the tutorials in the other {stocnet} packages — on network structure and centrality in {netrics}, and on diffusion and regression in @@ -1782,6 +2431,13 @@

Glossary

Here are some of the terms that we have covered in this tutorial:

+Backbone +
+
+The backbone of a network comprises the ties that carry more weight, or +hold more structure, than a null model local to their endpoints expects. +
+
Betweenness
@@ -1958,14 +2614,45 @@

Glossary

}) + + + - - + - + + - - + - + + - - + - + + - - + - + + - - + - + + - - + - + + - - + - + + - - + - + + - - + - + + - - + - + + - - + - + + - - + - - + + + + + + + - + + - - + - + + - - + + + + + + + + + + + - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - - - - + - + + - - + - + + - - + - + + - - + + + + + + - + + - - + + + + @@ -3402,13 +5095,50 @@

Glossary

+ + - + + - - + - + + - - + - + + - - + - + + + + + + - + + + + + + +

diff --git a/man-roxygen/param_ggraphlayouts.R b/man-roxygen/param_ggraphlayouts.R new file mode 100644 index 00000000..74a6a526 --- /dev/null +++ b/man-roxygen/param_ggraphlayouts.R @@ -0,0 +1,8 @@ +#' @param .data Some `{manynet}` compatible network data. +#' @param circular Should the layout be transformed into a radial +#' representation. Only possible for some layouts. Defaults to FALSE. +#' Required for `{ggraph}` compatibility. +#' @param times Maximum number of iterations, where appropriate. +#' Required for `{ggraph}` compatibility, and ignored by the layouts that +#' do not iterate. +#' @returns Returns a table of nodes' x and y coordinates. diff --git a/man/ag_call.Rd b/man/ag_call.Rd index 20172d3d..6e421079 100644 --- a/man/ag_call.Rd +++ b/man/ag_call.Rd @@ -1,8 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/theme_palettes.R +% Please edit documentation in R/theme_palette_get.R \name{ag_call} \alias{ag_call} \alias{ag_base} +\alias{ag_ink} +\alias{ag_missing} \alias{ag_highlight} \alias{ag_positive} \alias{ag_negative} @@ -14,6 +16,10 @@ \usage{ ag_base() +ag_ink() + +ag_missing() + ag_highlight() ag_positive() @@ -39,6 +45,18 @@ These functions assist in calling particular parts of a theme's palette. For example, \code{ag_base()} will return the current theme's base or background color, and \code{ag_highlight()} will return the color used in that theme to highlight one or more nodes, lines, or such. +\code{ag_ink()} returns the darker colour that theme writes with: +axis text, reference lines, and other chrome. +\code{ag_missing()} returns the neutral that theme sets aside for data that +should recede: missing values, isolates counted out of a drawing, +and any "other" remainder left when small categories are grouped down. +Keeping one colour for all three means a reader learns it once. +Keeping the two apart lets the base be light enough to stand away from +the highlight while the ink stays dark enough to read. +Where the ground changes under a theme -- the "print" medium forces +white, whatever the theme prefers -- \code{ag_ink()} falls back to black or +white rather than return an ink that cannot be read on it. +See \code{\link[=check_contrast]{check_contrast()}} and \code{\link[=stocnet_medium]{stocnet_medium()}}. Using palettes that are high contrast, aesthetically pleasing, and institutionally or thematically consistent is not without its challenges. @@ -56,15 +74,46 @@ those who are color-blind. These include the \href{https://CRAN.R-project.org/package=viridis}{viridis} palette, and the ColorBrewer palettes (included in the RColorBrewer package). -The default palettes in \code{{autograph}} are designed to be colour-blind -friendly, but users should always check that their visualisations serve -their intended audience. + +An institutional palette is not ours to change, but its order is. +Each theme's categorical palette is therefore reordered when the theme is +set, so that the first colours a plot draws on are those that stay +distinct under each type of colour blindness, and \code{ag_qualitative()} +takes those colours in order rather than interpolating between them. +Divergent palettes pair a warm pole with a cool one for the same reason. +Use \code{\link[=check_separation]{check_separation()}} to check how your own colours fare, +and \code{\link[=simulate_colorblind]{simulate_colorblind()}} to see them as a colour-blind viewer would. + +Two further questions are worth asking of a palette. +Whether its text can be read on what it sits on is a matter of contrast +rather than of hue, and \code{\link[=check_contrast]{check_contrast()}} scores it against the +thresholds of WCAG 2.1. +Whether it survives print is a matter of lightness alone, since a +greyscale device keeps the luminance of a colour and discards the rest; +\code{simulate_colorblind(type = "grey")} shows that view, and +\code{\link[=check_separation]{check_separation()}} reports the greyscale distances beside its own score. +Most institutional palettes separate by hue and so collapse in greyscale. +Where a figure has to print in black and white, use the "bw" theme, or +add a second channel such as \code{node_shape}. + +The "rainbow" theme is the exception, and is left in its own order. +Its point is fidelity to the spectrum of an observed rainbow, +which reordering would destroy, +so \code{ag_qualitative()} samples across its whole length instead. +A spectrum is not a colour-blind safe scheme: +its reds and greens are exactly the pair that red-green colour blindness +cannot separate. +Choose it where the order of the categories is itself meaningful, +and check the result with \code{\link[=check_separation]{check_separation()}}; +for categories with no order, another theme serves more readers. } \examples{ # Single colours from the currently active theme ag_base() +ag_ink() ag_highlight() +ag_missing() ag_positive() ag_negative() # Palettes of a requested length diff --git a/man/check_layout.Rd b/man/check_layout.Rd new file mode 100644 index 00000000..88b9b724 --- /dev/null +++ b/man/check_layout.Rd @@ -0,0 +1,128 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/graph_costs.R +\name{check_layout} +\alias{check_layout} +\alias{check_span} +\alias{check_offset} +\alias{check_stress} +\title{Checking how well a layout draws its ties} +\source{ +Kruskal, Joseph B. 1964. +"Multidimensional scaling by optimizing goodness of fit to a nonmetric +hypothesis", \emph{Psychometrika} 29(1): 1-27. +\doi{10.1007/BF02289565} +} +\usage{ +check_span(x) + +check_offset(x) + +check_stress(x) +} +\arguments{ +\item{x}{A plot, as \code{graphr()} returns.} +} +\value{ +\code{check_span()} returns one whole number for each tie, +with \code{total} and \code{mean} attributes holding the sum and the average. + +\code{check_offset()} returns one number between 0 and 1 for each tie, +with a \code{mean} attribute. + +\code{check_stress()} returns a single number of 0 or more, +with a \code{scale} attribute holding the factor the drawn distances were +scaled by, and a \code{pairs} attribute holding how many pairs were scored. +} +\description{ +These functions score a drawing rather than the network it draws, +so that a layout can be compared with another on the same network. + +\code{check_span()} reports how many rows of nodes each tie crosses. +A layered layout should send most ties to the next row down, +and a long tie is one that skips rows to get where it is going. + +\code{check_offset()} reports how far each tie travels sideways, +as a share of the width of the whole drawing. +A tie that drops straight down scores zero. + +\code{check_stress()} reports how far the distances drawn +depart from the distances through the network. +A layout that draws two nodes twice as far apart as two others +should be drawing a path twice as long. +} +\details{ +\code{check_span()} and \code{check_offset()} answer different questions, +and a layered layout needs both answered. +\code{check_span()} asks whether the rows were well chosen, +and \code{check_offset()} asks whether the nodes were well placed within them. +The "layered" layout minimises each in turn, and its \code{ranks} and +\code{alignment} arguments choose how. + +Which axis holds the rows is read from the plot, +as the axis on which the nodes take fewer distinct positions. +This is the y axis for "layered" and the x axis for "lineage", +so the same score can be compared across the two. +For a layout with no rows at all, such as "stress", +\code{check_span()} reports the distance in that axis' ranks, +which is not meaningful; the function is for layered layouts. + +\code{check_stress()} applies to any layout, since every layout draws its +nodes some distance apart, and the score is the share of the path +distances that the drawn distances get wrong. +It is Kruskal's stress-1, so 0 is a perfect drawing, +and Kruskal read 20\% as poor, 10\% as fair, 5\% as good, +and 2.5\% as excellent. +Those figures were set for psychometric data rather than for networks, +which are harder: most pairs of nodes in a small-world network sit +two or three steps apart, and a plane holds few such distances at once, +so a score near 30\% is ordinary and one near 5\% is rare. +A layout that never set out to draw path distances, +such as "layered", "circle" or "configuration", +scores poorly by design. + +The score belongs to the drawing rather than to the network, +which is what separates it from the share of distance variance +that \code{graphr()} reports beside it. +Draw one network two ways and the stress changes, since one drawing +holds its distances better than the other; +the share of variance does not, since two dimensions can hold +just as much of that network either way. +A network whose variance is held poorly sets a floor +that no layout gets under. + +The drawn distances are scaled to the path distances before they are +compared, since a layout may place its nodes on any scale it likes, +and the ties are counted unweighted, as \code{layout_scaling()} counts them. +Where a network is disconnected, the pairs with no path between them +are left out of the score. +} +\examples{ +thrones <- manynet::to_uniplex(manynet::fict_thrones, "parent") +# The default graph is drawn once here, since each check reads the same plot. +drawn <- graphr(thrones) +# How long are the ties of the default layout? +attr(check_span(drawn), "total") +# How straight are they? +attr(check_offset(drawn), "mean") +# Compare with the layers igraph would have chosen: +# attr(check_span(graphr(thrones, ranks = "compact")), "total") +# Which layout draws the path distances best? +check_stress(graphr(manynet::ison_southern_women, layout = "scaling")) +check_stress(graphr(manynet::ison_southern_women, layout = "circle")) +} +\seealso{ +Other mapping: +\code{\link{completion}}, +\code{\link[=layout_concentric]{layout_concentric()}}, +\code{\link[=layout_configuration]{layout_configuration()}}, +\code{\link[=layout_correspondence]{layout_correspondence()}}, +\code{\link[=layout_layered]{layout_layered()}}, +\code{\link[=layout_levels]{layout_levels()}}, +\code{\link[=layout_matching]{layout_matching()}}, +\code{\link[=layout_scaling]{layout_scaling()}}, +\code{\link[=layout_valence]{layout_valence()}}, +\code{\link{plot_graphr}}, +\code{\link{plot_graphs}}, +\code{\link{plot_grapht}} +} +\concept{mapping} diff --git a/man/completion.Rd b/man/completion.Rd new file mode 100644 index 00000000..e3a1a590 --- /dev/null +++ b/man/completion.Rd @@ -0,0 +1,71 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/graph_completion.R +\name{completion} +\alias{completion} +\alias{stocnet_completion} +\alias{set_completion} +\title{Completing argument values as you type} +\usage{ +stocnet_completion(activate, persist = FALSE) + +set_completion(activate, persist = FALSE) +} +\arguments{ +\item{activate}{Logical, by default TRUE. +If TRUE, completion of argument values is switched on. +If FALSE, RStudio's own completions are restored. +If missing, the current state is reported and nothing changes.} + +\item{persist}{Logical, by default FALSE. +If TRUE, the choice is remembered across sessions, +by writing it to the user's configuration directory +(see \code{tools::R_user_dir()}). +Nothing is written to disk unless this is set explicitly. +Use \code{stocnet_completion(persist = FALSE)} when activating +to forget a previously persisted choice.} +} +\value{ +Invisibly, TRUE where completion is now active and FALSE otherwise. +Called for the effect it has on the IDE. +} +\description{ +\code{graphr()} and its relatives take the names of node and tie variables, +layouts, and themes as strings, which means remembering what a network +holds. This offers those names to RStudio's completion system, so that +writing \verb{graphr(fict_lotr, node_color = "} and pressing Tab lists the +variables \code{fict_lotr} holds, \verb{layout = "} lists the layouts available, +and so on for every argument with a known set of values. + +This is off until it is asked for, because it works by replacing one of +RStudio's internal functions. That function is not part of a public +interface, so a future version of RStudio can change it. Nothing else about +completion changes: any line that is not one of these calls is passed to +RStudio untouched, as is any line this cannot make sense of. + +\code{stocnet_completion(FALSE)} puts RStudio's function back. +} +\examples{ +\dontrun{ +# In RStudio, switch completion on for this session: +stocnet_completion() +# Then type graphr(fict_lotr, node_color = " and press Tab. +# To switch it off again: +stocnet_completion(FALSE) +} +} +\seealso{ +Other mapping: +\code{\link{check_layout}}, +\code{\link[=layout_concentric]{layout_concentric()}}, +\code{\link[=layout_configuration]{layout_configuration()}}, +\code{\link[=layout_correspondence]{layout_correspondence()}}, +\code{\link[=layout_layered]{layout_layered()}}, +\code{\link[=layout_levels]{layout_levels()}}, +\code{\link[=layout_matching]{layout_matching()}}, +\code{\link[=layout_scaling]{layout_scaling()}}, +\code{\link[=layout_valence]{layout_valence()}}, +\code{\link{plot_graphr}}, +\code{\link{plot_graphs}}, +\code{\link{plot_grapht}} +} +\concept{mapping} diff --git a/man/count_pages.Rd b/man/count_pages.Rd new file mode 100644 index 00000000..111ca2ab --- /dev/null +++ b/man/count_pages.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot_diagnostics.R +\name{count_pages} +\alias{count_pages} +\title{How many pages a paged diagnostic figure has} +\usage{ +count_pages(x, nrow = 2, ncol = 2) +} +\arguments{ +\item{x}{a diagnostic object with one panel per term -- as returned by +\code{test_gof()}, \code{test_time()}, \code{diagnose_onset()}, or a fitted goldfish +model.} + +\item{nrow, ncol}{panels per page, matching what will be passed to \code{plot()}.} +} +\value{ +A single integer, at least 1. +} +\description{ +The page count of \code{\link[=plot]{plot()}} on a per-term diagnostic, derivable \strong{without +rendering} so a loop can write every page. + +A method that only discovers it is on the last page once it gets there +cannot be scripted, and scripting is the case this exists for: fits go to a +cluster, so a figure has to be producible with nobody at a screen to press +return. +} +\examples{ +count_pages(goldfish_gof) +} diff --git a/man/depth_first_recursive_search.Rd b/man/depth_first_recursive_search.Rd index 41b5175a..58432d3b 100644 --- a/man/depth_first_recursive_search.Rd +++ b/man/depth_first_recursive_search.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/layout_grid.R +% Please edit documentation in R/graph_snap.R \name{depth_first_recursive_search} \alias{depth_first_recursive_search} \title{Layouts for snapping layouts to a grid} diff --git a/man/figures/README-layout-comparison-1.png b/man/figures/README-layout-comparison-1.png deleted file mode 100644 index 13272a44..00000000 Binary files a/man/figures/README-layout-comparison-1.png and /dev/null differ diff --git a/man/figures/README-siena-ergm-gof-1.png b/man/figures/README-siena-ergm-gof-1.png deleted file mode 100644 index 11506530..00000000 Binary files a/man/figures/README-siena-ergm-gof-1.png and /dev/null differ diff --git a/man/figures/README-siena-ergm-gof-2.png b/man/figures/README-siena-ergm-gof-2.png deleted file mode 100644 index 2be39be8..00000000 Binary files a/man/figures/README-siena-ergm-gof-2.png and /dev/null differ diff --git a/man/figures/README-theme-opts-1.png b/man/figures/README-theme-opts-1.png deleted file mode 100644 index 1bf93465..00000000 Binary files a/man/figures/README-theme-opts-1.png and /dev/null differ diff --git a/man/figures/README-theme-opts-2.png b/man/figures/README-theme-opts-2.png deleted file mode 100644 index b3714823..00000000 Binary files a/man/figures/README-theme-opts-2.png and /dev/null differ diff --git a/man/figures/README-themeset-1.png b/man/figures/README-themeset-1.png deleted file mode 100644 index 8fb3c2a2..00000000 Binary files a/man/figures/README-themeset-1.png and /dev/null differ diff --git a/man/figures/README-themeset-2.png b/man/figures/README-themeset-2.png deleted file mode 100644 index 4eecd1ed..00000000 Binary files a/man/figures/README-themeset-2.png and /dev/null differ diff --git a/man/figures/logo-old.png b/man/figures/logo-old.png deleted file mode 100644 index bbaaaa01..00000000 Binary files a/man/figures/logo-old.png and /dev/null differ diff --git a/man/layout_concentric.Rd b/man/layout_concentric.Rd new file mode 100644 index 00000000..f4adacce --- /dev/null +++ b/man/layout_concentric.Rd @@ -0,0 +1,86 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/layout_concentric.R +\name{layout_concentric} +\alias{layout_concentric} +\alias{layout_tbl_graph_concentric} +\title{Concentric layout} +\source{ +Diego Diez, Andrew P. Hutchins and Diego Miranda-Saavedra. 2014. +"Systematic identification of transcriptional regulatory modules from +protein-protein interaction networks". +\emph{Nucleic Acids Research}, 42 (1) e6. +} +\usage{ +layout_concentric( + .data, + membership, + radius = NULL, + order.by = NULL, + circular = FALSE, + times = 1000 +) + +layout_tbl_graph_concentric( + .data, + membership, + radius = NULL, + order.by = NULL, + circular = FALSE, + times = 1000 +) +} +\arguments{ +\item{.data}{Some \code{{manynet}} compatible network data.} + +\item{membership}{A node attribute or a vector to draw concentric circles. +By default this is the two modes of a two-mode network.} + +\item{radius}{A vector of radii at which the concentric circles +should be located. +By default this is equal placement around an empty centre, +unless one (the core) is a single node, +in which case this node occupies the centre of the graph.} + +\item{order.by}{An attribute label indicating the (decreasing) order +for the nodes around the circles. +By default ordering is given by a bipartite placement that reduces +the number of edge crossings.} + +\item{circular}{Should the layout be transformed into a radial +representation. Only possible for some layouts. Defaults to FALSE. +Required for \code{{ggraph}} compatibility.} + +\item{times}{Maximum number of iterations, where appropriate. +Required for \code{{ggraph}} compatibility, and ignored by the layouts that +do not iterate.} +} +\value{ +Returns a table of nodes' x and y coordinates. +} +\description{ +The "concentric" layout places the nodes on one or more circles, +with each group of nodes on a circle of its own, +and the groups ordered around those circles +so that adjacent nodes are drawn close together. +Where one group holds a single node, that node occupies the centre. +} +\examples{ +#graphr(ison_southern_women, layout = "concentric", membership = "type", +# node_color = "type", node_size = 3) +} +\seealso{ +Other mapping: +\code{\link{check_layout}}, +\code{\link{completion}}, +\code{\link[=layout_configuration]{layout_configuration()}}, +\code{\link[=layout_correspondence]{layout_correspondence()}}, +\code{\link[=layout_layered]{layout_layered()}}, +\code{\link[=layout_levels]{layout_levels()}}, +\code{\link[=layout_matching]{layout_matching()}}, +\code{\link[=layout_scaling]{layout_scaling()}}, +\code{\link[=layout_valence]{layout_valence()}}, +\code{\link{plot_graphr}}, +\code{\link{plot_graphs}}, +\code{\link{plot_grapht}} +} +\concept{mapping} diff --git a/man/layout_configuration.Rd b/man/layout_configuration.Rd index 54e18020..fc8e86d0 100644 --- a/man/layout_configuration.Rd +++ b/man/layout_configuration.Rd @@ -4,15 +4,10 @@ \alias{layout_configuration} \alias{layout_tbl_graph_configuration} \alias{layout_dyad} -\alias{layout_tbl_graph_dyad} \alias{layout_triad} -\alias{layout_tbl_graph_triad} \alias{layout_tetrad} -\alias{layout_tbl_graph_tetrad} \alias{layout_pentad} -\alias{layout_tbl_graph_pentad} \alias{layout_hexad} -\alias{layout_tbl_graph_hexad} \title{Layout algorithms based on configurational positions} \usage{ layout_configuration(.data, circular = TRUE, times = 1) @@ -21,31 +16,27 @@ layout_tbl_graph_configuration(.data, circular = TRUE, times = 1) layout_dyad(.data, circular = TRUE, times = 1) -layout_tbl_graph_dyad(.data, circular = TRUE, times = 1) - layout_triad(.data, circular = TRUE, times = 1) -layout_tbl_graph_triad(.data, circular = TRUE, times = 1) - layout_tetrad(.data, circular = TRUE, times = 1) -layout_tbl_graph_tetrad(.data, circular = TRUE, times = 1) - layout_pentad(.data, circular = TRUE, times = 1) -layout_tbl_graph_pentad(.data, circular = TRUE, times = 1) - layout_hexad(.data, circular = TRUE, times = 1) - -layout_tbl_graph_hexad(.data, circular = TRUE, times = 1) } \arguments{ \item{.data}{Some \code{{manynet}} compatible network data.} -\item{circular}{Logical, required for \code{{ggraph}} compatibility, default TRUE.} +\item{circular}{Should the layout be transformed into a radial +representation. Only possible for some layouts. Defaults to FALSE. +Required for \code{{ggraph}} compatibility.} -\item{times}{Integer, how many times to run the algorithm. -Required by for \code{{ggraph}} compatibility, but not used here, so default = 1.} +\item{times}{Maximum number of iterations, where appropriate. +Required for \code{{ggraph}} compatibility, and ignored by the layouts that +do not iterate.} +} +\value{ +Returns a table of nodes' x and y coordinates. } \description{ Configurational layouts locate nodes at symmetric coordinates @@ -57,14 +48,20 @@ layout automatically. \examples{ # "configuration" picks the layout matching the number of nodes graphr(manynet::create_ring(4), layout = "configuration") -# or a specific configuration can be named -graphr(manynet::create_ring(3), layout = "triad") -# the layout functions can also be called directly for their coordinates +# the specific configurations are also available as functions layout_tetrad(manynet::create_ring(4)) } \seealso{ Other mapping: -\code{\link{layout_partition}}, +\code{\link{check_layout}}, +\code{\link{completion}}, +\code{\link[=layout_concentric]{layout_concentric()}}, +\code{\link[=layout_correspondence]{layout_correspondence()}}, +\code{\link[=layout_layered]{layout_layered()}}, +\code{\link[=layout_levels]{layout_levels()}}, +\code{\link[=layout_matching]{layout_matching()}}, +\code{\link[=layout_scaling]{layout_scaling()}}, +\code{\link[=layout_valence]{layout_valence()}}, \code{\link{plot_graphr}}, \code{\link{plot_graphs}}, \code{\link{plot_grapht}} diff --git a/man/layout_correspondence.Rd b/man/layout_correspondence.Rd new file mode 100644 index 00000000..7c5361fb --- /dev/null +++ b/man/layout_correspondence.Rd @@ -0,0 +1,172 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/layout_correspondence.R +\name{layout_correspondence} +\alias{layout_correspondence} +\alias{layout_tbl_graph_correspondence} +\title{Correspondence layout} +\source{ +Greenacre, Michael. 2017. +\emph{Correspondence Analysis in Practice}, 3rd ed. +Boca Raton: Chapman and Hall. +\doi{10.1201/9781315369983} + +Lorenzo-Seva, Urbano. 2011. +"Horn's parallel analysis for selecting the number of dimensions in +correspondence analysis", +\emph{Methodology} 7(3): 96-105. +\doi{10.1027/1614-2241/a000027} + +Constantine, A.G., and John C. Gower. 1978. +"Graphical representation of asymmetric matrices", +\emph{Journal of the Royal Statistical Society C} 27(3): 297-304. +\doi{10.2307/2347234} +} +\usage{ +layout_correspondence( + .data, + direction = c("all", "out", "in"), + double = FALSE, + circular = FALSE, + times = 1 +) + +layout_tbl_graph_correspondence( + .data, + direction = c("all", "out", "in"), + double = FALSE, + circular = FALSE, + times = 1 +) +} +\arguments{ +\item{.data}{Some \code{{manynet}} compatible network data.} + +\item{direction}{Which ties to read for a directed network, +as one of "all", "out", or "in". +By default this is "all", which reads a tie in either direction, +so that each node has one position. +"out" places each node by the ties it sends, +and "in" by the ties it receives. +This is ignored where the network is undirected or two-mode.} + +\item{double}{Whether to split each tie into a positive and a negative part, +so that a signed network can be drawn. +By default this is \code{FALSE}, and a signed network is not drawn, +since correspondence analysis is not defined for a negative tie.} + +\item{circular}{Should the layout be transformed into a radial +representation. Only possible for some layouts. Defaults to FALSE. +Required for \code{{ggraph}} compatibility.} + +\item{times}{Maximum number of iterations, where appropriate. +Required for \code{{ggraph}} compatibility, and ignored by the layouts that +do not iterate.} +} +\value{ +Returns a table of nodes' x and y coordinates. +} +\description{ +The "correspondence" layout places nodes by correspondence analysis, +so that two nodes are drawn together where they have similar ties. +Where the "scaling" layout reads the paths between nodes, +this one reads the profile of each node's ties, +and so two nodes with no tie between them can still be drawn together +if they are tied to the same others. + +This is the usual way to draw a two-mode network, +since correspondence analysis takes a rectangular table +and places its rows and its columns in one space. +Both modes are therefore drawn on one pair of axes. + +Like the "scaling" layout, the coordinates can be read, +and so this layout draws labelled axes at a fixed ratio. +Each axis is labelled with the share of the network's inertia +that the dimension holds. +} +\details{ +Correspondence analysis divides the ties of each node by how many ties +that node has, and so places nodes by the shape of their ties +rather than by how many they have. +The distance drawn is the chi-square distance between two such profiles. + +A two-mode network is read as its incidence matrix, +one row for each node of the first mode and one column for each of the +second. A one-mode network is read as its adjacency matrix instead, +as is a multimodal network that has ties within its modes as well as +between them, so that no tie is dropped. + +Tie weights are read as they are, since correspondence analysis was built +for counts and a weight counts in the same way. +A negative weight has no such reading, which is why a signed network +needs \code{double = TRUE}. That stacks the positive network and the negative +network side by side, doubling the width of the table, +so that a node is placed by both who it is tied to positively +and who it is tied to negatively. +A pair of nodes with no tie between them counts in neither half. +} +\section{Reading the plot}{ + +Two nodes of the same mode drawn together have similar ties. +A node drawn near the origin has a profile close to the average, +or is held poorly by the two dimensions drawn: these are not the same +thing, and \code{graphr()} names the nodes for which it is the second. + +A node of one mode drawn near a node of the other mode is \emph{not} +necessarily tied to it. +Only the distances within a mode can be read this way. + +Where a network runs along one strong gradient, +correspondence analysis draws it as an arch rather than as a line. +This is expected of the method, and the second dimension then repeats +the first rather than adding to it. + +Where a network is disconnected, the first dimensions merely separate its +components, and say little about the nodes within them. +} + +\section{Reading the inertia}{ + +The share of inertia a dimension holds is not a share of variance +explained, and does not have a fixed ceiling to be read against. +It is a share of however many dimensions the table has, +which \code{attr(x, "fit")$scree} reports in full. +Two dimensions of a table that has twelve start from a base of a sixth; +two of a table that has thirty start from a base of a fifteenth. +Compare the share drawn against that base rather than against 100\%, +and note that this can reverse the ranking the raw shares suggest. +Bear in mind that an even share is a lenient base, since inertia is +never spread evenly; the broken stick model asks what the dimensions +would hold if the inertia were divided at random, and is the harder test. +Neither is a standard statistic, and neither carries a threshold, +so read them as a check on the raw share rather than as a verdict. +\code{graphr()} says so at the console where two dimensions hold no more +than a random division of the inertia would give them. +To choose a number of dimensions properly, see Lorenzo-Seva (2011). + +These shares need no correction. +The Benzécri correction, and Greenacre's adjusted version of it, +exist because the indicator matrix that \emph{multiple} correspondence +analysis is run on invents dimensions that deflate every share. +This layout runs simple correspondence analysis on one two-way table, +which invents nothing, so the shares reported are already exact. +} + +\examples{ +graphr(manynet::ison_southern_women, layout = "correspondence") +} +\seealso{ +Other mapping: +\code{\link{check_layout}}, +\code{\link{completion}}, +\code{\link[=layout_concentric]{layout_concentric()}}, +\code{\link[=layout_configuration]{layout_configuration()}}, +\code{\link[=layout_layered]{layout_layered()}}, +\code{\link[=layout_levels]{layout_levels()}}, +\code{\link[=layout_matching]{layout_matching()}}, +\code{\link[=layout_scaling]{layout_scaling()}}, +\code{\link[=layout_valence]{layout_valence()}}, +\code{\link{plot_graphr}}, +\code{\link{plot_graphs}}, +\code{\link{plot_grapht}} +} +\concept{mapping} diff --git a/man/layout_deprecated.Rd b/man/layout_deprecated.Rd new file mode 100644 index 00000000..ba6ecba5 --- /dev/null +++ b/man/layout_deprecated.Rd @@ -0,0 +1,67 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/autograph-defunct.R +\name{layout_deprecated} +\alias{layout_deprecated} +\alias{layout_hierarchy} +\alias{layout_tbl_graph_hierarchy} +\alias{layout_alluvial} +\alias{layout_tbl_graph_alluvial} +\alias{layout_multilevel} +\alias{layout_tbl_graph_multilevel} +\alias{layout_tbl_graph_dyad} +\alias{layout_tbl_graph_triad} +\alias{layout_tbl_graph_tetrad} +\alias{layout_tbl_graph_pentad} +\alias{layout_tbl_graph_hexad} +\title{Deprecated layout names} +\usage{ +layout_hierarchy(.data, ...) + +layout_tbl_graph_hierarchy(.data, ...) + +layout_alluvial(.data, ...) + +layout_tbl_graph_alluvial(.data, ...) + +layout_multilevel(.data, ...) + +layout_tbl_graph_multilevel(.data, ...) + +layout_tbl_graph_dyad(.data, ...) + +layout_tbl_graph_triad(.data, ...) + +layout_tbl_graph_tetrad(.data, ...) + +layout_tbl_graph_pentad(.data, ...) + +layout_tbl_graph_hexad(.data, ...) +} +\arguments{ +\item{.data}{Some \code{{manynet}} compatible network data.} + +\item{...}{Arguments passed on to the replacement layout.} +} +\value{ +Returns a table of nodes' x and y coordinates. +} +\description{ +Each of these draws what its replacement draws, after saying so. +They are kept so that a call naming the older layout still draws, +and will be removed. +\itemize{ +\item "hierarchy" is now "layered", which is what the layout does to a +two-mode network, where the two modes are two layers and neither is +above the other in any hierarchy. +\item "alluvial" is now "lineage". The name is held for a plot of changing +membership composition over time. +\item "multilevel" is now "levels", which \code{{graphlayouts}} does not also use. +\item "dyad", "triad", "tetrad", "pentad" and "hexad" are now all +"configuration", which already picks the one matching the number of +nodes. The functions of those names are not deprecated. +} + +Note that \code{.deprecated_layouts()} lists these, so that neither the +completions nor the functional audit offers a retired name. +} +\keyword{internal} diff --git a/man/layout_layered.Rd b/man/layout_layered.Rd index 29f270ec..85cdd9e0 100644 --- a/man/layout_layered.Rd +++ b/man/layout_layered.Rd @@ -3,31 +3,172 @@ \name{layout_layered} \alias{layout_layered} \alias{layout_tbl_graph_layered} -\title{Layered layout} +\alias{layout_lineage} +\alias{layout_tbl_graph_lineage} +\alias{layout_railway} +\alias{layout_tbl_graph_railway} +\alias{layout_ladder} +\alias{layout_tbl_graph_ladder} +\title{Layered layouts} \usage{ -layout_tbl_graph_layered(.data, center = NULL, circular = FALSE, times = 4) +layout_layered( + .data, + center = NULL, + ranks = c("tight", "generation", "compact"), + alignment = c("straight", "rungs"), + circular = FALSE, + times = 1000 +) + +layout_tbl_graph_layered( + .data, + center = NULL, + ranks = c("tight", "generation", "compact"), + alignment = c("straight", "rungs"), + circular = FALSE, + times = 1000 +) + +layout_lineage( + .data, + ranks = c("tight", "generation", "compact"), + alignment = c("straight", "rungs"), + circular = FALSE, + times = 1000, + rank = NULL +) + +layout_tbl_graph_lineage( + .data, + ranks = c("tight", "generation", "compact"), + alignment = c("straight", "rungs"), + circular = FALSE, + times = 1000, + rank = NULL +) + +layout_railway( + .data, + ranks = c("tight", "generation", "compact"), + circular = FALSE, + times = 1000 +) + +layout_tbl_graph_railway( + .data, + ranks = c("tight", "generation", "compact"), + circular = FALSE, + times = 1000 +) + +layout_ladder( + .data, + ranks = c("tight", "generation", "compact"), + circular = FALSE, + times = 1000 +) + +layout_tbl_graph_ladder( + .data, + ranks = c("tight", "generation", "compact"), + circular = FALSE, + times = 1000 +) } \arguments{ \item{.data}{Some \code{{manynet}} compatible network data.} -\item{center, circular}{Extra parameters required for \code{{tidygraph}} -compatibility.} +\item{center}{Further split a "layered" layout by +declaring the "center" argument as the "events", "actors", +or by declaring a node name. +Defaults to NULL.} + +\item{ranks}{How the layers are assigned: +"tight" (the default) chooses the layers that make the total tie length +as short as possible, while still pointing every tie down at least one +layer; +"generation" ranks each node by its distance from a root, so that a layer +is a generation, at the cost of some longer ties; +"compact" asks \code{igraph::layout_with_sugiyama()} for the layers. +The first two need an acyclic network, and fall back to "compact" where +the network is not. +Ignored for a two-mode network, whose layers are its modes. + +A node attribute can be given here instead, either as the name of a +numeric node attribute or as a numeric vector as long as the network has +nodes. Then the layers are those values, and nodes are placed along that +axis in proportion to them rather than at even steps, so that a network +of dated nodes is drawn as a timeline. +The values run in the same direction as the layers the engine works out: +down the page in a "layered" or "railway" layout, and left to right in a +"lineage" or "ladder" layout, so that the smallest value comes first.} -\item{times}{Integer of sweeps that the algorithm will pass through. -By default 4.} +\item{alignment}{How each layer is spread out: +"straight" (the default) draws the ties as close to straight as the +ordering allows, which groups the nodes that belong together; +"rungs" gives every layer the same integer spacing, so that the nodes +line up across the layers.} + +\item{circular}{Should the layout be transformed into a radial +representation. Only possible for some layouts. Defaults to FALSE. +Required for \code{{ggraph}} compatibility.} + +\item{times}{Maximum number of iterations, where appropriate. +Required for \code{{ggraph}} compatibility, and ignored by the layouts that +do not iterate.} + +\item{rank}{Deprecated. Use \code{ranks} instead, which now takes a node +attribute as well as a method.} } \value{ -Returns a table of coordinates. +Returns a table of nodes' x and y coordinates. } \description{ -Layered layout +These algorithms assign each node to a layer, which becomes one axis, +and a position within that layer, which becomes the other. +They are recommended for use with \code{graphr()} or \code{{ggraph}}, +and suit two-mode networks and directed acyclic networks. + +The four layouts are one engine drawn four ways, +and differ only in which axis carries the layers +and in how each layer is spread out:\tabular{lll}{ + \tab Layers stacked flat \tab Layers standing up \cr + \code{alignment = "straight"} \tab "layered" \tab "lineage" \cr + \code{alignment = "rungs"} \tab "railway" \tab "ladder" \cr } -\examples{ -ties <- data.frame( - from = c("A", "A", "B", "C", "D", "F", "F", "E"), - to = c("B", "C", "D", "E", "E", "E", "G", "G"), - stringsAsFactors = FALSE) -coords <- layout_tbl_graph_layered(ties, times = 6) -coords + +That is, the "layered" layout places the first node set along the bottom +and the second node set along the top, +sequenced and spaced as necessary to minimise tie overlap. +The "lineage" layout is the same layout with the axes exchanged, +so that successive layers run left to right rather than bottom to top. +The "railway" and "ladder" layouts are "layered" and "lineage" +with every layer given the same spacing, +so that the nodes line up across the layers +like the rails and rungs the names describe. +} +\examples{ +#graphr(ison_southern_women, layout = "layered", center = "events", +# node_color = "type", node_size = 3) +#graphr(ison_southern_women, layout = "lineage") +# ison_adolescents |> +# mutate(year = rep(c(1985, 1990, 1995, 2000), times = 2)) |> +# graphr(layout = "lineage", ranks = "year") +} +\seealso{ +Other mapping: +\code{\link{check_layout}}, +\code{\link{completion}}, +\code{\link[=layout_concentric]{layout_concentric()}}, +\code{\link[=layout_configuration]{layout_configuration()}}, +\code{\link[=layout_correspondence]{layout_correspondence()}}, +\code{\link[=layout_levels]{layout_levels()}}, +\code{\link[=layout_matching]{layout_matching()}}, +\code{\link[=layout_scaling]{layout_scaling()}}, +\code{\link[=layout_valence]{layout_valence()}}, +\code{\link{plot_graphr}}, +\code{\link{plot_graphs}}, +\code{\link{plot_grapht}} } +\concept{mapping} diff --git a/man/layout_levels.Rd b/man/layout_levels.Rd new file mode 100644 index 00000000..6882b6ec --- /dev/null +++ b/man/layout_levels.Rd @@ -0,0 +1,96 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/layout_levels.R +\name{layout_levels} +\alias{layout_levels} +\alias{layout_tbl_graph_levels} +\title{Levels layout} +\usage{ +layout_levels( + .data, + level, + method = c("all", "separate", "fix1", "fix2"), + circular = FALSE, + times = 1, + alpha = 25, + beta = 45, + FUN1 = graphlayouts::layout_with_stress, + FUN2 = graphlayouts::layout_with_stress +) + +layout_tbl_graph_levels( + .data, + level, + method = c("all", "separate", "fix1", "fix2"), + circular = FALSE, + times = 1, + alpha = 25, + beta = 45, + FUN1 = graphlayouts::layout_with_stress, + FUN2 = graphlayouts::layout_with_stress +) +} +\arguments{ +\item{.data}{Some \code{{manynet}} compatible network data.} + +\item{level}{A node attribute or a vector to hierarchically order levels. +By default the levels are those already recorded in a "lvl" node attribute, +as \code{manynet::to_multilevel()} writes, or, for a two-mode network, +the two modes, with whichever mode holds the ties within itself +placed at the first level.} + +\item{method}{How the levels should be laid out: +"all" (the default) lays every level out at once, +"separate" lays each level out independently, +and "fix1" and "fix2" lay out the first or second level respectively +and derive the other from it. +Note that all but "all" require ties within the levels they lay out.} + +\item{circular}{Should the layout be transformed into a radial +representation. Only possible for some layouts. Defaults to FALSE. +Required for \code{{ggraph}} compatibility.} + +\item{times}{Maximum number of iterations, where appropriate. +Required for \code{{ggraph}} compatibility, and ignored by the layouts that +do not iterate.} + +\item{alpha, beta}{The angles, in degrees, at which the levels +are projected onto the plane.} + +\item{FUN1, FUN2}{The layout functions used for the first and second levels +respectively by the "separate", "fix1" and "fix2" methods. +By default both are \code{graphlayouts::layout_with_stress()}.} +} +\value{ +Returns a table of nodes' x and y coordinates. +} +\description{ +The "levels" layout draws each level of a multilevel network +as a plane of its own, projected at an angle, +with the ties within each level drawn on its plane +and the ties between levels drawn between them. + +Note that \code{{graphlayouts}} offers a layout of the same idea under the +name "multilevel". This one is named for its \code{level} argument. +} +\examples{ +# fict_marvel interlocks a one-mode layer of ties among its characters +# with a two-mode layer of their affiliations, so it is laid out this way +# by default; the levels need not be named. +graphr(manynet::fict_marvel, labels = FALSE) +} +\seealso{ +Other mapping: +\code{\link{check_layout}}, +\code{\link{completion}}, +\code{\link[=layout_concentric]{layout_concentric()}}, +\code{\link[=layout_configuration]{layout_configuration()}}, +\code{\link[=layout_correspondence]{layout_correspondence()}}, +\code{\link[=layout_layered]{layout_layered()}}, +\code{\link[=layout_matching]{layout_matching()}}, +\code{\link[=layout_scaling]{layout_scaling()}}, +\code{\link[=layout_valence]{layout_valence()}}, +\code{\link{plot_graphr}}, +\code{\link{plot_graphs}}, +\code{\link{plot_grapht}} +} +\concept{mapping} diff --git a/man/layout_matching.Rd b/man/layout_matching.Rd index aa7587c7..4f7e8d4b 100644 --- a/man/layout_matching.Rd +++ b/man/layout_matching.Rd @@ -5,13 +5,22 @@ \alias{layout_tbl_graph_matching} \title{Matching layout} \usage{ +layout_matching(.data, center = NULL, circular = FALSE, times = 1) + layout_tbl_graph_matching(.data, center = NULL, circular = FALSE, times = 1) } \arguments{ \item{.data}{Some \code{{manynet}} compatible network data.} -\item{center, circular, times}{Extra parameters required for \code{{tidygraph}} -compatibility.} +\item{center}{Required for \code{{ggraph}} compatibility, and not used here.} + +\item{circular}{Should the layout be transformed into a radial +representation. Only possible for some layouts. Defaults to FALSE. +Required for \code{{ggraph}} compatibility.} + +\item{times}{Maximum number of iterations, where appropriate. +Required for \code{{ggraph}} compatibility, and ignored by the layouts that +do not iterate.} } \value{ Returns a table of nodes' x and y coordinates. @@ -20,3 +29,19 @@ Returns a table of nodes' x and y coordinates. This layout works to position nodes opposite their matching nodes. See \code{manynet::to_matching()} for more details on the matching procedure. } +\seealso{ +Other mapping: +\code{\link{check_layout}}, +\code{\link{completion}}, +\code{\link[=layout_concentric]{layout_concentric()}}, +\code{\link[=layout_configuration]{layout_configuration()}}, +\code{\link[=layout_correspondence]{layout_correspondence()}}, +\code{\link[=layout_layered]{layout_layered()}}, +\code{\link[=layout_levels]{layout_levels()}}, +\code{\link[=layout_scaling]{layout_scaling()}}, +\code{\link[=layout_valence]{layout_valence()}}, +\code{\link{plot_graphr}}, +\code{\link{plot_graphs}}, +\code{\link{plot_grapht}} +} +\concept{mapping} diff --git a/man/layout_partition.Rd b/man/layout_partition.Rd deleted file mode 100644 index ae8e0599..00000000 --- a/man/layout_partition.Rd +++ /dev/null @@ -1,146 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/layout_partition.R -\name{layout_partition} -\alias{layout_partition} -\alias{layout_concentric} -\alias{layout_tbl_graph_concentric} -\alias{layout_multilevel} -\alias{layout_tbl_graph_multilevel} -\alias{layout_lineage} -\alias{layout_tbl_graph_lineage} -\alias{layout_hierarchy} -\alias{layout_tbl_graph_hierarchy} -\alias{layout_alluvial} -\alias{layout_tbl_graph_alluvial} -\alias{layout_railway} -\alias{layout_tbl_graph_railway} -\alias{layout_ladder} -\alias{layout_tbl_graph_ladder} -\title{Layout algorithms based on bi- or other partitions} -\source{ -Diego Diez, Andrew P. Hutchins and Diego Miranda-Saavedra. 2014. -"Systematic identification of transcriptional regulatory modules from -protein-protein interaction networks". -\emph{Nucleic Acids Research}, 42 (1) e6. -} -\usage{ -layout_concentric( - .data, - membership, - radius = NULL, - order.by = NULL, - circular = FALSE, - times = 1000 -) - -layout_tbl_graph_concentric( - .data, - membership, - radius = NULL, - order.by = NULL, - circular = FALSE, - times = 1000 -) - -layout_multilevel(.data, level, circular = FALSE) - -layout_tbl_graph_multilevel(.data, level, circular = FALSE) - -layout_lineage(.data, rank, circular = FALSE) - -layout_tbl_graph_lineage(.data, rank, circular = FALSE) - -layout_hierarchy(.data, center = NULL, circular = FALSE, times = 1000) - -layout_tbl_graph_hierarchy( - .data, - center = NULL, - circular = FALSE, - times = 1000 -) - -layout_alluvial(.data, circular = FALSE, times = 1000) - -layout_tbl_graph_alluvial(.data, circular = FALSE, times = 1000) - -layout_railway(.data, circular = FALSE, times = 1000) - -layout_tbl_graph_railway(.data, circular = FALSE, times = 1000) - -layout_ladder(.data, circular = FALSE, times = 1000) - -layout_tbl_graph_ladder(.data, circular = FALSE, times = 1000) -} -\arguments{ -\item{.data}{Some \code{{manynet}} compatible network data.} - -\item{membership}{A node attribute or a vector to draw concentric circles -for "concentric" layout.} - -\item{radius}{A vector of radii at which the concentric circles -should be located for "concentric" layout. -By default this is equal placement around an empty centre, -unless one (the core) is a single node, -in which case this node occupies the centre of the graph.} - -\item{order.by}{An attribute label indicating the (decreasing) order -for the nodes around the circles for "concentric" layout. -By default ordering is given by a bipartite placement that reduces -the number of edge crossings.} - -\item{circular}{Should the layout be transformed into a radial representation. -Only possible for some layouts. Defaults to FALSE.} - -\item{times}{Maximum number of iterations, where appropriate} - -\item{level}{A node attribute or a vector to hierarchically order levels for -"multilevel" layout.} - -\item{rank}{A numerical node attribute to place nodes in Y axis -according to values for "lineage" layout.} - -\item{center}{Further split "hierarchical" layouts by -declaring the "center" argument as the "events", "actors", -or by declaring a node name in hierarchy layout. -Defaults to NULL.} -} -\description{ -These algorithms layout networks based on two or more partitions, -and are recommended for use with \code{graphr()} or \code{{ggraph}}. - -The "hierarchy" layout layers the first node set along the bottom, -and the second node set along the top, -sequenced and spaced as necessary to minimise edge overlap. -The "alluvial" layout is similar to "hierarchy", -but places successive layers horizontally rather than vertically. -The "railway" layout is similar to "hierarchy", -but nodes are aligned across the layers. -The "ladder" layout is similar to "railway", -but places successive layers horizontally rather than vertically. -The "concentric" layout places a "hierarchy" layout -around a circle, with successive layers appearing as concentric circles. -The "multilevel" layout places successive layers as multiple levels. -The "lineage" layout ranks nodes in Y axis according to values. -} -\examples{ -#graphr(ison_southern_women, layout = "concentric", membership = "type", -# node_color = "type", node_size = 3) -#graphr(ison_lotr, layout = "multilevel", -# node_color = "Race", level = "Race", node_size = 3) -# ison_adolescents \%>\% -# mutate(year = rep(c(1985, 1990, 1995, 2000), times = 2), -# cut = node_is_cutpoint(ison_adolescents)) \%>\% -# graphr(layout = "lineage", rank = "year", node_color = "cut", -# node_size = migraph::node_degree(ison_adolescents)*10) -#graphr(ison_southern_women, layout = "hierarchy", center = "events", -# node_color = "type", node_size = 3) -#graphr(ison_southern_women, layout = "alluvial") -} -\seealso{ -Other mapping: -\code{\link[=layout_configuration]{layout_configuration()}}, -\code{\link{plot_graphr}}, -\code{\link{plot_graphs}}, -\code{\link{plot_grapht}} -} -\concept{mapping} diff --git a/man/layout_scaling.Rd b/man/layout_scaling.Rd new file mode 100644 index 00000000..14cc66e8 --- /dev/null +++ b/man/layout_scaling.Rd @@ -0,0 +1,95 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/layout_scaling.R +\name{layout_scaling} +\alias{layout_scaling} +\alias{layout_tbl_graph_scaling} +\title{Scaling layout} +\source{ +Kruskal, Joseph B. 1964. +"Multidimensional scaling by optimizing goodness of fit to a nonmetric +hypothesis", \emph{Psychometrika} 29(1): 1-27. +\doi{10.1007/BF02289565} + +Brandes, Ulrik, and Christian Pich. 2007. +"Eigensolver methods for progressive multidimensional scaling of large +data", in \emph{Graph Drawing}, 42-53. +\doi{10.1007/978-3-540-70904-6_6} +} +\usage{ +layout_scaling(.data, pivots = NULL, circular = FALSE, times = 1) + +layout_tbl_graph_scaling(.data, pivots = NULL, circular = FALSE, times = 1) +} +\arguments{ +\item{.data}{Some \code{{manynet}} compatible network data.} + +\item{pivots}{The number of nodes to approximate the scaling from. +By default this is \code{NULL}, which uses every node where the network has +no more than a hundred, and samples the nodes otherwise. +Giving a number selects the pivot algorithm whatever the size of network.} + +\item{circular}{Should the layout be transformed into a radial +representation. Only possible for some layouts. Defaults to FALSE. +Required for \code{{ggraph}} compatibility.} + +\item{times}{Maximum number of iterations, where appropriate. +Required for \code{{ggraph}} compatibility, and ignored by the layouts that +do not iterate.} +} +\value{ +Returns a table of nodes' x and y coordinates. +} +\description{ +The "scaling" layout places nodes by multidimensional scaling, +so that the distance drawn between two nodes approximates +the number of steps of the shortest path between them. +Unlike a force-directed layout, then, the coordinates can be read, +and so this layout draws labelled axes, +at a fixed ratio so that the two axes share one scale. + +Which algorithm is used depends on the size of the network. +Up to a hundred nodes, classical multidimensional scaling is used, +as \code{igraph::layout_with_mds()} offers it. +Above that, or where \code{pivots} is given, +pivot multidimensional scaling is used instead, +as \code{graphlayouts::layout_with_pmds()} offers it, +which approximates the same solution from a sample of the nodes +and is much the faster for a large network. +Note that "mds" and "pmds" remain available as layouts in their own right, +though "pmds" then requires its own \code{pivots}. + +Two dimensions rarely hold every path distance of a network at once, +so \code{graphr()} captions the plot with how well this one does: +see \code{check_stress()} for how to read the score. +} +\details{ +The distances scaled are those of the unweighted network, +that is, the number of ties on the shortest path between two nodes. +Tie weights are ignored, since the interpretation of a drawn distance +is then the same whatever the network, +and since a signed network has no shortest paths to speak of. + +Where a network is disconnected, there is no path between its components, +and so no distance to scale. Each component is laid out and the components +are then placed beside one another, and the fit is reported over +the pairs of nodes that a path does connect. +} +\examples{ +graphr(manynet::ison_southern_women, layout = "scaling") +} +\seealso{ +Other mapping: +\code{\link{check_layout}}, +\code{\link{completion}}, +\code{\link[=layout_concentric]{layout_concentric()}}, +\code{\link[=layout_configuration]{layout_configuration()}}, +\code{\link[=layout_correspondence]{layout_correspondence()}}, +\code{\link[=layout_layered]{layout_layered()}}, +\code{\link[=layout_levels]{layout_levels()}}, +\code{\link[=layout_matching]{layout_matching()}}, +\code{\link[=layout_valence]{layout_valence()}}, +\code{\link{plot_graphr}}, +\code{\link{plot_graphs}}, +\code{\link{plot_grapht}} +} +\concept{mapping} diff --git a/man/layout_valence.Rd b/man/layout_valence.Rd index d24e0a63..de3edec2 100644 --- a/man/layout_valence.Rd +++ b/man/layout_valence.Rd @@ -3,7 +3,7 @@ \name{layout_valence} \alias{layout_valence} \alias{layout_tbl_graph_valence} -\title{Valence-based layout} +\title{Valence layout} \usage{ layout_valence( .data, @@ -26,11 +26,15 @@ layout_tbl_graph_valence( \arguments{ \item{.data}{Some \code{{manynet}} compatible network data.} -\item{times}{Integer of sweeps that the algorithm will pass through. -By default 4.} +\item{times}{Maximum number of iterations, where appropriate. +Required for \code{{ggraph}} compatibility, and ignored by the layouts that +do not iterate.} -\item{center, circular}{Extra parameters required for \code{{tidygraph}} -compatibility.} +\item{center}{Required for \code{{ggraph}} compatibility, and not used here.} + +\item{circular}{Should the layout be transformed into a radial +representation. Only possible for some layouts. Defaults to FALSE. +Required for \code{{ggraph}} compatibility.} \item{repulsion_coef}{Coefficient for global repulsion force. Default is 1.} @@ -38,8 +42,12 @@ Default is 1.} \item{attraction_coef}{Coefficient for edge-based attraction/repulsion force. Default is 0.05.} } +\value{ +Returns a table of nodes' x and y coordinates. +} \description{ -Valence-based layout +The "valence" layout places the nodes of a signed network so that +positively tied nodes are drawn together and negatively tied nodes apart. } \examples{ edges <- data.frame( @@ -50,3 +58,19 @@ edges <- data.frame( ) graphr(as_igraph(edges), layout="valence") } +\seealso{ +Other mapping: +\code{\link{check_layout}}, +\code{\link{completion}}, +\code{\link[=layout_concentric]{layout_concentric()}}, +\code{\link[=layout_configuration]{layout_configuration()}}, +\code{\link[=layout_correspondence]{layout_correspondence()}}, +\code{\link[=layout_layered]{layout_layered()}}, +\code{\link[=layout_levels]{layout_levels()}}, +\code{\link[=layout_matching]{layout_matching()}}, +\code{\link[=layout_scaling]{layout_scaling()}}, +\code{\link{plot_graphr}}, +\code{\link{plot_graphs}}, +\code{\link{plot_grapht}} +} +\concept{mapping} diff --git a/man/list_fonts.Rd b/man/list_fonts.Rd new file mode 100644 index 00000000..62ace0b1 --- /dev/null +++ b/man/list_fonts.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/theme_fonts.R +\name{list_fonts} +\alias{list_fonts} +\title{Listing the fonts available to R} +\usage{ +list_fonts(pattern = NULL) +} +\arguments{ +\item{pattern}{Optionally, a string with which to filter the font families +returned, matched without regard to case. +For example, \code{list_fonts("sans")} returns every family whose name includes +"sans".} +} +\value{ +A vector of font family names. +} +\description{ +\code{list_fonts()} reports the font families that R can currently see, +which is what a theme's preferred fonts are matched against. +A font that is installed on the system but missing from this list is not +available to R yet; +see the Fonts section of \link{theme_set} for how to make it so. +} +\examples{ +head(list_fonts()) +} +\seealso{ +Other themes: +\code{\link{theme_colorblind}}, +\code{\link{theme_medium}}, +\code{\link{theme_set}} +} +\concept{themes} diff --git a/man/made_earlier.Rd b/man/made_earlier.Rd index 890446c9..d493c904 100644 --- a/man/made_earlier.Rd +++ b/man/made_earlier.Rd @@ -15,6 +15,11 @@ \alias{ergm_gof} \alias{goldfish_outliers} \alias{goldfish_changepoints} +\alias{goldfish_margins} +\alias{goldfish_gof} +\alias{goldfish_time} +\alias{goldfish_onset} +\alias{goldfish_fit} \title{Precooked results for demonstrating plotting} \format{ An object of class \code{netlm} of length 15. @@ -37,9 +42,19 @@ An object of class \code{gof.stats.monan} of length 2. An object of class \code{gof.ergm} (inherits from \code{gof}) of length 30. -An object of class \code{outliers.goldfish} (inherits from \code{dependent.goldfish}, \code{data.frame}) with 12 rows and 7 columns. +An object of class \code{goldfishOutliers} (inherits from \code{tbl_df}, \code{tbl}, \code{data.frame}) with 439 rows and 11 columns. -An object of class \code{changepoints.goldfish} (inherits from \code{list}) of length 2. +An object of class \code{goldfishChangepoints} (inherits from \code{tbl_df}, \code{tbl}, \code{data.frame}) with 115 rows and 10 columns. + +An object of class \code{goldfishMargins} (inherits from \code{tbl_df}, \code{tbl}, \code{data.frame}) with 308 rows and 5 columns. + +An object of class \code{goldfishGOF} (inherits from \code{list}) of length 3. + +An object of class \code{goldfishTimeTest} (inherits from \code{list}) of length 3. + +An object of class \code{goldfishOnset} (inherits from \code{list}) of length 3. + +An object of class \code{goldfishFit} of length 31. } \usage{ data(res_migraph_reg) @@ -65,6 +80,16 @@ data(ergm_gof) data(goldfish_outliers) data(goldfish_changepoints) + +data(goldfish_margins) + +data(goldfish_gof) + +data(goldfish_time) + +data(goldfish_onset) + +data(goldfish_fit) } \description{ These are all pre-cooked results objects, saved here to save time in diff --git a/man/plot_adequacy.Rd b/man/plot_adequacy.Rd index 1ff0162e..d0719d24 100644 --- a/man/plot_adequacy.Rd +++ b/man/plot_adequacy.Rd @@ -1,32 +1,180 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot_diagnostics.R -\name{plot_adequacy} -\alias{plot_adequacy} +% Please edit documentation in R/autograph-defunct.R, R/plot_diagnostics.R +\name{plot.diagnose_outliers} +\alias{plot.diagnose_outliers} \alias{plot.outliers.goldfish} +\alias{plot.diagnose_changepoints} \alias{plot.changepoints.goldfish} +\alias{plot_adequacy} +\alias{plot.goldfishOutliers} +\alias{plot.goldfishChangepoints} +\alias{plot.goldfishMargins} +\alias{plot.goldfishGOF} +\alias{plot.goldfishTimeTest} +\alias{plot.goldfishOnset} \title{Plotting adequacy diagnostics} \usage{ +\method{plot}{diagnose_outliers}(x, ...) + \method{plot}{outliers.goldfish}(x, ...) +\method{plot}{diagnose_changepoints}(x, ...) + \method{plot}{changepoints.goldfish}(x, ...) + +\method{plot}{goldfishOutliers}(x, ...) + +\method{plot}{goldfishChangepoints}(x, ...) + +\method{plot}{goldfishMargins}(x, ..., top = 25) + +\method{plot}{goldfishGOF}(x, ..., level = 0.95, page = NULL, nrow = 2, ncol = 2) + +\method{plot}{goldfishTimeTest}(x, ..., page = NULL, nrow = 2, ncol = 2) + +\method{plot}{goldfishOnset}( + x, + ..., + view = c("both", "path", "accrual"), + tolerance_band = TRUE, + page = NULL, + nrow = 2, + ncol = 2 +) } \arguments{ -\item{x}{An object of class "outliers.goldfish" or "changepoints.goldfish".} +\item{x}{An object of class \code{goldfishOutliers}, \code{goldfishChangepoints}, +\code{goldfishMargins}, \code{goldfishGOF}, \code{goldfishTimeTest} or \code{goldfishOnset}, +as returned by \code{diagnose_outliers()}, \code{diagnose_changepoints()}, +\code{margin_table()}, \code{test_gof()}, \code{test_time()} and \code{diagnose_onset()} in +goldfish.} \item{...}{Additional plotting parameters, currently unused.} + +\item{top}{The number of actors to draw, those furthest from the reference.} + +\item{level}{The confidence level of the reference bands, defaulting to +0.95. The band is the two-sided Kolmogorov quantile of the supremum of a +Brownian bridge, which is the reference the event-clock p-value uses.} + +\item{page}{Which page to draw, for the per-term figures. \code{NULL} (the +default) draws every panel in one figure, exactly as before. A number +draws that page alone; a number past the last is an error naming the +count. Use \code{\link[=count_pages]{count_pages()}} to learn the count without rendering, so a loop +can write every page with nobody at a screen.} + +\item{nrow, ncol}{Panels per page when \code{page} is given.} + +\item{view}{Which panels to draw: \code{"both"} (default), or \code{"path"} or +\code{"accrual"} alone, which is the escape hatch when a model has too many +coefficients for a composed figure to stay readable.} + +\item{tolerance_band}{Whether to draw each coefficient's stabilization +band, the \verb{+/- tolerance * std_error} corridor the path had to re-enter.} } \value{ -The function shows a line plot tracing the statistics obtained at -each simulation step, as well as a density plot showing the distribution -of the statistics over the entire simulation. +A ggplot object. } \description{ -These plotting methods are for diagnosing the adequacy of model specification, -such as those used in goldfish. +These plotting methods are for diagnosing the adequacy of model +specification, such as those used in goldfish. These plots are useful for identifying whether there might be significant -outliers affecting the results or significant time heterogeneity. +outliers affecting the results, whether there is significant time +heterogeneity, and which actors' activity the model does not reproduce. +} +\details{ +\code{plot.diagnose_outliers()}, \code{plot.outliers.goldfish()}, +\code{plot.diagnose_changepoints()} and \code{plot.changepoints.goldfish()} are +aliases for \code{plot.goldfishOutliers()} and \code{plot.goldfishChangepoints()}, +kept so that an object carrying one of the older class names plots as +before. Each reads the columns the current methods read. They will be +removed. + +goldfish emits these objects plot-ready. Each is a tibble carrying the +diagnostic metadata contract --- which function produced it, which model +and sub-model it came from, and the arguments that shape how it is read +--- so these methods take their series, their labels and their reference +lines from the object rather than inferring them from the columns that +happen to be present. + +The \code{.series} column is the series the diagnostic actually analysed: the +per-interval log-likelihood by default, and the selected term's own +series when the diagnostic was called with \verb{effect =}. It is \code{NA} on the +intervals that took no part, which on a rate or REM fit are the +right-censored ones. + +\code{plot.goldfishMargins()} shows each actor's observed activity against what +the model expected of them. Which comparison it draws follows the scales +the fit's model class defines, which the object records: where a +compensator is defined (the exact-time sub-models) the difference +\code{observed - expected_count} is the per-actor martingale residual, read +against zero; on the multinomial sub-models, which have no exposure-time +term and so no compensator, the ratio \code{observed / expected_probability} +is a calibration ratio, read against one. + +These are descriptives rather than per-actor tests: the differences are +plug-in quantities and are negatively correlated across actors. Read the +plot as a map screening for unmodelled actor heterogeneity. + +A node set large enough to make one row per actor unreadable is the +ordinary case, so only the \code{top} actors furthest from the reference are +drawn, and the subtitle says how many were left out. Actors are ranked by +their largest deviation over the roles they appear in, so an actor kept +for one margin keeps the other beside it. Pass \code{top = Inf} for all of +them. + +\code{plot.goldfishGOF()} draws each effect's standardized cumulative score +process against the Brownian-bridge bands its p-value was read from. At +the maximum the per-event scores sum to zero, so every path starts and +ends at zero; under a correctly specified model it is a bridge, and a path +that wanders outside the bands is an effect whose contribution is +concentrated somewhere in the sequence. + +The x axis is the object's own process-time axis, taken from its \code{u} +column and labelled by the \code{clock} it records. This is not a +presentational detail: the bands are valid on whichever clock produced the +process, and re-deriving an event-index axis here would draw the path on +one clock and the reference on another. On the information clock the +spacing of the steps is itself the diagnostic --- a path that crosses most +of the axis in a few steps is an effect whose information arrives late. + +\code{plot.goldfishTimeTest()} draws the scaled Schoenfeld residuals of each +tested effect against time, with a smooth and the fitted estimate as the +reference. A residual scatter is centred on the coefficient the model +estimated; a smooth that drifts away from that line over the sequence is +the coefficient failing to be constant, which is what the test's p-value +states formally. + +Under \code{method = "periods"} the intervals are coloured by their period, so +the regimes the test compared are visible against the same scatter. + +\code{plot.goldfishOnset()} composes two panels: each coefficient's +leave-the-first-\code{m}-events-out path, and the share of the model's +information those events delivered. + +Both panels are \strong{windowed on the excursion rather than the sequence}, +because the full range is mostly bridge tail --- the path returns to the +estimate by construction, so drawing all of it squashes the part being +read into a few percent of the axis. Each coefficient gets its own window +and its own x scale, since coefficients settle at very different points +and a window shared across facets re-creates the squashing it exists to +prevent. A coefficient whose path never left its band takes the full +range, there being no excursion to window on. + +The accrual panel is drawn full-range with the onset window shaded, and +carries the proportional diagonal \code{y = x / n}. Without the diagonal a +monotone curve from 0 to 1 says nothing: the signal is the \emph{departure} +from proportional, which is what makes an opening segment that carries +little information visible. + +Coefficients held fixed through \code{offset()} are not drawn. Their path is a +flat line at the imposed value by construction. } \examples{ plot(goldfish_outliers) plot(goldfish_changepoints) +plot(goldfish_margins) +plot(goldfish_gof) +plot(goldfish_time) +plot(goldfish_onset) } diff --git a/man/plot_goldfish_fit.Rd b/man/plot_goldfish_fit.Rd new file mode 100644 index 00000000..100446e0 --- /dev/null +++ b/man/plot_goldfish_fit.Rd @@ -0,0 +1,61 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/autograph-defunct.R, R/plot_diagnostics.R +\name{plot.result.goldfish} +\alias{plot.result.goldfish} +\alias{plot_goldfish_fit} +\alias{plot.goldfishFit} +\title{Plotting a goldfish model fit at a glance} +\usage{ +\method{plot}{result.goldfish}(x, ..., effects = 4) + +\method{plot}{goldfishFit}(x, ..., effects = 4) +} +\arguments{ +\item{x}{A fitted model of class \code{goldfishFit}.} + +\item{...}{Additional plotting parameters, currently unused.} + +\item{effects}{The number of effects to draw in the Schoenfeld panel.} +} +\value{ +A patchwork composition of the available panels. +} +\description{ +One call, four diagnostic panels: whether any interval is badly fitted, +whether any coefficient drifts, whether each effect's contribution is +spread over the sequence, and whether the waiting times are what the model +says they are. +} +\details{ +\code{plot.result.goldfish()} is an alias for \code{plot.goldfishFit()}, kept so that +a fit from a goldfish that still stamps the old class name plots as before. +It will be removed. + +Everything is drawn from what the \strong{fit already stores} --- no evaluation +pass and no preprocessed statistics --- so the figure costs a plot and not +a re-fit. The consequence is that a panel needing a primitive the fit did +not store is \strong{left out} rather than erroring: which panels appear is +itself a readout of what was requested at estimation. + +\describe{ +\item{deviance}{the per-interval log-likelihood with outlying intervals +marked. Needs the \code{"loglik"} primitive.} +\item{scaled Schoenfeld}{a smooth per effect against the fitted estimate, +flat under a constant coefficient. Needs \code{"scores"} on a multinomial +sub-model, and \code{"conditional_scores"} on an exact-time one, where the +score carries an exposure term the Schoenfeld residual does not.} +\item{cumulative score}{each effect's standardized process against its +Brownian-bridge band. Needs \code{"scores"}.} +\item{waiting times}{the Cox-Snell residuals against the unit +exponential they follow under the model. Exact-time sub-models only: +an ordinal likelihood conditions the timing away, so there is no +waiting time to check.} +} + +The Schoenfeld panel is capped at the \code{effects} most worth looking at, +ranked by their cumulative-score statistic, since a model with a dozen +terms makes a facet grid unreadable at overview size. +} +\examples{ +plot(goldfish_fit) +} diff --git a/man/plot_graphr.Rd b/man/plot_graphr.Rd index cf5088d7..ddf59f36 100644 --- a/man/plot_graphr.Rd +++ b/man/plot_graphr.Rd @@ -20,6 +20,8 @@ graphr( label_dist = NULL, label_repel = TRUE, edge_bundle = FALSE, + backbone = NULL, + .shared = NULL, ..., node_colour, edge_colour @@ -29,31 +31,79 @@ graphr( \item{.data}{A manynet-consistent object.} \item{layout}{An igraph, ggraph, or manynet layout algorithm. -If not declared, defaults to "triad" for networks with 3 nodes, -"quad" for networks with 4 nodes, -"stress" for all other one mode networks, -or "hierarchy" for two mode networks. -For "hierarchy" layout, one can further split graph by +If not declared, defaults to "configuration" for networks of up to +six nodes, "levels" for connected multilevel networks, +"layered" for other two mode networks, +and "stress" for all other networks. +For "layered" layout, one can further split graph by declaring the "center" argument as the "events", "actors", or by declaring a node name. For "concentric" layout algorithm please declare the "membership" as an extra argument. The "membership" argument expects either a quoted node attribute present in data or vector with the same length as nodes to draw concentric circles. -For "multilevel" layout algorithm please declare the "level" +For "levels" layout algorithm one may declare the "level" as extra argument. The "level" argument expects either a quoted node attribute present in data or vector with the same length as nodes to hierarchically order categories. -If "level" is missing, function will look for 'lvl' node attribute in data. -The "lineage" layout ranks nodes in Y axis according to values. -For "lineage" layout algorithm please declare the "rank" -as extra argument. -The "rank" argument expects either a quoted node attribute present -in data or vector with the same length as nodes.} +If "level" is missing, the levels are taken from a 'lvl' node attribute +where there is one, or else from the two modes of a two mode network. +The layered layouts ("layered", "lineage", "railway" and "ladder") +accept a "ranks" argument, which takes either one of the methods named +at \code{?layout_layered} or a numeric node attribute to lay the layers out by, +as a quoted attribute name or a vector with one value for each node. +The "scaling" layout places the nodes by multidimensional scaling, +so that the distance between two nodes approximates the number of steps +between them. Since those coordinates can be read, this layout is drawn +with labelled axes on one scale, and captioned with how well two +dimensions hold the distances; see \code{?layout_scaling} and \code{check_stress()}. +Note that those axes carry distances rather than named dimensions: +the drawing can be turned or mirrored without fitting the network +any better or any worse. +The "correspondence" layout places the nodes by correspondence analysis, +so that two nodes with similar ties are drawn together, +whether or not they are tied to each other. +It is the usual way to draw a two mode network, since it places both +modes against the same pair of axes, and it accepts a "direction" +argument for a directed network and a "double" argument for a signed +one; see \code{?layout_correspondence}. +Each axis names the share of the network's inertia that it holds.} + +\item{labels}{Which nodes to label, if the network is labelled. +\code{TRUE} (the default) labels every node and \code{FALSE} none of them, +but a label for every node of a large network hides the network behind +them, so a \emph{selection} of the nodes can be given instead: +\itemize{ +\item a number, e.g. \code{labels = 5}, labels the nodes within the top five ranks +by degree. Note that this is a depth of ranks rather than a count of +nodes: nodes tied at the cut are labelled together, so more than five +labels may appear. +\item a measure to rank by, e.g. \code{labels = "betweenness"}, labels just the +node or nodes that measure singles out. \code{"degree"}, \code{"betweenness"}, +\code{"cutpoints"} (every node the mark flags) and \code{"random"} +(a small random sample) are available. +The two can be combined by naming the number, +as in \code{labels = c(betweenness = 5)}. +\item the name of a logical node attribute, e.g. \code{labels = "is_broker"}, +labels the nodes it marks. +\item a logical vector, one value per node, e.g. +\code{labels = netrics::node_is_cutpoint(net)}; +or the names or positions of the nodes to label, +e.g. \code{labels = c("Alice", "Betty")}. +} -\item{labels}{Logical, whether to print node names -as labels if present.} +Where a length-one string could mean more than one of these, +a node attribute is preferred to a measure, and a measure to a node name. +A single number is always read as a depth of ranks rather than as one +node's position, so a lone node is best named, as in \code{labels = "Alice"}. +For networks of more than 30 nodes, \code{labels} defaults to a selection +rather than to every node; pass \code{labels = TRUE} for all of them. +Ranking nodes uses the \code{{netrics}} package, which is suggested rather than +required: without it installed, an automatic selection falls back to a +random sample. +Two-mode and multilevel networks are ranked within each mode or level, +so that every level is labelled and not just the densest.} \item{node_color, node_colour}{Node variable to be used for coloring the nodes. It is easiest if this is added as a node attribute to @@ -77,7 +127,16 @@ It is easiest if this is added as a hull over groups before plotting. Group variables should have a minimum of 3 nodes, if less, number groups will be reduced by -merging categories with lower counts into one called "other".} +merging categories with lower counts into one called "other". +A membership vector can also be given here. +Where nodes belong to several groups at once, as they can to several +cliques, give a membership matrix instead: one row for each node, +one column for each group, and a one wherever the node belongs to +the group. One hull is then drawn for each column, and the hulls +overlap where the groups do. +A measure that returns such a matrix, such as +\code{netrics::node_x_clique()}, can be named without its network, +which is taken to be the network being drawn.} \item{edge_color, edge_colour}{Tie variable to be used for coloring the nodes. It is easiest if this is added as an edge or tie attribute @@ -100,7 +159,12 @@ If the default layout ("stress") is used, we recommend that the "legend" option is used to avoid isolates crowding out the giant component.} -\item{snap}{Logical scalar, whether the layout should be snapped to a grid.} +\item{snap}{Logical scalar, whether the layout should be snapped to a grid. +Where the network repeats a structure, as a lattice does, the two steps it +repeats are mapped onto the axes, which draws it as a rectangle of rows and +columns. Where it does not, each node moves to the nearest vacant grid +point. Layouts that already carry meaning in their coordinates, such as +"layered" or "scaling", are left as they are.} \item{label_dist}{Numeric scalar, in points (pt), controlling the extra gap left between labels and node borders -- similar to \code{igraph}'s @@ -112,14 +176,18 @@ or to a larger value (e.g. \code{15}) for more spacing. Only used when \code{labels = TRUE} and \code{label_repel = TRUE} (as the padding passed to the repel algorithm) or \code{label_repel = FALSE} (as a fixed nudge away from the node, in the layouts where this makes -sense, e.g. "circle"/"concentric", "bipartite"/"railway", "alluvial").} +sense, e.g. "circle"/"concentric", "railway", "lineage").} \item{label_repel}{Logical scalar, whether labels should be repelled away from each other and from nodes using \code{ggrepel} (via \code{ggraph}'s \code{repel} argument). Defaults to \code{TRUE}. Set to \code{FALSE} to place labels at a fixed offset (see \code{label_dist}) without the (sometimes slow, and non-deterministic between runs for -some layouts) repelling algorithm.} +some layouts) repelling algorithm. +The layered layouts ("layered", "lineage", "railway" and "ladder") +place each node in a layer, which is where the reader looks for it, +so a repelled label there would say less about which node it labels +than a fixed offset does. They ignore this argument and always offset.} \item{edge_bundle}{Edge bundling, off by default (\code{FALSE}). When \code{TRUE} (or equivalently \code{"force"}), edges are bundled together using ggraph's @@ -132,6 +200,33 @@ when a network has enough edges; for directed networks arrowheads are retained, but the slight reciprocal-tie curvature used for unbundled edges does not apply.} +\item{backbone}{How to treat the network's backbone: the ties that a local +null model keeps, because they carry more weight, or sit in more +triangles, than chance alone would put there. +Where a backbone is used, those ties are drawn as the shortest, so that +the layout pulls apart the groups they hold together, and every tie is +still drawn, with the ties the filter does not keep faded well back. +This is what to reach for when a network is dense enough to draw as a +hairball. +By default (\code{NULL}) this is decided by the network: a network of at least +50 nodes and a mean degree of at least 8 is drawn this way, and reported. +\code{FALSE} draws every tie alike, and \code{TRUE} asks for a backbone whatever the +network's size. +One of \code{manynet}'s filters can be named instead: "disparity", "lans", +"noise", "mlf", or "simmelian". Where none is named, \code{manynet} uses "lans" +for a weighted network and "simmelian" for an unweighted one. +A number between 0 and 1 sets the threshold instead of the filter: +a smaller number keeps fewer ties. +Only the layouts that read tie lengths -- "stress" (the default), "fr", +"drl" and "kk" -- are laid out this way. Every other layout, including +those that already carry meaning in their coordinates such as "layered" +or "scaling", keeps its coordinates and only fades its ties. +Requires \code{manynet} 2.3.0 or later, and does not apply to signed networks.} + +\item{.shared}{Internal. A list of the aesthetic ranges and categories found +across a list of networks, which \code{graphs()} uses to draw and label each of +its panels against the same scales. Not intended to be set by hand.} + \item{...}{Extra arguments to pass on to the layout algorithm, if necessary.} } \value{ @@ -164,20 +259,33 @@ try \code{run_tute("Visualisation")}. } \examples{ graphr(ison_adolescents) -ison_adolescents \%>\% +ison_adolescents |> mutate(color = rep(c("introvert","extrovert"), times = 4), - size = ifelse(netrics::node_is_cutpoint(ison_adolescents), 6, 3)) \%>\% - mutate_ties(ecolor = rep(c("friends", "acquaintances"), times = 5)) \%>\% + size = ifelse(netrics::node_is_cutpoint(ison_adolescents), 6, 3)) |> + mutate_ties(ecolor = rep(c("friends", "acquaintances"), times = 5)) |> graphr(node_color = "color", node_size = "size", edge_size = 1.5, edge_color = "ecolor") graphr(ison_southern_women, labels = TRUE, label_dist = 10) graphr(ison_southern_women, labels = TRUE, label_repel = FALSE) +# Label a selection of the nodes rather than all of them +graphr(ison_southern_women, labels = 2) +graphr(ison_southern_women, labels = "betweenness") +graphr(ison_adolescents, labels = c("Alice", "Betty")) graphr(manynet::generate_random(40, 0.1), edge_bundle = TRUE) +graphr(manynet::generate_random(80, 0.2), backbone = TRUE) } \seealso{ Other mapping: +\code{\link{check_layout}}, +\code{\link{completion}}, +\code{\link[=layout_concentric]{layout_concentric()}}, \code{\link[=layout_configuration]{layout_configuration()}}, -\code{\link{layout_partition}}, +\code{\link[=layout_correspondence]{layout_correspondence()}}, +\code{\link[=layout_layered]{layout_layered()}}, +\code{\link[=layout_levels]{layout_levels()}}, +\code{\link[=layout_matching]{layout_matching()}}, +\code{\link[=layout_scaling]{layout_scaling()}}, +\code{\link[=layout_valence]{layout_valence()}}, \code{\link{plot_graphs}}, \code{\link{plot_grapht}} } diff --git a/man/plot_graphs.Rd b/man/plot_graphs.Rd index c260d4e0..c339c891 100644 --- a/man/plot_graphs.Rd +++ b/man/plot_graphs.Rd @@ -61,8 +61,16 @@ or a mix, "both", of them. } \seealso{ Other mapping: +\code{\link{check_layout}}, +\code{\link{completion}}, +\code{\link[=layout_concentric]{layout_concentric()}}, \code{\link[=layout_configuration]{layout_configuration()}}, -\code{\link{layout_partition}}, +\code{\link[=layout_correspondence]{layout_correspondence()}}, +\code{\link[=layout_layered]{layout_layered()}}, +\code{\link[=layout_levels]{layout_levels()}}, +\code{\link[=layout_matching]{layout_matching()}}, +\code{\link[=layout_scaling]{layout_scaling()}}, +\code{\link[=layout_valence]{layout_valence()}}, \code{\link{plot_graphr}}, \code{\link{plot_grapht}} } diff --git a/man/plot_grapht.Rd b/man/plot_grapht.Rd index ce63df6c..3772a617 100644 --- a/man/plot_grapht.Rd +++ b/man/plot_grapht.Rd @@ -45,31 +45,79 @@ It can also be a diffusion model result from e.g. \code{manynet::play_diffusion()}.} \item{layout}{An igraph, ggraph, or manynet layout algorithm. -If not declared, defaults to "triad" for networks with 3 nodes, -"quad" for networks with 4 nodes, -"stress" for all other one mode networks, -or "hierarchy" for two mode networks. -For "hierarchy" layout, one can further split graph by +If not declared, defaults to "configuration" for networks of up to +six nodes, "levels" for connected multilevel networks, +"layered" for other two mode networks, +and "stress" for all other networks. +For "layered" layout, one can further split graph by declaring the "center" argument as the "events", "actors", or by declaring a node name. For "concentric" layout algorithm please declare the "membership" as an extra argument. The "membership" argument expects either a quoted node attribute present in data or vector with the same length as nodes to draw concentric circles. -For "multilevel" layout algorithm please declare the "level" +For "levels" layout algorithm one may declare the "level" as extra argument. The "level" argument expects either a quoted node attribute present in data or vector with the same length as nodes to hierarchically order categories. -If "level" is missing, function will look for 'lvl' node attribute in data. -The "lineage" layout ranks nodes in Y axis according to values. -For "lineage" layout algorithm please declare the "rank" -as extra argument. -The "rank" argument expects either a quoted node attribute present -in data or vector with the same length as nodes.} +If "level" is missing, the levels are taken from a 'lvl' node attribute +where there is one, or else from the two modes of a two mode network. +The layered layouts ("layered", "lineage", "railway" and "ladder") +accept a "ranks" argument, which takes either one of the methods named +at \code{?layout_layered} or a numeric node attribute to lay the layers out by, +as a quoted attribute name or a vector with one value for each node. +The "scaling" layout places the nodes by multidimensional scaling, +so that the distance between two nodes approximates the number of steps +between them. Since those coordinates can be read, this layout is drawn +with labelled axes on one scale, and captioned with how well two +dimensions hold the distances; see \code{?layout_scaling} and \code{check_stress()}. +Note that those axes carry distances rather than named dimensions: +the drawing can be turned or mirrored without fitting the network +any better or any worse. +The "correspondence" layout places the nodes by correspondence analysis, +so that two nodes with similar ties are drawn together, +whether or not they are tied to each other. +It is the usual way to draw a two mode network, since it places both +modes against the same pair of axes, and it accepts a "direction" +argument for a directed network and a "double" argument for a signed +one; see \code{?layout_correspondence}. +Each axis names the share of the network's inertia that it holds.} + +\item{labels}{Which nodes to label, if the network is labelled. +\code{TRUE} (the default) labels every node and \code{FALSE} none of them, +but a label for every node of a large network hides the network behind +them, so a \emph{selection} of the nodes can be given instead: +\itemize{ +\item a number, e.g. \code{labels = 5}, labels the nodes within the top five ranks +by degree. Note that this is a depth of ranks rather than a count of +nodes: nodes tied at the cut are labelled together, so more than five +labels may appear. +\item a measure to rank by, e.g. \code{labels = "betweenness"}, labels just the +node or nodes that measure singles out. \code{"degree"}, \code{"betweenness"}, +\code{"cutpoints"} (every node the mark flags) and \code{"random"} +(a small random sample) are available. +The two can be combined by naming the number, +as in \code{labels = c(betweenness = 5)}. +\item the name of a logical node attribute, e.g. \code{labels = "is_broker"}, +labels the nodes it marks. +\item a logical vector, one value per node, e.g. +\code{labels = netrics::node_is_cutpoint(net)}; +or the names or positions of the nodes to label, +e.g. \code{labels = c("Alice", "Betty")}. +} -\item{labels}{Logical, whether to print node names -as labels if present.} +Where a length-one string could mean more than one of these, +a node attribute is preferred to a measure, and a measure to a node name. +A single number is always read as a depth of ranks rather than as one +node's position, so a lone node is best named, as in \code{labels = "Alice"}. +For networks of more than 30 nodes, \code{labels} defaults to a selection +rather than to every node; pass \code{labels = TRUE} for all of them. +Ranking nodes uses the \code{{netrics}} package, which is suggested rather than +required: without it installed, an automatic selection falls back to a +random sample. +Two-mode and multilevel networks are ranked within each mode or level, +so that every level is labelled and not just the densest.} \item{node_color, node_colour}{Node variable to be used for coloring the nodes. It is easiest if this is added as a node attribute to @@ -124,14 +172,18 @@ or to a larger value (e.g. \code{15}) for more spacing. Only used when \code{labels = TRUE} and \code{label_repel = TRUE} (as the padding passed to the repel algorithm) or \code{label_repel = FALSE} (as a fixed nudge away from the node, in the layouts where this makes -sense, e.g. "circle"/"concentric", "bipartite"/"railway", "alluvial").} +sense, e.g. "circle"/"concentric", "railway", "lineage").} \item{label_repel}{Logical scalar, whether labels should be repelled away from each other and from nodes using \code{ggrepel} (via \code{ggraph}'s \code{repel} argument). Defaults to \code{TRUE}. Set to \code{FALSE} to place labels at a fixed offset (see \code{label_dist}) without the (sometimes slow, and non-deterministic between runs for -some layouts) repelling algorithm.} +some layouts) repelling algorithm. +The layered layouts ("layered", "lineage", "railway" and "ladder") +place each node in a layer, which is where the reader looks for it, +so a repelled label there would say less about which node it labels +than a fixed offset does. They ignore this argument and always offset.} \item{keep_isolates}{Deprecated. Use \code{isolates = "keep"} or \code{isolates = "fade"} instead.} @@ -174,7 +226,7 @@ When another \code{layout} is requested, a single static layout is computed on the aggregate (union of waves) network instead, so that positions remain constant. Unlike \code{graphr()}, \code{grapht()} uses this dynamic stress layout by default -even for two-mode networks (rather than a hierarchy layout, which would +even for two-mode networks (rather than a layered layout, which would collapse many nodes onto a line); the two modes remain distinguishable by node shape. For networks with more than 30 nodes, node labels are suppressed by @@ -206,9 +258,19 @@ across animation frames), so \code{label_repel} here instead toggles a fixed offset nudging labels away from their nodes, and \code{label_dist} scales the size of that nudge rather than being used as repel padding. +\code{labels} can select which nodes to label here too, and the selection is +resolved once over all the waves so that the same nodes stay labelled from +frame to frame. Unlike \code{graphr()}, though, animations of more than 30 nodes +default to no labels at all rather than to a selection of them. + Some further \code{graphr()} features are not available in animations: \code{node_group} hulls, edge bundling, curved arcs for reciprocated ties, and self-loops (loops are not drawn; a note is printed if present). +Note too that, where no \code{layout} is named, \code{grapht()} defaults to +the "stress" layout for every network rather than choosing one by +the network's shape as \code{graphr()} does, +so that nodes move smoothly from one wave to the next. +A layout named explicitly is still used, computed on the aggregate network. } \examples{ # A dynamic signed network of shifting European alliances 1872-1918, @@ -221,8 +283,16 @@ grapht(irps_wwi) } \seealso{ Other mapping: +\code{\link{check_layout}}, +\code{\link{completion}}, +\code{\link[=layout_concentric]{layout_concentric()}}, \code{\link[=layout_configuration]{layout_configuration()}}, -\code{\link{layout_partition}}, +\code{\link[=layout_correspondence]{layout_correspondence()}}, +\code{\link[=layout_layered]{layout_layered()}}, +\code{\link[=layout_levels]{layout_levels()}}, +\code{\link[=layout_matching]{layout_matching()}}, +\code{\link[=layout_scaling]{layout_scaling()}}, +\code{\link[=layout_valence]{layout_valence()}}, \code{\link{plot_graphr}}, \code{\link{plot_graphs}} } diff --git a/man/theme_colorblind.Rd b/man/theme_colorblind.Rd new file mode 100644 index 00000000..99610324 --- /dev/null +++ b/man/theme_colorblind.Rd @@ -0,0 +1,120 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/theme_colorblind.R +\name{theme_colorblind} +\alias{theme_colorblind} +\alias{simulate_colorblind} +\alias{check_separation} +\alias{check_contrast} +\title{Checking colours for colour blindness, print, and legibility} +\usage{ +simulate_colorblind( + colors, + type = c("deutan", "protan", "tritan", "grey", "normal"), + severity = 1 +) + +check_separation(colors, background = NULL) + +check_contrast(colors, background = NULL) +} +\arguments{ +\item{colors}{One or more colours, given as hexcodes or as names R knows.} + +\item{type}{The type of colour blindness to simulate: +"deutan" (green-blind, the most common), "protan" (red-blind), +"tritan" (blue-blind), "grey" for greyscale, as a photocopier renders it, +or "normal" for unaffected vision.} + +\item{severity}{How severe the colour blindness is, between 0 and 1. +By default 1, which is dichromacy. +A value between 0 and 1 is anomalous trichromacy. +Ignored for the "grey" and "normal" types.} + +\item{background}{Optionally, a colour to include in the comparison, +so that a colour too pale or too dark to be seen against it is not +counted as distinct. +By default the current theme's background is used.} +} +\value{ +\code{simulate_colorblind()} returns a vector of hexcodes as long as \code{colors}. + +\code{check_separation()} returns a square matrix of worst-case distances, +with the colours as its dimnames and a missing diagonal, +so that \code{min(x, na.rm = TRUE)} gives the closest pair. +A "grey" attribute holds the same matrix as seen in greyscale. + +\code{check_contrast()} returns a square matrix of WCAG contrast ratios, +shaped the same way. +} +\description{ +These functions report how a set of colours holds up for viewers with +colour vision deficiency (CVD), which affects about 8\% of men and 0.5\% +of women, and for readers who see the plot in greyscale or at a distance. + +\code{simulate_colorblind()} returns what a set of colours looks like to a viewer with +a given type of colour blindness, or in greyscale. +\code{check_separation()} scores how far apart colours are, taking the worst case +over normal vision and each type of colour blindness, +so that a palette is only credited for a difference that every viewer +can see. +\code{check_contrast()} scores whether text can be read on a ground. +} +\details{ +The three functions answer three different questions, +and a palette needs all three answered. +\code{check_separation()} asks whether two marks can be told apart, +\code{check_contrast()} asks whether text can be read on what it sits on, +and the "grey" simulation asks whether either survives a photocopier. + +Simulation uses the matrices of Machado, Oliveira and Fernandes (2009), +applied in linear RGB. +Those matrices are published for each severity of colour blindness; +\code{severity} interpolates between the identity and the full-severity matrix, +which approximates the published steps closely enough for a check. +Full severity is dichromacy (deuteranopia, protanopia, tritanopia); +a lower severity is anomalous trichromacy (deuteranomaly, protanomaly), +which is the more common condition. +Greyscale conversion takes the relative luminance of the colour, +the same quantity \code{check_contrast()} scores with. + +Distances are Euclidean distances in CIELAB space, the same measure +\code{\link[=match_color]{match_color()}} uses. +As a rule of thumb, a distance below 10 means two colours are easily +confused, 10 to 25 means they are separable but close, +and above 25 means they are comfortably distinct. +Ratios are those of WCAG 2.1, which asks for at least 4.5 for body text +and at least 3 for large text and for graphical objects. +} +\examples{ +simulate_colorblind(c("#d73027", "#4575b4"), "deutan") +# A milder deuteranomaly, and the same colours in greyscale +simulate_colorblind(c("#d73027", "#4575b4"), "deutan", severity = 0.5) +simulate_colorblind(c("#d73027", "#4575b4"), "grey") +# How well does the current theme's palette separate five categories? +check_separation(ag_qualitative(5)) +# The closest pair in it +min(check_separation(ag_qualitative(5)), na.rm = TRUE) +# And the closest pair once it is printed in greyscale +min(attr(check_separation(ag_qualitative(5)), "grey"), na.rm = TRUE) +# A red and a green that only look different to some viewers +check_separation(c("#B7352D", "#627313"))[1, 2] +# Can the current theme's ink be read on its ground? +check_contrast(ag_ink())[1, 2] +} +\references{ +Machado, Gustavo M., Manuel M. Oliveira, and Leandro A. F. Fernandes. 2009. +"A Physiologically-Based Model for Simulation of Color Vision Deficiency". +\emph{IEEE Transactions on Visualization and Computer Graphics} 15(6): 1291-98. +\doi{10.1109/TVCG.2009.113} + +World Wide Web Consortium. 2018. +\emph{Web Content Accessibility Guidelines (WCAG) 2.1}. +\url{https://www.w3.org/TR/WCAG21/} +} +\seealso{ +Other themes: +\code{\link[=list_fonts]{list_fonts()}}, +\code{\link{theme_medium}}, +\code{\link{theme_set}} +} +\concept{themes} diff --git a/man/theme_medium.Rd b/man/theme_medium.Rd new file mode 100644 index 00000000..8558e554 --- /dev/null +++ b/man/theme_medium.Rd @@ -0,0 +1,87 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/theme_medium.R +\name{theme_medium} +\alias{theme_medium} +\alias{stocnet_medium} +\alias{set_stocnet_medium} +\alias{ag_size} +\title{Setting the medium a plot is made for} +\usage{ +stocnet_medium(medium = NULL, persist = FALSE) + +set_stocnet_medium(medium = NULL, persist = FALSE) + +ag_size() +} +\arguments{ +\item{medium}{String naming a medium. +By default "screen". +The following media are currently available: +screen, presentation, mobile, print. +This string can be capitalised or not.} + +\item{persist}{Logical, by default FALSE. +If TRUE, the medium is remembered across sessions, +by writing it to the user's configuration directory +(see \code{tools::R_user_dir()}). +Nothing is written to disk unless this is set explicitly. +Use \code{stocnet_medium(persist = FALSE)} when setting a medium +to forget a previously persisted choice.} +} +\value{ +\code{stocnet_medium()} sets the medium to be used across all +stocnet packages. The medium is written to an option and held there. +\code{ag_size()} returns the multiplier the current medium applies to text +sizes, which is 1 unless the medium says otherwise. +} +\description{ +A theme says how a plot should look. +A medium says where it will be seen, which is a separate question: +the same institutional theme serves a figure worked on at a desk, +projected in a lecture theatre, printed in an article, +and read on a phone, but each of those wants a different size of text +and, in one case, a different ground. +\code{stocnet_medium()} sets the medium for all subsequent plots, +as \code{stocnet_theme()} sets the theme, and leaves the theme alone. + +If no medium is specified (i.e. the function is called without argument), +the current medium is reported. +The default medium is "screen". +} +\details{ +The media available are: +\itemize{ +\item "screen", the default, which draws as \code{{autograph}} always has. +\item "presentation", which enlarges text by half, for a figure read from +the back of a room. +\item "mobile", which enlarges text further, for a figure read in a narrow +column on a handheld screen. +Keep such a figure to one point, with few categories: +a legend of more than about seven keys, or more than about three panels +from \code{graphs()}, will not survive the width. +\item "print", which leaves text at its usual size but draws on white, +whatever ground the theme prefers. +A dark or tinted ground costs ink and is often not reproduced. +} + +The medium scales text, not marks. +Node sizes are relative to the layout they sit in, +so enlarging them without enlarging the layout would crowd it. +Where a figure needs larger nodes as well, set \code{node_size} in \code{\link[=graphr]{graphr()}}. + +The medium does not set the size of the file written. +Give \code{ggplot2::ggsave()} the width, height and resolution the medium +calls for as well. +} +\examples{ +stocnet_medium("presentation") +ag_size() +stocnet_medium("screen") +} +\seealso{ +Other themes: +\code{\link[=list_fonts]{list_fonts()}}, +\code{\link{theme_colorblind}}, +\code{\link{theme_set}} +} +\concept{themes} diff --git a/man/theme_set.Rd b/man/theme_set.Rd index 05e3837a..dab3515f 100644 --- a/man/theme_set.Rd +++ b/man/theme_set.Rd @@ -1,21 +1,29 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/theme_set.R +% Please edit documentation in R/theme_palette_set.R \name{theme_set} \alias{theme_set} \alias{stocnet_theme} \alias{set_stocnet_theme} \title{Setting a consistent theme for all plots} \usage{ -stocnet_theme(theme = NULL) +stocnet_theme(theme = NULL, persist = FALSE) -set_stocnet_theme(theme = NULL) +set_stocnet_theme(theme = NULL, persist = FALSE) } \arguments{ \item{theme}{String naming a theme. By default "default". The following themes are currently available: -default, bw, crisp, neon, iheid, ethz, uzh, rug, unibe, oxf, unige, cmu, iast, hwu, rainbow. +default, bw, crisp, neon, clay, iheid, ethz, uzh, rug, unibe, oxf, unige, cmu, iast, hwu, rainbow. This string can be capitalised or not.} + +\item{persist}{Logical, by default FALSE. +If TRUE, the theme is remembered across sessions, +by writing it to the user's configuration directory +(see \code{tools::R_user_dir()}). +Nothing is written to disk unless this is set explicitly. +Use \code{stocnet_theme(persist = FALSE)} when setting a theme +to forget a previously persisted choice.} } \value{ This function sets the theme and palette(s) to be used across all @@ -44,6 +52,9 @@ universities, including ETH Zurich, UZH, UNIBE, RUG, and Oxford. Other themes include "bw" for black and white, "crisp" for a high-contrast black and white theme, "neon" for a dark theme with neon highlights, and "rainbow" for a colourful theme. +The "clay" theme follows the palette and fonts used in the slides and +documents that Anthropic's Claude produces: an ivory background, +a slate ink base, and a clay orange highlight. Most themes are designed to be colour-blind safe. } \section{Fonts}{ @@ -52,9 +63,39 @@ Some themes also set a preferred font for use in plots, if available on the system (a check is performed). In some cases, this includes a vector of options to try in sequence. If none of the preferred fonts are available, a sans-serif font is used. -If you receive a warning about a missing font when setting a theme, -try installing one of the preferred fonts or make sure that the font is -available to R using \code{extrafont::font_import()} and \code{extrafont::loadfont()} +Themes then look much more alike than they should, +since the typeface carries a good deal of an institution\'s identity. +Call \code{list_fonts()} to see which font families R can currently see, +and \code{ag_font()} to see which one the current theme settled on. + +To make more fonts available, there are two steps. +\enumerate{ +\item Install the font on your computer. +Many of the fonts these themes prefer are free: +Google Fonts (\url{https://fonts.google.com}) offers Roboto, Open Sans, +Source Sans 3, Source Serif 4, Noto Serif, Montserrat, and Playfair +Display, among others. +Download the family, then install it as you would any other font: +double-click the files and choose "Install" on Windows, +open them in Font Book on macOS, +or copy them into \verb{~/.local/share/fonts} and run \code{fc-cache -f} on Linux. +Some fonts are licensed and are only available to members of the +institution concerned, or for purchase; +the theme falls back to a near relative where it can. +\item Make the font available to R. +Install the \code{{systemfonts}} package and the fonts installed on your system +are found directly, with no further step. +Otherwise, use \code{extrafont::font_import()} once and +\code{extrafont::loadfonts()} in each session. +Restart R after installing a font, then call \code{list_fonts()} to check that +the family is now listed, and set the theme again. +} + +Note that a font is only used where the graphics device can draw it. +The \code{{ragg}} devices (for example \code{ragg::agg_png()}) and \code{{svglite}} are +the most reliable; +the default PDF device needs the font embedded, +for which \code{extrafont::embed_fonts()} is available. } \section{Custom}{ @@ -74,4 +115,10 @@ plot(netrics::node_by_degree(ison_karateka)) stocnet_theme("uzh") plot(netrics::node_by_degree(ison_karateka)) } +\seealso{ +Other themes: +\code{\link[=list_fonts]{list_fonts()}}, +\code{\link{theme_colorblind}}, +\code{\link{theme_medium}} +} \concept{themes} diff --git a/pkgdown/_pkgdown.yml b/pkgdown/_pkgdown.yml index 0425c078..307d27e8 100644 --- a/pkgdown/_pkgdown.yml +++ b/pkgdown/_pkgdown.yml @@ -68,7 +68,10 @@ reference: Functions for tailoring graphs with themes, scales, and palettes. contents: - theme_set + - theme_medium - ag_call + - list_fonts + - theme_colorblind - match_color - ends_with("themes") - ends_with("scales") @@ -83,11 +86,13 @@ reference: - graphr - graphs - grapht + - completion - title: "Plotting" desc: | `plot()` methods exist for results and other objects for stocnet packages. contents: - starts_with("plot.") + - count_pages - title: "Layouts" desc: | Functions for laying out the nodes in a graph. @@ -95,6 +100,7 @@ reference: in `{igraph}` and `{ggraph}` by default. contents: - starts_with("layout") + - check_layout - title: "Results objects from other packages" contents: - made_earlier diff --git a/tests/testthat/helper-functional.R b/tests/testthat/helper-functional.R index 6dd810a0..174a562e 100644 --- a/tests/testthat/helper-functional.R +++ b/tests/testthat/helper-functional.R @@ -12,9 +12,14 @@ # Exported functions in a family, excluding deprecated/defunct shims ag_alive_functions <- function(pattern) { fns <- sort(grep(pattern, getNamespaceExports("autograph"), value = TRUE)) + # A retired layout is an ordinary function forwarding to its replacement, so + # nothing in its body marks it as retired. The package declares them instead, + # and this reads that declaration rather than keeping a second copy of it. + retired <- c(paste0("layout_tbl_graph_", autograph:::.deprecated_layouts()), + paste0("layout_", autograph:::.deprecated_layouts())) keep <- vapply(fns, function(f) { fun <- get(f, envir = asNamespace("autograph")) - is.function(fun) && + is.function(fun) && !f %in% retired && !grepl("Deprecated|Defunct", paste(deparse(body(fun)), collapse = " ")) }, logical(1)) @@ -54,6 +59,24 @@ expect_buildable <- function(p) { invisible(built) } +# `plot.goldfishFit()` composes its panels out of goldfish's own +# diagnostics rather than out of the fit alone, so no precooked fixture can +# stand in for them: without goldfish, or with one older than the 1.9.21 that +# added them, every panel drops and the method prints and returns NULL. Tests +# of what the composition contains are skipped there. The test is for the +# functions rather than for the version string, matching the shims in +# R/autograph-defunct.R, since a pre-release build can carry the version +# without yet exporting them. +skip_without_gf_diagnostics <- function() { + testthat::skip_if_not_installed("goldfish") + needed <- c("diagnose_outliers", "test_gof") + missing <- setdiff(needed, getNamespaceExports("goldfish")) + if (length(missing) > 0) { + testthat::skip(paste("goldfish does not export", + paste(missing, collapse = ", "))) + } +} + # Standard grid of fixture networks covering the formats autograph's # layouts and graphr() aesthetics are expected to handle. ag_fixtures <- local({ @@ -73,3 +96,25 @@ ag_fixtures <- local({ ) }) +# The candidate pool the layout audit selects from. ag_fixtures covers the +# formats, but several layouts are declared (in .layout_requirements(), see +# R/graph_checks.R) to need a particular size or shape that the grid has no +# example of: the configurational layouts want exactly 2-6 nodes, and a ladder +# wants two equally sized modes. Adding those here rather than pinning a +# network per layout in the test means the audit picks its own fixtures, and a +# new layout needs no test change at all. +ag_layout_pool <- c(ag_fixtures, local({ + set.seed(1234) + list( + dyadic = manynet::create_ring(2), + triadic = manynet::create_ring(3), + tetradic = manynet::create_ring(4), + pentadic = manynet::create_ring(5), + hexadic = manynet::create_ring(6), + # Two-mode sizes are given as a vector; ison_southern_women is 18/14, so + # the pool needs an equally sized pair for the ladder layout + balanced = manynet::create_ring(c(4, 4)), + acyclic = manynet::create_tree(8, directed = TRUE) + ) +})) + diff --git a/tests/testthat/helper-manynet.R b/tests/testthat/helper-manynet.R new file mode 100644 index 00000000..3de58625 --- /dev/null +++ b/tests/testthat/helper-manynet.R @@ -0,0 +1,17 @@ +# manynet 2.3.0 ships several of its networks in a list-based class, where +# 2.2.3 and earlier shipped every network as an igraph. It also spells some +# tie attributes differently there: a layer is recorded as "layer" rather than +# as "type", and a sign as a negative weight rather than as a "sign". +# +# graphr() and its siblings coerce whatever network they are given, so the +# internal helpers beneath them only ever see a coerced network. A test that +# calls one of those helpers directly, or that reaches into igraph itself, +# therefore coerces first, so that it reads the same network under either +# manynet. A network that is already an igraph is unchanged by this. +ag_net <- function(x) manynet::as_tidygraph(x) + +# Whether the installed manynet exports a function, for a test of behaviour +# that only the newer manynet can offer. Tests for the function rather than +# for the version, as the package itself does, since a development build can +# carry a version string without the function. +manynet_has <- function(fn) fn %in% getNamespaceExports("manynet") diff --git a/tests/testthat/test-functional_aes.R b/tests/testthat/test-functional_aes.R index 053be42b..9844adae 100644 --- a/tests/testthat/test-functional_aes.R +++ b/tests/testthat/test-functional_aes.R @@ -19,7 +19,7 @@ aes_fixture <- local({ graphr_arg_values <- list( .data = NULL, # the fixture itself layout = NULL, # audited exhaustively in test-functional_layouts.R - labels = list(TRUE, FALSE), + labels = list(TRUE, FALSE, 3, "degree", "random"), node_color = list("grp", "num", "darkred"), node_colour = NULL, # alias of node_color node_shape = list("grp", "square"), @@ -31,8 +31,10 @@ graphr_arg_values <- list( edge_bundle = list("force"), isolates = list("legend", "caption", "keep"), snap = NULL, # exercised in test-functional_layouts.R + backbone = list(TRUE, FALSE, "simmelian", 0.1), # also test-graph_backbone.R label_dist = list(0.5), label_repel = list(TRUE, FALSE), + .shared = NULL, # internal, set by graphs(); exercised in test-functional_plots.R ... = NULL ) diff --git a/tests/testthat/test-functional_coverage.R b/tests/testthat/test-functional_coverage.R new file mode 100644 index 00000000..630f0b0f --- /dev/null +++ b/tests/testthat/test-functional_coverage.R @@ -0,0 +1,720 @@ +# Tests for paths the family audits do not reach: branches selected by a +# particular argument value, and helpers only some inputs route through. These +# were the largest uncovered clusters in the covr per-function report. + +# Hierarchy `center` ---- + +test_that("hierarchy centres on either mode, or on a named node", { + skip_on_cran() + sw <- manynet::ison_southern_women + # Each `center` takes its own branch through the coordinate construction, + # and each normalises its rows with nrm()/rng(). + for (ctr in c("actors", "events")) { + coords <- as.data.frame(layout_tbl_graph_layered(sw, center = ctr)) + expect_equal(nrow(coords), as.integer(manynet::net_nodes(sw))) + expect_true(all(is.finite(coords$x)) && all(is.finite(coords$y))) + # The centred mode sits between the two halves of the other one + expect_length(unique(coords$x), 3L) + } + # A node name centres on that node rather than on a mode + nm <- manynet::node_names(sw)[1] + coords <- as.data.frame(layout_tbl_graph_layered(sw, center = nm)) + expect_equal(nrow(coords), as.integer(manynet::net_nodes(sw))) + expect_true(all(is.finite(coords$x))) +}) + +test_that("hierarchy refuses to centre a one-mode network", { + skip_on_cran() + # Centring names a mode, so there is nothing to centre on without two of + # them. This is an abort rather than a substitution because the user can drop + # the argument (see .layout_requirements() in R/graph_checks.R). + expect_error( + layout_tbl_graph_layered(manynet::ison_adolescents, center = "actors"), + "one-mode network") +}) + +test_that(".nrm() normalises vectors and arrays onto a common scale", { + expect_equal(autograph:::.nrm(c(0, 5, 10)), c(0, 0.5, 1)) + # A single value has no range to normalise against and is returned as is + expect_equal(autograph:::.nrm(7), 7) + out <- autograph:::.nrm(cbind(c(0, 10), c(0, 5))) + expect_s3_class(out, "data.frame") + expect_equal(nrow(out), 2L) +}) + +# Multilevel weights ---- + +test_that("multilevel drops tie weights it cannot use", { + skip_on_cran() + # .drop_unusable_weights() strips a weight attribute that would otherwise + # make the level distances meaningless. + net <- manynet::add_tie_attribute(manynet::ison_southern_women, "weight", + rep(1, manynet::net_ties( + manynet::ison_southern_women))) + # suppressWarnings: the weighted edge scale goes through ggraph, which still + # calls continuous_scale(trans = ) and so emits a ggplot2 3.5.0 deprecation + # warning that is not ours to fix. + suppressWarnings( + expect_buildable(graphr(net, layout = "levels", level = "type"))) +}) + +# Radial label angles ---- + +test_that("labels on radial layouts are rotated to follow the circle", { + skip_on_cran() + # Only "circle" and "concentric" route through .cart2pol()/.hypot() to work + # out a per-label angle; every other layout leaves labels upright. + p <- graphr(manynet::ison_adolescents, layout = "circle", labels = TRUE) + built <- expect_buildable(p) + # The angle is passed as a per-node vector of aes_params, so it is only + # visible once the plot is built. + angles <- built$data[[length(built$data)]][["angle"]] + expect_false(is.null(angles)) + # Labels are spread around the circle rather than all at one angle + expect_gt(length(unique(angles)), 1) + expect_true(all(is.finite(angles))) + # An ordinary layout leaves them upright + flat <- ggplot2::ggplot_build(graphr(manynet::ison_adolescents, + layout = "stress", labels = TRUE)) + expect_equal(length(unique(flat$data[[length(flat$data)]][["angle"]])), 1L) +}) + +test_that("cartesian coordinates convert to polar", { + out <- as.data.frame(autograph:::.cart2pol(cbind(c(1, 0), c(0, 1)))) + expect_equal(nrow(out), 2L) + # (1,0) lies on the positive x axis, (0,1) a quarter turn round + expect_equal(out$phi[1], 0) + expect_equal(out$phi[2], pi / 2) + expect_equal(autograph:::.hypot(3, 4), 5) +}) + +# Theme persistence ---- + +test_that("the theme preference is written and forgotten on request", { + # R_user_dir() is redirected so the test never touches the real config. + tmp <- withr_tempdir <- tempfile("agconfig") + dir.create(tmp) + old <- Sys.getenv("R_USER_CONFIG_DIR", unset = NA) + Sys.setenv(R_USER_CONFIG_DIR = tmp) + on.exit({ + if (is.na(old)) Sys.unsetenv("R_USER_CONFIG_DIR") + else Sys.setenv(R_USER_CONFIG_DIR = old) + unlink(tmp, recursive = TRUE) + suppressMessages(stocnet_theme("default")) + }, add = TRUE) + + expect_true(autograph:::write_theme_pref("iheid")) + f <- autograph:::theme_pref_file() + expect_true(file.exists(f)) + expect_equal(readRDS(f), "iheid") + autograph:::forget_theme_pref() + expect_false(file.exists(f)) +}) + +test_that("the medium preference is written, read back, and forgotten", { + # The medium persists the same way the theme does, so it is redirected the + # same way and never touches the real config. + tmp <- tempfile("agconfig") + dir.create(tmp) + old <- Sys.getenv("R_USER_CONFIG_DIR", unset = NA) + Sys.setenv(R_USER_CONFIG_DIR = tmp) + on.exit({ + if (is.na(old)) Sys.unsetenv("R_USER_CONFIG_DIR") + else Sys.setenv(R_USER_CONFIG_DIR = old) + unlink(tmp, recursive = TRUE) + suppressMessages(stocnet_medium("screen")) + }, add = TRUE) + + f <- autograph:::pref_file("medium") + suppressMessages(stocnet_medium("presentation", persist = TRUE)) + expect_true(file.exists(f)) + expect_equal(autograph:::read_medium_pref(), "presentation") + # Setting a medium without `persist` forgets the remembered one, so that the + # next session does not start in a medium the user has since left. + suppressMessages(stocnet_medium("screen")) + expect_false(file.exists(f)) + expect_null(autograph:::read_medium_pref()) + # A stored value that is not one of the media is discarded rather than set. + autograph:::write_pref("medium", "papyrus") + expect_null(autograph:::read_medium_pref()) + autograph:::write_pref("medium", c("screen", "print")) + expect_null(autograph:::read_medium_pref()) +}) + +test_that("stocnet_medium reports the medium and rejects a bad argument", { + on.exit(suppressMessages(stocnet_medium("screen")), add = TRUE) + old <- options(snet_verbosity = "verbose") + on.exit(options(old), add = TRUE) + suppressMessages(stocnet_medium("screen")) + expect_message(stocnet_medium(), "currently set to") + # The medium must be one string: a vector or a number names no medium. + expect_error(stocnet_medium(c("screen", "print")), "single medium") + expect_error(stocnet_medium(2), "single medium") +}) + +# Goodness-of-fit variants ---- + +test_that("ergm gof plots each statistic it holds, and says so when it cannot", { + skip_on_cran() + # The fixture carries degree, espartners and distance statistics; each + # selects its own branch for extracting observed and simulated values. + for (s in c("degree", "espartners", "distance")) { + expect_buildable(plot(ergm_gof, statistic = s)) + } + # Asking for one the fit does not hold reports which, rather than failing + # somewhere in the extraction. + expect_error(plot(ergm_gof, statistic = "dspartners"), "dspart") +}) + +test_that("gof plots accept a cumulative view and a custom title", { + skip_on_cran() + for (cm in c(TRUE, FALSE)) { + expect_buildable(plot(ergm_gof, cumulative = cm)) + expect_buildable(plot(siena_gof, cumulative = cm)) + } + # `main` short-circuits the constructed title + p <- plot(siena_gof, main = "A title of my own") + expect_buildable(p) + expect_match(paste(unlist(p$labels), collapse = " "), "A title of my own") +}) + +# Group reduction ---- + +test_that("node_group folds sparse categories into an 'Other' group", { + skip_on_cran() + old <- options(snet_verbosity = "verbose") + on.exit(options(old), add = TRUE) + # Four categories of one member each, plus one of three: .reduce_categories() + # condenses the sparse ones rather than drawing a hull around every singleton. + net <- manynet::add_node_attribute(manynet::ison_adolescents, "grp", + c("a", "a", "a", "b", "c", "d", "e", "f")) + expect_message(p <- graphr(net, node_group = "grp"), "Other") + expect_buildable(p) + expect_true("Other" %in% manynet::node_attribute( + manynet::mutate_nodes(manynet::as_tidygraph(net), + g = autograph:::.reduce_categories( + manynet::as_tidygraph(net), "grp")), "g")) + # Exactly two sparse categories take the other branch + net2 <- manynet::add_node_attribute(manynet::ison_adolescents, "grp", + c("a", "a", "a", "b", "b", "b", "c", "d")) + expect_buildable(graphr(net2, node_group = "grp")) +}) + +# Label selection ---- + +test_that("labels select nodes by count, by criterion, and at random", { + skip_on_cran() + net <- manynet::ison_adolescents + n_labels <- function(p) { + lab <- p[["layers"]][[length(p[["layers"]])]][["data"]][["name"]] + length(stats::na.omit(lab)) + } + # A count selects by *rank* rather than by node, so ties widen the selection: + # ison_adolescents' degrees are 4,4,3,3,2,2,1,1, and asking for 3 labels the + # whole of each rank it reaches rather than cutting a tie arbitrarily. + p3 <- graphr(net, labels = 3) + expect_buildable(p3) + expect_gte(n_labels(p3), 3L) + expect_lt(n_labels(p3), as.integer(manynet::net_nodes(net))) + # A named criterion ranks by that measure instead + expect_buildable(graphr(net, labels = "degree")) + # "random" samples rather than ranks (.sample_labels) + set.seed(123) + expect_buildable(graphr(net, labels = "random")) + # A logical node attribute marks which to label + marked <- manynet::add_node_attribute(net, "keep", + rep(c(TRUE, FALSE), 4)) + pm <- graphr(marked, labels = "keep") + expect_buildable(pm) + expect_equal(n_labels(pm), 4L) + # Named nodes label exactly those + pn <- graphr(net, labels = manynet::node_names(net)[1:2]) + expect_buildable(pn) + expect_equal(n_labels(pn), 2L) +}) + +# Diffusion node colouring ---- + +test_that("graphr colours nodes by their adoption time on a diffusion", { + skip_on_cran() + set.seed(123) + diff <- manynet::play_diffusion(manynet::create_ring(10), seeds = 1) + p <- graphr(diff) + expect_buildable(p) + # .node_adoption_time() turns the event history into a per-node value, so + # nodes must differ rather than all taking one colour + built <- ggplot2::ggplot_build(p) + node_layer <- built$data[[length(built$data)]] + expect_gt(length(unique(stats::na.omit(node_layer$fill))), 0) +}) + +# Diffusion summaries ---- + +test_that("a diffusion that never spread says so rather than plotting", { + skip_on_cran() + # A single row is the whole diffusion, so there is no trace to draw. + flat <- manynet::as_diffusion( + manynet::play_diffusion(manynet::create_empty(5), seeds = 1)) + expect_equal(nrow(flat), 1L) + # snet_warn() speaks through cli, and only when verbosity is turned up. + old <- options(snet_verbosity = "verbose") + on.exit(options(old), add = TRUE) + # The method returns the cli message's own value, not a plot. + expect_message(out <- plot(flat), "No diffusion was observed") + expect_false(inherits(out, "ggplot")) +}) + +test_that("the diffusion plot adds a line for each compartment it holds", { + skip_on_cran() + # The exposed and recovered lines are added only when those compartments + # are populated, so an SI run draws two lines and an SIR run three. + set.seed(1) + si <- manynet::as_diffusion( + manynet::play_diffusion(manynet::create_ring(10), seeds = 1)) + expect_false(any(si$E > 0)) + expect_false(any(si$R > 0)) + n_lines <- function(p) { + sum(vapply(p[["layers"]], + function(l) inherits(l[["geom"]], "GeomLine"), logical(1))) + } + expect_equal(n_lines(si_p <- plot(si)), 2L) + expect_buildable(si_p) + set.seed(1) + sir <- manynet::as_diffusion( + manynet::play_diffusion(manynet::create_ring(10), seeds = 1, + recovery = 0.4)) + expect_true(any(sir$R > 0)) + expect_equal(n_lines(sir_p <- plot(sir)), 3L) + expect_buildable(sir_p) + set.seed(2) + seir <- manynet::as_diffusion( + manynet::play_diffusion(manynet::create_ring(10), seeds = 1, + latency = 0.9)) + expect_true(any(seir$E > 0)) + expect_equal(n_lines(seir_p <- plot(seir)), 3L) + expect_buildable(seir_p) +}) + +test_that("multiple diffusions smooth one line per compartment", { + skip_on_cran() + skip_if_not_installed("migraph") + set.seed(1) + sir <- migraph::play_diffusions(manynet::create_ring(10), seeds = 1, + latency = 0.9, recovery = 0.4, times = 3) + expect_true(any(sir$E > 0) && any(sir$R > 0)) + # suppressWarnings: loess on a short series warns about its span, which is + # not what this is checking. + suppressWarnings(expect_buildable(plot(sir))) + expect_equal( + sum(vapply(plot(sir)[["layers"]], + function(l) inherits(l[["geom"]], "GeomSmooth"), logical(1))), + 4L) +}) + +# Motif illustrations ---- + +test_that("motif results are illustrated by the census they come from", { + skip_on_cran() + skip_if_not_installed("netrics") + net <- manynet::ison_adolescents + set.seed(123) + dir <- manynet::generate_random(8, directed = TRUE) + # Each census names its own motifs, and each set of names selects the + # illustration drawn for it. + expect_buildable(plot(netrics::node_x_dyad(net))) # Mutual + expect_buildable(plot(netrics::node_x_dyad(dir))) # Asymmetric + expect_buildable(plot(netrics::node_x_triad(net))) # 102 + expect_buildable(plot(netrics::node_x_triad(dir))) # 021D + expect_buildable(plot(netrics::net_x_dyad(net))) + expect_buildable(plot(netrics::net_x_triad(dir))) +}) + +test_that("a census with no illustration says so rather than drawing", { + skip_on_cran() + # The message names the censuses that can be drawn, so the reader is not + # left guessing which results the method takes. + motifs <- structure(matrix(0, nrow = 2, ncol = 2, + dimnames = list(c("A", "B"), c("Q1", "Q2"))), + class = c("node_motif", "matrix", "array")) + expect_error(plot(motifs), "cannot be illustrated") + net_motifs <- structure(c(Q1 = 0, Q2 = 0), class = "network_motif") + expect_error(plot(net_motifs), "cannot be illustrated") +}) + +# Test distributions ---- + +test_that("the test plot shades one tail or two, on the side tested", { + skip_on_cran() + x <- res_migraph_test + # The density layers are areas too, so the shaded tails are counted by + # their own geom rather than by what they inherit from. + n_areas <- function(p) { + sum(vapply(p[["layers"]], + function(l) class(l[["geom"]])[1] == "GeomArea", logical(1))) + } + # Two tails is the default, and shades both ends of the distribution. + expect_equal(n_areas(plot(x)), 2L) + # A one-tailed test shades the end the observed value sits in, so a value + # below the median takes the other branch from one above it. + low <- x + low$testval <- stats::quantile(x$testdist, 0.1) + expect_equal(n_areas(p_low <- plot(low, tails = "one")), 1L) + expect_buildable(p_low) + high <- x + high$testval <- stats::quantile(x$testdist, 0.9) + expect_equal(n_areas(p_high <- plot(high, tails = "one")), 1L) + expect_buildable(p_high) + # A correlation-like distribution spanning zero expands to both limits + both <- x + both$testdist <- c(x$testdist, -x$testdist) + expect_buildable(plot(both)) +}) + +# Selection and influence tables ---- + +test_that("interpretation tables follow the theme and the curve asked for", { + skip_on_cran() + # `quad = FALSE` joins the points instead of smoothing them, and a + # monochrome theme takes its own branch through the colour scale. + expect_buildable(plot(siena_selection, quad = FALSE)) + expect_buildable(plot(siena_influence, quad = FALSE)) + old <- options(stocnet_theme = "bw") + on.exit(options(old), add = TRUE) + expect_buildable(plot(siena_selection)) + # Separation offsets the egos so that overlapping curves stay readable + expect_buildable(plot(siena_selection, separation = 0.1)) +}) + +# Fonts ---- + +test_that("a theme whose fonts are missing falls back to the default", { + old <- options(snet_font = getOption("snet_font"), + snet_verbosity = "verbose") + on.exit(options(old), add = TRUE) + # The system's own font list is not something a test can arrange, so the + # lookup is replaced: available_fonts() is its own function for this. + testthat::local_mocked_bindings(available_fonts = function() "sans") + expect_message(autograph:::set_font_theme("ethz"), "are available") + expect_equal(getOption("snet_font"), "sans") + # A font the theme asks for and the system has is used as it is + testthat::local_mocked_bindings( + available_fonts = function() c("sans", "Arial")) + expect_message(autograph:::set_font_theme("ethz"), "Setting font to Arial") + expect_equal(getOption("snet_font"), "Arial") + # A theme with no preferred fonts asks for none + autograph:::set_font_theme("default") + expect_equal(getOption("snet_font"), "sans") +}) + +# Label geometry ---- + +test_that("polar conversion takes a point, a matrix, or a third dimension", { + # A single point comes back as a vector, a matrix row-wise, and a third + # column is carried through untouched. + expect_equal(autograph:::.cart2pol(c(1, 0)), c(0, 1)) + expect_equal(autograph:::.cart2pol(c(1, 0, 5)), c(0, 1, 5)) + out <- autograph:::.cart2pol(cbind(c(1, 0), c(0, 1), c(2, 3))) + expect_equal(colnames(out), c("phi", "r", "z")) + expect_equal(out[, "z"], c(2, 3)) + # Anything else says what shape was expected rather than failing inside + # the arithmetic. + expect_error(autograph:::.cart2pol("a"), "numeric") + expect_error(autograph:::.cart2pol(1:5), "vector of length 3") +}) + +test_that("the hypotenuse recycles a single leg and refuses a mismatch", { + expect_equal(autograph:::.hypot(3, c(4, 4)), c(5, 5)) + expect_equal(autograph:::.hypot(c(3, 3), 4), c(5, 5)) + # Nothing to measure + expect_length(autograph:::.hypot(numeric(0), 3), 0L) + expect_error(autograph:::.hypot("a", 1), "numeric or complex") + expect_error(autograph:::.hypot(c(1, 2), c(1, 2, 3)), "same size") +}) + +test_that("labels are nudged clear of the nodes when they cannot be repelled", { + skip_on_cran() + # Without ggrepel there is no algorithm to keep labels off the nodes, so + # each layout family approximates the same clearance with a fixed nudge. + radial <- graphr(manynet::ison_adolescents, layout = "circle", + labels = TRUE, label_repel = FALSE) + built <- expect_buildable(radial) + # The nudge is radial, so it differs per label rather than being one offset + layer <- radial[["layers"]][[length(radial[["layers"]])]] + expect_s3_class(layer[["position"]], "PositionNudge") + expect_gt(length(unique(layer[["position"]][["x"]])), 1) + expect_buildable(graphr(manynet::ison_southern_women, layout = "bipartite", + labels = TRUE, label_repel = FALSE)) + expect_buildable(graphr(manynet::ison_southern_women, layout = "layered", + labels = TRUE, label_repel = FALSE)) + # A node size mapped from an attribute is cut down to the labelled nodes + sized <- manynet::add_node_attribute(manynet::ison_adolescents, "wt", + seq_len(8)) + expect_buildable(graphr(sized, node_size = "wt", labels = 3, + label_repel = FALSE)) +}) + +# Label selection without netrics ---- + +test_that("ranking labels without netrics falls back or says what is missing", { + skip_on_cran() + net <- manynet::ison_adolescents + # .has_netrics() is its own function so that this fallback can be tested + # with the package installed. + testthat::local_mocked_bindings(.has_netrics = function() FALSE) + # A criterion the user asked for by name is not silently substituted. + expect_error(graphr(net, labels = "degree"), "netrics") + # An automatic selection is too incidental to a plot to stop it, so it + # samples instead and says that it did. + old <- options(snet_verbosity = "verbose") + on.exit(options(old), add = TRUE) + set.seed(123) + # More than 30 named nodes drawn, so graphr() selects which to label itself. + big <- suppressMessages(manynet::to_named(manynet::generate_random(40, 0.2))) + expect_message(p <- graphr(big), "random selection") + expect_buildable(p) + # "random" needs nothing of netrics either way + expect_buildable(graphr(net, labels = "random")) +}) + +test_that("labels can mark every node a measure flags, however many", { + skip_on_cran() + skip_if_not_installed("netrics") + # A mark rather than a ranking: cutpoints are labelled by their flag. + net <- manynet::ison_adolescents + p <- graphr(net, labels = "cutpoints") + expect_buildable(p) + labelled <- p[["layers"]][[length(p[["layers"]])]][["data"]][["name"]] + expect_equal(sort(stats::na.omit(labelled)), + sort(manynet::node_names(net)[ + as.logical(netrics::node_is_cutpoint(net))])) +}) + +test_that("a random label sample is drawn within each mode or level", { + skip_on_cran() + # Both modes are sampled from, so a two-mode plot labels both rather than + # only the larger one. + sel <- autograph:::.sample_labels( + manynet::as_igraph(manynet::ison_southern_women), 2) + modes <- igraph::V(manynet::as_igraph(manynet::ison_southern_women))$type + expect_equal(sum(sel[!modes]), 2L) + expect_equal(sum(sel[modes]), 2L) + # The session's RNG is left as it was found, so a plot drawn twice is the + # same plot and the caller's stream is undisturbed. + set.seed(42) + before <- stats::runif(1) + set.seed(42) + invisible(autograph:::.sample_labels( + manynet::as_igraph(manynet::ison_adolescents), 3)) + expect_equal(stats::runif(1), before) +}) + +# Layer assignment ---- + +test_that("the layered layout asks igraph for layers when none are given", { + skip_on_cran() + # A one-mode network arrives without layers, so they are computed rather + # than taken from the modes. + lo <- autograph:::.sugiyama_layout( + manynet::as_igraph(manynet::create_tree(10, directed = TRUE))) + expect_equal(nrow(lo), 10L) + expect_gt(length(unique(lo[, 2])), 1) + # A network with nothing to layer is returned in one row of nodes rather + # than run through the crossing-minimisation sweeps. + flat <- autograph:::.sugiyama_layout( + manynet::as_igraph(manynet::create_empty(4))) + expect_equal(nrow(flat), 4L) + expect_equal(length(unique(flat[, 2])), 1L) +}) + +test_that("a tie spanning two layers is routed through a dummy node", { + skip_on_cran() + # a -> f skips the middle layer, so the sweeps need a placeholder there to + # count its crossings against. + el <- data.frame(from = c("a", "b", "a", "c", "d", "a"), + to = c("c", "d", "e", "e", "f", "f")) + g <- igraph::graph_from_data_frame(el, directed = TRUE) + lo <- autograph:::.sugiyama_layout(g, layers = c(0, 0, 1, 1, 2, 2), + times = 5) + # One row per real node: the dummy is a routing device, not a node. + expect_equal(nrow(lo), 6L) + expect_equal(lo[, 2], c(0, 0, 1, 1, 2, 2)) + expect_true(all(is.finite(lo[, 1]))) +}) + +test_that("a layer of nodes is spread, and a negative count refused", { + # .rng() spreads a layer's nodes over a common range; one node has no + # spread to take. + expect_equal(autograph:::.rng(1), 0) + spread <- autograph:::.rng(3) + expect_length(spread, 3L) + expect_equal(spread[2], 0) + expect_true(spread[1] < spread[3]) + expect_error(autograph:::.rng(-1), "negative number of nodes") +}) + +test_that("concentric needs one membership per node", { + skip_on_cran() + # A vector that is neither an attribute name nor one value per node says + # which of the two it should have been. + expect_error( + layout_concentric(manynet::as_igraph(manynet::ison_adolescents), + membership = c("a", "b")), + "membership") +}) + +test_that("hierarchy centres on a node of either mode", { + skip_on_cran() + sw <- manynet::ison_southern_women + # The events are the second mode, and centring on one takes its own branch + # from centring on an actor. + event <- utils::tail(manynet::node_names(sw), 1) + coords <- as.data.frame(layout_tbl_graph_layered(sw, center = event)) + expect_equal(nrow(coords), as.integer(manynet::net_nodes(sw))) + expect_true(all(is.finite(coords$x)) && all(is.finite(coords$y))) + # A name that is in neither mode names what was expected instead + expect_error(layout_tbl_graph_layered(sw, center = "Nobody"), "Nobody") +}) + +test_that("multilevel ignores weights it cannot read as distances", { + skip_on_cran() + old <- options(snet_verbosity = "verbose") + on.exit(options(old), add = TRUE) + # Negative weights are no distance, and igraph::distances() rejects them + # outright, so they are dropped rather than the layout failing. + sw <- manynet::ison_southern_women + net <- manynet::add_tie_attribute( + sw, "weight", rep(c(-1, 1), length.out = as.integer(manynet::net_ties(sw)))) + # suppressWarnings: the weighted edge scale goes through ggraph, see above. + suppressWarnings(expect_message( + p <- graphr(net, layout = "levels", level = "type"), + "Ignoring the tie weights")) + suppressWarnings(expect_buildable(p)) +}) + +# Margin dispersion ---- + +test_that("a margin table carrying dispersion is drawn as level against shape", { + skip_on_cran() + # `margin_table(dispersion = TRUE)` adds a second reading, and where both + # are present the figure is the two against each other. The fixture is the + # precooked table with that column put on it, since the method reads the + # object's columns rather than calling back into goldfish. + m <- goldfish_margins + set.seed(123) + m$dispersion <- c(rep(NA_real_, 10), + stats::runif(nrow(m) - 10, 0.5, 2)) + p <- plot(m) + expect_buildable(p) + # One point per actor kept, not one row per actor and margin + expect_equal(p$labels$y, "Dispersion of the actor's own spans") + # Both kinds of omission are named: actors with no shape reading, and + # actors beyond `top`. + expect_match(p$labels$subtitle, "below two completed spans") + expect_match(p$labels$subtitle, "further actors not shown") + # With every actor drawn, only the shape omission is left to report + full <- plot(m, top = Inf) + expect_match(full$labels$subtitle, "below two completed spans") + expect_false(grepl("further actors", full$labels$subtitle)) + expect_gt(nrow(full$data), nrow(p$data)) + # A table where every actor has a shape reading says nothing at all + m$dispersion <- stats::runif(nrow(m), 0.5, 2) + expect_null(plot(m, top = Inf)$labels$subtitle) +}) + +# Ego-alter goodness of fit ---- + +test_that("an ego-alter gof is split into one panel per ego", { + skip_on_cran() + # The statistic names pair an ego with an alter, so the figure facets on + # the ego and moves the p-value to the caption. + x <- siena_gof + cn <- colnames(x[[1]]$Simulations) + paired <- outer(1:3, 1:9, function(a, b) paste0(a, b))[seq_along(cn)] + colnames(x[[1]]$Simulations) <- paired + names(x[[1]]$Observations) <- paired + attr(x, "EgoAlter") <- TRUE + p <- plot(x) + expect_buildable(p) + expect_equal(p$labels$x, "Alter") + expect_match(p$labels$caption, "^p:") + # Names that do not pair an ego with an alter say so, rather than being + # split into halves that mean nothing. + y <- siena_gof + attr(y, "EgoAlter") <- TRUE + expect_error(plot(y), "two characters long") +}) + +# Argument checking ---- + +test_that("a choice argument names the argument, the options, and a near miss", { + skip_on_cran() + net <- manynet::ison_adolescents + # Not a single string at all + expect_error(graphr(net, isolates = 2), "single string") + # A near miss is suggested rather than only rejected + expect_error(graphr(net, isolates = "legned"), "Did you mean") + # A choice given in another case is taken as meant + expect_buildable(graphr(net, isolates = "Legend")) +}) + +test_that("labels of a type that selects nothing say what they could be", { + skip_on_cran() + expect_error(graphr(manynet::ison_adolescents, labels = list(1)), + "which nodes to label") +}) + +test_that("an attribute that varies nowhere is drawn in one colour", { + skip_on_cran() + old <- options(snet_verbosity = "verbose") + on.exit(options(old), add = TRUE) + # Mapping a colour to it would produce a legend of one entry, so it is + # dropped, and the reader told why the mapping had no effect. + flat <- manynet::add_node_attribute(manynet::ison_adolescents, "grp", + rep("a", 8)) + expect_message(p <- graphr(flat, node_color = "grp"), "same value") + expect_buildable(p) +}) + +# Colourblind palettes ---- + +test_that("a palette says when it is asked for more colours than it holds", { + skip_on_cran() + old <- options(snet_verbosity = "verbose") + on.exit({ + options(old) + suppressMessages(stocnet_theme("default")) + }, add = TRUE) + suppressMessages(stocnet_theme("iheid")) + n <- length(getOption("snet_cat")) + expect_silent(ag_qualitative(n)) + expect_message(ag_qualitative(n + 3), "mixtures") +}) + +test_that("a legend of more than seven keys is worth saying something about", { + skip_on_cran() + old <- options(snet_verbosity = "verbose") + on.exit(options(old), add = TRUE) + net <- manynet::as_igraph(manynet::ison_adolescents) + many <- igraph::set_vertex_attr(net, "band", + value = paste0("b", seq_len(igraph::vcount(net)))) + expect_message(graphr(many, node_colour = "band", labels = FALSE), "8 keys") + # Six categories are within what a reader can match, and a continuous + # attribute has no keys to count at all. + expect_no_message(autograph:::.check_legend_size( + manynet::as_igraph(fict_lotr), node_color = "Race")) + expect_no_message(autograph:::.check_legend_size( + many, node_color = NULL, node_shape = NULL, edge_color = NULL)) +}) + +test_that("a single colour and an indistinct palette are still handled", { + # convertColor() drops to a vector for one colour, which the caller reads + # by row like any other. + lab <- autograph:::colorblind_lab("#FF0000", "normal") + expect_equal(dim(lab), c(1L, 3L)) + # Where no colour stands out from the background, the one furthest from it + # leads rather than the sort failing. + faint <- c("#FFFFFE", "#FFFFFD", "#FFFFFC") + sorted <- colorblind_sort(faint) + expect_setequal(sorted, faint) + expect_length(sorted, 3L) +}) diff --git a/tests/testthat/test-functional_errors.R b/tests/testthat/test-functional_errors.R index f6ed991d..ed8e4bcb 100644 --- a/tests/testthat/test-functional_errors.R +++ b/tests/testthat/test-functional_errors.R @@ -25,12 +25,11 @@ test_that("graphr() handles degenerate node counts", { expect_buildable(graphr(manynet::create_empty(0))) expect_buildable(graphr(manynet::create_empty(2))) - # KNOWN GAP: a single-node network errors with "invalid indexing" from inside - # the layout code -- note that both 0 and 2 nodes work, so this is an - # off-by-one in the layout path rather than an unsupported case. It should - # draw one isolate. Pinned here so the crash is documented and regression- - # tested; tighten to expect_buildable() once fixed. - expect_error(graphr(manynet::create_empty(1)), "invalid indexing") + # A single-node network used to error with "invalid indexing" from inside the + # layout code. It now draws: the default layout for a network this small is + # "configuration", which declares that it needs 2-6 nodes, so one node falls + # back to "stress" instead of reaching the off-by-one. + expect_buildable(graphr(manynet::create_empty(1))) }) test_that("graphr() rejects a nonexistent node attribute name", { @@ -97,6 +96,41 @@ test_that("graphr() accepts out-of-range numeric aesthetics without erroring", { expect_buildable(graphr(net, edge_size = -1)) }) +test_that("graphr() rejects an unusable labels selection", { + net <- manynet::add_node_attribute(manynet::ison_adolescents, + "wealth", seq_len(8)) + # A name that is neither an attribute, a measure, nor a node + expect_error(graphr(net, labels = "nosuchthing"), "labels") + expect_error(graphr(net, labels = "wealthh"), "Did you mean") + # A selection has to be the right length, or within range + expect_error(graphr(net, labels = c(TRUE, FALSE, TRUE)), "8 nodes") + expect_error(graphr(net, labels = c(2, 99)), "between 1 and 8") + # Ranks are counted, not measured + expect_error(graphr(net, labels = -2), "positive whole number") + expect_error(graphr(net, labels = c(nosuchmeasure = 5)), "labels") + # An attribute can mark which nodes to label, but only a logical one can + expect_error(graphr(net, labels = "wealth"), "logical") + # Named nodes must exist + expect_error(graphr(net, labels = c("Alice", "Nobody")), "Nobody") + expect_error(graphr(net, labels = c("Nobody", "NoOne")), "were not found") +}) + +test_that("graphr() labels without netrics installed to rank nodes by", { + # netrics is only suggested, and labelling is too incidental to a plot to + # stop it: the selection graphr() makes on its own falls back to a random + # sample, while one asked for by name says what is missing. + testthat::local_mocked_bindings(.has_netrics = function() FALSE) + set.seed(123) + big <- manynet::to_named(manynet::generate_random(60, 0.08)) + p <- graphr(big, isolates = "keep") + labelled <- p[["layers"]][[length(p[["layers"]])]][["data"]][["name"]] + expect_gt(length(labelled), 0) + expect_lt(length(labelled), 60) + expect_error(graphr(big, labels = "betweenness"), "netrics") + # A selection that needs no ranking is unaffected + expect_buildable(graphr(big, labels = "random", isolates = "keep")) +}) + test_that("graphr() rejects an unknown layout by name", { net <- manynet::ison_adolescents expect_error(graphr(net, layout = "notalayout"), "layout") @@ -114,7 +148,7 @@ test_that("graphr() explains that a layout is named, not passed as a function", test_that("graphr() validates isolates whether or not there are isolates", { # `match.arg()` used to sit inside .infer_isolates(), which does not always # force its argument, so this was caught or ignored depending on the network. - with_isolates <- manynet::create_empty(4) %>% + with_isolates <- manynet::create_empty(4) |> manynet::add_ties(c(1, 2)) expect_error(graphr(manynet::ison_adolescents, isolates = "drop"), "isolates") expect_error(graphr(with_isolates, isolates = "drop"), "isolates") @@ -137,8 +171,12 @@ test_that("graphs() rejects waves outside the range available", { test_that("layouts that need an extra argument say how to give it", { net <- manynet::ison_adolescents - # Previously "argument \"rank\" is missing, with no default". - expect_error(graphr(net, layout = "lineage"), "rank") - expect_error(graphr(net, layout = "lineage"), "for each node") + # `ranks` is not one of them: the layered layouts work the layers out for + # themselves where none are given, and only a `ranks` that names something + # the network does not hold is an error. + expect_no_error(suppressMessages(graphr(net, layout = "lineage"))) + expect_error(graphr(net, layout = "lineage", ranks = "nope"), + "among the node attributes") expect_error(graphr(net, layout = "concentric"), "membership") + expect_error(graphr(net, layout = "concentric"), "for each node") }) diff --git a/tests/testthat/test-functional_layouts.R b/tests/testthat/test-functional_layouts.R index 4a47c8bd..b6e34800 100644 --- a/tests/testthat/test-functional_layouts.R +++ b/tests/testthat/test-functional_layouts.R @@ -1,130 +1,229 @@ -# Functional audit of the layout family: every exported -# layout_tbl_graph_ algorithm is run through graphr() on each fixture -# network it should conform to, and the resulting plot must build. -# Non-conformant layout x fixture combinations skip with an AUDIT message. +# Functional audit of the layout family. Rather than pinning a fixture per +# layout, this reads the applicability contract the package itself declares in +# .layout_requirements() (R/graph_checks.R) and selects fixtures from a shared +# pool accordingly. Adding a layout therefore needs no change here: declare its +# requirement next to the others and the audit picks it up. +# +# Both sides of the contract are audited. Where a layout applies, it must draw +# a buildable plot and must NOT announce a substitution; where it does not, it +# must still draw something and must say what it needed and what it used. -# Layouts that only make sense for particular structures get a restricted -# fixture set; everything else is tried on the full grid. -layout_fixture_map <- list( - alluvial = c("twomode"), - hierarchy = c("twomode", "labelled"), - railway = c("twomode", "labelled"), - ladder = c("twomode"), - matching = c("twomode"), - lineage = c("labelled"), - multilevel = c("twomode"), - layered = c("tree", "directed"), - configuration = c("basic", "labelled"), - concentric = c("labelled", "twomode"), - valence = c("basic", "directed", "signed"), - dyad = c("basic"), - triad = c("basic"), - tetrad = c("basic"), - pentad = c("basic"), - hexad = c("basic") +# Arguments some layouts require, keyed by argument name rather than by layout, +# and derived from formals() below. A new layout taking a `membership` needs +# nothing added here. +# +# An argmaker returns NULL where the network cannot support the argument. That +# matters for concentric and levels, whose requirement is "two-mode OR an +# explicit partition": supplying one unconditionally would make them applicable +# to everything, and the inapplicable half of the contract would go untested. +layout_argmakers <- list( + membership = function(net) if (manynet::is_twomode(net)) "type" + else if (manynet::is_labelled(net)) + rep(c("a", "b"), length.out = as.integer(manynet::net_nodes(net))) + else NULL, + level = function(net) if (manynet::is_twomode(net)) "type" else NULL, + ranks = function(net) if (manynet::is_labelled(net)) + seq_len(as.integer(manynet::net_nodes(net))) else NULL ) -# Some layouts only accept a network of a particular size or shape, so the -# shared ag_fixtures grid cannot supply them. Previously these combinations all -# errored into an AUDIT skip -- and because skip() aborts the whole test_that -# block, the very first one silently prevented every later layout from being -# audited at all. Give them a network they can actually lay out. -layout_net_map <- list( - # The configurational layouts place exactly n nodes at fixed positions - dyad = list(basic = manynet::create_ring(2)), - triad = list(basic = manynet::create_ring(3)), - tetrad = list(basic = manynet::create_ring(4)), - pentad = list(basic = manynet::create_ring(5)), - hexad = list(basic = manynet::create_ring(6)), - configuration = list(basic = manynet::create_ring(4), - labelled = manynet::to_named(manynet::create_ring(4))), - # A ladder pairs the two modes off, so they must be equally sized - ladder = list(twomode = manynet::create_ring(6, 6)), - # layered ranks nodes by path depth, so it needs an acyclic network; - # ag_fixtures$directed is a random digraph and may contain cycles - layered = list(directed = manynet::create_tree(8, directed = TRUE)) -) -# Extra arguments some layouts require, keyed layout -> fixture. Keying by -# fixture as well as layout matters because the right argument depends on the -# network: hierarchy's `center` only names a mode on a two-mode network, and -# concentric needs a membership for whichever fixture it is given. -layout_args_map <- list( - lineage = list(labelled = list(rank = "year")), - hierarchy = list(twomode = list(center = "events")), - concentric = list(labelled = list(membership = rep(c("a", "b"), 4)), - twomode = list(membership = "type")), - multilevel = list(twomode = list(level = "type")) -) +# `center` names one of the two modes rather than a node attribute, so it is +# the one argument that cannot be made generically. +layout_center_arg <- function(net) { + if (!manynet::is_twomode(net)) return(NULL) + list(center = "events") +} + +# Arguments with no default, minus the ones every layout takes. +ag_required_args <- function(fn) { + fm <- formals(get(fn, envir = asNamespace("autograph"))) + req <- names(fm)[vapply(fm, function(x) identical(x, quote(expr = )), logical(1))] + setdiff(req, c(".data", "...")) +} -test_that("every exported layout algorithm draws a buildable plot", { +# Build the extra arguments a layout needs for a given network. +layout_extra_args <- function(lay, net) { + fn <- paste0("layout_tbl_graph_", lay) + if (!exists(fn, envir = asNamespace("autograph"))) return(NULL) + args <- list() + for (a in ag_required_args(fn)) { + if (!is.null(layout_argmakers[[a]])) args[[a]] <- layout_argmakers[[a]](net) + } + if (lay == "layered") args <- c(args, layout_center_arg(net)) + args +} + +# Partition the pool by the package's own predicate, capped so the audit stays +# proportionate: every layout is checked on two networks it should handle and +# one it should not, which is enough to exercise both sides of the contract +# without running every layout against every fixture. Deterministic (the first +# matches in pool order), so a failure reproduces. +layout_candidates <- function(lay, n_ok = 2, n_no = 1) { + fn <- paste0("layout_tbl_graph_", lay) + needed <- if (exists(fn, envir = asNamespace("autograph"))) + ag_required_args(fn) else character() + applies <- vapply(names(ag_layout_pool), function(nm) { + net <- ag_layout_pool[[nm]] + args <- layout_extra_args(lay, net) + if (!all(needed %in% names(args))) { + # A required argument this network cannot supply. Two different cases: + # where the layout declares a requirement the network also fails + # (concentric and levels need two modes *or* an explicit partition), + # graphr() substitutes before ever calling it, so this is a genuine + # inapplicable case. Where it declares none (lineage needs a `ranks` that + # an unlabelled network has nothing to give), the call would rightly + # abort asking for the argument, so leave it out of the pool entirely. + declared <- !is.null(autograph:::.layout_requirements()[[lay]]) + fails <- !isTRUE(do.call(autograph:::.layout_applies, + c(list(net, lay), args))) + return(if (declared && fails) FALSE else NA) + } + # Judged with the same arguments the audit will pass, since for concentric + # and levels an explicit membership/level is itself what makes the + # layout applicable. + isTRUE(do.call(autograph:::.layout_applies, c(list(net, lay), args))) + }, logical(1)) + applies <- applies[!is.na(applies)] + list(ok = utils::head(names(applies)[applies], n_ok), + no = utils::head(names(applies)[!applies], n_no)) +} + +# Capture whether graphr() announced a layout substitution. +layout_substituted <- function(expr) { + msgs <- character() + p <- withCallingHandlers(expr, message = function(m) { + msgs <<- c(msgs, conditionMessage(m)); invokeRestart("muffleMessage") + }) + list(plot = p, substituted = any(grepl("is used instead", msgs)), msgs = msgs) +} + +test_that("every layout applies where the package says it does", { skip_on_cran() + old <- options(snet_verbosity = "verbose") + on.exit(options(old), add = TRUE) layouts <- sub("^layout_tbl_graph_", "", ag_alive_functions("^layout_tbl_graph_")) expect_true(length(layouts) > 0) - lineage_fix <- manynet::add_node_attribute(manynet::ison_adolescents, "year", - rep(c(1985, 1990, 1995, 2000), - times = 2)) + reqs <- autograph:::.layout_requirements() for (lay in layouts) { - fixtures <- layout_fixture_map[[lay]] - if (is.null(fixtures)) fixtures <- names(ag_fixtures) - for (fix in fixtures) { - net <- if (lay == "lineage") lineage_fix - else if (!is.null(layout_net_map[[lay]][[fix]])) - layout_net_map[[lay]][[fix]] - else ag_fixtures[[fix]] - extra <- layout_args_map[[lay]][[fix]] - p <- run_or_skip( - do.call(graphr, c(list(net, layout = lay), extra)), + cand <- layout_candidates(lay) + # Pool honesty: an audit that silently has nothing to test is worse than a + # failing one, so say so rather than passing vacuously. + if (length(cand$ok) == 0) { + fail(paste0("AUDIT [layout ", lay, "]: no applicable network in the pool")) + next + } + if (!is.null(reqs[[lay]]) && length(cand$no) == 0) { + fail(paste0("AUDIT [layout ", lay, + "]: declares a requirement but the pool has no network failing it")) + } + for (fix in cand$ok) { + net <- ag_layout_pool[[fix]] + res <- run_or_skip( + layout_substituted(do.call(graphr, + c(list(net, layout = lay), layout_extra_args(lay, net)))), paste0("layout ", lay), fix) - run_or_skip(expect_buildable(p), paste0("build ", lay), fix) + run_or_skip({ + expect_buildable(res$plot) + # It applies, so it must be the layout actually drawn + testthat::expect_false(res$substituted, + info = paste0(lay, " x ", fix, ": ", paste(res$msgs, collapse = " "))) + }, paste0("build ", lay), fix) + } + } +}) + +test_that("every layout substitutes and says so where it does not apply", { + skip_on_cran() + old <- options(snet_verbosity = "verbose") + on.exit(options(old), add = TRUE) + reqs <- autograph:::.layout_requirements() + for (lay in names(reqs)) { + cand <- layout_candidates(lay) + for (fix in cand$no) { + net <- ag_layout_pool[[fix]] + res <- run_or_skip( + layout_substituted(do.call(graphr, + c(list(net, layout = lay), layout_extra_args(lay, net)))), + paste0("inapplicable ", lay), fix) + run_or_skip({ + # Still draws something usable, and explains the swap + expect_buildable(res$plot) + testthat::expect_true(res$substituted, + info = paste0(lay, " x ", fix, " should have substituted")) + testthat::expect_match(paste(res$msgs, collapse = " "), lay, fixed = TRUE) + }, paste0("inapplicable build ", lay), fix) } } }) test_that("every exported layout_* alias returns usable coordinates", { skip_on_cran() - # The audit above enumerates the layout_tbl_graph_* functions, which the - # user-facing layout_* aliases delegate to. The aliases were previously - # covered by nothing at all -- they do not match that pattern -- so enumerate - # them here too, and a new alias is picked up automatically. One fixture - # each is enough, since the underlying algorithm is already exercised above. + # The audits above go through graphr(); the user-facing layout_* aliases can + # also be called directly, so check they return coordinates for every node. aliases <- grep("^layout_tbl_graph_", ag_alive_functions("^layout_"), value = TRUE, invert = TRUE) expect_true(length(aliases) > 0) for (fn in aliases) { lay <- sub("^layout_", "", fn) - fixtures <- layout_fixture_map[[lay]] - fix <- if (is.null(fixtures)) "basic" else fixtures[[1]] - net <- if (lay == "lineage") - manynet::add_node_attribute(manynet::ison_adolescents, "year", - rep(c(1985, 1990, 1995, 2000), times = 2)) - else if (!is.null(layout_net_map[[lay]][[fix]])) - layout_net_map[[lay]][[fix]] - else ag_fixtures[[fix]] - extra <- layout_args_map[[lay]][[fix]] + fix <- layout_candidates(lay, n_ok = 1)$ok + if (length(fix) == 0) { + fail(paste0("AUDIT [alias ", fn, "]: no applicable network in the pool")) + next + } + net <- ag_layout_pool[[fix]] coords <- run_or_skip( - do.call(get(fn, envir = asNamespace("autograph")), c(list(net), extra)), + do.call(get(fn, envir = asNamespace("autograph")), + c(list(net), layout_extra_args(lay, net))), paste0("alias ", fn), fix) run_or_skip({ coords <- as.data.frame(coords) testthat::expect_true(all(c("x", "y") %in% names(coords))) testthat::expect_equal(nrow(coords), as.integer(manynet::net_nodes(net))) + # No NA coordinates: they survive to draw time and fail there testthat::expect_true(all(is.finite(coords$x)) && all(is.finite(coords$y))) }, paste0("alias coords ", fn), fix) } }) -test_that("layered layout accepts a raw edgelist and returns coordinates", { +test_that("every deprecated layout still draws, and is offered nowhere", { ties <- data.frame( from = c("A", "A", "B", "C", "D", "F", "F", "E"), to = c("B", "C", "D", "E", "E", "E", "G", "G"), stringsAsFactors = FALSE) - coords <- layout_tbl_graph_layered(ties, times = 6) - expect_equal(sort(rownames(coords)), sort(unique(c(ties$from, ties$to)))) - expect_true(all(c("x", "y") %in% names(coords))) - # sources sit above sinks - expect_true(coords["A", "y"] > coords["G", "y"]) + g <- igraph::graph_from_data_frame(ties, directed = TRUE) + old <- options(snet_verbosity = "verbose") + on.exit(options(old), add = TRUE) + retired <- autograph:::.deprecated_layouts() + expect_true(length(retired) > 0) + # A retired name is not offered as a completion, nor audited as a live layout. + expect_length(intersect(retired, autograph:::.autograph_layouts()), 0) + expect_length(intersect(paste0("layout_tbl_graph_", retired), + ag_alive_functions("^layout_tbl_graph_")), 0) + for (lay in retired) { + fn <- get(paste0("layout_tbl_graph_", lay), envir = asNamespace("autograph")) + # A configurational layout needs a network of the size it is named for, + # and "levels" needs a network with levels, so each retired name is given + # one it can actually draw. + sizes <- c("dyad", "triad", "tetrad", "pentad", "hexad") + net <- if (lay %in% sizes) manynet::create_ring(match(lay, sizes) + 1L) + else if (lay == "multilevel") manynet::ison_southern_women else g + expect_message(coords <- fn(net), "deprecated", label = lay) + expect_true(all(c("x", "y") %in% names(coords)), label = lay) + expect_equal(nrow(coords), as.integer(manynet::net_nodes(net)), label = lay) + } +}) + +test_that("a deprecated layout name is renamed once, where it is checked", { + old <- options(snet_verbosity = "verbose") + on.exit(options(old), add = TRUE) + expect_message(lay <- autograph:::.check_layout("hierarchy"), "deprecated") + expect_equal(lay, "layered") + expect_equal(suppressMessages(autograph:::.check_layout("alluvial")), "lineage") + expect_equal(suppressMessages(autograph:::.check_layout("multilevel")), "levels") + expect_equal(suppressMessages(autograph:::.check_layout("triad")), "configuration") + # A live name passes through untouched and says nothing. + expect_no_message(expect_equal(autograph:::.check_layout("layered"), "layered")) }) test_that("matching layout aligns matched partners vertically", { @@ -135,42 +234,3 @@ test_that("matching layout aligns matched partners vertically", { manynet::net_nodes(manynet::ison_southern_women)) }) -test_that("snapping a layout to the grid yields integer-ish unique positions", { - skip_on_cran() - p <- graphr(manynet::ison_adolescents, snap = TRUE) - expect_buildable(p) - # depth_first_recursive_search() assigns each node its own grid point - expect_false(any(duplicated(p$data[, c("x", "y")]))) -}) - -test_that("lattice networks snap by rotation to align edges to the grid", { - skip_on_cran() - p <- suppressMessages(graphr(manynet::create_lattice(9), snap = TRUE)) - expect_buildable(p) - expect_true(all(p$data$x == round(p$data$x))) -}) - -test_that("snapping a two-mode (hierarchy) layout falls back gracefully", { - skip_on_cran() - # The default two-mode layout is "hierarchy", whose layered coordinates - # would be collapsed by square-grid snapping, so snapping is skipped and - # the original coordinates are retained (see graph_layout()). - old <- options(snet_verbosity = "verbose") - on.exit(options(old), add = TRUE) - expect_message( - graphr(manynet::ison_southern_women, snap = TRUE), - "hierarchy") - snapped <- suppressMessages(graphr(manynet::ison_southern_women, snap = TRUE)) - plain <- graphr(manynet::ison_southern_women) - expect_buildable(snapped) - expect_equal(snapped$data[, c("x", "y")], plain$data[, c("x", "y")]) -}) - -test_that("snapping still works on a two-mode network with a force layout", { - skip_on_cran() - p <- suppressMessages( - graphr(manynet::ison_southern_women, layout = "stress", snap = TRUE)) - expect_buildable(p) - # every node lands on its own grid point - expect_false(any(duplicated(p$data[, c("x", "y")]))) -}) diff --git a/tests/testthat/test-functional_plots.R b/tests/testthat/test-functional_plots.R index d39a7dd4..af12d739 100644 --- a/tests/testthat/test-functional_plots.R +++ b/tests/testthat/test-functional_plots.R @@ -11,8 +11,46 @@ plot_fixture_registry <- list( ag_conv = NULL, # internal wrapper class, exercised via traces.monan ag_gof = NULL, # internal wrapper class, exercised via sienaGOF etc. grapht = NULL, # print method for animations, tested in test-grapht.R - changepoints.goldfish = function() autograph::goldfish_changepoints, - outliers.goldfish = function() autograph::goldfish_outliers, + goldfishChangepoints = function() autograph::goldfish_changepoints, + goldfishOutliers = function() autograph::goldfish_outliers, + goldfishOnset = function() autograph::goldfish_onset, + goldfishMargins = function() autograph::goldfish_margins, + goldfishGOF = function() autograph::goldfish_gof, + goldfishTimeTest = function() autograph::goldfish_time, + # The aliases kept for the older class names. The fixture is the precooked + # object with an old class put back: an alias restores dispatch only, so what + # it must plot is an object of the current shape under the older name. + diagnose_outliers = function() { + x <- autograph::goldfish_outliers + class(x)[1] <- "diagnose_outliers" + x + }, + diagnose_changepoints = function() { + x <- autograph::goldfish_changepoints + class(x)[1] <- "diagnose_changepoints" + x + }, + outliers.goldfish = function() { + x <- autograph::goldfish_outliers + class(x)[1] <- "outliers.goldfish" + x + }, + changepoints.goldfish = function() { + x <- autograph::goldfish_changepoints + class(x)[1] <- "changepoints.goldfish" + x + }, + # The overview draws each panel from a goldfish diagnostic rather than from + # the fit alone, so with goldfish absent or older than 1.9.21 every panel + # drops and the method prints and returns NULL. The audit accepts that, so + # this fixture exercises the composition where goldfish can supply it and + # the message where it cannot. + goldfishFit = function() autograph::goldfish_fit, + result.goldfish = function() { + x <- autograph::goldfish_fit + class(x)[1] <- "result.goldfish" + x + }, diff_model = function() autograph::res_manynet_diff, diffs_model = function() autograph::res_migraph_diff, learn_model = function() { @@ -148,12 +186,15 @@ test_that("diffusion summaries plot for mnet and diff_model objects", { }) test_that("goldfish diagnostics print a message when nothing is found", { + # Both flags are logical columns as goldfish 1.9.21 emits them: `outlier` + # replaces the old "YES"/"NO" strings, and `cpt` the old list of a data + # frame and a vector of break positions. quiet_outliers <- autograph::goldfish_outliers - quiet_outliers$outlier <- rep("NO", nrow(quiet_outliers)) + quiet_outliers$outlier <- rep(FALSE, nrow(quiet_outliers)) expect_output(out <- plot(quiet_outliers), "No outliers found") expect_null(out) quiet_cpts <- autograph::goldfish_changepoints - quiet_cpts$cpt_points <- NULL + quiet_cpts$cpt <- rep(FALSE, nrow(quiet_cpts)) expect_output(out <- plot(quiet_cpts), "No regime changes found") expect_null(out) }) @@ -192,6 +233,68 @@ test_that("graphs() shares layouts across waves and selects waves", { "patchwork") }) +# One scale per aesthetic across the panels, so that `patchwork` collects the +# guides into one legend and the same value is drawn the same way in each panel +# (stocnet/autograph#15). + +test_that("graphs() shares continuous scales across panels", { + skip_on_cran() + m0 <- matrix(c(0, 0, 0, 2, 0, + 0, 0, 4, 0, 0, + 0, 4, 0, 0, 0, + 2, 0, 0, 0, 1, + 0, 0, 0, 1, 0), 5, 5, + dimnames = list(letters[1:5], letters[1:5])) + m1 <- m0 + m1[4, 5] <- 0 + m1[5, 4] <- 0 + p <- suppressMessages(graphs(list(manynet::as_igraph(m0), + manynet::as_igraph(m1)))) + breaks <- lapply(1:2, function(i) + p[[i]]$scales$get_scales("edge_width")$get_breaks()) + expect_equal(breaks[[1]], breaks[[2]]) + # The lighter network holds no tie of weight 1, but is still scaled for one + expect_equal(p[[2]]$scales$get_scales("edge_width")$limits, c(1, 4)) + gt <- suppressMessages(patchwork::patchworkGrob(p)) + expect_length(grep("guide-box", gt$layout$name), 1) +}) + +test_that("graphs() shares categorical scales across panels", { + skip_on_cran() + ties <- matrix(c(0, 1, 1, 0, + 1, 0, 1, 0, + 1, 1, 0, 1, + 0, 0, 1, 0), 4, 4, + dimnames = list(letters[1:4], letters[1:4])) + n0 <- manynet::mutate_ties(manynet::as_igraph(ties), + type = c("a", "b", "c", "a")) + fewer <- ties + fewer[3, 4] <- 0 + fewer[4, 3] <- 0 + n1 <- manynet::mutate_ties(manynet::as_igraph(fewer), + type = c("a", "b", "a")) + p <- suppressMessages(graphs(list(n0, n1), edge_color = "type")) + labels <- lapply(1:2, function(i) + p[[i]]$scales$get_scales("edge_colour")$get_labels()) + expect_equal(labels[[1]], labels[[2]]) + expect_equal(labels[[1]], c("a", "b", "c")) + # "a" is drawn in the same colour in both panels, although only one of them + # holds all three types + drawn <- lapply(1:2, function(i) + suppressMessages(ggplot2::ggplot_build(p[[i]]))$data[[1]]$edge_colour[1]) + expect_equal(drawn[[1]], drawn[[2]]) +}) + +test_that("graphs() shares the diffusion scale across waves", { + skip_on_cran() + set.seed(2) + diff <- manynet::play_diffusion(manynet::ison_adolescents) + p <- suppressMessages(graphs(diff)) + labels <- lapply(1:2, function(i) + p[[i]]$scales$get_scales("fill")$get_labels()) + expect_equal(labels[[1]], labels[[2]]) +}) + test_that("graphs() handles ego networks and changing networks", { skip_on_cran() # a full set of egos gets the star layout centred on each ego @@ -232,7 +335,8 @@ test_that("graphs() splits a longitudinal network with non-character changing at # "Can't combine and " error; .to_waves_safe() coerces # them and retries. See .split_time_network()/.to_waves_safe() in R/grapht.R. expect_true(manynet::is_changing(manynet::fict_starwars)) - expect_true("active" %in% names(manynet::node_attribute(manynet::fict_starwars))) + expect_true("active" %in% + manynet::net_node_attributes(manynet::fict_starwars)) expect_true(is.logical(manynet::node_attribute(manynet::fict_starwars, "active"))) expect_s3_class(suppressMessages(graphs(manynet::fict_starwars)), "patchwork") }) diff --git a/tests/testthat/test-functional_themes.R b/tests/testthat/test-functional_themes.R index 609ab665..7e5b0e29 100644 --- a/tests/testthat/test-functional_themes.R +++ b/tests/testthat/test-functional_themes.R @@ -124,3 +124,151 @@ test_that("dark backgrounds are applied to plots under the neon theme", { bg <- p$theme$panel.background$fill expect_equal(bg, "#070f23") }) + +test_that("font detection sees system fonts and falls back cleanly", { + on.exit(suppressMessages(stocnet_theme("default")), add = TRUE) + # list_fonts() must report more than the handful of device aliases that + # grDevices lists, otherwise a font a user installs for a theme can never + # be matched. + fonts <- list_fonts() + expect_type(fonts, "character") + expect_true(length(fonts) > 0) + expect_false(anyDuplicated(fonts) > 0) + expect_true(all(list_fonts("sans") %in% fonts)) + # Themes that name no font get the sans-serif fallback without complaint. + suppressMessages(stocnet_theme("default")) + expect_equal(ag_font(), "sans") + # A theme that names fonts either matches one of them or falls back. + suppressMessages(stocnet_theme("clay")) + expect_true(ag_font() %in% c(autograph:::theme_fonts("clay"), "sans")) +}) + +test_that("palettes separate colours for colour-blind viewers", { + on.exit(suppressMessages(stocnet_theme("default")), add = TRUE) + # Simulation is anchored on a pair that normal vision separates easily and + # red-green colour blindness does not. + expect_gt(check_separation(c("#B7352D", "#4575b4"))[1, 2], 40) + expect_lt(check_separation(c("#B7352D", "#627313"))[1, 2], 10) + expect_length(simulate_colorblind(c("#d73027", "#4575b4"), "deutan"), 2) + expect_error(simulate_colorblind("#d73027", "quadran")) + # A lower severity is anomalous trichromacy, which moves a colour less far + # than dichromacy does, and severity zero moves it not at all. + expect_identical(simulate_colorblind("#d73027", "deutan", severity = 0), + simulate_colorblind("#d73027", "normal")) + expect_lt(check_separation(c("#B7352D", "#627313"))[1, 2], + check_separation(c(simulate_colorblind("#B7352D", "deutan", 0.4), + simulate_colorblind("#627313", "deutan", 0.4)))[1, 2]) + expect_error(simulate_colorblind("#d73027", "deutan", severity = 2)) + # Greyscale keeps only the luminance, so a colour and its grey have the + # same relative luminance, and two colours of the same lightness merge. + expect_lt(min(attr(check_separation(c("#d73027", "#4575b4")), "grey"), + na.rm = TRUE), + check_separation(c("#d73027", "#4575b4"))[1, 2]) + + for (thm in autograph:::theme_opts) { + suppressMessages(stocnet_theme(thm)) + # Each stored palette is already in the order colorblind_sort() would choose, so + # that a palette added later cannot ship in an order that hides colours + # from one another. The exception is a palette whose own order is the + # point, which is sampled across its length instead. + pal <- getOption("snet_cat") + if (thm %in% autograph:::colorblind_unsorted) { + expect_true(getOption("snet_cat_spread"), info = thm) + } else { + expect_false(getOption("snet_cat_spread"), info = thm) + expect_identical(autograph:::colorblind_sort(pal, getOption("snet_background")), + pal, info = thm) + } + # The colours a plot of two to four categories gets must be separable by + # every viewer, not only by those with unaffected colour vision. + for (k in 2:4) { + if (k > length(pal)) next + cols <- ag_qualitative(k) + expect_gt(min(check_separation(cols)[upper.tri(diag(k))]), 10) + } + # Divergent poles must not be a red-green pair, and the two highlights + # must not be a pair only some viewers can tell apart. + dv <- getOption("snet_div") + expect_gt(check_separation(dv[c(1, length(dv))])[1, 2], 40, label = thm) + hl <- getOption("snet_highlight") + expect_gt(check_separation(hl)[1, 2], 20, label = thm) + # The ink must stay legible on the theme's own ground, whether that + # ground is white, ivory, or near-black. The distance says the two are + # different colours; the WCAG ratio says the text can actually be read, + # which is the question a reader is asking. + bg <- getOption("snet_background") + expect_gt(check_separation(c(ag_ink(), bg))[1, 2], 50, label = thm) + expect_gte(check_contrast(ag_ink(), bg)[1, 2], 4.5, label = thm) + # WCAG asks 3:1 of a graphical object. Two highlights are an institution's + # own colour on that institution's own ground, and repainting a brand is + # not something this package does -- see the Colour blindness section of + # ?ag_call -- so they are held to a lower floor, named here so that a + # palette added later cannot join them quietly. + hl_floor <- if (thm %in% c("clay", "oxf")) 2.5 else 3 + expect_gte(check_contrast(ag_highlight(), bg)[1, 2], hl_floor, label = thm) + # The colour missing data recedes into must be visible on the ground and + # must not be read as one of the categories. + expect_gte(check_contrast(ag_missing(), bg)[1, 2], 3, label = thm) + expect_gt(min(check_separation(c(ag_missing(), pal))[1, -1]), 8, label = thm) + } + # Greyscale is reported, not enforced: an institutional palette that + # separates by hue collapses in print and should not fail for it. The "bw" + # theme is the one built for print, so it is held to the standard. + suppressMessages(stocnet_theme("bw")) + expect_gt(min(attr(check_separation(ag_qualitative(2)), "grey"), na.rm = TRUE), + 25) +}) + +test_that("the medium scales text and prints on white", { + on.exit({ + suppressMessages(stocnet_theme("default")) + suppressMessages(stocnet_medium("screen")) + }, add = TRUE) + suppressMessages(stocnet_medium("screen")) + expect_equal(ag_size(), 1) + expect_equal(autograph:::ag_text_size(3), 3) + suppressMessages(stocnet_medium("presentation")) + expect_gt(ag_size(), 1) + expect_equal(autograph:::ag_text_size(3), 3 * ag_size()) + # The base size every plot is built from follows the medium. + small <- autograph:::ag_theme_minimal()$text$size + suppressMessages(stocnet_medium("mobile")) + expect_gt(autograph:::ag_theme_minimal()$text$size, small) + # A caller that sets its own base size still has it scaled, not overridden. + expect_equal(autograph:::ag_theme_minimal(base_size = 8)$text$size, + 8 * ag_size()) + # Print draws on white whatever the theme prefers, and the ink follows the + # ground rather than staying the light ink a dark theme chose. + suppressMessages(stocnet_theme("neon")) + expect_equal(getOption("snet_background"), "#070f23") + suppressMessages(stocnet_medium("print")) + expect_equal(autograph:::ag_ground_fill(), "#FFFFFF") + expect_gte(check_contrast(ag_ink())[1, 2], 4.5) + # The palettes are the theme's own in every medium. + expect_equal(ag_highlight(), "#fdfd54") + expect_error(stocnet_medium("papyrus")) +}) + +test_that("a theme's ground reaches every plot, not only the graphs", { + on.exit(suppressMessages(stocnet_theme("default")), add = TRUE) + suppressMessages(stocnet_theme("neon")) + # A dark theme used to ground graphr() alone, so every other plot drew the + # theme's bright colours on white. + p <- plot(netrics::node_by_degree(manynet::ison_adolescents)) + expect_equal(p$theme$plot.background$fill, "#070f23") + expect_equal(p$theme$text$colour, ag_ink()) + g <- graphr(manynet::ison_adolescents) + expect_equal(g$theme$panel.background$fill, "#070f23") + # Grounding a graph must not put back what theme_void() blanked: colouring + # the axis text drew coordinates and ticks onto graphs that have no use for + # them, and that the white-backed themes never showed. + expect_s3_class(g$theme$axis.text, "element_blank") + # Ties take the colour the theme writes with, so that a dark ground does + # not swallow them. + expect_equal(autograph:::.infer_ecolor(manynet::as_igraph(manynet::ison_adolescents), + NULL), ag_ink()) + # A white-backed theme is left exactly as ggplot2 draws it. + suppressMessages(stocnet_theme("default")) + p <- plot(netrics::node_by_degree(manynet::ison_adolescents)) + expect_null(p$theme$plot.background$fill) +}) diff --git a/tests/testthat/test-graph_backbone.R b/tests/testthat/test-graph_backbone.R new file mode 100644 index 00000000..819f9bdf --- /dev/null +++ b/tests/testthat/test-graph_backbone.R @@ -0,0 +1,132 @@ +# The backbone behind `graphr(backbone = )`: which ties a filter keeps, how +# they are drawn, and the layouts they move. See R/graph_backbone.R. + +# A modular network dense enough to draw as a hairball: four groups of thirty, +# tied often within a group and seldom between. +bb_fixture <- local({ + set.seed(42) + pm <- matrix(0.03, 4, 4) + diag(pm) <- 0.35 + ag_net(igraph::sample_sbm(120, pm, rep(30, 4))) +}) + +bb_alphas <- function(p) { + sort(unique(ggplot2::ggplot_build(p)$data[[1]][["edge_alpha"]])) +} + +test_that("the backbone argument resolves each of the forms it takes", { + expect_identical(.check_backbone(NULL), "auto") + expect_null(.check_backbone(FALSE)) + expect_equal(.check_backbone(TRUE), list(filter = NULL, threshold = NULL)) + expect_equal(.check_backbone("disparity"), + list(filter = "disparity", threshold = NULL)) + expect_equal(.check_backbone(0.01), list(filter = NULL, threshold = 0.01)) + # A misspelling is named, with the nearest filter suggested. + expect_error(.check_backbone("simmelain"), "simmelian") + expect_error(.check_backbone(5), "threshold between 0 and 1") + expect_error(.check_backbone(c(TRUE, FALSE)), "threshold between 0 and 1") +}) + +test_that("only a large, dense network counts as a hairball", { + expect_true(.is_hairball(bb_fixture)) + expect_false(.is_hairball(ag_net(manynet::ison_adolescents))) + # Fifty nodes are enough only where the ties are, at four for each node. + expect_false(.is_hairball(ag_net(manynet::create_ring(60)))) +}) + +test_that("a backbone fades the ties the filter does not keep", { + skip_if_not(manynet_has("tie_is_backbone")) + p <- suppressMessages(graphr(bb_fixture, backbone = TRUE, labels = FALSE)) + expect_buildable(p) + expect_equal(bb_alphas(p), c(0.08, 0.4)) + plain <- suppressMessages(graphr(bb_fixture, backbone = FALSE, + labels = FALSE)) + expect_buildable(plain) + expect_equal(bb_alphas(plain), 0.4) +}) + +test_that("a backbone is drawn without being asked for, and can be refused", { + skip_if_not(manynet_has("tie_is_backbone")) + auto <- suppressMessages(graphr(bb_fixture, labels = FALSE)) + expect_equal(bb_alphas(auto), c(0.08, 0.4)) + # A network the reader can already follow is left alone. + small <- graphr(manynet::ison_adolescents) + expect_equal(bb_alphas(small), 0.4) +}) + +test_that("a backbone moves the layouts that read tie lengths", { + skip_if_not(manynet_has("tie_is_backbone")) + moved <- suppressMessages(graphr(bb_fixture, layout = "stress", + backbone = TRUE, labels = FALSE)) + plain <- suppressMessages(graphr(bb_fixture, layout = "stress", + backbone = FALSE, labels = FALSE)) + expect_false(isTRUE(all.equal(moved$data[, c("x", "y")], + plain$data[, c("x", "y")]))) + # A layout whose coordinates carry meaning keeps them, and fades only. + fixed <- suppressMessages(graphr(manynet::ison_networkers, + layout = "scaling", backbone = TRUE, + labels = FALSE)) + unfixed <- suppressMessages(graphr(manynet::ison_networkers, + layout = "scaling", backbone = FALSE, + labels = FALSE)) + expect_equal(fixed$data[, c("x", "y")], unfixed$data[, c("x", "y")]) + expect_equal(bb_alphas(fixed), c(0.08, 0.4)) +}) + +test_that("a tie length points the way each layout reads it", { + # A line of four nodes, of which the middle tie is the one kept. Every node + # holds a kept tie except the last, whose only tie is anchored below. + line <- igraph::make_graph(~ A - B, B - C, C - D) + mark <- c(FALSE, TRUE, FALSE) + # ggraph inverts the weights it hands to "stress", so a larger weight there + # draws two nodes together, as it does in "fr" and "drl". + # The first and last ties are drawn short as well, since they are all that + # holds nodes A and D beside the rest. See `.backbone_anchored()`. + expect_equal(.backbone_layout_weights(line, "stress", mark), c(4, 4, 4)) + # A node that the filter left a tie of is not anchored again. + star <- igraph::make_graph(~ A - B, B - C, A - C, C - D) + expect_equal(.backbone_anchored(star, c(TRUE, TRUE, TRUE, FALSE)), + c(TRUE, TRUE, TRUE, TRUE)) + expect_equal(.backbone_anchored(star, c(TRUE, TRUE, TRUE, TRUE)), + c(TRUE, TRUE, TRUE, TRUE)) + short <- .backbone_anchored(line, mark) + expect_equal(.backbone_layout_weights(line, "fr", mark), + ifelse(short, 4, 1)) + # "kk" reads a weight as a distance, so the ties drawn short take the + # smaller one. + expect_equal(.backbone_layout_weights(line, "kk", mark), + ifelse(short, 1, 4)) + # A layout that reads no tie lengths is left as it is. + expect_null(.backbone_layout_weights(line, "circle", mark)) + expect_null(.backbone_layout_weights(line, "layered", mark)) + expect_false(.backbone_moves_layout("scaling")) +}) + +test_that("a network without a backbone to draw is drawn as it was", { + skip_if_not(manynet_has("tie_is_backbone")) + # A signed network has no backbone, since these null models have no place + # for a negative weight. + signed <- suppressMessages(graphr(manynet::fict_marvel, backbone = TRUE, + labels = FALSE)) + expect_buildable(signed) + expect_null(.infer_backbone(ag_net(manynet::fict_marvel), + list(filter = NULL, threshold = NULL))) + # A two-mode network holds no triangle, so a Simmelian filter keeps no tie. + expect_null(.infer_backbone(ag_net(manynet::ison_southern_women), + list(filter = NULL, threshold = NULL))) + # An empty network has no tie to mark. + expect_null(.infer_backbone(ag_net(manynet::create_empty(10)), + list(filter = NULL, threshold = NULL))) +}) + +test_that("a bundled network is drawn without a fading", { + skip_if_not(manynet_has("tie_is_backbone")) + p <- suppressMessages(graphr(bb_fixture, backbone = TRUE, labels = FALSE, + edge_bundle = TRUE)) + expect_buildable(p) +}) + +test_that("the filters are offered as completions", { + vals <- .completion_values("backbone", bb_fixture) + expect_setequal(vals[["value"]], .backbone_filters()) +}) diff --git a/tests/testthat/test-graph_completion.R b/tests/testthat/test-graph_completion.R new file mode 100644 index 00000000..ce6fe4ce --- /dev/null +++ b/tests/testthat/test-graph_completion.R @@ -0,0 +1,299 @@ +# Completion of argument values (R/graph_completion.R). +# +# The parsing and candidate functions are tested directly, since they know +# nothing about RStudio. The hook is tested against a stand-in for RStudio's +# `tools:rstudio` environment: pressing Tab itself cannot be tested here. + +# Reading the line ---- + +test_that("the line is read for the call, argument and value being typed", { + ctx <- autograph:::.completion_context('graphr(fict_lotr, node_color = "Ra') + expect_equal(ctx$fun, "graphr") + expect_equal(ctx$arg, "node_color") + expect_equal(ctx$token, "Ra") + expect_true(ctx$quoted) + expect_equal(ctx$data, "fict_lotr") +}) + +test_that("a value without quotes, and one still empty, are both read", { + ctx <- autograph:::.completion_context("graphr(fict_lotr, node_color = ") + expect_equal(ctx$arg, "node_color") + expect_equal(ctx$token, "") + expect_false(ctx$quoted) + ctx <- autograph:::.completion_context('graphr(fict_lotr, layout = "') + expect_equal(ctx$arg, "layout") + expect_equal(ctx$token, "") +}) + +test_that("an argument given by position is matched to the right formal", { + # The second formal of graphr() is `layout`, and the first is taken by the + # network, so an unnamed second value is a layout. + ctx <- autograph:::.completion_context('graphr(fict_lotr, "st') + expect_equal(ctx$arg, "layout") + # A formal already given by name is not offered again for a position. + ctx <- autograph:::.completion_context('graphr(fict_lotr, layout = "fr", "') + expect_equal(ctx$arg, "labels") +}) + +test_that("a value inside c() belongs to the argument c() is given to", { + ctx <- autograph:::.completion_context('graphr(fict_lotr, labels = c("Fro') + expect_equal(ctx$arg, "labels") + expect_equal(ctx$token, "Fro") +}) + +test_that("lines that are not one of these calls are left alone", { + expect_null(autograph:::.completion_context("mean(x, na.rm = ")) + expect_null(autograph:::.completion_context('graphr(fict_lotr, node_size = fn("')) + expect_null(autograph:::.completion_context("graphr(fict_lotr)")) + expect_null(autograph:::.completion_context("")) + expect_null(autograph:::.completion_context(NULL)) +}) + +test_that("a nested call does not confuse the commas", { + ctx <- autograph:::.completion_context('plot(graphr(fict_lotr, node_color = "R') + expect_equal(ctx$fun, "graphr") + expect_equal(ctx$arg, "node_color") + ctx <- autograph:::.completion_context('graphr(fict_lotr[1:2, ], node_color = "') + expect_equal(ctx$arg, "node_color") +}) + +# Candidate values ---- + +# The values are a data frame; `values()` reads just the column of values. +values <- function(...) autograph:::.completion_values(...)$value + +test_that("each argument offers the values it accepts", { + g <- manynet::as_igraph(manynet::fict_lotr) + expect_true("Race" %in% values("node_color", g)) + expect_true("Race" %in% values("node_colour", g)) + expect_true("Race" %in% values("node_size", g)) + # Node attributes come before the literal values an argument also takes. + shapes <- values("node_shape", g) + expect_equal(shapes[1], "Race") + expect_true("circle" %in% shapes) + # Node labels are not variables to map an aesthetic to. + expect_false("name" %in% values("node_color", g)) +}) + +test_that("layouts, themes and labels offer their own sets", { + g <- manynet::as_igraph(manynet::fict_lotr) + layouts <- values("layout", g) + expect_true(all(autograph:::.autograph_layouts() %in% layouts)) + # autograph's own layouts come first, being the ones not documented elsewhere. + expect_equal(layouts[seq_along(autograph:::.autograph_layouts())], + autograph:::.autograph_layouts()) + expect_equal(values("theme"), autograph:::theme_opts) + labels <- values("labels", g) + expect_true(all(autograph:::.label_criteria() %in% labels)) + expect_true("Frodo" %in% labels) +}) + +test_that("an argument whose default is a set of choices offers them", { + expect_equal(values("isolates", NULL, "graphr"), c("legend", "caption", "keep")) + expect_equal(values("isolates", NULL, "grapht"), c("keep", "fade")) + expect_equal(values("based_on", NULL, "graphs"), c("first", "last", "both")) +}) + +test_that("an argument with no known set offers nothing", { + g <- manynet::as_igraph(manynet::fict_lotr) + expect_equal(nrow(autograph:::.completion_values("snap", g)), 0L) + expect_equal(nrow(autograph:::.completion_values("", g)), 0L) + # Without a network there are no attributes to offer. + expect_equal(nrow(autograph:::.completion_values("node_color", NULL)), 0L) +}) + +# What each value is labelled with ---- + +test_that("a variable is labelled with its kind and a line about its values", { + g <- manynet::as_igraph(manynet::fict_greys) + vals <- autograph:::.completion_values("node_color", g) + expect_equal(vals$label[vals$value == "sex"], "character") + expect_equal(vals$label[vals$value == "birthyear"], "numeric") + # Few enough categories to read at a glance are named outright. + expect_equal(vals$meta[vals$value == "sex"], "F, M") + # More than that are counted instead. + expect_match(vals$meta[vals$value == "position"], "^[0-9]+ categories$") + # A number runs over a range. + expect_equal(vals$meta[vals$value == "birthyear"], "1944 to 1987") +}) + +test_that("values that are not variables carry a label of their own", { + g <- manynet::as_igraph(manynet::fict_lotr) + shapes <- autograph:::.completion_values("node_shape", g) + expect_equal(shapes$label[shapes$value == "circle"], "shape") + themes <- autograph:::.completion_values("theme") + expect_true(all(themes$label == "theme")) + labels <- autograph:::.completion_values("labels", g) + expect_equal(labels$label[labels$value == "degree"], "measure") + expect_equal(labels$label[labels$value == "Frodo"], "node") + isolates <- autograph:::.completion_values("isolates", NULL, "graphr") + expect_true(all(isolates$label == "option")) +}) + +test_that("a layout is labelled with the package that draws it", { + layouts <- autograph:::.completion_values("layout") + expect_true(all(layouts$label[layouts$value %in% autograph:::.autograph_layouts()] == + "autograph")) + expect_equal(layouts$label[layouts$value == "circle"], "igraph") + expect_true("ggraph" %in% layouts$label) +}) + +test_that("a mark is labelled as one, and only marks are offered for labels", { + g <- manynet::as_igraph(manynet::fict_lotr) + g <- igraph::set_vertex_attr(g, "is_hobbit", + value = manynet::node_labels(g) %in% c("Frodo", "Sam")) + vals <- autograph:::.completion_values("labels", g) + expect_equal(vals$label[vals$value == "is_hobbit"], "mark") + expect_equal(vals$meta[vals$value == "is_hobbit"], + paste("2 of", manynet::net_nodes(g))) + # `Race` is a variable rather than a selection of nodes, so it is not offered. + expect_false("Race" %in% autograph:::.completion_marks(g)) + expect_true("is_hobbit" %in% autograph:::.completion_marks(g)) +}) + +# Finding the network ---- + +test_that("only a symbol is looked up, and never a call", { + net <- manynet::fict_lotr + expect_s3_class(autograph:::.completion_object("net", environment()), "igraph") + expect_null(autograph:::.completion_object("to_undirected(net)", environment())) + expect_null(autograph:::.completion_object("nosuchobject", environment())) + expect_null(autograph:::.completion_object("", environment())) + # An object that is not a network is not one to complete from. + notanet <- 1:5 + expect_null(autograph:::.completion_object("notanet", environment())) +}) + +# What is offered ---- + +test_that("what is offered narrows to what has been typed", { + fict_lotr <- manynet::fict_lotr + out <- autograph:::.completion_suggest('graphr(fict_lotr, node_color = "', + environment()) + expect_equal(out$values$value, "Race") + expect_true(out$quoted) + out <- autograph:::.completion_suggest('graphr(fict_lotr, node_color = "Ra', + environment()) + expect_equal(out$token, "Ra") + expect_equal(out$values$value, "Race") + # Matching ignores case, as .match_name() does when the value is given. + out <- autograph:::.completion_suggest('graphr(fict_lotr, node_color = "ra', + environment()) + expect_equal(out$values$value, "Race") + # Nothing to offer, rather than an empty list of completions. + expect_null(autograph:::.completion_suggest('graphr(fict_lotr, node_color = "zz', + environment())) + expect_null(autograph:::.completion_suggest("mean(x, na.rm = ", environment())) +}) + +# The RStudio hook ---- + +# A stand-in for the three things this uses from RStudio, attached under the +# name RStudio gives its own environment. +with_fake_rstudio <- function(code) { + fake <- list( + .rs.rpc.get_completions = function(token, contextData, line, isConsole) + "rstudio's own", + .rs.makeCompletions = function(token, results, packages, meta, quote, type, + excludeOtherCompletions) + list(token = token, results = results, packages = packages, meta = meta, + quote = quote, type = type), + .rs.acCompletionTypes = list(COLUMN = 27, STRING = 20)) + suppressWarnings(attach(fake, name = "tools:rstudio", warn.conflicts = FALSE)) + on.exit(detach("tools:rstudio"), add = TRUE) + force(code) +} + +test_that("activation replaces RStudio's function and deactivation restores it", { + with_fake_rstudio({ + env <- as.environment("tools:rstudio") + original <- get(".rs.rpc.get_completions", envir = env) + expect_false(autograph:::.completion_active()) + expect_true(autograph:::.completion_activate()) + expect_true(autograph:::.completion_active()) + expect_false(identical(get(".rs.rpc.get_completions", envir = env), original)) + # Formals are taken from the version installed, so every argument RStudio + # passes still reaches the original. + expect_equal(names(formals(get(".rs.rpc.get_completions", envir = env))), + names(formals(original))) + # Activating twice is not an error, and does not wrap the wrapper. + expect_true(autograph:::.completion_activate()) + expect_true(autograph:::.completion_deactivate()) + expect_false(autograph:::.completion_active()) + expect_identical(get(".rs.rpc.get_completions", envir = env), original) + }) +}) + +test_that("a line this does not recognise is passed to RStudio untouched", { + with_fake_rstudio({ + env <- as.environment("tools:rstudio") + autograph:::.completion_activate() + on.exit(autograph:::.completion_deactivate(), add = TRUE) + completions <- get(".rs.rpc.get_completions", envir = env) + expect_equal(completions("", list(), "mean(x, na.rm = ", TRUE), + "rstudio's own") + # An argument that is missing is not forced, and a line of the wrong shape + # is RStudio's business too. + expect_equal(completions("", list(), character(), TRUE), "rstudio's own") + }) +}) + +test_that("a recognised line is answered with the values available", { + # `fict_lotr` is found on the search path, as it would be for a user who has + # attached manynet. + with_fake_rstudio({ + env <- as.environment("tools:rstudio") + autograph:::.completion_activate() + on.exit(autograph:::.completion_deactivate(), add = TRUE) + completions <- get(".rs.rpc.get_completions", envir = env) + out <- completions("", list(), 'graphr(fict_lotr, node_color = "', TRUE) + expect_equal(out$results, "Race") + # The kind of variable is shown in brackets beside it, and its values after. + expect_equal(out$packages, "character") + expect_match(out$meta, "categories$") + # Already inside quotes, so the value is inserted without adding more. + expect_false(out$quote) + out <- completions("", list(), "graphr(fict_lotr, node_color = ", TRUE) + expect_true(out$quote) + }) +}) + +test_that("a broken RStudio function leaves completion working", { + with_fake_rstudio({ + env <- as.environment("tools:rstudio") + # Whatever changes in RStudio, an error here must not stop completion. + assign(".rs.makeCompletions", function(...) stop("changed"), envir = env) + autograph:::.completion_activate() + on.exit(autograph:::.completion_deactivate(), add = TRUE) + completions <- get(".rs.rpc.get_completions", envir = env) + expect_equal(completions("", list(), 'graphr(fict_lotr, node_color = "', TRUE), + "rstudio's own") + }) +}) + +test_that("outside RStudio nothing is changed", { + expect_null(autograph:::.completion_env()) + expect_false(autograph:::.completion_active()) + expect_false(autograph:::.completion_activate()) + expect_false(autograph:::.completion_deactivate()) + expect_false(suppressMessages(stocnet_completion(TRUE))) + expect_false(suppressMessages(stocnet_completion())) +}) + +test_that("the completion preference is written and forgotten on request", { + # R_user_dir() is redirected so the test never touches the real config. + tmp <- tempfile("agconfig") + dir.create(tmp) + old <- Sys.getenv("R_USER_CONFIG_DIR", unset = NA) + Sys.setenv(R_USER_CONFIG_DIR = tmp) + on.exit({ + if (is.na(old)) Sys.unsetenv("R_USER_CONFIG_DIR") + else Sys.setenv(R_USER_CONFIG_DIR = old) + unlink(tmp, recursive = TRUE) + }, add = TRUE) + + expect_true(autograph:::write_pref("completion", TRUE)) + expect_true(autograph:::read_pref("completion")) + autograph:::forget_pref("completion") + expect_null(autograph:::read_pref("completion")) +}) diff --git a/tests/testthat/test-graph_snap.R b/tests/testthat/test-graph_snap.R new file mode 100644 index 00000000..184f971f --- /dev/null +++ b/tests/testthat/test-graph_snap.R @@ -0,0 +1,111 @@ +# The grid-snapping step behind `graphr(snap = TRUE)`, and the layouts it +# deliberately leaves alone. See R/graph_snap.R and `.fixed_layouts()`. + +test_that("snapping a layout to the grid yields integer-ish unique positions", { + skip_on_cran() + p <- graphr(manynet::ison_adolescents, snap = TRUE) + expect_buildable(p) + # depth_first_recursive_search() assigns each node its own grid point + expect_false(any(duplicated(p$data[, c("x", "y")]))) +}) + +test_that("lattice networks snap onto a full rectangular grid", { + skip_on_cran() + # A lattice repeats two steps, which .snap_basis() maps onto the axes, so + # every node lands on its own point of a rectangle of rows and columns. + # create_lattice(12) is triangular (interior degree 6): its third family of + # ties is drawn as diagonals of that same square grid. + for (g in list(manynet::create_lattice(9), + manynet::create_lattice(12), + manynet::create_lattice(16), + manynet::create_lattice(12, width = 4), + manynet::create_lattice(20, width = 4))) { + p <- suppressMessages(graphr(g, snap = TRUE)) + expect_buildable(p) + d <- p$data[, c("x", "y")] + expect_equal(d$x, round(d$x)) + expect_equal(d$y, round(d$y)) + expect_false(any(duplicated(d))) + # no gap in any row or column: the grid is filled exactly + expect_equal(length(unique(d$x)) * length(unique(d$y)), nrow(d)) + } +}) + +test_that("networks without a repeating structure take the fallback", { + skip_on_cran() + # A ring and a tree have about as many ties as nodes and no repeating steps, + # so .snap_basis() declines them and depth_first_recursive_search() snaps + # them instead. + for (g in list(manynet::ison_adolescents, manynet::create_ring(12), + manynet::create_tree(15))) { + lo <- ggraph::create_layout(manynet::as_tidygraph(g), "stress") + expect_null(.snap_basis(lo, manynet::as_igraph(g))) + p <- suppressMessages(graphr(g, snap = TRUE)) + expect_buildable(p) + expect_false(any(duplicated(p$data[, c("x", "y")]))) + } +}) + +test_that("snapping a named network reads its ties by position", { + skip_on_cran() + # Regression: .edge_angle_deviation() read the tie ends with + # igraph::as_edgelist(graph), which returns node names for a named network. + # Indexing the coordinates by name gave NA, and the rotation score with it. + p <- suppressMessages(graphr(manynet::fict_lotr, snap = TRUE)) + expect_buildable(p) + expect_false(anyNA(p$data[, c("x", "y")])) +}) + +test_that("a cardinal rotation scores better than a diagonal one", { + skip_on_cran() + # Regression: the deviation was measured from 45 degrees, so which.min() + # picked the angle at which the fewest ties ran cardinally. + g <- manynet::as_igraph(manynet::create_lattice(12, width = 4)) + lo <- ggraph::create_layout(manynet::as_tidygraph(g), "stress") + cardinal <- .snap_rotate(lo, g) + expect_lt(.edge_angle_deviation(cardinal, g), + .edge_angle_deviation(.rotate_layout(cardinal, pi/4), g)) +}) + +test_that("snapping a two-mode (layered) layout falls back gracefully", { + skip_on_cran() + # The default two-mode layout is "layered", whose layered coordinates + # would be collapsed by square-grid snapping, so snapping is skipped and + # the original coordinates are retained (see graph_layout()). + old <- options(snet_verbosity = "verbose") + on.exit(options(old), add = TRUE) + expect_message( + graphr(manynet::ison_southern_women, snap = TRUE), + "layered") + snapped <- suppressMessages(graphr(manynet::ison_southern_women, snap = TRUE)) + plain <- graphr(manynet::ison_southern_women) + expect_buildable(snapped) + expect_equal(snapped$data[, c("x", "y")], plain$data[, c("x", "y")]) +}) + +test_that("snapping still works on a two-mode network with a force layout", { + skip_on_cran() + p <- suppressMessages( + graphr(manynet::ison_southern_women, layout = "stress", snap = TRUE)) + expect_buildable(p) + # every node lands on its own grid point + expect_false(any(duplicated(p$data[, c("x", "y")]))) +}) + +test_that("snapping returns coordinates in the original node order (>= 10 nodes)", { + skip_on_cran() + # Regression: depth_first_recursive_search() sorts nodes by centroid distance + # internally, then must restore the input node order before returning, because + # graph_layout() assigns the result positionally. Ordering the row names + # lexicographically ("1","10","11",...,"2") scrambled coordinates across nodes + # for any network with 10+ nodes; they must be ordered numerically. + lo <- ggraph::create_layout(manynet::as_tidygraph(manynet::fict_lotr), + "stress") + expect_true(nrow(lo) >= 10) + out <- depth_first_recursive_search(lo) + # returned rows line up with the input nodes, not a lexicographic shuffle + expect_identical(rownames(out), as.character(seq_len(nrow(out)))) + # snapped positions track the pre-snap layout rather than being permuted + expect_gt(stats::cor(lo$x, out$x), 0.5) + expect_gt(stats::cor(lo$y, out$y), 0.5) +}) diff --git a/tests/testthat/test-graphr.R b/tests/testthat/test-graphr.R index 5645d232..843a6af5 100644 --- a/tests/testthat/test-graphr.R +++ b/tests/testthat/test-graphr.R @@ -90,7 +90,7 @@ test_that("weighted, unsigned, directed networks graph correctly", { test_that("fancy node mods graph correctly", { skip_on_cran() # one-mode network - fmrg <- dplyr::mutate(fmrg, nodesize = Appearances/1000) + fmrg <- dplyr::mutate(ag_net(fmrg), nodesize = Appearances/1000) testcolnodes <- graphr(fmrg, node_color = "Gender", node_size = "Appearances", node_shape = "Attractive") @@ -112,9 +112,9 @@ test_that("fancy node mods graph correctly", { test_that("edge colours and edge size graph correctly", { skip_on_cran() - ison_brandes2 <- ison_brandes %>% + ison_brandes2 <- ison_brandes |> add_tie_attribute("tiecolour", - c("A", "B", "A", "B", "B", "B", "B", "B", "B", "B", "B", "B")) %>% + c("A", "B", "A", "B", "B", "B", "B", "B", "B", "B", "B", "B")) |> add_tie_attribute("weight", c(rep(1:6, 2))) test_brandes2 <- graphr(ison_brandes2, edge_color = "tiecolour", edge_size = "weight") expect_false(is.null(test_brandes2$layers[[1]]$mapping$edge_colour)) @@ -137,6 +137,34 @@ test_that("node_group works correctly", { graphr(ison_lawfirm, node_group = "gender")) }) +test_that("node_group draws overlapping hulls from a membership matrix", { + skip_on_cran() + skip_if_not_installed("netrics", "1.0.0") + skip_if_not_installed("ggforce") + cliques <- netrics::node_x_clique(ison_adolescents) + p <- graphr(ison_adolescents, node_group = netrics::node_x_clique()) + hulls <- p[["layers"]][[1]][["data"]] + # One row for each membership, so a node in two cliques appears twice. + expect_equal(nrow(hulls), sum(cliques > 0)) + expect_equal(levels(hulls[["node_group"]]), colnames(cliques)) + # Naming the network, or a matrix calculated beforehand, gives the same plot. + expect_equal(graphr(ison_adolescents, node_group = cliques)[["layers"]][[1]][["data"]], + hulls) + expect_error(graphr(ison_adolescents, node_group = matrix(1, 3, 2)), + "8 nodes") +}) + +test_that("node_group accepts a membership vector", { + skip_on_cran() + skip_if_not_installed("ggforce") + memb <- c(1, 1, 1, 2, 2, 2, 3, 3) + expect_equal(graphr(ison_adolescents, node_group = memb)[["layers"]][[1]][["data"]][["node_group"]], + graphr(ison_adolescents |> dplyr::mutate(grp = memb), + node_group = "grp")[["layers"]][[1]][["data"]][["node_group"]]) + expect_error(graphr(ison_adolescents, node_group = c(1, 2)), + "membership vector") +}) + test_that("unquoted arguments plot correctly", { skip_on_cran() expect_equal(graphr(ison_lawfirm, node_color = "gender"), @@ -148,10 +176,12 @@ test_that("nodes use fill aesthetic instead of colour", { skip_on_cran() # Default node uses fill parameter p <- graphr(ison_brandes) - expect_equal(p[["layers"]][[2]][["aes_params"]][["fill"]], "black") + # The default node fill is the colour the theme writes with, which is a + # near-black on a white ground and a near-white on a dark one. + expect_equal(p[["layers"]][[2]][["aes_params"]][["fill"]], ag_ink()) # Mapped node_color uses fill in aes - p2 <- ison_brandes %>% - dplyr::mutate(color = c(rep(c(1, 2), 5), 1)) %>% + p2 <- ison_brandes |> + dplyr::mutate(color = c(rep(c(1, 2), 5), 1)) |> graphr(node_color = color) expect_false(is.null(p2[["layers"]][[2]][["mapping"]][["fill"]])) }) @@ -159,8 +189,8 @@ test_that("nodes use fill aesthetic instead of colour", { test_that("node_color with multiple values uses fill scale", { skip_on_cran() # More than 2 colors triggers scale_fill_manual with qualitative palette - p <- ison_brandes %>% - dplyr::mutate(grp = c(rep(c("a", "b", "c"), 3), "a", "b")) %>% + p <- ison_brandes |> + dplyr::mutate(grp = c(rep(c("a", "b", "c"), 3), "a", "b")) |> graphr(node_color = grp) expect_s3_class(p, c("ggraph", "gg", "ggplot")) # Check that fill scale is used (not colour) @@ -179,11 +209,95 @@ test_that("two-mode networks get correct node shapes", { expect_false(is.null(node_layer[["mapping"]][["shape"]])) }) +test_that("two-mode shape legends name the modes where the network does", { + skip_on_cran() + # "One" and "Two" say nothing that the shapes do not already say. + expect_equal(levels(.infer_nshape(ag_net(fict_marvel), NULL)), + c("characters", "teams")) + expect_equal(levels(.infer_nshape(ag_net(ison_southern_women), NULL)), + c("women", "social events")) + # A factor rather than a character vector, so that the first mode keeps the + # first shape: "social events" would otherwise sort before "women" and the + # two modes would swap symbols. + shapes <- .infer_nshape(ag_net(ison_southern_women), NULL) + expect_s3_class(shapes, "factor") + expect_equal(as.character(shapes[!manynet::node_is_mode(ison_southern_women)][1]), + "women") + # Networks that do not record their modes keep the old labels. + expect_null(manynet::mode_names(irps_revere)) + expect_equal(levels(.infer_nshape(ag_net(irps_revere), NULL)), + c("One", "Two")) + # One-mode networks are unaffected: mode_names() gives them a single name. + expect_equal(.infer_nshape(ag_net(ison_adolescents), NULL), 21) +}) + +test_that("multiplex networks are coloured by layer rather than by sign", { + skip_on_cran() + # fict_marvel's affiliation ties carry no sign, and were coloured "Negative" + # while being drawn solid, so colour and linetype disagreed about which ties + # were negative. Layer is what every tie has, and sign is left to linetype. + marvel <- ag_net(fict_marvel) + colours <- .infer_ecolor(marvel, NULL) + expect_setequal(levels(colours), c("affiliation", "relationship")) + expect_equal(.infer_ecolor_title(marvel, NULL), "Layer") + # Whether there are layers to draw is how many the ties are divided between, + # which is 1 for a network whose ties are not divided at all. + expect_equal(manynet::net_layers(ison_adolescents), 1L) + expect_false(.has_layers(ag_net(ison_adolescents))) + expect_gt(manynet::net_layers(fict_marvel), 1) + expect_true(.has_layers(ag_net(ison_algebra))) + # Not `is_multiplex()`, which is TRUE for a network with no layers to draw. + expect_true(manynet::is_multiplex(ison_monks)) + expect_true(.has_layers(ag_net(ison_monks))) + # Signed networks without layers still show their signs, and now treat an + # absent sign as positive, as the linetype always did. + signed <- ag_net(manynet::to_uniplex(fict_marvel, "relationship")) + expect_equal(manynet::net_layers(signed), 1L) + expect_false(.has_layers(signed)) + expect_setequal(levels(.infer_ecolor(signed, NULL)), c("Positive", "Negative")) + expect_equal(.infer_ecolor_title(signed, NULL), "Sign") + # The affiliation ties are the ties that carry no sign: manynet 2.2.3 leaves + # their sign missing, and 2.3.0 weights them positively. Either way they are + # drawn solid, as only a negative tie is dashed. + unsigned_ties <- manynet::tie_attribute(marvel, .layer_attribute(marvel)) == + "affiliation" + expect_equal(as.character(.infer_line_type(marvel)[unsigned_ties][1]), + "solid") + # An explicitly named attribute still titles the legend after itself. + expect_equal(.infer_ecolor_title(marvel, .layer_attribute(marvel)), + .layer_attribute(marvel)) + # Which tie attribute records the layer is read from the network rather than + # assumed, since manynet spells it "type" through 2.2.3 and "layer" from + # 2.3.0, and networks of both spellings are in circulation. + expect_true(.layer_attribute(marvel) %in% c("type", "layer")) + expect_equal(.layer_attribute(ag_net(ison_algebra)), "type") + expect_true(is.na(.layer_attribute(ag_net(ison_adolescents)))) +}) + +test_that("signs are given a legend wherever the colours no longer carry them", { + skip_on_cran() + # The linetype is drawn through an identity scale, which shows no legend of + # its own. That was right while the colours said "Sign" too, but leaves the + # dashes unexplained now that the colours of a multiplex network say "Layer". + guide_titles <- function(p) { + vapply(ggplot2::ggplot_build(p)$plot$scales$scales, function(s) { + nm <- s$name + if (is.null(nm) || !is.character(nm)) NA_character_ else nm + }, character(1)) + } + expect_true("Sign" %in% guide_titles(graphr(fict_marvel))) + # A signed network without layers is coloured by sign, so a second legend + # saying the same thing is not drawn. + signed <- manynet::to_giant(manynet::to_uniplex(fict_marvel, "relationship")) + expect_false("Sign" %in% guide_titles(signed |> graphr())) + expect_buildable(graphr(fict_marvel)) +}) + test_that("color legend uses fillable shape when node_shape is also mapped", { skip_on_cran() - p <- ison_brandes %>% + p <- ison_brandes |> dplyr::mutate(grp = c(rep(c("a", "b", "c"), 3), "a", "b"), - cat = c(rep(c("x", "y"), 5), "x")) %>% + cat = c(rep(c("x", "y"), 5), "x")) |> graphr(node_color = grp, node_shape = cat) # The fill guide should override shape to 21 so colors render in legend fill_guide <- p[["guides"]][["guides"]][["fill"]] @@ -192,8 +306,8 @@ test_that("color legend uses fillable shape when node_shape is also mapped", { test_that("node_color with 2 values uses highlight palette", { skip_on_cran() - p <- ison_brandes %>% - dplyr::mutate(grp = c(rep(c("x", "y"), 5), "x")) %>% + p <- ison_brandes |> + dplyr::mutate(grp = c(rep(c("x", "y"), 5), "x")) |> graphr(node_color = grp) expect_s3_class(p, c("ggraph", "gg", "ggplot")) # Should use scale_fill_manual with highlight defaults @@ -241,6 +355,119 @@ test_that("labels stay clear of larger nodes (#13)", { expect_gt(mean(built_big$data[[n]]$point.size), mean(built_small$data[[n]]$point.size)) }) +# Which nodes get labelled. The label layer now carries its own `data` (the +# selected rows) rather than inheriting the plot's, so the selection can be +# read straight off it. Found by its geom rather than by position, since an +# isolates legend can be added after it. +label_layer_of <- function(p) { + geoms <- vapply(p[["layers"]], function(l) class(l[["geom"]])[1], character(1)) + at <- which(geoms %in% c("GeomLabelRepel", "GeomLabel", + "GeomTextRepel", "GeomText")) + if (!length(at)) return(NULL) + p[["layers"]][[at[1]]] +} +label_names <- function(p) sort(as.character(label_layer_of(p)[["data"]][["name"]])) + +test_that("labels selects nodes by rank on a measure", { + skip_on_cran() + skip_if_not_installed("netrics") + net <- ison_adolescents + nms <- manynet::node_names(net) + expect_length(label_names(graphr(net)), length(nms)) + # A rank depth labels fewer than all of them, and a bare criterion (one rank) + # fewer still, nested within the deeper selection. + top <- label_names(graphr(net, labels = 3)) + most <- label_names(graphr(net, labels = "degree")) + expect_lt(length(top), length(nms)) + expect_lte(length(most), length(top)) + expect_true(all(most %in% top)) + # Each criterion selects what netrics itself says is maximal + expect_setequal(most, nms[as.logical(netrics::node_is_max( + netrics::node_by_degree(net, normalized = FALSE)))]) + expect_setequal(label_names(graphr(net, labels = c(betweenness = 1))), + nms[as.logical(netrics::node_is_max( + netrics::node_by_betweenness(net)))]) + expect_setequal(label_names(graphr(net, labels = "cutpoints")), + nms[as.logical(netrics::node_is_cutpoint(net))]) +}) + +test_that("labels accepts an explicit selection of nodes", { + skip_on_cran() + net <- ison_adolescents + nms <- manynet::node_names(net) + expect_setequal(label_names(graphr(net, labels = c("Alice", "Betty"))), + c("Alice", "Betty")) + expect_setequal(label_names(graphr(net, labels = nms %in% c("Betty", "Carol"))), + c("Betty", "Carol")) + expect_setequal(label_names(graphr(net, labels = c(2, 5))), nms[c(2, 5)]) + # A logical attribute, e.g. a netrics node_mark stored on the network + marked <- manynet::add_node_attribute(net, "mark", + nms %in% c("Alice", "Tina")) + expect_setequal(label_names(graphr(marked, labels = "mark")), + c("Alice", "Tina")) +}) + +test_that("an empty selection draws no label layer at all", { + skip_on_cran() + net <- ison_adolescents + expect_null(label_layer_of(graphr(net, labels = FALSE))) + expect_null(label_layer_of(graphr(net, labels = rep(FALSE, 8)))) + expect_false(is.null(label_layer_of(graphr(net)))) +}) + +test_that("a selection is measured against the network as given, isolates and all", { + skip_on_cran() + # Isolates are dropped before the plot is laid out, which shifts every later + # node's position, so a selection has to be resolved before that happens. + net <- manynet::add_nodes(ison_adolescents, 2, list(name = c("Ivy", "Jo"))) + nms <- manynet::node_names(net) + expect_setequal(label_names(graphr(net, labels = nms %in% c("Carol", "Tina"))), + c("Carol", "Tina")) + expect_setequal(label_names(graphr(net, labels = which(nms %in% c("Carol", "Tina")))), + c("Carol", "Tina")) + # A single number is a depth of ranks, never one node's position, so a lone + # node has to be named (or marked) rather than numbered + expect_gt(length(label_names(graphr(net, labels = 8))), 1) + expect_setequal(label_names(graphr(net, labels = "Tina")), "Tina") +}) + +test_that("a selection keeps node sizes aligned with the labelled nodes", { + skip_on_cran() + net <- manynet::add_node_attribute(ison_adolescents, "num", + c(1, 20, rep(1, 6))) + p <- graphr(net, node_size = "num", labels = "Sue") + geoms <- vapply(p[["layers"]], function(l) class(l[["geom"]])[1], character(1)) + built <- ggplot2::ggplot_build(p) + point_size <- built[["data"]][[which(geoms == "GeomLabelRepel")]][["point.size"]] + # Sue is the second node, so hers is the size that should have come through + expect_length(point_size, 1) + expect_equal(point_size, 20 * ggplot2::.pt) +}) + +test_that("large networks label only their most central nodes by default", { + skip_on_cran() + skip_if_not_installed("netrics") + set.seed(123) + net <- manynet::to_named(manynet::generate_random(60, 0.08)) + auto <- label_names(graphr(net, isolates = "keep")) + expect_gt(length(auto), 0) + expect_lt(length(auto), 60) + # Asking for labels outright still labels every node + expect_length(label_names(graphr(net, labels = TRUE, isolates = "keep")), 60) +}) + +test_that("selections on a two-mode network span both modes", { + skip_on_cran() + skip_if_not_installed("netrics") + net <- ison_southern_women + nms <- manynet::node_names(net) + modes <- igraph::V(manynet::as_igraph(net))$type + sel <- label_names(graphr(net, labels = 3)) + expect_lt(length(sel), length(nms)) + expect_true(any(sel %in% nms[!modes])) + expect_true(any(sel %in% nms[modes])) +}) + test_that("graphr() works on a stocnet-class object", { skip_on_cran() sn <- manynet::as_stocnet(ison_adolescents) @@ -328,10 +555,121 @@ test_that("graphs()/graphr() render signed longitudinal snapshots without error" # parameter), otherwise geom_edge_arc's point expansion length-checks the # linetype vector against the expanded data and fails ("Aesthetics must be # either length 1 or the same as the data"). - waves <- manynet::to_waves(manynet::ison_monks) + # Split the way graphs() splits it, since which manynet function does that + # depends on the manynet version. See .split_time_network(). + waves <- .split_time_network(manynet::ison_monks) expect_true(manynet::is_signed(waves[[1]])) p1 <- graphr(waves[[1]]) expect_buildable(p1) ps <- graphs(waves) expect_buildable(ps) }) + +# Room at the panel edge for the nodes drawn there ---- + +test_that("the panel leaves room for the radius of the nodes at its edge", { + # A node is drawn at an absolute size but a scale is expanded by a share of + # its data range, so ggplot2's default 5% clips the nodes of a small network. + # See .pad_for_nodes(). ison_adolescents draws 8 nodes, the largest default. + p <- graphr(manynet::ison_adolescents) + built <- ggplot2::ggplot_build(p) + nsize <- autograph:::.default_nsize(manynet::net_nodes(manynet::ison_adolescents)) + mult <- autograph:::.node_padding(nsize) + expect_gt(mult, 0.05) + for (axis in c("x", "y")) { + drawn <- range(built$data[[2]][[axis]]) + panel <- built$layout$panel_params[[1]][[paste0(axis, ".range")]] + # Each side is given at least the share of the data range asked for. + room <- c(drawn[1] - panel[1], panel[2] - drawn[2]) + expect_true(all(room >= mult * diff(drawn) - 1e-8)) + } +}) + +test_that("a large network is padded no more than ggplot2 pads it", { + # A crowded network draws small nodes, which need no more room than the + # default, and widening every plot would waste the panel. + expect_equal(autograph:::.node_padding(autograph:::.default_nsize(200)), 0.05) +}) + +test_that("padding widens the room a layout asked for without replacing it", { + # "layered" sets its own expansion, to keep the right-hand side clear for the + # labels it puts there. That side must keep its 0.25. + expect_equal(autograph:::.widen_expand(c(0.05, 0, 0.25, 0), 0.12), + c(0.12, 0, 0.25, 0)) + # A scale that set nothing is given the padding on both sides. + expect_equal(autograph:::.widen_expand(NULL, 0.12), + ggplot2::expansion(mult = 0.12)) + thrones <- manynet::to_uniplex(manynet::fict_thrones, "parent") + sc <- graphr(thrones)$scales$get_scales("x") + expect_equal(sc$expand[[4]], 0) + expect_equal(sc$expand[[3]], 0.25) +}) + +test_that("parallel ties are fanned apart", { + # Two ties between the same two nodes are drawn along the same line by + # `geom_edge_link0()`, and by a single arc, so one hides the other. Where the + # network holds such ties, they are drawn by `geom_edge_fan()` instead, which + # gives each tie in a group its own side of the pair. + # + # `irps_corruption`, which reported this, belongs to manynet 2.3.0, so the + # networks here are built from a dataset both versions carry. + .deviation <- function(p) { + d <- ggplot2::ggplot_build(p)$data[[1]] + vapply(split(d[, c("x", "y")], d$group), function(s) { + from <- as.numeric(s[1, ]); to <- as.numeric(s[nrow(s), ]) + v <- to - from + len <- sqrt(sum(v^2)) + if (len == 0) return(0) + max(abs(as.matrix(sweep(as.matrix(s), 2, from)) %*% (c(-v[2], v[1])/len))) + }, numeric(1)) + } + # An undirected network without parallel ties is drawn as it was before. + expect_false(autograph:::.has_parallel_ties(manynet::ison_adolescents)) + plain <- suppressMessages(graphr(manynet::ison_adolescents)) + expect_s3_class(plain$layers[[1]]$geom, "GeomEdgeSegment") + # Repeating one tie fans that pair apart and leaves every other tie straight. + par <- manynet::as_igraph(manynet::ison_adolescents) + par <- igraph::add_edges(par, igraph::as_edgelist(par, names = FALSE)[1, ]) + expect_true(autograph:::.has_parallel_ties(par)) + p <- suppressMessages(graphr(par, labels = FALSE)) + expect_s3_class(p$layers[[1]]$geom, "GeomEdgePath") + expect_no_warning(ggplot2::ggplot_build(p)) + # A straight path deviates by rounding noise rather than by exactly zero. + dev <- .deviation(p) + expect_equal(sum(dev > 1e-6), 2) + # A directed network keeps its arcs until two ties run the same way, which + # `which_mutual()` does not tell apart but `which_multiple()` does. + dir <- manynet::as_igraph(manynet::ison_networkers) + expect_false(autograph:::.has_parallel_ties(dir)) + dpar <- igraph::add_edges(dir, igraph::as_edgelist(dir, names = FALSE)[1, ]) + expect_true(autograph:::.has_parallel_ties(dpar)) + q <- suppressMessages(graphr(dpar, labels = FALSE)) + expect_no_warning(ggplot2::ggplot_build(q)) + # The arrowheads are still stopped short of the node they point to. + expect_true("end_cap" %in% names(q$layers[[1]]$mapping)) +}) + +test_that("an arc is drawn for every tie the arc stat keeps", { + # `geom_edge_arc()` drops every tie whose two ends sit at one point, and its + # `strength` is a parameter rather than an aesthetic, so it has to leave the + # same ties out. The "scaling" layout draws two nodes that hold the same + # distances to every other node at one point, which used to leave `strength` + # two ties longer than the ties it was measured against. + net <- manynet::ison_networkers + p <- suppressMessages(graphr(net, layout = "scaling", labels = FALSE)) + drawn <- sum(!autograph:::.tie_is_coincident(net, p)) + expect_lt(drawn, manynet::net_ties(net)) + expect_length(autograph:::.infer_arc_strength(net, p), drawn) + expect_no_warning(ggplot2::ggplot_build(p)) + # A network drawn with every node in its own place keeps every tie. + q <- suppressMessages(graphr(net, layout = "stress", labels = FALSE)) + expect_length(autograph:::.infer_arc_strength(net, q), manynet::net_ties(net)) + expect_no_warning(ggplot2::ggplot_build(q)) + # A self-loop sits at one point by definition, and is drawn by + # `geom_edge_loop0()` instead. + loops <- manynet::as_igraph(manynet::ison_adolescents) + loops <- igraph::add_edges(loops, c(1, 1)) + lp <- suppressMessages(graphr(loops)) + expect_true(utils::tail(autograph:::.tie_is_coincident(loops, lp), 1)) + expect_no_warning(ggplot2::ggplot_build(lp)) +}) diff --git a/tests/testthat/test-grapht.R b/tests/testthat/test-grapht.R index 8a2f7c7c..40fbbf7a 100644 --- a/tests/testthat/test-grapht.R +++ b/tests/testthat/test-grapht.R @@ -123,6 +123,23 @@ test_that("labels are suppressed by default for large networks", { expect_true("GeomText" %in% geoms2) }) +test_that("grapht() labels the same selection of nodes in every frame", { + skip_if_not_installed("netrics") + w1 <- manynet::ison_adolescents + p <- grapht(list(t1 = w1, t2 = w1), labels = 2) + text_layer <- p$layers[[which(vapply(p$layers, + function(l) class(l$geom)[1], + character(1)) == "GeomText")]] + labelled <- unique(as.character(text_layer$data$name)) + expect_gt(length(labelled), 0) + expect_lt(length(labelled), manynet::net_nodes(w1)) + # one selection across both frames, rather than one per frame + frames <- unique(text_layer$data$frame) + for (f in frames) + expect_setequal(as.character(text_layer$data$name[text_layer$data$frame == f]), + labelled) +}) + test_that("dense frames fade present edges below the sparse-network default", { set.seed(2) make_dense <- function() { diff --git a/tests/testthat/test-layout_concentric.R b/tests/testthat/test-layout_concentric.R new file mode 100644 index 00000000..9e06a674 --- /dev/null +++ b/tests/testthat/test-layout_concentric.R @@ -0,0 +1,83 @@ +# Layouts +test_that("concentric and circular layouts graph correctly", { + skip_on_cran() + fmrg <- to_giant(to_uniplex(fict_marvel, "relationship")) + test_circle <- graphr(fmrg, layout = "circle") + test_conc <- graphr(fmrg, layout = "concentric", membership = "Gender") + expect_equal(test_circle$plot_env$layout, "circle") + expect_equal(test_conc$plot_env$layout, "concentric") + expect_equal(eval(quote(pairlist(...)), + envir = test_conc$plot_env)$membership, + "Gender") +}) + +test_that("concentric layout works when node names are missing", { + skip_on_cran() + llabel <- ison_southern_women |> + mutate(name = ifelse(type == TRUE, "", name)) |> + graphr(layout = "concentric") + expect_true(any(llabel$data$name == "")) +}) + + +test_that("concentric refuses to draw a node in more than one circle", { + skip_on_cran() + # The circles are read from the node names, so two nodes of the same name + # are one node in two circles, which the layout cannot draw. + dupe <- manynet::as_igraph(ison_southern_women) + igraph::V(dupe)$name[2] <- igraph::V(dupe)$name[1] + expect_error(layout_concentric(dupe, membership = "type"), "one circle only") +}) + +test_that("concentric draws an unlabelled network", { + skip_on_cran() + # An unlabelled network used to put every node on a circle of its own, + # because the groups were named while `is_labelled()` said they were not. + un <- to_unnamed(ison_southern_women) + lo <- layout_concentric(un) + expect_equal(nrow(lo), as.integer(net_nodes(un))) + expect_false(anyNA(lo)) + # The two modes are the two circles, so the nodes sit at two radii. + expect_length(unique(round(sqrt(lo$x^2 + lo$y^2), 6)), 2) + expect_s3_class(graphr(un, layout = "concentric"), "ggraph") +}) + +test_that("concentric gathers the nodes no group claims onto their own circle", { + skip_on_cran() + # A membership of NA names no group, so those nodes belong to none of them. + net <- manynet::add_node_attribute(ison_adolescents, "grp", + c("a", "a", "a", "b", "b", "b", NA, NA)) + lo <- layout_concentric(net, membership = "grp") + expect_equal(nrow(lo), as.integer(net_nodes(net))) + expect_false(anyNA(lo)) + # Three circles: the two groups, and the two nodes left over. + radii <- round(sqrt(lo$x^2 + lo$y^2), 6) + expect_length(unique(radii), 3) + # Each group is drawn on one circle of its own. + expect_length(unique(radii[1:3]), 1) + expect_length(unique(radii[4:6]), 1) + expect_length(unique(radii[7:8]), 1) +}) + +test_that("order.by orders the nodes around each circle", { + skip_on_cran() + net <- manynet::add_node_attribute(ison_adolescents, "grp", + c("a", "a", "a", "a", "b", "b", "b", "b")) + net <- manynet::add_node_attribute(net, "val", 8:1) + lo <- layout_concentric(net, membership = "grp", order.by = "val") + expect_equal(nrow(lo), as.integer(net_nodes(net))) + expect_false(anyNA(lo)) + # The highest value in each group starts the circle, at angle zero. + expect_equal(lo$x[1], 0.5) + expect_equal(lo$y[1], 0) + expect_equal(lo$x[5], 1) + expect_equal(lo$y[5], 0) + # Reversing the values reverses the order the nodes are drawn in. + rev <- manynet::add_node_attribute(net, "rev", 1:8) + lo2 <- layout_concentric(rev, membership = "grp", order.by = "rev") + expect_equal(lo2$x[4], 0.5) + expect_equal(lo2$y[4], 0) + # A name no node attribute carries is reported rather than drawn. + expect_error(layout_concentric(net, membership = "grp", order.by = "vale"), + "Could not find") +}) diff --git a/tests/testthat/test-layout_correspondence.R b/tests/testthat/test-layout_correspondence.R new file mode 100644 index 00000000..eba7fe9b --- /dev/null +++ b/tests/testthat/test-layout_correspondence.R @@ -0,0 +1,190 @@ +# The correspondence layout and the fit it reports. See +# R/layout_correspondence.R. + +test_that("correspondence layout graphs correctly", { + skip_on_cran() + p <- graphr(manynet::ison_southern_women, layout = "correspondence") + expect_equal(p$plot_env$layout, "correspondence") + expect_buildable(p) + expect_equal(nrow(p$data), + as.integer(manynet::net_nodes(manynet::ison_southern_women))) +}) + +test_that("correspondence layout places both modes in one space", { + skip_on_cran() + lo <- layout_correspondence(manynet::ison_southern_women) + expect_named(lo, c("x", "y")) + expect_equal(nrow(lo), + as.integer(manynet::net_nodes(manynet::ison_southern_women))) + expect_true(all(is.finite(as.matrix(lo)))) + # Neither mode is placed off on its own: both are drawn against the same + # axes, which is the point of drawing a two-mode network this way. + mode <- manynet::node_is_mode(manynet::ison_southern_women) + expect_true(min(lo$x[mode]) < max(lo$x[!mode])) + expect_true(min(lo$x[!mode]) < max(lo$x[mode])) +}) + +test_that("correspondence layout reports inertia and cos2", { + skip_on_cran() + fit <- attr(layout_correspondence(manynet::ison_southern_women), "fit") + expect_equal(fit$type, "correspondence") + # The published correspondence analysis of this network. Both dimensions + # are shares of the total inertia, so both fall between 0 and 1. + expect_equal(fit$inertia, c(0.380, 0.193), tolerance = 1e-2) + expect_equal(fit$total, 1.65, tolerance = 1e-2) + expect_length(fit$cos2, + as.integer(manynet::net_nodes(manynet::ison_southern_women))) + expect_true(all(fit$cos2 >= 0 & fit$cos2 <= 1)) + expect_named(fit$cos2, manynet::node_names(manynet::ison_southern_women)) +}) + +test_that("correspondence layout reports every dimension, not only the two drawn", { + skip_on_cran() + fit <- attr(layout_correspondence(manynet::ison_southern_women), "fit") + # A table of 18 rows and 14 columns supports 13 dimensions at most, and the + # zeroes for those it does not support are dropped, so that the count is + # what the inertia was actually spread over. + expect_lte(length(fit$scree), 13) + expect_equal(sum(fit$scree), 1) + expect_true(!is.unsorted(rev(fit$scree))) + # The two drawn are the first two of them. + expect_equal(unname(fit$scree[1:2]), fit$inertia) + # The percentages are exact rather than corrected: no Benzecri or adjusted + # rescaling applies to a single two-way table, so the shares of the raw + # eigenvalues are what is reported. + m <- as.matrix(manynet::as_matrix(manynet::ison_southern_women)) + P <- m / sum(m) + r <- rowSums(P) + cm <- colSums(P) + eig <- svd((P - outer(r, cm)) / outer(sqrt(r), sqrt(cm)))$d^2 + expect_equal(fit$inertia, eig[1:2] / sum(eig), tolerance = 1e-8) + expect_equal(fit$total, sum(eig), tolerance = 1e-8) +}) + +test_that("correspondence layout is well defined for a one-mode network", { + skip_on_cran() + # A symmetric table places its rows and its columns identically, so a + # one-mode network has one position for each node whichever side it is read + # from, and the layout is not left to choose between them. + lo <- layout_correspondence(manynet::ison_adolescents) + expect_equal(nrow(lo), + as.integer(manynet::net_nodes(manynet::ison_adolescents))) + expect_true(all(is.finite(as.matrix(lo)))) + # Deterministic: the decomposition fixes the axes, and the layout fixes + # their direction, so two calls draw the same picture. + expect_equal(lo, layout_correspondence(manynet::ison_adolescents)) +}) + +test_that("correspondence layout reads a direction where there is one", { + skip_on_cran() + net <- manynet::ison_networkers + both <- layout_correspondence(net) + out <- layout_correspondence(net, direction = "out") + ins <- layout_correspondence(net, direction = "in") + for (lo in list(both, out, ins)) { + expect_equal(nrow(lo), as.integer(manynet::net_nodes(net))) + expect_true(all(is.finite(as.matrix(lo)))) + } + # Who a node sends to and who it receives from are different profiles. + expect_false(isTRUE(all.equal(out$x, ins$x))) + expect_false(isTRUE(all.equal(both$x, out$x))) + expect_error(layout_correspondence(net, direction = "sideways"), + "direction") +}) + +test_that("a signed network needs its signs split", { + skip_on_cran() + old <- options(snet_verbosity = "verbose") + on.exit(options(old), add = TRUE) + expect_message( + p <- graphr(manynet::ison_monks, layout = "correspondence"), + "unsigned network") + expect_equal(p$plot_env$layout, "stress") + lo <- layout_correspondence(manynet::ison_monks, double = TRUE) + expect_equal(nrow(lo), + as.integer(manynet::net_nodes(manynet::ison_monks))) + expect_true(all(is.finite(as.matrix(lo)))) + p2 <- suppressMessages( + graphr(manynet::ison_monks, layout = "correspondence", double = TRUE)) + expect_equal(p2$plot_env$layout, "correspondence") + expect_buildable(p2) +}) + +test_that("correspondence layout draws axes naming their inertia", { + skip_on_cran() + p <- graphr(manynet::ison_southern_women, layout = "correspondence") + expect_match(p$labels$x, "^Dimension 1 \\([0-9]+% of inertia\\)$") + expect_match(p$labels$y, "^Dimension 2 \\([0-9]+% of inertia\\)$") + # One scale for both axes, or the distances drawn cannot be compared. + expect_equal(p$coordinates$ratio, 1) + # Axes a void theme would have blanked. + expect_false(inherits(p$theme$axis.text, "element_blank")) + # The inertia is named on the axes, so the caption has nothing to add. + expect_null(p$labels$caption) +}) + +test_that("nodes the plane holds poorly are named at the console", { + skip_on_cran() + old <- options(snet_verbosity = "verbose") + on.exit(options(old), add = TRUE) + expect_message(graphr(manynet::ison_southern_women, + layout = "correspondence"), + "far off the plane") +}) + +test_that("two dimensions no better than chance are reported", { + skip_on_cran() + old <- options(snet_verbosity = "verbose") + on.exit(options(old), add = TRUE) + # The warning does not follow the raw share, which is the point of it. + # ison_adolescents draws the larger share of the two (60% against 36%) but + # has only seven dimensions to win it from, so two of them hold less than + # breaking the inertia at random would have given them. + expect_message(graphr(manynet::ison_adolescents, layout = "correspondence"), + "dividing it at random") + expect_no_message( + .note_corresp_inertia( + attr(layout_correspondence(manynet::ison_networkers), "fit"))) +}) + +test_that("the broken stick baseline is the share of a random division", { + skip_on_cran() + # The first two of k pieces of a stick broken at k - 1 random points, which + # is a good deal more than the even share of 2/k. + expect_equal(.broken_stick(7), mean(1/(1:7)) + mean(1/(2:7))) + expect_gt(.broken_stick(7), 2 / 7) + expect_gt(.broken_stick(31), 2 / 31) + # Fewer dimensions leaves more for each of the two drawn. + expect_gt(.broken_stick(5), .broken_stick(50)) +}) + +test_that("a node with no ties is placed at the origin", { + skip_on_cran() + iso <- manynet::add_nodes(manynet::ison_adolescents, 1, list(name = "Zoe")) + # graphr() sets isolates aside itself, so the layout only meets one where it + # is called directly or where the isolates are kept. + lo <- layout_correspondence(iso) + expect_equal(unname(unlist(lo[9, ])), c(0, 0)) + expect_true(all(is.finite(as.matrix(lo)))) + expect_true(is.na(attr(lo, "fit")$cos2[["Zoe"]])) + expect_buildable(suppressMessages( + graphr(iso, layout = "correspondence", isolates = "keep"))) +}) + +test_that("correspondence coordinates are kept when snapping is asked for", { + skip_on_cran() + snapped <- suppressMessages( + graphr(manynet::ison_southern_women, layout = "correspondence", + snap = TRUE)) + plain <- suppressMessages( + graphr(manynet::ison_southern_women, layout = "correspondence")) + expect_equal(snapped$data[, c("x", "y")], plain$data[, c("x", "y")]) +}) + +test_that("correspondence layout answers a network too small to analyse", { + skip_on_cran() + empty <- manynet::create_empty(5) + lo <- layout_correspondence(empty) + expect_equal(nrow(lo), 5) + expect_true(all(is.finite(as.matrix(lo)))) +}) diff --git a/tests/testthat/test-layout_layered.R b/tests/testthat/test-layout_layered.R new file mode 100644 index 00000000..d03afa01 --- /dev/null +++ b/tests/testthat/test-layout_layered.R @@ -0,0 +1,332 @@ +# Layered layouts +test_that("layered and lineage layouts graph correctly", { + skip_on_cran() + test_lin <- ison_adolescents |> + mutate(year = rep(c(1985, 1990, 1995, 2000), times = 2)) |> + graphr(layout = "lineage", ranks = "year") + test_hie <- graphr(ison_southern_women, + layout = "layered", center = "events") + expect_equal(test_lin$plot_env$layout, "lineage") + expect_equal((eval(quote(pairlist(...)), + envir = test_lin[["plot_env"]])[["ranks"]]), + "year") + expect_equal(test_hie$plot_env$layout, "layered") + expect_equal((eval(quote(pairlist(...)), + envir = test_hie[["plot_env"]])[["center"]]), + "events") +}) + +# test_that("graphr works for diff_model objects", { +# skip_on_cran() +# skip_on_ci() +# test_diff <- graphr(play_diffusion(ison_brandes, old_version = TRUE)) +# if (inherits(test_diff$guides, "Guides")) { +# expect_s3_class(test_diff[["guides"]][["guides"]][["shape"]], "GuideLegend") +# expect_s3_class(test_diff[["guides"]][["guides"]][["colour"]], "GuideColourbar") +# } else { +# expect_equal(test_diff[["guides"]][["shape"]][["name"]], "legend") +# expect_equal(test_diff[["guides"]][["colour"]][["name"]], "colorbar") +# } +# }) + +test_that("layered layout works for two mode networks", { + skip_on_cran() + tm <- ison_brandes |> + mutate(type = twomode_type, name = LETTERS[1:11]) |> + graphr() + expect_length(unique(tm$data[tm$data$type == TRUE, "y"]), 1) + expect_length(unique(tm$data[tm$data$type == FALSE, "y"]), 1) +}) + +test_that("default layered layout uses sugiyama for two-mode networks", { + skip_on_cran() + p <- graphr(ison_southern_women, layout = "layered") + expect_s3_class(p, c("ggraph", "gg", "ggplot")) + expect_equal(p$plot_env$layout, "layered") + # Two-mode should have exactly 2 unique y values (layers) + expect_equal(length(unique(round(p$data$y, 6))), 2) +}) + +test_that("layered is the default layout for directed acyclic networks", { + skip_on_cran() + thrones <- to_uniplex(fict_thrones, "parent") + expect_true(is_directed(thrones) && is_acyclic(thrones)) + expect_equal(graphr(thrones)$plot_env$layout, "layered") + # ison_adolescents is acyclic but undirected, so it has no roots to hang + # from and keeps the force-directed default. + expect_false(is_directed(ison_adolescents)) + expect_equal(graphr(ison_adolescents)$plot_env$layout, "stress") +}) + +test_that("layered draws parents above their children", { + skip_on_cran() + thrones <- to_uniplex(fict_thrones, "parent") + lo <- layout_layered(thrones) + ties <- igraph::as_edgelist(as_igraph(thrones), names = FALSE) + expect_true(all(lo$y[ties[, 1]] > lo$y[ties[, 2]])) +}) + +test_that("layered places every node, isolates included", { + skip_on_cran() + thrones <- to_uniplex(fict_thrones, "parent") + expect_equal(nrow(layout_layered(thrones)), + as.integer(net_nodes(thrones))) + # The retired "layered" layout dropped tie-less nodes, which failed here. + expect_s3_class(graphr(thrones, isolates = "keep"), "ggraph") +}) + +test_that("layered packs the components apart", { + skip_on_cran() + thrones <- .ag_delete_isolates(to_uniplex(fict_thrones, "parent")) + lo <- layout_layered(thrones) + memb <- igraph::components(as_igraph(thrones), mode = "weak")$membership + spans <- lapply(sort(unique(memb)), function(cc) range(lo$x[memb == cc])) + spans <- spans[order(vapply(spans, `[`, numeric(1), 1))] + # No component starts before the one to its left has finished. + for (i in seq_along(spans)[-1]) + expect_gt(spans[[i]][1], spans[[i - 1]][2]) +}) + +test_that("self-loops are sized to the layout rather than stretching it", { + skip_on_cran() + # A loop's `strength` is its diameter in the layout's own coordinates, and + # geom_edge_loop0() defaults it to 1. fict_marvel's levels layout spans + # about one unit each way, so the single loop was drawn wider than the whole + # network, stretching the panel to twice the width the nodes needed and + # leaving a gap between the plot and its legend. + expect_true(manynet::is_complex(fict_marvel)) + p <- graphr(fict_marvel, labels = FALSE) + panel <- ggplot2::ggplot_build(p)$layout$panel_params[[1]]$x.range + # Only the usual 5% expansion either side, rather than room for the loop. + expect_lt(diff(panel), diff(range(p$data$x)) * 1.25) + # The loop is still drawn, at a fraction of the layout rather than all of it. + loop <- ggplot2::ggplot_build(p)$data[[2]] + expect_gt(diff(range(loop$x)), 0) + expect_lt(diff(range(loop$x)), diff(range(p$data$x)) / 4) +}) + +test_that("lineage layout works", { + skip_on_cran() + p <- graphr(ison_southern_women, layout = "lineage") + expect_s3_class(p, c("ggraph", "gg", "ggplot")) + expect_equal(p$plot_env$layout, "lineage") +}) + +test_that("layered layout minimises edge crossings", { + skip_on_cran() + # Helper: count bipartite edge crossings given x positions + count_crossings <- function(el, x_pos) { + crossings <- 0 + if (nrow(el) < 2) return(0) + for (i in 1:(nrow(el) - 1)) { + for (j in (i + 1):nrow(el)) { + a1 <- x_pos[el[i, 1]]; b1 <- x_pos[el[i, 2]] + a2 <- x_pos[el[j, 1]]; b2 <- x_pos[el[j, 2]] + if ((a1 - a2) * (b1 - b2) < 0) crossings <- crossings + 1 + } + } + crossings + } + # Test with ison_southern_women (18 women, 14 events, 89 ties) + g <- manynet::as_igraph(ison_southern_women) + n <- igraph::vcount(g) + el <- igraph::as_edgelist(g, names = FALSE) + layers <- ifelse(igraph::V(g)$type, 2, 1) + lo <- autograph:::.sugiyama_layout(g, layers = layers, times = 100) + x_pos <- lo[, 1] + # Naive layout: sequential ordering within each layer + naive_x <- rep(0, n) + naive_x[layers == 1] <- seq_len(sum(layers == 1)) + naive_x[layers == 2] <- seq_len(sum(layers == 2)) + optimised_crossings <- count_crossings(el, x_pos) + naive_crossings <- count_crossings(el, naive_x) + # The optimised layout should have fewer crossings than naive + expect_lt(optimised_crossings, naive_crossings) + # Verify all nodes got valid positions + expect_true(all(is.finite(x_pos))) + expect_equal(length(unique(lo[layers == 1, 2])), 1) + expect_equal(length(unique(lo[layers == 2, 2])), 1) +}) + +# The engine behind the layered layouts, and the two costs it minimises. + +test_that("tight ranks shorten the ties", { + skip_on_cran() + thrones <- to_uniplex(fict_thrones, "parent") + spans <- vapply(c("tight", "generation", "compact"), function(r) + attr(check_span(graphr(thrones, ranks = r)), "total"), numeric(1)) + # Ranking by distance from a root pins a parent whose only child is several + # generations down to the top row, which manufactures a long tie. Choosing + # the ranks that shorten the ties instead is worth about a third. + expect_lt(spans[["tight"]], spans[["generation"]]) + expect_lt(spans[["tight"]], spans[["compact"]]) + expect_lte(spans[["tight"]], 300) + # The longest tie does not move, so it is the manufactured ties that go and + # not the real ones. + expect_equal(max(check_span(graphr(thrones))), + max(check_span(graphr(thrones, ranks = "generation")))) +}) + +test_that("all three rank rules layer the same network alike but rank it differently", { + skip_on_cran() + thrones <- to_uniplex(fict_thrones, "parent") + rows <- lapply(c("tight", "generation", "compact"), function(r) + layout_layered(thrones, ranks = r)$y) + expect_equal(length(unique(rows[[1]])), length(unique(rows[[2]]))) + expect_equal(length(unique(rows[[1]])), length(unique(rows[[3]]))) + expect_false(identical(rows[[1]], rows[[2]])) +}) + +test_that("straight alignment straightens the ties, rungs does not", { + skip_on_cran() + thrones <- to_uniplex(fict_thrones, "parent") + straight <- attr(check_offset(graphr(thrones)), "mean") + rungs <- attr(check_offset(graphr(thrones, alignment = "rungs")), "mean") + expect_lt(straight, rungs) + expect_lt(straight, 0.04) +}) + +test_that("the rank rules fall back where the network is not acyclic", { + skip_on_cran() + old <- options(snet_verbosity = "verbose") + on.exit(options(old), add = TRUE) + cyclic <- igraph::graph_from_data_frame( + data.frame(from = c("A", "B", "C", "C"), to = c("B", "C", "A", "D")), + directed = TRUE) + expect_message(lo <- layout_layered(cyclic), "acyclic") + expect_equal(nrow(lo), igraph::vcount(cyclic)) + expect_false(anyNA(lo)) +}) + +test_that("lineage is layered with the axes exchanged", { + skip_on_cran() + thrones <- to_uniplex(fict_thrones, "parent") + h <- layout_layered(thrones) + a <- layout_lineage(thrones) + expect_equal(a$x, -h$y) + expect_equal(a$y, h$x) +}) + +test_that("railway gives every layer the same spacing", { + skip_on_cran() + lo <- layout_railway(ison_southern_women) + for (row in unique(lo$y)) { + spaced <- sort(lo$x[lo$y == row]) + expect_equal(length(unique(round(diff(spaced), 8))), 1L) + } +}) + +# The pieces of the engine ---- + +test_that(".tighten_layers keeps every tie pointing down and shortens them", { + skip_on_cran() + g <- as_igraph(.ag_delete_isolates(to_uniplex(fict_thrones, "parent"))) + ties <- igraph::as_edgelist(g, names = FALSE) + loose <- autograph:::.rank_layers(g) + tight <- autograph:::.tighten_layers(g) + feasible <- function(r) all(r[ties[, 2]] > r[ties[, 1]]) + expect_true(feasible(loose)) + expect_true(feasible(tight)) + total <- function(r) sum(r[ties[, 2]] - r[ties[, 1]]) + expect_lte(total(tight), total(loose)) + # Running it again on its own output changes nothing. + expect_equal(autograph:::.tighten_layers(g, tight), tight) +}) + +test_that(".place_layer respects the order and the separation", { + want <- c(1, 1, 1, 8, 2) + got <- autograph:::.place_layer(want, sep = 1) + expect_length(got, length(want)) + expect_true(all(diff(got) >= 1 - 1e-9)) + # An input that already satisfies both is returned as it is. + fine <- c(1, 2, 3, 4) + expect_equal(autograph:::.place_layer(fine, sep = 1), fine) + expect_equal(autograph:::.place_layer(5), 5) +}) + +# The exported checks ---- + +test_that("check_span and check_offset read a graphr plot", { + skip_on_cran() + thrones <- to_uniplex(fict_thrones, "parent") + p <- graphr(thrones) + ties <- net_ties(.ag_delete_isolates(thrones)) + span <- check_span(p) + offset <- check_offset(p) + expect_length(span, ties) + expect_length(offset, ties) + expect_equal(attr(span, "total"), sum(span)) + expect_equal(attr(span, "mean"), mean(span)) + expect_equal(attr(offset, "mean"), mean(offset)) + expect_true(all(span >= 1)) + expect_true(all(offset >= 0 & offset <= 1)) + # Read from the axis holding the rows, so a flipped layout scores the same. + expect_equal(as.vector(check_span(graphr(thrones, layout = "lineage"))), + as.vector(span)) +}) + +test_that("the checks say what they need", { + expect_error(check_span(list(data = data.frame(a = 1))), "coordinates") + expect_error(check_offset(list(data = data.frame(x = 1, y = 1))), "network") +}) + +test_that("ranks given as values run down the page and left to right", { + skip_on_cran() + years <- rep(c(1985, 1990, 1995, 2000), times = 2) + net <- manynet::add_node_attribute(ison_adolescents, "year", years) + # The layers the engine works out run down the page, and values given for + # them do too, so the earliest year is at the top and the latest at the + # bottom. + down <- layout_layered(net, ranks = "year") + expect_equal(down$y[years == 1985], rep(max(down$y), 2)) + expect_equal(down$y[years == 2000], rep(min(down$y), 2)) + expect_true(all(diff(down$y[order(years)]) <= 0)) + # "lineage" is the same layout with the axes exchanged, so the earliest year + # is on the left. + across <- layout_lineage(net, ranks = "year") + expect_equal(across$x[years == 1985], rep(min(across$x), 2)) + expect_equal(across$x[years == 2000], rep(max(across$x), 2)) + # The values space the layers in proportion to themselves, and these years + # are evenly spaced. + expect_equal(diff(sort(unique(across$x))), rep(1/3, 3)) +}) + +test_that("a layered label sits immediately to the right of its own node", { + skip_on_cran() + years <- rep(c(1985, 1990, 1995, 2000), times = 2) + net <- manynet::add_node_attribute(ison_adolescents, "year", years) + for (lo in c("lineage", "ladder", "layered")) { + p <- graphr(net, layout = lo, ranks = "year") + labels <- p[["layers"]][[length(p[["layers"]])]] + # Nothing is repelled, so where a label sits says which node it labels. + expect_false(inherits(labels[["geom"]], "GeomLabelRepel")) + expect_false(inherits(labels[["geom"]], "GeomTextRepel")) + # One offset for every label, to the right, and the text starts there. + expect_s3_class(labels[["position"]], "PositionNudge") + expect_length(unique(labels[["position"]][["x"]]), 1L) + expect_gt(labels[["position"]][["x"]], 0) + expect_equal(labels[["position"]][["y"]], 0) + expect_equal(labels[["aes_params"]][["hjust"]], 0) + # In these two the x axis carries the layers, and the offset is smaller + # than the gap between them, so a label cannot reach the layer beside it. + if (lo != "layered") + expect_lt(labels[["position"]][["x"]], + min(diff(sort(unique(p[["data"]][["x"]]))))) + } + # `label_repel` is asked for by default, and these layouts do not take it. + expect_s3_class(graphr(net, layout = "lineage", ranks = "year", + label_repel = FALSE)[["layers"]][[3]][["position"]], + "PositionNudge") +}) + +test_that("the offset grows with the nodes and with label_dist", { + skip_on_cran() + years <- rep(c(1985, 1990, 1995, 2000), times = 2) + net <- manynet::add_node_attribute(ison_adolescents, "year", years) + nudge <- function(...) { + p <- graphr(net, layout = "lineage", ranks = "year", ...) + p[["layers"]][[length(p[["layers"]])]][["position"]][["x"]] + } + expect_gt(nudge(label_dist = 20), nudge(label_dist = 0)) + expect_gt(nudge(node_size = 10), nudge(node_size = 2)) +}) diff --git a/tests/testthat/test-layout_levels.R b/tests/testthat/test-layout_levels.R new file mode 100644 index 00000000..dc9a6f88 --- /dev/null +++ b/tests/testthat/test-layout_levels.R @@ -0,0 +1,122 @@ +# Levels layout +test_that("levels is the default layout for multilevel networks", { + skip_on_cran() + # fict_marvel interlocks a one-mode layer among its characters with a + # two-mode layer of their affiliations. A layered layout would put each + # mode on a row of its own, collapsing the one-mode layer entirely. + expect_true(.ag_is_multilevel(fict_marvel)) + expect_equal(graphr(fict_marvel)$plot_env$layout, "levels") + expect_equal(graphr(fict_actually)$plot_env$layout, "levels") + # Two-mode networks whose ties all run between the modes are unaffected, + # as are one-mode networks. + expect_false(.ag_is_multilevel(ison_southern_women)) + expect_equal(graphr(ison_southern_women)$plot_env$layout, "layered") + expect_equal(graphr(ison_adolescents)$plot_env$layout, "stress") + # The one-mode layer of fict_marvel on its own is not multilevel. + expect_equal(graphr(to_giant(to_uniplex(fict_marvel, + "relationship")))$plot_env$layout, + "stress") +}) + +test_that("levels layout infers its levels when none are given", { + skip_on_cran() + # Both of these used to fail with "argument 'level' is missing, with no + # default": the levels were never derived, only reported as found. + expect_equal(nrow(layout_levels(to_multilevel(fict_marvel))), + as.integer(net_nodes(fict_marvel))) + p <- graphr(fict_marvel, layout = "levels") + expect_equal(p$plot_env$layout, "levels") + expect_buildable(p) + # Naming the levels explicitly still works, and agrees with the inferred + # levels, since fict_marvel holds its within-mode ties in the first mode. + expect_equal(layout_levels(fict_marvel, level = "type"), + layout_levels(fict_marvel)) +}) + +test_that("levels layout keeps the ordering of numeric levels", { + skip_on_cran() + # as.factor() would re-code these in sorted order, silently reversing the + # levels of any attribute whose ordering is not already alphabetical. + expect_equal(.as_level(c(3, 1, 2)), c(3L, 1L, 2L)) + expect_equal(.as_level(c("c", "a", "b")), c(3L, 1L, 2L)) + expect_equal(.as_level(c(FALSE, TRUE)), c(1L, 2L)) +}) + +test_that("levels layout reports what it cannot lay out", { + skip_on_cran() + # graphlayouts lays each level out separately for these methods, and levels + # with no ties within them leave it an empty subgraph to lay out, which it + # reports as "attempt to select less than one element in integerOneIndex". + expect_error(graphr(fict_marvel, layout = "levels", + method = "separate"), "no ties within") + expect_error(graphr(fict_marvel, layout = "levels", + method = "fix2"), "no ties within") + expect_no_error(suppressMessages(layout_levels(fict_marvel, + method = "fix1"))) + expect_error(graphr(fict_marvel, layout = "levels", method = "bloop"), + "method") + # Distances are infinite between components, which graphlayouts reports as + # "missing value where TRUE/FALSE needed". Two disjoint multilevel triads: + # in each, two first-mode nodes are tied to each other and to one of the + # second mode. + disconnected <- igraph::make_undirected_graph( + c(1,2, 1,3, 2,3, 4,5, 4,6, 5,6)) + igraph::V(disconnected)$type <- c(FALSE, FALSE, TRUE, FALSE, FALSE, TRUE) + expect_true(.ag_is_multilevel(disconnected)) + expect_false(manynet::is_connected(disconnected)) + expect_error(layout_levels(disconnected), "connected") + # A one-mode network has no levels to derive, and says so. + expect_error(layout_levels(manynet::as_igraph(ison_adolescents)), + "level") +}) + +test_that("levels layout draws each level at a size of its own", { + skip_on_cran() + # The default size shrinks with how crowded the plot is, but each level of a + # levels layout is only as crowded as itself: sizing fict_marvel's 53 + # characters as if there were 194 of them draws them as specks. + marvel <- ag_net(fict_marvel) + sizes <- .infer_nsize(marvel, NULL, "levels") + expect_length(unique(sizes), 2) + expect_gt(min(sizes), .infer_nsize(marvel, NULL)) + # Other layouts, and an explicit size, are unaffected. + expect_length(unique(.infer_nsize(marvel, NULL, "layered")), 1) + expect_equal(unique(.infer_nsize(marvel, 5, "levels")), 5) + # A default size is not mapped through aes(), so it is neither rescaled nor + # given a legend of its own. + p <- graphr(fict_marvel, labels = FALSE) + expect_buildable(p) + expect_false("size" %in% names(ggplot2::ggplot_build(p)$plot$guides$guides)) +}) + +test_that("levels layout draws the ties between levels more faintly", { + skip_on_cran() + # Cross-level ties outnumber within-level ties in fict_marvel, and at equal + # strength they curtain over both levels. + marvel <- ag_net(fict_marvel) + alphas <- .infer_ealpha(marvel, "levels") + expect_length(unique(alphas), 2) + expect_lt(max(alphas[manynet::tie_is_twomode(marvel)]), + min(alphas[!manynet::tie_is_twomode(marvel)])) + # Every other layout keeps the single constant it always used. + expect_equal(.infer_ealpha(marvel, "layered"), 0.4) + expect_equal(.infer_ealpha(ag_net(ison_adolescents), "levels"), 0.4) + # The varying alpha reaches the drawn edges rather than being rescaled. + built <- ggplot2::ggplot_build(graphr(fict_marvel, labels = FALSE)) + expect_setequal(round(unique(built$data[[1]]$edge_alpha), 2), c(0.08, 0.5)) +}) + +test_that("levels labels are tied to the nodes they belong to", { + skip_on_cran() + p <- graphr(fict_actually) + lab <- p[["layers"]][[length(p[["layers"]])]] + expect_s3_class(lab[["geom"]], "GeomTextRepel") + # A leader line however short the displacement, rather than only past + # ggrepel's default half a line of text. + expect_equal(lab[["geom_params"]][["min.segment.length"]], 0) + # Pulled back towards its own node, so that most labels need no line at all. + expect_equal(lab[["geom_params"]][["force_pull"]], 4) + expect_equal(lab[["geom_params"]][["box.padding"]], 0.1) + expect_buildable(p) +}) + diff --git a/tests/testthat/test-layout_partition.R b/tests/testthat/test-layout_partition.R deleted file mode 100644 index 5b1f4be2..00000000 --- a/tests/testthat/test-layout_partition.R +++ /dev/null @@ -1,111 +0,0 @@ -# Layouts -test_that("concentric and circular layouts graph correctly", { - skip_on_cran() - fmrg <- to_giant(to_uniplex(fict_marvel, "relationship")) - test_circle <- graphr(fmrg, layout = "circle") - test_conc <- graphr(fmrg, layout = "concentric", membership = "Gender") - expect_equal(test_circle$plot_env$layout, "circle") - expect_equal(test_conc$plot_env$layout, "concentric") - expect_equal(eval(quote(pairlist(...)), - envir = test_conc$plot_env)$membership, - "Gender") -}) - -test_that("concentric layout works when node names are missing", { - skip_on_cran() - llabel <- ison_southern_women %>% - mutate(name = ifelse(type == TRUE, "", name)) %>% - graphr(layout = "concentric") - expect_true(any(llabel$data$name == "")) -}) - -test_that("hierarchy and lineage layouts graph correctly", { - skip_on_cran() - test_lin <- ison_adolescents %>% - mutate(year = rep(c(1985, 1990, 1995, 2000), times = 2)) %>% - graphr(layout = "lineage", rank = "year") - test_hie <- graphr(ison_southern_women, - layout = "hierarchy", center = "events") - expect_equal(test_lin$plot_env$layout, "lineage") - expect_equal((eval(quote(pairlist(...)), - envir = test_lin[["plot_env"]])[["rank"]]), - "year") - expect_equal(test_hie$plot_env$layout, "hierarchy") - expect_equal((eval(quote(pairlist(...)), - envir = test_hie[["plot_env"]])[["center"]]), - "events") -}) - -# test_that("graphr works for diff_model objects", { -# skip_on_cran() -# skip_on_ci() -# test_diff <- graphr(play_diffusion(ison_brandes, old_version = TRUE)) -# if (inherits(test_diff$guides, "Guides")) { -# expect_s3_class(test_diff[["guides"]][["guides"]][["shape"]], "GuideLegend") -# expect_s3_class(test_diff[["guides"]][["guides"]][["colour"]], "GuideColourbar") -# } else { -# expect_equal(test_diff[["guides"]][["shape"]][["name"]], "legend") -# expect_equal(test_diff[["guides"]][["colour"]][["name"]], "colorbar") -# } -# }) - -test_that("hierarchy layout works for two mode networks", { - skip_on_cran() - tm <- ison_brandes %>% - mutate(type = twomode_type, name = LETTERS[1:11]) %>% - graphr() - expect_length(unique(tm$data[tm$data$type == TRUE, "y"]), 1) - expect_length(unique(tm$data[tm$data$type == FALSE, "y"]), 1) -}) - -test_that("default hierarchy layout uses sugiyama for two-mode networks", { - skip_on_cran() - p <- graphr(ison_southern_women, layout = "hierarchy") - expect_s3_class(p, c("ggraph", "gg", "ggplot")) - expect_equal(p$plot_env$layout, "hierarchy") - # Two-mode should have exactly 2 unique y values (layers) - expect_equal(length(unique(round(p$data$y, 6))), 2) -}) - -test_that("alluvial layout works", { - skip_on_cran() - p <- graphr(ison_southern_women, layout = "alluvial") - expect_s3_class(p, c("ggraph", "gg", "ggplot")) - expect_equal(p$plot_env$layout, "alluvial") -}) - -test_that("hierarchy layout minimises edge crossings", { - skip_on_cran() - # Helper: count bipartite edge crossings given x positions - count_crossings <- function(el, x_pos) { - crossings <- 0 - if (nrow(el) < 2) return(0) - for (i in 1:(nrow(el) - 1)) { - for (j in (i + 1):nrow(el)) { - a1 <- x_pos[el[i, 1]]; b1 <- x_pos[el[i, 2]] - a2 <- x_pos[el[j, 1]]; b2 <- x_pos[el[j, 2]] - if ((a1 - a2) * (b1 - b2) < 0) crossings <- crossings + 1 - } - } - crossings - } - # Test with ison_southern_women (18 women, 14 events, 89 ties) - g <- manynet::as_igraph(ison_southern_women) - n <- igraph::vcount(g) - el <- igraph::as_edgelist(g, names = FALSE) - layers <- ifelse(igraph::V(g)$type, 2, 1) - lo <- autograph:::.sugiyama_layout(g, layers = layers, times = 100) - x_pos <- lo[, 1] - # Naive layout: sequential ordering within each layer - naive_x <- rep(0, n) - naive_x[layers == 1] <- seq_len(sum(layers == 1)) - naive_x[layers == 2] <- seq_len(sum(layers == 2)) - optimised_crossings <- count_crossings(el, x_pos) - naive_crossings <- count_crossings(el, naive_x) - # The optimised layout should have fewer crossings than naive - expect_lt(optimised_crossings, naive_crossings) - # Verify all nodes got valid positions - expect_true(all(is.finite(x_pos))) - expect_equal(length(unique(lo[layers == 1, 2])), 1) - expect_equal(length(unique(lo[layers == 2, 2])), 1) -}) diff --git a/tests/testthat/test-layout_scaling.R b/tests/testthat/test-layout_scaling.R new file mode 100644 index 00000000..ba17be28 --- /dev/null +++ b/tests/testthat/test-layout_scaling.R @@ -0,0 +1,94 @@ +# The scaling layout and the fit it reports. See R/layout_scaling.R. + +test_that("scaling layout graphs correctly", { + skip_on_cran() + p <- graphr(manynet::ison_southern_women, layout = "scaling") + expect_equal(p$plot_env$layout, "scaling") + expect_buildable(p) + expect_equal(nrow(p$data), + as.integer(manynet::net_nodes(manynet::ison_southern_women))) +}) + +test_that("scaling layout places every node of an awkward network", { + skip_on_cran() + # A disconnected network, which "pmds" refuses outright, and a signed one, + # whose weights make the shortest paths uncomputable. + for (net in list(manynet::ison_adolescents, manynet::ison_southern_women, + manynet::fict_thrones, manynet::fict_marvel)) { + lo <- layout_scaling(net) + expect_named(lo, c("x", "y")) + expect_equal(nrow(lo), as.integer(manynet::net_nodes(net))) + expect_true(all(is.finite(as.matrix(lo)))) + } +}) + +test_that("scaling layout scales in full where it can and by pivots otherwise", { + skip_on_cran() + full <- attr(layout_scaling(manynet::ison_southern_women), "fit") + expect_true(is.na(full$pivots)) + expect_false(is.na(full$variance)) + pivoted <- attr(layout_scaling(manynet::ison_southern_women, pivots = 5), + "fit") + expect_equal(pivoted$pivots, 5L) + # The share of variance comes from the decomposition the pivots avoid. + expect_true(is.na(pivoted$variance)) + expect_error(layout_scaling(manynet::ison_adolescents, pivots = 1), + "at least 2") +}) + +test_that("scaling layout draws axes and reports its fit", { + skip_on_cran() + p <- graphr(manynet::ison_southern_women, layout = "scaling") + expect_equal(p$labels$x, "Dimension 1") + expect_equal(p$labels$y, "Dimension 2") + expect_match(p$labels$caption, "Stress: [0-9]+%") + expect_match(p$labels$caption, "distance variance") + # One scale for both axes, or the distances drawn cannot be compared. + expect_equal(p$coordinates$ratio, 1) + # Axes a void theme would have blanked. + expect_false(inherits(p$theme$axis.text, "element_blank")) +}) + +test_that("a poor fit is reported at the console", { + skip_on_cran() + old <- options(snet_verbosity = "verbose") + on.exit(options(old), add = TRUE) + expect_message(graphr(manynet::ison_networkers, layout = "scaling"), + "read the clusters") + expect_no_message(graphr(manynet::ison_adolescents, layout = "scaling")) +}) + +test_that("scaling coordinates are kept when snapping is asked for", { + skip_on_cran() + snapped <- suppressMessages( + graphr(manynet::ison_southern_women, layout = "scaling", snap = TRUE)) + plain <- graphr(manynet::ison_southern_women, layout = "scaling") + expect_equal(snapped$data[, c("x", "y")], plain$data[, c("x", "y")]) +}) + +test_that("the fit is captioned alongside the isolates", { + skip_on_cran() + iso <- manynet::add_nodes(manynet::ison_adolescents, 1, + list(name = "Zoe")) + p <- suppressMessages( + graphr(iso, layout = "scaling", isolates = "caption")) + expect_match(p$labels$caption, "Isolates: Zoe") + expect_match(p$labels$caption, "Stress") +}) + +test_that("check_stress() scores a layout that draws distances better", { + skip_on_cran() + scaled <- check_stress(graphr(manynet::ison_southern_women, + layout = "scaling")) + circle <- check_stress(graphr(manynet::ison_southern_women, + layout = "circle")) + expect_length(scaled, 1) + expect_true(is.finite(scaled) && scaled >= 0) + expect_lt(scaled, circle) + expect_equal(attr(scaled, "pairs"), 32 * 31) + # The layout reports the same score it is measured by. + expect_equal(unname(scaled), + attr(layout_scaling(manynet::ison_southern_women), + "fit")$stress, tolerance = 1e-6) + expect_error(check_stress(ggplot2::ggplot()), "coordinates") +}) diff --git a/tests/testthat/test-plot_goldfish.R b/tests/testthat/test-plot_goldfish.R new file mode 100644 index 00000000..40aaed60 --- /dev/null +++ b/tests/testthat/test-plot_goldfish.R @@ -0,0 +1,481 @@ +# The goldfish diagnostic classes. These objects arrive plot-ready: each is a +# tibble carrying the metadata contract, so every method here reads its series +# and its labels off the object rather than reshaping it. + +test_that("outliers plotting works", { + p <- plot(goldfish_outliers) + expect_s3_class(p, "ggplot") + # The series is the one the diagnostic analysed, and the flag is logical. + expect_type(goldfish_outliers$outlier, "logical") + expect_true(".series" %in% names(goldfish_outliers)) + expect_true(any(goldfish_outliers$outlier)) +}) + +test_that("an object with nothing flagged says so instead of plotting", { + quiet <- goldfish_outliers + quiet$outlier <- FALSE + expect_output(p <- plot(quiet), "No outliers found") + expect_null(p) +}) + +test_that("changepoints plotting works", { + p <- plot(goldfish_changepoints) + expect_s3_class(p, "ggplot") + expect_type(goldfish_changepoints$cpt, "logical") + expect_true(any(goldfish_changepoints$cpt)) +}) + +test_that("margin table plotting works", { + p <- plot(goldfish_margins) + expect_s3_class(p, "ggplot") +}) + +test_that("the methods read the metadata contract, not the columns", { + for (object in list( + goldfish_outliers, + goldfish_changepoints, + goldfish_margins + )) { + expect_s3_class(object, "tbl_df") + expect_type(attr(object, "diagnostic"), "character") + expect_type(attr(object, "context"), "list") + expect_type(attr(object, "params"), "list") + # The producing goldfish version, so a precooked fixture can be seen to + # have aged. + expect_type(attr(object, "version"), "character") + } + expect_identical(attr(goldfish_outliers, "diagnostic"), "diagnose_outliers") + expect_identical( + attr(goldfish_changepoints, "diagnostic"), + "diagnose_changepoints" + ) + expect_identical(attr(goldfish_margins, "diagnostic"), "margin_table") +}) + +test_that("the plots render without goldfish attached", { + # Dispatch is on class alone, and nothing here calls back into goldfish. + expect_false("package:goldfish" %in% search()) + expect_s3_class(plot(goldfish_outliers), "ggplot") + expect_s3_class(plot(goldfish_changepoints), "ggplot") + expect_s3_class(plot(goldfish_margins), "ggplot") +}) + +test_that("the margin plot caps the actors it draws, and says how many", { + full <- plot(goldfish_margins, top = Inf) + capped <- plot(goldfish_margins) + expect_gt(nrow(full$data), nrow(capped$data)) + # Nothing is dropped silently. + expect_match(capped$labels$subtitle, "further actors not shown") + expect_null(full$labels$subtitle) +}) + +# The two test classes. Both are classed LISTS of tibbles rather than single +# tibbles -- one rectangle does not hold a per-effect table and a per-interval +# series -- so the methods take their series from a named component. + +test_that("gof process plotting works", { + p <- plot(goldfish_gof) + expect_s3_class(p, "ggplot") + # One panel per tested effect, from the object's own process table. + expect_identical( + length(unique(goldfish_gof$process$term)), + nrow(goldfish_gof$effects) + ) +}) + +test_that("the gof x axis is the object's clock, not a re-derived one", { + p <- plot(goldfish_gof) + # The bands are valid on whichever clock produced the process, so the axis + # has to be the `u` column the object carries. Reading an event index here + # would draw the path on one clock and the reference on another. + expect_identical(deparse(p$mapping$x), "~.data$u") + expect_identical(p$labels$x, "Share of events") + + # And the label follows the clock rather than being fixed. + information <- goldfish_gof + attr(information, "params")$clock <- "information" + expect_identical( + plot(information)$labels$x, + "Cumulative share of information" + ) +}) + +test_that("the gof reference band inverts the same distribution as the test", { + # The band is the two-sided Kolmogorov quantile, which is what the + # event-clock p-value comes from -- so a path touching the band must sit at + # the plotted level, or band and p-value disagree. + q <- gf_bridge_quantile(0.95) + j <- seq_len(100) + cdf <- 1 - 2 * sum((-1)^(j - 1) * exp(-2 * j^2 * q^2)) + expect_equal(cdf, 0.95, tolerance = 1e-8) + expect_gt(gf_bridge_quantile(0.99), q) +}) + +test_that("time residual plotting works", { + p <- plot(goldfish_time) + expect_s3_class(p, "ggplot") + expect_identical( + length(unique(goldfish_time$residuals$term)), + nrow(goldfish_time$effects) + ) + expect_match(p$labels$subtitle, "time trend") +}) + +test_that("the trend method draws no period legend", { + # `period` is all-NA under the trend method; colouring by a constant would + # put a one-level legend on every trend plot. + expect_true(all(is.na(goldfish_time$residuals$period))) + p <- plot(goldfish_time) + expect_false(any(vapply( + p$layers, + function(l) "colour" %in% names(l$mapping), + logical(1) + ))) + + # With periods present the scatter is coloured by them instead. + periods <- goldfish_time + periods$residuals$period <- rep( + c("early", "late"), + length.out = nrow(periods$residuals) + ) + attr(periods, "params")$method <- "periods" + q <- plot(periods) + expect_true(any(vapply( + q$layers, + function(l) "colour" %in% names(l$mapping), + logical(1) + ))) + expect_match(q$labels$subtitle, "across periods") +}) + +test_that("the test objects carry the metadata contract", { + for (object in list(goldfish_gof, goldfish_time)) { + expect_type(object, "list") + expect_type(attr(object, "diagnostic"), "character") + expect_type(attr(object, "context"), "list") + expect_type(attr(object, "params"), "list") + expect_type(attr(object, "version"), "character") + } + expect_identical(attr(goldfish_gof, "diagnostic"), "test_gof") + expect_identical(attr(goldfish_time, "diagnostic"), "test_time") +}) + +test_that("the test plots render without goldfish attached", { + expect_false("package:goldfish" %in% search()) + expect_s3_class(plot(goldfish_gof), "ggplot") + expect_s3_class(plot(goldfish_time), "ggplot") +}) + +# The onset class. Two panels composed with patchwork, both windowed on the +# excursion rather than the sequence -- the geometry is the substance here, so +# it is what the tests pin. + +test_that("onset plotting composes two panels", { + p <- plot(goldfish_onset) + expect_s3_class(p, "patchwork") + # And each panel is available alone, the escape hatch for a model with too + # many coefficients for a composed figure. + expect_s3_class(plot(goldfish_onset, view = "path"), "ggplot") + expect_s3_class(plot(goldfish_onset, view = "accrual"), "ggplot") + expect_error(plot(goldfish_onset, view = "nonesuch")) +}) + +test_that("the path panel is windowed on each coefficient's own excursion", { + drawn <- plot(goldfish_onset, view = "path")$data + summary <- as.data.frame(goldfish_onset$summary) + n_events <- attr(goldfish_onset, "context")$n_events + + # Full range is mostly bridge tail: the path returns to the estimate by + # construction, so drawing all of it squashes what is being read. + expect_lt(max(drawn$dropped_events), n_events) + + for (i in seq_len(nrow(summary))) { + at <- summary$stabilized_at[i] + window <- max(drawn$dropped_events[drawn$term == summary$term[i]]) + expected <- if (at == 0) { + n_events + } else { + min(n_events, max(ceiling(1.15 * at), 10)) + } + # `expect_equal`, not identical: the window comes off an integer column + # and the formula returns a double from `ceiling()`. + expect_equal(window, expected) + # The window has to reach past the point it marks, or the marker falls + # outside the panel it belongs to. + if (at > 0) expect_gte(window, at) + } +}) + +test_that("the path facets carry free scales, not one shared window", { + # A window shared across facets re-creates the squashing the per-coefficient + # window exists to prevent. + p <- plot(goldfish_onset, view = "path") + expect_true(p$facet$params$free$x) + expect_true(p$facet$params$free$y) +}) + +test_that("the accrual panel is full range with the diagonal drawn", { + accrual <- plot(goldfish_onset, view = "accrual") + n_events <- attr(goldfish_onset, "context")$n_events + # Full range, unlike the path panel: the window is shaded, not cut to. + expect_identical(max(accrual$data$dropped_events), n_events) + # Without the proportional diagonal a monotone 0-to-1 curve says nothing -- + # the departure from it is the finding. + slopes <- vapply( + accrual$layers, + function(l) { + if (is.null(l$data$slope)) NA_real_ else l$data$slope[[1]] + }, + numeric(1) + ) + expect_true(any(!is.na(slopes) & abs(slopes - 1 / n_events) < 1e-12)) +}) + +test_that("a fixed coefficient is not drawn", { + # An offset is a flat line at its imposed value by construction. + held <- goldfish_onset + held$summary$fixed[1] <- TRUE + drawn <- plot(held, view = "path")$data + expect_false(goldfish_onset$summary$term[1] %in% drawn$term) + + # And with every coefficient held there is nothing to trace. + all_held <- goldfish_onset + all_held$summary$fixed <- TRUE + expect_output(p <- plot(all_held), "No estimated coefficient") + expect_null(p) +}) + +test_that("the onset plot renders without goldfish attached", { + expect_false("package:goldfish" %in% search()) + expect_s3_class(plot(goldfish_onset), "patchwork") +}) + +# The one-call overview. It plots a FIT rather than a diagnostic object, and +# everything it draws comes from what the fit already stores -- so which panels +# appear is itself a readout of what was requested at estimation. + +test_that("the overview composes the panels the fit can supply", { + skip_without_gf_diagnostics() + p <- plot(goldfish_fit) + expect_s3_class(p, "patchwork") + # The fixture stores loglik, scores and conditional_scores and is + # exact-time, so all four panels are available. + expect_length(p$patches$plots, 3L) +}) + +test_that("the overview costs no evaluation pass", { + skip_without_gf_diagnostics() + # Stored primitives only: the fixture carries no preprocessed statistics, so + # anything reaching for a replay would abort rather than draw. + expect_null(goldfish_fit$preprocessed) + expect_s3_class(plot(goldfish_fit), "patchwork") +}) + +test_that("a panel whose primitive is missing is left out, not an error", { + skip_without_gf_diagnostics() + stripped <- goldfish_fit + stripped$event_scores <- NULL + stripped$conditional_scores <- NULL + p <- plot(stripped) + # Deviance and waiting times survive on "loglik" alone; the two score-based + # panels drop. + expect_s3_class(p, "patchwork") + expect_length(p$patches$plots, 1L) +}) + +test_that("an ordinal fit has no waiting-time panel", { + skip_without_gf_diagnostics() + # An ordinal likelihood conditions the timing away, so there is no + # compensator and no waiting time to check. + ordinal <- goldfish_fit + ordinal$total_rate <- NULL + ordinal$intervals <- NULL + drawn <- plot(ordinal) + expect_s3_class(drawn, "patchwork") + expect_lt(length(drawn$patches$plots), 3L) +}) + +test_that("a fit with nothing stored says so instead of drawing", { + bare <- goldfish_fit + for (component in c( + "interval_log_lik", "event_scores", "conditional_scores", + "total_rate", "intervals" + )) { + bare[[component]] <- NULL + } + expect_output(p <- plot(bare), "no diagnostic primitive") + expect_null(p) +}) + +test_that("the Schoenfeld panel caps the effects it draws", { + skip_without_gf_diagnostics() + # A model with a dozen terms makes a facet grid unreadable at overview size, + # so the panel is capped and ranked by the cumulative-score statistic. + wide <- plot(goldfish_fit, effects = 2) + # patchwork keeps the last plot at the top level and the rest under + # `$patches$plots`, so the panels are found by their subtitle rather than by + # a position that shifts whenever one drops out. + panels <- c(wide$patches$plots, list(wide)) + subtitles <- vapply(panels, function(p) p$labels$subtitle %||% "", character(1)) + # Matched on the prefix: a reduced panel now names what it dropped, so the + # subtitle carries a count after it. + schoenfeld <- panels[[which(startsWith(subtitles, "Scaled Schoenfeld"))[1]]] + expect_length(unique(schoenfeld$data$term), 2L) + # And says so, rather than drawing two of several as though that were the + # model. + expect_match(schoenfeld$labels$subtitle, "not shown") +}) + +# A multi-process fit arrives row-bound, with `flavor` and `family` naming the +# process each row came from. The series plots draw with `geom_line()`, so +# without a panel per process the line runs straight from one process's last +# event to the next process's first -- a segment joining two unrelated series. + +flavor_stack <- function(object) { + block <- function(flavor, family) { + out <- dplyr::as_tibble(object) + out$flavor <- flavor + out$family <- family + out + } + stacked <- rbind( + block("creation", "rate"), + block("dissolution", "rate") + ) + attributes(stacked) <- c( + attributes(stacked), + attributes(object)[ + setdiff(names(attributes(object)), names(attributes(stacked))) + ] + ) + class(stacked) <- class(object) + stacked +} + +facet_vars <- function(p) { + params <- p$facet$params + names(c(params$facets, params$rows, params$cols)) +} + +test_that("a row-bound flavoured table gets a panel per process", { + for (object in list(goldfish_outliers, goldfish_changepoints)) { + p <- plot(flavor_stack(object)) + expect_s3_class(p, "ggplot") + expect_identical(facet_vars(p), c("flavor", "family")) + } +}) + +test_that("a single-process table is not faceted", { + # The identity columns are absent there, so the panel split has nothing to + # split on and the plot is the one it always was. + for (object in list(goldfish_outliers, goldfish_changepoints)) { + p <- plot(object) + expect_s3_class(p, "ggplot") + expect_length(facet_vars(p), 0L) + } +}) + +test_that("changepoint breaks stay in the process they were found in", { + # Drawn from a data frame rather than a bare `xintercept` vector: a vector + # would put every process's breaks onto every panel. + stacked <- flavor_stack(goldfish_changepoints) + p <- plot(stacked) + vline <- Filter( + function(l) inherits(l$geom, "GeomVline"), + p$layers + ) + expect_length(vline, 1L) + marked <- vline[[1]]$data + expect_true(all(c("flavor", "family") %in% names(marked))) + expect_true(all(marked$cpt)) +}) + +# Pagination. A model with many terms breaks a one-panel-per-term figure, and +# the remedy cannot assume someone is at a screen: fits go to a cluster, so the +# page count has to be knowable before rendering and every page has to render +# with nobody there to press return. + +# A paginate facet lays out EVERY panel and marks each with the page it belongs +# to, so the page's own panels are the rows carrying it -- not the whole layout, +# which is what makes a naive reading show every term on every page. +page_terms <- function(p) { + layout <- ggplot2::ggplot_build(p)$layout$layout + if (!is.null(layout$page)) { + page <- attr(p$facet$params, "page") %||% p$facet$params$page + layout <- layout[layout$page == page, , drop = FALSE] + } + keys <- intersect(c("term", "flavor", "family"), names(layout)) + unique(do.call(paste, c(layout[keys], sep = " | "))) +} + +test_that("the page count is known without rendering", { + # Read off the object, so a loop can size itself before anything is drawn. + for (object in list(goldfish_gof, goldfish_time, goldfish_onset)) { + panels <- gf_panel_count(object) + expect_gt(panels, 0L) + expect_identical(count_pages(object, nrow = 1, ncol = 1), as.integer(panels)) + expect_identical(count_pages(object, nrow = panels, ncol = panels), 1L) + # Never zero: a figure with nothing to facet is still one page. + expect_gte(count_pages(object), 1L) + } +}) + +test_that("the count matches the panels actually drawn", { + # `goldfish_onset` is excluded on purpose: its plot is a patchwork of two + # panels rather than one faceted ggplot, so it has no single layout to count. + for (object in list(goldfish_gof, goldfish_time)) { + expect_identical( + gf_panel_count(object), + length(page_terms(plot(object))) + ) + } +}) + +test_that("the pages cover every term exactly once", { + for (object in list(goldfish_gof, goldfish_time)) { + all_terms <- page_terms(plot(object)) + n_pages <- count_pages(object, nrow = 1, ncol = 1) + + seen <- unlist(lapply(seq_len(n_pages), function(k) { + page_terms(plot(object, page = k, nrow = 1, ncol = 1)) + })) + expect_setequal(seen, all_terms) + expect_identical(anyDuplicated(seen), 0L) + } +}) + +test_that("every page renders without prompting", { + # `devAskNewPage()` is what a base-graphics multi-page walk uses, and it is + # exactly what cannot be scripted. Asserted rather than assumed: the flag is + # read back after rendering every page. + expect_false(interactive()) + before <- grDevices::devAskNewPage() + + n_pages <- count_pages(goldfish_gof, nrow = 1, ncol = 1) + for (k in seq_len(n_pages)) { + p <- plot(goldfish_gof, page = k, nrow = 1, ncol = 1) + expect_s3_class(p, "ggplot") + # Rendering, not merely constructing: a paginate facet that cannot resolve + # its page fails here rather than at print time. + expect_no_error(ggplot2::ggplot_build(p)) + } + expect_identical(grDevices::devAskNewPage(), before) +}) + +test_that("a page past the last one is an error naming the count", { + n_pages <- count_pages(goldfish_gof, nrow = 1, ncol = 1) + expect_error( + plot(goldfish_gof, page = n_pages + 1L, nrow = 1, ncol = 1), + "past the last page" + ) + expect_error(plot(goldfish_gof, page = 0), "positive") + expect_error(plot(goldfish_gof, page = c(1, 2)), "single positive") +}) + +test_that("an unpaged figure is untouched by pagination existing", { + for (object in list(goldfish_gof, goldfish_time)) { + facet <- plot(object)$facet + expect_s3_class(facet, "FacetWrap") + expect_false(inherits(facet, "FacetWrapPaginate")) + } +}) diff --git a/tests/testthat/test-theme_set.R b/tests/testthat/test-theme_set.R index b45c9f80..569a6f7d 100644 --- a/tests/testthat/test-theme_set.R +++ b/tests/testthat/test-theme_set.R @@ -6,20 +6,23 @@ test_that("setting theme provides correct palette", { # Tests run in parallel (Config/testthat/parallel) and the theme is global # state, so restore it rather than leaving the last theme set here in place. + # These check which colours a theme holds, not the order they come in: + # the order is chosen by cvd_sort() so that the first few colours separate + # for colour-blind viewers, and is tested in test-functional_themes.R. on.exit(suppressMessages(stocnet_theme("default")), add = TRUE) stocnet_theme("default") - expect_equal(getOption("snet_cat"), c("#1B9E77","#4575b4","#d73027", + expect_setequal(getOption("snet_cat"), c("#1B9E77","#4575b4","#d73027", "#66A61E","#E6AB02","#D95F02","#7570B3", "#A6761D","#E7298A","#666666")) stocnet_theme("iheid") - expect_equal(getOption("snet_cat"), c("#006564","#0094D8","#622550", + expect_setequal(getOption("snet_cat"), c("#006564","#0094D8","#622550", "#268D2B","#3E2682","#820C2B", "#008F92","#006EAA","#A8086E")) stocnet_theme("ethz") - expect_equal(getOption("snet_cat"), c("#215CAF","#007894","#627313", + expect_setequal(getOption("snet_cat"), c("#215CAF","#007894","#627313", "#8E6713","#B7352D","#A7117A","#6F6F6F")) stocnet_theme("uzh") - expect_equal(getOption("snet_cat"), c("#0028A5","#4AC9E3","#A4D233", + expect_setequal(getOption("snet_cat"), c("#0028A5","#4AC9E3","#A4D233", "#FFC845","#FC4C02","#BF0D3E", "#BDC9E8","#DBF4F9","#ECF6D6", "#FFF4DA","#FFDBCC","#FBC6D4", @@ -32,7 +35,7 @@ test_that("setting theme provides correct palette", { "#001452","#147082","#536B18", "#A27200","#7E2601","#60061F")) stocnet_theme("unibe") - expect_equal(getOption("snet_cat"), c("#466553","#668271","#8aa092","#afbfb5","#d6ded9", + expect_setequal(getOption("snet_cat"), c("#466553","#668271","#8aa092","#afbfb5","#d6ded9", "#007ea2","#5294b4","#85adc6","#b0c7d9","#d8e2ec", "#203a5d","#4a5575","#757792","#a1a0b4","#d0ced9", "#8a1e22","#a14540","#b86f65","#d19d93","#e8cdc6", @@ -43,7 +46,7 @@ test_that("setting theme provides correct palette", { "#c2b600","#cfc43c","#dcd274","#e8e1a4","#f4f0d3", "#ee7402","#f3923e","#f7af70","#fbcba1","#fde6d1")) stocnet_theme("rainbow") - expect_equal(getOption("snet_cat"), c('#E8ECFB', '#D9CCE3', '#D1BBD7', + expect_setequal(getOption("snet_cat"), c('#E8ECFB', '#D9CCE3', '#D1BBD7', '#CAACCB', '#BA8DB4', '#AE76A3', '#AA6F9E', '#994F88', '#882E72', '#1965B0', '#437DBF', '#5289C7', diff --git a/vignettes/articles/visualising-networks.Rmd b/vignettes/articles/visualising-networks.Rmd index 40247214..9229c751 100644 --- a/vignettes/articles/visualising-networks.Rmd +++ b/vignettes/articles/visualising-networks.Rmd @@ -127,7 +127,9 @@ Remember the three flavours of bundled data as a rough difficulty ladder — **Real-world** (`irps_*`, larger & realistic) — and that you can browse the full list with `table_data()`. -gif of Bob Ross painting a happy little landscape +::: {.callout} +**Try it yourself**: This section includes an interactive quiz in the live tutorial — run `run_tute()` at the R console to try it. +::: ## Getting started @@ -271,7 +273,9 @@ graphr(fict_lotr) Note everything that happened without being asked: `graphr()` recognised that the network is `r gloss("labelled","label")` -and printed the node labels, +and printed node labels — but only for the most central characters, +since 36 labels at once would hide the network behind them +(the Labels section below shows how to choose differently), chose a deterministic layout (so you get the same picture every time), sized and spaced the labels to minimise overlap, and dropped the axes and grey background that mean nothing for networks. @@ -297,7 +301,8 @@ Click 'Next Topic' to continue. ::: {.callout} **In brief**: `graphr()` graphs any manynet-compatible network object with sensible defaults inferred from the data: -labels where the network is labelled, arrowheads where it is directed, +labels where the network is labelled (and, where it is large, +only for the nodes that stand out), arrowheads where it is directed, a deterministic layout, and no chart junk. It returns a `{ggplot2}` object, so anything you can do to a ggplot — adding layers, titles, scales with `+` — you can do to a graph. @@ -409,8 +414,6 @@ graphr(ison_southern_women) ### Colouring nodes {#colouring-nodes} -gif of an artist swirling paint colours together on a palette - Let's try instead colouring the nodes by this "Race" variable. It is very similar to the shape example above. **Can you complete the code yourself?** @@ -531,23 +534,70 @@ setting `edge_size` yourself resizes both together. ### Taming dense or disconnected networks {#taming-networks} -Two arguments help when a network is too dense, or too sparse, to read at a -glance. +Sometimes networks are just a dense hairball. +This is a technical term to describe networks with many high-degree nodes and many ties, +where the sheer number of ties obscures the structure of the network. +Autograph includes three arguments that can help with this. -Larger, denser networks can turn into a 'hairball', where the sheer number of -ties obscures everything. `edge_bundle` pulls ties that travel in similar -directions into shared paths — like cabling them together — so that the main -'highways' of the network stand out. It is off by default; set -`edge_bundle = TRUE` (or name a specific algorithm: `"force"`, `"path"`, or -`"minimal"`) to switch it on. **Compare a dense random network with and -without bundling.** +#### Bundling ties {#bundling} + +The first option is to draw all of the ties 'bundled' together, +which can reveal where the most common paths through the network are. +`edge_bundle` pulls ties that travel in similar +directions into shared paths — like cabling them together — +so that the main 'highways' of the network stand out. +It is off by default; set `edge_bundle = TRUE` +(or name a specific algorithm: `"force"`, `"path"`, or `"minimal"`) to switch it on. +**`ison_lawfirm` records 71 lawyers and 2571 +ties between them, which is about as thick a hairball as a network this small +can be. Compare it drawn with and without bundling (turn backbone off too for clearest comparison results).** ```{r bundle, fig.width=9} -rand <- manynet::generate_random(40, 0.1) -(graphr(rand) + ggtitle("Unbundled") | - graphr(rand, edge_bundle = TRUE) + ggtitle("Bundled")) +graphr(ison_lawfirm, backbone = FALSE) + ggtitle("Unbundled") | + graphr(ison_lawfirm, backbone = FALSE, edge_bundle = "path") + ggtitle("Bundled") +``` + +I find this works best with networks that are at least moderately dense, +and sometimes requires a little bit of playing around to get a good result. + +#### Backbones {#backbone} + +By contrast, `r gloss("backbone")` changes which ties the picture is built around. +Ties that carry more weight/structure than expected by a null model local to their endpoints +are in essence what the network would be if it were stripped back to its skeleton. +`graphr()` then draws the layout according to this skeleton and +fades other ties into the background to further emphasise the main structure. + +Most of the time you will not have to ask for this. +Networks of 50+ nodes with 8 ties each on average is drawn this way by default. +But you can specify `backbone = FALSE` to turns it off, `backbone = TRUE` to force it on, +or you can name a filter — `"disparity"`, `"lans"`, `"noise"`, `"mlf"`, or `"simmelian"` — or threshold. +**Compare `ison_lawfirm` drawn with and without its backbone.** + +```{r backbone, fig.width=9} +(graphr(ison_lawfirm, node_colour = "office", backbone = FALSE) + + ggtitle("Every tie alike") | + graphr(ison_lawfirm, node_colour = "office", backbone = TRUE) + + ggtitle("Backbone")) ``` +The offices are hardly visible on the left. On the right they separate, because +the ties that hold each office together are the ties the filter keeps. + +Only the layouts that read tie lengths are laid out this way: `"stress"` (the +default), `"fr"`, `"drl"` and `"kk"`. Every other layout, including those whose +coordinates already mean something such as `"layered"` or `"scaling"`, keeps +its coordinates and only fades its ties. Signed networks have no backbone, +since these null models have no place for a negative weight, and are drawn as +they were. + +Bundling and backbones answer the same problem from different ends, so try one +before reaching for both. A bundled tie cannot carry a fading of its own — +bundling merges ties into shared paths — so where both are asked for, the +backbone still shapes the layout but every tie is drawn alike. + +#### Isolates {#isolates} + At the other extreme, many networks contain `r gloss("isolates","isolate")` — unconnected nodes — which, under a force-directed layout, drift to the margins and squeeze the connected core into a clump. The `isolates` argument decides @@ -563,10 +613,11 @@ lotr_iso <- fict_lotr |> graphr(lotr_iso, isolates = "legend") + ggtitle("legend")) ``` -For very large real-world networks such as `irps_blogs`, the two work well -together: `edge_bundle = TRUE` untangles the connected core while -`isolates = "legend"` keeps its several hundred unconnected blogs from -crowding that core out. +For very large real-world networks such as `irps_blogs`, these work well +together: a backbone picks out the ties that hold the connected core together +(or `edge_bundle = TRUE`, if you would rather see the paths the ties take than +which of them matter most), while `isolates = "legend"` keeps its several +hundred unconnected blogs from crowding that core out. ### Free play {#illustrating-free-play} @@ -589,7 +640,7 @@ for nodes, `edge_colour` and `edge_size` for ties. Use colour or shape for categorical attributes (colour scales better), size for continuous ones, and `node_group` to shade spatially clustered memberships. -For dense or disconnected networks, `edge_bundle` and `isolates` +For dense or disconnected networks, `edge_bundle`, `backbone` and `isolates` (see _Taming dense or disconnected networks_ above) keep the picture legible. ::: @@ -598,8 +649,10 @@ For dense or disconnected networks, `edge_bundle` and `isolates` On this page: Setting a theme · Hues · +Colour blindness · Greyscale · -Manual override +Manual override · +Medium ### Setting a theme {#setting-a-theme} @@ -626,13 +679,45 @@ Currently available themes include a number of institutional themes (`"iheid"`, `"ethz"`, `"uzh"`, `"rug"`, `"unibe"`, `"oxf"`, `"unige"`, `"cmu"`, `"iast"`, `"hwu"`) as well as stylistic ones (`"default"`, `"bw"`, `"crisp"`, `"neon"`, -`"rainbow"`). +`"clay"`, `"rainbow"`). Run `stocnet_theme()` without arguments to see which theme is currently set. More institutional scales and themes can be implemented upon pull request. -### Who's hue? {#whos-hue} +A theme lasts for the session in which you set it, +and a new session starts on the default again. +Where a theme is your usual one, `persist = TRUE` remembers it, +by writing the name to your user configuration directory: -gif from The Devil Wears Prada: that is not just blue, that is cerulean +```{r persist} +# stocnet_theme("iheid", persist = TRUE) # remembered next session too +stocnet_theme() +``` + +Nothing is written to disk unless you ask for it. +Setting any theme with `persist = FALSE`, the default, +forgets a choice you persisted earlier, +so `stocnet_theme("default", persist = FALSE)` puts you back where you began. + +A theme sets a typeface as well as a palette, +but only where that typeface is installed and R can see it. +`list_fonts()` lists the families R can see, +and `ag_font()` reports the one the current theme settled on. + +```{r fonts} +ag_font() +head(list_fonts("sans")) +``` + +If `ag_font()` returns `"sans"`, +the theme found none of the fonts it prefers, +and your graphs will look more generic than they should. +Install the missing family — many are free from +[Google Fonts](https://fonts.google.com) — +then install the `{systemfonts}` package so that R can see the fonts on your +system, and set the theme again. +`?stocnet_theme` sets out the steps for each operating system. + +### Who's hue? {#whos-hue} By default, `graphr()` will use a colour palette that offers fairly good contrast and better accessibility. @@ -671,11 +756,103 @@ The old trope is that males are less sensitive to colour distinctions:^[Though s comic strip about perceived colour vocabulary differences +### Seeing what others see {#seeing-what-others-see} + +About one man in twelve, and one woman in two hundred, +sees colour differently from the palette designer. +The most common form, deuteranopia, confuses reds with greens — +which is precisely the pairing a "stop/go" palette relies on. + +`{autograph}` gives you two functions for checking this. +`simulate_colorblind()` shows you a set of colours as such a viewer sees them, +and `check_separation()` scores how far apart colours are, +taking the worst case across normal vision and each type of colour blindness. +A score below 10 means two colours are easily confused, +10 to 25 that they are separable but close, +and above 25 that they are comfortably distinct. + +```{r cvdcheck} +# A red and a green that look quite different to most viewers +check_separation(c("#B7352D", "#627313")) +# But not to everyone +simulate_colorblind(c("#B7352D", "#627313"), "deutan") +``` + +**Run the code, then try `"protan"` or `"tritan"` instead of `"deutan"`.** + +How far the simulation goes is set by `severity`. +Full severity, the default, is dichromacy: +deuteranopia, protanopia, tritanopia. +A lower severity is anomalous trichromacy — +deuteranomaly, protanomaly — which is the more common condition, +and which the paragraph above named without being able to show you. + +```{r cvdseverity} +simulate_colorblind(c("#B7352D", "#627313"), "deutan", severity = 1) +simulate_colorblind(c("#B7352D", "#627313"), "deutan", severity = 0.4) +``` + +You can also look at a whole graph the way another viewer would, +by mapping the simulated colours back onto it. + +```{r cvdgraph, fig.width=9} +graphr(fict_lotr, node_colour = "Race") +graphr(fict_lotr, node_colour = "Race") + + ggplot2::scale_fill_manual(values = simulate_colorblind(ag_qualitative(6), "deutan")) +``` + +Much of this work is already done for you. +Each theme's palette is reordered when the theme is set, +so that the colours a graph uses first are the ones that stay distinct +for every viewer, +and each divergent palette pairs a warm pole with a cool one +rather than a red with a green. + +```{r cvdpalette} +stocnet_theme("iheid") +round(check_separation(ag_qualitative(4))) +# The closest pair among those four colours +min(check_separation(ag_qualitative(4)), na.rm = TRUE) +stocnet_theme("default") +``` + +::: {.callout} +**Going further**: +The `"rainbow"` theme is the exception, and is left in the order of the +spectrum, since that fidelity is its point. +A spectrum is not a colour-blind safe scheme: +its reds and greens are the pair that red-green colour blindness cannot +separate. +Choose it where the order of your categories is itself meaningful, +and check the result with `check_separation()`. +Where you need particular colours in an institutional palette, +`match_color()` finds the closest the palette has to those you ask for. +::: + ### Greyscale {#greyscale} Other times colour may not be desired. -Some publications require greyscale images. -To use a greyscale colour palette, +Some publications require greyscale images, +and a figure may be photocopied whether or not you meant it to be. +A greyscale device keeps the luminance of a colour and throws the rest away, +so two colours of the same lightness merge, however different their hues. +This is why ColorBrewer marks a palette print-safe and photocopy-safe +separately from marking it colour-blind safe: +they are different questions, and a palette can pass one and fail the other. + +`simulate_colorblind()` answers the second with `type = "grey"`, +and `check_separation()` reports the greyscale distances beside its own score. + +```{r greysim} +check_separation(ag_qualitative(4)) +``` + +The matrix is what every viewer can see. +The line beneath it is what survives a photocopier. +Most institutional palettes separate their categories by hue, +so most of them collapse in greyscale. + +To draw in greyscale from the start, replace `_hue` from above with `_grey` (note the 'e' spelling): ```{r greyscale, fig.width=9} @@ -689,6 +866,8 @@ or for very few discrete categories than for the six categories used here. If you need to distinguish several categories in print, consider combining greyscale with `node_shape`, or use the `"bw"` theme, which is designed for this purpose. +`stocnet_medium("print")` is the companion to this; +see _Where will it be seen?_ below. ### Manual override {#manual-override} @@ -711,14 +890,65 @@ graphr(fict_lotr, labs(fill = "Colour") ``` +### Where will it be seen? {#where-will-it-be-seen} + +A theme says how a plot should look. +Where it will be seen is a separate question, +and the answer changes more often than the theme does. +The same institutional theme has to serve a figure worked on at a desk, +projected in a lecture theatre, printed in an article, +and read on a phone in a narrow column. +Each of those wants a different size of text, +and one of them wants a different background. + +`stocnet_medium()` sets this, and leaves the theme alone. + +```{r medium, fig.width=9} +stocnet_medium() +stocnet_medium("presentation") +graphr(fict_lotr, node_colour = "Race") +stocnet_medium("screen") +``` + +The media are `"screen"` (the default), `"presentation"`, `"mobile"`, +and `"print"`. +The first three differ in the size of their text; +`ag_size()` reports the multiplier in force. +`"print"` leaves the text alone and draws on white, +whatever ground the theme prefers, +since a dark or tinted ground costs ink and is often not reproduced. +As with `stocnet_theme()`, `persist = TRUE` remembers your choice. + +The medium scales text, not marks. +A node's size is relative to the layout it sits in, +so enlarging the nodes without enlarging the layout would only crowd it. +Use `node_size` in `graphr()` where a figure needs larger nodes too. + +Nor does the medium set the size of the file you write. +Give `ggsave()` the width, height, and resolution to match; +see _Exporting plots_ below. + +::: {.callout} +**Going further**: +A small figure limits how much it can carry, not just how large the type is. +Keep a legend to about seven keys, and `graphs()` to about three panels. +`graphr()` says so when a colour or shape legend grows past that, +because past it a reader stops matching keys to marks and starts guessing. +Splitting one crowded figure into two that each make a single point +is almost always better than shrinking the type until it fits. +::: + ::: {.callout} **In brief**: `stocnet_theme()` sets a theme once for all subsequent -graphs and plots, with institutional and stylistic palettes included. +graphs and plots, with institutional and stylistic palettes included, +and `persist = TRUE` keeps it for future sessions. Individual graphs can still be adjusted by appending `ggplot2::scale_fill_*()` functions — `_hue()` for a different palette, `_grey()` for print, `_manual()` for hand-picked colours — -and it is worth checking your palette is colour-blind accessible. +and `simulate_colorblind()`, `check_separation()` and `check_contrast()` check +that your palette works for colour-blind viewers, in greyscale, and as text. +`stocnet_medium()` then sizes the result for where it will be seen. ::: ## Titles, labels, and legends @@ -736,8 +966,8 @@ In this section, we will learn how to add titles, labels, and legends to graphs. ### Labels {#labels} With our `fict_lotr` example above, because the network is itself labelled, -`graphr()` automatically adds the node labels. -If you do not want these labels, you can remove them from the network before +`graphr()` adds node labels. +If you do not want any labels, you can remove the names from the network before passing it on to `graphr()`, or more simply use the argument `labels = FALSE`. ```{r nodelab, fig.width=9} @@ -749,6 +979,46 @@ interpret, though we lose the information about which node is which character. Which you prefer depends on what the graph is _for_: exploring who-is-who, or communicating overall structure. +But this is not really a choice between all and nothing. +`fict_lotr` has 36 nodes, and 36 labels would cover the very network they +describe, so `graphr()` labelled only the handful of most central characters +and told you so. +**Ask for all of them with `labels = TRUE` and compare.** + +```{r nodelaball, fig.width=9} +graphr(fict_lotr, labels = TRUE) +``` + +You can decide how many to label by passing a number. +This is a depth of _ranks_ rather than a count of nodes, +so characters tied at the cut are labelled together — +ask for the top three and you may get four names. + +```{r nodelabn, fig.width=9} +graphr(fict_lotr, labels = 3) +``` + +`r gloss("Degree","degree")` is only one reason a node might be worth naming. +Passing the name of a measure labels whichever node or nodes it singles out: +`"betweenness"` for the characters who sit between others, +`"cutpoints"` for those holding the network together, +or `"random"` for a small unbiased sample. + +```{r nodelabmeasure, fig.width=9} +graphr(fict_lotr, labels = "betweenness") +``` + +To combine the two, name the number: `labels = c(betweenness = 5)`. +And when you know exactly who matters to your argument, +you can just say so — by name, or with any logical vector of the nodes. + +```{r nodelabwho, fig.width=9} +graphr(fict_lotr, labels = c("Frodo", "Gandalf")) + + ggtitle("Named outright") | + graphr(fict_lotr, labels = node_is_cutpoint(fict_lotr)) + + ggtitle("Every cutpoint") +``` + ::: {.callout} **Going further**: By default `graphr()` repels labels away from each other and from nodes @@ -756,8 +1026,9 @@ so that they do not overlap. Two further arguments offer finer control: `label_repel = FALSE` places labels at a fixed offset instead, and `label_dist` controls how far labels sit from their nodes (in points). -For crowded graphs, also consider labelling only some nodes, -e.g. `mutate(name = ifelse(node_is_max(node_by_deg(.)), name, ""))`. +On a `r gloss("two-mode","twomode")` or multilevel network, a selection is ranked +within each mode or level, so that a dense level cannot crowd the others +out of the labelling. ::: ### Titles {#titles} @@ -777,6 +1048,15 @@ for _x_ and _y_ axes, and legends (see below). ### Legends {#legends} +A legend asks a reader to hold a colour in mind while they hunt for it in the +graph, and people are poor at that: +colour is not recalled reliably, even over a couple of seconds. +Labelling nodes directly asks less of them, +which is why `graphr()` labels nodes where it can, +and why, above thirty nodes, it labels the most central ones +rather than none at all (see _Labels_ above). +Keep a legend for what cannot be written onto the graph itself, and keep it short. + While `{autograph}` attempts to provide legends where necessary, in some cases the legends offer insufficient detail, or are absent, such as in the following figure, @@ -814,7 +1094,8 @@ or removed using "none". ::: {.callout} **In brief**: `labs()` adds titles, subtitles, and legend titles; `guides()` forces or removes legends; -`labels = FALSE` hides node labels, +`labels` chooses which nodes to name — all of them, none, +the top few by a measure, or the ones you name yourself — and `label_repel`/`label_dist` fine-tune their placement. A graph that leaves your hands should be readable without you standing next to it explaining. @@ -864,8 +1145,6 @@ In the following sections, we review some of the most common types of layouts. ### Force-directed layouts {#force-directed-layouts} -gif of yoda moving things with the force - Force-directed layouts update some initial placement of vertices through the operation of some system of metaphorically-physical forces. These might include attractive and repulsive forces. @@ -908,37 +1187,116 @@ Other force-directed layouts available include: ### Layered layouts {#layered-layouts} -Layered layouts arrange nodes into horizontal (or vertical) layers, +Layered layouts arrange nodes into layers, positioning them so that they reduce crossings. These layouts are best suited for directed acyclic graphs, two-mode networks, -or other data with a natural hierarchy or ordering. +or other data with a natural ordering. + +`{autograph}` offers four, and they are one layout drawn four ways. +Two things vary: which axis the layers run along, and whether the nodes +line up across them. The names say which is which — a railway lies flat, +a ladder stands up: + +| | Layers stacked flat | Layers standing up | +|--------------------------|---------------------|--------------------| +| Nodes spaced by their ties | `"layered"` | `"lineage"` | +| Nodes lined up across layers | `"railway"` | `"ladder"` | ```{r bipartite, fig.width=9} graphr(ison_southern_women, layout = "bipartite") + ggtitle("Bipartite") -graphr(ison_southern_women, layout = "hierarchy") + ggtitle("Hierarchy") +graphr(ison_southern_women, layout = "layered") + ggtitle("Layered") graphr(ison_southern_women, layout = "railway") + ggtitle("Railway") ``` -Note that `"hierarchy"` and `"railway"` use a different algorithm to +Note that `"layered"` and `"railway"` use a different algorithm to `{igraph}`'s `"bipartite"`, and generally perform better, especially where there are multiple layers. -Whereas `"hierarchy"` tries to position nodes to minimise overlaps, +Whereas `"layered"` tries to position nodes to minimise overlaps, `"railway"` sequences the nodes in each layer to a grid so that nodes are matched as far as possible. -For the `"hierarchy"` layout you can also steer which set sits where by +For the `"layered"` layout you can also steer which set sits where by passing a `center` argument — `"events"` or `"actors"` for a two-mode network, or the name of a particular node — which helps when the default places the less interesting set on top. -```{r hierarchy-center, fig.width=9} -graphr(ison_southern_women, layout = "hierarchy", center = "events") +```{r layered-center, fig.width=9} +graphr(ison_southern_women, layout = "layered", center = "events") ``` If you want to flip the horizontal and vertical, -you could flip the coordinates, or use something like the following layout. +you could flip the coordinates, or use `"lineage"`, +which is the same layout with the axes exchanged. -```{r alluvial, fig.align='center'} -graphr(ison_southern_women, layout = "alluvial") + ggtitle("Alluvial") +```{r lineage, fig.align='center'} +graphr(ison_southern_women, layout = "lineage") + ggtitle("Lineage") +``` + +These layouts serve both multimodal and directed acyclic networks. +A genealogical network offers the clearest case: +every tie points from an earlier generation to a later one. +Where a force-directed layout obscures this ordering, +`graphr()` uses the `"layered"` layout to make it clear. +**Draw the parent ties among the characters of Westeros.** + +```{r thrones-default, fig.width=9, fig.height=6} +thrones <- to_uniplex(fict_thrones, "parent") +graphr(thrones) +``` + +This layout tries to minimise two costs. +The first is which layer each node goes in. Ranking each node +by its distance from a root sounds right — a row is then a generation — but it +pins a parent whose only child is born several generations later to the top +row, and manufactures a long tie to reach them. +The `ranks` argument chooses the rule, +and `check_span()` reports how many rows each tie crosses, +so you can measure the difference. + +```{r thrones-ranks} +thrones <- to_uniplex(fict_thrones, "parent") +spans <- sapply(c("generation", "compact", "tight"), function(r) { + span <- check_span(graphr(thrones, ranks = r)) + c(total = attr(span, "total"), `over one row` = mean(span > 1), max = max(span)) +}) +round(t(spans), 3) +``` + +`"generation"` is the distance-from-a-root rule and +`"compact"` is the one `{igraph}` uses in its Sugiyama layout. +`"tight"`, the default, minimises total tie length while +still pointing every tie down at least one row. +Note that the longest tie is the same under all three. + +The second cost is where each node sits within its row. +`check_offset()` reports how far each tie travels sideways, +as a share of the width of the drawing, +so a tie that drops straight down scores zero. +Again, you are wanting to minimise this, +and the `alignment` argument chooses the rule. +**Compare the two alignments.** + +```{r thrones-alignment} +thrones <- to_uniplex(fict_thrones, "parent") +c(straight = attr(check_offset(graphr(thrones)), "mean"), + rungs = attr(check_offset(graphr(thrones, alignment = "rungs")), "mean")) +``` + +`alignment = "rungs"` gives every row the same spacing, +which is what `"railway"` and `"ladder"` are for. +The default, `"straight"`, pulls each node towards its parents and children instead, +which is what makes the families read as families. + +`ranks` also accepts a node attribute, instead of one of those three rules. +Then the layers are that attribute's values, and nodes are placed along the +axis in proportion to them rather than at even steps, +so a network of dated nodes is drawn as a timeline. +**Rank the adolescents by a year of your choosing.** + +```{r lineage-ranks, fig.align='center'} +ison_adolescents |> as_stocnet() |> + mutate_nodes(year = rep(c(1985, 1990, 1995, 2000), times = 2), + label = paste0(label, " (", year, ")")) |> + graphr(layout = "lineage", ranks = "year") ``` Other layered layouts include: @@ -976,32 +1334,208 @@ Other such layouts include: Spectral layouts arrange nodes according to the eigenvalues of the Laplacian matrix of a graph. -These layouts tend to exaggerate the clustering of like-nodes and the -separation of less similar nodes in two-dimensional space. +These layouts exaggerate the clustering of similarly located nodes and +separate less similar nodes in two-dimensional space. ```{r eigen, fig.align='center'} graphr(ison_southern_women, layout = "eigen") + ggtitle("Eigenvector") ``` -Somewhat similar are multidimensional scaling (MDS) techniques, +#### Multidimensional scaling {#scaling} + +Of similar purpose are multidimensional scaling (MDS) techniques, which visualise the similarity between nodes in terms of their proximity in a two-dimensional (or more) space. +The `"scaling"` layout places the nodes so that the distance drawn between them +stands for the number of steps between them in the network. -```{r mds, fig.align='center'} -graphr(ison_southern_women, layout = "mds") + ggtitle("Multidimensional Scaling") +```{r scaling, fig.align='center'} +graphr(ison_southern_women, layout = "scaling") + ggtitle("Multidimensional Scaling") ``` -Other such layouts include: +Note that this layout is drawn with the axes labelled, +whereas you may have noticed that the other graphs are not. +That is because here the coordinates can be read: +two nodes drawn twice as far apart are, more or less, twice as far apart. +The axes are drawn on one scale for the same reason. +The layout scales the whole network where it is small enough for that, +using `"mds"` from `{igraph}`, +and otherwise approximates the scaling from a sample of the nodes +using `"pmds"` (or pivot MDS) from `{graphlayouts}`. +You can still call each of these directly, but since they are both used in `"scaling"`, +dispatch can be automatic, based on the size and structure of the network. + +"More or less" is doing some work in that sentence. +A network usually has more structure than two dimensions alone can hold, +so some of the distances drawn won't capture the real distances in the network. +In some cases, the dimensionality is so high that the drawing is misleading. +We can check how much disagreement there is between scaled distances and +the network distances as a *stress* score. +This is printed as a caption under the plot as a percentage of the network distances, +such that zero would represent a perfect drawing. + +How low is low? Kruskal ([1964](https://doi.org/10.1007/BF02289565)), +who introduced the score, recommends 20% as poor, 10% as fair, 5% as good, +and 2.5% as excellent. +Those figures were established for psychometric data though. +Networks typically contain a lot more structure, +which is hard to capture in just two dimensions, +so a 20% threshold is often too demanding. + +For networks, a score near 30% is quite common, +and means the clustering can be interpreted though perhaps the distances should not be interpreted as exact. +Above 40% and the plot does not really show any interpretable structure; +`graphr()` will alert you in the console where the score is above 30%. +By contrast, a stress score near 5% is rare and worth trusting. + +Note that this stress score is not only for this layout. +`check_stress()` measures any drawing the same way, +so layouts can be compared on the same network +(Brandes and Pich [2007](https://doi.org/10.1007/978-3-540-70904-6_6)): + +```{r checkstress, fig.align='center'} +sapply(c("scaling", "stress", "fr", "circle"), + function(x) check_stress(graphr(ison_southern_women, layout = x))) +``` -- Pivot multidimensional scaling: `"pmds"` +The default `"stress"` layout scores a little better here, +which is no accident: it minimises a related criterion directly. +What `"scaling"` adds is the axes and the score, +so that the distances can be read and the reading can be checked. + +In addition to stress, the scaling layout also reports +how much of the variance in the network's distances the two dimensions drawn hold. +The two numbers answer different questions, +and the comparison above shows how. +Stress belongs to the drawing: +draw this one network four ways and you get four different scores. +The variance explained belongs to the network: +it is the same 31% whichever of the four you draw, +because it asks how much of the structure two dimensions could hold at all. + +So read them together. +A low variance explained sets a floor that no layout gets under. +Where two dimensions can hold only a third of the structure, +no arrangement of the nodes will draw the distances faithfully, +and stress tells you how close to that floor this particular drawing gets. ::: {.callout} **Try it yourself**: This section includes an interactive quiz in the live tutorial — run `run_tute()` at the R console to try it. ::: -### Grid layouts {#grid-layouts} +#### Correspondence analysis {#correspondence} + +Whereas scaling lays out nodes by their distances from each other, +correspondence analysis (CA) lays them out by the similarity of their ties. +This is useful where nodes may not be tied to each other at all, +but can be tied to the same others, such as in a two-mode network. +Correspondence analysis takes a rectangular table --- +here the incidence matrix of the Southern Women dataset, +one row for each woman and one column for each event --- +and places its rows and its columns in one space. + +```{r correspondence, fig.align='center'} +graphr(ison_southern_women, layout = "correspondence") + ggtitle("Correspondence Analysis") +``` + +We can see the similarity to the eigenvector layout above, +but the axes are labelled with the share of the network's `r gloss("inertia")` they hold. +Inertia is the CA analogue of variance in PCA. +It measures the total dispersion of points (rows and columns) in the cloud around the centroid, +computed as the chi-square statistic of the table divided by the total sample size (N). +In other words, inertia tell us how far the ties depart from what one would expect +if every woman attended events in the same proportion as every other. +A network whose nodes all had much the same ties would have almost none. + +Each dimension extracted captures a share of this total inertia. +Because it is a share of variance explained, +and not a measure of fit like regression's R-squared, +the scores depend on the number of dimensions. +`ison_southern_women` has 12 dimensions, +and a total inertia of `r round(attr(layout_correspondence(ison_southern_women), "fit")$total, 2)`. +The top two dimensions (in terms of variance explained) together account for 57% of this total inertia. + +Is this good? I.e. is this a presentation of the data that is worth interpreting? +Well, if the inertia were spread evenly across these 12 dimensions, +(any) 2 dimensions would jointly account for about 17% of the variance. +57% is about 3.4 times better than this. +But this flatters because inertia is never spread evenly (Jackson [1993](https://doi.org/10.2307/1939574)). +The *broken stick* model offers a more demanding baseline, +asking what two dimensions would hold if the inertia were divided randomly rather than evenly (here 1.3 times better): + +```{r inertiacompare, fig.align='center'} +bstick <- function(K) sum(sapply(1:2, function(k) mean(1 / (k:K)))) +sapply(c("ison_southern_women", "ison_adolescents", "ison_networkers"), + function(x) { + fit <- attr(layout_correspondence(get(x)), "fit") + K <- length(fit$scree) + c(dimensions = K, + inertia_drawn = round(sum(fit$inertia), 2), + vs_even = round(sum(fit$inertia) / (2 / K), 1), + vs_random = round(sum(fit$inertia) / bstick(K), 1)) + }) +``` + +`ison_adolescents` looks the best summarised by two dimensions of three datasets considered at 60%. +However, it is a small network with only seven dimensions to spread across, +so two of them were always going to hold a good deal. +Against the harder baseline it scores below 1, +which is to say two dimensions hold *less* than dividing the inertia +at random would have given them. +By comparison, `ison_networkers` looks the worst at 36% and yet summarises best: +it has 31 dimensions, and the top two beat either baseline. +Note that these scores are not verdicts, +but help gauge whether the two dimensions presented are worth interpreting further. +`graphr()` applies the stricter of the two baselines for you, +noting at the console where two dimensions hold no more inertia +than a random division would have given them. + +Since the two dimensions have different percentages here, +we can see where we should put the emphasis of our interpretation. +Because the first dimension holds twice as much, +it suggests that what distinguishes nodes most runs along the x-axis rather than the y-axis. + +Two more things to note about correspondence analysis. +First, while the distances among nodes of the same mode are interpretable, +distances between nodes from different modes are not necessarily interpretable. +That is, a woman drawn near an event is **not** necessarily an attendee of it. +Only the distances *within* a mode can be read this way: +two women drawn together attended similar events, +and two events drawn together were attended by similar women. +These plots are often misread this way. + +Second, some nodes are better represented by the top two dimensions than others. +A plot can hold most of the network's inertia +and still put one particular node nowhere near where it belongs. +This representation is captured by a measure called `r gloss("cos2")`: +how much of its position the two dimensions drawn actually hold, from 0 to 1, +where lower is worse. +A node the plane captures badly may be located near the centre of the plot, +not because it is average, but because there is nowhere else to put it. +`graphr()` names these nodes in the console when it draws the layout, +but you can recover the scores like so: + +```{r cos2, fig.align='center'} +fit <- attr(layout_correspondence(ison_southern_women), "fit") +round(sort(fit$cos2), 2) +``` + +For a directed network, each node has two profiles: +who it sends ties to, and who it receives them from. +By default the layout reads a tie in either direction, +so that each node has one position; +`direction = "out"` and `direction = "in"` read one profile or the other. +For a signed network there is no correspondence analysis at all, +since the method divides by the mass of each node +and a negative tie has no such reading. +`double = TRUE` splits each tie into a positive and a negative part, +so that a node is placed by both who it likes and who it dislikes. + +::: {.callout} +**Try it yourself**: This section includes an interactive quiz in the live tutorial — run `run_tute()` at the R console to try it. +::: -gif of a cartoon character energetically rearranging the living room furniture +### Grid layouts {#grid-layouts} Grid layouts arrange nodes based on some Cartesian coordinates. These can be useful for making sure all nodes' labels are visible, @@ -1028,6 +1562,10 @@ snapped version.** graphr(fict_lotr, snap = TRUE) + ggtitle("stress + snap")) ``` +::: {.callout} +**Try it yourself**: This section includes an interactive quiz in the live tutorial — run `run_tute()` at the R console to try it. +::: + ### Manual layouts {#manual-layouts} Whatever their differences, all these layout algorithms do the same job: @@ -1057,24 +1595,26 @@ useful when readers need to compare them. ::: {.callout} **Going further**: `{autograph}` also provides its own special-purpose layouts — -`"configuration"`, `"lineage"`, `"multilevel"`, `"triad"`/`"quad"`, -and layouts that align nodes by partition — -documented at `?layout_partition` and friends. +`"configuration"`, `"correspondence"`, `"levels"`, `"matching"`, +`"scaling"`, `"valence"`, +and the layered family — +documented at `?layout_layered` and friends. Several layouts take a layout-specific extra argument (passed through `...`) to control how nodes are ordered: `"concentric"` a `membership`, -`"multilevel"` a `level`, and `"lineage"` a `rank` — each a node attribute +`"levels"` a `level`, and the layered layouts `ranks` — each a node attribute name or a vector. See `?graphr` for the full list. ::: ::: {.callout} **In brief**: Pass `layout =` to `graphr()` to choose among force-directed (`"stress"`, `"fr"`, `"kk"`), -layered (`"hierarchy"`, `"railway"`, `"alluvial"`), +layered (`"layered"`, `"railway"`, `"lineage"`), circular (`"concentric"`, `"circle"`), -spectral (`"eigen"`, `"mds"`), +spectral (`"eigen"`, `"scaling"`, `"correspondence"`), and grid layouts. Force-directed layouts are illustrative — do not over-interpret distances; -spectral/MDS layouts place nodes by measured similarity; +spectral/MDS layouts place nodes by measured similarity, +and `"scaling"` captions the plot with how far that reading can be trusted; layered layouts suit two-mode or hierarchical data. And since every layout is just a table of coordinates, you can always compute one with `ggraph::create_layout()`, @@ -1137,8 +1677,6 @@ every node, so in that case isolates are kept in place. ### Dynamics {#dynamics} -gif of a hand flipping through a flipbook of animated stick figures - `grapht()` is another alternative to `graphr()`, this time rendering network changes over time as an animated gif. Longitudinal networks (with discrete waves) @@ -1167,6 +1705,10 @@ will split it without being told which attribute to use. From `{manynet}` 2.2.2, any other name (say, `year`) works just as well — it only needs declaring via `to_waves()`'s `attribute` argument. +::: {.callout} +**Try it yourself**: This section includes an interactive quiz in the live tutorial — run `run_tute()` at the R console to try it. +::: + ::: {.callout} **Going further**: Animation constrains a few things that a static graph allows. @@ -1178,7 +1720,8 @@ And because they do not translate cleanly from frame to frame, and self-loops are not drawn in animations. Labels, too, are placed at a fixed offset rather than repelled, and are hidden by default once a network has more than 30 nodes -(pass `labels = TRUE` to force them). +(pass `labels = TRUE` to force them, or select a few as in `graphr()`, +which is resolved once so the same nodes stay named in every frame). ::: ::: {.callout} @@ -1190,8 +1733,6 @@ and animate longitudinal or dynamic networks with `grapht()`. ## Going further with ggraph -gif of Mr Bean taking the restoration of a painting into his own hands - For more flexibility with visualisations, `{autograph}` users are encouraged to use the excellent `{ggraph}` package. `{ggraph}` is built upon the venerable `{ggplot2}` package @@ -1261,6 +1802,10 @@ and padding between the arrowhead and the node can also be specified. For more see David Schoch's [excellent resources on this](http://mr.schochastics.net/netVizR.html). +::: {.callout} +**Try it yourself**: This section includes an interactive quiz in the live tutorial — run `run_tute()` at the R console to try it. +::: + ::: {.callout} **In brief**: Because `graphr()` returns a ggplot object, you can go a long way just appending `{ggplot2}`/`{ggraph}` layers to it. @@ -1309,8 +1854,6 @@ of the packages that produce those results. ## Exporting plots -gif of a maker declaring that the masterpiece is done and it is time to show the world - We can save the plots we have made by point-and-click by selecting 'Save as PDF...' from under the 'Export' dropdown menu in the plots panel tab of RStudio. @@ -1340,9 +1883,11 @@ Animations made with `grapht()` are saved slightly differently: use `gganimate::anim_save("my_animation.gif")`, which works just like `ggsave()` but for the last animation rendered. -## Summary +::: {.callout} +**Try it yourself**: This section includes an interactive quiz in the live tutorial — run `run_tute()` at the R console to try it. +::: -gif of an enthusiastic standing ovation and cries of bravo +## Summary Well done — you have completed the tutorial on visualising networks! Along the way, you have learned to use these functions: @@ -1352,11 +1897,11 @@ Along the way, you have learned to use these functions: | `graphr()` | graphs any manynet-compatible network with sensible defaults | | `graphr(..., node_colour/node_shape/node_size/node_group)` | maps node attributes to aesthetics | | `graphr(..., edge_colour/edge_size)` | maps tie attributes to aesthetics | -| `graphr(..., labels, label_repel, label_dist)` | controls node labelling | +| `graphr(..., labels, label_repel, label_dist)` | chooses which nodes to label, and places the labels | | `graphr(..., layout, snap)` | chooses and adjusts the layout algorithm | | `graphr(..., x, y)` | places nodes at manually supplied coordinates | | `ggraph::create_layout()` | returns a layout's table of node coordinates for tweaking | -| `graphr(..., edge_bundle, isolates)` | tames large, dense, or disconnected networks | +| `graphr(..., edge_bundle, backbone, isolates)` | tames large, dense, or disconnected networks | | `stocnet_theme()` | sets a consistent theme for all graphs and plots | | `ggplot2::scale_fill_hue()`, `_grey()`, `_manual()` | overrides node colour palettes | | `labs()`, `ggtitle()`, `guides()` | adds titles, axis and legend labels | @@ -1365,6 +1910,10 @@ Along the way, you have learned to use these functions: | `plot()` | plots measures, motifs, and model results consistently | | `ggsave()` | exports the last plot at publication quality | +::: {.callout} +**Try it yourself**: This section includes an interactive quiz in the live tutorial — run `run_tute()` at the R console to try it. +::: + When you are ready, continue with the tutorials in the other `{stocnet}` packages — on network structure and centrality in `{netrics}`, and on diffusion and regression in `{migraph}` —