---
title: "Seriation"
author: "N. Frerebeau"
date: "`r Sys.Date()`"
output:
  rmarkdown::html_vignette:
    number_sections: yes
    fig_caption: yes
    toc: true
header-includes:
   - \usepackage{amsmath}
   - \usepackage{amssymb}
bibliography: bibliography.bib
vignette: >
  %\VignetteIndexEntry{Seriation}
  %\VignetteEncoding{UTF-8}
  %\VignetteEngine{knitr::rmarkdown}
editor_options: 
  chunk_output_type: console
---

```{r setup, include = FALSE, echo=FALSE}
knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>"
)
```

```{r packages}
# Load packages
library(tabula)
library(magrittr)
```

# Introduction

The matrix seriation problem in archaeology is based on three conditions and two assumptions, which @dunnell1970 summarizes as follows.

The homogeneity conditions state that all the groups included in a seriation must:

* Be of comparable duration,
* Belong to the same cultural tradition,
* Come from the same local area.

The mathematical assumptions state that the distribution of any historical or temporal class:

* Is continuous through time,
* Exhibits the form of a unimodal curve.

Theses assumptions create a distributional model and ordering is accomplished by arranging the matrix so that the class distributions approximate the required pattern. The resulting order is *inferred* to be chronological.

# Visualization

Several types of graphs are available in **tabula** which uses **ggplot2** for plotting informations. This makes it easy to customize diagrams (e.g. using themes and scales).

## Spot plot
Spot matrix allows direct examination of data (above/below some threshold):

```{r plot-freq, fig.cap="Spot plot", fig.width=4, fig.height=6, fig.align="center"}
## Plot frequencies with the column means as a threshold
mississippi %>%
  as_count() %>%
  plot_spot(threshold = mean) +
  ggplot2::labs(size = "Frequency", colour = "Mean") +
  khroma::scale_colour_vibrant()
```

```{r plot-occ, fig.cap="Spot plot of co-occurrence", fig.width=6, fig.height=4, fig.align="center"}
## Plot co-occurrence of types
## (i.e. how many times (percent) each pairs of taxa occur together 
## in at least one sample.)
mississippi %>%
  as_occurrence() %>%
  plot_spot() +
  ggplot2::labs(size = "", colour = "Co-occurrence") +
  ggplot2::theme(legend.box = "horizontal") +
  khroma::scale_colour_YlOrBr()
```

## Heatmap

Abundance matrix can be displayed as a heatmap of relative abundances (frequency), or as percentages of the independence value (in french, "pourcentages de valeur d'indépendance", PVI).

```{r plot-matrix, fig.cap="Heatmap", fig.width=7, fig.height=3.5, fig.align="center"}
boves %>%
  as_count() %>%
  plot_heatmap() +
  khroma::scale_fill_YlOrBr()
```


PVI is calculated for each cell as the percentage to the column theoretical independence value: PVI greater than $1$ represent positive deviations from the independence, whereas PVI smaller than $1$ represent negative deviations [@desachy2004]. The PVI matrix allows to explore deviations from independence (an intuitive graphical approach to $\chi^2$), in such a way that a high-contrast matrix has quite significant deviations, with a low risk of being due to randomness [@desachy2004].

```{r plot-matrigraphe, fig.cap="Matrigraphe", fig.width=7, fig.height=3.5, fig.align="center"}
## Reproduce B. Desachy's matrigraphe
boves %>%
  as_count() %>%
  plot_heatmap(PVI = TRUE) +
  khroma::scale_fill_BuRd(midpoint = 1)
```

## Bar plot
@bertin1977 or @ford1962 (battleship curve) diagrams can also be plotted, with statistic threshold.

```{r plot-bertin, fig.cap="Bertin diagram", fig.width=7, fig.height=7, fig.align="center"}
mississippi %>%
  as_count() %>%
  plot_bertin(threshold = mean) +
  khroma::scale_fill_bright()
```

```{r plot-ford, fig.cap="Ford diagram", fig.width=7, fig.height=3.5, fig.align="center"}
boves %>%
  as_count() %>%
  plot_ford(EPPM = TRUE) +
  khroma::scale_fill_contrast()
```

