Load data

library(vcd)
data("UCBAdmissions")

rearrange dimensions

UCB <- aperm(UCBAdmissions, c(2,1,3))
# marginal table, collapsing over Dept
(UCB2 <- margin.table(UCB, c(1,2)))
##         Admit
## Gender   Admitted Rejected
##   Male       1198     1493
##   Female      557     1278

Chisquare test

chisq.test(UCB2)
## 
##  Pearson's Chi-squared test with Yates' continuity correction
## 
## data:  UCB2
## X-squared = 91.61, df = 1, p-value < 2.2e-16

Fourfold plots

fourfold(UCB2)

# unstandardized version
fourfold(UCB2, std="ind.max")

3-way table, stratified by Dept

fourfold(UCB, mfrow=c(2,3))

test homogeneity of odds ratios over Dept

woolf_test(UCB)
## 
##  Woolf-test on Homogeneity of Odds Ratios (no 3-Way assoc.)
## 
## data:  UCB
## X-squared = 17.902, df = 5, p-value = 0.003072

calculate odds ratios

oddsratio(UCBAdmissions, log=FALSE)
##  odds ratios for Admit and Gender by Dept 
## 
##         A         B         C         D         E         F 
## 0.3492120 0.8025007 1.1330596 0.9212838 1.2216312 0.8278727
# ## plot log odds ratios
plot(oddsratio(UCBAdmissions), 
     xlab="Department", 
     ylab="Log Odds Ratio (Admit|Gender)")

IycgLS0tDQojJyB0aXRsZTogIlVDQkFkbWlzc2lvbnM6IGZvdXJmb2xkIGRpc3BsYXlzIGFuZCBvZGRzIHJhdGlvcyINCiMnIGF1dGhvcjogIk1pY2hhZWwgRnJpZW5kbHkiDQojJyBkYXRlOiAiYHIgZm9ybWF0KFN5cy5EYXRlKCkpYCINCiMnIG91dHB1dDoNCiMnICAgaHRtbF9kb2N1bWVudDoNCiMnICAgICB0aGVtZTogcmVhZGFibGUNCiMnICAgICBjb2RlX2Rvd25sb2FkOiB0cnVlDQojJyAtLS0NCg0KIysgZWNobz1GQUxTRQ0Ka25pdHI6Om9wdHNfY2h1bmskc2V0KA0KICB3YXJuaW5nID0gRkFMU0UsICAgIyBhdm9pZCB3YXJuaW5ncyBhbmQgbWVzc2FnZXMgaW4gdGhlIG91dHB1dA0KICBtZXNzYWdlID0gRkFMU0UNCikNCg0KIycgIyMgTG9hZCBkYXRhDQpsaWJyYXJ5KHZjZCkNCmRhdGEoIlVDQkFkbWlzc2lvbnMiKQ0KDQojJyAjIyByZWFycmFuZ2UgZGltZW5zaW9ucyANClVDQiA8LSBhcGVybShVQ0JBZG1pc3Npb25zLCBjKDIsMSwzKSkNCiMgbWFyZ2luYWwgdGFibGUsIGNvbGxhcHNpbmcgb3ZlciBEZXB0DQooVUNCMiA8LSBtYXJnaW4udGFibGUoVUNCLCBjKDEsMikpKQ0KDQojJyMjICBDaGlzcXVhcmUgdGVzdA0KY2hpc3EudGVzdChVQ0IyKQ0KDQojJyAjIyBGb3VyZm9sZCBwbG90cw0KZm91cmZvbGQoVUNCMikNCiMgdW5zdGFuZGFyZGl6ZWQgdmVyc2lvbg0KZm91cmZvbGQoVUNCMiwgc3RkPSJpbmQubWF4IikNCg0KIycgIyMgMy13YXkgdGFibGUsIHN0cmF0aWZpZWQgYnkgRGVwdA0KZm91cmZvbGQoVUNCLCBtZnJvdz1jKDIsMykpDQoNCiMnICMjIHRlc3QgaG9tb2dlbmVpdHkgb2Ygb2RkcyByYXRpb3Mgb3ZlciBEZXB0DQp3b29sZl90ZXN0KFVDQikNCg0KIycgIyMgY2FsY3VsYXRlIG9kZHMgcmF0aW9zDQpvZGRzcmF0aW8oVUNCQWRtaXNzaW9ucywgbG9nPUZBTFNFKQ0KDQojICMjIHBsb3QgbG9nIG9kZHMgcmF0aW9zDQpwbG90KG9kZHNyYXRpbyhVQ0JBZG1pc3Npb25zKSwgDQogICAgIHhsYWI9IkRlcGFydG1lbnQiLCANCiAgICAgeWxhYj0iTG9nIE9kZHMgUmF0aW8gKEFkbWl0fEdlbmRlcikiKQ0K