Here are a couple of examples from DDAR, trying to use the seriation package for reordering rows and columns of frequency tables to make mosaic displays more coherent.

The idea is pretty simple, but I’m looking for some technique that can be used semi-automatically to permute rows/cols by CA dimensions in the vcd package or vcdExtra

This document tests some recent additions to seriation in Version 1.3.6.9000, installed using

 install.packages("seriation", repos = "https://mhahsler.r-universe.dev")

Packages

library(seriation)
library(vcd)
library(vcdExtra)
library(ca)

Hair color, eye color data

Only use hair color and eye color here

data("HairEyeColor")
haireye <- margin.table(HairEyeColor, 1:2)

Mosaic of the original table

The order of the eye colors doesn’t permit an understanding of an overall pattern of association.

mosaic(haireye, shade=TRUE, legend=FALSE)

Show correspondence analysis

It’s clear that both variables are ordered on Dim 1, and the nature of association is that light eyes are associated with light hair and vice versa.

haireye.ca <- ca(haireye)
plot(haireye.ca, lines = TRUE)

Try to use seriation for this.

The goal here is to find a **simple* interface to seriation that could be used in the vcd or vcdExtra package to make it easier to permute the table being plotted by mosaic().

seriate() finds an order based on the CA dim=1, which is fine here, and usually enough.