# Reciprocal ranking

Reciprocal ranking iteratively rearrange rows and/or columns according to their weighted rank in the data matrix until convergence [@ihm2005].

For a given incidence matrix $C$:

* The rows of $C$ are rearranged in increasing order of:

$$ x_{i} = \sum_{j = 1}^{p} j \frac{c_{ij}}{c_{i \cdot}} $$

* The columns of $C$ are rearranged in a similar way:

$$ y_{j} = \sum_{i = 1}^{m} i \frac{c_{ij}}{c_{\cdot j}} $$

These two steps are repeated until convergence.
Note that this procedure could enter into an infinite loop.

```{r ranking, fig.show='hold'}
## Build an incidence matrix with random data
set.seed(12345)
incidence1 <- IncidenceMatrix(data = sample(0:1, 400, TRUE, c(0.6, 0.4)),
                              nrow = 20)

## Get seriation order on rows and columns
## If no convergence is reached before the maximum number of iterations (100), 
## it stops with a warning.
(indices <- seriate_reciprocal(incidence1, margin = c(1, 2), stop = 100))

## Permute matrix rows and columns
incidence2 <- permute(incidence1, indices)

## Plot matrix
plot_heatmap(incidence1) + 
  ggplot2::labs(title = "Original matrix") +
  ggplot2::scale_fill_manual(values = c("TRUE" = "black", "FALSE" = "white"))
plot_heatmap(incidence2) + 
  ggplot2::labs(title = "Rearranged matrix") +
  ggplot2::scale_fill_manual(values = c("TRUE" = "black", "FALSE" = "white"))
```

The positive difference from the column mean percentage (in french "écart positif au pourcentage moyen", EPPM) represents a deviation from the situation of statistical independence [@desachy2004]. As independence can be interpreted as the absence of relationships between types and the chronological order of the assemblages, EPPM is a useful graphical tool to explore significance of relationship between rows and columns related to seriation [@desachy2004].

```{r averaging, fig.width=7, fig.height=3.5, fig.show='hold'}
## Replicates Desachy 2004 results

## Coerce dataset to an abundance matrix
compiegne_counts <- as_count(compiegne)

## Plot original data matrix
plot_ford(compiegne_counts, EPPM = TRUE) +
  ggplot2::labs(title = "Original dataset") +
  khroma::scale_fill_bright()

## Get seriation order for columns on EPPM using the reciprocal averaging method
## Expected column order: N, A, C, K, P, L, B, E, I, M, D, G, O, J, F, H
compiegne_indices <- seriate_reciprocal(compiegne_counts, EPPM = TRUE, margin = 2)

## Permute columns
compiegne_seriation <- permute(compiegne_counts, compiegne_indices)

## Plot new matrix
plot_ford(compiegne_seriation, EPPM = TRUE) +
  ggplot2::labs(title = "Reordered dataset") +
  khroma::scale_fill_bright()
```

# correspondence analysis
## Seriation

correspondence Analysis (CA) is an effective method for the seriation of archaeological assemblages. The order of the rows and columns is given by the coordinates along one dimension of the CA space, assumed to account for temporal variation. The direction of temporal change within the correspondence analysis space is arbitrary: additional information is needed to determine the actual order in time.

```{r ca}
## Coerce dataset to an abundance matrix
zuni_counts <- as_count(zuni)

## correspondence analysis of the whole dataset
corresp <- ca::ca(zuni_counts)
coords <- ca::cacoord(corresp, type = "principal")

## Plot CA results
ggplot2::ggplot(mapping = ggplot2::aes(x = Dim1, y = Dim2)) +
  ggplot2::geom_vline(xintercept = 0, linetype = 2) +
  ggplot2::geom_hline(yintercept = 0, linetype = 2) +
  ggplot2::geom_point(data = as.data.frame(coords$rows), color = "black") +
  ggplot2::geom_point(data = as.data.frame(coords$columns), color = "red") +
  ggplot2::coord_fixed() + 
  ggplot2::theme_bw()
```