(NB: in other cases, we might want to seriate along CA dim=2, but I don’t know how to do this. There is some buried option, also used in the seriate PCA method to use the 2nd dimension.

order <- seriate(haireye, method = "CA")

Actual permutation is done by permute(). But sadly, permute() only allows one margin :( Would be easier if I could use margin = 1:2.

permute(haireye, order, margin=1)
       Eye
Hair    Brown Blue Hazel Green
  Black    68   20    15     5
  Brown   119   84    54    29
  Red      26   17    14    14
  Blond     7   94    10    16
permute(haireye, order, margin=2)
       Eye
Hair    Brown Hazel Green Blue
  Black    68    15     5   20
  Brown   119    54    29   84
  Red      26    14    14   17
  Blond     7    10    16   94

To do both, without looking at the plot, need to extract the orders for the two margins, confusingly also called dim=.

o1 <- get_order(order, dim=1)
o2 <- get_order(order, dim=2)
haireye[o1, o2]
       Eye
Hair    Brown Hazel Green Blue
  Black    68    15     5   20
  Brown   119    54    29   84
  Red      26    14    14   17
  Blond     7    10    16   94

Mosaic of the permuted table

The trick that works is to index the table by [o1, o2] The difference here is subtle; it was only the eye colors that needed to be permuted.

mosaic(haireye[o1, o2], shade=TRUE, legend=FALSE)

Mental impairment data

Maybe a better test case for this. Take something simple, make it more complicated, see whether/how seriate can help.

data(Mental, package = "vcdExtra")
str(Mental)
'data.frame':   24 obs. of  3 variables:
 $ ses   : Ord.factor w/ 6 levels "1"<"2"<"3"<"4"<..: 1 1 1 1 2 2 2 2 3 3 ...
 $ mental: Ord.factor w/ 4 levels "Well"<"Mild"<..: 1 2 3 4 1 2 3 4 1 2 ...
 $ Freq  : int  64 94 58 46 57 94 54 40 57 105 ...

mental and ses were created as ordered factors. For this example, unorder them: mental: alphabetically; ses: random permutation

set.seed(1234)
Mental$mental <- factor(Mental$mental, levels = sort(levels(Mental$mental)))
Mental$ses    <- factor(Mental$ses, levels = sample(levels(Mental$ses)))

mental.tab <- xtabs(Freq ~ ses + mental, data=Mental)

Initial mosaic

mosaic(mental.tab, shade=TRUE, legend=FALSE)

CA

ca() uncovers the true ordering

mental.ca <- ca(mental.tab)
plot(mental.ca, lines = TRUE)

Use seriate to get this

order <- seriate(mental.tab, method = "CA")
o1 <- get_order(order, dim=1)
o2 <- get_order(order, dim=2)

Mosaic of permuted table

mosaic(mental.tab[o1, o2], shade=TRUE, legend = FALSE)

Using the latest version of permute

Michael Hahsler updated permute() to allow specifying margin=1:2 to permute both dimensions in a single call. See: https://github.com/mhahsler/seriation/issues/17#issuecomment-1280091881

hec_perm <- permute(haireye, "CA", margin = 1:2)
mosaic(hec_perm, shade=TRUE, legend=FALSE)

mental.tab <- permute(mental.tab, "CA")          # margin=1:2 is the default
mosaic(mental.tab, shade=TRUE, legend = FALSE)

Summary

seriation::seriate() has the infrastructure for a wide range of seriation tasks, but initially seemed overly complex for the application to frequency tables using CA with a goal of incorporating in vcd:mosaic().

The latest version, with the change to permute() is now something that can be easily used.

Some questions:

IycgLS0tDQojJyB0aXRsZTogVGVzdCBvcmRlcmluZyBvZiBmcmVxdWVuY3kgdGFibGVzIHVzaW5nIHNlcmlhdGlvbiBwYWNrYWdlDQojJyBhdXRob3I6IE1pY2hhZWwgRnJpZW5kbHkNCiMnIGRhdGU6ICJgciBmb3JtYXQoU3lzLkRhdGUoKSlgIg0KIycgb3V0cHV0Og0KIycgICBodG1sX2RvY3VtZW50Og0KIycgICAgIHRoZW1lOiByZWFkYWJsZQ0KIycgICAgIGNvZGVfZG93bmxvYWQ6IHRydWUNCiMnIC0tLQ0KIycgDQojJyBIZXJlIGFyZSBhIGNvdXBsZSBvZiBleGFtcGxlcyBmcm9tIFtEREFSXShodHRwOi8vZGRhci5kYXRhdmlzLmNhL3BhZ2VzL2hvbWUpLCB0cnlpbmcgdG8gdXNlIHRoZSBbc2VyaWF0aW9uIHBhY2thZ2VdKGh0dHBzOi8vY3Jhbi5yLXByb2plY3Qub3JnL3BhY2thZ2U9c2VyaWF0aW9uKSBmb3IgcmVvcmRlcmluZyByb3dzIGFuZCBjb2x1bW5zDQojJyBvZiBmcmVxdWVuY3kgdGFibGVzIHRvIG1ha2UgbW9zYWljIGRpc3BsYXlzIG1vcmUgY29oZXJlbnQuIA0KIycgDQojJyBUaGUgaWRlYSBpcyBwcmV0dHkgc2ltcGxlLCBidXQgSSdtDQojJyBsb29raW5nIGZvciBzb21lIHRlY2huaXF1ZSB0aGF0IGNhbiBiZSB1c2VkIHNlbWktYXV0b21hdGljYWxseSB0byBwZXJtdXRlIHJvd3MvY29scyBieSBDQSBkaW1lbnNpb25zDQojJyBpbiB0aGUgW3ZjZCBwYWNrYWdlXShodHRwczovL2NyYW4uci1wcm9qZWN0Lm9yZy9wYWNrYWdlPXZjZCkgb3IgW3ZjZEV4dHJhXShodHRwczovL2NyYW4uci1wcm9qZWN0Lm9yZy9wYWNrYWdlPXZjZEV4dHJhKQ0KIycgDQojJyBUaGlzIGRvY3VtZW50IHRlc3RzIHNvbWUgcmVjZW50IGFkZGl0aW9ucyB0byBgc2VyaWF0aW9uYCBpbiBWZXJzaW9uIGByIHBhY2thZ2VWZXJzaW9uKCJzZXJpYXRpb24iKWAsDQojJyBpbnN0YWxsZWQgdXNpbmcgDQojJyANCiMnICAgICAgaW5zdGFsbC5wYWNrYWdlcygic2VyaWF0aW9uIiwgcmVwb3MgPSAiaHR0cHM6Ly9taGFoc2xlci5yLXVuaXZlcnNlLmRldiIpDQojJyANCg0KIysgc2V0dXAsIGluY2x1ZGU9RkFMU0UNCmtuaXRyOjpvcHRzX2NodW5rJHNldChtZXNzYWdlPUZBTFNFLCBlcnJvcj1UUlVFLCB3YXJuaW5nPUZBTFNFLCBjb21tZW50PU5BKQ0Kb3B0aW9ucyh3aWR0aD0xMDApDQoNCiMnIFBhY2thZ2VzDQpsaWJyYXJ5KHNlcmlhdGlvbikNCmxpYnJhcnkodmNkKQ0KbGlicmFyeSh2Y2RFeHRyYSkNCmxpYnJhcnkoY2EpDQoNCiMnICMjIEhhaXIgY29sb3IsIGV5ZSBjb2xvciBkYXRhDQojJyBPbmx5IHVzZSBoYWlyIGNvbG9yIGFuZCBleWUgY29sb3IgaGVyZQ0KZGF0YSgiSGFpckV5ZUNvbG9yIikNCmhhaXJleWUgPC0gbWFyZ2luLnRhYmxlKEhhaXJFeWVDb2xvciwgMToyKQ0KDQojJyAjIyMgTW9zYWljIG9mIHRoZSBvcmlnaW5hbCB0YWJsZQ0KIycgVGhlIG9yZGVyIG9mIHRoZSBleWUgY29sb3JzIGRvZXNuJ3QgcGVybWl0IGFuIHVuZGVyc3RhbmRpbmcgb2YgYW4gb3ZlcmFsbCBwYXR0ZXJuIG9mIGFzc29jaWF0aW9uLg0KbW9zYWljKGhhaXJleWUsIHNoYWRlPVRSVUUsIGxlZ2VuZD1GQUxTRSkNCg0KIycgIyMjIFNob3cgY29ycmVzcG9uZGVuY2UgYW5hbHlzaXMNCiMnIEl0J3MgY2xlYXIgdGhhdCBib3RoIHZhcmlhYmxlcyBhcmUgb3JkZXJlZCBvbiBEaW0gMSwgKiphbmQqKiB0aGUgbmF0dXJlIG9mIGFzc29jaWF0aW9uIGlzIHRoYXQNCiMnIGxpZ2h0IGV5ZXMgYXJlIGFzc29jaWF0ZWQgd2l0aCBsaWdodCBoYWlyIGFuZCB2aWNlIHZlcnNhLg0KaGFpcmV5ZS5jYSA8LSBjYShoYWlyZXllKQ0KcGxvdChoYWlyZXllLmNhLCBsaW5lcyA9IFRSVUUpDQoNCiMnICMjIyBUcnkgdG8gdXNlIHNlcmlhdGlvbiBmb3IgdGhpcy4NCiMnIFRoZSBnb2FsIGhlcmUgaXMgdG8gZmluZCBhICoqc2ltcGxlKiBpbnRlcmZhY2UgdG8gYHNlcmlhdGlvbmAgdGhhdCBjb3VsZCBiZSB1c2VkIGluIHRoZSBgdmNkYCBvciBgdmNkRXh0cmFgDQojJyBwYWNrYWdlIHRvIG1ha2UgaXQgZWFzaWVyIHRvIHBlcm11dGUgdGhlIHRhYmxlIGJlaW5nIHBsb3R0ZWQgYnkgYG1vc2FpYygpYC4NCiMnIA0KIycgYHNlcmlhdGUoKWAgZmluZHMgYW4gb3JkZXIgYmFzZWQgb24gdGhlIENBIGRpbT0xLCB3aGljaCBpcyBmaW5lIGhlcmUsIGFuZCB1c3VhbGx5IGVub3VnaC4NCiMnIA0KIycgIChOQjogaW4gb3RoZXIgY2FzZXMsIHdlIG1pZ2h0IHdhbnQgdG8gc2VyaWF0ZSBhbG9uZyBDQSBgZGltPTJgLCBidXQgSSBkb24ndCBrbm93IGhvdyB0byBkbyB0aGlzLg0KIycgIFRoZXJlIGlzIHNvbWUgYnVyaWVkIG9wdGlvbiwgYWxzbyB1c2VkIGluIHRoZSBzZXJpYXRlIGBQQ0FgIG1ldGhvZCB0byB1c2UgdGhlIDJuZCBkaW1lbnNpb24uDQpvcmRlciA8LSBzZXJpYXRlKGhhaXJleWUsIG1ldGhvZCA9ICJDQSIpDQoNCiMnIEFjdHVhbCBwZXJtdXRhdGlvbiBpcyBkb25lIGJ5IGBwZXJtdXRlKClgLg0KIycgQnV0IHNhZGx5LCBgcGVybXV0ZSgpYCBvbmx5IGFsbG93cyBvbmUgbWFyZ2luIDooDQojJyBXb3VsZCBiZSBlYXNpZXIgaWYgIEkgY291bGQgdXNlIGBtYXJnaW4gPSAxOjJgLg0KcGVybXV0ZShoYWlyZXllLCBvcmRlciwgbWFyZ2luPTEpDQpwZXJtdXRlKGhhaXJleWUsIG9yZGVyLCBtYXJnaW49MikNCg0KIycgVG8gZG8gYm90aCwgd2l0aG91dCBsb29raW5nIGF0IHRoZSBwbG90LCBuZWVkIHRvIGV4dHJhY3QgdGhlIG9yZGVycyBmb3IgdGhlIHR3byBtYXJnaW5zLCBjb25mdXNpbmdseQ0KIycgYWxzbyBjYWxsZWQgYGRpbT1gLiANCm8xIDwtIGdldF9vcmRlcihvcmRlciwgZGltPTEpDQpvMiA8LSBnZXRfb3JkZXIob3JkZXIsIGRpbT0yKQ0KaGFpcmV5ZVtvMSwgbzJdDQoNCiMnICMjIyBNb3NhaWMgb2YgdGhlIHBlcm11dGVkIHRhYmxlDQojJyBUaGUgdHJpY2sgdGhhdCB3b3JrcyBpcyB0byBpbmRleCB0aGUgdGFibGUgYnkgYFtvMSwgbzJdYA0KIycgVGhlIGRpZmZlcmVuY2UgaGVyZSBpcyBzdWJ0bGU7IGl0IHdhcyBvbmx5IHRoZSBleWUgY29sb3JzIHRoYXQgbmVlZGVkIHRvIGJlIHBlcm11dGVkLiANCm1vc2FpYyhoYWlyZXllW28xLCBvMl0sIHNoYWRlPVRSVUUsIGxlZ2VuZD1GQUxTRSkNCg0KDQojJyAjIyBNZW50YWwgaW1wYWlybWVudCBkYXRhDQojJyBNYXliZSBhIGJldHRlciB0ZXN0IGNhc2UgZm9yIHRoaXMuIFRha2Ugc29tZXRoaW5nIHNpbXBsZSwgbWFrZSBpdCBtb3JlIGNvbXBsaWNhdGVkLCBzZWUNCiMnIHdoZXRoZXIvaG93IGBzZXJpYXRlYCBjYW4gaGVscC4NCiMnIA0KZGF0YShNZW50YWwsIHBhY2thZ2UgPSAidmNkRXh0cmEiKQ0Kc3RyKE1lbnRhbCkNCg0KIycgYG1lbnRhbGAgYW5kIGBzZXNgIHdlcmUgY3JlYXRlZCBhcyBvcmRlcmVkIGZhY3RvcnMuDQojJyBGb3IgdGhpcyBleGFtcGxlLCB1bm9yZGVyIHRoZW06IG1lbnRhbDogYWxwaGFiZXRpY2FsbHk7IHNlczogcmFuZG9tIHBlcm11dGF0aW9uDQoNCnNldC5zZWVkKDEyMzQpDQpNZW50YWwkbWVudGFsIDwtIGZhY3RvcihNZW50YWwkbWVudGFsLCBsZXZlbHMgPSBzb3J0KGxldmVscyhNZW50YWwkbWVudGFsKSkpDQpNZW50YWwkc2VzICAgIDwtIGZhY3RvcihNZW50YWwkc2VzLCBsZXZlbHMgPSBzYW1wbGUobGV2ZWxzKE1lbnRhbCRzZXMpKSkNCg0KbWVudGFsLnRhYiA8LSB4dGFicyhGcmVxIH4gc2VzICsgbWVudGFsLCBkYXRhPU1lbnRhbCkNCg0KIycgIyMjIEluaXRpYWwgbW9zYWljIA0KbW9zYWljKG1lbnRhbC50YWIsIHNoYWRlPVRSVUUsIGxlZ2VuZD1GQUxTRSkNCg0KIycgIyMjIENBDQojJyBjYSgpIHVuY292ZXJzIHRoZSB0cnVlIG9yZGVyaW5nDQptZW50YWwuY2EgPC0gY2EobWVudGFsLnRhYikNCnBsb3QobWVudGFsLmNhLCBsaW5lcyA9IFRSVUUpDQoNCiMnICMjIyBVc2Ugc2VyaWF0ZSB0byBnZXQgdGhpcw0Kb3JkZXIgPC0gc2VyaWF0ZShtZW50YWwudGFiLCBtZXRob2QgPSAiQ0EiKQ0KbzEgPC0gZ2V0X29yZGVyKG9yZGVyLCBkaW09MSkNCm8yIDwtIGdldF9vcmRlcihvcmRlciwgZGltPTIpDQoNCiMnICMjIyBNb3NhaWMgb2YgcGVybXV0ZWQgdGFibGUNCm1vc2FpYyhtZW50YWwudGFiW28xLCBvMl0sIHNoYWRlPVRSVUUsIGxlZ2VuZCA9IEZBTFNFKQ0KDQojJyAjIyMgVXNpbmcgdGhlIGxhdGVzdCB2ZXJzaW9uIG9mIHBlcm11dGUNCiMnIA0KIycgTWljaGFlbCBIYWhzbGVyIHVwZGF0ZWQgYHBlcm11dGUoKWAgdG8gYWxsb3cgc3BlY2lmeWluZyBgbWFyZ2luPTE6MmAgdG8gcGVybXV0ZSBib3RoIGRpbWVuc2lvbnMgaW4gYSBzaW5nbGUNCiMnIGNhbGwuIFNlZTogaHR0cHM6Ly9naXRodWIuY29tL21oYWhzbGVyL3NlcmlhdGlvbi9pc3N1ZXMvMTcjaXNzdWVjb21tZW50LTEyODAwOTE4ODENCiMnIA0KIycgDQpoZWNfcGVybSA8LSBwZXJtdXRlKGhhaXJleWUsICJDQSIsIG1hcmdpbiA9IDE6MikNCm1vc2FpYyhoZWNfcGVybSwgc2hhZGU9VFJVRSwgbGVnZW5kPUZBTFNFKQ0KDQptZW50YWwudGFiIDwtIHBlcm11dGUobWVudGFsLnRhYiwgIkNBIikgICAgICAgICAgIyBtYXJnaW49MToyIGlzIHRoZSBkZWZhdWx0DQptb3NhaWMobWVudGFsLnRhYiwgc2hhZGU9VFJVRSwgbGVnZW5kID0gRkFMU0UpDQoNCg0KIycgIyMgU3VtbWFyeQ0KIycgYHNlcmlhdGlvbjo6c2VyaWF0ZSgpYCBoYXMgdGhlIGluZnJhc3RydWN0dXJlIGZvciBhIHdpZGUgcmFuZ2Ugb2Ygc2VyaWF0aW9uIHRhc2tzLCBidXQgDQojJyBpbml0aWFsbHkgc2VlbWVkIG92ZXJseSBjb21wbGV4DQojJyBmb3IgdGhlIGFwcGxpY2F0aW9uIHRvIGZyZXF1ZW5jeSB0YWJsZXMgdXNpbmcgQ0Egd2l0aCBhIGdvYWwgb2YgaW5jb3Jwb3JhdGluZyBpbiBgdmNkOm1vc2FpYygpYC4NCiMnIA0KIycgVGhlIGxhdGVzdCB2ZXJzaW9uLCB3aXRoIHRoZSBjaGFuZ2UgdG8gYHBlcm11dGUoKWAgaXMgbm93IHNvbWV0aGluZyB0aGF0IGNhbiBiZSBlYXNpbHkgdXNlZC4NCiMnIA0KIycgU29tZSBxdWVzdGlvbnM6DQojJyANCiMnICogVGhlcmUgYXJlIGNhc2VzIHdoZXJlIG9uZSBtaWdodCB3YW50IHRvIHBlcm11dGUgdGhlIHJvd3MvY29scyBhY2NvcmRpbmcgdG8gdGhlIENBIDJuZCBkaW1lbnNpb24uDQojJyBJcyB0aGlzIHBvc3NpYmxlPw0KIycgDQojJyANCg0KDQoNCg==