```{r ca-seriation, fig.width=7, fig.height=7}
## Get row permutations from CA coordinates
zuni_indices <- zuni_counts %>%
  seriate_correspondence(margin = 1)

## Permute data matrix
zuni_seriation <- permute(zuni_counts, zuni_indices)

## Plot Ford diagram
## Warning: this may take a few seconds!
plot_ford(zuni_seriation) +
  ggplot2::theme(axis.text = ggplot2::element_blank(),
                 axis.ticks = ggplot2::element_blank())
```

## Refining

@peeples2012 propose a procedure to identify samples that are subject to sampling error or samples that have underlying structural relationships and might be influencing the ordering along the CA space. This relies on a partial bootstrap approach to CA-based seriation where each sample is replicated `n` times. The maximum dimension length of the convex hull around the sample point cloud allows to remove samples for a given `cutoff` value.

According to @peeples2012, "[this] point removal procedure [results in] a reduced dataset where the position of individuals within the CA are highly stable and which produces an ordering consistend with the assumptions of frequency seriation."

```{r refine, fig.show='hold'}
## Replicates Peeples and Schachner 2012 results

## Samples with convex hull maximum dimension length greater than the cutoff
## value will be marked for removal.
## Define cutoff as one standard deviation above the mean
fun <- function(x) { mean(x) + sd(x) }

## Get indices of samples to be kept
## Warning: this may take a few seconds!
set.seed(123)
(zuni_keep <- refine_seriation(zuni_counts, cutoff = fun, n = 1000))

## Plot convex hull
## blue: convex hull for samples; red: convex hull for types
### All bootstrap samples
ggplot2::ggplot(mapping = ggplot2::aes(x = x, y = y, group = id)) +
  ggplot2::geom_vline(xintercept = 0, linetype = 2) +
  ggplot2::geom_hline(yintercept = 0, linetype = 2) +
  ggplot2::geom_polygon(data = zuni_keep[["rows"]], 
                        fill = "blue", alpha = 0.05) +
  ggplot2::geom_polygon(data = zuni_keep[["columns"]], 
                        fill = "red", alpha = 0.5) +
  ggplot2::coord_fixed() + 
  ggplot2::labs(title = "Whole dataset", x = "Dim. 1", y = "Dim. 2") + 
  ggplot2::theme_bw()
### Only retained samples
ggplot2::ggplot(mapping = ggplot2::aes(x = x, y = y, group = id)) +
  ggplot2::geom_vline(xintercept = 0, linetype = 2) +
  ggplot2::geom_hline(yintercept = 0, linetype = 2) +
  ggplot2::geom_polygon(data = subset(zuni_keep[["rows"]], 
                                      id %in% names(zuni_keep[["keep"]][[1]])),
                        fill = "blue", alpha = 0.05) +
  ggplot2::geom_polygon(data = zuni_keep[["columns"]], 
                        fill = "red", alpha = 0.5) +
  ggplot2::coord_fixed() + 
  ggplot2::labs(title = "Selected samples", x = "Dim. 1", y = "Dim. 2") + 
  ggplot2::theme_bw()

## Histogram of convex hull maximum dimension length
hull_length <- cbind.data.frame(length = zuni_keep[["lengths"]][[1]])
ggplot2::ggplot(data = hull_length, mapping = ggplot2::aes(x = length)) +
  ggplot2::geom_histogram(breaks = seq(0, 4.5, by = 0.5), fill = "grey70") +
  ggplot2::geom_vline(xintercept = fun(hull_length$length), colour = "red") +
  ggplot2::labs(title = "Convex hull max. dim.", 
                x = "Maximum length", y = "Count") + 
  ggplot2::theme_bw()
```

If the results of `refine_seriation` is used as an input argument in `seriate`, a correspondence analysis is performed on the subset of `object` which matches the samples to be kept. Then excluded samples are projected onto the dimensions of the CA coordinate space using the row transition formulae. Finally, row coordinates onto the first dimension give the seriation order.

```{r refine-ca}
## Get CA-based seriation order
(zuni_refined <- seriate_correspondence(zuni_counts, zuni_keep, margin = 1))
```

# References
