vcd/0000755000175100001440000000000014672002320011040 5ustar hornikusersvcd/tests/0000755000175100001440000000000012212345476012214 5ustar hornikusersvcd/tests/demos.R0000755000175100001440000000015011150520606013433 0ustar hornikuserslibrary(vcd) demo(discrete) demo(twoway) demo(mosaic) demo(mondrian) demo(strucplot) demo(hullternary) vcd/.Rinstignore0000755000175100001440000000002012214053200013330 0ustar hornikusersinst/doc/Z.cls vcd/MD50000644000175100001440000002156714672002320011363 0ustar hornikusers537387a220363804199143cdb2c14c17 *DESCRIPTION d9d1b59e8b88b4ad346afc404ea475cc *NAMESPACE 3c097b80a9e49b4d417f0e5ea45427ce *R/Kappa.R 059845124a77cda96758bfe96e8fbb76 *R/Ord_plot.R 6ee698049c09955fbd88be265264393c *R/agreementplot.R 00a9c863579ce1da6cc72e59bbda6f02 *R/assoc.R c3d1a9c7b4cae7e7bcdf7dea1d712835 *R/assocstats.R 1aa980fb3f23ac810f1cc67bb69daf1a *R/binregplot.R 4088faa0871130598e07ea26430a3c5a *R/cd_plot.R 3ea43d07743875dfce874f4cc067196c *R/co_table.R 1cfff0fdbfa0b20fe4e691b997a5a328 *R/coindep_test.R 6e1c60aa0e8afd51604702791d8947fb *R/cotabplot.R 1d404a765bea252806ae8a094d5be2e9 *R/distplot.R c230becde3443593da1fc18ac168592d *R/doubledeckerplot.R 7bf60e7f713b254cd5afc5f2becf47ea *R/fourfold.R 40fa6290dea68cd3505166907731f742 *R/goodfit.R cb59d1ec73b001757a20e006a2c2c9d2 *R/grid_legend.R 2c061c5f3b6c7480155aca387cbae2bf *R/hls.R 5847d00b373d9de7854e7d5cdecb9b26 *R/labeling.R 445cbabada42553eb7fb35e35a8d2ac0 *R/legends.R d73189e85cf671591cfffa975e807ebf *R/lodds.R 273d8ce40a5ea5302ab2351467b146a1 *R/loddsratio.R ee9268575c067494a320b412a7b94462 *R/mosaic.R e399eefbaf6b57cd9c0d63627e5e0960 *R/mplot.R e64948c0c3e16187701584d8ca54831d *R/oddsratioplot.R aa0734ee958c8c618781a1443df114ca *R/pairsplot.R f429718cc703e950773811364d9335ed *R/plot.loglm.R d0d1334f8b9a76cd4e16923d70a1a9d3 *R/rootogram.R d72e1a190e1d7bef503a2f94f885fa0c *R/shadings.R 5844e6cfd389dc23e364496f6d1059fe *R/sieve.R fd79ebf9c8a9b483b500bad1f0b228e9 *R/spacings.R 8c1e69e46e0d3127ca572abc3b813924 *R/spine.R 87becefab44226b0cdb3f2eb83971c90 *R/strucplot.R f718c8633b0acb39d4018cf495a80d5c *R/structable.R 54abbe94cad0a0322a44327e62a810ca *R/tabletools.R bee629d8802f7f1d158a7975ec346c5f *R/ternaryplot.R d18de2cb6dca77a82c49edc57c1e5d9c *R/tile.R f1f0d3194326666f81dc1ef97623a911 *R/utils.R a54ac332c792d35e0846d4bf45d45bd8 *R/woolf_test.R f61db891eb928123aba4412ca322f508 *build/partial.rdb 36dcf29866c71a7fa71e23bed88f8471 *build/vignette.rds 1fcacdd810545176c5dfc8ad4be480d3 *data/Arthritis.rda af42b0e82f7602ef3a21ac54ba67071c *data/Baseball.rda 4956f3321e6fb5582e3f2ba8901012cd *data/BrokenMarriage.rda 4db232a9f37c6afe361051f4f3d425a5 *data/Bundesliga.rda 93e7f6208ec8c8db86401c1afc3320f6 *data/Bundestag2005.rda 0cb7e806706012f3cedf5855defec7f2 *data/Butterfly.rda f4e45bae788977b0bfb08529b9ecd604 *data/CoalMiners.rda aa7e80a1cd039d8fc05298dac9a2d0bf *data/DanishWelfare.rda 6f3d0d17e3fc3c1fc24db9ee245f51f3 *data/Employment.rda 959746e92f189a5226d95ce8f67649e7 *data/Federalist.rda 59c4403257e7fdd114f70aedb279b9eb *data/Hitters.rda 414cdb694b280c93ab9af35996ad09c1 *data/HorseKicks.rda f8e3b3469e4ca81efbbe5758eb02dd09 *data/Hospital.rda 30aa94bd0a31ce461608ba6934ebe5ba *data/JobSatisfaction.rda c8f5e67eab217718fa29e5400dd45bf5 *data/JointSports.rda cc56cb25ddc3597af573381130099575 *data/Lifeboats.rda 2a64fb9fc44ebd6a1f30f9a18af0d2e0 *data/MSPatients.rda ba9681b79f4ebe1322cacaa081b968d8 *data/NonResponse.rda 134589af7ec903a3c3e00d4206dd1360 *data/OvaryCancer.rda bb7b4fb517d4621ed1d9499c3dee6605 *data/PreSex.rda f0935833b88518d4cec4cbd4cad1c93c *data/Punishment.rda fd84835d9953f840d5e48ace5bb10e67 *data/RepVict.rda 26ba651e9d3ba5b7d04f8978a6026fde *data/Rochdale.rda 582c0ae5e9b6b86318324f9121cf9216 *data/Saxony.rda d9056090e3ef45162e3e61a33e9b1bc1 *data/SexualFun.rda a9971961ea92c34cfa6df11a2702ab57 *data/SpaceShuttle.rda 5685c4d45cfed1d3ac6edcbb28e30c73 *data/Suicide.rda 645187968a5775ec0f32c58b00fa416b *data/Trucks.rda 134c24eaaa7c387e23c1410ed9fe0b99 *data/UKSoccer.rda 203346753d583e64ebaae114e009466f *data/VisualAcuity.rda 7f1432aa827fde459adce4e66fcac287 *data/VonBort.rda c29f363012c0cdbb21ef6ab07e49009e *data/WeldonDice.rda 7079173552b0d5fc274cf95156e59bf5 *data/WomenQueue.rda fea43b041738222b9ca05543c2103248 *demo/00Index 6446ca2edeae8ffaab647cbaf9badc92 *demo/discrete.R 7eb8e56560704b20fe6ca89df6a37843 *demo/hcl.R b96320b9a646b8fc6c63661f49b6aa6f *demo/hls.R 002ca3d1e79c9d84416d3b4e0bf8024e *demo/hsv.R 1da0bb6bdd21c0b13a1599b2121253be *demo/hullternary.R 32aefed96167152c94cf9f5c1a3708cf *demo/mondrian.R a61a25a7b48e3d172cc6353b956c9392 *demo/mosaic.R 7b08161f2cdc60d9e594f3aa76479272 *demo/strucplot.R baec36bb9bda9e52aa5467bd11c71f9d *demo/twoway.R 77f0034bb51876a99a37aaddb8c68548 *inst/CITATION 14a645f6739c8c3717a2e63f904ccefa *inst/NEWS.Rd e5f957f776ca944873a58789e8a5510a *inst/doc/residual-shadings.R ae7fab4a5f5d688165a945e26d3b502b *inst/doc/residual-shadings.Rnw a9a893d6bc15dd446bb02f6cf17c5d9c *inst/doc/residual-shadings.pdf 23a35b9e4ad98965a8b98c760e030f21 *inst/doc/strucplot.R a44ed39ac8ea56c4237505f414e251ae *inst/doc/strucplot.Rnw bfdb54cdf9dc307fad897852f37362f6 *inst/doc/strucplot.pdf 3fa3f0e0c73f66764e33b8f8598efdbc *man/Arthritis.Rd 912a44043a40235b1800aae01d50042e *man/Baseball.Rd 1059d318cb78e6586c3b772ad941cc36 *man/BrokenMarriage.Rd d6bf3e6a57243a4fed61c3de50282738 *man/Bundesliga.Rd 17001eedd4bec5bf7836a28133710c00 *man/Bundestag2005.Rd d5d5c262a89021e918ad8ec488568ed5 *man/Butterfly.Rd 6ed74b82637f822590003c9ce61440c5 *man/CoalMiners.Rd 9a605318f578054afcff4fbe130450c2 *man/DanishWelfare.Rd a8fbbdb872f26bc25aa776061febbd36 *man/Employment.Rd 5e26cab32f3905b6b243f5688dd11cb3 *man/Federalist.Rd ceabf42729a57cb25fa2c707572ccbf1 *man/Hitters.Rd 011a90b18bb38c0828a4e605d4431964 *man/HorseKicks.Rd 8e75757feb4d17a3c40a34a0dcc3ca81 *man/Hospital.Rd c533f38a41280541958fdec1520d2341 *man/JobSatisfaction.Rd df94bd111d97c846f201ad51626a0a97 *man/JointSports.Rd 428dc2a741a2c42b75697f2869dfd5ed *man/Kappa.Rd 0ab6cfcde586f29bb80ba421f7de5350 *man/Lifeboats.Rd e686fe387a14379483d85806089ac133 *man/MSPatients.Rd aa707134c91334b4c6e9ad33af97a6b8 *man/NonResponse.Rd a361b8cb90c7fc63d59a07ac8fafa4a1 *man/Ord_plot.Rd 946f6acc0d04013c7dd1314528415e3c *man/OvaryCancer.Rd a152d72f1d57461592fde61827ace9ed *man/PreSex.Rd 1b730f1a2c0d485806af6db905d34f74 *man/Punishment.Rd 35dd143e4e35bc2b72804ca99e6f746e *man/RepVict.Rd 7c9a39dcc04d539a98407436c5254c20 *man/Rochdale.Rd 250e3176df959f30b160b10b381ac598 *man/Saxony.Rd 57dbc598ae5f4a0b07023d97b9eac55c *man/SexualFun.Rd 57c0d552618bf1b43de02a34883d10a9 *man/SpaceShuttle.Rd 0135b1039084161d9304ac1e9f983467 *man/Suicide.Rd 0b3b7d616076bda3643fea65ec4792f6 *man/Trucks.Rd c4221305498c64d7cce56fd05d38c10b *man/UKSoccer.Rd 43a94ba83e261bac38c238ebc699796c *man/VisualAcuity.Rd 77f1d19db65cb08d6dee0e7c174d029f *man/VonBort.Rd ca83003c80bb9d41eeff4805c4f4df1c *man/WeldonDice.Rd 135bb378b788ecad51c1154872bb30ad *man/WomenQueue.Rd a6cffe6ffa4c65b1339d2d4510a5d826 *man/agreementplot.Rd 12486910f46efddd248a23f660e3960d *man/assoc.Rd e245640865a0d036e5ed49dfc6b22af0 *man/assocstats.Rd 71e4c5635afca020ba5db75d21f7f31d *man/binregplot.Rd 78359b5cf62d25114f272820302e1db8 *man/cd_plot.Rd 09171e763dcdae39764a92d5359965e2 *man/co_table.Rd b4ead52bf1478fe214c0c5ed3f808156 *man/coindep_test.Rd 59bb55f76b4469017ba4b12a2a429ed5 *man/cotab_panel.Rd b4c03b67e2fa609850d2e5e0ae7e48a4 *man/cotabplot.Rd bb5bfbce246384f79ff951a6b63437f4 *man/distplot.Rd d46ddeed29580719692499f35aeaa694 *man/doubledecker.Rd b0568cd2e02a37d19c49192d2f3dc6d6 *man/fourfold.Rd 558a95508e38e92b2be107b82827549c *man/goodfit.Rd 24347c086dd30cecb12e4aacb1ec2079 *man/grid_barplot.Rd 6891014a51c9b278fe89225e9d251d49 *man/grid_legend.Rd f3084a15ca398a9835c9ba3eae26f773 *man/hls.Rd f9b406c3111ee9cacaa55124de6c9df8 *man/independence_table.Rd ca221dad9ef636d3ab21c1ad23fc8ce8 *man/labeling_border.Rd 6b9c689766588315526c84568017fd8f *man/labeling_cells_list.Rd 22985378b6c7b056f358b10ea9ff100c *man/legends.Rd 38edfa781bdfeb423aa717b6a0582555 *man/lodds.Rd 7904c410ad3e24822f9f0d78dbcd628c *man/loddsratio.Rd 6166d08f94e23cb571c4d655eeaa66cd *man/mar_table.Rd 8d1f2f4fa710e1feff230dd667693daf *man/mosaic.Rd 081e08e1bba6835aa647e699797f72bf *man/mplot.Rd 38cd6f996a44be8366f54a9d3630e57d *man/pairs.table.Rd 46ebaef3333677ff2a97f125877761b6 *man/panel_pairs_diagonal.Rd af824945edd4d7522002a2b87f6ba31b *man/panel_pairs_off-diagonal.Rd ed140a424046a7e4cc86e10e5c38bdc3 *man/plot.loddsratio.Rd 73496a137112338719f2c1f44c7bd469 *man/plot.loglm.Rd c501827395d3d2d7f5e9146fc66df5d1 *man/rootogram.Rd 9c786ab52ecd6128cdaacec2ab78a153 *man/shadings.Rd 2a0885931a1def593e3ba6ee411f1d79 *man/sieve.Rd 10f7e4a15b8fd5e66a920031902ef7d5 *man/spacings.Rd 9475ef38895fac17d95f0f4b736c6d66 *man/spine.Rd 273226a90a50b90f6826ffab41f50556 *man/struc_assoc.Rd 03d3d00420c3c8b40b23a55693c6742a *man/struc_mosaic.Rd 6c2358ab831e6a9b901f8df9902201df *man/struc_sieve.Rd da3babfd50885d3e73592c42223a0f2a *man/strucplot.Rd 34e38d68093b570429c78cb6ec863dd8 *man/structable.Rd 46c27c579666ca1f114d556cbda0b638 *man/table2d_summary.Rd b7b2ff805cf8f94c6ab19f5b62d5349c *man/ternaryplot.Rd 4324403cb1c03a8f6c228828eefcc56e *man/tile.Rd bec04ba65f65e48db59acafdd14e3caf *man/woolf_test.Rd 60b5a25113c95aef01c2793f797d69aa *tests/demos.R ae7fab4a5f5d688165a945e26d3b502b *vignettes/residual-shadings.Rnw 0f08ab21c366ba4d4204fae211e89104 *vignettes/struc.pdf fe22f0d95f4098096281d58c459928f9 *vignettes/struc.sxi a44ed39ac8ea56c4237505f414e251ae *vignettes/strucplot.Rnw 2d1a1962971fe0434a420e4e53e6fd37 *vignettes/vcd.bib vcd/R/0000755000175100001440000000000014543516074011256 5ustar hornikusersvcd/R/coindep_test.R0000755000175100001440000000576311150520606014062 0ustar hornikuserscoindep_test <- function(x, margin = NULL, n = 1000, indepfun = function(x) max(abs(x)), aggfun = max, alternative = c("greater", "less"), pearson = TRUE) { DNAME <- deparse(substitute(x)) alternative <- match.arg(alternative) if(is.null(margin)) { rs <- rowSums(x) cs <- colSums(x) expctd <- rs %o% cs / sum(rs) Pearson <- function(x) (x - expctd)/sqrt(expctd) resids <- Pearson(x) ff <- if(is.null(aggfun)) { if(pearson) function(x) aggfun(indepfun(Pearson(x))) else function(x) aggfun(indepfun(x)) } else { if(pearson) function(x) indepfun(Pearson(x)) else function(x) indepfun(x) } if(length(dim(x)) > 2) stop("currently only implemented for (conditional) 2d tables") dist <- sapply(r2dtable(n, rowSums(x), colSums(x)), ff) STATISTIC <- ff(x) } else { ff <- if(pearson) function(x) indepfun(Pearson(x)) else function(x) indepfun(x) cox <- co_table(x, margin) nc <- length(cox) if(length(dim(cox[[1]])) > 2) stop("currently only implemented for conditional 2d tables") dist <- matrix(rep(0, n * nc), ncol = nc) for(i in 1:nc) { coxi <- cox[[i]] cs <- colSums(coxi) rs <- rowSums(coxi) expctd <- rs %o% cs / sum(rs) Pearson <- function(x) (x - expctd)/sqrt(expctd) if(any(c(cs, rs) < 1)) warning("structural zeros") ## FIXME dist[, i] <- sapply(r2dtable(n, rs, cs), ff) } dist <- apply(dist, 1, aggfun) Pearson <- function(x) { expctd <- rowSums(x) %o% colSums(x) / sum(x) return((x - expctd)/sqrt(expctd)) } STATISTIC <- aggfun(sapply(cox, ff)) ## just for returning nicely formatted fitted values ## and residuals: fit once more with loglm() vars <- names(dimnames(x)) condvars <- if(is.numeric(margin)) vars[margin] else margin indvars <- vars[!(vars %in% condvars)] coind.form <- as.formula(paste("~ (", paste(indvars, collapse = " + "), ") * ", paste(condvars, collapse = " * "), sep = "")) fm <- loglm(coind.form, data = x, fitted = TRUE) expctd <- fitted(fm) resids <- residuals(fm, type = "pearson") } pdist <- function(x) sapply(x, function(y) mean(dist <= y)) qdist <- function(p) quantile(dist, p) PVAL <- switch(alternative, greater = mean(dist >= STATISTIC), less = mean(dist <= STATISTIC)) METHOD <- "Permutation test for conditional independence" names(STATISTIC) <- "f(x)" rval <- list(statistic = STATISTIC, p.value = PVAL, method = METHOD, data.name = DNAME, observed = x, expected = expctd, residuals = resids, margin = margin, dist = dist, qdist = qdist, pdist = pdist) class(rval) <- c("coindep_test", "htest") return(rval) } fitted.coindep_test <- function(object, ...) object$expected ## plot.coindep_test ## mosaic.coindep_test ## assoc.coindep_test ## difficult, depends on functionals... vcd/R/shadings.R0000644000175100001440000002454014543515724013207 0ustar hornikusers## convenience function for interfacing ## HCL colors as implemented in colorspace hcl2hex <- function(h = 0, c = 35, l = 85, fixup = TRUE) { colorspace::hex(polarLUV(l, c, h), fixup = fixup) } ## shading-generating functions should take at least the arguments ## observed, residuals, expected, df ## and return a function which takes a single argument (interpreted ## to be a vector of residuals). shading_hsv <- function(observed, residuals = NULL, expected = NULL, df = NULL, h = c(2/3, 0), s = c(1, 0), v = c(1, 0.5), interpolate = c(2, 4), lty = 1, eps = NULL, line_col = "black", p.value = NULL, level = 0.95, ...) { ## get h/s/v and lty my.h <- rep(h, length.out = 2) ## positive and negative hue my.s <- rep(s, length.out = 2) ## maximum and minimum saturation my.v <- rep(v, length.out = 2) ## significant and non-significant value lty <- rep(lty, length.out = 2) ## positive and negative lty ## model fitting (if necessary) if(is.null(expected) && !is.null(residuals)) stop("residuals without expected values specified") if(!is.null(expected) && is.null(df) && is.null(p.value)) { warning("no default inference available without degrees of freedom") p.value <- NA } if(is.null(expected) && !is.null(observed)) { expected <- loglin(observed, 1:length(dim(observed)), fit = TRUE, print = FALSE) df <- expected$df expected <- expected$fit } if(is.null(residuals) && !is.null(observed)) residuals <- (observed - expected)/sqrt(expected) ## conduct significance test (if specified) if(is.null(p.value)) p.value <- function(observed, residuals, expected, df) pchisq(sum(as.vector(residuals)^2), df, lower.tail = FALSE) if(!is.function(p.value) && is.na(p.value)) { v <- my.v[1] p.value <- NULL } else { if(is.function(p.value)) p.value <- p.value(observed, residuals, expected, df) v <- if(p.value < (1-level)) my.v[1] else my.v[2] } ## set up function for interpolation of saturation if(!is.function(interpolate)) { col.bins <- sort(interpolate) interpolate <- stepfun(col.bins, seq(my.s[2], my.s[1], length.out = length(col.bins) + 1)) col.bins <- sort(unique(c(col.bins, 0, -col.bins))) } else { col.bins <- NULL } ## store color and lty information for legend legend <- NULL if(!is.null(col.bins)) { res2 <- col.bins res2 <- c(head(res2, 1) - 1, res2[-1] - diff(res2)/2, tail(res2, 1) + 1) legend.col <- hsv(ifelse(res2 > 0, my.h[1], my.h[2]), pmax(pmin(interpolate(abs(res2)), 1), 0), v, ...) lty.bins <- 0 legend.lty <- lty[2:1] legend <- list(col = legend.col, col.bins = col.bins, lty = legend.lty, lty.bins = lty.bins) } ## set up function that computes color/lty from residuals rval <- function(x) { res <- as.vector(x) fill <- hsv(ifelse(res > 0, my.h[1], my.h[2]), pmax(pmin(interpolate(abs(res)), 1), 0), v, ...) dim(fill) <- dim(x) col <- rep(line_col, length.out = length(res)) if(!is.null(eps)) { eps <- abs(eps) col[res > eps] <- hsv(my.h[1], 1, v, ...) col[res < -eps] <- hsv(my.h[2], 1, v, ...) } dim(col) <- dim(x) # line type should be solid if abs(resid) < eps ltytmp <- ifelse(x > 0, lty[1], lty[2]) if(!is.null(eps)) ltytmp[abs(x) < abs(eps)] <- lty[1] dim(ltytmp) <- dim(x) return(structure(list(col = col, fill = fill, lty = ltytmp), class = "gpar")) } attr(rval, "legend") <- legend attr(rval, "p.value") <- p.value return(rval) } class(shading_hsv) <- "grapcon_generator" shading_hcl <- function(observed, residuals = NULL, expected = NULL, df = NULL, h = NULL, c = NULL, l = NULL, interpolate = c(2, 4), lty = 1, eps = NULL, line_col = "black", p.value = NULL, level = 0.95, ...) { ## set defaults if(is.null(h)) h <- c(260, 0) if(is.null(c)) c <- c(100, 20) if(is.null(l)) l <- c(90, 50) ## get h/c/l and lty my.h <- rep(h, length.out = 2) ## positive and negative hue my.c <- rep(c, length.out = 2) ## significant and non-significant maximum chroma my.l <- rep(l, length.out = 2) ## maximum and minimum luminance lty <- rep(lty, length.out = 2) ## positive and negative lty ## model fitting (if necessary) if(is.null(expected) && !is.null(residuals)) stop("residuals without expected values specified") if(!is.null(expected) && is.null(df) && is.null(p.value)) { warning("no default inference available without degrees of freedom") p.value <- NA } if(is.null(expected) && !is.null(observed)) { expected <- loglin(observed, 1:length(dim(observed)), fit = TRUE, print = FALSE) df <- expected$df expected <- expected$fit } if(is.null(residuals) && !is.null(observed)) residuals <- (observed - expected)/sqrt(expected) ## conduct significance test (if specified) if(is.null(p.value)) p.value <- function(observed, residuals, expected, df) pchisq(sum(as.vector(residuals)^2), df, lower.tail = FALSE) if(!is.function(p.value) && is.na(p.value)) { max.c <- my.c[1] p.value <- NULL } else { if(is.function(p.value)) p.value <- p.value(observed, residuals, expected, df) max.c <- ifelse(p.value < (1-level), my.c[1], my.c[2]) } ## set up function for interpolation of saturation if(!is.function(interpolate)) { col.bins <- sort(interpolate) interpolate <- stepfun(col.bins, seq(0, 1, length.out = length(col.bins) + 1)) col.bins <- sort(unique(c(col.bins, 0, -col.bins))) } else { col.bins <- NULL } ## store color and lty information for legend legend <- NULL if(!is.null(col.bins)) { res2 <- col.bins res2 <- c(head(res2, 1) - 1, res2[-1] - diff(res2)/2, tail(res2, 1) + 1) legend.col <- hcl2hex(ifelse(res2 > 0, my.h[1], my.h[2]), max.c * pmax(pmin(interpolate(abs(res2)), 1), 0), my.l[1] + diff(my.l) * pmax(pmin(interpolate(abs(res2)), 1), 0), ...) lty.bins <- 0 legend.lty <- lty[2:1] legend <- list(col = legend.col, col.bins = col.bins, lty = legend.lty, lty.bins = lty.bins) } ## set up function that computes color/lty from residuals rval <- function(x) { res <- as.vector(x) fill <- hcl2hex(ifelse(res > 0, my.h[1], my.h[2]), max.c * pmax(pmin(interpolate(abs(res)), 1), 0), my.l[1] + diff(my.l) * pmax(pmin(interpolate(abs(res)), 1), 0), ...) dim(fill) <- dim(x) col <- rep(line_col, length.out = length(res)) if(!is.null(eps)) { eps <- abs(eps) col[res > eps] <- hcl2hex(my.h[1], max.c, my.l[2], ...) col[res < -eps] <- hcl2hex(my.h[2], max.c, my.l[2], ...) } dim(col) <- dim(x) ltytmp <- ifelse(x > 0, lty[1], lty[2]) if(!is.null(eps)) ltytmp[abs(x) < abs(eps)] <- lty[1] dim(ltytmp) <- dim(x) return(structure(list(col = col, fill = fill, lty = ltytmp), class = "gpar")) } attr(rval, "legend") <- legend attr(rval, "p.value") <- p.value return(rval) } class(shading_hcl) <- "grapcon_generator" shading_Friendly <- function(observed = NULL, residuals = NULL, expected = NULL, df = NULL, h = c(2/3, 0), lty = 1:2, interpolate = c(2, 4), eps = 0.01, line_col = "black", ...) { shading_hsv(observed = NULL, residuals = NULL, expected = NULL, df = NULL, h = h, v = 1, lty = lty, interpolate = interpolate, eps = eps, line_col = line_col, p.value = NA, ...) } class(shading_Friendly) <- "grapcon_generator" shading_Friendly2 <- function(observed = NULL, residuals = NULL, expected = NULL, df = NULL, lty = 1:2, interpolate = c(2, 4), eps = 0.01, line_col = "black", ...) { shading_hcl(observed = NULL, residuals = NULL, expected = NULL, df = NULL, lty = lty, interpolate = interpolate, eps = eps, line_col = line_col, p.value = NA, ...) } class(shading_Friendly2) <- "grapcon_generator" shading_sieve <- function(observed = NULL, residuals = NULL, expected = NULL, df = NULL, h = c(260, 0), lty = 1:2, interpolate = c(2, 4), eps = 0.01, line_col = "black", ...) { shading_hcl(observed = NULL, residuals = NULL, expected = NULL, df = NULL, h = h, c = 100, l = 50, lty = lty, interpolate = interpolate, eps = eps, line_col = line_col, p.value = NA, ...) } class(shading_sieve) <- "grapcon_generator" shading_max <- function(observed = NULL, residuals = NULL, expected = NULL, df = NULL, h = NULL, c = NULL, l = NULL, lty = 1, eps = NULL, line_col = "black", level = c(0.9, 0.99), n = 1000, ...) { stopifnot(length(dim(observed)) == 2) ## set defaults if(is.null(h)) h <- c(260, 0) if(is.null(c)) c <- c(100, 20) if(is.null(l)) l <- c(90, 50) obs.test <- coindep_test(observed, n = n) col.bins <- obs.test$qdist(sort(level)) rval <- shading_hcl(observed = NULL, residuals = NULL, expected = NULL, df = NULL, h = h, c = c, l = l, interpolate = col.bins, lty = lty, eps = eps, line_col = line_col, p.value = obs.test$p.value, ...) return(rval) } class(shading_max) <- "grapcon_generator" shading_binary <- function(observed = NULL, residuals = NULL, expected = NULL, df = NULL, col = NULL) { ## check col argument if(is.null(col)) col <- hcl2hex(c(260, 0), 50, 70) col <- rep(col, length.out = 2) ## store color information for legend legend <- list(col = col[2:1], col.bins = 0, lty = NULL, lty.bins = NULL) ## set up function that computes color/lty from residuals rval <- function(x) gpar(fill = ifelse(x > 0, col[1], col[2])) ## add meta information for legend attr(rval, "legend") <- legend attr(rval, "p.value") <- NULL rval } class(shading_binary) <- "grapcon_generator" shading_Marimekko <- function(x, fill = NULL, byrow = FALSE) { if (is.null(fill)) fill <- colorspace::rainbow_hcl d <- dim(x) l1 <- if (length(d) > 1L) d[2] else d l2 <- if (length(d) > 1L) d[1] else 1 if (is.function(fill)) fill <- fill(l1) fill <- if (byrow) rep(fill, l2) else rep(fill, each = l2) gpar(col = NA, lty = "solid", fill = array(fill, dim = d)) } shading_diagonal <- function(x, fill = NULL) { if (is.null(fill)) fill <- colorspace::rainbow_hcl d <- dim(x) if (length(d) < 1L) stop("Need matrix or array!") if (d[1] != d[2]) stop("First two dimensions need to be of same length!") if (is.function(fill)) fill <- fill(d[1]) tp = toeplitz(seq_len(d[1])) gpar(col = NA, lty = "solid", fill = array(rep(fill[tp], d[1]), dim = d)) } vcd/R/loddsratio.R0000755000175100001440000006034213163113030013533 0ustar hornikusers## Modifications: ## -- return a dnames component, containing dimnames for the array version of coef ## -- added dim methods: dim.loddsratio, dimnames.loddsratio ## -- added print.loddsratio ## -- handle strata: result computed correctly, but structure of coef() loses names ## and confint doesn't work in the 2x2xk or RxCxk case ## -- Fixed problem with strata by setting rownames and colnames for contrast matrix ## DONE: handle multiple strata (|foo:bar) ## -- print.loddsratio now uses drop() for dimensions of length 1 ## -- made generic, anticipating a formula method, maybe structable or ftable methods ## DONE: decide which methods should allow a log=FALSE argument to provide exp(lor) ## -- Now handle any number of strata ## -- Added log= argument to print, coef methods, and added confint.loddsratio method, ## allowing log=FALSE ## -- Incorporated Z code additions, fixing some s ## -- Added as.matrix and as.array methods; had to make as.array S3 generic ## -- Added header to print method ## -- Added as.data.frame method (for use in plots) ## -- "LOR" is renamed "OR" if log=FALSE ## -- Revised as.matrix to drop leading 1:2 dimensions of length 1 ## -- Removed as.array generic, now in base ## -- DM: added plot.oddsratio method ## -- DM: added formula interface ## -- DM: add t() and aperm() methdos loddsratio <- function(x, ...) UseMethod("loddsratio") loddsratio.formula <- function(formula, data = NULL, ..., subset = NULL, na.action = NULL) { m <- match.call(expand.dots = FALSE) edata <- eval(m$data, parent.frame()) fstr <- strsplit(paste(deparse(formula), collapse = ""), "~") vars <- strsplit(strsplit(gsub(" ", "", fstr[[1]][2]), "\\|")[[1]], "\\+") varnames <- vars[[1]] condnames <- if (length(vars) > 1) vars[[2]] else NULL dep <- gsub(" ", "", fstr[[1]][1]) if (!dep %in% c("","Freq")) { if (all(varnames == ".")) { varnames <- if (is.data.frame(data)) colnames(data) else names(dimnames(as.table(data))) varnames <- varnames[-which(varnames %in% dep)] } varnames <- c(dep, varnames) } if (inherits(edata, "ftable") || inherits(edata, "table") || length(dim(edata)) > 2) { condind <- NULL dat <- as.table(data) if(all(varnames != ".")) { ind <- match(varnames, names(dimnames(dat))) if (any(is.na(ind))) stop(paste("Can't find", paste(varnames[is.na(ind)], collapse=" / "), "in", deparse(substitute(data)))) if (!is.null(condnames)) { condind <- match(condnames, names(dimnames(dat))) if (any(is.na(condind))) stop(paste("Can't find", paste(condnames[is.na(condind)], collapse=" / "), "in", deparse(substitute(data)))) ind <- c(ind, condind) } dat <- margin.table(dat, ind) } loddsratio.default(dat, strata = if (is.null(condind)) NULL else match(condnames, names(dimnames(dat))), ...) } else { m <- m[c(1, match(c("formula", "data", "subset", "na.action"), names(m), 0))] m[[1]] <- as.name("xtabs") m$formula <- formula(paste(if("Freq" %in% colnames(data)) "Freq", "~", paste(c(varnames, condnames), collapse = "+"))) tab <- eval(m, parent.frame()) loddsratio.default(tab, ...) } } loddsratio.default <- function(x, strata = NULL, log = TRUE, ref = NULL, correct = any(x == 0), ...) { ## check dimensions L <- length(d <- dim(x)) if(any(d < 2L)) stop("All table dimensions must be 2 or greater") if(L > 2L && is.null(strata)) strata <- 3L:L if(is.character(strata)) strata <- which(names(dimnames(x)) == strata) if(L - length(strata) != 2L) stop("All but 2 dimensions must be specified as strata.") ## dimensions of primary R x C table dp <- if (length(strata)) d[-strata] else d dn <- if (length(strata)) dimnames(x)[-strata] else dimnames(x) R <- dp[1] C <- dp[2] # shadow matrix with proper dimnames X <- matrix(0, R, C, dimnames=dn) ## process reference categories (always return list of length ## two with reference for rows/cols, respectively) if(is.null(ref)) { ref <- list(NULL, NULL) } else if(is.character(ref)) { if(length(ref) != 2L) stop("'ref' must specify both reference categories") ref <- list(match(ref[1L], rownames(x)), match(ref[2L], colnames(x))) } else if(is.numeric(ref)) { ref <- as.integer(rep(ref, length.out = 2L)) ref <- list(ref[1L], ref[2L]) } ## compute corresponding indices compute_index <- function(n, ref) { if(is.null(ref)) return(cbind(1:(n-1), 2:n)) rval <- cbind(ref, 1:n) d <- rval[,2L] - rval[,1L] rval <- rbind( rval[d > 0, 1:2], rval[d < 0, 2:1] ) return(rval[order(rval[,1L]),,drop = FALSE]) } Rix <- compute_index(R, ref[[1L]]) Cix <- compute_index(C, ref[[2L]]) ## set up contrast matrix for the primary R x C table contr <- matrix(0L, nrow = (R-1) * (C-1), ncol = R * C) colnames(contr) <- paste(rownames(X)[as.vector(row(X))], colnames(X)[as.vector(col(X))], sep = ":") rownames(contr) <- rep("", (R-1) * (C-1)) for(i in 1:(R-1)) for(j in 1:(C-1)) { rix <- (j-1) * (R-1) + i cix <- rep(Rix[i,], 2L) + R * (rep(Cix[j,], each = 2L) - 1L) contr[rix, cix] <- c(1L, -1L, -1L, 1L) if (R > 2 || C > 2 || is.null(strata)) rownames(contr)[rix] <- sprintf("%s/%s", paste(rownames(X)[Rix[i,]], collapse = ":"), paste(colnames(X)[Cix[j,]], collapse = ":")) } # handle strata if (!is.null(strata)) { if (length(strata)==1) { sn <- dimnames(x)[[strata]] } else { sn <- apply(expand.grid(dimnames(x)[strata]), 1, paste, collapse = ":") } SEP <- if (R > 2 || C > 2 || is.null(strata)) "|" else "" rn <- as.vector(outer( dimnames(contr)[[1]], sn, paste, sep=SEP)) cn <- as.vector(outer( dimnames(contr)[[2]], sn, paste, sep=SEP)) contr <- kronecker(diag(prod(dim(x)[strata])), contr) rownames(contr) <- rn colnames(contr) <- cn } ## dimnames for array version dn <- list(rep("", R-1), rep("", C-1)) for(i in 1:(R-1)) dn[[1]][i] <- paste(rownames(x)[Rix[i,]], collapse = ":") for(j in 1:(C-1)) dn[[2]][j] <- paste(colnames(x)[Cix[j,]], collapse = ":") if (!is.null(strata)) dn <- c(dn, dimnames(x)[strata]) if (!is.null(names(dimnames(x)))) names(dn) <- names(dimnames(x)) ## point estimates if (is.logical(correct)) { add <- if(correct) 0.5 else 0 } else if(is.numeric(correct)) { add <- as.vector(correct) if (length(add) != length(x)) stop("array size of 'correct' does not conform to the data") } else stop("correct is not valid") ##coef <- drop(contr %*% log(as.vector(x) + add)) ##FIXME: 0 cells mess up the matrix product, try workaround: mat <- log(as.vector(x) + add) * t(contr) nas <- apply(contr != 0 & is.na(t(mat)), 1, any) coef <- apply(mat, 2, sum, na.rm = TRUE) coef[nas] <- NA ## covariances ##vcov <- crossprod(diag(sqrt(1/(as.vector(x) + add))) %*% t(contr)) tmp <- sqrt(1/(as.vector(x) + add)) * t(contr) tmp[is.na(tmp)] <- 0 vcov <- crossprod(tmp) vcov[nas,] <- NA vcov[,nas] <- NA rval <- structure(list( coefficients = coef, dimnames = dn, dim = as.integer(sapply(dn, length)), vcov = vcov, contrasts = contr, log = log ), class = "loddsratio") rval } ## dim methods dimnames.loddsratio <- function(x, ...) x$dimnames dim.loddsratio <- function(x, ...) x$dim ## t/aperm-methods t.loddsratio <- function(x) aperm(x) aperm.loddsratio <- function(a, perm = NULL, ...) { d <- length(a$dim) if(is.null(perm)) { perm <- if (d < 3) 2L : 1L else c(2L : 1L, d : 3L) } else { if (any(perm[1:2] > 2L) || (d > 2L) && any(perm[-c(1:2)] < 2L)) stop("Mixing of strata and non-strata variables not allowed!") } nams <- names(a$coefficients) a$coefficients <- as.vector(aperm(array(a$coef, dim = a$dim), perm, ...)) nams <- as.vector(aperm(array(nams, dim = a$dim), perm, ...)) names(a$coefficients) <- nams a$dimnames <- a$dimnames[perm] a$dim <- a$dim[perm] a$vcov <- a$vcov[nams, nams] a$contrasts <- a$contrasts[nams,] a } ## straightforward methods coef.loddsratio <- function(object, log = object$log, ...) if(log) object$coefficients else exp(object$coefficients) vcov.loddsratio <- function(object, log = object$log, ...) if(log) object$vcov else `diag<-`(object$vcov, diag(object$vcov) * exp(object$coefficients)^2) confint.loddsratio <- function(object, parm, level = 0.95, log = object$log, ...) { if (log) confint.default(object, parm = parm, level = level, ... ) else { object$log = TRUE exp(confint.default(object, parm = parm, level = level, ... )) } } make_header <- function(x) { vn <- names(dimnames(x)) header <- c(if(x$log) "log" else "", "odds ratios for", vn[1], "and", vn[2], if (length(vn)>2) c("by", paste(vn[-(1:2)], collapse=', ')), "\n\n") paste(header, sep = " ") } ## print method print.loddsratio <- function(x, log = x$log, ...) { cat(make_header(x)) print(drop(array(coef(x, log = log), dim = dim(x), dimnames = dimnames(x)), ...)) invisible(x) } summary.loddsratio <- function(object, ...) lmtest::coeftest(object, ...) ## reshape coef() methods as.matrix.loddsratio <- function (x, log=x$log, ...) { Coef <- coef(x, log = log) if (length(dim(x))==2) matrix(Coef, ncol = dim(x)[2], dimnames=dimnames(x)) else { # drop leading dimensions with length 1, then reshape ddim <- which(dim(x)[1:2]==1) dim(Coef) <- dim(x)[-ddim] dimnames(Coef) <- dimnames(x)[-ddim] if (length(dim(Coef))==1) Coef else matrix(Coef, ncol = prod(dim(Coef)[-1]), dimnames=list(dimnames(Coef)[[1]], apply(expand.grid(dimnames(Coef)[[-1]]), 1, paste, collapse = ":"))) } } as.array.loddsratio <- function (x, log=x$log, ...) { res <- array(coef(x, log = log), dim = dim(x), dimnames=dimnames(x)) drop(res) } as.data.frame.loddsratio <- function(x, row.names = NULL, optional, log=x$log, ...) { df <-data.frame(expand.grid(dimnames(x)), LOR = coef(x, log=log), ASE = sqrt(diag(vcov(x, log=log))), row.names=row.names, ... ) if (!log) colnames(df)[ncol(df)-1] <- "OR" df } image.loddsratio <- function(x, interpolate = NULL, legend = legend_fixed, gp = shading_Friendly, gp_args = NULL, labeling = labeling_values("residuals", suppress = 0), perm = NULL, ...) { a <- as.array(x) if (!is.null(dim(a))) { if (is.null(perm)) { d <- seq_along(dim(a)) perm <- c(d[-c(1:2)], 1:2) } a <- aperm(a, perm) } else { a <- as.table(a) names(dimnames(a)) <- names(dimnames(x))[1] } if (is.null(interpolate)) interpolate <- seq(0.1, max(abs(a), length.out = 4)) if (is.null(gp_args)) gp_args <- list(interpolate = interpolate) tmp <- a tmp[] <- 1 mosaic(tmp, type = "expected", residuals = a, shade = TRUE, gp = shading_Friendly, gp_args = gp_args, legend = legend, labeling = labeling, ...) } tile.loddsratio <- function(x, interpolate = NULL, legend = legend_fixed, gp = shading_Friendly, gp_args = NULL, labeling = labeling_values("residuals", suppress = 0), halign = "center", valign = "center", perm = NULL, ...) { a <- as.array(x) if (!is.null(dim(a))) { if (is.null(perm)) { d <- seq_along(dim(a)) perm <- c(d[-c(1:2)], 1:2) } a <- aperm(a, perm) } else { a <- as.table(a) names(dimnames(a)) <- names(dimnames(x))[1] } if (is.null(interpolate)) interpolate <- seq(0.1, max(abs(a), length.out = 4)) if (is.null(gp_args)) gp_args <- list(interpolate = interpolate) tile(abs(a), halign = halign, valign = valign, residuals = a, shade = TRUE, gp = shading_Friendly, gp_args = gp_args, legend = legend, labeling = labeling, ...) } "plot.loddsratio" <- function(x, baseline = TRUE, gp_baseline = gpar(lty = 2), lines = TRUE, lwd_lines = 3, confidence = TRUE, conf_level = 0.95, lwd_confidence = 2, whiskers = 0, transpose = FALSE, col = NULL, cex = 0.8, pch = NULL, bars = NULL, gp_bars = gpar(fill = "lightgray", alpha = 0.5), bar_width = unit(0.05, "npc"), legend = TRUE, legend_pos = "topright", legend_inset = c(0, 0), legend_vgap = unit(0.5, "lines"), gp_legend_frame = gpar(lwd = 1, col = "black"), gp_legend_title = gpar(fontface = "bold"), gp_legend = gpar(), legend_lwd = 1, legend_size = 1, xlab = NULL, ylab = NULL, xlim = NULL, ylim = NULL, main = NULL, gp_main = gpar(fontsize = 12, fontface = "bold"), newpage = TRUE, pop = FALSE, return_grob = FALSE, add = FALSE, prefix = "", ...) { ## handle default values, limits etc. LOG <- x$log values <- as.array(x) d <- dim(values) if (is.null(bars)) bars <- is.null(d) oddsrange <- range(values, na.rm = TRUE) if(confidence) { CI <- confint(x, log = LOG, level = conf_level) lwr <- CI[,1] upr <- CI[,2] oddsrange <- if (baseline) c(min(0, lwr, na.rm = TRUE), max(0, upr, na.rm = TRUE)) else c(min(lwr, na.rm = TRUE), max(upr, na.rm = TRUE)) } if (is.null(main)) main <- paste(make_header(x), collapse = " ") if (is.null(xlim)) xlim <- if (is.null(d)) c(1, length(values)) else c(1, d[1]) if (is.null(ylim)) ylim <- oddsrange ylimaxis <- ylim + c(-1, 1) * diff(ylim) * 0.04 xlimaxis <- xlim + c(-1, 1) * diff(xlim) * 0.04 ncols <- if (is.null(d)) 1 else prod(d[-1]) if (is.null(col)) col <- rainbow_hcl(ncols, l = 50) if (is.null(pch)) pch <- c(19,15,17, 1:14, 16, 18, 20:25) labs <- if (is.null(d)) names(values) else dimnames(values)[[1]] if (is.null(xlab)) xlab <- if (is.null(d)) names(dimnames(x))[3] else names(dimnames(values))[1] if (is.null(ylab)) ylab <- paste(if (LOG) "L" else "", "OR(", paste(names(dimnames(x))[1:2], collapse = " / "), ")", sep = "") if (newpage) grid.newpage() if (transpose) { if (!add) { ## set up plot region, similar to plot.xy() pushViewport(plotViewport(xscale = ylimaxis, yscale = xlimaxis, default.units = "native", name = paste(prefix,"oddsratio_plot"))) grid.yaxis(name = "yaxis", seq_along(labs), labs, edits = gEdit("labels", rot = 90, hjust = .5, vjust = 0)) grid.xaxis() grid.text(ylab, y = unit(-3.5, "lines")) grid.text(xlab, x = unit(-3, "lines"), rot = 90) grid.text(main, y = unit(1, "npc") + unit(1, "lines"), gp = gp_main) pushViewport(viewport(xscale = ylimaxis, yscale = xlimaxis, default.units = "native", clip = "on")) ## baseline if (baseline) grid.lines(unit(c(1,1) - LOG, "native"), unit(c(0,1), "npc"), gp = gp_baseline) } # workhorse for one stratum draw_one_stratum <- function(vals, pch = "o", col = "black", offset = 0, jitter = 0) { if (bars) { if (any(vals > !LOG)) grid.rect(unit(vals[vals > !LOG], "native"), unit(seq_along(vals)[vals > !LOG], "native"), height = bar_width, width = unit(vals[vals > !LOG] - !LOG, "native"), just = "right", gp = gp_bars ) if (any(vals < !LOG)) grid.rect(unit(vals[vals < !LOG], "native"), unit(seq_along(vals)[vals < !LOG], "native"), height = bar_width, width = unit(abs(vals[vals < !LOG] - !LOG), "native"), just = "left", gp = gp_bars ) } if (lines) grid.lines(unit(vals, "native"), unit(seq_along(vals), "native"), gp = gpar(col = col, lwd = lwd_lines), default.units = "native" ) grid.points(unit(vals, "native"), unit(seq_along(vals), "native"), pch = pch, size = unit(cex, "char"), gp = gpar(col = col, lwd = lwd_lines), default.units = "native" ) if (confidence) for (i in seq_along(vals)) { ii <- i + jitter grid.lines(unit(c(lwr[offset + i], upr[offset + i]), "native"), unit(c(ii, ii), "native"), gp = gpar(col = col, lwd = lwd_confidence)) grid.lines(unit(c(lwr[offset + i], lwr[offset + i]), "native"), unit(c(ii - whiskers/2, ii + whiskers/2), "native"), gp = gpar(col = col, lwd = lwd_confidence)) grid.lines(unit(c(upr[offset + i], upr[offset + i]), "native"), unit(c(ii - whiskers/2, ii + whiskers/2), "native"), gp = gpar(col = col, lwd = lwd_confidence)) } } } else { if (!add) { ## set up plot region pushViewport(plotViewport(xscale = xlimaxis, yscale = ylimaxis, default.units = "native", name = "oddsratio_plot")) grid.xaxis(seq_along(labs), labs) grid.yaxis() grid.text(xlab, y = unit(-3.5, "lines")) grid.text(ylab, x = unit(-3, "lines"), rot = 90) grid.text(main, y = unit(1, "npc") + unit(1, "lines"), gp = gp_main) pushViewport(viewport(xscale = xlimaxis, yscale = ylimaxis, default.units = "native", clip = "on")) ## baseline if (baseline) grid.lines(unit(c(0,1), "npc"), unit(c(1,1) - LOG, "native"), gp = gp_baseline) } ## workhorse for one stratum draw_one_stratum <- function(vals, pch = "o", col = "black", offset = 0, jitter = 0) { if (bars) { if (any(vals > !LOG)) grid.rect(unit(seq_along(vals)[vals > !LOG], "native"), unit(vals[vals > !LOG], "native"), width = bar_width, height = unit(vals[vals > !LOG] - !LOG, "native"), just = "top", gp = gp_bars ) if (any(vals < !LOG)) grid.rect(unit(seq_along(vals)[vals < !LOG], "native"), unit(vals[vals < !LOG], "native"), width = bar_width, height = unit(abs(vals[vals < !LOG] - !LOG), "native"), just = "bottom", gp = gp_bars ) } if (lines) grid.lines(unit(seq_along(vals), "native"), unit(vals, "native"), gp = gpar(col = col, lwd = lwd_lines), default.units = "native" ) grid.points(unit(seq_along(vals), "native"), unit(vals, "native"), pch = pch, size = unit(cex, "char"), gp = gpar(col = col, lwd = lwd_lines), default.units = "native" ) if (confidence) for (i in seq_along(vals)) { ii <- i + jitter grid.lines(unit(c(ii, ii), "native"), unit(c(lwr[offset + i], upr[offset + i]), "native"), gp = gpar(col = col, lwd = lwd_confidence)) grid.lines(unit(c(ii - whiskers/2, ii + whiskers/2), "native"), unit(c(lwr[offset + i], lwr[offset + i]), "native"), gp = gpar(col = col, lwd = lwd_confidence)) grid.lines(unit(c(ii - whiskers/2, ii + whiskers/2), "native"), unit(c(upr[offset + i], upr[offset + i]), "native"), gp = gpar(col = col, lwd = lwd_confidence)) } } } if (is.null(d)) draw_one_stratum(values, pch[1], col[1]) else { jitt <- scale(seq_len(prod(d[-1])), scale = 25 * prod(d[-1])) for (i in 1 : prod(d[-1])) draw_one_stratum(values[(i - 1) * d[1] + seq(d[1])], pch[(i - 1 ) %% length(pch) + 1], col[i], offset = (i - 1) * d[1], jitt[i]) if (legend) grid_legend(legend_pos, labels = apply(expand.grid(dimnames(values)[-1]), 1, paste, collapse = "|"), pch = pch[1 : prod(d[-1])], col = col, lwd = legend_lwd, lty = "solid", size = legend_size, vgap = legend_vgap, gp = gp_legend, gp_frame = gp_legend_frame, inset = legend_inset, title = paste(names(dimnames(values)[-1]), collapse = " x "), gp_title = gp_legend_title, ...) } grid.rect(gp = gpar(fill = "transparent")) if (!add && pop) popViewport(2) if (return_grob) invisible(grid.grab()) else invisible(NULL) } lines.loddsratio <- function(x, legend = FALSE, confidence = FALSE, cex = 0, ...) { plot(x, add = TRUE, newpage = FALSE, legend = legend, confidence = confidence, cex = cex, ...) } vcd/R/tile.R0000755000175100001440000001463613607016754012353 0ustar hornikuserstile <- function(x, ...) UseMethod("tile") tile.formula <- function(formula, data = NULL, ..., main = NULL, sub = NULL, subset = NULL, na.action = NULL) { if (is.logical(main) && main) main <- deparse(substitute(data)) else if (is.logical(sub) && sub) sub <- deparse(substitute(data)) m <- match.call(expand.dots = FALSE) edata <- eval(m$data, parent.frame()) fstr <- strsplit(paste(deparse(formula), collapse = ""), "~") vars <- strsplit(strsplit(gsub(" ", "", fstr[[1]][2]), "\\|")[[1]], "\\+") varnames <- vars[[1]] dep <- gsub(" ", "", fstr[[1]][1]) if (!dep %in% c("","Freq")) { if (all(varnames == ".")) { varnames <- if (is.data.frame(data)) colnames(data) else names(dimnames(as.table(data))) varnames <- varnames[-which(varnames %in% dep)] } varnames <- c(varnames, dep) } if (inherits(edata, "ftable") || inherits(edata, "table") || length(dim(edata)) > 2) { dat <- as.table(data) if(all(varnames != ".")) { ind <- match(varnames, names(dimnames(dat))) if (any(is.na(ind))) stop(paste("Can't find", paste(varnames[is.na(ind)], collapse=" / "), "in", deparse(substitute(data)))) dat <- margin.table(dat, ind) } tile.default(dat, main = main, sub = sub, ...) } else { m <- m[c(1, match(c("formula", "data", "subset", "na.action"), names(m), 0))] m[[1]] <- as.name("xtabs") m$formula <- formula(paste(if("Freq" %in% colnames(data)) "Freq", "~", paste(varnames, collapse = "+"))) tab <- eval(m, parent.frame()) tile.default(tab, main = main, sub = sub, ...) } } tile.default <- function(x, tile_type = c("area", "squaredarea", "height", "width"), halign = c("left", "center", "right"), valign = c("bottom", "center", "top"), split_vertical = NULL, shade = FALSE, spacing = spacing_equal(unit(1, "lines")), set_labels = NULL, margins = unit(3, "lines"), keep_aspect_ratio = FALSE, legend = NULL, legend_width = NULL, squared_tiles = TRUE, main = NULL, sub = NULL, ...) { ## argument handling if (is.logical(main) && main) main <- deparse(substitute(x)) else if (is.logical(sub) && sub) sub <- deparse(substitute(x)) tile_type <- match.arg(tile_type) halign <- match.arg(halign) valign <- match.arg(valign) x <- as.table(x) dl <- length(d <- dim(x)) ## determine starting positions xpos <- 1 - (halign == "left") - 0.5 * (halign == "center") ypos <- 1 - (valign == "bottom") - 0.5 * (valign == "center") ## heuristic to adjust right/bottom margin to obtain squared tiles ## FIXME: better push another viewport? if (squared_tiles) { ## splitting argument if (is.structable(x) && is.null(split_vertical)) split_vertical <- attr(x, "split_vertical") if (is.null(split_vertical)) split_vertical <- FALSE if (length(split_vertical) == 1) split_vertical <- rep(c(split_vertical, !split_vertical), length.out = dl) if (length(split_vertical) < dl) split_vertical <- rep(split_vertical, length.out = dl) ## compute resulting dimnension dflat <- dim(unclass(structable(x, split_vertical = split_vertical))) ## adjust margins spacing <- spacing(d) delta <- abs(dflat[1] - dflat[2]) fac <- delta / max(dflat) un <- unit(fac, "npc") - unit(fac * 5 / convertWidth(spacing[[1]], "lines", valueOnly=TRUE), "lines") leg <- if (shade) { if (is.null(legend_width)) unit(5, "lines") else legend_width } else unit(0, "npc") if (dflat[1] < dflat[2]) margins <- margins + unit.c(unit(0, "npc"), unit(0, "npc"), un + leg, unit(0, "npc")) if (dflat[1] > dflat[2]) margins <- margins + unit.c(unit(0, "npc"), un - leg, unit(0, "npc"), unit(0, "npc")) if (dflat[1] == dflat[2]) margins <- margins + unit.c(unit(0, "npc"), unit(0, "npc"), leg, unit(0, "npc")) } ## create dummy labels if some are duplicated ## and set the labels via set_labels dn <- dimnames(x) if (any(unlist(lapply(dn, duplicated)))) { dimnames(x) <- lapply(dn, seq_along) if (is.null(set_labels)) set_labels <- lapply(dn, function(i) structure(i, names = seq(i))) } ## workhorse function creating bars panelfun <- function(residuals, observed, expected, index, gp, name) { xprop <- expected / max(expected) if (tile_type == "height") grid.rect(x = xpos, y = ypos, height = xprop[t(index)], width = 1, gp = gp, just = c(halign, valign), name = name) else if (tile_type == "width") grid.rect(x = xpos, y = ypos, width = xprop[t(index)], height = 1, gp = gp, just = c(halign, valign), name = name) else if (tile_type == "area") grid.rect(x = xpos, y = ypos, width = sqrt(xprop[t(index)]), height = sqrt(xprop[t(index)]), gp = gp, just = c(halign, valign), name = name) else grid.rect(x = xpos, y = ypos, width = xprop[t(index)], height = xprop[t(index)], gp = gp, just = c(halign, valign), name = name) } mycore <- function(residuals, observed, expected = NULL, spacing, gp, split_vertical, prefix = "") { struc_mosaic(panel = panelfun)(residuals, array(1, dim = d, dimnames = dimnames(observed)), expected = observed, spacing, gp, split_vertical, prefix) } strucplot(x, core = mycore, spacing = spacing, keep_aspect_ratio = keep_aspect_ratio, margins = margins, shade = shade, legend = legend, legend_width = legend_width, main = main, sub = sub, set_labels = set_labels, ...) } vcd/R/assoc.R0000755000175100001440000002717412200255346012515 0ustar hornikusers#################################################################333 ## assocplot assoc <- function(x, ...) UseMethod("assoc") assoc.formula <- function(formula, data = NULL, ..., subset = NULL, na.action = NULL, main = NULL, sub = NULL) { if (is.logical(main) && main) main <- deparse(substitute(data)) else if (is.logical(sub) && sub) sub <- deparse(substitute(data)) assoc.default(structable(formula, data, subset = subset, na.action = na.action), main = main, sub = sub, ...) } assoc.default <- function(x, row_vars = NULL, col_vars = NULL, compress = TRUE, xlim = NULL, ylim = NULL, spacing = spacing_conditional(sp = 0), spacing_args = list(), split_vertical = NULL, keep_aspect_ratio = FALSE, xscale = 0.9, yspace = unit(0.5, "lines"), main = NULL, sub = NULL, ..., residuals_type = "Pearson", gp_axis = gpar(lty = 3) ) { if (is.logical(main) && main) main <- deparse(substitute(x)) else if (is.logical(sub) && sub) sub <- deparse(substitute(x)) if (!inherits(x, "ftable")) x <- structable(x) tab <- as.table(x) dl <- length(dim(tab)) ## spacing cond <- rep(TRUE, dl) cond[length(attr(x, "row.vars")) + c(0, length(attr(x, "col.vars")))] <- FALSE if (inherits(spacing, "grapcon_generator")) spacing <- do.call("spacing", spacing_args) spacing <- spacing(dim(tab), condvars = which(cond)) ## splitting arguments if (is.null(split_vertical)) split_vertical <- attr(x, "split_vertical") if(match.arg(tolower(residuals_type), "pearson") != "pearson") warning("Only Pearson residuals can be visualized with association plots.") strucplot(tab, spacing = spacing, split_vertical = split_vertical, core = struc_assoc(compress = compress, xlim = xlim, ylim = ylim, yspace = yspace, xscale = xscale, gp_axis = gp_axis), keep_aspect_ratio = keep_aspect_ratio, residuals_type = "Pearson", main = main, sub = sub, ...) } ## old code: more elegant conceptually, but less performant ## ## struc_assoc2 <- function(compress = TRUE, xlim = NULL, ylim = NULL, ## yspace = unit(0.5, "lines"), xscale = 0.9, ## gp_axis = gpar(lty = 3)) ## function(residuals, observed = NULL, expected, spacing, gp, split_vertical, prefix = "") { ## dn <- dimnames(expected) ## dnn <- names(dn) ## dx <- dim(expected) ## dl <- length(dx) ## ## axis limits ## resid <- structable(residuals, split_vertical = split_vertical) ## sexpected <- structable(sqrt(expected), split_vertical = split_vertical) ## rfunc <- function(x) c(min(x, 0), max(x, 0)) ## if (is.null(ylim)) ## ylim <- if (compress) ## matrix(apply(as.matrix(resid), 1, rfunc), nrow = 2) ## else ## rfunc(as.matrix(resid)) ## if (!is.matrix(ylim)) ## ylim <- matrix(as.matrix(ylim), nrow = 2, ncol = nrow(as.matrix(resid))) ## attr(ylim, "split_vertical") <- rep(TRUE, sum(!split_vertical)) ## attr(ylim, "dnames") <- dn[!split_vertical] ## class(ylim) <- "structable" ## if(is.null(xlim)) ## xlim <- if (compress) ## matrix(c(-0.5, 0.5) %o% apply(as.matrix(sexpected), 2, max), nrow = 2) ## else ## c(-0.5, 0.5) * max(sexpected) ## if (!is.matrix(xlim)) ## xlim <- matrix(as.matrix(xlim), nrow = 2, ncol = ncol(as.matrix(resid))) ## attr(xlim, "split_vertical") <- rep(TRUE, sum(split_vertical)) ## attr(xlim, "dnames") <- dn[split_vertical] ## class(xlim) <- "structable" ## ## split workhorse ## split <- function(res, sexp, i, name, row, col) { ## v <- split_vertical[i] ## splitbase <- if (v) sexp else res ## splittab <- lapply(seq(dx[i]), function(j) splitbase[[j]]) ## len <- sapply(splittab, function(x) sum(unclass(x)[1,] - unclass(x)[2,])) ## d <- dx[i] ## ## compute total cols/rows and build split layout ## dist <- unit.c(unit(len, "null"), spacing[[i]] + (1 * !v) * yspace) ## idx <- matrix(1:(2 * d), nrow = 2, byrow = TRUE)[-2 * d] ## layout <- if (v) ## grid.layout(ncol = 2 * d - 1, widths = dist[idx]) ## else ## grid.layout(nrow = 2 * d - 1, heights = dist[idx]) ## vproot <- viewport(layout.pos.col = col, layout.pos.row = row, ## layout = layout, name = remove_trailing_comma(name)) ## ## next level: either create further splits, or final viewports ## name <- paste(name, dnn[i], "=", dn[[i]], ",", sep = "") ## rows <- cols <- rep.int(1, d) ## if (v) cols <- 2 * 1:d - 1 else rows <- 2 * 1:d - 1 ## f <- if (i < dl) { ## if (v) ## function(m) split(res, splittab[[m]], i + 1, name[m], rows[m], cols[m]) ## else ## function(m) split(splittab[[m]], sexp, i + 1, name[m], rows[m], cols[m]) ## } else { ## if (v) ## function(m) viewport(layout.pos.col = cols[m], layout.pos.row = rows[m], ## name = remove_trailing_comma(name[m]), ## yscale = unclass(res)[,1], ## xscale = unclass(sexp)[,m], default.units = "null") ## else ## function(m) viewport(layout.pos.col = cols[m], layout.pos.row = rows[m], ## name = remove_trailing_comma(name[m]), ## yscale = unclass(res)[,m], ## xscale = unclass(sexp)[,1], default.units = "null") ## } ## vpleaves <- structure(lapply(1:d, f), class = c("vpList", "viewport")) ## vpTree(vproot, vpleaves) ## } ## ## start spltting on top, creates viewport-tree ## pushViewport(split(ylim, xlim, i = 1, name = paste(prefix, "cell:", sep = ""), ## row = 1, col = 1)) ## ## draw tiles ## mnames <- paste(apply(expand.grid(dn), 1, ## function(i) paste(dnn, i, collapse = ",", sep = "=") ## ) ## ) ## for (i in seq_along(mnames)) { ## seekViewport(paste(prefix, "cell:", mnames[i], sep = "")) ## grid.lines(y = unit(0, "native"), gp = gp_axis) ## grid.rect(y = 0, x = 0, ## height = residuals[i], ## width = xscale * unit(sqrt(expected[i]), "native"), ## default.units = "native", ## gp = structure(lapply(gp, function(x) x[i]), class = "gpar"), ## just = c("center", "bottom"), ## name = paste(prefix, "rect:", mnames[i], sep = "") ## ) ## } ## } ## class(struc_assoc2) <- "grapcon_generator" struc_assoc <- function(compress = TRUE, xlim = NULL, ylim = NULL, yspace = unit(0.5, "lines"), xscale = 0.9, gp_axis = gpar(lty = 3)) function(residuals, observed = NULL, expected, spacing, gp, split_vertical, prefix = "") { if(is.null(expected)) stop("Need expected values.") dn <- dimnames(expected) dnn <- names(dn) dx <- dim(expected) dl <- length(dx) ## axis limits resid <- structable(residuals, split_vertical = split_vertical) sexpected <- structable(sqrt(expected), split_vertical = split_vertical) rfunc <- function(x) c(min(x, 0), max(x, 0)) if (is.null(ylim)) ylim <- if (compress) matrix(apply(as.matrix(resid), 1, rfunc), nrow = 2) else rfunc(as.matrix(resid)) if (!is.matrix(ylim)) ylim <- matrix(as.matrix(ylim), nrow = 2, ncol = nrow(as.matrix(resid))) ylim[2,] <- ylim[2,] + .Machine$double.eps attr(ylim, "split_vertical") <- rep(TRUE, sum(!split_vertical)) attr(ylim, "dnames") <- dn[!split_vertical] class(ylim) <- "structable" if(is.null(xlim)) xlim <- if (compress) matrix(c(-0.5, 0.5) %o% apply(as.matrix(sexpected), 2, max), nrow = 2) else c(-0.5, 0.5) * max(sexpected) if (!is.matrix(xlim)) xlim <- matrix(as.matrix(xlim), nrow = 2, ncol = ncol(as.matrix(resid))) attr(xlim, "split_vertical") <- rep(TRUE, sum(split_vertical)) attr(xlim, "dnames") <- dn[split_vertical] class(xlim) <- "structable" ## split workhorse split <- function(res, sexp, i, name, row, col, index) { v <- split_vertical[i] d <- dx[i] splitbase <- if (v) sexp else res splittab <- lapply(seq(d), function(j) splitbase[[j]]) len <- abs(sapply(splittab, function(x) sum(unclass(x)[1,] - unclass(x)[2,]))) ## compute total cols/rows and build split layout dist <- if (d > 1) unit.c(unit(len, "null"), spacing[[i]] + (1 * !v) * yspace) else unit(len, "null") idx <- matrix(1:(2 * d), nrow = 2, byrow = TRUE)[-2 * d] layout <- if (v) grid.layout(ncol = 2 * d - 1, widths = dist[idx]) else grid.layout(nrow = 2 * d - 1, heights = dist[idx]) pushViewport(viewport(layout.pos.col = col, layout.pos.row = row, layout = layout, name = paste(prefix, "cell:", remove_trailing_comma(name), sep = ""))) ## next level: either create further splits, or final viewports rows <- cols <- rep.int(1, d) if (v) cols <- 2 * 1:d - 1 else rows <- 2 * 1:d - 1 for (m in 1:d) { nametmp <- paste(name, dnn[i], "=", dn[[i]][m], ",", sep = "") if (i < dl) { if (v) sexp <- splittab[[m]] else res <- splittab[[m]] split(res, sexp, i + 1, nametmp, rows[m], cols[m], cbind(index, m)) } else { pushViewport(viewport(layout.pos.col = cols[m], layout.pos.row = rows[m], name = paste(prefix, "cell:", remove_trailing_comma(nametmp), sep = ""), yscale = unclass(res)[,if (v) 1 else m], xscale = unclass(sexp)[,if (v) m else 1], default.units = "npc") ) ## draw tiles grid.lines(y = unit(0, "native"), gp = gp_axis) grid.rect(y = 0, x = 0, height = residuals[cbind(index, m)], width = xscale * unit(sqrt(expected[cbind(index, m)]), "native"), default.units = "native", gp = structure(lapply(gp, function(x) x[cbind(index,m)]), class = "gpar"), just = c("center", "bottom"), name = paste(prefix, "rect:", remove_trailing_comma(nametmp), sep = "") ) } upViewport(1) } } split(ylim, xlim, i = 1, name = "", row = 1, col = 1, index = cbind()) } class(struc_assoc) <- "grapcon_generator" vcd/R/spacings.R0000755000175100001440000000344311566471034013215 0ustar hornikusers################################################################## ## spacings spacing_equal <- function(sp = unit(0.3, "lines")) { if (!is.unit(sp)) sp <- unit(sp, "lines") function(d, condvars = NULL) lapply(d, function(x) if(x > 1) rep(sp, x - 1) else NA) } class(spacing_equal) <- "grapcon_generator" spacing_dimequal <- function(sp) { if (!is.unit(sp)) sp <- unit(sp, "lines") function(d, condvars = NULL) lapply(seq_along(d), function(i) if(d[i] > 1) rep(sp[i], d[i] - 1) else NA) } class(spacing_dimequal) <- "grapcon_generator" spacing_increase <- function(start = unit(0.3, "lines"), rate = 1.5) { if (!is.unit(start)) start <- unit(start, "lines") function(d, condvars = NULL) { sp <- start * rev(cumprod(c(1, rep.int(rate, length(d) - 1)))) spacing_dimequal(sp)(d = d, condvars = condvars) } } class(spacing_increase) <- "grapcon_generator" spacing_highlighting <- function(start = unit(0.2, "lines"), rate = 1.5) { if (!is.unit(start)) start <- unit(start, "lines") function(d, condvars = NULL) c(spacing_increase(start, rate)(d, condvars)[-length(d)], list(unit(rep(0, d[length(d)]), "lines"))) } class(spacing_highlighting) <- "grapcon_generator" spacing_conditional <- function(sp = unit(0.3, "lines"), start = unit(2, "lines"), rate = 1.8) { condfun <- spacing_increase(start, rate) equalfun <- spacing_equal(sp) equalfun2 <- spacing_equal(start) function(d, condvars) { if (length(d) < 3) return(spacing_equal(sp)(d, condvars)) condvars <- seq(condvars) ret <- vector("list", length(d)) ret[condvars] <- if (length(condvars) < 3) equalfun2(d[condvars]) else condfun(d[condvars]) ret[-condvars] <- equalfun(d[-condvars]) ret } } class(spacing_conditional) <- "grapcon_generator" vcd/R/strucplot.R0000755000175100001440000003000713631232430013427 0ustar hornikusers################################################################ ### strucplot - generic plot framework for mosaic-like layouts ### 2 core functions are provided: struc_mosaic and struc_assoc ################################################################ strucplot <- function(## main parameters x, residuals = NULL, expected = NULL, condvars = NULL, shade = NULL, type = c("observed", "expected"), residuals_type = NULL, df = NULL, ## layout split_vertical = NULL, spacing = spacing_equal, spacing_args = list(), gp = NULL, gp_args = list(), labeling = labeling_border, labeling_args = list(), core = struc_mosaic, core_args = list(), legend = NULL, legend_args = list(), main = NULL, sub = NULL, margins = unit(3, "lines"), title_margins = NULL, legend_width = NULL, ## control parameters main_gp = gpar(fontsize = 20), sub_gp = gpar(fontsize = 15), newpage = TRUE, pop = TRUE, return_grob = FALSE, keep_aspect_ratio = NULL, prefix = "", ... ) { ## default behaviour of shade if (is.null(shade)) shade <- !is.null(gp) || !is.null(expected) type <- match.arg(type) if (is.null(residuals)) { residuals_type <- if (is.null(residuals_type)) "pearson" else match.arg(tolower(residuals_type), c("pearson", "deviance", "ft")) } else { if (is.null(residuals_type)) residuals_type <- "" } ## convert structable object if (is.structable(x)) { if (is.null(split_vertical)) split_vertical <- attr(x, "split_vertical") x <- as.table(x) } if (is.null(split_vertical)) split_vertical <- FALSE ## table characteristics d <- dim(x) dl <- length(d) dn <- dimnames(x) if (is.null(dn)) dn <- dimnames(x) <- lapply(d, seq) dnn <- names(dimnames(x)) if (is.null(dnn)) dnn <- names(dn) <- names(dimnames(x)) <- LETTERS[1:dl] ## replace NAs by 0 if (any(nas <- is.na(x))) x[nas] <- 0 ## model fitting: ## calculate df and expected if needed ## (used for inference in some shading (generating) functions). ## note: will *not* be calculated if residuals are given if ((is.null(expected) && is.null(residuals)) || !is.numeric(expected)) { if (!is.null(df)) warning("Using calculated degrees of freedom.") if (inherits(expected, "formula")) { fm <- loglm(expected, x, fitted = TRUE) expected <- fitted(fm) df <- fm$df } else { if (is.null(expected)) expected <- if (is.null(condvars)) as.list(1:dl) else lapply((condvars + 1):dl, c, seq(condvars)) fm <- loglin(x, expected, fit = TRUE, print = FALSE) expected <- fm$fit df <- fm$df } } ## compute residuals if (is.null(residuals)) residuals <- switch(residuals_type, pearson = (x - expected) / sqrt(ifelse(expected > 0, expected, 1)), deviance = { tmp <- 2 * (x * log(ifelse(x == 0, 1, x / ifelse(expected > 0, expected, 1))) - (x - expected)) tmp <- sqrt(pmax(tmp, 0)) ifelse(x > expected, tmp, -tmp) }, ft = sqrt(x) + sqrt(x + 1) - sqrt(4 * expected + 1) ) ## replace NAs by 0 if (any(nas <- is.na(residuals))) residuals[nas] <- 0 ## splitting if (length(split_vertical) == 1) split_vertical <- rep(c(split_vertical, !split_vertical), length.out = dl) if (is.null(keep_aspect_ratio)) keep_aspect_ratio <- dl < 3 ## spacing if (is.function(spacing)) { if (inherits(spacing, "grapcon_generator")) spacing <- do.call("spacing", spacing_args) spacing <- spacing(d, condvars) } ## gp (color, fill, lty, etc.) argument if (shade) { if (is.null(gp)) gp <- shading_hcl if (is.function(gp)) { if (is.null(legend) || (is.logical(legend) && legend)) legend <- legend_resbased gpfun <- if (inherits(gp, "grapcon_generator")) do.call("gp", c(list(x, residuals, expected, df), as.list(gp_args))) else gp gp <- gpfun(residuals) } else if (!is.null(legend) && !(is.logical(legend) && !legend)) stop("gp argument must be a shading function for drawing a legend") } else { if(!is.null(gp)) { warning("gp parameter ignored since shade = FALSE") gp <- NULL } } ## choose gray when no shading is used if (is.null(gp)) gp <- gpar(fill = grey(0.8)) ## recycle gpar values in the *first* dimension size <- prod(d) FUN <- function(par) { if (is.structable(par)) par <- as.table(par) if (length(par) < size || is.null(dim(par))) array(par, dim = d) else par } gp <- structure(lapply(gp, FUN), class = "gpar") ## set up page if (newpage) grid.newpage() if (keep_aspect_ratio) pushViewport(viewport(width = 1, height = 1, default.units = "snpc")) pushViewport(vcdViewport(mar = margins, oma = title_margins, legend = shade && !(is.null(legend) || is.logical(legend) && !legend), main = !is.null(main), sub = !is.null(sub), keep_aspect_ratio = keep_aspect_ratio, legend_width = legend_width, prefix = prefix)) ## legend if (inherits(legend, "grapcon_generator")) legend <- do.call("legend", legend_args) if (shade && !is.null(legend) && !(is.logical(legend) && !legend)) { seekViewport(paste(prefix, "legend", sep = "")) residuals_type <- switch(residuals_type, deviance = "deviance\nresiduals:", ft = "Freeman-Tukey\nresiduals:", pearson = "Pearson\nresiduals:", residuals_type) legend(residuals, gpfun, residuals_type) } ## titles if (!is.null(main)) { seekViewport(paste(prefix, "main", sep = "")) if (is.logical(main) && main) main <- deparse(substitute(x)) grid.text(main, gp = main_gp) } if (!is.null(sub)) { seekViewport(paste(prefix, "sub", sep = "")) if (is.logical(sub) && sub && is.null(main)) sub <- deparse(substitute(x)) grid.text(sub, gp = sub_gp) } ## make plot seekViewport(paste(prefix, "plot", sep = "")) if (inherits(core, "grapcon_generator")) core <- do.call("core", core_args) core(residuals = residuals, observed = if (type == "observed") x else expected, expected = if (type == "observed") expected else x, spacing = spacing, gp = gp, split_vertical = split_vertical, prefix = prefix) upViewport(1) ## labels if (is.logical(labeling)) labeling <- if (labeling) labeling_border else NULL if (!is.null(labeling)) { if (inherits(labeling, "grapcon_generator")) labeling <- do.call("labeling", c(labeling_args, list(...))) labeling(dn, split_vertical, condvars, prefix) } ## pop/move up viewport seekViewport(paste(prefix, "base", sep = "")) ## one more up if sandwich-mode if (pop) popViewport(1 + keep_aspect_ratio) else upViewport(1 + keep_aspect_ratio) ## return visualized table if (return_grob) invisible(structure(structable(if (type == "observed") x else expected, split_vertical = split_vertical), grob = grid.grab() ) ) else invisible(structable(if (type == "observed") x else expected, split_vertical = split_vertical)) } vcdViewport <- function(mar = rep.int(2.5, 4), legend_width = unit(5, "lines"), oma = NULL, legend = FALSE, main = FALSE, sub = FALSE, keep_aspect_ratio = TRUE, prefix = "") { ## process parameters if (is.null(legend_width)) legend_width <- unit(5 * legend, "lines") if (!is.unit(legend_width)) legend_width <- unit(legend_width, "lines") if (legend && !main && !sub && keep_aspect_ratio) main <- sub <- TRUE mar <- if (!is.unit(mar)) unit(pexpand(mar, 4, rep.int(2.5, 4), c("top","right","bottom","left")), "lines") else rep(mar, length.out = 4) if (is.null(oma)) { space <- if (legend && keep_aspect_ratio) legend_width + mar[2] + mar[4] - mar[1] - mar[3] else unit(0, "lines") oma <- if (main && sub) max(unit(2, "lines"), 0.5 * space) else if (main) unit.c(max(unit(2, "lines"), space), unit(0, "lines")) else if (sub) unit.c(unit(0, "lines"), max(unit(2, "lines"), space)) else 0.5 * space } oma <- if (!is.unit(oma)) unit(pexpand(oma, 2, rep.int(2, 2), c("top","bottom")), "lines") else rep(oma, length.out = 2) ## set up viewports vpPlot <- vpStack(viewport(layout.pos.col = 2, layout.pos.row = 3), viewport(width = 1, height = 1, name = paste(prefix, "plot", sep = ""), default.units = if (keep_aspect_ratio) "snpc" else "npc")) vpMarginBottom <- viewport(layout.pos.col = 2, layout.pos.row = 4, name = paste(prefix, "margin_bottom", sep = "")) vpMarginLeft <- viewport(layout.pos.col = 1, layout.pos.row = 3, name = paste(prefix, "margin_left", sep = "")) vpMarginTop <- viewport(layout.pos.col = 2, layout.pos.row = 2, name = paste(prefix, "margin_top", sep = "")) vpMarginRight <- viewport(layout.pos.col = 3, layout.pos.row = 3, name = paste(prefix, "margin_right", sep = "")) vpCornerTL <- viewport(layout.pos.col = 1, layout.pos.row = 2, name = paste(prefix, "corner_top_left", sep = "")) vpCornerTR <- viewport(layout.pos.col = 3, layout.pos.row = 2, name = paste(prefix, "corner_top_right", sep = "")) vpCornerBL <- viewport(layout.pos.col = 1, layout.pos.row = 4, name = paste(prefix, "corner_bottom_left", sep = "")) vpCornerBR <- viewport(layout.pos.col = 3, layout.pos.row = 4, name = paste(prefix, "corner_bottom_right", sep = "")) vpLegend <- viewport(layout.pos.col = 4, layout.pos.row = 3, name = paste(prefix, "legend", sep = "")) vpLegendTop <- viewport(layout.pos.col = 4, layout.pos.row = 2, name = paste(prefix, "legend_top", sep = "")) vpLegendSub <- viewport(layout.pos.col = 4, layout.pos.row = 4, name = paste(prefix, "legend_sub", sep = "")) vpBase <- viewport(layout = grid.layout(5, 4, widths = unit.c(mar[4], unit(1, "null"), mar[2], legend_width), heights = unit.c(oma[1], mar[1], unit(1, "null"), mar[3], oma[2])), name = paste(prefix, "base", sep = "")) vpMain <- viewport(layout.pos.col = 1:4, layout.pos.row = 1, name = paste(prefix, "main", sep = "")) vpSub <- viewport(layout.pos.col = 1:4, layout.pos.row = 5, name = paste(prefix, "sub", sep = "")) vpTree(vpBase, vpList(vpMain, vpMarginBottom, vpMarginLeft, vpMarginTop, vpMarginRight, vpLegendTop, vpLegend, vpLegendSub, vpCornerTL, vpCornerTR, vpCornerBL, vpCornerBR, vpPlot, vpSub)) } vcd/R/fourfold.R0000644000175100001440000003661714541375200013226 0ustar hornikusers## Modifications - MF - 1 Dec 2010 # -- change default colors to more distinguishable values # -- allow to work with >3 dimensional arrays # -- modified defaults for mfrow/mfcol to give landscape display, nr <= nc, rather than nr >= nc # Take a 2+D array and return a 3D array, with dimensions 3+ as a single dimension # Include as a separate function, since it is useful in other contexts array3d <- function(x, sep=':') { if(length(dim(x)) == 2) { x <- if(is.null(dimnames(x))) array(x, c(dim(x), 1)) else array(x, c(dim(x), 1), c(dimnames(x), list(NULL))) return(x) } else if(length(dim(x))==3) return(x) else { x3d <- array(x, c(dim(x)[1:2], prod(dim(x)[-(1:2)]))) if (!is.null(dimnames(x))) { n3d <- paste(names(dimnames(x))[-(1:2)], collapse=sep) d3d <- apply(expand.grid(dimnames(x)[-(1:2)]), 1, paste, collapse=sep) dimnames(x3d) <- c(dimnames(x)[1:2], list(d3d)) names(dimnames(x3d))[3] <- n3d } return(x3d) } } "fourfold" <- function(x, # color = c("#99CCFF","#6699CC","#FF5050","#6060A0", "#FF0000", "#000080"), color = c("#99CCFF","#6699CC","#FFA0A0","#A0A0FF", "#FF0000", "#000080"), conf_level = 0.95, std = c("margins", "ind.max", "all.max"), margin = c(1, 2), space = 0.2, main = NULL, sub = NULL, mfrow = NULL, mfcol = NULL, extended = TRUE, ticks = 0.15, p_adjust_method = p.adjust.methods, newpage = TRUE, fontsize = 12, default_prefix = c("Row", "Col", "Strata"), sep = ": ", varnames = TRUE, return_grob = FALSE) { ## Code for producing fourfold displays. ## Reference: ## Friendly, M. (1994). ## A fourfold display for 2 by 2 by \eqn{k} tables. ## Technical Report 217, York University, Psychology Department. ## http://datavis.ca/papers/4fold/4fold.pdf ## ## Implementation notes: ## ## We need plots with aspect ratio FIXED to 1 and glued together. ## Hence, even if k > 1 we prefer keeping everything in one plot ## region rather than using a multiple figure layout. ## Each 2 by 2 pie is is drawn into a square with x/y coordinates ## between -1 and 1, with row and column labels in [-1-space, -1] ## and [1, 1+space], respectively. If k > 1, strata labels are in ## an area with y coordinates in [1+space, 1+(1+gamma)*space], ## where currently gamma=1.25. The pies are arranged in an nr by ## nc layout, with horizontal and vertical distances between them ## set to space. ## ## The drawing code first computes the complete are of the form ## [0, totalWidth] x [0, totalHeight] ## needed and sets the world coordinates using plot.window(). ## Then, the strata are looped over, and the corresponding pies ## added by filling rows or columns of the layout as specified by ## the mfrow or mfcol arguments. The world coordinates are reset ## in each step by shifting the origin so that we can always plot ## as detailed above. if(!is.array(x)) stop("x must be an array") dimx <- dim(x) # save original dimensions for setting default mfrow/mfcol when length(dim(x))>3 x <- array3d(x) if(any(dim(x)[1:2] != 2)) stop("table for each stratum must be 2 by 2") dnx <- dimnames(x) if(is.null(dnx)) dnx <- vector("list", 3) for(i in which(sapply(dnx, is.null))) dnx[[i]] <- LETTERS[seq(length.out = dim(x)[i])] if(is.null(names(dnx))) i <- 1 : 3 else i <- which(is.null(names(dnx))) if(any(i > 0)) names(dnx)[i] <- default_prefix[i] dimnames(x) <- dnx k <- dim(x)[3] if(!((length(conf_level) == 1) && is.finite(conf_level) && (conf_level >= 0) && (conf_level < 1))) stop("conf_level must be a single number between 0 and 1") if(conf_level == 0) conf_level <- FALSE std <- match.arg(std) findTableWithOAM <- function(or, tab) { ## Find a 2x2 table with given odds ratio `or' and the margins ## of a given 2x2 table `tab'. m <- rowSums(tab)[1] n <- rowSums(tab)[2] t <- colSums(tab)[1] if(or == 1) x <- t * n / (m + n) else if(or == Inf) x <- max(0, t - m) else { A <- or - 1 B <- or * (m - t) + (n + t) C <- - t * n x <- (- B + sqrt(B ^ 2 - 4 * A * C)) / (2 * A) } matrix(c(t - x, x, m - t + x, n - x), nrow = 2) } drawPie <- function(r, from, to, n = 500, color = "transparent") { p <- 2 * pi * seq(from, to, length.out = n) / 360 x <- c(cos(p), 0) * r y <- c(sin(p), 0) * r grid.polygon(x, y, gp = gpar(fill = color), default.units = "native") invisible(NULL) } stdize <- function(tab, std, x) { ## Standardize the 2 x 2 table `tab'. if(std == "margins") { if(all(sort(margin) == c(1, 2))) { ## standardize to equal row and col margins u <- sqrt(odds(tab)$or) u <- u / (1 + u) y <- matrix(c(u, 1 - u, 1 - u, u), nrow = 2) } else if(margin %in% c(1, 2)) y <- prop.table(tab, margin) else stop("incorrect margin specification") } else if(std == "ind.max") y <- tab / max(tab) else if(std == "all.max") y <- tab / max(x) y } odds <- function(x) { ## Given a 2 x 2 or 2 x 2 x k table `x', return a list with ## components `or' and `se' giving the odds ratios and standard ## deviations of the log odds ratios. if(length(dim(x)) == 2) { dim(x) <- c(dim(x), 1) k <- 1 } else k <- dim(x)[3] or <- double(k) se <- double(k) for(i in 1 : k) { f <- x[ , , i] if(any(f == 0)) f <- f + 0.5 or[i] <- (f[1, 1] * f[2, 2]) / (f[1, 2] * f[2, 1]) se[i] <- sqrt(sum(1 / f)) } list(or = or, se = se) } gamma <- 1.25 # Scale factor for strata labels angle.f <- c( 90, 180, 0, 270) # `f' for `from' angle.t <- c(180, 270, 90, 360) # `t' for `to' byrow <- FALSE if(!is.null(mfrow)) { nr <- mfrow[1] nc <- mfrow[2] } else if(!is.null(mfcol)) { nr <- mfcol[1] nc <- mfcol[2] byrow <- TRUE } else if(length(dimx)>3) { nr <- dimx[3] nc <- prod(dimx[-(1:3)]) } else { # nr <- ceiling(sqrt(k)) nr <- round(sqrt(k)) nc <- ceiling(k / nr) } if(nr * nc < k) stop("incorrect geometry specification") if(byrow) indexMatrix <- expand.grid(1 : nc, 1 : nr)[, c(2, 1)] else indexMatrix <- expand.grid(1 : nr, 1 : nc) totalWidth <- nc * 2 * (1 + space) + (nc - 1) * space totalHeight <- if(k == 1) 2 * (1 + space) else nr * (2 + (2 + gamma) * space) + (nr - 1) * space xlim <- c(0, totalWidth) ylim <- c(0, totalHeight) if (newpage) grid.newpage() if (!is.null(main) || !is.null(sub)) pushViewport(viewport(height = 1 - 0.1 * sum(!is.null(main), !is.null(sub)), width = 0.9, y = 0.5 - 0.05 * sum(!is.null(main), - !is.null(sub)) ) ) pushViewport(viewport(xscale = xlim, yscale = ylim, width = unit(min(totalWidth / totalHeight, 1), "snpc"), height = unit(min(totalHeight / totalWidth, 1), "snpc"))) o <- odds(x) ## perform logoddsratio-test for each stratum (H0: lor = 0) and adjust p-values if(is.numeric(conf_level) && extended) p.lor.test <- p.adjust(sapply(1 : k, function(i) { u <- abs(log(o$or[i])) / o$se[i] 2 * (1 - pnorm(u)) }), method = p_adjust_method ) scale <- space / (2 * convertY(unit(1, "strheight", "Ag"), "native", valueOnly = TRUE) ) v <- 0.95 - max(convertX(unit(1, "strwidth", as.character(c(x))), "native", valueOnly = TRUE) ) / 2 fontsize = fontsize * scale for(i in 1 : k) { tab <- x[ , , i] fit <- stdize(tab, std, x) xInd <- indexMatrix[i, 2] xOrig <- 2 * xInd - 1 + (3 * xInd - 2) * space yInd <- indexMatrix[i, 1] yOrig <- if(k == 1) (1 + space) else (totalHeight - (2 * yInd - 1 + ((3 + gamma) * yInd - 2) * space)) pushViewport(viewport(xscale = xlim - xOrig, yscale = ylim - yOrig)) ## drawLabels() u <- 1 + space / 2 adjCorr <- 0.2 grid.text( paste(names(dimnames(x))[1], dimnames(x)[[1]][1], sep = sep), 0, u, gp = gpar(fontsize = fontsize), default.units = "native" ) grid.text( paste(names(dimnames(x))[2], dimnames(x)[[2]][1], sep = sep), -u, 0, default.units = "native", gp = gpar(fontsize = fontsize), rot = 90) grid.text( paste(names(dimnames(x))[1], dimnames(x)[[1]][2], sep = sep), 0, -u, gp = gpar(fontsize = fontsize), default.units = "native" ) grid.text( paste(names(dimnames(x))[2], dimnames(x)[[2]][2], sep = sep), u, 0, default.units = "native", gp = gpar(fontsize = fontsize), rot = 90) if (k > 1) { grid.text(if (!varnames) dimnames(x)[[3]][i] else paste(names(dimnames(x))[3], dimnames(x)[[3]][i], sep = sep), 0, 1 + (1 + gamma / 2) * space, gp = gpar(fontsize = fontsize * gamma), default.units = "native" ) } ## drawFrequencies() ### in extended plots, emphasize charts with significant logoddsratios emphasize <- if(extended && is.numeric(conf_level)) 2 * extended * (1 + (p.lor.test[i] < 1 - conf_level)) else 0 d <- odds(tab)$or drawPie(sqrt(fit[1,1]), 90, 180, color = color[1 + (d > 1) + emphasize]) drawPie(sqrt(fit[2,1]), 180, 270, color = color[2 - (d > 1) + emphasize]) drawPie(sqrt(fit[1,2]), 0, 90, color = color[2 - (d > 1) + emphasize]) drawPie(sqrt(fit[2,2]), 270, 360, color = color[1 + (d > 1) + emphasize]) u <- 1 - space / 2 grid.text(as.character(c(tab))[1], -v, u, just = c("left", "top"), gp = gpar(fontsize = fontsize), default.units = "native") grid.text(as.character(c(tab))[2], -v, -u, just = c("left", "bottom"), gp = gpar(fontsize = fontsize), default.units = "native") grid.text(as.character(c(tab))[3], v, u, just = c("right", "top"), gp = gpar(fontsize = fontsize), default.units = "native") grid.text(as.character(c(tab))[4], v, -u, just = c("right", "bottom"), gp = gpar(fontsize = fontsize), default.units = "native") ## draw ticks if(extended && ticks) if(d > 1) { grid.lines(c(sqrt(fit[1,1]) * cos(3*pi/4), (sqrt(fit[1,1]) + ticks) * cos(3*pi/4)), c(sqrt(fit[1,1]) * sin(3*pi/4), (sqrt(fit[1,1]) + ticks) * sin(3*pi/4)), gp = gpar(lwd = 1), default.units = "native" ) grid.lines(c(sqrt(fit[2,2]) * cos(-pi/4), (sqrt(fit[2,2]) + ticks) * cos(-pi/4)), c(sqrt(fit[2,2]) * sin(-pi/4), (sqrt(fit[2,2]) + ticks) * sin(-pi/4)), gp = gpar(lwd = 1), default.units = "native" ) } else { grid.lines(c(sqrt(fit[1,2]) * cos(pi/4), (sqrt(fit[1,2]) + ticks) * cos(pi/4)), c(sqrt(fit[1,2]) * sin(pi/4), (sqrt(fit[1,2]) + ticks) * sin(pi/4)), gp = gpar(lwd = 1), default.units = "native" ) grid.lines(c(sqrt(fit[2,1]) * cos(-3*pi/4), (sqrt(fit[2,1]) + ticks) * cos(-3*pi/4)), c(sqrt(fit[2,1]) * sin(-3*pi/4), (sqrt(fit[2,1]) + ticks) * sin(-3*pi/4)), gp = gpar(lwd = 1), default.units = "native" ) } ## drawConfBands() if(is.numeric(conf_level)) { or <- o$or[i] se <- o$se[i] ## lower theta <- or * exp(qnorm((1 - conf_level) / 2) * se) tau <- findTableWithOAM(theta, tab) r <- sqrt(c(stdize(tau, std, x))) for(j in 1 : 4) drawPie(r[j], angle.f[j], angle.t[j]) ## upper theta <- or * exp(qnorm((1 + conf_level) / 2) * se) tau <- findTableWithOAM(theta, tab) r <- sqrt(c(stdize(tau, std, x))) for(j in 1 : 4) drawPie(r[j], angle.f[j], angle.t[j]) } ## drawBoxes() grid.polygon(c(-1, 1, 1, -1), c(-1, -1, 1, 1), default.units = "native", gp = gpar(fill = "transparent") ) grid.lines(c(-1, 1), c(0, 0), default.units = "native") for(j in seq(from = -0.8, to = 0.8, by = 0.2)) grid.lines(c(j, j), c(-0.02, 0.02), default.units = "native") for(j in seq(from = -0.9, to = 0.9, by = 0.2)) grid.lines(c(j, j), c(-0.01, 0.01), default.units = "native") grid.lines(c(0, 0), c(-1, 1), default.units = "native") for(j in seq(from = -0.8, to = 0.8, by = 0.2)) grid.lines(c(-0.02, 0.02), c(j, j), default.units = "native") for(j in seq(from = -0.9, to = 0.9, by = 0.2)) grid.lines(c(-0.01, 0.01), c(j, j), default.units = "native") popViewport(1) } if(!is.null(main) || !is.null(sub)) { if (!is.null(main)) grid.text(main, y = unit(1, "npc") + unit(1, "lines"), gp = gpar(fontsize = 20, fontface = 2)) if (!is.null(sub)) grid.text(sub, y = unit(0, "npc") - unit(1, "lines"), gp = gpar(fontsize = 20, fontface = 2)) popViewport(1) } popViewport(1) if (return_grob) return(invisible(grid.grab())) else return(invisible(NULL)) } vcd/R/labeling.R0000644000175100001440000007221714543515655013173 0ustar hornikusers################################################################ ## labeling pexpand <- function(par, len, default_value, default_names, choices = NULL) { if (is.null(par)) par <- default_value nam <- names(par) if (!is.null(choices)) par <- sapply(par, match.arg, choices) if (is.null(nam)) { default_value <- par par <- rep(par, length.out = len) nam <- names(par) <- default_names } else if (length(nam[nam == ""])) { default_value <- par[nam == ""] nam <- nam[nam != ""] } ret <- rep(default_value, length.out = len) if (!is.null(nam)) { names(ret) <- default_names ret[nam] <- par[nam] } ret } labeling_list <- function(gp_text = gpar(), just = "left", pos = "left", lsep = ": ", sep = " ", offset = unit(c(2, 2), "lines"), varnames = TRUE, cols = 2, ...) { function(d, split_vertical, condvars, prefix = "") { if (is.table(d) || is.structable(d)) d <- dimnames(d) ld <- length(d) labeling_border(labels = FALSE, varnames = varnames)(d, split_vertical, condvars, prefix) seekViewport(paste(prefix, "margin_bottom", sep = "")) pos <- unit(switch(pos, left = 0, center = 0.5, 1) / cols, "npc") ind <- split(seq(ld), rep.int(seq(cols), ceiling(ld / cols))[seq(ld)]) for (i in seq_along(ind)) grid.text(x = offset[1] + pos + unit((i - 1) / cols, "npc"), y = unit(1, "npc") - offset[2], paste(names(d[ind[[i]]]), sapply(d[ind[[i]]], paste, collapse = sep), sep = lsep, collapse = "\n" ), just = c(just, "top"), gp = gp_text ) } } class(labeling_list) <- "grapcon_generator" labeling_conditional <- function(...) { function (d, split_vertical, condvars, prefix = "") { if (is.table(d) || is.structable(d)) d <- dimnames(d) v <- rep.int(TRUE, length(d)) v[seq(condvars)] <- FALSE labeling_border(labels = !v, ...)(d, split_vertical, condvars, prefix) labeling_cells(labels = v, ...)(d, split_vertical, condvars, prefix) } } class(labeling_conditional) <- "grapcon_generator" labeling_cells <- function(labels = TRUE, varnames = TRUE, abbreviate_labels = FALSE, abbreviate_varnames = FALSE, gp_text = gpar(), lsep = ": ", lcollapse = "\n", just = "center", pos = "center", rot = 0, margin = unit(0.5, "lines"), clip_cells = TRUE, text = NULL, ...) { function(d, split_vertical, condvars, prefix = "") { if (is.table(d) || is.structable(d)) d <- dimnames(d) dn <- names(d) ld <- length(d) ## expand parameters if (length(pos) < 2) pos <- c(pos, pos) labels <- pexpand(labels, ld, TRUE, dn) varnames <- pexpand(varnames, ld, TRUE, dn) abbreviate_labels <- pexpand(abbreviate_labels, ld, FALSE, dn) abbreviate_varnames <- pexpand(abbreviate_varnames, ld, FALSE, dn) ## margin if (!is.unit(margin)) margin <- unit(margin, "lines") prvars <- ifelse(abbreviate_varnames, sapply(seq_along(dn), function(i) abbreviate(dn[i], abbreviate_varnames[i])), dn) prvars <- ifelse(varnames, paste(prvars, lsep, sep = ""), "") if (is.structable(text)) text <- as.table(text) ## draw labels split <- function(vind = 1, labs = c()) { n <- d[[vind]] for (labind in seq_along(n)) { lab <- c(labs, n[labind]) names(lab) <- names(d)[1:vind] mlab <- paste(prefix, "cell:", paste(dn[1:vind], lab, sep = "=", collapse = ","), sep = "") if (vind < ld) split(vind + 1, lab) else { seekViewport(mlab) pushViewport(viewport(width = max(unit(0, "npc"), unit(1, "npc") - 2 * margin), height = unit(1, "npc") - 2 * margin, clip = clip_cells)) txt <- if (!is.null(text)) { lab <- lab[names(dimnames(text))] do.call("[", c(list(text), as.list(lab))) } else { prlab <- ifelse(abbreviate_labels, sapply(seq_along(lab), function(i) abbreviate(lab[i], abbreviate_labels[i])), lab) prlab <- prlab[labels[1:ld]] paste(prvars[labels[1:ld]], prlab, sep = "", collapse = lcollapse) } grid.text(if(!is.na(txt)) txt, x = switch(pos[1], left =, top = 0, center = 0.5, 1), y = switch(pos[2], left =, top = 1, center = 0.5, 0), gp = gp_text, just = just, rot = rot) popViewport() } } } split() seekViewport(paste(prefix, "base", sep = "")) upViewport(1) } } class(labeling_cells) <- "grapcon_generator" labeling_border <- function(labels = TRUE, varnames = labels, set_labels = NULL, set_varnames = NULL, tl_labels = NULL, alternate_labels = FALSE, tl_varnames = NULL, gp_labels = gpar(fontsize = 12), gp_varnames = gpar(fontsize = 12, fontface = 2), rot_labels = c(0, 90, 0, 90), rot_varnames = c(0, 90, 0, 90), pos_labels = "center", pos_varnames = "center", just_labels = "center", just_varnames = pos_varnames, boxes = FALSE, fill_boxes = FALSE, offset_labels = c(0, 0, 0, 0), offset_varnames = offset_labels, labbl_varnames = NULL, labels_varnames = FALSE, sep = ": ", abbreviate_labs = FALSE, rep = TRUE, clip = FALSE, ... ) { ## expand parameters that apply to the four table margins pos_labels <- pexpand(pos_labels, 4, "center", c("top", "right", "bottom", "left"), c("left", "center", "right")) just_labels <- pexpand(just_labels, 4, "center", c("top", "right", "bottom", "left"), c("left", "center", "right")) offset_varnames <- if (!is.unit(offset_varnames)) unit(pexpand(offset_varnames, 4, rep.int(0, 4), c("top","right","bottom","left")), "lines") else rep(offset_varnames, length.out = 4) offset_labels <- if (!is.unit(offset_labels)) unit(pexpand(offset_labels, 4, rep.int(0, 4), c("top","right","bottom","left")), "lines") else rep(offset_labels, length.out = 4) rot_labels <- pexpand(rot_labels, 4, c(0, 90, 0, 90), c("top", "right", "bottom", "left")) if (inherits(gp_varnames, "gpar")) gp_varnames <- list(gp_varnames) gp_varnames <- pexpand(gp_varnames, 4, list(gpar(fontsize = 12, fontface = 2)), c("top", "right", "bottom", "left")) rot_varnames <- pexpand(rot_varnames, 4, c(0, 90, 0, 90), c("top", "right", "bottom", "left")) pos_varnames <- pexpand(pos_varnames, 4, "center", c("top", "right", "bottom", "left"), c("left", "center", "right")) just_varnames <- pexpand(just_varnames, 4, pos_varnames, c("top", "right", "bottom", "left"), c("left", "center", "right")) function(d, split_vertical, condvars, prefix = "") { if (is.table(d) || is.structable(d)) d <- dimnames(d) dn <- names(d) ld <- length(d) ## expand table- (i.e., dimensionality)-dependent parameters clip <- pexpand(clip, ld, TRUE, dn) labels <- pexpand(labels, ld, TRUE, dn) labels_varnames <- pexpand(labels_varnames, ld, FALSE, dn) ## tl_labels def <- logical() def[split_vertical] <- rep(c(TRUE, FALSE), length.out = sum(split_vertical)) def[!split_vertical] <- rep(c(TRUE, FALSE), length.out = sum(!split_vertical)) tl_labels <- if (is.null(tl_labels)) def else pexpand(tl_labels, ld, def, dn) ## rep labels rep <- pexpand(rep, ld, TRUE, dn) printed <- lapply(d, function(i) rep.int(FALSE, length(i))) ## alternate labels alternate_labels <- pexpand(alternate_labels, ld, FALSE, dn) ## abbreviate abbreviate_labs <- pexpand(abbreviate_labs, ld, FALSE, dn) labs <- d for (i in seq_along(d)) if (abbreviate_labs[i]) labs[[i]] <- abbreviate(labs[[i]], abbreviate_labs[i]) ## gp_labels if (inherits(gp_labels, "gpar")) gp_labels <- list(gp_labels) gp_labels <- pexpand(gp_labels, ld, list(gpar(fontsize = 12)), dn) ## varnames varnames <- pexpand(varnames, ld, labels, dn) ## tl_varnames if (is.null(tl_varnames) && is.null(labbl_varnames)) tl_varnames <- tl_labels tl_varnames <- pexpand(tl_varnames, ld, tl_labels, dn) ## labbl_varnames if (!is.null(labbl_varnames)) labbl_varnames <- pexpand(labbl_varnames, ld, TRUE, dn) ## boxes boxes <- pexpand(boxes, ld, FALSE, dn) ## fill_boxes dnl <- sapply(d, length) fill_boxes <- if (is.atomic(fill_boxes)) { fill_boxes <- if (is.logical(fill_boxes)) ifelse(pexpand(fill_boxes, ld, FALSE, dn), "grey", NA) else pexpand(fill_boxes, ld, "grey", dn) col <- rgb2hsv(col2rgb(fill_boxes)) lapply(seq(along.with = dnl), function(i) if (is.na(fill_boxes[i])) "white" else hsv(h = col["h",i], s = col["s",i], v = seq(from = col["v",i], to = 0.5 * col["v",i], length.out = dnl[i]) ) ) } else { fill_boxes <- pexpand(fill_boxes, ld, "white", dn) lapply(seq(ld), function(i) pexpand(fill_boxes[[i]], dnl[i], "white", d[[i]]) ) } ## precompute spaces lsp <- tsp <- bsp <- rsp <- 0 labsp <- rep.int(0, ld) for (i in seq_along(dn)[tl_labels & labels]) labsp[i] <- if (split_vertical[i]) { if (alternate_labels[i]) bsp <- bsp - 1 tsp <- tsp + 1 } else { if (alternate_labels[i]) rsp <- rsp + 1 lsp <- lsp - 1 } for (i in rev(seq_along(dn)[!tl_labels & labels])) labsp[i] <- if (split_vertical[i]) { if (alternate_labels[i]) tsp <- tsp + 1 bsp <- bsp - 1 } else { if (alternate_labels[i]) lsp <- lsp - 1 rsp <- rsp + 1 } if(is.null(labbl_varnames)) { ## varnames in the outer margin ## compute axis names tt <- bt <- lt <- rt <- "" for (i in seq_along(dn)) { var <- if (!is.null(set_varnames) && !is.na(set_varnames[dn[i]])) set_varnames[dn[i]] else dn[i] if (varnames[i]) { if (split_vertical[i]) { if (tl_varnames[i]) tt <- paste(tt, var, sep = if (tt == "") "" else " / ") else bt <- paste(bt, var, sep = if (bt == "") "" else " / ") } else { if (tl_varnames[i]) lt <- paste(lt, var, sep = if (lt == "") "" else " / ") else rt <- paste(rt, var, sep = if (rt == "") "" else " / ") } } } ## draw axis names if (tt != "") grid.text(tt, y = unit(1, "npc") + unit(tsp + 1, "lines") + offset_varnames[1], x = switch(pos_varnames[1], left =, bottom = 0, center =, centre = 0.5, 1), rot = rot_varnames[1], just = just_varnames[1], gp = gp_varnames[[1]]) if (bt != "") grid.text(bt, y = unit(bsp - 1, "lines") + -1 * offset_varnames[3], x = switch(pos_varnames[3], left =, bottom = 0, center =, centre = 0.5, 1), rot = rot_varnames[3], just = just_varnames[3], gp = gp_varnames[[3]]) if (lt != "") grid.text(lt, x = unit(lsp - 1, "lines") + -1 * offset_varnames[4], y = switch(pos_varnames[4], left =, bottom = 0, center =, centre = 0.5, 1), rot = rot_varnames[4], just = just_varnames[4], gp = gp_varnames[[4]]) if (rt != "") grid.text(rt, x = unit(1, "npc") + unit(rsp + 1, "lines") + offset_varnames[2], y = switch(pos_varnames[2], left =, bottom = 0, center =, centre = 0.5, 1), rot = rot_varnames[2], just = just_varnames[2], gp = gp_varnames[[2]]) } else { ## varnames beneath labels for (i in seq_along(dn)) { var <- if (!is.null(set_varnames) && !is.na(set_varnames[dn[i]])) set_varnames[dn[i]] else dn[i] if (varnames[i]) { if (split_vertical[i]) { if (tl_labels[i]) { if (labbl_varnames[i]) { grid.text(var, y = unit(1, "npc") + unit(1 + tsp - labsp[i], "lines") + offset_varnames[1], x = unit(-0.5, "lines"), just = "right", gp = gp_varnames[[4]]) } else { grid.text(var, y = unit(1, "npc") + unit(1 + tsp - labsp[i], "lines") + offset_varnames[1], x = unit(1, "npc") + unit(0.5, "lines"), just = "left", gp = gp_varnames[[2]]) } } else { if (labbl_varnames[i]) { grid.text(var, y = unit(labsp[i], "lines") + -1 * offset_varnames[3], x = unit(-0.5, "lines"), just = "right", gp = gp_varnames[[4]]) } else { grid.text(var, y = unit(labsp[i], "lines") + -1 * offset_varnames[3], x = unit(1, "npc") + unit(0.5, "lines"), just = "left", gp = gp_varnames[[2]]) } } } else { if (tl_labels[i]) { if (labbl_varnames[i]) { grid.text(var, x = unit(lsp - 1 - labsp[i], "lines") + -1 * offset_varnames[4], y = unit(-0.5, "lines"), just = "right", rot = 90, gp = gp_varnames[[4]]) } else { grid.text(var, x = unit(lsp - 1 - labsp[i], "lines") + -1 * offset_varnames[4], y = unit(1, "npc") + unit(0.5, "lines"), just = "left", rot = 90, gp = gp_varnames[[2]]) } } else { if (labbl_varnames[i]) { grid.text(var, x = unit(1, "npc") + unit(labsp[i], "lines") + offset_varnames[2], y = unit(-0.5, "lines"), just = "right", rot = 90, gp = gp_varnames[[4]]) } else { grid.text(var, x = unit(1, "npc") + unit(labsp[i], "lines") + offset_varnames[2], y = unit(1, "npc") + unit(0.5, "lines"), just = "left", rot = 90, gp = gp_varnames[[2]]) } } } } } } ## draw labels split <- function(vind = 1, root = paste(prefix, "cell:", sep = ""), left = TRUE, right = TRUE, top = TRUE, bottom = TRUE) { n <- d[[vind]] vl <- length(n) sp <- split_vertical[vind] labseq <- seq_along(n) if (!sp) labseq <- rev(labseq) for (labind in labseq) { mlab <- paste(root, dn[vind], "=", n[labind], sep = "") if (labels[vind] && (rep[vind] || !printed[[vind]][labind])) { lab <- if (!is.null(set_labels) && !is.null(set_labels[[dn[vind]]])) set_labels[[dn[vind]]][labind] else labs[[vind]][labind] if (labels_varnames[vind]) lab <- if (!is.null(set_varnames) && !is.na(set_varnames[dn[vind]])) paste(set_varnames[dn[vind]], lab, sep = sep) else paste(dn[vind], lab, sep = sep) if (sp) { if (tl_labels[vind]) { if (top) { seekViewport(mlab) if (clip[vind]) pushViewport(viewport(height = unit(1, "npc") + 2 * offset_labels[1] + unit(2 * (2 + tsp - labsp[vind]), "lines"), clip = "on")) if (boxes[vind]) grid.rect(height = unit(0.8, "lines"), y = unit(1, "npc") + offset_labels[1] + unit(1 + tsp - labsp[vind] - (2 + as.numeric(offset_labels[1]) + tsp - labsp[vind]) * clip[vind], "lines"), gp = gpar(fill = fill_boxes[[vind]][labind])) grid.text(lab, y = unit(1, "npc") + offset_labels[1] + unit(1 + tsp - labsp[vind] - (2 + as.numeric(offset_labels[1]) + tsp - labsp[vind]) * clip[vind], "lines"), x = unit(0.15 * switch(pos_labels[1], left =, bottom = 1, center =, centre = 0, -1) * boxes[vind], "lines") + unit(switch(pos_labels[1], left =, bottom = 0, center =, centre = 0.5, 1), "npc"), rot = rot_labels[1], just = just_labels[1], gp = gp_labels[[vind]]) if (clip[vind]) popViewport() printed[[vind]][labind] <<- TRUE } } else { if (bottom) { seekViewport(mlab) if (clip[vind]) pushViewport(viewport(height = unit(1, "npc") + 2 * offset_labels[3] + unit(2 * (1 + abs(labsp[vind])), "lines"), clip = "on")) ### if (boxes[vind]) grid.rect(height = unit(0.8, "lines"), y = -1 * offset_labels[3] + unit(labsp[vind] + (1 + as.numeric(offset_labels[3]) + abs(labsp[vind])) * clip[vind], "lines"), gp = gpar(fill = fill_boxes[[vind]][labind])) grid.text(lab, y = -1 * offset_labels[3] + unit(labsp[vind] + (1 + as.numeric(offset_labels[3]) + abs(labsp[vind])) * clip[vind], "lines"), x = unit(0.15 * switch(pos_labels[3], left =, bottom = 1, center =, centre = 0, -1) * boxes[vind], "lines") + unit(switch(pos_labels[3], left =, bottom = 0, center =, centre = 0.5, 1), "npc"), rot = rot_labels[3], just = just_labels[3], gp = gp_labels[[vind]]) if (clip[vind]) popViewport() printed[[vind]][labind] <<- TRUE } } } else { if (tl_labels[vind]) { if (left) { seekViewport(mlab) if (clip[vind]) pushViewport(viewport(width = unit(1, "npc") + 2 * offset_labels[4] + unit(2 * (2 - lsp + labsp[vind]), "lines"), clip = "on")) if (boxes[vind]) grid.rect(width = unit(0.8, "lines"), x = -1 * offset_labels[4] + unit(lsp - 1 - labsp[vind] + (2 - lsp + as.numeric(offset_labels[4]) + labsp[vind]) * clip[vind], "lines"), gp = gpar(fill = fill_boxes[[vind]][labind])) grid.text(lab, x = -1 * offset_labels[4] + unit(lsp - 1 - labsp[vind] + (2 - lsp + as.numeric(offset_labels[4]) + labsp[vind]) * clip[vind], "lines"), y = unit(0.15 * switch(pos_labels[4], left =, bottom = 1, centre = 0, -1) * boxes[vind], "lines") + unit(switch(pos_labels[4], left =, bottom = 0, center =, centre = 0.5, 1), "npc"), rot = rot_labels[4], just = just_labels[4], gp = gp_labels[[vind]]) if (clip[vind]) popViewport() printed[[vind]][labind] <<- TRUE } } else { if (right) { seekViewport(mlab) if (clip[vind]) pushViewport(viewport(width = unit(1, "npc") + 2 * offset_labels[2] + unit(2 * (1 + abs(labsp[vind])), "lines"), clip = "on")) if (boxes[vind]) grid.rect(width = unit(0.8, "lines"), x = offset_labels[2] + unit(1, "npc") + unit(labsp[vind] - (1 + as.numeric(offset_labels[2]) + abs(labsp[vind])) * clip[vind], "lines"), gp = gpar(fill = fill_boxes[[vind]][labind])) grid.text(lab, x = offset_labels[2] + unit(1, "npc") + unit(0.1, "lines") + unit(labsp[vind] - (1 + as.numeric(offset_labels[2]) + abs(labsp[vind])) * clip[vind], "lines"), y = unit(0.15 * switch(pos_labels[2], left =, bottom = 1, center =, centre = 0, -1) * boxes[vind], "lines") + unit(switch(pos_labels[2], left =, bottom = 0, center =, centre = 0.5, 1), "npc"), rot = rot_labels[2], just = just_labels[2], gp = gp_labels[[vind]]) if (clip[vind]) popViewport() printed[[vind]][labind] <<- TRUE } } } } if (vind < ld) Recall(vind + 1, paste(mlab, ",", sep = ""), if (sp) left && labind == 1 else left, if (sp) right && labind == vl else right, if (!sp) top && labind == 1 else top, if (!sp) bottom && labind == vl else bottom) } } ## patch for alternating labels, part 1 if (any(alternate_labels)) { ## save set_labels set_labels_hold <- set_labels ## create vanilla set_labels-object set_labels <- d ## copy old set_labels if (!is.null(set_labels_hold)) set_labels[names(set_labels_hold)] <- set_labels_hold ## mask half of the labels for (i in which(alternate_labels)) if (length(d[[i]]) > 1) set_labels[[i]][seq(2, length(d[[i]]), 2)] <- "" } split() ## patch for alternating labels, part 2 if (any(alternate_labels)) { ## create again vanilla set_labels-object set_labels <- d ## copy again old set_labels if (!is.null(set_labels_hold)) set_labels[names(set_labels_hold)] <- set_labels_hold ## clear all non-alternated labels labels[!alternate_labels] <- FALSE ## mask other half of alternated labels for (i in which(alternate_labels)) set_labels[[i]][seq(1, length(d[[i]]), 2)] <- "" ## invert tl_labels and labsp tl_labels <- ! tl_labels labsp <- -labsp ## label again split() } seekViewport(paste(prefix, "base", sep = "")) upViewport(1) } } class(labeling_border) <- "grapcon_generator" labeling_doubledecker <- function(lab_pos = c("bottom", "top"), dep_varname = TRUE, boxes = NULL, clip = NULL, labbl_varnames = FALSE, rot_labels = rep.int(0, 4), pos_labels = c("left", "center", "left", "center"), just_labels = c("left", "left", "left", "center"), varnames = NULL, gp_varnames = gpar(fontsize = 12, fontface = 2), offset_varnames = c(0, -0.6, 0, 0), tl_labels = NULL, ...) { lab_pos <- match.arg(lab_pos) if (inherits(gp_varnames, "gpar")) gp_varnames <- list(gp_varnames) gp_varnames <- pexpand(gp_varnames, 4, list(gpar(fontsize = 12, fontface = 2)), c("top", "right", "bottom", "left")) function(d, split_vertical, condvars, prefix = "") { if (is.table(d) || is.structable(d)) d <- dimnames(d) ld <- length(d) dn <- names(d) ## expand dimension parameters boxes <- pexpand(boxes, ld, c(rep.int(TRUE, ld - 1), FALSE), dn) clip <- pexpand(clip, ld, c(rep.int(TRUE, ld - 1), FALSE), dn) varnames <- pexpand(varnames, ld, c(rep.int(TRUE, ld - 1), FALSE), dn) tl_labels <- pexpand(tl_labels, ld, c(rep.int(lab_pos == "top", ld - 1), FALSE), dn) if (!is.null(labbl_varnames)) labbl_varnames <- pexpand(labbl_varnames, ld, FALSE, dn) ## expand side parameters rot_labels <- pexpand(rot_labels, 4, c(0, 0, 0, 0), c("top", "right", "bottom", "left")) pos_labels <- pexpand(pos_labels, 4, c("left", "center", "left", "center"), c("top", "right", "bottom", "left"), c("left", "center", "right")) just_labels <- pexpand(just_labels, 4, c("left", "left", "left", "center"), c("top", "right", "bottom", "left"), c("left", "center", "right")) offset_varnames <- if (!is.unit(offset_varnames)) unit(pexpand(offset_varnames, 4, c(0, -0.6, 0, 0), c("top","right","bottom","left")), "lines") else rep(offset_varnames, length.out = 4) labeling_border(boxes = boxes, clip = clip, labbl_varnames = labbl_varnames, rot_labels = rot_labels, pos_labels = pos_labels, just_labels = just_labels, varnames = varnames, gp_varnames = gp_varnames, offset_varnames = offset_varnames, tl_labels = tl_labels, ... )(d, split_vertical, condvars, prefix) if (!(is.logical(dep_varname) && !dep_varname)) { if (is.null(dep_varname) || is.logical(dep_varname)) dep_varname <- names(d)[length(d)] seekViewport(paste(prefix, "margin_right", sep = "")) grid.text(dep_varname, x = unit(0.5, "lines"), y = unit(1, "npc"), just = c("left","top"), gp = gp_varnames[[2]]) } } } class(labeling_doubledecker) <- "grapcon_generator" labeling_left <- function(rep = FALSE, pos_varnames = "left", pos_labels = "left", just_labels = "left", ...) labeling_border(rep = rep, pos_varnames = pos_varnames, pos_labels = pos_labels, just_labels = just_labels, ...) class(labeling_left) <- "grapcon_generator" labeling_left2 <- function(tl_labels = TRUE, clip = TRUE, pos_varnames = "left", pos_labels = "left", just_labels = "left", ...) labeling_border(tl_labels = tl_labels, clip = clip, pos_varnames = pos_varnames, pos_labels = pos_labels, just_labels = just_labels, ...) class(labeling_left2) <- "grapcon_generator" labeling_cboxed <- function(tl_labels = TRUE, boxes = TRUE, clip = TRUE, pos_labels = "center", ...) labeling_border(tl_labels = tl_labels, boxes = boxes, clip = clip, pos_labels = pos_labels, ...) class(labeling_cboxed) <- "grapcon_generator" labeling_lboxed <- function(tl_labels = FALSE, boxes = TRUE, clip = TRUE, pos_labels = "left", just_labels = "left", labbl_varnames = FALSE, ...) labeling_border(tl_labels = tl_labels, boxes = boxes, clip = clip, pos_labels = pos_labels, labbl_varnames = labbl_varnames, just_labels = just_labels, ...) class(labeling_lboxed) <- "grapcon_generator" labeling_values <- function(value_type = c("observed", "expected", "residuals"), suppress = NULL, digits = 1, clip_cells = FALSE, ...) { value_type <- match.arg(value_type) if (value_type == "residuals" && is.null(suppress)) suppress <- 2 if (is.null(suppress)) suppress <- 0 if (length(suppress) == 1) suppress <- c(-suppress, suppress) function(d, split_vertical, condvars, prefix) { lookup <- if (value_type == "observed") "x" else value_type if (!exists(lookup, envir = parent.frame())) stop(paste("Could not find", dQuote(value_type), "object.")) values <- get(lookup, envir = parent.frame()) values <- ifelse((values > suppress[2]) | (values < suppress[1]), round(values, digits), NA) labeling_border(...)(d, split_vertical, condvars, prefix) labeling_cells(text = values, clip_cells = clip_cells, ...)(d, split_vertical, condvars, prefix) } } class(labeling_values) <- "grapcon_generator" labeling_residuals <- function(suppress = NULL, digits = 1, clip_cells = FALSE, ...) labeling_values(value_type = "residuals", suppress = suppress, digits = digits, clip_cells = clip_cells, ...) class(labeling_residuals) <- "grapcon_generator" vcd/R/cd_plot.R0000755000175100001440000000705012445057350013026 0ustar hornikuserscd_plot <- function(x, ...) { UseMethod("cd_plot") } cd_plot.formula <- function(formula, data = list(), plot = TRUE, ylab_tol = 0.05, bw = "nrd0", n = 512, from = NULL, to = NULL, main = "", xlab = NULL, ylab = NULL, margins = c(5.1, 4.1, 4.1, 3.1), gp = gpar(), name = "cd_plot", newpage = TRUE, pop = TRUE, return_grob = FALSE, ...) { ## extract x, y from formula mf <- model.frame(formula, data = data) if(NCOL(mf) != 2) stop("`formula' should specify exactly two variables") y <- mf[,1] if(!is.factor(y)) stop("dependent variable should be a factor") x <- mf[,2] if(!is.numeric(x)) stop("explanatory variable should be numeric") ## graphical parameters if(is.null(xlab)) xlab <- names(mf)[2] if(is.null(ylab)) ylab <- names(mf)[1] ## call default interface cd_plot(x, y, plot = plot, ylab_tol = ylab_tol, bw = bw, n = n, from = from, to = to, main = main, xlab = xlab, ylab = ylab, margins = margins, gp = gp, name = name, newpage = newpage, pop = pop, ...) } cd_plot.default <- function(x, y, plot = TRUE, ylab_tol = 0.05, bw = "nrd0", n = 512, from = NULL, to = NULL, main = "", xlab = NULL, ylab = NULL, margins = c(5.1, 4.1, 4.1, 3.1), gp = gpar(), name = "cd_plot", newpage = TRUE, pop = TRUE, return_grob = FALSE, ...) { ## check x and y if(!is.numeric(x)) stop("explanatory variable should be numeric") if(!is.factor(y)) stop("dependent variable should be a factor") ny <- length(levels(y)) ## graphical parameters if(is.null(xlab)) xlab <- deparse(substitute(x)) if(is.null(ylab)) ylab <- deparse(substitute(y)) if(is.null(gp$fill)) gp$fill <- gray.colors(ny) gp$fill <- rep(gp$fill, length.out = ny) ## unconditional density of x dx <- if(is.null(from) & is.null(to)) density(x, bw = bw, n = n, ...) else density(x, bw = bw, from = from, to = to, n = n, ...) x1 <- dx$x ## setup conditional values yprop <- cumsum(prop.table(table(y))) y1 <- matrix(rep(0, n*(ny-1)), nrow = (ny-1)) ## setup return value rval <- list() for(i in 1:(ny-1)) { dxi <- density(x[y %in% levels(y)[1:i]], bw = dx$bw, n = n, from = min(dx$x), to = max(dx$x), ...) y1[i,] <- dxi$y/dx$y * yprop[i] rval[[i]] <- approxfun(x1, y1[i,], rule = 2) } names(rval) <- levels(y)[1:(ny-1)] ## use known ranges y1 <- rbind(0, y1, 1) y1 <- y1[,which(x1 >= min(x) & x1 <= max(x))] x1 <- x1[x1 >= min(x) & x1 <= max(x)] ## plot polygons if(plot) { ## setup if(newpage) grid.newpage() pushViewport(plotViewport(xscale = range(x1), yscale = c(0, 1), default.units = "native", name = name, margins = margins, ...)) ## polygons for(i in 1:(NROW(y1)-1)) { gpi <- gp gpi$fill <- gp$fill[i] grid.polygon(x = c(x1, rev(x1)), y = c(y1[i+1,], rev(y1[i,])), default.units = "native", gp = gpi) } ## axes grid.rect(gp = gpar(fill = "transparent")) grid.xaxis() grid.yaxis(main = FALSE) equidist <- any(diff(y1[,1]) < ylab_tol) yat <- if(equidist) seq(1/(2*ny), 1-1/(2*ny), by = 1/ny) else (y1[-1,1] + y1[-NROW(y1), 1])/2 grid.text(x = unit(-1.5, "lines"), y = unit(yat, "native"), label = levels(y), rot = 90, check.overlap = TRUE) ## annotation grid.text(xlab, y = unit(-3.5, "lines")) grid.text(ylab, x = unit(-3, "lines"), rot = 90) grid.text(main, y = unit(1, "npc") + unit(2, "lines"), gp = gpar(fontface = "bold")) ## pop if(pop) popViewport() } ## return conditional density functions if (plot && return_grob) invisible(structure(rval, grob = grid.grab())) else invisible(rval) } vcd/R/pairsplot.R0000644000175100001440000002146014543516074013421 0ustar hornikusers################################################################# ### pairsplot ## modified, 2-14-2014, MF: fix expected values for type= pairs.table <- function(x, upper_panel = pairs_mosaic, upper_panel_args = list(), lower_panel = pairs_mosaic, lower_panel_args = list(), diag_panel = pairs_diagonal_mosaic, diag_panel_args = list(), main = NULL, sub = NULL, main_gp = gpar(fontsize = 20), sub_gp = gpar(fontsize = 15), space = 0.3, newpage = TRUE, pop = TRUE, return_grob = FALSE, margins = unit(1, "lines"), ...) { if (newpage) grid.newpage() if (inherits(upper_panel, "grapcon_generator")) upper_panel <- do.call("upper_panel", c(upper_panel_args, list(...))) if (inherits(lower_panel, "grapcon_generator")) lower_panel <- do.call("lower_panel", c(lower_panel_args, list(...))) if (inherits(diag_panel, "grapcon_generator")) diag_panel <- do.call("diag_panel", diag_panel_args) d <- length(dim(x)) l <- grid.layout(d, d) pushViewport(viewport(width = unit(1, "snpc"), height = unit(1, "snpc"))) pushViewport(vcdViewport(mar = margins, legend = FALSE, legend_width = NULL, main = !is.null(main), sub = !is.null(sub))) ## titles if (!is.null(main)) { seekViewport("main") if (is.logical(main) && main) main <- deparse(substitute(x)) grid.text(main, gp = main_gp) } if (!is.null(sub)) { seekViewport("sub") if (is.logical(sub) && sub && is.null(main)) sub <- deparse(substitute(x)) grid.text(sub, gp = sub_gp) } seekViewport("plot") pushViewport(viewport(layout = l, y = 0, just = "bottom")) for (i in 1:d) for(j in 1:d) { pushViewport(viewport(layout.pos.col = i, layout.pos.row = j)) pushViewport(viewport(width = 1 - space, height = 1 - space)) if (i > j) { if (!is.null(upper_panel)) upper_panel(x, j, i) } else if (i < j) { if (!is.null(lower_panel)) lower_panel(x, j, i) } else if (!is.null(diag_panel)) diag_panel(x, i) if (pop) popViewport(2) else upViewport(2) } if (pop) popViewport(3) else upViewport(3) if (return_grob) invisible(structure(x, grob = grid.grab())) else invisible(x) } pairs.structable <- function(x, ...) pairs(as.table(x), ...) ## upper/lower panels pairs_assoc <- function(...) pairs_strucplot(panel = assoc, ...) class(pairs_assoc) <- "grapcon_generator" pairs_mosaic <- function(...) pairs_strucplot(panel = mosaic, ...) class(pairs_mosaic) <- "grapcon_generator" pairs_sieve <- function(...) pairs_strucplot(panel = sieve, ...) class(pairs_sieve) <- "grapcon_generator" pairs_strucplot <- function(panel = mosaic, type = c("pairwise", "total", "conditional", "joint"), legend = FALSE, margins = c(0, 0, 0, 0), labeling = NULL, ...) { type = match.arg(type) function(x, i, j) { index <- 1:length(dim(x)) rest <- index[!index %in% c(i, j)] rest2 <- index[!index %in% 1:2] tl <- tail(index, 2) rest3 <- index[!index %in% tl] expected <- switch(type, joint = list(1:2, rest2), conditional = list(c(tl[1], rest3), c(tl[2], rest3)), total = sapply(c(j, i, rest), list), NULL) margin <- switch(type, pairwise = c(j, i), conditional = c(rest, j, i), c(j, i, rest)) panel(x = margin.table(x, margin), expected = expected, labeling = labeling, margins = margins, legend = legend, split_vertical = TRUE, newpage = FALSE, pop = FALSE, prefix = paste("panel:Y=",names(dimnames(x))[i],",X=", names(dimnames(x))[j],"|",sep = ""), ...) } } class(pairs_strucplot) <- "grapcon_generator" ## diagonal panels pairs_text <- function(dimnames = TRUE, gp_vartext = gpar(fontsize = 17), gp_leveltext = gpar(), gp_border = gpar(), ...) function(x, i) { x <- margin.table(x, i) grid.rect(gp = gp_border) grid.text(names(dimnames(x)), gp = gp_vartext, y = 0.5 + dimnames * 0.05, ...) if (dimnames) grid.text(paste("(",paste(names(x), collapse = ","), ")", sep = ""), y = 0.4, gp = gp_leveltext) } class(pairs_text) <- "grapcon_generator" pairs_diagonal_text <- function(varnames = TRUE, gp_vartext = gpar(fontsize = 17, fontface = "bold"), gp_leveltext = gpar(), gp_border = gpar(), pos = c("right","top"), distribute = c("equal","margin"), rot = 0, ...) { xc <- unit(switch(pos[1], left = 0.1, center = 0.5, 0.9), "npc") yc <- unit(switch(pos[2], top = 0.9, center = 0.5, 0.1), "npc") distribute <- match.arg(distribute) function(x, i) { x <- margin.table(x, i) grid.rect(gp = gp_border) if (varnames) grid.text(names(dimnames(x)), gp = gp_vartext, x = xc, y = yc, just = pos, ...) l <- length(dimnames(x)[[1]]) po <- if (distribute == "equal") unit(cumsum(rep(1 / (l + 1), l)), "npc") else { sizes = prop.table(x) unit(cumsum(c(0,sizes))[1:l] + sizes / 2, "npc") } grid.text(dimnames(x)[[1]], x = po, y = unit(1, "npc") - po, gp = gp_leveltext, rot = rot) } } class(pairs_diagonal_text) <- "grapcon_generator" pairs_barplot <- function(gp_bars = NULL, gp_vartext = gpar(fontsize = 17), gp_leveltext = gpar(), gp_axis = gpar(), just_leveltext = c("center", "bottom"), just_vartext = c("center", "top"), rot = 0, abbreviate = FALSE, check_overlap = TRUE, fill = "grey", var_offset = unit(1, "npc"), ...) function(x, i) { if (!is.unit(var_offset)) var_offset <- unit(var_offset, "npc") dn <- names(dimnames(x)) x <- margin.table(x, i) if (is.function(fill)) fill <- rev(fill(dim(x))) if (is.null(gp_bars)) gp_bars <- gpar(fill = fill) pushViewport(viewport(x = 0.3, y = 0.1, width = 0.7, height = 0.7, yscale = c(0,max(x)), just = c("left", "bottom")) ) xpos <- seq(0, 1, length.out = length(x) + 1)[-1] halfstep <- (xpos[2] - xpos[1]) / 2 grid.rect(xpos - halfstep, rep.int(0, length(x)), height = x, just = c("center", "bottom"), width = halfstep, gp = gp_bars, default.units = "native", name = paste("panel:diag=", dn[i], "|bars", sep = ""), ...) grid.yaxis(at = pretty(c(0,max(x))), gp = gp_axis) txt <- names(x) if (abbreviate) txt <- abbreviate(txt, abbreviate) grid.text(txt, y = unit(-0.15, "npc"), rot = rot, x = xpos - halfstep, just = just_leveltext, gp = gp_leveltext, check.overlap = check_overlap) popViewport(1) grid.text(names(dimnames(x)), y = var_offset, just = just_vartext, gp = gp_vartext) } class(pairs_barplot) <- "grapcon_generator" pairs_diagonal_mosaic <- function(split_vertical = TRUE, margins = unit(0, "lines"), offset_labels = -0.4, offset_varnames = 0, gp = NULL, fill = "grey", labeling = labeling_values, alternate_labels = TRUE, ...) function(x, i) { if (is.function(fill)) fill <- rev(fill(dim(x)[i])) if (is.null(gp)) gp <- gpar(fill = fill) mosaic(margin.table(x, i), newpage = FALSE, split_vertical = split_vertical, margins = margins, offset_labels = offset_labels, offset_varnames = offset_varnames, prefix = "diag", gp = gp, labeling = labeling_values, labeling_args = list(alternate_labels = TRUE), ...) } class(pairs_diagonal_mosaic) <- "grapcon_generator" vcd/R/distplot.R0000755000175100001440000001365012610700530013234 0ustar hornikusers# added lwd arg, changed default point sizes distplot <- function(x, type = c("poisson", "binomial", "nbinomial"), size = NULL, lambda = NULL, legend = TRUE, xlim = NULL, ylim = NULL, conf_int = TRUE, conf_level = 0.95, main = NULL, xlab = "Number of occurrences", ylab = "Distribution metameter", gp = gpar(cex = 0.8), lwd=2, gp_conf_int = gpar(lty = 2), name = "distplot", newpage = TRUE, pop = TRUE, return_grob = FALSE, ...) { if(is.vector(x)) { x <- table(x) } if(is.table(x)) { if(length(dim(x)) > 1) stop ("x must be a 1-way table") freq <- as.vector(x) count <- as.numeric(names(x)) } else { if(!(!is.null(ncol(x)) && ncol(x) == 2)) stop("x must be a 2-column matrix or data.frame") freq <- as.vector(x[,1]) count <- as.vector(x[,2]) } myindex <- (1:length(freq))[freq > 0] mycount <- count[myindex] myfreq <- freq[myindex] switch(match.arg(type), "poisson" = { par.ml <- suppressWarnings(goodfit(x, type = type)$par$lambda) phi <- function(nk, k, N, size = NULL) ifelse(nk > 0, lgamma(k + 1) + log(nk/N), NA) y <- phi(myfreq, mycount, sum(freq)) if(!is.null(lambda)) y <- y + lambda - mycount * log(lambda) fm <- lm(y ~ mycount) par.estim <- exp(coef(fm)[2]) names(par.estim) <- "lambda" txt <- "exp(slope)" if(!is.null(lambda)) { par.estim <- par.estim * lambda txt <- paste(txt, "x lambda") } legend.text <- paste(txt, "=", round(par.estim, digits = 3)) if(is.null(main)) main <- "Poissoness plot" }, "binomial" = { if(is.null(size)) { size <- max(count) warning("size was not given, taken as maximum count") } par.ml <- suppressWarnings(goodfit(x, type = type, par = list(size = size))$par$prob) phi <- function(nk, k, N, size = NULL) log(nk) - log(N * choose(size, k)) y <- phi(myfreq, mycount, sum(freq), size = size) fm <- lm(y ~ mycount) par.estim <- exp(coef(fm)[2]) par.estim <- par.estim / (1 + par.estim) names(par.estim) <- "prob" legend.text <- paste("inv.logit(slope) =", round(par.estim, digits = 3)) if(is.null(main)) main <- "Binomialness plot" }, "nbinomial" = { if(is.null(size)) { par.ml <- suppressWarnings(goodfit(x, type = type)$par) size <- par.ml$size par.ml <- par.ml$prob }else{ xbar <- weighted.mean(mycount, myfreq) par.ml <- size / (size+xbar) } phi <- function(nk, k, N, size = NULL) log(nk) - log(N * choose(size + k - 1, k)) y <- phi(myfreq, mycount, sum(freq), size = size) fm <- lm(y ~ mycount) par.estim <- 1 - exp(coef(fm)[2]) names(par.estim) <- "prob" legend.text <- paste("1-exp(slope) =", round(par.estim, digits = 3)) if(is.null(main)) main <- "Negative binomialness plot" }) yhat <- ifelse(myfreq > 1.5, myfreq - 0.67, 1/exp(1)) yhat <- phi(yhat, mycount, sum(freq), size = size) if(!is.null(lambda)) yhat <- yhat + lambda - mycount * log(lambda) phat <- myfreq / sum(myfreq) ci.width <- qnorm(1-(1 - conf_level)/2) * sqrt(1-phat)/sqrt(myfreq - (0.25 * phat + 0.47)*sqrt(myfreq)) RVAL <- cbind(count, freq, NA, NA, NA, NA, NA) RVAL[myindex,3:7] <- cbind(y,yhat,ci.width, yhat-ci.width, yhat + ci.width) RVAL <- as.data.frame(RVAL) names(RVAL) <- c("Counts", "Freq", "Metameter", "CI.center", "CI.width", "CI.lower", "CI.upper") if(is.null(xlim)) xlim <- range(RVAL[,1]) if(is.null(ylim)) ylim <- range(RVAL[,c(3,6,7)], na.rm = TRUE) xlim <- xlim + c(-1, 1) * diff(xlim) * 0.04 ylim <- ylim + c(-1, 1) * diff(ylim) * 0.04 if(newpage) grid.newpage() pushViewport(plotViewport(xscale = xlim, yscale = ylim, default.units = "native", name = name)) grid.points(x = RVAL[,1], y = RVAL[,3], default.units = "native", gp = gp, ...) grid.lines(x = xlim, y = predict(fm, newdata = data.frame(mycount = xlim)), default.units = "native", gp = gpar(lwd=lwd, col = 2)) grid.rect(gp = gpar(fill = "transparent")) grid.xaxis() grid.yaxis() grid.text(xlab, y = unit(-3.5, "lines")) grid.text(ylab, x = unit(-3, "lines"), rot = 90) grid.text(main, y = unit(1, "npc") + unit(2, "lines"), gp = gpar(fontface = "bold")) if(conf_int) { grid.points(x = RVAL[,1], y = RVAL[,4], pch = 19, gp = gpar(cex = 0.5)) grid.segments(RVAL[,1], RVAL[,6], RVAL[,1], RVAL[,7], default.units = "native", gp = gp_conf_int) } if(legend) { mymin <- which.min(RVAL[,5]) leg.x <- RVAL[mymin,1] if(RVAL[mymin,6] - ylim[1] > ylim[2] - RVAL[mymin,7]) leg.y <- ylim[1] + 0.7 * (RVAL[mymin,6] - ylim[1]) else leg.y <- ylim[2] legend.text <- c(paste("slope =", round(coef(fm)[2], digits = 3)), paste("intercept =", round(coef(fm)[1], digits = 3)), "", paste(names(par.estim),": ML =", round(par.ml, digits=3)), legend.text) legend.text <- paste(legend.text, collapse = "\n") grid.text(legend.text, leg.x, leg.y - 0.05 * abs(leg.y), default.units = "native", just = c("left", "top")) } if(pop) popViewport() else upViewport() if (return_grob) structure(invisible(RVAL), grob = grid.grab()) else invisible(RVAL) } vcd/R/spine.R0000755000175100001440000001077211150520606012514 0ustar hornikusersspine <- function(x, ...) UseMethod("spine") spine.formula <- function(formula, data = list(), breaks = NULL, ylab_tol = 0.05, off = NULL, main = "", xlab = NULL, ylab = NULL, ylim = c(0, 1), margins = c(5.1, 4.1, 4.1, 3.1), gp = gpar(), name = "spineplot", newpage = TRUE, pop = TRUE, ...) { ## extract x, y from formula mf <- model.frame(formula, data = data) if(NCOL(mf) != 2) stop("`formula' should specify exactly two variables") y <- mf[,1] if(!is.factor(y)) stop("dependent variable should be a factor") x <- mf[,2] if(is.null(xlab)) xlab <- names(mf)[2] if(is.null(ylab)) ylab <- names(mf)[1] spine(x, y, breaks = breaks, ylab_tol = ylab_tol, off = off, main = main, xlab = xlab, ylab = ylab, ylim = ylim, margins = margins, gp = gp, name = name, newpage = newpage, pop = pop, ...) } spine.default <- function(x, y = NULL, breaks = NULL, ylab_tol = 0.05, off = NULL, main = "", xlab = NULL, ylab = NULL, ylim = c(0, 1), margins = c(5.1, 4.1, 4.1, 3.1), gp = gpar(), name = "spineplot", newpage = TRUE, pop = TRUE, ...) { ## either supply a 2-way table (i.e., both y and x are categorical) ## or two variables (y has to be categorical - x can be categorical or numerical) if(missing(y)) { if(length(dim(x)) != 2) stop("a 2-way table has to be specified") tab <- x x.categorical <- TRUE if(is.null(xlab)) xlab <- names(dimnames(tab))[1] if(is.null(ylab)) ylab <- names(dimnames(tab))[2] xnam <- dimnames(tab)[[1]] ynam <- dimnames(tab)[[2]] ny <- NCOL(tab) nx <- NROW(tab) } else { if(!is.factor(y)) stop("dependent variable should be a factor") x.categorical <- is.factor(x) if(!x.categorical) stopifnot(is.numeric(x), is.vector(x)) if(is.null(xlab)) xlab <- deparse(substitute(x)) if(is.null(ylab)) ylab <- deparse(substitute(y)) if(x.categorical) { tab <- table(x, y) xnam <- levels(x) nx <- NROW(tab) } ynam <- levels(y) ny <- length(ynam) } ## graphical parameters if(is.null(gp$fill)) gp$fill <- gray.colors(ny) gp$fill <- rep(gp$fill, length.out = ny) off <- if(!x.categorical) 0 else if(is.null(off)) 0.02 else off/100 if(x.categorical) { ## compute rectangle positions on x axis xat <- c(0, cumsum(prop.table(margin.table(tab, 1)) + off)) } else { ## compute breaks for x if(is.null(breaks)) breaks <- list() if(!is.list(breaks)) breaks <- list(breaks = breaks) breaks <- c(list(x = x), breaks) breaks$plot <- FALSE breaks <- do.call("hist", breaks)$breaks ## categorize x x1 <- cut(x, breaks = breaks, include.lowest = TRUE) ## compute rectangle positions on x axis xat <- c(0, cumsum(prop.table(table(x1)))) ## construct table tab <- table(x1, y) nx <- NROW(tab) } ## compute rectangle positions on y axis yat <- rbind(0, apply(prop.table(tab, 1), 1, cumsum)) ## setup plot if(newpage) grid.newpage() pushViewport(plotViewport(xscale = c(0, 1 + off * (nx-1)), yscale = ylim, default.units = "native", name = name, margins = margins, ...)) ## compute coordinates ybottom <- as.vector(yat[-(ny+1),]) ybottom[ybottom < ylim[1]] <- ylim[1] ybottom[ybottom > ylim[2]] <- ylim[2] ytop <- as.vector(yat[-1,]) ytop[ytop < ylim[1]] <- ylim[1] ytop[ytop > ylim[2]] <- ylim[2] xleft <- rep(xat[1:nx], rep(ny, nx)) xright <- rep(xat[2:(nx+1)] - off, rep(ny, nx)) gp$fill <- rep(gp$fill, nx) ## plot rectangles grid.rect(xleft, ybottom, width = (xright-xleft), height = (ytop-ybottom), just = c("left", "bottom"), default.units = "native", gp = gp) ## axes ## 1: either numeric or level names if(x.categorical) grid.text(x = unit((xat[1:nx] + xat[2:(nx+1)] - off)/2, "native"), y = unit(-1.5, "lines"), label = xnam, check.overlap = TRUE) else grid.xaxis(at = xat, label = breaks) ## 2: axis with level names of y yat <- yat[,1] equidist <- any(diff(yat) < ylab_tol) yat <- if(equidist) seq(1/(2*ny), 1-1/(2*ny), by = 1/ny) else (yat[-1] + yat[-length(yat)])/2 grid.text(x = unit(-1.5, "lines"), y = unit(yat, "native"), label = ynam, rot = 90, check.overlap = TRUE) ## 3: none ## 4: simple numeric grid.yaxis(main = FALSE) ## annotation grid.text(xlab, y = unit(-3.5, "lines")) grid.text(ylab, x = unit(-3, "lines"), rot = 90) grid.text(main, y = unit(1, "npc") + unit(2, "lines"), gp = gpar(fontface = "bold")) ## pop if(pop) popViewport() ## return table visualized names(dimnames(tab)) <- c(xlab, ylab) invisible(tab) } vcd/R/ternaryplot.R0000755000175100001440000001143513210517341013757 0ustar hornikusers"ternaryplot" <- function (x, scale = 1, dimnames = NULL, dimnames_position = c("corner", "edge", "none"), dimnames_color = "black", dimnames_rot = c(-60, 60, 0), id = NULL, id_color = "black", id_just = c("center", "center"), coordinates = FALSE, grid = TRUE, grid_color = "gray", labels = c("inside", "outside", "none"), labels_color = "darkgray", labels_rot = c(120, -120, 0), border = "black", bg = "white", pch = 19, cex = 1, prop_size = FALSE, col = "red", main = "ternary plot", newpage = TRUE, pop = TRUE, return_grob = FALSE, ...) { ## parameter handling labels <- match.arg(labels) if (grid == TRUE) grid <- "dotted" if (coordinates) id <- paste("(",round(x[,1] * scale, 1),",", round(x[,2] * scale, 1),",", round(x[,3] * scale, 1),")", sep="") dimnames_position <- match.arg(dimnames_position) if(is.null(dimnames) && dimnames_position != "none") dimnames <- colnames(x) if(is.logical(prop_size) && prop_size) prop_size <- 3 ## some error handling if(ncol(x) != 3) stop("Need a matrix with 3 columns") if(any(x < 0)) stop("X must be non-negative") s <- rowSums(x) if(any(s <= 0)) stop("each row of X must have a positive sum") ## rescaling x <- x / s ## prepare plot top <- sqrt(3) / 2 if (newpage) grid.newpage() xlim <- c(-0.03, 1.03) ylim <- c(-1, top) pushViewport(viewport(width = unit(1, "snpc"))) if (!is.null(main)) grid.text(main, y = 0.9, gp = gpar(fontsize = 18, fontstyle = 1)) pushViewport(viewport(width = 0.8, height = 0.8, xscale = xlim, yscale = ylim, name = "plot")) eps <- 0.01 ## coordinates of point P(a,b,c): xp = b + c/2, yp = c * sqrt(3)/2 ## triangle grid.polygon(c(0, 0.5, 1), c(0, top, 0), gp = gpar(fill = bg, col = border), ...) ## title, labeling if (dimnames_position == "corner") { grid.text(x = c(0, 1, 0.5), y = c(-0.02, -0.02, top + 0.02), label = dimnames, gp = gpar(fontsize = 12)) } if (dimnames_position == "edge") { shift <- eps * if (labels == "outside") 8 else 0 grid.text(x = 0.25 - 2 * eps - shift, y = 0.5 * top + shift, label = dimnames[2], rot = dimnames_rot[2], gp = gpar(col = dimnames_color)) grid.text(x = 0.75 + 3 * eps + shift, y = 0.5 * top + shift, label = dimnames[1], rot = dimnames_rot[1], gp = gpar(col = dimnames_color)) grid.text(x = 0.5, y = -0.02 - shift, label = dimnames[3], rot = dimnames_rot[3], gp = gpar(col = dimnames_color)) } ## grid if (is.character(grid)) for (i in 1:4 * 0.2) { ## a - axis grid.lines(c(1 - i , (1 - i) / 2), c(0, 1 - i) * top, gp = gpar(lty = grid, col = grid_color)) ## b - axis grid.lines(c(1 - i , 1 - i + i / 2), c(0, i) * top, gp = gpar(lty = grid, col = grid_color)) ## c - axis grid.lines(c(i / 2, 1 - i + i/2), c(i, i) * top, gp = gpar(lty = grid, col = grid_color)) ## grid labels if (labels == "inside") { grid.text(x = (1 - i) * 3 / 4 - eps, y = (1 - i) / 2 * top, label = i * scale, gp = gpar(col = labels_color), rot = labels_rot[1]) grid.text(x = 1 - i + i / 4 + eps, y = i / 2 * top - eps, label = (1 - i) * scale, gp = gpar(col = labels_color), rot = labels_rot[2]) grid.text(x = 0.5, y = i * top + eps, label = i * scale, gp = gpar(col = labels_color), rot = labels_rot[3]) } if (labels == "outside") { grid.text(x = (1 - i) / 2 - 6 * eps, y = (1 - i) * top, label = (1 - i) * scale, rot = labels_rot[3], gp = gpar(col = labels_color)) grid.text(x = 1 - (1 - i) / 2 + 3 * eps, y = (1 - i) * top + 5 * eps, label = i * scale, rot = labels_rot[2], gp = gpar(col = labels_color)) grid.text(x = i + eps, y = -0.05, label = (1 - i) * scale, vjust = 1, rot = labels_rot[1], gp = gpar(col = labels_color)) } } ## plot points xp <- x[,2] + x[,3] / 2 yp <- x[,3] * top size = unit(if(prop_size) prop_size * (s / max(s)) else cex, "lines") grid.points(xp, yp, pch = pch, gp = gpar(col = col), default.units = "snpc", size = size, ...) ## plot if (!is.null(id)) grid.text(x = xp, y = unit(yp - 0.015, "snpc") - 0.5 * size, label = as.character(id), just = id_just, gp = gpar(col = id_color, cex = cex)) ## cleanup if(pop) popViewport(2) else upViewport(2) if (return_grob) invisible(grid.grab()) else invisible(NULL) } vcd/R/cotabplot.R0000755000175100001440000003025512505557216013377 0ustar hornikuserscotabplot <- function(x, ...) { UseMethod("cotabplot") } cotabplot.formula <- function(formula, data = NULL, ...) { m <- match.call() edata <- eval(m$data, parent.frame()) fstr <- deparse(formula) fstr <- gsub("*", "+", fstr, fixed = TRUE) fstr <- gsub("/", "+", fstr, fixed = TRUE) fstr <- gsub("(", "", fstr, fixed = TRUE) fstr <- gsub(")", "", fstr, fixed = TRUE) fstr <- strsplit(paste(fstr, collapse = ""), "~") vars <- strsplit(strsplit(gsub(" ", "", fstr[[1]][2]), "\\|")[[1]], "\\+") varnames <- vars[[1]] condnames <- if(length(vars) > 1) vars[[2]] else NULL if (inherits(edata, "ftable") || inherits(edata, "table") || length(dim(edata)) > 2) { tab <- as.table(data) if(all(varnames != ".")) { ind <- match(varnames, names(dimnames(tab))) if (any(is.na(ind))) stop(paste("Can't find", paste(varnames[is.na(ind)], collapse=" / "), "in", deparse(substitute(data)))) if (!is.null(condnames)) { condind <- match(condnames, names(dimnames(tab))) if (any(is.na(condind))) stop(paste("Can't find", paste(condnames[is.na(condind)], collapse=" / "), "in", deparse(substitute(data)))) ind <- c(condind, ind) } tab <- margin.table(tab, ind) } } else { tab <- if ("Freq" %in% colnames(data)) xtabs(formula(paste("Freq~", paste(c(condnames, varnames), collapse = " + "))), data = data) else xtabs(formula(paste("~", paste(c(condnames, varnames), collapse = " + "))), data = data) } tab <- margin.table(tab, match(c(varnames, condnames), names(dimnames(tab)))) cotabplot(tab, cond = condnames, ...) } cotabplot.default <- function(x, cond = NULL, panel = cotab_mosaic, panel_args = list(), margins = rep(1, 4), layout = NULL, text_gp = gpar(fontsize = 12), rect_gp = gpar(fill = grey(0.9)), pop = TRUE, newpage = TRUE, return_grob = FALSE, ...) { ## coerce to table x <- as.table(x) ## initialize newpage if(newpage) grid.newpage() ## process default option ldx <- length(dim(x)) if(is.null(cond)) { indep <- if(ldx > 1) 1:2 else 1 if(ldx > 2) cond <- 3:ldx } else { if(is.character(cond)) cond <- match(cond, names(dimnames(x))) cond <- as.integer(cond) indep <- (1:ldx)[!(1:ldx %in% cond)] } ## sort margins x <- margin.table(x, c(indep, cond)) ## convenience variables that describe conditioning variables if(is.null(cond)) { cond.n <- 0 cond.num <- cond.dnam <- cond.char <- NULL } else { cond.n <- length(cond) ## number of variables cond.num <- (length(indep) + 1):ldx ## position in x cond.dnam <- dimnames(x)[cond.num] ## corresponding dimnames cond.char <- names(cond.dnam) ## names of variables } ## create panel function (if necessary) if(inherits(panel, "grapcon_generator")) panel <- do.call("panel", c(list(x, cond.char), as.list(panel_args), list(...))) if(cond.n < 1) panel(x, NULL) ## no conditioning variables else { cond.nlevels <- sapply(cond.dnam, length) nplots <- prod(cond.nlevels) condition <- as.matrix(expand.grid(cond.dnam)) ## compute layout #Z# needs fixing for more than two conditioning variables if(is.null(layout)) { layout <- c(1,1,1) ## rows, cols, pages if(cond.n == 1) { layout[2] <- ceiling(sqrt(floor(cond.nlevels))) layout[1] <- ceiling(cond.nlevels/layout[2]) } else { layout[1] <- cond.nlevels[1] layout[2] <- cond.nlevels[2] if(cond.n >= 3) layout[3] <- nplots/prod(cond.nlevels[1:2]) #Z# FIXME if(layout[3] > 1) stop("multiple pages not supported yet") } } else { layout <- c(rep(layout, length.out = 2), 1) if(layout[1] * layout[2] < nplots) stop("number of panels specified in 'layout' is too small") } layout <- expand.grid(lapply(layout, function(x) 1:x))[1:nplots,] ## push basic grid of nr x nc cells nr <- max(layout[,1]) nc <- max(layout[,2]) pushViewport(plotViewport(margins)) pushViewport(viewport(layout = grid.layout(nr, nc, widths = unit(1/nc, "npc")))) strUnit <- unit(2 * ncol(condition), "strheight", "A") cellport <- function(name) viewport(layout = grid.layout(2, 1, heights = unit.c(strUnit, unit(1, "npc") - strUnit)), name = name) ## go through each conditioning combination for(i in 1:nrow(condition)) { ## conditioning information in ith cycle condi <- as.vector(condition[i,]) names(condi) <- colnames(condition) condistr <- paste(condi, collapse = ".") condilab <- paste(cond.char, condi, sep = " = ") ## header pushViewport(viewport(layout.pos.row = layout[i,1], layout.pos.col = layout[i,2])) pushViewport(cellport(paste("cell", condistr, sep = "."))) pushViewport(viewport(layout.pos.row = 1, name = paste("lab", condistr, sep = "."))) grid.rect(gp = rect_gp) grid.text(condilab, y = cond.n:1/cond.n - 1/(2*cond.n), gp = text_gp) grid.segments(0, 0:cond.n/cond.n, 1, 0:cond.n/cond.n) upViewport() ## main plot pushViewport(viewport(layout.pos.row = 2, name = paste("plot", condistr, sep = "."))) panel(x, condi) upViewport(2) grid.rect(gp = gpar(fill = "transparent")) upViewport() } upViewport() if(pop) popViewport() else upViewport() } if (return_grob) invisible(structure(x, grob = grid.grab())) else invisible(x) } cotab_mosaic <- function(x = NULL, condvars = NULL, ...) { function(x, condlevels) { if(is.null(condlevels)) mosaic(x, newpage = FALSE, pop = FALSE, return_grob = FALSE, ...) else mosaic(co_table(x, names(condlevels))[[paste(condlevels, collapse = ".")]], newpage = FALSE, pop = FALSE, return_grob = FALSE, prefix = paste("panel:", paste(names(condlevels), condlevels, sep = "=", collapse = ","), "|", sep = ""), ...) } } class(cotab_mosaic) <- "grapcon_generator" cotab_sieve <- function(x = NULL, condvars = NULL, ...) { function(x, condlevels) { if(is.null(condlevels)) sieve(x, newpage = FALSE, pop = FALSE, return_grob = FALSE, ...) else sieve(co_table(x, names(condlevels))[[paste(condlevels, collapse = ".")]], newpage = FALSE, pop = FALSE, return_grob = FALSE, prefix = paste("panel:", paste(names(condlevels), condlevels, sep = "=", collapse = ","), "|", sep = ""), ...) } } class(cotab_sieve) <- "grapcon_generator" cotab_assoc <- function(x = NULL, condvars = NULL, ylim = NULL, ...) { if(!is.null(x)) { fm <- coindep_test(x, condvars, n = 1) if(is.null(ylim)) ylim <- range(residuals(fm)) } function(x, condlevels) { if(is.null(condlevels)) assoc(x, newpage = FALSE, pop = FALSE, ylim = ylim, return_grob = FALSE, ...) else assoc(co_table(x, names(condlevels))[[paste(condlevels, collapse = ".")]], newpage = FALSE, pop = FALSE, return_grob = FALSE, ylim = ylim, prefix = paste("panel:", paste(names(condlevels), condlevels, sep = "=", collapse = ","), "|", sep = ""), ...) } } class(cotab_assoc) <- "grapcon_generator" cotab_fourfold <- function (x = NULL, condvars = NULL, ...) { function(x, condlevels) { if (is.null(condlevels)) fourfold(x, newpage = FALSE, return_grob = FALSE, ...) else fourfold(co_table(x, names(condlevels))[[paste(condlevels, collapse = ".")]], newpage = FALSE, return_grob = FALSE, ...) } } class(cotab_fourfold) <- "grapcon_generator" cotab_loddsratio <- function(x = NULL, condvars = NULL, ...) { function(x, condlevels) { if(is.null(condlevels)) { plot(loddsratio(x, ...), newpage = FALSE, pop = FALSE, return_grob = FALSE, ...) } else { plot(loddsratio(co_table(x, names(condlevels))[[paste(condlevels, collapse = ".")]], ...), newpage = FALSE, pop = FALSE, return_grob = FALSE, prefix = paste("panel:", paste(names(condlevels), condlevels, sep = "=", collapse = ","), "|", sep = ""), ...) } upViewport(2) } } class(cotab_loddsratio) <- "grapcon_generator" cotab_agreementplot <- function(x = NULL, condvars = NULL, ...) { function(x, condlevels) { if(is.null(condlevels)) agreementplot(x, newpage = FALSE, pop = FALSE, return_grob = FALSE, ...) else agreementplot(co_table(x, names(condlevels))[[paste(condlevels, collapse = ".")]], newpage = FALSE, pop = FALSE, return_grob = FALSE, prefix = paste("panel:", paste(names(condlevels), condlevels, sep = "=", collapse = ","), "|", sep = ""), ...) } } class(cotab_agreementplot) <- "grapcon_generator" cotab_coindep <- function(x, condvars, test = c("doublemax", "maxchisq", "sumchisq"), level = NULL, n = 1000, interpolate = c(2, 4), h = NULL, c = NULL, l = NULL, lty = 1, type = c("mosaic", "assoc"), legend = FALSE, ylim = NULL, ...) { if(is.null(condvars)) stop("at least one conditioning variable is required") ## set color defaults if(is.null(h)) h <- c(260, 0) if(is.null(c)) c <- c(100, 20) if(is.null(l)) l <- c(90, 50) ## process conditional variables and get independent variables ## store some convenience information ldx <- length(dim(x)) if(is.character(condvars)) condvars <- match(condvars, names(dimnames(x))) condvars <- as.integer(condvars) indep <- (1:ldx)[!(1:ldx %in% condvars)] ## sort margins x <- margin.table(x, c(indep, condvars)) ind.n <- length(indep) ind.num <- 1:ind.n ind.dnam <- dimnames(x)[ind.num] ind.char <- names(ind.dnam) cond.n <- length(condvars) cond.num <- (ind.n + 1):length(dim(x)) cond.dnam <- dimnames(x)[cond.num] cond.char <- names(cond.dnam) test <- match.arg(test) switch(test, "doublemax" = { if(is.null(level)) level <- c(0.9, 0.99) fm <- coindep_test(x, cond.num, n = n) resids <- residuals(fm) col.bins <- fm$qdist(sort(level)) gpfun <- shading_hcl(observed = NULL, residuals = NULL, expected = NULL, df = NULL, h = h, c = c, l = l, interpolate = col.bins, lty = lty, p.value = fm$p.value) }, "maxchisq" = { if(is.null(level)) level <- 0.95 level <- level[1] fm <- coindep_test(x, cond.num, n = n, indepfun = function(x) sum(x^2)) resids <- residuals(fm) chisqs <- sapply(co_table(residuals(fm), fm$margin), function(x) sum(x^2)) pvals <- 1 - fm$pdist(chisqs) gpfun <- sapply(pvals, function(p) shading_hcl(observed = NULL, residuals = NULL, expected = NULL, df = NULL, h = h, c = c, l = l, interpolate = interpolate, lty = lty, level = level, p.value = p)) }, "sumchisq" = { if(is.null(level)) level <- 0.95 level <- level[1] fm <- coindep_test(x, cond.num, n = n, indepfun = function(x) sum(x^2), aggfun = sum) resids <- residuals(fm) gpfun <- shading_hcl(observed = NULL, residuals = NULL, expected = NULL, df = NULL, h = h, c = c, l = l, interpolate = interpolate, lty = lty, level = level, p.value = fm$p.value) }) type <- match.arg(type) if(type == "mosaic") { rval <- function(x, condlevels) { if(is.null(condlevels)) { tab <- x gp <- if(is.list(gpfun)) gpfun[[1]] else gpfun } else { tab <- co_table(x, names(condlevels))[[paste(condlevels, collapse = ".")]] gp <- if(is.list(gpfun)) gpfun[[paste(condlevels, collapse = ".")]] else gpfun } mosaic(tab, newpage = FALSE, pop = FALSE, return_grob = FALSE, gp = gp, legend = legend, prefix = paste("panel:", paste(names(condlevels), condlevels, sep = "=", collapse = ","), "|", sep = ""), ...) } } else { if(is.null(ylim)) ylim <- range(resids) rval <- function(x, condlevels) { if(is.null(condlevels)) { tab <- x gp <- if(is.list(gpfun)) gpfun[[1]] else gpfun } else { tab <- co_table(x, names(condlevels))[[paste(condlevels, collapse = ".")]] gp <- if(is.list(gpfun)) gpfun[[paste(condlevels, collapse = ".")]] else gpfun } assoc(tab, newpage = FALSE, pop = FALSE, return_grob = FALSE, gp = gp, legend = legend, ylim = ylim, prefix = paste("panel:", paste(names(condlevels), condlevels, sep = "=", collapse = ","), "|", sep = ""), ...) } } return(rval) } class(cotab_coindep) <- "grapcon_generator" vcd/R/sieve.R0000755000175100001440000003147212467662166012535 0ustar hornikusers########################################################### ## sieveplot sieve <- function(x, ...) UseMethod("sieve") sieve.formula <- function(formula, data = NULL, ..., main = NULL, sub = NULL, subset = NULL) { if (is.logical(main) && main) main <- deparse(substitute(data)) else if (is.logical(sub) && sub) sub <- deparse(substitute(data)) m <- match.call(expand.dots = FALSE) edata <- eval(m$data, parent.frame()) fstr <- strsplit(paste(deparse(formula), collapse = ""), "~") vars <- strsplit(strsplit(gsub(" ", "", fstr[[1]][2]), "\\|")[[1]], "\\+") varnames <- vars[[1]] condnames <- if (length(vars) > 1) vars[[2]] else NULL if (inherits(edata, "ftable") || inherits(edata, "table") || length(dim(edata)) > 2) { condind <- NULL dat <- as.table(data) if(all(varnames != ".")) { ind <- match(varnames, names(dimnames(dat))) if (any(is.na(ind))) stop(paste("Can't find", paste(varnames[is.na(ind)], collapse=" / "), "in", deparse(substitute(data)))) if (!is.null(condnames)) { condind <- match(condnames, names(dimnames(dat))) if (any(is.na(condind))) stop(paste("Can't find", paste(condnames[is.na(condind)], collapse=" / "), "in", deparse(substitute(data)))) ind <- c(condind, ind) } dat <- margin.table(dat, ind) } sieve.default(dat, main = main, sub = sub, condvars = if (is.null(condind)) NULL else match(condnames, names(dimnames(dat))), ...) } else { tab <- if ("Freq" %in% colnames(data)) xtabs(formula(paste("Freq~", paste(c(condnames, varnames), collapse = "+"))), data = data, subset = subset) else xtabs(formula(paste("~", paste(c(condnames, varnames), collapse = "+"))), data = data, subset = subset) sieve.default(tab, main = main, sub = sub, ...) } } sieve.default <- function(x, condvars = NULL, gp = NULL, shade = NULL, legend = FALSE, split_vertical = NULL, direction = NULL, spacing = NULL, spacing_args = list(), sievetype = c("observed","expected"), gp_tile = gpar(), scale = 1, main = NULL, sub = NULL, ...) { if (is.logical(main) && main) main <- deparse(substitute(x)) else if (is.logical(sub) && sub) sub <- deparse(substitute(x)) sievetype = match.arg(sievetype) if (is.logical(shade) && shade && is.null(gp)) gp <- if (sievetype == "observed") # shading_sieve(interpolate = 0, lty = c("longdash", "solid")) shading_sieve(interpolate = 0, lty = c("solid", "longdash")) else shading_sieve(interpolate = 0, line_col = "darkgray", eps = Inf, lty = "dotted") if (is.structable(x)) { if (is.null(direction) && is.null(split_vertical)) split_vertical <- attr(x, "split_vertical") x <- as.table(x) } if (is.null(split_vertical)) split_vertical <- FALSE dl <- length(dim(x)) ## splitting argument if (!is.null(direction)) split_vertical <- direction == "v" if (length(split_vertical) == 1) split_vertical <- rep(c(split_vertical, !split_vertical), length.out = dl) if (length(split_vertical) < dl) split_vertical <- rep(split_vertical, length.out = dl) ## condvars if (!is.null(condvars)) { if (is.character(condvars)) condvars <- match(condvars, names(dimnames(x))) x <- aperm(x, c(condvars, seq(dl)[-condvars])) if (is.null(spacing)) spacing <- spacing_conditional } ## spacing argument if (is.null(spacing)) spacing <- if (dl < 3) spacing_equal(sp = 0) else spacing_increase strucplot(x, condvars = if (is.null(condvars)) NULL else length(condvars), core = struc_sieve(sievetype = sievetype, gp_tile = gp_tile, scale = scale), split_vertical = split_vertical, spacing = spacing, spacing_args = spacing_args, main = main, sub = sub, shade = shade, legend = legend, gp = gp, ...) } ## old version (not performant enough) ## ## struc_sieve <- function(sievetype = c("observed", "expected")) { ## sievetype = match.arg(sievetype) ## function(residuals, observed, expected, spacing, gp, split_vertical, prefix = "") { ## dn <- dimnames(expected) ## dnn <- names(dn) ## dx <- dim(expected) ## dl <- length(dx) ## n <- sum(expected) ## ## split workhorse ## split <- function(x, i, name, row, col, rowmargin, colmargin) { ## cotab <- co_table(x, 1) ## margin <- sapply(cotab, sum) ## v <- split_vertical[i] ## d <- dx[i] ## ## compute total cols/rows and build split layout ## dist <- unit.c(unit(margin, "null"), spacing[[i]]) ## idx <- matrix(1:(2 * d), nrow = 2, byrow = TRUE)[-2 * d] ## layout <- if (v) ## grid.layout(ncol = 2 * d - 1, widths = dist[idx]) ## else ## grid.layout(nrow = 2 * d - 1, heights = dist[idx]) ## vproot <- viewport(layout.pos.col = col, layout.pos.row = row, ## layout = layout, name = remove_trailing_comma(name)) ## ## next level: either create further splits, or final viewports ## name <- paste(name, dnn[i], "=", dn[[i]], ",", sep = "") ## row <- col <- rep.int(1, d) ## if (v) col <- 2 * 1:d - 1 else row <- 2 * 1:d - 1 ## proptab <- function(x) x / max(sum(x), 1) ## f <- if (i < dl) { ## if (v) ## function(m) split(cotab[[m]], i + 1, name[m], row[m], col[m], ## colmargin = colmargin * proptab(margin)[m], ## rowmargin = rowmargin) ## else ## function(m) split(cotab[[m]], i + 1, name[m], row[m], col[m], ## colmargin = colmargin, ## rowmargin = rowmargin * proptab(margin)[m]) ## } else { ## if (v) ## function(m) viewport(layout.pos.col = col[m], layout.pos.row = row[m], ## name = remove_trailing_comma(name[m]), ## yscale = c(0, rowmargin), ## xscale = c(0, colmargin * proptab(margin)[m])) ## else ## function(m) viewport(layout.pos.col = col[m], layout.pos.row = row[m], ## name = remove_trailing_comma(name[m]), ## yscale = c(0, rowmargin * proptab(margin)[m]), ## xscale = c(0, colmargin)) ## } ## vpleaves <- structure(lapply(1:d, f), class = c("vpList", "viewport")) ## vpTree(vproot, vpleaves) ## } ## ## start splitting on top, creates viewport-tree ## pushViewport(split(expected + .Machine$double.eps, ## i = 1, name = paste(prefix, "cell:", sep = ""), row = 1, col = 1, ## rowmargin = n, colmargin = n)) ## ## draw rectangles ## mnames <- apply(expand.grid(dn), 1, ## function(i) paste(dnn, i, collapse=",", sep = "=") ## ) ## for (i in seq_along(mnames)) { ## seekViewport(paste(prefix, "cell:", mnames[i], sep = "")) ## vp <- current.viewport() ## gpobj <- structure(lapply(gp, function(x) x[i]), class = "gpar") ## div <- if (sievetype == "observed") observed[i] else expected[i] ## if (div > 0) { ## square.side <- sqrt(vp$yscale[2] * vp$xscale[2] / div) ## ii <- seq(0, vp$xscale[2], by = square.side) ## jj <- seq(0, vp$yscale[2], by = square.side) ## grid.segments(x0 = ii, x1 = ii, y0 = 0, y1 = vp$yscale[2], ## default.units = "native", gp = gpobj) ## grid.segments(x0 = 0, x1 = vp$xscale[2], y0 = jj, y1 = jj, ## default.units = "native", gp = gpobj) ## } ## grid.rect(name = paste(prefix, "rect:", mnames[i], sep = ""), ## gp = gpar(fill = "transparent")) ## } ## } ## } ##class(struc_sieve) <- "grapcon_generator" struc_sieve <- function(sievetype = c("observed", "expected"), gp_tile = gpar(), scale = 1) { sievetype = match.arg(sievetype) function(residuals, observed, expected, spacing, gp, split_vertical, prefix = "") { observed <- scale * observed expected <- scale * expected if (is.null(expected)) stop("Need expected values.") dn <- dimnames(expected) dnn <- names(dn) dx <- dim(expected) dl <- length(dx) n <- sum(expected) ## split workhorse split <- function(x, i, name, row, col, rowmargin, colmargin, index) { cotab <- co_table(x, 1) margin <- sapply(cotab, sum) v <- split_vertical[i] d <- dx[i] ## compute total cols/rows and build split layout dist <- if (d > 1) unit.c(unit(margin, "null"), spacing[[i]]) else unit(margin, "null") idx <- matrix(1:(2 * d), nrow = 2, byrow = TRUE)[-2 * d] layout <- if (v) grid.layout(ncol = 2 * d - 1, widths = dist[idx]) else grid.layout(nrow = 2 * d - 1, heights = dist[idx]) pushViewport(viewport(layout.pos.col = col, layout.pos.row = row, layout = layout, name = paste(prefix, "cell:", remove_trailing_comma(name), sep = ""))) ## next level: either create further splits, or final viewports row <- col <- rep.int(1, d) if (v) col <- 2 * 1:d - 1 else row <- 2 * 1:d - 1 proptab <- function(x) x / max(sum(x), 1) for (m in 1:d) { nametmp <- paste(name, dnn[i], "=", dn[[i]][m], ",", sep = "") if (v) { colmargintmp <- colmargin * proptab(margin)[m] rowmargintmp <- rowmargin } else { rowmargintmp <- rowmargin * proptab(margin)[m] colmargintmp <- colmargin } if (i < dl) split(cotab[[m]], i + 1, nametmp, row[m], col[m], colmargin = colmargintmp, rowmargin = rowmargintmp, index = cbind(index, m)) else { pushViewport(viewport(layout.pos.col = col[m], layout.pos.row = row[m], name = paste(prefix, "cell:", remove_trailing_comma(nametmp), sep = ""), yscale = c(0, rowmargintmp), xscale = c(0, colmargintmp))) gpobj <- structure(lapply(gp, function(x) x[cbind(index, m)]), class = "gpar") ## draw sieve div <- if (sievetype == "observed") observed[cbind(index, m)] else expected[cbind(index, m)] gptmp <- gp_tile gptmp$col <- "transparent" grid.rect(name = paste(prefix, "rect:", nametmp, sep = ""), gp = gptmp) if (div > 0) { square.side <- sqrt(colmargintmp * rowmargintmp / div) ii <- seq(0, colmargintmp, by = square.side) jj <- seq(0, rowmargintmp, by = square.side) grid.segments(x0 = ii, x1 = ii, y0 = 0, y1 = rowmargintmp, default.units = "native", gp = gpobj) grid.segments(x0 = 0, x1 = colmargintmp, y0 = jj, y1 = jj, default.units = "native", gp = gpobj) } gptmp <- gp_tile gptmp$fill <- "transparent" grid.rect(name = paste(prefix, "border:", nametmp, sep = ""), gp = gptmp) } upViewport(1) } } ## start splitting on top, creates viewport-tree split(expected + .Machine$double.eps, i = 1, name = "", row = 1, col = 1, rowmargin = n, colmargin = n, index = cbind()) } } class(struc_sieve) <- "grapcon_generator" vcd/R/binregplot.R0000644000175100001440000002555414177254342013561 0ustar hornikusersbinreg_plot <- function(model, main = NULL, xlab = NULL, ylab = NULL, xlim = NULL, ylim = NULL, pred_var = NULL, pred_range = c("data", "xlim"), group_vars = NULL, base_level = NULL, subset, type = c("response", "link"), conf_level = 0.95, delta = FALSE, pch = NULL, cex = 0.6, jitter_factor = 0.1, lwd = 5, lty = 1, point_size = 0, col_lines = NULL, col_bands = NULL, legend = TRUE, legend_pos = NULL, legend_inset = c(0, 0.1), legend_vgap = unit(0.5, "lines"), labels = FALSE, labels_pos = c("right", "left"), labels_just = c("left","center"), labels_offset = c(0.01, 0), gp_main = gpar(fontface = "bold", fontsize = 14), gp_legend_frame = gpar(lwd = 1, col = "black"), gp_legend_title = gpar(fontface = "bold"), newpage = TRUE, pop = FALSE, return_grob = FALSE) { if (!inherits(model, "glm")) stop("Method requires a model of class 'glm'.") type <- match.arg(type) labels_pos <- match.arg(labels_pos) if (is.character(pred_range)) pred_range <- match.arg(pred_range) ## extract data from model mod <- model.frame(model) term <- terms(mod) data.classes <- attr(term, "dataClasses") nam <- names(data.classes) ## determine response r <- attr(term, "response") resp <- nam[r] data.classes <- data.classes[-r] nam <- nam[-r] ## determine numeric predictor (take first) if (is.null(pred_var)) { fac <- data.classes %in% c("factor","logical") pred_var_model <- names(data.classes[!fac][1]) pred_var <- names(unlist(sapply(all.vars(term), grep, pred_var_model)))[1] } else pred_var_model <- pred_var ## filter observed data using model (to account for models fitted with subset=...) dat <- model$data[row.names(mod),] ## sort observations using order of numeric predictor o <- order(dat[,pred_var,drop=TRUE]) mod <- mod[o,] dat <- dat[o,] ## apply subset argument, if any if (!missing(subset)) { e <- substitute(subset) i <- eval(e, dat, parent.frame()) i <- i & !is.na(i) dat <- dat[i,] mod <- mod[i,] } ## determine conditioning variables. Remove all those with only one level observed. if (is.null(group_vars)) { group_vars <- nam[data.classes %in% "factor"] sing <- na.omit(sapply(dat, function(i) all(i == i[1]))) if (any(sing)) group_vars <- setdiff(group_vars, names(sing)[sing]) if(length(group_vars) < 1) group_vars <- NULL } else if (is.na(group_vars) || is.logical(group_vars) && !group_vars[1]) group_vars <- NULL ## set y axis limits - either probability or logit scale if(is.null(ylim)) ylim <- if (type == "response") c(0,1) else range(predict(model, dat, type = "link")) ## allow for some cosmetic extra space ylimaxis <- ylim + c(-1, 1) * diff(ylim) * 0.04 if(is.null(xlim)) xlim <- if (is.numeric(pred_range)) range(pred_range) else range(dat[,pred_var]) xlimaxis <- xlim + c(-1, 1) * diff(xlim) * 0.04 ## set default base level ("no effect") of response to first level/0 if (is.null(base_level)) base_level <- if(is.matrix(mod[,resp])) 2 else if(is.factor(mod[,resp])) levels(mod[,resp])[1] else 0 if (is.matrix(mod[,resp]) && is.character(base_level)) base_level <- switch(base_level, success =, Success = 1, failure =, Failure = 2) ## determine labels of conditioning variables, if any if (is.null(group_vars)) { labels <- legend <- FALSE } else { ## compute cross-factors for more than two conditioning variables if (length(group_vars) > 1) { cross <- paste(group_vars, collapse = " x ") dat[,cross] <- factor(apply(dat[,group_vars], 1, paste, collapse = " : ")) group_vars <- cross } lev <- levels(dat[,group_vars,drop=TRUE]) } ## set x- and y-lab if (is.null(xlab)) xlab <- pred_var if (is.null(ylab)) ylab <- if (type == "response") { if (is.matrix(mod[,resp])) paste0("P(", c("Failure","Success")[base_level], ")") else paste0("P(", resp, ")") } else { if (is.matrix(mod[,resp])) paste0("logit(", c("Failure","Success")[base_level], ")") else paste0("logit(", resp, ")") } ## rearrange default plot symbol palette if (is.null(pch)) pch <- c(19,15,17, 1:14, 16, 18, 20:25) ## determine normal quantile for confidence band quantile <- qnorm((1 + conf_level) / 2) ## determine default legend position, given the curve's slope ## (positive -> topleft, negative -> topright) if (is.null(legend_pos)) legend_pos <- if (coef(model)[grep(pred_var, names(coef(model)))[1]] > 0) "topleft" else "topright" ## work horse for drawing points, fitted curve and confidence band draw <- function(ind, colband, colline, pch, label) { ## plot observed data as points on top or bottom ycoords <- if (is.matrix(mod[,resp])) { tmp <- prop.table(mod[ind,resp], 1)[,switch(base_level, 2, 1)] if (type == "link") family(model)$linkfun(tmp) else tmp } else jitter(ylim[1 + (mod[ind, resp] != base_level)], jitter_factor) if (cex > 0) grid.points(unit(dat[ind, pred_var, drop = TRUE], "native"), unit(ycoords, "native"), pch = pch, size = unit(cex, "char"), gp = gpar(col = colline), default.units = "native" ) ## confidence band and fitted values typ <- if (type == "response" && !delta) "link" else type if (is.character(pred_range)) { if (pred_range == "data") { D <- dat[ind,] P <- D[,pred_var, drop = TRUE] } else { P <- seq(from = xlim[1L], to = xlim[2L], length.out = 100L) D <- dat[ind,][rep(1L, length(P)),] D[,pred_var] <- P } } else { P <- pred_range D <- dat[ind,][rep(1L, length(P)),] D[,pred_var] <- P } pr <- predict(model, D, type = typ, se.fit = TRUE) lower <- pr$fit - quantile * pr$se.fit upper <- pr$fit + quantile * pr$se.fit if (type == "response" && !delta) { lower <- family(model)$linkinv(lower) upper <- family(model)$linkinv(upper) pr$fit <- family(model)$linkinv(pr$fit) } if (type == "response") { ## cut probs at unit interval lower[lower < 0] <- 0 upper[upper > 1] <- 1 } grid.polygon(unit(c(P, rev(P)), "native"), unit(c(lower, rev(upper)), "native"), gp = gpar(fill = colband, col = NA)) grid.lines(unit(P, "native"), unit(pr$fit, "native"), gp = gpar(col = colline, lwd = lwd, lty = lty)) if (point_size > 0) grid.points(unit(P, "native"), unit(pr$fit, "native"), pch = pch, size = unit(point_size, "char"), gp = gpar(col = colline)) ## add labels, if any if (labels) { x = switch(labels_pos, left = P[1], right = P[length(P)]) y = switch(labels_pos, left = pr$fit[1], right = pr$fit[length(pr$fit)]) grid.text(x = unit(x, "native") + unit(labels_offset[1], "npc"), y = unit(y, "native") + unit(labels_offset[2], "npc"), label = label, just = labels_just, gp = gpar(col = colline)) } } ## determine colors and plot symbols llev <- if (is.null(group_vars)) 1 else length(lev) pch <- rep(pch, length.out = llev) if (is.null(col_bands)) col_bands <- colorspace::rainbow_hcl(llev, alpha = 0.2) if (is.null(col_lines)) col_lines <- colorspace::rainbow_hcl(llev, l = 50) ## set up plot region, similar to plot.xy() if (newpage) grid.newpage() pushViewport(plotViewport(xscale = xlimaxis, yscale = ylimaxis, default.units = "native", name = "binreg_plot")) grid.rect(gp = gpar(fill = "transparent")) grid.xaxis() grid.yaxis() grid.text(xlab, y = unit(-3.5, "lines")) grid.text(ylab, x = unit(-3, "lines"), rot = 90) grid.text(main, y = unit(1, "npc") + unit(2, "lines"), gp = gp_main) pushViewport(viewport(xscale = xlimaxis, yscale = ylimaxis, default.units = "native", clip = "on")) ## draw fitted curve(s) if (is.null(group_vars)) { ## single curve draw(1:nrow(dat), col_bands, col_lines, pch[1]) } else { ## multiple curves for (i in seq_along(lev)) { ind <- dat[,group_vars,drop=TRUE] == lev[i] draw(ind, col_bands[i], col_lines[i], pch[i], lev[i]) } if (legend) grid_legend(legend_pos, labels = lev, col = col_lines, lty = "solid", lwd = lwd, vgap = legend_vgap, gp_frame = gp_legend_frame, inset = legend_inset, title = group_vars, gp_title = gp_legend_title) } if (pop) popViewport(2) if (return_grob) invisible(grid.grab()) else invisible(NULL) } ########### grid_abline <- function(a, b, ...) { ## taken from graphics::abline() if (is.object(a) || is.list(a)) { p <- length(coefa <- as.vector(coef(a))) if (p > 2) warning(gettextf("only using the first two of %d regression coefficients", p), domain = NA) islm <- inherits(a, "lm") noInt <- if (islm) !as.logical(attr(stats::terms(a), "intercept")) else p == 1 if (noInt) { a <- 0 b <- coefa[1L] } else { a <- coefa[1L] b <- if (p >= 2) coefa[2L] else 0 } } grid.abline(a, b, ...) } vcd/R/legends.R0000644000175100001440000001725414543516045013031 0ustar hornikuserslegend_resbased <- function(fontsize = 12, fontfamily = "", x = unit(1, "lines"), y = unit(0.1, "npc"), height = unit(0.8, "npc"), width = unit(0.7, "lines"), digits = 2, pdigits = max(1, getOption("digits") - 2), check_overlap = TRUE, text = NULL, steps = 200, ticks = 10, pvalue = TRUE, range = NULL) { if(!is.unit(x)) x <- unit(x, "native") if(!is.unit(y)) y <- unit(y, "npc") if(!is.unit(width)) width <- unit(width, "lines") if(!is.unit(height)) height <- unit(height, "npc") function(residuals, shading, autotext) { res <- as.vector(residuals) if(is.null(text)) text <- autotext p.value <- attr(shading, "p.value") legend <- attr(shading, "legend") if (all(residuals == 0)) { pushViewport(viewport(x = x, y = y, just = c("left", "bottom"), default.units = "native", height = height, width = width)) grid.lines(y = 0.5) grid.text(0, x = unit(1, "npc") + unit(0.8, "lines"), y = 0.5, gp = gpar(fontsize = fontsize, fontfamily = fontfamily)) warning("All residuals are zero.") } else { if (is.null(range)) range <- range(res) if (length(range) != 2) stop("Range must have length two!") if (is.na(range[1])) range[1] <- min(res) if (is.na(range[2])) range[2] <- max(res) pushViewport(viewport(x = x, y = y, just = c("left", "bottom"), yscale = range, default.units = "native", height = height, width = width)) if(is.null(legend$col.bins)) { col.bins <- seq(range[1], range[2], length.out = steps) at <- NULL } else { col.bins <- sort(unique(c(legend$col.bins, range))) col.bins <- col.bins[col.bins <= range[2] & col.bins >= range[1]] at <- col.bins } y.pos <- col.bins[-length(col.bins)] y.height <- diff(col.bins) grid.rect(x = unit(rep.int(0, length(y.pos)), "npc"), y = y.pos, height = y.height, default.units = "native", gp = gpar(fill = shading(y.pos + 0.5 * y.height)$fill, col = 0), just = c("left", "bottom")) grid.rect(gp = gpar(fill = "transparent")) if(is.null(at)) at <- seq(from = head(col.bins, 1), to = tail(col.bins, 1), length.out = ticks) lab <- format(round(at, digits = digits), nsmall = digits) tw <- lab[which.max(nchar(lab))] ## if(is.null(at)) ## at <- seq(from = head(col.bins, 1), to = tail(col.bins, 1), length = ticks) ## tw <- paste(rep("4", digits), collapse = "") ## if (any(trunc(at) != at)) ## tw <- paste(tw, ".", sep = "") ## if (any(at < 0)) ## tw <- paste(tw, "-", sep = "") grid.text(format(signif(at, digits = digits)), x = unit(1, "npc") + unit(0.8, "lines") + unit(1, "strwidth", tw), y = at, default.units = "native", just = c("right", "center"), gp = gpar(fontsize = fontsize, fontfamily = fontfamily), check.overlap = check_overlap) grid.segments(x0 = unit(1, "npc"), x1 = unit(1,"npc") + unit(0.5, "lines"), y0 = at, y1 = at, default.units = "native") } popViewport(1) grid.text(text, x = x, y = unit(1, "npc") - y + unit(1, "lines"), gp = gpar(fontsize = fontsize, fontfamily = fontfamily, lineheight = 0.8), just = c("left", "bottom") ) if(!is.null(p.value) && pvalue) { grid.text(paste("p-value =\n", format.pval(p.value, digits = pdigits), sep = ""), x = x, y = y - unit(1, "lines"), gp = gpar(fontsize = fontsize, fontfamily = fontfamily, lineheight = 0.8), just = c("left", "top")) } } } class(legend_resbased) <- "grapcon_generator" legend_fixed <- function(fontsize = 12, fontfamily = "", x = unit(1, "lines"), y = NULL, height = NULL, width = unit(1.5, "lines"), steps = 200, digits = 1, space = 0.05, text = NULL, range = NULL) { if(!is.unit(x)) x <- unit(x, "native") if(!is.unit(y) && !is.null(y)) y <- unit(y, "npc") if(!is.unit(width)) width <- unit(width, "lines") if(!is.unit(height) && !is.null(height)) height <- unit(height, "npc") function(residuals, shading, autotext) { res <- as.vector(residuals) if(is.null(text)) text <- autotext if (is.null(y)) y <- unit(1, "strwidth", text) + unit(1, "lines") if (is.null(height)) height <- unit(1, "npc") - y pushViewport(viewport(x = x, y = y, just = c("left", "bottom"), yscale = c(0,1), default.units = "npc", height = height, width = width)) p.value <- attr(shading, "p.value") legend <- attr(shading, "legend") if (is.null(range)) range <- range(res) if (length(range) != 2) stop("Range must have length two!") if (is.na(range[1])) range[1] <- min(res) if (is.na(range[2])) range[2] <- max(res) if(is.null(legend$col.bins)) { col.bins <- seq(range[1], range[2], length.out = steps) } else { col.bins <- sort(unique(c(legend$col.bins, range))) col.bins <- col.bins[col.bins <= range[2] & col.bins >= range[1]] } l <- length(col.bins) y.height <- (1 - (l - 2) * space) / (l - 1) y.pos <- cumsum(c(0, rep(y.height + space, l - 2))) res <- col.bins[-l] + diff(col.bins) / 2 grid.rect(x = unit(rep.int(0, length(y.pos)), "npc"), y = y.pos, height = y.height, default.units = "npc", gp = shading(res), just = c("left", "bottom")) numbers <- format(col.bins, nsmall = digits, digits = digits) wid <- unit(1, "strwidth", format(max(abs(col.bins)), nsmall = digits, digits = digits)) grid.text(numbers[-l], x = unit(1, "npc") + unit(0.6, "lines") + wid, y = y.pos, gp = gpar(fontsize = fontsize, fontfamily = fontfamily), default.units = "npc", just = c("right", "bottom")) grid.text(numbers[-1], x = unit(1, "npc") + unit(0.6, "lines") + wid, y = y.pos + y.height, gp = gpar(fontsize = fontsize, fontfamily = fontfamily), default.units = "npc", just = c("right", "top")) wid2 <- unit(1, "strwidth", format(max(abs(trunc(col.bins))))) + unit(0.3, "strwidth", ".") grid.segments(x0 = unit(1, "npc") + wid2 + unit(0.6, "lines"), x1 = unit(1, "npc") + wid2 + unit(0.6, "lines"), y0 = unit(y.pos, "npc") + 1.5 * unit(1, "strheight", "-44.4"), y1 = unit(y.pos + y.height, "npc") - 1.5 * unit(1, "strheight", "-44.4") ) popViewport(1) grid.text(text, x = x + 0.5 * width, y = 0, gp = gpar(fontsize = fontsize, fontfamily = fontfamily, lineheight = 0.8), just = c("left", "top"), rot = 90 ) } } class(legend_fixed) <- "grapcon_generator" vcd/R/utils.R0000755000175100001440000000006611150520606012531 0ustar hornikusersremove_trailing_comma <- function(x) sub(",$", "", x) vcd/R/rootogram.R0000755000175100001440000001661312510525066013415 0ustar hornikusersrootogram <- function(x, ...) { UseMethod("rootogram") } rootogram.goodfit <- function(x, ...) { rootogram.default(x$observed, x$fitted, names = x$count, df = x$df, ...) } rootogram.default <- function(x, fitted, names = NULL, scale = c("sqrt", "raw"), type = c("hanging", "standing", "deviation"), shade = FALSE, legend = TRUE, legend_args = list(x = 0, y = 0.2, height = 0.6), df = NULL, rect_gp = NULL, rect_gp_args = list(), lines_gp = gpar(col = "red", lwd = 2), points_gp = gpar(col = "red"), pch = 19, xlab = NULL, ylab = NULL, ylim = NULL, main = NULL, sub = NULL, margins = unit(0, "lines"), title_margins = NULL, legend_width = NULL, main_gp = gpar(fontsize = 20), sub_gp = gpar(fontsize = 15), name = "rootogram", prefix = "", keep_aspect_ratio = FALSE, newpage = TRUE, pop = TRUE, return_grob = FALSE, ...) { if(is.null(names)) names <- names(x) if(is.table(x)) { if(length(dim(x)) > 1) stop ("x must be a 1-way table") x <- as.vector(x) } obs <- x fit <- fitted res <- (obs - fit) / sqrt(fit) if(is.null(xlab)) {xlab <- "Number of Occurrences"} if(match.arg(scale) == "sqrt") { obs <- sqrt(obs) fit <- sqrt(fit) if(is.null(ylab)) {ylab <- "sqrt(Frequency)"} } else { if(is.null(ylab)) {ylab <- "Frequency"} } ## rect_gp (color, fill, lty, etc.) argument if (shade) { if (is.null(rect_gp)) rect_gp <- shading_hcl if (is.function(rect_gp)) { if (is.null(legend) || (is.logical(legend) && legend)) legend <- legend_resbased gpfun <- if (inherits(rect_gp, "grapcon_generator")) do.call("rect_gp", c(list(obs, res, fit, df), rect_gp_args)) else rect_gp rect_gp <- gpfun(res) } else if (!is.null(legend) && !(is.logical(legend) && !legend)) stop("rect_gp argument must be a shading function for drawing a legend") } if (is.null(rect_gp)) rect_gp <- gpar(fill = "lightgray") ## set up page if (newpage) grid.newpage() if (keep_aspect_ratio) pushViewport(viewport(width = 1, height = 1, default.units = "snpc")) pushViewport(vcdViewport(mar = margins, oma = title_margins, legend = shade && !(is.null(legend) || is.logical(legend) && !legend), main = !is.null(main), sub = !is.null(sub), keep_aspect_ratio = keep_aspect_ratio, legend_width = legend_width, prefix = prefix)) ## legend if (inherits(legend, "grapcon_generator")) legend <- do.call("legend", legend_args) if (shade && !is.null(legend) && !(is.logical(legend) && !legend)) { seekViewport(paste(prefix, "legend", sep = "")) legend(res, gpfun, "Pearson\nresiduals:") } ## titles if (!is.null(main)) { seekViewport(paste(prefix, "main", sep = "")) if (is.logical(main) && main) main <- deparse(substitute(x)) grid.text(main, gp = main_gp) } if (!is.null(sub)) { seekViewport(paste(prefix, "sub", sep = "")) if (is.logical(sub) && sub && is.null(main)) sub <- deparse(substitute(x)) grid.text(sub, gp = sub_gp) } seekViewport(paste(prefix, "plot", sep = "")) switch(match.arg(type), "hanging" = { if(is.null(ylim)) {ylim <- range(-0.1 * c(fit-obs,fit), c(fit-obs,fit)) + c(0, 0.1)} dummy <- grid_barplot(obs, names = names, offset = fit - obs, gp = rect_gp, xlab = xlab, ylab = ylab, ylim = ylim, name = name, newpage = FALSE, pop = FALSE, return_grob = FALSE, ...) downViewport(name) grid.lines(x = dummy, y = fit, default.units = "native", gp = lines_gp) grid.points(x = dummy, y = fit, default.units = "native", gp = points_gp, pch = pch) grid.lines(x = unit(c(0, 1), "npc"), y = unit(0, "native")) if(pop) popViewport() else upViewport() }, "standing" = { if(is.null(ylim)) {ylim <- range(-0.01 * c(obs,fit), c(obs,fit)) } dummy <- grid_barplot(obs, names = names, gp = rect_gp, xlab = xlab, ylab = ylab, ylim = ylim, name = name, newpage = FALSE, pop = FALSE, return_grob = FALSE, ...) downViewport(name) grid.lines(x = dummy, y = fit, default.units = "native", gp = lines_gp) grid.points(x = dummy, y = fit, default.units = "native", gp = points_gp, pch = pch) if(pop) popViewport() else upViewport() }, "deviation" = { if(is.null(ylim)) {ylim <- range(-0.1 * c(fit-obs,fit), c(fit-obs,fit)) + c(0, 0.1)} dummy <- grid_barplot(fit - obs, names = names, gp = rect_gp, xlab = xlab, ylab = ylab, ylim = ylim, name = name, newpage = FALSE, pop = FALSE, return_grob = FALSE, ...) downViewport(name) grid.lines(x = dummy, y = fit, default.units = "native", gp = lines_gp) grid.points(x = dummy, y = fit, default.units = "native", gp = points_gp, pch = pch) if(pop) popViewport() else upViewport() } ) if (return_grob) invisible(grid.grab()) else invisible(NULL) } grid_barplot <- function(height, width = 0.8, offset = 0, names = NULL, xlim = NULL, ylim = NULL, xlab = "", ylab = "", main = "", gp = gpar(fill = "lightgray"), name = "grid_barplot", newpage = TRUE, pop = FALSE, return_grob = FALSE) { if(is.null(names)) names <- names(height) height <- as.vector(height) n <- length(height) width <- rep(width, length.out = n) offset <- rep(offset, length.out = n) if(is.null(names)) names <- rep("", n) if(is.null(xlim)) xlim <- c(1 - mean(width[c(1, n)]), n + mean(width[c(1, n)])) if(is.null(ylim)) ylim <- c(min(offset), max(height + offset)) if(newpage) grid.newpage() pushViewport(plotViewport(xscale = xlim, yscale = ylim, default.units = "native", name = name)) grid.rect(x = 1:n, y = offset, width = width, height = height, just = c("centre", "bottom"), default.units = "native", gp = gp) grid.yaxis() grid.text(names, x = unit(1:n, "native"), y = unit(rep(-1.5, n), "lines")) grid.text(xlab, y = unit(-3.5, "lines")) grid.text(ylab, x = unit(-3, "lines"), rot = 90) grid.text(main, y = unit(1, "npc") + unit(2, "lines"), gp = gpar(fontface = "bold")) if(pop) popViewport() else upViewport() if (return_grob) invisible(structure(1:n, grob = grid.grab())) else invisible(1:n) } vcd/R/agreementplot.R0000755000175100001440000001365113044210676014252 0ustar hornikusers## Modified 1/25/2012 11:43AM by M. friendly # -- added fill_col argument, specifying a function to be used to fill the tiles # -- added xscale, yscale arguments to show the marginal frequencies at top & right # -- added line_col to change the color of the diagonal line ## Modified 3/24/2012 11:38AM by M. friendly # -- fixed buglet with yscale=TRUE and reverse_y=FALSE "agreementplot" <- function (x, ...) UseMethod ("agreementplot") "agreementplot.formula" <- function (formula, data = NULL, ..., subset) { m <- match.call(expand.dots = FALSE) edata <- eval(m$data, parent.frame()) if (inherits(edata, "ftable") || inherits(edata, "table")) { data <- as.table(data) varnames <- attr(terms(formula), "term.labels") if (all(varnames != ".")) data <- margin.table(data, match(varnames, names(dimnames(data)))) agreementplot(data, ...) } else { if (is.matrix(edata)) m$data <- as.data.frame(data) m$... <- NULL m[[1L]] <- quote(stats::model.frame) mf <- eval(m, parent.frame()) if (length(formula) == 2) { by <- mf y <- NULL } else { i <- attr(attr(mf, "terms"), "response") by <- mf[-i] y <- mf[[i]] } by <- lapply(by, factor) x <- if (is.null(y)) do.call("table", by) else if (NCOL(y) == 1) tapply(y, by, sum) else { z <- lapply(as.data.frame(y), tapply, by, sum) array(unlist(z), dim = c(dim(z[[1]]), length(z)), dimnames = c(dimnames(z[[1]]), list(names(z)))) } x[is.na(x)] <- 0 agreementplot(x, ...) } } "agreementplot.default" <- function(x, reverse_y = TRUE, main = NULL, weights = c(1, 1 - 1 / (ncol(x) - 1)^2), margins = par("mar"), newpage = TRUE, pop = TRUE, xlab = names(dimnames(x))[2], ylab = names(dimnames(x))[1], xlab_rot = 0, xlab_just = "center", ylab_rot = 90, ylab_just = "center", fill_col = function(j) gray((1 - (weights[j]) ^ 2) ^ 0.5), line_col = "red", xscale=TRUE, yscale = TRUE, return_grob = FALSE, prefix = "", ...) { if (length(dim(x)) > 2) stop("Function implemented for two-way tables only!") if (ncol(x) != nrow(x)) stop("Dimensions must have equal length!") nc <- ncol(x) ## compute relative frequencies n <- sum(x) colFreqs <- colSums(x) / n rowFreqs <- rowSums(x) / n ## open viewport if (newpage) grid.newpage() pushViewport(plotViewport(margins, name = paste(prefix,"agreementplot"))) pushViewport(viewport(width = unit(1, "snpc"), height = unit(1, "snpc"))) if(!is.null(main)) grid.text(main, y = unit(1.1, "npc"), gp = gpar(fontsize = 25)) ## axis labels grid.text(xlab, y = -0.12, gp = gpar(fontsize = 20)) grid.text(ylab, x = -0.1, gp = gpar(fontsize = 20), rot = 90) grid.rect(gp = gpar(fill = "transparent")) xc <- c(0, cumsum(colFreqs)) yc <- c(0, cumsum(rowFreqs)) my.text <- if(reverse_y) function(y, ...) grid.text(y = y, ...) else function(y, ...) grid.text(y = 1 - y, ...) my.rect <- if(reverse_y) function(xleft, ybottom, xright, ytop, ...) grid.rect(x = xleft, y = ybottom, width = xright - xleft, height = ytop - ybottom, just = c("left","bottom"), ...) else function(xleft, ybottom, xright, ytop, ...) grid.rect(x = xleft, y = 1 - ybottom, width = xright - xleft, height = ytop - ybottom, just = c("left","top"), ...) A <- matrix(0, length(weights), nc) for (i in 1:nc) { ## x - axis grid.text(dimnames(x)[[2]][i], x = xc[i] + (xc[i + 1] - xc[i]) / 2, y = - 0.04, check.overlap = TRUE, rot = xlab_rot, just = xlab_just, ...) ## y - axis my.text(dimnames(x)[[1]][i], y = yc[i] + (yc[i + 1] - yc[i]) / 2, x = - 0.03, check.overlap = TRUE, rot = ylab_rot, just = ylab_just, ...) ## expected rectangle my.rect(xc[i], yc[i], xc[i + 1], yc[i + 1]) ## observed rectangle y0 <- c(0, cumsum(x[i,])) / sum(x[i,]) x0 <- c(0, cumsum(x[,i])) / sum(x[,i]) rec <- function (col, dens, lb, tr) my.rect(xc[i] + (xc[i + 1] - xc[i]) * x0[lb], yc[i] + (yc[i + 1] - yc[i]) * y0[lb], xc[i] + (xc[i + 1] - xc[i]) * x0[tr], yc[i] + (yc[i + 1] - yc[i]) * y0[tr], gp = gpar(fill = fill_col(j), col = col, rot = 135) ) for (j in length(weights):1) { lb <- max(1, i - j + 1) tr <- 1 + min(nc, i + j - 1) A[j, i] <- sum(x[lb:(tr-1),i]) * sum(x[i, lb:(tr-1)]) rec("white", NULL, lb, tr) ## erase background rec("black", if (weights[j] < 1) weights[j] * 20 else NULL, lb, tr) } ## correct A[j,i] -> not done by Friendly==Bug? for (j in length(weights):1) if (j > 1) A[j, i] <- A[j, i] - A[j - 1, i] } if (reverse_y) grid.lines(c(0, 1), c(0, 1), gp = gpar(col = line_col, linetype = "longdash")) else grid.lines(c(0, 1), c(1, 0), gp = gpar(col = line_col, linetype = "longdash")) if (xscale) { cx <- xc[-(nc+1)] + diff(xc)/2 grid.text(colSums(x), x = cx, y = 1.03, rot = xlab_rot, just = xlab_just, ...) grid.xaxis(at = xc, label = FALSE, main=FALSE, gp = gpar(fontsize=10), draw = TRUE, vp = NULL) } if (yscale) { cy <- yc[-(nc+1)] + diff(yc)/2 my.text(rowSums(x), x = 1.04, y = cy, rot = 0, just = ylab_just, ...) grid.yaxis(at = if(reverse_y) yc else 1-yc, FALSE, main=FALSE, gp = gpar(fontsize=10), draw = TRUE, vp = NULL) } if (pop) popViewport(2) else upViewport(2) ## Statistics - Returned invisibly ads <- crossprod(diag(x)) ar <- n * n * crossprod(colFreqs, rowFreqs) if (return_grob) invisible(structure(list( Bangdiwala = ads / ar, Bangdiwala_Weighted = (sum(weights * A)) / ar, weights = weights), grob = grid.grab() ) ) else invisible(list( Bangdiwala = ads / ar, Bangdiwala_Weighted = (sum(weights * A)) / ar, weights = weights) ) } vcd/R/woolf_test.R0000755000175100001440000000131411150520606013553 0ustar hornikuserswoolf_test <- function(x) { DNAME <- deparse(substitute(x)) if (any(x == 0)) x <- x + 1 / 2 k <- dim(x)[3] or <- apply(x, 3, function(x) (x[1,1] * x[2,2]) / (x[1,2] * x[2,1])) w <- apply(x, 3, function(x) 1 / sum(1 / x)) o <- log(or) e <- weighted.mean(log(or), w) STATISTIC <- sum(w * (o - e)^2) PARAMETER <- k - 1 PVAL <- 1 - pchisq(STATISTIC, PARAMETER) METHOD <- "Woolf-test on Homogeneity of Odds Ratios (no 3-Way assoc.)" names(STATISTIC) <- "X-squared" names(PARAMETER) <- "df" structure(list(statistic = STATISTIC, parameter = PARAMETER, p.value = PVAL, method = METHOD, data.name = DNAME, observed = o, expected = e), class = "htest") } vcd/R/lodds.R0000755000175100001440000002514212566042766012522 0ustar hornikusersodds <- function(x, log = FALSE, ...) lodds(x, log = log, ...) lodds <- function(x, ...) UseMethod("lodds") lodds.formula <- function(formula, data = NULL, ..., subset = NULL, na.action = NULL) { m <- match.call(expand.dots = FALSE) edata <- eval(m$data, parent.frame()) fstr <- strsplit(paste(deparse(formula), collapse = ""), "~") vars <- strsplit(strsplit(gsub(" ", "", fstr[[1]][2]), "\\|")[[1]], "\\+") varnames <- vars[[1]] condnames <- if (length(vars) > 1) vars[[2]] else NULL dep <- gsub(" ", "", fstr[[1]][1]) if (!dep %in% c("","Freq")) { if (all(varnames == ".")) { varnames <- if (is.data.frame(data)) colnames(data) else names(dimnames(as.table(data))) varnames <- varnames[-which(varnames %in% dep)] } varnames <- c(dep, varnames) } if (inherits(edata, "ftable") || inherits(edata, "table") || length(dim(edata)) > 2) { condind <- NULL dat <- as.table(data) if(all(varnames != ".")) { ind <- match(varnames, names(dimnames(dat))) if (any(is.na(ind))) stop(paste("Can't find", paste(varnames[is.na(ind)], collapse=" / "), "in", deparse(substitute(data)))) if (!is.null(condnames)) { condind <- match(condnames, names(dimnames(dat))) if (any(is.na(condind))) stop(paste("Can't find", paste(condnames[is.na(condind)], collapse=" / "), "in", deparse(substitute(data)))) ind <- c(ind, condind) } dat <- margin.table(dat, ind) } lodds.default(dat, strata = if (is.null(condind)) NULL else match(condnames, names(dimnames(dat))), ...) } else { m <- m[c(1, match(c("formula", "data", "subset", "na.action"), names(m), 0))] m[[1]] <- as.name("xtabs") m$formula <- formula(paste(if("Freq" %in% colnames(data)) "Freq", "~", paste(c(varnames, condnames), collapse = "+"))) tab <- eval(m, parent.frame()) lodds.default(tab, ...) } } lodds.default <- function(x, response = NULL, strata = NULL, log = TRUE, ref = NULL, correct = any(x == 0), ...) { ## check dimensions L <- length(d <- dim(x)) if(any(d < 2L)) stop("All table dimensions must be 2 or greater") ## assign and check response and stata; convert variable names to indices if (is.null(response)) { if (is.null(strata)) { response <- 1 strata <- setdiff(1:L, response) } else { # only strata was specified if(L - length(strata) != 1L) stop("All but 1 dimension must be specified as strata.") if(is.character(strata)) strata <- which(names(dimnames(x)) == strata) response <- setdiff(1:L, strata) } } else { # response was specified; take strata as the complement if(length(response) > 1) stop("Only 1 dimension can be specified as a response") if(is.character(response)) response <- which(names(dimnames(x)) == response) if (!is.null(strata)) warning(paste("strata =", paste(strata, collapse=","), "ignored when response has been specified")) strata <- setdiff(1:L, response) } ## dimensions of primary R x 1 table ### [Or should this just be a vector???] dp <- if (length(strata)) d[response] else d dn <- if (length(strata)) dimnames(x)[response] else dimnames(x) R <- dp[1] C <- 1 # shadow matrix with proper dimnames X <- matrix(0, R, C, dimnames=dn) ## process reference category if(!is.null(ref)) { if(is.character(ref)) { ref <- match(ref, colnames(x)) } else if(is.numeric(ref)) { ref <- as.integer(ref) } else { stop("Wrong 'ref=' argument!") } } ## compute corresponding indices compute_index <- function(n, ref) { if(is.null(ref)) return(cbind(1:(n-1), 2:n)) rval <- cbind(ref, 1:n) d <- rval[,2L] - rval[,1L] rval <- rbind( rval[d > 0, 1:2], rval[d < 0, 2:1] ) return(rval[order(rval[,1L]),,drop = FALSE]) } Rix <- compute_index(R, ref[[1L]]) contr <- matrix(0L, nrow = (R-1), ncol = R) colnames(contr) <- rownames(X) rownames(contr) <- rep("", R-1) for(i in 1:(R-1)) { rix <- i cix <- Rix[i,] contr[rix, cix] <- c(1L, -1L) rownames(contr)[rix] <- paste(rownames(X)[Rix[i,]], collapse = ":") } ## handle strata if (!is.null(strata)) { if (length(strata)==1) { sn <- dimnames(x)[[strata]] } else { sn <- apply(expand.grid(dimnames(x)[strata]), 1, paste, collapse = ":") } rn <- as.vector(outer( dimnames(contr)[[1]], sn, paste, sep='|')) cn <- as.vector(outer( dimnames(contr)[[2]], sn, paste, sep='|')) contr <- kronecker(diag(prod(dim(x)[strata])), contr) rownames(contr) <- rn colnames(contr) <- cn } ## dimnames for array version dn <- list(rep("", R-1)) for(i in 1:(R-1)) dn[[1]][i] <- paste(rownames(X)[Rix[i,]], collapse = ":") if (!is.null(strata)) dn <- c(dn, dimnames(x)[strata]) ndn <- names(dimnames(x)) if (!is.null(names(dimnames(x)))) names(dn) <- c(ndn[response], ndn[strata]) ## point estimates if (is.logical(correct)) { add <- if(correct) 0.5 else 0 } else if(is.numeric(correct)) { add <- as.vector(correct) if (length(add) != length(x)) stop("array size of 'correct' does not conform to the data") } else stop("correct is not valid") ## reorder columns of contrast matrix to match original data contr <- contr[, order(as.vector(aperm(array(seq.int(prod(d)), d), c(response, strata))))] ##coef <- drop(contr %*% log(as.vector(x) + add)) ##FIXME: 0 cells mess up the matrix product, try workaround: mat <- log(as.vector(x) + add) * t(contr) nas <- apply(contr != 0 & is.na(t(mat)), 1, any) coef <- apply(mat, 2, sum, na.rm = TRUE) coef[nas] <- NA ## covariances ##vcov <- crossprod(diag(sqrt(1/(as.vector(x) + add))) %*% t(contr)) tmp <- sqrt(1/(as.vector(x) + add)) * t(contr) tmp[is.na(tmp)] <- 0 vcov <- crossprod(tmp) vcov[nas,] <- NA vcov[,nas] <- NA rval <- structure(list( response = response, strata = strata, coefficients = coef, dimnames = dn, dim = as.integer(sapply(dn, length)), vcov = vcov, contrasts = contr, log = log ), class = "lodds") rval } ## ---------------- Methods ------------------- summary.lodds <- function(object, ...) lmtest::coeftest(object, ...) ## dim methods dimnames.lodds <- function(x, ...) x$dimnames dim.lodds <- function(x, ...) x$dim ## t/aperm-methods t.lodds <- function(x) aperm(x) ### FIXME aperm.lodds <- function(a, perm = NULL, ...) { d <- length(a$dim) if(is.null(perm)) { perm <- if (d < 3) 2L : 1L else c(2L : 1L, d : 3L) } else { if (any(perm[1:2] > 2L) || (d > 2L) && any(perm[-c(1:2)] < 2L)) stop("Mixing of strata and non-strata variables not allowed!") } nams <- names(a$coefficients) a$coefficients <- as.vector(aperm(array(a$coef, dim = a$dim), perm, ...)) nams <- as.vector(aperm(array(nams, dim = a$dim), perm, ...)) names(a$coefficients) <- nams a$dimnames <- a$dimnames[perm] a$dim <- a$dim[perm] a$vcov <- a$vcov[nams, nams] a$contrasts <- a$contrasts[nams,] a } ## straightforward methods coef.lodds <- function(object, log = object$log, ...) if(log) object$coefficients else exp(object$coefficients) vcov.lodds <- function(object, log = object$log, ...) if(log) object$vcov else `diag<-`(object$vcov, diag(object$vcov) * exp(object$coefficients)^2) confint.lodds <- function(object, parm, level = 0.95, log = object$log, ...) { if (log) confint.default(object, parm = parm, level = level, ... ) else { object$log = TRUE exp(confint.default(object, parm = parm, level = level, ... )) } } ### DONE: ## The header should say: # (log) odds for vn[response] by ... all the rest (strata) # Fixed: clash with make_header in loddsratio make_header_odds <- function(x) { vn <- names(dimnames(x)) resp <- vn[x$response] strat <- paste(vn[x$strata], collapse=", ") header <- c(if(x$log) "log" else "", "odds for", resp, "by", strat, # if (length(vn)>2) c("by", paste(vn[-(1:2)], collapse=', ')), "\n\n") paste(header, sep = " ") } ## print method print.lodds <- function(x, log = x$log, ...) { cat(make_header_odds(x)) print(drop(array(coef(x, log = log), dim = dim(x), dimnames = dimnames(x)), ...)) invisible(x) } ## as.data.frame #as.data.frame.lodds <- # function(x, ...) # as.data.frame.table(vcd:::as.array.loddsratio(x), ...) ## Q: I don't understand the purpose of the row.names and optional arguments ## DM: The generic has them, so each method must have them, too as.data.frame.lodds <- function(x, row.names = NULL, optional = FALSE, log=x$log, ...) { df <-data.frame(expand.grid(dimnames(x)), logodds = coef(x, log = log), ASE = sqrt(diag(vcov(x, log = log))), row.names = row.names, ... ) if (!log) colnames(df)[ncol(df) - 1] <- "odds" df } ## FIXME ## reshape coef() methods as.matrix.lodds <- function (x, log=x$log, ...) { ## Coef <- coef(x, log = log) ## if (length(dim(x))==2) matrix(Coef, ncol = dim(x)[2], dimnames=dimnames(x)) ## else { # drop leading dimensions with length 1, then reshape ## ddim <- which(dim(x)[1:2]==1) ## dim(Coef) <- dim(x)[-ddim] ## dimnames(Coef) <- dimnames(x)[-ddim] ## if (length(dim(Coef))==1) Coef ## else ## matrix(Coef, ncol = prod(dim(Coef)[-1]), ## dimnames=list(dimnames(Coef)[[1]], apply(expand.grid(dimnames(Coef)[[-1]]), 1, paste, collapse = ":"))) ## } as.array(x, log = log, ...) } as.array.lodds <- function (x, log=x$log, ...) { res <- array(coef(x, log = log), dim = dim(x), dimnames=dimnames(x)) drop(res) } vcd/R/plot.loglm.R0000755000175100001440000000206612305101202013450 0ustar hornikusersplot.loglm <- function(x, panel = mosaic, type = c("observed", "expected"), residuals_type = c("pearson", "deviance"), gp = shading_hcl, gp_args = list(), ...) { residuals_type <- match.arg(tolower(residuals_type), c("pearson", "deviance")) if(is.null(x$fitted)) x <- update(x, fitted = TRUE) expected <- fitted(x) residuals <- residuals(x, type = "pearson") observed <- residuals * sqrt(expected) + expected if(residuals_type == "deviance") residuals <- residuals(x, type = "deviance") gp <- if(inherits(gp, "grapcon_generator")) do.call("gp", c(list(observed, residuals, expected, x$df), as.list(gp_args))) else gp panel(observed, residuals = residuals, expected = expected, type = type, residuals_type = residuals_type, gp = gp, ...) } mosaic.loglm <- function(x, ...) { plot(x, panel = mosaic, ...) } assoc.loglm <- function(x, ...) { plot(x, panel = assoc, ...) } sieve.loglm <- function(x, ...) { plot(x, panel = sieve, ...) } vcd/R/hls.R0000755000175100001440000000106511150520606012157 0ustar hornikusershls <- function(h = 1, l = 0.5, s = 1) { RGB <- function(q1, q2, hue) { if (hue > 360) hue <- hue - 360 if (hue < 0) hue <- hue + 360 if (hue < 60) q1 + (q2 - q1) * hue / 60 else if (hue < 180) q2 else if (hue < 240) q1 + (q2 - q1) * (240 - hue) / 60 else q1 } h <- h * 360 p2 <- if (l <= 0.5) l * (1 + s) else l + s - (l * s) p1 <- 2 * l - p2; if (s == 0) R <- G <- B <- l else { R <- RGB(p1, p2, h + 120) G <- RGB(p1, p2, h) B <- RGB(p1, p2, h - 120) } rgb(R, G, B) } vcd/R/mosaic.R0000755000175100001440000003526313641353220012656 0ustar hornikusers########################################################### ## mosaicplot mosaic <- function(x, ...) UseMethod("mosaic") mosaic.formula <- function(formula, data = NULL, highlighting = NULL, ..., main = NULL, sub = NULL, subset = NULL, na.action = NULL) { if (is.logical(main) && main) main <- deparse(substitute(data)) else if (is.logical(sub) && sub) sub <- deparse(substitute(data)) m <- match.call(expand.dots = FALSE) edata <- eval(m$data, parent.frame()) fstr <- strsplit(paste(deparse(formula), collapse = ""), "~") vars <- strsplit(strsplit(gsub(" ", "", fstr[[1]][2]), "\\|")[[1]], "\\+") varnames <- vars[[1]] condnames <- if (length(vars) > 1) vars[[2]] else NULL dep <- gsub(" ", "", fstr[[1]][1]) if (is.null(highlighting) && (!dep %in% c("","Freq"))) { if (all(varnames == ".")) { varnames <- if (is.data.frame(data)) colnames(data) else names(dimnames(as.table(data))) varnames <- varnames[-which(varnames %in% dep)] } varnames <- c(varnames, dep) highlighting <- length(varnames) + length(condnames) } if (inherits(edata, "ftable") || inherits(edata, "table") || length(dim(edata)) > 2) { condind <- NULL dat <- as.table(data) if(all(varnames != ".")) { ind <- match(varnames, names(dimnames(dat))) if (any(is.na(ind))) stop(paste("Can't find", paste(varnames[is.na(ind)], collapse=" / "), "in", deparse(substitute(data)))) if (!is.null(condnames)) { condind <- match(condnames, names(dimnames(dat))) if (any(is.na(condind))) stop(paste("Can't find", paste(condnames[is.na(condind)], collapse=" / "), "in", deparse(substitute(data)))) ind <- c(condind, ind) } dat <- margin.table(dat, ind) } mosaic.default(dat, main = main, sub = sub, highlighting = highlighting, condvars = if (is.null(condind)) NULL else match(condnames, names(dimnames(dat))), ...) } else { m <- m[c(1, match(c("formula", "data", "subset", "na.action"), names(m), 0))] m[[1]] <- as.name("xtabs") m$formula <- formula(paste(if("Freq" %in% colnames(data)) "Freq", "~", paste(c(condnames, varnames), collapse = "+"))) tab <- eval(m, parent.frame()) mosaic.default(tab, main = main, sub = sub, highlighting = highlighting, ...) } } mosaic.default <- function(x, condvars = NULL, split_vertical = NULL, direction = NULL, spacing = NULL, spacing_args = list(), gp = NULL, expected = NULL, shade = NULL, highlighting = NULL, highlighting_fill = rev(gray.colors(tail(dim(x), 1))), highlighting_direction = NULL, zero_size = 0.5, zero_split = FALSE, zero_shade = NULL, zero_gp = gpar(col = 0), panel = NULL, main = NULL, sub = NULL, ...) { zero_shade <- !is.null(shade) && shade || !is.null(expected) || !is.null(gp) if (!is.null(shade) && !shade) zero_shade = FALSE if (is.logical(main) && main) main <- deparse(substitute(x)) else if (is.logical(sub) && sub) sub <- deparse(substitute(x)) if (is.structable(x)) { if (is.null(direction) && is.null(split_vertical)) split_vertical <- attr(x, "split_vertical") x <- as.table(x) } if (is.null(split_vertical)) split_vertical <- FALSE d <- dim(x) dl <- length(d) ## splitting argument if (!is.null(direction)) split_vertical <- direction == "v" if (length(split_vertical) == 1) split_vertical <- rep(c(split_vertical, !split_vertical), length.out = dl) if (length(split_vertical) < dl) split_vertical <- rep(split_vertical, length.out = dl) ## highlighting if (!is.null(highlighting)) { if (is.character(highlighting)) highlighting <- match(highlighting, names(dimnames(x))) if (length(highlighting) > 0) { if (is.character(condvars)) condvars <- match(condvars, names(dimnames(x))) perm <- if (length(condvars) > 0) c(condvars, seq(dl)[-c(condvars,highlighting)], highlighting) else c(seq(dl)[-highlighting], highlighting) x <- aperm(x, perm) d <- d[perm] split_vertical <- split_vertical[perm] if (is.null(spacing)) spacing <- spacing_highlighting if (is.function(highlighting_fill)) highlighting_fill <- highlighting_fill(d[dl]) if (is.null(gp)) gp <- gpar(fill = aperm(array(highlighting_fill, dim = rev(d)))) if (!is.null(highlighting_direction)) { split_vertical[dl] <- highlighting_direction %in% c("left", "right") if (highlighting_direction %in% c("left", "top")) { ## ugly: tmp <- as.data.frame.table(x) tmp[,dl] <- factor(tmp[,dl], rev(levels(tmp[,dl]))) x <- xtabs(Freq ~ ., data = tmp) gp <- gpar(fill = aperm(array(rev(highlighting_fill), dim = rev(d)))) } } } } else if (!is.null(condvars)) { # Conditioning only if (is.character(condvars)) condvars <- match(condvars, names(dimnames(x))) if (length(condvars) > 0) { perm <- c(condvars, seq(dl)[-condvars]) x <- aperm(x, perm) split_vertical <- split_vertical[perm] } if (is.null(spacing)) spacing <- spacing_conditional } ## spacing argument if (is.null(spacing)) spacing <- if (dl < 3) spacing_equal else spacing_increase strucplot(x, condvars = if (is.null(condvars)) NULL else length(condvars), core = struc_mosaic(zero_size = zero_size, zero_split = zero_split, zero_shade = zero_shade, zero_gp = zero_gp, panel = panel), split_vertical = split_vertical, spacing = spacing, spacing_args = spacing_args, gp = gp, expected = expected, shade = shade, main = main, sub = sub, ...) } ## old code: more elegant, but less performant ## ## struc_mosaic2 <- function(zero_size = 0.5, zero_split = FALSE, ## zero_shade = TRUE, zero_gp = gpar(col = 0)) ## function(residuals, observed, expected = NULL, spacing, gp, split_vertical, prefix = "") { ## dn <- dimnames(observed) ## dnn <- names(dn) ## dx <- dim(observed) ## dl <- length(dx) ## ## split workhorse ## zerostack <- character(0) ## split <- function(x, i, name, row, col, zero) { ## cotab <- co_table(x, 1) ## margin <- sapply(cotab, sum) ## v <- split_vertical[i] ## d <- dx[i] ## ## compute total cols/rows and build split layout ## dist <- unit.c(unit(margin, "null"), spacing[[i]]) ## idx <- matrix(1:(2 * d), nrow = 2, byrow = TRUE)[-2 * d] ## layout <- if (v) ## grid.layout(ncol = 2 * d - 1, widths = dist[idx]) ## else ## grid.layout(nrow = 2 * d - 1, heights = dist[idx]) ## vproot <- viewport(layout.pos.col = col, layout.pos.row = row, ## layout = layout, name = remove_trailing_comma(name)) ## ## next level: either create further splits, or final viewports ## name <- paste(name, dnn[i], "=", dn[[i]], ",", sep = "") ## row <- col <- rep.int(1, d) ## if (v) col <- 2 * 1:d - 1 else row <- 2 * 1:d - 1 ## f <- if (i < dl) ## function(m) { ## co <- cotab[[m]] ## z <- mean(co) <= .Machine$double.eps ## if (z && !zero && !zero_split) zerostack <<- c(zerostack, name[m]) ## split(co, i + 1, name[m], row[m], col[m], z && !zero_split) ## } ## else ## function(m) { ## if (cotab[[m]] <= .Machine$double.eps && !zero) ## zerostack <<- c(zerostack, name[m]) ## viewport(layout.pos.col = col[m], layout.pos.row = row[m], ## name = remove_trailing_comma(name[m])) ## } ## vpleaves <- structure(lapply(1:d, f), class = c("vpList", "viewport")) ## vpTree(vproot, vpleaves) ## } ## ## start spltting on top, creates viewport-tree ## pushViewport(split(observed + .Machine$double.eps, ## i = 1, name = paste(prefix, "cell:", sep = ""), ## row = 1, col = 1, zero = FALSE)) ## ## draw rectangles ## mnames <- apply(expand.grid(dn), 1, ## function(i) paste(dnn, i, collapse=",", sep = "=") ## ) ## zeros <- observed <= .Machine$double.eps ## ## draw zero cell lines ## for (i in remove_trailing_comma(zerostack)) { ## seekViewport(i) ## grid.lines(x = 0.5) ## grid.lines(y = 0.5) ## if (!zero_shade && zero_size > 0) { ## grid.points(0.5, 0.5, pch = 19, size = unit(zero_size, "char"), ## gp = zero_gp, ## name = paste(prefix, "disc:", mnames[i], sep = "")) ## grid.points(0.5, 0.5, pch = 1, size = unit(zero_size, "char"), ## name = paste(prefix, "circle:", mnames[i], sep = "")) ## } ## } ## # draw boxes ## for (i in seq_along(mnames)) { ## seekViewport(paste(prefix, "cell:", mnames[i], sep = "")) ## gpobj <- structure(lapply(gp, function(x) x[i]), class = "gpar") ## if (!zeros[i]) { ## grid.rect(gp = gpobj, name = paste(prefix, "rect:", mnames[i], sep = "")) ## } else { ## if (zero_shade && zero_size > 0) { ## grid.points(0.5, 0.5, pch = 19, size = unit(zero_size, "char"), ## gp = gpar(col = gp$fill[i]), ## name = paste(prefix, "disc:", mnames[i], sep = "")) ## grid.points(0.5, 0.5, pch = 1, size = unit(zero_size, "char"), ## name = paste(prefix, "circle:", mnames[i], sep = "")) ## } ## } ## } ## } ## class(struc_mosaic2) <- "grapcon_generator" struc_mosaic <- function(zero_size = 0.5, zero_split = FALSE, zero_shade = TRUE, zero_gp = gpar(col = 0), panel = NULL) function(residuals, observed, expected = NULL, spacing, gp, split_vertical, prefix = "") { dn <- dimnames(observed) dnn <- names(dn) dx <- dim(observed) dl <- length(dx) zeros <- function(gp, name) { grid.lines(x = 0.5) grid.lines(y = 0.5) if (zero_size > 0) { grid.points(0.5, 0.5, pch = 19, size = unit(zero_size, "char"), gp = gp, name = paste(prefix, "disc:", name, sep = "")) grid.points(0.5, 0.5, pch = 1, size = unit(zero_size, "char"), name = paste(prefix, "circle:", name, sep = "")) } } ## split workhorse zerostack <- character(0) split <- function(x, i, name, row, col, zero, index) { cotab <- co_table(x, 1) margin <- sapply(cotab, sum) margin[margin == 0] <- .Machine$double.eps # margin <- margin + .Machine$double.eps v <- split_vertical[i] d <- dx[i] ## compute total cols/rows and build split layout dist <- if (d > 1) unit.c(unit(margin, "null"), spacing[[i]]) else unit(margin, "null") idx <- matrix(1:(2 * d), nrow = 2, byrow = TRUE)[-2 * d] layout <- if (v) grid.layout(ncol = 2 * d - 1, widths = dist[idx]) else grid.layout(nrow = 2 * d - 1, heights = dist[idx]) pushViewport(viewport(layout.pos.col = col, layout.pos.row = row, layout = layout, name = paste(prefix, "cell:", remove_trailing_comma(name), sep = ""))) ## next level: either create further splits, or final viewports row <- col <- rep.int(1, d) if (v) col <- 2 * 1:d - 1 else row <- 2 * 1:d - 1 for (m in 1:d) { nametmp <- paste(name, dnn[i], "=", dn[[i]][m], ",", sep = "") if (i < dl) { co <- cotab[[m]] ## zeros z <- mean(co) <= .Machine$double.eps split(co, i + 1, nametmp, row[m], col[m], z && !zero_split, cbind(index, m)) if (z && !zero && !zero_split && !zero_shade && (zero_size > 0)) zeros(zero_gp, nametmp) } else { pushViewport(viewport(layout.pos.col = col[m], layout.pos.row = row[m], name = paste(prefix, "cell:", remove_trailing_comma(nametmp), sep = ""))) ## zeros if (cotab[[m]] <= .Machine$double.eps && !zero) { zeros(if (!zero_shade) zero_gp else gpar(col = gp$fill[cbind(index,m)]), nametmp) } else { ## rectangles gpobj <- structure(lapply(gp, function(x) x[cbind(index, m)]), class = "gpar") nam <- paste(prefix, "rect:", remove_trailing_comma(nametmp), sep = "") if (!is.null(panel)) panel(residuals, observed, expected, c(cbind(index, m)), gpobj, nam) else grid.rect(gp = gpobj, name = nam) } } upViewport(1) } } ## start splitting on top, creates viewport-tree split(observed, i = 1, name = "", row = 1, col = 1, zero = FALSE, index = cbind()) } class(struc_mosaic) <- "grapcon_generator" vcd/R/assocstats.R0000644000175100001440000000323614541402627013570 0ustar hornikusersassocstats <- function(x) { if(!is.matrix(x)) { l <- length(dim(x)) str <- apply(x, 3 : l, FUN = assocstats) if (l == 3) { names(str) <- paste(names(dimnames(x))[3], names(str), sep = ":") } else { dn <- dimnames(str) dim(str) <- NULL names(str) <- apply(expand.grid(dn), 1, function(x) paste(names(dn), x, sep = ":", collapse = "|")) } return(str) } tab <- summary(loglm(~1+2, x))$tests phi <- sqrt(tab[2,1] / sum(x)) cont <- sqrt(phi^2 / (1 + phi^2)) cramer <- sqrt(phi^2 / min(dim(x) - 1)) structure( list(table = x, chisq_tests = tab, phi = ifelse(all(dim(x) == 2L), phi, NA), contingency = cont, cramer = cramer), class = "assocstats" ) } print.assocstats <- function(x, digits = 3, ...) { print(x$chisq_tests, digits = 5, ...) cat("\n") cat("Phi-Coefficient :", round(x$phi, digits = digits), "\n") cat("Contingency Coeff.:", round(x$contingency, digits = digits), "\n") cat("Cramer's V :", round(x$cramer, digits = digits), "\n") invisible(x) } summary.assocstats <- function(object, percentage = FALSE, ...) { tab <- summary(object$table, percentage = percentage, ...) tab$chisq <- NULL structure(list(summary = tab, object = object), class = "summary.assocstats" ) } print.summary.assocstats <- function(x, ...) { cat("\n") print(x$summary, ...) print(x$object, ...) cat("\n") invisible(x) } vcd/R/Kappa.R0000755000175100001440000000454612477411346012451 0ustar hornikusersKappa <- function (x, weights = c("Equal-Spacing", "Fleiss-Cohen")) { if (is.character(weights)) weights <- match.arg(weights) d <- diag(x) n <- sum(x) nc <- ncol(x) colFreqs <- colSums(x)/n rowFreqs <- rowSums(x)/n ## Kappa kappa <- function (po, pc) (po - pc) / (1 - pc) std <- function (p, pc, kw, W = diag(1, ncol = nc, nrow = nc)) { sqrt((sum(p * sweep(sweep(W, 1, W %*% colSums(p) * (1 - kw)), 2, W %*% rowSums(p) * (1 - kw)) ^ 2) - (kw - pc * (1 - kw)) ^ 2) / crossprod(1 - pc) / n) } ## unweighted po <- sum(d) / n pc <- crossprod(colFreqs, rowFreqs)[1] k <- kappa(po, pc) s <- std(x / n, pc, k) ## weighted W <- if (is.matrix(weights)) weights else if (weights == "Equal-Spacing") 1 - abs(outer(1:nc, 1:nc, "-")) / (nc - 1) else 1 - (abs(outer(1:nc, 1:nc, "-")) / (nc - 1))^2 pow <- sum(W * x) / n pcw <- sum(W * colFreqs %o% rowFreqs) kw <- kappa(pow, pcw) sw <- std(x / n, pcw, kw, W) structure( list(Unweighted = c( value = k, ASE = s ), Weighted = c( value = kw, ASE = sw ), Weights = W ), class = "Kappa" ) } print.Kappa <- function (x, digits=max(getOption("digits") - 3, 3), CI=FALSE, level=0.95, ...) { tab <- rbind(x$Unweighted, x$Weighted) z <- tab[,1] / tab[,2] tab <- cbind(tab, z, `Pr(>|z|)` = 2 * pnorm(-abs(z))) if (CI) { q <- qnorm((1 + level)/2) lower <- tab[,1] - q * tab[,2] upper <- tab[,1] + q * tab[,2] tab <- cbind(tab, lower, upper) } rownames(tab) <- names(x)[1:2] print(tab, digits=digits, ...) invisible(x) } summary.Kappa <- function (object, ...) structure(object, class = "summary.Kappa") print.summary.Kappa <- function (x, ...) { print.Kappa(x, ...) cat("\nWeights:\n") print(x$Weights, ...) invisible(x) } confint.Kappa <- function(object, parm, level = 0.95, ...) { q <- qnorm((1 + level) / 2) matrix(c(max(-1, object[[1]][1] - object[[1]][2] * q), min(1, object[[1]][1] + object[[1]][2] * q), max(-1, object[[2]][1] - object[[2]][2] * q), min(1, object[[2]][1] + object[[2]][2] * q)), ncol = 2, byrow = TRUE, dimnames = list(Kappa = c("Unweighted","Weighted"), c("lwr","upr")) ) } vcd/R/mplot.R0000755000175100001440000000471112445041730012531 0ustar hornikusersmplot <- function(..., .list = list(), layout = NULL, cex = NULL, main = NULL, gp_main = gpar(fontsize = 20), sub = NULL, gp_sub = gpar(fontsize = 15), keep_aspect_ratio = TRUE) { l <- c(list(...), .list) ll <- length(l) m <- !is.null(main) s <- !is.null(sub) ## calculate layout if (is.null(layout)) layout <- c(trunc(sqrt(ll)), ceiling(ll / trunc(sqrt(ll)))) ## push base layout grid.newpage() hts = unit(1 - 0.1 * m - 0.1 * s, "null") if (m) hts <- c(unit(0.1, "null"), hts) if (s) hts <- c(hts, unit(0.1, "null")) pushViewport(viewport(layout = grid.layout(nrow = 1 + m + s, ncol = 1, heights = hts) ) ) ## push main, if any if (!is.null(main)) { pushViewport(viewport(layout.pos.row = 1, layout.pos.col = NULL)) grid.text(main, gp = gp_main) popViewport(1) } ## push strucplots if (is.null(cex)) cex <- sqrt(1/layout[1]) pushViewport(viewport(layout.pos.row = 1 + m, layout.pos.col = NULL)) pushViewport(viewport(layout = grid.layout(nrow = layout[1], ncol = layout[2]), gp = gpar(cex = cex) ) ) count <- 1 for (i in seq_len(layout[1])) for (j in seq_len(layout[2])) if(count <= ll) { pushViewport(viewport(layout.pos.row = i, layout.pos.col = j)) pushViewport(viewport(width = 1, height = 1, default.units = if (keep_aspect_ratio) "snpc" else "npc")) if (inherits(l[[count]], "grob")) grid.draw(l[[count]]) else if (!is.null(attr(l[[count]], "grob"))) grid.draw(attr(l[[count]], "grob")) popViewport(2) count <- count + 1 } popViewport(2) ## push sub, if any if (!is.null(sub)) { pushViewport(viewport(layout.pos.row = 1 + m + s, layout.pos.col = NULL)) grid.text(sub, gp = gp_sub) popViewport() } popViewport(1) } vcd/R/tabletools.R0000755000175100001440000000522712456226636013565 0ustar hornikusersindependence_table <- function(x, frequency = c("absolute", "relative")) { if (!is.array(x)) stop("Need array of absolute frequencies!") frequency <- match.arg(frequency) n <- sum(x) x <- x / n d <- dim(x) ## build margins margins <- lapply(1:length(d), function(i) apply(x, i, sum)) ## multiply all combinations & reshape tab <- array(apply(expand.grid(margins), 1, prod), d, dimnames = dimnames(x)) if (frequency == "relative") tab else tab * n } mar_table <- function(x) { if(!is.matrix(x)) stop("Function only defined for 2-way tables.") tab <- rbind(cbind(x, TOTAL = rowSums(x)), TOTAL = c(colSums(x), sum(x))) names(dimnames(tab)) <- names(dimnames(x)) tab } table2d_summary <- function(object, margins = TRUE, percentages = FALSE, conditionals = c("none", "row", "column"), chisq.test = TRUE, ... ) { ret <- list() if (chisq.test) ret$chisq <- summary.table(object, ...) if(is.matrix(object)) { conditionals <- match.arg(conditionals) tab <- array(0, c(dim(object) + margins, 1 + percentages + (conditionals != "none"))) ## frequencies tab[,,1] <- if(margins) mar_table(object) else object ## percentages if(percentages) { tmp <- prop.table(object) tab[,,2] <- 100 * if(margins) mar_table(tmp) else tmp } ## conditional distributions if(conditionals != "none") { tmp <- prop.table(object, margin = 1 + (conditionals == "column")) tab[,,2 + percentages] <- 100 * if(margins) mar_table(tmp) else tmp } ## dimnames dimnames(tab) <- c(dimnames(if(margins) mar_table(object) else object), list(c("freq", if(percentages) "%", switch(conditionals, row = "row%", column = "col%") ) ) ) ## patch row% / col% margins if(conditionals == "row") tab[dim(tab)[1],,2 + percentages] <- NA if(conditionals == "column") tab[,dim(tab)[2],2 + percentages] <- NA ret$table <- tab } class(ret) <- "table2d_summary" ret } print.table2d_summary <- function (x, digits = max(1, getOption("digits") - 3), ...) { if (!is.null(x$table)) if(dim(x$table)[3] == 1) print(x$table[,,1], digits = digits, ...) else print(ftable(aperm(x$table, c(1,3,2))), 2, digits = digits, ...) cat("\n") if (!is.null(x$chisq)) print.summary.table(x$chisq, digits, ...) invisible(x) } vcd/R/oddsratioplot.R0000755000175100001440000001125312475151320014264 0ustar hornikusers"oddsratio" <- function(x, stratum = NULL, log = TRUE) loddsratio(x, strata = stratum, log = log) ## "oddsratio" <- ## function (x, stratum = NULL, log = TRUE) { ## l <- length(dim(x)) ## if (l > 2 && is.null(stratum)) ## stratum <- 3:l ## if (l - length(stratum) > 2) ## stop("All but 2 dimensions must be specified as strata.") ## if (l == 2 && dim(x) != c(2, 2)) ## stop("Not a 2x2 table.") ## if (!is.null(stratum) && dim(x)[-stratum] != c(2,2)) ## stop("Need strata of 2x2 tables.") ## lor <- function (y) { ## if (any(y == 0)) ## y <- y + 0.5 ## y <- log(y) ## or <- y[1,1] + y[2,2] - y[1,2] - y[2,1] ## if (log) or else exp(or) ## } ## ase <- function(y) { ## if (any(y == 0)) ## y <- y + 0.5 ## sqrt(sum(1/y)) ## } ## if(is.null(stratum)) { ## LOR <- lor(x) ## ASE <- ase(x) ## } else { ## LOR <- apply(x, stratum, lor) ## ASE <- apply(x, stratum, ase) ## } ## structure(LOR, ## ASE = ASE, ## log = log, ## class = "oddsratio" ## )} ## "print.oddsratio" <- ## function(x, ...) { ## if (length(dim(x)) > 1) ## print(cbind(unclass(x)), ...) ## else ## print(c(x), ...) ## invisible(x) ## } ## "summary.oddsratio" <- ## function(object, ...) { ## if(!is.null(dim(object))) ## ret <- object ## else { ## LOG <- attr(object, "log") ## ASE <- attr(object, "ASE") ## Z <- object / ASE ## ret <- cbind("Estimate" = object, ## "Std. Error" = if (LOG) ASE, ## "z value" = if (LOG) Z, ## "Pr(>|z|)" = if (LOG) 2 * pnorm(-abs(Z)) ## ) ## colnames(ret)[1] <- if (LOG) "Log Odds Ratio" else "Odds Ratio" ## } ## class(ret) <- "summary.oddsratio" ## ret ## } ## "print.summary.oddsratio" <- ## function(x, ...) { ## if(!is.null(attr(x, "log"))) { ## cat("\n") ## cat(if(attr(x, "log")) "Log Odds Ratio(s):" else "Odds Ratio(s):", "\n\n") ## print(as.data.frame(unclass(x)), ...) ## cat("\nAsymptotic Standard Error(s):\n\n") ## print(attr(x, "ASE"), ...) ## cat("\n") ## } else printCoefmat(unclass(x), ...) ## invisible(x) ## } ## "plot.oddsratio" <- ## function(x, ## conf_level = 0.95, ## type = "o", ## xlab = NULL, ## ylab = NULL, ## xlim = NULL, ## ylim = NULL, ## whiskers = 0.1, ## baseline = TRUE, ## transpose = FALSE, ## ...) ## { ## if (length(dim(x)) > 1) ## stop ("Plot function works only on vectors.") ## LOG <- attr(x, "log") ## confidence <- !(is.null(conf_level) || conf_level == FALSE) ## oddsrange <- range(x) ## if(confidence) { ## CI <- confint(x, level = conf_level) ## lwr <- CI[,1] ## upr <- CI[,2] ## oddsrange[1] <- trunc(min(oddsrange[1], min(lwr))) ## oddsrange[2] <- ceiling(max(oddsrange[2], max(upr))) ## } ## if (transpose) { ## plot(x = unclass(x), ## y = 1:length(x), ## ylab = if (!is.null(ylab)) ylab else "Strata", ## xlab = if (!is.null(xlab)) xlab else if (LOG) "Log Odds Ratio" else "Odds Ratio", ## type = type, ## yaxt = "n", ## xlim = if(is.null(xlim)) oddsrange else xlim, ## ...) ## axis (2, at = 1:length(x), names(x)) ## if (baseline) ## lines(c(1,1) - LOG, c(0,length(x) + 1), lty = 2, col = "red") ## if (confidence) ## for (i in 1:length(x)) { ## lines(c(lwr[i], upr[i]), c(i, i)) ## lines(c(lwr[i], lwr[i]), c(i - whiskers/2, i + whiskers/2)) ## lines(c(upr[i], upr[i]), c(i - whiskers/2, i + whiskers/2)) ## } ## } else { ## plot(unclass(x), ## xlab = if (!is.null(xlab)) xlab else "Strata", ## ylab = if(!is.null(ylab)) ylab else if(LOG) "Log Odds Ratio" else "Odds Ratio", ## type = type, ## xaxt = "n", ## ylim = if(is.null(ylim)) oddsrange else ylim, ## ...) ## axis (1, at = 1:length(x), names(x)) ## if (baseline) ## lines(c(0,length(x) + 1), c(1,1) - LOG, lty = 2, col = "red") ## if (confidence) ## for (i in 1:length(x)) { ## lines(c(i, i), c(lwr[i], upr[i])) ## lines(c(i - whiskers/2, i + whiskers/2), c(lwr[i], lwr[i])) ## lines(c(i - whiskers/2, i + whiskers/2), c(upr[i], upr[i])) ## } ## } ## } ## "confint.oddsratio" <- ## function(object, parm, level = 0.95, ...) { ## ASE <- attr(object, "ASE") ## LOG <- attr(object, "log") ## I <- ASE * qnorm((1 + level) / 2) ## cbind( ## lwr = if (LOG) object - I else exp(log(object) - I), ## upr = if (LOG) object + I else exp(log(object) + I) ## ) ## } vcd/R/doubledeckerplot.R0000755000175100001440000000624213631232345014730 0ustar hornikusers####################################### ### doubledecker plot doubledecker <- function(x, ...) UseMethod("doubledecker") doubledecker.formula <- function(formula, data = NULL, ..., main = NULL) { if (is.logical(main) && main) main <- deparse(substitute(data)) if (is.structable(data)) data <- as.table(data) m <- match.call(expand.dots = FALSE) edata <- eval(m$data, parent.frame()) fstr <- strsplit(paste(deparse(formula), collapse = ""), "~") vars <- strsplit(strsplit(gsub(" ", "", fstr[[1]][2]), "\\|")[[1]], "\\+") dep <- gsub(" ", "", fstr[[1]][1]) varnames <- vars[[1]] if (dep == "") stop("Need a dependent variable!") varnames <- c(varnames, dep) if(inherits(edata, "ftable") || inherits(edata, "table") || length(dim(edata)) > 2) { dat <- as.table(data) if(all(varnames != ".")) { ind <- match(varnames, names(dimnames(dat))) if (any(is.na(ind))) stop(paste("Can't find", paste(varnames[is.na(ind)], collapse=" / "), "in", deparse(substitute(data)))) dat <- margin.table(dat, ind) } else { ind <- match(dep, names(dimnames(dat))) if (is.na(ind)) stop(paste("Can't find", dep, "in", deparse(substitute(data)))) dat <- aperm(dat, c(seq_along(dim(dat))[-ind], ind)) } doubledecker.default(dat, main = main, ...) } else { tab <- if ("Freq" %in% colnames(data)) xtabs(formula(paste("Freq~", varnames, collapse = "+")), data = data) else xtabs(formula(paste("~", varnames, collapse = "+")), data = data) doubledecker.default(tab, main = main, ...) } } doubledecker.default <- function(x, depvar = length(dim(x)), margins = c(1, 4, length(dim(x)) + 1, 1), gp = gpar(fill = rev(gray.colors(tail(dim(x), 1)))), labeling = labeling_doubledecker, spacing = spacing_highlighting, main = NULL, keep_aspect_ratio = FALSE, ...) { x <- as.table(x) d <- dim(x) l <- length(d) if (is.character(depvar)) depvar <- match(depvar, names(dimnames(x))) condvars <- (1:l)[-depvar] ## order dependend var *last* x <- aperm(x, c(condvars, depvar)) ## recycle gpar elements along *last* dimension, if needed size <- prod(d) FUN <- function(par) { if (is.structable(par)) par <- as.table(par) if (length(par) < size || is.null(dim(par))) aperm(array(par, dim = rev(d))) else par } gp <- structure(lapply(gp, FUN), class = "gpar") strucplot(x, core = struc_mosaic(zero_split = FALSE, zero_shade = FALSE), condvars = l - 1, spacing = spacing, split_vertical = c(rep.int(TRUE, l - 1), FALSE), gp = gp, shade = TRUE, labeling = labeling, main = main, margins = margins, legend = NULL, keep_aspect_ratio = keep_aspect_ratio, ... ) } vcd/R/Ord_plot.R0000755000175100001440000000737412445046670013200 0ustar hornikusers# This should be revised to allow graphical parameters to be more easily passed # for points and lines # For now, added lwd, lty and col args for lines, with more useful defaults Ord_plot <- function(obj, legend = TRUE, estimate = TRUE, tol = 0.1, type = NULL, xlim = NULL, ylim = NULL, xlab = "Number of occurrences", ylab = "Frequency ratio", main = "Ord plot", gp = gpar(cex = 0.5), lwd = c(2,2), lty=c(2,1), col=c("black", "red"), name = "Ord_plot", newpage = TRUE, pop = TRUE, return_grob = FALSE, ...) { if(is.vector(obj)) { obj <- table(obj) } if(is.table(obj)) { if(length(dim(obj)) > 1) stop ("obj must be a 1-way table") x <- as.vector(obj) count <- as.numeric(names(obj)) } else { if(!(!is.null(ncol(obj)) && ncol(obj) == 2)) stop("obj must be a 2-column matrix or data.frame") x <- as.vector(obj[,1]) count <- as.vector(obj[,2]) } y <- count * x/c(NA, x[-length(x)]) fm <- lm(y ~ count) fmw <- lm(y ~ count, weights = sqrt(pmax(x, 1) - 1)) fit1 <- predict(fm, data.frame(count)) fit2 <- predict(fmw, data.frame(count)) if(is.null(xlim)) xlim <- range(count) if(is.null(ylim)) ylim <- range(c(y, fit1, fit2), na.rm = TRUE) xlim <- xlim + c(-1, 1) * diff(xlim) * 0.04 ylim <- ylim + c(-1, 1) * diff(ylim) * 0.04 lwd <- rep_len(lwd, 2) # assure length=2 lty <- rep_len(lty, 2) col <- rep_len(col, 2) if(newpage) grid.newpage() pushViewport(plotViewport(xscale = xlim, yscale = ylim, default.units = "native", name = name)) grid.points(x = count, y = y, default.units = "native", gp = gp, ...) grid.lines(x = count, y = fit1, default.units = "native", gp = gpar(lwd=lwd[1], lty=lty[1], col=col[1])) grid.lines(x = count, y = fit2, default.units = "native", gp = gpar(lwd=lwd[2], lty=lty[2], col=col[2])) grid.rect(gp = gpar(fill = "transparent")) grid.xaxis() grid.yaxis() grid.text(xlab, y = unit(-3.5, "lines")) grid.text(ylab, x = unit(-3, "lines"), rot = 90) grid.text(main, y = unit(1, "npc") + unit(2, "lines"), gp = gpar(fontface = "bold")) RVAL <- coef(fmw) names(RVAL) <- c("Intercept", "Slope") if(legend) { legend.text <- c(paste("slope =", round(RVAL[2], digits = 3)), paste("intercept =", round(RVAL[1], digits = 3))) if(estimate) { ordfit <- Ord_estimate(RVAL, type = type, tol = tol) legend.text <- c(legend.text, "", paste("type:", ordfit$type), paste("estimate:", names(ordfit$estimate),"=", round(ordfit$estimate, digits = 3))) legend.text <- paste(legend.text, collapse = "\n") } grid.text(legend.text, min(count), ylim[2] * 0.95, default.units = "native", just = c("left", "top")) } if(pop) popViewport() else upViewport() if(return_grob) invisible(structure(RVAL, grob = grid.grab())) else invisible(RVAL) } Ord_estimate <- function(x, type = NULL, tol = 0.1) { a <- x[1] b <- x[2] if(!is.null(type)) type <- match.arg(type, c("poisson", "binomial", "nbinomial", "log-series")) else { if(abs(b) < tol) type <- "poisson" else if(b < (-1 * tol)) type <- "binomial" else if(a > (-1 * tol)) type <- "nbinomial" else if(abs(a + b) < 4*tol) type <- "log-series" else type <- "none" } switch(type, "poisson" = { par <- a names(par) <- "lambda" if(par < 0) warning("lambda not > 0") }, "binomial" = { par <- b/(b - 1) names(par) <- "prob" if(abs(par - 0.5) > 0.5) warning("prob not in (0,1)") }, "nbinomial" = { par <- 1 - b names(par) <- "prob" if(abs(par - 0.5) > 0.5) warning("prob not in (0,1)") }, "log-series" = { par <- b names(par) <- "theta" if(par < 0) warning("theta not > 0") }, "none" = { par <- NA }) list(estimate = par, type = type) } vcd/R/grid_legend.R0000755000175100001440000001036712471732076013656 0ustar hornikusersgrid_legend <- function (x, y, pch = NA, col = par('col'), labels, frame = TRUE, hgap = unit(0.8, "lines"), vgap = unit(0.8, "lines"), default_units = "lines", gp = gpar(), draw = TRUE, title = NULL, just = 'center', lwd = NA, lty = NA, size = 1, gp_title = NULL, gp_labels = NULL, gp_frame = gpar(fill = "transparent"), inset = c(0, 0)) { inset <- rep(inset, length.out = 2) if((length(x) > 1) && missing(y)) { y <- x[2] x <- x[1] } if(is.character(x)) switch(x, left = {x = unit(0 + inset[1],'npc'); y = unit(0.5 + inset[2],'npc'); just = c("left","center")}, topleft = {x = unit(0 + inset[1],'npc'); y = unit(1 - inset[2],'npc'); just = c(0,1)}, top = {x = unit(0.5 + inset[1],'npc'); y = unit(1 - inset[2],'npc'); just = c("center", "top")}, topright = {x = unit(1 - inset[1],'npc'); y = unit(1 - inset[2],'npc'); just = c(1,1)}, center = {x = unit(0.5 + inset[1],'npc'); y = unit(0.5 + inset[2],'npc'); just = c("center","center")}, bottom = {x = unit(0.5 - inset[1],'npc'); y = unit(0 + inset[2],'npc'); just = c("center","bottom")}, bottomright = {x = unit(1 - inset[1],'npc'); y = unit(0 + inset[2],'npc'); just = c(1,0)}, right = {x = unit(1 - inset[1],'npc'); y = unit(0.5 + inset[2],'npc'); just = c("right","center")}, bottomleft = {x = unit(0 + inset[1],'npc'); y = unit(0 + inset[2],'npc'); just = c(0,0)}) labels <- as.character(labels) nlabs <- length(labels) if(length(pch) == 1) pch <- rep(pch, nlabs) if(length(lwd) == 1) lwd <- rep(lwd, nlabs) if(length(lty) == 1) lty <- rep(lty, nlabs) if(length(col) == 1) col <- rep(col, nlabs) if(length(gp_labels) == 1) gp_labels <- rep(list(gp_labels), nlabs) if (is.logical(title) && !title) title <- NULL if(is.null(title)) tit <- 0 else tit <- 1 if (!is.unit(hgap)) hgap <- unit(hgap, default_units) if (length(hgap) != 1) stop("hgap must be single unit") if (!is.unit(vgap)) vgap <- unit(vgap, default_units) if (length(vgap) != 1) stop("vgap must be single unit") if(tit) legend.layout <- grid.layout(nlabs + tit, 3, widths = unit.c(unit(2, "lines"), max(unit(rep(1, nlabs), "strwidth", as.list(c(labels))), unit(1, "strwidth", title) - unit(2, "lines")), hgap), heights = unit.pmax(unit(1, "lines"), vgap + unit(rep(1, nlabs + tit ), "strheight", as.list(c(labels,title))))) else legend.layout <- grid.layout(nlabs, 3, widths = unit.c(unit(2, "lines"), max(unit(rep(1, nlabs), "strwidth", as.list(labels))), hgap), heights = unit.pmax(unit(1, "lines"), vgap + unit(rep(1, nlabs), "strheight", as.list(labels)))) fg <- frameGrob(layout = legend.layout, gp = gp) if (frame) fg <- placeGrob(fg, rectGrob(gp = gp_frame)) if (tit) fg <- placeGrob(fg, textGrob(title, x = .2, y = 0.5, just = c("left", "center"), gp = gp_title), col = 1, row = 1) for (i in 1:nlabs) { if(!is.na(pch[i])) fg <- placeGrob(fg, pointsGrob(0.5, 0.5, pch = pch[i], size = unit(size, "char"), gp = gpar(col = col[i])), col = 1, row = i + tit) else if(!is.na(lwd[i]) || !is.na(lty[i])) fg <- placeGrob(fg, linesGrob( unit(c(0.2, .8), "npc"), unit(c(.5), "npc"), gp = gpar(col = col[i], lwd = lwd[i], lty=lty[i])), col = 1, row = i + tit) fg <- placeGrob(fg, textGrob(labels[i], x = .1, y = 0.5, just = c("left", "center"), gp = gp_labels[[i]]), col = 2, row = i + tit) } pushViewport(viewport(x, y, height = grobHeight(fg), width = grobWidth(fg), just = just )) if (draw) grid.draw(fg) popViewport(1) invisible(fg) } vcd/R/co_table.R0000755000175100001440000000161211623033204013135 0ustar hornikusersco_table <- function(x, margin, collapse = ".") { if (!is.array(x)) stop("x is not an array") if("xtabs" %in% class(x)) attr(x, "call") <- NULL dx <- dim(x) idx <- lapply(dx, function(i) 1:i) dn <- dimnames(x) if(is.character(margin)) { if(is.null(dn)) stop("margin must be an index when no dimnames are given") margin <- which(names(dn) %in% margin) } idxm <- expand.grid(idx[margin]) cotab1 <- function(i) { idx[margin] <- lapply(1:length(margin), function(j) idxm[i,j]) rval <- as.table(do.call("[", c(list(x), idx, list(drop = FALSE)))) if(length(dim(rval)) > 1) { dim(rval) <- dim(x)[-margin] dimnames(rval) <- dimnames(x)[-margin] } return(rval) } rval <- lapply(1:NROW(idxm), cotab1) if(!is.null(dn)) names(rval) <- apply(expand.grid(dn[margin]), 1, function(z) paste(z, collapse = collapse)) return(rval) } vcd/R/goodfit.R0000755000175100001440000002325212511044620013025 0ustar hornikusersgoodfit <- function(x, type = c("poisson", "binomial", "nbinomial"), method = c("ML", "MinChisq"), par = NULL) { if(is.vector(x)) { x <- table(x) } if(is.table(x)) { if(length(dim(x)) > 1) stop ("x must be a 1-way table") freq <- as.vector(x) count <- as.numeric(names(x)) } else { if(!(!is.null(ncol(x)) && ncol(x) == 2)) stop("x must be a 2-column matrix or data.frame") freq <- as.vector(x[,1]) count <- as.vector(x[,2]) } ## fill-in possibly missing cells nfreq <- rep(0, max(count) + 1) nfreq[count + 1] <- freq freq <- nfreq count <- 0:max(count) n <- length(count) ## starting value for degrees of freedom df <- -1 type <- match.arg(type) method <- match.arg(method) switch(type, "poisson" = { if(!is.null(par)) { if(!is.list(par)) stop("`par' must be a named list") if(names(par) != "lambda") stop("`par' must specify `lambda'") par <- par$lambda method <- "fixed" } else if(method == "ML") { df <- df - 1 par <- weighted.mean(count,freq) } else if(method == "MinChisq") { df <- df - 1 chi2 <- function(x) { p.hat <- diff(c(0, ppois(count[-n], lambda = x), 1)) expected <- sum(freq) * p.hat sum((freq - expected)^2/expected) } par <- optimize(chi2, range(count))$minimum } par <- list(lambda = par) p.hat <- dpois(count, lambda = par$lambda) }, "binomial" = { size <- par$size if(is.null(size)) { size <- max(count) warning("size was not given, taken as maximum count") } if(size > max(count)) { nfreq <- rep(0, size + 1) nfreq[count + 1] <- freq freq <- nfreq count <- 0:size n <- length(count) } if(!is.null(par$prob)) { if(!is.list(par)) stop("`par' must be a named list and specify `prob'") par <- par$prob method <- "fixed" } else if(method == "ML") { df <- df - 1 par <- weighted.mean(count/size, freq) } else if(method == "MinChisq") { df <- df - 1 chi2 <- function(x) { p.hat <- diff(c(0, pbinom(count[-n], prob = x, size = size), 1)) expected <- sum(freq) * p.hat sum((freq - expected)^2/expected) } par <- optimize(chi2, c(0,1))$minimum } par <- list(prob = par, size = size) p.hat <- dbinom(count, prob = par$prob, size = par$size) }, "nbinomial" = { if(!is.null(par)) { if(!is.list(par)) stop("`par' must be a named list") if(!(isTRUE(all.equal(names(par), "size")) | isTRUE(all.equal(sort(names(par)), c("prob", "size"))))) stop("`par' must specify `size' and possibly `prob'") if(!is.null(par$prob)) method <- "fixed" } switch(method, "ML" = { if(is.null(par$size)) { df <- df - 2 par <- fitdistr(rep(count, freq), "negative binomial")$estimate par <- par[1]/c(1, sum(par)) } else { df <- df - 1 method <- c("ML", "with size fixed") size <- par$size xbar <- weighted.mean(count,freq) par <- c(size, size/(xbar+size)) } }, "MinChisq" = { if(is.null(par$size)) { df <- df - 2 ## MM xbar <- weighted.mean(count,freq) s2 <- var(rep(count,freq)) p <- xbar / s2 size <- xbar^2/(s2 - xbar) par1 <- c(size, p) ## minChisq chi2 <- function(x) { p.hat <- diff(c(0, pnbinom(count[-n], size = x[1], prob = x[2]), 1)) expected <- sum(freq) * p.hat sum((freq - expected)^2/expected) } par <- optim(par1, chi2)$par } else { df <- df - 1 method <- c("MinChisq", "with size fixed") chi2 <- function(x) { p.hat <- diff(c(0, pnbinom(count[-n], size = par$size, prob = x), 1)) expected <- sum(freq) * p.hat sum((freq - expected)^2/expected) } par <- c(par$size, optimize(chi2, c(0, 1))$minimum) } }, "fixed" = { par <- c(par$size, par$prob) }) par <- list(size = par[1], prob = par[2]) p.hat <- dnbinom(count, size = par$size, prob = par$prob) }) expected <- sum(freq) * p.hat df <- switch(method[1], "MinChisq" = { length(freq) + df }, "ML" = { sum(freq > 0) + df }, "fixed" = { c(length(freq), sum(freq > 0)) + df } ) structure(list(observed = freq, count = count, fitted = expected, type = type, method = method, df = df, par = par), class = "goodfit") } # does this need a residuals_type arg? print.goodfit <- function(x, residuals_type = c("pearson", "deviance", "raw"), ...) { residuals_type <- match.arg(residuals_type) cat(paste("\nObserved and fitted values for", x$type, "distribution\n")) if(x$method[1] == "fixed") cat("with fixed parameters \n\n") else cat(paste("with parameters estimated by `", paste(x$method, collapse = " "), "' \n\n", sep = "")) resids <- residuals(x, type = residuals_type) RVAL <- cbind(x$count, x$observed, x$fitted, resids) colnames(RVAL) <- c("count", "observed", "fitted", paste(residuals_type, "residual")) rownames(RVAL) <- rep("", nrow(RVAL)) print(RVAL, ...) invisible(x) } summary.goodfit <- function(object, ...) { df <- object$df obsrvd <- object$observed count <- object$count expctd <- fitted(object) G2 <- sum(ifelse(obsrvd == 0, 0, obsrvd * log(obsrvd/expctd))) * 2 n <- length(obsrvd) pfun <- switch(object$type, poisson = "ppois", binomial = "pbinom", nbinomial = "pnbinom") p.hat <- diff(c(0, do.call(pfun, c(list(q = count[-n]), object$par)), 1)) expctd <- p.hat * sum(obsrvd) X2 <- sum((obsrvd - expctd)^2 / expctd) names(G2) <- "Likelihood Ratio" names(X2) <- "Pearson" if(any(expctd < 5) & object$method[1] != "ML") warning("Chi-squared approximation may be incorrect") RVAL <- switch(object$method[1], ML = G2, MinChisq = X2, fixed = c(X2, G2) ) RVAL <- cbind(RVAL, df, pchisq(RVAL, df = df, lower.tail = FALSE)) colnames(RVAL) <- c("X^2", "df", "P(> X^2)") cat(paste("\n\t Goodness-of-fit test for", object$type, "distribution\n\n")) print(RVAL, ...) invisible(RVAL) } plot.goodfit <- function(x, ...) { rootogram(x, ...) } fitted.goodfit <- function(object, ...) { object$fitted } residuals.goodfit <- function(object, type = c("pearson", "deviance", "raw"), ...) { obsrvd <- object$observed expctd <- fitted(object) count <- object$count n <- length(obsrvd) pfun <- switch(object$type, poisson = "ppois", binomial = "pbinom", nbinomial = "pnbinom") p.hat <- diff(c(0, do.call(pfun, c(list(q = count[-n]), object$par)), 1)) expctd <- p.hat * sum(obsrvd) res <- switch(match.arg(type), pearson = (obsrvd - expctd) / sqrt(expctd), deviance = ifelse(obsrvd == 0, 0, obsrvd * log(obsrvd / expctd)), obsrvd - expctd) return(res) } predict.goodfit <- function(object, newcount = NULL, type = c("response", "prob"), ...) { if(is.null(newcount)) newcount <- object$count type <- match.arg(type) densfun <- switch(object$type, poisson = "dpois", binomial = "dbinom", nbinomial = "dnbinom") RVAL <- do.call(densfun, c(list(x = newcount), object$par)) if (type == "response") RVAL <- RVAL * sum(object$observed) return(RVAL) } vcd/R/structable.R0000755000175100001440000004370013044210742013544 0ustar hornikusers######################################### ## structable structable <- function(x, ...) UseMethod("structable") structable.formula <- function(formula, data = NULL, direction = NULL, split_vertical = NULL, ..., subset, na.action) { if (missing(formula) || !inherits(formula, "formula")) stop("formula is incorrect or missing") m <- match.call(expand.dots = FALSE) edata <- eval(m$data, parent.frame()) if (!is.null(direction)) split_vertical <- direction == "v" if (is.structable(data)) { split_vertical <- attr(data, "split_vertical") data <- as.table(data) } if (is.null(split_vertical)) split_vertical <- FALSE if (length(formula) == 3 && formula[[2]] == "Freq") formula[[2]] = NULL ## only rhs present without `.' in lhs => xtabs-interface if (length(formula) != 3) { if (formula[[1]] == "~") { if (inherits(edata, "ftable") || inherits(edata, "table") || length(dim(edata)) > 2) { data <- as.table(data) varnames <- attr(terms(formula, allowDotAsName = TRUE), "term.labels") dnames <- names(dimnames(data)) di <- match(varnames, dnames) if (any(is.na(di))) stop("incorrect variable names in formula") if (all(varnames != ".")) data <- margin.table(data, di) return(structable(data, split_vertical = split_vertical, ...)) } else if (is.data.frame(data)) { if ("Freq" %in% colnames(data)) return(structable(xtabs(formula(paste("Freq", deparse(formula))), data = data), split_vertical = split_vertical, ...)) else return(structable(xtabs(formula, data), split_vertical = split_vertical, ...)) } else { if (is.matrix(edata)) m$data <- as.data.frame(data) m$... <- m$split_vertical <- m$direction <- NULL m[[1L]] <- quote(stats::model.frame) mf <- eval(m, parent.frame()) return(structable(table(mf), split_vertical = split_vertical, ...)) } } else stop("formula must have both left and right hand sides") } ## `ftable' behavior if (any(attr(terms(formula, allowDotAsName = TRUE), "order") > 1)) stop("interactions are not allowed") rvars <- attr(terms(formula[-2], allowDotAsName = TRUE), "term.labels") cvars <- attr(terms(formula[-3], allowDotAsName = TRUE), "term.labels") rhs.has.dot <- any(rvars == ".") lhs.has.dot <- any(cvars == ".") if (lhs.has.dot && rhs.has.dot) stop(paste("formula has", sQuote("."), "in both left and right hand side")) if (inherits(edata, "ftable") || inherits(edata, "table") || length(dim(edata)) > 2) { if (inherits(edata, "ftable")) data <- as.table(data) dnames <- names(dimnames(data)) rvars <- pmatch(rvars, dnames) cvars <- pmatch(cvars, dnames) if (rhs.has.dot) rvars <- seq_along(dnames)[-cvars] else if (any(is.na(rvars))) stop("incorrect variable names in rhs of formula") if (lhs.has.dot) cvars <- seq_along(dnames)[-rvars] else if (any(is.na(cvars))) stop("incorrect variable names in lhs of formula") split_vertical <- c(rep(FALSE, length(rvars)), rep(TRUE, length(cvars))) structable(margin.table(data, c(rvars, cvars)), split_vertical = split_vertical, ...) } else { if (is.matrix(edata)) m$data <- as.data.frame(data) m$... <- m$split_vertical <- m$direction <- NULL if (!is.null(data) && is.environment(data)) { dnames <- names(data) if (rhs.has.dot) rvars <- seq_along(dnames)[-cvars] if (lhs.has.dot) cvars <- seq_along(dnames)[-rvars] } else { if (lhs.has.dot || rhs.has.dot) stop("cannot use dots in formula with given data") } if ("Freq" %in% colnames(m$data)) m$formula <- formula(paste("Freq~", paste(c(rvars, cvars), collapse = "+"))) else m$formula <- formula(paste("~", paste(c(rvars, cvars), collapse = "+"))) m[[1]] <- as.name("xtabs") mf <- eval(m, parent.frame()) split_vertical <- c(rep(FALSE, length(rvars)), rep(TRUE, length(cvars))) structable(mf, split_vertical = split_vertical, ...) } } structable.default <- function(..., direction = NULL, split_vertical = FALSE) { ## several checks & transformations for arguments args <- list(...) if (length(args) == 0) stop("Nothing to tabulate") x <- args[[1]] x <- if (is.list(x)) table(x) else if (inherits(x, "ftable")) as.table(x) else if (!(is.array(x) && length(dim(x)) > 1 || inherits(x, "table"))) do.call("table", as.list(substitute(list(...)))[-1]) else x if (is.null(dimnames(x))) dimnames(x) <- lapply(dim(x), function(i) letters[seq_len(i)]) if (is.null(names(dimnames(x)))) names(dimnames(x)) <- LETTERS[seq_along(dim(x))] idx <- sapply(names(dimnames(x)), nchar) < 1 if(any(idx)) names(dimnames(x))[idx] <- LETTERS[seq_len(sum(idx))] ## splitting argument dl <- length(dim(x)) if (!is.null(direction)) split_vertical <- direction == "v" if (length(split_vertical) == 1) split_vertical <- rep(c(split_vertical, !split_vertical), length.out = dl) if (length(split_vertical) < dl) split_vertical <- rep(split_vertical, length.out = dl) ## permute & reshape ret <- base::aperm(x, c(rev(which(!split_vertical)), rev(which(split_vertical)))) dn <- dimnames(x) rv <- dn[split_vertical] cv <- dn[!split_vertical] rl <- if (length(rv)) sapply(rv, length) else 1 cl <- if (length(cv)) sapply(cv, length) else 1 dim(ret) <- c(prod(cl), prod(rl)) ## add dimnames attr(ret, "dnames") <- dn attr(ret, "split_vertical") <- split_vertical ## add dimension attributes in ftable-format attr(ret, "col.vars") <- rv attr(ret, "row.vars") <- cv class(ret) <- c("structable", "ftable") ret } "[[.structable" <- function(x, ...) { if(nargs() > 3) stop("Incorrect number of dimensions (max: 2).") args <- if (nargs() < 3) list(..1) else .massage_args(...) args <- lapply(args, function(x) if (is.logical(x)) which(x) else x) ## handle one-arg cases if (nargs() < 3) if (length(args[[1]]) > 1) ## resolve calls like x[[c(1,2)]] return(x[[ args[[1]][1] ]] [[ args[[1]][-1] ]]) else ## resolve x[[foo]] return(if (attr(x, "split_vertical")[1]) x[[,args[[1]] ]] else x[[args[[1]],]]) ## handle calls like x[[c(1,2), c(3,4)]] if (length(args[[1]]) > 1 && length(args[[2]]) > 1) return(x[[ args[[1]][1], args[[2]][1] ]] [[ args[[1]][-1], args[[2]][-1] ]]) ## handle calls like x[[c(1,2), 3]] if (length(args[[1]]) > 1) return(x[[ args[[1]][1], args[[2]] ]] [[ args[[1]][-1], ]]) ## handle calls like x[[1, c(1,3)]] if (length(args[[2]]) > 1) return(x[[ args[[1]], args[[2]][1] ]] [[ , args[[2]][-1] ]]) ## final cases like x[[1,2]] or x[[1,]] or x[[,1]] dnames <- attr(x, "dnames") split <- attr(x, "split_vertical") rv <- dnames[!split] cv <- dnames[split] lsym <- is.symbol(args[[1]]) rsym <- is.symbol(args[[2]]) if (!lsym) { rstep <- dim(unclass(x))[1] / length(rv[[1]]) if (is.character(args[[1]])) args[[1]] <- match(args[[1]], rv[[1]]) } if (!rsym) { cstep <- dim(unclass(x))[2] / length(cv[[1]]) if (is.character(args[[2]])) args[[2]] <- match(args[[2]], cv[[1]]) } lind <- if (!lsym) (1 + (args[[1]] - 1) * rstep) : (args[[1]] * rstep) else 1:nrow(unclass(x)) rind <- if (!rsym) (1 + (args[[2]] - 1) * cstep) : (args[[2]] * cstep) else 1:ncol(unclass(x)) ret <- unclass(x)[lind, rind, drop = FALSE] if (!lsym) { i <- which(!split)[1] split <- split[-i] dnames <- dnames[-i] } if (!rsym) { i <- which(split)[1] split <- split[-i] dnames <- dnames[-i] } attr(ret, "split_vertical") <- split attr(ret, "dnames") <- dnames ## add dimension attributes in ftable-format attr(ret, "col.vars") <- dnames[split] attr(ret, "row.vars") <- dnames[!split] class(ret) <- class(x) ret } "[[<-.structable" <- function(x, ..., value) { args <- if (nargs() < 4) list(..1) else .massage_args(...) ## handle one-arg cases if (nargs() < 4) return(if (length(args[[1]]) > 1) ## resolve calls like x[[c(1,2)]]<-value Recall(x, args[[1]][1], value = Recall(x[[ args[[1]][1] ]], args[[1]][-1], value = value)) else ## resolve x[[foo]]<-value if (attr(x, "split_vertical")[1]) Recall(x,,args[[1]], value = value) else Recall(x,args[[1]],, value = value) ) ## handle calls like x[[c(1,2), c(3,4)]]<-value if (length(args[[1]]) > 1 && length(args[[2]]) > 1) return(Recall(x, args[[1]][1], args[[2]][1], value = Recall(x[[ args[[1]][1], args[[2]][1] ]], args[[1]][-1], args[[2]][-1], value = value))) ## handle calls like x[[c(1,2), 3]]<-value if (length(args[[1]]) > 1) return(Recall(x, args[[1]][1], args[[2]], value = Recall(x[[ args[[1]][1], args[[2]] ]], args[[1]][-1], ,value = value))) ## handle calls like x[[1, c(1,3)]]<-value if (length(args[[2]]) > 1) return(Recall(x, args[[1]], args[[2]][1], value = Recall(x[[ args[[1]], args[[2]][1] ]],, args[[2]][-1], value = value))) ## final cases like x[[1,2]]<-value or x[[1,]]<-value or x[[,1]]<-value dnames <- attr(x, "dnames") split <- attr(x, "split_vertical") rv <- dnames[!split] cv <- dnames[split] lsym <- is.symbol(args[[1]]) rsym <- is.symbol(args[[2]]) if (!lsym) { rstep <- dim(unclass(x))[1] / length(rv[[1]]) if (is.character(args[[1]])) args[[1]] <- match(args[[1]], rv[[1]]) } if (!rsym) { cstep <- dim(unclass(x))[2] / length(cv[[1]]) if (is.character(args[[2]])) args[[2]] <- match(args[[2]], cv[[1]]) } lind <- if (!lsym) (1 + (args[[1]] - 1) * rstep) : (args[[1]] * rstep) else 1:nrow(unclass(x)) rind <- if (!rsym) (1 + (args[[2]] - 1) * cstep) : (args[[2]] * cstep) else 1:ncol(unclass(x)) ret <- unclass(x) ret[lind, rind] <- value class(ret) <- class(x) ret } "[.structable" <- function(x, ...) { if(nargs() > 3) stop("Incorrect number of dimensions (max: 2).") args <- if (nargs() < 3) list(..1) else .massage_args(...) args <- lapply(args, function(x) if (is.logical(x)) which(x) else x) ## handle one-arg cases if (nargs() < 3) return(if (attr(x, "split_vertical")[1]) x[,args[[1]] ] else x[args[[1]],]) ## handle calls like x[c(1,2), foo] if (length(args[[1]]) > 1) return(do.call(rbind, lapply(args[[1]], function(i) x[i, args[[2]]]))) ## handle calls like x[foo, c(1,3)] if (length(args[[2]]) > 1) return(do.call(cbind, lapply(args[[2]], function(i) x[args[[1]], i]))) ## final cases like x[1,2] or x[1,] or x[,1] dnames <- attr(x, "dnames") split <- attr(x, "split_vertical") rv <- dnames[!split] cv <- dnames[split] lsym <- is.symbol(args[[1]]) rsym <- is.symbol(args[[2]]) if (!lsym) { rstep <- dim(unclass(x))[1] / length(rv[[1]]) if (is.character(args[[1]])) args[[1]] <- match(args[[1]], rv[[1]]) } if (!rsym) { cstep <- dim(unclass(x))[2] / length(cv[[1]]) if (is.character(args[[2]])) args[[2]] <- match(args[[2]], cv[[1]]) } lind <- if (!lsym) (1 + (args[[1]] - 1) * rstep) : (args[[1]] * rstep) else 1:nrow(unclass(x)) rind <- if (!rsym) (1 + (args[[2]] - 1) * cstep) : (args[[2]] * cstep) else 1:ncol(unclass(x)) ret <- unclass(x)[lind, rind, drop = FALSE] if (!lsym) { i <- which(!split)[1] dnames[[i]] <- dnames[[i]][args[[1]]] } if (!rsym) { i <- which(split)[1] dnames[[i]] <- dnames[[i]][args[[2]]] } attr(ret, "split_vertical") <- split attr(ret, "dnames") <- dnames ## add dimension attributes in ftable-format attr(ret, "col.vars") <- dnames[split] attr(ret, "row.vars") <- dnames[!split] class(ret) <- class(x) ret } "[<-.structable" <- function(x, ..., value) { args <- if (nargs() < 4) list(..1) else .massage_args(...) ## handle one-arg cases if (nargs() < 4) return(## resolve x[foo] if (attr(x, "split_vertical")[1]) Recall(x,,args[[1]], value = value) else Recall(x,args[[1]],, value = value) ) ## handle calls like x[c(1,2), 3] if (length(args[[1]]) > 1) { for (i in seq_along(args[[1]])) x[ args[[1]][i], args[[2]] ] <- value[i,] return(x) } ## handle calls like x[1, c(2,3)] if (length(args[[2]]) > 1) { for (i in seq_along(args[[2]])) x[ args[[1]], args[[2]][i] ] <- value[,i] return(x) } ## final cases like x[1,2] or x[1,] or x[,1] dnames <- attr(x, "dnames") split <- attr(x, "split_vertical") rv <- dnames[!split] cv <- dnames[split] lsym <- is.symbol(args[[1]]) rsym <- is.symbol(args[[2]]) if (!lsym) { rstep <- dim(unclass(x))[1] / length(rv[[1]]) if (is.character(args[[1]])) args[[1]] <- match(args[[1]], rv[[1]]) } if (!rsym) { cstep <- dim(unclass(x))[2] / length(cv[[1]]) if (is.character(args[[2]])) args[[2]] <- match(args[[2]], cv[[1]]) } lind <- if (!lsym) (1 + (args[[1]] - 1) * rstep) : (args[[1]] * rstep) else 1:nrow(unclass(x)) rind <- if (!rsym) (1 + (args[[2]] - 1) * cstep) : (args[[2]] * cstep) else 1:ncol(unclass(x)) ret <- unclass(x) ret[lind, rind] <- value class(ret) <- class(x) ret } cbind.structable <- function(..., deparse.level = 1) { mergetables <- function(t1, t2) { ret <- cbind(unclass(t1),unclass(t2)) class(ret) <- class(t1) attr(ret, "split_vertical") <- attr(t1, "split_vertical") attr(ret, "dnames") <- attr(t1, "dnames") attr(ret, "row.vars") <- attr(t1, "row.vars") attr(ret, "col.vars") <- attr(t1, "col.vars") attr(ret, "col.vars")[[1]] <- c(attr(t1, "col.vars")[[1]],attr(t2, "col.vars")[[1]]) if (length(unique(attr(ret, "col.vars")[[1]])) != length(attr(ret, "col.vars")[[1]])) stop("Levels of factor(s) to be merged must be unique.") attr(ret, "dnames")[names(attr(ret, "col.vars"))] <- attr(ret, "col.vars") ret } args <- list(...) if (length(args) < 2) return(args[[1]]) ret <- mergetables(args[[1]], args[[2]]) if (length(args) > 2) do.call(cbind, c(list(ret), args[-(1:2)])) else ret } rbind.structable <- function(..., deparse.level = 1) { mergetables <- function(t1, t2) { ret <- rbind(unclass(t1),unclass(t2)) class(ret) <- class(t1) attr(ret, "split_vertical") <- attr(t1, "split_vertical") attr(ret, "dnames") <- attr(t1, "dnames") attr(ret, "row.vars") <- attr(t1, "row.vars") attr(ret, "col.vars") <- attr(t1, "col.vars") attr(ret, "row.vars")[[1]] <- c(attr(t1, "row.vars")[[1]],attr(t2, "row.vars")[[1]]) if (length(unique(attr(ret, "row.vars")[[1]])) != length(attr(ret, "row.vars")[[1]])) stop("Levels of factor(s) to be merged must be unique.") attr(ret, "dnames")[names(attr(ret, "row.vars"))] <- attr(ret, "row.vars") ret } args <- list(...) if (length(args) < 2) return(args[[1]]) ret <- mergetables(args[[1]], args[[2]]) if (length(args) > 2) do.call(rbind, c(list(ret), args[-(1:2)])) else ret } as.table.structable <- function(x, ...) { class(x) <- "ftable" ret <- NextMethod("as.table", object = x) structure(base::aperm(ret, match(names(attr(x, "dnames")), names(dimnames(ret)))), class = "table") } plot.structable <- function(x, ...) mosaic(x, ...) t.structable <- function(x) { ret <- t.default(x) attr(ret, "split_vertical") <- !attr(ret, "split_vertical") hold <- attr(ret, "row.vars") attr(ret, "row.vars") = attr(ret, "col.vars") attr(ret, "col.vars") = hold ret } is.structable <- function(x) inherits(x, "structable") dim.structable <- function(x) as.integer(sapply(attr(x, "dnames"), length)) print.structable <- function(x, ...) { class(x) <- "ftable" NextMethod("print", object = x) } dimnames.structable <- function(x) attr(x,"dnames") as.vector.structable <- function(x, ...) as.vector(as.table(x), ...) ## FIXME: copy as.matrix.ftable, committed to R-devel on 2014/1/12 ## replace by call to as.matrix.ftable when this becomes stable as_matrix_ftable <- function (x, sep = "_", ...) { if (!inherits(x, "ftable")) stop("'x' must be an \"ftable\" object") make_dimnames <- function(vars) { structure(list(do.call(paste, c(rev(expand.grid(rev(vars))), list(sep = sep)))), names = paste(collapse = sep, names(vars))) } structure(unclass(x), dimnames = c(make_dimnames(attr(x, "row.vars")), make_dimnames(attr(x, "col.vars"))), row.vars = NULL, col.vars = NULL) } as.matrix.structable <- function(x, sep="_", ...) { structure(as_matrix_ftable(x, sep, ...), dnames = NULL, split_vertical = NULL ) } length.structable <- function(x) dim(x)[1] is.na.structable <- function(x) sapply(seq_along(x), function(sub) any(is.na(sub))) str.structable <- function(object, ...) str(unclass(object), ...) find.perm <- function(vec1, vec2) { unlist(Map(function(x) which(x == vec2), vec1)) } aperm.structable <- function(a, perm, resize=TRUE, ...){ newtable <- aperm(as.table(a), perm = perm, resize = resize, ...) if (!is.numeric(perm)) perm <- find.perm(names(dimnames(newtable)), names(dimnames(a))) structable(newtable, split_vertical = attr(a, "split_vertical")[perm]) } ############# helper function .massage_args <- function(...) { args <- vector("list", 2) args[[1]] <- if(missing(..1)) as.symbol("grrr") else ..1 args[[2]] <- if(missing(..2)) as.symbol("grrr") else ..2 args } vcd/demo/0000755000175100001440000000000012367374474012011 5ustar hornikusersvcd/demo/twoway.R0000755000175100001440000001521212475147056013464 0ustar hornikusers ##################### ## Fourfold tables ## ##################### ### Berkeley Admission Data ### ############################### data(UCBAdmissions) ## unstratified ### no margin is standardized x <- margin.table(UCBAdmissions, 2:1) fourfold(x, std = "i", extended = FALSE) ### std. for gender fourfold(x, margin = 1, extended = FALSE) ### std. for both fourfold(x, extended = FALSE) ## stratified fourfold(UCBAdmissions, extended = FALSE) fourfold(UCBAdmissions) ## extended plots ## using cotabplot cotabplot(UCBAdmissions, panel = function(x, condlevels, ...) fourfold(co_table(x, names(condlevels))[[paste(condlevels, collapse = ".")]], newpage = F, return_grob = FALSE, ...) ) ### Coal Miners Lung Data ### ############################# data(CoalMiners) ## Fourfold display, both margins equated fourfold(CoalMiners, mfcol = c(3,3)) ## Log Odds Ratio Plot data(CoalMiners, package = "vcd") lor_CM <- loddsratio(CoalMiners) plot(lor_CM) lor_CM_df <- as.data.frame(lor_CM) # fit linear models using WLS age <- seq(20, 60, by = 5) lmod <- lm(LOR ~ age, weights = 1 / ASE^2, data = lor_CM_df) grid.lines(age, fitted(lmod), gp = gpar(col = "blue")) qmod <- lm(LOR ~ poly(age, 2), weights = 1 / ASE^2, data = lor_CM_df) grid.lines(age, fitted(qmod), gp = gpar(col = "red")) ## Fourfold display, strata equated fourfold(CoalMiners, std = "ind.max", mfcol = c(3,3)) #################### ## Sieve Diagrams ## #################### ### Hair Eye Color ### ###################### data(HairEyeColor) ## aggregate over `sex': (tab <- margin.table(HairEyeColor, 1:2)) ## plot expected values: sieve(t(tab), sievetype = "expected", shade = TRUE) ## plot sieve diagram: sieve(t(tab), shade = TRUE) ### Visual Acuity ### ##################### data(VisualAcuity) attach(VisualAcuity) sieve(Freq ~ right + left, data = VisualAcuity, subset = gender == "female", main = "Unaided distant vision data", labeling_args = list(set_varnames = c(left = "Left Eye Grade", right = "Right Eye Grade")), shade = TRUE ) detach(VisualAcuity) ### Berkeley Admission ### ########################## ## -> Larger tables: e.g., Cross factors ### Cross Gender and Admission data(UCBAdmissions) (tab <- xtabs(Freq ~ Dept + I(Gender : Admit), data = UCBAdmissions)) sieve(tab, labeling_args = list(set_varnames = c("I(Gender:Admit)" = "Gender:Admission", Dept = "Department")), main = "Berkeley Admissions Data", shade = TRUE ) ## or use extended sieve plots: sieve(UCBAdmissions, shade = TRUE) ###################### ## Association Plot ## ###################### ### Hair Eye Color ### ###################### data(HairEyeColor) assoc(margin.table(HairEyeColor, 1:2), labeling_args = list(set_varnames = c(Hair = "Hair Color", Eye = "Eye Color")), main = "Association Plot") #################### ## Agreement Plot ## #################### ### Sexual Fun ### ################## data(SexualFun) ## Kappa statistics Kappa(SexualFun) ## Agreement Chart agreementplot(t(SexualFun), weights = 1) ## Partial Agreement Chart and B-Statistics (agreementplot(t(SexualFun), xlab = "Husband's Rating", ylab = "Wife's Rating", main = "Husband's and Wife's Sexual Fun") ) ### MS Diagnosis data ### ######################### data(MSPatients) ## use e.g., X11(width = 12), or expand graphics device agreementplot(t(MSPatients[,,1]), main = "Winnipeg Patients") agreementplot(t(MSPatients[,,2]), main = "New Orleans Patients") ################## ## Ternary Plot ## ################## ### sample data ### ################### (x <- rbind(c(A=10,B=10,C=80), c(40,30,30), c(20,60,20) ) ) ternaryplot(x, cex = 2, col = c("black", "blue", "red"), coordinates = TRUE ) ### Arthritis Treatment Data ### ################################ data(Arthritis) ## Build table by crossing Treatment and Sex (tab <- as.table(xtabs(~ I(Sex:Treatment) + Improved, data = Arthritis))) ## Mark groups col <- c("red", "red", "blue", "blue") pch <- c(1, 19, 1, 19) ## plot ternaryplot( tab, col = col, pch = pch, cex = 2, bg = "lightgray", grid_color = "white", labels_color = "white", main = "Arthritits Treatment Data" ) ## legend grid_legend(0.8, 0.7, pch, col, rownames(tab), title = "GROUP") ### Baseball Hitters Data ### ############################# data(Hitters) attach(Hitters) colors <- c("black","red","green","blue","red","black","blue") pch <- substr(levels(Positions), 1, 1) ternaryplot( Hitters[,2:4], pch = as.character(Positions), col = colors[as.numeric(Positions)], main = "Baseball Hitters Data" ) grid_legend(0.8, 0.9, pch, colors, levels(Positions), title = "POSITION(S)") detach(Hitters) ### Lifeboats on the Titanic ### ################################ data(Lifeboats) attach(Lifeboats) ternaryplot( Lifeboats[,4:6], pch = ifelse(side=="Port", 1, 19), col = ifelse(side=="Port", "red", "blue"), id = ifelse(men/total > 0.1, as.character(boat), NA), dimnames_position = "edge", dimnames = c("Men of Crew", "Men passengers", "Women and Children"), main = "Lifeboats on the Titanic" ) grid_legend(0.8, 0.9, c(1, 19), c("red", "blue"), c("Port", "Starboard"), title = "SIDE") ## Load against time for Port/Starboard boats plot(launch, total, pch = ifelse(side == "Port", 1, 19), col = ifelse(side == "Port", "red", "darkblue"), xlab = "Launch Time", ylab = "Total loaded", main = "Lifeboats on the Titanic" ) legend(as.POSIXct("1912-04-15 01:48:00"), 70, legend = c("SIDE","Port","Starboard"), pch = c(NA, 1, 19), col = c(NA, "red", "darkblue") ) text(as.POSIXct(launch), total, labels = as.character(boat), pos = 3, offset = 0.3 ) abline(lm(total ~ as.POSIXct(launch), subset = side == "Port"), col = "red") abline(lm(total ~ as.POSIXct(launch), subset = side == "Starboard"), col = "darkblue") detach(Lifeboats) vcd/demo/strucplot.R0000755000175100001440000000413111566471034014163 0ustar hornikusersdata("Titanic") data("UCBAdmissions") data("HairEyeColor") data("PreSex") mosaic(Titanic) mosaic(Titanic, shade = TRUE) mosaic(~ Sex + Class, data = Titanic, shade = TRUE) mosaic(~ Sex + Class + Survived, data = Titanic, shade = TRUE) mosaic(~ PremaritalSex + ExtramaritalSex | MaritalStatus + Gender, data = PreSex) mosaic(~ PremaritalSex + ExtramaritalSex | MaritalStatus + Gender, data = PreSex, labeling = labeling_conditional(abbreviate_varnames = TRUE)) mosaic(Titanic, spacing = spacing_increase()) mosaic(Titanic, spacing = spacing_equal()) mosaic(Titanic, labeling = labeling_border()) mosaic(Titanic, labeling = labeling_cells()) mosaic(Titanic, labeling = labeling_cells(abbreviate_labels = TRUE)) mosaic(Titanic, labeling = labeling_cells(abbreviate_varnames = TRUE)) mosaic(Titanic, labeling = labeling_cells(abbreviate_varnames = TRUE, abbreviate_labels = TRUE)) mosaic(Titanic, labeling = labeling_border(abbreviate = TRUE)) mosaic(Titanic, labeling = labeling_border(abbreviate = c(Survived = TRUE))) mosaic(Titanic, labeling = labeling_border(rot_labels = c(bottom = 45))) mosaic(Titanic, labeling = labeling_border(tl_labels = TRUE)) mosaic(Titanic, labeling = labeling_border(tl_labels = TRUE, tl_varnames = FALSE)) mosaic(Titanic, labeling = labeling_border(tl_labels = TRUE, tl_varnames = c(TRUE,TRUE,FALSE,FALSE), boxes = TRUE)) mosaic(Titanic, labeling = labeling_cboxed()) mosaic(Titanic, labeling = labeling_lboxed()) mosaic(Titanic, labeling = labeling_left()) mosaic(Titanic, labeling = labeling_list(), mar = c(2,2,4,2)) mosaic(Titanic, labeling = labeling_border(rep = FALSE)) mosaic(Titanic, labeling = labeling_border(labbl_varnames = c(TRUE,TRUE,FALSE,FALSE))) mosaic(~ Gender + Admit | Dept, data = UCBAdmissions, labeling = labeling_conditional(labels_varnames = TRUE, varnames = FALSE), keep_aspect_ratio = FALSE, split_vertical = c(Dept = TRUE)) doubledecker(Titanic) assoc(Hair ~ Eye, data = HairEyeColor) assoc(Hair ~ Eye, data = HairEyeColor, compress = FALSE) assoc(HairEyeColor, labeling = labeling_lboxed()) pairs(Titanic, shade = TRUE) pairs(Titanic, panel_upper = pairs_assoc, shade = TRUE) vcd/demo/hcl.R0000755000175100001440000000467211566471034012704 0ustar hornikusersif(require("tcltk")) { hue <- tclVar("hue") chroma <- tclVar("chroma") luminance <- tclVar("luminance") fixup <- tclVar("fixup") hue <- tclVar(230) hue.sav <- 230 chroma <- tclVar(55) chroma.sav <- 55 luminance <- tclVar(75) luminance.sav <- 75 fixup <- tclVar(FALSE) replot <- function(...) { hue.sav <- my.h <- as.numeric(tclvalue(hue)) chroma.sav <- my.c <- as.numeric(tclvalue(chroma)) luminance.sav <- my.l <- as.numeric(tclvalue(luminance)) my.fixup <- as.logical(as.numeric(tclvalue(fixup))) barplot(1, col = hcl2hex(my.h, my.c, my.l, fixup = my.fixup), axes = FALSE) } replot.maybe <- function(...) { if(!((as.numeric(tclvalue(hue)) == hue.sav) && (as.numeric(tclvalue(chroma)) == chroma.sav) && (as.numeric(tclvalue(luminance)) == luminance.sav))) replot() } base <- tktoplevel() tkwm.title(base, "HCL Colors") spec.frm <- tkframe(base, borderwidth = 2) hue.frm <- tkframe(spec.frm, relief = "groove", borderwidth = 2) chroma.frm <- tkframe(spec.frm, relief = "groove", borderwidth = 2) luminance.frm <- tkframe(spec.frm, relief = "groove", borderwidth = 2) fixup.frm <- tkframe(spec.frm, relief = "groove", borderwidth = 2) tkpack(tklabel(hue.frm, text = "Hue")) tkpack(tkscale(hue.frm, command = replot.maybe, from = 0, to = 360, showvalue = TRUE, variable = hue, resolution = 1, orient = "horiz")) tkpack(tklabel(chroma.frm, text = "Chroma")) tkpack(tkscale(chroma.frm, command = replot.maybe, from = 0, to = 100, showvalue = TRUE, variable = chroma, resolution = 5, orient = "horiz")) tkpack(tklabel(luminance.frm, text = "Luminance")) tkpack(tkscale(luminance.frm, command = replot.maybe, from = 0, to = 100, showvalue = TRUE, variable = luminance, resolution = 5, orient = "horiz")) tkpack(tklabel(fixup.frm, text="Fixup")) for (i in c("TRUE", "FALSE") ) { tmp <- tkradiobutton(fixup.frm, command = replot, text = i, value = as.logical(i), variable = fixup) tkpack(tmp, anchor="w") } tkpack(hue.frm, chroma.frm, luminance.frm, fixup.frm, fill="x") ## Bottom frame on base: q.but <- tkbutton(base, text = "Quit", command = function() tkdestroy(base)) tkpack(spec.frm, q.but) replot() } vcd/demo/discrete.R0000755000175100001440000001357211566471034013737 0ustar hornikusers ################################################# ## Fitting and Graphing Discrete Distributions ## ################################################# data(HorseKicks) barplot(HorseKicks, col = 2, xlab = "Number of Deaths", ylab = "Number of Corps-Years", main = "Deaths by Horse Kicks") data(Federalist) barplot(Federalist, col = 2, xlab = "Occurrences of 'may'", ylab = "Number of Blocks of Text", main = "'may' in Federalist papers") data(WomenQueue) barplot(WomenQueue, col = 2, xlab = "Number of women", ylab = "Number of queues", main = "Women in queues of length 10") data(WeldonDice) barplot(WeldonDice, names = c(names(WeldonDice)[-11], "10+"), col = 2, xlab = "Number of 5s and 6s", ylab = "Frequency", main = "Weldon's dice data") data(Butterfly) barplot(Butterfly, col = 2, xlab = "Number of individuals", ylab = "Number of Species", main = "Butterfly species im Malaya") ############################ ## Binomial distributions ## ############################ par(mfrow = c(1,2)) barplot(dbinom(0:10, p = 0.15, size = 10), names = 0:10, col = grey(0.7), main = "p = 0.15", ylim = c(0,0.35)) barplot(dbinom(0:10, p = 0.35, size = 10), names = 0:10, col = grey(0.7), main = "p = 0.35", ylim = c(0,0.35)) par(mfrow = c(1,1)) mtext("Binomial distributions", line = 2, cex = 1.5) plot(0:10, dbinom(0:10, p = 0.15, size = 10), type = "b", ylab = "Density", ylim = c(0, 0.4), main = "Binomial distributions, N = 10", pch = 19) lines(0:10, dbinom(0:10, p = 0.35, size = 10), type = "b", col = 2, pch = 19) lines(0:10, dbinom(0:10, p = 0.55, size = 10), type = "b", col = 4, pch = 19) lines(0:10, dbinom(0:10, p = 0.75, size = 10), type = "b", col = 3, pch = 19) legend(3, 0.4, c("p", "0.15", "0.35", "0.55", "0.75"), lty = rep(1,5), col = c(0,1,2,4,3), bty = "n") ########################### ## Poisson distributions ## ########################### par(mfrow = c(1,2)) dummy <- barplot(dpois(0:12, 2), names = 0:12, col = grey(0.7), ylim = c(0,0.3), main = expression(lambda == 2)) abline(v = dummy[3], col = 2) diff <- (dummy[3] - dummy[2]) * sqrt(2)/2 lines(c(dummy[3] - diff, dummy[3] + diff), c(0.3, 0.3), col = 2) dummy <- barplot(dpois(0:12, 5), names = 0:12, col = grey(0.7), ylim = c(0,0.3), main = expression(lambda == 5)) abline(v = dummy[6], col = 2) diff <- (dummy[6] - dummy[5]) * sqrt(5)/2 lines(c(dummy[6] - diff, dummy[6] + diff), c(0.3, 0.3), col = 2) par(mfrow = c(1,1)) mtext("Poisson distributions", line = 2, cex = 1.5) ##################################### ## Negative binomial distributions ## ##################################### nbplot <- function(p = 0.2, size = 2, ylim = c(0, 0.2)) { plot(0:20, dnbinom(0:20, p = p, size = size), type = "h", col = grey(0.7), xlab = "Number of failures (k)", ylab = "Density", ylim = ylim, yaxs = "i", bty = "L") nb.mean <- size * (1-p)/p nb.sd <- sqrt(nb.mean/p) abline(v = nb.mean, col = 2) lines(nb.mean + c(-nb.sd, nb.sd), c(0.01, 0.01), col = 2) legend(14, 0.2, c(paste("p = ", p), paste("n = ", size)), bty = "n") } par(mfrow = c(3,2)) nbplot() nbplot(size = 4) nbplot(p = 0.3) nbplot(p = 0.3, size = 4) nbplot(p = 0.4, size = 2) nbplot(p = 0.4, size = 4) par(mfrow = c(1,1)) mtext("Negative binomial distributions for the number of trials to observe n = 2 or n = 4 successes", line = 3) ##################### ## Goodness of fit ## ##################### p <- weighted.mean(as.numeric(names(HorseKicks)), HorseKicks) p.hat <- dpois(0:4, p) expected <- sum(HorseKicks) * p.hat chi2 <- sum((HorseKicks - expected)^2/expected) pchisq(chi2, df = 3, lower = FALSE) ## or: HK.fit <- goodfit(HorseKicks) summary(HK.fit) ## Are the dice fair? p.hyp <- 1/3 p.hat <- dbinom(0:12, prob = p.hyp, size = 12) expected <- sum(WeldonDice) * p.hat expected <- c(expected[1:10], sum(expected[11:13])) chi2 <- sum((WeldonDice - expected)^2/expected) G2 <- 2*sum(WeldonDice*log(WeldonDice/expected)) pchisq(chi2, df = 10, lower = FALSE) ## Are the data from a binomial distribution? p <- weighted.mean(as.numeric(names(WeldonDice))/12, WeldonDice) p.hat <- dbinom(0:12, prob = p, size = 12) expected <- sum(WeldonDice) * p.hat expected <- c(expected[1:10], sum(expected[11:13])) chi2 <- sum((WeldonDice - expected)^2/expected) G2 <- 2*sum(WeldonDice*log(WeldonDice/expected)) pchisq(chi2, df = 9, lower = FALSE) ## or: WD.fit1 <- goodfit(WeldonDice, type = "binomial", par = list(prob = 1/3, size = 12)) WD.fit1$fitted[11] <- sum(predict(WD.fit1, newcount = 10:12)) WD.fit2 <- goodfit(WeldonDice, type = "binomial", par = list(size = 12), method = "MinChisq") summary(WD.fit1) summary(WD.fit2) F.fit1 <- goodfit(Federalist) F.fit2 <- goodfit(Federalist, type = "nbinomial") summary(F.fit1) par(mfrow = c(2,2)) plot(F.fit1, scale = "raw", type = "standing") plot(F.fit1, type = "standing") plot(F.fit1) plot(F.fit1, type = "deviation") par(mfrow = c(1,1)) plot(F.fit2, type = "deviation") summary(F.fit2) data(Saxony) S.fit <- goodfit(Saxony, type = "binomial", par = list(size = 12)) summary(S.fit) plot(S.fit) ############### ## Ord plots ## ############### par(mfrow = c(2,2)) Ord_plot(HorseKicks, main = "Death by horse kicks") Ord_plot(Federalist, main = "Instances of 'may' in Federalist papers") Ord_plot(Butterfly, main = "Butterfly species collected in Malaya") Ord_plot(WomenQueue, main = "Women in queues of length 10") par(mfrow = c(1,1)) ############### ## Distplots ## ############### distplot(HorseKicks, type = "poisson") distplot(HorseKicks, type = "poisson", lambda = 0.61) distplot(Federalist, type = "poisson") distplot(Federalist, type = "nbinomial") distplot(Saxony, type = "binomial", size = 12) vcd/demo/00Index0000755000175100001440000000062611566471034013140 0ustar hornikusersdiscrete Fitting and Graphing Discrete Distributions twoway 2-Way Contingency Tables mosaic Mosaic displays hcl Tcl/Tk-Demo for `hcl' colors hsv Tcl/Tk-Demo for `hsv' colors hls Tcl/Tk-Demo for `hls' colors strucplot Demo for new strucplot suite (assoc, mosaic, doubledeckerplot) mondrian Demo for (re)producing modern art using mosaic() hullternary Demo for adding data point hulls to a ternary plot vcd/demo/mondrian.R0000755000175100001440000000115011566471034013731 0ustar hornikuserslibrary(vcd) ## shape foo1 <- c(3, 7, 3, 1.5) foo2 <- c(2, 6.5, 1.5) foo <- outer(foo1/sum(foo1), foo2/sum(foo2), "*") ## color mondrian <- rep("#EAE6E3", 12) mondrian[1] <- "#DE1024" mondrian[3] <- "#FFD83B" mondrian[12] <- "#032349" ## plot ## best visualized with resized display, e.g. using: ## get(getOption("device"))(width = 4.9, height = 7.5) grid.newpage() grid.rect(gp = gpar(fill = 1)) mondrianMosaic <- function(x, fill) mosaic(x, gp = gpar(col = rep(0, length(fill)), fill = fill), legend = FALSE, margins = 0, newpage = FALSE, keep_aspect_ratio = FALSE) mondrianMosaic(foo, mondrian) vcd/demo/hsv.R0000755000175100001440000000373611566471034012736 0ustar hornikusersif(require("tcltk")) { hue <- tclVar("hue") saturation <- tclVar("saturation") value <- tclVar("value") hue <- tclVar(0) hue.sav <- 0 saturation <- tclVar(1) saturation.sav <- 1 value <- tclVar(1) value.sav <- 1 replot <- function(...) { hue.sav <- my.h <- as.numeric(tclvalue(hue)) saturation.sav <- my.s <- as.numeric(tclvalue(saturation)) value.sav <- my.v <- as.numeric(tclvalue(value)) barplot(1, col = hsv(my.h, my.s, my.v), axes = FALSE) } replot.maybe <- function(...) { if(!((as.numeric(tclvalue(hue)) == hue.sav) && (as.numeric(tclvalue(saturation)) == saturation.sav) && (as.numeric(tclvalue(value)) == value.sav))) replot() } base <- tktoplevel() tkwm.title(base, "HSV Colors") spec.frm <- tkframe(base, borderwidth = 2) hue.frm <- tkframe(spec.frm, relief = "groove", borderwidth = 2) saturation.frm <- tkframe(spec.frm, relief = "groove", borderwidth = 2) value.frm <- tkframe(spec.frm, relief = "groove", borderwidth = 2) tkpack(tklabel(hue.frm, text = "Hue")) tkpack(tkscale(hue.frm, command = replot.maybe, from = 0, to = 1, showvalue = TRUE, variable = hue, resolution = 0.01, orient = "horiz")) tkpack(tklabel(saturation.frm, text = "Saturation")) tkpack(tkscale(saturation.frm, command = replot.maybe, from = 0, to = 1, showvalue = TRUE, variable = saturation, resolution = 0.01, orient = "horiz")) tkpack(tklabel(value.frm, text = "Value")) tkpack(tkscale(value.frm, command = replot.maybe, from = 0, to = 1, showvalue = TRUE, variable = value, resolution = 0.01, orient = "horiz")) tkpack(hue.frm, saturation.frm, value.frm, fill="x") ## Bottom frame on base: q.but <- tkbutton(base, text = "Quit", command = function() tkdestroy(base)) tkpack(spec.frm, q.but) replot() } vcd/demo/hullternary.R0000755000175100001440000000301211566471034014472 0ustar hornikusers###################################################### #### ternary plot demo #### Task: plotting data point hulls in a ternary plot #### data provided by Manuel Dominguez-Rodrigo ###################################################### library(vcd) ## data humans=matrix(c(18,19,17,21,7,9,8,62,70,53,69,81,73,71,20,10,30,10,12,18,19), ncol=3) colnames(humans)=c("young", "adult", "old") lions=matrix(c(41,59,62,49,45,21,12,5,11,13,38,29,33,40,42), ncol=3) colnames(lions)=c("young", "adult", "old") site=matrix(c(9,12,15,11,70,62,69,68,21,26,16,21), ncol=3) colnames(site)=c("young", "adult", "old") humans=matrix(c(18,19,17,21,7,9,8,62,70,53,69,81,73,71,20,10,30,10,12,18,19), ncol=3) ## regular ternary plot data = rbind(humans, lions, site) count = c(nrow(humans), nrow(lions), nrow(site)) rownames(data) = rep(c("humans", "lions", "site"), count) cols = rep(c("red", "green", "blue"), count) ternaryplot(data, col = cols) ## now try to draw hull prop2xy <- function(x) { x <- as.matrix(x) x <- x / rowSums(x) xp <- x[,2] + x[,3] / 2 yp <- x[,3] * sqrt(3) / 2 cbind(x = xp, y = yp) } hullpoints <- function(x) { ind <- chull(x) ind <- c(ind, ind[1]) x[ind,] } drawhull <- function(data, color) { hp <- hullpoints(prop2xy(data)) grid.lines(hp[,"x"], hp[,"y"], gp = gpar(col = color)) } ## setup plot region without data points ternaryplot(data, col = NA, pop = FALSE) ## grab plot viewport downViewport("plot") ## now plot hulls drawhull(humans, "blue") drawhull(site, "red") drawhull(lions, "green") vcd/demo/hls.R0000755000175100001440000000403211566471034012712 0ustar hornikusersif(require("tcltk")) { hue <- tclVar("hue") luminance <- tclVar("luminance") saturation <- tclVar("saturation") hue <- tclVar(0) hue.sav <- 0 luminance <- tclVar(0.5) luminance.sav <- 0.5 saturation <- tclVar(1) saturation.sav <- 1 replot <- function(...) { hue.sav <- my.h <- as.numeric(tclvalue(hue)) saturation.sav <- my.s <- as.numeric(tclvalue(saturation)) luminance.sav <- my.l <- as.numeric(tclvalue(luminance)) barplot(1, col = hls(my.h, my.l, my.s), axes = FALSE) } replot.maybe <- function(...) { if(!((as.numeric(tclvalue(hue)) == hue.sav) && (as.numeric(tclvalue(saturation)) == saturation.sav) && (as.numeric(tclvalue(luminance)) == luminance.sav))) replot() } base <- tktoplevel() tkwm.title(base, "HLS Colors") spec.frm <- tkframe(base, borderwidth = 2) hue.frm <- tkframe(spec.frm, relief = "groove", borderwidth = 2) saturation.frm <- tkframe(spec.frm, relief = "groove", borderwidth = 2) luminance.frm <- tkframe(spec.frm, relief = "groove", borderwidth = 2) tkpack(tklabel(hue.frm, text = "Hue")) tkpack(tkscale(hue.frm, command = replot.maybe, from = 0, to = 1, showvalue = TRUE, variable = hue, resolution = 0.01, orient = "horiz")) tkpack(tklabel(luminance.frm, text = "Luminance")) tkpack(tkscale(luminance.frm, command = replot.maybe, from = 0, to = 1, showvalue = TRUE, variable = luminance, resolution = 0.01, orient = "horiz")) tkpack(tklabel(saturation.frm, text = "Saturation")) tkpack(tkscale(saturation.frm, command = replot.maybe, from = 0, to = 1, showvalue = TRUE, variable = saturation, resolution = 0.01, orient = "horiz")) tkpack(hue.frm, luminance.frm, saturation.frm, fill="x") ## Bottom frame on base: q.but <- tkbutton(base, text = "Quit", command = function() tkdestroy(base)) tkpack(spec.frm, q.but) replot() } vcd/demo/mosaic.R0000755000175100001440000000651711566471034013411 0ustar hornikusers##################### ## Mosaic Displays ## ##################### ######################### ## Hair Eye Color Data ## ######################### data(HairEyeColor) ## Basic Mosaic Display ## HairEye <- margin.table(HairEyeColor, c(1,2)) mosaic(HairEye, main = "Basic Mosaic Display of Hair Eye Color data") ## Hair Mosaic Display with Pearson residuals ## Hair <- margin.table(HairEyeColor,1) Hair mHair <- as.table(rep(mean(margin.table(HairEyeColor, 1)), 4)) names(mHair) <- names(Hair) mHair ## Pearson residuals from Equiprobability model ## resid <- (Hair - mHair) / sqrt(mHair) resid ## First Step in a Mosaic Display ## mosaic(Hair, residuals = resid, main = "Hair Color Proportions") ## Hair Eye Mosais Display with Pearson residuals ## mosaic(HairEye, main = " Hair Eye Color with Pearson residuals") ## Show Pearson Residuals ## (HairEye - loglin(HairEye, c(1, 2), fit = TRUE)$fit) / sqrt(loglin(HairEye, c(1, 2), fit = TRUE)$fit) ################### ## UKSoccer Data ## ################### data(UKSoccer) ## UKSoccer Mosaic Display ## mosaic(UKSoccer, main = "UK Soccer Scores") ############################### ## Repeat Victimization Data ## ############################### data(RepVict) ## mosaic(RepVict[-c(4, 7), -c(4, 7)], main = "Repeat Victimization Data") ################## ## 3-Way Tables ## ################## ## Hair Eye Sex Mosais Display with Pearson residuals ## mosaic(HairEyeColor, main = "Hair Eye Color Sex" ) mosaic(HairEyeColor, expected = ~ Hair * Eye + Sex, main = "Model: (Hair Eye) (Sex)" ) mosaic(HairEyeColor, expected = ~ Hair * Sex + Eye*Sex, main = "Model: (Hair Sex) (Eye Sex)") #################### ## Premarital Sex ## #################### data(PreSex) ## Mosaic display for Gender and Premarital Sexual Expirience ## ## (Gender Pre) ## mosaic(margin.table(PreSex, c(3, 4)), legend = FALSE, main = "Gender and Premarital Sex") ## (Gender Pre)(Extra) ## mosaic(margin.table(PreSex,c(2,3,4)), legend = FALSE, expected = ~ Gender * PremaritalSex + ExtramaritalSex , main = "(PreMaritalSex Gender) (Sex)") ## (Gender Pre Extra)(Marital) ## mosaic(PreSex, expected = ~ Gender * PremaritalSex * ExtramaritalSex + MaritalStatus, legend = FALSE, main = "(PreMarital ExtraMarital) (MaritalStatus)") ## (GPE)(PEM) ## mosaic(PreSex, expected = ~ Gender * PremaritalSex * ExtramaritalSex + MaritalStatus * PremaritalSex * ExtramaritalSex, legend = FALSE, main = "(G P E) (P E M)") ############################ ## Employment Status Data ## ############################ data(Employment) ## Employment Status ## # mosaic(Employment, # expected = ~ LayoffCause * EmploymentLength + EmploymentStatus, # main = "(Layoff Employment) + (EmployStatus)") # mosaic(Employment, # expected = ~ LayoffCause * EmploymentLength + # LayoffCause * EmploymentStatus, # main = "(Layoff EmpL) (Layoff EmplS)") # ## Closure ## # mosaic(Employment[,,1], main = "Layoff : Closure") # ## Replaced ## # mosaic(Employment[,,2], main = "Layoff : Replaced") ##################### ## Mosaic Matrices ## ##################### data(UCBAdmissions) pairs(PreSex) pairs(UCBAdmissions) pairs(UCBAdmissions, type = "conditional") pairs(UCBAdmissions, type = "pairwise", gp = shading_max) vcd/vignettes/0000755000175100001440000000000014671771755013100 5ustar hornikusersvcd/vignettes/struc.pdf0000755000175100001440000000622011720273432014713 0ustar hornikusers%PDF-1.4 % 1 0 obj << /Length 2 0 R /Filter /FlateDecode >> stream xZn7 ?l99Hrv$ ?;A /=CɥZIP "ݬ.6əˋ Ya!jU_ȿvy!"LN//Y,6Hh ƶNيȽŝpX470/kj4~r-.eQCx4 |6RIᢾaBZ[F$'%8+[~U[uR[K@L]tcҡú7Ӵ6VgwBu(HqkWiK1uґF[K@o$T'j2kHA6ĢĐNWd#@c6ZJl`)cVٸF0@еXh>NuA?Q`~E[JJ) -b-[yy ƕҀ~L~iiuuPiIn00-ݨJ.jS~#S(^" YQm"PSvg[*C3*Ne ~*=zKek08-RzY cAm3yAF3s),>7l^Z")h&n ٣LIkkFr^Z3%E%vmk(;,*XK憣Ξn?ⅅ3LӷҜ9E#:{h5lg!䰩\j鷣mN1,#QFvhMBp[cl嚢((.)oW좵ۀٷXw";!B%x5*Z-tM^?푉׫[wHδe!]=Wix09Es{kp5 R.l'DodP"!YFh-UdYrB;qڣaJSvR(AT^ -,na&Qr!t  \\UӸDtPt-3ݘslHAVsF@{Tf!.Sڳ 埝'n5n']y<,i|-xѰ&ؒl9ǩs5K( gsņaqRR$+ܕ< zֺ'-]{=`_Cby3?a:H}22Ԉ+cMBܘ0>5 Q 1DN!S=A”Duibj/VZT_f~5@Mx#CkƸF+sG/h<,p @4^SL2:QI'4#w}Ǘ v35 O kڻq:2H/k:o^a{ͣQ'}nLQ˟+?YgX< ݨy:,Ҩ1);mG@cEI7%.`4ڨUҏyB3|SWS܉1mZ@X#d~TƔJ_&endstream endobj 2 0 obj 1891 endobj 4 0 obj << /Type /Font /Subtype /Type1 /BaseFont /Courier /Encoding /WinAnsiEncoding >> endobj 5 0 obj << /Type /Font /Subtype /Type1 /BaseFont /Helvetica /Encoding /WinAnsiEncoding >> endobj 6 0 obj << /F1 5 0 R /F2 4 0 R >> endobj 7 0 obj << /Font 6 0 R /ProcSet [ /PDF ] >> endobj 8 0 obj << /Type /Page /Parent 3 0 R /Resources 7 0 R /MediaBox [ 0 0 794 595 ] /Contents 1 0 R >> endobj 3 0 obj << /Type /Pages /Resources 7 0 R /MediaBox [ 0 0 595 842 ] /Kids [ 8 0 R ] /Count 1 >> endobj 9 0 obj << /Type /Catalog /Pages 3 0 R >> endobj 10 0 obj << /Creator /Producer /CreationDate (D:20051019112228+02'00') >> endobj xref 0 11 0000000000 65535 f 0000000017 00000 n 0000001993 00000 n 0000002495 00000 n 0000002020 00000 n 0000002133 00000 n 0000002248 00000 n 0000002302 00000 n 0000002367 00000 n 0000002631 00000 n 0000002690 00000 n trailer << /Size 11 /Root 9 0 R /Info 10 0 R >> startxref 2901 %%EOF vcd/vignettes/residual-shadings.Rnw0000644000175100001440000003714114541404366017167 0ustar hornikusers\documentclass[nojss]{jss} %% need no \usepackage{Sweave} \usepackage{rotating} \newcommand{\given}{\, | \,} \title{Residual-Based Shadings in \pkg{vcd}} \Plaintitle{Residual-Based Shadings in vcd} \author{Achim Zeileis, David Meyer, \textnormal{and} Kurt Hornik\\Wirtschaftsuniversit\"at Wien, Austria} \Plainauthor{Achim Zeileis, David Meyer, Kurt Hornik} \Abstract{ This vignette is a companion paper to \cite{vcd:Zeileis+Meyer+Hornik:2007} which introduces several extensions to residual-based shadings for enhancing mosaic and association plots. The paper introduces (a)~perceptually uniform Hue-Chroma-Luminance (HCL) palettes and (b)~incorporates the result of an associated significance test into the shading. Here, we show how the examples can be easily reproduced using the \pkg{vcd} package. } \Keywords{association plots, conditional inference, contingency tables, HCL colors, HSV colors, mosaic plots} \Address{ Achim Zeileis\\ E-mail: \email{Achim.Zeileis@R-project.org}\\ David Meyer\\ E-mail: \email{David.Meyer@R-project.org}\\ Kurt Hornik\\ E-mail: \email{Kurt.Hornik@R-project.org}\\ } \begin{document} %\VignetteIndexEntry{Residual-Based Shadings in vcd} %\VignetteDepends{vcd,colorspace,MASS,grid,HSAUR3,grid} %\VignetteKeywords{association plots, conditional inference, contingency tables, HCL colors, HSV colors, mosaic plots} %\VignettePackage{vcd} \SweaveOpts{engine=R,eps=FALSE} \section{Introduction} \label{sec:intro} In this vignette, we show how all empirical examples from \cite{vcd:Zeileis+Meyer+Hornik:2007} can be reproduced in \proglang{R}\citep[\mbox{\url{http://www.R-project.org/}}]{vcd:R:2006}, in particular using the package \pkg{vcd} \citep{vcd:Meyer+Zeileis+Hornik:2006}. Additionally, the pakcages \pkg{MASS} \citep[see][]{vcd:Venables+Ripley:2002}, \pkg{grid} \citep[see][]{vcd:Murrell:2002} and \pkg{colorspace} \citep{vcd:Ihaka:2004} are employed. All are automatically loaded together with \pkg{vcd}: <>= library("grid") library("vcd") rseed <- 1071 @ Furthermore, we define a \code{rseed} which will be used as the random seed for making the results of the permutation tests (conditional inference) below exactly reproducible. In the following, we focus on the \proglang{R} code and output---for background information on the methods and the data sets, please consult \cite{vcd:Zeileis+Meyer+Hornik:2007}. \section{Arthritis data} \label{sec:arthritis} First, we take a look at the association of treatment type and improvement in the \code{Arthritis} data. The data set can be loaded and brought into tabular form via: <>= data("Arthritis", package = "vcd") (art <- xtabs(~ Treatment + Improved, data = Arthritis, subset = Sex == "Female")) @ Two basic explorative views of such a 2-way table are mosaic plots and association plots. They can be generated via \code{mosaic()} and \code{assoc()} from \pkg{vcd}, respectively. For technical documentation of these functions, please see \cite{vcd:Meyer+Zeileis+Hornik:2006b}. When no further arguments are supplied as in <>= mosaic(art) assoc(art) @ this yields the plain plots without any color shading, see Figure~\ref{fig:classic}. Both indicate that there are more patients in the treatment group with marked improvement and less without improvement than would be expected under independence---and vice versa in the placebo group. \setkeys{Gin}{width=\textwidth} \begin{figure}[b!] \begin{center} <>= grid.newpage() pushViewport(viewport(layout = grid.layout(1, 2))) pushViewport(viewport(layout.pos.col=1, layout.pos.row=1)) mosaic(art, newpage = FALSE, margins = c(2.5, 4, 2.5, 3)) popViewport() pushViewport(viewport(layout.pos.col=2, layout.pos.row=1)) assoc(art, newpage = FALSE, margins = c(5, 2, 5, 4)) popViewport(2) @ \caption{Classic mosaic and association plot for the arthritis data.} \label{fig:classic} \end{center} \end{figure} For 2-way tables, \cite{vcd:Zeileis+Meyer+Hornik:2007} suggest to extend the shading of \cite{vcd:Friendly:1994} to also visualize the outcome of an independence test---either using the sum of squares of the Pearson residuals as the test statistic or their absolute maximum. Both statistics and their corresponding (approximate) permutation distribution can easily be computed using the function \code{coindep_test()}. Its arguments are a contingency table, a specification of margins used for conditioning (only for conditional independence models), a functional for aggregating the Pearson residuals (or alternatively the raw counts) and the number of permutations that should be drawn. The conditional table needs to be a 2-way table and the default is to compute the maximum statistic (absolute maximum of Pearson residuals). For the Arthritis data, both, the maximum test <>= set.seed(rseed) (art_max <- coindep_test(art, n = 5000)) @ and the sum-of-squares test, indicate a significant departure from independence. <>= ss <- function(x) sum(x^2) set.seed(rseed) coindep_test(art, n = 5000, indepfun = ss) @ Thus, it can be concluded that the treatment is effective and leads to significantly more improvement than the placebo. The classic views from Figure~\ref{fig:classic} and the inference above can also be combined, e.g., using the maximum shading that highlights the cells in an association or mosaic plot when the associated residuals exceed critical values of the maximum test (by default at levels 90\% and 99\%). To compare this shading (using either HSV or HCL colors) with the Friendly shading (using HSV colors), we generate all three versions of the mosaic plot: <>= mosaic(art, gp = shading_Friendly(lty = 1, eps = NULL)) mosaic(art, gp = shading_hsv, gp_args = list( interpolate = art_max$qdist(c(0.9, 0.99)), p.value = art_max$p.value)) set.seed(rseed) mosaic(art, gp = shading_max, gp_args = list(n = 5000)) @ the results are shown in the upper row of Figure~\ref{fig:shadings}. The last plot could hae also been generated analogously to the second plot using \code{shading_hcl()} instead of \code{shading_hsv()}---\code{shading_max()} is simply a wrapper function which performs the inference and then visualizes it based on HCL colors. \section{Piston rings data} \label{sec:arthritis} Instead of bringing out the result of the maximum test in the shading, we could also use a sum-of-squares shading that visualizes the result of the sum-of-squares test. As an illustration, we use the \code{pistonrings} data from the \code{HSAUR3} \citep{vcd:Everitt+Hothorn:2006} package giving the number of piston ring failurs in different legs of different compressors at an industry plant: <>= data("pistonrings", package = "HSAUR3") pistonrings @ \begin{sidewaysfigure}[p] \begin{center} <>= mymar <- c(1.5, 0.5, 0.5, 2.5) grid.newpage() pushViewport(viewport(layout = grid.layout(2, 3))) pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 1)) mosaic(art, margins = mymar, newpage = FALSE, gp = shading_Friendly(lty = 1, eps = NULL)) popViewport() pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 2)) mosaic(art, gp = shading_hsv, margins = mymar, newpage = FALSE, gp_args = list(interpolate = art_max$qdist(c(0.9, 0.99)), p.value = art_max$p.value)) popViewport() pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 3)) set.seed(rseed) mosaic(art, gp = shading_max, margins = mymar, newpage = FALSE, gp_args = list(n = 5000)) popViewport() pushViewport(viewport(layout.pos.row = 2, layout.pos.col = 1)) mosaic(pistonrings, margins = mymar, newpage = FALSE, gp = shading_Friendly(lty = 1, eps = NULL, interpolate = c(1, 1.5))) popViewport() pushViewport(viewport(layout.pos.row = 2, layout.pos.col = 2)) mosaic(pistonrings, gp = shading_hsv, margins = mymar, newpage = FALSE, gp_args = list(p.value = 0.069, interpolate = c(1, 1.5))) popViewport() pushViewport(viewport(layout.pos.row = 2, layout.pos.col = 3)) mosaic(pistonrings, gp = shading_hcl, margins = mymar, newpage = FALSE, gp_args = list(p.value = 0.069, interpolate = c(1, 1.5))) popViewport(2) @ \includegraphics[width=.9\textwidth,keepaspectratio]{residual-shadings-shadings} \caption{Upper row: Mosaic plot for the arthritis data with Friendly shading (left), HSV maximum shading (middle), HCL maximum shading (right). Lower row: Mosaic plot for the piston rings data with fixed user-defined cut offs 1 and 1.5 and Friendly shading (left), HSV sum-of-squares shading (middle), HCL sum-of-squares shading (right).} \label{fig:shadings} \end{center} \end{sidewaysfigure} Although there seems to be some slight association between the leg (especially center and South) and the compressor (especially numbers 1 and 4), there is no significant deviation from independence: <>= set.seed(rseed) coindep_test(pistonrings, n = 5000) set.seed(rseed) (pring_ss <- coindep_test(pistonrings, n = 5000, indepfun = ss)) @ This can also be brought out graphically in a shaded mosaicplot by enhancing the Friendly shading (based on the user-defined cut-offs 1 and 1.5, here) to use a less colorful palette, either based on HSV or HCL colors: <>= mosaic(pistonrings, gp = shading_Friendly(lty = 1, eps = NULL, interpolate = c(1, 1.5))) mosaic(pistonrings, gp = shading_hsv, gp_args = list(p.value = pring_ss$p.value, interpolate = c(1, 1.5))) mosaic(pistonrings, gp = shading_hcl, gp_args = list(p.value = pring_ss$p.value, interpolate = c(1, 1.5))) @ The resulting plots can be found in the lower row of Figure~\ref{fig:shadings}. The default in \code{shading_hcl()} and \code{shading_hsv()} is to use the asymptotical $p$~value, hence we set it explicitely to the permtuation-based $p$~value computed above. \section{Alzheimer and smoking} \label{sec:alzheimer} For illustrating that the same ideas can be employed for visualizing (conditional) independence in multi-way tables, \cite{vcd:Zeileis+Meyer+Hornik:2007} use a 3-way and a 4-way table. The former is taken from a case-control study of smoking and {A}lzheimer's disease (stratified by gender). The data set is available in \proglang{R} in the package \pkg{coin} \cite{vcd:Hothorn+Hornik+VanDeWiel:2006}. <>= data("alzheimer", package = "coin") alz <- xtabs(~ smoking + disease + gender, data = alzheimer) alz @ \begin{figure}[b!] \begin{center} <>= set.seed(rseed) cotabplot(~ smoking + disease | gender, data = alz, panel = cotab_coindep, panel_args = list(n = 5000)) @ \caption{Conditional mosaic plot with double maximum shading for conditional independence of smoking and disease given gender.} \label{fig:alz} \end{center} \end{figure} To assess whether smoking behaviour and disease status are conditionally independent given gender, \cite{vcd:Zeileis+Meyer+Hornik:2007} use three different types of test statistics: double maximum (maximum of maximum statistics in the two strata), maximum sum of squares (maximum of sum-of-squares statistics), and sum of squares (sum of sum-of-squares statistics). All three can be computed and assessed via permutation methods using the function \code{coindep_test()}: <>= set.seed(rseed) coindep_test(alz, 3, n = 5000) set.seed(rseed) coindep_test(alz, 3, n = 5000, indepfun = ss) set.seed(rseed) coindep_test(alz, 3, n = 5000, indepfun = ss, aggfun = sum) @ The conditional mosaic plot in Figure~\ref{fig:alz} shows clearly that the association of smoking and disease is present only in the group of male patients. The double maximum shading employed allows for identification of the male heavy smokers as the cells `responsible' for the dependence: other dementias are more frequent and Alzheimer's disease less frequent in this group than expected under independence. Interestingly, there seems to be another large residual for the light smoker group ($<$10 cigarettes) and Alzheimer's disease---however, this is only significant at 10\% and not at the 1\% level as the other two cells. <>= <> @ \section{Corporal punishment of children} As a 4-way example, data from a study of the Gallup Institute in Denmark in 1979 about the attitude of a random sample of 1,456 persons towards corporal punishment of children is used. The contingency table comprises four margins: memory of punishments as a child (yes/no), attitude as a binary variable (approval of ``moderate'' punishment or ``no'' approval), highest level of education (elementary/secondary/high), and age group (15--24, 25--39, $\ge$40 years). <>= data("Punishment", package = "vcd") pun <- xtabs(Freq ~ memory + attitude + age + education, data = Punishment) ftable(pun, row.vars = c("age", "education", "memory")) @ It is of interest whether there is an association between memories of corporal punishments as a child and attitude towards punishment of children as an adult, controlling for age and education. All three test statistics already used above confirm that memories and attitude are conditionally associated: \setkeys{Gin}{width=\textwidth} \begin{figure}[t!] \begin{center} <>= set.seed(rseed) cotabplot(~ memory + attitude | age + education, data = pun, panel = cotab_coindep, n = 5000, type = "assoc", test = "maxchisq", interpolate = 1:2) @ \caption{Conditional association plot with maximum sum-of-squares shading for conditional independence of memory and attitude given age and education.} \label{fig:pun} \end{center} \end{figure} \setkeys{Gin}{width=\textwidth} \begin{figure}[t!] \begin{center} <>= set.seed(rseed) cotabplot(~ memory + attitude | age + education, data = pun, panel = cotab_coindep, n = 5000, type = "mosaic", test = "maxchisq", interpolate = 1:2) @ \caption{Conditional mosaic plot with maximum sum-of-squares shading for conditional independence of memory and attitude given age and education.} \label{fig:pun2} \end{center} \end{figure} <>= set.seed(rseed) coindep_test(pun, 3:4, n = 5000) set.seed(rseed) coindep_test(pun, 3:4, n = 5000, indepfun = ss) set.seed(rseed) coindep_test(pun, 3:4, n = 5000, indepfun = ss, aggfun = sum) @ Graphically, this dependence can be brought out using conditional association or mosaic plots as shown in Figure~\ref{fig:pun} and \ref{fig:pun2}, respectively. Both reveal an association between memories and attitude for the lowest education group (first column) and highest age group (last row): experienced violence seems to engender violence again as there are less adults that disapprove punishment in the group with memories of punishments than expected under independence. For the remaining four age-education groups, there seems to be no association: all residuals of the conditional independence model are very close to zero in these cells. The figures employ the maximum sum-of-squares shading with user-defined cut offs 1 and 2, chosen to be within the range of the residuals. The full-color palette is used only for those strata associated with a sum-of-squares statistic significant at (overall) 5\% level, the reduced-color palette is used otherwise. This highlights that the dependence pattern is significant only for the middle and high age group in the low education column. The other panels in the first column and last row also show a similar dependence pattern, however, it is not significant at 5\% level and hence graphically down-weighted by using reduced color. <>= <> @ <>= <> @ \bibliography{vcd} \end{document} vcd/vignettes/struc.sxi0000755000175100001440000002162011720273432014746 0ustar hornikusersPKJS3Xmimetypeapplication/vnd.sun.xml.impressPKJS3 content.xml\[~ϯ ReWZ/SJuص$O$2HF3 yIIN7!GGt>Ǖ/<{ap-H8kK7o~ۻ|As!WnW$H&N$WoV'釈8 b:}wNHew 􇿊>+޼iz8WiﵸLj: 55$IZn'0=f1zaS1:Z+xH0-: A(ϙp=7oޅwW`n$Y< RCDxAΈ4H,a~AuN&5FY8'qxxxlfxA+ /(7IzWԭ{5|Z 8/!IY{ZyY9q{sY 2۶UeN!WC?qB{R YKb?ˀ<ɨOL6E[,s^heΪh!6 =Vmh6_XBWV` sKBd~; # 1 IXFYd Ɇ.Đ_zOOR\> XFiD$U#l!~)zA|L:R5 QHzeuc?Ï[Jȕj8/rZ#,/d qsQuww2Q[d{y|h)v>Vs8A7mԭm+L %H鮹0V4{ -)mwn+YPs)~mdAB=ƋK4lC#~.ijmsDZU LDkӱ4wM`1W}Qw^+xx}GkauνGn":ETm,Zl5)i WOq2,@!@L$adt3swp6*Įߤo$_W8ObL]^YX&1[>I2횰cȟL?=faaW@Psʬ,4Ji\8!CNG؁'yHIy+}kڅ;>{XH/vyء t(:'!+]bꃎLU 1䗠KRRkoQGn(KeUdjrG9)(32J T8!nf.~ҏr T$Ea@ x$pYPO0(np16ۀ0eaSC <a"8ς~ a q=;B6tu hH95őXLv 'x dl:\򁒰dժ+VeYzmd8sYevϵA}G;RtR&}x"&VoviyvC-P_ LI<1qz&ux<c!j3`pct2~^%tzʼxjs;:MnS J> ogVY%3$̗8И:}:S^@cpLq}ė˯eg˯{-3a*cR!L!!k>,IIS;p34OoPXZI$d᭖ܧw_9I\fZmFxmeˬM6N7e9T|}FPy-+u$)reHBn[:*FѲN] }746-L7ZN}PKF1D *\PKJS3 styles.xml][6~_J޸ v&dk3S=UGd vw>_ .6`Ʒf|^@zqh".K0rGe,pۿ?Kh6]x!w(U5ˏ$+i OTJE\%>k$hϿʒ.z'6\k%7r"/tyiw1u]o9k@[S .—U`T{1XJ8\z^kJh|亼~QrhNaܮ HAe  Ҳ,N3snq;Tviy\#h@g=J8l8scٮ9 噧?_a,G ~!Z0b7>\^&.钩K1 -LY׽ l2C7_;DO~ ?P"V(;F0݉O]q PJ?0$M@e+0E0.ZEiuXwK ~/#k4zV6% `jJP7̔*+p@O`Q,hV-U.SBR,Ⱦu#Er銆e'r⓫T18x%)\u8*!J:Uh`6=6/x"Xu"j̻mk"Ϊk@W?^gaRa=,&EDbpV Y_,~OayMљOWU]gfU ɴ&84=S5Ϊ.l%9֦i;vPA:})S:HӐD ZnyXfbͷ3Pͫ6>U?8|Sa[Wm@<3߾ju>C?eFRu5$MnS [F纜8_{U6hj 2|٫+ڹ2ÿ*kad(8f|O|C³`2fdq6e|V-Ϗ;H)^OF1vVU{6U}s&쵻 8ccKXTuAd^yAd^yAOKS݉W*ݲͶmnoUlkmܖ[3u6 l溎sr܊5fW숀j4+Jd {ͼ.`n &`n &˼xXY7%L6Ra&6;=ni _/Z~)̯;R짘B~w=FPP@mUeg-ԮTz0@y&-]p~Wىy:N7uqd^ՈV#jZXk5|ǵ CT#Xb-̞g- j r[ZkEZkeLu#t)aS&oS/`l[RF{:>F矆"~̞'~ jJ.]D 蟠 '蟠Y8`')c2΢/wvQW=Isq?{IθwG;v{3@nwΏntιjv~xfǧl?Mő>U8NfvDZ]m7nImeK1.r"+,鼍aVۆ޾Z Ϫ6Z[mPjvY֞X^~ZϠKt} jt u>ku}@uTPj}Sj#eI>WD'Ų2 J;$6'+,tl2} `g>LWGzT0ma[3&v~nXUxmQvz=!ꑁ`T.sLC8Ů2xD_|g8'.X\Lmj['[#Vqǵw:f/2wK1v'/o}A,n6cLQgv_VTKP&Ed)]3n{ō.bHd!S96`d!{b56D42J[-Lp? Ucmߑ:ܑO%S|}ҍ#25(dJ | <;zԦ]U~yiUyOҗa2h9E/ձQ9gXial"e}T齆|$*ޔekZgۊ(gXi7PָɼL} HZ|lTaxG%PlGO(tޥ#TݟXNIwܿN[ILmwhJ7q^!w7?PK 8PKJS3*meta.xml OpenOffice.org 1.1.4 (Linux)2005-09-18T14:10:532005-10-19T11:22:15en-US8PT1H47M45SPKJS3 settings.xmlZ[W8~_u(.9I'I_?i/XӚYli}{d_' xhD]a:0?Ne0V cn#*Rn6*4;d!3tNauﬧiVFXz3.w+)8[=0Rg{)Ye'y|EQ2X.fhPP&d<`Z\ 16|cg7^D~lk }eGgisގa\!Ҹ<8*q~ d*xh}ύ~=9O?*Os_!<_*}8> 0PXY|Q+O0.c(fDc!؂2F$qFm.y!h}߅3Ԃ|ЧCiL"WָRV,]N]rtI( Dp{cUiDT 1uY&fk/$Ҏ7ʪ{.K^&\~l+!Ҹ4?wzM:!%HdyE1CX60ދ{!A|oɎ7* o9jd7}DԉK"q^6J- "Vv$M "cQ"gLU\Q5hLZ7L-($L7|PJY\1r_*|{'1.@|Q7ނ,L-12&0)}t_^w˞N1J[\qUVdxsc'b߷Cq(g{Qd,9A="b*݂]C6aДA5=]m5+W7!OZ ˡ@܁~}&acn05wt0AgЛ3>RIy5c3T2E0:/9lM.r ^a~r%ԗVI]Qw7XsRyB0$R ֗iSy>@~qSKaJ&Y'w61| ^~bq43Bz{ L&e[+(]{s5 NP~ +C]}HZ6c v7BG51 z+ttI_\+݀$HBIWI GZ UXwiz 0 ԑבXqTP㉟J)*_ajɞUi׌`}_W I6)O1E2 ee.0/_RJ9:cdu}aΚGh Zu0=ohyCh4Ok6_ƽzSJoQF:/['W-+~Y=awd?:!/KHwPZ kp㻠Dqt@*Qt͸Tӣ޶c- P^=Ұ0o՞3-ŲΫ޼B4tjjbATէ D+4--Wbyj_M5y~ So^e5>ndJm[z5T=-E,n*'NxJDڬݫXxw9[2^b*k~XM-ᥨq 7ZvSiJT-پ2CPKOץ1)PKJS3META-INF/manifest.xmlұj0Onө;)ڃ3t49Ȓ!~BI_piq+kRX6S8+l7Osʟb/ʨ<(o;bmj?"fe&`#A$n fe‰٭m Yj Ԩ*Q sZ_4FRu'aj#W)|h}P5aȣӅ1dphĢQ_툫sko6k PKI\zPKJS3XmimetypePKJS3F1D *\ Econtent.xmlPKJS3 8 3 styles.xmlPKJS3*meta.xmlPKJS3Oץ1) settings.xmlPKJS3I\z META-INF/manifest.xmlPKZ "vcd/vignettes/strucplot.Rnw0000644000175100001440000031200314543516402015606 0ustar hornikusers\documentclass[nojss]{jss} %% need no \usepackage{Sweave} %% omit thumbpdf at the moment due to problems on some systems %% \usepackage{thumbpdf} %% almost as usual \author{David Meyer, Achim Zeileis, \textnormal{and} Kurt Hornik\\Wirtschaftsuniversit\"at Wien, Austria} \title{The Strucplot Framework:\\ Visualizing Multi-way Contingency Tables with \pkg{vcd}} %% for pretty printing and a nice hypersummary also set: \Plainauthor{David Meyer, Achim Zeileis, Kurt Hornik} %% comma-separated \Shorttitle{The Strucplot Framework} %% a short title (if necessary) \Plaintitle{The Strucplot Framework: Visualizing Multi-way Contingency Tables with vcd} %% an abstract and keywords \Abstract{ This paper has been published in the Journal of Statistical Software \citep{vcd:Meyer+Zeileis+Hornik:2006b} and describes the ``strucplot'' framework for the visualization of multi-way contingency tables. Strucplot displays include hierarchical conditional plots such as mosaic, association, and sieve plots, and can be combined into more complex, specialized plots for visualizing conditional independence, GLMs, and the results of independence tests. The framework's modular design allows flexible customization of the plots' graphical appearance, including shading, labeling, spacing, and legend, by means of ``graphical appearance control'' functions. The framework is provided by the \proglang{R} package \pkg{vcd}. } \Keywords{contingency tables, mosaic plots, association plots, sieve plots, categorical data, independence, conditional independence, HSV, HCL, residual-based shading, \pkg{grid}, \proglang{R}} \Plainkeywords{contingency tables, mosaic plots, association plots, sieve plots, categorical data, independence, conditional independence, HSV, HCL, residual-based shading, grid, R} \Address{ David Meyer\\ E-mail: \email{David.Meyer@R-project.org}\\ Achim Zeileis\\ E-mail: \email{Achim.Zeileis@R-project.org}\\ Kurt Hornik\\ E-mail: \email{Kurt.Hornik@R-project.org}\\ } \SweaveOpts{engine=R,eps=TRUE,height=6,width=7,results=hide,fig=FALSE,echo=TRUE,eps=FALSE} \setkeys{Gin}{width=0.7\textwidth} %\VignetteIndexEntry{The Strucplot Framework: Visualizing Multi-way Contingency Tables with vcd} %\VignetteDepends{vcd,grid} %\VignetteKeywords{contingency tables, mosaic plots, association plots, sieve plots, categorical data, independence, conditional independence, HSV, HCL, residual-based shading, grid, R} %\VignettePackage{vcd} <>= set.seed(1071) library(grid) library(vcd) data(Titanic) data(HairEyeColor) data(PreSex) data(Arthritis) art <- xtabs(~Treatment + Improved, data = Arthritis) @ \newcommand{\var}[1]{\textit{\texttt{#1}}} \newcommand{\data}[1]{\texttt{#1}} \newcommand{\class}[1]{\textsf{#1}} %% \code without `-' ligatures \def\nohyphenation{\hyphenchar\font=-1 \aftergroup\restorehyphenation} \def\restorehyphenation{\hyphenchar\font=`-} {\catcode`\-=\active% \global\def\code{\bgroup% \catcode`\-=\active \let-\codedash% \Rd@code}} \def\codedash{-\discretionary{}{}{}} \def\Rd@code#1{\texttt{\nohyphenation#1}\egroup} \newcommand{\codefun}[1]{\code{#1()}} %% end of declarations %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{document} %% include your article here, just as usual %% Note that you should use the \pkg{}, \proglang{} and \code{} commands. \section[Introduction]{Introduction} %% Note: If there is markup in \(sub)section, then it has to be escape as above. In order to explain multi-dimensional categorical data, statisticians typically look for (conditional) independence structures. Whether the task is purely exploratory or model-based, techniques such as mosaic and association plots offer good support for visualization. Both visualize aspects of (possibly higher-dimensional) contingency tables, with several extensions introduced over the last two decades, and implementations available in many statistical environments. A \emph{mosaic plot} \citep{vcd:Hartigan+Kleiner:1984} is basically an area-proportional visualization of (typically, observed) frequencies, composed of tiles (corresponding to the cells) created by recursive vertical and horizontal splits of a rectangle. Thus, the area of each tile is proportional to the corresponding cell entry \emph{given} the dimensions of previous splits. An \emph{association plot} \citep{vcd:Cohen:1980} visualizes the standardized deviations of observed frequencies from those expected under a certain independence hypothesis. Each cell is represented by a rectangle that has (signed) height proportional to the residual and width proportional to the square root of the expected counts, so that the area of the box is proportional to the difference in observed and expected frequencies. Extensions to these techniques have mainly focused on the following aspects. \begin{enumerate} \item Varying the shape of bar plots and mosaic displays to yield, e.g., double-decker plots \citep{vcd:hofmann:2001}, spine plots, or spinograms \citep{vcd:hofmann+theus}. \item Using residual-based shadings to visualize log-linear models \citep{vcd:Friendly:1994,vcd:Friendly:2000} and significance of statistical tests \citep{vcd:Meyer+Zeileis+Hornik:2003,vcd:Zeileis+Meyer+Hornik:2007}. \item Using pairs plots and trellis-like layouts for marginal, conditional and partial views \citep{vcd:Friendly:1999}. \item Adding direct user interaction, allowing quick exploration and modification of the visualized models \citep{vcd:Unwin+Hawkins+Hofmann:1996,vcd:Theus:2003}. \item Providing a modular and flexible implementation to easily allow user extensions \citep{vcd:Meyer+Zeileis+Hornik:2003,vcd:Meyer+Zeileis+Hornik:2006b}. \end{enumerate} \noindent Current implementations of mosaic displays can be found, e.g., for \proglang{SAS} \citep{vcd:SAS:2005}, \pkg{ViSta} \citep{vcd:young:1996}, \pkg{MANET} \citep{vcd:Unwin+Hawkins+Hofmann:1996}, \pkg{Mondrian} \citep{vcd:Theus:2003}, \proglang{R} \citep{vcd:R:2006}, and \proglang{S-PLUS} \citep{vcd:SPLUS:2005}. For \proglang{R}, currently three implementations do exist in the packages \pkg{graphics} (in base \proglang{R}), \pkg{vcd} \citep{vcd:Meyer+Zeileis+Hornik:2006b}, and \pkg{iplots} \citep{vcd:urbanek+wichtrey:2006}, respectively. Table \ref{tab:compare} gives an overview of the available functionality in these systems. Most environments are available on Windows, MacOS, and Linux/Unix variants, except \pkg{MANET} which is only available for the Macinthosh platforms. \begin{table}[h] \centering \begin{tabular}{|l|c|c|c|c|c|c|c|c|c|} \hline & & &\multicolumn{3}{c|}{} & & &\\ & \proglang{SAS} & \proglang{S-PLUS} &\multicolumn{3}{c|}{\proglang{R}} & \pkg{ViSta} & \pkg{MANET} & \pkg{Mondrian}\\ & & &\pkg{base}&\pkg{vcd} &\pkg{iplots}& & &\\\hline Basic functionality & $\times$ & $\times$ & $\times$ &$\times$ &$\times$ & $\times$ & $\times$& $\times$\\ Shape & & & &$\times$ && $\times$ & $\times$&\\ Res.-based shadings & $\times$ & & $\times$ & $\times$ & ($\times$) & &($\times$)& ($\times$)\\ Highlighting & & & &$\times$ &$\times$ & $\times$ & $\times$& $\times$\\ Conditional views & $\times$ & & &$\times$ & & $\times$ & $\times$&\\ Interaction & & & & &$\times$ & $\times$ & $\times$& $\times$\\ Linking & & & & &$\times$ & $\times$ & $\times$& $\times$\\ Extensible design & & & &$\times$ & & & &\\ Language & \proglang{SAS} & \proglang{S} & \proglang{R} & \proglang{R} & \proglang{R}/\proglang{Java} & \proglang{XLisp} & \proglang{C++} & \proglang{Java}\\ \hline \end{tabular} \caption{Comparison of current software environments.} \label{tab:compare} \end{table} Figures \ref{fig:arthritis} to \ref{fig:titanic} illustrate some of these extensions. Figure~\ref{fig:arthritis} shows the results from a double-blind clinical trial investigating a new treatment for rheumatoid arthritis, using an extended mosaic plot with residual-based shading based on the maximum statistic: clearly, the new treatment is effective. The dark blue cell indicates that the rate of treated patients showing marked improvement is significant at the 1\% level. Figure \ref{fig:ucbadmissions} visualizes the well-known UCB admissions data by means of a conditional association plot. The panels show the residuals from a conditional independence model (independence of gender and admission, given department), stratified by department. Clearly, the situation in department A (more women/less men accepted than would be expected under the null hypothesis) causes the rejection of the hypothesis of conditional independence. Figure~\ref{fig:presex} illustrates the conditional independence of premarital and extramarital sex, given gender and marital status. The $\chi^2$ test of independence, based on the permutation distribution, rejects the null hypothesis: possibly, because the tendency of people to have extramarital sex when they had premarital sex is particularly marked among married people? The rate of such women and men ist significant at the 0.01 and 0.1 level, respectively. Finally, Figure~\ref{fig:titanic} visualizes the ``Survival on the Titanic'' data using a double-decker plot. Here, a binary response (survival of the disaster) is to be explained by other factors (class, gender, and age). The gray boxes represent the proportion of survived passengers in a particular stratum. The proportions of saved women and children are indeed higher than those of men, but they clearly decrease from the 1st to the 3rd class. In addition, the proportion of saved men in the 1st class is higher than in the others. \setkeys{Gin}{width=0.7\textwidth} \begin{figure}[p] \begin{center} <>= mosaic(art, gp = shading_max, split_vertical = TRUE) @ \caption{Mosaic plot for the \data{Arthritis} data.} \label{fig:arthritis} \end{center} \end{figure} \setkeys{Gin}{width=\textwidth} \begin{figure}[p] \begin{center} <>= cotabplot(UCBAdmissions, panel = cotab_coindep, shade = TRUE, legend = FALSE, type = "assoc") @ \caption{Conditional association plot for the \data{UCBAdmissions} data.} \label{fig:ucbadmissions} \end{center} \end{figure} \setkeys{Gin}{width=0.7\textwidth} \begin{figure}[p] \begin{center} <>= presextest <- coindep_test(PreSex, margin = c(1,4), indepfun = function(x) sum(x^2), n = 5000) mosaic(PreSex, condvars = c(1, 4), shade = TRUE, gp_args = list(p.value = presextest$p.value)) @ \caption{Mosaic plot for the \data{PreSex} data.} \label{fig:presex} \end{center} \end{figure} \setkeys{Gin}{width=0.8\textwidth} \begin{figure}[p] \begin{center} <>= doubledecker(Survived ~ ., data = Titanic, labeling_args = list(set_varnames = c(Sex = "Gender"))) @ \caption{Double-decker plot for the \data{Titanic} data.} \label{fig:titanic} \end{center} \end{figure} This paper describes the strucplot framework provided by the \pkg{vcd} package for the \proglang{R} environment for statistical computing and graphics, available from the Comprehensive \proglang{R} Archive Network (\url{http://CRAN.R-project.org/}). The framework integrates displays such as mosaic, association, and sieve plots by their unifying property of being flat representations of contingency tables. These basic plots, as well as specialized displays for conditional independence, can be used both for exploratory visualization and model-based analysis. Exploratory techniques include specialized displays for the bivariate case, as well as pairs and trellis-type displays for higher-dimensional tables. Model-based tools include methods suitable for the visualization of conditional independence tests (including permutation tests), as well as for the visualization of particular GLMs (logistic regression, log-linear models). Additionally, two of the framework's further strengths are its flexibility and extensibility: graphical appearance aspects such as shading, labeling, and spacing are modularized by means of ``\underline{\vphantom{g}gr}aphical \underline{\vphantom{g}ap}pearance \underline{\vphantom{g}con}trol'' (\emph{grapcon}) functions, allowing fine-granular customization and user-level extensions. The remainder of the paper is organized as follows. In Section \ref{sec:strucplot}, we give an overview of the strucplot framework, describing the hierarchy of the main components and the basic functionality. In Section \ref{sec:shading}, we demonstrate how (residual-based) shadings support the visualization of log-linear models and the results of independence tests. Also, we explain step-by-step how the concepts of generating and grapcon functions can be combined to provide a flexible customization of complex graphical displays as created by the strucplot framework. Sections \ref{sec:labeling} and \ref{sec:spacing} discuss in detail the labeling and spacing features, respectively. Section \ref{sec:example} exemplifies the framework in the analysis of a four-way data set. Section \ref{sec:conclusion} concludes the work. \section[The strucplot framework]{The strucplot framework} \label{sec:strucplot} The strucplot framework in the \proglang{R} package \pkg{vcd}, used for visualizing multi-way contingency tables, integrates techniques such as mosaic displays, association plots, and sieve plots. The main idea is to visualize the tables' cells arranged in rectangular form. For multi-way tables, the variables are nested into rows and columns using recursive conditional splits, given the margins. The result is a ``flat'' representation that can be visualized in ways similar to a two-dimensional table. This principle defines a class of conditional displays which allows for granular control of graphical appearance aspects, including: \begin{itemize} \item the content of the tiles \item the split direction for each dimension \item the graphical parameters of the tiles' content \item the spacing between the tiles \item the labeling of the tiles \end{itemize} The strucplot framework is highly modularized: Figure~\ref{fig:struc} shows the hierarchical relationship between the various components. On the lowest level, there are several groups of workhorse and parameter functions that directly or indirectly influence the final appearance of the plot (see Table \ref{tab:grapcons} for an overview). These are examples of grapcon functions. They are created by generating functions (\emph{grapcon generators}), allowing flexible parameterization and extensibility (Figure~\ref{fig:struc} only shows the generators). The generator names follow the naming convention \code{\textit{group\_foo}()}, where \code{\textit{group}} reflects the group the generators belong to (strucplot core, labeling, legend, shading, or spacing). The workhorse functions (created by \code{struc\_\textit{foo}()}, \code{labeling\_\textit{foo}()}, and \code{legend\_\textit{foo}()}) directly produce graphical output (i.e., ``add ink to the canvas''), whereas the parameter functions (created by \code{spacing\_\textit{foo}()} and \code{shading\_\textit{foo}()}) compute graphical parameters used by the others. The grapcon functions returned by \code{struc\_\textit{foo}()} implement the core functionality, creating the tiles and their content. On the second level of the framework, a suitable combination of the low-level grapcon functions (or, alternatively, corresponding generating functions) is passed as ``hyperparameters'' to \codefun{strucplot}. This central function sets up the graphical layout using grid viewports (see Figure~\ref{fig:layout}), and coordinates the specified core, labeling, shading, and spacing functions to produce the plot. On the third level, we provide several convenience functions such as \codefun{mosaic}, \codefun{sieve}, \codefun{assoc}, and \codefun{doubledecker} which interface \codefun{strucplot} through sensible parameter defaults and support for model formulae. Finally, on the fourth level, there are ``related'' \pkg{vcd} functions (such as \codefun{cotabplot} and the \codefun{pairs} methods for table objects) arranging collections of plots of the strucplot framework into more complex displays (e.g., by means of panel functions). \begin{table} \begin{tabular}{|l|l|l|} \hline \textbf{Group} & \textbf{Grapcon generator} & \textbf{Description}\\\hline strucplot & \codefun{struc\_assoc} & core function for association plots\\ core & \codefun{struc\_mosaic} & core function for mosaic plots\\ & \codefun{struc\_sieve} & core function for sieve plots\\\hline\hline labeling & \codefun{labeling\_border} & border labels\\ & \codefun{labeling\_cboxed} & centered labels with boxes, all labels clipped,\\ && and on top and left border\\ & \codefun{labeling\_cells} & cell labels\\ & \codefun{labeling\_conditional} & border labels for conditioning variables\\ && and cell labels for conditioned variables\\ & \codefun{labeling\_doubledecker} & draws labels for doubledecker plot\\ & \codefun{labeling\_lboxed} & left-aligned labels with boxes\\ & \codefun{labeling\_left} & left-aligned border labels\\ & \codefun{labeling\_left2} & left-aligned border labels, all labels on top and left border\\ & \codefun{labeling\_list} & draws a list of labels under the plot\\\hline\hline shading & \codefun{shading\_binary} & visualizes the sign of the residuals\\ & \codefun{shading\_Friendly} & implements Friendly shading (based on HSV colors)\\ & \codefun{shading\_hcl} & shading based on HCL colors\\ & \codefun{shading\_hsv} & shading based on HSV colors\\ & \codefun{shading\_max} & shading visualizing the maximum test statistic\\ && (based on HCL colors)\\ & \codefun{shading\_sieve} & implements Friendly shading customized for sieve plots\\ && (based on HCL colors)\\\hline\hline spacing & \codefun{spacing\_conditional} & increasing spacing for conditioning variables,\\&& equal spacing for conditioned variables\\ & \codefun{spacing\_dimequal} & equal spacing for each dimension\\ & \codefun{spacing\_equal} & equal spacing for all dimensions\\ & \codefun{spacing\_highlighting} & increasing spacing, last dimension set to zero\\ & \codefun{spacing\_increase} & increasing spacing\\\hline\hline legend & \codefun{legend\_fixed} & creates a fixed number of bins (similar to \codefun{mosaicplot})\\ & \codefun{legend\_resbased} & suitable for an arbitrary number of bins\\&& (also for continuous shadings)\\\hline \end{tabular} \caption{Available grapcon generators in the strucplot framework} \label{tab:grapcons} \end{table} \begin{figure}[h] \begin{center} \includegraphics[width=0.8\textwidth]{struc} \caption{Components of the strucplot framework.} \label{fig:struc} \end{center} \end{figure} \setkeys{Gin}{width=0.6\textwidth} \begin{figure}[h] \begin{center} <>= pushViewport(vcd:::vcdViewport(legend = T, mar =4)) seekViewport("main") grid.rect(gp = gpar(lwd = 3)) grid.text("main", gp = gpar(fontsize = 20)) seekViewport("sub") grid.rect(gp = gpar(lwd = 3)) grid.text("sub", gp = gpar(fontsize = 20)) seekViewport("plot") grid.rect(gp = gpar(lwd = 3)) grid.text("plot", gp = gpar(fontsize = 20)) seekViewport("legend") grid.text("legend", rot = 90, gp = gpar(fontsize = 20)) grid.rect(gp = gpar(lwd = 3)) seekViewport("legend_sub") grid.rect(gp = gpar(lwd = 3)) grid.text("[F]", gp = gpar(fontsize = 20)) seekViewport("legend_top") grid.rect(gp = gpar(lwd = 3)) grid.text("[E]", gp = gpar(fontsize = 20)) seekViewport("margin_top") grid.rect(gp = gpar(lwd = 3)) grid.text("margin_top", gp = gpar(fontsize = 20)) seekViewport("margin_bottom") grid.rect(gp = gpar(lwd = 3)) grid.text("margin_bottom", gp = gpar(fontsize = 20)) seekViewport("margin_right") grid.rect(gp = gpar(lwd = 3)) grid.text("margin_right", rot = 90, gp = gpar(fontsize = 20)) seekViewport("margin_left") grid.rect(gp = gpar(lwd = 3)) grid.text("margin_left", rot = 90, gp = gpar(fontsize = 20)) seekViewport("corner_top_left") grid.rect(gp = gpar(lwd = 3)) grid.text("[A]", gp = gpar(fontsize = 20)) seekViewport("corner_top_right") grid.rect(gp = gpar(lwd = 3)) grid.text("[B]", gp = gpar(fontsize = 20)) seekViewport("corner_bottom_left") grid.rect(gp = gpar(lwd = 3)) grid.text("[C]", gp = gpar(fontsize = 20)) seekViewport("corner_bottom_right") grid.rect(gp = gpar(lwd = 3)) grid.text("[D]", gp = gpar(fontsize = 20)) @ \caption{Viewport layout for strucplot displays with their names. [A] = ``corner\_top\_left'', [B] = ``corner\_top\_right'', [C] = ``corner\_bottom\_left'', [D] = ``corner\_bottom\_right'', [E] = ``legend\_top'', [F] = ``legend\_sub''.} \label{fig:layout} \end{center} \end{figure} \setkeys{Gin}{width=0.7\textwidth} \subsection{Mosaic, association, and sieve plots} As an example, consider the \data{HairEyeColor} data containing two polytomous variables (hair and eye color), as well as one (artificial) dichotomous gender variable (\code{Sex}). The ``flattened'' contingency table can be obtained using the \codefun{structable} function (quite similar to \codefun{ftable} in base \proglang{R}, but allowing the specification of split directions): <>= (HEC <- structable(Eye ~ Sex + Hair, data = HairEyeColor)) @ Let us first visualize the contingency table by means of a mosaic plot. % \citep{vcd:Hartigan+Kleiner:1984} which is basically % an area-proportional visualization of (typically, observed) frequencies, composed % of tiles (corresponding to the cells) created by recursive % vertical and horizontal splits of a square. Thus, the area of each tile % is proportional to the corresponding cell entry \emph{given} the % dimensions of previous splits. The effect of <>= mosaic(HEC) @ \noindent equivalent to <>= mosaic(~ Sex + Eye + Hair, data = HairEyeColor) @ %\setkeys{Gin}{width=0.75\textwidth} \begin{figure}[p] \begin{center} <>= <> @ \caption{Mosaic plot for the \data{HairEyeColor} data.} \label{fig:observed} \end{center} \end{figure} \noindent depicts the observed frequencies of the \code{HairEyeColor} data. If there are zero entries, tiles have zero area and are, additionally, marked by small bullets (see, e.g, Figure~\ref{fig:titanic}). By default, these cells are not split further. The bullets help distinguishing very small cells from zero entries, and are particularly useful when color shadings come into play (see the example using the \data{Bundesliga} data in Section \ref{sec:overview}). Note that in contrast to, e.g., \codefun{mosaicplot} in base \proglang{R}, the default split direction and level ordering in all strucplot displays correspond to the textual representation produced by the print methods. It is also possible to visualize the expected values instead of the observed values (see Figure~\ref{fig:expected}): <>= mosaic(HEC, type = "expected") @ \begin{figure}[p] \begin{center} <>= <> @ \caption{Mosaic plot for the \data{HairEyeColor} data (expected values).} \label{fig:expected} \end{center} \end{figure} %\setkeys{Gin}{width=0.7\textwidth} \noindent In order to compare observed and expected values, a sieve plot \citep{vcd:riedwyl+schuepbach:1994} could be used (see Figure~\ref{fig:sieve}): <>= sieve(~ Sex + Eye + Hair, data = HEC, spacing = spacing_dimequal(c(2,0,0))) @ \begin{figure}[h] \begin{center} <>= <> @ \caption{Sieve plot for the \data{HairEyeColor} data visualizing simultaneously observed and expected values.} \label{fig:sieve} \end{center} \end{figure} \noindent where \code{spacing\_dimequal} is used to set the spacing of the second and third dimension to zero. Alternatively, we can directly inspect the residuals. The Pearson residuals (standardized deviations of observed from expected values) are conveniently visualized using association plots \citep{vcd:Cohen:1980}. In contrast to \codefun{assocplot} in base \proglang{R}, \pkg{vcd}'s \codefun{assoc} function scales to more than two variables (see Figure~\ref{fig:residuals}): <>= assoc(HEC, compress = FALSE) @ \begin{figure}[p] \begin{center} <>= <> @ \caption{Association plot for the \data{HairEyeColor} data.} \label{fig:residuals} \end{center} \end{figure} \noindent where the \code{compress} argument keeps distances between tiles equal. For both mosaic plots and association plots, the splitting of the tiles can be controlled using the \code{split\_vertical} argument. The default is to alternate splits starting with a horizontal one (see Figure~\ref{fig:split}): <>= options(width=60) @ <>= mosaic(HEC, split_vertical = c(TRUE, FALSE, TRUE), labeling_args = list(abbreviate_labs = c(Eye = 3))) @ <>= options(width=70) @ \begin{figure}[p] \begin{center} <>= <> @ \caption{Mosaic plot for the \data{HairEyeColor} data---alternative splitting.} \label{fig:split} \end{center} \end{figure} \noindent (Note that \code{HEC}, a \class{structable} object, already includes a splitting information which simply gets overloaded in this example.) For compatibility with \codefun{mosaicplot} in base \proglang{R}, the \codefun{mosaic} function also allows the use of a \code{direction} argument taking a vector of \code{"h"} and \code{"v"} characters: <>= mosaic(HEC, direction = c("v","h","v")) @ By a suitable combination of splitting, spacing, and labeling settings, the functions provided by the strucplot framework can be customized in a quite flexible way. For example, the default method for \codefun{doubledecker} is simply a wrapper for \codefun{strucplot}, setting the right defaults. Most default settings such as colors, spacing, and labeling are specified via the parameters and passed through to \codefun{strucplot}. The additional code just handles the dependent variable information, and in particular permutes the table to have the dependent variable as the last dimension as required for the doubledecker plot. Figure~\ref{fig:titanic} shows a doubledecker plot of the \data{Titanic} data, explaining the probability of survival (``survived'') by age, given sex, given class. It is created by: <>= doubledecker(Titanic) @ \noindent equivalent to: <>= doubledecker(Survived ~ Class + Sex + Age, data = Titanic) @ \subsection{Conditional and partial views} So far, we have visualized either full or collapsed tables, as suggested by the analysis task at hand. Subtables can be selected in a similar way as for objects of class \class{table} using indexing. Note, however, that subsetting of \class{structable} objects is more restrictive because of their inherent conditional structure. Since the variables on both the row and the columns side are nested, subsetting is only possible ``outside-in'', that is, indexing operates on blocks defined by the variable levels. In the following, we use the Titanic data again, this time collapsed over \code{Survived} to investigate the structure of crew and passengers (and having the \code{Child} and \code{Age} labels of the \code{Age} variable swapped for optical clarity): <>= options(width=75) @ <>= (STD <- structable(~ Sex + Class + Age, data = Titanic[,,2:1,])) STD["Male",] STD["Male", c("1st","2nd","3rd")] @ <>= options(width=70) @ \noindent \emph{Conditioning} on levels (i.e., choosing a table subset for fixed levels of the conditioning variable(s)) is done using the \code{[[} operator. %]] Here again, the sequence of conditioning levels is restricted by the hierarchical structure of the \class{structable} object. In the following examples, note that compared to subsetting, the first dimension(s) are dropped: <>= STD[["Male",]] STD[[c("Male", "Adult"),]] STD[["Male","1st"]] @ \noindent Now, there are several ways for visualizing conditional independence structures. The ``brute force'' method is to draw separate plots for the strata. The following example compares the association between hair and eye color, given gender, by using subsetting on the flat table and \pkg{grid}'s viewport framework to visualize the two groups besides each other: <>= pushViewport(viewport(layout = grid.layout(ncol = 2))) @ <>= pushViewport(viewport(layout.pos.col = 1)) mosaic(STD[["Male"]], margins = c(left = 2.5, top = 2.5, 0), sub = "Male", newpage = FALSE) popViewport() @ <>= pushViewport(viewport(layout.pos.col = 2)) mosaic(STD[["Female"]], margins = c(top = 2.5, 0), sub = "Female", newpage = FALSE) popViewport(2) @ \setkeys{Gin}{width=\textwidth} \begin{figure}[p] \begin{center} <>= <> <> <> @ \caption{Two mosaic displays put side-by-side, visualizing the distribution of class and age, given gender. The marginal distribution of gender cannot be seen.} \label{fig:parttable} \end{center} \end{figure} \setkeys{Gin}{width=0.7\textwidth} \noindent Note the use of the \code{margins} argument: it takes a vector with up to four values whose unnamed components are recycled, but ``overruled'' by the named arguments. Thus, in the second example, only the top margin is set to 2.5 lines, and all other to 0. This idea applies to almost all vectorized arguments in the strucplot framework (with \code{split\_vertical} as a prominent exception). The \codefun{cotabplot} function does a much better job on this task: it arranges stratified strucplot displays in a lattice-like layout, conditioning on variable \emph{levels}. The plot in Figure~\ref{fig:cotabplot} shows class and age group, given sex: <>= cotabplot(~ Class + Age | Sex, data = STD, split_vertical = TRUE) @ \setkeys{Gin}{width=\textwidth} \begin{figure}[p] \begin{center} <>= <> @ \caption{Conditional table plot for the \data{Titanic} data, again visualizing the distribution of age and class, given gender, using separate mosaic displays like the ``manual'' plot in Figure~\ref{fig:parttable}.} \label{fig:cotabplot} \end{center} \end{figure} \setkeys{Gin}{width=0.7\textwidth} %\noindent The \code{labeling\_args} argument modifies the labels' %appearance: here, to be left-aligned and unclipped %(see Section \ref{sec:labeling}). \noindent Visualizing the strata separately ``hides'' the distribution of the conditioning variable(s) which may or may not be appropriate or sensible in a particular analysis step. If we wish to keep the information on the marginal distribution(s), we can use one single mosaic for the stratified plot since mosaic displays are ``conditional plots'' by definition. We just need to make sure that conditioning variables are used first for splitting. Both the default and the formula interface of \codefun{mosaic} allow the specification of conditioning variables (see Figure~\ref{fig:conditioning}): <>= mosaic(STD, condvars = "Sex", split_vertical = c(TRUE, TRUE, FALSE)) @ <>= mosaic(~ Class + Age | Sex, data = STD, split_vertical = c(TRUE, TRUE, FALSE)) @ \setkeys{Gin}{width=\textwidth} \begin{figure}[h] \begin{center} <>= <> @ \caption{Mosaic plot again visualizing the distribution of class and age, given gender, this time using a single mosaic plot. In contrast to Figures~\ref{fig:parttable} and \ref{fig:cotabplot}, this plot also visualizes the marginal distribution of gender.} \label{fig:conditioning} \end{center} \end{figure} \setkeys{Gin}{width=0.7} \noindent The effect of using this is that conditioning variables are permuted ahead of the the conditioned variables in the table, and that \codefun{spacing\_conditional} is used as default to better distinguish conditioning from conditioned dimensions. This spacing uses equal space between tiles of conditioned variables, and increasing space between tiles of conditioning variables (See Section~\ref{sec:spacing}). Another set of high-level functions for visualizing conditional independence models are the \codefun{pairs} methods for \class{table} and \class{structable} objects. In contrast to \codefun{cotabplot} which conditions on variables, the \codefun{pairs} methods create pairwise views of the table. They produce, by default, a plot matrix having strucplot displays in the off-diagonal panels, and the variable names (optionally, with univariate displays) in the diagonal cells. Figure~\ref{fig:pairs} shows a pairs display for the \data{Titanic} data with univariate mosaics in the diagonal, and mosaic plots visualizing the corresponding bivariate mosaics in the upper and lower triangles. Due to the inherent asymmetry of mosaic displays, the corresponding plots in the upper and lower triangle differ depending on which variable is used first for splitting---inspecting both views might help detecting patterns in a data set. Additionally, we are using a special spacing and shading normally used to `highlight' %' the second variable in the first (as will be discussed in Section \ref{sec:spacing}): here, the intention of the spacing is to emphasize the conditional distributions of the second variable, given the first one, and the shading helps identifying the factor levels in the second variable. <>= pairs(STD, highlighting = 2, diag_panel = pairs_diagonal_mosaic, diag_panel_args = list(fill = grey.colors)) @ %\setkeys{Gin}{width=\textwidth} \setkeys{Gin}{width=0.7\textwidth} \begin{figure}[h] \begin{center} <>= <> @ \caption{Pairs plot for the \data{Titanic} data.} \label{fig:pairs} \end{center} \end{figure} \setkeys{Gin}{width=0.7\textwidth} \noindent The labels of the variables are to be read from left to right and from top to bottom. In addition, the levels can be matched by position within the columns and by shading within the rows. In plots produced by \codefun{pairs}, each panel's row and column define two variables $X$ and $Y$ used for the specification of four different types of independence: pairwise, total, conditional, and joint. The pairwise mosaic matrix shows bivariate marginal relations between $X$ and $Y$, collapsed over all other variables. The total independence mosaic matrix shows mosaic plots for mutual independence, i.e., for marginal and conditional independence among all pairs of variables. The conditional independence mosaic matrix shows mosaic plots for marginal independence of $X$ and $Y$, given all other variables. The joint independence mosaic matrix shows mosaic plots for joint independence of all pairs ($X$, $Y$) of variables from the others. Upper and lower parts can independently be used to display different types of independence models, or different strucplot displays (mosaic, association, or sieve plots). The available panel functions (\codefun{pairs\_assoc}, \codefun{pairs\_mosaic}, and \codefun{pairs\_sieve}) are simple wrappers to \codefun{assoc}, \codefun{mosaic}, and \codefun{sieve}, respectively. Obviously, seeing patterns in strucplot matrices becomes increasingly difficult with higher dimensionality. Therefore, this plot is typically used with a suitable residual-based shading (see Section \ref{sec:shading}). \subsection{Interactive plot modifications} All strucplot core functions are supposed to produce conditional hierarchical plots by the means of nested viewports, corresponding to the provided splitting information. Thus, at the end of the plotting, each tile is associated with a particular viewport. Each of those viewports has to be conventionally named, enabling other strucplot modules, in particular the labeling functions, to access specific tiles after they have been plotted. The naming convention for the viewports is: \begin{center} \code{\emph{[Optional prefix]}cell:\emph{Variable1}=\emph{Level1},\emph{Variable2}=\emph{Level2}} \dots \end{center} \noindent Clearly, these names depend on the splitting. The following example shows how to access parts of the plot after it has been drawn (see Figure~\ref{fig:afterplot}): <>= mosaic(~ Hair + Eye, data = HEC, pop = FALSE) seekViewport("cell:Hair=Blond") grid.rect(gp = gpar(col = "red", lwd = 4)) seekViewport("cell:Hair=Blond,Eye=Blue") grid.circle(r = 0.2, gp = gpar(fill = "cyan")) @ \noindent Note that the viewport tree is removed by default. Therefore, the \texttt{pop} argument has to be set to \texttt{FALSE} when viewports shall be accessed. \setkeys{Gin}{width=0.6\textwidth} \begin{figure}[h] \begin{center} <>= <> @ \caption{Adding elements to a mosaic plot after drawing.} \label{fig:afterplot} \end{center} \end{figure} In addition to the viewports, the main graphical elements get names following a similar construction method. This allows to change graphical parameters of plot elements \emph{after} the plotting (see Figure~\ref{fig:changeplot}): <>= assoc(Eye ~ Hair, data = HEC, pop = FALSE) getNames()[1:6] grid.edit("rect:Hair=Blond,Eye=Blue", gp = gpar(fill = "red")) @ %% code-chunk reuse does not work with parameter changing \begin{figure}[h] \begin{center} <>= x <- tab <- margin.table(HairEyeColor, 1:2) x[] <- "light gray" x["Blond","Blue"] <- "Red" assoc(tab, gp = gpar(fill = x)) @ \caption{Changing graphical parameters of elements after drawing.} \label{fig:changeplot} \end{center} \end{figure} \subsection{Performance issues} \label{sec:performance} As stated above, the implementation of strucplot displays is based on creating and nesting \pkg{grid} viewports. The main time-consuming steps performed by the core functions are the following: \begin{enumerate} \item recursively, split the table until the individual cells are reached \item during the splits, add viewports to the plot \item for the individual cells, add plot-specific content (rectangles for mosaics, bars for association plots, etc.) \end{enumerate} \noindent All these operations scale linearly with the amount of created viewports. For a $d$-dimensional table with $k_i$ levels, $i=1 \dots d$, the total number of needed viewports $T_d$ can roughly be estimated as \begin{equation} \label{eq:numbervp} T_d \quad = \quad k_1 + k_1k_2 + \cdots + k_1 \cdots k_d \quad =\quad \sum_{i=1}^d \prod_{j \le i} k_j \end{equation} \noindent since we first push the $k_1$ viewports for the levels of the first dimension, then, for \emph{each} of these, the $k_2$ levels of the second dimension, etc. If the number of levels is equal ($k$) for all dimensions, $T_d$ simplifies to \begin{equation} \label{eq:equalvp} T_d \quad = \quad \sum_{i=1}^d k^i = \frac{k(k^d-1)}{k-1} \end{equation} \noindent and so the time complexity for drawing a strucplot display is of order $k^d$. \section{Shadings} \label{sec:shading} Unlike other graphics functions in base \proglang{R}, the strucplot framework allows almost full control over the graphical parameters of all plot elements. In particular, in association plots, mosaic plots, and sieve plots, the user can modify the graphical appearance of each tile individually. Built on top of this functionality, the framework supplies a set of shading functions choosing colors appropriate for the visualization of log-linear models. The tiles' graphical parameters are set using the \code{gp} argument of the functions of the strucplot framework. This argument basically expects an object of class \class{gpar} whose components are arrays of the same shape (length and dimensionality) as the data table (see Section \ref{sec:gp}). For convenience, however, the user can also supply a grapcon function that computes such an object given a vector of residuals, or, alternatively, a generating function that takes certain arguments and returns such a grapcon function (see Section \ref{sec:shadingcustom}). We provide several shading functions, including support for both HSV and HCL colors, and the visualization of significance tests (see Section \ref{sec:overview}). \subsection{Specifying graphical parameters of strucplot displays} \label{sec:gp} As an example, consider the \data{UCBAdmissions} data. In the table aggregated over departments, we would like to highlight the (incidentally wrong) impression that there were too many male students accepted compared to the presumably discriminated female students (see Figure~\ref{fig:ucb}): <>= (ucb <- margin.table(UCBAdmissions, 1:2)) (fill_colors <- matrix(c("dark cyan","gray","gray","dark magenta"), ncol = 2)) mosaic(ucb, gp = gpar(fill = fill_colors, col = 0)) @ \begin{figure}[h] \begin{center} <>= <> @ \caption{Mosaic plot for the \data{UCBAdmissions} data with highlighted cells.} \label{fig:ucb} \end{center} \end{figure} \noindent As the example shows, we create a fourfold table with appropriate colors (dark cyan for admitted male students and dark magenta for rejected female students) and supply them to the \code{fill} component of the \class{gpar} object passed to the \code{gp} argument of \codefun{mosaic}. For visual clarity, we additionally hide the tiles' borders by setting the \code{col} component to 0 (transparent). If the parameters specified in the \class{gpar} object are ``incomplete'', they will be recycled along the last splitting dimension. In the following example based on the \data{Titanic} data, we will highlight all cells corresponding to survived passengers (see Figure~\ref{fig:recycling}): <>= mosaic(Titanic, gp = gpar(fill = c("gray","dark magenta")), spacing = spacing_highlighting, labeling_args = list(abbreviate_labs = c(Age = 3), rep = c(Survived = FALSE)) ) @ \noindent Note that \codefun{spacing\_highlighting} sets the spaces between tiles in the last dimension to 0. The \code{labeling\_args} argument ensures that labels do not overlap (see Section \ref{sec:labeling}). \begin{figure}[h] \begin{center} <>= <> @ \caption{Recycling of parameters, used for highlighting the survived passengers in the \data{Titanic} data.} \label{fig:recycling} \end{center} \end{figure} \subsection{Customizing residual-based shadings} \label{sec:shadingcustom} This flexible way of specifying graphical parameters is the basis for a suite of shading functions that modify the tiles' appearance with respect to a vector of residuals, resulting from deviations of observed from expected frequencies under a given log-linear model. The idea is to visualize at least sign and absolute size of the residuals, but some shadings, additionally, indicate overall significance. One particular shading, the maximum shading \citep{vcd:Meyer+Zeileis+Hornik:2003,vcd:Zeileis+Meyer+Hornik:2007}, even allows to identify the cells that cause the rejection of the null hypothesis. Conceptually, the strucplot framework offers three alternatives to add residual-based shading to plots: \begin{enumerate} \item Precomputing the graphical parameters (e.g., fill colors), encapsulating them into an object of class \class{gpar} as demonstrated in the previous section, and passing this object to the \code{gp} argument. \item Providing a grapcon function to the \code{gp} argument that takes residuals as input and returns an object as described in alternative 1. \item Providing a grapcon generator taking parameters and returning a function as described in alternative~2. \end{enumerate} \noindent For each of these approaches, we will demonstrate the necessary steps to obtain a binary shading that visualizes the sign of the residuals by a corresponding fill color (for simplicity, we will treat 0 as positive). \subsubsection*{Alternative 1: Precomputed \class{gpar} object} The first method is precomputing the graphical parameters ``by hand''. We will use \code{royalblue4} color for positive and \code{mediumorchid4} color for negative residuals (see Figure~\ref{fig:binary}): <>= expected <- independence_table(ucb) (x <- (ucb - expected) / sqrt(expected)) (shading1_obj <- ifelse(x > 0, "royalblue4", "mediumorchid4")) mosaic(ucb, gp = gpar(fill = shading1_obj)) @ \begin{figure}[h] \begin{center} <>= <> @ \caption{Binary shading visualizing the sign of the residuals.} \label{fig:binary} \end{center} \end{figure} \subsubsection*{Alternative 2: Grapcon function} For implementing alternative 2, we need to create a ``shading function'' that computes \class{gpar} objects from residuals. For that, we can just reuse the code from the previous step: <>= shading2_fun <- function(x) gpar(fill = ifelse(x > 0, "royalblue4", "mediumorchid4")) @ \noindent To create a mosaic display with binary shading, it now suffices to specify the data table along with \codefun{shading2\_fun}: <>= mosaic(ucb, gp = shading2_fun) @ \noindent \codefun{mosaic} internally calls \codefun{strucplot} which computes the residuals from the specified independence model (total independence by default), passes them to \codefun{shading2\_fun}, and uses the \class{gpar} object returned to finally create the plot. Our \codefun{shading2\_fun} function might be useful, but can still be improved: the hard-wired colors should be customizable. We cannot simply extend the argument list to include, e.g., a \code{fill = c("royalblue4", "mediumorchid4")} argument because \codefun{strucplot} will neither know how to handle it, nor let us change the defaults. In fact, the interface of shading functions is fixed, they are expected to take exactly one argument: a table of residuals. This is where generating functions (alternative 3) come into play. \subsubsection*{Alternative 3: Grapcon generator} We simply wrap our grapcon shading function in another function that takes all additional arguments it needs to use, possibly preprocesses them, and returns the actual shading function. This returned function will have access to the parameters since in \proglang{R}, nested functions are lexically scoped. Thus, the grapcon generator returns (``creates'') a ``parameterized'' shading function with the minimal standard interface \codefun{strucplot} requires. The following example shows the necessary extensions for our running example: <>= shading3a_fun <- function(col = c("royalblue4", "mediumorchid4")) { col <- rep(col, length.out = 2) function(x) gpar(fill = ifelse(x > 0, col[1], col[2])) } @ \noindent The first statement just makes sure that exactly two colors are specified. In the call to \codefun{mosaic}, using the new \codefun{shading3a\_fun} function, we can now simply change the colors: <>= mosaic(ucb, gp = shading3a_fun(c("royalblue4","mediumorchid4"))) @ \noindent (figure not shown). The procedure described so far is a rather general concept, applicable to a wide family of user-level \pkg{grid} graphics. Indeed, the customization of other components of the strucplot framework (labeling, spacing, legend, and core functions) follows the same idea. Now for the shading functions, more customization is needed. Note that \codefun{shading3a\_fun} needs to be evaluated by the user, even if the defaults are to be used. It is a better idea to let \codefun{strucplot} call the generating function, which, in particular, allows the passing of arguments that are computed by \codefun{strucplot}. Since shading functions can be used for visualizing significance (see Section \ref{sec:overview}), it makes sense for generating functions to have access to the model, i.e., observed and expected values, residuals, and degrees of freedom. For example, the \codefun{shading\_max} generating function computes a permutation distribution of the maximum statistic and $p$ values for specified significance levels based on the observed table to create data-driven cut-off points. If this was done in the shading function itself, the permutation statistic would be recomputed every time the shading function is called, resulting in possibly severe performance loss and numerical inconsistencies. Therefore, generating functions for shadings are required to take at least the parameters \code{observed}, \code{expected}, \code{residuals}, and \code{df} (these are provided by the strucplot framework), followed by other parameters controlling the shading appearance (to be specified by the user): <>= shading3b_fun <- function(observed = NULL, residuals = NULL, expected = NULL, df = NULL, col = c("royalblue4", "mediumorchid4")) { col <- rep(col, length.out = 2) function(x) gpar(fill = ifelse(x > 0, col[1], col[2])) } class(shading3b_fun) <- "grapcon_generator" @ Note that in this simple binary shading example, the first four parameters are not used. In some sense, generating functions for shadings are parameterized both by the user and the strucplot framework. For shading functions that require model information, the user-specified parameters are to be passed to the \code{gp\_args} argument instead, and for this to work, the generating function needs a class attribute to be distinguishable from the ``normal'' shading functions. For others (like our simple \codefun{shading3b\_fun}) this is optional, but recommended for consistency: <>= mosaic(ucb, gp = shading3b_fun, gp_args = list(col = c("red","blue"))) @ \noindent The final \codefun{shading3b\_fun} pretty much resembles \codefun{shading\_binary}, one of the standard shading functions provided by the \pkg{vcd} package. \subsection[An overview of the shading functions in vcd]{An overview of the shading functions in \pkg{vcd}} \label{sec:overview} \cite{vcd:Friendly:1994} suggested a residual-based shading for the mosaic tiles that can also be applied to the rectangles in association plots \citep{vcd:Meyer+Zeileis+Hornik:2003}. Apart from \codefun{shading\_binary}, there are currently two basic shadings available in \pkg{vcd}: \codefun{shading\_hcl} and \codefun{shading\_hsv}, as well as two derived functions: \codefun{shading\_Friendly} building upon \codefun{shading\_hsv}, and \codefun{shading\_max} building upon \codefun{shading\_hcl}. \codefun{shading\_hsv} and \codefun{shading\_hcl} provide the same conceptual tools, but use different color spaces: the Hue-Saturation-Value (HSV) and the Hue-Chroma-Luminance (HCL) scheme, respectively. We will first expose the basic concept of these shading functions using HSV space, and then briefly explain the differences to HCL space \citep[a detailed discussion can be found in][]{vcd:Zeileis+Meyer+Hornik:2007}. Color palettes in HCL space are preferable to palettes derived from HSV space from a perceptual point of view. Functions for creating palettes (see, e.g., \codefun{diverge\_hcl}) are provided with the \pkg{vcd} package. In HSV space, colors are specified in three dimensions: Hue, Saturation (``colorfulness''), and Value (``lightness'', amount of gray). These three dimensions are used by \codefun{shading\_hsv} to visualize information about the residuals and the underlying independence model. The hue indicates the residuals' sign: by default, blue for positive, and red for negative residuals. The saturation of a residual is set according to its size: high saturation for large, and low saturation for small residuals. Finally, the overall lightness is used to indicate the significance of a test statistic: light colors for significant, and dark colors for non-significant results. As an example, we will visualize the association of hair and eye color in the \data{HairEyeColor} data set (see Figure~\ref{fig:haireye}, top): <>= haireye <- margin.table(HairEyeColor, 1:2) mosaic(haireye, gp = shading_hsv) @ \noindent As introduced before, the default shading scheme is not \codefun{shading\_hsv} but \codefun{shading\_hcl} due to the better perceptual characteristics of HCL color space. The following example again illustrates the \data{HairEyeColor} data, this time with HCL colors: <>= mosaic(haireye, gp = shading_hcl) @ <>= mosaic(haireye, gp = shading_hcl, gp_args = list(h = c(130, 43), c = 100, l = c(90, 70))) @ \noindent In Figure~\ref{fig:haireye}, the plot in the middle depicts the default palette, and the bottom plot an alternative setting for Hue (\code{h}), Chroma (\code{c}), and Luminance (\code{l}). \setkeys{Gin}{width=0.5\textwidth} \begin{figure}[htbp] \begin{center} <>= mosaic(haireye, gp = shading_hsv, margin = c(bottom = 1), keep_aspect_ratio = FALSE) @ <>= mosaic(haireye, gp = shading_hcl, margin = c(bottom = 1), keep_aspect_ratio = FALSE) @ <>= mosaic(haireye, gp = shading_hcl, margin = c(bottom = 1), gp_args = list(h = c(130, 43), c = 100, l = c(90, 70)), keep_aspect_ratio = FALSE) @ \caption{Three mosaic plots for the \data{HairEyeColor} data using different color palettes. Top: default HSV color palette. Middle: default HCL color palette. Bottom: a custom HCL color palette.} \label{fig:haireye} \end{center} \end{figure} \setkeys{Gin}{width=0.7\textwidth} \noindent Large positive residuals (greater than $4$) can be found for brown eyes/black hair and blue eyes/blond hair, and are colored in deep blue. On the other hand, there is a large negative residual (less than $-4$) for brown eyes/blond hair, colored deep red. There are also three medium-sized positive (negative) residuals between 2 and 4 ($-2$ and $-4$): the colors for them are less saturated. Residuals between $-2$ and $2$ are shaded in white (gray for HCL-shading). The heuristic for choosing the cut-off points $2$ and $4$ is that the Pearson residuals are approximately standard normal which implies that the highlighted cells are those with residuals \emph{individually} significant at approximately the $\alpha = 0.05$ and $\alpha = 0.0001$ levels, respectively. These default cut-off points can be changed to alternative values using the \code{interpolate} argument (see Figure~\ref{fig:interpolatecontinuous}): <>= mosaic(haireye, shade = TRUE, gp_args = list(interpolate = 1:4)) @ \noindent The elements of the numeric vector passed to \code{interpolate} define the knots of an interpolating step function used to map the absolute residuals to saturation levels. The \code{interpolate} argument also accepts a user-defined function, which then is called with the absolute residuals to get a vector of cut-off points. Thus, it is possible to automatically choose the cut-off points in a data-driven way. For example, one might think that the extension from four cut-off points to a continuous shading---visualizing the whole range of residuals---could be useful. We simply need a one-to-one mapping from the residuals to the saturation values: <>= ipol <- function(x) pmin(x/4, 1) @ \noindent Note that this \codefun{ipol} function maps residuals greater than 4 to a saturation level of 1. However, the resulting plot (Figure~\ref{fig:interpolatecontinuous}, right) is deceiving: <>= mosaic(haireye, shade = TRUE, gp_args = list(interpolate = ipol), labeling_args = list(abbreviate_labs = c(Sex = TRUE))) @ \setkeys{Gin}{width=\textwidth} \begin{figure}[htbp] \begin{center} <>= pushViewport(viewport(layout = grid.layout(ncol = 2))) pushViewport(viewport(layout.pos.col = 1)) mosaic(haireye, gp_args = list(interpolate = 1:4), margin = c(right = 1), keep_aspect_ratio= FALSE,newpage = FALSE,legend_width=5.5,shade = TRUE) popViewport(1) pushViewport(viewport(layout.pos.col = 2)) mosaic(haireye, gp_args = list(interpolate = ipol), margin = c(left=3,right = 1), keep_aspect_ratio = FALSE, newpage = FALSE, shade = TRUE) popViewport(2) @ \caption{\label{fig:interpolatecontinuous}The \data{HairEyeColor} data. Left: shading with 4 cut-off points. Right: continuous shading.} \end{center} \end{figure} \setkeys{Gin}{width=0.7\textwidth} \noindent Too much color makes it difficult to interpret the image, and the subtle color differences are hard to catch. Therefore, we only included shadings with discrete cut-off points. The third remaining dimension, the value, is used for visualizing the significance of a test statistic. The user can either directly specify the $p$ value, or, alternatively, a function that computes it, to the \code{p.value} argument. Such a function must take observed and expected values, residuals, and degrees of freedom (used by the independence model) as arguments. If nothing is specified, the $p$ value is computed from a $\chi^2$ distribution with \code{df} degrees of freedom. The \code{level} argument is used to specify the confidence level: if \code{p.value} is smaller than \code{1 - level}, light colors are used, otherwise dark colors are employed. The following example using the \data{Bundesliga} data shows the relationship of home goals and away goals of Germany's premier soccer league in 1995: although there are two ``larger'' residuals (one greater than 2, one less then $-2$), the $\chi^2$ test does not reject the null hypothesis of independence. Consequently, the colors appear dark (see Figure~\ref{fig:bundesliga}, left): <>= BL <- xtabs(~ HomeGoals + AwayGoals, data = Bundesliga, subset = Year == 1995) mosaic(BL, shade = TRUE) @ \noindent Note that in extended mosaic plots, bullets drawn for zero cells are shaded, too, bringing out non-zero residuals, if any. A shading function building upon \codefun{shading\_hsv} is \codefun{shading\_Friendly}, implementing the shading introduced by \cite{vcd:Friendly:1994}. In addition to the defaults of the HSV shading, it uses the border color and line type to redundantly code the residuals' sign. The following example again uses the \data{Bundesliga} data from above, this time using the Friendly scheme and, in addition, an alternative legend (see Figure~\ref{fig:bundesliga}, right): <>= mosaic(BL, gp = shading_Friendly, legend = legend_fixed, zero_size = 0) @ \setkeys{Gin}{width=\textwidth} \begin{figure}[htbp] \begin{center} <>= pushViewport(viewport(layout = grid.layout(ncol = 2))) pushViewport(viewport(layout.pos.col = 1)) mosaic(BL, margin = c(right = 1), keep_aspect_ratio= FALSE, newpage = FALSE, legend_width=5.5, shade = TRUE) popViewport(1) pushViewport(viewport(layout.pos.col = 2)) mosaic(BL, gp = shading_Friendly, legend = legend_fixed, zero_size = 0, margin = c(right = 1), keep_aspect_ratio= FALSE, newpage = FALSE, legend_width=5.5) popViewport(2) @ \caption{The \data{Bundesliga} data for 1995. Left: Non-significant $\chi^2$ test. Right: using the Friendly shading and a legend with fixed bins.} \label{fig:bundesliga} \end{center} \end{figure} \setkeys{Gin}{width=0.7\textwidth} \noindent (The \code{zero\_size = 0} argument removes the bullets indicating zero observed values. This feature is not provided in the original \proglang{SAS} implementation of the Friendly mosaic plots.) % Figure~\ref{fig:shadingHSVHCL} depicts % HSV space in the upper panel and HCL space in the lower panel. % On the left (right) side, we see the color scales for red (blue) % hue, respectively. The $x$-axis represents the colorfulness, and the % $y$-axis the brightness. % The boxes represent the diverging color palettes used for the shadings. % For HSV space, we can see that the effect of changing the % level of brightness (`value') is not the same for different levels of % saturation, and again not the same for the two different hues. % In fact, in HSV space all dimensions are confounded, which % obviously is problematic for coding information. In contrast, HCL color % space offers perceptually uniform colors: as can be seen from the lower panel, % the chroma is homogeneous for different levels of luminance. % Unfortunately, this comes at the % price of the space being irregularly shaped, making it difficult to automatically select % diverging color palettes. % <>= % hue.slice <- function(hue, grid.n = 101, type = c("HCL", "HSV"), plot = TRUE, fixup = FALSE) % { % type <- match.arg(type) % if(type == "HCL") { % chroma = seq(0, 100, length.out = grid.n) % luminance = seq(0, 100, length.out = grid.n) % nc <- length(chroma) % nl <- length(luminance) % color.slice <- outer(chroma, luminance, function(y, x) hcl(hue, x, y, fixup = fixup)) % xlab <- "chroma" % ylab <- "luminance" % main <- paste("hue =", round(hue, digits = 0)) % } else { % chroma = seq(0, 1, length.out = grid.n) % luminance = seq(0, 1, length.out = grid.n) % nc <- length(chroma) % nl <- length(luminance) % color.slice <- outer(chroma, luminance, function(y, x) hsv(hue, x, y)) % xlab <- "saturation" % ylab <- "value" % main <- paste("hue =", round(hue, digits = 3)) % } % if(plot) { % plot(0.5, 0.5, xlim = range(chroma), ylim = range(luminance), type = "n", axes = FALSE, % xlab = xlab, ylab = ylab, yaxs = "i", xaxs = "i", main = main) % for(i in 1:(nc-1)) { % rect(chroma[i], luminance[-nl], chroma[i] + 100/(nc-1), luminance[-1], border = color.slice[,i+1], col = color.slice[,i+1]) % } % axis(1) % axis(2) % box() % } % colnames(color.slice) <- chroma % rownames(color.slice) <- luminance % attr(color.slice, "type") <- type % class(color.slice) <- "slice" % invisible(color.slice) % } % @ % \setkeys{Gin}{width=.8\textwidth} % \begin{figure}[p] % \begin{center} % <>= % ## generate colors % hue23 <- hue.slice(2/3, grid.n = 101, plot = FALSE, type = "HSV") % hue0 <- hue.slice(0, grid.n = 101, plot = FALSE, type = "HSV") % saturation <- as.numeric(colnames(hue23)) % value <- as.numeric(rownames(hue23)) % ## select those with value >= 0.5 % hue23 <- hue23[value >= .5, ] % hue0 <- hue0[value >= .5, ] % value <- value[value >= .5] % nl <- nrow(hue23) % nc <- ncol(hue23) % ## plot 2 slides from HSV space % plot(0.5, 0.5, xlim = c(-1, 1), ylim = c(0, 1), type = "n", axes = FALSE, % xlab = "", ylab = "", yaxs = "i", xaxs = "i", main = "") % for(i in 1:(nc-1)) { % rect(saturation[i], value[-nl], saturation[i] + 1/(nc-1), value[-1], border = hue23[,i+1], col = hue23[,i+1]) % } % for(i in 1:(nc-1)) { % rect(-saturation[i], value[-nl], -(saturation[i] + 1/(nc-1)), value[-1], border = hue0[,i+1], col = hue0[,i+1]) % } % axis(2, at = c(50, 75, 100)/100, labels = c(0.5, 0.75, 1)) % axis(4, at = c(50, 75, 100)/100, labels = c(0.5, 0.75, 1)) % axis(3, at = -4:4*.25, labels=c(4:0*.25, 1:4*.25)) % mtext(c("hue = 0", "hue = 2/3"), side = 3, at = c(-.5, .5), line = 3, cex = 1.2) % mtext("saturation", side = 3, at = 0, line = 2) % mtext("value", side = 2, at = .75, line = 2) % mtext("value", side = 4, at = .75, line = 2) % lines(c(-1, 1), c(.5, .5)) % ## significant colors % rect(-1, 0.95, -.90, 1, col = hsv(0, 1, 1)) % rect(-0.45, 0.95, -.55, 1, col = hsv(0, 0.5, 1)) % rect(-.05, .95, .05, 1, col = hsv(2/3, 0, 1)) % rect(0.45, 0.95, .55, 1, col = hsv(2/3, 0.5, 1)) % rect(.90, .95, 1, 1, col = hsv(2/3, 1, 1)) % text(-1, .33, "significant", pos = 4, cex = 1.2) % rect(-1, .20, -.80, .30, col = hsv(0, 1, 1)) % rect(-.40, .20, -0.6, .30, col = hsv(0, 0.5, 1)) % rect(-.20, .20, 0, .30, col = hsv(0, 0, 1)) % rect(0, .20, .20, .30, col = hsv(2/3, 0, 1)) % rect(0.4, .20, .60, .30, col = hsv(2/3, .5, 1)) % rect(.80, .20, 1, .30, col = hsv(2/3, 1, 1)) % lines(c(-.9, -.55), c(0.975, .975), lty = 2) % lines(c(-.45, -.05), c(0.975, .975), lty = 2) % lines(c(.45, .05), c(0.975, .975), lty = 2) % lines(c(.9, .55), c(0.975, .975), lty = 2) % ## non-significant colors % rect(-1, 0.5, -.90, 0.55, col = hsv(0, 1, 0.5)) % rect(-0.4, 0.5, -.55, 0.55, col = hsv(0, 0.5, 0.5)) % rect(-.05, .5, .05, 0.55, col = hsv(2/3, 0, 0.5)) % rect(0.45, 0.5, .55, 0.55, col = hsv(2/3, 0.5, 0.5)) % rect(.90, .5, 1, 0.55, col = hsv(2/3, 1, 0.5)) % text(-1, .13, "non-significant", pos = 4, cex = 1.2) % rect(-1, 0, -.80, .10, col = hsv(0, 1, 0.5)) % rect(-.60, 0, -.4, .10, col = hsv(0, 0.5, 0.5)) % rect(-.20, 0, 0, .10, col = hsv(0, 0, 0.5)) % rect(0, 0, .20, .10, col = hsv(2/3, 0, 0.5)) % rect(0.4, 0, .60, .1, col = hsv(2/3, .5, 0.5)) % rect(.80, 0, 1, .10, col = hsv(2/3, 1, 0.5)) % lines(c(-.9, -.55), c(0.525, .525), lty = 2) % lines(c(-.45, -.05), c(0.525, .525), lty = 2) % lines(c(.45, .05), c(0.525, .525), lty = 2) % lines(c(.9, .55), c(0.525, .525), lty = 2) % @ % <>= % ## generate colors % hue260 <- hue.slice(260, grid.n = 101, plot = FALSE) % hue360 <- hue.slice(360, grid.n = 101, plot = FALSE) % mychroma <- as.numeric(colnames(hue260)) % luminance <- as.numeric(rownames(hue260)) % ## select those with lumincance >= 50 % hue260 <- hue260[luminance >= 50, ] % hue360 <- hue360[luminance >= 50, ] % luminance <- luminance[luminance >= 50] % nc <- ncol(hue260) % nl <- nrow(hue260) % ## plot 2 slides from HCL space % plot(0.5, 0.5, xlim = c(-100, 100), ylim = c(0, 100), type = "n", axes = FALSE, % xlab = "", ylab = "", yaxs = "i", xaxs = "i", main = "") % for(i in 1:(nc-1)) { % rect(mychroma[i], luminance[-nl], mychroma[i] + 100/(nc-1), luminance[-1], border = hue260[,i+1], col = hue260[,i+1]) % } % for(i in 1:(nc-1)) { % rect(-mychroma[i], luminance[-nl], -(mychroma[i] + 100/(nc-1)), luminance[-1], border = hue360[,i+1], col = hue360[,i+1]) % } % axis(2, at = c(50, 70, 90, 100), labels = c(50, 70, 90, 100)) % axis(4, at = c(50, 70, 90, 100), labels = c(50, 70, 90, 100)) % axis(3, at = -4:4*25, labels=c(4:0*25, 1:4*25)) % mtext(c("hue = 0", "hue = 260"), side = 3, at = c(-50, 50), line = 3, cex = 1.2) % mtext("chroma", side = 3, at = 0, line = 2) % mtext("luminance", side = 2, at = 75, line = 2) % mtext("luminance", side = 4, at = 75, line = 2) % lines(c(-100, 100), c(50, 50)) % ## significant colors % rect(-100, 47.5, -90, 52.5, col = hcl(0, 100, 50)) % rect(-55, 67.5, -45, 72.5, col = hcl(0, 50, 70)) % rect(-5, 95, 5, 100, col = hcl(260, 0, 100)) ## grey vs. white % rect(-5, 87.5, 5, 92.5, col = hcl(260, 0, 90)) ## grey vs. white % rect(45, 67.5, 55, 72.5, col = hcl(260, 50, 70)) % rect(90, 47.5, 100, 52.5, col = hcl(260, 100, 50)) % text(-100, 33, "significant", pos = 4, cex = 1.2) % rect(-100, 20, -80, 30, col = hcl(0, 100, 50)) % rect(-60, 20, -40, 30, col = hcl(0, 50, 70)) % rect(-20, 20, 0, 30, col = hcl(0, 0, 90)) % rect(0, 20, 20, 30, col = hcl(260, 0, 90)) % #white# rect(-20, 20, 0, 30, col = hcl(0, 0, 100)) % #white# rect(0, 20, 20, 30, col = hcl(260, 0, 100)) % rect(40, 20, 60, 30, col = hcl(260, 50, 70)) % rect(80, 20, 100, 30, col = hcl(260, 100, 50)) % lines(c(-45, -5), c(72.5, 87.5), lty = 2) % lines(c(45, 5), c(72.5, 87.5), lty = 2) % lines(c(-95, -55), c(52.5, 67.5), lty = 2) % lines(c(95, 55), c(52.5, 67.5), lty = 2) % ## non-significant colors % rect(-25, 47.5, -15, 52.5, col = hcl(0, 20, 50)) % rect(-15, 67.5, -5, 72.5, col = hcl(0, 10, 70)) % rect(5, 67.5, 15, 72.5, col = hcl(260, 10, 70)) % rect(25, 47.5, 15, 52.5, col = hcl(260, 20, 50)) % text(-100, 13, "non-significant", pos = 4, cex = 1.2) % rect(-60, 0, -40, 10, col = hcl(0, 20, 50)) % rect(-40, 0, -20, 10, col = hcl(0, 10, 70)) % rect(-20, 0, 0, 10, col = hcl(0, 0, 90)) % rect(0, 0, 20, 10, col = hcl(260, 0, 90)) % rect(20, 0, 40, 10, col = hcl(260, 10, 70)) % rect(40, 0, 60, 10, col = hcl(260, 20, 50)) % lines(c(-18.75, -11.25), c(52.5, 67.5), lty = 2) % lines(c(-8.75, -1.25), c(72.5, 87.5), lty = 2) % lines(c(18.75, 11.75), c(52.5, 67.5), lty = 2) % lines(c(8.75, 1.25), c(72.5, 87.5), lty = 2) % @ % \caption{Residual-based shadings in HSV (upper) and HCL space (lower).} % \label{fig:shadingHSVHCL} % \end{center} % \end{figure} A more ``advanced'' function building upon \codefun{shading\_hcl} is \codefun{shading\_max}, using the maximum statistic both to conduct the independence test and to visualize significant \emph{cells} causing the rejection of the independence hypothesis \citep{vcd:Meyer+Zeileis+Hornik:2003,vcd:Zeileis+Meyer+Hornik:2007}. The \code{level} argument of \codefun{shading\_max} then can be used to specify several confidence levels from which the corresponding cut-off points are computed. By default, two cut-off points are computed corresponding to confidence levels of $90\%$ and $99\%$, respectively. In the following example, we investigate the effect of a new treatment for rheumatoid arthritis on a group of female patients using the maximum shading (see Figure~\ref{fig:maximum}): <>= set.seed(4711) mosaic(~ Treatment + Improved, data = Arthritis, subset = Sex == "Female", gp = shading_max) @ \begin{figure}[h] \begin{center} <>= <> @ \caption{The \data{Arthritis} data (female patients) with significant maximum test.} \label{fig:maximum} \end{center} \end{figure} \noindent The maximum test is significant although the residuals are all in the $\left[-2,2\right]$ interval. The \codefun{shading\_hcl} function with default cut-off points would not have shown any color. In addition, since the test statistic is the maximum of the absolute Pearson residuals, \emph{each} colored residual violates the null hypotheses of independence, and thus, the ``culprits'' can immediately be identified. \clearpage \section[Labeling]{Labeling} \label{sec:labeling} One of the major enhancements in package \pkg{vcd} compared to \codefun{mosaicplot} and \codefun{assocplot} in base \proglang{R} is the labeling in the strucplot framework which offers more features and greater flexibility. Like shading, spacing, and drawing of legend and core plot, labeling is now carried out by grapcon functions, rendering labeling completely modular. The user supplies either a labeling function, or, alternatively, a generating function that parameterizes a labeling function, to \codefun{strucplot} which then draws the labels. Labeling is well-separated from the actual plotting that occurs in the low-level core functions. It only relies on the viewport tree produced by them, and the \code{dimnames} attribute of the visualized table. Labeling functions are grapcons that ``add ink to the canvas'': the drawing of the labels happens after the actual plot has been drawn by the core function. Thus, it is possible to supply one's own labeling function, or to combine some of the basic functions to produce a more complex labeling. In the following, we describe the three basic modules (\codefun{labeling\_text}, \codefun{labeling\_list}, and \codefun{labeling\_cells}) and derived functions that build upon them. \subsection[Labels in the borders]{Labels in the borders: \texttt{labeling\_text()}} \codefun{labeling\_text} is the default for all strucplot displays. It plots labels in the borders similar to the \codefun{mosaicplot} function in base \proglang{R}, but is much more flexible: it is not limited to 4 dimensions, and the positioning and graphical parameters of levels and variable names are customizable. In addition, the problem of overlapping labels can be handled in several ways. As an example, again consider the \data{Titanic} data: by default, the variable names and levels are plotted ``around'' the plot in a counter-clockwise way (see Figure~\ref{fig:labels1}, top left): <>= mosaic(Titanic) @ % \begin{figure}[p] % \begin{center} % <>= % <> % @ % \caption{Mosaic plot for the \data{Titanic} data with default settings % for labeling.} % \label{fig:defaults} % \end{center} % \end{figure} \noindent Note that the last two levels of the \code{survived} variable do overlap, as well as some adult and child labels of the \code{age} Variable. This issue can be addressed in several ways. The ``brute force'' method is to enable clipping for these dimensions (see Figure~\ref{fig:labels1}, top right): <>= mosaic(Titanic, labeling_args = list(clip = c(Survived = TRUE, Age = TRUE))) @ % \begin{figure}[p] % \begin{center} % <>= % <> % @ % \caption{The effect of clipping.} % \label{fig:clipping} % \end{center} % \end{figure} \noindent The \code{clip} parameter is passed to the labeling function via the \code{labeling\_args} argument which takes a list of parameters. \code{clip} itself takes a vector of logicals (one for each dimension). % as mentioned before Almost all vectorized arguments in the strucplot framework can be abbreviated in the following way: unnamed components (or the defaults, if there are none) are recycled as needed, but overridden by the named components. Here, the default is \code{FALSE}, and therefore clipping is enabled only for the \code{survived} and \code{age} variables. A more sensible solution to the overlap problem is to abbreviate the levels (see Figure~\ref{fig:labels1}, middle left): <>= mosaic(Titanic, labeling_args = list(abbreviate_labs = c(Survived = TRUE, Age = 3))) @ % \begin{figure}[h] % \begin{center} % <>= % <> % @ % \caption{Abbreviating.} % \label{fig:abbreviating} % \end{center} % \end{figure} \noindent The \code{abbreviate} argument takes a vector of integers indicating the number of significant characters the levels should be abbreviated to (\code{TRUE} is interpreted as 1, obviously). Abbreviation is performed using the \codefun{abbreviate} function in base \proglang{R}. Another possibility is to rotate the levels (see Figure~\ref{fig:labels1}, bottom): <>= mosaic(Titanic, labeling_args = list(rot_labels = c(bottom = 90, right = 0), offset_varnames = c(right = 1), offset_labels = c(right = 0.3)), margins = c(right = 4, bottom = 3)) @ % \begin{figure}[p] % \begin{center} % <>= % <> % @ % \caption{Rotating labels.} % \label{fig:rotating} % \end{center} % \end{figure} \noindent Finally, we could also inhibit the output of repeated levels (see Figure~\ref{fig:labels1}, middle right): <>= mosaic(Titanic, labeling_args = list(rep = c(Survived = FALSE, Age = FALSE))) @ \setkeys{Gin}{width=0.9\textwidth} \begin{figure}[p] \begin{center} <>= pushViewport(viewport(layout = grid.layout(ncol = 2,nrow=3))) pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 1)) mosaic(Titanic, newpage = FALSE, keep = TRUE, margin = c(right = 3), gp_labels = gpar(fontsize = 10)) popViewport() pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 1)) mosaic(Titanic, labeling_args = list(clip = c(Survived = TRUE, Age = TRUE)), newpage = FALSE, keep = TRUE, margin = c(left = 3), gp_labels = gpar(fontsize = 10)) popViewport() pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 2)) mosaic(Titanic, labeling_args = list(abbreviate_labs = c(Survived = TRUE, Age = 2)), newpage = FALSE, keep = TRUE, margin = c(right = 3), gp_labels = gpar(fontsize = 10)) popViewport() pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 2)) mosaic(Titanic, labeling_args = list(rep = c(Survived = FALSE, Age = FALSE)), newpage = FALSE, keep = TRUE, margin = c(left = 3), gp_labels = gpar(fontsize = 10)) popViewport() pushViewport(viewport(layout.pos.col = 1:2, layout.pos.row = 3)) pushViewport(viewport(width = 0.55)) mosaic(Titanic, labeling_args = list(rot_labels = c(bottom = 90, right = 0), offset_varnames = c(right = 1), offset_labels = c(right = 0.3)), margins = c(right = 4, bottom = 3), newpage = FALSE, keep = FALSE, gp_labels = gpar(fontsize = 10)) popViewport(3) @ \caption{Examples for possible labeling strategies for the Titanic data mosaic. Top left: default labeling (many labels overlap). Top right: with clipping turned on. Middle left: \texttt{Age} and \texttt{Survived} labels abbreviated. Middle right: \texttt{Age} labels not repeated. Bottom: \texttt{Age} and \texttt{Survived} labels rotated.} \label{fig:labels1} \end{center} \end{figure} \setkeys{Gin}{width=0.7\textwidth} We now proceed with a few more ``cosmetic'' features (which do not all produce satisfactory results for our sample data). A first simple, but effectful modification is to position all labels and variables left-aligned (see Figure~\ref{fig:labels2}, top left): <>= mosaic(Titanic, labeling_args = list(pos_varnames = "left", pos_labels = "left", just_labels = "left", rep = FALSE)) @ % \begin{figure}[h] % \begin{center} % <>= % <> % @ % \caption{Left-aligning.} % \label{fig:left} % \end{center} % \end{figure} \noindent Note that obviously we need to change the justification to \code{"left"} as well. We can achieve the same effect by using the convenience function \codefun{labeling\_left}: <>= mosaic(Titanic, labeling = labeling_left) @ \noindent Next, we show how to put all levels to the bottom and right margins, and all variable names to the top and left margins (see Figure~\ref{fig:labels2}, top right): <>= mosaic(Titanic, labeling_args = list(tl_labels = FALSE, tl_varnames = TRUE, abbreviate_labs = c(Survived = 1, Age = 3))) @ % \begin{figure}[p] % \begin{center} % <>= % <> % @ % \caption{Changes in the margins.} % \label{fig:margins} % \end{center} % \end{figure} \noindent The tl\_\var{foo} (``top left'') arguments are \code{TRUE} by default. Now, we will add boxes to the labels and additionally enable clipping (see Figure~\ref{fig:labels2}, bottom left): <>= mosaic(Titanic, labeling_args = list(tl_labels = FALSE, tl_varnames = TRUE, boxes = TRUE, clip = TRUE)) @ % \begin{figure}[p] % \begin{center} % <>= % <> % @ % \caption{Boxes and Clipping.} % \label{fig:boxes} % \end{center} % \end{figure} \noindent The values to \code{boxes} and \code{clip} are recycled for all dimensions. The result is pretty close to what calling \codefun{mosaic} with the \codefun{labeling\_cboxed} wrapper does, except that variables and levels, by default, are put to the top and to the left of the plot: <>= mosaic(Titanic, labeling = labeling_cboxed) @ \noindent Another variant is to put the variable names into the same line as the levels (see Figure~\ref{fig:labels2}, bottom right---clipping for \code{Survived} and \code{Age} is, additionally, disabled, and \code{Age} abbreviated): <>= mosaic(Titanic, labeling_args = list(tl_labels = TRUE, boxes = TRUE, clip = c(Survived = FALSE, Age = FALSE, TRUE), abbreviate_labs = c(Age = 4), labbl_varnames = TRUE), margins = c(left = 4, right = 1, 3)) @ % \begin{figure}[h] % \begin{center} % <>= % <> % @ % \caption{Variable names beneath levels, and clipping disabled for the % survival variable.} % \label{fig:labbl} % \end{center} % \end{figure} \noindent \code{labbl\_varnames} (``variable names to the bottom/left of the labels'') is a vector of logicals indicating the side for the variable names. The resulting layout is close to what \codefun{labeling\_lboxed} produces, except that variables and levels, by default, are left-aligned and put to the bottom and to the right of the plot: <>= mosaic(Titanic, labeling = labeling_lboxed, margins = c(right = 4, left = 1, 3)) @ \noindent A similar design is used by the \codefun{doubledecker} function. \setkeys{Gin}{width=\textwidth} \begin{figure}[p] \begin{center} <>= pushViewport(viewport(layout = grid.layout(ncol = 2, nrow = 2))) pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 1)) mosaic(Titanic, labeling_args = list(pos_varnames = "left", pos_labels = "left", just_labels = "left", rep = FALSE), newpage = FALSE, keep = TRUE, gp_labels = gpar(fontsize = 12)) popViewport() pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 1)) mosaic(Titanic, labeling_args = list(tl_labels = FALSE, tl_varnames = TRUE, abbreviate_labs = c(Survived = 1, Age = 3)), newpage = FALSE, keep = TRUE, margins = c(left = 4, right = 1, 3), gp_labels = gpar(fontsize = 12)) popViewport() pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 2)) mosaic(Titanic, labeling_args = list(tl_labels = FALSE, tl_varnames = TRUE, boxes = TRUE, clip = TRUE), newpage = FALSE, keep = TRUE, gp_labels = gpar(fontsize = 12)) popViewport() pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 2)) mosaic(Titanic, labeling_args = list(tl_labels = TRUE, boxes = TRUE, clip = c(Survived = FALSE, Age = FALSE, TRUE), labbl_varnames = TRUE, abbreviate_labs = c(Age = 4)), margins = c(left = 4, right = 1, 3), newpage = FALSE, keep = TRUE, gp_labels = gpar(fontsize = 12)) popViewport(2) @ \caption{Advanced strategies for labeling of the Titanic data. Top left: left aligning of both variable names and labels. Top right: changes in the margins (all variable names are in the top and left margins, and all labels in the bottom and right margins). Bottom left: clipping turned on, and boxes used. Bottom right: variable names beneath levels, clipping disabled for the survival and age variables, and \texttt{Age} abbreviated.} \label{fig:labels2} \end{center} \end{figure} \setkeys{Gin}{width=0.7\textwidth} \subsection[Labels in the cells]{Labels in the cells: \texttt{labeling\_cells()}} This labeling draws both variable names and levels in the cells. As an example, we use the \data{PreSex} data on pre- and extramarital sex and divorce (see Figure~\ref{fig:labels3}, top left): <>= mosaic(~ MaritalStatus + Gender, data = PreSex, labeling = labeling_cells) @ % \begin{figure}[h] % \begin{center} % <>= % <> % @ % \caption{Cell labeling for the \data{PreSex} data.} % \label{fig:cell} % \end{center} % \end{figure} \noindent In the case of narrow cells, it might be useful to abbreviate labels and/or variable names and turn off clipping (see Figure~\ref{fig:labels3}, top right): <>= mosaic(~ PremaritalSex + ExtramaritalSex, data = PreSex, labeling = labeling_cells(abbreviate_labels = TRUE, abbreviate_varnames = TRUE, clip = FALSE)) @ % \begin{figure}[h] % \begin{center} % <>= % <> % @ % \caption{Cell labeling for the \data{PreSex} data, labels abbreviated.} % \label{fig:cell2} % \end{center} % \end{figure} \noindent For some data, it might be convenient to combine cell labeling with border labeling as done by \codefun{labels\_conditional} (see Figure~\ref{fig:labels3}, bottom left): <>= mosaic(~ PremaritalSex + ExtramaritalSex | MaritalStatus + Gender, data = PreSex, labeling = labeling_conditional(abbreviate_varnames = TRUE, abbreviate_labels = TRUE, clip = FALSE, gp_text = gpar(col = "red"))) @ % \begin{figure}[h] % \begin{center} % <>= % <> % @ % \caption{Conditional labeling for the \data{PreSex} data, labels (in % red for clarity) abbreviated.} % \label{fig:conditional} % \end{center} % \end{figure} \noindent Additionally, the cell labeling allows the user to add arbitrary text to the cells by supplying a character array in the same shape as the data array to the \code{text} argument (cells with missing values are ignored). In the following example using the \code{Titanic} data, this is used to add all observed values greater than 5 to the cells after the mosaic has been plotted (see Figure~\ref{fig:labels3}, bottom right): <>= mosaic(Titanic, labeling_args = list(abbreviate_labs = c(Survived = 1, Age = 4)), pop = FALSE) tab <- ifelse(Titanic < 6, NA, Titanic) labeling_cells(text = tab, clip = FALSE)(Titanic) @ % \begin{figure}[h] % \begin{center} % <>= % <> % @ % \caption{User-supplied text (observed frequencies exceeding 5) % added to a mosaic display of the \data{Titanic} data.} % \label{fig:text} % \end{center} % \end{figure} \setkeys{Gin}{width=\textwidth} \begin{figure}[p] \begin{center} <>= grid.newpage() pushViewport(viewport(layout = grid.layout(ncol = 2, nrow = 2))) pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 1)) mosaic(~ MaritalStatus + Gender, data = PreSex, labeling = labeling_cells, newpage = FALSE, keep = TRUE, gp_labels = gpar(fontsize = 10)) popViewport() pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 1)) mosaic(~ PremaritalSex + ExtramaritalSex, data = PreSex, labeling = labeling_cells(abbreviate_labels = TRUE, abbreviate_varnames = TRUE, clip = FALSE), newpage = FALSE, keep = TRUE, gp_labels = gpar(fontsize = 10)) popViewport() pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 2)) mosaic(~ PremaritalSex + ExtramaritalSex | MaritalStatus + Gender, data = PreSex, labeling = labeling_conditional(abbreviate_varnames = TRUE, abbreviate_labels = TRUE, clip = FALSE, gp_text = gpar(col = "red")), newpage = FALSE, keep = TRUE, gp_labels = gpar(fontsize = 10)) popViewport() pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 2)) mosaic(Titanic, labeling_args = list(abbreviate_labs = c(Survived = 1, Age = 3)), pop = FALSE, newpage = FALSE, keep = TRUE, gp_labels = gpar(fontsize = 10)) tab <- ifelse(Titanic < 6, NA, Titanic) labeling_cells(text = tab, clip = FALSE)(Titanic) @ \caption{Cell labeling. Top left: default labeling using the \data{PreSex} data. Top right: abbreviated labels. Bottom left: conditional labeling (labels abbreviated and in red for clarity). Bottom right: user-supplied text (observed frequencies exceeding 5) added to a mosaic display of the \data{Titanic} data. Note that clipping is on by default (top left), and has explicitly been turned off for the three other plots.} \label{fig:labels3} \end{center} \end{figure} \setkeys{Gin}{width=0.7\textwidth} \subsection[A simple list of labels]{A simple list of labels: \texttt{labeling\_list()}} If problems with overlapping labels cannot satisfactorily resolved, the last remedy could be to simply list the levels below the plot (see Figure~\ref{fig:list}): <>= mosaic(Titanic, labeling = labeling_list, margins = c(bottom = 5)) @ \setkeys{Gin}{width=0.7\textwidth} \begin{figure}[p] \begin{center} <>= mosaic(Titanic, labeling = labeling_list, margins = c(bottom = 5), keep = TRUE) @ \caption{Labels indicated below the plot.} \label{fig:list} \end{center} \end{figure} \noindent The number of columns can be specified. \section{Spacing} \label{sec:spacing} Spacing of strucplot displays is customizable in a similar way than shading. The \code{spacing} argument of the \codefun{strucplot} function takes a list of \class{unit} vectors, one for each dimension, specifying the space between the tiles corresponding to the levels. Consider again the introductory example of the \data{Arthritis} data (Figure~\ref{fig:arthritis}). Since we are interested in the effect of the medicament in the placebo and treatment groups, a mosaic plot is certainly appropriate to visualize the three levels of \code{Improved} in the two \code{Treatment} strata. Another conceptual approach is to use spine plots with highlighting \citep{vcd:hummel:1996}. A spine plot is a variation of a bar plot where the heights of the bars are held constant, whereas the widths are used to represent the number of cases in each category. This is equivalent to a mosaic plot for a one-way table. If a second (indicator) variable is highlighted in a spine plot, we obtain a display equivalent to a simple mosaic display for a two-way table, except that no space between the levels of the highlighted variable is used. In the \data{Arthritis} example, we will highlight patients with \code{Marked} improvement in both groups. To obtain such a display within the strucplot framework, it suffices to set the space between the \code{Improved} tiles to 0 (see Figure~\ref{fig:artspine}): <>= (art <- structable(~Treatment + Improved, data = Arthritis, split_vertical = TRUE)) (my_spacing <- list(unit(0.5, "lines"), unit(c(0, 0), "lines"))) my_colors <- c("lightgray", "lightgray", "black") mosaic(art, spacing = my_spacing, gp = gpar(fill = my_colors, col = my_colors)) @ \begin{figure}[p] \begin{center} <>= <> @ \caption{Spine plot for the \data{Arthritis} data using the strucplot framework.} \label{fig:artspine} \end{center} \end{figure} \noindent Note that the default and formula methods for \codefun{mosaic} provide a convenience interface for highlighting. A similar plot (with slightly different shading) than the previous one can be obtained using: <>= mosaic(Improved ~ Treatment, data = Arthritis, split_vertical = TRUE) @ \noindent The strucplot framework also provides a set of spacing grapcon generators which compute suitable spacing objects for typical applications. The simplest spacing is \codefun{spacing\_equal} that uses the same space between all tiles (see Figure~\ref{fig:spacing}, top left): <>= mosaic(art, spacing = spacing_equal(unit(2, "lines"))) @ \noindent \codefun{spacing\_equal} is the default grapcon generator for two-dimensional tables. Slightly more flexible is \codefun{spacing\_dimequal} that allows an individual setting for each dimension (see Figure~\ref{fig:spacing}, top right): <>= mosaic(art, spacing = spacing_dimequal(unit(1:2, "lines"))) @ \noindent The default for multi-way contingency tables is \codefun{spacing\_increase} which uses increasing spaces for the dimensions. The user can specify a start value and the increase factor (see Figure~\ref{fig:spacing}, bottom left): <>= mosaic(art, spacing = spacing_increase(start = unit(0.5, "lines"), rate = 1.5)) @ \noindent For the arthritis example above, we could as well have used \codefun{spacing\_highlighting} which is similar to \codefun{spacing\_increase} but sets the spacing in the last splitting dimension to 0 (see Figure~\ref{fig:spacing}, bottom right): <>= mosaic(art, spacing = spacing_highlighting, gp = my_colors) @ \noindent Finally, \codefun{spacing\_conditional} can be used for visualizing conditional independence: it combines \codefun{spacing\_equal} (for the conditioned dimensions) and \codefun{spacing\_increase} (for the conditioning dimensions). As an example, consider Figure~\ref{fig:presex}: the spacing clearly allows to better distinguish the conditioning variables (\code{Gender} and \code{MaritalStatus}) from the conditioned variables (\code{PremaritalSex} and \code{ExtramaritalSex}). This spacing is the default when conditional variables are specified for a strucplot display (see Section \ref{sec:strucplot}). \setkeys{Gin}{width=\textwidth} \begin{figure}[p] \begin{center} <>= pushViewport(viewport(layout = grid.layout(ncol = 2, nrow = 2))) pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 1)) mosaic(art, spacing = spacing_equal(unit(2, "lines")), keep = TRUE, newpage = FALSE) popViewport() pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 1)) mosaic(art, spacing = spacing_dimequal(unit(c(0.5, 2), "lines")), keep = TRUE, newpage = FALSE) popViewport() pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 2)) mosaic(art, spacing = spacing_increase(start = unit(0.3, "lines"), rate = 2.5), keep = TRUE, newpage = FALSE) popViewport() pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 2)) mosaic(art, spacing = spacing_highlighting, keep = TRUE, newpage = FALSE) popViewport(2) @ \caption{Varying spacing for the Arthritis data. Top left: equal spacing for all dimensions. Top right: different spacings for individial dimensions. Bottom left: increasing spacing. Bottom right: spacing used for highlighting.} \label{fig:spacing} \end{center} \end{figure} \setkeys{Gin}{width=0.7\textwidth} \section{Example: Ovarian cancer survival} \label{sec:example} In the following, we demonstrate some of the described techniques in analyzing a data set originating from \citep{vcd:obel:1975} \cite[taken from][]{vcd:andersen:1991} about a retrospective study of ovary cancer carried out in 1973. Information was obtained from 299 women, who were operated for ovary cancer 10 years before. The data consists of four binary variables: the \code{stage} of the cancer at the time of operation (levels: \code{early}, \code{advanced}), the type of \code{operation} performed (\code{radical}, \code{limited}), the \code{survival} status after 10 years (\code{yes}, \code{no}), and \code{xray} indicating whether X-ray treatment was received (\code{yes}, \code{no}). The dataset in \pkg{vcd} comes pretabulated in a data frame, so we first create the four-way table: <>= tab <- xtabs(Freq ~ stage + operation + xray + survival, data = OvaryCancer) @ \noindent A ``flattened'' textual representation can be obtained using \codefun{structable}: <>= structable(survival ~ ., data = tab) @ \noindent A first overview can be obtained using a pairs plot (Figure~\ref{fig:ocpairs}): <>= dpa <- list(var_offset = 1.2, rot = -30, just_leveltext= "left") pairs(tab, diag_panel = pairs_barplot, diag_panel_args = dpa) @ \begin{figure}[h] \begin{center} <>= <> @ \caption{Pairs plot for the \data{OvaryCancer} data showing mosaic displays for all pairwise distributions and bar plots for all marginal distributions.} \label{fig:ocpairs} \end{center} \end{figure} \noindent The pairs plot, by default, creates mosaic displays for all pairwise variable combinations, and bar plots in the diagonal to visualize the absolute frequencies of the variables. The \texttt{var\_offset} argument modifies the offset of the (centered) variable names to avoid overlap with the bars. Additionally, we use the \texttt{rot} and the \texttt{just\_leveltext} arguments to rotate the level names, again to avoid their overlap. First, we consider the marginal distributions. The study design involved (nearly) the same number of survived (150) and deceased (149) patients. Similarly balanced, 158 cases were in an advanced and 141 in an early stage. Most patients (251, 84\%) were treated with a radical operation, and 186 (62\%) were submitted to X-ray treatment. Next, we inspect the two-way interaction of the influencing factors (\code{stage}, \code{operation}, and \code{xray}): the corresponding mosaics exhibit symmetric, regular shapes with aligned tiles, which indicate no marginal interaction between these variables. The same is true for the interactions of \code{survival} with \code{operation} and \code{xray}, respectively. Only the stage seems to influence survival: here, the tiles are ``shifted''. A different view on the data, focused on the influence of the explanatory variables on \code{Survival}, can be obtained using a doubledecker plot (Figure~\ref{fig:ocdoubledecker}): <>= doubledecker(survival ~ stage + operation + xray, data = tab) @ \begin{figure}[h] \begin{center} <>= <> @ \caption{Doubledecker plot for the \data{OvaryCancer} data showing the conditional distribution of X-ray, given operation, given stage, and with survival highlighted.} \label{fig:ocdoubledecker} \end{center} \end{figure} \noindent From a technical point of view, the display is constructed as a mosaic plot showing the conditional distribution of \code{survival}, given \code{xray}, given \code{operation}, given \code{stage}, with vertical splits for the conditioning variables and horizontal ones for \code{survival}. Additionally, there is zero space between the tiles of the last dimension and a binary shading is used for survived and deceased patients. Conceptually, this plot is interpreted as a mosaic plot of just the influencing variables, with \code{survival} highlighted in the tiles. Thus, the plot really shows the influence of the explanatory variables on \code{survival}. Clearly, the survival rate is higher among patients in an early stage, but neither radical operation nor X-ray treatment seem to improve the situation. From this exploratory phase, the survival rate seems to be slightly higher for patients who received a limited operation only, whereas the effect for X-ray treatment is less marked. To visualize inference results, we can make use of residual-based shadings, investigating log-linear models for the four-way table. Figure~\ref{fig:ocmosaicnull} visualizes the null model, where survival is independent from the combined effect of operation, X-ray treatment, and stage: <>= split <- c(TRUE, TRUE, TRUE, FALSE) mosaic(tab, expected = ~ survival + operation * xray * stage, split_vertical = split) @ \begin{figure}[p] \begin{center} <>= <> @ \caption{Mosaic plot for the \data{OvaryCancer} data, with residual-based shading for the (clearly rejected) null model (survival)(operation, X-ray, stage).} \label{fig:ocmosaicnull} \end{center} \end{figure} \noindent The model is clearly rejected ($p$-value: 0.000). From the exploratory phase of our analysis, we (only) suspect \code{stage} to be influential on the survival rate. A corresponding hypothesis is that \code{survival} be independent of \code{xray} and \code{operation}, given \code{stage}. The model is specified using the \texttt{expected} argument, either using the \codefun{loglin} interface or the \codefun{loglm} formula interface (the resulting mosaic plot is shown in Figure \ref{fig:ocmosaicstage}): <>= mosaic(tab, expected = ~ (survival + operation * xray) * stage, split_vertical = split) @ \begin{figure}[p] \begin{center} <>= <> @ \caption{Mosaic plot for the \data{OvaryCancer} data, with residual-based shading for the hypothesis of survival being independent of X-ray and operation, given stage. The hypothesis is not rejected.} \label{fig:ocmosaicstage} \end{center} \end{figure} \noindent Thus, based on this data, only pre-diagnosis seems to matter in ovarian cancer therapy. \section{Conclusion} \label{sec:conclusion} In this paper, we describe the ``strucplot'' framework for the visualization of multi-way contingency tables. Strucplot displays include popular basic plots such as mosaic, association, and sieve plots, integrated in a unified framework: all can be seen as visualizations of hierarchical conditional flat tables. Additionally, these core strucplot displays can be combined into more complex, specialized plots, such as pairs and trellis-like displays for visualizing conditional independence. Residual-based shadings permit the visualization of log-linear models and the results of independence tests. The framework's modular design allows flexible customization of the plots' graphical appearance, including shading, labeling, spacing, and legend, by means of graphical appearance control (``grapcon'') functions. These ``graphical hyperparameters'' are customized and created by generating functions. Our work includes a set of predefined grapcon generators for typical analysis tasks, and user-level extensions can easily be added. \bibliography{vcd} \begin{appendix} \section{Data sets} \label{sex:data} The data set names in the paper are those from the \proglang{R} system. In the following, we give a short description of each data set. \begin{description} \item[\texttt{Arthritis}] Data from a double-blind clinical trial investigating a new treatment for rheumatoid arthritis. Source: \cite{vcd:Koch+Edwards:1988}. Taken from: \cite{vcd:Friendly:2000}. Package: \pkg{vcd}. \item[\texttt{Bundesliga}] Results from the first German soccer league in the years 1995/6 \citep{vcd:Knorr-Held:1999} and 2001/2 (Collected by: Achim Zeileis). Package: \pkg{vcd}. \item[\texttt{HairEyeColor}] Distribution of hair and eye color and gender in 592 statistics students. The gender information is artificial. Source: \cite{vcd:Snee:1974}. Taken from: \cite{vcd:Friendly:2000}. Package: \pkg{datasets} (included in base \proglang{R}). \item[\texttt{OvaryCancer}] Data about a retrospective study of ovary cancer carried out in 1973. Information was obtained from 299 women, who were operated for ovary cancer 10 years before. Source: \cite{vcd:obel:1975}. Taken fromn: \cite{vcd:andersen:1991}. Package: \pkg{vcd}. \item[\texttt{PreSex}] Data on pre- and extra-marital sex and divorce. Source: \cite{vcd:thornes+collard:1979}. Taken from \cite{vcd:gilbert:1981}. Package: \pkg{vcd}. \item[\texttt{Titanic}] Information on the fate of passengers on the fatal maiden voyage of the ocean liner ``Titanic'', summarized according to economic status (class), gender (\code{Sex}), age and survival. Data originally collected by the British Board of Trade in their investigation of the sinking. Taken from: \cite{vcd:dawson:1995}. Package: \pkg{datasets} (included in base \proglang{R}). \item[\texttt{UCBAdmissions}] Aggregate data on applicants to graduate school at Berkeley for the six largest departments in 1973 classified by admission and gender. Source: \cite{vcd:Bickel+Hammel+O'Connell:1975}. Taken from: \cite{vcd:Friendly:2000}. Package: \pkg{datasets} (included in base \proglang{R}). \end{description} \end{appendix} \end{document} vcd/vignettes/vcd.bib0000755000175100001440000006163014133456605014326 0ustar hornikusers%% general graphics & original methods @Article{vcd:Cohen:1980, author = {A. Cohen}, title = {On the Graphical Display of the Significant Components in a Two-Way Contingency Table}, journal = {Communications in Statistics---Theory and Methods}, year = {1980}, volume = {A9}, pages = {1025--1041} } @InProceedings{vcd:Hartigan+Kleiner:1981, author = {J. A. Hartigan and B. Kleiner}, title = {Mosaics for Contingency Tables}, booktitle = {Computer Science and Statistics: Proceedings of the 13th Symposium on the Interface}, pages = {268--273}, year = {1981}, editor = {W. F. Eddy}, address = {New York}, publisher = {Springer-Verlag} } @Article{vcd:Hartigan+Kleiner:1984, author = {J. A. Hartigan and B. Kleiner}, title = {A Mosaic of Television Ratings}, journal = {The American Statistician}, year = {1984}, volume = {38}, pages = {32--35} } @TechReport{vcd:Young:1996, author = {Forrest W. Young}, title = {{\pkg{ViSta}}: The Visual Statistics System}, institution = {UNC L.~L.~Thurstone Psychometric Laboratory Research Memorandum}, year = 1996, number = {94--1(c)} } @Book{vcd:Cleveland:1993, author = {William S. Cleveland}, title = {Visualizing Data}, publisher = {Hobart Press}, year = 1993, address = {Summit, New Jersey} } @Article{vcd:Becker+Cleveland+Shyu:1996, author = {Richard A. Becker and William S. Cleveland and Ming-Jen Shyu}, title = {The Visual Design and Control of Trellis Display}, journal = {Journal of Computational and Graphical Statistics}, year = {1996}, volume = {5}, pages = {123--155} } @InProceedings{vcd:Riedwyl+Schuepbach:1994, author = {H. Riedwyl and M. Sch{\"u}pbach}, title = {Parquet Diagram to Plot Contingency Tables}, booktitle = {Softstat '93: Advances in Statistical Software}, pages = {293--299}, year = 1994, editor = {F. Faulbaum}, address = {New York}, publisher = {Gustav Fischer} } %% color @InProceedings{vcd:Ihaka:2003, author = {Ross Ihaka}, title = {Colour for Presentation Graphics}, booktitle = {Proceedings of the 3rd International Workshop on Distributed Statistical Computing, Vienna, Austria}, editor = {Kurt Hornik and Friedrich Leisch and Achim Zeileis}, year = {2003}, url = {http://www.ci.tuwien.ac.at/Conferences/DSC-2003/Proceedings/}, note = {{ISSN 1609-395X}}, } @Article{vcd:Lumley:2006, author = {Thomas Lumley}, title = {Color Coding and Color Blindness in Statistical Graphics}, journal = {ASA Statistical Computing \& Graphics Newsletter}, year = {2006}, volume = {17}, number = {2}, pages = {4--7} } @Book{vcd:Munsell:1905, author = {Albert H. Munsell}, title = {A Color Notation}, publisher = {Munsell Color Company}, year = {1905}, address = {Boston, Massachusetts} } @Article{vcd:Harrower+Brewer:2003, author = {Mark A. Harrower and Cynthia A. Brewer}, title = {\pkg{ColorBrewer.org}: An Online Tool for Selecting Color Schemes for Maps}, journal = {The Cartographic Journal}, year = {2003}, volume = {40}, pages = {27--37} } @InProceedings{vcd:Brewer:1999, author = {Cynthia A. Brewer}, title = {Color Use Guidelines for Data Representation}, booktitle = {Proceedings of the Section on Statistical Graphics, American Statistical Association}, address = {Alexandria, VA}, year = {1999}, pages = {55--60} } @Article{vcd:Cleveland+McGill:1983, author = {William S. Cleveland and Robert McGill}, title = {A Color-caused Optical Illusion on a Statistical Graph}, journal = {The American Statistician}, year = {1983}, volume = {37}, pages = {101--105} } @Book{vcd:CIE:2004, author = {{Commission Internationale de l'\'Eclairage}}, title = {Colorimetry}, edition = {3rd}, publisher = {Publication CIE 15:2004}, address = {Vienna, Austria}, year = {2004}, note = {{ISBN} 3-901-90633-9} } @InProceedings{vcd:Moretti+Lyons:2002, author = {Giovanni Moretti and Paul Lyons}, title = {Tools for the Selection of Colour Palettes}, booktitle = {Proceedings of the New Zealand Symposium On Computer-Human Interaction (SIGCHI 2002)}, address = {University of Waikato, New Zealand}, month = {July}, year = {2002} } @Article{vcd:MacAdam:1942, author = {D. L. MacAdam}, title = {Visual Sensitivities to Color Differences in Daylight}, journal = {Journal of the Optical Society of America}, year = {1942}, volume = {32}, number = {5}, pages = {247--274}, } @Book{vcd:Wyszecki+Stiles:2000, author = {G\"unter Wyszecki and W. S. Stiles}, title = {Color Science}, edition = {2nd}, publisher = {Wiley}, year = {2000}, note = {{ISBN} 0-471-39918-3} } @Misc{vcd:Poynton:2000, author = {Charles Poynton}, title = {Frequently-Asked Questions About Color}, year = {2000}, howpublished = {URL \url{http://www.poynton.com/ColorFAQ.html}}, note = {Accessed 2006-09-14}, } @Misc{vcd:Wiki+HSV:2006, author = {Wikipedia}, title = {{HSV} Color Space --- {W}ikipedia{,} The Free Encyclopedia}, year = {2006}, howpublished = {URL \url{http://en.wikipedia.org/w/index.php?title=HSV_color_space&oldid=74735552}}, note = {Accessed 2006-09-14}, } @Misc{vcd:Wiki+LUV:2006, author = {Wikipedia}, title = {{Lab} Color Space --- {W}ikipedia{,} The Free Encyclopedia}, year = {2006}, howpublished = {URL \url{http://en.wikipedia.org/w/index.php?title=Lab_color_space&oldid=72611029}}, note = {Accessed 2006-09-14}, } @Article{vcd:Smith:1978, author = {Alvy Ray Smith}, title = {Color Gamut Transform Pairs}, journal = {Computer Graphics}, pages = {12--19}, year = {1978}, volume = {12}, number = {3}, note = {ACM SIGGRAPH 78 Conference Proceedings}, } %% url = {http://www.alvyray.com/}, @Article{vcd:Meier+Spalter+Karelitz:2004, author = {Barbara J. Meier and Anne Morgan Spalter and David B. Karelitz}, title = {Interactive Color Palette Tools}, journal = {{IEEE} Computer Graphics and Applications}, volume = {24}, number = {3}, year = {2004}, pages = {64--72}, } %% url = {http://graphics.cs.brown.edu/research/color/} @InCollection{vcd:Mollon:1995, author = {J. Mollon}, editor = {T. Lamb and J. Bourriau}, booktitle = {Colour: Art and Science}, title = {Seeing Color}, publisher = {Cambridge Univesity Press}, year = 1995 } %% Friendly publications @Article{vcd:Friendly:1994, author = {Michael Friendly}, title = {Mosaic Displays for Multi-Way Contingency Tables}, journal = {Journal of the American Statistical Association}, year = {1994}, volume = {89}, pages = {190--200} } @Article{vcd:Friendly:1999, author = {Michael Friendly}, title = {Extending Mosaic Displays: Marginal, Conditional, and Partial Views of Categorical Data}, journal = {Journal of Computational and Graphical Statistics}, year = {1999}, volume = {8}, number = {3}, pages = {373--395} } @Book{vcd:Friendly:2000, author = {Michael Friendly}, title = {Visualizing Categorical Data}, publisher = {\textsf{SAS} Insitute}, year = {2000}, address = {Carey, NC}, URL = {http://www.datavis.ca/books/vcd/} } %% Augsburg publications @Article{vcd:Theus+Lauer:1999, author = {Martin Theus and Stephan R. W. Lauer}, title = {Visualizing Loglinear Models}, journal = {Journal of Computational and Graphical Statistics}, year = 1999, volume = 8, number = 3, pages = {396--412} } @Article{vcd:Hofmann:2003, author = {Heike Hofmann}, title = {Constructing and Reading Mosaicplots}, journal = {Computational Statistics \& Data Analysis}, year = {2003}, volume = {43}, pages = {565--580} } @Article{vcd:Hofmann:2001, author = {Heike Hofmann}, title = {Generalized Odds Ratios for Visual Modelling}, journal = {Journal of Computational and Graphical Statistics}, year = {2001}, volume = {10}, pages = {1--13} } @Article{vcd:Theus:2003, author = {Martin Theus}, title = {Interactive Data Visualization Using \pkg{Mondrian}}, journal = {Journal of Statistical Software}, volume = 7, number = 11, pages = {1--9}, year = 2003, doi = {10.18637/jss.v007.i11}, } @Unpublished{vcd:Hofmann+Theus, author = {Heike Hofmann and Martin Theus}, title = {Interactive Graphics for Visualizing Conditional Distributions}, note = {Unpublished Manuscript}, year = {2005} } @Article{vcd:Hummel:1996, author = {J. Hummel}, title = {Linked Bar Charts: Analysing Categorical Data Graphically}, journal = {Computational Statistics}, year = 1996, volume = 11, pages = {23--33} } @Article{vcd:Unwin+Hawkins+Hofmann:1996, author = {Antony R. Unwin and G. Hawkins and Heike Hofmann and B. Siegl}, title = {Interactive Graphics for Data Sets with Missing Values -- \pkg{MANET}}, journal = {Journal of Computational and Graphical Statistics}, year = 1996, pages = {113--122}, volume = 4, number = 6 } @Manual{vcd:Urbanek+Wichtrey:2006, title = {\pkg{iplots}: Interactive Graphics for \textsf{R}}, author = {Simon Urbanek and Tobias Wichtrey}, year = {2006}, note = {\textsf{R} package version 1.0-3}, url = {http://www.rosuda.org/iPlots/} } %% Software @Manual{vcd:R:2006, title = {\textsf{R}: {A} Language and Environment for Statistical Computing}, author = {{\textsf{R} Development Core Team}}, organization = {\textsf{R} Foundation for Statistical Computing}, address = {Vienna, Austria}, year = {2006}, note = {{ISBN} 3-900051-00-3}, url = {http://www.R-project.org/} } @Article{vcd:Murrell:2002, author = {Paul Murrell}, title = {The \pkg{grid} Graphics Package}, journal = {\proglang{R} News}, year = 2002, volume = 2, number = 2, pages = {14--19}, month = {June}, url = {http://CRAN.R-project.org/doc/Rnews/} } @Book{vcd:Murrell:2006, author = {Paul Murrell}, title = {\textsf{R} Graphics}, publisher = {Chapmann \& Hall/CRC}, address = {Boca Raton, Florida}, year = {2006}, } @Book{vcd:Venables+Ripley:2002, author = {William N. Venables and Brian D. Ripley}, title = {Modern Applied Statistics with \textsf{S}}, edition = {4th}, publisher = {Springer-Verlag}, address = {New York}, year = {2002}, note = {{ISBN} 0-387-95457-0}, url = {http://www.stats.ox.ac.uk/pub/MASS4/} } @Manual{vcd:Ihaka:2006, title = {\pkg{colorspace}: Colorspace Manipulation}, author = {Ross Ihaka}, year = {2006}, note = {\textsf{R} package version 0.95} } @Manual{vcd:Meyer+Zeileis+Hornik:2006, title = {\pkg{vcd}: Visualizing Categorical Data}, author = {David Meyer and Achim Zeileis and Kurt Hornik}, year = {2006}, note = {\textsf{R} package version 1.0-6} } @article{vcd:Ligges+Maechler:2003, title = {\pkg{scatterplot3d} -- An {R} Package for Visualizing Multivariate Data}, author = {Uwe Ligges and Martin M{\"a}chler}, journal = {Journal of Statistical Software}, year = 2003, pages = {1--20}, number = 11, volume = 8, doi = {10.18637/jss.v008.i11} } @Manual{vcd:SAS:2005, title = {\proglang{SAS/STAT} Version 9}, author = {\proglang{SAS} Institute Inc.}, year = {2005}, address = {Cary, NC} } @Manual{vcd:SPLUS:2005, title = {\proglang{S-PLUS} 7}, author = {{Insightful Inc.}}, year = {2005}, address = {Seattle, WA} } %% data @Article{vcd:Azzalini+Bowman:1990, author = {A. Azzalini and A. W. Bowman}, title = {A Look at Some Data on the {O}ld {F}aithful Geyser}, journal = {Applied Statistics}, year = {1990}, volume = {39}, pages = {357--365}, } @Article{vcd:Obel:1975, author = {E.B. Obel}, title = {A Comparative Study of Patients with Cancer of the Ovary Who Have Survived More or Less Than 10 Years}, journal = {Acta Obstetricia et Gynecologica Scandinavica}, year = 1975, volume = 55, pages = {429--439} } @InCollection{vcd:Koch+Edwards:1988, author = {G. Koch and S. Edwards}, title = {Clinical Efficiency Trials with Categorical Data}, booktitle = {Biopharmaceutical Statistics for Drug Development}, editor = {K. E. Peace}, publisher = {Marcel Dekker}, address = {New York}, year = {1988}, pages = {403--451} } @TechReport{vcd:Knorr-Held:1999, author = {Leonhard Knorr-Held}, title = {Dynamic Rating of Sports Teams}, institution = {SFB 386 ``Statistical Analysis of Discrete Structures''}, year = {1999}, type = {Discussion Paper}, number = {98}, url = {http://www.stat.uni-muenchen.de/sfb386/} } @Article{vcd:Snee:1974, author = {R. D. Snee}, title = {Graphical Display of Two-Way Contingency Tables}, journal = {The American Statistician}, year = 1974, volume = 28, pages = {9--12} } @Article{vcd:Bickel+Hammel+O'Connell:1975, author = {P. J. Bickel and E. A. Hammel and J. W. O'Connell}, title = {Sex Bias in Graduate Admissions: Data from {B}erkeley}, journal = {Science}, year = 1975, volume = 187, pages = {398--403} } @Book{vcd:Gilbert:1981, author = {G. N. Gilbert}, title = {Modelling Society: An Introduction to Loglinear Analysis for Social Researchers}, publisher = {Allen and Unwin}, year = 1981, address = {London} } @Book{vcd:Thornes+Collard:1979, author = {B. Thornes and J. Collard}, title = {Who Divorces?}, publisher = {Routledge \& Kegan}, year = 1979, address = {London} } @Article{vcd:Dawson:1995, author = {Robert J. MacG Dawson}, title = {The ``Unusual Episode'' Data Revisited}, journal = {Journal of Statistics Education}, year = 1995, volume = 3, url = {http://www.amstat.org/publications/jse/v3n3/datasets.dawson.html} } @Article{vcd:Haberman:1974, author = {S. J. Haberman}, title = {Log-linear Models for Frequency Tables with Ordered Classifications}, journal = {Biometrics}, year = 1974, volume = 30, pages = {689--700} } @Article{vcd:Wing:1962, author = {J. K. Wing}, title = {Institutionalism in Mental Hospitals}, journal = {British Journal of Social Clinical Psychology}, year = 1962, volume = 1, pages = {38--51} } @Book{vcd:Andersen:1991, author = {E. B. Andersen}, title = {The Statistical Analysis of Categorical Data}, publisher = {Springer-Verlag}, year = {1991}, address = {Berlin}, edition = {2nd} } @Article{vcd:Haberman:1973, author = {S. J. Haberman}, title = {The Analysis of Residuals in Cross-classified Tables}, journal = {Biometrics}, year = {1973}, volume = {29}, pages = {205--220} } @Book{vcd:Everitt+Hothorn:2006, author = {Brian S. Everitt and Torsten Hothorn}, title = {A Handbook of Statistical Analyses Using \textsf{R}}, publisher = {Chapman \& Hall/CRC}, address = {Boca Raton, Florida}, year = {2006} } @Article{vcd:Salib+Hillier:1997, author = {Emad Salib and Valerie Hillier}, title = {A Case-Control Study of Smoking and {A}lzheimer's Disease}, journal = {International Journal of Geriatric Psychiatry}, year = {1997}, volume = {12}, pages = {295--300} } %% inference @Book{vcd:Agresti:2002, author = {Alan Agresti}, title = {Categorical Data Analysis}, publisher = {John Wiley \& Sons}, year = {2002}, address = {Hoboken, New Jersey}, edition = {2nd} } @Book{vcd:Mazanec+Strasser:2000, author = {Josef A. Mazanec and Helmut Strasser}, title = {A Nonparametric Approach to Perceptions-based Market Segmentation: Foundations}, publisher = {Springer-Verlag}, year = {2000}, address = {Berlin} } @Article{vcd:Strasser+Weber:1999, author = {Helmut Strasser and Christian Weber}, title = {On the Asymptotic Theory of Permutation Statistics}, journal = {Mathematical Methods of Statistics}, volume = {8}, pages = {220--250}, year = {1999} } @Book{vcd:Pesarin:2001, author = {Fortunato Pesarin}, title = {Multivariate Permutation Tests}, year = {2001}, publisher = {John Wiley \& Sons}, address = {Chichester} } @Article{vcd:Ernst:2004, author = {Michael D. Ernst}, title = {Permutation Methods: A Basis for Exact Inference}, journal = {Statistical Science}, volume = {19}, year = {2004}, pages = {676--685} } @Article{vcd:Patefield:1981, author = {W. M. Patefield}, title = {An Efficient Method of Generating $R \times C$ Tables with Given Row and Column Totals}, note = {{A}lgorithm AS 159}, journal = {Applied Statistics}, volume = {30}, year = {1981}, pages = {91--97} } %% own @InProceedings{vcd:Meyer+Zeileis+Hornik:2003, author = {David Meyer and Achim Zeileis and Kurt Hornik}, title = {Visualizing Independence Using Extended Association Plots}, booktitle = {Proceedings of the 3rd International Workshop on Distributed Statistical Computing, Vienna, Austria}, editor = {Kurt Hornik and Friedrich Leisch and Achim Zeileis}, year = {2003}, url = {http://www.ci.tuwien.ac.at/Conferences/DSC-2003/Proceedings/}, note = {{ISSN 1609-395X}}, } @TechReport{vcd:Zeileis+Meyer+Hornik:2005, author = {Achim Zeileis and David Meyer and Kurt Hornik}, title = {Residual-based Shadings for Visualizing (Conditional) Independence}, institution = {Department of Statistics and Mathematics, Wirtschaftsuniversit\"at Wien, Research Report Series}, year = {2005}, type = {Report}, number = {20}, month = {August}, url = {http://epub.wu-wien.ac.at/dyn/openURL?id=oai:epub.wu-wien.ac.at:epub-wu-01_871} } @Article{vcd:Zeileis+Meyer+Hornik:2007, author = {Achim Zeileis and David Meyer and Kurt Hornik}, title = {Residual-based Shadings for Visualizing (Conditional) Independence}, journal = {Journal of Computational and Graphical Statistics}, year = {2007}, volume = {16}, number = {3}, pages = {507--525}, doi = {10.1198/106186007X237856} } @TechReport{vcd:Meyer+Zeileis+Hornik:2005a, author = {David Meyer and Achim Zeileis and Kurt Hornik}, title = {The Strucplot Framework: Visualizing Multi-Way Contingency Tables with \pkg{vcd}}, institution = {Department of Statistics and Mathematics, Wirtschaftsuniversit\"at Wien, Research Report Series}, year = {2005}, type = {Report}, number = {22}, month = {November}, url = {http://epub.wu-wien.ac.at/dyn/openURL?id=oai:epub.wu-wien.ac.at:epub-wu-01_8a1} } @Article{vcd:Meyer+Zeileis+Hornik:2006b, author = {David Meyer and Achim Zeileis and Kurt Hornik}, title = {The Strucplot Framework: Visualizing Multi-way Contingency Tables with \pkg{vcd}}, year = {2006}, journal = {Journal of Statistical Software}, volume = {17}, number = {3}, pages = {1--48}, doi = {10.18637/jss.v017.i03} } @InCollection{vcd:Meyer+Zeileis+Hornik:2006a, author = {David Meyer and Achim Zeileis and Kurt Hornik}, title = {Visualizing Contingency Tables}, editor = {Chun-Houh Chen and Wolfang H\"ardle and Antony Unwin}, booktitle = {Handbook of Data Visualization}, series = {Springer Handbooks of Computational Statistics}, year = {2006}, publisher = {Springer-Verlag}, address = {New York}, note = {{ISBN} 3-540-33036-4, to appear} } @Article{vcd:Hothorn+Hornik+VanDeWiel:2006, author = {Torsten Hothorn and Kurt Hornik and Mark A. van de Wiel and Achim Zeileis}, title = {A {L}ego System for Conditional Inference}, journal = {The American Statistician}, year = {2006}, volume = {60}, number = {3}, pages = {257--263}, doi = {10.1198/000313006X118430} } @TechReport{vcd:Zeileis+Hornik:2006, author = {Achim Zeileis and Kurt Hornik}, title = {Choosing Color Palettes for Statistical Graphics}, institution = {Department of Statistics and Mathematics, Wirtschaftsuniversit\"at Wien, Research Report Series}, year = {2006}, type = {Report}, number = {41}, month = {October}, url = {http://epub.wu-wien.ac.at/} } @Article{vcd:Zeileis+Hornik+Murrell:2009, author = {Achim Zeileis and Kurt Hornik and Paul Murrell}, title = {Escaping {RGB}land: Selecting Colors for Statistical Graphics}, journal = {Computational Statistics \& Data Analysis}, year = {2009}, volume = {53}, number = {9}, pages = {3259--3270}, doi = {10.1016/j.csda.2008.11.033}, } %% bad color examples @Article{vcd:Gneiting+Sevcikova+Percival:2006, author = {Tilmann Gneiting and Hana \v{S}ev\v{c}\'ikov\'a and Donald B. Percival and Martin Schlather and Yindeng Jiang}, title = {Fast and Exact Simulation of Large Gaussian Lattice Systems in {$\mathbb{R}^2$}: Exploring the Limits}, year = {2006}, journal = {Journal of Computational and Graphical Statistics}, volume = {15}, number = {3}, pages = {483--501}, note = {Figures~1--4} } @Article{vcd:Yang+Buckley+Dudoit:2002, author = {Yee Hwa Yang and Michael J. Buckley and Sandrine Dudoit and Terence P. Speed}, title = {Comparison of Methods for Image Analysis on {cDNA} Microarray Data}, year = {2002}, journal = {Journal of Computational and Graphical Statistics}, volume = {11}, number = {1}, pages = {108--136}, note = {Figure~4a} } @Article{vcd:Kneib:2006, author = {Thomas Kneib}, title = {Mixed Model-based Inference in Geoadditive Hazard Regression for Interval-censored Survival Times}, year = {2006}, journal = {Computational Statistics \& Data Analysis}, volume = {51}, pages = {777--792}, note = {Figure~5 (left)} } @Article{vcd:Friendly:2002, author = {Michael Friendly}, title = {A Brief History of the Mosaic Display}, year = {2002}, journal = {Journal of Computational and Graphical Statistics}, volume = {11}, number = {1}, pages = {89--107}, note = {Figure~11 (left, middle)} } @Article{vcd:Celeux+Hurn+Robert:2000, author = {Gilles Celeux and Merrilee Hurn and Christian P. Robert}, title = {Computational and Inferential Difficulties with Mixture Posterior Distributions}, year = {2000}, journal = {Journal of the American Statistical Association}, volume = {95}, number = {451}, pages = {957--970}, note = {Figure~3} } %% pointers from Hadley @article{cleveland:1987, Author = {Cleveland, William and McGill, Robert}, Journal = {Journal of the Royal Statistical Society A}, Number = {3}, Pages = {192-229}, Title = {Graphical Perception: The Visual Decoding of Quantitative Information on Graphical Displays of Data}, Volume = {150}, Year = {1987}} @article{cleveland:1984, Author = {Cleveland, William S. and McGill, M. E.}, Journal = {Journal of the American Statistical Association}, Number = 387, Pages = {531-554}, Title = {Graphical Perception: Theory, Experimentation and Application to the Development of Graphical Methods}, Volume = 79, Year = 1984} @article{huang:1997, Author = {Huang, Chisheng and McDonald, John Alan and Stuetzle, Werner}, Journal = {Journal of Computational and Graphical Statistics}, Pages = {383--396}, Title = {Variable resolution bivariate plots}, Volume = {6}, Year = {1997}} @article{carr:1987, Author = {Carr, D. B. and Littlefield, R. J. and Nicholson, W. L. and Littlefield, J. S.}, Journal = {Journal of the American Statistical Association}, Number = {398}, Pages = {424-436}, Title = {Scatterplot Matrix Techniques for Large N}, Volume = {82}, Year = {1987}} @book{cleveland:1994, Author = {Cleveland, William}, Publisher = {Hobart Press}, Title = {The Elements of Graphing Data}, Year = {1994}} @book{chambers:1983, Author = {Chambers, John and Cleveland, William and Kleiner, Beat and Tukey, Paul}, Publisher = {Wadsworth}, Title = {Graphical methods for data analysis}, Year = {1983}} @book{bertin:1983, Address = {Madison, WI}, Author = {Bertin, Jacques}, Publisher = {University of Wisconsin Press}, Title = {Semiology of Graphics}, Year = {1983}} @book{wilkinson:2006, Author = {Wilkinson, Leland}, Publisher = {Springer-Verlag}, Series = {Statistics and Computing}, Title = {The Grammar of Graphics}, Year = {2005}} vcd/data/0000755000175100001440000000000012367374476012000 5ustar hornikusersvcd/data/UKSoccer.rda0000755000175100001440000000032614671771756014154 0ustar hornikusers r0b```b`a@& `d`aɩE |@586@h(J@i[(U@i(&ea5h(̀F ?S2s/8(X!5(JsSJ 0!ac&djBq +`,0cyb%19'.X Qvcd/data/Butterfly.rda0000755000175100001440000000037214671771756014457 0ustar hornikusers]@ c[Q ʂ<zDxvaO.6 9͟@6qc,pmT«oQ?_:v-TKbH zOcW9GNA|!eS&q9](zc1,>K2c Y,˂><1#b3Pl. #302 ui8lk?e]׋䘥U7fӥ'+!:ű\wBƹ?nτ:cࠦ\$ '2-U/U7OBRzτ;$qSEl^`(9]+ήS^p=. vYϵy ze]q-J1P0:Bvi Ŀ."(IU URF#x+/̇ӼQV2{o!H$e7G0ϷBDy8E }pWHi,]iybig{VIEI2iStPڪȃ!sύ8:\nHY=uf5G4AJD\#u|Y ou#d7Nⷦ]-$sExBw 0>qn>]Z &Wߑ?ܞ Ƃ+Ph;_uTWi&}"!__o` y#٩O\HN;~&61淾K~ o@^r_G_b+o֏F&BK3NB((;i{hYXWg;J3UG}{C]Џۊ"XmYS則Cm)jߐU k,quzlVs( _9?iJ^;y۹_-wAdu?LIZ'z^P|_jw)n ]Uv΢ГKfB݄'N`XУ=stF} I2:yK/%, g># $?z6kH"]9b6Dό-i¿c.@N1:RNtϦb0D}:!uo'c2 /p78\'<%&~{v~iUl $fףb(09oŸCē6 lҿX w :R߼c9O6f =ػMOM).w~hޭ TwC-sVpS{אo u&Y3h$C'Ⱦñb=dW:#ezxo=|N?;= z$u@M?k&qqhѼޕ凞#,;wzN_!K,4'dyFVO畮kk7ӇLX8Z>>>84~yŲLX+Q@TPAK~%%%%Jj4(iQB 28dp!C <2xd#G <2xd! C@ 2dB *dB *dB jdFjdFjdAdhAdhAZdhEZdhEZdhC:d萡C:d萡C2̔c2QD<&fZ&2єd4%)MhJFS2є1hq1hq1h<3h<3h<&0h &0h &0h*FS1T&]G ū?Z8:^-~(^_Dvcd/data/PreSex.rda0000755000175100001440000000037114671771756013704 0ustar hornikusers 0E&{ .(.c6Jy~86S!ue93so&}W!wp])G\GII< upL>1 Έk7= KXe5%g.nitYזBSN#VwY"¹J8[8EEBߊޝC+C^|;i(FyX\E-N4nxvcd/data/HorseKicks.rda0000755000175100001440000000024114671771756014537 0ustar hornikusers r0b```b`a@& `d`a\Eũޙ ̼@V bG bfjT]) %)it^bn*H&a:<ac0 P&\RK2@'$g-ILIf8kvcd/data/Hospital.rda0000755000175100001440000000035614671771756014264 0ustar hornikusers]@ c[W\j77Wpq=5Sp/c wI$4wMpu9TL%Rm>gއ1f9Օ(&2+ IѐǺLk<ߔL9aCEhkcZjvɬOt㒏*Nv8x>+g$ʼJb7i^aSapvcd/data/Saxony.rda0000755000175100001440000000032614671771756013757 0ustar hornikusers r0b```b`a@& `d`aly |@8X@((]B|T ?zb|k@h-(`NY(@bj 0!ac&0)ac0%dhgYFhc:(x&E+OI,FWZ QЖ vcd/data/Federalist.rda0000755000175100001440000000024714671771756014562 0ustar hornikusers r0b```b`a@& `d`a\n)E9% ̼@v @,  -``9%3HBѤ9y@j 0!ac&0)af +0A y1 vvcd/data/SexualFun.rda0000755000175100001440000000034111566471044014370 0ustar hornikusersM @/RA:wdҩz_ a3;}qct 9΅Z&0hxr_{R&HW+4Ҽ@b#R׈,3WQӈSsRx2 GX}N +SJ[q^ VVA4Mwvcd/data/Rochdale.rda0000755000175100001440000000101414671771756014212 0ustar hornikusersVKK@޶ƂЃă_j +o֢&@;E-5/=:(/]Wix>>c-vTO;I75djj$ wћHN`=?ogKC /֘Ѿ}OԡduҘ:=Ò$/C x'twnӃ4}hŗ6=eTh|_ș"8{ϟZ3884@h(J@i5(ePz(: T{;0ꃋBU7WMVWA !\ b䠘 MPY^bn*(jj!ΩE%y0EII9p~~qq&%4$4032 Rӡ|nrļb4B} GRZZY\E0 Vҩvcd/data/BrokenMarriage.rda0000755000175100001440000000056011566471044015351 0ustar hornikusersj@'_BECћAW]m1&&xk߬'nܙrhٙYrw=u2` 0l)?@$2њ#&[qy"ߊ]K OG ox~<*RUųNu\fL A,gp’x3XL I$$~)Jl4-_Zf6|'|grB~.?͔N<:(OyًنEt\Њ`Vf?$`IDo5]%h :]GЧ6\M-MmMM]M&m%򤪭R?Uvcd/data/CoalMiners.rda0000755000175100001440000000053512367374476014532 0ustar hornikusers]J@7I+`)x u!$٪=Jc]m%Mk(zx?GG|Yinө61Y-u,j3XU;(>&r2fTf_c?+_O|b%#\%_A(QwSb>Пp[7)-bQIcNp< ZݞȦMR-*[zfsKAQ ZcsӁV6w jųOpO+B+Bp^a2&B eubZ.)d>T(dp=|vcd/data/WomenQueue.rda0000755000175100001440000000027614671771756014574 0ustar hornikusers]0 1}*r҃/Nyo،6K/mv=7*i %!x aLWge0WXY?)&ĒX "n&{Mt%cl[ݙ^S&ud,9b)X,;=Kr`HDyD[3mV~n7#7URnX[MGͣM0fӱ:JW~^}vڴPC~+u=4 '6L}|x Utq7esn૴pe6N$v':mrA09)<4 ,kfRQF((hJQ^ѴET0<;iH'.v4^>Jvcd/data/Punishment.rda0000755000175100001440000000074211566471044014615 0ustar hornikusersSMK@ݤڀRЃG= ՋxAÒmI0*i@ݚ1 6yq~t+1f3a1nh6?Ala8&c`}~+> lV}c" ~% =(_ ܨW>o úw (*uy`-_}B6sKcuƹ6atJF*ZU9X8͂[43mN)}ALmõGx7핥j93jPjeF4h0۸]*/hs;[3uEj=ғHRӯMW$z&XTV#Kv2-ȵ<$@III qbO, !%#F48ipAdsI' A4i!HCt~n$ܹI}J0vcd/data/JointSports.rda0000755000175100001440000000074311566471044014762 0ustar hornikusers͓O0ǻ10=za-?FQ Y+?ͿL--tk_off:BIA KYTҽi(d0"dPM%Uʁ\~P+}[wItD?B^ k}Yl9)h>\,/DILSKhs_=c0׌Ěa#;> VV1.LXs~]L%^m yP;pFc@NB*ӲdתlΗ¼F +N#~&ݍ5W{-&o=9K/wxKn$+ _/M#'qFr{}Z<"醭 FwQԦMY6Umj`LFG1tEt%tettUtȠȠȠȠȠȠȠȠȠȠ``````````(4Ju'ߓf!߿ 5fvcd/data/RepVict.rda0000755000175100001440000000070314671771756014051 0ustar hornikusers͓?K@6b-(J;8vGqV"RTg&1.""( psAL>)@}{K/DSo {J:º=v儽kpk>jV%!g ≶4xEܶ+u!DO WO 4WbC7[9q:t- M ė:U0q?x'+g}Yϻ7{'>Rԝ/߿28?vD.=qD<+$1:+9n %]W ٺ|V>/hVʶ/ ǵLn$f ST)5?cU]Q5Ui%JbS__~vM!$cDO+eejm%%C|/vcd/data/Lifeboats.rda0000755000175100001440000000113414671771756014404 0ustar hornikusersVMo@|B^B"B{Ԕ^r]GvrOf3"M+By;;v2L}0x#l7 46OI#Y i8#*.㫄t,&$6!@:D, q#r69kóQFjIK(dS_ATNG ㄓi^d2yQ8)%ty::Z}Ǡ%&JQ7 E7Zm"vak_ǰw7k[nqe{L|drdpRKJ͕y%aƥHȱ6_rkSY ]F!]D]V- '#{JomLod?lY]=){cUմvtY}*WݴvqITֆ7j_Iq\%a'܌܀G;s,dA+e&' $gE vcd/data/Bundestag2005.rda0000755000175100001440000000122611566471044014704 0ustar hornikusers]S]HQwa5!HE"i\3g#\wGgfmf@ʴ"2(z^J| ^"!;Xpf9;Fd^ȳTٿ<7j$rY0k!e�~zfWlE/m׎X͟?w; \ y r-a O~_ jT[|^2dAQugօs`1fR A SA9CtVָ w4˦QԞQ ̱S:dnyJjZ$#&=/1 ?U-|%QSdTL2]Av1ֶ橩/RhLD8hyB4YmS=E=e BLz{҅G]AD3Ԡ.#/.n%'%@λzFŶ&՜#x"˥f6Iit Ϳ `vcd/data/JobSatisfaction.rda0000755000175100001440000000044411566471044015544 0ustar hornikusersPMO1MHwLHL [&+{Se`vvu:}o/Q2K ҈ڍ\ϟb*aVlY %zc~:7׀)x|_p>zN[6mFY݂oxal"ܺhg@\dY0oHHƔl{o,ݵ UZkِ3l~d%PQI #0NWjҍK\## ArHI*6\ikۄ/NqIvcd/data/DanishWelfare.rda0000755000175100001440000000212411566471044015173 0ustar hornikusersNGCDT.zBQTUys7mISF@X?ҵi;?Gi9)Q+[2xf~;;3x#h)zTkբZLO-V[e\güwy-~\V6F2(SAdr~Yiq``|-pV)ާGTzv܏C\j𹥸MS>T>}A{xgu/.󼣠 a9k]b>ؠܥ3zܟ0?yګ}Vm}:E^jo'Uy\>w?]f*>%LOns^7UMvRw4fO,?~]V<ɻg%F9\'AG5.xtG~Υq6>?(ghg[o"ԺO5~>iN 'lj$$kdEyd 2 `( `( ahahaha`a`ǥaaXaaX`8`8`8axaxH`$0 F#H`0R)F #Ha0R6䑹L7h[I%5ZI^DRbbbbbbbbbbєhJ4%MDS)єhJ4-MEӢiѴhZ4-͈fD3ьhF4#͈fDYѬhV4+͊fEYќhN4'͉Ds9ќhN4/͋EyѼh^4/-yХlmzyņvcd/data/NonResponse.rda0000755000175100001440000000052111566471044014727 0ustar hornikusersJ@76 ^*xYݺބ>Oֺag)6dvff2IjD1ƙz ,><B۷JL4Xs{jkYyu'NoPY ]_N?0cu\;ŗ__Wh =̖Ѩ& #HQ1Enԋ,tj+ͅ!'6"-4_1uf_ tO r!qy,EUb 45<#(R~7mPz7׻ǽ !8&8!8%8#8' G%L"D!:Cm;s`_^evcd/data/SpaceShuttle.rda0000755000175100001440000000075111566471044015067 0ustar hornikusersR0RPOpxmx)E;ϧR7On7KRgƘtl[LØkz[`,{#2Q/2 ͽSO>rnYTIŃ̝D>bF L|ȿt; w%DD"GCKD<8yp|ߔN3vcd/data/Arthritis.rda0000755000175100001440000000141011566471044014425 0ustar hornikusersՖYS@3 L"耂<!( sS!Ńeǜd:t:wXkݖeٖb?%gW5k~˶[;\ʼnvp10e  x2#  wkpiiY`R}J4sṕyp \ׁK<\<Gf@?j೬XdQ_&~ox.w uÁ ]'I}G?IFv,KjW$n&k񎹴ǖ7f!G?u#Zy6iD-t#ۗyե= XLZɸfJ3^^^=^Z֐fT4~r畖&jR#PZBM3sCZ#iCҲ\f)]W_8cXߣY\auL R|ag(>{xx G}os'{'$sŚZ=ޗ1ݾns篤 q4.tFׇ_n;n$ӵ\MVl$M}YI~XjkCײ{#n#YHvdϑ| R߄eBd˜(Se|)dRL..........>>>>>>>>>>!!!!!!!!!!ECѡPt(:EGDGDGDGDG$ vcd/data/Baseball.rda0000755000175100001440000003602311566471044014171 0ustar hornikusers} \Gun{{EH-oYmlϢZ,Y#K2igZbD00l!@!! Bd@IB%!Uԩf}7wusUTඣicLl|dℊYLxiX,Z>}[RR\zp򘯌 JUr2>m-CiډXYeKJr,(ONWiӽLʧ}U:+f889J41UՓZԇ'gL fEObb2Q !gcAm/ +S2#%?r ,Jq?X@k ^X)MSm+=yREj?9t6PK9[ kikC+ҳ\΢3*2C'=RTLUf-8Vv898S>1"  NۇP 78k!i;qb մJuҏV6J۽pg`PPeY(vdv-RR_%ZU3T\d7]Z2 ]AځGlޕq/ˣZ1kZzjZ*ӗGƞa9Zvw Fi|r]M z\QgT PIx8g1C $XfkfemzzҽXIJZ{j1mcvo`r{CC}w}}EB UfPyb2hwZL Qno̾gҾ1}y1Z[ 7G5`ٳf$O-f^=&JsGʕiʹ|jكP Jry|t℟Gc-9?XtDP +"q*^c3)f<֡냪B9aHv`wX (aTLZ%9AȡSͯRg̊C oxUu3(f8:=PSV8Rm%J a%sD9UU WKghw|ӸP8:,"IǼ[8TswhΎzAhMqfOH6+ y≢4,潕JqL77T&Y}ձaiQ]YՇN|m՚'J۔:EfC#jiX=]E],p.)Rm¯#gu"U]Ъ|F~[ A1mM'S W9:$Bj C#E)jn+ǪЈw8YԼv)Z("n wdO6y_2\+̎_0!(ZM m@jxGj2n+-T4nܛԈJʀ8_W(Ѩ~WQB-y >VOAD& ƓqZv'Ξ -ROڒw-{BK>hB5>((R]}ȑ'/;Z6 o&kR^ đ``qo7-49x,(s˵~;ĦVPq0U+ԻX|K^.䣆! $^Y+yrM SȔgU-C h䱡,j8XUWngiXUS_FQ9O:m*^,#<݊c!C2!{Oﲻ2J xuFa7л"imOJ$08X%;䗔Oޣ$:)do񌗡b d)/Ǜ3^lT!(7JMWʄO(bٳ;(QZx*NH2N~q!@)wT?^=s =! u o۩e񾐇MdjȧXasYSjv3D'oTZ){ B`fWq2Eߒ V@AzE%V a$;K*XVNyx)2߅utƘ:*Q =]?utOׅttQIQTsJǨ.TWѝDۨO꟧OW7Aѵ]t]OPRGt}\*=ʋ3*?Nеܕ-?q_Kz!]kw_(;%]C<1V^BW;ѝt-#o|]t 5͡2/wsUKTz. t.=?Dwx=Q9*Mwt]m&r(ԍ31wkL't7L;5gtŷS+T^BYtu;z-(vGY#nNcq_LnG77:y24}LL?# 됙_q|'1,eR;/a~]'T_AtahĽKwr6tŮ H"s''ېcK(ft+]X6&C͏|1xb+f[D1lBNeHp,:y?O:=.ư=LSTn辍M_ K7=϶ONwL{^X8ىy{N 6 !ߠ-!/E0 !:#퉗~%$ՐaH 鮹.R` ?z<p)It>®C^BׇB5f8x0]D C\NWqpP=2=Y_y<Krn>Htz Frb`׾Gl!r|uy^,##K<ޫv~ 6ix ?8C̷K#L *~qDŽL@-yXt;̼>2. z1?O0lÆ 4쾁 fƁl.l<`BIWMZ1Q7 S2{N7x10|^yy{+7G{}iq:mx1sпk_0Y/: `H Ow2~LkȮCl>A4\?Gd2~, ȽKz~k"_ xks}&+0Vp #8gyÃ%nmn?q_, \jbp+V?-+2 cIp a^ }3G̴e4ZsXXɴ~1MMknb :~⶘ċ1 62[,fݔ\n#y >| A 7WWr;]Q]by ÷.1hf㧕̣5<[o1:Be;R-U[~{~ϰ0u ctX6s`nAC>z.C֕| ncܷs:.8'#b|y,>0>_x^sa ƹۯyc:pO6C 2-L̵iw- qd )c|mV.;a'070͌m|mlf:}ܷs \dKxۜaZmf~Ot@<Ƈ\ȼ:W?㸒) mofމ=lbz }73<g <9fZ/dCU_pzE<ȂU<`_Ϯ`zCΎ'7;㳘bc`ǔuJ~wGaC~'׻|A*Fuh n`]t.1/d?2}W̧qq[i4]cc pcX1n |c'?mh\Ug^x/wy+h1NO3/ \33e:]8r˙ &-c6sVnѵׅF^œBw1_633 g:Y*J*X`\x/bz-fdA~lb=]{%ШNm!Y{%rC,%uuኜ$ ׇhF~! Oʑ3Eϡ;_=5Gߣ$o _H_nL'9XB^Bo~$߭4GcR옱6 dx#YQrXuS )J&u3:@G맑M/bt,FٺkG%Gd@>r~w r1oW.w:\d*KMk46tlafӋig6{N~eH{\Df&'K>@c ː.D;1Q/%ŵӜ3N>|<|ͻ=&ksZM̐\& 7!{>"'#zs^_޷>ɷ;/&G MS GhcSdO։=}a:ɴz{G_2IrZ`3^A<#ߛu~ɞtۮ DžF%3n~2¸]}. #/0V\Ms9w4G\i7 b{Fo1 clHe7]ow37p8^f4/fhh$5^ F~|FgkROME )!Lͯ@/0]K#OH 'cw@Sفt'#cζ8B>"7zCW3#u$=M_Fnj]w/as!O`wc-h 9G -1lbdobxح#,/s(C]BGƞk}MbSca'@w,4ig5ټ6{BgF | 0Σ6]ě b!hـ̣,k{ϐo8:Y[g2'?Vp r78Yp(x>'ӭaj銘hŘC.ey{ae#QB5gXܞ9 ׍S\o/ 'Cm{6 1WX'.##ͺu`O`Os8Y(_G.Fż\mb8M3qV!?r' ߭^Q/řcd&ubVd K DW^ ggjW*C k8n^?bYi5| '_'Bq^&3@Xs?A.p k%~6~*1.N8_X~)ٞ'\Gdktg} ?ƍ;ZX.%Xo .غ۳3$s_wa7j_،Gy{FVƉ1trVFzzC;|bݎWNl v {8CGv"Ct`f|-'[^6h6% И \9wC}n-{3+F\}E{V9.5Pe š <؃6ۜ5.ş1 .ցAsWGQ==0:D|o~ ?:yKMn~6V-FlYp{} 76N$ayhi::yGCtcձ.- |繱93;ߐٵ܋ѯYcl|1/!q&6%Zď a7o^Y.O0 Ώw9[_? 'Sس:F[ Kı!q#9掾#s%>팳V>O8bNwo}IJcРTșC+ '/0-(~@Bgiho6.񓎮t;O:\cN|:{i}ʌ+v>cov2E1I#þ 'O8E>;b 7seW31|ם2=3ڝL[hyjÿɦo?p?|B|r5,gߊ8fN^LGGJĘ8?ipIU}^1b x~oد,ox''8lm.Ġxbnh ?\#@|= /֠qhsk+ |+)\EL7B_| a{yldu#^GYO9$+OX6x{mcW:;IIo#Lƚnz45uOg3L;\s{D?ts gLzM&gl7=fL:0[d=XslNsw6k6Fpmri[zKx C xKAφ,0ϔs\K+V3|Lw. l8=GmCz\*7_Do0g|6s}7,6c`5R8Z$"զ?ۀZ=2yl ܗTIInKq8=bCR?%e92zTOq3. JJuYX|N~ B>1v9Rǖo9jm峟da l#H 5{-L*i/xFScO~> N_I9^ʸ.75n,,bZIJ Ly?7z J?mZ-Ksl4^RދXiTx€_!_e\/"̒/"oVhz)tk{џ>. 3*Y=J ǾVfr^XEDbn+B9\TB#I39z%GĆ-9 (T[mxDn7 $7ЭeM]ø%)?cLGʾNd]Kio]~})ow'elzTʼnR42{m@}1Bϰͪ)FF(Lޯ1%|9rFM/4T!A;>bdbE^ĉ0dB`b)]!`a0+AT.֡Y eF2ȌȮ%;ZmQ"8 DV\c\np"aւ/~)mߦR*|߂/%?^nV_׷~ـG~|\is >î36do n{Tj`O.mܧp,IrҔ87h\Z:;GQ$s3e>H{?eRHIǧ3rצOY|j?"% 2S >ȸOEh&$}Ѹŧ';?f cG39뇴:cYH!ϾH+106-1O$qsd4tTG,O3O~~gp&'?N۸tS}n/io_2.,[ Rʴ>KcH;Jsç|f`۟f?gpLl2~=ƥgy !I<&>~3p,G\ ت3nϖ4JA")y-d&]ҏsZuNc|Zm68;r9i2?~i0H#Go~7h^'GKuÆ,HU|ŧF`~C%>"}% tq㎏\-.qwҘH>HM@ʊMS{\~> &,4 {æww' vK6tiis*_gYl[w PACn. ?@>`hڝeY= @\hѽ&Ini ;HفnS[s9mA~DަmÇ#]C*96`B}'s!K]| Oosx8 v r ?p6E=fl\emǫaЊR<0ot-gt"?Ua=`ʞ/+'Nב}g'u $엽Yً>7_)si`JYύџc0SRD ~[ c[٠,޼+aI^֋C}Jy'wr~f3Ǭџ@Udqd0)4HBӈ1ei)|cns- cɾ|oi6z=yɾ|w%Xd?:\fШȞ|L&x{N0'9”D_=D/5*"/˹Ȯ `l4]E7'Fm"~-sr~,4G.tۈ.G}=7eyɇK/Uy7HS·z^OK֕rwýM?yۓ˿O2.=|q<~ D}}}c蘻3=oX<՘b~G;0Ue~՞vϙo_wx#bwd~w|׶N2S(?PIc;_S~3%{7_;Α;[>lxsgݛ~*6pkskk.Ztg\g&%>/\Ifm&t8Gf?\fp/f\25\Φӌ?}nlLkrce/&̍g;7V~zuX{:$hXIq sc%7rX+dˍ=Lsc%hML2率+?|ש:Jj'7VdnL+?wJZXyaه3>dO:Wn ~͍}יrc<۹l"{?7xm8Z3nkÇ[Jʕ|qb8!㎔'}-?R-e>/ϳ^{?U5n]fUw.^߽x^u?U.//~O.~.~.~/!C^@~k0O 8?:8s#6ؿCm9eydg!(] x=?'~GVxwu!RGu7b)v5[w`{ {p 0p XOY./˧ uY'.)uR ?^?O/M_ /o.:^=|`Uj:ÛpIy]+qngqz;TȷMXZOr';XX5q纣k'Vpʷu|P9xgu:<č'*Խ]^Hk\_saX7@8w7,;vzv%V|;cg*kb \s$ rn51_GW7q<V?4ş)9YgQW˱MX&n<^UyZ=0*.v׭[_gO8Gv8Ox ^ 8S`o[5T,u&YL\dk8?u=\b*xg˟[qg]]:ΰcV>3'zd:|uqiy֭5,nSzauX=}+qz>^eXpnU+aܪֿëb"ĝ7q}b9Ai9ր9Zago:<~ |j58 xn!w*}~Ա:7==BxP#|^Ku~,qGÚ!+ͼVc= A殮CI rx3IN/x֣j<60uXsG>]oW;ǂaj{ZbzBMg;0ȫuXA:~o!8q5=:H0bWWz9vfΏSC` ݀?ή0k|r%[}?8ßm|Du{PWuuGc=Mܠ/$6l'ެZOwWz jwb7 =۔NSX=xh-88l#Ջ8_ƙz)~85לVk3^o8c^]Y$gqZǟ)Nżǟ)Ib?̟SzjԢZ=逅'{ɰv?߀p~k^L}nA݀<33v}<=Oz͇??1]ky\>+6~9[j]tZ7/N6ZEܩSxẘO|}WreLnG`O:8qlQzqy9ea 3ƺ/p摰V`d"ta<LuQO7[a}m8?k;ݿj)eO;]ux؋ 8)O`ˏՓ))zXӋYoI}kߛɁE'Z |Ԁ Kڗ 8?(l_סLMv^g^xų/LN :Mxn]Ƴ ;x{*\>ٯV Ŝ !l05zX1/s &{%2?jy/b{>ϻ#tpL⁵j7vF3񸖳KbM`q]Ts;S Xωu_v'}Xo ?8œ a=?Oak{QLJnygU=Zu1ϪUuy8q}Jy|r8˟`OGp\qn0㳔㗲Oj+ГxB0 <52KHg4B?jT8<cjȴ {Ov7N/:=TLya{0,;1]t^i5/kܭƟǧ󳱦ŽǟuܙT78Î y.pǡ)^2G5l{+j5mE2]Dy kq6p:mZclk 'ıoT;&4gXiWp8z8ԅu)*/YUL?a#˵|/{Z ?`myHة:p< 8ikbq:Ǻng*kzpl7 {:cĖ{u[y!<9Rkvtns~/sfVc`u NƝ\%\Ysѧ9:mDf% 1M&q]WxNXCW?Ћ;5)yH1UǶS+γ&Sq9v9ѱr"׭-Nk%valwk9 ͫ}>q P]m>9)Ї3`s(ysp޶ zn PCaI)[Hk.`#Gw[2=tH?K:a!;UҮX0|8#pߴ] ҋu3i1[J~zf}N,H 鶮?`wלpЇڔfSgX?0YmLróuq=?WxIYftossn^ǟLqq'1z"WgA猓l8pﴮyqbɝeOts5^51{9:y f/0|n}6߮񽗉Of0 tv\gI?^rl~;t[O.Kv ͟)J;)z8j1 g8j?xs?@ 3\xL=9輀`>rot;cS5ggOKq~ZL3(Txg9E'4sij^U3#w0l:r9_c$z,6Yc8sؖ"|q>3k8ﰦ9i;1Nڴ.=|Cu<ߧ9+o yς ]0gcX'jcb=p_ͳ[޳XΧonNjo.''ZgssR}Yx%&A'c788ef^h"5xOL8uw8u2~x:bڳz7 =/5?}]ȲslȲlr"ϭ &3E8p\ϬۮpJ0d+XؘvYݒm?pSc̉2l 'c{zⅾ胾'?a9 7[=buJ?T  e8f>~cfq~nטCiׇ0 YY˛uF 9j<;`>`|g3Zo~_X'}'¾pHomA7| Ϫc պ7~/>u_|۴0+&Gg|P82:DNpBϻ>[or^d>_L]5ɟMqVܝj/V?vğ<Uɀ3&xƠWEٰa^;-yO:yScx \<JqxxXvUgc~:>\٭iĪZ0ŗ <3 +cxSwr:¿j߼|1GJx<{8?rc5ȦoΏ}+`LdFCk,x'b ֺX;ά=̓|NLpz}ȉ\D!7S[7Z-{!==sr_8'{5_'r ^ sjZτXpqg{YC2Ϟ=RȭpV5>q)v/=pW&5`ڿ]\g>Gҗƌ\L `a|o%HD:X|y+s%-{Y ^c^=İ>},Lz˙CRd;gWzs "j98̖wq#N?՞Lj; 6p-g‚?v 0P$õPxpы3v+6~vW gޯA6z{اh!u| /ғ;; l߉drv>lUW*|y#c QLXmr}6gC?ѝ~?/Cs:< U>gZg<0>·EmW8|5k:<=uunԺs9p=: gO/̫}o)yh̕m.a 5#zFq\YO9ς laS?'Emo07$ގ59|<b|לNipݭg^ybYi52#߅@e^^Te;sΊ3lպgYH u6JӋ¤6!ZNa۪; V/9ϼPCXAG|yK̼3`Y7|g=\T=O#̣uZ_ k]XjU^M-D}Z9/{r̨ 5:U|Y~2"6 w{kd+YⰪq>ez-L|Wq\U5c'W'2T'p8j{'?PHXܯ>?S~,)8V6},8j}%su}N`rga=Gkm k7yI:~-rIqy 65v5.Uۿ\\?VOwPOKsH+xc^~K6qSm#g, yczcŘ>DEV/X I؃cyh%]g5֋02*n_j٥̽a xL}&?=˥5{'z¢ ]5~ IK_5#a 9鬋>G§ }>y]j72˸Wnd {OP>'þ,z#5Q8/߫Ɲa xcW-ju=z0r~Ω=%OO :P!?6LcS4=ő0=w{~O85gI|T_%άƳlzu/ ]gY/yzvl> f>8<繫B3{2a-Ag봨VۨE0󚧱QYϯg`8f{0/PCcP',=D+1 ?Qٖ{ =-ᒷؿOA1BKk<{Z;q_<3<3a=:|W?6F1[!6șaT؎.O:8TX`lx&ߡg/?g`& ZMF'x&&1џK^K\7L<,={M?xXbxGf>T?P^S!WEJg8E|I۱k/p^Zb?zXse<0Їյ^p=Yr׳Vߧs$j ?:18[Ыr#g%%?ΰlgZX {<N3G8G8Ô<~_rc_\ݪεsl70ެqd|S8V0eటOlv[xa[(nʇ =zl=׉.)/{nUu9jqGjnl,<yzh֤0'~ý: uAX~=yk>xSi)N\=>}τ&>Kςa\Y5Ray`q`U`QG9R`vjL#v7V'^|"g q]Tۏ{: | !/0o ܹ>[/7ݷe\NVxsvwo_ 7%/}Kߟaxy_<~wg_l$oWy?wٷ_z|Ͽ/._˳^~|6ݛvvՋW_~?ߝxfg_~_{b_>W,7~;?|/ ݫ?8׊{|~훷Ͽz ׫_+݋Wo/P߮>?՛/g/Οb߽ċ/^}wow/Qڻ ۓ??0ݫ ߝys_o-xy/~ O~}Yxտ~ÿ>;El~o.Qf\ rY_R ً_|5~y?]D;r;~onݛưtAo}]Xo)OV\3Ņz[bwoŅPto.21zvCoVpoY{Tz_˗_[~?\`ͻoe_ۣw~W߼"_oߞ]"6g?wAoW߽ӟ.g_2J/_>CE}˷//Jک?*%;wtoԸepV۽o ײq*өw\_~w>Gj'վ!/fßw'[x~g_u:Y|G;,k sbxjicF<sH{&Yz}#Ú?pzg}ƿ_G%_O>bf\ǺDžE~}x2lX9pAt\GĊ5*W<9;'^^x3a T`mN0\rW:vGޏ?qk%8w?5Lu1;xSq/}g8 3 j9;8==8t9Wbi^R{/\Iߣ 8$R0x{uUMٷ ^Ͼk`pbݚ yI~5΅ubO;kfb'y6r㨃>غMO+qnNq5k eCmxzߪ0qZy2|\Ǽ%8E{5[8ȼiS̳^]Jwt%GW?O#q ?vF fO=]nUu'5~ r~.l1dײ` Bޫ#Ppɝ}_‏ Of ;f(w7Ʀ$NV5gԻ =4YGKSd6*SpgS[bZn p |UUKaĩm 啰m#=j=vCpvgxf8)dCGc.o!om;{14Qm hT{gkl91?]ISb-`)=?v5հɀayf0X'[uZ0vf\ո/NkZtfcɀ56™jt*ְϼÇzu )|o9(q_3a%_TQZ3l֘}8<` #8~`Ù5M <.UlfgpꪏA5m_}ɳf [79j. S5:XWId'/qXAѷXֽ% g}tXo>sܑ'Ϭߔ2y:.'}jOգ']Szá8em\+U50Oo!%|&.kp8j`Ϸ;K>vt*5rTvjR׳\uZ>5<g5`or?6M]SLS+,=c0]ɵ]Ƀ=Aۼ[Wm[M`Xߟgyָ/ԃuQ=yǥg õ ɦ/VB >1Yje7q81rO&KXqOqPlz՘=;Kl5+' 2n/.u{yZ/c o [jʁ s#{:`?j=ms [+Y50Z#Y|B~Uclk`x~N_zpC:d\6GN6\ìfkd0&`^|0,O=,l<yiݺ^&d8Fq?gɼsV({g=-a|0!gX80f:N`+؄>b{6nro٫IVZ@:+\ɏ\s|3bo3ɩ]a} <>Or:m)wuxhEk`Vu"?==1&T{d? {Z'/݀ȧ?/׸hoC{!>Д ~`Z?cIi#߂1}5lBoz`Xz"ğMdž|n)#3|jq_0<'f1Gվv>wm7-9fƽ_cSnO:aNa[kM̒O-xRj3llus>61ğ<ހSŋ5NX<=*õ`N/vo槾8~LclߤO s._@ܫv:jp57rWs]Ǫ'µ,OYi}~odDO9zFlZ8jߪ/c{~`nrv×}~!ۈvz rًg\7-u#u;*AG>:JN9?f1q֦[ɜ qOHKzj0zo'5֏9bkᢃǵGk0%9i8%oz}ebYR0i5̥loa_Qeb;ݿG*p!'qGX5e*wOcA<؃8=]L!j/XGo %=q_`YP!A0X}ϳ18l$1ovm@{c{݉g|Lzڳ'j-zC덝b&u>r`a}Lop3m}ϳj{O:mk3?La.ܳMqǟ?ޞ?dw/c+v(L5o g2'ϰ{u5,;A{31Hs$g=9 `c~!FW560[T;)}aY\) vPSkܷphZk͡8ݓqot`B+ &yτ;#֘M`xL%_c>4G_bOC<7s|aYrgCp]IutZ_g 1Bzd>Ϝ5)wa={}lE` oPfl|lgyIvָ=~ྰAvr|nuMท貮ڸ;Ef:[绞?ȱ7K|FpuD@e:܇%dpxZXG<~'\[u>DqF x`{Xg_}bmc?6 yZLۄo[{όQCί;5VgO'cK8NjЏ;x'|~m|VW}23y7cz>6.}{{{~VL赯39< ^`z{y Sa%8 A_Ǧ]gL;d{ufNԭψ%o[uV|TXYT$xӁsCEb9_FoơŷҟoX!2Tvw}a& bu{%ާ_To{*;jO}fKNn `YSɯ:vAo%]AGϟ8wvk`ۖt3a3`"{IlЏY{K$֘WV;#cnpKoi\3C0s3a9SO/fwYm<֙~kOa wj9|bOFrήpݗE }ϙ8Nߒ[IݩVo<;c'}3a{I;^.}_v]{@lی^ష&y=G70>y9 zV{6ﰡG0>VC;GoQbmz y7wbz.xݩv~:lح>IMbe܋Zx@M@;5ؠ ܤ'yҳYXVC~ygXc89K7k`CV҇]CvoFjpJ`s3Adj{VmߓO ,|ơ 0Mp;p%g` ic}J n]Cԧ=<~̿Հ}+~?g|8b.P|/q &>"SjU؂zM:&6/1Ok.1wtݩ6 }aPkZʃߟ-j\pnėD`3g0K/| ,u-["<ξOLqGߣ#yld}bĄ:qUK#X o=I>^։u!>^Y yk\|ìIܮVKcO8;57*0]*&LY܆;XD̅{֝p0sfO/_Ak1q1wA9 ^E@O8р,vg8yy_]g[Ϛnf@ g?mHQWH\prM|O\ksl'Pk\ؿ39 Z@=E> 1}k]s }8ہz0|oZ|U8ȃMt}zW^+;N,IGCꇯ%N,,zmJyh_6B7|*IU" ; ٗVXd^ٟ3:9q,[X]V҇u/ bx"yb#spUW9lEnç5|w|;MN`q1}fz˞Y=q﹧Cj7=۟V$>yg3u>. p$O]@'VۃKV}>}(j16K '硰Y!߾pc0c.}a{'|J̫>O9ֻc,sy`J:syV{ո{-{X_ p!ǔh;cs0x)ְ>滑VҙZ\\c7A-XkG,kD+RCN zjMن:.j9ڬP c)jstZ;sxc]a_.}2r.p"Lܠnf\Iv}u'k|\v |{ {0=Ə[4`wy8`R~\6=% u>'5O'y/A/ð {wW%KI XUzCl'5;8&'61j=ɀ?5{Rg8ۃ # yp1oUpl5i}/znܠ߄kgzY.r6d`_л5>=CAEu'cƙUkZ=ƽj y6:O}.kޗgNzVj8Ч]۩^DW'3{s\L^gBL?q0 e5`+X3Uz 3q/У{̾d̞3>5j=|".ɗdX n}ӽ t&ʞ?؇0U _әy߫OyϏX"}1/@w{,8^zO++؏%O carM7mz|f|ͼ'Gf Nqmlts^ u2{a~9Խj7>ܧ5zaD2kp\_74pc}|}҇p4plj|3{:.҃3dq#NC ơgle8t$6e},:8`v>~t<=* Ls*ϭ 83}=~#s-k<~\ȽdRzo0ݎؕ,ra/pvszsCzl߃3a"|_?X85|#{"y}_vfϦR/헼C]_#N-=a߃-+Spsqvvk3q^y}8"y|'vr{r9q \s w,Lf>Gy|4}r ,d6Z?٬' vuoVaQ- 38U98Cl̀ú7>|ܫA}rܟR8^?0}$cv 7_-A?s ā}X՞]9YƼ~lW;p[.:baž]8=\̕^bJvGnn ⊞j Ϥ_s @k"srgdk /j9<v  rCa!r0= XMCar~~;i.3$GrT-l}ϝ,y ϰC>)5??,#F)ً>u{̣j\kG/@][`ԇUyCsWҿ[[Fp-3[A|TX:N@?e^Y :9T֥o!LbxWj"{u|g yO8>lgsq/prOw&q!QEwԻ /.q/3NVxsvwo_ 7%/}Kߟaxy_<~wg_l$oWy?wٷ_z|Ͽ/._˳^~|g4^^Cjwgś7?[}~vKݛ7ko߽b߿ߡ~\g^ŹVo߼}fx_߾^W_y^z{~vw|<{wu~w[E$^~߿{3{_マeޞ/Յ^]͛ >zxk[&ޯ [xHKo#o.b/Ʈ_o}s_P7z_\ꟾbo^|uvoo.w/ w"Zgߑ㿼~;p4}^ \{’__~VHWo/ž/./޾{/.\ ۿ>s/a׳zcFg2 ן_ҋ?Z\ۯo}.^/I7g/=Y=9ꅅ}JݟtA/>ŗmQf\^v_}}]IUm,ߪ{Cۖr^ߊg_ZFut=jcqccԑgZ55Sbތת g56u~Ћ5gq k~K2^2>t}u؋yo?ąZpKr-f0lvyupjMsFגk_;̫#TfČkm| ky]C&c &p{f\g:V`:^ѹvKc{r ƱYWիCirVe{ٶ`՟6{[w䩃s^?ۀ7?3q߬qrz1zU)z!kn#sM%kkboV]˵:^2a둵yVn k{5r?=1ʘg?ox%f+m[jw'ٯsݽĺ%u5z|~=W wƾm]3~ y-۝'佐}(neY};u~{Y{M/3SLu# ^d}!5 ƺug$7zr=}\^sl9'} __{W!Aڷjle=nE2_rzc<b[5YgYK ԣW#_'ưm{*-DlgKdm{9{dJ]l_Vkv`8vY{=}߫Yɋ=^$F2wemٝskΟj~O{Y:g׫uLݧr9{3t>gx遲U~ƪjܯ{tves.|m/kl_#)޸7˺t#qsސϽ3g,woc^kqHNX2'wNrړWտ'^ݷYzyn'˞͚39s;v:z~u3쪫f~.7kCǬRל9mMl7U7gontN͸6}kz{f96+SulW?%W5g9bo}Mz'SzݫS_S޻W߭{]vj\7q~j~zRq}F϶'yzރJXkX#kݬGf}\Ͻ3}p:|.뽙Ⱦ=ژzfUc?9&Yo3DQGUz7UGz{S?}/sPXGx\+]Gv=:eW~LMo6\CgVqO^dl֡j ̩gMe95W37c-c]WnvzM;#'\}&e9|+dz6em'j'd]+s h|c<=Em)3<ףkooՋog}7ާΩ^.o̴Xn*~3kXSuײ߳}{gYc81\oU8}Sa|j>jW?2G]'|V%gd^[y4nsKGf!cޫ;ֹ&v ae@grӶ87{8B=YVyg߱x~}qw9't %}6]܎=%f׋L~+p?c݌k{QϬ؎IjcX|j >(>57c]ϝ|֨qnfO2{#^n~iݹֳq:3ߪ|^oeH?q>̣js8=3vz-+z{ϰeNmU䞕٧Y~yk/{{P> kd]Y>wOcy79aswW?R8r=\{kLL뭷uN;3v%mz2eCrs d wۓ>܊Ёώ'1Ǎx?VUs%y:5Oc)>QWcQ&?9.u;!x_saXWck㒜8?o6?S̳^<g߈bny\1W].^upOz}Ž@oMzdV\k}\W%9ls_Ucd Q>\t,mco'{2E+=:$]:X7_zӔ#usrǼv| igV7ڬeDZK<dNgFөɸZl[3zk+8k/Gd~)oG3'X5ֵW󺪖CYדּ=۶8kfܓr=}u짶ρkѫ?SﲮN_+D=q]c_\uY?~ȱ?:[ohx_znBxϘ'Oχ%]s7+ۣKx~=&amvޟ=3c|s{~絜+㔼ճ'=9zκ59{}yM Vy٧YyF5W]ڌ_ﺴ1slU55gu>8 _z=_uwO33yd]{8z$瞐Xܵ/|`Zc0/=q² >{Uu5+G.~/޷쯊k̷1AwUux~z}ol?3X}ܳ>'52vK{<սaɮܗ'yY`|2W|!kp 7+ql7:6yxjtu_rX9czje՘_wKdz5v9>;8^gD %y <0aOiYSgF&M鬙߹^u*~\{\Xٿʵ-.=.lId#9ٵ5{gj3/}`[z}̺czslUkb~YǺpk{+krwڗ{Es}\G/G{3oܳ{A﹭k}zo1GzƬ+=]Aۙ9_s}}*gr_7*)gھuyN5iwR^;wg~`:r{m4z${c#_O':֣5-gdr&7KdS{lNԵg?ԫw?|V\߬{xƭ7uY׽^ O޾Ï+3d{wUWizϽ=ۜ7K~u-h)^P5^;yXoҧ&ޟ/{Uc܇2.[qMU?v-}匝>h_䞗>dt?#zsҟ|ސֽ_O=t'= ˏorS:eȺ{u}̗^|׭s 5N?`K7sݹ<5?Q2>̳^&[q;xñL^ǺKrΐWg(;կձك}~2?㱦s4`fM2VoWgo-zr6z浩c՞zOe rO~ۃxu5'9o˙\<ϱ2Rޑ5J̬5kDꔳ)=~?O^ˏ^,lkom={vkh?=}m1Zwmoߌs+eS&Y]]g'͐72˾Ylw&jmί:"׻rvgSqz=s6ߨݎ]5׸^K_o\eZ<#d9Şًma9-l}5Y̝^=0SYcڰ7ݒl25Υ ӫ3Sr}xGގ=]3/rȾ=IE;={oE6!,"jŀ7ԀQFD@ (pQn] %Hd a-컌 {TTzͩIo\~z>3]UNzg~*}o06ja1Mc껅 C C7=އ4{.ưn8pKfʦqUրsUߟ-9Z~A Bݳ#p`M_c|M1Eue/?V:F/=3+6O]~S7i\7ƨ܅1Z52!m~s8|cB0AwR([:6 |,ڀPƭ1:p;UH}RڰTk}\/PXuNMtcǧa-IU΍ wx3H>Y|}Ncڌs6qk7 5 co~?i6췎?Zj7'sFjΝ_j3q9=c8Z ~r16}AvPhY`i*o^Ә4 s`n|JykوC}JXKWhV^z.7ԯ5%Kc5cvw.P[qCV}KL}&چڄaȾ4 cnV Ӹq*q:p]uq6ns>9􌮅/\S_r{DGW||~ri|x? ǘJh\r~ʆ!')tXkVN1Iۊ5h VSaq^ۀG9Ck3u8b]1oGlYA8q6Zvtkc#?1f1 C7xs?r>D E.qޢ1oP p=~nIDc-mj څ: j.~ڌZz.։q~ڏ ]X?{C _4ݣkmU[qs#~bOox}Jڋc}!C˦1 ʹ\)]oN6n]mvtia^w!ˍ{(ݟ9IM9wMuǧJp.O!ۆぶ7@ m76v!(u+j<zO4uj.?w0Ƨ5Q +UO8[!]ZU%Ayxjch]06X8.p>87&A9Aqv`fpI5* 0N ډe~ƭ5u.%-pQ?]tZV~F1f/-c,ñxj t霮jXN9(16·h]X>1n;_Fc6}r$|My0N95cj3W.ƝPGۃusmQ)zݓSѸx}U C7e9c;}:2i;1fi>!zM Wa^ϨN'6q1{|?'*]. C=rcb*Q{iwrL^o ϣxڈU1c0ui4 9ԏ/c~b ǂ{G7ԖS FR jaȾjAu7ߜqƾ @rUmvpqgW%9\g7|=vjW>E~SgWmڀmE?bpDÍ 5&0Һ[ZPwT 8sm¹ #Ur1iù*4Y[Xcֆ4O$Σk4Zg0J˳6<{_X!?cʏuc8UW׷Quʲ>SL,3Q]X6$CڂH>P=p|T3hsWtmIG7? K7 AUFk*-㜖Y6)>ϯcuT}M4̣jNOq;8gy+nX6 =d\N 8t\.Aޗg\a_pp{n!j%ڄk,j3#*O3Z4^C__ j=NJ}8u>l@ŕKrmD?Q{lS:{UkZg9={TP\_.ܨ߹7=77pSU2ұ`@\u3f~Q;3DyhYu|bmQi!kڐd}UZ͇Mur~n88ty`ΡbBxq^V?C_sHT78W*?-C57Auìxok'j3W&^Cr3{VCXqNו\_qqA~R{Ĝܽ{nm7n?;mܽU<_z]tgGw^ TCA܇cKտV/t w}a˭wwY'8p~FmlHd'-˦|殏zDe#w0d{9[UP۸JdjTmǏU`TG1PՉʶGsߵ6Q#iL% U֡1{0Z{\}]Wce{]~+\"S\Էla<ѲBR˓2۠̕}kΏ8ݰL硲t(@mXEUB,-oϫs wQZ.p)/ 1 ^7:[n- A,]7`wj\sX&wIFiӵ MC׾tJ>*AV;:Qq)>֓\9`[mDZl>sym8?o~U58scLc7NUk6xRIY6r3gGy`{V=4*k#[pycQym@>.& ؇Y86%\>n'wcŲډc|k"z=ǜ] 1W? >ô8sk5{7V~U0x/9$sV~Jo-_qQ7G`98}̓vcg(8vrPw{\P}Tϸ'j1Z76h\q>8Zreօ}Җ㯹эc~k?j!m;=PT:}ǹ6qx|}R6ր8537}_cN 4OǍMn9k6 ]p76USN=7>>T!3rPsLCeΡl8fWiUVAP/h~7~GahW5 N^ Ush~z;ZcaoF߲T=a .9Dpk?NІKϷ6􋵖# #GNx[>nGJ"[:k|nHvT$y<&sSs6qqNc_`=\̃c'P]dXڊ:SPVV*&☾TLSrJD:g]E+81h$8=CqNAo3.n~3c IqCai;9 Si[i]xu۸1އtNTEϸb7Xqϟ(Vbpͥs2Nh9KUwuY] |b/gr`TsUS}aLP۰^, qc{U~6Í{n$U qn.66a9}0ntS՚^kiXέ񨽴|ƲO[\s+)7}ܵ3>D-Be?v`}ps-n 73\,qh~=r hٮGtN_vUZ~5j+֓HCq c \{P{lʡ~zإ߳ȀXӘ:'mh0~./aաvsq`g:ډ}Z}EJ$sb]n.sh7xω:=X-i*=7YzփmT5 j:ڎk7^ս~.9{T'ZCpi\*퇊LVscۂeZ'׏nqDڋGV9Wimm\SD>y9yӀI{h;s6>8OcqcW4}ڃjmXQ*2 ;h^G869? ,<9Nۣ5h|緞Mbc +kjrg8/ ; 5|-ܜs wk^kuNq *78{88ݨ`\%D(+,{ŕGGöƌak&Z'QٖO+s2-7jqn~+-[W|nq0eͯ4?։+:iut{&..>>ȭ?8vPrs( y߸ءjմ|nc9?}\W͓x.}Ʊ|:h[e~Pyc礊p܀h3701+j\jj'9A﮸øu~61Z͏t1 - |NK=DNیGrx|Ms>K8-Fmڮڇu_ewe ͛N!q|pnyŹsAQz\'1օcmtfGhp!ZRr&0JK$X>G~U|^º1y-њN5'rXn5[CpjJ1pUr\lqsHD[׉|Kי?h,`{_h\3JG\\sk\rkFW1}ƭIbˣELz.=&6pI:|,D۬"- Ǎ_g+JqmV)4&m3^qwk.wڮYY6sߨ_`>Kk-՘XDZ6c^̯>굎kZuU>esߩDUv9ʛ跒}w0><57a,5{UUk 8T]h!Xm }߸:_maÐ͍lu^ڇ8oZè#\y8U1L\kk֎0=ա/8C[}z>{|\  Ahj']p,#Q^nA >TygÜ;3=7QkTg2$^[2\la| /e9Wڇ>>4Z\ t9MyTk?@V^u>֩dU=OvYzu 5pQUcG:shJ3 EMx^CqƍqUlrd^wɍo\$&ϳssiUWFu&pm:p=bǸ:,>DJeM˲ڎP.=+n_>Xǭg=@[ 8_2PP-0JMuA7W~'-)-ۣ:S*Q}1%C&oO\=FPrNq9\:GbS.hFu}B[zۍk l?_nZ`?'k!i[PcConF?K(yPև6}] qms>RRP5~|KTòF_p~ڢZW:U~5m5ƚ5[ay=^41h\}}lG]|Ճa`˯a4 Z~19➖~._N9gS?%x>=:~^ևD>PgnN`[T㶬jraT3!FQNU[u4ySp@ }QX89?qqAm2>uL}JWF';W>j7ne`۸9;.yXݬrUYV>== uاxO3oV}g6$Av)Cu em|K^Wes1Z_t/* aՉmes(114 zSuJu-0K'UƭhlkWU}Dͭ C~ͯw\<`bscZη|D>j P ha6sq~Qj#=R~n_1|z=Wp}Z6е5oقe`𞻇1č+&p}JیFmQ5V,Z8;h\Z7p]>|xڦ{;ܸAZim9{_/ط;OOWML/ܽSUHls*?`FCMU_r}78cYan}:ONn|:-[Ða~nY6qqbGsaZ~W7h{=[LnMw>g~]9G;a|WDqm(pj,&ƍ#S\Qܬ2*{NNSpSoC]e5a$7˲ʣ%I"=nGآ1a[i*bnSj¹p'.ZG5"}ÕmKE|)j%_$c;a?ӶujMXUGamWOC?>1:eՁ}ƍY}9>k09sza0J7i>+օOtc*1cF*n5[}~@hhܩZj G{-~nߋb>kޣq>&α즟rm7.^qQ˵ܸc$v2 wﲬvXAFb98G8B%z1a>k4Ul)ێ\>GA [wѾV35H>zڎF}Ec J{ܳ\l { ׊XQ2i8sus84F5ܵ.ngX\np԰Ӝ/pLrk1(=Psp4@mcn5j! <[?⎞íqΧ?7cFL;1a0/#%****N*#U)#\FZF:tj2RJZ2R2R2R2R2e2R2R2ҙeHuHHzwǯ1lgvƳ1mg\vƷ1ngvƻ1ogvƿ v;`GvŽ^ьl)F:Fo#i:uL1cZǴi:uL1cZǴi:uL1cZǴi:uL1cZǴi:uL1cZǴi:uL1cZǴi:uL1cZǴi:uL1cZǴi:f#i:uL1cZǴi:uL1cZǴi:uL1cZǴi:uL1cZǴi:uL1cZǴi:uL1cZǴi:uLu̮3fWj]}qvuή;gWj]vuЮChWj]}vuҮVKiW7j]Ǔӹ6y666^u^u֭ZǴi:uL1cZǴi:uL1cZǴi:uL1cZǴi:F1cZǴi:uL1cZǴi:uL1cZǴi:uL1cZǴi:uL1cZǴi:uL1cZǴi:uձ&oX/I'NI'NN: ^I't:btI<ꤓN:iN: I't:RtI<餓N:iN: 뤓N:iN: VꤓN:iN: I't:jtII't:ST'tNO5&7̏}a{~p7n*%Ox*84-.M XCo<'r;oz7W0 |;E[2bfEu(7yc壮8oN?.vFh/OƷgxK][fx;Swa`Ş8:Xk7&gx✟V{mq87N~7W]yckNOCoܻDp7wlIޘ;g| Wo>8v7}Cq{o|7>~7)xW,v%sol//kF/_v8??k?l/|pgpox޹&U'Z g,k3ǻ{]CWkf󇗼+~ 4Z0?vËQ8eS?䤏?>??L '>"y vy}c+/av?X/|%&^q8a?U_81ZNݗ73ݟ;2}5%|Y~K:3/>Sݞ8<#ك \ql\g+q>o1|AO{S]U /,&U7]>f 4l/Z y%_Kħ5iԂž5rqdf>(;žقQofb/| 8vxZ/38my/^^S.wtu^SՅV{cbªWy_ {f^8o|ᐵXZ|&5/) ?N. ׸BO9J UMp8pGOhZ\O,*';~'>|io[0臲gz\O3.XuO{}v}ޔW}}<+=MPEWxb=GE]l2;'C_'5&;~:E洶ar{_P6U,3׎wīE%6wŌ,̯gVNjkی-v#xGlW+|8/gew65B,rv8&{_[ek:Mްjd71y۴b1D?zD˯_,cV[ZukZsw-~oNΏ9bS=-ub}]b噽VYs#⾍wmirOk+G=_7놏NhgM^Z?G3GD? :e7k!㹞xYΐd9Է('oP'7qMn8/P'ʽoz }Ҝ|]#~z/|az_8K%(LO-T9eQ'o#3=qmp%plO;[;  w-8Ɔ;Uɬg.W|qGgz߫{M>y5?/:Beɥ Dy]V gnWDg7 lTMMFO,M3Ovg8)f*2qlw\N=~>t/kk5)P'lo(ϼ6/̬Yڈy&Z,-_ :A%W_)9S+yw?,-? l"O/z_/*I_̗S[UV-e.;A^_.xM0 8b.pĿ'6VsIW|("_]OW'k-ʹ7!D9DpN3E'tH\pI8ED)L3Y-+DzgiOE|9ö_nxQ9a=~]g$iכX?1H^]w,~MgxQ޷+¹CVsD8=≹EFɣ?၀hק- ]i&XIW/(5^0{֊'^R z"x󟅾Baǚ"?,i W\4yw|jÖx>qY#'H KD\qz?O/-Wϥn58o/آxNv_qM{-8sdȽ3~=&?9qÅo_(OΉ[zMgI̸3⊙{I݈+\P]nbi$[qC/x̳$.q7psň/|7*0o _=yWOqKW͒vKo|#=H`E YOF<Ѳg/\y(gkv dô$_q+.mbÿ#v5{9}}ef?qE?G?G"Mwxw|aJVn(߬UxWӈ'[ :w<2Vk_(?X?↯_KcU#xX^8"mw~u#^\WU%qEW?<Oy/|Cpt?̟QK*/F>D񿵭^$G<.$q1/'≵FJ_X(UaBxg2/#!V B0Qĕ!OsZq|v88pu~^4)/Pb1O ri`C괘/lTu!OZׇ\q@}@.m'NXı_| U3$NrŗJŽW^y=1_7aϪ!O<? ?fҤCX'K51fǐ' {.K/xsū70٬ySGcyg.G] i{t~MM:F]qXEQCy>4>OrT#>< ?s_Dݰȸ =A_x Y$k奚_ѶiQ_8fO3Qr#~w*˯jX~;)Ŀ֋z--uߧIb]7eHt?v8?5!wg;=w彻$51W+5qŇ ?uX$M7s_Ίz_f<7+5̘'$Isn ‹J+6Ϳ2-yb۫B]/<sŬX^2ne']󅳟 5}?wo0ʢCIMQ޺bhoՏܖ{y%抖ѽ2?<䄫j4瑕H̘J)|_`_:=7?kN*vjdb,dGT:%'J1ム#6][ =s/Όz8Z5g̹8Sq}gvgYpK*`gQG|iȷ4k :fN)nsĝd8n9ꏫ\s!SVј#~V.CCMBsğfeLל%~5<8t;Yst/\S#V̴wM=9S-`yڕ1G<(?'nsc,v[3e?3>\5@:ɋy#z>1eUsBy\qڼ'~rgaOcY2} G?4Suxmu?W q_FvKcAG<,_h[[i,hՉ}awk{zbi,~9舡w$wn#.b󵃪=*gi 9<?6'׹̘#N\/QW~XAOnk絉ykg{m@#k70YkwZr1G|/,Zh5PBrs!ˣc*ZC=vˠ孻t Xru&|a1'WU-k<1O̫ougɅ|n/0zlS~\qRyu%e/?'X@bLh׸!WPkrR-Ѿ 8c˗q^4]7Fyfa47k\ y#Pdc5CDIlt Xf{\户U/buii,/ύ¡{D> z⨚x_ԅ1O|6+!G2Pԗbj5F3юC:P1Wܲ! |SbyMBnX\GlvMϵ.>wh#^T8c9^/X-fRC¾+~xUGEy͞ĖX^S?숭Z*/ w;ʒg-޺DTˢˮ#votGjю;ΒlG-磸Y#NI$xJ,oe;b~,MLIOˍr8n WqA5a7$.._-OgaG\,Qƨ_|Z*z}n7?(ڷOqhǎOܳHV #Dw.W?(#S%~\5NS H:o>_ⅿyCz97Vg/s^-^!_2k9זx⹷G xg_h_.864.{L}дC'-lOB'^7[7Vc®/qS/|dCĜ]qy2]q4#OOwQ-Dk>n%s}+}7Oî܃b|=Gw 2TIS=qʒ_89omXoQ}q,_+8zoZxs'.]%)Wupc¿[?g+ns]928 Ou%^>|a?r|aSeN)rŔWE5.qXC|{cͷX6I<;94l㹩⎘q/1OeC®xųMj?.IY-[b" }a<Ѱ+f#?wƊ{z#4LI#8xg!8ⰛþU'6#rFI1/eI|lWwMVbRlq1<O'NMS.hYs;Ee/q e.-reD+J<5VM}D9r]~1۳xӦr畸bRen IsY%튧ϯaWRq])x|xV,{]ޡ,[<;/%!Ϲ/ /.a]=D{{';DI͒9+[aG|SDpi_EG~La3$?rHlG|ªKîmOfqtЯѿX|NXs(OcY"U6I}Re JUCs\16Y%tfSGTKxO#]y<u 7'ޞeqG0#bIf6W>'^ams;y; 5<w:^byvlGhǹɌA/lxr/lVͷ]cv _]i)"pVBvGv4쌷z 'vys-.sw|"]dzX[) E ;'sn{heí8T_\qAFSY97]QkK\q;,pg<Esr+NY8Whߋק\qfsѾ_%qYW*E|%Es[<'8Ooߗo~T^p ܝ?gExrѮb-~&ΏwWgpoVY~*oa>aˤV+rĜ<_/qRYiš5#"G==sKq\TAyw8 :70妴#neW>ȼߺeww/rȀ(KʓxN1g'-0RX~7$d|-ƫYW$z#'EEy,:숿v&gNwg1$6ɶ+s ߈M'͞*y=5|=nHB^;-^)Ebئs{RX^r{{\ea[JNmw|kI2'bk,{qĞkTdkm]+sfIBn~޼zikHW\ }9,Td\.3p\%WiE<8[soq'뱭9k:K|[\BؿQX.prW+C/ {V!qMEQG0G?&I2:SE{f ȷczssK{FOȷVm1"~X&H|k߫i򃍢YnsM~[l[/>W,Ŝ"rG'p2g8n] kH (E(PQ#.$E 8DdfG\wNWÎar㺈MqsRɭKXn*5,vȔ2;b%?"sR#^! X^rY#^zmUo1#漳inīNJwƝZ7|-[3mZUraG\vz{/qy7UK|E3&.+KGَb}q_)2Ӌ s\,KŒ;" ,5vƟ&"q'i44ggS$&N/;+<"ʩ!O)7 jwFd;鳅=5HT#qh_iYϬlY ywiP?漳a ϗslQ՝/E9ls4!z1?!3}*# tɗxؠƩBua#_~]7lGysTaϽeN/r=*q%hSypa%?wv.n8jCħn 8d_Iȱx,+!+_QE\S#_w3MN%qtG8䋻$%gVlqG?v "*Kynvv*wKDf4nI/dJ]ĊRϻ͒xrl{S,_f5n;bʢ]t[#nŠr^;Sv-~絫cLSPCpc9!Sw6_&djQN 3*sG#^8ʜ/v]IK1K%f$8:@M|oW`V+nlZ\OڮME%^ղ8r|tVmծo~{ ㈡//1(roV,XC%PPOmp_qġ ?<9 ; n͔Yӄ<05zQ3VJ?fI65MuϓE'l{Dܸ-Ni.;hT;-%3 ^&H^/^_K6<( ^JҒz3Kvls-6l*sOn$>}s^Tb%pPOVhb~TC,;]+z>FWat{"=tQv~k-%=n!KQ5ٓnߋzyT/D/ljziКrOL:3n%yQoޛ%Vٰx,ӾIȔJe%YdD}53d4agļVYHwf2?QXhwu{TSdM]տ~jv(W巬Rbޖ6K6M{!꽮gĶ넝׷ɱ{Dm-Λ%ddQ_i$z[&o9"zgz;6,dag{l)^ṉb: ]#_wǥcXjuT}GD 7l)ypKz%v>;nDk8dsnz.?*پpd/\3ߨ)ڳᆊ&vK[H|sZWg I[#qϩaw2\ۋN5?hǎJu+BiqwpغtW&9[KX+|Ŀd>q÷ '뱷s\%$Tox+zOvbCф"W( *qFolQ3jiWl,&9]k-rcGI|[]YbS%YbE9xc;PFIU+:yۆbo펑{5\vĻָ/t_j9ѮWdžmqQ_k= KbѰKL\2᥸+nuĭǣw~튻&7'슑KK.Nwŏx}+~RE7m"W<8į-qC7K<|I&Ka{+Dk%}\׳FI#WmwA-ro[\NQzmox#֛YEv?6Jx9Ikl.ra$fU⊗n8p+'KWlvkk-*rGI+pQd]%viwǿHv0xٮسI } ~pr=Oq ⋗835{H<;+.y6o^#q%QonvOo.q{A+zT➫%K\+6KtU+~`k_v-růN%1K+~fM 7$KaQjBxk#Í+[IWOwiIO͖xʾ}xjk%\4Gx:kl}k֯/kW"ŵ\*KrW׭Ĵ]q:掿? PSWcu KѮTq]Kx,RXM@#`(j),]k36&0_̹K搂= ſYۈ gvKbw74 LAt l5"׷L 7䳹Ig7.f2ٻ)հyԎL-[+]2IYt2}4|!duۖAfba$ f{h0/Ggj&KeBˑ{ l.DLdEiȪl-W<խ"& kfX=aÎCn~Ь C&@?'T i4I&:|5;\>ݰF\ܸ+VŻ䦕Z7*M^O-4s<&0]M9LO HnkC6pxT\OMR"{;˩!W\m?=`$ <}{fii~,C"AdWB$Y z aȽB&E#Uf5Ȫ5'=*?C^Or2#zȃbXbuB?Rhv#?RC?'yoD~>맧)"G/<34ex!qby*4^Hp?et$uf#vOT$;a/iZȮj1ɋJ _^;+ې fHhfC>'s:9 Hdiϓw=^s_! k5#R7]iA>\LiX_qGHYgc ljuZ_O`{zSO",ңsJhskg%𲆤ע0 . 4s/qJfv~Un1(9蜆䫳Kۡy iُ &i,DO7]ϛVr˴*BI]WӼ3 Vj!W.!&Ƚ0^]r";5 qoph1>i]#rR)"&cgrMq^6r ܨvͦIMHM h!750z*guhg;ې@{ҷh"9s[gۦ|9ssf5OFb?XmY񍅤r])2{ygzC ]RI}f6K '|daY'Ys#`=,),2a Yunq8eu{7yzxS=a]rxiWr_GeޔuJ|)u_VTvs+N?8=VCQ.񢼦@kBJYV x%)o<7e9meAvp\j)V ^,O5)pI</Svcd/data/VisualAcuity.rda0000755000175100001440000000065311566471044015106 0ustar hornikusersJAggWAz@r֯F@QgmaZW#z/GIYA߬g; n !Pے!ѡeII]9CZC?%^dV'o$~ݪ3mYtzx@^zJ!ԇc}|__݅SXߕ6Akmf>TH)ρE;Kb$ d_P0NH>Xx+ꇒFApl|}wf5ˆݒJ.V-/ǻ8{N~2?Ӝ^[y?3PPPPPѰ @Hy$"H%2R =z0`ЃC =z0pE}q6x m'xDvcd/data/VonBort.rda0000755000175100001440000000210611566471044014050 0ustar hornikusers[kW{ ЛYs-T\ՖIdRӎd7s-×|g3QE櫩.IIӯiI~}1Y<|X>&Ig|寓į%jgN8yܮ!q]}E^|wv73`߫z kߙ]3߾';3tbc/w{4ynY|]|>6wv(mw&gm;sn|?r&#燑39?F#痑m>r9ȹ9#g>rM>τn>sy?||ԧZu~?7_]ׯ|^-I.,M|dxf΄%wLQng'f7e} ::׎R_Tk`=,[~z( =oǷwv?Y,YΗ_-uSMx(,EXʰTa҄ KܛJo[fC6dC6dC6dC6dC6dQ(l6 FaQ(m6JFiQ(m6*FeQ٨lT6*FmQۨm6jFmhl46Fchm6ZFkhm6:Fglt6:]05gkZV5kڲh9Zh9Zh9Є&4 MhBЄVhZVhZVh%ZVh%ZVh%ZVUhZVUhZVUh5ZVh5ZVh5Z֠5h Z֠5h Z֠5h-Z֢h-Z֢h-Z֡uhZ֡uhZ֡[ݲl~iH>+,vcd/data/Suicide.rda0000755000175100001440000000362414671771756014067 0ustar hornikusersoTer).Xhqah39w/0[b@NKtʴEQ(,]tҥK]t {Mc19Mw=;gfСyzy%oW]jzZ}xajljy]ϵvg[zUfr^~W[CePtJ,._˚UnW\Vd|\9Fk֏._ {Kge^~i;^K~r~s2.]/7]!>̯Ί˗dsw':$y%/<_r35=ǥnA9.uIWƫvK_c2~Ls^#UeX~]fy.Gd=R)sRߔI~rܐ#Y?%yn~=ү.Od^ߗGd|^aS_}2>,eOW\Sw yթ2[vY֋~7 KSwڶ[CқW=5R 7]l.+먜y2=mh@S:}ڼ_k2aWEI~,9O;-ǝ'm “}_Cwsԥ^Yԩ/ϓp\d˼}RS?>驶eE9S?g%+yٕ|~zzǍWS>VrkRIާ:gC:kerꟽOH&g+z֯>4>Vl_s2o[JVlw=n]MϵZkRuq[ǦszM6Q7ZGm\=txP=nom=EMQS5OwͪJzx=j\}F/NVdw|/Tg&՟Gz\6^PvpiVj .]ƺfsCv(>l6y#^gfg]39XLmΡ3yҙ)66cgᱍ!G#>íNJ{1oQDA;a?(m$)gh7zf/jykr ݱo]O癩^I6HvYs:˥T'u=d*i߀-ջ-6'F 8k#FL%l-ZV`Zbk%Je ,0c0c1c>K1c#4Fh1Bc#4}3(Eƈ#2Fd1"cDƈ#6Fl#6Fl1c$H#1Fb1cH#5Fj1RcH#3Ff12cdȌ#SF_. 66C6#6c66S6IIIIIIIIIIIi 4@Hi - - - - - - - - - - -$-$-$-$-$-$-$-$-$-$-"-"-"-"-"-"-"-"-"-"-&-&-&-&-&-&-&-&-&-&-!-!-!-!-!-!-!-!-!-!-%-%-%-%-%-%-%-%-%-%-#-#-#-#-#-#-#-#-#.]t %K@.]t %K@.]t %K@.]t %K@.]t %K@.]t %K@.]t %K@.]t %K@.]t %K@.]t %K@.]t %K@.]t %K@.]t 蒀. 蒀. 蒀. 蒠vWCoG,6vcd/NAMESPACE0000755000175100001440000001236313210522464012272 0ustar hornikusersimport(MASS) import(grid) import(stats) import(grDevices) import(colorspace) importFrom("graphics", "pairs", "par") importFrom("utils","head","str","tail") importFrom("lmtest","coeftest","coeftest.default") export( ## generic functions "agreementplot", "assoc", "cd_plot", "cotabplot", "distplot", "doubledecker", "fourfold", "goodfit", "mosaic", "oddsratio", "odds", "rootogram", "sieve", "spine", "tile", "structable", "loddsratio", "lodds", ## spacings "spacing_conditional", "spacing_equal", "spacing_dimequal", "spacing_increase", "spacing_highlighting", ## labelings "labeling_lboxed", "labeling_border", "labeling_cboxed", "labeling_left", "labeling_cells", "labeling_conditional", "labeling_list", "labeling_doubledecker", "labeling_values", "labeling_residuals", ## legends "legend_resbased", "legend_fixed", # shadings "shading_binary", "shading_hcl", "shading_hsv", "shading_max", "shading_Friendly", "shading_Friendly2", "shading_diagonal", "shading_Marimekko", "shading_sieve", "hcl2hex", # core functions "struc_mosaic", "struc_assoc", "struc_sieve", ## panel functions "pairs_barplot", "pairs_text", "pairs_diagonal_text", "pairs_diagonal_mosaic", "pairs_strucplot", "pairs_mosaic", "pairs_assoc", "pairs_sieve", "cotab_mosaic", "cotab_assoc", "cotab_sieve", "cotab_loddsratio", "cotab_agreementplot", "cotab_fourfold", "cotab_coindep", ## `normal' functions "Kappa", "assocstats", "table2d_summary", "co_table", "coindep_test", "grid_barplot", "hls", "is.structable", "independence_table", "mar_table", "Ord_estimate", "Ord_plot", "strucplot", "ternaryplot", "binreg_plot", "mplot", "grid_legend", "grid_abline", "woolf_test") S3method("[", "structable") S3method("[[", "structable") S3method("[<-", "structable") S3method("[[<-", "structable") ## We cannot do the following: S3method("rbind", "structable") S3method("cbind", "structable") ## Instead, we currently have to use: ##export("rbind.structable") ##export("cbind.structable") S3method("str", "structable") S3method("is.na", "structable") S3method("length", "structable") S3method("as.table", "structable") S3method("as.matrix", "structable") S3method("as.vector", "structable") S3method("dim", "structable") S3method("t", "structable") S3method("dimnames", "structable") S3method("agreementplot", "default") S3method("agreementplot", "formula") S3method("assoc", "default") S3method("assoc", "formula") S3method("assoc", "loglm") S3method("cd_plot", "default") S3method("cd_plot", "formula") S3method("cotabplot", "default") S3method("cotabplot", "formula") S3method("doubledecker", "default") S3method("doubledecker", "formula") S3method("mosaic", "default") S3method("mosaic", "formula") S3method("mosaic", "loglm") S3method("tile", "default") S3method("tile", "formula") S3method("rootogram", "default") S3method("rootogram", "goodfit") S3method("sieve", "default") S3method("sieve", "formula") S3method("sieve", "loglm") S3method("structable", "default") S3method("structable", "formula") S3method("spine", "default") S3method("spine", "formula") S3method("pairs", "table") S3method("pairs", "structable") S3method("fitted", "goodfit") S3method("fitted", "coindep_test") S3method("residuals", "goodfit") S3method("predict", "goodfit") S3method("confint", "Kappa") S3method("plot", "goodfit") S3method("plot", "loglm") S3method("plot", "structable") S3method("print", "Kappa") S3method("print", "summary.Kappa") S3method("print", "goodfit") S3method("print", "assocstats") S3method("print", "summary.assocstats") S3method("print", "table2d_summary") S3method("print", "structable") S3method("summary", "Kappa") S3method("summary", "assocstats") S3method("summary", "goodfit") # loddsratio related methods S3method("loddsratio", "default") S3method("loddsratio", "formula") S3method("coef", "loddsratio") S3method("confint", "loddsratio") S3method("dim", "loddsratio") S3method("dimnames", "loddsratio") S3method("print", "loddsratio") S3method("plot", "loddsratio") S3method("lines", "loddsratio") S3method("summary", "loddsratio") S3method("vcov", "loddsratio") S3method("as.matrix", "loddsratio") S3method("as.array", "loddsratio") S3method("as.data.frame", "loddsratio") S3method("aperm", "loddsratio") S3method("t", "loddsratio") S3method("image", "loddsratio") S3method("tile", "loddsratio") # loddsratio related methods S3method("lodds", "default") S3method("lodds", "formula") S3method("coef", "lodds") S3method("confint", "lodds") S3method("dim", "lodds") S3method("dimnames", "lodds") S3method("print", "lodds") #S3method("plot", "lodds") #S3method("lines", "lodds") S3method("summary", "lodds") S3method("vcov", "lodds") S3method("as.matrix", "lodds") S3method("as.array", "lodds") S3method("as.data.frame", "lodds") S3method("aperm", "lodds") S3method("t", "lodds") vcd/inst/0000755000175100001440000000000014671771752012042 5ustar hornikusersvcd/inst/CITATION0000644000175100001440000000401714366250071013164 0ustar hornikuserscitation(auto = meta) bibentry("Article", header = "To cite the strucplot framework (e.g., functions mosaic(), sieve(), assoc(), strucplot(), structable(), pairs.table(), cotabplot(), doubledecker()), additionally use:", title = "The Strucplot Framework: Visualizing Multi-Way Contingency Tables with vcd", author = c(person("David", "Meyer", email = "David.Meyer@R-project.org", comment = c(ORCID = "0000-0002-5196-3048")), person("Achim", "Zeileis", email = "Achim.Zeileis@R-project.org", comment = c(ORCID = "0000-0003-0918-3766")), person("Kurt", "Hornik", email = "Kurt.Hornik@R-project.org", comment = c(ORCID = "0000-0003-4198-9911"))), journal = "Journal of Statistical Software", year = "2006", volume = "17", number = "3", pages = "1--48", doi = "10.18637/jss.v017.i03" ) bibentry("Article", header = "If you use the residual-based shadings (in mosaic() or assoc()), please cite:", title = "Residual-based Shadings for Visualizing (Conditional) Independence", author = c(person("Achim", "Zeileis", email = "Achim.Zeileis@R-project.org", comment = c(ORCID = "0000-0003-0918-3766")), person("David", "Meyer", email = "David.Meyer@R-project.org", comment = c(ORCID = "0000-0002-5196-3048")), person("Kurt", "Hornik", email = "Kurt.Hornik@R-project.org", comment = c(ORCID = "0000-0003-4198-9911"))), journal = "Journal of Computational and Graphical Statistics", year = "2007", volume = "16", number = "3", pages = "507--525", doi = "10.1198/106186007X237856" ) vcd/inst/doc/0000755000175100001440000000000014671771752012607 5ustar hornikusersvcd/inst/doc/strucplot.pdf0000644000175100001440000102010614671771755015344 0ustar hornikusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 5561 /Filter /FlateDecode /N 94 /First 803 >> stream x\[sƶ~?Bo;R/RT bb 90$ 2Ҍ4Ʊ)3H-V^KnI*ṯW WaE 4*BX 4e!pWTօfM mw!rH @SEa B`mqzpBy-J9_xm]SoQI;$Xf8eF Jm/qq񩨋NiA7YfD@YI J$e. W5(kAOVIX8+4(YiPβBe#ꀲE'\AP-$gƀ2j RCa*: (;;hXpmw T`sqA=#Ġ!U ^@[4 ޸EZ@ f08fIi`r Q2#BeeN PP@kAYh@̃0'Po|}Qh9*6+jy1֋"_ޣbzl^|V1cPf ?!NNG\tf\z4^ףX7\7V}rgs[D,^3uz}p>Glz0Z7H) 1oS=My?構YlxQ6\:w&'_z>>e陳Hg96#ӳW:Z6?XV[:?o\_,D'7eퟵn7ڿa;/kl^fjܒh6aui@Оjߥ[Z׶dZG`b>;]kɋl\—Z UNV,/y $(X r2gpNi,Gi-pm%dcBq3$@7WK_Yq50g#p.CV?M`8YT wNG0ޡ"pL}pz(1WyԎO\^4>>ǣNX"Y$ oK*#Yyْ:?ilIILt?b)1|;6ղNgK$N,Ob<3 >OaK^:*L>sZyf#6zr<+/]~ъBvrNqavdі axU0BKf 9bцϸM5TA XKT,i8(:Z.؀Wt ?}֊Ř0K?֓ ~Vգqc:Ջ:^V߫QWl//GiUWg٤ >U ay=&՟EuYMY5Շ 촚WjQBjY-u]-?ϪU\U]`fbfU{:mxrQC.~];{NhXw0,Wp겍;r繡rٽo4؞0]L putGn0ݱd8Tk@ ԍ &j 1JF#]w$L$hCQچA҂j,93’Hna !GBmalc %yPޤSz_܇$$Zadiqsr˸l)C9/ER?h@%,q(,Cka46Wg~z`Hme?PБ"l[0-L 5ko e'CQC |#TiMM7܃{\ݳ~n_aW^Wo߂Ny,%b4=y7j-Z񑁓<-ΫzW=7EcE*4b~8AC+(&jO]'r!>Jx1IM^EBDټnxz>04(}b.ceLewZO~{G߫\ [@)?෩.D[\4ݞČhV)BEp8CLQC)Žgmjm͸*`񺠀m#q:PEortxVOF]T*-τ1"\^<~X}qKa/VSs)-mDP$"nQ/NޜB"% Z Z !I=xJdbC>x<}d%y^JHCؐ?6i4i}-lE+Jk]#DBD~.v$΄Dh d GASq=od?4Y͈Ix{2ck} PN Uھc %8omJFu1fվe8#J~, OƖ4i\'SZxm8/5~z8EIJ%R}#ӯy;+uiy]c GRx뚒Zci^E|^voD&Sf !R*ѷ6y< 4IG?Av6L&Dg̮lxQ>n~ صcfmߵ]Ծzɯl|Ei7wu}0öE{x2YN.NkRx'Eqyuw={z神wНzKX~Nn4 QկOƴ/}s\~wU}].e9>aK"72rQ>/f|yymLH0ْގ$0zY4:Khs]Z8Y;i(Ei|ZðC` Tɤ^צr`~rD%g.VY i.-ri}:͓9} c\Bg;ZLҋg u4' ݎOvT# R }OhIQY0qCup`LxI7錢*:E-K-n3 t6 .;#-ĸ-'LL ~\Z]2sp+F_$li}ڒucw{3z]=o-,nL;/nj+;"/h^z& R!c$}\"@5CW/mMg͇6_c'luyP\]dRsɶww6t *rWKqu7ѐl:M^\̖y6 N>T[Um-h-В7sMm3D0QUMMyۜ0AMjJ';?Ǭ_kxy^`%}IaN 󶙒f& Y"LSmX6<)JW` }3֣Hќ<&oZw{37IH1XexʻwoFq JII]ӎ컖.(pa `&vL ǹ1O<)ڜDPyi\Iq Ԧu;FpnyI߷0 L-()A{5;`;zґӳOf0_%~A_H,Adq76Sr>=8!;Xv0U/3U1ar7'̧N7Sa)-D^uoO>de:f45W?nu O$~IrN$1nCOqϥou`r Iv 1 OU(}#2 s}U4}Ó~?6דhHyq*u៮nQ$,'$HUTZsk9J]^I; kyF ~t>gpJqa-ѣ,5endstream endobj 96 0 obj << /Subtype /XML /Type /Metadata /Length 1665 >> stream GPL Ghostscript 9.55.0 contingency tables, mosaic plots, association plots, sieve plots, categorical data, independence, conditional independence, HSV, HCL, residual-based shading, grid, R 2024-09-16T11:01:31+02:00 2024-09-16T11:01:31+02:00 LaTeX with hyperref The Strucplot Framework: Visualizing Multi-way Contingency Tables with vcdDavid Meyer, Achim Zeileis, Kurt Hornik endstream endobj 97 0 obj << /Type /ObjStm /Length 3580 /Filter /FlateDecode /N 94 /First 872 >> stream x[]s6}_v:!v:q:lfIEfl5Jr9 )ɢжG&!)HJ$*\R"$)R7e+I75*Xhm0(YhѼRAF:S[-V|x4qxPDTLea3( Ѻџuj[XO6ZJ¦vt(2ct TBu# "Z6E0)D elh\ SgPxOh('SYY-y)Jp@q+B [A!EncC6BI/|$K:(0A)x>uɟ3"$ 5ͱyImdu!iE|V/UCh5kD֠b, kP2T/SGݠn6b!zad\nZ 5uVB+a9*** U4T#kdK>GeѤ\DEmL׏?bo2.eq5^_msu1nϽ+ģdQMКm/3ڗsɕ,0x5BQ |65WZ!~!^Wh᧟pbSr͠\3( ʹ-͎@~o:4 S} ʛ-Dh$\}smbsM[v5n5 &6 b t臃yO߼_,NJ>8ǃY!~ Gq lxteq5Fg,/]8T hqBX뻥lTo钵E-d8 WLĒ"KLuVLwX} zYމ xKHĖd)Sh@-]}j}ݣH~0iiI  LoʁHD4k 1[P&2fzV\D-( i@]B î1LmډP{*6Ȓ%dK%vizUV8 2Ϻf(60SFү0&vIVwvJ3P ӥC0b2X^$It YHn/e-iX}u=jU5cn7ٵ+& 82?iLG<$y6ųL |w'cw۰2ƒ5sX}FbrU(=L NcLduLbz.UgMD)AN7Vaullvf; 88>lm!m&]M$]XEuâ`$be?,įϖ 껓B<:{Y<8MDtv,3eFy4M 7AZ|~R\KR @xऴDi7$li7/((C8Vכ(̙g/Lk<u]EﲑՆ7oxjZ;Fwwm#UV{7c0DٖꬍcӶxnΟ\NBrA݈Sܪ|* ouOKR^Gkw^:z׶1uZn-˴Şx(g/x!^_+q k)^ ŸhglO p:NđDɄ|F*K8'I5#(TLd44L9Bn>Սu>]TGP4s1>賘1? +Y0\O&"T酌m6us]L4uN+34!.3434m;G:3By5Lw6;BL<&;fyuJ?/@[?mmsR9%헝[ϥka 2ENR0@geH Pg],}ϔy;#/f] %ߐ؍:JFe̹aL. Bw y1~dLpw?1ӌrS$!0 U0oRvW5A0|*Ypm߁ xA0fNv&nˀ)w`X 0NL"PAݒ;j/X_1 ƌ\w.P1>|`4n ~'xX$GBYqY~ QŶӢ~i{OzFendstream endobj 192 0 obj << /Type /ObjStm /Length 3238 /Filter /FlateDecode /N 94 /First 866 >> stream x[ے}W1)sT\;|Y)(.by\\GH)][\ td Yd 0& JF>J[hF*)*9'PA&ة(86% *:xG(vTaXJb9la;T7FVwZD!:Ra#+kI 0ucDmGt}a!.YУceb?ڢ`aTk0)|\E_>|fP`}0B@NhPV!u!eF"J2: m@X@!l*bvrH+$Pd1gdK΁f Ӆ"EOS :ʆzAt1SCL4c94+{ dDX+%Vr"` K-|1Ќ%#gdDE~a 10adVe" b KJȅB|EQ>UswY\d)|}SOu5Gm 1Eu9<^|@{r XJOhPغEZ-ժ[&eFGO=|%Vmh"Ss3c!E=)\u^54F\tcq1O">Ԅp׆j_jXI=ܼ|_ϞXLJ~~Q]]OE|ͯ:C<-W'RaVrv^,1՞Oڵ^޽]ISr -WSـr-]_W%)`uN'W+X>ge=g{śͳue 8ѷ?YOgG늃VNB^庺y c؞c?/ղJfܠJ#$dcE5eEp&`AxĊg_6e>:4)+hmabT2  :*MC2Nd}r%ca\Z/$b! ./q}g%8ٔ 6ei RS^A^, z[v|5= W66q&ԿMn}]ow]YWy@˖6-|]NʷdKޭ7%[U*gu9/b^\.ʻn]M˪Ҝӕh'4ƾ/=@*(U@ rXu?5<>i3ҡnGLExuww$v^_c Hxc8W *#a;rTMTP!Ƃ8Jxb?[8ĂN tδTQ-Y?seثE}F ҘIo^Ld܄LP fP& \ݎhЖnn0y|̰*r 4bsi"=f_~Ϟ%j9Do,@Domh5D{5|y;Vu~jn3~kLk <_?}ZN77aE6gӟKf~Un' k^Ű5f_{7)7Fw}Wf~5=4F_rT`vT]g-@8O zQQ]23*d3hP,=C D1 \2 fJB0хG0FnMdihh1cG233"(7`)e'`!m; ͬ$7|HDfKShΎATo 0RxK9 .$s JgLI t;vw b ]̩FoQK-Q^ؠzJac0 ̲,=ivdmiQ$3 M=vV'F=z:GCCR&yQˌT-3V\sC ŀ-Jyar"3 LhfNWɣM<;-}.?,aV5'mtu_AW"gNst➫rq^Z;Z2q,o0&-k>0ڤ0b[`E8&virflR? 3}b< 7g3 `Jg|LL /cPIX̩,k1X&b1tN"lc&9kW )w0vY&Q˙ H')#;[oyX f!P)d>);Kt>p>)h~};to׻un[Uټs"Ւw_\]#|&o?oU_ |F<~ڊQW3V}ϚͰHHe)k rqy7]_Vדd42.Vnv'T<[^<N0pH Y2mǝRds48c:d]@Ѳ-e~8r{DgJs((̪J||B_">19/B~2uzIi / |Qu~$dZ7Z!`Zw8&L Z6^zt5 w&bxrasyϽqsI| ʏT@CJzK:Oa V,nim-daF't, 8v-JH޽D?4ym+#=./:^ᨩendstream endobj 287 0 obj << /Type /ObjStm /Length 3390 /Filter /FlateDecode /N 94 /First 872 >> stream x[Y~ϯG}T_aD,ȉe8?)\g8).WQ(abja=Zp5"iZPč9tM^&r 0*)/B;nxPDnOS$&4%9l`- ZZK"*7"6QDgWC$-b"LI1xL K;(I]-%)-7" 2 icNtw4"xwwkmYshbx̡;̡k=0Ujj=0LZ d B.cY|Z~|9 o0xe - } 906AF ɰ<" ZΛ|=[߮v j?ٰ 1ERIV77g1{ܠ![gn M.[f~v0/Ow/w7쪺RʑR>)f x3oÐ6g2 qA.&2h+& tYBE )nr]}Ϟ4aрIqD&5Krp !C2!jc::3 a87$.1 3Ljk'.`30Q0{L s|C~@ LW})c=IĢ\bqv2'+ᡇ.2|e.c-NCw̄L*"$I١4b4s(,mm]QȬ { }b_ZDϝuőǼ结l4]ט'O!4*w`:~ oߢ=y I7 MYW0m$҉hx6 ުLKԀ!¬Mu옵mT'UYOEYQ[BbtFAh#MMMJCd@@}R{:a)Cvԃpm2/x4&$aaNz\vQiU46?Ias戆Nf ?\dt5>Y0ࠝ\4QI۵QeசbHH+܈H:By_i ?Ff]O?HsֺQ|[Xc?~׳/J'|#f_Z\=]mٍ>{VзZzZj׷|W3\l .x@$!vق={6Z^i1j'>gէչFf~E XT#]<˛ T5QokZn`[&!bWNpzsYm2Hp.N5RN&/3.E89J#*T#krkj=$$ʅ}@-DXɋ[e^JJW7> & @ѷy՘3 $!]P0ݪ8hdey0M'j1@i-N`&y0o#0C-Y"} LHawL>!qhj!QBaAi&;+~ $O7*kk?$"yOta^Kb )!ucu>ߌܓTpADk2E8,?wΏ) yNVd@ ,A*;ewtay`/w{֥]eZ M>$4nFan!C)vɻA} HKk57TjT6m5l B$2^Uy#GEE$-cԧ j,Nm] Vpe6OoqO@olB?q7Q닁w%o8w=Rz2/oeW?!t6ǓYkigF)!aD:) HN޻4':xRud"B'7)"Bav|k˵ȝ܉ʵȟ&8˟Owql$/!3AV9we)Y>aIF*u ٤!c^\|װR(S \ !^ q¼T1,\`+>*#CPO<ȳ>`J X*r 66x1^!ie-\Rȡl ApH#麐W0NsN9zɧ,/@5Jau9nC4GX#tY{+#@qF>*dTΗkȬu/9EҼbhS>%~r5ZC+3ΘҸLsPB0!&b&$V_8TLvJeO<p3tދr2l )Lܘ(u.1Ȳ\;z\ <|)鮯D,|{ܹl·gl,z!8;S[j(gL\{4pwUxKPSpLC] $L4Cv"8;{fz3ELm$ }lն8tA'aV )NBT3N\38Fm#4K8򯋤oJ=:*@(4tq·%&z< -tb\ґ:҇h`Y/e^B5.Pk.yL4 z{ΛU;nuP28>Rxx-fb\W/ov=?/۬{O8ś[c3`,,ॆ`=2G|ެ>W=Է2%r=y˫ z̊SHowVm1endstream endobj 382 0 obj << /Filter /FlateDecode /Length 4941 >> stream x[Kܸ>{7nFmh xO=sL{akZ\գEVKC636:H$||enSW|S]&w}7I\0ozcv?NZ]յfߟ_{>ԞuVrxSvnwuU+oŎ׺Vnv09~‹RKqColwi:Ͼ%J#{؟]RslOǸdž:B3H=^]Ыmgъ}hohN\UvE Xi]k#-hcA6@!;)Te@N jN$  lo}>Lmm^b/Q DۆͼiI`mA!{6*5r+*D(k7mDJ*œ6%p}}m-kXHF3V/Tj6;.+ vaohruǹ:f[0nwƱo`q.5 |IKqR|ܵ iWrwpoU~B/_ Ke7)LJ;^UXJ n(q؎kSIARAAK1vz\owQa5#X""@^PP-8-}>_؁8۷}>]!&I,|}~G2 `@?Ic}| z}ι9W^: } ǚnXe8[3v-XـZz!ؓY@ Cg KV\d^zDO)s{0-um=sWWԨ[~% !pC}aϮ>({~{X!9uH O F)<\Nb5_mPzctv3qZp̷̤'!)[ ݠcL-0'g-q ɭ9Ulv<]-`‡ھx 1,HhG06?Z(۶ঋ[6(܂w3Pbkl$Unn9KupL5v|sqdSߔEX5r ) Qxm&K cq=3JQW27tq8<pQ:51DR8SiC!YEl̲MPL}(pd 8~5b>mF>˩'VJ0$9m>w"%r9C6%VGWO|S&n#iI;3:_ҫp; e087g=sB!uvGF`塺4@ɀTĒ*}Bg)#yѹ3!=H]0]xOg6l݇APm}bFW^ĦS*4D8_9!1'֟O+@7 biahhNFEj\iX QY:vt5'Re1bitIN_B%ڜ>/Π)"iEҬ%Ͼ ; ˈ) *S4`7` |hgc cacij b> "@AY7HpeP:N_/`!wN׹:'G)$bh)P!CB`=8 >ux(i40M:o`\-ՃQeadUΙ n+uR+h̔!AAo)Sm#m$kMkCC)+Ƥ Bq-'i]<.P8zyj1t? шoWJWʈaW5UJX7yFcCAS11ɕC YxB wH>pYE8i&im#*e;}HrqXSs!ESJJ&,uBoы`hO 5|NYe@NSYW_* Y"F7TSoY##aY †> gM;Hآ2Ԓ;T/DGD0pC!XOR1n *.@X #OBZWB7`fFq(U`-`7|=~L€" 3_@+z}oGD|8m0cU8'hK槡|̱]s>uq!┇lkAqw|b;)F(Q0]nÚZQRP?J|#46AX(Lr$~%O$VIP>*)y¹a_M0F>B(VbiVIGuIghiյ%x)dA^z;jT7[Uca">i-ti{GyG߷}}C[Ÿd' Rczi>t^$x}dѯ@wDh.72Z"uӝ;w6I'ʠ㜓16.HԦ*Xa`_vGtS"t̒3 ѭ;- $Xp Lr^q0_^;,lN~Q /Z\;a0c&PY)vWzL=}ҏސ Z<Ύ)n'ɢv\DM(KW\ Jrla!g Qg"u91gf>)Yl+։}{\K.fԀa<ݧ-Pϲ-Z|ߞǏlfc)cp?'7Q6[,*vAiC9O_p#+cF(]y}u\`*€^ԟC/QPXkwlwb?z2]%RԈH@}8MW8,7I OT%nUY#vyCN`/?Q U+8-td]$˯v: A+P턻Q\Q1n',[O\$_^m=.cY4|\Laڕ#?lw b>[j@:Eg0"c͊&BlF vyXȍD),U?q.;&3MOmXfS,FM%|#24S$(!ݿ+j.=O$ްHVXGV=`Ls[W9 N$NVk+Usbi=?2H R>l.$3JpYlw4nE5Zd6;4w6 kY2ZLAr_}^Ǫp/*l8+ >JQy;Yz*Oi*퀝!(a},3" KR ӨedFɃQ}Xֱк`.RJC];4.BKOjXR&2/Jΐ.M&8$9Ǜ{ zN6Ct[xwE.V8ӋPN{>%"y& ǡZ^1!%E10}@YAIR-0 L~@wCXn2LqNՆlLUR(p~&Zf7'}I6wނ,۫Ze早 in6XblVr(1>8}|NYȁsھH`RW*bqiհ4ά U:ua@?3~eRxLxQqLA0\IXH)42QUj}~D?g\,۵sV%ny->,;:2xnctvMBzu?tB[bpXrFJ8Dg22_QRxk. _gHo*alЩK9QkqrD5)+[4O]kI2l-b,]#Z/OIYOOnr >ƻkCR;̴Sl / jd~tJ{GM2S¢V~6 TE:Οrc_/Gendstream endobj 383 0 obj << /Filter /FlateDecode /Length 4373 >> stream x[Msȑ$fOmAwAgFcKa5[-X ffUUhֳ@˗Y?-rvZ?pRN~os8}vyrJ*xEN/ߝ*ԲSL^ uzy8ɤ\] .scT: % +lZ !O^-JimYˬMTl~Y++`:k6qm^0iGY1ʭnz_qW"Vem{WU{ iU*]9,fn )]J!87P9+pQE,] gLx\ǎJѺ鼴2kލggX2_uC ӫ3,窴fV}\X,C7g82Mw8 Ov3Î amggs-sZKe̸KX)ǝ١qd7=d؛o,-@sVmek[:]3Wr7۝kC)єxj1fWR)(~n605C&֫Jݲ:]ƭ ~ƮL0c-4;c&x^0}o79K\yI }#~Q_\682옍eE4Ґ̅5Ek+I'xYN㤍"LڵQ%\TYaiwΚ7c xBd]+Yf^"|} zr@mכxLCO''iCV*׳% ~?yʣFeM8ynbmV}sv!à0kbW^:ƫFH5acPhOv&p 4^4+ -ro0&T%;Y *'aMw(Ƅ1iRцu]#UL1>(]؟Qޕ(K0NDuAdk3?61KN M; T2yV*8rg|xGI(^x> ᑡM*7PG^pOӊEb86(]  W udaf qiH-Jڷ=8vuₓWČL #IaAy@Q&t)0}7o}$bNTATR4:V 霫Z ZMi/%bW `_y t$&Mqij4v>s͒ [s@Xs?RR{F50 * 4!t!f55C o}ȑMÌ\4B873b00ǂ3=L")c:_ miJ{<#0!6" n d3lK QX@<{Җ~- @cs'CɲTQΰ(WeIs@HȻ&r]ͅk Lqa`5ِ [>!kgn/D9Gi4H&=dո"sV}ӆ, DW20mMGOdOj.\uBfm*԰XaSt/AH OX3sHzHC8KAjSjwh2. xT&R7 yts#Bݔ.1P[.mכmVϨ\OgB'n 9!n.D>̿xN { L<.ĎRX=pP #bz^^q5#*! 2>DRC ʮi/?QgU}5̅ b*>qU2 -J{½I z*7_ q|Ob_x6DnSװVt U<}*DK6|`A`Q/LFe*ӳu-o_Rk!-e"^iTjL` |m%o'8d|pnJPO|~#Rm98A!~pzsyI l1+D,{T A, Qbve$%<&T.v&d6swO6%"9˄NُX][-0r߂ސ@? +QnGnj]ETVGYǀ8wM; m\XD+71m筶ӿq~#Pcv&w)է4 nu|D 6e'%> stream x[{F9ݦ ݾÙq&G쮽XR()BV4VU7.TЏׯi]ϯO?O$==_>;;y[xR:ӳ_NyjU:z뫨U3Sc{1kr6\3sb-{=J:4$h#闖Q\p΋ .ͪV /VMNnɁF<ʼn0~v'sc\*8߈7t6DqF*(BŋtG0Bܽo}yt4!urʰa)Oi},&N<0⭐1j6zw7xQQ9sֈHjvk>h)w4[9+5h"2ϿjfKhy2FT&qt.ueMT)wmܖilk-hg迡Nwt?HIPJ4FVG2}MF|o_O UAS˅w|Y0/vkX$^ы9VnoWy4Yo.9xIވ0^|=> $y#|9UVC,JzAg@_J* *oT; [h"A4.6GLrUH'-sKq6,I)jX7P\IaCJ0lnk NVks jovx? DE]3& +ѴA\ErH3{hiB_M]X2<dp\NoT0\^z}}vnT*3G liQq<~|wwWuESGdl3lQjZ {d`o }A+oMC=FQVfc&nFO4) 8$ަq/  esgv~U ex=up.+斸 en6GFɛ~8OWltL _eLKUn,xLȷt]KI7>ߊ0#wA0x䋺4~hŦ{^ݎ"gI7kJ|18"WO~J(yڔ+3X %]us{[f])[o8?_ { 0z/rCLcIA 6j0.nq[l@08 =9`g < y)| fXn+pfcA X8v[/-m"@m"nxdэ@Eyj$ ^6ESDzvp;p_wV5ٺǯ4&Sio 25zZ%7 Bx3s F\_SK`2ov^W#+,cԤk&}^N l|\s@UӪ4e+[r.NVZnu_ԻT;oQ !x++]ΘCJ>6 ÃrIPb/0P{MbX~ L/+F$NX쉘 X'N &LrMe$o @J&bFX"2Xttg/OӮga߲AKq IrD?HnUr8rB(˖;L9C|Gd?i@^,N H;F &8<7hQL߉5 SnMQb"A җ*u)*w SmzxpP1˴©!f$JtZ y+5Y 1XӕQ~4z3/|g fr]/uF9A^&{bATŏ\1Dsd`9m.@b)Q^d$'?ByjDօ>$p=x> X'dXǩpNo9g  .d2wvfZl<&UYG<\/OfaYL+J۶1(`3cb!d0!oIevX)сN BchCOmE ` uP:" YnXT  VLfs*NS둔b8k"4}=C\WOғQgY9G,QǑY0{Ii)*j*V4+ĉ@ZγI8nKs ;{ 3rvm1Б!?L,? rC_pkj#ue E*u !N;KR[BS7Y:eAڱ.Ƞ5SX`ݍVua!r6(a7`I3WRu{EN)OW~ҿxQzf͔_Nۄ‚j8$9O0c,lN-ې)x]P)O֔yss~9 RN4 : \z5-=tVVu e9&҅iQu| P 9]#"K^e3xl{T`]2|R2b0jtG&&T\障Ų МX=,}b+ٰ 6a??ĖS&}Dz@+;Mf.Q' G\:l :G\+u^ |(YRXaĻ:Ј_ ЌvBDJ7o˓|oKB >^*!Nף(=Õ[-J jiXVrg){I'=u/wSfOv O Hˣ3]28<Z`gT.p^ۀHG&Z)c{Pps3TJ*Kqqҡ#;k5k{29C \\~%vBT(\=/VC.QMJm|h~8^XЈŗT1`Ql]̇)`ќRwP#1CnddpQ!*&ŷ2qWQ?ŪTƛr0/[WpUbƖsdy1zhT) 6uNX^@e;D0Ni,$5q}s ˔ɚ _HHW(7ET(l#hxKP j7@>]7mmв`ok.ݛ%qG &faGlX{B{zGF -CzM HJ5H{j.pGe~G7k5'՞R#]l5(bFM{V"wLrlOc> ˺F!iJ#KRS7s rCEm[ OS %m(eX.5%}<rئsf6_a|X zY2mV<[!Ht/}tbƤMSrTZlm}NFQ2&~ܳ vy ˡLAC!n=>:8u ~H@/8|6}u,Rr2EMQclebgO/5~e\ ۛXQV5v?+=f+m[ЌxrMwʞQ`FXC׮rp C>TA/LAs+x:=pLMBP/lQHivP.8W_PBP@GP; =%Y)_gBH{endstream endobj 385 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5426 >> stream xX XWW* M}5{DQ1 *l ڀ 4;݇DVDqCČ[L21h$Ds /yn&N7oWTW=?J` E߅MxiaBCin=RB/3^ľT(|6 MıcߩZqã"a-}3< Ҏm ׆kmZ]={v˽Gנ~a eլn]0fâ7- \,8dE脗&N˓_0f8a1/fy c2f93Yb| f 3ˬbf1lƓ`0k \lrRށ>T.12`C.JlÑ>I=Ɣ:i'"Ra;1:=*FmMa9X^$cul J#O`f'nOEXP \ "9`>L,|Po ``W3Oͭx\I"G#H4'r4R†Co wzL1^.B?ST8qZA< m_k<1JjQajU@T2;>ɆE6'6&C}ӍHid}6g{]ӄ5xѢ+ñ`_HĆa}Ǐ4v{%$wj9A)ە[ߤPA3 sk6NĞnC;*+t+ʫT?έLlB-pKӽj3pۨW>}~Fצf$-.jDQ@zSZd+Xk.(ΫJi$jTpj5PPy2kvYL͑)] 嚿s%+ 4CRJZxVdAo{m*Ś ˿ !mp\4$fhxx(׳?])#M;{T6ao6Z}}ya!r޾i#TNnZζk7ݠ*KeX۰qKmOl\Q B=!P'txyZ-2]t-i2Y#EIpT#qxʕޜ6=(N~xna?U܀614ӍH.6bGk/=C :ڈ7?&zoLhҤЎ҆'.k9MG|=Z)FzcnY%A AO:It8֗ ,l7L1oӱ;}'>fiJ2^:aeO{ YudÚtt1TQHiP/9R(MUJ+qeܷ{'=XXK!˵$ELF&fT%\evK@( k,"'؞#!Ym/Y_Ia4l"ђ_F׳'KG5>0';MߕnpԲMYp cT,5=.ߤ4 y)-6Y:^6jCMvNgX,IƷ{<88GO3]U$5K?ZZ_RwFB-Y~5t]^_08DH2 '$C 0Ly3"hnu k7z?GKcW?VyZt,_eӭ<iU{+WUfy&‹C OV=EF_)M,qW|b6˒tzlrxR )^̘TcLW B|W qwxh5,s4]3 Y[/=Y;9Yg<ɺ"$ QU1zQpb*6ZVqkCr4;cKw·Eۖuy..WŒ|quRuq =2woj*2R (()ɦQ9IrI矃Z }UKZf:\åPAak+]._m2 [5+T6߲R ?-g;ͽ@gP*twJ@/1#6ڔkS чHz?Ark Xѭz %{V;cwz#uqe[k<~-AxR'S-3M"'֣#3znuJlk;qm]Js-Fs;5 ! \+ߒ~T yߡcu֣"śЧ=JAԭ(}(*_@s֜9xۣ2pX&v%bȈzڽ\{z%W˳쭬|wXy B_n_rߌp6s`"3/hf 5h["gŋ`?γjv)y5*;! 3R3 U Qydal8+SSS!0{I ߒSn.iqJn-+C-LN4xQ0GQyGC @..~(W=Ѯhj >&#oR|݅څLH~`VwА[M|;Io 6MΐgGKT$\b:kofNc^I*߬u>U6&v )lN >: }⑲ \Х ۥ(F{Egm R~+aCkV^ht0wߍx ][ls^R2c05i$]I`Y**j |ڏ؏Z0fmWym}鉦ҐLDkf)ϜbNCBIT|u1;)\ךqGQDwz'\Hݏbj1Hy8GoG|MW}Q sE!vS^yՇKNZ-6 YԵ~A[q(S19 ߑE)`uNC56Ka-ªD!ioXG˱/NGgҖ)?lRmm*M1F':N'=G-%^\VٗdN3;4ja9=7G/o y& &}L2of'Qq\=y<t8('O PQ)M nǨ^3eM-G/.\V)ug8lk~o_d4R0H!ҍo?FgrRV>^.vcKѡ[6Mj `g4sy_v3*t˳d}JWԫ "|Xmʂ":7-@7qQ[r>/Z8Dq(1ZU6nܸ9rHZ~w> stream xVyTwdf@eq'*VhxB,mL[KL$땯̝;?8XS. KHd(㴉ʰ᳕u9LVNKKR꒔՛Q!"+׭< / Xեdf q ቫ՚ib* /z"H,#+D1%$~K pb!(AH=qMtbq8_|M-*}]zL|t}xeM[pH)9D5 JwZ`baWNv>,-0r=aE&)G@V@b)ґKHsDcjj ^sp:=D `>Osh/5/F˚=H.UC_ UQ׊|¡HM15H|;t>;ÄEԛ7 ]t5O̧" MO²9xňA_BJ@ S HuxQ/\>`H^mMj66M".uF, m&PWEC;^&:շh c [bӺ岨bX} lc@qZڊ8r̍Q uT/z:k%][2H鲲عl6}L9^,92 HݪςUq[Qϰe;[;{[fwI /UAWJHzr=9]]=-9(=ޫO6\#'RBZmݪڨZ8E_Ȳv*Ck)(kT)>`+1`ku@/9eKgFNEOj]EwB8S\}ϖ1[s΂\T]MlmOMu@w L4" -*]I i9C9"R}!O-;M,A^B*ʼPɗh twi|Bn>D ~2˵LH؊]FBū2Js$1aUDiNڌ}0luUdM`>kE);il7 ڐ;zb^@ͅF B46P>//X C@wDTh(<݄a*~ţ}'ZXl#!R ,[?ڏP`}G%vώ֞}g`L 9Eщ),rPϜ1&!jk^M$",@]-+IgjsF-TcO/PV~DBSxQ` 4AG=̼ۡ-^4֚sO} {Mu}"㻠Ҏ_s|n$cÜ弳|=< ;9H\s3G:!QH,e6*˱Z00 `2ьєmby`%*eK9lCE% h 靷LJy3*Q>$S{kߧ3F|}&9 p?T|Xn"\#wsTx1878鋷fgY u4<%ėat1$ж7 }{zۏB7 :9>Qbvl52$eKw3-v!v(|_gkLĉ'z/WK K5 6?BA+XXi@\nEB<`5Bi~yR6kZCЄ d%۫-h;e r&E1 M5$|bEm !V;fѢob /@cJQx0aM'^!z{B^`JXّJ3Ļ%&m9k}x ٵdFEF+je7.ȑWI+S﮳MPHg6ut4? d`uh(\:2痜W@fKmӴ ɓǡO^̏Q|w>^xysD'6ftd8NOT+%M4wވ`Q?Qy̵&+eǒoR q}A໑e{*2+ܓ'ּ֢Nm4h0:p~5)JZP)gqV.9[Ϧ'nm\+vB|,hܦn+uVn W`.,fMP<Ʋbimc|?b0?|<\Pf78BSţ3Pׄ/rd r3"_YL4'7(azQ X{jS̕3Ɓ0*DcVa&8 Wεx)-#54VZuBrʷuă`]݈ՍU)f#jPLKmyXz;x,6Kuu}\hC՞ݕ:Aendstream endobj 387 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 8601 >> stream xzw\T2 j`XQK"0kf ADI,KPS,77317{?Ǚ3o}[k#L:Qlr?' ظx;Wr܀NB}h3nBfrbh7VZy~[=-'?iwsܱK\‚Z:n\2vX~aV~ήNn~n]Y~jckn툱Y E]7o< > \0xQ%aNKÝE,߶eJwu?Ih3>paֲq6uןA55LfPCUԇ 5Q5ZCRu\j4G6PFSjO-&P$j 5ZJMQQ˩ jeĘdJL$T_*2ՏO DMCm:ST>uIP)_GP]]d)*z%4SpdIKS';% tӃq,輥.#v]nvê=kT.̜n/Y""q;\` fKO_ߡ %YhwvנC\m踡+~?lذ}niç1~d7Gkz9LA[CT|'n5&&GB$(Qإi:v*ƛYh^Ъdn@tQ'idc 7]}P e㟝Fi)0p u\z-jlixﺨBϒU069-g~W@7}-#a rXDނLȄ_"9엡e.]̶aq;wn6VϾpPvG_HhfWM@c6›ޣ҅@0&''ȱϒb K&f@  jI(N(C˰AĨ0C< p *2)hr8^MĄls䱮$#+:`0Cft2T9O^/l['rM]VN'?a"q0x B$K7LBT,%|ZY9n_;}{6% z{H`W3**IJu|tŏ0F⾸ӡָZ' ݑW_HPt&`hA4z;MU:TAFza%&8sEG5iAC$*Jήx󦖯5ҰJUX 0~uE>zЀmr%PoFqXX 1 =ihȭ!Ǭ7@LNAi"v(H`l@@ubn`CP!s4ԆHώϚ-Nًr S[uJaqBj'c&&CL4LKRV9v5=\zUj_D1p5pVJ&"dXJoTh@STi}//QAQC|"l B):;):5#M&Xo5 ~{<+aF_jN '^?vB$dsN]ܐ=.dBF ͥRR/=$|K0o@~Jv>%9qu[ Yd@ x0_i'T},G$1!pWpbW]Ķۋ H} A'O?,CH NM:xwCiqc@9QGҳ`<}j_ՅjvMP: h} LeGlLiL)M;VMD,+gsQB.B |iWeC8%'%?Rlj`QE8b\>bH.B" HIrgfJ2Ge{W BtLI 55"'",9WcuLWB:D{6ۮaŃ0!rvTCF9`uݺ׾fbtc\dk/ T`7ZPCH!0N_P@rbx)jrT l`ZYѩl)8Q:$72:}r9^ &MhR~Buҟq}d ZiCn-Ax"6*xtHgVs\A' k W*ISY&hpҰ`#0lZS"'qfpv 0Oo(s)?U.5p-80bsuIt:ؿ|72QX=zV εGN65iBasЯ5BS|H-BVǏ~f[ M 8OW1)hĠNh1.Mˌ --Z/X0`éJ.,Y"4ոؽpy1 }Tk4jleirFtd?DYY?03KԌ84 Mj@:hK!yU+Ca }'WeIixTU( ~#|-|O]óDvN}q:%zk?lۮZԙC`SHNѩ٠HFRuuћD~nla>z2𑃞C2Y]B0C|L2p2,Ab~.GCpM[89$CET:,R2|$_1roj% -.x؛s_=h`Htil1I*$1Hoc }CrWhTFל_jؽBv}6wZU*b)Og%K/kMW\A\JNĻZ%|URp^H&U) ntSifZL˸t%|ɾ%O)kt0,^Of=LXX.;}cPHvOI1㆐~IXYHp( ,]C*ZyRꊞH#E%x!'cghZFIȞ'EF~ߢ<~ 3O蘾2tdrC!jm)w۹ӏ d1=67WHdC{>m>$1IUV痔o%<оD/ſp ɳX-޿) qh!!}7I?jI0p?e2e1efhWa_i9 l sP8;b, ?vOtPYO\WC6/Gpa=_z.Uut]j  jPUVXר,滫WoGvե6V%OJC -7 81%`?`&ËJuM^&$(! Nm]%v׏iٳN,:r󍑽7C`ΨO72TojnNЀбŭJ ;Zq *V1#"6@ѨH#.mعipa,6}?yÇ4DKnްK+#>xR»U2M,䈠 rt,M5$ |ɹnBWfAM8)A iilct9SAM6NZMޥKWs?I*+|URgt{lyQ%8uKh%!VHSKpty?v-OOc Pdw4hKPbXjƉDڄS' v|-Yvјk*v$Tdy'3SaWP^RթAOdS՚t@a%R:y:ڥo #0.O@r[/4Cr3%m7eib0)%yPTDE=w >LqhAPG-(C/lI'JyhJN4 K@ aVĺx? O\AdR5\{)o '|ּՕ]3A6 B8R&12.mҔW ~//DƳX%h!~y !iqJEKɛl!"|[R8k4P&f5.]0l4-w]r_xȏGo]ȆzޝS;$*d% {t UN:z"$#9轱 CvUhG?m(l}; , 1UiqAJE/m b[N3vէAo.gb˼#tE^KSP<ݗWVwB+9R0 +\Zeۿsypb_   uAuF|U>@ē eȯ~לKTJ3<;cL|>^?sr{Jab8ZZut+CP.hi6һgN:5jlٞjC&_ɭdȄU2[xUPrīTӡ'[pqNYYmA: (-FY#Ԩ !XΟMq iqJ~fϵm5Fœyhņb~&8no`)ΦXQgz2o_UNfvyhGϑ\ܧ|uS#=Y3 5QksӔ 2qg HmLTm[D,['6o*&Cb)ÇKhR1oΈ(pl!l&bs|YF?fJNߵ)42k/+̓a56Bcߴ͎o[;3^+27v>Y6[6Z{^ww$B7.ǖI$VsN2BK笪>¸'. _"8NuWt| }apoG MgX/G޼jf?/e HBK6d֑a2GfQG҃Gvߴsk=#feuxW+^{H}}|}˃˫Y|/ڿ"4_ڽkV l:[NլV ;a+aVPgvy/z4ћo]+Ɏ˔&&$( υOa~|Oŝq/f|ut 2Ƀdݎ$pԐVI1!dIYqYY Ӷ*25ZHhn#C|8_ƶySk [f/?j5ۆKd;Z}j2\7PάyTztxq6R)@J)[=~|b>p@sM{ yrNdǏv.{~ޝU병HOkR\iv|~vÕ5 aAwgSS{[ޖ#Yj<iOO|1nS~ukݘ4vT~BRQlۏp +|(Jdx l;h{gy2GQYS])y}_Z"1= !]f[!̼*@cݍ梞wns x%wBbcge'9,`Rml+G\$>ř 9ZdMDhfedeiY빩 ZѧTi ?i)e5)Mf4fb?Դ[95D*iBX8a0"Sݦˇ}gƀOvF"_awE9(Fb-'ٸl`kJ3w&$dKr\AHNdQ"4_> stream xeV P׺fUDm!A@-$^E. 8( edU`pAVdEPF7pj/F^/ɵ7{kr+ϙe:R(׮;+nwؒdf y=W f&`f:8})+ɸƂ2Q(6]7:2*I=}D=M^#&.%1&Z^M"/FbwFޥۥ޴3H[(eq+&$ ߾cgd .zoK(j=HͤM3@R^rjZE,)+P5Q6-e'@RI}l8lSMwJ$*^Af1&Ox11|"&;)Q(^Tх&寕9-ٰl`^~1a6CLF㋻*و4̇j"NRb&qTѨ:B/t(t9B)5:V泌±0TY**f%H♧з B Vjh*F+RN#niHI/[Js龶[bve8DXm$3 uo^dLKX@>T{?{sQ Ѱ 2ME7∘!t[B!L),CI1Cg$͖SW;7?@Yz'(dTbyu9`zh> ˥ܽKY2cQN8]F' 9̿ 14rnA׏d(cmY q A}MxXV4OGskYL+wlYģfONF$ q9}8SZ[y׏RdnffͦJ PAoJGɈ֘ҥջVW?t7d iCM—t=CjPU= c QFY {&IQЩ[WVGxVRsM:QsrD  J.LD:J"`#A@1AGR!6")!#F`Qk𭰡[@c^31qNrЉ#kB`gg)K59R/ X]{_)~˧X:u%HMGizIPןty;}?܇R\5q)t5Z1{tkʂ,<<^ G.H=pTj?Ynp!^#e@f2llHK\#zcU,9Y{vtG \, QbčC-2k]'3Ħ$Os>Z_[wa?;|!6%DnɉoٔcGX bm!ɝl "B>ª8͙nk3@$7f ^܇O_z|BOj}h.%cȧVl(aH0 9z 3ϤhF=|+ ?w}hu RA5[+^NҥzB"'u4UOm~=nކƋÏf͝F`F}WBq kpC#dfۧ `yqK.8q;Pyw< 8X ƼbVuCsl.F4dA<el]!js :`2!'] }td5V.+zy >'bеpn,jmv$1cs{ߓgٺL= j-;, {蚒" ay+=N,">*g%/z|xOF%<m2se㻎0 u ZCOidZ4zGTI@e$+*)EU%E_A\a*m_jrھt9x_ң⡿4 wnt\\5]mb`;b"_wb{ƶpѽкCŻB`C&!.jj 8!:4<^W g{Oʺ]7-vMw+xq~dj`W]r^㌱>V-bٽN~ ^2Gm[ iYXUc$HLsMCi#,Ɍ 3ρ_׍%|(1ϩ6㶆J8U ƃCQM33\uieabI4endstream endobj 389 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2120 >> stream x]{PTG2̽#!D5wFe] "DE(2E1 OG(Q"Ђ2("Qa@WDQ|Ьk]wsʽuNW>}26BEM[۹/2:)Vh͢FܗLP!6`SE prS]wNTGo%sǕr[B" [o[x ?/EnUF~rO?@B?֧!$]uG]I UغHe?0DV6 d\+An-FEHe"34#?t3u1r6J7fAb`fIa mJ/w f*dyh w܂h M = OB PBӭ0/j.?U>;V/:LK,ٌ 8aiLlq vub0d1}gu-%̧CJ73 ZDIdhh #+bAD'C鷹T߸{$n&.E_5[XYKPeݏ^|Wf·{>~<6?hјÕ o;lmny#cɯɫ,PZ&vax씀:0Ma['͇ S߅E2' +7w%4"E”^*k¢]Y$3{O& xH8K>; 86D}blc9I@tTx`Kp{TMVnD펣 (-[퐺=TF,M$s0|>L2P{z4Au?M?Ÿ7UUlM]ճyaݠ%$Ǥ`iT6œN2D))a|w[a?YiG0?Nqߺ&281ڵlӓM-&oA% &8ę^M"blfu w [:<+PR~Qg %\҉K7ؚ/TO`' xһ lc̿])ٱ=uZa ^i_# eWYDs?k_F3`))8Q;2;6m)keǚrd膋Yp@cx RS=ٰ{OZ'X7|.Ojzގ`_=Y#XzVpı<թXդ"ّR\qӏXF\,qʊ ʞ<^Vt%I|Iض{9U^Žòt) "wC"KϬH,tyxم-Xu xڃ`˿Pv]:J_`>T rcr+W, P1d>Lᡜ3AF'SfS, t!dk> HȕTTA5ŧ4GդIM)ѩ8ҲP U.1;A`'U8NR˘%rʓTz651t 60iGaNn!CJT7endstream endobj 390 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6745 >> stream xy\TgGkFDFͽF][%`P"1}F/CADnԘj47f;^ `ͻ?}9vpC3vIaZ 8a&a⦲7FqaӓCcP I^*M ;gμYߋ³^6,">)s_0 Lvo$eӓDQa I[vlyKA6n1A,^.z-iE}d [>;bCNdTPƘ-[' -^3f&)D Jl"%[tbx&^ v3,bM&׉9*Eb5G%$"b# ?! &N#LjD1XL %j8or~<}nP~Ö%?:Fz}$=&׌x''K'O?O1͉7' >9㩧:L-hn` yW]fO&1wuPZ{ n)QdݾKC5:^ @j &<ШmR.( c8,h?%~2)dI rT36i-2]|6@]D,7<=w*@)]R$'dYk+NK޵xwPR6B d&fEHg;Rh0-Tc kA$fireIJ@fϫ((ۨChmPd{cnB3,>|Fmwg\bćOVwpu} 76^b9{+CrӈivR!PX+Jh MAаtgY. qJ7v>Kjru䇖13ɃEC\Ɗ TLY^_"A 1hýn&-~ý@`uZm f˩ ?A#t4fǰ@nߵ &>6ٛ.< Ndvh=ګ1YG, ˧ˏ s< mABN/jF]Wԇ(l3`|ǻu3^] |A = ޥ\ |i&]Ї]C~xWmJ}BDN:2i (F 2+} Kx~h,5+u>Z烖\d0*hUAbx9rȖؠ MN;b0x`0؊?GI  bw?z\Jv2<) v#uL),PX6ԤđU[)j3L>F` >ƽeB/+e$k:ʫ׵#]TF rRfͩ.- o[!zuD)md|KS7YR-p\RFo;V4 ߛW)A:P!߮'OB)H2e.(B(+v=A>W'KL *r+H[Bߣyi|Mݮc;60ZMnZetЅp};<(8s1 }l3PSb[=+uaC.M7,]EduEڍVL83Q)RNu6%$Q^ C8RdO'tv,;]5@c{ ˥M'OG))!+:u*֡*)H H[F._ `sĴk t&"L t85'\~>:^Kq ȇlMg;tt;thiHfB4|4s.#gFQZjZĦ*S<6Ф=Ms^ Rb-~$, =K.Zj4Nw_{8wL-cIz x1sCF̒}Y6npQF ETSY:q雯MLfA?)Ly{SrӃrgnau>^0c|)1j6Y$}ƣ,a@xT{۔NH]X1S[ \p8PY8iچfIU.}_E5q*^)T멬xl\v;+G*]Z2,"~Ò@Qme]=8u^SsO}Ĉ·|* I=?ZfU_}U`78 PJ4eFҨX2s$%s-t@-;'/Wn(s)ʨp-Dnvч] B%dnjoh*qcy6P 8Va7%}q;nB::0h>kzezȜPmTʵZ1PhVQWy*qq4G>p<tЂ,W>͂>+o >;ߪ54qs6x/PfVs 0s@Y Bج.f_f+ `ҭB-%]0q@( OwB&2Rs&Aj^YS_E$22,QB6ȝYҒ*WCgetBkZn< /'_.boٺ{9grμf`dg|w =YOdKjoKjF0WכXI'. vu_KNlP/Kr:EZF"pF/a!uZ;mN[kM72ȮuSg/v/TC4 ^ZWCUBH._0QwF>Zw86`l7h2ڃQ:RQ a^ +>g-˝qsF#Pu4>͗AD_+z|Q1A>tsR x$ >)TR5>djx n2 $8e7Xtg;sSS3cC:2Z~lGmXYۼR ^5Ƀ C07Q-dzekEpu7GSG:#s,TZ߯Iu[ۢձ ԻyNﻧe2G^yeaDu僫"A"ݍ}ҍNx1وńޘ6U"ѫZ*gKb|ںZS6UY@%= M9xK\zK BǤ_ۿm˨'rW-lF Y/iNd޶-Q3mx*[h3 lF(0kj q3GOO!%;j ЗR~#~騚YBv8Pu)D,:qQtqTY~y35>WK276zb;v_E{1Q>+SS=R,KCm4B;y~Sjy^Ib'PCcZcmȖȷW2 a9gX{{o2mպUŚcbyvmiKJr+]U: g?W>v%$lNlh6i\–mNEѸx+#}D~Ze07R}N^&6xUFvZ' e`2dFY{=]_@6@Tqf'5am r '8PC˅Lj3aXBf,JJ_N FSp |Y"%;V.YWUQe7XhK%֭wTUVyNm.:LE]_Z=4,BHm^f z:/e&(Ac T0hjrn-:&t.پd-Rg܍!]O諕8Id%{/Sp,-DQB5u|c~>g2K@bpowj1 .g w6U ܹwo"\A+N10TdKVtZ?՞gy:~#%MK>*4FT|E32?Л̥ڎ)PUёZ}cI4wa*H48TrVܷ X_y jNP3}0d58nz}jCJ}2t7BuIi0;91ǘLG<˱(x1H &˂0}~<ʬRyRթJVyu\||bG + P H &蠏@ȃZ@ ;N'#ޯD|.Q@<9 nts{p\ sdLˇrͻKl> = ;rڔ墖rGRUZΤ.'2Ue7滖rv#N%r0 v(y彺%Ӄ$ᛩ!v6@1Y"+Iۡ ^tKQXVy*<̷#k\FTķk@#zݿ?}m*%GCK^mhWt ѣ*dE6Hر{Q+YeR&[ .awBegC#(U; ]UVM`A’r3.4IzS}W5Pyۢ#AbmUɰKikU }_zz Œ+js xz=UA;,ҤQJ\d.aflYiNyШh|/zuQ恍15z.F-2(u*[dSZş{{C\LQSBY}gY3 \x};?J+eSRK/eP-Om=iKXһg?Q5UY"xpu3SP2_2=L v<;RE9tC<wKF Bdt,d,E-ޕ|;>J.Bp\{"OWOwZФq sJaqg("ߝ[RS9@Br+ i%MFG03ж8qޑJЈXQ|tRkIiMJ[9zDEa3er.fXMtn M> CJZTd0`4&ÖSSvM`c}ΚAOp (ZAߌƇ0w|MTVUb&RxmlmVffzA\Y;ߩWI4qlR¤leYI[YѥN÷6_W'g*e1;p6bvOۡb @cӧ@ 7 clX%fՅBSQhZA[ l~EiGĵZQQ2[Ww!g+;Z9|\wVddq ѩY/PF> stream x[Ks89:*Eo YjX=;=RYb[*Y>L$Pj=>E@f~em,~߳rbNo㟳';o7/=?}zz)3;ۼ:N/geQjiyb6RON]{KWα8c7I ̩,amuH| W\Yִ_f{bc=^ƹԅ3&HcvEͅӅ8|~c/,^L^o)P'q,oGƽSg,{TaUU^Fs=; 4<*uWꦗ[92.VŌK㰿<e!K;(-|Jyv8FzтN33-W]}V۩BD` )G [pyJۮ - %D¤sK0ND]aR*r, clf?£+i>2FnH,ebùATWG*vpdD(fI}M>UW uYr (G0‹]ҤצȤUY2_v<(J _(֝ cPϠu<uv\_MkD|dϗ3pRY,*ா j/h\ݟ+ J{a4A&Ra(zoE9܊iBFZ C5XЙhJk^Gc0$p[>FH,o\>3W ]*MYޠZ`#x :;=?xbNPΛ14EH{Aժ-R'ڗ`{¦d=~9 )V>b%r9xq +#GYY:R ATF4yRI}/A ^bd$6ky,w[1U=F#):{5:B.%L8ۤoaT=.vH%ՎWNb{'rD4æk!s8NXozնBj*ѲmI!$Y~,S:fq;AztTE)#fJ6fC>O%Ӹ"9%e9Yh: F?x|x$oM8늦FQ~_(HqV[g,߃u) 'F H vI9m95S@L. zt(.\%ff$2ns4NKlq]]BAl5#VЀjcPopvqi/+G)ߝJן'15sȧX 7`8 Q[v嬭3L Ƥd1ޕ#:B[ ܨ-e)*xoLU4Y^߅|'E~ėnظ'3XA W2N^߈u1*T!TpfJtòPfa i;z%fJW3NhK<pXy3Kg(.B{sx%tf#-\Von\V{>蒯el-EU̅;ub xp.'޲~n@,U2>RlK|Qkwסb–vnq֠|#/H$@u1ǛTHP9IZ44~ޘ,Ri޷dBfSLˈ|)E350o+x!#3ˊf4Vڢ7 Nl@ lw^ ;bٓTޏ^~LH\Ç˦vȱXU9WQoc_kW؋?3X_ծ͈uX/_w g K'endstream endobj 392 0 obj << /Filter /FlateDecode /Length 6088 >> stream x]YGr ^꺻ZVH.Z<rHzg֝ 4+̺r~]u-[ur{խn~br׏' l͕{z2ʴP۫_?Je+XO_]=oN úy}BW<75Ⱦo^^Kz7ddѽ? C^]tWi;Yۿߧ?\}/WjoY׷܈=|ZdAY'u&g{o~Zjίyqݢ׆L|{T,vy0f*_ 88/ 5،ٸmi/f:7[mf3^sm?wL4{A^6o=<)l ָz: *j/Uy:N;ڄ&~/9ʀb_.@kT`)D`Ǟ >(1Ex52*W_ -*AA@\\7\0x"s5REsE75W7U XN9E:{{ @{"ƐکEs$(`dLen 󮄣k.Ҿy- MLزѼVBR::4y |YXVCޛu}LkJ%R9[{_i 6 g6(pt4 E!:x*cr%cVkU':M/L3%s}4|CP5Bmp\f%}R~K(~Ke~ϙS\W@?E;j;H -Aq9w}SR7ͦ;<=|.+a.Pq=p?GBvuϾS ʰ'"'_c ۰~XqŇdϛM0=Ii}+T6Pi>vpHȼô{ 1 _=@s ?e9{H[ e'KqJ}i/#m-%DhxM΃mk?[$]܃@e)/=k]ͫ,3(ˉiOfEmsȇKj6| }0{&CLW nty;t$SR!ɛHhѫK/[0o_N2V>zCbKfcեK9" ~H,;Y96VN[˦/Ma8{PwB|4@M] @uqfz܌M?kE` ((m Sa;V۬8=_wgiuV 44ZƤ.Zi*Z:s3G;)t}.i긵$.Ľ@1Ը`հ -M?dC Դ4*N7o':ɲ7NQ [,UZtBsS1hJ%R8W5i u"ѣ*ɋIÃ#vg;~8] NR<.rұimײ{3a/ g/DsaɗLz zdR <"][(bMg+6g<< :I zx ])g{b;A&#+a_az9O qы.`\(3?e j;3C1-V?\er)l`R)S C2ؠ2*i.!A܍ ȻS"WrOa;G4v!DY@VXEOZ!w655;62B=^D2ttF [ 1| H>^ ;0նJȆ~6=ڵMѐ;X4`[4i`SvHd>)µV+_vәqq~zOϛ2ɲ>~,od6[ c\K;2L#8$ Γc5Qa0{-V1_+Tzq5MaËӝ6t)T}a*tk_ŰNia;eq`UGD?oW=3j[+U|z(t߷ȉ4&3@i'Ylh'B0ȣzJ5r,Oocq84rٳF.q{i܁!\G "PN2dU_k VhbQ /d}+|oO );OBT T1QTB&[(HQHU>10cL=63/u]+LliyTo.͗MoLM.SxrL´L$ܨ#4҉T%s(bǏDg $Rpܝ1SB%iρBn}%Zv<ؽM`$wHoR~ȼ#b72 ~+c4KQ#6r@}&G.\ \8&q.GZ9fNL0R9& r"1\,0FGG8!(t-q#1\~kec"D0 Qx &!N}p$JW#UH OTD!*RлhI'5%&Qp9U"".c!1h!6& ӵѠ-E1=fDq^V7bzxԏ8Ti 9iQ-F]A9bX+02@U!9$ G%8.BĐb(TEÏ KpD(>a%_"<N 2ufa9^BJHcQT *vAƔX˘"$aDHTb"RK4ԊIZhJˋv^YȊߒӔ7X8]l;F`d:yhC=dzsفʇ}3?};ٯ)dz%@ώ`,vQg,dW;"׵kDJu3 G?d_f79 UG`,߷0 ?a Yv^c49F,2s))@^*o[=5kRJ[ю$_!G[UmJ H!c<|ïH/x#N8PbnW\o4Mo ڞ7XA_|tl wp.4ҮT6rl0kk"8,' Q/50O0i8|m]-(_6u Ϥ2+&їtlhy{kM %|.`- k3/d _kd\Ve4'Da9],-fErW֙ShjtvazwCBɫv$v0X+;_L9NiP"|We'IXF>-hAK/A=P+?j )V~zEvjd&mȨb0!Uɋ`lFQ k`Nsc"m";)^wo^+,-zXC"=Zֵ ջp6v [5˻UA `ȂĮ%ٕH@]RotѴ|UbyIy0 h-f;>R,XE45LJW z[4M‰!h6mrcEZ$qt֣)ƾ[~/Kc> stream xWyXTWEQϧKCI-FqE7,XR {N(ki!X"MIFGdKw`43|?nݺg AI$7&%D$)"̞TDzAx2𒂗g3?Iəq1i~sgϞ7s&^'o,2H[?k,I0oJRߞ^~[w [)xsYs?=(I!RO PgD!*:6.h>E Dm6S[%T" Rۨj5 VQjzONm6Rc$I''% 1%9Ƴ[6M-JfG2#F8飿lLؗ;QBp.qw?iKIoM3q $A.K,h7&D,`2"݀g֠&!n7ǁJXIlMDKFn['6'C*M(+ϯJ+ 8x)ivɗΰ4c'T2vFq0--1TO Zrg+Rcvsa⭜Yt`?DBlmFgALh?w އ`g(hᒈATzx0x!-ߗ`(Mjf`+2']d{B`z@5 U E.u4y?$B뾒Q b 4 N9})T y)R> P/ wt:OԟcuT<fډ?`ٗ>eth姐2&yhT )a?:/'䥗S'7E؂+޲6w>s PaԘ&V}m26A9ZPo9BH@A:<鰲!vCE;""j @(e*1鲄b;XIfj#uFw!r%ȅ^Fn۝$;4^^zDvnXu8MɝEoM}z7nL>oc jЇbȗ[@`k!G1:>CͣF<_;Pޯ̰I@Ȕ?-?2%: 4r\]Kqқ dP\RzB2O}xM˛׮~.1,st.|*4g6q#gGLF/\v{qJ'i'q %iPըƭGM 0A$DK(Cgk7)124WR6\a;; %C.߇WJ_"ۄLM"/}qq) 5[v@$]$ޖǛ5T+7>%IFq캒};o\cѠ& ڸnnT Z,G\ŖVK,ÛM5}+A[RԤ|`iF֎]o"xuj&*Ro,݆.{\zvj~q\0U-sM|9]8[7e.94.7b[mK߼r-$KG^"H!MaT0dNx3F]›ɺ}D1niB}v~Aa1_.;)]S4E\g.,UEymH !G8?؇Xu YT^_@'a @}`v׾j~U<9}͊k^ @dW7JK}Vef&!-"Q*\E .ov*.J.v{|XQ\FˍeBiuY{a,9U7}'/C)IVѩyC P,̻5tԟ o2\hnX{WI# 92ȪK  \xơ#Q'FI.5yP2!Tn2Y}b@0 ˀf ;O]@wIBo:^7͑.ZQ*cZVVb"->8;̭X)[rIcS$2}^ÞވQ¾%WK:ujV8s8Ԗz]R&ԡDuHXdԸm< `'nWтhTWej1%>MÿF&" TÄ!^ X@>-b~pF)ۿ@&e #oeOi@/o4!A8$y͇u" ά.Jex6E!|(v<)5BEYr$m&&\B]h -n|rK*EU_mӒZQ jiAUF)Pȥ6u,)2]عe d7;VXUV.DXf tܲʊH8kXh^qoY8>y 2hY=DDhDtDt27T_իi +r'I:/p'lIOAK Ɛ^6՚VrQB_<<&R4m/(!2? ZăZN)cHAF# Fyڌ|X#1j?02B)O7@k9P_Gs=_V[i[ /OGI:[Yddm6< !kEY+*V h?֠XC\YV7z(ϭ[üF:h0 Fu//z"mL&jCQendstream endobj 394 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 6050 >> stream xYTT־C36WzػX `EAކ^U#vb2/FM!E1jL4&Zɋ/p>{> (- J dktgDp:?AO'i(6HOi]hbO En )8y x{z,25]M#Co&^n~M8zl7d9̚f )n&ym:U an#7EgyG^>[M.ZdO^az,swϛﺀ&S#j*ZIM5rfR[Y6j6Dm,j 5rR:jeER멅ʚZLPKRj쨱>P(OPIS(APQ(j4eN֓hPZT *4&ihִXK蟅wEDy1i]ۢ^޿G5nThzh٘cfSmsrqD6;TCCt~Xƕ 'O84S'6N4iIՓN82Ad{F6k-,:v(>?57 "<2L:&C(%yՆRR3RSQȿso:<ŵi2vgC7tyjհņ3큝G(Ir4_¶JP /O16Tc$dT">{\U#XL)vu4K7s8bp`^b޼y⁝yLl%:)0bC0BiT6jХS:VjQx-L׮E-`kiakLuLxí[w?icʑdA"a{$%$L.eY;.fìǿ]۬DӂDJ baJKLI2Qfħiwv$,@~x}Ta1` n+AuJ&i|ы~~oK7Ǽj, 'NImH~Fl5~:u kW/޸r 7*u9|L>Vo/MBthc'9Gl)DaGg.BG%ƢTh]*9xK9P6 [A*Qp%Ka66~ijD'`KxYΙD+57kM0~/&WjeP!]a,~lobÀQC[ߔr9ѭ 'ȷtiJ&Z"IW\6Tܕ(mcˡ衄KH/ F"Eij1HRXQuy^l"鲨s28%C9} - ź*g㱖mHd!P0=aPLs J i ޱWR7bT<[Ma#нrJ"U:Ѓ|v[&P|1c+'+<˲O EЅz1$r^z+( zm{>ǩY- zU$\]pJT#U͒5(**>4|+7`bVǥ K-fБ6jQHϑ<1|Qń{tYүJVHrh)^ Z~S%PRL Wp^G&C*]GDc~@Iq#TjA{WjdTjQ Öae2vj4%EqXHG Jq΢wF(B$#2Rb.=BE;y. E?&\}yǑq[X!][#ʦ: T:PnY^u3l(]r!ɗqᖘ́o=ӐuL]iSaG6fgWdFHb.ށ战6o:zssY&4Ր_YEў.(yOiyuVX'ed%p患 $/VS'ԆaP B ԦkzxNa\a%@] (3v&p6`k{i< 3%CM j[L톚AG >N{i~9P+}xvH# }h/6ϧ:~A\]Z@=RD8[:2U2tKFް2;w;e o+a[FeiI)!Ű9JdG^"@!q%BŌy}TcNEG4aSEB4 `PjLbfD ù&?AIlJiU7ߛ\f3QKRstSuq]삠ڔCHT^[,&kEԩ N1jg * ڪBt@-LCEđ8!`Z"=7'Z&"G9F:uс`R-Z--1oQ)4^u?H(b GanW7Eu:FFuvbʭi٩v3ڒXI `<$jd5dk+[)Bx8a|<E#` ?"P|Nl9耨)<<4,:c>u´A&nj_IJL|kijw\fK.,:ZmUr.030cGY FP]&th ՆJslT_*_ӏ.^ΰ$x L@ U#:6vrfshQH֖2G?^g0W-wtN"?T^8IĪK8/vǀO҈Jz{ܾ@.h`EҐ0uKf4},=BAx2YD LW_ڒhKCD/axrE Xk˳{ @^1pVE,iuV ߻3 (@Yns|9H4cSBdfLVx& I*J+; L*vS" >H6e~là p͌v僓Egn>2(jŲM յMipgζ^F/w/^Q]Rrj)ɇg4# 2ȹ 2S}|/1!Kuͺ+gXV)6,I=˵U~?t K2=3c )`ϝCobtEgEVIBb}wϞ"%'!R,v*ZqrЛ CPZV\&šL!)Li Sj`*lz8x7hb x@ OEB/u\S9'%W+Q("/A*iKk7@răCc-vhWOASZ=пxwWY@/NN.\ :W*TD4Wty^MkGbZ8)~Yjmf_,K˩C%~ WeS+BjPoԲ(D(,R6ȦMoAkȧˇkU99dA<`7QqJ4=fQt"]bWٟU05a,?{sts_=I\?asrn]d3| g>"Q@BajބQ~Ev/=۾tKT,?#]jxIw FEtw%,"4%/v7!B(+:G:iUx6ąXEmȯ:8rMx Xz}ywIR#cR3İ JRfb<4619 Ŋ "aqV: ZȇTݰA#)%FgD#j6P0fצӉvEY]/O-1x-`(l&O,v0~.=sS[,1I qKĶ<֮X+I?~G9VQ25U=+P_fɑ9X]1QibK\ mč?6j+k511?S\ x{)"}"nW.]ܮ4RAS(U?c[[J(?V)1Y%EFW(=\7X(FѨ"~M.+e:r]NG1Po=VVʯ+k;]}ґCz#)ol֏endstream endobj 395 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3651 >> stream xW{\M_n$m{7IRI(!ݤ;iT*7Rdm\pøL\I0i.vѮ`n{w{>]k}|l1ǰ,k`V,&sx$̤d`;s } ~0#a٩"#ƍ0k̴,k牮֋sxb퓼2-Em=.3-W%BTW^:S,zrLYs&%$F]:/=Cg1vL$3D1_2,f0L,81~Df63 d\9d& fB7fcșX0 c3#+f`JA1`lc?~dNoq&&4Lz\zy6,oO FaZ _GS[8 _Lpv@4SfgZF )Ȕ2o8%;"mE,V2,~JJ8JkeR[Hr`Ϥ2\pģ"fn)?݈ECq\m|~bb[󝁵crgOZ-hyU ZyZu!:KV pC.UU[HXX&SgjF9O>t6;_$*NGjtbrP"JW\E7"^QS73&]IjlY'tJ(.$C|0> 8( ė^Ă rrh9o5딽}XI%J#IR)98chK4G^Ijpuj!h:{V-"np+~)6FO[VyҘ8 $hh0N!b^͢i ^e2զP|60K[ѵ֜Ir Xڹa.s_g*avn%(b8JNX^> yR/.᫳Wh.ؿD5TNKQeYչS'=])S5lґVx\_%GQ[wEmފ V{e~$*!ͦ#=a-Dب1MDtL:~JU=H志 vgS$#q3Kl~ݖr9UYIɅR{0FH6R^kFiMĊ~A&lUh˻~{#7RenFRr-!ۅ6,-jyd:P*L2a_Äpdc>Z4,O Ug k.fLXxsm}{80:m؃k22:qj8Hjpq`/ z71Lh$ D >'љYץ9aw3U; O|IVOVw.xW!> :{{ݷv*P a]#dO9(p>!s!ż;/KyCWJPk+1'C&M'RG 'y zx/(=DBj,3b46^Ҥ'LçE8Ox^wW8O3[ %5.'VXq/EZd ?'2NVc5=޿vv0n, F7 05w]B]̿׺{#6վx57Ƥ,>EpNjfnYV .>pOMuZv50r}'endstream endobj 396 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2128 >> stream xU{XWCɠ1ˆD%b[E^ (>&D$T VE?\_XPBR[Z3ۛߗrιCE O34%/хG؉#%֙;y!A&dG8T;u dOQSbJ={z{֭[W7_:8%;#-SNn6%SM\MV[@_hjVn5asrrMNѪ#4EyG(!y ţE(-FK/ Ah GMBsQ= UJMmgv['IddO﴿B;!Qe"Z"*bX;ͩ(qX|Ӭq +ii4Ycp D_ipl5]4r#y*{=vtU '+,„٠%YQI*[RB4#@51CpK ADz3LsCGLJhQW{xRp΂'1Ҿ^ÄL ,NNx,.A ie4_68#p 9^& l9$V+&+u̗M.@S{畋.&,̈f0@86ciXH𲮗}nP|;Ay`AzO O;R; w)zPJ H!.A*[`j"vюnF99K5s]\TkUɹ]{T7!#=#:CyA4 >G㛶EΞ?gLMfJkBCZ6t0Y9Bt%E*U=y ^iVI#%lÉ4DEcW|!tL|lB>춷endstream endobj 397 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7206 >> stream xY |֟R2 @;N JeMA6"[+ Jto&iEpdaU Ey}ߝ4>'Lf{9?sD F999MX%*(&s7&G%O'~0q۰߼E0 ?1q(W%>O9;9G`s璟K=z/2V{< 2r3cflఠW=nYynyjmM^y)feVůNX6i]Tw}>7m5j[g2d.zv&/]f>5+`]s>MQʗZFM6QӨtj 5fR[m,ʟzZIm^R;U<*ZM=MSkgu򦞥^QŔrvR.vSR@QL=FIǩ'IHj5ZA^R(Oj<ĊNi;kv|i់piđG^쨶ћFSGc~:|.]]G6} S&\qqǽ'eʼn'FNOL~B>eR4ǹ'?Y_ٔiSLu޴1ӖN5M7$ׁVIS=ĆRMܬ2&C5@> b 2qZ.@VhMP Ot4.P8O-SBA(wutT c*aDs4Ή6V?lƶembs{Y _G?) k0IV@,(me5kCEl뽊IN@al`,lm5:h+ #rq-ם8^t,3!F^z?S70͆ \-Cb=^Jw"Bbu_, =AþTVՉ%E./AfJA@E|q\wVf<?o RQ"qW:)nFn@;SgGfh/ZG3ZDM#Wqg7L4mvafX]?!Ѧ!Q8;;IVm4ՅK@ Nn il9R<,paHю!pYs bK oP~/a]^M@R'ۢQy!qya'Ȳp$UʽnSg6aMWeI@a6MJ^rwXCan+ Hbr_]fo`N(,4w0=gC_3hFx֥ztqLa=rxˆ|4a;WGH4Ff劆۶I~w J\rog]of%-bv Ni5!BZݵk'2esCzCVau擐إ6UŘJ_75h]6M8=AQ !t*4z3^RlS쉘;akq5F[->t4y mP7COh[-wVpB+zkCm<߉bs[Gty6XՈf4?|X{&I)])%\Rx `W,^Qx Fpd<[2}>fU-hEbvsyHv#Xe PK5irߜ$x vA%%4˔K C%r;s~$4 H`{o{&}~nY;$f 1;ۍ%MmB Lേ:ǻE8fgRB$ Lؔ%!/?m2Hm6?\}m@<76/kC {#PBq}%ّ`4wpF?N$<ojauyP%LWƴ?RK C"ew)pÁ|E !>xMXRʏ"m;SD ?!9mi|^^M[ى<߹>: 8iĿ3x*Ej`31&;C d}fZ?1:Z$t4&%ABko=_Gr ӪzRQP˵oE+0 ( PPW|qߗx*iR]@Zc(k eRB4Uxsg3|O0x;zFU%,$IR!Wa] ~ۃKkځ'fk^GOG$4St9@5Mj;*|gxhͶzF@ Q/4;Br_З#8ljC-[4.jL}A AeOS4(ﱧVZX7 @+`uc?YL>ola9h;QOQ0TJ"5;J{6TjRZe EfaS}1+&IXv͘.-!/D/48R GRA=88K1JHti/N$)Iln"G+f|  9F ɬAPUf642%nOX(c>\Mw0V:Ԋ**GOOR*Þoq?RC3c1F%:!A- Q"IU/xNOwu`?C))?ؤ4+K L"K &>duՆOCӃJ2u4tFo4V[.ߨC>Cs3yȬ-dmm. {Wsf{gWS\Nϴ3Slȅ6[mlhM7v/̟}8g9,ޕb7c[#͚6d0XjLuY;DRcivZkHuwC 4V["%l8{+#ޓBÅăMzህn! wߚ!W{h_fKz\O۶ NoIO.TپCΰgFV̅<3+Ddg%UaE Kwj噋ۀq+Kݝ͌<3s! 2E(Tf)bXЕtT-|uHkv-5T)KaLf@ O0'/:qIIvzc2p0־.EὤlB"G@d?sGuhßh!P尮/5Bwh:~+¹QpxUA,#SE )ŗzZʾG5Zkt5tsl4/YDz"J.d%] 8wߦl~M} ]z+2ڲ6~Ox<$~BGyvVNljI%O΋UV%@ 4埝~\%ڄe5h裘7a=Dv.J\qus4_B3,\XD5>~滂` kff*C*ѐ'cё3 :O$ݼaEFސ^MO\~_<Ԃ<&kզ)##Fb ېi`XFoBGmUJ%. b^И⏈ҡ(l ' j(5y&?8"quA]UPw"6>AF hK NI@mHNHwZ!xh،`h6O^ڄO{5hitZog>(O&! /2A{w6ZlQ|Kb`ݺJMO$u;^y ޾_ə+-Pރb*f䇧hrcU}B:!5g!fDÞ"#3czQA.Bݷ 0eZ˱G{ˏ>$4~ɥ $x gUGt)Kˑf?g?n·$C֒YW,N3Qϓ.q7Ոf6_߽B≧ a%Vp9hyތqFӡm4v&45445tj-'0bVB*w:6NNߟp Dutt(e::wI'G~ch8ҏMS 7[x\eX[NU%T ް;2ngK P1{PbU6ӿiUanC0| ɎCbSS)&E`}{ҩ?*YxR-\ iW\6UZ %wNGZ&X(_NRk2_otB'V 9NS-h9gj)x{gk`) _Wq*Tq}E'm٩ˋk8u*O:DCMu]sKm@G ;Ύ Vs^"whER\r1̆_x9"tx> {:.s,HciBswa! P P8- lٰn|ũ-2jHKPGf, ?~Kt1WbCEvE:QNJu*<6&=h(e$46 *=!-)#"YM/I'C> _Q]U!"4^TYWYgr0 e'hT]cBFӤX:U*4.Ms,V#SE(ۅ&I)Ȯ\}hֻ QD9ouD}AiEk Dh ?nC!uBV#q5IK h6uvUun@Jwe# =0t䭲 )0P\ri@<.فagh)f V1ە/$n܂.(*JEO,5+mGN">x~$އsk?%1d.zq GsKO:.%")paFk*R!!/Y F7A4ރׯqx6SMrz o*Xf$.:Y)% @N*S%)h籥gQqkjH56GPx~$ӗ?U?ϙ9O0-cDCR)\UB\:3K`+RvK&4$Ț[RWف\rq'=M Q(eHS|vׯ3PH>7bc '!/]@^%jwS}ZI:ZKWUF&Ee*1̕* B%z/ܸ]Ŗ<ߥ3!0*JH.NBL1 -"t uL6w$5=UI)R(rxo2S1MırU|:FPEt [>14 0!PU}vKMJCaM9CAUNe"X."]6k滈.@a22 hʠZOz"""ϲ!̎nKl-"=#m"-Yl-@Dإ#Uύ"k끤2ŒS7&}C==;ONdF(I@'а{GGĈ:kH4~'Vrk> [wv/8[gkd͘K!6VeW r2ro} ]&$꠨BbS1meĨ~cF˜*,z៹d3攡X_/:ii.E endstream endobj 398 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3253 >> stream xWiXSWrsY8 "Uܩ$l $@EVɹ,RV!aM*8նc7}ZDX;:sg?$Aәs}~oD!~cFJF V'>/ 8 :*3O5yAO pǧQ4 e -X.e$N b7J:aO)eRu42nt떵HC6o??^5$BJZfF)q"ʄ-[S/MD1BD[ bXM$`b-XHLaz"XLHx׆p!)QSӰϻp.bq~D#DPmήrnwRO% |*h|GxD$Rɬ"ęd~Qy$%ݹ{xU+K0 $}jsd ׂ1{^ce&ik1 -Et ˬB"T1Hh43t[HK*ś׆l|^taX|@EYDV؇Ȃ+!؟ —We귯=AFue>@ 'i2v+y ْC$?+Ѽ(_ m?n_zb4bK0$mF<ƨղFC S=#ir#\zڽdv`nc%AlU>j4q-SGU6qCNUՃӯ(ٰ0;z#2F~3{v^BKrVJ+ %Gwwq4LT`%i!&7pul!QF6CGGu4Em->tiKov8QK^ז2݀mg=M%]ʌbV(@ЊŊup#`L]z<-l-MWW7:tXI'c_MEmܤ0-]kX֝y -̀S7NCWVG5KuHqWNEM+܌AO4K53Q35m@ah3 kɮ)Y R3Q096#پYq:\gS /xE]P=XDc`uPաGQ$=\U ;fG?*"Ӯ Vg(mei8.lD`~ F ijs$gj'Qڀo k1霶x*p&*ޠ)+gLre-4V$:{O,8Vp&E6@ѹU20}>1+%@?# ED!|VG6)[>Y8ߔv#yy6SHi EY$Ab"Ks:s߻)*)xv4xZZ`rfz mJ;iVlRkYv=<4ߍitop{цr>;̆gYM}z5x1`3 ̵t=˫NlQ%3U{߽?}kY/ln>V}V5{I渒/(Et Zz橎'GS7N>WVg_AO}odjVPhCjDbB6ˈZ<)b8 y~`եslƼ@"ڰ&o?9Ft6yy] BO&(x4( ||4z_o:p> ɆO5A!w +$?0dz' GihlKpc{<.b&.wZë`H78㪑'gngDP>,@EZ:La9ʯ+TkAϙɑ `HC;w1v7.b.o5i' :y%a|+>Bx[f̺(c[&!P/^s$鈎;/?AruzUE-w[ ,A7y?xkP.ve@# (۔WclK+3ĝHe}YMiUZ{A ;s(̎XyK9geQLL%r_ nxĵW5#X1-&v͸񟹸K$c~d?qo7d` $>Lt݉Xf) a:^rB LƜ$'5ǎFX e΂ ΀bNV.7-7͍QwS'/>l RUiu&2vIg;kdu|KjG5xw|Mty*46- m:hbO}s( ڭB1f!!w'w0/ L06e$dђy|F; =d&M¸MU,Etص{כc߱zu4jD& Iȕ9,̑cbN9 Y̭%55κD=\rST~r)WUs_A)Řbendstream endobj 399 0 obj << /Filter /FlateDecode /Length 2126 >> stream xYn#}W[\b$qV1b;dZȜPLRsn-F6K0]O\v߷3Ͼɴڕ_g'xE,N ōGm W ,{Zkd_\`/NMw B$a铖}דRD~(C`XYo_U˾xN&l4PhC5_DnƌfX̾/*rg;-ӝ Vqݪ{8<(+h) 5^h$Ǎ֤;{K*6vgEz+a<Y 9a ·i!4%MHIssPcݥJf~@}Я8PƖ:vKnh;ې!-c: To?B=UW@Ӫʫ!Ϋꜝnnx0j3*5d ݎ+ >iJ+T*+PQB 7Bee"D0+$cj91Q>Wř8Z4ۭfiha6|Þ{a[nWoN*KT3,uQQ\贷cPM1L1<y}2ܽ4&*+Օ @^yzyoJ4>.1r6/*Uml#8I]U:O+ gxuW4=Hlؕ+#$H6=Hl%Ε u\M]' PL넹 "|Œsu̗e)_Mi2,ceʛW ]@:ϖglElp l- D5)[6)I-'dWe@EL$B3e4"L'n4z0DrT*2/-W@).m\ ݯ1mf۷JKJhiB,'cf"L/bU@91^'T5Kq@q{=!8bfz, x11eF.j i.ņ> stream x]QlSUセk)ent1%mF4Ѷ:زjm0F6av?6bňNdĒK1b NޜsT<8njuq!\/q򓼜/R"JHѪfKuмv?ՙHFV[mƽH%EEf3%WT^(U9hv77I7Bg&n\ {-{$ְ[[_JjkA]G-{ijEh 2bTsh@HúB*dE(Εq=Yf͏EФ1ϝ .JXS*-8DQ0A| ֮a!z y•jFA+E')f.`U4b &`U/LHVS?p=i#\^I@qP7e>@0#j ԟ8P%B.&#a S㒊Jڑd^V`4g:7]NPr ]v)rSCAĸlr.C .H9ӿR\G`=csaDN$κtp!m?'SZN ݇zUn8|w Q20?([,7|0'̯wJCԱ)> stream xm{L[u;da/|\td3 Ȧq>&\X, k tSni`p 'fU@DLa0fƜ;9~s("EZUg /'? n uyeJ<;웂(Hx\ 9poSVU@_Z#'WuºH}6 ~EDE3,bw(C6=39m/{e}-(_ SM".wL{I,`q*_AU_J̖lPx[ O7?pFL$EWKo,@<߶ ",/G~ HRFrwZƛOݻq˫R8ⴘ~43Ωy4|84E#F|<>5YNendstream endobj 402 0 obj << /Filter /FlateDecode /Length 5462 >> stream x\Ks6dg#fFM<ygDL[-5]R$m/؟ Dd4V#__>_6U)6uwQmn/~twuˋoMՈ ?Dld%K]5]V.>ﯷ;TQxUeU;+4(PU^qJWMq*+ͨH.Hԍa݀?HXHcw˿59Ei-6;U|h=!-m <ʦukF28lS\/vC|Ua ;]gN N+G>=_Ila֥GGˋ_xѪ7ݺHerTX4(Rcd_LJ>J >01Ő >o9;pUPf #( TN^\ɣ竑H[|U+Y [J#iI!4vBnt$-i<0asN~JTPOd(* M\<)L -ھ_:-Kw/ O8dUr7Uj8~Gg8ZnR>wﷁD#0=XHqkDחK,[vd5(/$'m.zq`"4Xt~wRŇDhZn]O^k9=m[F>1 69TbLxb *5/[3h30m\IGotA ͭ nÚA%uOVC=7=F8vmAbAa)HT+}``HKTO]-mx s=0Lx\w~T%l];!_uE4+yX,a.(9r:b)Xx_ HeLeRSo5RIQ׫rt&M8Zs臧n0ءsF&cqpbH~C4#J %%yu$$o! I@*C,YTK:O)Uuhq^fm,gʻ,DvBu8ŭϑ94v0l^:)B=ܨr9!zgD=J#->Ps Dq].wfoc,Q+9$$NRTNFN\2 2s fۣ4hb&lzWkbŵ2ci c,;aܨ`%0(w:alA;J;S|"CxG<)٤s~[ f1(M\1YmlVx# X.v!HB Iagx#wÞCd.98Nzb-xq߿oLIL~cwm23OHQ3 M g`Im{sSAznr>.i P)l$ h.S}ߎE!ݛkxGndAkԅyZ܇-1z}U~)>^}u<bizmqG)Ĥi}ňjx&"YlZogc`ccy-S&$@Qͬ)dC &C3e}lUsLl&kX8(17!m&` =~:&Ô8)e w"1e<*hXIJ>g{^\S,M ȋP4G6udyo^w]s:ITj40xS{D@q(,* )YT94O, 'MDw-g2mrhoxǵY+3I myI{}H~\[ ,ᑲw|ctxgr{O+'ݔ!9'!}ةe0w8`膚@7=Ǧ<s>G,MFf/b̆+ ]A3E.e&dp s+'8Q.T7i <_L 0jVnyBiYSM/eI| A4ZH g71^sWhs??8A-MJ,}b(e]dMr~g4;<{&,Q2g$`WOW<‸ك`z,6g/ i+3hC_MI1B4ۓbD,o%^XUѤ5_D,-=8{^6P:Y-s;) vdXG2֧hʚD⡡O =Pe<+c! Gxʝ/gl䁦A>s zV+0H`fy1(Q&p֗~q{ayifjp‡-ςOq C 4NPL]r޼ơ>J:$>j,'7VďʷhS H]74Ƒ`.>K0BNǬ Ha| OK4x3!7`Qb7`%v㓗/e)TY)Հ%Bcw!XhᒝZW( ;+ IoYNQŌ5NMY# jװ)zvZhJ妪 uh3> `>4vl%WM["U ǻhEO[HxzҏHTB1 O#:uuVu_Mw8_  ᾍ' n\%w@kkH类 D!g -0䗔8@)Qpi|2 D턘TuI!_|[iSz(%՘X -/mgt>I!PKNe,/d1Y8k|g S/h(Xa7iPkG؆&܅ @04":ygVjXCExP:_۠[(/`'҂wi$,y,ee‡Sݦ^Pl-qKoWmadimhXW^¸R*m}l*?gU︻:awJRyz7׀tsQ$2;>a HK=ÀK %*6G~AsuoެP`>`,.ߌvx=Qjx~ N DN[}F.~<.}p I+#e˨//sw4>s\FuSiR^ ﶻ I]KO$Om$zU/uP%\p9⾄Xlh_9dAYcʅUz^ӯ3Jx8ĕF'B/L<LL^[j6ʚRJpBiwe AO2]QqM|. UG N͡khf~ 3E̋YԨ*bni%EITamx?.uЄQ۩pXMŊͳe,bkxm*DϼBJ!k.z/p8wk NNKgi Kx秭P-^tH&Д`շ̄A|Cv;޿f ΛTژltBg}t((7*0HrCuD{7Cf+kд6rmu|ZZ5J 'KiA:US&De*Ǜ"|(W/[Bm6 )xKO4uR΅.ϫu*]gd&qT'[-ޖX-m-ޖ- ~XJ ;cu RSGY?@wcp9 @y &E_1 3ٸQS:wcd, 0&!aÊn#&?AnP61@jMu8͛cj)88/"@n ipuE&q밌aC9iq|Yk =_hOvBWD>>Sjݲ K緫=ipz@ п?u)u%HA?3&m\t^nТϗ|`:2LYD_LT^vRUgWvcrh=e_6k.Ų%ë/0w2tMXw51X6jȿtﷇ.tU㜦@Z HY8`eˤ`ie kFY,?u~`z?;b*9Iz8i.ĥ^> stream x[K䶑1%ހcg#${%}nxZAu8j5zg&IGc"H$6M-6 KoWf+Ao7qտ~ CU"6nWe6ǫ7ۭu#~;Tx5ucWO[ }B#*;4>&^ꖞ[lhBWetsG5!LЭ? T_r]\ 뻫J;N(w5a3n:6n`-VٝP3 -_Zlmh$Q7;!- i`,}h,6}SoқZi,M;Etq/J9j+zz'3KU8JjjFצQur%[k;ٕM__fQ'g+Fӵ"w\9%I+[jf7[lWB|JI66+elabؠkXϋkE}cpT p"탌i@d⷟VZ` 6rۂRN};iz'ԮЕO64pmnK{,>N#TA$cA8wK!No( ߗbsNl/׊]pScKDmº5p!bB۝i@dQ}C{=\% HVB'l5VKEE & sm vCbL TBjH2jqX]}_h$/$ӀY,0ImUJr8\3$ӿ4fշGhiAUp";FVH^O97i8N)s A8ܟd ;Y]հ5>{SPє*"pKu>9m/۹ܚIDlHyWvbljGb0)D[k4@[`>!-_%>wLl_>A BlxЌOw3Tu(JB%+G'-w7_TGy-ݒ:F-& ,dU&kȰfl ,f0Vf,V]itO=aӊ&/kXM`he(! 0p1lr`ggSV-gVG3aj3}*U Fl8pP &vus6wS2#crz̆ ]sak8 22UZdG^h@Žlq3:h ;A{q@g%%_ -CMBЂ,X2ȡ,HvٷFhAJ,*H@0FA?r[zD=/Ruw-22Fu4h%ڄ$∰~w`Kn>\"FG_q#gy0) ݎH ,_ᦵ= 0doA،BwH1(R\ԐX{I òߗ\W"%;1 5߅alPZ.GM7NzHV#82V5t JPeqATcH,*D05୧'E >͢}imyvs ȏ}?\6f[;7B^ѠSҜLbj\mh?CWoBmd1bsa^`/M >s!).brSȃ@࢑t9iC Tb 6#ȸ)&$69Ā3fȶYb6̄C ЁafE|R(Uٞ$ 0-CqߧY}{ia'blnZV qzT-ƺs #zYF"XJO/>paGe 7$8)jb/~a k1dCJTIq>mwE~¶R|^"VQ(Ll!0}14U,eaCfd%nXA)p 2d6?cw$hF%g <8)K|ҀEGwnpOQ:z\nƭH(gsUeN܆2|:s1.CL)\-ذ'P|/=s>[qN$mH 2Mi37R4ɠC,Ecu''y2 f_IH |d XQ7bf ]${(!x+H( O=~[Z狊(3XTjJ^0U}{6#ǬYAV &> KNŦZ*!poƉٻ'z*F{@t&:P[2n#gT!w&li`*X%}5 Ϗv(ID y57mj Y}?>'DH:Nm3le!as=YR2 l~]=Vdkgcش(# </w_|~wՃ>W[oRY5;LN:2`v%$n{[m5])4p#T ̒TGT>`9`zw*+ȁ*-OA#P)6<+D?)+R8"&SwQEQ DZUNQx-r,>"o{G{P㇕4DD 6wWc-9IR07OA)9s ~J@jh6AhSM<}wd@\qKM]e,`7f[س1y_V= ՗j94>SC+*ޫ5acl/攷]Rc@glrޚn[H񧦳ۥg#{C ~^U*[yNXu<ҩ4#}OW$Dži?gپ'(Z#fL]wy "xho֎侹w˻頶;a08;1-pݷ頏^Z>7M]YۧWAh4M Nùf;`un-g6 *Z.+;wlވWM;5I|d]Ǹ*O*7!K7P~A5 tzjp3Vi]f hz(a1ŘH#z1xת#aN0D6Ba0.xDvm" XmQ!=a]Z=wta1Ӌ"XS %;1㙤4f%GFoZfJxktfc"[NvPEīDJ3;@sSZR&<: aZ:3T>Sh\if]̭J,/)x͝?fXV+Z> stream xZoܸߧW@K֫dKۻ(и8rZ+YN3$%%m7j7wYYЬ~Ufջuf>|o [Z_< ʹԅ2;߯cXZs 8߬^(%״d9ȫp랤Ɛ|ehYZK^FeI9TmL>g(Ф=ooWQ@RɌ)*cL $ v+FK]LZd18ʔlu*#r.9Ѝ%mŁdVɂ8N0z2L\ 'lJXlTfBh,вl.XR X2%s˞mu}*3_s[p-MօT`% ?ll&_Rq3ZiAKi* 02FVlb4h 6%τaFnwjk2X+˶R%_ePE{|]*e"YרۛΛ =tMSWAf*)Jb]#ƕP*ڟS4rEMJk5-x/߷"{/z@W,Qou zaAt;#I6_3]C _ lNv%p`*GiAb8& *9p}Prk;+8>TO<7'O>/ظ)-k4(NaY'O3GhR5m|w3 o%Ӏ]&ԵD 9D T]Js\@G&QUS`FEVR:3rU^6GӴ} ,g̺38mE`gpv>U O뾺\*SaheəWwp>b3->@`|341 eOMR0mx.kd@31[tIN#@M=1Oe~~  P8ƾX<.-)2TTXlP>!0b& /v4qk( JwkɤsKK, G?9\;, +P?9{b WM_=/3_"!Y_?kcꪾYFûoG0yf16:E>M="dD:*H0c]2T2>I;tc|ѾqFƃ66-u/J9 iG1oIt%cޙ(ꇼQt8k"Xm"'VyhI(;%wycTo!t'5/Q&CR;_OM$.bZam5pi@>BP]a7(}:׈~< ~_onf}Y$%mjrjoA֟K5oOC}hj勄.P_Uq}x sE¸i6jq1|?+iISf8SR##l\eFKHl3gհDPbu9H |takxyq},>Ri56>K9zܜH+=kt /8/Vu`6. ݘrf#,ȞXrNiI[ͺ()A{I~kohYg .ŞM)#mNv%K\XM0˜: f>XC9uЦq(s٤)Iq7\(] .ʥVUS#*ڏaxq܌@zwTN]VxjC4& حAK|!u({Ļ8uEv?)4&8@D8ne IZ>7 X1uZVrbL݃XnY!td:*b҅c du/͙>RXaCo[l40W.ib@ d`O6x ?Naitw'ٕ"h !둃 fW` 4=4ڦ=tYgjXⴛT !(c}# V ~-o4H3oQJXydj9YTݐp~?x7أ_nI U͛U7G֝P  qS C&yi&(7.l-;*'7}.\{b.b_cSR -+ShhvG~ƍ3 j?5endstream endobj 405 0 obj << /Filter /FlateDecode /Length 4828 >> stream x[o8r~s6/:79H-n 6Y QVmif_UHJݶ?%7U_}UevY*xSƱw (S;.כ&/]m w?U7M(aXf+G^%y=?ғrvˬՇX}}\ʺi~Vn4s1mVjG߇ڑZՍf--?YWuynd5tlaŪ{hk~hI鲵w:~*_E+ ,v(yU8L3ջcZj.!P3ctB qFVO|SkM7[Ӗ3Q+SipT.4B~?/W dñ}d*̳c0v{l-1x>v؜$E8WkN!~ /Z% I3+2ѩ2 J߬t'?$H qͩwɇy|%PCxΤ@5TNȬp8v ;נ@G6l8-OTl+MWo4rC;[qǾ -xRM\GP(9S) I7Rg>ʦPiD(ET8R\#S%i~ ~ЫP3]Ъ $2.3m\pvuʁ{n<%Gɢ}bhηC+!%䣭}yi*$_N?8,P 1pBCg [Z+܃e٢Q~EFYÚEPqILg: TGlA3ˏPaLʢ!4{P8BAά^L21r}vtHІ+UP8o8<87/Lrȵ=_j` Y B1 cYšnţ^|9ͷDi7rԲA; ۻ^LJf'ŸQM@?IÂeuH5^pm巭iLuR,c0e?HҜ[׶y@m5&?Ƈ qvCn0N7a2``G#w0hmnoo[$oslb9P0#@=s+qwoo6)\IRoVX3^$#Υ8ˉ( B$By!2(X2i}OJTX1cV\3m~);Vk qx4'A9<YV”҅d;;u,ʓ$dS3pIBAq /~F3{vO)$Ʀd[ԭhf=K lSLM'Y@0[őj֤%6 H.? w R=mtV4"9Q`PPATbЃpl"oXOKI?QOҁên9(M\v6 r(/Zp9ʠ:Ox-,+b5-E= ş.<._@)fk z}m]M28%!l@YSU3v7)-4j!~;xO #ɝ`1 D:O! #Tg6U5? $N2^2jВcKoW 6<<*(֕`r ~8b6U؝G7L5XyzoԴC^>+^`=[a9iBwmeuu`f~?aPUpv^7rހjWd)cj9cvtshުzt98j"Ԭ888BZrOfFBkKhc/VW@@6Pd+QM6JaLwH#lUR"GJP"f쑞jLc @; dd%$Obf@Em@ 8{ƁwEuڬ 5θIo>A۟ycjLX@-:tEgçI8H<-fz_!PFx|?IRb4v3 "&y" nsw&M oe'/6H8ft9t7P`rr$6)>NLT4Xۜc>]$DU$+='}APs\L$?T)+a;Oa¸):P0frG"q @r y17O(ro}"r ;82 |r;(6ّr")DA J[ CZWxwJ ;6LK{VEse"BpYR홲E\&ԯȣc"yE͙f?}ɘm) mX z<4`ݑ]г?'shuS{6 LڱzXO!$rG~5T ;ƃ+ҟV\~&(aʡr9}c-JRժ1kNa7=G༄6M-)]eb4eQ^bV@"É&|]A_R@waCY;Qg'8eYb. z{RӮ-&6]U'OA MR+ 95 1? Qy)=)G{uu]\l!WrTZws} q:y$nBky+ Y8nÞ?;keH?dkp!`̔,gXmyzn [@K(t%6ږ^KEo2`o BR7Z v:Ɩ4&vrf#!)~9] G5+oOq*{e%olŷ݅$S84d'O Gާpԛ\SF"36@u SpސOƟgjE+N׻J%|?.$\M #`ǡ Ne/tflf0Nt]fOcN޷r\L3%= ;QOYeذnУBH Ryg<- aXG&_ipccwT-.Jȭ l$Yaj}}$!˜e5`F`T0Ѿ= 9@-m Stmf ~#)슣(!dطHxr?.s8ХC&[V $Mgւ}\F0#KC$qգ 0If(Wk>J+t|t94)MS5^mRa Z'.x2d_3"/]oC."cF"hȂ2cB/Ʌ2k\ ]bߪ~ w|'zz,%SR 圛 %2K)mȫɡS==缒]hKV2'i tT ܉X)}3_*ii Ҝqfy ggrEP8| ]'cv+f]\aTMzh y\}ӖX?Ϲ4׳YN{$QMi&ˮdJt4c+YKLǻ5g]ڠO PƩlN\~2Uv5\{ؚn qP~wtBW O²Zbm~BdsDZjy{e@ݪK# xX8)|s.4\؊ (cK<~Y^zf. a n>.R&8jm$=?`4M,rg ܅+WUyrC 5LI2Uvj:! LGP‡h*!]ēF`0 ŪWOWºDs5j?l*4I~ yev !?]Iendstream endobj 406 0 obj << /Filter /FlateDecode /Length 5016 >> stream x\KHril/7 |2sx ai2UUÿ~If&ji*#232/ =\5WuoGm7^\߾.ډִWpU)ysh捭VAۻ?U?4ucT+_RUV?%?_ڹ8ᬫ>$W?8]7.n8VJ씩,ovaD{|۲uHU m_$mq6iUu|]5wE;FT>;m$MBVIt۴G=#횆TPQ.<2ن|ic8G!u:5-]c׿z}KBs+& ͓/QL%4qU7dzSTwBp#QNI ;aצqeS5kK{+^:ܛCڙy&:[Vc4 @]`(Xhªt)g$#@ ]󢵓pCYnVUwJW4d0\hS8jW= hׁ{}Acc]~r$_>D|m+Z ܺU{vYjL5K74] ~H}J2ċ^ҥ7N}B{̰gG}[NM1r4ƚR_iI&/x%iJfyM)M7 }3̫Su%bxpLo&?DI,(gW^0w9Lp7XQ˰N1]{G19Y6=5OwOT|iM_ol. ]@R0%H;1RD`BT5?$#fcX7/wiPh'r}W{Whאo ʭ۶p(MP|4  nːrwgR>m|6P+X 2byz`-rwڝX2-9>B5‘~]='X2&ژᲹY {"3Z; x˶mX QchxbZMwm1b.Ri& g'Le>ã~7fQѩp(< 8Z.MV-)K@)w;{͐,^0v0㴃x 3'}%KP&oJT~yP 0}^"rz^؏3@ֿ?Ux]eoR,0R)N!%KdKc+>x)A۶nB1$`$chf fķYTts$0x;.fUM&ya|m/m X9Fa1~ ih׶Ը0TlZL&~Π$fpy"ڗG`Ri7fHH*S(ڟ}:a 8MQ2{Cx4xǬ&Dž}E2+Oci1ɰ Iw/V0IXFzp}AA8^t ]6+۴J8n|:o%qq",T>IO<{8mxތ nQ jdQQw0o z?E PX_'E)~ċ*3Ch9%J6[2 QusQJ%Ar7ڂ>\hzP!H -CCD#9(dd02&EL%µKr߇?;t Dt(q0T . "U*rʳvi_vE@$iH;K}a\TwRtU?Q'!>L!FԩǬYPA'-)HrÎQ!+?oK#(B(&)c݌b4W[i.O8+M ]jER_<\6B;E}h7)Hf8(=L$Oss x=~uC>g{1Ô) 8:&K%A#NN3) d=C R>):D)ieҙbS%4cAYK~~ i)ɣ,i*߅ 54b|k(RQBqԐ6b&9H."W !/ HrxGE B؞7}8!ϰﶂ˭9>eҤc@jOTŊ>> OÁg>N"G5S!91CF=".  J9*s+L\EF%=tD{Uҍد ~4DqsVq۟GUV'T}iB7L (;"8HnZMd͚tDV.ldF%RYcXp)ix U:oCg[!v897 Aۖ6'dE"?#TNZL~-%!Bcq;eX)9۫?^qQ[ l{Q+"T"ag(U-8Lqtor]}}$aD^L%Ͱ6^topI!̀ui*Ț?ԕVLP.ZuVCS 9F'7gK| 9_q9( jlҵF\`[,y_U/Θ [k09p9XԢ$F=kF]іb;= 7|dg+SVnj'dq-1K0o&+C#pC몖v>P6baJQ[秨Iz"zHa~B1#yMkP6F:?-sWY7A 4مN+1#QWL&ݹLfq'`"-ʒJ{V Y+pL̝GPrfߞ;b4^~Xst8Ͻ&Zsk<֊.q}a.WxRdruȽ|L.,y~IU5B/tRNc7m_th>b04qR`_3 2ZՃ\j嫂93|۔4ۤ`PO.L̽;MZ9 =t| !0u)k`|QPb.򇗯~~ɺ*;" Y2qj5飿Kd)4G/u+aggcL'48h$,"C8M@_;/ LSf~ yb{oieYohEpziWĬ9<)> >%9 4F/*(|2n3VJNꫦ`bp2-q`&0"?"ݒ% Mѳ;S(羶>Qr@?+Dnz0'8"W29Y:T~.GG@R{>I0C$lҞ?X[8ggaKC)PI$16[`jҚoSZڻDt M%ſǫf1endstream endobj 407 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 440 >> stream xcd`ab`ddM,M)64 JM/I,ɩf!C׏znn? ~O(W_PYQ`d`` $-*ˋ3R|ˁ y I9i i ! A Az8܆&t,bXE}k3gW!DW/+.[\b+3s`ɵB{rgoôc$iz{'KNk$;c4Lmllljho$=(;UajɽӦ}1S'vL얜>y4y}߫63g~Ewܟlg6s^|yƩ'Zi!fr\"<< &N3w ¾ӧ endstream endobj 408 0 obj << /Filter /FlateDecode /Length 227 >> stream x]P10 kH8t㬑 ˄P\1#gvx:4Nኳ)ӳRVfw_TsUPSe,CaQ| U< ,C\[ƩD'6I06n$N@sIKA+aaK׊K[l&V.f.cZ1Ҙ4ERTxJi0q`endstream endobj 409 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1933 >> stream xm}l8Rhټ[{gĠdt ^ZZZD hR( Iv>&vp8 !,P^.еC֪*ZvlkуI{GB-"$ɓ{Ui˵חoh:٦*Z$ԢVZb(BIѵM]ԏɛ'W;:]-MZ/֯PZ*>7+;ʔUuݭ-JU{rw2bَvfU[QYPkV AP:#=LHOXTjQ^<cHZJMֲr/[їP/;5b@Φ++x00Pymiށ`̬s ǁdSO*.d9@YԀEf lO/ŏg/oC)Ed2 @b%zYVzpU:>s9V&ߡ;7= v:D͒jw R4P,DN]ĐJfY 0JGF5[ 9$o3߆2Ҋ'"6mu<P黳I bcqi(&5F5G&/ޝFkh`daSCF;87A!@ݿX֦YOD{zkgNgY<Nd1)AdX'oz4k B|2Q𺇑"?&!Oi swjhC? h)*0{!Bmu-:cl̝tGiw d6Orū\^gC.< ,:Xa g2vh֭R- u o2auiLX?SxBw^$y 5(ٺ+tt:A*i12yI'EUWeT{{ww{{;I2ԣ t'}5Sk&Ba?@ <ωljp4Wմ$bH ~ ZZpRsD_p+e,gf(KwWarYP\ uzvfաXGWܧys^O^Bv{6-I`y3V+6;9vGܚP}"|"Q%說 }T!/(1/al AK#+endstream endobj 410 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 533 >> stream xcd`ab`dd M̳ JM/I, f!C礟<<,~}G1<=9(3=DXWHZ*$U*8)x%&ggg*$(x)34R3sBR#B]܃C530002013ȁpQL k~^s{-bk2u:o}YgO\RrXN7GGqʞQ#Ŷa |Խj]#t/^ /Q]49پw|gm]3{#u?έ~㷠poM-3Q^8kdw܊+x\7o^BX'7twIglww~3l5%%gd5{ E 9Arb'۬@9?g}ϟ:yr\,!<<{@`„GxxZ7qR_ yxendstream endobj 411 0 obj << /Filter /FlateDecode /Length 2233 >> stream xYێ7}m- ./[k'A6>Z !ޅw]T >>#[EMdxtz}@WEcZ(p}ԼtF7gWL"tsߖE"]q==mP6 e,Q2+G< y@@z!3PSrL92о}:_/jL+m$鴘D d6% gR`o ^@"氾t-Y@H x҇1'm sKBft{!pMwI4*z)vL0tFeM2۞S:=Թol+24I9KeHxV<%թn/u2s霾"9u}eX9-#'P1I*=HɌ99Fr@̸FJ[Ǵ2ʶȴ%e^v/ ȴ/е< }[62MT79'k#@k8.6 Sq"l僡7nkө,8/?{b9W%kOѝtFzHʄ$n LLm/w)8|o7A 0}`fHGHa<+o&?. n"iǴ#gwE27 79'paBj)=\!WYc%N.x9rk$Fbr*9"΋,38s/n2ec q` 0o;uvؑ2wYCYyvgɔ^C.ɺyuX]~9݌Zk/R٦quKiӴ4n%=0<Ĩo?Nٌendstream endobj 412 0 obj << /Filter /FlateDecode /Length 3109 >> stream xZ[[ ~ׯ8o=*ӹ_i$A胪m%Dgs."pdQ$C~!lW>7 Ѽ[ڔm.(,"%TgDl]Զ]\K:!m?n+ul.W6BߥLBUb ڴ7-c~IKmQB~jߞ  !_wC?/} vnF; EkW?-Z@~3^vV6Dߩh|qa-D"mnF yD;';nŦ- l333Ygґ "[yIR4Z&I7t{ ӡNbܦo'ޜĥ@_GQiOh*ە$Kua:cHQN&WD{MT5L4bn.Ia\9lCLrqz. 8F=SF\%BsSWG]G| _Zn]:UPoayZ>[a`臫?^>,TzmR-K-d$,QtT A >P2h5909v=3EqQ)4pldr*g Ɗba8v*j*LZGZhP],k`}c)\;l]]*d1sk|:Pư"p'>F* iј bGgG!m ,{|zef=M,krsj4JJ2O|6y S9 !-YXqSNz{w=P:ZIcut/=XL9 ^ 2Z5aILj$9/^F!s?xn+j_̑~u])I2ɊIuv"#1eb'[zWa31\xq@0*_v{] 9x*5Mm)"ъMF8B,9ݻAsؖjV\CEwmoF d2RqX eFmJNP|Vr ԯ]%HH(>U%]g5tj >% Z8G\~pIMyU(XUz(;IhZtJ^C^HLJ7(~?;I+*GhcC%tO{<}49z.%XM netSQ&Lan=fm)az`R{yBI~D5 Wr#Baw[ppR}R2XJTr|SYnaM%|)NN4NnfBCd$bZ tCpzuBI8ь".E^r 7r߫y>Bw3TâACu?5BlEv }lTȹCOE,u )_FpWmSE=)b^'\q%rJ3JaK@9=_ {Bq/1Qb *C5(oa3|u$Z,HoPhw~ q̚Y^M5+tT!܎4@0\Y53֨fQ' w #>-Im ͺSD7d|]GΦYH4m1sdfPRٸ=[)e_)!x?Z >(}ۋDnEqUKu/E UKl݀#`F($+$tTy5w`+d }䚄@TIINHLP.&Q%3FASp)e_)/ 9(M*^"aeqB݈RR=v}{% CȧQ%H=%אܯ@F0 ƻ@#_JH2|Ԥ(5wͿ[iLlH_yX'[7~Dn_CIm0۩<@3S:I8?qnAUqϘMt8pی,ul8*aR:Յن{\w:Tḻ$'#q(qjyA*X<n,do&~*[^ǭ.ډV?7"~u-'(dQ)N]$ DXrO$7r~=އv{KhP"]3RYBN%ujnf %E2nqT 7O%jIb\EsdˀBstF9Pݼ`sɁuYs`0's`]:;ՙfiIliXs#\,>xY.:Om΀6i!$XE9 ыN~Dny`4_<^xab3K^"\X 3zF.Es.d}B}y OͅU/˅S_:!bfB LXBh᧡ͣRgY"zQx6L/MxL8+(_E2pJ}L.f$Pk.`X/ $`Ќ<3*Y,z`|CB)YɆ!il؋lȢFӋ]*6FJ~%VNYI_/KSI_:!vJKQy_LA3~@q|>u KIC%)Mst DA(yd-hbы 9: R`:RUAԔP.TIHd)6yyRU"zλ->zazF;= M ?M0p.p~wߊ +:Z؄.P8my^wͱ;9qtGendstream endobj 413 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 4206 >> stream xWyTvq@A@+KdDv¦" *"-.jb4.1p#8(.(YPQyqͻ=Wy3gz{{)AMӆ9i ;{F FV?&kh# A({08l M(MO`7?2j Wgf[8OrZo+Ui)V '9c ErfvhbUVs2W5EQޙ>ˣ}WgZ:'7!oIp~bȚ䰥)isKPD9Orqu{igx~m7>6~"'(*ARXj5GQ*)_j"CQT,O9Q(g*DR)W*rP`* Q(SJJ xʌʥ)AYP#)KJFQ)Cʃ$Lʄ! k(=tq㠌A=N/`A2*ox15ɦ7\wpŃo56h,yd=!c[@w@EhD0n *>P0xNW!q\?iu-k7=c 6zrDoT J+Shu ]K$ ]x(Ul?b(y?栥1|&;#6sNA\PzɻY*8ƒ|GbS;0\,~ɀă92I;Xi/pdmuS4?`M !^S>`'+“pq kӕh-I.xH,hg #]XIva_W>`i~A*(@odn80:N>C{ KH"~usO(Olv{X5 kk{S4Lz/!@5mV "! @U`ũ}8Ck, $@I4BDX@3&=akU)iZ;LLF`cG5ҵxri<4))H@_d[D-"HN 8jFS?g#ݏ294hξeh1(N&i'(Mӕt07ZTN0M+ݨhG5[z&selLHf7p*Kc5.,E()'1cufNpJUFXoщĚY B]sS$=ss#\z?P7g6iGk ~F}&ꋭh̏ݳ}{,$e!`uݵSkFtg!bGB1j1qC4+"f鳷Sd>S+?s[+}O w&psIhkrcd7 NV. ?Ԯ5"m0~+9ї^B1l= ?nD A \|DXrҜ;De^` Ep7ߟ#V69l!}Koz2)=\`*! $Pִ@!3 0qU9Fd0W,U/$1}$DLǯ0=nspo7 fت+Ur;|@};b[x䰺uE=BW@+Q-Lb'@6Xqj$- BNYQ%/āsơ|A#Åռ,G) ngi^66@OAN._c \_ Im#Dz`7!n ;s2[]L7=:R>8IAɩ 61 <`9 |48 w!$.s5QbDΩ5{bS8}dC/o}dxL;Dd]뫰 ?C=7} ~5ЌMI/z_}z k׋%٥BܛyjҺȨcP!!endstream endobj 414 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 729 >> stream xm_HSq{݊.+Fu- 4ذz)zS4\M?hbN9;u9ns3gdV*jYD ! |{ ė y8s`0|DBP)jo Kd ;\)%axܵ=YZ~&Nէ! WQhBaƥFJMPxf: |o '2=0cPcgp ~Db xkڄiMv xT7Zq?=ؚ(dڥms=i M:mm:Q}A0?^xpYrtr Db >ܓ,Lj*'L}N*>Cȴߢꕲ9 :eI&;> stream xZߏ~Sއ_- sN6Eb":9,}!΅7#p3oR⍨8>W6 FW_^-> FϽ^/QI.}k2~#sW˶B^*ov]/yM+Z۲+ yifM jUNp϶mٿ -]xǠxi30pϕ\x aCc<u`RWoZ|O^@Qe4B]%E8tu\W?T ثiw7qz!hHr8"jvWoD*oIEY>+(Y: 4j|xc8yx I3iv*D..he YKXaFz{g̎ (?3uPRm^}~?CV %qpc@K_)H6a߅yu<tLw[@}m cGQ%I@ryaq|S"\w8`q,X$a!Pj윢!liR׿ss+M h 2.$ynG;{G m9а.V $>@B\}SA`x!D>D(7xu8md"VPS X_JYӴ /:b+B\(`"% Ь/q5r`7ɤ' ldRbt0$LDݙfv?׏>4)}FV&h"6y8⠕ױc|zzruszI%Lc1pS 5@$䓗"22"0APsҁtET.bPnGTqqc] E+J3څ4"L*GP.^[8vF[ . Wv >D!NbK$ <JU0f܅vA3D\VOBV?Sa݇E9^n/,3$_lo~F4gfpqiOuW`E8mSp B>P\GT XxbTNrwq&H19ס='5SF/p\mo/:Lf,X8q`tjzh?`?P}Xڼ)^)v> stream xWyTSw!c{:n*mֶՊ,@[B$n|@6B,ZmGbgyrN缙˜ЎoN߼9I\$ p8' 3l'(p=(~,!WȜ=\XrUQ0[¸adXR* se1[>y3\tfi-ѱʒ|QtFQVt- b%(z(:3;7 'Z}(;-:K&'8i?{ *K{erEFBQ^Aᶘv`X"vKb,;va=^l2, [}{krZ~m\_r)뼣ɥ¥\|n{y*h+*PF>>Pq'gqC JˎVZډ ,| d]S P4kc%VU=v%{ xM-I9d3"JFG>XtTe.}{(0UZjA$ֹZ|g{:~QvDž'XA:ȠJqJS-ZC4L7OE*ܤ!w2c& X$tW[&'qYkZ^C p,$Qv& uMN"6/ fP 6nL$`SA( E|8U„ܝ& ?S$zGZ;TC'h&Q:)B"Do q:Tw\ YiҲjtC# Ҥܤc/ε(G!o߰hk"3Ij)j8aXOuł922yoO5c9M%p8٦l##{,t[C(K\VHTdmeq48[ -4220f|TRJ&WJ-n!osΨJ`ƥ/&jV-R|yK}9@(U4/M4;8 N1v(Pf~yZ]|dV@ywO_g,V+4·M w>@.W{x$8).V+u*JFٍ*Uȁr8eiF_zp}QN3\#h8{?U.@T\tu, VՄV,e63c&>wcl%U5r8q{੖j'a؅W'6,SM! )Yq$ty9q ]68ʭ5+eRC$PUFj$mP ZO_=t-Ah+ZK<F|-$^]s? zB"fǥwJ]&^75pIr;P351uz, ;;u$z؝r{D`(M4t+%_/I|[R 1H@/s&2~;G]!ׇR'm⽍Aݡy2Q|3(+!N" 8UV(V^UM18Yd[].2yD[=eJiY~Pܺ~覗әS@*.8H_e-~V'~5G&Ox[2궎~yrm\ f=l4>e,kP/%g urJ4::H ZeaHr+"5+?*4I?PhlJcSְ"f'owVAF>1'0 fC!9 eɊݾg@n)>{;|uIIm*%V7YX3Qs6 eւZڛ;h'=칅tٙ^< [A-FWEꖚ3-%Vd_JcbJkkh\Z!DK;#lC_FxÖz{Z-VwFoZ+)"#БJ6{:GBf\NDQnp(ʎpm)f|@#(lEк; g Ec"2r=%5^IM1`1ۯiokjkʼn_ßn0^`NՉFT2MH65qq.276]%Ucy/YMIqX<6:Vvt7v:T!ePY&0E 췈 @ϝV2Iwo]a o?,?Іi \H,aoqnTWC1Wc1aq XIn/nL&RY9[r F]^M=wCh>=]$ Y s{sѫc3j4_\(V)=Ag'.L\ )7VwyQ /|j|!q2XJ""zlM3@VgsFİendstream endobj 417 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 763 >> stream x]{HSqw/n,'U\(#i(aNr[YYs\m{,=wsLYlhCjzX)? z@ƊOÁss s ˪tdNdDL\_cbF?}wnC\Nz~!=`d=Q7`o$c~6}~ɘE3y*Z81 p8ǙNP80Nf8S8 aP endstream endobj 418 0 obj << /Filter /FlateDecode /Length 2257 >> stream xYKKH]A`7 I#s,IynRG`Iꮮꫯ8baAxZGQNJ"²(S9aA,WO䋵`,ޑVT è#r)3orZ.2-yNO}wΑK++J&m}ئ&/%eҐS_%cRRjf⅖pEX2Q)x_6g{8Qs*d{xcTESk~)YI^aWӰѫvӜv?#?n|Qx#b<[ ~('SW7{r^?_)'lA|Y{{SA9ϧ}ZԎBRGk5%v[T\88L!&hw 0/QU~J(A8B;Yaś'~BaGS.{ӸVNJ8 3h4?/u83Z+`#2#f+&/ q28q^(*_ A-$/|xRJ-@AFx{AP\ Nz1+!P`o&+i p]iH02};'ю˥QE4DŽz#.%z|LvhL tOKMɰ#Gi.x0",S5c=1Z{ӢkRs*rT] 7B\2ZLV m{`KǸϜmKIBPGP$x% <뾁_+y9sO B34' v+ '0sE6^I{LvނC~F gPۂE}{yJY&YhQqM*-Jd E{h=uƏXOLjSÍ9˵炗r썝tF ۗ6h wڧ|8ev #d%z5߭ov7č{/g;5Ǹn~W6YђuhL!\LxLٚ|jмqfA PeAkN_̧r~Lzy)tql-`)HN$msP an#A!0aS.P<̉E_گl -5"qd5C酖 ɮ)=l4UUT 7XM$Ւ!'\h(L!qs-#5zy!+j.d.r \S%Irl34AipB24қQ g+ g8Ơ ]ER1]icnhcGGg4qlBȵC[mZa"|^S ~?;,_fn֖׍a:a!"?e$72eLk$+٘t8_E #a/'Jrhv̫Ag%xSĦguጒ˵ '!OŮ^ur޳&kVi|MSryzQ;͹^LEiom|Rx>O-jreg%=ЧKl)j\JLS+r4͗ ^Ql19}-]݄n?]ŵ@6{w%#/M|> stream xY[o#E~_ߨ^YF0H\,6+ N ~=jW9ݝ LFO/}^]/DfBv&}\]7z "fzѫF ōGm}nUB*~۾jZkd_mڥ\`o[($ćz!O ڰ7-#%RDNW՗é}yaH7 a/6pիS]xZ|CRqX(% Lk{6M BZ%3y 4BK-$d,e&qPi,MpJKVW%H_hW^hs0 ϧ#$]k~7[R ],x$HCU˖G%;)ߥ"I\'UT=jDQtT7z]Uit~5$Ns%;`@(PIR(@8B (PIRR TT("WD% 1:xlG0 _[ѐѳp۠t6WwÅDN,\u~Y*˅ww?A,z Oi 04TN 5Ι: џ!S Wκ3Tq8( UFW( QZPs58S:{bE̓&47  KP+?t@ysN(<~PU&ּ05" Ј9aczP"Zǔ݀DO 6s-@2܀-P^LSH/4po[55;5 !"+)vz{wpN_`:[/KvtBPo7 b_$H U1 Pfsك֝T;(߁N n@G+ٱ$f.#1ͦ)]@;)F xPUF7\6uu@3R)V.P;9CPG0U $ϩug9’Atzi  MHhiV,=qn O;p3rN5Kʽ ʒ *@%IJ%RBr(PIR^P1lK%3X7,g' cw<P 1U1RE EvgbUbQͳg5"2jET":cUYĀ*I<:G*vUQbYuaQ1Q1Qy *#x$hᇉ3D <%ѐLi#Rr%jUjh RIRԮG1 e xAU G_! %. _NΒrY:)PIRR$PB TTT*IJT}ABiwUG Q1O+Ǚ0HT#=j YQTCYK=@52jjd<Ȩy"wT#ƀ #114G:BM1JD#kN2Ơ(ixD%&'!q4/Glw+ݾ+ޯLca-SYDqᩊ~)u<*ф|^Z4YmR{A^Ya1?Bљmux.o9ңpнGl_𬫓HXKAC(`HcRꔛƺƎ\@k7'Wei$HEqzZIm:8TU; <{:KTKpQft>]u=ΏRJu@FʬNX_L?oQendstream endobj 420 0 obj << /Filter /FlateDecode /Length 5714 >> stream x\oe~_q ܳG5A@]`w ,>8ĭ'({},b""),۪WؖOPn.eM[R_/Ddruq0o`#Ok>\?\}{3AmhPuy䒍psyATsR:2u۔?<^x)߫?^RͶ:(bkKά6.Yp!GP:Յ%lzrSjrw񮧹5ؑ+S F.x`d0jv)e|1JwɎx\t ذEmզSQ4`6 WqmkDV)櫠x:苯.g|iuvI ~W*1EFe.mJ:z Ŧ'mn!l{&x-5x^[2Le(A'Jq@3bEẌ́n򺍫qqQUGB FRcr6~"*nȖ~42)TjժEeG"YBXomXMB>,"ZًF Ms@6(E00fdתi7wGGQ)e%zs5 E8^8Re)eFQ& ;E`J@uHJ(cVlEhVV :NƯI7?ٸYT1sBxMf9)*Ů)L\-N)HE0]pNN%+si!3W`[FI#v,_G ly [A_-й CubYU!PUD:r9Tc-oӖkJ¶Arw2ͺ6 K:Y+zRIMEUՃ]#euw~5f n;z2qUZ\rnR=P)U&E` R5\$ h:ʘfVq7W\qjц.n #Gˇ!rg(93 %Y0rw\=,.2&)#GW}4P݇X< Qug,rHsJ^B=gEyɁAI[QO'3tWj.84**[xxO8hX_ 807/+WcJ ( t ,gJEdU=Jn/JHa%KwxP(=.EO1r4#i?A&X dDc5q~v( .gJ)F. YXhhS0 Ŧ H$aP2d bsU2jNQֵD¾5!V:JC>̉oi#9]gJ~1#D+RBM@AbeË́fa>.&l}$!Q6HjQHT(V6S v S Q6a)R-q"x(Q(G3E#Q9J0#o\t"ѦjZS/HxZ\:0$d!\a:wZDFڇց_M mktPWg(Ӭ LJ6a֣aRYM$2QeaH^V*QWAbJυ@N"P@`"V0[ut`̋C삚cw2̪1a5S8 3&'{'l zY-ΫMڀ .N8P5I1I(%"Ytp"Vq7v)T{z€` '+RC fAqi6Yl\Q] V̄y;N:T+vQΛ햷nF~ރU7o/`è&ԩg(,*o Թڮ:e@خlx[zfQNB1G=5e..V|ͮ.A/zf;-Y3R`Z7ֵ{%Wv,oNVjGiI x(#9XI<-%vkoHdXǜ&U1[>ߨБf{>l# '=p-'*$3)w/Lo՟pL8B~#Q;=㥱kW7reJ7s5 r3 E+UR8!/B$q!XkbP^hE$FV*N;WF u1nQ=Ǧ'97èaBTj FI(Ci0>P:rE٦5$5*X ;9F]WJssㄭv l2'~\&#as&#^DBJ x%]F6?v:X6pT+q}MqnYiLFO+KU7SN)qT^ύH8JQ7)ZbiMb+]%L;OF~4b}WZc6yUuN#wRXnQ2+<7<.? v{ noTaĔsia$HN)Ӥèk n8*F]㐫4c0?$IbJ4f0)ci/6:e^A[d9K t1+\Ab&vO:Yۧy2̚zFJ_Q5J wp8jP#)b^#,kh&46:e^AY_r%ن"u,T/] E!tfb*cҊR-.`!w~6@ ,N;y!yuʙ!m?pMЊvF:Vϴ );tfc[;-_1D'f}$5%J@snrcPŔMa@ɭ>Q:JsS / i.b#md *fW0%+,*[ht gJm:.dHːQ0)DBKQTH$T(+dP٬`%L蛆Aeӵ*ihTrFq͔i窔 ]!bP-?QZDBwmFL)IQ,6jE`Y¸ihT6UAe .䦡}Pd *ehUr>䆡}Td*]hUu6ɝ e55 0n S p4 C"Rh^8_GE~f/ ͦgHU~ӄjA`Y¸d*wWGߍF< u.C>? c$f.Mot#Q怭5=Efaʔ]7<"21QGjM <.:JlP+YGӌjE`+Y¸|>Rid?y\zNv 5.O*]G@̀.nU52ˠLy76k D]^,xHӿ:7~:[ZE$P]?Dn89fG>f}x_ +ұ6u!tMȂ̀N}΢Sq@I"Gs;_miu?d~{ytzgF~E #HW_9r&ѺKITw6\O ~MT&}xz~~X?CMUӊ޴1pu|k~_?_{x~Hq> stream x\sƱd_R[/"A*IUJ%*o+\LrΟ`zPZK)D`GOO_ eU n.ۋ. l._^_[mMT~sỈK'.kS2w\ּե_.^o2US7WJ)x?ק=F;Wl7WxH4M鲪-nvyuY )vW3WʔZ_MrMW2WlՀh͕DT}wt.`Û:ʎG d5Hqm,1k{\'pt - \&1ase$)XDuV-orO2R#TL,.it s{ zAljvOFc0VQ$؀S^& xGGh/]-ȃْs[ Z{QGJkeÃ#W^v8Ε‡'s74Wɞr0#Pݠ4`{)r{0t6{`o^ic_pfGEt 0{ jXoLg;4X"ᗳ 1i7/s:~N!JixܰsF˺sٔ%0ߍgOmz!&)z7P듭7HJ!.-p!br=YkNꆠIUb.<{=F /dqC^?wl2d vh9i0Eqe::n^CN_&tM1-\4W*) V2? 1 0帵 p0fqEapJn>,PF)+S =;7LA/)|d9hA;`*~yAbpK Fni`+1'6T4ѥE05J<렷;ikl_<-&}w'w ԓ,b LAiXꪬL{XW7c`\ȖI;w^m*& 4h(Br `vJ%CiHRkf)kPp:x E1gL:qݤ{ RǂQˇ>RM!@h xb.J rEjYv`&jJ&sirK'8y[Ǡs1}=gDYJ;c-9v2'h!8Juq:=fHr-«D qdf6G-B0y-jNSOt6a'S9Hebyw6QOcYNgŶlj5D1` )am>(L@623ۃA~rрm?hN0 +ai.cZ=_SaaeJEC"X8lH6c棣!a8G4 r:vLd2$Yϕ%FH! l!IiULJv)|Rf̟rxw)P>}Umj !̜i繬5U#1cCh8Avʝo(n6~< |o ?SŚ X̢;ugS4e0Ž2ajv2I [t3L1^&{ uQøSX[T2~ /'aZ{K3vp@xs@Fh1 ;?] f/D놩sn e Ʊ4bbT RT, MX,KZf_+1V>ZHux:>BG$^"vj'ٕ! ,RvTh@LwvVv6;oAtS*SŅEiEh p5?|rx  wɑAK^XPe[m&"ɩ+Jc V-3b|LCDzt#E{q#?m܅f*Lb~꧇ 0G9!/U" k|.@ZWgH.ޚ= e,n)qyLJyχ4DŴpsCޙu.PuEә"EC[1c бK67J",{'iΣj:4n}]rx?U<#0 ^ )vIJ-])ǶRp Xea ^hk(WGg4@6ۏ͟YZzVEA2 ;{w6CiY(M p4Yb9&7`ĚȢ5 9f9мK]ITz˓ N5: B^8OZgJk;8Ӝ)jS%imɫgPwId~8/{H:|Iخ0eY]i^SB^R!r:IH??}رHw?e4j=PMU3C)^4dQhۄ|텓M?~Kn/g??endstream endobj 422 0 obj << /Filter /FlateDecode /Length 5438 >> stream xo$Gr;xt?h q;sh3fzs7ƁsQ^ߺlU)ޚoo,hՆK:BjvSMTCHSMTAECUcnVATe50ƁZDϵ_'Z`)B,JTI>"eTkiÏnZ~A9̫zҩ m8IAިSUT7jNp>*ʨ4‡:M^PMᔆ]iW8e #] =8}]r6ڔQYwX̱;rZNSde]5Q;,e0)j}Y]=Ըt9E0P8/8)2'5-TW8-N)H1jY]mHI )r`Z(R8s153VW^!% \0aTSus6jMY#Wz-a>g~*-ڞ)ʐ)ReƮpJC5vS+:j$SW5)/:(@]2*躎 h,C^F©K@E 2mASA5e4n+RU>ab"(Ye5ERIPUT0t)rւ[DUF#_躎 q+J]Q)i"QC IdPz\ *pFAep)YPM5~ܗ.lCMDmWXA9<ߪ*_K&F5eTV?e>k>ii{p O?ʨjmfL^%BL=lLj|fr) "?$'E1Qe>?UdשSMᔎuSPpȓâQl-m5yS0@z%gQmHXݱr4O"(ȲHuS,8EI_SF5@p?9M{SGL{ȕ͜/>l2ޖiz*[GHiL ~iwojT(`Nx 0ZC|N@0 ~qtk,LWqgZhsA?7w8? Ix#MpD=3JxfP7EN_a>D{ r܋䠳>mBX]k=Pxӳ&~&ni(70tW}5!b}+׍5MP[ : WN7S^QNUʧ^ÍSy7ax9Oߕ?dt3]}.~g޽`83뀡nql'SXᯧGVmMHvz;wwKϻCğ_/i:e|6-{\ &ӻZM\؞vd^!gY]:c cAE ,r}Nb/vkm`)X%0ro;^.i9Wn_cs1f:7ӗ_|iSwK{N O}'>ffxπoZ,X|'aI`0bvw̔ay@ P@'>˜'vx]- JB]. ?m$!'/[nyuk{-pvC袥0zغVn*Mj\h>GD5ZhҼ>E%T%jIm)r 84H:Nt^n1kY)b~s?2ΛALiL,~sMQ0 ;fuUX9ӑO8Xv`P.“ w/DKk K0G1m UYt٨FFZb X'%pٽj췧V@Qg)lz^sC\-vWd*Y&,J)+fmF{>^Wُ rG9 siL/m36B׶40~{ G6;uĺNqkYON|b3lq{}:8r,~pvvBy\f}=XP$H~>tp@KaREpe?_w)^=Ⱦ-r2Î 7D_8@&عbΒp Xl:N;3" vݥ~o_m!gE|["ͼ!8Ѕop0֬Ri_#O֕HS)#ŬQyaN#۝۷GաcC1Lɭ^3NQ$\">86̻VN`B݄p-}MϵA-uP/zrӧTr|Kk1zyS3$H&ij tJ#>?>?W1%l0˩% c̴{;*1ǯ䱀5ht/8Jd+ zxNbC֛݋__}k `K/?s6^x,Ek2+krF;qMZx2h ,ʽvἣ]!T/=!ɭKB9</exf> stream xZmEoX~KhТMEB\>3$%}wI"% Gyyaյb[FUs_}t{k;mX~{+g\Yo׷߃ؕ6),nݵQNtyXoRۧቯL7w ]xo^vS\Bh>]{vK^o;]sg7|N[NFԪUb:o`ǿ꟫ڊn^V{h쏴=CaeDZ\Cm7݀bR*j5R -ZauM}X`!BwRAۂuZz#_䂉2-yqޫhO ^4{"$ 2pJ>VFn}V騼n`᠞2#'1UV%4qfHANYko\gZ7O#Hr#u L 6;*HIkXɼ35  5:P8*#z$jD0ldґrPiH_|Qv*sVSd\[$h$U+woЦ32ӍL3{AYL1 8YQ&ƊV"PW)~?R'Pr 7($$.eL-=* Iү -S9gk*DҤL,ju@ i#5iJPGC&"8SQ2wh%Ht` 䛨;5/2E-#Zx*KXMwX1@! _7Ђ|VcGȳ" K)jʡZL:뾢~jLmz 4×k1lpF iw.+IoeY.\9%߳t缥O/fM0HP}Jo#!K k=8 ޻T5cc)u!:ttlv¢"e9rS|?{EXȀ[j5v^#i%P9PMӗ6H%gGVU[]dݻ:HR~=CQd?{ fߟ>49~R5$ƞX0oa۟tz'L`W)޶!!(ݜX4B( xbJxG?3sP|re xP%/XgdN+I[{Л׍F]@,(a_d8#~3~dDQ9vi6.Y >]A}ZK6 Oը:'ԧww)xD= >|uʕ jNtW Kd5> Ǥ  0ތEKgm~R%K?5;l{z `֤Reu:]!~oIˏHZqgs0NCV0K{Y5%*-]d)jїv!HOHyHIAŨ] .1̡潔# B5́Ve0 $?]QVWވa_Ҋ3J-M]Y;?9ؓ0|D@DR4mJp_(,,EG [euXdI^G(Jeؗ 0Wvʰ=Ͱ(F}W/Ӫ*\5/v5b=͡댁n5hMFq);H"/NbHڢ $c I)ĸa8_K wj#;|Qo+FʄԤWs<mt'&ԌJ/ΞRiJ$!:ݟw K +? Q$[ccΑq8)϶qu<S+{)ntl8n܆cl΍yE!UqFÂfE_fRXx8[oQ`Mz3Zע995ƢO E}p,Sk~kUNjg$2XAkټa+D:GCEֿhEHΦ% ƶeJgD!Ic}٭0=g~Q昿8#bأuwscZ24y7(Q1i ,YNBPm>ǯlxI ^]҂{^NkPe(̕`M&!)t.C|>*{N'<<:cfTSMۜoI%^P682n1L<On^%1wb^A?leeb >/SJs&7c}=Re5}UE',7cEؾ/?S?* ɅsM:h7t ,S*[6]e۟׊ڃ#UTCu\K+g^ŃB#j]^m_q}ws,$CnO5Շak'g ʼn5bx/Pq_fzA^qyTVDDǃ'Db6}HuA~#gB-OҖ-M-9A \zx#O s1endstream endobj 424 0 obj << /Filter /FlateDecode /Length 3068 >> stream xZK#:C'*4!H3ڱhW+"[qB Xﯪ}rѴ/msxinwş~Oxhh,x8xP-lWoՋm)l[\_-or l\)p+ُC3A{n+[˶cB`,m+,;tuq)=ovluw80tרdѵT=q,EzpFPF7FkN&9Fp_.W8R@a}@e%M:QG J%Yw&XɽɴgբmuW{@iGRuoJYsT^7"Z+Q-9n 6h/CJٽ+^Z8fƏǣJ~WC@ҘZETSDKe)DG3+AiTEr| l{~ n'A6fpi- 8/㦲8p{xjqc7W}iTg` /OA0׵s%S"쪗wñB#ا,qN`ZƱ7JΜ9J 3] 2'{ f2" mrT CN4C}g/-o>HA* L|Y_q!<S9venRgDє^,xlOcStlSc?>nrpe8#k۟w<1h vnId)`3d 7,Lt~l,fDOGgM{'75\%(\S,,%bዱ4"Mʦ4h?>ӆb".4ibRcSFDG[<=r< o'6\@C~b8? ϜADgsRB]hr0vR:E?[D#pgԭBآ&L4kœ4 tԵ\n> stream xZKo/$ukŧ&L9QFJg*)LfVSdQzUUpn~:ԺξQihʼ䫫wgn_Y*tRgL?sv6eV\ް<˵,x^z#]F}@teXneQػeYVey k>q-lsUca?7a3k[-4 pz{ͮ꾺FnM}wb mss vF`}߇=L35w})N<$kTp*:oQun.٥:϶o8%Yy}r!SJœ\ FҞܲټJ7~~ط 6NLmeEŨ1~ZT) *ϤQM2jr Y{8r ^Jwj8%h6lo͞ZoBs%2aHO& 8Q]&UY`'Kkp/?,/L Ctn eΎh 8{\kGfX0q{?XDen;?$iKD'85[ `.(&b!J؏b$ԀK\jT:Suly|y@ ,=vxˌ0F˷LfZ#SofÕ\UɎwꛄ?O(vЕCR ~{+PA[.X?x~ =GߜR4f08'Gg˾"+nߞ ;:s`,1%o:G\ýrݻ^E r|` -ܢB Ĕ+X~ev0>H|XX 5MOM~+v3ͩY^.P1gr篏mظ|ɀ`%Eq4Jp?DXh#G[TM} 9 #&HL<Pf5b&L$3Y x Z>G<\Yd Z%yY+Ω ոghI|ӅyK0_W=V`[ 2&öʥ8㻋ח^/ʰSМ { rY#37qPIa/ Č`6;H8-M_zF+Drҙ/vsUͦnF.RĽ58*y8\?֎rN8Nʿ.Π3*N(k uK mJZ!=C|EC_Qr<(J/ijĞ/*5͑V^0vr池[3_x $9@.qO d['[Jr$$)5Ght˞|@MOSBx5/R'7̜nH3On/6;?<-- Fomv[XU[%* xTm/3 <ɜv/p{YԧT[$U,Dy-Sq@R̼( j=`!jVRڄS<>ςfji(oL݉+pAn%fj,|H vο9jqR"&X#SJb]\F)A˥$,%k1PVŬI \gL|~ JfŀY.ܟr]H?1-Q܁ހB0ݢCvk֏ǟ]0>b?-/9 Ѷ{o7hD:r[ c&k@iɬ*U&؅/yzOn T4TNV*v2>l(d̨LINUz=-pkHZچ᱾;}BL|^KͬpI*!ROs.*-ۺy $ 5M {0/J-0NtIO^gvypXƝlSn!S׿~fclS4&x5+' _+-w빕9 50?bBfVk_`U DF7ђ:X_@DvoGn!^mscAjt'AeZqNn9FЬ/{w=Ĺ.#'CPP:dv>UrZ׿>qKL g`qL 9V:`8ߥ3 rV)dS>W 3:;+7>LQѠɧ>utzP؇Nyb' Yӽu*#3\fkD7IA!Fz i$nrDCބ}|rzC3i`b%0`ΐvKgLV᳞aR-VWKl Sd>r+54>W fL0\eWh{6t(4\imCb.PɷTDp哃ְ 7HNsXqb%Upendstream endobj 426 0 obj << /Filter /FlateDecode /Length 3710 >> stream x[K)''NaN`(hx+ߞ~|Zaꫯ[V+¿+zwEݯaSH+ ]Rd}ʖZsxz{]qvMJ"s_Yms ٩J* k!+ 2[5ٺ6yoJEjCy {fn}U,P A-JNv]0Rt#JsTŶ>mh1bN2͌Ţ1'cx1iu07x]Al'Tk0a>$nJ"0_~ʮ'/yÃԟSoS܌Lz:sۣȫ.5{'+yjZTѕҤR]nr, Tw ~N? IpSם =LxGMY\BdD6z7\K4ӄD[Su( t s}Y@ zkM=;[ ?p?BkUvS&1{LBe5[`]իsYl}!U捶N+j:JIo뻷{ n1-1[2)>2,8ĥCwq UރC0|"@5HiSvnn޹-?Oթ/X̀Q? ,Ǣ}vN6ɾhld 9rZt*$L^C.Tգ?XC?c=%'vٱ X/LɨI@ (tMuy28l pM7NO(0Wn+'̱ٓYy{0-KM/ӝOMpH|`-ykSO6"Ia7]Q$3ld/Μ|f|'ՃE+G< INM<- <ʞG?ʉaEex'Z{SfBRr H~2<=|V6p  v*'`3G/T+as@Cc 7RD#d^˯2#~>}ߧr}/lFPN%_uAoO^|9 1%Vyi)u`ui/K'сV9NugV]ƌΏ|!8j䟚.otWIK= tq#l^>/3,O{Qe:S'f|b-Lr>owQ$rZaZ`\/SRM&vkС,[L4jVaZuͺop831o%Sb|XIWe5̈́85$BUzQ&+XcSАrHGp_|2م |bnh3Zxvw9sC]HI U/it,SSu.XG'(Tf3)mՂss ".Ψc1+PgebEu@lKcLNvO;\ء못\v[ b<9Ƶ$. Vq6 B.y7L=Ӭ:%VRlj+'vM5rΒi%4raϢ)=mYT7#& d *\̱\<7I]@&.JT9^r ݎ $5\U)`mܡm5i8kYVچv&Ǟe~x\σH~̕xFJ /ݷ΂9m h,$MٕnGDzt!1Sx<&Ħ7rr;(J%p_"fʠXsK7q=zڅe,ߨCŶog^|'Mٽw*dEX :H:%b2Jmݾܳ{Ÿ]sӮq|uֳSelQХV՟"/ǸnokܥPv"I޿6YG|R1,܄Qy/+Sji#咗̨eMLx*_Eb :LoޙƴkKd~4H|94ÇE$fMH%)^$*]۩o#'[8.YFj- W d42#['6NF!;!lZJ eƉBEp3&c{PHC?~o䅤/ Aendstream endobj 427 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 283 >> stream xcd`ab`dd M34 JM/I,f!Cܬ<<,7 }_1<9(3=DXWHZ*$U*8)x%&ggg*$(x)34R3sBR#B]܃C50\``````(a`bdd?3qG߷0~բxy؜u̙[r| 87mBU\XBBy8yL;ódKމ}}}&201g>endstream endobj 428 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2637 >> stream xuV PSWr"ulv J+jA}DJ0gߛDyB[g<q:iB&9_*Zt%KhmhKvnT^R(emIږ$z]*%E#bT,ڙ!ڕ!-])mMTTXVZV]5o;EۉD*N"v{:b XJl"6[m b@&~OB'b~G1RF'F̋%%!vnl?rO9MGmsƍ >nyK/4tI jE-[~ (}k`hK}7zVB,Uȇcu:TS:onO(Rm0 Ϡz0Mn3GpTdf8U6WԪ+ @sӤlI* ջDK&N:y9FYm]=gWwql/(g@0P3$Q(r6jS\<0w*p: NaXsd<9aolҝ_ =@k*k*{y飃o) Qև3= t9PN]zȐYءtVʵ:txfO:s͌Uۙ@Y=v 'W(| ޙ1F]KW+< TaEgtpr.6yNE)APq-C˗ ͓@AsP0/'ŽpY@PPUgu @c7:\`:iś>: xAϑ*唦GdD.)DV lˆ)%m]!A#\N G / GmP}0ߢkgzvD0[,h:X)Uj2kH4U/GGxD"UǸ>Az8ݏt8'|@8:)hhWh@8EFc; GM 6^/aFh-~ p^ڑ;F`q^LDڗdo<xyw>Cߌf+Ou5W_hwan(.Nو%*- t9:sL YTv4mEI,Y&SGO{u+.ҕDa6FOy?fس!I`|ͦ}tM{<<d%DZŋP Fb3M4W+^歓ʹ\s~ <8Ƴz(`0r?Uvty,*Ɓ /h6}*@4p|,v|pv)1J8&hlpqiّ׾a/8iY2毣*G>og!͸<rGnQ.Uv/e%'Vᅃw-H ">6tgí@9* uL2ΩՀ\{8{(Ne=2YiNxb#Z@r {A+-.ީ>ÿ4w%@/p½_zg9{+#~"' ^lQ S/bZ!?~)5?Ho5:=Ξ=wf/ "I$`uIUzVGoZ )@CimJ묹E OG,AWY&1,訴+*w|}Pu]Z7P;0V^Qx X{Z}jn'endstream endobj 429 0 obj << /Filter /FlateDecode /Length 3845 >> stream x[KFW0~=Ĉ@!^IњǤf!baAv#{0U)]. Y]PG]W/_ KW^. ]jKj(s^%JN _mW+R5%خ.9/w%~0(S%lusʈoSw+KB-_W?,Z;e,2jϚsBk=;zqn犖. 4=E)FJҪ 4֋eK8e{QRSؼԸ:TPJ/5RvGYr?Ro 3ri`i BK(𠦘/V2YVHV$)1YɅ )r2)vV4&NR#,s)~5t )e VIËCtZwn%KKߋg[S P04uܔK%!\YJ& k\i9(i$@ p|sJpBLcW'!) v !D0Je81=)t 4! 2GX4r;g\Q3DQ^ YI 5΍a2eZ-V',tq']k8-h&X4^@B2sc% Hc)4Ic5!2i<s>1VLPqA 9>A}}))# us&%S%ٻ$)RzmY4?$hʑ3{ ;Oo4%2OJQJE)J=g eHS=K&*UN@vg@' PpεLFOpPz@ =$iZN)Tȶ?K,FwRXwIQ+ar{ܭt㱧;%yR MF@_) fT |XZ7 RA)%  RqTHp,K erf`v\b"q(hb3vC5v_Y֟SO0t&d)a)(RP=`54)bCqvnK-JfYRa"ग़5q}Ip#bOԘ+wJ8̄f kJIX]m6祆3)42ܬKFI.cF-D-fyOSĽ"nS1U3 SI ⠖Fha*]۽*^.X]?Qbtnaku_vf: /ޯ{쨔,Ig@If7@g7RgɝH # I{?w b5ߓ~^-#zw5qC؛ev6̕g@f(C bŠFS%$)}[Wzwi7>O/=uGs)4z[ݠ˜7v]Wvz{OJ -7ڠ!,֏оzP2wݾ Hw͡_-nnk{anaaYIX/?e ߮8XP/ iV8A23$=mBSX W !X䭇9|8?Q 06HەKxH+du3+)Sl'U9m_.wjo_[9uagIenްԗRK_񡉔+1_l\[;D<. F0L(ā5OqK@-B?sDE@Ũ 2c( MNr ,{^(܂Ұo3 rDZ|J+W![7X*=_]i8ޭŲa|Ԩڳ4 O6w̰zMF绛Yۿr o!Jkh1f5jKeam#<ߡ&LE >221Vuj4^5ւKpdtd :АhjbgcDɌ}rACzoDZm-:⼦Q/, 1w$aDr>~0_o3t^|EHUೲk:5uӞp;6xQ.bSEPPӣwtizy}@1 JcWBxaHqӒb|@*!\ {./omГC(Υ0@N8w/Bd!XԄ s\U\^D1`m(;pv D縫Gs5tM/%D4 *Bj>̈́ X>.Ri8h.Lv1RtUTd oT/P?0,oy3xPw Ur2//|BkPkQ2gR}9_t~a#Pp±r_e;ՠh}>0an[@t>!H1h5-!9Ȭa.K,\U 8HUOɻ>&̿yzi?]9.fEm) V i: U:夜::x>_E"wG) q:[S |{mWnBᥫ1':DB'a /OE4߲B+%^'TTdDq;> `E0s@+*k^y%E(ۼؼ*3EIzg1Eê+ w(G9Qp|ȹWvᩧ;ݟmN V݆Yg|as v]IE~)&Cs;ְ,xl`lf0/*WuQBh].b ;+8Vz΅EGiSKl'``&jUx1AevN.:>mg.Xv}n>;{gwZ !xptqf4f\Z7}Z 9~{h'Nٸzl8ho^BO;.@U |'!% Q2#¯w=;zXqzzv pHsZ"݆5ao?vÒR+n84Е)U~5&k"F)V_!"FCS_6 3 G%٧ LIB&d>XgwKοȇ|ۇ\W+h?ܹVendstream endobj 430 0 obj << /Filter /FlateDecode /Length 3143 >> stream x\K۸70GFfw+S{8EK1%Eylק@ Lڲ6F_7 RnmmX~ߌ9^w"LцRɷRXrr|-dyƓnSjmfK)OHUBVJڿI'FVI?nmw򕲢?kNv<5(p8ÏXO0rEF:07_/w/,.S3+v Yx-M'!bRD'orfet e ˍ=$P5.b&5L+Δai갇?mc-y܅ kf.h?| if9A,I5Q쌇9k.=v(G ԚN![({ [1[ (HfcK/^<ӹy -L~԰.Gç yUuFEn. Af#ޮ1k$HeO'" %UYJj<[:ĄL@K*NY]u!Mw{od4S]ɇ@H PH7OÀ1 *疰~1>CQ t:g:@P C*ĠNk?+?Kֿ#r3* n%ەX34DwҫK/[LG$j֎ɇODG*q:he"9wl~cF& dW='l"F Ђ1/HoA DFX߂"K0&sN+* 1($릋r 7uUk/_`d8y.S+5"0 sII݄Z,[X!8TJV9Va|B9 fF@F%bاuxHb7PSv[f 2^V_u%ø,zڬH7+?GXωrDb9H^ b" !jY5C0vU0Tef$Ή2ISBj&dMc-(!`N4Ľ[Xæ0znuS- +gkص5Ŋ-^ lj ǣ>19-aowyH͞0u{W7x{tun qr7(1kQ=4 /K{H:I'ymb _O#TA@& !~?oTCS"dDc'/ U)dA+OY)Ls*[EUp6|y{G4zקOln-nǼ%(^r-VR&Ӧ/۫0؞}zRML˒o(_a @h3hbG9.[nt'Dv ސHG?8YcAϭ{R>xH\V`endstream endobj 431 0 obj << /Filter /FlateDecode /Length 2957 >> stream xZmo~pȗ:v_ IӴj u:ID3K.ĖayۙyYlN_z~yο;QpԱ,lasNy!e 'd;{C/qERQ8׋%-jK8H9 (_b$+`,p0:Rmpk3)&*^r5`nnSg'?2l(CO.g-NΎOf0n13ʂ9RL ?? ?o!? Quan3b6~0\QBSDeu;}T*J *W~tr*ea\qHiL:,ΕӅ«K\'\Y^Er0MXgeR̲F:* 5BqpJEA[,m.b*kH'Lx|wF>OQɥ{S۲nϻnOu/ZX8B@;C Z?'9FRGhQ}X2(F%o:t OH\ZH0lW^WO?~ 0 !mp➩]O),lLBnbLpK~ArձJGyԗVeA #b)%j nDVFڣ,vlx @ ZZQSJS=J]ڲJa.y?X .S\oe` W n: vpk2̮(f̣-0>dlr&ƈXG Nh5#c!97mr vqCrN orlt5m0 \98AA:n`|/,I&,4׽(GD!y^gD)Nʩ*fp|͂jQBV't?I }^:dƽ3 HŰ< bɂ\+h@ɢs[塎q_AiBIRzZTHxt$3{qG[ATmƫ/jm9qça#iY0SHuF)ӫ <.,QY>.U~h*`\yD $0! _ۻfݶ#G!?r 6yZ4}_t}: {C-u:'pߜKwC3gGJlsɼ+kJְݼ6"=4=,P7'RvG_ jAjX <օ+ ?iΘ7Q mݖ*.#Jzu?ct&U09.ՙl:Alf_T]7f !9gr^- !a܋vlv!dbK5f3;^lߙCB_U\ҡ"u~nj5=WR `)P2gMjUMJPPtq7^Mh{94MN˽|ZH>@PCå ̾M>c&Hh97TING3:чphO$@Ҝ̅u=̄?%5@C@gS8{N^h_.+b;#(h!h8]a46MǏ+qaA0$n+8 %ќ@YQTޖ)R$-y6]tKB@7cG L0,Ա (ַ*H;{D_'ɄVĤ<&k䛴.~1=z67!t _W:R&`6S]D,fyI<#g[q9Y WI~S>/N&kNY6'7b]V|Bj ip T6JcN#h$J*4 ÆCP^ a8؁aXRkV%,:GF\ᔺC-S}䀗ޅ}H/4"g/x#fF6F?ff%<_}WQC)e 0\Vz孜nK>6OI] n!wN_劉WQ(4>~s͔wy3F05+7X6$v:g2U6$ǘo.?eLyj.^zendstream endobj 432 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 2504 >> stream xVkTSWBZnK<\05-Ђ`]*>x(Zy)ፆ@OTՙj-6PQT 0Ut5;]̹ΚV+߷oo#cD"LI6LSL H/v‰va'{$3u‹0<4MIX$z}J襱޾~3S֭W<=KJYI$flLKJ^XxҤuԵ>F`fZzMYʜy I֧lHMa"f)bh&eeV0Le™f3Y,d1"Ɓqd&0!Lj O4OݛvO7`$Bi4Bc' .I/8~! +1 =gmpIl74uO;HYRZPUܵbL@J)Miѫ49|]x#KJ2"|:lE+;e,͠ Kn{8g+'n3 G&.ap3FǗ/t3dA׆ܼ>d^4@!GC )3q#&x |YhsՁ:0 U|Յ}`p>DF3 OcI(]Ȇ0UrӅ-%JqHhX>>{?\[4 ΰid٢.,l,icURd!h&E!'B"l?ފwf՗Ti0j <qRcM/Zn`Xd `-D)iih[ jU"A,Hs4*msqftm25>e"so'Vg¾G^-2_h:S^t۽7~=Y冊jeSV쉞6TlϯW0+d_rSi҅%%EU4M!q>ؕz((Km+q`ko;SP<(QSrDN67c;C\^.G&cUmjE20  | EE[` 4^O{M2K4|k%nSKƯF'Kdw_tS:3|¾̰p@I,̇9gT"ӉQ`#xkT,dnW 38SwYti2b{Qh`XoyQ⊲R-֪vThRqV ̚T_.D9uПc^9x~dlv8f=uǧ*J;ǵ"!9-a*lYI'@#Ϝu9ě$mTjh/+L'XS'2X-,ZcjaqapQgF3č?q.Mw#<jmRi7VTՊ/!ƑuRҊZ~{n}E])`RI yfgL;`Z$}h gyQ' {s_pvaȈt'ɅŐY<)|mkjL5L{ V^/ ^2s6@h&C :.T/᷿*~->;X+FII,fPlsx,:}ȗul-=۶oǬ^۠k*k0?/:z:`nbc!cclTIϏп˸^;/Y%z~Ko t`~l!ę'K0V~Ehկ*8Բvg *$yt'ɠ;Iu<_eVx_d|nJwA uE0K߰Hh 2]%#k!2($E60*1tM|bZGʎOk]};<$apޠpבuX&s-e#l7m+tKLG!]8v {o1/Wf@=:shQ>a=O.ߴ+cO'f;fg܋.lQ|ZE֩ mk1I酩IV>7ͧmeey.HLut"ڛQ7۶o#)1tx2jjlm@?T [4VJU\Q]US_&ÞTS"mU-nT57ܭx8p:n،` ̖*UJ<]QQ&CRӸEX^2\\6nGdK#endstream endobj 433 0 obj << /Filter /FlateDecode /Length 1445 >> stream xŘMo6:ReGv9$YIƮH(u( c#|ɟz%uO_'Wl*~}н^FcU'vQzo{#ֿ J*kVQl1$^Ͼ9܎W6r|X ocl,N6W#w4{?>~ޝi쵴gg 7*;%|F=azioԺwIZ옵DJzDwuF }'vKEyA I₪s2> s=+wŕ OYBm`tGlTEd3ǡD)鲨'㑴/(C K6B- pOPUb#]رq"3b,T$PNuQW)B $PS)$ZY POM1],*k1‹M"(P .(1Hw4 'ٽ} Y1F$Ji(cRTJj "uTեSNHd_++.~ACQ:JOPEdtHL`6HZRGʢtBAK☒P G,+(eK=!'qu@YTTXJhbi:x2z;71x_FE9tЯyNb)&8f,l0’qC!Qߥ-~0>mYlvaOъg_~cp,%jG$ Z\{j6PڻYL PR5őOUnݛJ~P.f67$ob1$#o-Z3#FRh (-e6Z(<34+djA eyTQc(jU,LQ-5H"UcRѴT9T%eiM2Q4'L;PTBUI 5j*H U=l UD5T*&QRQ]) U⩡LxjITFj<5H1=f^TTCQjQTArS1>RS2T$5Ф(EQC|H`ҤUH-Q;ߎ#G4<a){xAU076zl"0m \pkݛ (9:g!e@H3O[cA֬Ym /W[hq3ryq7jcVlvK|~;QA endstream endobj 434 0 obj << /Filter /FlateDecode /Length 1435 >> stream xXKoFWq2 9AVdL<\ S}bYDyQz^Q+9ʹ= t=^$:xaNc{T;x,s#/K(%! rt+,x֣_ep 0& %:lȑE95Áqڜ/\D|ZBԢts!8d{!=q2)TxUNFހ B$Ü   EuR%T .\XK td\=)GRYmqzB0\<\HdyI(Y@%" gvCeҙp <:ܣI^GE 2!VBA< n䄕n]\"(g#<;29e|IՂ9\%/ - (`5ЮA-N׽b 199e E:F ΆCRG ޙŤcATń<|m[MFN*]-N=^떿6?dnGK)Vf!ֿl>&ep|0TȄVry|䇡/5UPYJq[p7q'C~}\0p(/㗉^|wwjiN/݅endstream endobj 435 0 obj << /Filter /FlateDecode /Length 1066 >> stream xVMs#5}0Fw"պ(ߚuLR}g\D2M> Vqt06{9|>eJkzHC1^9mCe@ay9_;>BE4QeŒYpʺ퀲usP!D)h%E Dzhj6A儀(PNx0CEtq  eDfFW5 xy ibpw@Y "QA?/E"BAV(䴦8B(t"^N*Tأ!)9 koF/㜩$Ak qb2FtjJv(:F3TJ;>JLqʫ(dS63$(. O:Km wE6ڃ&)ZeeE<%rH-HrM5Յ96%zp h2v@%A2P, 1ԵVcALu̱ ഏҗyӦAܹQ"¢I흺~mRn$M.mBkF쪛3|Euv}F(Brq:4 &p_|k]H!z{j3FH,V?l0N%asdž6#C*VvveiNid6jϼ(-6셋w-HCrӘ ˜$v\X| U1q~}xӦ>)o+K=>nI1:;cԽ :_C ©{T~|m'}G7ΫV t{ 'N=I8Nnm{DZ9endstream endobj 436 0 obj << /Filter /FlateDecode /Length 2226 >> stream xYsHw\h-[@ lP[2%dk[3\%9ːTR~Ꮻrp񊺧i#$<)lij_+CWZrڝpX燕-pa!eQJiiaWF&}VC[bQ|H߷֒oFeIi!f(Фi\}6ʸ0JyIz˄f:4<Q) ,iTa3ZFjFޓHd yLX%绌WH46s:R|9(4,h=Cn`]wQ`CnԴ`iII\ɻD9V$ŔbTxYkTpn)H3n䪜p.Nv2oר zNaIe,b:&JߴYtd<"tT\q,jRLL4s7+TVī pEn-dFp`JT}"E*15)%ei TBlVsE8q&%һLIQxvB1?v4~LK`4vY fC_ i ]WlЇ: /P}3?6G*񒃜k|Zi>h~$dAxZ ?v—U<;cx(YeX u~RFZ*[PQ"HF5E^y70qs<5Eb=Z.ISI2EoG_έ2,wZd~ʽ CI4Yxa  >E@`D̵n _J<0C[Cj:D( oۧ_z^mA5xp1]^?%3{xȉČ޺_(o&0"o{j%."VƆ _ ۀ*|U|orDq0ǽ3@4:@ZMؗeCнj WY,O}Pڋ"!X8h6A A~I>߮,if{ e6ؐAPv h%6|6>]~Kn@mx{H7GHxobfaͻz(Qގ QDvޏ_x|y}eB;A:ƋIJ"o''Ebfy+GI)e|i&wOlgGggeJ%b(q͘&|L6~p~pxK:W&~7/b6vd6n1N=D:Y  yrEyYHС|iJnZanUCkŹJlv~c~jnђ>݄x)vo[F\5&Zn' 5D'&E3p24A$,* \9Sj=cŰԏ_4E /PJv"^Ei+PLbjdˀ0Ô< (_:}wB8yO) +FOnh)U"npF`$v \DK'D%㾓3J/*~aJv<_?eژ!:*h`,̎_R0 G&m3_h@Sz@08|OFWÆ |.9`ٌ p)ME:cNl8endstream endobj 437 0 obj << /Filter /FlateDecode /Length 3532 >> stream xZ[o~-p/i׊xZ`sC&)"c[9#v\I (#p~g|;Wpj]ՇG|UjhLn+LfU23RvoZTY΅fwPJ/6kpUs!tv^}}aCP* e}F>~vK/߽s+qYP؛.3 Rc߲7g[挗&^ق Dn MJ1hɀ=v U%@[NFb*(X=>h۝dtȧ=Z: {ۊjoWOdаӰӰSv: =ahwV\p +jǃќK+E =Rc hwTnCn C.c${q]xSFx:"-G4=OGڏeC> 1ed!UWQ' ո1dj~J̽3mT5j蹶'n[bs*6C޸sUxkS`= bt44Z{4=ٚʡ5FkvbɁ EU?tNNɂ8#"QζH}!skW^AIK$I)B^Bņ$qK lD+:.ESLp[v5110~sBF73c֯dzY%#mwgV6̃P7I38.4T H \tm8wxp>̮;Yx'qB,IuB9VڣZ"@77pfrC{;`?E~$Gcv}n{5\ yMgnM)>X' /~usz¼w^yyٮ.~3Fm7kȋho'7컧dԭ=YÙAkHq7?}ן:K no&?nvAP)8Uk{ LUUc:"/(e1CԮCYX ,LQ&nMJgs K2 y,^"n N`8+`86> uGQp;dzZQIX4^F4tئqb m3|{.JeD1^K]Iv*v iLk`z: 2RIJ a> ufcNб\!N[ 7`" *tVIS! *"PځЂ0h6ReBz|oQLŸmh6X_f iX~%3c\.T*3FTbo%{W'xXaZV-ܼ?yB2pB@ܶN"$]@71q@Ҷ}*Ɗ9wpAFg ǘӕΪ66bL`Xav&Da"F=*N=J]`pv1;qy$jեGR[BhoO y uHn(ӏĚ4IX 4"RɅpցu|EP0Aln:@= mKŒ3Q2Y@ Տ۹,YUDe󊙬l ÑPA"OJ* Jnj/B:>c;o.َ$Pׇ :4DyƓF3EN,zTYU~ݨ"KZF:Ue_V]̌zc\,"MCkSyW@=esHXJCWN-gp9[BYK1z~.R/EUx?nyIK~܋}C4-سp҇-՟q1/~ ׮4RŖ.XvqN_5 {0s~DBpXŪ.3>咂2z?  ,pU$ GKe(횶f_m"0%]q1jGe3)k=XQ;̮hZ5v*dԧŷdqor * )4KU/9+bOWH'9ϔy%2ϊ>P&"eν?7j(4hLz07 3aWҍmTǨ4aMSU]J[>OWwsmu1tE=<&̈[<*endstream endobj 438 0 obj << /Filter /FlateDecode /Length 2277 >> stream xYK7}l,k993cE4Hrί߯f4c{bX|.~_ڕCzeT"oQ]P^Dma+\a?vQxa}xӯ^J!JnZ>=hBo+~*ֈy FH\-.).Zz iC3.KI+$uǻɜ(:/u͉ $uJ6;NL*EJ-e?{ 3lgU¸?Rx-)e*eaDRЦda@A3AWR졩R!i&|;;΅Ae"iPRLtT$HU)p_nt R+v&e| )A#8|4o4(a% T}xcXA:F R m_>Q=YFuN(xa&a.YpioN'MXd4bD8z]FrfDQ*F/ь>QĄBgX`(vR$޾ߟAVp@ztyd%zq[d0h߱Y -V&chz$4p=;@EiZ #Zg}tȥ; 6(Bh|N g` #υTQU*eT ;oȐAG=yLR E#5CsXpFa֜6)~-pӍF!Xtv&WroY{TmN,8u#!4 sq%wר!w`C^} Q<= Ը,W3ST{jj:ԞZwC)ܝV[=J.{x7}`dE^8+H<13E-x'ɫ/F/hmNFYH NUgs NۆLm"0a_MS[/:ԚwyFr&g{]ȆûͥM/.qw,_鷻?0ctc*q/jswgf Oz$,[dk X6z =uʊ\q@0Hp0^]N@2L x2v.ql {rXh.8̰· 1 m KeJ-9/:p0>5^uRh2ˠHA & &r>ue)\(ֹ" Еq4_gBUUY0!^&$8͑n!EbsVu5Ryz"E#[jh0Cy_V}8D AC}6ҎBY5}4ēyGb.q|,s@[ZW5  pf <SK+Lځ 9h#*A)(qc~D4 @T,s pRV%nGjEmJ o"J$BGu΀SFO s@Ǝ894RУZM(qD|9Z[q -^0w!,[7L\ hL1 s`&;؇GTU a Dɯ =Bl'ӫ.+iT)Z33)ڵCsT`F &FH4vsf%GPeBOb.q<zp$G_*E\*υ&> =!ߨҟ=h-=N#f ƯZM oWӴ` 6yU(p-: i.`g1"<6"yc>"m^Do"S 3)-s+xVM<L"=C*@riJssN_.$]MV׺wdHcqK@\uǪ#hA߫d~>endstream endobj 439 0 obj << /Filter /FlateDecode /Length 4120 >> stream x[ݓ۶?/BK|igi6ovǥ:"Ҿ\.I]gDVMV ^. FOWaůb<]xkٸQvB./5uø!D4YoQYm5w\êilX!+$n׸VָjwĭQ@UUzG$ک8RxK{o`29P+Y_~ˋ@qT`5+)F8obuYuuwt,j-S7{AJIk>L;Q+.jEaP(Y[$H J,W ªƀ*Vb`j]3!VL0/J" W|*mj =*bH>:L/^$*] q(^wứ9hj_wQ j@ayphۄ~u1JV R >`oYQ ό`p[P&w0./@q`RKW3Ţ\HEZGIM!RZ_Lk)U*nTi^[1 ]Jx0W9cQr6٪[: (;8+ <11 0 =r|=R02JWD)#|.琝I媑;xe0_ܬ`aq3 YX:DF$A`K4@z]oY<29Y$8`a#R} HbˁF쿼!91.^=~IȒIb;yN;x +q׍j/O7k"$Q3(8Jz"4W7߫PԼ:K3gs %FŸwڦ\W@Wk k vޗ7@+D_Y/dNU*vw^Qv_PCΥ͔J˝Wojrذ$X`)UkpkxH+l"$?D1UҰ9It*ewz*#5y~Pѝ 4!O X6SܣG 990%KOÞlh!c.cQܻ0ppio|"+z5C{fnC r,_8c@\"gM\65,/OthU *nk B:} Ql$kR _+NB{ڵ [&RkI2Qty] $UzN|#7?42_>%C;z٨n;T!fV@kΤ?GdE{#D!`2GLS^,8}ޣ^$&\*{˧cAH}1.k MdJպ2!5403=SéxnAB]>A6ag￧EPxȂϼ%~EEHw;RRSd]_;ƽ5ExЕZFt3W b1&H5QEQVOhL̼CQݝW' MoQka^v[HLvX}s)rҬn}K$e՛} `fy|\R U5 ]ܥ1!@}UbEURa2)]QI9n ԼTcE+KXP'\@к4EmQxcG qmq(TتaR 2͎V<$Arh6zh#:9kg"* {/gML/%bh ]jג J!-K)AH9F>tA`o&LuR@gpl΀5H#p SQV6H#59!\\ꁮsO*h ~?΂чIPYe=n$f`&Xs#R"!5N"=` ]HϪ YT@8 rr(u3[0Fbvq:hs =qfQv,P"<); .v#D2n@)zTf3ܤD3CIo'y3-KU_+wm1%( & &)\r;(hzNF++ 1dLk < )ZIv-O"&15l"W);/fWћ೓Ы]%_]!iίagqV_^,g}<@1 3e[*6,`v† 7hjMLzTO=#U s(sX侺{~} w |?q 0Jnu4i 4'Y%Gbę-A3ncJ_v"R|۹|n$-KSxjt_Ao ^I:qC 6oK-d ;xKOan^ėCnxKSC6Eat<HK̻uX$?Ƙ ~KCI^?;' xIS-")BGv^~^$I"91Eeg?EѴdzV\Zi (Rz/Wk a…Q69vXOwxH选Ft`dbM}k᠕8'H|cfG(( < ΜxP,+c$B8p9Ln8al)P,tSuT0wbqI1Ҹ*}9s=`ypgECIcjyj>)| lVs ŲC[(oV _=ÇX*&fN(öa)oŖU׻vُ5%kߺ=Ċ:"ٔ@U汾:lR r;c<[jA /~Y?Pe6Hy7҅5ωxXnF'atYq:ج.#31>jJ͈g2\f8?GҭdkǾ?pWG [P~t}(98yƋFm䐞: /sѽpuEmQב0]'hqh9"4UNЖUA̶&f}2xN/qe42T6 |Mbh*x m8U#7x*F3Y"58㛞y!4-#WdPpk?pf8KVk+]x*S2 ('jcHkB> stream xYK70{FUJeDqJS] ] ro׃8(J wsQ_y73]rwVK+ϋ˛Yw|a-}Sυ++.4^RUYiǝq\8>OUWIŖIr9'Ziy.2w#fXhp=>e埡4 jƸ_8[(ŋԥ3>_H9uJJ2Jhަ“}4;l< Yyc3kgR"Xܾ\%{ܰ&9rȝHT+vH6 HT|FHֳO!*.XԲ*f4},%wo\Uc9_(Y.Gf{uzeTLTVS\?K{d?&(V^ofBe<m>dim|һb!Li]0_mG՛B xk/{.B\/1Cf2H##u?lisZ˞I~ߛSf&U)YfppGp٨R7Kn rt:T쾐V-c#_  Kn>ϝp@ P^6P:1{v(O=˓ $Tǒl^y>u`JklR<әN0e²_](S ޲͜1.PN1cd(WlDA}졷 徻c r>ܞ}]ٺ&Ju@ZQQ'ťhʇ`Me^"ʰo2SDPmR®ihR?Gg!b3VA TYH|pNO^\:D<RHvNFqKHqC)~1CJO)y_J5OϠ@?Qքv_׾+^ (G'V>=${l]J7߿J*n4?nvhQ" ~ud8ۮWe,qv?,9ݱjU(䇀'lϷd.?=ޒ f?,lO,:VJEA7 /=T1$xJ3FomqZU$6` (Q!]IL'\UL$\8*p7}j24sLMS/?vr 3G:CSY߬B6Va<p4bB҅|VM~VjW<{P?߼B$T?+Ÿ+$w fg =f;&z3 *JS9*yA:e*%v% c\Dr=Ӗ.tjD%kO%/#* E931Hkn Q_zk<9%)ŭL=q S4pq^ j [ Ч4jtT\&r*JXڑD=d8֔YdK"iwS(=+,^|Ôns,Q.">tǘEO ]!mo,{y;U`/3[ rkAn AqO9;nԈy q5s+lY3^MsrX]ɐtWcs\S.>XB=}Hw]B.\ISa,}9Ãk {0+@1JTBu"D/DO sȵXR̽B̵/]m|:a ><̥:pu\:Q5 1khԍQؔm{V7&ɟZ35^0 vRnh4,@B"1*ڷ4 W L֭DxB集}V@9ʴ8ن}CLz= ֩riXTusw\1 ? O.\kOmt.jezSS{lMC&N6**e ;o㽫W._W h%<33s4B~qG^u;r(z6.|T5#{LbC @l:/CNNH1.sh:9OWLS?2LnLob8M 8 mbopׁM \ >,uǟ t9|_C+Ԝ菖WQWܬ=ZMK߂Zu[vp1ιyyfeث\||ښ'tendstream endobj 441 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1563 >> stream xeS PT}܋d7N4BX1`k̥~ 1Lvi'Ms-U6[ eX ԁΒ8WZJi_b?uT;%ڑSpz ̚Jjf[ -M(L8;pL`6?e9J6l^׆lgl4^ZAI0>ޛOd=*qUE)]СUutAr~[Uc]+ڧ27ZJ&Ͳx8ڄ#Nc`h[+8@`넚JȿBS9,-4T9LCXgCv,ϠV JEe,]i4,+*:is65׊rJ0orO3|rl[8趏P<)/Y&*}F 'Ыj.JKLw栔*y ;1@-u,w~h&%Kq)HM}-\p!0'8NA9/e!>endstream endobj 442 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 505 >> stream xcd`ab`ddM,p(I+34 JM/I,ɪf!C[W kv7k7s7B' ~)^8qs~AeQfzF.THTpSJL//THKQS/ f*h)$f$))F(+kt!Dqinnb Y\XYPR\1000ED20v1v3032t?Bɰ|3El)ʊs4 tsyc⏗&uO2OOA;ؾKu?yQխ%Zq,a}-$֮KfHsc}wkwdÔr2,=rAV X]Y(PP oɜa?zw 2CٿKw+;\RB?mɰ5N2Ծ\XBy8y3o <<'O3|endstream endobj 443 0 obj << /Filter /FlateDecode /Length 3383 >> stream xZI/77Saêmh\It8Cd{Xr%s<<}N _.DjB.ln/3zH[d3ndRAHew劈`ef0^zK=AȾ>-mGOĿHaImF}v#V60Ac j];pA`u-~[|}'!2%AZcp-!b38u@o ) e邗sJ J9X|X(i̠e hUpi8x\a *I0FAZ=b f3J䠤8ۍ=`=. ;ckFgy>,WXJ~{Z֧'WwKmkassy;2[EB^] Oel[ޘC&-G􃃆>CFlj9=Č`霃QGBt>?|쟨 8o@VOU c6OP1UXj8ŞgҧE"[Ғj@Zg%g@$ ϡ2Az  2! R ,'/MG[TQtc\rIɛŽ55 ̎;%&Qc4LSMT"T,"x-g $ |8$ >8R|,GcǙkH+䣸l#! cb'56;!Qs2~eɾ)B8'Ā: .H:b(į{ 3(D a=#?RX(}3nxVϙ@<`L.$\]F-8x ªX8j!$#e@~:"yG&b(D 0;W!z R. J @OegJJF@)l\PZ'9>@̨*@<`5L@ ٞ#cFl@~"UAC0e9<X04 !:s:9N &kE(Q="&Q%Y̤j.+o>(j4 p*P 2)% ¢zq4.g2e Nli;D`h>["'W''Ѯ14 zzˈq\#j&b<aT/YuϩI9*g@탲wPEDR݈ vԻ,(ǖ&}7=_~!4QGs)@ P֊q"b#*.]v|~ }GBE2C$KŢD )^p R:BZGJФ哌XE?_h]B8X}D;B Cj~X^ s A_ߤkw[^8+ -9>#w4rWU}@%RR޸y*RȏQ(`bFҚLWpZ஢4'x- TCZR:´TdcqPދT>ZH3>2 X]Q;m w24y@Yzg" :J" R*'уOeWG}@M(ۂ0"!nX`Q2(Cm )1{Q:g`ϯ(\CoVO^'`_/#m}۱Ap4~u} Mg`x5ddWKd>d}~YutpPu5fCz*^,NX*bl{!6yBQHO/MZGOg79d5:3*S+<> stream xX[s5~_7v"t--P%a4Ӕw+v0߹_Lp7v`WF&*~V;h|(d7M"Gmb~TB*~^wgZkl_l3 2)D! M Dh/$hӮҿێK (?w.s36pźiu+ [ɌSaZϔ36WvP5y= bw lWQi(=Jc*]@Ƥ咸ED(?5B;nM%1P \l׾џ#[,a PTV9S4n5%6.Y&J σ oW4lq&LAZ!h"ZQJv*!w' wz'y \pvKF)y[)*ñ@`dd"+ MNcp{R@Gi449 d%a! -"* o=GPI'D[daW"0#o" ](aYg "5jc"a*IAQgIQ(L0)},$9ɱV9JEZ")U:Flz)={nU({Ŵ {eVJE@FUT!S\Ԥ* @L bz}½/QC%*<97,M:Ԯ08x2  P%cu=Cq yA*',LPF&qׁ]LR 3z}JQR! =1TPSu8A FOO :JD34 U\aVxE}26o0"o+)eUIJ)v3.LQcƳT$CWfQ+ ?TC4JFLSiđMȈlb0ubU/ח4S9A&0 Wzx*U24a=@r 1Z^'<0T]2S!Į)% O_8Lj[*QP D^}Ƥ.!G#bg/ {aZ2fszG$S<:EA=&b̃+=5qe"y|r}uWp_mlU8 Vtg|&b-gERv{R^.W~:zE}<:r!io.W{$FtD@ јiI%^`5}gj^whrwt֞*Ldr~3=fĮ忷s c0Ucn7U3iP"Nv?CPOh3]o4[h$z,ˬߴun'jX BPO@ @T[҈D{^(~u 2oendstream endobj 445 0 obj << /Filter /FlateDecode /Length 1282 >> stream xW[o6~_ axڵúb^n8((!AؒsЊ٦PQVtgq-8QI'7UkBhX'\P:TD8i}^XkU$_}kI^j YYRo댵tM-K]Rqq0mxlxfuh(p)Ðe!!$` Eq$ۆkIpzUyT^5ѼFajue//ŗ gCPms%a5 ))q/:ET_5掼 eSM4ȍ Fi+1/Fݠmah;IpnJI<+{KkD0Jlt{/SU8uZxo„*%>G[]c4!N_KUR<bL/O^\ endstream endobj 446 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 652 >> stream xcd`ab`dd M34 JM/I,f!Cܟ^<<,~}_1<9(3=DXWHZ*$U*8)x%&ggg*$(x)34R3sBR#B]܃C50\````KLa`gpbpQq5|?tfũy3|F\ʏb+#Vr|a~ѽduަZݩ]؄i`c??%Jbn/<w>ؽcw}~_.>yrfz*3ж{߼%wo ===\T\}`wgv2V͌ ʛWh9w/ں{nR v؛wq;> stream xcd`ab`ddM,M) JM/I,If!Cϒ<<,?/={ #cxnus~AeQfzF.THTpSJL//THKQS/ f*h)$f$))F(+kawhNjqqjaibc##K5|~dYrZ{f v/cy'N=CrFԺ?~mii쮝6%fvws̘:utEݵr.Ֆv,)2̅݋nShl;vrq1pvp/0gbτi<> stream x[o云w\Nܽ"ERRb7}$d =t$yIVIEI3`ӖbU~sd@m *wպ01oNS- ێ|a8I}*/rb12OZKRrt+?]n#*؉;NlU)/=;+Sk%T%reP&QAo5qKs;>Ft8!J`0c n&0!. q/Rusk 9qAk!Vw :S%~wڵ+0L7寫,H#i]}d[Ç>\;Q`qJg\2 ӟ7 {XHj*ͱr$ܽ41jv N,2U-޽dܸ1?ϊ[d0aj<Ka/«>t(]7`=Tdu~8--7f?mL%y(F@ A]_dY9-t]}+-҄ߡ2s8 c6 lɤ8Wh`t8n|g)>鹎>w(- ϯ͵q3x0,@$Z.vl|P9 LQX"y0~"7c<ͰA8mx*CVmŭ1{@AӚPE,&wȟ0/ 5S\8ߋ@qвjiCa n7$PBC"ǚ-%"D G@?t$@ .,}*?8Q yrЭ#^cY ^7t\%?aLpoSln^K'wa 4,OD)R?#?2/OKiPbHk#0TcHOc߀/S668E ) X˲7^YRP`g]*)Θ1"/Jo\~  (Eg ՚18/ daPb0_=t%ٍP1[1``uUi(W==r!`T,4%3wK<_P% 8N?.Z0e+6r+oyz`j[Y?Vɯ[$M*in!߸J޶ͧp}ߩnn=io[je s5_B4٭HBׁ(;kA P(Xacj[MFZ`ʸoƷ@߉/s{: b(C#6eɛP:;T\28Y4K=$S( ϭMPeCD^9(V<NlqSP܆n`¨^?spa&I5C7SDIy5n#H!cU MEaV" !{QaUأ..%7y0s|w!Ԡa] <&|fj5m]]yx+0)[Rs#fvR z<ܽ\_6B<g,PCAӳ 2[ M !<ӫEA$0UI^hlFô HE/E5>WeH;Fݍaw垦hfo@EbPkJIw%vNK=; RSviԑH½ElƲw%  Gi Ǜ=Y+ CuirV|r"ĝtjm;wv4W۝ Cdzbе3p[b.ȕ@lZ$ν&| J!` o[|wk&6yglrY j#bJob߁nSLl,ԫQTv%R8߮+E톣^;s6X-3vorӧ&ꢘ07]72ka30uQ.%x P0}Wuǰn`oM(ztIoOYT$Oۘ"%=~G?+ dt|Q%\,cM˹CsN<4H \iݖv'曼QEc&g(\T.tV]kn:rLLl.fh:D,VIq1Ѷr?Wu %"$ˀHP<`py7x`LI8ꑳ. 0!|Gݜ:\vG"A%T(/"Y2#o*-QuPX=۽Kg>%@B)wT'k<:We+Iװ!se֡)؈u?P&T=mԀ2g!m~&B_2ˍmV+ip_q ^>󔣎Z\\(X#q}Y'^Q`V*'@$ -ߝ#ei i3/UBEc8QQж;ӥ-M/.XExW{R˾ ;2A!] q@k?sqX[q& v7?AC5GM As.A#[BhEpffՓܒ[EFWe`%$1U)օ=TN/ZJe!b'`]wrVRbzn 9mBa^pG`d3;teA"KmO+>5Q3mk/rjbNJo'NXvkV]dO#m7Bu[BC3|BWqWW^?w',o/~th3 `n 7vW&]5xGW?Wqt9T]woJ$os9@w0oWCguUendstream endobj 449 0 obj << /Filter /FlateDecode /Length 5392 >> stream x\Kq}/HfeɁ׀w֪ Ø6tO5U]EKvGDfI{V9 gd ݅<>BUJYVu)a'eiL|Q\vX5hlpU-զ)H%b;tTžM>ϻqx߭j{$^|u 톰ư? '5Iۮ^ZVԢ8 a.2ёr+Tit#=;Cr} YiY)t'QDpl- 7E-!5cIbY /!8ךʺ1QCl°*M z<[# :aWO,?Ut{F1օqVRZ4c[[ h=Xq6j+;Ǜ 6n(-d4LJD)>142{k_Q3mܢ(5cb#guyB_Ғud &.jcXyel\Y.3Z")[va{8R/4ԚY лll4ҁs&*Fk{WU"P ymǑh`t><jã"56*[cOP<?SSMuD:PZGa-&毼Ȕ+֞S.Z1"5sn };˅?L~j!\PK"5t!KD쐏Ĥ5C@hP5cf|-3tWlc@ ^ji)؃AM5 ee5Fcnh>0#k2IJQ_mS)sxh.䴞\{@p&#(r.Fԡ\EWֵ(rNjY֙ϭ Ev3MOQ۹ZN>'EN=0dO~XG,87U.z2N'ĩEߤ FXZH,x :Trb n1$P(ɕ'X8Q?5q\ /E ്G3eؠE +cڻq zQOK|sA,)eS (d80vd܂ŭ+n ^ 6ΜY-]s֖ /BwRk3 yl040h)րGOtRuew}$D!PBU ;mW5CG|) \ҦmZw _$SPva@࠺hd!VK{Ī9R\<'J`7+=ta9ކq(1?<3+|Ø怟HC7hTef1nWQ:q->vhkLmDʱBt݇=ݢ h<R ZNڶ~iF"?ZdE83}>q?FXuikT&ؤM^~*`U1*jgc**V,*E Ϡ&ZPD%-§l@/2@QtهW) A%0*ݔ v}PZ<2B9 ۊlūTqI*n@j!4]:ѢqZ| y=&r?o-b8ghwytoH]H2vXzsɧ*Eq-ڔѮLp WiмLxmm.n-h4:X`~zZ : ."}m;YVQAٺW_^e3/4ڃX/2AKr4&1g]4'ݺ\!rj#%8w"es!u}=fo:y|D%.5gHc_, vN>|7C•%-xʗ4+%b\20<:L}/wiO6 H8|]~֟\Hy)!X%Ut=Pa̭ӊ;ֵ޺1 vL1Lù9t՝Y" |61G O-lـK2 #ixH5眺Lbr]ch!0,[M*aTggY慅ldJ' QAvc$]!q1?t}]L+cNT=09s#x;hjM ̣gG Ւgh1W eʄr$ira]Y s(jQa<)_0|鰚m.O>cQ'鈋VjP:P]*;umj/GfX͸pg5n|zqM_ M +\M |WzTŊSfmVk1=4T71+lUMi1;w5ڔʸR< ;=_ц1z,!e Kad^lڭy|A+XUg>O:j&ƾ@*M^Ac]8҅"n/7kQkiQ'id鄽'vzt@*nB8j2W"wBDv=q}qEl\0iUȨ5t׾ul6=#l˗ǻLGũuiuwt;v4XGbbBKc8bCKxmP^`Z{ ąA|9v:b[CCakw1;Ƒr[ +pݾ %@R +-h(=O 餻Ha[ uqa1uJSxgR4Ɵ53ۈ&t$*-k2wju4t 4/`쎗xt)5aK&:Y|lp,{ d2|%V.%:vm9';Z-ʣ EhC<6\‡`|ɕbr ߕ `pcDbiE3Y_A^}ȉ4~H.~!_㑼 w\y M\IfpA"#- A0KM|}iZb0|~#^:2 Ш9{/tJHIBਞu4` {?ڕ5uV=}֎U?dWuZ}ܜzR3淯9L9 aJHP, :MZ$5 ̧(H0#mQd]]RSQ/?r#(4%Xǰec+_:ƹ Ez-޴Ppd8RP̐VR}XըKl-Cr+ҳ>5eZ&Q͙ n~wn18RT3 '9UCr0E0,4"Gy/(,e"T[1 63g:nô6[S)cR\H.5pn7A}9o8i ?rg҃-,F2Xk.GMCl]h= U]2t[uK;~%e7ۜ妉lqev:C g}5>oMfVB_Kb8+agZ?]/Y$UFdcLM@>wCNGۜxc7Q/&>K3 ]*,mE1h!Xϐ`pĚ\50ǵoPn(Ln'_wag%NXI0aΠlFoSV+?|xR R*+Y: } />P7Y0=ƴCQ- *p>^R |@oS;W?%oR`&xSb"+9th7ϧꜴRоo߃7!?l?ǫ0L'P/!!TSZmeHvg2o'J,OoFjendstream endobj 450 0 obj << /Filter /FlateDecode /Length 6634 >> stream x]ݏGr>%w sdED:.]Hje!{{f{gaUTǯk:ߛnuw+FOW?7gWQucWx[ٹQuBﯞ7]svq!ZYk;eնy:$OxDbln/\j°50$0j ఐ!#\&;5o?^}q}')dJT` ZaVWW]ks)_tw jRZȖ4t OȨ *a oFN8t`ta ljlb.d> r1aBW1K 4\T++1`_kidkj[EŌR. C @ggM >0 rSJ-VoluJݬ2V  lbVB Zm6%U]+aN Gx:TOaIZÝA>KiqUia`ӝQ~+㟒rU B'uÓHu Q' U*l99p(3Hf) L0IM( 1,#G@ZiVAsV@ "-ȉKORN1]bU ZJ+ r8 Z rNA873#8>g$,Fb'1x.N b-3NHހ,)7b5hX`"w7V+şͳmAͷ;AoAtͳqЅ0Ѽ}XoP8lo<V,`n_qnp-p>0W۟ILn=^L퐨j -tkJF")L*D{4_"BRD袖 'lBdjHX"rUzx_"r-[ڝap|,Я.  L#Eмq˧b E"ӊ%SA83]XƲC)Cx* ʉpqb I![S)*AN qt)'QXIKM !#Ci*RL%Nʂ#ԙ 3JZQ#Xt] y"ۑCb8i6 $"8ilT\a P$ZU3NkCTM|Y:T81qճL`|T@$NCY!O-X%c3Z=p)Z]]O4`u|GSd$nU6#yAUٌ'IRbu43J8 r5swu8^=P-"6s&3qqZhy`gJX@Pӄ1]}ACsD9EK gX '";(bM\m h9˳xF'DHWи✜?b5̜sSU?<PW5­Ȉc.VNP/D6>L#'j5NJ] K0"Z (ڀxs vUj+]'"IڕVwVUBڕU-Έ"49;] q]ը59;bBƉj!{ A!T|F4sMΧ"bz(!/SAlW=o&SEׇ H'i*KDG8BO9uz d\"([]դ}E~HmLUN2DdW (SNpyUJ_Rĉ!5%(tD;I[rN՗C 󪢕N8WK˗sa*@yUXf5}+M;7SB-Ή@))W 'zN9"j,9KŻQ r#M4W9hUS HY^uU iDzU+4q Z#\dDRdR 2jJ1jрYJՆꡎD5(l0ҕx;!Y:lDfqkWntQ{D9vg],t Q=i5,n=b{3%cuc^ K1x\#ޅm1.ŀ; Ks(sta[:,,abɧ: UK:0*-y{$X8FSx*{_^u :5iɱmL^ƏSNa8w[XuIJXV5W SU{Ǧw:% 9IDŽ ՎO1|F( ' a5$|LH=Ih' +' cݓ|p:/dvu?]]pѮw}.КՔ3\0umTxһ^twCfuԻ9׺ |5+:i纝t[[,.qΥ8o{G\Y>1"R&Z -Qn>"g-ߙzRz|@'7 E+}ײC>tCX|͠!_]ywп=}l{Wj{G2]]Pd8i)_Do`~mn8tQmS(}f3ؿˣ(/x8ѧKwLxysMl[XXrm^Rͅ f9capBj/aɍ _oWkc!]6_11ټ{+#ٙN4sX9J+zYXuVS@18O#$`gäCF 8}O ^cl0?t55M#o4(4pk L YaCugBP_[ hkl&Q)*lɊ.45EKi^4Cn[/e<*Nb [+K<0q=UDmb<+gx =l`/òƸNaW"J_Ġu1b?'{cHb)xE">Ƅ?rq| .3$tq}4Ko{!]\vMmAaqZEv%@X"ܑ)d,5<·ݶ \_AO{A1j T¯$Ǽ?のQdϓl2 jLCT !v#US݆qmgY61pM?"J-Dzνo*ZBy#U)pMKaI3{@͟Z!NqQpLJh_j(8Ģ񞇓 YMX~9)JG v!-^4Ͼug#m;? _uNnY\"|O۞yʎLЖ~ v u|O.sG,Ż 3~.@%@KhqOn댮y&t@{&\?)F 'Aq;4' ܯX4xi$>= *@kESrXי>e/ So2q9NjI?Dq_cTr#ar~~l+KRX02~p|k{xW*xK_5f -*:Oo@z~~߸οQ:C_3IEZCz+xWp;z͡ZpTw'o*-T(|gJ7_ j! ّ;/}H8["8JWsRrY)K?/H(y"8k$Z6@4M2_,ܐR1 fs0O)A71KHc$Zݬҡ[n'\D~M@d iIĉkgG"0nd&w^N1MRɑRZDê}DJǂ190^4@NH2\CآAL^v x=n-#[2v$଀m5ð"¯Ąm/$BRn!aFb~BRA&_7#BØCFgO>ܺ=+^.96w )Oƈd9a*Ei0|h +NcmFđxW<: Efɴ.qw4AlMsXUߠB5q z>J|*&}d L_bIu/$?caNYG, yP9{VqZʃ]+ K/DQ`up _G8!T3+~]`8s'/zNOUiV.@- H Y7A#ǐM5mR]\ P~ 6Қ'haoe\˿\ 435EޕFhtn%_꺿dVRyt_V]$ M%AE984&՝fROOlaԜAWq$,)R&']Tl:f3ta1΀RԀЛ$1stm*l\Hһg)mgW32EUI''#ya69mZ)^JәxI Atzy&1&H"oF>@;cNǬ{JI7K(w=E$#J$96s%%_)|X|৹(4mA?pXfA׾WOFc3//!i{t'r~yw)pO%g~7^pòi٥K3w H򜤿./oѽ-p4.>V*0W`7^xWcv:u+Oa bDPɋorǗ#Ditu{m7&!i;o> stream x\M$qɾpݜ%&S^ N: th5j_ U۵c_W`0UݨYo?ܨ_otF7aͿ~H=[,uTqӄ{fIS`r'-6Mf(4U`F#[zEFW- z08XJ205'!`ʖBrWAƢ+ٰbk_M"$?Sr2+fy!}IVjLU;N?j`|b o/²1vJKD!,T,c?| a pBBal"yTNF HPX%Ս_Y Z߱IZޓp2Ȃ6+,.g5E~$te|j-CCTra!۳*YXf$Zt;qRroh",dW.s;FPmd`)uJ0C.F+4/߮Q1CE``VD`Hy7lFּ/XZ֒Njo5A3[/k1:Ctk)sP fpiVA2i` Hm\G7ݔt @w9`]7\y@Etko|M#Xf,a4uZGY.h.t"hK[93ڔաrL5;TPլd `Yhę䪬 HL_!狒fLY}%o-#dJvs>y\aKY{B_ `ۃg #!2A fE.H"ia:Ŕ):L k2/f` nX ah=ɏ9a lZ ni$095`-Z 5Hm']@0`6F؂{5eKn^\'A_,s4`-YhGjໟyw1UrFb!-:L+ixZv :IeK XBV&8.oZ0d Uՠ-0arR؂o4d(KV2B&g `Yhiz]uh ?"g ֎-HS ֜Uk2aԚM$ȵ%7x/ւx|f:/49u={)Hu[C]N?m53^s) ܑJ_1b5χfם.kBk=vG' Py:E'('eTH̡97B뤪9jc2pL,kedJFiKY/ 5a%AA2s+SFSo,5/vE>T.MVi?hgg&N*ˑWibk/<ŹAšTA *8g}}sVqCHlx,Ux?[wlWLѫş|u_bO0B'OǻbH^?xWq}BxD'$S?cHd ~JM ۽?u/}ο'e:nq n\ J@بbLqR'<3C).;X&NlF}ߒ\?m vV_}o#NLF_\hd&e?xKh^?u X6;:QS2b$䦧bR'$~"C0'a):ptS}5Ιq?)#RJX$PN.HރC~ }wܿrfڿSȬ"֒@$c͚&E R01/욞8s<~lH=SyUhQ{-v9=l=itw-vi76=i29}x18a8xte OEI>7L`ǎW+kOa-:~9%@zҐQM^u},:?<8_>!ɹe# w, d1CO|,RmI$aQ]ZFIey,?C{)>,q8R*tSendstream endobj 452 0 obj << /Filter /FlateDecode /Length 1041 >> stream xVnFr- `#vL @i$=H2"UWK%T7/6*r|]luA"JTW@R+-JepA&zS7RvnuY-12y/BI"E')3qd (ų/CIT5Tͨ/uoOhv&LDUSdqĹ%B2{kdJԾAIDŌ>s*: CC;/۶BNpUH($}`qV*w Ud|4H,8[ @ODmKm0M0^?^vP:β8naNn/Pi`Ň0srU8Q9l7\}{v7[['zth YN\e}v4j+%q;Ӱ!Ś(jXiݜ.3UqkF}^tt90>ymptU^{w2g endstream endobj 453 0 obj << /Filter /FlateDecode /Length 3297 >> stream xZo~Sҗaj[E%Z&(ڴ@- \k{(ݵw;3$%֗^I|3ߐ?* FoWqjoJ[Y^.l+^ʮҥj=^*[sSVⱹYoYzS2ԦxZsc+V$O/\2Kjb,`amf-nLDJsHA*D(+۩&R=ϰrP*\B?BXh#%[m*M]cW*8ݮ,Mo_8 ESnWm߷G++l7w?[f-RIWۯ/yUv\F{{wq?3SHpa*^ڸI3`\9g=:9gg 9̏E*E]hY[uɬAy_5ξᠧ6hy.yoq*YOJd+u$׵뢉-9q.U]0{?DɇE5*YqJa ^zp]Q?nR@CqoYVZ9ռ]r{ͅCB:-#E@ x ^յ) ܟ-P1:Gq5C6Z5bf%`s._xqJHKmT`"r^M_/_n?E= 30*K2P(bgi]buf7֨57^o [~2n# ( Mc{sY|r[~O/F)Ǐmv}"oskܛZ\栗ae*1KHTއ5bPZT N\su]tn~}}{zuٺQ LFjt2qY 9>IJfvr]7RhA,>ҡ&A/\ !Lb8 WSvAa1HV|yaSm حI ]5 FCHrMBHv>8s]I8Z!N*۹C0N? 7Csw?q((tخB@s?񺂀&WؒZ 1F_oUf֖ և`m$Y,i~cL^C>a_wY:|vTZ3 #}7 #(.Z1 xIANZ,T f(EIؙ-],. NRZ?&2Ѯ #DIy{OiR9H^qt땦\@Y !fXU-{RaCKCa FAe#д4ZY@ KBl(q_l LB|IMbh`fo ٹ 2[4itOC)q4cRX2I>h0[Lã͋}ІoV&l {l2}ŸE a!~:y" m!fRQ*# G򢋍u{W4[@x[bClnԀ USj$UrI ꛇv0Z$*p5&2@t86E ;;$=:b?!-*4avKZF<\9a2w)iR%=  Zp̜˳BaΨddiLJJQe?@e0ұ{ i@v42HNпr?rત㼇ݐ<'xU]ΡpZߥVek;i>ȸ|AK9Z1߻!X9&_QYo.*Gendstream endobj 454 0 obj << /Filter /FlateDecode /Length 5411 >> stream x<]s$7nJeMvrI]rJU/vEIH|[ےw\.׊rks}cMRĝӚֹtz{W̋i\2/h`YUC)!Nq:RލGᚦH5~A_>=|4 Ü*ۿ\ۋ+d>b%ȿOyxK  ?ÊeNjWw@^;rsqpkE!'G1R^`% vs[a?V@.fpc2K U*TI5PK.2ns AR]_m$ b$4'Y`خ/nC'A#XVJh8`*X3VV-J![9 u?:!,RMx2P)5+Ăv F)(l Y|>0a(e>(`;|wM %|,+lHQR@dRW^mq \65pP Ám hDž2S;oc`!C&ת;!1͹Y]$8%-+Y0vLf_-[d)0#s-6ǽވY`5#@7ST7X4  e Ntl|1Dj0hqmg®iNv5#\7XGe npD[׀|ʸ%&^k/4g.ݼpeK{|NM!(z|ɿ|*z`3+8"Ou24@"P]hG@܂ۦ=>='dxD 70 i% {[|bI ʡ-cˀ%VU2)Ⱥ~ OZTjHI P*hpC,IfC0ߌտA!@dsE  Ö{Eݿi)VD< T,NvEb?8阵ՅC'jC)Bo))i7 GF2EdUM3^۬,aό{fa] IPygXCɧX ?]qLzfP-G=3A:|c*ֿ֢CD>"![M 6B1Hyt$H^s;}e>brqC;h T`}4`)èiARZ_洞H-4efT6e[[t64lfєN$H$:˔N T:J,%s5qGM\7먭y_.elKm(˳!ljLH^ز'3<_]4` eRLVa׹GCHL mmYȒae ~VrVPkjtRy/;)f)>Lqu^qL]o? H3C$"ryjs߷rUwy 9^ ӞYkȰ3Ue{ ^;__EItWAtY7Ǿ9ng{s:gbV97uEj'1xj2Ȇ 3Dnf#32ssX_fX' >}N?&f3*_{t6ě Spf\Me nʚ;*!|v`٩BcٵB{i`?xg)eЇҠQ@ߎ:<*&Dè}w@ $.B``Bp1Xi}qVwq'](Qac ?gzT;nL ~7tb5m)Dm0l!bHo;noS{izZiw>7l2P3}{wlssul~'=Ը>{)o+w_;}+:Rv'ПݠZbӞكGn7k񫗥 ,gxg]? rڧs!+|^ ]\#} 7?ߊ\2|KK|/[tq._t%Q>hOp40|=`czݭD_ӧxz7={O8ۧiE@IՌT4}QU+~¥ueک+IE|b'\+qD6n x@?f(:]=²%Q<>"An.Ƿ=B&,EƅnF yz׮_:|l}pI/LW7B :LrGC`GKѩKit Kh$[C\= wr.38V(]dӧ~FM qneO 43OP䞱6N3 a>4+ΆD|~tSɍq`!a:ue|v? OtČ #oyhXhH6avk,]ZlGR 5_NB@x`@ U~vJ)tKQ[0X(A)h  /sQ;B. LKR}ܩ.l;~0&ӯ+&E8 60z[Xn arGzz; oRnC1ҟ1 ,Xԁ!/ׯV&mA`4a~zI/ޙ_˝m>{>endstream endobj 455 0 obj << /Filter /FlateDecode /Length 3593 >> stream xZݏܶ!hqKw+~KA[ -4EZ4yX{:K%ׇIinQ$r8 dzpsxU쪢7gn ?/vWI}?1Yn?`6Z WgZZ^TzR£`E=J%l)m4F7*T:F+˺_RJcf+`w+ZedP8R&iX05Jd%6qC0px ߥ6P%Nn<# GF`شɔ3Pt]ߧPHu7+ڙeE `9F ʰ ˓ MO^"… AV?' ULEY} 8I|!AYT̗V Ơtl-;*qlW*elTcU[l`%>&f uo <(3y.T5-ofp;S2xp,zӜ]/Çkb*o\sÍv,ĜiA!# .a"rE5 IMl<6T|Q饖Ãd-ZD'#sͼjLY .b3$Y&|Jv(j+'lɖҩ~=^ci./Ydv\,6d+pl\Wf0E+#qY Q;wnj /qa?vC2gW~30I--2N,A=Y%OMJKv Wk?"B{V(}6"[|CgY0+:jB!I*+.ܒ2rnʁPkD̵0j16U ֻ@)E40` S|Hc:E40sWʡ2oO |g]fkЀ+ie3@*C 0U-,PRDK@R C0b35qwZ_GSҰPBǫfuuS~YȮU9㸁\~q#rV(]'/iP 9^]&F+IBTt,($JzkfΌufLLșΆƗ.};u8?Y8>M= u9J3&փ{ׇ%U,v7x[$Dž́)jJ8tQrq[M$z@ʉ,|W }doFuMGm0os#%{% M Nqeud!7<…QP ]ɹ 2'ZY?\Ÿr2;rJ-o?*I%RVpj6T.' TJ wL"}@,JPII0*>I1$oc;4rRLP>]գ+J,.}̜?;ۤ] z4&v-MO|Gb8Լ~c*9ŜؒeEnVZǚeq=$s@ ;e+ꖋ#%eBb$<9OS|+*݆j)6_@zQs `=2?62_N<"P{ /lu"DO _1B~ OD~:t¨G # ^.7VC<9JHSS ~bB_G4n>:=T'\ʙ.nRp2!*=i\-4Ēu~Bb_eH,UINLaqZօ+VOJz)]GAaɸߦEcN?uMzF2cƲcYM- @b#~jydu{ lÜ sO Ε;t3&ӓa DS. R6I@n7#zh|INV;c­ca_D+l:Aޭdj1YTբ[%aWK|jHl#>]lqG?7OSw"x dPDEJLi7gڶsGMx}eppl-DAwɭj[䵑[ʪ7EA[?Df瞏[> stream x[[#G~'x&HM/ % !Rzgxb{vw|.UM&>]>]Թ|竪oV+F[_}s*ݯ>?HWr|emԫUkZZ﮾lZii9vRhY Oʹv/;Blw8kZƸi~[>~-\˸8[&۸uDK?&'ArXͻ $^Bs|Wߧsǻ|~ФQ9)oIcݍco#"sxuw?͗?ɤ-DJYRZڕd χ_+8" ^{DZ}x; V+kZ9:Jj 0WWIr9C5~1VKR¸цJ#(H)eB*TR\pTHJ*ZHF8f2H +m]uvF%Af9܊V+"=dOXBA] fI%Gdko TU!]앭v#h=Xq+GU5twn ޥAs*pDZ|s:wZsJ+brf)4A JFhW播u+!yːĊ*ݺT+I5fQ&P FxkJ @ 3U *MA:iRa$" DHB7-WNM4ߍMIcX)N\SH{ò]Bz"I^W!cr"QFR`8CX8)'RiA4L'B{G-PgIZc-Ҵ,G4Se%)f[1 TBz¡Q( TB;Q( BX'p4B2 JHWJ(x*\=T(RARZ#iӀDBIKIKIL?sbhwєsk3(j..Ҿ?j H+"%w mReӝ/"#r1$xC <ۀKY\RzTA !'KHfu>Q%*m#vv*0iD:e $Tkr%96ƍ_ a9UL"* B >\Bj998z ;JS] ?($xRe)9 9Ci.T+K05h+y+)8C*a\ ,~b@%)/,'TRhЭTSJJоRiJR3%7hxJte/Tr 9ca@jP7?{JrSڇͷH6&oM)8ɟ'''VZԘ1$cjviF%9!t՟*'Q98tUtU7dΣxӥ -ƪΜio:^؈oVxCnr9xk(o~1DR/ҔŷB&D.]zMB%79f ɣ67ɥq.>~SgDZ8yN3,7U&3!gwKr 2CJ)v]QHU!{nտW0b\D+%ϢMyX'v a1:w@bжy)#OȈ&t NWQ|j9C慚|~חK6`'56 KQ;d]Xhn9BHEJ -TM/ o쪪{;DA Q h#׿=`R:VUU@z4je6M]+U4HiMWhi_՜6*1cо\u~D f~%@~v7ӬX}j")'n VF.eш1?J.i莻gluI ߐ *PSi:4pV$ jL "^xP={[2#V*_AX_E]^)YTw/1uU5z[pwEYiU5Z L5ڰMoC>]iuz"&1[AabysJχ9%QͯW?jy 93䝳m?KPhVX\± @_}F2i|^ΑUu (*S!V<.^jXUg}DUxouzUf%k0"=/.AǬހܘ%-[;erB5l覇 FW pYmy>}MŪoζ^F$2zNXDDꀵ+;;J6gz lӝsᤱ x] CN:'D c̆xh!5e|"`/-vC_fpwD˕–(HWFĜNS8V@k&C筓8f<*fEGJ 92K=ܰyXҜYO6̿-X8:}JK\¶<;7 { B> stream x[o!{h ])&*Z* Zwi|$[п3 KR:[Gwǝٙ/gZ?Wg(vԱY aUF U_=#4+nkʸ"fBN3jMk,ڒG~J-BKI0G^p0:^ɭ%fiwC?"S(';?7_s\f;jp3"ZJV3|9mrX,F7^jirDj`F5$#ǗEZvOsl@\J+#/FOF9G܌2N7a'݈ =c~>|b84d"r!٤ߎ횰lݝ'#+Hӵ-|qِC\Tq*7m{PcJ;ת'A՚ZIǃf%qM_6:H1 P> Ψ?PoG`i٩Ǔ Wq-I.W_> \iE^{[Lw$s 9C.w՘=?Y>Uuː'g!OpYkj*Cm8",NnяX= J~,|5,ğVk?n^v4ٓ6~nxcFwݓl)4y~ZHÀJrk] jrtS5gUY9ýrI4;3&Qi  Eͤ9ξ:)" JaG9`efתZ3S kkX1wNe-u9ȶ0J8[ 'Db`M:NS 8;*ОJSZrA(gci0 VCP l۩bʡ+Gǹhx&L d Z,%q0"ituAܒjZsS)^({L4@|~3ƩE;}/ʛjO bjٛ}<# ZjNԛM&,ռ Gc7 @9S96ە n\o#)ϜHV~7iKT>t9Ye(iN6i}>I8 +ii ,$ EnARS3Ȼ~91x(z :Hv dF $5@j%',t-|(ZBB&VkBq烪5UkLkj=/Avwk&żv316賺24~VG//TsAe̫eu^ BH‚pŵbv96@T9b&p2Vñk/Q}%}͗2 ک K䏣Jn/z9~ %!ĚQ> Ehzx=7q*jTL4\@ћ"46j<[Cf ht  _$Sb5Rjr\/!οK\Y,òk;-^4c9_4(13]{9-/-۾Ԏ5BxEp}yȦV.j 6 7=oshibRm؍&XO HCCZF b4zhP6)xrߩful4xhn|8.i|fy3@?X00āq_ Z3 yx&p"Ш"| Ӱ4E0-+NWHBjۭln"S lu hcրX7F6=ڵG!6"Hw #+pY|5*ڐ Fۍ ḛvP=f3 "dPJih `h8.7fdf E1dB;: 8L_H~grj2^eÈcد6]pb~FތL|au< _ -nauZ2A!,K8Vkie qbˌx4HcnBz.C:!R}T5|>q,^3}Gɳ3,e ۂ{^ d `-mr,ѽHeoF< >yʬ"Lkgw*ʢw[-؇8'n!S5&ʔA'T2(CA*LagT3f*AC{(` sbлun!!~2`̉pC޳ޟ= N6nlYˆ\sKu ldqDZ-ܫ-v!hVcE 9 C!>FQ9=b%4Y,۹VD:8. U a׌}q0c \8ig }1z .[zzP%}Lb@qYȎ7jd:i $UL]4xOoMY2g~'+ x(/Paòh Cu:n҉"֜wͿ˽Kt_7Ji\/+e >c!f{δ0ƑVC[c!󋻙գ*~}kdZShwiUB:Lah410D.=a5SFn!0 -/SDt<(#Cj|6yr:Kۃ UKEñSa_4]hFNjBX:u{j.8D,Ld~z!gZÃoz xu 27ߥ.Ƒ4 o@mϰZSM!}1}LֆϖuƯ9\\xɁϺ UӗäRbu\x]:]_BxQܓl:!]+<YnbcDq*.ŊGk̇U2N/= udr@4Ց?`٨vWul˵ r?}2t珿-~? ;Z,\] hn/&.fVr}͂U/7zVtox 2^hw:wA1kG 6賧;38e%䕦^ K4Rq(N -#_ ڣأT_/)/8-W|?Xa ̰'J*u)\qX7Χ;I]:3[k;;ReweH/{йߢzXjt8^KyF1ߤ\/6 y/НeVRr^\bs YmHT3d0_m]&QsL8@:y%/nTQVG$mΨendstream endobj 458 0 obj << /Filter /FlateDecode /Length 437 >> stream xSKO0GT>:z6nUU(`vCd[k;Adr*d3 g>1|,ǟ> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 460 /ID [<88ef8c36d7931d87d06133a221085ee7><1f82dc7b37683758ae6d5d94bbfedda6>] >> stream x핱/AgvsnoP(PP$ PHHtr *$F\#tR IDp߯/_޼7엌gy֘4_5h˒c2TRss9gZΩ_88&sTCoVHΉxU1>;nŁ/15|դ-nKDbnS1s)R9lX;wҐ,zlG}f}։e8]y6 G3,vC̝rC"ON}un{cbLUMND 0, "royalblue4", "mediumorchid4")) mosaic(ucb, gp = gpar(fill = shading1_obj)) ################################################### ### code chunk number 48: shading1fig ################################################### expected <- independence_table(ucb) (x <- (ucb - expected) / sqrt(expected)) (shading1_obj <- ifelse(x > 0, "royalblue4", "mediumorchid4")) mosaic(ucb, gp = gpar(fill = shading1_obj)) ################################################### ### code chunk number 49: shading2 ################################################### shading2_fun <- function(x) gpar(fill = ifelse(x > 0, "royalblue4", "mediumorchid4")) ################################################### ### code chunk number 50: shading3 ################################################### mosaic(ucb, gp = shading2_fun) ################################################### ### code chunk number 51: shading3 ################################################### shading3a_fun <- function(col = c("royalblue4", "mediumorchid4")) { col <- rep(col, length.out = 2) function(x) gpar(fill = ifelse(x > 0, col[1], col[2])) } ################################################### ### code chunk number 52: shading4 ################################################### mosaic(ucb, gp = shading3a_fun(c("royalblue4","mediumorchid4"))) ################################################### ### code chunk number 53: shading4 ################################################### shading3b_fun <- function(observed = NULL, residuals = NULL, expected = NULL, df = NULL, col = c("royalblue4", "mediumorchid4")) { col <- rep(col, length.out = 2) function(x) gpar(fill = ifelse(x > 0, col[1], col[2])) } class(shading3b_fun) <- "grapcon_generator" ################################################### ### code chunk number 54: shading5 ################################################### mosaic(ucb, gp = shading3b_fun, gp_args = list(col = c("red","blue"))) ################################################### ### code chunk number 55: haireye1 ################################################### haireye <- margin.table(HairEyeColor, 1:2) mosaic(haireye, gp = shading_hsv) ################################################### ### code chunk number 56: haireye2 ################################################### mosaic(haireye, gp = shading_hcl) ################################################### ### code chunk number 57: haireye3 ################################################### mosaic(haireye, gp = shading_hcl, gp_args = list(h = c(130, 43), c = 100, l = c(90, 70))) ################################################### ### code chunk number 58: haireyefig1 ################################################### mosaic(haireye, gp = shading_hsv, margin = c(bottom = 1), keep_aspect_ratio = FALSE) ################################################### ### code chunk number 59: haireyefig2 ################################################### mosaic(haireye, gp = shading_hcl, margin = c(bottom = 1), keep_aspect_ratio = FALSE) ################################################### ### code chunk number 60: haireyefig3 ################################################### mosaic(haireye, gp = shading_hcl, margin = c(bottom = 1), gp_args = list(h = c(130, 43), c = 100, l = c(90, 70)), keep_aspect_ratio = FALSE) ################################################### ### code chunk number 61: interpolate ################################################### mosaic(haireye, shade = TRUE, gp_args = list(interpolate = 1:4)) ################################################### ### code chunk number 62: continuous1 ################################################### ipol <- function(x) pmin(x/4, 1) ################################################### ### code chunk number 63: continuous2 ################################################### mosaic(haireye, shade = TRUE, gp_args = list(interpolate = ipol), labeling_args = list(abbreviate_labs = c(Sex = TRUE))) ################################################### ### code chunk number 64: interpolatefig ################################################### pushViewport(viewport(layout = grid.layout(ncol = 2))) pushViewport(viewport(layout.pos.col = 1)) mosaic(haireye, gp_args = list(interpolate = 1:4), margin = c(right = 1), keep_aspect_ratio= FALSE,newpage = FALSE,legend_width=5.5,shade = TRUE) popViewport(1) pushViewport(viewport(layout.pos.col = 2)) mosaic(haireye, gp_args = list(interpolate = ipol), margin = c(left=3,right = 1), keep_aspect_ratio = FALSE, newpage = FALSE, shade = TRUE) popViewport(2) ################################################### ### code chunk number 65: bundesliga ################################################### BL <- xtabs(~ HomeGoals + AwayGoals, data = Bundesliga, subset = Year == 1995) mosaic(BL, shade = TRUE) ################################################### ### code chunk number 66: friendly ################################################### mosaic(BL, gp = shading_Friendly, legend = legend_fixed, zero_size = 0) ################################################### ### code chunk number 67: bundesligafig ################################################### pushViewport(viewport(layout = grid.layout(ncol = 2))) pushViewport(viewport(layout.pos.col = 1)) mosaic(BL, margin = c(right = 1), keep_aspect_ratio= FALSE, newpage = FALSE, legend_width=5.5, shade = TRUE) popViewport(1) pushViewport(viewport(layout.pos.col = 2)) mosaic(BL, gp = shading_Friendly, legend = legend_fixed, zero_size = 0, margin = c(right = 1), keep_aspect_ratio= FALSE, newpage = FALSE, legend_width=5.5) popViewport(2) ################################################### ### code chunk number 68: arthritis ################################################### set.seed(4711) mosaic(~ Treatment + Improved, data = Arthritis, subset = Sex == "Female", gp = shading_max) ################################################### ### code chunk number 69: arthritisfig ################################################### set.seed(4711) mosaic(~ Treatment + Improved, data = Arthritis, subset = Sex == "Female", gp = shading_max) ################################################### ### code chunk number 70: default ################################################### mosaic(Titanic) ################################################### ### code chunk number 71: clipping ################################################### mosaic(Titanic, labeling_args = list(clip = c(Survived = TRUE, Age = TRUE))) ################################################### ### code chunk number 72: abbreviating ################################################### mosaic(Titanic, labeling_args = list(abbreviate_labs = c(Survived = TRUE, Age = 3))) ################################################### ### code chunk number 73: rotate ################################################### mosaic(Titanic, labeling_args = list(rot_labels = c(bottom = 90, right = 0), offset_varnames = c(right = 1), offset_labels = c(right = 0.3)), margins = c(right = 4, bottom = 3)) ################################################### ### code chunk number 74: repeat ################################################### mosaic(Titanic, labeling_args = list(rep = c(Survived = FALSE, Age = FALSE))) ################################################### ### code chunk number 75: label1fig ################################################### pushViewport(viewport(layout = grid.layout(ncol = 2,nrow=3))) pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 1)) mosaic(Titanic, newpage = FALSE, keep = TRUE, margin = c(right = 3), gp_labels = gpar(fontsize = 10)) popViewport() pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 1)) mosaic(Titanic, labeling_args = list(clip = c(Survived = TRUE, Age = TRUE)), newpage = FALSE, keep = TRUE, margin = c(left = 3), gp_labels = gpar(fontsize = 10)) popViewport() pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 2)) mosaic(Titanic, labeling_args = list(abbreviate_labs = c(Survived = TRUE, Age = 2)), newpage = FALSE, keep = TRUE, margin = c(right = 3), gp_labels = gpar(fontsize = 10)) popViewport() pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 2)) mosaic(Titanic, labeling_args = list(rep = c(Survived = FALSE, Age = FALSE)), newpage = FALSE, keep = TRUE, margin = c(left = 3), gp_labels = gpar(fontsize = 10)) popViewport() pushViewport(viewport(layout.pos.col = 1:2, layout.pos.row = 3)) pushViewport(viewport(width = 0.55)) mosaic(Titanic, labeling_args = list(rot_labels = c(bottom = 90, right = 0), offset_varnames = c(right = 1), offset_labels = c(right = 0.3)), margins = c(right = 4, bottom = 3), newpage = FALSE, keep = FALSE, gp_labels = gpar(fontsize = 10)) popViewport(3) ################################################### ### code chunk number 76: left ################################################### mosaic(Titanic, labeling_args = list(pos_varnames = "left", pos_labels = "left", just_labels = "left", rep = FALSE)) ################################################### ### code chunk number 77: left2 ################################################### mosaic(Titanic, labeling = labeling_left) ################################################### ### code chunk number 78: margins ################################################### mosaic(Titanic, labeling_args = list(tl_labels = FALSE, tl_varnames = TRUE, abbreviate_labs = c(Survived = 1, Age = 3))) ################################################### ### code chunk number 79: boxes ################################################### mosaic(Titanic, labeling_args = list(tl_labels = FALSE, tl_varnames = TRUE, boxes = TRUE, clip = TRUE)) ################################################### ### code chunk number 80: boxes2 ################################################### mosaic(Titanic, labeling = labeling_cboxed) ################################################### ### code chunk number 81: labbl ################################################### mosaic(Titanic, labeling_args = list(tl_labels = TRUE, boxes = TRUE, clip = c(Survived = FALSE, Age = FALSE, TRUE), abbreviate_labs = c(Age = 4), labbl_varnames = TRUE), margins = c(left = 4, right = 1, 3)) ################################################### ### code chunk number 82: labbl2 ################################################### mosaic(Titanic, labeling = labeling_lboxed, margins = c(right = 4, left = 1, 3)) ################################################### ### code chunk number 83: label2fig ################################################### pushViewport(viewport(layout = grid.layout(ncol = 2, nrow = 2))) pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 1)) mosaic(Titanic, labeling_args = list(pos_varnames = "left", pos_labels = "left", just_labels = "left", rep = FALSE), newpage = FALSE, keep = TRUE, gp_labels = gpar(fontsize = 12)) popViewport() pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 1)) mosaic(Titanic, labeling_args = list(tl_labels = FALSE, tl_varnames = TRUE, abbreviate_labs = c(Survived = 1, Age = 3)), newpage = FALSE, keep = TRUE, margins = c(left = 4, right = 1, 3), gp_labels = gpar(fontsize = 12)) popViewport() pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 2)) mosaic(Titanic, labeling_args = list(tl_labels = FALSE, tl_varnames = TRUE, boxes = TRUE, clip = TRUE), newpage = FALSE, keep = TRUE, gp_labels = gpar(fontsize = 12)) popViewport() pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 2)) mosaic(Titanic, labeling_args = list(tl_labels = TRUE, boxes = TRUE, clip = c(Survived = FALSE, Age = FALSE, TRUE), labbl_varnames = TRUE, abbreviate_labs = c(Age = 4)), margins = c(left = 4, right = 1, 3), newpage = FALSE, keep = TRUE, gp_labels = gpar(fontsize = 12)) popViewport(2) ################################################### ### code chunk number 84: cell ################################################### mosaic(~ MaritalStatus + Gender, data = PreSex, labeling = labeling_cells) ################################################### ### code chunk number 85: cell2 ################################################### mosaic(~ PremaritalSex + ExtramaritalSex, data = PreSex, labeling = labeling_cells(abbreviate_labels = TRUE, abbreviate_varnames = TRUE, clip = FALSE)) ################################################### ### code chunk number 86: conditional ################################################### mosaic(~ PremaritalSex + ExtramaritalSex | MaritalStatus + Gender, data = PreSex, labeling = labeling_conditional(abbreviate_varnames = TRUE, abbreviate_labels = TRUE, clip = FALSE, gp_text = gpar(col = "red"))) ################################################### ### code chunk number 87: text ################################################### mosaic(Titanic, labeling_args = list(abbreviate_labs = c(Survived = 1, Age = 4)), pop = FALSE) tab <- ifelse(Titanic < 6, NA, Titanic) labeling_cells(text = tab, clip = FALSE)(Titanic) ################################################### ### code chunk number 88: label3fig ################################################### grid.newpage() pushViewport(viewport(layout = grid.layout(ncol = 2, nrow = 2))) pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 1)) mosaic(~ MaritalStatus + Gender, data = PreSex, labeling = labeling_cells, newpage = FALSE, keep = TRUE, gp_labels = gpar(fontsize = 10)) popViewport() pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 1)) mosaic(~ PremaritalSex + ExtramaritalSex, data = PreSex, labeling = labeling_cells(abbreviate_labels = TRUE, abbreviate_varnames = TRUE, clip = FALSE), newpage = FALSE, keep = TRUE, gp_labels = gpar(fontsize = 10)) popViewport() pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 2)) mosaic(~ PremaritalSex + ExtramaritalSex | MaritalStatus + Gender, data = PreSex, labeling = labeling_conditional(abbreviate_varnames = TRUE, abbreviate_labels = TRUE, clip = FALSE, gp_text = gpar(col = "red")), newpage = FALSE, keep = TRUE, gp_labels = gpar(fontsize = 10)) popViewport() pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 2)) mosaic(Titanic, labeling_args = list(abbreviate_labs = c(Survived = 1, Age = 3)), pop = FALSE, newpage = FALSE, keep = TRUE, gp_labels = gpar(fontsize = 10)) tab <- ifelse(Titanic < 6, NA, Titanic) labeling_cells(text = tab, clip = FALSE)(Titanic) ################################################### ### code chunk number 89: list ################################################### mosaic(Titanic, labeling = labeling_list, margins = c(bottom = 5)) ################################################### ### code chunk number 90: listfig ################################################### mosaic(Titanic, labeling = labeling_list, margins = c(bottom = 5), keep = TRUE) ################################################### ### code chunk number 91: artspine ################################################### (art <- structable(~Treatment + Improved, data = Arthritis, split_vertical = TRUE)) (my_spacing <- list(unit(0.5, "lines"), unit(c(0, 0), "lines"))) my_colors <- c("lightgray", "lightgray", "black") mosaic(art, spacing = my_spacing, gp = gpar(fill = my_colors, col = my_colors)) ################################################### ### code chunk number 92: artspinefig ################################################### (art <- structable(~Treatment + Improved, data = Arthritis, split_vertical = TRUE)) (my_spacing <- list(unit(0.5, "lines"), unit(c(0, 0), "lines"))) my_colors <- c("lightgray", "lightgray", "black") mosaic(art, spacing = my_spacing, gp = gpar(fill = my_colors, col = my_colors)) ################################################### ### code chunk number 93: artspine ################################################### mosaic(Improved ~ Treatment, data = Arthritis, split_vertical = TRUE) ################################################### ### code chunk number 94: space1 ################################################### mosaic(art, spacing = spacing_equal(unit(2, "lines"))) ################################################### ### code chunk number 95: space2 ################################################### mosaic(art, spacing = spacing_dimequal(unit(1:2, "lines"))) ################################################### ### code chunk number 96: space3 ################################################### mosaic(art, spacing = spacing_increase(start = unit(0.5, "lines"), rate = 1.5)) ################################################### ### code chunk number 97: spine4 ################################################### mosaic(art, spacing = spacing_highlighting, gp = my_colors) ################################################### ### code chunk number 98: spacingfig ################################################### pushViewport(viewport(layout = grid.layout(ncol = 2, nrow = 2))) pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 1)) mosaic(art, spacing = spacing_equal(unit(2, "lines")), keep = TRUE, newpage = FALSE) popViewport() pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 1)) mosaic(art, spacing = spacing_dimequal(unit(c(0.5, 2), "lines")), keep = TRUE, newpage = FALSE) popViewport() pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 2)) mosaic(art, spacing = spacing_increase(start = unit(0.3, "lines"), rate = 2.5), keep = TRUE, newpage = FALSE) popViewport() pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 2)) mosaic(art, spacing = spacing_highlighting, keep = TRUE, newpage = FALSE) popViewport(2) ################################################### ### code chunk number 99: oc1 ################################################### tab <- xtabs(Freq ~ stage + operation + xray + survival, data = OvaryCancer) ################################################### ### code chunk number 100: oc2 ################################################### structable(survival ~ ., data = tab) ################################################### ### code chunk number 101: oc3 ################################################### dpa <- list(var_offset = 1.2, rot = -30, just_leveltext= "left") pairs(tab, diag_panel = pairs_barplot, diag_panel_args = dpa) ################################################### ### code chunk number 102: ocpairs ################################################### dpa <- list(var_offset = 1.2, rot = -30, just_leveltext= "left") pairs(tab, diag_panel = pairs_barplot, diag_panel_args = dpa) ################################################### ### code chunk number 103: oc4 ################################################### doubledecker(survival ~ stage + operation + xray, data = tab) ################################################### ### code chunk number 104: ocdoubledecker ################################################### doubledecker(survival ~ stage + operation + xray, data = tab) ################################################### ### code chunk number 105: oc6 ################################################### split <- c(TRUE, TRUE, TRUE, FALSE) mosaic(tab, expected = ~ survival + operation * xray * stage, split_vertical = split) ################################################### ### code chunk number 106: ocmosaicnull ################################################### split <- c(TRUE, TRUE, TRUE, FALSE) mosaic(tab, expected = ~ survival + operation * xray * stage, split_vertical = split) ################################################### ### code chunk number 107: oc7 ################################################### mosaic(tab, expected = ~ (survival + operation * xray) * stage, split_vertical = split) ################################################### ### code chunk number 108: ocmosaicstage ################################################### mosaic(tab, expected = ~ (survival + operation * xray) * stage, split_vertical = split) vcd/inst/doc/residual-shadings.R0000644000175100001440000001661014671771732016342 0ustar hornikusers### R code from vignette source 'residual-shadings.Rnw' ################################################### ### code chunk number 1: preliminaries ################################################### library("grid") library("vcd") rseed <- 1071 ################################################### ### code chunk number 2: Arthritis-data ################################################### data("Arthritis", package = "vcd") (art <- xtabs(~ Treatment + Improved, data = Arthritis, subset = Sex == "Female")) ################################################### ### code chunk number 3: Arthritis-classic (eval = FALSE) ################################################### ## mosaic(art) ## assoc(art) ################################################### ### code chunk number 4: Arthritis-classic1 ################################################### grid.newpage() pushViewport(viewport(layout = grid.layout(1, 2))) pushViewport(viewport(layout.pos.col=1, layout.pos.row=1)) mosaic(art, newpage = FALSE, margins = c(2.5, 4, 2.5, 3)) popViewport() pushViewport(viewport(layout.pos.col=2, layout.pos.row=1)) assoc(art, newpage = FALSE, margins = c(5, 2, 5, 4)) popViewport(2) ################################################### ### code chunk number 5: Arthritis-max ################################################### set.seed(rseed) (art_max <- coindep_test(art, n = 5000)) ################################################### ### code chunk number 6: Arthritis-sumsq ################################################### ss <- function(x) sum(x^2) set.seed(rseed) coindep_test(art, n = 5000, indepfun = ss) ################################################### ### code chunk number 7: Arthritis-extended (eval = FALSE) ################################################### ## mosaic(art, gp = shading_Friendly(lty = 1, eps = NULL)) ## mosaic(art, gp = shading_hsv, gp_args = list( ## interpolate = art_max$qdist(c(0.9, 0.99)), p.value = art_max$p.value)) ## set.seed(rseed) ## mosaic(art, gp = shading_max, gp_args = list(n = 5000)) ################################################### ### code chunk number 8: pistonrings-data ################################################### data("pistonrings", package = "HSAUR3") pistonrings ################################################### ### code chunk number 9: shadings ################################################### mymar <- c(1.5, 0.5, 0.5, 2.5) grid.newpage() pushViewport(viewport(layout = grid.layout(2, 3))) pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 1)) mosaic(art, margins = mymar, newpage = FALSE, gp = shading_Friendly(lty = 1, eps = NULL)) popViewport() pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 2)) mosaic(art, gp = shading_hsv, margins = mymar, newpage = FALSE, gp_args = list(interpolate = art_max$qdist(c(0.9, 0.99)), p.value = art_max$p.value)) popViewport() pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 3)) set.seed(rseed) mosaic(art, gp = shading_max, margins = mymar, newpage = FALSE, gp_args = list(n = 5000)) popViewport() pushViewport(viewport(layout.pos.row = 2, layout.pos.col = 1)) mosaic(pistonrings, margins = mymar, newpage = FALSE, gp = shading_Friendly(lty = 1, eps = NULL, interpolate = c(1, 1.5))) popViewport() pushViewport(viewport(layout.pos.row = 2, layout.pos.col = 2)) mosaic(pistonrings, gp = shading_hsv, margins = mymar, newpage = FALSE, gp_args = list(p.value = 0.069, interpolate = c(1, 1.5))) popViewport() pushViewport(viewport(layout.pos.row = 2, layout.pos.col = 3)) mosaic(pistonrings, gp = shading_hcl, margins = mymar, newpage = FALSE, gp_args = list(p.value = 0.069, interpolate = c(1, 1.5))) popViewport(2) ################################################### ### code chunk number 10: pistonrings-inference ################################################### set.seed(rseed) coindep_test(pistonrings, n = 5000) set.seed(rseed) (pring_ss <- coindep_test(pistonrings, n = 5000, indepfun = ss)) ################################################### ### code chunk number 11: pistonrings-plot (eval = FALSE) ################################################### ## mosaic(pistonrings, gp = shading_Friendly(lty = 1, eps = NULL, interpolate = c(1, 1.5))) ## mosaic(pistonrings, gp = shading_hsv, gp_args = list(p.value = pring_ss$p.value, interpolate = c(1, 1.5))) ## mosaic(pistonrings, gp = shading_hcl, gp_args = list(p.value = pring_ss$p.value, interpolate = c(1, 1.5))) ################################################### ### code chunk number 12: alzheimer-data ################################################### data("alzheimer", package = "coin") alz <- xtabs(~ smoking + disease + gender, data = alzheimer) alz ################################################### ### code chunk number 13: alzheimer-plot1 ################################################### set.seed(rseed) cotabplot(~ smoking + disease | gender, data = alz, panel = cotab_coindep, panel_args = list(n = 5000)) ################################################### ### code chunk number 14: alzheimer-inference ################################################### set.seed(rseed) coindep_test(alz, 3, n = 5000) set.seed(rseed) coindep_test(alz, 3, n = 5000, indepfun = ss) set.seed(rseed) coindep_test(alz, 3, n = 5000, indepfun = ss, aggfun = sum) ################################################### ### code chunk number 15: alzheimer-plot (eval = FALSE) ################################################### ## set.seed(rseed) ## cotabplot(~ smoking + disease | gender, data = alz, panel = cotab_coindep, panel_args = list(n = 5000)) ################################################### ### code chunk number 16: Punishment-data ################################################### data("Punishment", package = "vcd") pun <- xtabs(Freq ~ memory + attitude + age + education, data = Punishment) ftable(pun, row.vars = c("age", "education", "memory")) ################################################### ### code chunk number 17: Punishment-assoc1 ################################################### set.seed(rseed) cotabplot(~ memory + attitude | age + education, data = pun, panel = cotab_coindep, n = 5000, type = "assoc", test = "maxchisq", interpolate = 1:2) ################################################### ### code chunk number 18: Punishment-mosaic1 ################################################### set.seed(rseed) cotabplot(~ memory + attitude | age + education, data = pun, panel = cotab_coindep, n = 5000, type = "mosaic", test = "maxchisq", interpolate = 1:2) ################################################### ### code chunk number 19: Punishment-inference ################################################### set.seed(rseed) coindep_test(pun, 3:4, n = 5000) set.seed(rseed) coindep_test(pun, 3:4, n = 5000, indepfun = ss) set.seed(rseed) coindep_test(pun, 3:4, n = 5000, indepfun = ss, aggfun = sum) ################################################### ### code chunk number 20: Punishment-assoc (eval = FALSE) ################################################### ## set.seed(rseed) ## cotabplot(~ memory + attitude | age + education, data = pun, panel = cotab_coindep, ## n = 5000, type = "assoc", test = "maxchisq", interpolate = 1:2) ################################################### ### code chunk number 21: Punishment-mosaic (eval = FALSE) ################################################### ## set.seed(rseed) ## cotabplot(~ memory + attitude | age + education, data = pun, panel = cotab_coindep, ## n = 5000, type = "mosaic", test = "maxchisq", interpolate = 1:2) vcd/inst/doc/residual-shadings.pdf0000644000175100001440000025132014671771753016714 0ustar hornikusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 3776 /Filter /FlateDecode /N 59 /First 486 >> stream x[[s6~_M~aY_$d$MYlHTwR!wdX$<1$6JLaODX!.񊐉tu(Љrn- 6Vc`̑9h%ct\zdb3UD0ITiJMλUQU<:IryFB'5=:'7Eu\bq>M9O5Uhްnuyi!`y_[<kYf{62ǞI;ρΚVy/3 j'vUӑw!{Zocqٟre9&qq]%YjLlz{ޫG()a4$z!iIȄ{ygOA;(4+;.@/TB͇ml[V7p + j[#Q)ʊ&%'rqH_uq`(@ڨQ|Q|rT#L+jEwBhtT1^hU'q%ag^80'/xR%LvEji|RHe44U +t6 ղx:#CtP5hnw'yx|ه_~<9Wݑa?aOG_.Ȕ[.cafl|j(q }L$U q_~uI)OsC>Pq{ݷ}6/VY( .o B5@K818ξ]႐c=\z> vON@7&[VVТ"hN'%[ _@̅ qQNGP(<{ŎW&b!tЯB3^Wș^C;5Q6q4h_l#H%7xΑ]c]۸72 6iNz1fƘ6);bjKsY[7-{~e|O ^L>;_cT,w',Y(v*rq+}U?M% y{l$5?cIMDݲa_?qh6k=^Rt?:Wtu6Qj_8~y֚+N9k\{ ]~₇0Au!ÒCx=D2J6lM(hIO 6JOLPW+F V߳ jz"d)Z-AbHBL,{$oݛUS/W$hdZ}4D6iiY JI=H0Lv7sy=)F4LjZ5:5D-`bDL̫^<05<jUyX8wJV"*<**xUۏ~^fEߋ}-8nr75YH4"5Hxjo(jLDrD)buR:}iC&O|.~TAp%KINfDYҗ( Q`h[Diҗֿ(ɳMTߍTQcL,TSt8#PݤGLmpp,O&ʧe$}צnRvvcIgA2&+)r:( ( ƀ0鳔DX+ƯO'Qqjlk¦RMԀ vK@ծ&JK :g BnDu6ҖۥւmೄգرeU]O~b_i9`kgs%{Z6ohsXΆ2ӈ,h;%wʽU>9Spu) 212Ͱ  kr/';&JPw4d'AAgey|=.v_XgL؝jB|5LZWnZB_p"GDñt\<,777K4i3: g VRrhRMNLrzOȇIխ&i%zzN; Rgy5"OWr_Ey˹{r7d ^ !C =ܷR^EdPp6bLC\[ eq~-`. B%a< inLwo]Aߎ9ҫI^M2zA\xL~RKS{fυCsuD `֎_aendstream endobj 61 0 obj << /Subtype /XML /Type /Metadata /Length 1554 >> stream GPL Ghostscript 9.55.0 association plots, conditional inference, contingency tables, HCL colors, HSV colors, mosaic plots 2024-09-16T11:01:30+02:00 2024-09-16T11:01:30+02:00 LaTeX with hyperref Residual-Based Shadings in vcdAchim Zeileis, David Meyer, Kurt Hornik endstream endobj 62 0 obj << /Type /ObjStm /Length 2322 /Filter /FlateDecode /N 59 /First 486 >> stream xZkSH?~?Rl l&L1c$bE[ʊf)⮎ү68m09;̦SV-@\;,tL71 G{GyN1>]Z&zrkZ":WWkQ .`M~();"6@c|gH2,L6$%՗IiR5@V$&s'kR&"; n&p3hEfF, sc.'dogz<̧t]s3f4f-/sA9’NHnVª2_LNIrݪ#Ng A/rRm# ̥ H 4[Q%]($F*>=n7NY@ fJn{aAAErl#rCry0)HH';bћڮ1KfFWK?\OI>غ优'?VldфP\t MkCYϽF] *.@5ӀR.rU)^3jϒ1a GiA)e= (m WI#N-(OgaJGn|7y! թ)@u+$- rt*sP|#Plp2TjJ0^nۆyM1iv^T1h۸~NO%pT᰼Zщ&-ITu|c탈=Yjd8Nc֕-0_ !JZEX >2`[l;͖0-aT5J9$DӉ;\j^Ԟҷ.\V=M$1eEB*) ZT+5_SM7_X˔т{ћAD HS+ c=Tm.Pi -Ґ<Ih TfV8'<0InkoN٧5٦y_oP_r!Uy?9fn+e/G=9 9@yҼ1~h'C .>Q;:0O{)?L-ԓ7)'n`/pz@Gs,'I_<ም\RAOԕi}(03|J6vcendstream endobj 122 0 obj << /Filter /FlateDecode /Length 3711 >> stream xZKsÖN <1㊓8rb˩]v E_`#)D,ӏOg3NWgO_rU!V7g~ _qc e:^7eQVٮ_ÃrFjɚ}|A*XmY)XJW7/v,6E(8Y.`J+G;mb[FJqXW \dV% =[K^\YXL,b7e$?wJ5]CѼRiW5l@4Nc^ SIW*>%,lʊppQ2JB pVn?LB*ţvv Aְmwۼi`•jrpYh_M7WlUvC/$C<&7`*2 [cY7PJ)A/v^K.z`*Jkjޟ/ξ;0b3 nu`L 1=^V0++M0`^*m644j eyסAkáfTlv8Ѐi8c~.tᦽIFlzw H;^u$SȨG'Jȕv0ҀJb\NH "6=] 'VoT)os}D"t v#&uMWeY%~Rdz\T>dz p 鋜6Y>qE*xTXLq afzcm_":q M);H#cvIB7\j3IO[5]1]7m{ GnNzo\ 5١k0__[ w&.Y"C/A p۳A;bb&15 z>B')Ì.j( l>d5F =r0c#Z)C\XeeД!Wl͗Oth%.:VoC2oq@~VX&`t%,Y}/ǮR2Z~'.K#R\%lZ %N·T *eQ̖]P:2BVA8#Z"*.Ϟ>}xx(^nBk] E]?}T8+W\|+S3Iban %֧ ?Qs, |kx.Bh3ß !D%PK%=++a,-Z;ەt]Δ0,̝ǎTsb9ρ\vjoֿR?$@1Pk 2MLq_<t#㆛!kYXdtzɏ8,G/TZKraf3 BVj%-r`%,tΈom4ȀkkGA1X\r6B/ᕛ tWl]S6p8 #d6z^Xu9@uX=ZpBigtU2Gr-#VrgE("K7o)«OU!Ф^\fumWw;8G }^@ƌg÷ E LS$xx4ҬN3yC8%;RVs ַWsLMk0j#,b"ݽ\bxE>֖9 L+ F~?BL@}󺫻 F}U/ǿtHG o8Ee}V^ tKm0SsV\ rlŬ|-`FQ)F)\w+B*p%B2|R k{gg9ѡ/R?GCMWabY?d)@ia_v@.6Pnzw{?!V5/#"s 7ȒljjSīrعع,oC.RK5/羋zJۑ{>͛C)nih[ (i Tԩͥ<&dm>=aީ=Ѝa vO$ڔxo%x^:euWG.wZoeScՌmxi Dy!D2޴Y %^͔)UH kO}RaB> mwA-qCrl,dhE3 AwZC ʻ)a WiCԈjRi*xzdBV`]@.*իbxԫđ~^0NU:Bk.VT&t]L-N#H 7mӝ3`R$(`/ۉ^.UHX5uѳٷ}^[YrUR4,G$y.<}BfC~]N4U;BfI.vq-?KB.G;#y̎2lRIebBıyeKԑRōG~|w_ 9cU`P@FG&|/ vO q4<=ysXzJW6b~ah<;M׹XFBbk4]}ۻ~dOUڌ$_b:j./aKiɋns;N`^~swe\:m<x43 }ʲ?+ݡ( UfT/Cca3|~PJoowCzc>w]endstream endobj 123 0 obj << /Filter /FlateDecode /Length 2977 >> stream xZ[o~K0`ղ Nm"%ZծVlK$眙!gHh Z36|2~JJ?pgo8]?WWgN+xW"J*yb^]^kOT~In:MR-sV)%,)w ~)xܮLSXE\hv_mH._-"¹fv Tܑ,(a/Jͅ5emP-(W"pkF ³n'nd-Y.X]:umPW TSw[:nwo]s5HSizv|A4]мXmBJͮ=e_5Ǒ82tbͮTLmz\Obǫ $5;ږ}zS 'Q!ZFd@痣8d磒-&[<\R;D*6\zͪ6;|4 6uކ_࣬sѰv֨B܆z)#2V: ͺj9/6U,x| e:X6L%ld"D\)Lm>4Z|b]7_w+IwwxOyQ,2.Lv9FF$ AL]sP!?TOB'QAvqCHiˆ\SK#<%8ȢFg_kTdVy9/ݣn Ke墔 ?xA@Řr OsiqYE`_͐yYe,.P .7n'0/i5 :6J3rz "?DOiun2 ~0x(1\@8\ &%ɡT|PuugPE:'&^Tqg3[U{2/VR9c>^aPӐ 3QjLő=,n׳ӟ.`FϲXc xKs5xFHMx+ӂܠ[k eAAd)8ul3`;΁nnM 1'qS6#lk=.F@EJ3) IFzFƎx()TsVsE fKpT5z%T.xL{rF.а+ NӻP=̏'XT ^c [qINq1l# DӑSޝES|l# .:cǥ5X )12C+/]BE',*j +)CF5KԪ '!M>{Y1~njģkQa- `|~ƌmźF^jj69=1bVO| rGb0"fb ܇Sb{}@Q7)?+]7m RM: 6Q.pr`=CVEGu"dkI[qRNzkyUP?i7 5DRJOvq3nʺv$w5CX]'db)p: c#U\T@Y\㘂8=3+Q/Z-ݧSUwSn͋~ ~5$n5իa(uI( oa1훲w=`]a[=Do:GW?wmSx/7-9PMN7[3Xcfe3`$ #Q]ݜ,kh<=(.Z:lA@o*Oۙ6 o)ԉ6Ev )m4 **@6T*ngmiq *\y2tr\`gPQcO 1ӃjnM{T-f^Kz*4XNffN;ߩa.+'?PakTnҺ@\m)XkJг)+ұ!LpL x a8T TК1{#5/DDMRBb@jpSڇ&# qӖ֜IxNN六ȂF0Bk Ϣ z&Yg^FPft.i7I$iD2"iĢq'a 8RYCxJY;x;9K+T6MD0'eZ{Hc7;)>LEtwe&N_ƹ8@o';v>{ # +{>S]L8W>B-, /:! Y w.- ! ϹN.IԅtɛA7[u<\q-.:R3Kodqf9q&ZmS%WJ`ʏ%+UdL4L!Ԯ?[U꾺_($72D;,潞4F#0M@MA(peLQ M>?ӌ>am k8li& UZm?tPi3P~2ZL5>gWZ!G bmU >Ǘ:C> stream xX XTGmC "iAŌFŕbĥAMApAvEE6&E5& Dż@+nwQU991VCL6|ʨȩ/Mz-*Xf22 fǼLd1Ɍ?b2SEbf,c%32*Ɓqa1pPf"cŤ0=-! #wʿ*ognb6}sll޲aЏ}7l0bï7grDe_,a7z;,YRk?l`H''N`ʌ̀X4#0p6@TQvL9eKzFQo&"{htjK%ڬD9p#ٯ$Cy 8DNְ HM>Ұp=xa('b^Ho?B~G:[f8R*zu2V toq_F\@;&3SՂyF /`.V<*Z:Yo?=!lTkK:&Q|,C;,F;XQ*t-JfLCc$3+Tq{*m[N;иPԑ`0uL0FqEt:'9tF!L$*vPoJ>:}򭇅gఀZ2ߔRURld sYT9I*LV/Ѓ YG[5Y,Qb.9#O1Fgm\f,w?!ؗbbۣG=ǩqvFS~:\<̉΃.W.':N_X+|g-֫&V82N!/}\ Z/[#m Ytp}]I);\KSƈݔ.cGJti*Ԓ8}T*O)MMFf YaѶtn>=WXB((J9GU|UdU~R_௓-Zpq ˏ74 4着2j*g:43>WjʚkrTsՅK}(Cyh/1 +ԟ'){L>=3`" qDl]:ݜ-)-ڵvG iGYBN5axЗhɐ08gљ*kւqQІnG: pE8Ln;Nvw獛oңˣʤ~6:{:X6 tB<&m<l 4jh$&'CyJ5[jъg<ײn|}s`_>~ʛp"dR؋38Dtt+J-+ lxxѪXiFCh!4J8dE'sP+NīJe@IV*~ؐBsNv?{}ʂxSz8|S:_iџQmG5OM媲+,˂Pa8EKlg'T֔5*P ܵ-,yLD]Ͷ#j~V|'t(\MF5iFBغ@/f?78Ye;2% )qQA}p &g [ƣɜ%7Hm죿RoI g:4ljO֛+Y92~@bff1S`yk%b !BeӓF'9k7y-\SVm14q昲m}b@l/frl5Q7Zr1XɻƤtA}*WnO^BGt̻`H`Tgf&h.aWUYw x-2˒_OqjryG#R EK}ǝ^]n!p>wS t@5 PĢ\\$p%J<X+* Υ/1zD():9P`f\-uT\Kjx-p>-TEwܬc9O&Uʛu/V@+'7IT-:5Y)Eq],Rœ(LYe-. ɳ:%I}j {#'gT -jnSOQa!C=WLFC'9eh GKڥeM ;\OwBfgS8Ѕva 쑚9,d@؉jNυylǗneݕǹwyıʄM6A+J20` V 0-T+>!bknFss>W2u[[Q],W.i =KD5-?h硄tD6&kV2ehi=zL [&6tgS_5᪐IS˗D G$RA˵AFA_*X[7?BJ(~Eξw0X?z+dZ-~lЭ޿vf'F!pm,]i1K=}x }֚ >dPd{a8mP9{X}jR/NV2N'/ qgd{Hb`t|cНp=|;XYT HY\;!j -(!,zZЫEv59{Dy?蒁6?>0Mٖq2܋r1ƻQaܥD.ݾ5Й۲+'j kLփ/sEv& >INφ=T(hE:h!q"N\cSQXv-,> stream xmyPT_{"h@[_[02*:c482,M`7K4cM^Eɨ`2N5ELf1nqS2y3I;~J(%H?d؛_ݛpMZ]~VrwGJ"LI${^~Rr*s;'!&RRd[i!۔m,Z b|MI*\i($41Bq1C3Ǡפhw'gk -q4k7m{,R5qސWeeQ jKm6j "(}*ZLPD锌2R,\sU:M!cdn{NEt o}G/dJ^$f&0CY=UheբVxy<FJhPD%_p;CQp[£II+c\7M#7CEp9#h-"]=ePɊry<}fT< GfPzVfC/X [҃AB&8=1B,"ɬ'ː?G GJ3Jҍ:Hm\ xX_?x}]f [d+݂ / نA!D()1, "KLާOsUqڠʡHDk 0pͶ;zOqJA}]'Ϋ #jo%A~ #uCXa S~۽+!9|He3Ad~1+AC(*֧qb}kuM_KtWcV}M{t)%fuvVb?1T!3+> ȝxN~u`&$󷊹"`QM$tڡvv qDwF S-l^"؅Jέ[s!lbFkYUKՋI\tȯ `!2<&34T5.p64T|Zaɣ^I}8-qRxL mv-M`tuT-Lro?oly~]k:̲]0Y$st|;W[qgmpLMQ\O1D m{=$z0$ I0$㔇AiA\Ea䱞M[,\Y#02% y\,7e hxa/1ЈBغa|^ 䒸1e5$Nel?V@>X, k@0^@?51ޅ4 \ؠNh4ݗW;T݈‹P{wkepƍ|ű| dYptLxKm^])<`d_:fWP_XYgL7$A$ 0W]GNCKkɸ' 2wH* n^k+{66Ag0 砅{w8 /x=BTۅ|F*{7-1N)vMMv^Xya|ϥALRpхܓm7f2;3".6amdsTxK,\YeVkNHhɤ"mO:G=] SZSu)e0; .[CzQSY[:{|EW\OS3?J?] JE+c{ Bl&7(x_1m66}N7>TmkpMO^,endstream endobj 126 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 7639 >> stream xzyXS HP CՊV8[YFyC d%a@< VűֶŶuhm> h{{'ϓ?NN{w}W"LM(@`n]v^a~ 7!`kEWBs#dJM)@;hY@`T/PӧϜ:ϷrZ:Ww=V>~Նrq+7oW_OO+V+V:n4Oz{6K- ܾ&_ M֚6 ю4Ǭf ;oK?`>v`:cq20a3 {l.YJ,-C-3B?rȃbv.([m5*Ũ!c`ۘ1c>v%qA0.Ly=2&fFC4(1ؽ{iV*ƗIhGo Wi9j80C jS)XC K7j?C([D5LRf\gLn"ZnGo`P`= m)[ N/&%7?J.崓VU6Zdh-և׮:ڱ8ww־HF7t3Gtc]2V_ ޼1_cM|+Ew4r/Yw%* GġIex0z(Y}.xR5'X4X$afY%,2,vfPHMN[-+z~NPӁtyWNx!A}Ѐ!1;/K^ \vwYI87]J}関"6E!q9^N&-iXR.݀{K!K^CQŅ}Our$po[Ɩ"1 !Z|OLVҳvZ:7YV=-= L/hʇGkԲ4ꞑo(nd= c '[HεOVEL)_v}XN8.'(c|:?'4_ I ")! JHse 4UHSI3b4@NA4 5ɒt썋E`aF. Aɱqt"KSru35(g&(J͉MWeF),947M#JH!x2B! |Vn?21 ٱg鷛m_G@ 8cٲx#DiBkpd#=pЩ*!NSlĪɶVYcI`hPX]f$Ӕ2v ԪϱDRwش15ȓ4 WJK´IAW[/&Hu UXIfՁT7}]!Vt QQ'zUԤXegT4>{DȻӍW C[}oԒZN{{:WeHNZ(a -j|V%ƠJ*7-kFBm:(b^^N'O/P=[ω^mnXԛa?QqՕ<̙>$JMUR,D4RyUMPf8IT&w VKd R¥e須, sj:}…J-W]=.2g CK(|+g~xPvR>f#h6-ʫATA,TQSUV|!b CO$^*{STV5)|-TIQ8] :%9%^V(@9 hQr 'e|F1IM'mVZ.Ru oZc m89!}8dK2;c("sQ,MDl"3~*mB&D+D{@R!2&u~YrJ/ag{1_E y*u$B(S*jD2ݥ"tzZt?fǩU@f?EWÉ[F/paTEb*=am; 7Au"ʟ;>%uǼ;e2Q!al xQP9xnֽz ~%D]]$MWB܁/*uz{2?`C< bpC"{_X {#>r^q`52ϔ Y'G䉠tM-qo+2Bz$xkRқe_V]Vҽ=R,RGIuhߞjlOnGZe-|xkh5!6HŚsPNp9>9w.zO9ej(r{me4FI*U\mW2АpQږ 妜d_uҁ򠜽Ym\6)U9|v]Zh۸=׼: c z2ˆp4QV'"߆*4`$4G z@䤖B=3uhZHPpH Jr5դA-ߊ6C7IB:,O6,F*Mr,isiՔě2\1RUb!"&hQx wK;Z!2r_J$kdP%+!p'zΗۖWmGO~oNWX~лh< 1<OCbV[pAz8f^ms! K2g(/&$uڕ CVaId`ATU%T*p)5ߪz0r%3nnPUhkifd2A^BG҂ڏ ~Kh9NuĴ#+\ߍ_O5I/TNg\0șo}0F/W$cP&HMvY|*-5UH 4.w!KBe6x6/WimCZr'%&h4ih>.E 3z.Z\e=‘fR%W1BNx{IվjxUH-HYjdŸmӑ*0]T'h@YBݖޟa~+ i>+{$ͺe#N9u7=f^{|)v~N6~÷p szQsa13x^&Z~&|hkenHW&]v&Ty*0Κ10y}e0ޏ(KGtmxw_~OBwDKMKrߟp W^D~^X"}<ټ;4hZSAd+k7G̗{:xTn! O E +z- 1b ĺ׏nD6#:Ai=ftAٰ2?Kn+ɼW~E/$X)BJ;hYtxPF~99tZ&1%Aho/mL>n7$g%+#G&Rʄr];)xHSt$djilnQӹ/,weEyjv !!=vVkw/YjU#{cv7'#S^ :ZBɍ,i9TXVAڴF6ԕ&&'iٺ8w%ˢ#ɏ޼ yBM0B\pl%M3=:v;8Vnnw>9#U eYL| ;ʬyJu׮(:[IqXϱ%0;u+ l"!5? nD hef܅|"$Eϰ#bX{Y* F ;i㉻O#iC},@Gkdytß6: 7og\>aʹ(SN67)Xol{Ȍi/_' aߗ:r[oݾe[-,2+=:Aj"OK>}XqU"k!C˟$/ȦHpº9z2zq]9jGj°hݫϹ=B'F"ٻJL<vը&8 "=QT}P~M{1C5WB_8~6?$߿2wMtցiu_?rY-m]k% $mF]|.|:i?+y:3\FZ%v"2p$hrX^ۥh!òD?<& S[mX痷~Kj{fDcr0*ҙvEc=o1N&+0gFw\LΨR&;r[HTߜ}/Gw,_o05cY vd]Ah9.obo^>I|1ArڽN[:vo7tnQ"~(5 fW^yxF[ٝ'Yk>)yO}yYngߑ[<ޖ>+9i QF2o!JSQG_8IBf_1}&@S-=AhH~sRxUX݊MⰐExyl֎= 4m쟞[Vwh2Ef_FPBji x&`"{>Lc$ĞA&yHiߛI{eq|xy<%'0FIexEoTpXpyh5W`a~ qg7U4q8tB'D LUBa܆D_9Zƺ* [[ZQQtC4o+X# Sw xf W91/NgZHd䲚w**w ZH!ۋ\T"DVrl2=S fH0 g۟0@чĘx%ɱl܂-zi:q`Ū^σu%х.kFgdֿ>=)ق)ICw> stream xX TSw1jզs/Zj[QNZep";D! %!{žQqZ-]fڙt:o7u:x:;Á½۾??p86mޞxт72q1?汉+ %Dd.L㏞^؇..^+.gZh g^Z!1Y+ sR6,ܼ0jK)3uOԮwDlݵuA[F6:/? čI7lIMK)ڕ;1%smb'1E'vq%b G%hGψb@,#~Ll"1b*17O4r^lW{ū`$%{'.8cvcb ]xӓg<>RGf=rm暙oG^L,AS.h_9 \= 38TBg 2@*ٛF&0*M"`.4Z B Hj=jPi9ApټwH$y"$ /XZ#N ^ٵHgSyh [P3R =wAS =oTYnr6ux ?Xi)9#lKteKKUn怍yL&Q R^^0jM:0Β:oAEl΁9m=h6zCBQl=LI s q/݃zz?|Γ)1&Plbr}lZU`*]mhze氱˟ܷ}m@eavQYW>x?^ݮD+50QX*cHv]&j7䐉5u FAj)_AbnWR0j)Zis@>D&gHhkRC>mҙ@* }\wj+Kyj@ͼlݿ/ ;^K\fNM-%!$4Wgm`xԕlMHXV*d2D`ohV` vvmrlPJ,OEZ q䲁:]ǵ `MJLX+.r3ߥ;|ԡkCVvl9;al@'P*{}\ Er.DDMa`Aέ/q|֪L7VaW @T%aR,9)]=z'$AFb`=&а~s1ڭ,@LA%txNCwxw Z)7_<<$f'ĉ^r9AC?G1IшRMS@rw4w)G~۵}NaS~{nڡv22\c}mo p;aoC.4BUKqgعOF{QڳHjvy@}lM9F7<ۇcTc\"4F-n051WC=Z>2*ݬp(LH -zuivtm<2 *e&iQq {2}v[ ݅ MͶK]Kj*zYtGzM K}K(Mxq:8R"!0 *@S+LJHJ7ThTyôɠJTc1?GDNwL'\]G;RYzȻWsL|+ ADKX]wEǙ>Wܣ}L'A5~Z;'V8NثCHZ 61V;4kg`(r$nVN|>*}v@lq U_)f)q}WnG'z 7LmMQM&Z`]yt>rlW?~ce^-$`<@ϙwy=џ*B 7t"^ia^@Y~1|5r3` !އx@4 N+q^YAo`/B%R J{!~5=4{0v@ހ\.Qꩢ C)%5L=yy{"i)TR @6)^NX )s^knu@Q)e2v%"rq"Tp/*=&JR) EH}%@'6$(nN3/]WWgmy \̝R0F-y'i.Y_fpVКnTS]yS̨1q#XZ[e2㵁 p`Plp|gZ R|D÷l%fcbբ(f0%kzct7IAvoL :8ȓigOe^Q% ',dRhx!֋)/ # 8yx?T4?}D qýAVWy/ OTlV%i jai\:@jUV* eyyݷP}6C^{/rg8oɲu|5ƺ.J1l(ľ]>ۊ=%oN`米y>.\ث- $T Y 9~챾CEYR2-} eyNStVi<^^9iuYQ}R7hRKZcc7#fKM{]7K"W_MG_:Ds9qj릯ݭ~+i |?ň+s4R:{en䪯/< dStFӌ@KMOSQgd!}LQgQ>ߓm:v6h@oc`[s*DCz*: t33dcgΐ/a DXE Yn b~#jJN8L}ƌ|M|mt qn]ᢎ봠3Phib.#e cIDH鞺FUUq CqRCOrCLheyT6nQ~0&ԠT)kcÒ=?]1 iHamrRg [f]0͞_ۑGt[f+c[]h&'aOXc,7sw5|rZG N.̜qC5M6+~.U%:\%i ; [5o \D=0~΃'I+T[]n<vX*pfa$ ORendstream endobj 128 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5670 >> stream xX\֟vvD,0 {!*@A!"V,,,_:HE؉,3QML4Lr~wŗ߃e;ssQc(HN/{tG\}q0U$L##mHW j_F~%x"^&MM,X@W0\hbGevB{Ye2[o젉6gG+G wSenM.`zuP0E췋<`^N>ξ~o/^l;W\f9,ܳfPԛjH͢(gjKP(Kj>ZGS L FʆZBRK(3j)=JbɔBPeLMޠ8R:tj<5HS( {JQ1ZJ]AD+)fLڎq92cu]kݮoxĵONrtIW֌<} U[SL`2d  Fr>3k0&S B-RgYKHnC!(Ba1E/GQ(1T`bFT+QKk~2b0W*tE#j&ņ?x`gQ:)Rʀ=-H[(/Nα6TdFTʟ={FF.%+m~q; wX=o<~`gA? v\΂g v]!`OJC.SOϷ̵0S\]Z[[V#*h!WCh&*X@ibA([lsLC:d%|]VAJK_)-|X?·10gYKڙ[X͛w>akʑBRt\WZz$%#t.iʠ}15 œ]{e)ՂvTS/)G ~)I)\z*J{7ކ,%Vc[Ow}c)MPOPV>qwFzqR?ų?sv2 1 G`y)lx>:ݕW\~Rn(k*7SDRj_6 Q *\l}C  -x" g4 B~T"hз%VǞXMNQ yk!/ _ផ##()=}`<TրÃy_*:MN#$KJ1H{Ae ]PTQT[=s>O#JTj {@O~ ņ9чLc[_fsYT /(Uك VX*J2me6X@ΥT"Fn~$ [ 3;.M>۾>7V(EjW/&gw}i%2]h!KO`ZTC*t}yxܽ> !T JCx38hq 7=w)_!YrO*]!Ԙ҇FXhlP*m D zhRh핱>ё6$QHS<|2kPԻtyjI'vPL FGկԨatz ۵4M ؑ6Xc7rW OQ 2BuHÖa~畢rr-A(:"h.z;>/ΠScvF\O+Dq!iI1d.p^ܥ)~(z  Ύ>JeãZ&ucs#+Q1@9נϰFʁQ( B91nىJ8/k*PAffuVif *Dg|* O܎1luۗ=g9ܷ\ƱMd+_RRCD0lI+Jj]u[9#1gx[KH$a%ՃKIK!'é)WVR6D4n  zxNOa,lba` $);H>6ᚽƓ h->NB njab滿kKΐi$l&O a_ȗ&bP&Ի =%""fH [ۿSB V7pSFW8=JaR㍽` X%W$_ :*&j!$6>eZiωGi!$'FΰIN -,YJ9Ǟ t;i0,aS2}ԌWA}ZAIQrT|zX1\Iȩ5>ӳJQ@|3PBRr/a0`P I:X3ul9GRR aG?K8=/^q6dmu\3^i[3%Eo`ܤbTJ J󾅼Lf ^B{1[Q : 2d+#J&tTgfAaT#LvFȒ+4,# Ej0CըO1#/但*7<'=[MkǹA )|wݾyFӈz ZBG1Y7 iGцQO]߆G*o,Mi%Ȩ8/5HF@}v &+ "“m 2d?tMn )K^t]@=7aܭ$jpE 'B 'Mg](Evh}sc`bkb?=K}Rtjkq/ʜw!X)T?=lVUkw/*eHE =0aT6O8K?ZuMd)%X0>x%Y_7JIGMDMsSL[ZCo[T5|{~p 6\1`'QB`( ouۑᵛcu(ϪS7_»,gET\TB1,֙d60UϷka:">v8&߭mXщ(%fzl)Έ+ͨE('4Pv.>k+={g2?yk(/Dwbd6֟ qqW +/W'F妪&GꩴwDep#e mQ1vT);{pSmAm26#[WSu1yNj_[Lu)=9aB^X+I,34(1 b܃ǏB9MgM VR+d!MMM=*U7 X_VJ %䯩\YiVގ2y\vHQrPk5R"}ŮW/x $b)밥.{_-ۑsx?v8DFeFEF`ہ ڼҶB2)̧xM&Dƹ>0|aE-h 6xҿF=3ݗh4EjDg+BC"96ݟQ'ə³:ICзTOȯ2ݛب_"i*,F}Dp8a+ac〔/Vq&`:h +9#_cTg3=i/ xKgX"<8r ၺFD:V -j2`ٟf=ć^x&rEFcSP{ iqHƩ_lP2 d<8HT#9 㢏*S0W-a(b{$He$lW_κH[+$CDrOf ?\I!9ڿx ֞5%61.ٶXg[Ё0SsANP„0=g*T OMܗąGe##L);v_i*aQ^$ֿr?ɦ4S8eNIW?8>}ƗƠ;>uVXv)8$!+;sbz?߽j'b0R! OhzCos_I`;ڴtt}ܳ%XjwZailU#Whπ'P?=wf=?q&kD1h?m!e퓧H)7u);5N^~T  1(1ޅIbnT8ov@=x[J9k<Ъ3 2HH}Aڟ瞤}8@Ҩ(wR$(2'Pw iKU7#{ 9<4/o@?- Ø!;뿀/\ >,zIϕ+?>BGQy\n IFLPeXcCuEKs |xA9>߀.Q8f6lt)øzT\賯.nP(TR]RRM'GDxpmM8(w{EEQ3 ,W+xRn' T'5ho{բçew<뾳zÙ_r77t G?qn%;}.tKRkܦ[r'7yEt;+ЛRHZXkr*bsBEi.OZ3{J@9yET'͐Rvpk>:9;,_ֽw?=FRi;PXY2D -kql l;F)x~/EU1q8y+/)@UFuQ i  1(;nXA2N}xp{[$D U"̯8<=bvnF&:t. lRTXwCEaZfbc$cL -/,, 6łYʒr"ovm`}yQ~i R^l 3oo.Zw$scnu>Pi+I0ncϏ5B<9,1()7XT͈uxit|b fa/^y%7ѩpJ&LC񜧏{QJ\`忚NiYŬ5b<{]NMQx='a"7l&;Bt]n|s҉ӧ4PCcm+*65>-"YtYdEˏaPOBJ:lwXOvuH횰wjͶJ 6UϒVFW$E$2_뤨 ""kJ8wL & `MQNQtdccy<]̪C9;|Zendstream endobj 129 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 5804 >> stream xX |SU~XW#cEEVKBe޴[%i4I6KtYn"āMQpaԿ2zsMZJS!i.~;; (@0~5q%㒟9}CXDdw$^,OpKi _c`>vӓU(7 HrĨdY3gΞ>\'o1񲤘(q>3Y/#Q>S|Ećmٴqن>+66A/!qyRʔUR= 10f$vsY33o\)OO6}Hj#5 6QOSg j Gm^SۨT0zZNVRٔ?<5ZMͥPk)ʓAT%SF=B)!5 5ERK(wʗZL৆Sz$AҰ'pCwF98rQтѡ?#yz(n쨱q=yz.<Ɩ=,~8ADT"gw{mqvi _EY° X\6C'6H"E/Lb)f?]-dV3|}_`ۥ_983Dzֆ:kObNfLd [/p3?_c;zbǁCIHѷwlzT%}6,%qQDR<3paE6Z=V't948lΏ7^@fπa]UAAH;?ďkt͇-2mjK'9Qb<+N02r|QFg )T\=$'+MD;>h}ȗboVd`n#'=A*f]pO!vF3i Gi}FtX]q3V@CoVo֧t7Uj5XMdnM0;w~f.D(!s"tD\lwwᢌ%4{f]S U tØ>xy9 - )DrrCf_8Rʏ F[ni^#]Aj<|)]6HW[%jꡲoA|oPidtc/rh=Ts sihԽ0$H,)Rt/KQL&OoS `7dsCdᄏHxx l#4rRȝ;!\Ñ笋6$$t$z{nE-sYixw'ƃ8c*b vF'M"G0֘j/G*sX 4˻b7ו wPTdnw~m- 6h+$߹ګW5 m%eK:ʑV*5\8^ͩfXj3Ґ>LfuLcXO*VGmU1+W :/=1,0 ((/%tLD1>$hv7=w ,%(&qRKH CS@dn-"ˠeg̅u_>F 1W!WT'[_ina}a~T>[|r_("t+Mh/tdMXmLq&t4;8}{89O#I\>[U5;]o1"?ۯ]tKG:ϊo X@*8GF^| 8°~ZdY4OvmTQϕߨGp^ݨ| ?@nMyܕ {$gNqx*}2P?DV6w+-ȵ>=Lr>^:@4PRclTǃ/zҵfKw5&Lbwce_LB"1MRlGEnp^8'` qٞn_~E;u͋7?XH,_sw(Wo&)`V@fG:iwI4:%DcK~x,>Ux)޹9. ssmmHoJR J&T=*n#]Omu vH+r5%nCȃF \Y~d́˧:\ރ_mz3ۤ}^zВb?,?cϰo&v8.=Th*ؖŰgBK1;abf5$53#3E,N,P.ةZaP)|= ψSe_ZooobTuΆLˉ߳e: h zC~g-<)Y֜esu,/o_ V p0v#KPHlCEo+>1;й0"MȂ]a2x cUy{WMsE\ RoA~8XkG܆8gz⊻!?4?v=$*ܞDG kH.F HEbet; 9Lޛa㱪_VVmh=#瞽 w[5$C͍ xVk!W 6@/_^xit,]ĪhE| ^i5 M3pZxHq }cVc(?rG\%*PR'K[P~L1} h|:)")x!Ü#_~/rGYY"JSQIj@SI_ݹHIxr?cmh̤} J2h&\AX+'k{9$y%ވ!%VKW,FΠFvcʷFXN$L}l.jQD]z.} g,PՆ7*IXijηJ :.0WC>[,`o 6㵜*[+tg>5)QPiyF REm'D' mW+z3jc`qr.NQ<ܜ_S7v#-sވީFƦ'$" s䠋h\>k3a/ Im/I$(g][yHC(BYAdPFe( jT֬tұIFbz<:EfȰfJ\QP.QdVH;IVXYWQg!O D؉'$|"i,Bx>7]p\^.Դ9*Jd&%ekPdk^CU"*Miԉ~9͆b CD?x=vjv  yR.&Wsvp:T/GTjMasQ}ZdR`ֆ*_,@jXʟ$v\|]i}EdCS5>!T5Q^TI]xR/ 3(].1C{*?X挖+萀Of&M  i3_aHl)M[ Htiا9T/b,@z$xܴ)SA yfbt0TANbe=<:6: LŲkWNaUjIU.u yUC燋 c b%:&1@kQ-?~'Ŧ%lDTxDy4uP#琢p*[gKMHZK?u3ŖE9 -iKd' r.V=j1Y Mfi`١拈ViÝJUYrC}eep ohw~XrK}ǝڙEjUaV.F8ԋVY ަtk9P{,<[jȴ4(JE$cZMN(z CZ$j#;J":HZe42)d?h%DInn!w7UEu>8e>OM-U$SK5p/^8ITV4g+/)+8 twDZS" yWwm1U%\B8RE2<=~mL#:FLA%7$YlHc֣IXsT33ӳ:<7;_L )^GEz׋5dc(9H~J* ?!$ϔķˁ/[l_Ƞԑ!R2֒ )jDŶWCH'a kH$ށ5[39*"pzAnMv@nTa o9WCйAG A~SQ 7^(,<=.8S}ߦk 'JKS meQnj1TX5&˘1'KyX> stream xZKs|MpT>mR1IIcZm PkSJ_FILG gdt}uOGj`26ttquKX,;Rǖ 933\Ԓq'kXbC2$[o$cf2I>ds|b+ 9 ܍$Ȑ[7i|,:/Y[X9cbbiqBA$E\F)|^0 m&d{1/,MPjr]^tAtkLiɼ.2k+$Uf^-4y]gmo2iI3bצ ~s}a|q?<\ ]:q$DؐrQb1$7v)h=˫fW?ӄbwͽ&i:pVUVm |"`Cwu;-YZe~ 0Okv.]/vO_<[v`f0*5lyw)$qPma䳴,g݂EY U&+u(62ˠG#>jOe*vOWyfݦٞNTP1az 3SZmW.fP!,z('C:jGp~/|te:'+I8]d,[(J^aXcT`8a^YC. Ku9nSua= yHuC8퇁Yy-=j+ Hr^ $ex,"k| cI ]4.v"uq78L͈S$}f8k(9=Jk}:*ADq''S`Æ5y#[joӆ Uާ"_d}J&F8#EV_ >a [p\_/ V `"-#gg1暑Ӭ[k:c+F*@'>wx>Sʢ[Q[rG0Q)F.s ӷYֶà@X'Էp98P,:ivsP@< 8Y+-\ם)5w?kS{a)VRр;M-@&yq'Xb ,?8n=_'tRط)YJ^6 bT(yzH?v4Ef(H0ZVv}K.F&gɫ`Y"9 瀞wZsGO.]+tTċ|u?g t T7wsd+?* x^~9n4&sG$t j?P> 1Y2ϳ#h g& 8倷(xw_| uYL)IAm?lB },'w>N"hS4ѽ$k<6P fF]}i'nd(n SꃣT=yBR1WUGڕ#ܢb-xZ CH ȩi&  &Q5`&;Z0RDp`C5<&$0܎Hٳ^X(dV)#!6,_>bzbcg_yYiubk"Qk".xy@fu&R?WC KWo}EhKi[qvj%ކ,{ɲt4NcJ: : n cNpĎh-AnZc8Cxb ^P`K)(Äv3(feHk 5Tm/Z>ZbW%KݚW&VW[ÀEUЂ:H d_Af;TЭf ^AP#(jt^% 3jgq4LzE`"f]^bdC46/49DA\|?}膔:(Lغdr2=~a%En1⼸dKMz{4T!Sd-wDDϱe exKߐ3>t:L]v 'NuqxLDPjQț6` [ځ(&Ś S>:B^D4dzsq|FXȊ^-UV+ 8Uy>(l)f[ufTA ]PbH-nIޏS_%(28ݺ+1A4M[ `Xm>j Hd.|SHzK wv]_wuS/RVEB@F?B&i$oFOb, e,Uӹ|C&۸06/U@;B~Vib#=(RZǭrk֕4 iK5)^wpP,IA%.\ѝjc2&M .Z6/{38b.D3B#Va…>Ma2Rܘٷs1IeP;H:[m%tAmܒ!0{}F ȢčS≜S/*>異ex~پ't$UtE{L9#P̔E)L aî@v^ƼZ9N!c"gӰ*?oQ?J!>%8 ฬ{w3s|ۯŠSmΖ̻񡠐SgL)v\:?Z\MQ4cvOm pVQ(Ћ-pl7WuI77uF Bڏ 'p'~/*ii&mYsG@2Id؝t+v*suy& qmXd{];Žbmv-#P hЖVRAڌ_<բ~?Vi> stream xZK)9a98~,`+#39|tq8^I@fz~U7E]WU]ܮެDxZ^W?}+%TM݈*.3j)R~ь`ڂfu]~]o6^xawuSnoThS~Q?nZ-?K2(۵U] U̘:gz]l[y}o_m_v0N,YoA r Ҷ|_K$xtZ+=-2%w}{ܽm3h..ڗN{Mdj*"Wk 3ZΑԸ9RnxBd5=#)f |0z|ڂ{qHSnymw$=RVɳ6ؖhl^ͬV2 Ҝj~)cgxU~CWȲ듽kU95%\;&Aڨ)bO&s<),́.h6!AyB+oQ=ty\Tr(nhV1wz7P!}9!, ak'K^?HqZ}S(S⬦Rz]~6|Ԃ;HTO:FјghUk TB0勒b㔤bȂ)Iֵ iR X#lHb6zRV⼙)S垬C/B}.ۘ*8!k^Xn!_;Vv!S7"~ r4AhY}d)Hی+vTjM|cJ9-#_L5-W,q]bsTcNA %.nO>Lލ>#\Hb!yc[~?m^S7@ D ]SaG;h;pUr!S,a یOz= `O1¦W o}ЅE1AqDZ'9)Q-sg%iXߜLAE68mϜ>:>B fC B1C]OH!-t ,hrukaWdR񯡨k;1v bs)ZprzHɔ]7p8r6,1o2`-‘+ګ@Ì|!H H,~1VBuɨf U=pg Q7+ 4 *QdoΣ;6h29Uc+D ͯ%86U8ޅm*' #E+8@Z-#djKJ!ɔ\OJ%a)4 P>I3J1Q bVcDם~3;v| (Ą3 Q}BTaJU~we.8W)|rw^Ta/ҏp'SƹASD۔vO-DowG6QJ#Gwdժ;t@#PSl2߫j(7%Os R:VY3UpC9͖f,OVUi uGcru(*;`&<( T99]'|"Uo4,0Fv)p$@hL3,Dpl}ZnZQ mwFw9m12$H\簆k@'u\`GesьsspcK(Fy fq 47 ͘ñ߽56 1e E)Ë5yE=i.+Fxt s{˫m{\2dӜ7 <4zi8@[ASr>@i+' ,y:ӝֻqy68(M+ȌNEo a/60"9XStuRfzBOz;!eL7pnnC^&u<5gv4Fnrm"j> stream xW TTW~EQKz!Mvh\A4d]Y k/(P)b 4b\;F1G.[x2sN:u޻uݍ^V'Ƈ'HҦN#nh7|'Yo aѣx| I MK2Sbb|M2}$=gk>+#'fn OY9yd5bQhh Q,Y6p]{qJQ%,N Z'K/3budTL\viI5ZKARoR*@m6QTL-|)?j5ZIKVSkrrM0mw(Xt^F; ` ymHV3=FơF|pN~K7USI\$R5ARM~XNN-<1"Zkvns-FcpyIuxh*S@խO03Ph4y#N^T8<шV M\ uLi {b \]񃄽PUą⪂"ڈ.?PW<} x5)vH@D-GX=|cAɣ/J?cvF UUF1Tu~4ͦ!~)EwĊVB`!4'C#iÇP)-/]1{,Y3x J:uMV1VQOqx&B< ,HǣdX|4p@CVXfML J aQx⋖k[Y㧫QhUUWE14?;=z;Ix5)m?Ar2dӷ2Q ]DGoYt+@+Yf>W@|V<Pc^h&D똷^„!AI~3nI?#|,k[ڸN=#wy75ރ{^%67$ׇ*ïBe"(HǛl 6-GZ&f'.[ZjdIw=+dru&"@L)JJrI!? ".:?$!ʶh_YZ|x 7ț2vRZccު zBȑk4|v[VA~yؒjY]>՝%Gf&$ujJu<R)6KpZ]i uWUUU>As3PD k:jkEG4R\)J EQA_ 'Sޠ F əxV&Kox_-]]L]r&҉zt=(|y07̰{--&%hApQ⌤'Jp݆rb3[8Zuh""yhuСx-fMP8O:'ږZt!ۊ'+b7mD {W- FMȴS.,EbݐT?$G=8dxu9? o}ht͍(Xb=liKh\̆Z=ZC 4n76GLcTћ˴9qq p 0B'w\޵YĜyq!Al;]h!|uTL4yo#2LiG9}Т"ۥ[zIdtq1\"93fCr]MmGK$Ѹʔo-Iܕl?=ᎊ;CwwCj4K r<$~QX3P Z-=I.b>A:cԐ \UFIU3-1D=ԉ_ iܮ/s(82Ư[kEpIWO[U/U'ΨZ.7gcWm] Sxd:~;@ .M+o%IoӐ}jJd]^& #NCKޚ#7^BuRAاa1`;a-"=^/7c18;l;wDOw@pm hCv^l.ߋ2/b4%6;t,N.hoߠX!aR$k3uY { *HkdvZYZK.j ިcPͲˠjoĔXڞ'OJPB#S5}ʚⒺdIcN <3Zk=j$~D<;g0܀r%/K3!p,cE=+IDh~=CMdvqܻv|ċ+/[ \qPeҨ} eWX{_,Qoo?g@V"}jV6/ZadAtqD 1*ORsVnKsr9xJLՆa<$Ԥ7]= ПG{5 ]"c<`1TA\v> stream xm[HSqg7: -EQUOaM,Ӽ`67i8:ۙgs˔tfN%Qh"'N` T DQTə&⩶:*ng%gTJIe iX:5JU/B( =))=|8u:zAPeeFc0>au.3rbdžF|@'` 0Sou88YR'y @ޘ^ t޻|Br>PxwPnWRErs V>+" 9' ?GD]W-z26պ\! -7ڒV r.LW(Q*^K Xcߋu)tvw}._h:b.YBoC7endstream endobj 134 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 1596 >> stream xTTU0eD QD6'Ef@P(A1bAgDa\BP@PքBȳ'=vl*|?N{3w|=yy_i5ayE%yӜ8kQ72T應ut`̪aiLC> iل嵳V,ψ=;jtca~]yOG_+rϳ[tQWd-6Y)6i&M}o@!ZfߴT_ȌP*zP:ZVHj ȈQ3Z$ -J@LsDjk 4UMֺ`vuñC GP?UUqU^z񓏆K74tIn"ĭސ#1)X,N/ԂzO%\8aG@ɳX. V ݻ=tE@68J*Ք TM#N `!blߥ'&LKa ^VrGŒY 5#w:/S)TꓠI dxůOz&jvMEq8yNE;UgL,F_WT4mi<[gחMºIk+mJos@ jsCwHn}n,msq`[]#7`>R,$z28w}[ˮ݇;ު.ʺN:~)lZ5V_''N pO'j2dMOt ]*c1jp0fDdH{q;RT'Kfq(dxr>P zH0ZW@dkրp$V՞ozVnZlXV/HǑB@ҭCg(ElU/Dq> fiANV!G͎ rg{;vOT$^Wi=a_ c\EË?f.+mksWYcq@p ]ho=#IY,yTLjL-NeWh+T(x* ҙ?DI4dor(Ed osf-a ]ͻkIJF7xF4:^/P&\t*sH% 1y͒gG-2E|?phB p n:ZeE.pW_d\cK3W&b:Yi=X~?ƃlNJnB?nnendstream endobj 135 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 3237 >> stream xVkTǶv"*m LqQPyQ O Hx  HDch |#GAP j""#ʈrԨ9fx敏s]{ך]ӻjo}2FeR S 2 O؊œG2DԺ"9b 21:8t;B8FƲ 6D-]>s,;ܢ\gUR|R3ԪtP.NZLT_o*ass &&%gD.v&e?Ɓ0Lc&Ϙ1"392%3b0 Fe2XƈqcFv:gZ2Qͣڍ&%1[Ƚpn%INB你{kfh|ݣ$$ݤNQ9jC9Ր#ueˉ G˖ GHd&@nP9^z;ܬ˳?t I_x%+bhifJp<9'x2:qi7W)M!qmWf[0_ foöMPRf ?[k2X$xC^A VKerxac aSikZ`[s)0.[YSB2f*Խ }jAƴGZE_+GVN}U[֟?~JlNƶ^5̃i.dzUn=Ttm|k16Vy8̄1 Z{aGNsq-.+\H/֩"}ކwn]!t/e@j&B<戍ރBB>vb^>Y/mz3 OQu~пHkR^.q;9Aݳ915ִ͙CWg#-쏶[:Rp}VS 3_B9 2>]MW**)QwRq<)zr*.[zyC4o[b)J8 R! )d[G7nd 2]oG&a;#.%+Jґe l[a_ltu#L-5'(e2ᕴ?|r,>卵1"^c@0^'Lح\,8 :a_ i4GZn^9|F0Rd4 !>ĄF8L^9"z`Wx nHP]EueO՞`[ B`Dbݣc)՚xBT?2'cڰxq@+":cЩbI]t|Ce3mryJY>geMlBC]?;SXNċY$?D6,&DpN`B݇x?K-H1zȦuCEJaĆW/N(XBySo\({Wl}E6╆,m #-~crZ2ƕX8^|+RKRF]!rO~v*jiޏ%7 _/T՟>Jl9J[8ʬDк|VbXu| RJM=[;a.Bٟo$>w/*xN.PHɓo y{ hwنzs ?so޽rƩygxax^hxSQ3} W(#AtEq? =~a@ *uiR ^"~I,D& dK7l{h7jӸ6ʆcH0zv|Hg͜b!гG+=;=Z]ZEd#%UKfA]dx{udMfW.AеӉ5˿@sQGn{_9tG}-#bULp>qY!Ae~-X ojgelRI4bwjYf!3jaʓǕ⃶?4ܞ:;EJkw@CWaQVJ2CЭp`nZ7xK[ oY tcsxh'<݄~ ؝⑫hD}leHxd==> stream xZr}_H-ؔw2CQ;eLR+rEJd}Ncp"%2@9@svCϻ/7_oZz?x]&;m.6ON*v%gC?hiz3_H)q쟫8cqɈ~ \hn}Eڱ cYӼ9 ncO=^^01^{Ռ?\̾a^jq9N:VV?Xw U/:-UdT/ΰB^f-) =63ι酮=ft/fJ i{e'6-xoi7(IJI!5;{K`zwXn[03e(Ԡ4*Ζs¢KZ_5&ŭdn}B8+.j[?jci>ڎ+ߺJێ"V;,p7%AkH/|U-%$NBg)XZ!(7={MA?^SMtAόJ;YK$($AF`% ^Xiag(3"ᇁmѬQ ۨD&1I%J OrA7w# GJ`h*ՈvjdH#Qap2Sg#AUaDO DDɡ0Bc!!SčTc$ǂ?rP>̝)# `ġ "ʌ>$l9EO$vO I8ԙħXh\kȈgq(yB!W:[NX,iOG 5pʛ\Q0?\`zK D灶b!q%šh%~΁|< JMWbHOTGHK%BGG4b\7D/SVǓ tw8f*ĂF }\R$bK qAAa+PjA9*2(Ԡ[jиA/QOP @r@›Ts"t V;=eg39\hЧ/p0lui)!p;J0d ^@f2(8M ϛXL[ElDaO`&(Ae%3XD EkaK 6ᑜ.K7hld5f囐S2.g3hpPJ:InCfuMi\Jbu4V-now=( DB[NMLJakb9&={[SU0YgPAn_zjZ(Puu ڪTU8iğRQERZ.XJt֑wd@DѧUaI&g*URH9p *T%[ *TA "rKJPPB-.E$^HѹmS*Eč5&5k$8fv% fg.{Z*\^:(?$ޣ4ߧyFD&DM-.·Zh{!eSlOjP{~cP>C͋Vqm_Vo.wM 8kc\' !h.G~R0~,"[-r|\}؍qЄ#MTFendstream endobj 137 0 obj << /Filter /FlateDecode /Length 2705 >> stream xYmPЇ]'JnHFa@`%5%*$˯̾$u|rwvvfyfF?.ӄ.StyXft˯7?c Fj.2Y\n "V\)H?wj&irU񌦚E՚sh!`]*WCYnHc.kby]HOC!kR5H/"uy@f,5}vܖ]״d4ۦUoSߖQ}spkIs+Z3fpf.65k%,@?aW+k8L'^_}FF#7~p99ftї(N`uM ֜ 'E# cVW ƏH~5? Qmi GLlrO^NvkY uϩ։RL)lj.U&:4 eYK%97ДZG"ϣ뇡>" $rv=õ$d,A]& , r(ZeXԣą#d<. B< RaCF\Ο]jEcp("xQpB&!H,@q4v:[UVW"pS澠:L6pa=fZM]b㈹8;b\/x'!Oog5]SC_voNmu:t7~F{Qiďy-b&B_x;ܲALv{ݜ.aQNl=>4/ VXg~/$Sv3~(r P&z0sy<@k_ś}oO^R@<~!p8tJϦ #oB@JT p sgjd{Oc>7딀J&Du?Hxhep7X|%7"6dDL a[Os\ *7 թ яqr%?IG;r9/s>`׫cjH[]:<6ls0(A3i9-OdaAĤN$(J@\/I 0D^NO1|uCSͧ,A'$mvҦM4+ݰ^8љio& "ʹZ3v5W:7iJ 9 @-MvtRKO(y2dS_ĕea0]?0b~Arzyۍ@W"j!" i/idf <(ͮ-N3t 40 inZY|Bl$' R_lIi; `NP$RLLfcjgq/ئax[H^/:jjqlԨo[qsnO 36޳{ge;`dê 7wRc=78tqc`JwJVKόw &3jz1M!IXղ6|NPHf ~p$6L7L8AQsM &A娝*q/>bOfp+`&GNũC΅)D% (^9"Cg?Z`jIE…bɄ˜-fOlt~ NmYpuKNgs}ư1ٵj7Um9OKXw蘼<3MnZ%$CLen )sWl =8e 4%Ro>U\{U>y@/B ΔL49 ~LI.d-OJ+ r!^9A !k]Ms#3tN8GqgC`LJA7qe]Z@Pg&ڀ83*.qZO[|3: Nj׮WKc_'/0liưըN9t=mS;tyH̻\24e7Y*sw-F]dF؍Xt :jz5^/a sfȶ㦉3)LVF'(bo:)6QAbSԴ\eB))K]ɒUzRӶ5.n0|,y!EH%˩,cw;/guXB `i0@6 ;yїsaqIdzPKZ(i}|kfWbȲ)|9e\)OX,?@endstream endobj 138 0 obj << /Filter /FlateDecode /Length 2886 >> stream xZݏS>A/AV~4nӏ)T_'X:$ 흙];+ɗFQ0[Y癜/ff&<u9{kMV啜_9WL^ [dxPTj#ie%^-,y%b)z/,])-.E*qt>'NGݛxNz8*<@J\h8#Qώ :Rog?10dJ*-lX+@X$O*crF(V+<)ƝHJrL-?e"̗Ug,j-N&RCX, AU]@iaG̀fC.9Y;%Y-LjJqXq$Jm^,&8^6]@i #^,"T^QM B2ċo>;BH̍%=jS= ;Ѡ_z"/~fU8vaWz.q|Qn#RO PݮIMhB_j4KW$"S%uљ!C5Cl̓>ZS= gEI,a1@T.G4AC2*VK Ol!b(E~SSI |o1^*xs L52?$9&ʷp-fwy"(E{`.GbQ@ci6ce痶a]Âu?κy -V{ p50EN g،Zel>,ɓH庥 Zb[Zs=dhrFLZ/X?|_N6W KB/eNT M &> +`~ʜfid/&3n8Kysk6I熄5q:,)zAs h:oIGR܏;v(x1V)Y k6>ȲX~ QdȺ.*s|0>W%M^{]"_DFvVB~>\$={8, k:!ϜEIF6>B_z _=mpJ94`jzl R:;Ў:(t"^mo+mo"i2m EҀȪh!ØŌMBP[J-8 *Jލx[.t@1i $_5U sO1!3 =n"6˷ы !|Aaʃ@0E"Rm !_ pߝ ,k'~U? oX%jE#*fXyJBDՄ9,H%$y|2 .FŽq)}ߜCC 9hE%DcӅ]zs.M >QC}9Qݦ=NQzaq<޹h^9e՚ㄻKj/ *]81(Tpw 1mb(~1XV3H&WU1s=JmpzxKe~C+7qCiѢ,F^E.A]܎a߷*qy ֒m)g˒:r#AiQ 1yӘaݢ1J4b|حI϶U > stream xcd`ab`dd M34 JM/I,f!Cܟ^<<,~}_1<9(3=DXWHZ*$U*8)x%&ggg*$(x)34R3sBR#B]܃C50\````KLa`gpbpQq5|?tfũy3|F\ʏb+#Vr|a~ѽduަZݩ]؄i`c??%Jbn/<w>ؽcw}~_.>yrfz*3ж{߼%wo ===\T\}`wgv2V͌ ʛWh9w/ں{nR v؛wq;> stream xU{PTpU加]ӈQDd*FWy#ay",.Xd)SAw!EEh|4>8մZms{If~3QVL&.Dsfgdh8K&ζȡ`D lVqt t2٦՚Ԝ <={*:GKf$%RbU^T5Z)Фvƫ4񪰸ͪPPU@Ȇ^EQWgdFEx/Yϧ})* ©Ujj H9Q ʅIRnrLL'jjuKB~D:ɆIi=R)]kef1j¦cW +*!e^6q.IRSVԞC;lwEjX4vؿ=huz}.ڻ(<5w!kA<0qYfX%V͠nEW3cG5vDhzZy)7 '"q꽍{n(t2Tq05'J.X{94M ;.+i)2MPt|Z]Be KLsj.eB~E7YŐ57m|p_R_yf>SId P 0t4%@3vR*rSJߏ :AZ-TERtBz37x쒜!fa`wH\NZ\KzKũ`,. xkˇ|~}AI̳57ɂboYYr꘮P)9WȬ1S!y`!:0pWm?ts-+6d87ǘO#K%VO)EtIi@gt@gE38t[u6!bxU,:x6,\T* PCXZlJ$؋{XtFE{ vXϖzб⹘S<؛4O ڪ ,Q89sPTfVn-$`%aK\\^1dMJ{NE,\H=Y.v~,"zO x\cq9zZBxSWP^2 F<8RlN€)1rVRA 72܃b q J_!dU7 0Zv}WOj-[8m9:e+8]Fy#~BE(c: ¯ ~+O }#g %vno=7հjﭱd(om\i8HT(k(Wғ::Xѡiy\?Jl(UĎW|%e@et]hXpЖ$'6M__{GﵨslUX 2ƤP)rVoJk(s{`xQ}~ŹS-vc7LDҙ@ȫȮ_UZͪb{uu5CZHWY@ ߰>Ch|aO|DdRÏV 9ؒB>z<3J'رLE-q>! B?xpa'aUY ݗbΙ`-K>N7 ^>UwFn_ 9> stream xcd`ab`dd N+64 JM/I, f!Cß^=<<<,*=3#cxzs~AeQfzF.THTpSJL//THKQS/ f*h)$f$))F(+k꡻ g``` b`0f`bdd ?SUe/>0oaWw[V}GoG~zw#/ KUؾs p+]#`-ýyVT#3z@| НVendstream endobj 142 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 544 >> stream xmKqǿ[u53\_І$L ;N'6mӍ9ܭ\v$*D GEГzWN0fՂ9s] Kma1(59=8w@16cf~8< u*TG|dbddJzS x(ﺰ[fXnW ?T/&_ nz{-B2ٌPjDlYe;bFf&jPЛX%;=? : #DhKE14GK 8_x*î{,Fօ-N.[}C._DnVĺ HH. f\/kk/2 ˭^ln}|+uv'"~vV}CzГ٘vhVPrY|>^dqkD bv-bR pz> izǍ5jkw _|L^}UR_UUUI/endstream endobj 143 0 obj << /Filter /FlateDecode /Length 1885 >> stream xXK_eS3;~v(y@6rRKRڡ%ۇ|3=j 9S]j>Vj߈v|hdzNM󫯕Em3^mGm;anT"}]6^~(E7T׫֚Gc7Vɮ??vV<#i*5R !59c+Uخ-87jmB*vݝYwm>{>﮾vLWձ?<{ZT5Q?5_V~C`_YOݛ5q) &M-uԾCQS2[|QG-"V}wM k?P0fӐiPoٗnné;};0Orc$Մ0w(WkM$f. .K) {\7"MPPwG{DN&(ʣItJJV:>Dzdкl cY:Γ0 TrNFK8Dzv;Zh!Wﺛ2C]oT)`)ڟɬ.R{s:dɑqueδ]&^,cvW(htU3!}!#D5r)%M ߲WrJ~)_{MjB[D# TB[^W*@ _p~*KLSՎE^@Y)1Fۺo'ۈf"_/?4K%G}0ItTߎ#TBA0S)HXe=QRAKMԙ ?RE\e85IQ8d#Eg^L9aІ ZY{D.mcS_ZB$ăºg# *?׸|ZsbmF9ܔEF յe AeId  ;à ? PM۩τprhC9|t܋x90R G\d"ǫʁ}~8-0IG,ECh l:$ cDO=&$4ϟВX H.8boKn'ߴ\t-/*KL4^:\)N WqeWmMfZCG^F/gb{ ;endstream endobj 144 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 377 >> stream xcd`ab`ddM,M)64 JM/I,ɩf!CO<<,^*{ #cx^ms~AeQfzF.THTpSJL//THKQS/ f*h)$f$))F(+kppzQjbIjQjaib(c##K5|9O0;M>SnRgwG7GCSSCĎ?woS{S{wdÔi}֔KIf_]#g3[mywy?͜=_q ?oZȶk3s=g7¾SzL]óori3{{:20endstream endobj 145 0 obj << /Filter /FlateDecode /Length 1447 >> stream xXKD7prjClm{"H ˒7q2$ v;qY!!H3vꫯ]54cs?8݌չ>_f_VlΆ#l^yj:H~JF{6_ț:IiFU ]nIM䌖hX@V%y?BQs :zoT B:G³`1Ħ}KiQQ}.5ۍHrX~ix,ĵ@Eb+t"G,8$ٸno&VXV:`jÖB|^K#W46Io-gT%3a/4,O: 4խHs:ȣouQ`]\A\ms8  6 ɯ`GW gO.> stream x[ێ}7䁏Tb~18 6 g{#zFidK_>nCQG0;ͮ:NQxynaƛ"|nW7?[+Ty^ܼB0Q) m.n7ߜTms%/bZZ|RJtq8+כᇶ'cr.\ŸE+=e. ̚@c3a$_mHg/7?aB+b*i7Y7r3{ 9xLxB)KhwD xFA!Fdqre,.}3R12w+xM: p!~|x>!b5B+JzMV#H*=ašpTX{z3G:@58A\S܃ݱuw*XOZz+q-V{T[ӶoZ !uADw T ȿr] pߗiY0,^IY0tUk,I7$/A IrDAef*cz CTE#KK&eWH{=/2!A^+>ppc  _gg[H"<2{~e|ET-l] VѺB.+`6])'2_w 'i.kY0I d =02@)(8?](RԻذt khH*6= zJNwvGpACh֒DZF@`f-@5Ê}hW]PH J䀢E~K!0Tʅ@T!@ug*?o^?WbIݯ8R_s^)lCJ#'@GhJ*Ox4:%%[IJ o1M`8f1+JiM2+hYAl9P_ @~嫁܁4?%~Dez>(c^ ?"Jҏ_zP^y%kLz ~sE3zU[^gwGt6/y7DnB L4bEA@MfA44VG?[?izj>}YQ8@SD{L:kWLR%ڵǡPy_8Ghr^T( 0rCC9I<x6;׵lk~l6c>x]~^oe^]u=Nڔi>;-v6ז|XzX.[v>L ]2\%$7m\A[n~&_UX|MwK+>:6Qtʖm{OQ z[IheS> nro\~!$e0+3f1<85N",=lFxBeH T*RĿb\Sc@J}87 EFvYp۲""xjy\ *Ӕ3Mgwoo͗ap.J0Cl@,>.7uѳХ?)ZglA@,9P"1{* vctOɇny{&tx.oFLl85F52D)҈ 3p1 Uu9qb0df^1F$Ivw.'cIHm] o0d]|w7ۣ̚deG(yZ):;%MNI&ýrRw}ٓ殟3wiyMN7i\40: ,X·aW;K>#k !e 3ya W.7=LE9{_Fb1–qU@ƾq\$'Kp㹫ﵢm΍i;:{J Pn$|c# HNw'0*6=UZAɶՆ J@uZRho.c_W2(Cu^97Dnqy 3Ck 膏U:.wendstream endobj 147 0 obj << /Filter /FlateDecode /Length 3270 >> stream x[Mo/$d;@.x- oDK\Cye!Xk8z kwv7_gmmf8ǝ57gak,k2Zo~R4ni5_],ڶnNakfr( !xh?}C>(m}hzƋ/s#X;Biǿ͹M1?nf> qVHIm_5ng%Ӣy; YG1Xas`H{G ta}o S .)n ,ĔpaAa{jڮ|]cxzlfVLIrHfV\VY(N+Ej~87vB7@F5+WRGkmug{WYsFvLǜ8LV'"VJcg*KÂ3nSϖnEQ#󳹮тuJ2nW01`5FxS>u }qOUNX1=nww(԰)NIGzoe&cW ތ iG;9ƕ.2xʬ%8RťCm/)Id s"k+PHW#R4& zVL,h[YJCZ]KHa)BDg8oFI-U,=XHj%F,H*Yb<V;:rԻ΄!oOUjY*@k)]7vxKU+8[ýV rV[,,ēor9'k3G?GG~^<{xQJ& =QS ]~^7VP (XsU˥*P2R@WXN>2ygedp_řFudB BGKN&++^gUQdtߐP?%^ZM5EQdQGMpkZeV&]Yh}N2mõ>j"MBJ3`CI eCzrF=dZR;B Pe#?,qkBBAנ+YQq("gtY@>-Fп@bX"9_E yoIAYԛɕVqpnf8DKC8ZdN+1a\ADhg,NExOh.=IxO, }8 h=U:SM,эW h?-HSJq J޽8W\&0׮Hqbю{^\é`8'D;8 y 2zFaJѬrvC72o-]<(KV}ޙhwYq $G2_U)jLT7(9!$ VD{˗uE̚ BߢI_rƥM; .4kkPE Ap^p:xTScZo H)ƢD$[ sYy#}ȫըQZLKgbIb1'{+~1ܯxQ% ? qkYrҩt!kѵл]9 vCUe"d; "5CiG<%J97蔼*5#;A?zfQ݆ `ƧM!;zyʼnjD‘s܉e֓X_Ðq'grCr ,jѬ3*~$P{pϋfX#gS F:Ѡ2]ŘONKEj/҆<_Q\B.r*",ioP&Or*_g ~O Ɲv[$z3zs.E%4R`( 7ʫ̄ ҈iFQ(>].ݖBV݅$ig|;#cJqC>[Tb NdT"6K̕*>:x& %5&8(m4W92\R:/ByC Hd|5( Oa T{ %HTBQ!gJ>W<$39$$}QAOa롿FsrRmy.$<-endstream endobj 148 0 obj << /Filter /FlateDecode /Subtype /Type1C /Length 484 >> stream xcd`ab`dd N+64O,,M f!CgnnC?܅ ~#_PYQ`d`` $-*ˋ3R|ˁ y I9i i ! A Az莂L@?SUe/>0K|o﷾3{i V[Cs/~7b"Dk\~sU> w5.@+J/|_}?,WG g/d;[%$$P>+{z{\^^endstream endobj 149 0 obj << /Filter /FlateDecode /Length 370 >> stream xR=O0+<:H9 U(ZU QJچCNH]P޽=0 _wfx5YYG.82^Q a0PU0/VrP( .GK(Umȡ̣QKNtà8b!8X)s['o}P|C .^cPK9(edC5?H;`g3Z\!c̒sd j'K: }%- %4*$O$qۻjQPQu_W=T*P7ގSfťG[v*Xvщ&dh$Soعmîn|/˜Yi_T!H*7W61G.'endstream endobj 150 0 obj << /Type /XRef /Length 145 /Filter /FlateDecode /DecodeParms << /Columns 5 /Predictor 12 >> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 151 /ID [<3b879c4fd7b7aae3a658133f60da5a4e>] >> stream xcb&F~0 $8J҄oz fK%MЖ mpy "փHz)o"Ax#d<"jrA$3X}:e $njMLdXd9}D~ 6G,n&w3> endstream endobj startxref 86317 %%EOF vcd/inst/doc/residual-shadings.Rnw0000644000175100001440000003714114541404366016701 0ustar hornikusers\documentclass[nojss]{jss} %% need no \usepackage{Sweave} \usepackage{rotating} \newcommand{\given}{\, | \,} \title{Residual-Based Shadings in \pkg{vcd}} \Plaintitle{Residual-Based Shadings in vcd} \author{Achim Zeileis, David Meyer, \textnormal{and} Kurt Hornik\\Wirtschaftsuniversit\"at Wien, Austria} \Plainauthor{Achim Zeileis, David Meyer, Kurt Hornik} \Abstract{ This vignette is a companion paper to \cite{vcd:Zeileis+Meyer+Hornik:2007} which introduces several extensions to residual-based shadings for enhancing mosaic and association plots. The paper introduces (a)~perceptually uniform Hue-Chroma-Luminance (HCL) palettes and (b)~incorporates the result of an associated significance test into the shading. Here, we show how the examples can be easily reproduced using the \pkg{vcd} package. } \Keywords{association plots, conditional inference, contingency tables, HCL colors, HSV colors, mosaic plots} \Address{ Achim Zeileis\\ E-mail: \email{Achim.Zeileis@R-project.org}\\ David Meyer\\ E-mail: \email{David.Meyer@R-project.org}\\ Kurt Hornik\\ E-mail: \email{Kurt.Hornik@R-project.org}\\ } \begin{document} %\VignetteIndexEntry{Residual-Based Shadings in vcd} %\VignetteDepends{vcd,colorspace,MASS,grid,HSAUR3,grid} %\VignetteKeywords{association plots, conditional inference, contingency tables, HCL colors, HSV colors, mosaic plots} %\VignettePackage{vcd} \SweaveOpts{engine=R,eps=FALSE} \section{Introduction} \label{sec:intro} In this vignette, we show how all empirical examples from \cite{vcd:Zeileis+Meyer+Hornik:2007} can be reproduced in \proglang{R}\citep[\mbox{\url{http://www.R-project.org/}}]{vcd:R:2006}, in particular using the package \pkg{vcd} \citep{vcd:Meyer+Zeileis+Hornik:2006}. Additionally, the pakcages \pkg{MASS} \citep[see][]{vcd:Venables+Ripley:2002}, \pkg{grid} \citep[see][]{vcd:Murrell:2002} and \pkg{colorspace} \citep{vcd:Ihaka:2004} are employed. All are automatically loaded together with \pkg{vcd}: <>= library("grid") library("vcd") rseed <- 1071 @ Furthermore, we define a \code{rseed} which will be used as the random seed for making the results of the permutation tests (conditional inference) below exactly reproducible. In the following, we focus on the \proglang{R} code and output---for background information on the methods and the data sets, please consult \cite{vcd:Zeileis+Meyer+Hornik:2007}. \section{Arthritis data} \label{sec:arthritis} First, we take a look at the association of treatment type and improvement in the \code{Arthritis} data. The data set can be loaded and brought into tabular form via: <>= data("Arthritis", package = "vcd") (art <- xtabs(~ Treatment + Improved, data = Arthritis, subset = Sex == "Female")) @ Two basic explorative views of such a 2-way table are mosaic plots and association plots. They can be generated via \code{mosaic()} and \code{assoc()} from \pkg{vcd}, respectively. For technical documentation of these functions, please see \cite{vcd:Meyer+Zeileis+Hornik:2006b}. When no further arguments are supplied as in <>= mosaic(art) assoc(art) @ this yields the plain plots without any color shading, see Figure~\ref{fig:classic}. Both indicate that there are more patients in the treatment group with marked improvement and less without improvement than would be expected under independence---and vice versa in the placebo group. \setkeys{Gin}{width=\textwidth} \begin{figure}[b!] \begin{center} <>= grid.newpage() pushViewport(viewport(layout = grid.layout(1, 2))) pushViewport(viewport(layout.pos.col=1, layout.pos.row=1)) mosaic(art, newpage = FALSE, margins = c(2.5, 4, 2.5, 3)) popViewport() pushViewport(viewport(layout.pos.col=2, layout.pos.row=1)) assoc(art, newpage = FALSE, margins = c(5, 2, 5, 4)) popViewport(2) @ \caption{Classic mosaic and association plot for the arthritis data.} \label{fig:classic} \end{center} \end{figure} For 2-way tables, \cite{vcd:Zeileis+Meyer+Hornik:2007} suggest to extend the shading of \cite{vcd:Friendly:1994} to also visualize the outcome of an independence test---either using the sum of squares of the Pearson residuals as the test statistic or their absolute maximum. Both statistics and their corresponding (approximate) permutation distribution can easily be computed using the function \code{coindep_test()}. Its arguments are a contingency table, a specification of margins used for conditioning (only for conditional independence models), a functional for aggregating the Pearson residuals (or alternatively the raw counts) and the number of permutations that should be drawn. The conditional table needs to be a 2-way table and the default is to compute the maximum statistic (absolute maximum of Pearson residuals). For the Arthritis data, both, the maximum test <>= set.seed(rseed) (art_max <- coindep_test(art, n = 5000)) @ and the sum-of-squares test, indicate a significant departure from independence. <>= ss <- function(x) sum(x^2) set.seed(rseed) coindep_test(art, n = 5000, indepfun = ss) @ Thus, it can be concluded that the treatment is effective and leads to significantly more improvement than the placebo. The classic views from Figure~\ref{fig:classic} and the inference above can also be combined, e.g., using the maximum shading that highlights the cells in an association or mosaic plot when the associated residuals exceed critical values of the maximum test (by default at levels 90\% and 99\%). To compare this shading (using either HSV or HCL colors) with the Friendly shading (using HSV colors), we generate all three versions of the mosaic plot: <>= mosaic(art, gp = shading_Friendly(lty = 1, eps = NULL)) mosaic(art, gp = shading_hsv, gp_args = list( interpolate = art_max$qdist(c(0.9, 0.99)), p.value = art_max$p.value)) set.seed(rseed) mosaic(art, gp = shading_max, gp_args = list(n = 5000)) @ the results are shown in the upper row of Figure~\ref{fig:shadings}. The last plot could hae also been generated analogously to the second plot using \code{shading_hcl()} instead of \code{shading_hsv()}---\code{shading_max()} is simply a wrapper function which performs the inference and then visualizes it based on HCL colors. \section{Piston rings data} \label{sec:arthritis} Instead of bringing out the result of the maximum test in the shading, we could also use a sum-of-squares shading that visualizes the result of the sum-of-squares test. As an illustration, we use the \code{pistonrings} data from the \code{HSAUR3} \citep{vcd:Everitt+Hothorn:2006} package giving the number of piston ring failurs in different legs of different compressors at an industry plant: <>= data("pistonrings", package = "HSAUR3") pistonrings @ \begin{sidewaysfigure}[p] \begin{center} <>= mymar <- c(1.5, 0.5, 0.5, 2.5) grid.newpage() pushViewport(viewport(layout = grid.layout(2, 3))) pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 1)) mosaic(art, margins = mymar, newpage = FALSE, gp = shading_Friendly(lty = 1, eps = NULL)) popViewport() pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 2)) mosaic(art, gp = shading_hsv, margins = mymar, newpage = FALSE, gp_args = list(interpolate = art_max$qdist(c(0.9, 0.99)), p.value = art_max$p.value)) popViewport() pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 3)) set.seed(rseed) mosaic(art, gp = shading_max, margins = mymar, newpage = FALSE, gp_args = list(n = 5000)) popViewport() pushViewport(viewport(layout.pos.row = 2, layout.pos.col = 1)) mosaic(pistonrings, margins = mymar, newpage = FALSE, gp = shading_Friendly(lty = 1, eps = NULL, interpolate = c(1, 1.5))) popViewport() pushViewport(viewport(layout.pos.row = 2, layout.pos.col = 2)) mosaic(pistonrings, gp = shading_hsv, margins = mymar, newpage = FALSE, gp_args = list(p.value = 0.069, interpolate = c(1, 1.5))) popViewport() pushViewport(viewport(layout.pos.row = 2, layout.pos.col = 3)) mosaic(pistonrings, gp = shading_hcl, margins = mymar, newpage = FALSE, gp_args = list(p.value = 0.069, interpolate = c(1, 1.5))) popViewport(2) @ \includegraphics[width=.9\textwidth,keepaspectratio]{residual-shadings-shadings} \caption{Upper row: Mosaic plot for the arthritis data with Friendly shading (left), HSV maximum shading (middle), HCL maximum shading (right). Lower row: Mosaic plot for the piston rings data with fixed user-defined cut offs 1 and 1.5 and Friendly shading (left), HSV sum-of-squares shading (middle), HCL sum-of-squares shading (right).} \label{fig:shadings} \end{center} \end{sidewaysfigure} Although there seems to be some slight association between the leg (especially center and South) and the compressor (especially numbers 1 and 4), there is no significant deviation from independence: <>= set.seed(rseed) coindep_test(pistonrings, n = 5000) set.seed(rseed) (pring_ss <- coindep_test(pistonrings, n = 5000, indepfun = ss)) @ This can also be brought out graphically in a shaded mosaicplot by enhancing the Friendly shading (based on the user-defined cut-offs 1 and 1.5, here) to use a less colorful palette, either based on HSV or HCL colors: <>= mosaic(pistonrings, gp = shading_Friendly(lty = 1, eps = NULL, interpolate = c(1, 1.5))) mosaic(pistonrings, gp = shading_hsv, gp_args = list(p.value = pring_ss$p.value, interpolate = c(1, 1.5))) mosaic(pistonrings, gp = shading_hcl, gp_args = list(p.value = pring_ss$p.value, interpolate = c(1, 1.5))) @ The resulting plots can be found in the lower row of Figure~\ref{fig:shadings}. The default in \code{shading_hcl()} and \code{shading_hsv()} is to use the asymptotical $p$~value, hence we set it explicitely to the permtuation-based $p$~value computed above. \section{Alzheimer and smoking} \label{sec:alzheimer} For illustrating that the same ideas can be employed for visualizing (conditional) independence in multi-way tables, \cite{vcd:Zeileis+Meyer+Hornik:2007} use a 3-way and a 4-way table. The former is taken from a case-control study of smoking and {A}lzheimer's disease (stratified by gender). The data set is available in \proglang{R} in the package \pkg{coin} \cite{vcd:Hothorn+Hornik+VanDeWiel:2006}. <>= data("alzheimer", package = "coin") alz <- xtabs(~ smoking + disease + gender, data = alzheimer) alz @ \begin{figure}[b!] \begin{center} <>= set.seed(rseed) cotabplot(~ smoking + disease | gender, data = alz, panel = cotab_coindep, panel_args = list(n = 5000)) @ \caption{Conditional mosaic plot with double maximum shading for conditional independence of smoking and disease given gender.} \label{fig:alz} \end{center} \end{figure} To assess whether smoking behaviour and disease status are conditionally independent given gender, \cite{vcd:Zeileis+Meyer+Hornik:2007} use three different types of test statistics: double maximum (maximum of maximum statistics in the two strata), maximum sum of squares (maximum of sum-of-squares statistics), and sum of squares (sum of sum-of-squares statistics). All three can be computed and assessed via permutation methods using the function \code{coindep_test()}: <>= set.seed(rseed) coindep_test(alz, 3, n = 5000) set.seed(rseed) coindep_test(alz, 3, n = 5000, indepfun = ss) set.seed(rseed) coindep_test(alz, 3, n = 5000, indepfun = ss, aggfun = sum) @ The conditional mosaic plot in Figure~\ref{fig:alz} shows clearly that the association of smoking and disease is present only in the group of male patients. The double maximum shading employed allows for identification of the male heavy smokers as the cells `responsible' for the dependence: other dementias are more frequent and Alzheimer's disease less frequent in this group than expected under independence. Interestingly, there seems to be another large residual for the light smoker group ($<$10 cigarettes) and Alzheimer's disease---however, this is only significant at 10\% and not at the 1\% level as the other two cells. <>= <> @ \section{Corporal punishment of children} As a 4-way example, data from a study of the Gallup Institute in Denmark in 1979 about the attitude of a random sample of 1,456 persons towards corporal punishment of children is used. The contingency table comprises four margins: memory of punishments as a child (yes/no), attitude as a binary variable (approval of ``moderate'' punishment or ``no'' approval), highest level of education (elementary/secondary/high), and age group (15--24, 25--39, $\ge$40 years). <>= data("Punishment", package = "vcd") pun <- xtabs(Freq ~ memory + attitude + age + education, data = Punishment) ftable(pun, row.vars = c("age", "education", "memory")) @ It is of interest whether there is an association between memories of corporal punishments as a child and attitude towards punishment of children as an adult, controlling for age and education. All three test statistics already used above confirm that memories and attitude are conditionally associated: \setkeys{Gin}{width=\textwidth} \begin{figure}[t!] \begin{center} <>= set.seed(rseed) cotabplot(~ memory + attitude | age + education, data = pun, panel = cotab_coindep, n = 5000, type = "assoc", test = "maxchisq", interpolate = 1:2) @ \caption{Conditional association plot with maximum sum-of-squares shading for conditional independence of memory and attitude given age and education.} \label{fig:pun} \end{center} \end{figure} \setkeys{Gin}{width=\textwidth} \begin{figure}[t!] \begin{center} <>= set.seed(rseed) cotabplot(~ memory + attitude | age + education, data = pun, panel = cotab_coindep, n = 5000, type = "mosaic", test = "maxchisq", interpolate = 1:2) @ \caption{Conditional mosaic plot with maximum sum-of-squares shading for conditional independence of memory and attitude given age and education.} \label{fig:pun2} \end{center} \end{figure} <>= set.seed(rseed) coindep_test(pun, 3:4, n = 5000) set.seed(rseed) coindep_test(pun, 3:4, n = 5000, indepfun = ss) set.seed(rseed) coindep_test(pun, 3:4, n = 5000, indepfun = ss, aggfun = sum) @ Graphically, this dependence can be brought out using conditional association or mosaic plots as shown in Figure~\ref{fig:pun} and \ref{fig:pun2}, respectively. Both reveal an association between memories and attitude for the lowest education group (first column) and highest age group (last row): experienced violence seems to engender violence again as there are less adults that disapprove punishment in the group with memories of punishments than expected under independence. For the remaining four age-education groups, there seems to be no association: all residuals of the conditional independence model are very close to zero in these cells. The figures employ the maximum sum-of-squares shading with user-defined cut offs 1 and 2, chosen to be within the range of the residuals. The full-color palette is used only for those strata associated with a sum-of-squares statistic significant at (overall) 5\% level, the reduced-color palette is used otherwise. This highlights that the dependence pattern is significant only for the middle and high age group in the low education column. The other panels in the first column and last row also show a similar dependence pattern, however, it is not significant at 5\% level and hence graphically down-weighted by using reduced color. <>= <> @ <>= <> @ \bibliography{vcd} \end{document} vcd/inst/doc/strucplot.Rnw0000644000175100001440000031200314543516402015320 0ustar hornikusers\documentclass[nojss]{jss} %% need no \usepackage{Sweave} %% omit thumbpdf at the moment due to problems on some systems %% \usepackage{thumbpdf} %% almost as usual \author{David Meyer, Achim Zeileis, \textnormal{and} Kurt Hornik\\Wirtschaftsuniversit\"at Wien, Austria} \title{The Strucplot Framework:\\ Visualizing Multi-way Contingency Tables with \pkg{vcd}} %% for pretty printing and a nice hypersummary also set: \Plainauthor{David Meyer, Achim Zeileis, Kurt Hornik} %% comma-separated \Shorttitle{The Strucplot Framework} %% a short title (if necessary) \Plaintitle{The Strucplot Framework: Visualizing Multi-way Contingency Tables with vcd} %% an abstract and keywords \Abstract{ This paper has been published in the Journal of Statistical Software \citep{vcd:Meyer+Zeileis+Hornik:2006b} and describes the ``strucplot'' framework for the visualization of multi-way contingency tables. Strucplot displays include hierarchical conditional plots such as mosaic, association, and sieve plots, and can be combined into more complex, specialized plots for visualizing conditional independence, GLMs, and the results of independence tests. The framework's modular design allows flexible customization of the plots' graphical appearance, including shading, labeling, spacing, and legend, by means of ``graphical appearance control'' functions. The framework is provided by the \proglang{R} package \pkg{vcd}. } \Keywords{contingency tables, mosaic plots, association plots, sieve plots, categorical data, independence, conditional independence, HSV, HCL, residual-based shading, \pkg{grid}, \proglang{R}} \Plainkeywords{contingency tables, mosaic plots, association plots, sieve plots, categorical data, independence, conditional independence, HSV, HCL, residual-based shading, grid, R} \Address{ David Meyer\\ E-mail: \email{David.Meyer@R-project.org}\\ Achim Zeileis\\ E-mail: \email{Achim.Zeileis@R-project.org}\\ Kurt Hornik\\ E-mail: \email{Kurt.Hornik@R-project.org}\\ } \SweaveOpts{engine=R,eps=TRUE,height=6,width=7,results=hide,fig=FALSE,echo=TRUE,eps=FALSE} \setkeys{Gin}{width=0.7\textwidth} %\VignetteIndexEntry{The Strucplot Framework: Visualizing Multi-way Contingency Tables with vcd} %\VignetteDepends{vcd,grid} %\VignetteKeywords{contingency tables, mosaic plots, association plots, sieve plots, categorical data, independence, conditional independence, HSV, HCL, residual-based shading, grid, R} %\VignettePackage{vcd} <>= set.seed(1071) library(grid) library(vcd) data(Titanic) data(HairEyeColor) data(PreSex) data(Arthritis) art <- xtabs(~Treatment + Improved, data = Arthritis) @ \newcommand{\var}[1]{\textit{\texttt{#1}}} \newcommand{\data}[1]{\texttt{#1}} \newcommand{\class}[1]{\textsf{#1}} %% \code without `-' ligatures \def\nohyphenation{\hyphenchar\font=-1 \aftergroup\restorehyphenation} \def\restorehyphenation{\hyphenchar\font=`-} {\catcode`\-=\active% \global\def\code{\bgroup% \catcode`\-=\active \let-\codedash% \Rd@code}} \def\codedash{-\discretionary{}{}{}} \def\Rd@code#1{\texttt{\nohyphenation#1}\egroup} \newcommand{\codefun}[1]{\code{#1()}} %% end of declarations %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \begin{document} %% include your article here, just as usual %% Note that you should use the \pkg{}, \proglang{} and \code{} commands. \section[Introduction]{Introduction} %% Note: If there is markup in \(sub)section, then it has to be escape as above. In order to explain multi-dimensional categorical data, statisticians typically look for (conditional) independence structures. Whether the task is purely exploratory or model-based, techniques such as mosaic and association plots offer good support for visualization. Both visualize aspects of (possibly higher-dimensional) contingency tables, with several extensions introduced over the last two decades, and implementations available in many statistical environments. A \emph{mosaic plot} \citep{vcd:Hartigan+Kleiner:1984} is basically an area-proportional visualization of (typically, observed) frequencies, composed of tiles (corresponding to the cells) created by recursive vertical and horizontal splits of a rectangle. Thus, the area of each tile is proportional to the corresponding cell entry \emph{given} the dimensions of previous splits. An \emph{association plot} \citep{vcd:Cohen:1980} visualizes the standardized deviations of observed frequencies from those expected under a certain independence hypothesis. Each cell is represented by a rectangle that has (signed) height proportional to the residual and width proportional to the square root of the expected counts, so that the area of the box is proportional to the difference in observed and expected frequencies. Extensions to these techniques have mainly focused on the following aspects. \begin{enumerate} \item Varying the shape of bar plots and mosaic displays to yield, e.g., double-decker plots \citep{vcd:hofmann:2001}, spine plots, or spinograms \citep{vcd:hofmann+theus}. \item Using residual-based shadings to visualize log-linear models \citep{vcd:Friendly:1994,vcd:Friendly:2000} and significance of statistical tests \citep{vcd:Meyer+Zeileis+Hornik:2003,vcd:Zeileis+Meyer+Hornik:2007}. \item Using pairs plots and trellis-like layouts for marginal, conditional and partial views \citep{vcd:Friendly:1999}. \item Adding direct user interaction, allowing quick exploration and modification of the visualized models \citep{vcd:Unwin+Hawkins+Hofmann:1996,vcd:Theus:2003}. \item Providing a modular and flexible implementation to easily allow user extensions \citep{vcd:Meyer+Zeileis+Hornik:2003,vcd:Meyer+Zeileis+Hornik:2006b}. \end{enumerate} \noindent Current implementations of mosaic displays can be found, e.g., for \proglang{SAS} \citep{vcd:SAS:2005}, \pkg{ViSta} \citep{vcd:young:1996}, \pkg{MANET} \citep{vcd:Unwin+Hawkins+Hofmann:1996}, \pkg{Mondrian} \citep{vcd:Theus:2003}, \proglang{R} \citep{vcd:R:2006}, and \proglang{S-PLUS} \citep{vcd:SPLUS:2005}. For \proglang{R}, currently three implementations do exist in the packages \pkg{graphics} (in base \proglang{R}), \pkg{vcd} \citep{vcd:Meyer+Zeileis+Hornik:2006b}, and \pkg{iplots} \citep{vcd:urbanek+wichtrey:2006}, respectively. Table \ref{tab:compare} gives an overview of the available functionality in these systems. Most environments are available on Windows, MacOS, and Linux/Unix variants, except \pkg{MANET} which is only available for the Macinthosh platforms. \begin{table}[h] \centering \begin{tabular}{|l|c|c|c|c|c|c|c|c|c|} \hline & & &\multicolumn{3}{c|}{} & & &\\ & \proglang{SAS} & \proglang{S-PLUS} &\multicolumn{3}{c|}{\proglang{R}} & \pkg{ViSta} & \pkg{MANET} & \pkg{Mondrian}\\ & & &\pkg{base}&\pkg{vcd} &\pkg{iplots}& & &\\\hline Basic functionality & $\times$ & $\times$ & $\times$ &$\times$ &$\times$ & $\times$ & $\times$& $\times$\\ Shape & & & &$\times$ && $\times$ & $\times$&\\ Res.-based shadings & $\times$ & & $\times$ & $\times$ & ($\times$) & &($\times$)& ($\times$)\\ Highlighting & & & &$\times$ &$\times$ & $\times$ & $\times$& $\times$\\ Conditional views & $\times$ & & &$\times$ & & $\times$ & $\times$&\\ Interaction & & & & &$\times$ & $\times$ & $\times$& $\times$\\ Linking & & & & &$\times$ & $\times$ & $\times$& $\times$\\ Extensible design & & & &$\times$ & & & &\\ Language & \proglang{SAS} & \proglang{S} & \proglang{R} & \proglang{R} & \proglang{R}/\proglang{Java} & \proglang{XLisp} & \proglang{C++} & \proglang{Java}\\ \hline \end{tabular} \caption{Comparison of current software environments.} \label{tab:compare} \end{table} Figures \ref{fig:arthritis} to \ref{fig:titanic} illustrate some of these extensions. Figure~\ref{fig:arthritis} shows the results from a double-blind clinical trial investigating a new treatment for rheumatoid arthritis, using an extended mosaic plot with residual-based shading based on the maximum statistic: clearly, the new treatment is effective. The dark blue cell indicates that the rate of treated patients showing marked improvement is significant at the 1\% level. Figure \ref{fig:ucbadmissions} visualizes the well-known UCB admissions data by means of a conditional association plot. The panels show the residuals from a conditional independence model (independence of gender and admission, given department), stratified by department. Clearly, the situation in department A (more women/less men accepted than would be expected under the null hypothesis) causes the rejection of the hypothesis of conditional independence. Figure~\ref{fig:presex} illustrates the conditional independence of premarital and extramarital sex, given gender and marital status. The $\chi^2$ test of independence, based on the permutation distribution, rejects the null hypothesis: possibly, because the tendency of people to have extramarital sex when they had premarital sex is particularly marked among married people? The rate of such women and men ist significant at the 0.01 and 0.1 level, respectively. Finally, Figure~\ref{fig:titanic} visualizes the ``Survival on the Titanic'' data using a double-decker plot. Here, a binary response (survival of the disaster) is to be explained by other factors (class, gender, and age). The gray boxes represent the proportion of survived passengers in a particular stratum. The proportions of saved women and children are indeed higher than those of men, but they clearly decrease from the 1st to the 3rd class. In addition, the proportion of saved men in the 1st class is higher than in the others. \setkeys{Gin}{width=0.7\textwidth} \begin{figure}[p] \begin{center} <>= mosaic(art, gp = shading_max, split_vertical = TRUE) @ \caption{Mosaic plot for the \data{Arthritis} data.} \label{fig:arthritis} \end{center} \end{figure} \setkeys{Gin}{width=\textwidth} \begin{figure}[p] \begin{center} <>= cotabplot(UCBAdmissions, panel = cotab_coindep, shade = TRUE, legend = FALSE, type = "assoc") @ \caption{Conditional association plot for the \data{UCBAdmissions} data.} \label{fig:ucbadmissions} \end{center} \end{figure} \setkeys{Gin}{width=0.7\textwidth} \begin{figure}[p] \begin{center} <>= presextest <- coindep_test(PreSex, margin = c(1,4), indepfun = function(x) sum(x^2), n = 5000) mosaic(PreSex, condvars = c(1, 4), shade = TRUE, gp_args = list(p.value = presextest$p.value)) @ \caption{Mosaic plot for the \data{PreSex} data.} \label{fig:presex} \end{center} \end{figure} \setkeys{Gin}{width=0.8\textwidth} \begin{figure}[p] \begin{center} <>= doubledecker(Survived ~ ., data = Titanic, labeling_args = list(set_varnames = c(Sex = "Gender"))) @ \caption{Double-decker plot for the \data{Titanic} data.} \label{fig:titanic} \end{center} \end{figure} This paper describes the strucplot framework provided by the \pkg{vcd} package for the \proglang{R} environment for statistical computing and graphics, available from the Comprehensive \proglang{R} Archive Network (\url{http://CRAN.R-project.org/}). The framework integrates displays such as mosaic, association, and sieve plots by their unifying property of being flat representations of contingency tables. These basic plots, as well as specialized displays for conditional independence, can be used both for exploratory visualization and model-based analysis. Exploratory techniques include specialized displays for the bivariate case, as well as pairs and trellis-type displays for higher-dimensional tables. Model-based tools include methods suitable for the visualization of conditional independence tests (including permutation tests), as well as for the visualization of particular GLMs (logistic regression, log-linear models). Additionally, two of the framework's further strengths are its flexibility and extensibility: graphical appearance aspects such as shading, labeling, and spacing are modularized by means of ``\underline{\vphantom{g}gr}aphical \underline{\vphantom{g}ap}pearance \underline{\vphantom{g}con}trol'' (\emph{grapcon}) functions, allowing fine-granular customization and user-level extensions. The remainder of the paper is organized as follows. In Section \ref{sec:strucplot}, we give an overview of the strucplot framework, describing the hierarchy of the main components and the basic functionality. In Section \ref{sec:shading}, we demonstrate how (residual-based) shadings support the visualization of log-linear models and the results of independence tests. Also, we explain step-by-step how the concepts of generating and grapcon functions can be combined to provide a flexible customization of complex graphical displays as created by the strucplot framework. Sections \ref{sec:labeling} and \ref{sec:spacing} discuss in detail the labeling and spacing features, respectively. Section \ref{sec:example} exemplifies the framework in the analysis of a four-way data set. Section \ref{sec:conclusion} concludes the work. \section[The strucplot framework]{The strucplot framework} \label{sec:strucplot} The strucplot framework in the \proglang{R} package \pkg{vcd}, used for visualizing multi-way contingency tables, integrates techniques such as mosaic displays, association plots, and sieve plots. The main idea is to visualize the tables' cells arranged in rectangular form. For multi-way tables, the variables are nested into rows and columns using recursive conditional splits, given the margins. The result is a ``flat'' representation that can be visualized in ways similar to a two-dimensional table. This principle defines a class of conditional displays which allows for granular control of graphical appearance aspects, including: \begin{itemize} \item the content of the tiles \item the split direction for each dimension \item the graphical parameters of the tiles' content \item the spacing between the tiles \item the labeling of the tiles \end{itemize} The strucplot framework is highly modularized: Figure~\ref{fig:struc} shows the hierarchical relationship between the various components. On the lowest level, there are several groups of workhorse and parameter functions that directly or indirectly influence the final appearance of the plot (see Table \ref{tab:grapcons} for an overview). These are examples of grapcon functions. They are created by generating functions (\emph{grapcon generators}), allowing flexible parameterization and extensibility (Figure~\ref{fig:struc} only shows the generators). The generator names follow the naming convention \code{\textit{group\_foo}()}, where \code{\textit{group}} reflects the group the generators belong to (strucplot core, labeling, legend, shading, or spacing). The workhorse functions (created by \code{struc\_\textit{foo}()}, \code{labeling\_\textit{foo}()}, and \code{legend\_\textit{foo}()}) directly produce graphical output (i.e., ``add ink to the canvas''), whereas the parameter functions (created by \code{spacing\_\textit{foo}()} and \code{shading\_\textit{foo}()}) compute graphical parameters used by the others. The grapcon functions returned by \code{struc\_\textit{foo}()} implement the core functionality, creating the tiles and their content. On the second level of the framework, a suitable combination of the low-level grapcon functions (or, alternatively, corresponding generating functions) is passed as ``hyperparameters'' to \codefun{strucplot}. This central function sets up the graphical layout using grid viewports (see Figure~\ref{fig:layout}), and coordinates the specified core, labeling, shading, and spacing functions to produce the plot. On the third level, we provide several convenience functions such as \codefun{mosaic}, \codefun{sieve}, \codefun{assoc}, and \codefun{doubledecker} which interface \codefun{strucplot} through sensible parameter defaults and support for model formulae. Finally, on the fourth level, there are ``related'' \pkg{vcd} functions (such as \codefun{cotabplot} and the \codefun{pairs} methods for table objects) arranging collections of plots of the strucplot framework into more complex displays (e.g., by means of panel functions). \begin{table} \begin{tabular}{|l|l|l|} \hline \textbf{Group} & \textbf{Grapcon generator} & \textbf{Description}\\\hline strucplot & \codefun{struc\_assoc} & core function for association plots\\ core & \codefun{struc\_mosaic} & core function for mosaic plots\\ & \codefun{struc\_sieve} & core function for sieve plots\\\hline\hline labeling & \codefun{labeling\_border} & border labels\\ & \codefun{labeling\_cboxed} & centered labels with boxes, all labels clipped,\\ && and on top and left border\\ & \codefun{labeling\_cells} & cell labels\\ & \codefun{labeling\_conditional} & border labels for conditioning variables\\ && and cell labels for conditioned variables\\ & \codefun{labeling\_doubledecker} & draws labels for doubledecker plot\\ & \codefun{labeling\_lboxed} & left-aligned labels with boxes\\ & \codefun{labeling\_left} & left-aligned border labels\\ & \codefun{labeling\_left2} & left-aligned border labels, all labels on top and left border\\ & \codefun{labeling\_list} & draws a list of labels under the plot\\\hline\hline shading & \codefun{shading\_binary} & visualizes the sign of the residuals\\ & \codefun{shading\_Friendly} & implements Friendly shading (based on HSV colors)\\ & \codefun{shading\_hcl} & shading based on HCL colors\\ & \codefun{shading\_hsv} & shading based on HSV colors\\ & \codefun{shading\_max} & shading visualizing the maximum test statistic\\ && (based on HCL colors)\\ & \codefun{shading\_sieve} & implements Friendly shading customized for sieve plots\\ && (based on HCL colors)\\\hline\hline spacing & \codefun{spacing\_conditional} & increasing spacing for conditioning variables,\\&& equal spacing for conditioned variables\\ & \codefun{spacing\_dimequal} & equal spacing for each dimension\\ & \codefun{spacing\_equal} & equal spacing for all dimensions\\ & \codefun{spacing\_highlighting} & increasing spacing, last dimension set to zero\\ & \codefun{spacing\_increase} & increasing spacing\\\hline\hline legend & \codefun{legend\_fixed} & creates a fixed number of bins (similar to \codefun{mosaicplot})\\ & \codefun{legend\_resbased} & suitable for an arbitrary number of bins\\&& (also for continuous shadings)\\\hline \end{tabular} \caption{Available grapcon generators in the strucplot framework} \label{tab:grapcons} \end{table} \begin{figure}[h] \begin{center} \includegraphics[width=0.8\textwidth]{struc} \caption{Components of the strucplot framework.} \label{fig:struc} \end{center} \end{figure} \setkeys{Gin}{width=0.6\textwidth} \begin{figure}[h] \begin{center} <>= pushViewport(vcd:::vcdViewport(legend = T, mar =4)) seekViewport("main") grid.rect(gp = gpar(lwd = 3)) grid.text("main", gp = gpar(fontsize = 20)) seekViewport("sub") grid.rect(gp = gpar(lwd = 3)) grid.text("sub", gp = gpar(fontsize = 20)) seekViewport("plot") grid.rect(gp = gpar(lwd = 3)) grid.text("plot", gp = gpar(fontsize = 20)) seekViewport("legend") grid.text("legend", rot = 90, gp = gpar(fontsize = 20)) grid.rect(gp = gpar(lwd = 3)) seekViewport("legend_sub") grid.rect(gp = gpar(lwd = 3)) grid.text("[F]", gp = gpar(fontsize = 20)) seekViewport("legend_top") grid.rect(gp = gpar(lwd = 3)) grid.text("[E]", gp = gpar(fontsize = 20)) seekViewport("margin_top") grid.rect(gp = gpar(lwd = 3)) grid.text("margin_top", gp = gpar(fontsize = 20)) seekViewport("margin_bottom") grid.rect(gp = gpar(lwd = 3)) grid.text("margin_bottom", gp = gpar(fontsize = 20)) seekViewport("margin_right") grid.rect(gp = gpar(lwd = 3)) grid.text("margin_right", rot = 90, gp = gpar(fontsize = 20)) seekViewport("margin_left") grid.rect(gp = gpar(lwd = 3)) grid.text("margin_left", rot = 90, gp = gpar(fontsize = 20)) seekViewport("corner_top_left") grid.rect(gp = gpar(lwd = 3)) grid.text("[A]", gp = gpar(fontsize = 20)) seekViewport("corner_top_right") grid.rect(gp = gpar(lwd = 3)) grid.text("[B]", gp = gpar(fontsize = 20)) seekViewport("corner_bottom_left") grid.rect(gp = gpar(lwd = 3)) grid.text("[C]", gp = gpar(fontsize = 20)) seekViewport("corner_bottom_right") grid.rect(gp = gpar(lwd = 3)) grid.text("[D]", gp = gpar(fontsize = 20)) @ \caption{Viewport layout for strucplot displays with their names. [A] = ``corner\_top\_left'', [B] = ``corner\_top\_right'', [C] = ``corner\_bottom\_left'', [D] = ``corner\_bottom\_right'', [E] = ``legend\_top'', [F] = ``legend\_sub''.} \label{fig:layout} \end{center} \end{figure} \setkeys{Gin}{width=0.7\textwidth} \subsection{Mosaic, association, and sieve plots} As an example, consider the \data{HairEyeColor} data containing two polytomous variables (hair and eye color), as well as one (artificial) dichotomous gender variable (\code{Sex}). The ``flattened'' contingency table can be obtained using the \codefun{structable} function (quite similar to \codefun{ftable} in base \proglang{R}, but allowing the specification of split directions): <>= (HEC <- structable(Eye ~ Sex + Hair, data = HairEyeColor)) @ Let us first visualize the contingency table by means of a mosaic plot. % \citep{vcd:Hartigan+Kleiner:1984} which is basically % an area-proportional visualization of (typically, observed) frequencies, composed % of tiles (corresponding to the cells) created by recursive % vertical and horizontal splits of a square. Thus, the area of each tile % is proportional to the corresponding cell entry \emph{given} the % dimensions of previous splits. The effect of <>= mosaic(HEC) @ \noindent equivalent to <>= mosaic(~ Sex + Eye + Hair, data = HairEyeColor) @ %\setkeys{Gin}{width=0.75\textwidth} \begin{figure}[p] \begin{center} <>= <> @ \caption{Mosaic plot for the \data{HairEyeColor} data.} \label{fig:observed} \end{center} \end{figure} \noindent depicts the observed frequencies of the \code{HairEyeColor} data. If there are zero entries, tiles have zero area and are, additionally, marked by small bullets (see, e.g, Figure~\ref{fig:titanic}). By default, these cells are not split further. The bullets help distinguishing very small cells from zero entries, and are particularly useful when color shadings come into play (see the example using the \data{Bundesliga} data in Section \ref{sec:overview}). Note that in contrast to, e.g., \codefun{mosaicplot} in base \proglang{R}, the default split direction and level ordering in all strucplot displays correspond to the textual representation produced by the print methods. It is also possible to visualize the expected values instead of the observed values (see Figure~\ref{fig:expected}): <>= mosaic(HEC, type = "expected") @ \begin{figure}[p] \begin{center} <>= <> @ \caption{Mosaic plot for the \data{HairEyeColor} data (expected values).} \label{fig:expected} \end{center} \end{figure} %\setkeys{Gin}{width=0.7\textwidth} \noindent In order to compare observed and expected values, a sieve plot \citep{vcd:riedwyl+schuepbach:1994} could be used (see Figure~\ref{fig:sieve}): <>= sieve(~ Sex + Eye + Hair, data = HEC, spacing = spacing_dimequal(c(2,0,0))) @ \begin{figure}[h] \begin{center} <>= <> @ \caption{Sieve plot for the \data{HairEyeColor} data visualizing simultaneously observed and expected values.} \label{fig:sieve} \end{center} \end{figure} \noindent where \code{spacing\_dimequal} is used to set the spacing of the second and third dimension to zero. Alternatively, we can directly inspect the residuals. The Pearson residuals (standardized deviations of observed from expected values) are conveniently visualized using association plots \citep{vcd:Cohen:1980}. In contrast to \codefun{assocplot} in base \proglang{R}, \pkg{vcd}'s \codefun{assoc} function scales to more than two variables (see Figure~\ref{fig:residuals}): <>= assoc(HEC, compress = FALSE) @ \begin{figure}[p] \begin{center} <>= <> @ \caption{Association plot for the \data{HairEyeColor} data.} \label{fig:residuals} \end{center} \end{figure} \noindent where the \code{compress} argument keeps distances between tiles equal. For both mosaic plots and association plots, the splitting of the tiles can be controlled using the \code{split\_vertical} argument. The default is to alternate splits starting with a horizontal one (see Figure~\ref{fig:split}): <>= options(width=60) @ <>= mosaic(HEC, split_vertical = c(TRUE, FALSE, TRUE), labeling_args = list(abbreviate_labs = c(Eye = 3))) @ <>= options(width=70) @ \begin{figure}[p] \begin{center} <>= <> @ \caption{Mosaic plot for the \data{HairEyeColor} data---alternative splitting.} \label{fig:split} \end{center} \end{figure} \noindent (Note that \code{HEC}, a \class{structable} object, already includes a splitting information which simply gets overloaded in this example.) For compatibility with \codefun{mosaicplot} in base \proglang{R}, the \codefun{mosaic} function also allows the use of a \code{direction} argument taking a vector of \code{"h"} and \code{"v"} characters: <>= mosaic(HEC, direction = c("v","h","v")) @ By a suitable combination of splitting, spacing, and labeling settings, the functions provided by the strucplot framework can be customized in a quite flexible way. For example, the default method for \codefun{doubledecker} is simply a wrapper for \codefun{strucplot}, setting the right defaults. Most default settings such as colors, spacing, and labeling are specified via the parameters and passed through to \codefun{strucplot}. The additional code just handles the dependent variable information, and in particular permutes the table to have the dependent variable as the last dimension as required for the doubledecker plot. Figure~\ref{fig:titanic} shows a doubledecker plot of the \data{Titanic} data, explaining the probability of survival (``survived'') by age, given sex, given class. It is created by: <>= doubledecker(Titanic) @ \noindent equivalent to: <>= doubledecker(Survived ~ Class + Sex + Age, data = Titanic) @ \subsection{Conditional and partial views} So far, we have visualized either full or collapsed tables, as suggested by the analysis task at hand. Subtables can be selected in a similar way as for objects of class \class{table} using indexing. Note, however, that subsetting of \class{structable} objects is more restrictive because of their inherent conditional structure. Since the variables on both the row and the columns side are nested, subsetting is only possible ``outside-in'', that is, indexing operates on blocks defined by the variable levels. In the following, we use the Titanic data again, this time collapsed over \code{Survived} to investigate the structure of crew and passengers (and having the \code{Child} and \code{Age} labels of the \code{Age} variable swapped for optical clarity): <>= options(width=75) @ <>= (STD <- structable(~ Sex + Class + Age, data = Titanic[,,2:1,])) STD["Male",] STD["Male", c("1st","2nd","3rd")] @ <>= options(width=70) @ \noindent \emph{Conditioning} on levels (i.e., choosing a table subset for fixed levels of the conditioning variable(s)) is done using the \code{[[} operator. %]] Here again, the sequence of conditioning levels is restricted by the hierarchical structure of the \class{structable} object. In the following examples, note that compared to subsetting, the first dimension(s) are dropped: <>= STD[["Male",]] STD[[c("Male", "Adult"),]] STD[["Male","1st"]] @ \noindent Now, there are several ways for visualizing conditional independence structures. The ``brute force'' method is to draw separate plots for the strata. The following example compares the association between hair and eye color, given gender, by using subsetting on the flat table and \pkg{grid}'s viewport framework to visualize the two groups besides each other: <>= pushViewport(viewport(layout = grid.layout(ncol = 2))) @ <>= pushViewport(viewport(layout.pos.col = 1)) mosaic(STD[["Male"]], margins = c(left = 2.5, top = 2.5, 0), sub = "Male", newpage = FALSE) popViewport() @ <>= pushViewport(viewport(layout.pos.col = 2)) mosaic(STD[["Female"]], margins = c(top = 2.5, 0), sub = "Female", newpage = FALSE) popViewport(2) @ \setkeys{Gin}{width=\textwidth} \begin{figure}[p] \begin{center} <>= <> <> <> @ \caption{Two mosaic displays put side-by-side, visualizing the distribution of class and age, given gender. The marginal distribution of gender cannot be seen.} \label{fig:parttable} \end{center} \end{figure} \setkeys{Gin}{width=0.7\textwidth} \noindent Note the use of the \code{margins} argument: it takes a vector with up to four values whose unnamed components are recycled, but ``overruled'' by the named arguments. Thus, in the second example, only the top margin is set to 2.5 lines, and all other to 0. This idea applies to almost all vectorized arguments in the strucplot framework (with \code{split\_vertical} as a prominent exception). The \codefun{cotabplot} function does a much better job on this task: it arranges stratified strucplot displays in a lattice-like layout, conditioning on variable \emph{levels}. The plot in Figure~\ref{fig:cotabplot} shows class and age group, given sex: <>= cotabplot(~ Class + Age | Sex, data = STD, split_vertical = TRUE) @ \setkeys{Gin}{width=\textwidth} \begin{figure}[p] \begin{center} <>= <> @ \caption{Conditional table plot for the \data{Titanic} data, again visualizing the distribution of age and class, given gender, using separate mosaic displays like the ``manual'' plot in Figure~\ref{fig:parttable}.} \label{fig:cotabplot} \end{center} \end{figure} \setkeys{Gin}{width=0.7\textwidth} %\noindent The \code{labeling\_args} argument modifies the labels' %appearance: here, to be left-aligned and unclipped %(see Section \ref{sec:labeling}). \noindent Visualizing the strata separately ``hides'' the distribution of the conditioning variable(s) which may or may not be appropriate or sensible in a particular analysis step. If we wish to keep the information on the marginal distribution(s), we can use one single mosaic for the stratified plot since mosaic displays are ``conditional plots'' by definition. We just need to make sure that conditioning variables are used first for splitting. Both the default and the formula interface of \codefun{mosaic} allow the specification of conditioning variables (see Figure~\ref{fig:conditioning}): <>= mosaic(STD, condvars = "Sex", split_vertical = c(TRUE, TRUE, FALSE)) @ <>= mosaic(~ Class + Age | Sex, data = STD, split_vertical = c(TRUE, TRUE, FALSE)) @ \setkeys{Gin}{width=\textwidth} \begin{figure}[h] \begin{center} <>= <> @ \caption{Mosaic plot again visualizing the distribution of class and age, given gender, this time using a single mosaic plot. In contrast to Figures~\ref{fig:parttable} and \ref{fig:cotabplot}, this plot also visualizes the marginal distribution of gender.} \label{fig:conditioning} \end{center} \end{figure} \setkeys{Gin}{width=0.7} \noindent The effect of using this is that conditioning variables are permuted ahead of the the conditioned variables in the table, and that \codefun{spacing\_conditional} is used as default to better distinguish conditioning from conditioned dimensions. This spacing uses equal space between tiles of conditioned variables, and increasing space between tiles of conditioning variables (See Section~\ref{sec:spacing}). Another set of high-level functions for visualizing conditional independence models are the \codefun{pairs} methods for \class{table} and \class{structable} objects. In contrast to \codefun{cotabplot} which conditions on variables, the \codefun{pairs} methods create pairwise views of the table. They produce, by default, a plot matrix having strucplot displays in the off-diagonal panels, and the variable names (optionally, with univariate displays) in the diagonal cells. Figure~\ref{fig:pairs} shows a pairs display for the \data{Titanic} data with univariate mosaics in the diagonal, and mosaic plots visualizing the corresponding bivariate mosaics in the upper and lower triangles. Due to the inherent asymmetry of mosaic displays, the corresponding plots in the upper and lower triangle differ depending on which variable is used first for splitting---inspecting both views might help detecting patterns in a data set. Additionally, we are using a special spacing and shading normally used to `highlight' %' the second variable in the first (as will be discussed in Section \ref{sec:spacing}): here, the intention of the spacing is to emphasize the conditional distributions of the second variable, given the first one, and the shading helps identifying the factor levels in the second variable. <>= pairs(STD, highlighting = 2, diag_panel = pairs_diagonal_mosaic, diag_panel_args = list(fill = grey.colors)) @ %\setkeys{Gin}{width=\textwidth} \setkeys{Gin}{width=0.7\textwidth} \begin{figure}[h] \begin{center} <>= <> @ \caption{Pairs plot for the \data{Titanic} data.} \label{fig:pairs} \end{center} \end{figure} \setkeys{Gin}{width=0.7\textwidth} \noindent The labels of the variables are to be read from left to right and from top to bottom. In addition, the levels can be matched by position within the columns and by shading within the rows. In plots produced by \codefun{pairs}, each panel's row and column define two variables $X$ and $Y$ used for the specification of four different types of independence: pairwise, total, conditional, and joint. The pairwise mosaic matrix shows bivariate marginal relations between $X$ and $Y$, collapsed over all other variables. The total independence mosaic matrix shows mosaic plots for mutual independence, i.e., for marginal and conditional independence among all pairs of variables. The conditional independence mosaic matrix shows mosaic plots for marginal independence of $X$ and $Y$, given all other variables. The joint independence mosaic matrix shows mosaic plots for joint independence of all pairs ($X$, $Y$) of variables from the others. Upper and lower parts can independently be used to display different types of independence models, or different strucplot displays (mosaic, association, or sieve plots). The available panel functions (\codefun{pairs\_assoc}, \codefun{pairs\_mosaic}, and \codefun{pairs\_sieve}) are simple wrappers to \codefun{assoc}, \codefun{mosaic}, and \codefun{sieve}, respectively. Obviously, seeing patterns in strucplot matrices becomes increasingly difficult with higher dimensionality. Therefore, this plot is typically used with a suitable residual-based shading (see Section \ref{sec:shading}). \subsection{Interactive plot modifications} All strucplot core functions are supposed to produce conditional hierarchical plots by the means of nested viewports, corresponding to the provided splitting information. Thus, at the end of the plotting, each tile is associated with a particular viewport. Each of those viewports has to be conventionally named, enabling other strucplot modules, in particular the labeling functions, to access specific tiles after they have been plotted. The naming convention for the viewports is: \begin{center} \code{\emph{[Optional prefix]}cell:\emph{Variable1}=\emph{Level1},\emph{Variable2}=\emph{Level2}} \dots \end{center} \noindent Clearly, these names depend on the splitting. The following example shows how to access parts of the plot after it has been drawn (see Figure~\ref{fig:afterplot}): <>= mosaic(~ Hair + Eye, data = HEC, pop = FALSE) seekViewport("cell:Hair=Blond") grid.rect(gp = gpar(col = "red", lwd = 4)) seekViewport("cell:Hair=Blond,Eye=Blue") grid.circle(r = 0.2, gp = gpar(fill = "cyan")) @ \noindent Note that the viewport tree is removed by default. Therefore, the \texttt{pop} argument has to be set to \texttt{FALSE} when viewports shall be accessed. \setkeys{Gin}{width=0.6\textwidth} \begin{figure}[h] \begin{center} <>= <> @ \caption{Adding elements to a mosaic plot after drawing.} \label{fig:afterplot} \end{center} \end{figure} In addition to the viewports, the main graphical elements get names following a similar construction method. This allows to change graphical parameters of plot elements \emph{after} the plotting (see Figure~\ref{fig:changeplot}): <>= assoc(Eye ~ Hair, data = HEC, pop = FALSE) getNames()[1:6] grid.edit("rect:Hair=Blond,Eye=Blue", gp = gpar(fill = "red")) @ %% code-chunk reuse does not work with parameter changing \begin{figure}[h] \begin{center} <>= x <- tab <- margin.table(HairEyeColor, 1:2) x[] <- "light gray" x["Blond","Blue"] <- "Red" assoc(tab, gp = gpar(fill = x)) @ \caption{Changing graphical parameters of elements after drawing.} \label{fig:changeplot} \end{center} \end{figure} \subsection{Performance issues} \label{sec:performance} As stated above, the implementation of strucplot displays is based on creating and nesting \pkg{grid} viewports. The main time-consuming steps performed by the core functions are the following: \begin{enumerate} \item recursively, split the table until the individual cells are reached \item during the splits, add viewports to the plot \item for the individual cells, add plot-specific content (rectangles for mosaics, bars for association plots, etc.) \end{enumerate} \noindent All these operations scale linearly with the amount of created viewports. For a $d$-dimensional table with $k_i$ levels, $i=1 \dots d$, the total number of needed viewports $T_d$ can roughly be estimated as \begin{equation} \label{eq:numbervp} T_d \quad = \quad k_1 + k_1k_2 + \cdots + k_1 \cdots k_d \quad =\quad \sum_{i=1}^d \prod_{j \le i} k_j \end{equation} \noindent since we first push the $k_1$ viewports for the levels of the first dimension, then, for \emph{each} of these, the $k_2$ levels of the second dimension, etc. If the number of levels is equal ($k$) for all dimensions, $T_d$ simplifies to \begin{equation} \label{eq:equalvp} T_d \quad = \quad \sum_{i=1}^d k^i = \frac{k(k^d-1)}{k-1} \end{equation} \noindent and so the time complexity for drawing a strucplot display is of order $k^d$. \section{Shadings} \label{sec:shading} Unlike other graphics functions in base \proglang{R}, the strucplot framework allows almost full control over the graphical parameters of all plot elements. In particular, in association plots, mosaic plots, and sieve plots, the user can modify the graphical appearance of each tile individually. Built on top of this functionality, the framework supplies a set of shading functions choosing colors appropriate for the visualization of log-linear models. The tiles' graphical parameters are set using the \code{gp} argument of the functions of the strucplot framework. This argument basically expects an object of class \class{gpar} whose components are arrays of the same shape (length and dimensionality) as the data table (see Section \ref{sec:gp}). For convenience, however, the user can also supply a grapcon function that computes such an object given a vector of residuals, or, alternatively, a generating function that takes certain arguments and returns such a grapcon function (see Section \ref{sec:shadingcustom}). We provide several shading functions, including support for both HSV and HCL colors, and the visualization of significance tests (see Section \ref{sec:overview}). \subsection{Specifying graphical parameters of strucplot displays} \label{sec:gp} As an example, consider the \data{UCBAdmissions} data. In the table aggregated over departments, we would like to highlight the (incidentally wrong) impression that there were too many male students accepted compared to the presumably discriminated female students (see Figure~\ref{fig:ucb}): <>= (ucb <- margin.table(UCBAdmissions, 1:2)) (fill_colors <- matrix(c("dark cyan","gray","gray","dark magenta"), ncol = 2)) mosaic(ucb, gp = gpar(fill = fill_colors, col = 0)) @ \begin{figure}[h] \begin{center} <>= <> @ \caption{Mosaic plot for the \data{UCBAdmissions} data with highlighted cells.} \label{fig:ucb} \end{center} \end{figure} \noindent As the example shows, we create a fourfold table with appropriate colors (dark cyan for admitted male students and dark magenta for rejected female students) and supply them to the \code{fill} component of the \class{gpar} object passed to the \code{gp} argument of \codefun{mosaic}. For visual clarity, we additionally hide the tiles' borders by setting the \code{col} component to 0 (transparent). If the parameters specified in the \class{gpar} object are ``incomplete'', they will be recycled along the last splitting dimension. In the following example based on the \data{Titanic} data, we will highlight all cells corresponding to survived passengers (see Figure~\ref{fig:recycling}): <>= mosaic(Titanic, gp = gpar(fill = c("gray","dark magenta")), spacing = spacing_highlighting, labeling_args = list(abbreviate_labs = c(Age = 3), rep = c(Survived = FALSE)) ) @ \noindent Note that \codefun{spacing\_highlighting} sets the spaces between tiles in the last dimension to 0. The \code{labeling\_args} argument ensures that labels do not overlap (see Section \ref{sec:labeling}). \begin{figure}[h] \begin{center} <>= <> @ \caption{Recycling of parameters, used for highlighting the survived passengers in the \data{Titanic} data.} \label{fig:recycling} \end{center} \end{figure} \subsection{Customizing residual-based shadings} \label{sec:shadingcustom} This flexible way of specifying graphical parameters is the basis for a suite of shading functions that modify the tiles' appearance with respect to a vector of residuals, resulting from deviations of observed from expected frequencies under a given log-linear model. The idea is to visualize at least sign and absolute size of the residuals, but some shadings, additionally, indicate overall significance. One particular shading, the maximum shading \citep{vcd:Meyer+Zeileis+Hornik:2003,vcd:Zeileis+Meyer+Hornik:2007}, even allows to identify the cells that cause the rejection of the null hypothesis. Conceptually, the strucplot framework offers three alternatives to add residual-based shading to plots: \begin{enumerate} \item Precomputing the graphical parameters (e.g., fill colors), encapsulating them into an object of class \class{gpar} as demonstrated in the previous section, and passing this object to the \code{gp} argument. \item Providing a grapcon function to the \code{gp} argument that takes residuals as input and returns an object as described in alternative 1. \item Providing a grapcon generator taking parameters and returning a function as described in alternative~2. \end{enumerate} \noindent For each of these approaches, we will demonstrate the necessary steps to obtain a binary shading that visualizes the sign of the residuals by a corresponding fill color (for simplicity, we will treat 0 as positive). \subsubsection*{Alternative 1: Precomputed \class{gpar} object} The first method is precomputing the graphical parameters ``by hand''. We will use \code{royalblue4} color for positive and \code{mediumorchid4} color for negative residuals (see Figure~\ref{fig:binary}): <>= expected <- independence_table(ucb) (x <- (ucb - expected) / sqrt(expected)) (shading1_obj <- ifelse(x > 0, "royalblue4", "mediumorchid4")) mosaic(ucb, gp = gpar(fill = shading1_obj)) @ \begin{figure}[h] \begin{center} <>= <> @ \caption{Binary shading visualizing the sign of the residuals.} \label{fig:binary} \end{center} \end{figure} \subsubsection*{Alternative 2: Grapcon function} For implementing alternative 2, we need to create a ``shading function'' that computes \class{gpar} objects from residuals. For that, we can just reuse the code from the previous step: <>= shading2_fun <- function(x) gpar(fill = ifelse(x > 0, "royalblue4", "mediumorchid4")) @ \noindent To create a mosaic display with binary shading, it now suffices to specify the data table along with \codefun{shading2\_fun}: <>= mosaic(ucb, gp = shading2_fun) @ \noindent \codefun{mosaic} internally calls \codefun{strucplot} which computes the residuals from the specified independence model (total independence by default), passes them to \codefun{shading2\_fun}, and uses the \class{gpar} object returned to finally create the plot. Our \codefun{shading2\_fun} function might be useful, but can still be improved: the hard-wired colors should be customizable. We cannot simply extend the argument list to include, e.g., a \code{fill = c("royalblue4", "mediumorchid4")} argument because \codefun{strucplot} will neither know how to handle it, nor let us change the defaults. In fact, the interface of shading functions is fixed, they are expected to take exactly one argument: a table of residuals. This is where generating functions (alternative 3) come into play. \subsubsection*{Alternative 3: Grapcon generator} We simply wrap our grapcon shading function in another function that takes all additional arguments it needs to use, possibly preprocesses them, and returns the actual shading function. This returned function will have access to the parameters since in \proglang{R}, nested functions are lexically scoped. Thus, the grapcon generator returns (``creates'') a ``parameterized'' shading function with the minimal standard interface \codefun{strucplot} requires. The following example shows the necessary extensions for our running example: <>= shading3a_fun <- function(col = c("royalblue4", "mediumorchid4")) { col <- rep(col, length.out = 2) function(x) gpar(fill = ifelse(x > 0, col[1], col[2])) } @ \noindent The first statement just makes sure that exactly two colors are specified. In the call to \codefun{mosaic}, using the new \codefun{shading3a\_fun} function, we can now simply change the colors: <>= mosaic(ucb, gp = shading3a_fun(c("royalblue4","mediumorchid4"))) @ \noindent (figure not shown). The procedure described so far is a rather general concept, applicable to a wide family of user-level \pkg{grid} graphics. Indeed, the customization of other components of the strucplot framework (labeling, spacing, legend, and core functions) follows the same idea. Now for the shading functions, more customization is needed. Note that \codefun{shading3a\_fun} needs to be evaluated by the user, even if the defaults are to be used. It is a better idea to let \codefun{strucplot} call the generating function, which, in particular, allows the passing of arguments that are computed by \codefun{strucplot}. Since shading functions can be used for visualizing significance (see Section \ref{sec:overview}), it makes sense for generating functions to have access to the model, i.e., observed and expected values, residuals, and degrees of freedom. For example, the \codefun{shading\_max} generating function computes a permutation distribution of the maximum statistic and $p$ values for specified significance levels based on the observed table to create data-driven cut-off points. If this was done in the shading function itself, the permutation statistic would be recomputed every time the shading function is called, resulting in possibly severe performance loss and numerical inconsistencies. Therefore, generating functions for shadings are required to take at least the parameters \code{observed}, \code{expected}, \code{residuals}, and \code{df} (these are provided by the strucplot framework), followed by other parameters controlling the shading appearance (to be specified by the user): <>= shading3b_fun <- function(observed = NULL, residuals = NULL, expected = NULL, df = NULL, col = c("royalblue4", "mediumorchid4")) { col <- rep(col, length.out = 2) function(x) gpar(fill = ifelse(x > 0, col[1], col[2])) } class(shading3b_fun) <- "grapcon_generator" @ Note that in this simple binary shading example, the first four parameters are not used. In some sense, generating functions for shadings are parameterized both by the user and the strucplot framework. For shading functions that require model information, the user-specified parameters are to be passed to the \code{gp\_args} argument instead, and for this to work, the generating function needs a class attribute to be distinguishable from the ``normal'' shading functions. For others (like our simple \codefun{shading3b\_fun}) this is optional, but recommended for consistency: <>= mosaic(ucb, gp = shading3b_fun, gp_args = list(col = c("red","blue"))) @ \noindent The final \codefun{shading3b\_fun} pretty much resembles \codefun{shading\_binary}, one of the standard shading functions provided by the \pkg{vcd} package. \subsection[An overview of the shading functions in vcd]{An overview of the shading functions in \pkg{vcd}} \label{sec:overview} \cite{vcd:Friendly:1994} suggested a residual-based shading for the mosaic tiles that can also be applied to the rectangles in association plots \citep{vcd:Meyer+Zeileis+Hornik:2003}. Apart from \codefun{shading\_binary}, there are currently two basic shadings available in \pkg{vcd}: \codefun{shading\_hcl} and \codefun{shading\_hsv}, as well as two derived functions: \codefun{shading\_Friendly} building upon \codefun{shading\_hsv}, and \codefun{shading\_max} building upon \codefun{shading\_hcl}. \codefun{shading\_hsv} and \codefun{shading\_hcl} provide the same conceptual tools, but use different color spaces: the Hue-Saturation-Value (HSV) and the Hue-Chroma-Luminance (HCL) scheme, respectively. We will first expose the basic concept of these shading functions using HSV space, and then briefly explain the differences to HCL space \citep[a detailed discussion can be found in][]{vcd:Zeileis+Meyer+Hornik:2007}. Color palettes in HCL space are preferable to palettes derived from HSV space from a perceptual point of view. Functions for creating palettes (see, e.g., \codefun{diverge\_hcl}) are provided with the \pkg{vcd} package. In HSV space, colors are specified in three dimensions: Hue, Saturation (``colorfulness''), and Value (``lightness'', amount of gray). These three dimensions are used by \codefun{shading\_hsv} to visualize information about the residuals and the underlying independence model. The hue indicates the residuals' sign: by default, blue for positive, and red for negative residuals. The saturation of a residual is set according to its size: high saturation for large, and low saturation for small residuals. Finally, the overall lightness is used to indicate the significance of a test statistic: light colors for significant, and dark colors for non-significant results. As an example, we will visualize the association of hair and eye color in the \data{HairEyeColor} data set (see Figure~\ref{fig:haireye}, top): <>= haireye <- margin.table(HairEyeColor, 1:2) mosaic(haireye, gp = shading_hsv) @ \noindent As introduced before, the default shading scheme is not \codefun{shading\_hsv} but \codefun{shading\_hcl} due to the better perceptual characteristics of HCL color space. The following example again illustrates the \data{HairEyeColor} data, this time with HCL colors: <>= mosaic(haireye, gp = shading_hcl) @ <>= mosaic(haireye, gp = shading_hcl, gp_args = list(h = c(130, 43), c = 100, l = c(90, 70))) @ \noindent In Figure~\ref{fig:haireye}, the plot in the middle depicts the default palette, and the bottom plot an alternative setting for Hue (\code{h}), Chroma (\code{c}), and Luminance (\code{l}). \setkeys{Gin}{width=0.5\textwidth} \begin{figure}[htbp] \begin{center} <>= mosaic(haireye, gp = shading_hsv, margin = c(bottom = 1), keep_aspect_ratio = FALSE) @ <>= mosaic(haireye, gp = shading_hcl, margin = c(bottom = 1), keep_aspect_ratio = FALSE) @ <>= mosaic(haireye, gp = shading_hcl, margin = c(bottom = 1), gp_args = list(h = c(130, 43), c = 100, l = c(90, 70)), keep_aspect_ratio = FALSE) @ \caption{Three mosaic plots for the \data{HairEyeColor} data using different color palettes. Top: default HSV color palette. Middle: default HCL color palette. Bottom: a custom HCL color palette.} \label{fig:haireye} \end{center} \end{figure} \setkeys{Gin}{width=0.7\textwidth} \noindent Large positive residuals (greater than $4$) can be found for brown eyes/black hair and blue eyes/blond hair, and are colored in deep blue. On the other hand, there is a large negative residual (less than $-4$) for brown eyes/blond hair, colored deep red. There are also three medium-sized positive (negative) residuals between 2 and 4 ($-2$ and $-4$): the colors for them are less saturated. Residuals between $-2$ and $2$ are shaded in white (gray for HCL-shading). The heuristic for choosing the cut-off points $2$ and $4$ is that the Pearson residuals are approximately standard normal which implies that the highlighted cells are those with residuals \emph{individually} significant at approximately the $\alpha = 0.05$ and $\alpha = 0.0001$ levels, respectively. These default cut-off points can be changed to alternative values using the \code{interpolate} argument (see Figure~\ref{fig:interpolatecontinuous}): <>= mosaic(haireye, shade = TRUE, gp_args = list(interpolate = 1:4)) @ \noindent The elements of the numeric vector passed to \code{interpolate} define the knots of an interpolating step function used to map the absolute residuals to saturation levels. The \code{interpolate} argument also accepts a user-defined function, which then is called with the absolute residuals to get a vector of cut-off points. Thus, it is possible to automatically choose the cut-off points in a data-driven way. For example, one might think that the extension from four cut-off points to a continuous shading---visualizing the whole range of residuals---could be useful. We simply need a one-to-one mapping from the residuals to the saturation values: <>= ipol <- function(x) pmin(x/4, 1) @ \noindent Note that this \codefun{ipol} function maps residuals greater than 4 to a saturation level of 1. However, the resulting plot (Figure~\ref{fig:interpolatecontinuous}, right) is deceiving: <>= mosaic(haireye, shade = TRUE, gp_args = list(interpolate = ipol), labeling_args = list(abbreviate_labs = c(Sex = TRUE))) @ \setkeys{Gin}{width=\textwidth} \begin{figure}[htbp] \begin{center} <>= pushViewport(viewport(layout = grid.layout(ncol = 2))) pushViewport(viewport(layout.pos.col = 1)) mosaic(haireye, gp_args = list(interpolate = 1:4), margin = c(right = 1), keep_aspect_ratio= FALSE,newpage = FALSE,legend_width=5.5,shade = TRUE) popViewport(1) pushViewport(viewport(layout.pos.col = 2)) mosaic(haireye, gp_args = list(interpolate = ipol), margin = c(left=3,right = 1), keep_aspect_ratio = FALSE, newpage = FALSE, shade = TRUE) popViewport(2) @ \caption{\label{fig:interpolatecontinuous}The \data{HairEyeColor} data. Left: shading with 4 cut-off points. Right: continuous shading.} \end{center} \end{figure} \setkeys{Gin}{width=0.7\textwidth} \noindent Too much color makes it difficult to interpret the image, and the subtle color differences are hard to catch. Therefore, we only included shadings with discrete cut-off points. The third remaining dimension, the value, is used for visualizing the significance of a test statistic. The user can either directly specify the $p$ value, or, alternatively, a function that computes it, to the \code{p.value} argument. Such a function must take observed and expected values, residuals, and degrees of freedom (used by the independence model) as arguments. If nothing is specified, the $p$ value is computed from a $\chi^2$ distribution with \code{df} degrees of freedom. The \code{level} argument is used to specify the confidence level: if \code{p.value} is smaller than \code{1 - level}, light colors are used, otherwise dark colors are employed. The following example using the \data{Bundesliga} data shows the relationship of home goals and away goals of Germany's premier soccer league in 1995: although there are two ``larger'' residuals (one greater than 2, one less then $-2$), the $\chi^2$ test does not reject the null hypothesis of independence. Consequently, the colors appear dark (see Figure~\ref{fig:bundesliga}, left): <>= BL <- xtabs(~ HomeGoals + AwayGoals, data = Bundesliga, subset = Year == 1995) mosaic(BL, shade = TRUE) @ \noindent Note that in extended mosaic plots, bullets drawn for zero cells are shaded, too, bringing out non-zero residuals, if any. A shading function building upon \codefun{shading\_hsv} is \codefun{shading\_Friendly}, implementing the shading introduced by \cite{vcd:Friendly:1994}. In addition to the defaults of the HSV shading, it uses the border color and line type to redundantly code the residuals' sign. The following example again uses the \data{Bundesliga} data from above, this time using the Friendly scheme and, in addition, an alternative legend (see Figure~\ref{fig:bundesliga}, right): <>= mosaic(BL, gp = shading_Friendly, legend = legend_fixed, zero_size = 0) @ \setkeys{Gin}{width=\textwidth} \begin{figure}[htbp] \begin{center} <>= pushViewport(viewport(layout = grid.layout(ncol = 2))) pushViewport(viewport(layout.pos.col = 1)) mosaic(BL, margin = c(right = 1), keep_aspect_ratio= FALSE, newpage = FALSE, legend_width=5.5, shade = TRUE) popViewport(1) pushViewport(viewport(layout.pos.col = 2)) mosaic(BL, gp = shading_Friendly, legend = legend_fixed, zero_size = 0, margin = c(right = 1), keep_aspect_ratio= FALSE, newpage = FALSE, legend_width=5.5) popViewport(2) @ \caption{The \data{Bundesliga} data for 1995. Left: Non-significant $\chi^2$ test. Right: using the Friendly shading and a legend with fixed bins.} \label{fig:bundesliga} \end{center} \end{figure} \setkeys{Gin}{width=0.7\textwidth} \noindent (The \code{zero\_size = 0} argument removes the bullets indicating zero observed values. This feature is not provided in the original \proglang{SAS} implementation of the Friendly mosaic plots.) % Figure~\ref{fig:shadingHSVHCL} depicts % HSV space in the upper panel and HCL space in the lower panel. % On the left (right) side, we see the color scales for red (blue) % hue, respectively. The $x$-axis represents the colorfulness, and the % $y$-axis the brightness. % The boxes represent the diverging color palettes used for the shadings. % For HSV space, we can see that the effect of changing the % level of brightness (`value') is not the same for different levels of % saturation, and again not the same for the two different hues. % In fact, in HSV space all dimensions are confounded, which % obviously is problematic for coding information. In contrast, HCL color % space offers perceptually uniform colors: as can be seen from the lower panel, % the chroma is homogeneous for different levels of luminance. % Unfortunately, this comes at the % price of the space being irregularly shaped, making it difficult to automatically select % diverging color palettes. % <>= % hue.slice <- function(hue, grid.n = 101, type = c("HCL", "HSV"), plot = TRUE, fixup = FALSE) % { % type <- match.arg(type) % if(type == "HCL") { % chroma = seq(0, 100, length.out = grid.n) % luminance = seq(0, 100, length.out = grid.n) % nc <- length(chroma) % nl <- length(luminance) % color.slice <- outer(chroma, luminance, function(y, x) hcl(hue, x, y, fixup = fixup)) % xlab <- "chroma" % ylab <- "luminance" % main <- paste("hue =", round(hue, digits = 0)) % } else { % chroma = seq(0, 1, length.out = grid.n) % luminance = seq(0, 1, length.out = grid.n) % nc <- length(chroma) % nl <- length(luminance) % color.slice <- outer(chroma, luminance, function(y, x) hsv(hue, x, y)) % xlab <- "saturation" % ylab <- "value" % main <- paste("hue =", round(hue, digits = 3)) % } % if(plot) { % plot(0.5, 0.5, xlim = range(chroma), ylim = range(luminance), type = "n", axes = FALSE, % xlab = xlab, ylab = ylab, yaxs = "i", xaxs = "i", main = main) % for(i in 1:(nc-1)) { % rect(chroma[i], luminance[-nl], chroma[i] + 100/(nc-1), luminance[-1], border = color.slice[,i+1], col = color.slice[,i+1]) % } % axis(1) % axis(2) % box() % } % colnames(color.slice) <- chroma % rownames(color.slice) <- luminance % attr(color.slice, "type") <- type % class(color.slice) <- "slice" % invisible(color.slice) % } % @ % \setkeys{Gin}{width=.8\textwidth} % \begin{figure}[p] % \begin{center} % <>= % ## generate colors % hue23 <- hue.slice(2/3, grid.n = 101, plot = FALSE, type = "HSV") % hue0 <- hue.slice(0, grid.n = 101, plot = FALSE, type = "HSV") % saturation <- as.numeric(colnames(hue23)) % value <- as.numeric(rownames(hue23)) % ## select those with value >= 0.5 % hue23 <- hue23[value >= .5, ] % hue0 <- hue0[value >= .5, ] % value <- value[value >= .5] % nl <- nrow(hue23) % nc <- ncol(hue23) % ## plot 2 slides from HSV space % plot(0.5, 0.5, xlim = c(-1, 1), ylim = c(0, 1), type = "n", axes = FALSE, % xlab = "", ylab = "", yaxs = "i", xaxs = "i", main = "") % for(i in 1:(nc-1)) { % rect(saturation[i], value[-nl], saturation[i] + 1/(nc-1), value[-1], border = hue23[,i+1], col = hue23[,i+1]) % } % for(i in 1:(nc-1)) { % rect(-saturation[i], value[-nl], -(saturation[i] + 1/(nc-1)), value[-1], border = hue0[,i+1], col = hue0[,i+1]) % } % axis(2, at = c(50, 75, 100)/100, labels = c(0.5, 0.75, 1)) % axis(4, at = c(50, 75, 100)/100, labels = c(0.5, 0.75, 1)) % axis(3, at = -4:4*.25, labels=c(4:0*.25, 1:4*.25)) % mtext(c("hue = 0", "hue = 2/3"), side = 3, at = c(-.5, .5), line = 3, cex = 1.2) % mtext("saturation", side = 3, at = 0, line = 2) % mtext("value", side = 2, at = .75, line = 2) % mtext("value", side = 4, at = .75, line = 2) % lines(c(-1, 1), c(.5, .5)) % ## significant colors % rect(-1, 0.95, -.90, 1, col = hsv(0, 1, 1)) % rect(-0.45, 0.95, -.55, 1, col = hsv(0, 0.5, 1)) % rect(-.05, .95, .05, 1, col = hsv(2/3, 0, 1)) % rect(0.45, 0.95, .55, 1, col = hsv(2/3, 0.5, 1)) % rect(.90, .95, 1, 1, col = hsv(2/3, 1, 1)) % text(-1, .33, "significant", pos = 4, cex = 1.2) % rect(-1, .20, -.80, .30, col = hsv(0, 1, 1)) % rect(-.40, .20, -0.6, .30, col = hsv(0, 0.5, 1)) % rect(-.20, .20, 0, .30, col = hsv(0, 0, 1)) % rect(0, .20, .20, .30, col = hsv(2/3, 0, 1)) % rect(0.4, .20, .60, .30, col = hsv(2/3, .5, 1)) % rect(.80, .20, 1, .30, col = hsv(2/3, 1, 1)) % lines(c(-.9, -.55), c(0.975, .975), lty = 2) % lines(c(-.45, -.05), c(0.975, .975), lty = 2) % lines(c(.45, .05), c(0.975, .975), lty = 2) % lines(c(.9, .55), c(0.975, .975), lty = 2) % ## non-significant colors % rect(-1, 0.5, -.90, 0.55, col = hsv(0, 1, 0.5)) % rect(-0.4, 0.5, -.55, 0.55, col = hsv(0, 0.5, 0.5)) % rect(-.05, .5, .05, 0.55, col = hsv(2/3, 0, 0.5)) % rect(0.45, 0.5, .55, 0.55, col = hsv(2/3, 0.5, 0.5)) % rect(.90, .5, 1, 0.55, col = hsv(2/3, 1, 0.5)) % text(-1, .13, "non-significant", pos = 4, cex = 1.2) % rect(-1, 0, -.80, .10, col = hsv(0, 1, 0.5)) % rect(-.60, 0, -.4, .10, col = hsv(0, 0.5, 0.5)) % rect(-.20, 0, 0, .10, col = hsv(0, 0, 0.5)) % rect(0, 0, .20, .10, col = hsv(2/3, 0, 0.5)) % rect(0.4, 0, .60, .1, col = hsv(2/3, .5, 0.5)) % rect(.80, 0, 1, .10, col = hsv(2/3, 1, 0.5)) % lines(c(-.9, -.55), c(0.525, .525), lty = 2) % lines(c(-.45, -.05), c(0.525, .525), lty = 2) % lines(c(.45, .05), c(0.525, .525), lty = 2) % lines(c(.9, .55), c(0.525, .525), lty = 2) % @ % <>= % ## generate colors % hue260 <- hue.slice(260, grid.n = 101, plot = FALSE) % hue360 <- hue.slice(360, grid.n = 101, plot = FALSE) % mychroma <- as.numeric(colnames(hue260)) % luminance <- as.numeric(rownames(hue260)) % ## select those with lumincance >= 50 % hue260 <- hue260[luminance >= 50, ] % hue360 <- hue360[luminance >= 50, ] % luminance <- luminance[luminance >= 50] % nc <- ncol(hue260) % nl <- nrow(hue260) % ## plot 2 slides from HCL space % plot(0.5, 0.5, xlim = c(-100, 100), ylim = c(0, 100), type = "n", axes = FALSE, % xlab = "", ylab = "", yaxs = "i", xaxs = "i", main = "") % for(i in 1:(nc-1)) { % rect(mychroma[i], luminance[-nl], mychroma[i] + 100/(nc-1), luminance[-1], border = hue260[,i+1], col = hue260[,i+1]) % } % for(i in 1:(nc-1)) { % rect(-mychroma[i], luminance[-nl], -(mychroma[i] + 100/(nc-1)), luminance[-1], border = hue360[,i+1], col = hue360[,i+1]) % } % axis(2, at = c(50, 70, 90, 100), labels = c(50, 70, 90, 100)) % axis(4, at = c(50, 70, 90, 100), labels = c(50, 70, 90, 100)) % axis(3, at = -4:4*25, labels=c(4:0*25, 1:4*25)) % mtext(c("hue = 0", "hue = 260"), side = 3, at = c(-50, 50), line = 3, cex = 1.2) % mtext("chroma", side = 3, at = 0, line = 2) % mtext("luminance", side = 2, at = 75, line = 2) % mtext("luminance", side = 4, at = 75, line = 2) % lines(c(-100, 100), c(50, 50)) % ## significant colors % rect(-100, 47.5, -90, 52.5, col = hcl(0, 100, 50)) % rect(-55, 67.5, -45, 72.5, col = hcl(0, 50, 70)) % rect(-5, 95, 5, 100, col = hcl(260, 0, 100)) ## grey vs. white % rect(-5, 87.5, 5, 92.5, col = hcl(260, 0, 90)) ## grey vs. white % rect(45, 67.5, 55, 72.5, col = hcl(260, 50, 70)) % rect(90, 47.5, 100, 52.5, col = hcl(260, 100, 50)) % text(-100, 33, "significant", pos = 4, cex = 1.2) % rect(-100, 20, -80, 30, col = hcl(0, 100, 50)) % rect(-60, 20, -40, 30, col = hcl(0, 50, 70)) % rect(-20, 20, 0, 30, col = hcl(0, 0, 90)) % rect(0, 20, 20, 30, col = hcl(260, 0, 90)) % #white# rect(-20, 20, 0, 30, col = hcl(0, 0, 100)) % #white# rect(0, 20, 20, 30, col = hcl(260, 0, 100)) % rect(40, 20, 60, 30, col = hcl(260, 50, 70)) % rect(80, 20, 100, 30, col = hcl(260, 100, 50)) % lines(c(-45, -5), c(72.5, 87.5), lty = 2) % lines(c(45, 5), c(72.5, 87.5), lty = 2) % lines(c(-95, -55), c(52.5, 67.5), lty = 2) % lines(c(95, 55), c(52.5, 67.5), lty = 2) % ## non-significant colors % rect(-25, 47.5, -15, 52.5, col = hcl(0, 20, 50)) % rect(-15, 67.5, -5, 72.5, col = hcl(0, 10, 70)) % rect(5, 67.5, 15, 72.5, col = hcl(260, 10, 70)) % rect(25, 47.5, 15, 52.5, col = hcl(260, 20, 50)) % text(-100, 13, "non-significant", pos = 4, cex = 1.2) % rect(-60, 0, -40, 10, col = hcl(0, 20, 50)) % rect(-40, 0, -20, 10, col = hcl(0, 10, 70)) % rect(-20, 0, 0, 10, col = hcl(0, 0, 90)) % rect(0, 0, 20, 10, col = hcl(260, 0, 90)) % rect(20, 0, 40, 10, col = hcl(260, 10, 70)) % rect(40, 0, 60, 10, col = hcl(260, 20, 50)) % lines(c(-18.75, -11.25), c(52.5, 67.5), lty = 2) % lines(c(-8.75, -1.25), c(72.5, 87.5), lty = 2) % lines(c(18.75, 11.75), c(52.5, 67.5), lty = 2) % lines(c(8.75, 1.25), c(72.5, 87.5), lty = 2) % @ % \caption{Residual-based shadings in HSV (upper) and HCL space (lower).} % \label{fig:shadingHSVHCL} % \end{center} % \end{figure} A more ``advanced'' function building upon \codefun{shading\_hcl} is \codefun{shading\_max}, using the maximum statistic both to conduct the independence test and to visualize significant \emph{cells} causing the rejection of the independence hypothesis \citep{vcd:Meyer+Zeileis+Hornik:2003,vcd:Zeileis+Meyer+Hornik:2007}. The \code{level} argument of \codefun{shading\_max} then can be used to specify several confidence levels from which the corresponding cut-off points are computed. By default, two cut-off points are computed corresponding to confidence levels of $90\%$ and $99\%$, respectively. In the following example, we investigate the effect of a new treatment for rheumatoid arthritis on a group of female patients using the maximum shading (see Figure~\ref{fig:maximum}): <>= set.seed(4711) mosaic(~ Treatment + Improved, data = Arthritis, subset = Sex == "Female", gp = shading_max) @ \begin{figure}[h] \begin{center} <>= <> @ \caption{The \data{Arthritis} data (female patients) with significant maximum test.} \label{fig:maximum} \end{center} \end{figure} \noindent The maximum test is significant although the residuals are all in the $\left[-2,2\right]$ interval. The \codefun{shading\_hcl} function with default cut-off points would not have shown any color. In addition, since the test statistic is the maximum of the absolute Pearson residuals, \emph{each} colored residual violates the null hypotheses of independence, and thus, the ``culprits'' can immediately be identified. \clearpage \section[Labeling]{Labeling} \label{sec:labeling} One of the major enhancements in package \pkg{vcd} compared to \codefun{mosaicplot} and \codefun{assocplot} in base \proglang{R} is the labeling in the strucplot framework which offers more features and greater flexibility. Like shading, spacing, and drawing of legend and core plot, labeling is now carried out by grapcon functions, rendering labeling completely modular. The user supplies either a labeling function, or, alternatively, a generating function that parameterizes a labeling function, to \codefun{strucplot} which then draws the labels. Labeling is well-separated from the actual plotting that occurs in the low-level core functions. It only relies on the viewport tree produced by them, and the \code{dimnames} attribute of the visualized table. Labeling functions are grapcons that ``add ink to the canvas'': the drawing of the labels happens after the actual plot has been drawn by the core function. Thus, it is possible to supply one's own labeling function, or to combine some of the basic functions to produce a more complex labeling. In the following, we describe the three basic modules (\codefun{labeling\_text}, \codefun{labeling\_list}, and \codefun{labeling\_cells}) and derived functions that build upon them. \subsection[Labels in the borders]{Labels in the borders: \texttt{labeling\_text()}} \codefun{labeling\_text} is the default for all strucplot displays. It plots labels in the borders similar to the \codefun{mosaicplot} function in base \proglang{R}, but is much more flexible: it is not limited to 4 dimensions, and the positioning and graphical parameters of levels and variable names are customizable. In addition, the problem of overlapping labels can be handled in several ways. As an example, again consider the \data{Titanic} data: by default, the variable names and levels are plotted ``around'' the plot in a counter-clockwise way (see Figure~\ref{fig:labels1}, top left): <>= mosaic(Titanic) @ % \begin{figure}[p] % \begin{center} % <>= % <> % @ % \caption{Mosaic plot for the \data{Titanic} data with default settings % for labeling.} % \label{fig:defaults} % \end{center} % \end{figure} \noindent Note that the last two levels of the \code{survived} variable do overlap, as well as some adult and child labels of the \code{age} Variable. This issue can be addressed in several ways. The ``brute force'' method is to enable clipping for these dimensions (see Figure~\ref{fig:labels1}, top right): <>= mosaic(Titanic, labeling_args = list(clip = c(Survived = TRUE, Age = TRUE))) @ % \begin{figure}[p] % \begin{center} % <>= % <> % @ % \caption{The effect of clipping.} % \label{fig:clipping} % \end{center} % \end{figure} \noindent The \code{clip} parameter is passed to the labeling function via the \code{labeling\_args} argument which takes a list of parameters. \code{clip} itself takes a vector of logicals (one for each dimension). % as mentioned before Almost all vectorized arguments in the strucplot framework can be abbreviated in the following way: unnamed components (or the defaults, if there are none) are recycled as needed, but overridden by the named components. Here, the default is \code{FALSE}, and therefore clipping is enabled only for the \code{survived} and \code{age} variables. A more sensible solution to the overlap problem is to abbreviate the levels (see Figure~\ref{fig:labels1}, middle left): <>= mosaic(Titanic, labeling_args = list(abbreviate_labs = c(Survived = TRUE, Age = 3))) @ % \begin{figure}[h] % \begin{center} % <>= % <> % @ % \caption{Abbreviating.} % \label{fig:abbreviating} % \end{center} % \end{figure} \noindent The \code{abbreviate} argument takes a vector of integers indicating the number of significant characters the levels should be abbreviated to (\code{TRUE} is interpreted as 1, obviously). Abbreviation is performed using the \codefun{abbreviate} function in base \proglang{R}. Another possibility is to rotate the levels (see Figure~\ref{fig:labels1}, bottom): <>= mosaic(Titanic, labeling_args = list(rot_labels = c(bottom = 90, right = 0), offset_varnames = c(right = 1), offset_labels = c(right = 0.3)), margins = c(right = 4, bottom = 3)) @ % \begin{figure}[p] % \begin{center} % <>= % <> % @ % \caption{Rotating labels.} % \label{fig:rotating} % \end{center} % \end{figure} \noindent Finally, we could also inhibit the output of repeated levels (see Figure~\ref{fig:labels1}, middle right): <>= mosaic(Titanic, labeling_args = list(rep = c(Survived = FALSE, Age = FALSE))) @ \setkeys{Gin}{width=0.9\textwidth} \begin{figure}[p] \begin{center} <>= pushViewport(viewport(layout = grid.layout(ncol = 2,nrow=3))) pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 1)) mosaic(Titanic, newpage = FALSE, keep = TRUE, margin = c(right = 3), gp_labels = gpar(fontsize = 10)) popViewport() pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 1)) mosaic(Titanic, labeling_args = list(clip = c(Survived = TRUE, Age = TRUE)), newpage = FALSE, keep = TRUE, margin = c(left = 3), gp_labels = gpar(fontsize = 10)) popViewport() pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 2)) mosaic(Titanic, labeling_args = list(abbreviate_labs = c(Survived = TRUE, Age = 2)), newpage = FALSE, keep = TRUE, margin = c(right = 3), gp_labels = gpar(fontsize = 10)) popViewport() pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 2)) mosaic(Titanic, labeling_args = list(rep = c(Survived = FALSE, Age = FALSE)), newpage = FALSE, keep = TRUE, margin = c(left = 3), gp_labels = gpar(fontsize = 10)) popViewport() pushViewport(viewport(layout.pos.col = 1:2, layout.pos.row = 3)) pushViewport(viewport(width = 0.55)) mosaic(Titanic, labeling_args = list(rot_labels = c(bottom = 90, right = 0), offset_varnames = c(right = 1), offset_labels = c(right = 0.3)), margins = c(right = 4, bottom = 3), newpage = FALSE, keep = FALSE, gp_labels = gpar(fontsize = 10)) popViewport(3) @ \caption{Examples for possible labeling strategies for the Titanic data mosaic. Top left: default labeling (many labels overlap). Top right: with clipping turned on. Middle left: \texttt{Age} and \texttt{Survived} labels abbreviated. Middle right: \texttt{Age} labels not repeated. Bottom: \texttt{Age} and \texttt{Survived} labels rotated.} \label{fig:labels1} \end{center} \end{figure} \setkeys{Gin}{width=0.7\textwidth} We now proceed with a few more ``cosmetic'' features (which do not all produce satisfactory results for our sample data). A first simple, but effectful modification is to position all labels and variables left-aligned (see Figure~\ref{fig:labels2}, top left): <>= mosaic(Titanic, labeling_args = list(pos_varnames = "left", pos_labels = "left", just_labels = "left", rep = FALSE)) @ % \begin{figure}[h] % \begin{center} % <>= % <> % @ % \caption{Left-aligning.} % \label{fig:left} % \end{center} % \end{figure} \noindent Note that obviously we need to change the justification to \code{"left"} as well. We can achieve the same effect by using the convenience function \codefun{labeling\_left}: <>= mosaic(Titanic, labeling = labeling_left) @ \noindent Next, we show how to put all levels to the bottom and right margins, and all variable names to the top and left margins (see Figure~\ref{fig:labels2}, top right): <>= mosaic(Titanic, labeling_args = list(tl_labels = FALSE, tl_varnames = TRUE, abbreviate_labs = c(Survived = 1, Age = 3))) @ % \begin{figure}[p] % \begin{center} % <>= % <> % @ % \caption{Changes in the margins.} % \label{fig:margins} % \end{center} % \end{figure} \noindent The tl\_\var{foo} (``top left'') arguments are \code{TRUE} by default. Now, we will add boxes to the labels and additionally enable clipping (see Figure~\ref{fig:labels2}, bottom left): <>= mosaic(Titanic, labeling_args = list(tl_labels = FALSE, tl_varnames = TRUE, boxes = TRUE, clip = TRUE)) @ % \begin{figure}[p] % \begin{center} % <>= % <> % @ % \caption{Boxes and Clipping.} % \label{fig:boxes} % \end{center} % \end{figure} \noindent The values to \code{boxes} and \code{clip} are recycled for all dimensions. The result is pretty close to what calling \codefun{mosaic} with the \codefun{labeling\_cboxed} wrapper does, except that variables and levels, by default, are put to the top and to the left of the plot: <>= mosaic(Titanic, labeling = labeling_cboxed) @ \noindent Another variant is to put the variable names into the same line as the levels (see Figure~\ref{fig:labels2}, bottom right---clipping for \code{Survived} and \code{Age} is, additionally, disabled, and \code{Age} abbreviated): <>= mosaic(Titanic, labeling_args = list(tl_labels = TRUE, boxes = TRUE, clip = c(Survived = FALSE, Age = FALSE, TRUE), abbreviate_labs = c(Age = 4), labbl_varnames = TRUE), margins = c(left = 4, right = 1, 3)) @ % \begin{figure}[h] % \begin{center} % <>= % <> % @ % \caption{Variable names beneath levels, and clipping disabled for the % survival variable.} % \label{fig:labbl} % \end{center} % \end{figure} \noindent \code{labbl\_varnames} (``variable names to the bottom/left of the labels'') is a vector of logicals indicating the side for the variable names. The resulting layout is close to what \codefun{labeling\_lboxed} produces, except that variables and levels, by default, are left-aligned and put to the bottom and to the right of the plot: <>= mosaic(Titanic, labeling = labeling_lboxed, margins = c(right = 4, left = 1, 3)) @ \noindent A similar design is used by the \codefun{doubledecker} function. \setkeys{Gin}{width=\textwidth} \begin{figure}[p] \begin{center} <>= pushViewport(viewport(layout = grid.layout(ncol = 2, nrow = 2))) pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 1)) mosaic(Titanic, labeling_args = list(pos_varnames = "left", pos_labels = "left", just_labels = "left", rep = FALSE), newpage = FALSE, keep = TRUE, gp_labels = gpar(fontsize = 12)) popViewport() pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 1)) mosaic(Titanic, labeling_args = list(tl_labels = FALSE, tl_varnames = TRUE, abbreviate_labs = c(Survived = 1, Age = 3)), newpage = FALSE, keep = TRUE, margins = c(left = 4, right = 1, 3), gp_labels = gpar(fontsize = 12)) popViewport() pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 2)) mosaic(Titanic, labeling_args = list(tl_labels = FALSE, tl_varnames = TRUE, boxes = TRUE, clip = TRUE), newpage = FALSE, keep = TRUE, gp_labels = gpar(fontsize = 12)) popViewport() pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 2)) mosaic(Titanic, labeling_args = list(tl_labels = TRUE, boxes = TRUE, clip = c(Survived = FALSE, Age = FALSE, TRUE), labbl_varnames = TRUE, abbreviate_labs = c(Age = 4)), margins = c(left = 4, right = 1, 3), newpage = FALSE, keep = TRUE, gp_labels = gpar(fontsize = 12)) popViewport(2) @ \caption{Advanced strategies for labeling of the Titanic data. Top left: left aligning of both variable names and labels. Top right: changes in the margins (all variable names are in the top and left margins, and all labels in the bottom and right margins). Bottom left: clipping turned on, and boxes used. Bottom right: variable names beneath levels, clipping disabled for the survival and age variables, and \texttt{Age} abbreviated.} \label{fig:labels2} \end{center} \end{figure} \setkeys{Gin}{width=0.7\textwidth} \subsection[Labels in the cells]{Labels in the cells: \texttt{labeling\_cells()}} This labeling draws both variable names and levels in the cells. As an example, we use the \data{PreSex} data on pre- and extramarital sex and divorce (see Figure~\ref{fig:labels3}, top left): <>= mosaic(~ MaritalStatus + Gender, data = PreSex, labeling = labeling_cells) @ % \begin{figure}[h] % \begin{center} % <>= % <> % @ % \caption{Cell labeling for the \data{PreSex} data.} % \label{fig:cell} % \end{center} % \end{figure} \noindent In the case of narrow cells, it might be useful to abbreviate labels and/or variable names and turn off clipping (see Figure~\ref{fig:labels3}, top right): <>= mosaic(~ PremaritalSex + ExtramaritalSex, data = PreSex, labeling = labeling_cells(abbreviate_labels = TRUE, abbreviate_varnames = TRUE, clip = FALSE)) @ % \begin{figure}[h] % \begin{center} % <>= % <> % @ % \caption{Cell labeling for the \data{PreSex} data, labels abbreviated.} % \label{fig:cell2} % \end{center} % \end{figure} \noindent For some data, it might be convenient to combine cell labeling with border labeling as done by \codefun{labels\_conditional} (see Figure~\ref{fig:labels3}, bottom left): <>= mosaic(~ PremaritalSex + ExtramaritalSex | MaritalStatus + Gender, data = PreSex, labeling = labeling_conditional(abbreviate_varnames = TRUE, abbreviate_labels = TRUE, clip = FALSE, gp_text = gpar(col = "red"))) @ % \begin{figure}[h] % \begin{center} % <>= % <> % @ % \caption{Conditional labeling for the \data{PreSex} data, labels (in % red for clarity) abbreviated.} % \label{fig:conditional} % \end{center} % \end{figure} \noindent Additionally, the cell labeling allows the user to add arbitrary text to the cells by supplying a character array in the same shape as the data array to the \code{text} argument (cells with missing values are ignored). In the following example using the \code{Titanic} data, this is used to add all observed values greater than 5 to the cells after the mosaic has been plotted (see Figure~\ref{fig:labels3}, bottom right): <>= mosaic(Titanic, labeling_args = list(abbreviate_labs = c(Survived = 1, Age = 4)), pop = FALSE) tab <- ifelse(Titanic < 6, NA, Titanic) labeling_cells(text = tab, clip = FALSE)(Titanic) @ % \begin{figure}[h] % \begin{center} % <>= % <> % @ % \caption{User-supplied text (observed frequencies exceeding 5) % added to a mosaic display of the \data{Titanic} data.} % \label{fig:text} % \end{center} % \end{figure} \setkeys{Gin}{width=\textwidth} \begin{figure}[p] \begin{center} <>= grid.newpage() pushViewport(viewport(layout = grid.layout(ncol = 2, nrow = 2))) pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 1)) mosaic(~ MaritalStatus + Gender, data = PreSex, labeling = labeling_cells, newpage = FALSE, keep = TRUE, gp_labels = gpar(fontsize = 10)) popViewport() pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 1)) mosaic(~ PremaritalSex + ExtramaritalSex, data = PreSex, labeling = labeling_cells(abbreviate_labels = TRUE, abbreviate_varnames = TRUE, clip = FALSE), newpage = FALSE, keep = TRUE, gp_labels = gpar(fontsize = 10)) popViewport() pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 2)) mosaic(~ PremaritalSex + ExtramaritalSex | MaritalStatus + Gender, data = PreSex, labeling = labeling_conditional(abbreviate_varnames = TRUE, abbreviate_labels = TRUE, clip = FALSE, gp_text = gpar(col = "red")), newpage = FALSE, keep = TRUE, gp_labels = gpar(fontsize = 10)) popViewport() pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 2)) mosaic(Titanic, labeling_args = list(abbreviate_labs = c(Survived = 1, Age = 3)), pop = FALSE, newpage = FALSE, keep = TRUE, gp_labels = gpar(fontsize = 10)) tab <- ifelse(Titanic < 6, NA, Titanic) labeling_cells(text = tab, clip = FALSE)(Titanic) @ \caption{Cell labeling. Top left: default labeling using the \data{PreSex} data. Top right: abbreviated labels. Bottom left: conditional labeling (labels abbreviated and in red for clarity). Bottom right: user-supplied text (observed frequencies exceeding 5) added to a mosaic display of the \data{Titanic} data. Note that clipping is on by default (top left), and has explicitly been turned off for the three other plots.} \label{fig:labels3} \end{center} \end{figure} \setkeys{Gin}{width=0.7\textwidth} \subsection[A simple list of labels]{A simple list of labels: \texttt{labeling\_list()}} If problems with overlapping labels cannot satisfactorily resolved, the last remedy could be to simply list the levels below the plot (see Figure~\ref{fig:list}): <>= mosaic(Titanic, labeling = labeling_list, margins = c(bottom = 5)) @ \setkeys{Gin}{width=0.7\textwidth} \begin{figure}[p] \begin{center} <>= mosaic(Titanic, labeling = labeling_list, margins = c(bottom = 5), keep = TRUE) @ \caption{Labels indicated below the plot.} \label{fig:list} \end{center} \end{figure} \noindent The number of columns can be specified. \section{Spacing} \label{sec:spacing} Spacing of strucplot displays is customizable in a similar way than shading. The \code{spacing} argument of the \codefun{strucplot} function takes a list of \class{unit} vectors, one for each dimension, specifying the space between the tiles corresponding to the levels. Consider again the introductory example of the \data{Arthritis} data (Figure~\ref{fig:arthritis}). Since we are interested in the effect of the medicament in the placebo and treatment groups, a mosaic plot is certainly appropriate to visualize the three levels of \code{Improved} in the two \code{Treatment} strata. Another conceptual approach is to use spine plots with highlighting \citep{vcd:hummel:1996}. A spine plot is a variation of a bar plot where the heights of the bars are held constant, whereas the widths are used to represent the number of cases in each category. This is equivalent to a mosaic plot for a one-way table. If a second (indicator) variable is highlighted in a spine plot, we obtain a display equivalent to a simple mosaic display for a two-way table, except that no space between the levels of the highlighted variable is used. In the \data{Arthritis} example, we will highlight patients with \code{Marked} improvement in both groups. To obtain such a display within the strucplot framework, it suffices to set the space between the \code{Improved} tiles to 0 (see Figure~\ref{fig:artspine}): <>= (art <- structable(~Treatment + Improved, data = Arthritis, split_vertical = TRUE)) (my_spacing <- list(unit(0.5, "lines"), unit(c(0, 0), "lines"))) my_colors <- c("lightgray", "lightgray", "black") mosaic(art, spacing = my_spacing, gp = gpar(fill = my_colors, col = my_colors)) @ \begin{figure}[p] \begin{center} <>= <> @ \caption{Spine plot for the \data{Arthritis} data using the strucplot framework.} \label{fig:artspine} \end{center} \end{figure} \noindent Note that the default and formula methods for \codefun{mosaic} provide a convenience interface for highlighting. A similar plot (with slightly different shading) than the previous one can be obtained using: <>= mosaic(Improved ~ Treatment, data = Arthritis, split_vertical = TRUE) @ \noindent The strucplot framework also provides a set of spacing grapcon generators which compute suitable spacing objects for typical applications. The simplest spacing is \codefun{spacing\_equal} that uses the same space between all tiles (see Figure~\ref{fig:spacing}, top left): <>= mosaic(art, spacing = spacing_equal(unit(2, "lines"))) @ \noindent \codefun{spacing\_equal} is the default grapcon generator for two-dimensional tables. Slightly more flexible is \codefun{spacing\_dimequal} that allows an individual setting for each dimension (see Figure~\ref{fig:spacing}, top right): <>= mosaic(art, spacing = spacing_dimequal(unit(1:2, "lines"))) @ \noindent The default for multi-way contingency tables is \codefun{spacing\_increase} which uses increasing spaces for the dimensions. The user can specify a start value and the increase factor (see Figure~\ref{fig:spacing}, bottom left): <>= mosaic(art, spacing = spacing_increase(start = unit(0.5, "lines"), rate = 1.5)) @ \noindent For the arthritis example above, we could as well have used \codefun{spacing\_highlighting} which is similar to \codefun{spacing\_increase} but sets the spacing in the last splitting dimension to 0 (see Figure~\ref{fig:spacing}, bottom right): <>= mosaic(art, spacing = spacing_highlighting, gp = my_colors) @ \noindent Finally, \codefun{spacing\_conditional} can be used for visualizing conditional independence: it combines \codefun{spacing\_equal} (for the conditioned dimensions) and \codefun{spacing\_increase} (for the conditioning dimensions). As an example, consider Figure~\ref{fig:presex}: the spacing clearly allows to better distinguish the conditioning variables (\code{Gender} and \code{MaritalStatus}) from the conditioned variables (\code{PremaritalSex} and \code{ExtramaritalSex}). This spacing is the default when conditional variables are specified for a strucplot display (see Section \ref{sec:strucplot}). \setkeys{Gin}{width=\textwidth} \begin{figure}[p] \begin{center} <>= pushViewport(viewport(layout = grid.layout(ncol = 2, nrow = 2))) pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 1)) mosaic(art, spacing = spacing_equal(unit(2, "lines")), keep = TRUE, newpage = FALSE) popViewport() pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 1)) mosaic(art, spacing = spacing_dimequal(unit(c(0.5, 2), "lines")), keep = TRUE, newpage = FALSE) popViewport() pushViewport(viewport(layout.pos.col = 1, layout.pos.row = 2)) mosaic(art, spacing = spacing_increase(start = unit(0.3, "lines"), rate = 2.5), keep = TRUE, newpage = FALSE) popViewport() pushViewport(viewport(layout.pos.col = 2, layout.pos.row = 2)) mosaic(art, spacing = spacing_highlighting, keep = TRUE, newpage = FALSE) popViewport(2) @ \caption{Varying spacing for the Arthritis data. Top left: equal spacing for all dimensions. Top right: different spacings for individial dimensions. Bottom left: increasing spacing. Bottom right: spacing used for highlighting.} \label{fig:spacing} \end{center} \end{figure} \setkeys{Gin}{width=0.7\textwidth} \section{Example: Ovarian cancer survival} \label{sec:example} In the following, we demonstrate some of the described techniques in analyzing a data set originating from \citep{vcd:obel:1975} \cite[taken from][]{vcd:andersen:1991} about a retrospective study of ovary cancer carried out in 1973. Information was obtained from 299 women, who were operated for ovary cancer 10 years before. The data consists of four binary variables: the \code{stage} of the cancer at the time of operation (levels: \code{early}, \code{advanced}), the type of \code{operation} performed (\code{radical}, \code{limited}), the \code{survival} status after 10 years (\code{yes}, \code{no}), and \code{xray} indicating whether X-ray treatment was received (\code{yes}, \code{no}). The dataset in \pkg{vcd} comes pretabulated in a data frame, so we first create the four-way table: <>= tab <- xtabs(Freq ~ stage + operation + xray + survival, data = OvaryCancer) @ \noindent A ``flattened'' textual representation can be obtained using \codefun{structable}: <>= structable(survival ~ ., data = tab) @ \noindent A first overview can be obtained using a pairs plot (Figure~\ref{fig:ocpairs}): <>= dpa <- list(var_offset = 1.2, rot = -30, just_leveltext= "left") pairs(tab, diag_panel = pairs_barplot, diag_panel_args = dpa) @ \begin{figure}[h] \begin{center} <>= <> @ \caption{Pairs plot for the \data{OvaryCancer} data showing mosaic displays for all pairwise distributions and bar plots for all marginal distributions.} \label{fig:ocpairs} \end{center} \end{figure} \noindent The pairs plot, by default, creates mosaic displays for all pairwise variable combinations, and bar plots in the diagonal to visualize the absolute frequencies of the variables. The \texttt{var\_offset} argument modifies the offset of the (centered) variable names to avoid overlap with the bars. Additionally, we use the \texttt{rot} and the \texttt{just\_leveltext} arguments to rotate the level names, again to avoid their overlap. First, we consider the marginal distributions. The study design involved (nearly) the same number of survived (150) and deceased (149) patients. Similarly balanced, 158 cases were in an advanced and 141 in an early stage. Most patients (251, 84\%) were treated with a radical operation, and 186 (62\%) were submitted to X-ray treatment. Next, we inspect the two-way interaction of the influencing factors (\code{stage}, \code{operation}, and \code{xray}): the corresponding mosaics exhibit symmetric, regular shapes with aligned tiles, which indicate no marginal interaction between these variables. The same is true for the interactions of \code{survival} with \code{operation} and \code{xray}, respectively. Only the stage seems to influence survival: here, the tiles are ``shifted''. A different view on the data, focused on the influence of the explanatory variables on \code{Survival}, can be obtained using a doubledecker plot (Figure~\ref{fig:ocdoubledecker}): <>= doubledecker(survival ~ stage + operation + xray, data = tab) @ \begin{figure}[h] \begin{center} <>= <> @ \caption{Doubledecker plot for the \data{OvaryCancer} data showing the conditional distribution of X-ray, given operation, given stage, and with survival highlighted.} \label{fig:ocdoubledecker} \end{center} \end{figure} \noindent From a technical point of view, the display is constructed as a mosaic plot showing the conditional distribution of \code{survival}, given \code{xray}, given \code{operation}, given \code{stage}, with vertical splits for the conditioning variables and horizontal ones for \code{survival}. Additionally, there is zero space between the tiles of the last dimension and a binary shading is used for survived and deceased patients. Conceptually, this plot is interpreted as a mosaic plot of just the influencing variables, with \code{survival} highlighted in the tiles. Thus, the plot really shows the influence of the explanatory variables on \code{survival}. Clearly, the survival rate is higher among patients in an early stage, but neither radical operation nor X-ray treatment seem to improve the situation. From this exploratory phase, the survival rate seems to be slightly higher for patients who received a limited operation only, whereas the effect for X-ray treatment is less marked. To visualize inference results, we can make use of residual-based shadings, investigating log-linear models for the four-way table. Figure~\ref{fig:ocmosaicnull} visualizes the null model, where survival is independent from the combined effect of operation, X-ray treatment, and stage: <>= split <- c(TRUE, TRUE, TRUE, FALSE) mosaic(tab, expected = ~ survival + operation * xray * stage, split_vertical = split) @ \begin{figure}[p] \begin{center} <>= <> @ \caption{Mosaic plot for the \data{OvaryCancer} data, with residual-based shading for the (clearly rejected) null model (survival)(operation, X-ray, stage).} \label{fig:ocmosaicnull} \end{center} \end{figure} \noindent The model is clearly rejected ($p$-value: 0.000). From the exploratory phase of our analysis, we (only) suspect \code{stage} to be influential on the survival rate. A corresponding hypothesis is that \code{survival} be independent of \code{xray} and \code{operation}, given \code{stage}. The model is specified using the \texttt{expected} argument, either using the \codefun{loglin} interface or the \codefun{loglm} formula interface (the resulting mosaic plot is shown in Figure \ref{fig:ocmosaicstage}): <>= mosaic(tab, expected = ~ (survival + operation * xray) * stage, split_vertical = split) @ \begin{figure}[p] \begin{center} <>= <> @ \caption{Mosaic plot for the \data{OvaryCancer} data, with residual-based shading for the hypothesis of survival being independent of X-ray and operation, given stage. The hypothesis is not rejected.} \label{fig:ocmosaicstage} \end{center} \end{figure} \noindent Thus, based on this data, only pre-diagnosis seems to matter in ovarian cancer therapy. \section{Conclusion} \label{sec:conclusion} In this paper, we describe the ``strucplot'' framework for the visualization of multi-way contingency tables. Strucplot displays include popular basic plots such as mosaic, association, and sieve plots, integrated in a unified framework: all can be seen as visualizations of hierarchical conditional flat tables. Additionally, these core strucplot displays can be combined into more complex, specialized plots, such as pairs and trellis-like displays for visualizing conditional independence. Residual-based shadings permit the visualization of log-linear models and the results of independence tests. The framework's modular design allows flexible customization of the plots' graphical appearance, including shading, labeling, spacing, and legend, by means of graphical appearance control (``grapcon'') functions. These ``graphical hyperparameters'' are customized and created by generating functions. Our work includes a set of predefined grapcon generators for typical analysis tasks, and user-level extensions can easily be added. \bibliography{vcd} \begin{appendix} \section{Data sets} \label{sex:data} The data set names in the paper are those from the \proglang{R} system. In the following, we give a short description of each data set. \begin{description} \item[\texttt{Arthritis}] Data from a double-blind clinical trial investigating a new treatment for rheumatoid arthritis. Source: \cite{vcd:Koch+Edwards:1988}. Taken from: \cite{vcd:Friendly:2000}. Package: \pkg{vcd}. \item[\texttt{Bundesliga}] Results from the first German soccer league in the years 1995/6 \citep{vcd:Knorr-Held:1999} and 2001/2 (Collected by: Achim Zeileis). Package: \pkg{vcd}. \item[\texttt{HairEyeColor}] Distribution of hair and eye color and gender in 592 statistics students. The gender information is artificial. Source: \cite{vcd:Snee:1974}. Taken from: \cite{vcd:Friendly:2000}. Package: \pkg{datasets} (included in base \proglang{R}). \item[\texttt{OvaryCancer}] Data about a retrospective study of ovary cancer carried out in 1973. Information was obtained from 299 women, who were operated for ovary cancer 10 years before. Source: \cite{vcd:obel:1975}. Taken fromn: \cite{vcd:andersen:1991}. Package: \pkg{vcd}. \item[\texttt{PreSex}] Data on pre- and extra-marital sex and divorce. Source: \cite{vcd:thornes+collard:1979}. Taken from \cite{vcd:gilbert:1981}. Package: \pkg{vcd}. \item[\texttt{Titanic}] Information on the fate of passengers on the fatal maiden voyage of the ocean liner ``Titanic'', summarized according to economic status (class), gender (\code{Sex}), age and survival. Data originally collected by the British Board of Trade in their investigation of the sinking. Taken from: \cite{vcd:dawson:1995}. Package: \pkg{datasets} (included in base \proglang{R}). \item[\texttt{UCBAdmissions}] Aggregate data on applicants to graduate school at Berkeley for the six largest departments in 1973 classified by admission and gender. Source: \cite{vcd:Bickel+Hammel+O'Connell:1975}. Taken from: \cite{vcd:Friendly:2000}. Package: \pkg{datasets} (included in base \proglang{R}). \end{description} \end{appendix} \end{document} vcd/inst/NEWS.Rd0000644000175100001440000002441614671770650013110 0ustar hornikusers\name{NEWS} \title{News for Package \pkg{vcd}} \newcommand{\cpkg}{\href{https://CRAN.R-project.org/package=#1}{\pkg{#1}}} \section{Changes in version 1.4-13}{ \itemize{\item Minor bug fix in docs.} } \section{Changes in version 1.4-11}{ \itemize{\item add ORCID IDs} } \section{Changes in version 1.4-10}{ \itemize{\item cosmetic changes.} } \section{Changes in version 1.4-9}{ \itemize{ \item add \code{gp_axis} argument to \code{pairs_barplot()}. \item fix URLs in JSS references. } } \section{Changes in version 1.4-8}{ \itemize{ \item New argument \code{pdigits=} in \code{legend_resbased()} to specify the number of digits of p-values. } } \section{Changes in version 1.4-7}{ \itemize{ \item bugfix: highlighting was wrong since 1.4-5. It now correctly recycles the fill parameter along \emph{last} dimension (i.e., the dependent variable), in contrast to standard behavior of \code{mosaic()} } } \section{Changes in version 1.4-6}{ \itemize{ \item bugfix: doubledecker plot had wrong shading since 1.4-5. It now correctly recycles graphical parameters along \emph{last} dimension (i.e., the dependent variable), in contrast to standard behavior of mosaic(). } } \section{Changes in version 1.4-5}{ \itemize{ \item small internal change in \code{tile()} to account for new grid package. \item graphical parameters are now recycled along \emph{first} dimension. } } \section{Changes in version 1.4-4}{ \itemize{ \item Bugfix: \code{labeling_cells()} could not handle structable objects when called separately from \code{mosaic()}. \item \code{ternaryplot()} now has additional \code{dimnames_rot=} and \code{labels_rot=} arguments for changing the angle of the labels. \item The loddratio plot now suppresses labels in the 2x2x(strata) case. } } \section{Changes in version 1.4-3}{ \itemize{ \item Remove outdated inst/doc directory. } } \section{Changes in version 1.4-2}{ \itemize{ \item add \code{lines()} method for \code{loddsratio} objects. \item add \code{gpar()} argment to control confidence intervals in \code{distplot()}. } } \section{Changes in version 1.4-1}{ \itemize{ \item add imports for functions in recommended packages to NAMESPACE \item \code{shading_hcl} now also uses solid line type for \code{abs(residuals) < eps} like \code{shading_hsv()}. } } \section{Changes in version 1.4-0}{ \itemize{ \item Add \code{shading_Marimekko} and \code{shading_diagonal}. \item Add residual-based shading to \code{rootogram()}. \item Add \code{residuals()} method for \code{"goodfit"} objects. \item Add \code{grid_abline()} for convenience. \item Add P-values to the output print.Kappa() produces. \item Fix legend of \code{distplot()} in case of leveled plots. \item \code{cotab_agreementplot} panel function for plotting conditional (stratified) agreement charts added. \item \code{loddsratio} added as an extension of \code{oddsratio} for conditioned generalized odds ratios. The plot method is greatly enhanced, and structural zeros (missing values) are also accepted. \code{oddsratio} is now just an alias for \code{loddsratio}. \item Bug fix in \code{pairs.table()}: for \code{"conditional"} type, tables are now reordered so that the conditioning variables come \emph{first}. \item \code{cotab_loddsratio} panel function for plotting conditional log-odds ratios plots added. \item \code{assocstats} now handles strata (all but the first two dimensions). \item \code{sieve} now accepts a \code{scale=} argument. \item \code{binreg_plot()} added for (conditioned) binary regression plots \item Bug fix in \code{mosaic()}: using \code{highlighting=} and/or \code{condvars=} now not only reorders the table, but also the split information, so that both remain consistent. \item All plot functions now have an option to return the produced plot as a grid object for further use (e.g., in \code{mplot()}). \item \code{mplot()} added for combining multiple grid plots in a multi-panel-layout. \item \code{legend_grid} now allows more options for positioning, and an \code{inset} argument has been added for relative adjustments. } } \section{Changes in version 1.3-2}{ \itemize{ \item \code{Ord_plot()} gets \code{lwd}, \code{lty} and \code{col} arguments to control plotting of the OLS and WLS lines. \item \code{distplot()} gets an \code{lwd} argument. \item Changed default line types for \code{sieve} so that positive residuals are shown with solid lines, as per Friendly specifications. \item fixed problems with \code{pairs_strucplot()} type argument, particularly for \code{type="conditional"} \item Fixed error in \code{CoalMiners} data (missing group, labels switched) \item Change default area type for sieve plots to "area" } } \section{Changes in version 1.3-1}{ \itemize{ \item several namespace issues fixed } } \section{Changes in version 1.3-0}{ \itemize{ \item Bug fixed in \code{assoc()} \item \code{grid_legend()} extended for better finetuning of graphical parameters \item \code{legend_resbased()} better handles spacing for labels. \item \code{legend_resbased()} and \code{legend_fixed()} now allow changing the font family. \item default diagonal panel in \code{pairs()} is now set to \code{pairs_diagonal_mosaic()}, with alternating labels and frequencies shown on the bars. \item labeling is more customizable in \code{fourfold()} } } \section{Changes in version 1.2-13}{ \itemize{ \item \code{agreementplot()} now allows to add marginals to the plot \item \code{abbreviate} argument of \code{labeling_border()} renamed to \code{abbreviate_labs} to prevent name clash with \code{abbreviate_foo} args in \code{labeling_cells()} \item Several partial matches fixed in code } } \section{Changes in version 1.2-12}{ \itemize{ \item Bug fix: \code{assoc()} would not plot tables with 0 residuals \item Bug fix: \code{structable()} adds dimnames and dimname names if none are specified \item Bug fix: print error message when subsetting/selecting of structable objects using more than 2 indices \item \file{NEWS} file changed to .Rd format } } \section{Changes in version 1.2-11}{ \itemize{ \item Bug fix: \code{gamma} argument removed from \code{hcl2hex()} } } \section{Changes in version 1.2-10}{ \itemize{ \item Add aperm method for structable objects \item For use with \code{shading_Friendly()}, \code{shading_hsv()} now sets the line type of borders corresponding to \code{abs(residual) < eps} to \code{lty[1]} in addition to setting \code{color} to \code{line_color}. \item In \code{fourfold()}, modified default \code{colors[3:4]} for non-significant log odds ratios to be more visually distinct from the fully saturated \code{colors[5:6]} for significant ones. \item In \code{fourfold()}, allow the function to work with tables with more than 3 dimensions, by restructuring all strata dimensions into a single combined 3rd dimension. \item In \code{fourfold()}, modified defaults for \code{mfrow}/\code{mfcol} to give landscape display, \eqn{nr <= nc}, rather than \eqn{nr >= nc}. If \code{length(dim(x)) > 3}, set \code{nr=dim(x)[3]}. } } \section{Changes in version 1.2-9}{ \itemize{ \item Fixed \code{Ord_plot()} for devices where the default filling is \code{"white"} and not \code{"transparent"} by explicitly setting it to the latter. \item Bug fix in \code{as.table.structable()}, returning the table in a different order than defined in the structable object, confusing in particular \code{plot.structable()}. \item add parameter to \code{ternaryplot()} to control the positioning of the plot labels. } } \section{Changes in version 1.2-8}{ \itemize{ \item Small bug fixes in handling of some graphical parameters. } } \section{Changes in version 1.2-7}{ \itemize{ \item Corrected df handling in \code{goodfit()} with ML estimation: only non-zero cells are used. This is backward compatible with versions \eqn{<=} 1.2-4. \item Fixed bug in \code{goodfit()} for binomial distribution with specified \code{"size"} parameter (introduced in 1.2-5). } } \section{Changes in version 1.2-6}{ \itemize{ \item Small typo in doc of \code{co_table()}. } } \section{Changes in version 1.2-5}{ \itemize{ \item Bundesliga data set has been augmented with the results of the seasons 2006/7, 2007/8, 2008/9 (thanks to Torsten Hothorn). \item \code{goodfit()} was modified to treat zero cells better: \sQuote{Internal} zero cells (i.e., counts below the maximal observed count that did not occur in the sample) are retained (and not dropped as before). \sQuote{Trailing} zero cells (i.e., counts above the maximal observed count) are still not considered. The documentation now points out the problems with the minimum-chi-squared method in the latter situation. \item \code{sieve()} now accepts a \code{gp_tile} argument to control the appearance of the cells (apart from the sieve color) } } \section{Changes in version 1.2-4}{ \itemize{ \item Bug fix: labeling arguments were incorrectly handled when the options were not provided as named vector \item \code{ternaryplot()} now makes use of the \code{cex} argument also for the rendering of optional labels, if any } } \section{Changes in version 1.2-3}{ \itemize{ \item \file{hcl-colors.pdf} removed from source ball (vignette now in \cpkg{colorspace}) } } \section{Changes in version 1.2-2}{ \itemize{ \item \code{strucplot()} now accepts a \code{df} argument that is passed to the shading functions. Also, expected values are no longer computed if residuals are given. } } \section{Changes in version 1.2-1}{ \itemize{ \item Fixed a bug in labeling (incorrect handling of some parameters) } } \section{Changes in version 1.2-0}{ \itemize{ \item Moved color palettes from \cpkg{vcd} to \cpkg{colorspace}, including \code{vignette("hcl-colors")}. Package \cpkg{colorspace} is (as before) loaded automatically with \cpkg{vcd}. } } vcd/build/0000755000175100001440000000000014671771752012164 5ustar hornikusersvcd/build/vignette.rds0000644000175100001440000000067114671771752014527 0ustar hornikusersSMO1]5#O@.޼!İhnKKOrpv$;}әyo:AD!%.UJ<8)M& ujlJS~mE>RxXbO=F. i):T_47Ɛij.sҔ \ ̨ȸ$g~u8?YDU{$\1J'qD8vP;YmǍImumϩ֒5 yj&E9LSWCGmmu)eGNRS`\dgf?jc |=QÇRCA 5 eXz5b4l C_EXڄoOu8x*H:/|~#%+v.rKkyn !]vcd/build/partial.rdb0000644000175100001440000000007414671771713014307 0ustar hornikusersb```b`a 00 FN ͚Z d@$$7vcd/man/0000755000175100001440000000000014671771705011636 5ustar hornikusersvcd/man/Suicide.Rd0000755000175100001440000000211711150520606013473 0ustar hornikusers\name{Suicide} \alias{Suicide} \docType{data} \title{Suicide Rates in Germany} \description{ Data from Heuer (1979) on suicide rates in West Germany classified by age, sex, and method of suicide. } \usage{ data("Suicide") } \format{ A data frame with 306 observations and 6 variables. \describe{ \item{Freq}{frequency of suicides.} \item{sex}{factor indicating sex (male, female).} \item{method}{factor indicating method used.} \item{age}{age (rounded).} \item{age.group}{factor. Age classified into 5 groups.} \item{method2}{factor indicating method used (same as \code{method} but some levels are merged).} } } \references{ J. Heuer (1979), \emph{Selbstmord bei Kindern und Jugendlichen}. Ernst Klett Verlag, Stuttgart. M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \source{ Michael Friendly (2000), Visualizing Categorical Data: \url{http://euclid.psych.yorku.ca/ftp/sas/vcd/catdata/suicide.sas} } \examples{ data("Suicide") structable(~ sex + method2 + age.group, data = Suicide) } \keyword{datasets} vcd/man/UKSoccer.Rd0000755000175100001440000000174411150520606013571 0ustar hornikusers\name{UKSoccer} \alias{UKSoccer} \docType{data} \title{UK Soccer Scores} \description{ Data from Lee (1997), on the goals scored by Home and Away teams in the Premier Football League, 1995/6 season. } \usage{ data("UKSoccer") } \format{ A 2-dimensional array resulting from cross-tabulating the number of goals scored in 380 games. The variables and their levels are as follows: \tabular{rll}{ No \tab Name \tab Levels \cr 1 \tab Home \tab 0, 1, \dots, 4 \cr 2 \tab Away \tab 0, 1, \dots, 4 } } \references{ A. J. Lee (1997), Modelling scores in the Premier League: Is Manchester United really the best?, \emph{Chance}, \bold{10}(1), 15--19. M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \source{ M. Friendly (2000), Visualizing Categorical Data, page 27. } \seealso{ \code{\link{Bundesliga}} } \examples{ data("UKSoccer") mosaic(UKSoccer, gp = shading_max, main = "UK Soccer Scores") } \keyword{datasets} vcd/man/plot.loddsratio.Rd0000755000175100001440000001526612554433622015252 0ustar hornikusers\name{plot.loddsratio} \alias{plot.loddsratio} \alias{lines.loddsratio} \title{Plotting (Log) Odds Ratios} \description{ Produces a (conditional) line plot of extended (log) odds ratios. } \usage{ \method{plot}{loddsratio}(x, baseline = TRUE, gp_baseline = gpar(lty = 2), lines = TRUE, lwd_lines = 3, confidence = TRUE, conf_level = 0.95, lwd_confidence = 2, whiskers = 0, transpose = FALSE, col = NULL, cex = 0.8, pch = NULL, bars = NULL, gp_bars = gpar(fill = "lightgray", alpha = 0.5), bar_width = unit(0.05, "npc"), legend = TRUE, legend_pos = "topright", legend_inset = c(0, 0), legend_vgap = unit(0.5, "lines"), gp_legend_frame = gpar(lwd = 1, col = "black"), gp_legend_title = gpar(fontface = "bold"), gp_legend = gpar(), legend_lwd = 1, legend_size = 1, xlab = NULL, ylab = NULL, xlim = NULL, ylim = NULL, main = NULL, gp_main = gpar(fontsize = 12, fontface = "bold"), newpage = TRUE, pop = FALSE, return_grob = FALSE, add = FALSE, prefix = "", \dots) \method{lines}{loddsratio}(x, legend = FALSE, confidence = FALSE, cex = 0, \dots) } \arguments{ \item{x}{an object of class \code{loddsratio}.} \item{baseline}{if \code{TRUE}, a dashed line is plotted at a value of 1 (in case of odds) or 0 (in case of log-odds).} \item{gp_baseline}{object of class \code{"gpar"} used for the baseline.} \item{lines}{if \code{TRUE}, the points are connected by lines (only sensible if the variable represented by the x-axis is ordinal).} \item{lwd_lines}{Width of the connecting lines (in \code{char} units).} \item{confidence}{logical; shall confindence intervals be plotted?} \item{conf_level}{confidence level used for confidence intervals.} \item{lwd_confidence}{Line width of the confidence interval bars (in \code{char} units).} \item{whiskers}{width of the confidence interval whiskers.} \item{transpose}{if \code{TRUE}, the plot is transposed.} \item{col}{character vector specifying the colors of the fitted lines, by default chosen with \code{\link[colorspace]{rainbow_hcl}}.} \item{cex}{size of the plot symbols (in lines).} \item{pch}{character or numeric vector of symbols used for plotting the (possibly conditioned) observed values, recycled as needed.} \item{bars}{logical; shall bars be plotted additionally to the points? Defaults to \code{TRUE} in case of only one conditioning variable.} \item{gp_bars}{object of class \code{"gpar"} used for the bars.} \item{bar_width}{Width of the bars, if drawn.} \item{legend}{logical; if \code{TRUE} (default), a legend is drawn.} \item{legend_pos}{numeric vector of length 2, specifying x and y coordinates of the legend, or a character string (e.g., \code{"topleft"}, \code{"center"} etc.). Defaults to \code{"topleft"} if the fitted curve's slope is positive, and \code{"topright"} else.} \item{legend_inset}{numeric vector or length 2 specifying the inset from the legend's x and y coordinates in npc units.} \item{legend_vgap}{vertical space between the legend's line entries.} \item{gp_legend_frame}{object of class \code{"gpar"} used for the legend frame.} \item{gp_legend_title}{object of class \code{"gpar"} used for the legend title.} \item{gp_legend}{object of class \code{"gpar"} used for the legend defaults.} \item{legend_lwd}{line width used in the legend for the different groups.} \item{legend_size}{size used for the group symbols (in char units).} \item{xlab}{label for the x-axis. Defaults to \code{"Strata"} if \code{transpose} is \code{FALSE}.} \item{ylab}{label for the y-axis. Defaults to \code{"Strata"} if \code{transpose} is \code{TRUE}.} \item{xlim}{x-axis limits. Ignored if \code{transpose} is \code{FALSE}.} \item{ylim}{y-axis limits. Ignored if \code{transpose} is \code{TRUE}.} \item{main}{user-specified main title.} \item{gp_main}{object of class \code{"gpar"} used for the main title.} \item{newpage}{logical; if \code{TRUE}, the plot is drawn on a new page.} \item{pop}{logical; if \code{TRUE}, all newly generated viewports are popped after plotting.} \item{return_grob}{logical. Should a snapshot of the display be returned as a grid grob?} \item{add}{logical; should the plot added to an existing log odds ratio plot?} \item{prefix}{character string used as prefix for the viewport name.} \item{\dots}{other graphics parameters (see \code{\link{par}}).} } \value{ if \code{return_grob} is \code{TRUE}, a grob object corresponding to the plot. \code{NULL} (invisibly) else. } \details{ The function basically produces conditioned line plots of the (log) odds ratios structure provided in \code{x}. The \code{lines} method can be used to overlay different plots (for example, observed and expected values). \code{\link{cotabplot}} can be used for stratified analyses (see examples). } \references{ M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \author{ David Meyer \email{David.Meyer@R-project.org} } \seealso{ \code{\link{loddsratio}} } \examples{ ## 2 x 2 x k cases data(CoalMiners, package = "vcd") lor_CM <- loddsratio(CoalMiners) plot(lor_CM) lor_CM_df <- as.data.frame(lor_CM) # fit linear models using WLS age <- seq(20, 60, by = 5) lmod <- lm(LOR ~ age, weights = 1 / ASE^2, data = lor_CM_df) grid.lines(seq_along(age), fitted(lmod), gp = gpar(col = "blue", lwd = 2), default.units = "native") qmod <- lm(LOR ~ poly(age, 2), weights = 1 / ASE^2, data = lor_CM_df) grid.lines(seq_along(age), fitted(qmod), gp = gpar(col = "red", lwd = 2), default.units = "native") ## 2 x k x 2 lor_Emp <-loddsratio(Employment) plot(lor_Emp) ## 4 way tables data(Punishment, package = "vcd") mosaic(attitude ~ age + education + memory, data = Punishment, highlighting_direction="left", rep = c(attitude = FALSE)) # visualize the log odds ratios, by education plot(loddsratio(~ attitude + memory | education, data = Punishment)) # visualize the log odds ratios, by age plot(loddsratio(~ attitude + memory | age, data = Punishment)) # visualize the log odds ratios, by age and education plot(loddsratio(~ attitude + memory | age + education, data = Punishment)) # same, transposed plot(loddsratio(~ attitude + memory | age + education, data = Punishment), transpose = TRUE) # alternative visualization methods image(loddsratio(Freq ~ ., data = Punishment)) tile(loddsratio(Freq ~ ., data = Punishment)) ## cotabplots for more complex tables cotabplot(Titanic, cond = c("Age","Sex"), panel = cotab_loddsratio) cotabplot(Freq ~ opinion + grade + year | gender, data = JointSports, panel = cotab_loddsratio) cotabplot(Freq ~ opinion + grade | year + gender, data = JointSports, panel = cotab_loddsratio) } \keyword{category} vcd/man/table2d_summary.Rd0000755000175100001440000000232712456227164015220 0ustar hornikusers\name{table2d_summary} \alias{table2d_summary} \alias{print.table2d_summary} \title{Summary of a 2-way Table} \description{ Prints a 2-way contingency table along with percentages, marginal, and conditional distributions. } \usage{ table2d_summary(object, margins = TRUE, percentages = FALSE, conditionals = c("none", "row", "column"), chisq.test = TRUE, \dots) } \arguments{ \item{object}{a \eqn{r \times c}{r x c}-contingency table} \item{margins}{if \code{TRUE}, marginal distributions are computed.} \item{percentages}{if \code{TRUE}, relative frequencies are computed.} \item{conditionals}{if not \code{"none"}, the conditional distributions, given the row/column factor, are computed.} \item{chisq.test}{if \code{TRUE}, a chi-squared test of independence is carried out.} \item{\dots}{currently not used.} } \value{ Returns invisibly a \eqn{r \times c \times k}{r x c x k} table, \eqn{k} depending on the amount of choices (at most 3). } \author{ David Meyer \email{David.Meyer@R-project.org} } \seealso{ \code{\link{mar_table}}, \code{\link{prop.table}}, \code{\link{independence_table}} } \examples{ data("UCBAdmissions") table2d_summary(margin.table(UCBAdmissions, 1:2)) } \keyword{category} vcd/man/VonBort.Rd0000644000175100001440000000256414246371504013514 0ustar hornikusers\name{VonBort} \alias{VonBort} \docType{data} \title{Von Bortkiewicz Horse Kicks Data} \description{ Data from von Bortkiewicz (1898), given by Andrews & Herzberg (1985), on number of deaths by horse or mule kicks in 14 corps of the Prussian army. } \usage{ data("VonBort") } \format{ A data frame with 280 observations and 4 variables. \describe{ \item{deaths}{number of deaths.} \item{year}{year of the deaths.} \item{corps}{factor indicating the corps.} \item{fisher}{factor indicating whether the corresponding corps was considered by Fisher (1925) or not.} } } \references{ D. F. Andrews & A. M. Herzberg (1985), \emph{Data: A Collection of Problems from Many Fields for the Student and Research Worker}. Springer-Verlag, New York, NY. R. A. Fisher (1925), \emph{Statistical Methods for Research Workers}. Oliver & Boyd, London. L. von Bortkiewicz (1898), \emph{Das Gesetz der kleinen Zahlen}. Teubner, Leipzig. M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \source{ Michael Friendly (2000), Visualizing Categorical Data: \url{http://euclid.psych.yorku.ca/ftp/sas/vcd/catdata/vonbort.sas} } \seealso{ \code{\link{HorseKicks}} for a popular subsample. } \examples{ data("VonBort") ## HorseKicks data xtabs(~ deaths, data = VonBort, subset = fisher == "yes") } \keyword{datasets} vcd/man/VisualAcuity.Rd0000755000175100001440000000231212472413512014532 0ustar hornikusers\name{VisualAcuity} \alias{VisualAcuity} \docType{data} \title{Visual Acuity in Left and Right Eyes} \description{ Data from Kendall & Stuart (1961) on unaided vision among 3,242 men and 7,477 women, all aged 30-39 and employed in the U.K. Royal Ordnance factories 1943-1946. } \usage{ data("VisualAcuity") } \format{ A data frame with 32 observations and 4 variables. \describe{ \item{Freq}{frequency of visual acuity measurements.} \item{right}{visual acuity on right eye.} \item{left}{visual acuity on left eye.} \item{gender}{factor indicating gender of patient.} } } \references{ M. G. Kendall & A. Stuart (1961), \emph{The Advanced Theory of Statistics}, Vol. 2. Griffin, London. M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \source{ M. Friendly (2000), Visualizing Categorical Data: \url{http://euclid.psych.yorku.ca/ftp/sas/vcd/catdata/vision.sas} } \examples{ data("VisualAcuity") structable(~ gender + left + right, data = VisualAcuity) sieve(Freq ~ left + right | gender, data = VisualAcuity, shade = TRUE) cotabplot(Freq ~ left + right | gender, data = VisualAcuity, panel = cotab_agreementplot) } \keyword{datasets} vcd/man/Punishment.Rd0000644000175100001440000000300314543517312014241 0ustar hornikusers\name{Punishment} \alias{Punishment} \docType{data} \title{Corporal Punishment Data} \description{ Data from a study of the Gallup Institute in Denmark in 1979 about the attitude of a random sample of 1,456 persons towards corporal punishment of children. } \usage{ data("Punishment") } \format{ A data frame with 36 observations and 5 variables. \describe{ \item{Freq}{frequency.} \item{attitude}{factor indicating attitude: (no, moderate) punishment of children.} \item{memory}{factor indicating whether the person had memories of corporal punishment as a child (yes, no).} \item{education}{factor indicating highest level of education (elementary, secondary, high).} \item{age}{factor indicating age group in years (15-24, 25-39, 40-).} } } \note{Anderson (1991) erroneously indicates the total sum of respondents to be 783.} \references{ E. B. Andersen (1991), \emph{The Statistical Analysis of Categorical Data}. 2nd edition. Springer-Verlag, Berlin. } \source{ E. B. Andersen (1991), The Statistical Analysis of Categorical Data, pages 207--208. } \examples{ data("Punishment", package = "vcd") pun <- xtabs(Freq ~ memory + attitude + age + education, data = Punishment) ## model: ~ (memory + attitude) * age * education ## use maximum sum-of-squares test/shading cotabplot(~ memory + attitude | age + education, data = pun, panel = cotab_coindep, panel_args = list( n = 5000, type = "assoc", test = "maxchisq", interpolate = 1:2)) } \keyword{datasets} vcd/man/struc_mosaic.Rd0000755000175100001440000000612214133457341014612 0ustar hornikusers\name{struc_mosaic} \alias{struc_mosaic} \title{Core-generating Function for Mosaic Plots} \description{ Core-generating function for \code{strucplot} returning a function producing mosaic plots. } \usage{ struc_mosaic(zero_size = 0.5, zero_split = FALSE, zero_shade = TRUE, zero_gp = gpar(col = 0), panel = NULL) } \arguments{ \item{zero_size}{size of the bullets used for zero-entries in the contingency table (if 0, no bullets are drawn).} \item{zero_split}{logical controlling whether zero cells should be further split. If \code{FALSE} and \code{zero_shade} is \code{FALSE}, only one bullet is drawn (centered) for unsplit zero cells. If \code{FALSE} and \code{zero_shade} is \code{TRUE}, a bullet for each zero cell is drawn to allow, e.g., residual-based shadings to be effective also for zero cells.} \item{zero_shade}{logical controlling whether zero bullets should be shaded.} \item{zero_gp}{object of class \code{"gpar"} used for zero bullets in case they are \emph{not} shaded.} \item{panel}{Optional function with arguments: \code{residuals}, \code{observed}, \code{expected}, \code{index}, \code{gp}, and \code{name} called by the \code{struc_mosaic} workhorse for each tile that is drawn in the mosaic. \code{index} is an integer vector with the tile's coordinates in the contingency table, \code{gp} a \code{gpar} object for the tile, and \code{name} a label to be assigned to the drawn grid object.} } \details{ This function is usually called by \code{\link{strucplot}} (typically when called by \code{\link{mosaic}}) and returns a function used by \code{\link{strucplot}} to produce mosaic plots. } \value{ A function with arguments: \item{residuals}{table of residuals.} \item{observed}{table of observed values.} \item{expected}{not used by \code{struc_mosaic}.} \item{spacing}{object of class \code{"unit"} specifying the space between the tiles.} \item{gp}{list of \code{gpar} objects used for the drawing the tiles.} \item{split_vertical}{vector of logicals indicating, for each dimension of the table, the split direction.} } \author{ David Meyer \email{David.Meyer@R-project.org} } \seealso{ \code{\link{mosaic}}, \code{\link{strucplot}}, \code{\link{structable}} } \references{ Cohen, A. (1980), On the graphical display of the significant components in a two-way contingency table. \emph{Communications in Statistics---Theory and Methods}, \bold{A9}, 1025--1041. Friendly, M. (1992), Graphical methods for categorical data. \emph{SAS User Group International Conference Proceedings}, \bold{17}, 190--200. \url{http://datavis.ca/papers/sugi/sugi17.pdf} Meyer, D., Zeileis, A., and Hornik, K. (2006), The strucplot framework: Visualizing multi-way contingency tables with \pkg{vcd}. \emph{Journal of Statistical Software}, \bold{17(3)}, 1-48. \doi{10.18637/jss.v017.i03} and available as \code{vignette("strucplot")}. } \examples{ ## Titanic data data("Titanic") ## mosaic plot with large zeros strucplot(Titanic, core = struc_mosaic(zero_size = 1)) } \keyword{hplot} vcd/man/tile.Rd0000755000175100001440000001237012466747674013100 0ustar hornikusers\name{tile} \alias{tile} \alias{tile.default} \alias{tile.formula} \title{Tile Plot} \description{ Plots a tile display. } \usage{ \method{tile}{default}(x, tile_type = c("area", "squaredarea", "height", "width"), halign = c("left", "center", "right"), valign = c("bottom", "center", "top"), split_vertical = NULL, shade = FALSE, spacing = spacing_equal(unit(1, "lines")), set_labels = NULL, margins = unit(3, "lines"), keep_aspect_ratio = FALSE, legend = NULL, legend_width = NULL, squared_tiles = TRUE, main = NULL, sub = NULL, ...) \method{tile}{formula}(formula, data, \dots, main = NULL, sub = NULL, subset = NULL, na.action = NULL) } \arguments{ \item{x}{a contingency table, or an object coercible to one.} \item{formula}{a formula specifying the variables used to create a contingency table from \code{data}}. \item{data}{either a data frame, or an object of class \code{"table"} or \code{"ftable"}.} \item{subset}{an optional vector specifying a subset of observations to be used.} \item{na.action}{a function which indicates what should happen when the data contain \code{NA}s. Ignored if \code{data} is a contingency table.} \item{tile_type}{character string indicating how the tiles should reflect the table frequencies (see details).} \item{halign, valign}{character string specifying the horizontal and vertical alignment of the tiles.} \item{split_vertical}{vector of logicals of length \eqn{k}, where \eqn{k} is the number of margins of \code{x} (values are recycled as needed). A \code{TRUE} component indicates that the tile(s) of the corresponding dimension should be split vertically, \code{FALSE} means horizontal splits. Default is \code{FALSE.}} \item{spacing}{spacing object, spacing function, or corresponding generating function (see \code{\link{strucplot}} for more information).} \item{set_labels}{An optional character vector with named components replacing the so-specified variable names. The component names must exactly match the variable names to be replaced.} \item{shade}{logical specifying whether shading should be enabled or not (see \code{\link{strucplot}}).} \item{margins}{either an object of class \code{"unit"} of length 4, or a numeric vector of length 4. The elements are recycled as needed. The four components specify the top, right, bottom, and left margin of the plot, respectively. When a numeric vector is supplied, the numbers are interpreted as \code{"lines"} units. In addition, the unit or numeric vector may have named arguments (\samp{top}, \samp{right}, \samp{bottom}, and \samp{left}), in which case the non-named arguments specify the default values (recycled as needed), overloaded by the named arguments.} \item{legend}{either a legend-generating function, or a legend function (see details and \code{\link{legends}}), or a logical. If \code{legend} is \code{NULL} or \code{TRUE} and \code{gp} is a function or missing, legend defaults to \code{\link{legend_resbased}}. } \item{legend_width}{An object of class \code{"unit"} of length 1 specifying the width of the legend (if any). Default: 5 lines.} \item{keep_aspect_ratio}{logical indicating whether the aspect ratio should be fixed or not. The default is \code{FALSE} to enable the creation of squared tiles.} \item{squared_tiles}{logical indicating whether white space should be added as needed to rows or columns to obtain squared tiles in case of an unequal number of row and column labels.} \item{main, sub}{either a logical, or a character string used for plotting the main (sub) title. If logical and \code{TRUE}, the name of the \code{data} object is used.} \item{\dots}{Other arguments passed to \code{\link{strucplot}}} } \details{ A tile plot is a matrix of tiles. For each tile, either the \code{"width"}, \code{"height"}, \code{"area"}, or squared area is proportional to the corresponding entry. The first three options allow column-wise, row-wise and overall comparisons, respectively. The last variant allows to compare the tiles both column-wise and row-wise, considering either the width or the height, respectively. In contrast to other high-level strucplot functions, \code{tile} also accepts a table with duplicated levels (see examples). In this case, artificial dimnames will be created, and the actual ones are drawn using \code{set_labels}. Note that multiway-tables are first \dQuote{flattened} using \code{structable}. } \value{ The \code{"structable"} visualized is returned invisibly. } \author{ David Meyer \email{David.Meyer@R-project.org} } \seealso{ \code{\link{assoc}}, \code{\link{strucplot}}, \code{\link{mosaic}}, \code{\link{structable}}, } \examples{ data("Titanic") ## default plot tile(Titanic) tile(Titanic, type = "expected") tile(Titanic, shade = TRUE) ## some variations tile(Titanic, tile_type = "squaredarea") tile(Titanic, tile_type = "width", squared_tiles = FALSE) tile(Titanic, tile_type = "height", squared_tiles = FALSE) tile(Titanic, tile_type = "area", halign = "center", valign = "center") ## repeat levels tile(Titanic[,,,c(1,2,1,2)]) } \keyword{hplot} vcd/man/HorseKicks.Rd0000644000175100001440000000247614246371504014172 0ustar hornikusers\name{HorseKicks} \alias{HorseKicks} \docType{data} \title{Death by Horse Kicks} \description{ Data from von Bortkiewicz (1898), given by Andrews & Herzberg (1985), on number of deaths by horse or mule kicks in 10 (of 14 reported) corps of the Prussian army. 4 corps were not considered by Fisher (1925) as they had a different organization. This data set is a popular subset of the \code{\link{VonBort}} data. } \usage{ data("HorseKicks") } \format{ A 1-way table giving the number of deaths in 200 corps-years. The variable and its levels are \tabular{rll}{ No \tab Name \tab Levels \cr 1 \tab nDeaths \tab 0, 1, \dots, 4 \cr } } \references{ D. F. Andrews & A. M. Herzberg (1985), \emph{Data: A Collection of Problems from Many Fields for the Student and Research Worker}. Springer-Verlag, New York, NY. R. A. Fisher (1925), \emph{Statistical Methods for Research Workers}. Oliver & Boyd, London. L. von Bortkiewicz (1898), \emph{Das Gesetz der kleinen Zahlen}. Teubner, Leipzig. M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \source{ Michael Friendly (2000), Visualizing Categorical Data, page 18. } \seealso{ \code{\link{VonBort}} } \examples{ data("HorseKicks") gf <- goodfit(HorseKicks) summary(gf) plot(gf) } \keyword{datasets} vcd/man/MSPatients.Rd0000644000175100001440000000351214246371504014144 0ustar hornikusers\name{MSPatients} \alias{MSPatients} \docType{data} \title{Diagnosis of Multiple Sclerosis} \description{ Data from Westlund & Kurland (1953) on the diagnosis of multiple sclerosis (MS): two samples of patients, one from Winnipeg and one from New Orleans, were each rated by two neurologists (one from each city) in four diagnostic categories. } \usage{ data("MSPatients") } \format{ A 3-dimensional array resulting from cross-tabulating 218 observations on 3 variables. The variables and their levels are as follows: \tabular{rll}{ No \tab Name \tab Levels \cr 1 \tab New Orleans Neurologist \tab Certain, Probable, Possible, Doubtful \cr 2 \tab Winnipeg Neurologist \tab Certain, Probable, Possible, Doubtful \cr 3 \tab Patients \tab Winnipeg, New Orleans } } \references{ K. B. Westlund & L. T. Kurland (1953), Studies on multiple sclerosis in Winnipeg, Manitoba and New Orleans, Louisiana, \emph{American Journal of Hygiene}, \bold{57}, 380--396. M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \source{M. Friendly (2000), Visualizing Categorical Data: \url{http://euclid.psych.yorku.ca/ftp/sas/vcd/catdata/msdiag.sas} } \examples{ data("MSPatients") \dontrun{ ## best visualized using a resized device, e.g. using: ## get(getOption("device"))(width = 12) pushViewport(viewport(layout = grid.layout(ncol = 2))) pushViewport(viewport(layout.pos.col = 1)) popViewport() pushViewport(viewport(layout.pos.col = 2)) popViewport(2) dev.off() } ## alternative, more convenient way mplot( agreementplot(t(MSPatients[,,1]), return_grob = TRUE, main = "Winnipeg Patients"), agreementplot(t(MSPatients[,,2]), return_grob = TRUE, main = "New Orleans Patients") ) ## alternatively, use cotabplot: cotabplot(MSPatients, panel = cotab_agreementplot) } \keyword{datasets} vcd/man/cotab_panel.Rd0000755000175100001440000000744014133457265014377 0ustar hornikusers\name{cotab_panel} \alias{cotab_mosaic} \alias{cotab_assoc} \alias{cotab_sieve} \alias{cotab_loddsratio} \alias{cotab_agreementplot} \alias{cotab_coindep} \alias{cotab_fourfold} \title{Panel-generating Functions for Contingency Table Coplots} \description{ Panel-generating functions visualizing contingency tables that can be passed to \code{cotabplot}. } \usage{ cotab_mosaic(x = NULL, condvars = NULL, \dots) cotab_assoc(x = NULL, condvars = NULL, ylim = NULL, \dots) cotab_sieve(x = NULL, condvars = NULL, \dots) cotab_loddsratio(x = NULL, condvars = NULL, \dots) cotab_agreementplot(x = NULL, condvars = NULL, \dots) cotab_fourfold(x = NULL, condvars = NULL, \dots) cotab_coindep(x, condvars, test = c("doublemax", "maxchisq", "sumchisq"), level = NULL, n = 1000, interpolate = c(2, 4), h = NULL, c = NULL, l = NULL, lty = 1, type = c("mosaic", "assoc"), legend = FALSE, ylim = NULL, \dots) } \arguments{ \item{x}{a contingency tables in array form.} \item{condvars}{margin name(s) of the conditioning variables.} \item{ylim}{y-axis limits for \code{assoc} plot. By default this is computed from \code{x}.} \item{test}{character indicating which type of statistic should be used for assessing conditional independence.} \item{level,n,h,c,l,lty,interpolate}{variables controlling the HCL shading of the residuals, see \code{\link{shadings}} for more details.} \item{type}{character indicating which type of plot should be produced.} \item{legend}{logical. Should a legend be produced in each panel?} \item{\dots}{further arguments passed to the plotting function (such as \code{\link{mosaic}} or \code{\link{assoc}} or \code{\link{sieve}} respectively).} } \details{ These functions of class \code{"panel_generator"} are panel-generating functions for use with \code{\link{cotabplot}}, i.e., they return functions with the interface \code{panel(x, condlevels)} required for \code{cotabplot}. The functions produced by \code{cotab_mosaic}, \code{cotab_assoc} and \code{cotab_sieve} essentially only call \code{co_table} to produce the conditioned table and then call \code{\link{mosaic}}, \code{\link{assoc}} or \code{\link{sieve}} respectively with the arguments specified. The function \code{cotab_coindep} is similar but additionally chooses an appropriate residual-based shading visualizing the associated conditional independence model. The conditional independence test is carried out via \code{\link{coindep_test}} and the shading is set up via \code{\link{shading_hcl}}. A description of the underlying ideas is given in Zeileis, Meyer, Hornik (2005). } \seealso{ \code{\link{cotabplot}}, \code{\link{mosaic}}, \code{\link{assoc}}, \code{\link{sieve}}, \code{\link{co_table}}, \code{\link{coindep_test}}, \code{\link{shading_hcl}} } \references{ Meyer, D., Zeileis, A., and Hornik, K. (2006), The strucplot framework: Visualizing multi-way contingency tables with \pkg{vcd}. \emph{Journal of Statistical Software}, \bold{17(3)}, 1-48. \doi{10.18637/jss.v017.i03} and available as \code{vignette("strucplot")}. Zeileis, A., Meyer, D., Hornik K. (2007), \emph{Residual-based shadings for visualizing (conditional) independence}, \emph{Journal of Computational and Graphical Statistics}, \bold{16}, 507--525. } \author{ Achim Zeileis \email{Achim.Zeileis@R-project.org} } \examples{ data("UCBAdmissions") cotabplot(~ Admit + Gender | Dept, data = UCBAdmissions) cotabplot(~ Admit + Gender | Dept, data = UCBAdmissions, panel = cotab_assoc) cotabplot(~ Admit + Gender | Dept, data = UCBAdmissions, panel = cotab_fourfold) ucb <- cotab_coindep(UCBAdmissions, condvars = "Dept", type = "assoc", n = 5000, margins = c(3, 1, 1, 3)) cotabplot(~ Admit + Gender | Dept, data = UCBAdmissions, panel = ucb) } \keyword{hplot} vcd/man/assoc.Rd0000644000175100001440000002256314541371400013225 0ustar hornikusers\name{assoc} \alias{assoc} \alias{assoc.default} \alias{assoc.formula} \title{Extended Association Plots} \description{ Produce an association plot indicating deviations from a specified independence model in a possibly high-dimensional contingency table. } \usage{ \method{assoc}{default}(x, row_vars = NULL, col_vars = NULL, compress = TRUE, xlim = NULL, ylim = NULL, spacing = spacing_conditional(sp = 0), spacing_args = list(), split_vertical = NULL, keep_aspect_ratio = FALSE, xscale = 0.9, yspace = unit(0.5, "lines"), main = NULL, sub = NULL, \dots, residuals_type = "Pearson", gp_axis = gpar(lty = 3)) \method{assoc}{formula}(formula, data = NULL, \dots, subset = NULL, na.action = NULL, main = NULL, sub = NULL) } \arguments{ \item{x}{a contingency table in array form with optional category labels specified in the \code{dimnames(x)} attribute, or an object inheriting from the \code{"ftable"} class (such as \code{"structable"} objects).} \item{row_vars}{a vector of integers giving the indices, or a character vector giving the names of the variables to be used for the rows of the association plot.} \item{col_vars}{a vector of integers giving the indices, or a character vector giving the names of the variables to be used for the columns of the association plot.} \item{compress}{logical; if \code{FALSE}, the space between the rows (columns) are chosen such that the \emph{total} heights (widths) of the rows (columns) are all equal. If \code{TRUE}, the space between rows and columns is fixed and hence the plot is more \dQuote{compressed}.} \item{xlim}{a \eqn{2 \times k}{2 x k} matrix of doubles, \eqn{k} number of total columns of the plot. The columns of \code{xlim} correspond to the columns of the association plot, the rows describe the column ranges (minimums in the first row, maximums in the second row). If \code{xlim} is \code{NULL}, the ranges are determined from the residuals according to \code{compress} (if \code{TRUE}: widest range from each column, if \code{FALSE}: from the whole association plot matrix).} \item{ylim}{a \eqn{2 \times k}{2 x k} matrix of doubles, \eqn{k} number of total rows of the plot. The columns of \code{ylim} correspond to the rows of the association plot, the rows describe the column ranges (minimums in the first row, maximums in the second row). If \code{ylim} is \code{NULL}, the ranges are determined from the residuals according to \code{compress} (if \code{TRUE}: widest range from each row, if \code{FALSE}: from the whole association plot matrix).} \item{spacing}{a spacing object, a spacing function, or a corresponding generating function (see \code{\link{strucplot}} for more information). The default is the spacing-generating function \code{\link{spacing_conditional}} that is (by default) called with the argument list \code{spacing_args} (see \code{spacings} for more details).} \item{spacing_args}{list of arguments for the spacing-generating function, if specified (see \code{\link{strucplot}} for more information).} \item{split_vertical}{vector of logicals of length \eqn{k}, where \eqn{k} is the number of margins of \code{x} (default: \code{FALSE}). Values are recycled as needed. A \code{TRUE} component indicates that the corresponding dimension is folded into the columns, \code{FALSE} folds the dimension into the rows.} \item{keep_aspect_ratio}{logical indicating whether the aspect ratio should be fixed or not.} \item{residuals_type}{a character string indicating the type of residuals to be computed. Currently, only Pearson residuals are supported.} \item{xscale}{scale factor resizing the tile's width, thus adding additional space between the tiles. } \item{yspace}{object of class \code{"unit"} specifying additional space separating the rows.} \item{gp_axis}{object of class \code{"gpar"} specifying the visual aspects of the tiles' baseline.} \item{formula}{a formula object with possibly both left and right hand sides specifying the column and row variables of the flat table.} \item{data}{a data frame, list or environment containing the variables to be cross-tabulated, or an object inheriting from class \code{table}.} \item{subset}{an optional vector specifying a subset of observations to be used. Ignored if \code{data} is a contingency table.} \item{na.action}{an optional function which indicates what should happen when the data contain \code{NA}s. Ignored if \code{data} is a contingency table.} \item{main, sub}{either a logical, or a character string used for plotting the main (sub) title. If logical and \code{TRUE}, the name of the \code{data} object is used.} \item{\dots}{other parameters passed to \code{\link{strucplot}}} } \details{ Association plots have been suggested by Cohen (1980) and extended by Friendly (1992) and provide a means for visualizing the residuals of an independence model for a contingency table. \code{assoc} is a generic function and currently has a default method and a formula interface. Both are high-level interfaces to the \code{\link{strucplot}} function, and produce (extended) association plots. Most of the functionality is described there, such as specification of the independence model, labeling, legend, spacing, shading, and other graphical parameters. For a contingency table, the signed contribution to Pearson's \eqn{\chi^2}{chi^2} for cell \eqn{\{ij\ldots k\}} is \deqn{d_{ij\ldots k} = \frac{(f_{ij\ldots k} - e_{ij\ldots k})}{ \sqrt{e_{ij\ldots k}}}}{d_\{ij\ldotsk\} = (f_\{ij\ldotsk\} - e_\{ij\ldotsk\}) / sqrt(e_\{ij\ldotsk\})} where \eqn{f_{ij\ldots k}}{f_\{ij\ldotsk\}} and \eqn{e_{ij\ldots k}}{e_\{ij\ldotsk\}} are the observed and expected counts corresponding to the cell. In the association plot, each cell is represented by a rectangle that has (signed) height proportional to \eqn{d_{ij\ldots k}}{d_\{ij\ldotsk\}} and width proportional to \eqn{\sqrt{e_{ij\ldots k}}}{sqrt(e_\{ij...k\})}, so that the area of the box is proportional to the difference in observed and expected frequencies. The rectangles in each row are positioned relative to a baseline indicating independence (\eqn{d_{ij\ldots k} = 0}{d_\{ij\ldotsk\} = 0}). If the observed frequency of a cell is greater than the expected one, the box rises above the baseline, and falls below otherwise. Additionally, the residuals can be colored depending on a specified shading scheme (see Meyer et al., 2003). Package \pkg{vcd} offers a range of \emph{residual-based} shadings (see the shadings help page). Some of them allow, e.g., the visualization of test statistics. Unlike the \code{\link[graphics]{assocplot}} function in the \pkg{graphics} package, this function allows the visualization of contingency tables with more than two dimensions. Similar to the construction of \sQuote{flat} tables (like objects of class \code{"ftable"} or \code{"structable"}), the dimensions are folded into rows and columns. The layout is very flexible: the specification of shading, labeling, spacing, and legend is modularized (see \code{\link{strucplot}} for details). } \value{ The \code{"structable"} visualized is returned invisibly. } \seealso{ \code{\link{mosaic}}, \code{\link{strucplot}}, \code{\link{structable}} } \references{ Cohen, A. (1980), On the graphical display of the significant components in a two-way contingency table. \emph{Communications in Statistics---Theory and Methods}, \bold{A9}, 1025--1041. Friendly, M. (1992), Graphical methods for categorical data. \emph{SAS User Group International Conference Proceedings}, \bold{17}, 190--200. \url{http://datavis.ca/papers/sugi/sugi17.pdf} Meyer, D., Zeileis, A., Hornik, K. (2003), Visualizing independence using extended association plots. \emph{Proceedings of the 3rd International Workshop on Distributed Statistical Computing}, K. Hornik, F. Leisch, A. Zeileis (eds.), ISSN 1609-395X. \url{https://www.R-project.org/conferences/DSC-2003/Proceedings/} Meyer, D., Zeileis, A., and Hornik, K. (2006), The strucplot framework: Visualizing multi-way contingency tables with \pkg{vcd}. \emph{Journal of Statistical Software}, \bold{17(3)}, 1-48. \doi{10.18637/jss.v017.i03} and available as \code{vignette ("strucplot", package = "vcd")}. } \author{ David Meyer \email{David.Meyer@R-project.org} } \examples{ data("HairEyeColor") ## Aggregate over sex: (x <- margin.table(HairEyeColor, c(1, 2))) ## Ordinary assocplot: assoc(x) ## and with residual-based shading (of independence) assoc(x, main = "Relation between hair and eye color", shade = TRUE) ## Aggregate over Eye color: (x <- margin.table(HairEyeColor, c(1, 3))) chisq.test(x) assoc(x, main = "Relation between hair color and sex", shade = TRUE) # Visualize multi-way table assoc(aperm(HairEyeColor), expected = ~ (Hair + Eye) * Sex, labeling_args = list(just_labels = c(Eye = "left"), offset_labels = c(right = -0.5), offset_varnames = c(right = 1.2), rot_labels = c(right = 0), tl_varnames = c(Eye = TRUE)) ) assoc(aperm(UCBAdmissions), expected = ~ (Admit + Gender) * Dept, compress = FALSE, labeling_args = list(abbreviate_labs = c(Gender = TRUE), rot_labels = 0) ) } \keyword{hplot} vcd/man/binregplot.Rd0000755000175100001440000002230512535260710014261 0ustar hornikusers\name{binreg_plot} \alias{binreg_plot} \alias{grid_abline} \title{Binary Regression Plot} \description{ Creates a display of observed and fitted values for a binary regression model with one numeric predictor, conditioned by zero or many co-factors. } \usage{ binreg_plot(model, main = NULL, xlab = NULL, ylab = NULL, xlim = NULL, ylim = NULL, pred_var = NULL, pred_range = c("data", "xlim"), group_vars = NULL, base_level = NULL, subset, type = c("response", "link"), conf_level = 0.95, delta = FALSE, pch = NULL, cex = 0.6, jitter_factor = 0.1, lwd = 5, lty = 1, point_size = 0, col_lines = NULL, col_bands = NULL, legend = TRUE, legend_pos = NULL, legend_inset = c(0, 0.1), legend_vgap = unit(0.5, "lines"), labels = FALSE, labels_pos = c("right", "left"), labels_just = c("left","center"), labels_offset = c(0.01, 0), gp_main = gpar(fontface = "bold", fontsize = 14), gp_legend_frame = gpar(lwd = 1, col = "black"), gp_legend_title = gpar(fontface = "bold"), newpage = TRUE, pop = FALSE, return_grob = FALSE) grid_abline(a, b, \dots) } \arguments{ \item{model}{a binary regression model fitted with \code{\link[stats]{glm}}.} \item{main}{user-specified main title.} \item{xlab}{x-axis label. Defaults to the name of the (first) numeric predictor.} \item{ylab}{y-axis label. Defaults to the name of the response - within either 'P(...)' or 'logit(...)', depending on the response type.} \item{xlim}{Range of the x-axis. Defaults to the range of the numeric predictor.} \item{ylim}{Range of the y-axis. Defaults to the unit interval on probability scale or the fitted values range on the link scale, depending on \code{type}.} \item{pred_var}{character string of length 1 giving the name of the numeric predictor. Defaults to the first one found in the data set.} \item{pred_range}{\code{"data"}, \code{"xlim"}, or a numeric vector. If \code{"data"}, the numeric predictor corresponds to the observed values. If \code{"xlim"}, 100 values are taken from the \code{"xlim"} range. A numeric vector will be interpreted as the values to be predicted.} \item{group_vars}{optional character string of conditioning variables. Defaults to all factors found in the data set, response excluded. If \code{FALSE}, no variables are used for conditioning.} \item{base_level}{vector of length one. If the response is a vector, this specifies the base ('no effect') value of the response variable (e.g., "Placebo", 0, FALSE, etc.) and defaults to the first level for factor responses, or 0 for numeric/binary variables. This controls which observations will be plotted on the top or the bottom of the display. If the response is a matrix with success and failure column, this specifies the one to be interpreted as failure (default: 2), either as an integer, or as a string (\code{"success"} or \code{"failure"}). The proportions of \emph{successes} will be plotted as observed values.} \item{subset}{an optional vector specifying a subset of the data rows. The value is evaluated in the data environment, so expressions can be used to select the data (see examples).} \item{type}{either "response" or "link" to select the scale of the fitted values. The y-axis will be adapted accordingly.} \item{conf_level}{confidence level used for calculating confidence bands.} \item{delta}{logical; indicates whether the delta method should be employed for calculating the limits of the confidence band or not (see details).} \item{pch}{character or numeric vector of symbols used for plotting the (possibly conditioned) observed values, recycled as needed.} \item{cex}{size of the plot symbols (in lines).} \item{jitter_factor}{argument passed to \code{\link[base]{jitter}} used for the points representing the observed values.} \item{lwd}{Line width for the fitted values.} \item{lty}{Line type for the fitted values.} \item{point_size}{size of points for the fitted values in char units (default: 0, so no points are plotted).} \item{col_lines, col_bands}{character vector specifying the colors of the fitted lines and confidence bands, by default chosen with \code{\link[colorspace]{rainbow_hcl}}. The confidence bands are using alpha blending with alpha = 0.2.} \item{legend}{logical; if \code{TRUE} (default), a legend is drawn.} \item{legend_pos}{numeric vector of length 2, specifying x and y coordinates of the legend, or a character string (e.g., \code{"topleft"}, \code{"center"} etc.). Defaults to \code{"topleft"} if the fitted curve's slope is positive, and \code{"topright"} else.} \item{legend_inset}{numeric vector or length 2 specifying the inset from the legend's x and y coordinates in npc units.} \item{legend_vgap}{vertical space between the legend's line entries.} \item{labels}{logical; if \code{TRUE}, labels corresponding to the factor levels are plotted next to the fitted lines.} \item{labels_pos}{either \code{"right"} or \code{"left"}, determining on which side of the fitted lines (start or end) the labels should be placed.} \item{labels_just}{character vector of length 2, specifying the relative justification of the labels to their coordinates. See the documentation of the \code{just} parameter of \code{\link[grid]{grid.text}} for more details.} \item{labels_offset}{numeric vector of length 2, specifying the offset of the labels' coordinates in npc units.} \item{gp_main}{object of class \code{"gpar"} used for the main title.} \item{gp_legend_frame}{object of class \code{"gpar"} used for the legend frame.} \item{gp_legend_title}{object of class \code{"gpar"} used for the legend title.} \item{newpage}{logical; if \code{TRUE}, the plot is drawn on a new page.} \item{pop}{logical; if \code{TRUE}, all newly generated viewports are popped after plotting.} \item{return_grob}{logical. Should a snapshot of the display be returned as a grid grob?} \item{a}{intercept; alternatively, a regression model from which coefficients can be extracted via \code{\link[stats]{coef}}.} \item{b}{slope.} \item{\dots}{Further arguments passed to \code{\link[grid]{grid.abline}}.} } \details{ The primary purpose of \code{binreg_plot()} is to visualize observed and fitted values for binary regression models (like the logistic or probit regression model) with one numeric predictor. If one or more categorical predictors are used in the model, the \emph{fitted} values are conditioned on them, i.e. separate curves are drawn corresponding to the factor level combinations. Thus, it shows a \emph{full-model plot}, not a conditional plot where several models would be fit to data subsets. The implementation relies on objects returned by \code{\link[stats]{glm}}, as it uses its \code{"terms"} and \code{"model"} components. The function tries to determine suitable values for the legend and/or labels, but depending on the data, this might require some tweaking. By default, the limits of the confidence band are determined for the linear predictor (i.e., on the link scale) and transformed to response scale (if this is the chosen plot type) using the inverse link function. If \code{delta} is \code{TRUE}, the limits are determined on the response scale. Note that the resulting band using the delta method is symmetric around the fitted mean, but may exceed the unit interval (on the response scale) and will be cut off. \code{grid_abline()} is a simple convenience wrapper for \code{\link[grid]{grid.abline}} with similar behavior than \code{\link[graphics]{abline}} in that it extracts coefficients from a regression model, if given instead of the intercept \code{a}. } \value{ if \code{return_grob} is \code{TRUE}, a grob object corresponding to the plot. \code{NULL} (invisibly) else. } \references{ Michael Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \author{ David Meyer \email{David.Meyer@R-project.org} } \examples{ ## Simple model with no conditioning variables art.mod0 <- glm(Improved > "None" ~ Age, data = Arthritis, family = binomial) binreg_plot(art.mod0, "Arthritis Data") binreg_plot(art.mod0, type = "link") ## logit scale ## one conditioning factor art.mod1 <- update(art.mod0, . ~ . + Sex) binreg_plot(art.mod1) binreg_plot(art.mod1, legend = FALSE, labels = TRUE, xlim = c(20, 80)) ## two conditioning factors art.mod2 <- update(art.mod1, . ~ . + Treatment) binreg_plot(art.mod2) binreg_plot(art.mod2, subset = Sex == "Male") ## subsetting ## some tweaking binreg_plot(art.mod2, gp_legend_frame = gpar(col = NA, fill = "white"), col_bands = NA) binreg_plot(art.mod2, legend = FALSE, labels = TRUE, labels_pos = "left", labels_just = c("left", "top")) ## model with grouped response data shuttle.mod <- glm(cbind(nFailures, 6 - nFailures) ~ Temperature, data = SpaceShuttle, na.action = na.exclude, family = binomial) binreg_plot(shuttle.mod, xlim = c(30, 81), pred_range = "xlim", ylab = "O-Ring Failure Probability", xlab = "Temperature (F)") } \keyword{category} \keyword{hplot} vcd/man/Ord_plot.Rd0000755000175100001440000001122212445061132013667 0ustar hornikusers\name{Ord_plot} \alias{Ord_plot} \alias{Ord_estimate} \title{Ord Plots} \description{ Ord plots for diagnosing discrete distributions. } \usage{ Ord_plot(obj, legend = TRUE, estimate = TRUE, tol = 0.1, type = NULL, xlim = NULL, ylim = NULL, xlab = "Number of occurrences", ylab = "Frequency ratio", main = "Ord plot", gp = gpar(cex = 0.5), lwd = c(2,2), lty=c(2,1), col=c("black", "red"), name = "Ord_plot", newpage = TRUE, pop = TRUE, return_grob = FALSE, \dots) Ord_estimate(x, type = NULL, tol = 0.1) } \arguments{ \item{obj}{either a vector of counts, a 1-way table of frequencies of counts or a data frame or matrix with frequencies in the first column and the corresponding counts in the second column.} \item{legend}{logical. Should a legend be plotted?.} \item{estimate}{logical. Should the distribution and its parameters be estimated from the data? See details.} \item{tol}{tolerance for estimating the distribution. See details.} \item{type}{a character string indicating the distribution, must be one of \code{"poisson"}, \code{"binomial"}, \code{"nbinomial"} or \code{"log-series"} or \code{NULL}. In the latter case the distribution is estimated from the data. See details.} \item{xlim}{limits for the x axis.} \item{ylim}{limits for the y axis.} \item{xlab}{a label for the x axis.} \item{ylab}{a label for the y axis.} \item{main}{a title for the plot.} \item{gp}{a \code{"gpar"} object controlling the grid graphical parameters of the points.} \item{lwd, lty}{vectors of length 2, giving the line width and line type used for drawing the OLS line and the WLS lines.} \item{col}{vector of length 2 giving the colors used for drawing the OLS and WLS lines.} \item{name}{name of the plotting viewport.} \item{newpage}{logical. Should \code{\link{grid.newpage}} be called before plotting?} \item{pop}{logical. Should the viewport created be popped?} \item{return_grob}{logical. Should a snapshot of the display be returned as a grid grob?} \item{\dots}{further arguments passed to \code{\link{grid.points}}.} \item{x}{a vector giving intercept and slope for the (fitted) line in the Ord plot.} } \details{ The Ord plot plots the number of occurrences against a certain frequency ratio (see Friendly (2000) for details) and should give a straight line if the data comes from a poisson, binomial, negative binomial or log-series distribution. The intercept and slope of this straight line conveys information about the underlying distribution. \code{Ord_plot} fits a usual OLS line (black) and a weighted OLS line (red). From the coefficients of the latter the distribution is estimated by \code{Ord_estimate} as described in Table 2.10 in Friendly (2000). To judge whether a coefficient is positive or negative a tolerance given by \code{tol} is used. If none of the distributions fits well, no parameters are estimated. Be careful with the conclusions from \code{Ord_estimate} as it implements just some simple heuristics! } \value{ A vector giving the intercept and slope of the weighted OLS line. } \author{ Achim Zeileis \email{Achim.Zeileis@R-project.org} } \references{ J. K. Ord (1967), Graphical methods for a class of discrete distributions, \emph{Journal of the Royal Statistical Society}, \bold{A 130}, 232--238. Michael Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \examples{ ## Simulated data examples: dummy <- rnbinom(1000, size = 1.5, prob = 0.8) Ord_plot(dummy) ## Real data examples: data("HorseKicks") data("Federalist") data("Butterfly") data("WomenQueue") \dontrun{ grid.newpage() pushViewport(viewport(layout = grid.layout(2, 2))) pushViewport(viewport(layout.pos.col=1, layout.pos.row=1)) Ord_plot(HorseKicks, main = "Death by horse kicks", newpage = FALSE) popViewport() pushViewport(viewport(layout.pos.col=1, layout.pos.row=2)) Ord_plot(Federalist, main = "Instances of 'may' in Federalist papers", newpage = FALSE) popViewport() pushViewport(viewport(layout.pos.col=2, layout.pos.row=1)) Ord_plot(Butterfly, main = "Butterfly species collected in Malaya", newpage = FALSE) popViewport() pushViewport(viewport(layout.pos.col=2, layout.pos.row=2)) Ord_plot(WomenQueue, main = "Women in queues of length 10", newpage = FALSE) popViewport(2) } ## same mplot( Ord_plot(HorseKicks, return_grob = TRUE, main = "Death by horse kicks"), Ord_plot(Federalist, return_grob = TRUE, main = "Instances of 'may' in Federalist papers"), Ord_plot(Butterfly, return_grob = TRUE, main = "Butterfly species collected in Malaya"), Ord_plot(WomenQueue, return_grob = TRUE, main = "Women in queues of length 10") ) } \keyword{category} vcd/man/BrokenMarriage.Rd0000755000175100001440000000165311150520606015002 0ustar hornikusers\name{BrokenMarriage} \alias{BrokenMarriage} \docType{data} \title{Broken Marriage Data} \description{ Data from the Danish Welfare Study about broken marriages or permanent relationships depending on gender and social rank. } \usage{ data("BrokenMarriage") } \format{ A data frame with 20 observations and 4 variables. \describe{ \item{Freq}{frequency.} \item{gender}{factor indicating gender (male, female).} \item{rank}{factor indicating social rank (I, II, III, IV, V).} \item{broken}{factor indicating whether the marriage or permanent relationship was broken (yes, no).} } } \references{ E. B. Andersen (1991), \emph{The Statistical Analysis of Categorical Data}. 2nd edition. Springer-Verlag, Berlin. } \source{ E. B. Andersen (1991), The Statistical Analysis of Categorical Data, page 177. } \examples{ data("BrokenMarriage") structable(~ ., data = BrokenMarriage) } \keyword{datasets} vcd/man/mar_table.Rd0000755000175100001440000000057511150520606014042 0ustar hornikusers\name{mar_table} \alias{mar_table} \title{Table with Marginal Sums} \description{ Adds row and column sums to a two-way table. } \usage{ mar_table(x) } \arguments{ \item{x}{a two-way table.} } \value{ A table with row and column totals added. } \author{ David Meyer \email{David.Meyer@R-project.org} } \examples{ data("SexualFun") mar_table(SexualFun) } \keyword{category} vcd/man/agreementplot.Rd0000755000175100001440000001146214671771705015002 0ustar hornikusers\name{agreementplot} \alias{agreementplot} \alias{agreementplot.default} \alias{agreementplot.formula} \title{Bangdiwala's Observer Agreement Chart} \description{ Representation of a \eqn{k \times k}{k by k} confusion matrix, where the observed and expected diagonal elements are represented by superposed black and white rectangles, respectively. The function also computes a statistic measuring the strength of agreement (relation of respective area sums). } \usage{ \method{agreementplot}{default}(x, reverse_y = TRUE, main = NULL, weights = c(1, 1 - 1/(ncol(x) - 1)^2), margins = par("mar"), newpage = TRUE, pop = TRUE, xlab = names(dimnames(x))[2], ylab = names(dimnames(x))[1], xlab_rot = 0, xlab_just = "center", ylab_rot = 90, ylab_just = "center", fill_col = function(j) gray((1 - (weights[j]) ^ 2) ^ 0.5), line_col = "red", xscale = TRUE, yscale = TRUE, return_grob = FALSE, prefix = "", \dots) \method{agreementplot}{formula}(formula, data = NULL, ..., subset) } \arguments{ \item{x}{a confusion matrix, i.e., a table with equal-sized dimensions.} \item{reverse_y}{if \code{TRUE}, the y axis is reversed (i.e., the rectangles' positions correspond to the contingency table).} \item{main}{user-specified main title.} \item{weights}{vector of weights for successive larger observed areas, used in the agreement strength statistic, and also for the shading. The first element should be 1.} \item{margins}{vector of margins (see \code{\link[graphics]{par}}).} \item{newpage}{logical; if \code{TRUE}, the plot is drawn on a new page.} \item{pop}{logical; if \code{TRUE}, all newly generated viewports are popped after plotting.} \item{return_grob}{logical. Should a snapshot of the display be returned as a grid grob?} \item{xlab, ylab}{labels of x- and y-axis.} \item{xlab_rot, ylab_rot}{rotation angle for the category labels.} \item{xlab_just, ylab_just}{justification for the category labels.} \item{fill_col}{a function, giving the fill colors used for exact and partial agreement} \item{line_col}{color used for the diagonal reference line} \item{formula}{a formula, such as \code{y ~ x}. For details, see \code{\link{xtabs}}.} \item{data}{a data frame (or list), or a contingency table from which the variables in \code{formula} should be taken.} \item{subset}{an optional vector specifying a subset of the rows in the data frame to be used for plotting.} \item{xscale, yscale}{logicals indicating whether the marginals should be added on the x-axis/y-axis, respectively.} \item{prefix}{character string used as prefix for the viewport name} \item{\dots}{further graphics parameters (see \code{\link{par}}).} } \details{ Weights can be specified to allow for partial agreement, taking into account contributions from off-diagonal cells. Partial agreement is typically represented in the display by lighter shading, as given by \code{fill_col(j)}, corresponding to \code{weights[j]}. A weight vector of length 1 means strict agreement only, each additional element increases the maximum number of disagreement steps. \code{\link{cotabplot}} can be used for stratified analyses (see examples). } \value{ Invisibly returned, a list with components \item{Bangdiwala}{the unweighted agreement strength statistic.} \item{Bangdiwala_Weighted}{the weighted statistic.} \item{weights}{the weight vector used.} } \references{ Bangdiwala, S. I. (1988). The Agreement Chart. Department of Biostatistics, University of North Carolina at Chapel Hill, Institute of Statistics Mimeo Series No. 1859, \url{https://repository.lib.ncsu.edu/bitstreams/fea554e9-8750-4f1a-8419-ee126ce1a790/download} Bangdiwala, S. I., Ana S. Haedo, Marcela L. Natal, and Andres Villaveces. The agreement chart as an alternative to the receiver-operating characteristic curve for diagnostic tests. \emph{Journal of Clinical Epidemiology}, 61 (9), 866-874. Michael Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \author{ David Meyer \email{David.Meyer@R-project.org} } \examples{ data("SexualFun") agreementplot(t(SexualFun)) data("MSPatients") \dontrun{ ## best visualized using a resized device, e.g. using: ## get(getOption("device"))(width = 12) pushViewport(viewport(layout = grid.layout(ncol = 2))) pushViewport(viewport(layout.pos.col = 1)) agreementplot(t(MSPatients[,,1]), main = "Winnipeg Patients", newpage = FALSE) popViewport() pushViewport(viewport(layout.pos.col = 2)) agreementplot(t(MSPatients[,,2]), main = "New Orleans Patients", newpage = FALSE) popViewport(2) dev.off() } ## alternatively, use cotabplot: cotabplot(MSPatients, panel = cotab_agreementplot) } \keyword{category} \keyword{hplot} vcd/man/labeling_border.Rd0000755000175100001440000002525114133457303015233 0ustar hornikusers\name{labeling_border} \alias{labeling_border} \alias{labeling_conditional} \alias{labeling_left} \alias{labeling_left2} \alias{labeling_cboxed} \alias{labeling_lboxed} \alias{labeling_doubledecker} \alias{labeling_values} \alias{labeling_residuals} \alias{labelings} \title{Labeling Functions for Strucplots} \description{ These functions generate labeling functions used for strucplots. } \usage{ labeling_border(labels = TRUE, varnames = labels, set_labels = NULL, set_varnames = NULL, tl_labels = NULL, alternate_labels = FALSE, tl_varnames = NULL, gp_labels = gpar(fontsize = 12), gp_varnames = gpar(fontsize = 12, fontface = 2), rot_labels = c(0, 90, 0, 90), rot_varnames = c(0, 90, 0, 90), pos_labels = "center", pos_varnames = "center", just_labels = "center", just_varnames = pos_varnames, boxes = FALSE, fill_boxes = FALSE, offset_labels = c(0, 0, 0, 0), offset_varnames = offset_labels, labbl_varnames = NULL, labels_varnames = FALSE, sep = ": ", abbreviate_labs = FALSE, rep = TRUE, clip = FALSE, \dots) labeling_values(value_type = c("observed", "expected", "residuals"), suppress = NULL, digits = 1, clip_cells = FALSE, \dots) labeling_residuals(suppress = NULL, digits = 1, clip_cells = FALSE, \dots) labeling_conditional(\dots) labeling_left(rep = FALSE, pos_varnames = "left", pos_labels = "left", just_labels = "left", \dots) labeling_left2(tl_labels = TRUE, clip = TRUE, pos_varnames = "left", pos_labels = "left", just_labels = "left", \dots) labeling_cboxed(tl_labels = TRUE, boxes = TRUE, clip = TRUE, pos_labels = "center", \dots) labeling_lboxed(tl_labels = FALSE, boxes = TRUE, clip = TRUE, pos_labels = "left", just_labels = "left", labbl_varnames = FALSE, \dots) labeling_doubledecker(lab_pos = c("bottom", "top"), dep_varname = TRUE, boxes = NULL, clip = NULL, labbl_varnames = FALSE, rot_labels = rep.int(0, 4), pos_labels = c("left", "center", "left", "center"), just_labels = c("left", "left", "left", "center"), varnames = NULL, gp_varnames = gpar(fontsize = 12, fontface = 2), offset_varnames = c(0, -0.6, 0, 0), tl_labels = NULL, \dots) } \arguments{ \item{labels}{vector of logicals indicating whether labels should be drawn for a particular dimension.} \item{varnames}{vector of logicals indicating whether variable names should be drawn for a particular dimension.} \item{set_labels}{An optional character vector with named components replacing the so-specified variable names. The component names must exactly match the variable names to be replaced.} \item{set_varnames}{An optional list with named components of character vectors replacing the labels of the so-specified variables. The component names must exactly match the variable names whose labels should be replaced.} \item{tl_labels}{vector of logicals indicating whether labels should be positioned on top (column labels) / left (row labels) for a particular dimension.} \item{alternate_labels}{vector of logicals indicating whether labels should be alternated on the top/bottom (left/right) side of the plot for a particular dimension.} \item{tl_varnames}{vector of logicals indicating whether variable names should be positioned on top (column labels) / on left (row labels) for a particular dimension.} \item{gp_labels}{list of objects of class \code{"gpar"} used for drawing the labels.} \item{gp_varnames}{list of objects of class \code{"gpar"} used for drawing the variable names.} \item{rot_labels}{vector of rotation angles for the labels for each of the four sides of the plot.} \item{rot_varnames}{vector of rotation angles for the variable names for each of the four sides of the plot.} \item{pos_labels}{character string of label positions (\code{"left"}, \code{"center"}, \code{"right"}) for each of the variables.} \item{pos_varnames}{character string of variable names positions (\code{"left"}, \code{"center"}, \code{"right"}) for each of the four sides of the plot.} \item{just_labels}{character string of label justifications (\code{"left"}, \code{"center"}, \code{"right"}) for each of the variables.} \item{just_varnames}{character string of variable names justifications (\code{"left"}, \code{"center"}, \code{"right"}) for each of the four sides of the plot.} \item{boxes}{vector of logicals indicating whether boxes should be drawn around the labels for a particular dimension.} \item{fill_boxes}{Either a vector of logicals, or a vector of characters, or a list of such vectors, specifying the fill colors for the boxes. \code{"TRUE"} and \code{"FALSE"} values are transformed into \code{"grey"} and \code{"white"}, respectively. If \code{fill_boxes} is atomic, each component specifies a basic color for the corresponding dimension. This color is transformed into its HSV representation, and the value is varied from 50\% to 100\% to give a sequential color palette for the levels. For \code{NA} components, no palette is produced (no fill color). If \code{fill_boxes} is a list of vectors, each vector specifies the level colors of the corresponding dimension.} \item{offset_labels, offset_varnames}{numeric vector of length 4 indicating the offset of the labels (variable names) for each of the four sides of the plot.} \item{labbl_varnames}{vector of logicals indicating whether variable names should be drawn on the left (column variables) / on top (row variables) of the corresponding labels.} \item{labels_varnames}{vector of logicals indicating, for each dimension, whether the variable name should be added to the corresponding labels or not.} \item{sep}{separator used if any component of \code{"labels_varnames"} is \code{TRUE}.} \item{abbreviate_labs}{vector of integers or logicals indicating, for each dimension, the number of characters the labels should be abbreviated to. \code{TRUE} means 1 character, \code{FALSE} causes no abbreviation. Values are recycled as needed.} \item{rep}{vector of logicals indicating, for each dimension, whether labels should be repeated for all conditioning strata, or appear only once.} \item{clip}{vector of integers indicating, for each dimension, whether labels should be clipped to not overlap.} \item{lab_pos}{character string switching between \code{"top"} or \code{"bottom"} position of the labels (only used for \code{labeling_doubledecker}).} \item{dep_varname}{logical or character string. If logical, this is indicating whether the name of the dependent variable should be printed or not. A character string will be printed instead of the variable name taken from the dimnames.} \item{value_type}{character string specifying which values should be displayed in the cells.} \item{suppress}{numeric vector of length 2 specifying an interval of values that are not displayed. 0 values are never displayed. A single number, \var{k}, is treated as \code{c(-\var{k}, \var{k})}. The default for labeling residuals is \code{c(-2,2)}. Use \code{suppress = 0} to show all non-zero values.} \item{digits}{integer specifying the number of digits used for rounding.} \item{clip_cells}{logical indicating whether the values should be clipped at the cell borders.} \item{\dots}{only used for \code{labeling_conditional} and \code{labeling_doubledecker}: parameters passed to \code{labeling_cells} and \code{labeling_border}.} } \details{ These functions generate labeling functions called by \code{\link{strucplot}} for their side-effect of adding labels to the plot. They suppose that a strucplot has been drawn and the corresponding viewport structure is pushed, since the positions of the viewports are used for the label positioning. Note that the functions can also be used \sQuote{stand-alone} as shown in the examples. All values supplied to vectorized arguments can be \sQuote{abbreviated} by using named components which override the default component values. In addition, these defaults can be overloaded by the sequence of non-named components which are recycled as needed (see examples). This help page only documents \code{labeling_border} and derived functions, more functions are described on the help page for \code{\link{labeling_cells}} and \code{\link{labeling_list}}. \code{labeling_left}, \code{labeling_left2}, \code{labeling_cboxed}, and \code{labeling_lboxed} are really just wrappers to \code{labeling_border}, and good examples for the parameter usage. \code{labeling_residuals} is a trivial wrapper for \code{labeling_values}, which in turn calls \code{labeling_border} by additionally adding the observed or expected frequencies or residuals to the cells. } \value{ A function with arguments: \item{d}{\code{"dimnames"} attribute from the visualized contingency table, or the visualized table itself from which the \code{"dimnames"} attributes will then be extracted.} \item{split_vertical}{vector of logicals indicating the split directions.} \item{condvars}{integer vector of conditioning dimensions.} } \author{ David Meyer \email{David.Meyer@R-project.org} } \references{ Meyer, D., Zeileis, A., and Hornik, K. (2006), The strucplot framework: Visualizing multi-way contingency tables with \pkg{vcd}. \emph{Journal of Statistical Software}, \bold{17(3)}, 1-48. \doi{10.18637/jss.v017.i03} and available as \code{vignette("strucplot")}. } \seealso{ \code{\link{labeling_cells}}, \code{\link{labeling_list}}, \code{\link{structable}}, \code{\link[grid]{grid.text}} } \examples{ data("Titanic") mosaic(Titanic) mosaic(Titanic, labeling = labeling_left) labeling_left mosaic(Titanic, labeling = labeling_cboxed) labeling_cboxed mosaic(Titanic, labeling = labeling_lboxed) labeling_lboxed data("PreSex") mosaic(~ PremaritalSex + ExtramaritalSex | Gender + MaritalStatus, data = PreSex, labeling = labeling_conditional) ## specification of vectorized arguments mosaic(Titanic, labeling_args = list(abbreviate_labs = c(Survived = TRUE))) mosaic(Titanic, labeling_args = list(clip = TRUE, boxes = TRUE, fill_boxes = c(Survived = "green", "red"))) mosaic(Titanic, labeling_args = list(clip = TRUE, boxes = TRUE, fill_boxes = list(Sex = "red", "green"))) mosaic(Titanic, labeling_args = list(clip = TRUE, boxes = TRUE, fill_boxes = list(Sex = c(Male = "red", "blue"), "green"))) ## change variable names mosaic(Titanic, labeling_args = list(set_varnames = c(Sex = "Gender"))) ## change labels mosaic(Titanic, labeling_args = list(set_varnames = c(Survived = "Status"), set_labels = list(Survived = c("Survived", "Not Survived")), rep = FALSE)) ## show frequencies mosaic(Titanic, labeling = labeling_values) } \keyword{hplot} vcd/man/spacings.Rd0000755000175100001440000000630114133457325013727 0ustar hornikusers\name{spacings} \alias{spacings} \alias{spacing_highlighting} \alias{spacing_equal} \alias{spacing_dimequal} \alias{spacing_increase} \alias{spacing_conditional} \title{Spacing-generating Functions} \description{ These functions generate spacing functions to be used with \code{\link{strucplot}} to obtain customized spaces between the elements of a strucplot. } \usage{ spacing_equal(sp = unit(0.3, "lines")) spacing_dimequal(sp) spacing_increase(start = unit(0.3, "lines"), rate = 1.5) spacing_conditional(sp = unit(0.3, "lines"), start = unit(2, "lines"), rate = 1.8) spacing_highlighting(start = unit(0.2, "lines"), rate = 1.5) } \arguments{ \item{start}{object of class \code{"unit"} indicating the start value for increasing spacings.} \item{rate}{increase rate for spacings.} \item{sp}{object of class \code{"unit"} specifying a fixed spacing.} } \details{ These generating functions return a function used by \code{\link{strucplot}} to generate appropriate spaces between tiles of a strucplot, using the \code{dimnames} information of the visualized table. \code{spacing_equal} allows to specify one fixed space for \emph{all} dimensions. \code{spacing_dimequal} allows to specify a fixed space for \emph{each} dimension. \code{spacing_increase} creates increasing spaces for all dimensions, based on a starting value and an increase rate. \code{spacing_conditional} combines \code{spacing_equal} and \code{spacing_increase} to create fixed spaces for conditioned dimensions, and increasing spaces for conditioning dimensions. \code{spacing_highlighting} is essentially \code{spacing_conditional} but with the space of the last dimension set to 0. With a corresponding color scheme, this gives the impression of the last class being \sQuote{highlighted} in the penultimate class (as, e.g., in \code{\link{doubledecker}} plots). } \value{ A spacing function with arguments: \item{d}{\code{"dim"} attribute of a contingency table.} \item{condvars}{index vector of conditioning dimensions (currently only used by \code{spacing_conditional}).} This function computes a list of objects of class \code{"unit"}. Each list element contains the spacing information for the corresponding dimension of the table. The length of the \code{"unit"} objects is \eqn{k-1}, \eqn{k} number of levels of the corresponding factor. } \author{ David Meyer \email{David.Meyer@R-project.org} } \references{ Meyer, D., Zeileis, A., and Hornik, K. (2006), The strucplot framework: Visualizing multi-way contingency tables with \pkg{vcd}. \emph{Journal of Statistical Software}, \bold{17(3)}, 1-48. \doi{10.18637/jss.v017.i03} and available as \code{vignette("strucplot")}. } \seealso{ \code{\link{strucplot}}, \code{\link{doubledecker}} } \examples{ data("Titanic") strucplot(Titanic, spacing = spacing_increase(start = 0.5, rate = 1.5)) strucplot(Titanic, spacing = spacing_equal(1)) strucplot(Titanic, spacing = spacing_dimequal(1:4 / 4)) strucplot(Titanic, spacing = spacing_highlighting, gp = gpar(fill = c("light gray","dark gray"))) data("PreSex") strucplot(aperm(PreSex, c(1,4,2,3)), spacing = spacing_conditional, condvars = 2) } \keyword{hplot} vcd/man/panel_pairs_diagonal.Rd0000755000175100001440000001313314133212714016243 0ustar hornikusers\name{Pairs plot panel functions for diagonal cells} \alias{pairs_barplot} \alias{pairs_text} \alias{pairs_diagonal_text} \alias{pairs_diagonal_mosaic} \title{Diagonal Panel Functions for Table Pairs Plot} \description{ Diagonal panel functions for \code{\link{pairs.table}}. } \usage{ pairs_barplot(gp_bars = NULL, gp_vartext = gpar(fontsize = 17), gp_leveltext = gpar(), gp_axis = gpar(), just_leveltext = c("center", "bottom"), just_vartext = c("center", "top"), rot = 0, abbreviate = FALSE, check_overlap = TRUE, fill = "grey", var_offset = unit(1, "npc"), \dots) pairs_text(dimnames = TRUE, gp_vartext = gpar(fontsize = 17), gp_leveltext = gpar(), gp_border = gpar(), \dots) pairs_diagonal_text(varnames = TRUE, gp_vartext = gpar(fontsize = 17, fontface = "bold"), gp_leveltext = gpar(), gp_border = gpar(), pos = c("right","top"), distribute = c("equal","margin"), rot = 0, \dots) pairs_diagonal_mosaic(split_vertical = TRUE, margins = unit(0, "lines"), offset_labels = -0.4, offset_varnames = 0, gp = NULL, fill = "grey", labeling = labeling_values, alternate_labels = TRUE, ...) } \arguments{ \item{dimnames}{vector of logicals indicating whether the factor levels should be displayed (only used for \code{pairs_text}).} \item{varnames}{vector of logicals indicating whether the variable names should be displayed (only used for \code{pairs_text_diagonal}).} \item{gp_bars}{object of class \code{"gpar"} used for bars (only used for \code{pairs_barplot}). If unspecified, the default is to set the \code{fill} component of this object to the \code{fill} argument.} \item{gp_vartext}{object of class \code{"gpar"} used for the factor names.} \item{gp_leveltext}{object of class \code{"gpar"} used for the factor levels.} \item{gp_axis}{object of class \code{"gpar"} used for the y axis.} \item{gp_border}{object of class \code{"gpar"} used for the border (only used for \code{pairs_text}).} \item{gp}{object of class \code{"gpar"} used for the tiles (only used for \code{pairs_diagonal_mosaic}). If unspecified, the default is to set the \code{fill} component of this object to the \code{fill} argument.} \item{fill}{color vector or palette function used for the fill colors of bars (for \code{pairs_barplot}) or tiles (for \code{pairs_diagonal_mosaic}).} \item{labeling}{labeling function, passed to \code{mosaic()}} \item{alternate_labels}{should labels alternate top/bottom?} \item{just_leveltext, just_vartext}{character string indicating the justification for variable names and levels.} \item{pos}{character string of length 2 controlling the horizontal and vertical position of the variable names (only used for \code{pairs_text_diagonal}).} \item{rot}{rotation angle for the variable levels.} \item{distribute}{character string indicating whether levels should be distributed equally or according to the margins (only used for \code{pairs_text_diagonal}).} \item{abbreviate}{integer or logical indicating the number of characters the labels should be abbreviated to. \code{TRUE} means 1 character, \code{FALSE} causes no abbreviation.} \item{check_overlap}{If \code{TRUE}, some levels will suppressed to avoid overlapping, if any.} \item{split_vertical}{vector of logicals of length \eqn{k}, where \eqn{k} is the number of margins of \code{x} (values are recycled as needed). A \code{TRUE} component indicates that the tile(s) of the corresponding dimension should be split vertically, \code{FALSE} means horizontal splits. Default is \code{FALSE.}} \item{margins}{either an object of class \code{"unit"} of length 4, or a numeric vector of length 4. The elements are recycled as needed. The four components specify the top, right, bottom, and left margin of the plot, respectively. When a numeric vector is supplied, the numbers are interpreted as \code{"lines"} units. In addition, the unit or numeric vector may have named arguments (\samp{top}, \samp{right}, \samp{bottom}, and \samp{left}), in which case the non-named arguments specify the default values (recycled as needed), overloaded by the named arguments.} \item{offset_labels, offset_varnames}{numeric vector of length 4 indicating the offset of the labels (variable names) for each of the four sides of the plot.} \item{var_offset}{object of class \code{"unit"} specifying the offset of variable names from the bottom of the bar plots created by \code{pairs_barplot}. If numeric, the unit defaults to "npc".} \item{\dots}{other parameters passed to the underlying graphics functions.} } \details{ In the diagonal cells, the pairsplot visualizes statistics or information for each dimension (that is: the single factors) alone. \code{\link{pairs_text}} displays the factor's name, and optionally also the factor levels. \code{\link{pairs_barplot}} produces a bar plot of the corresponding factor, along with the factor's name. } \value{ A function with one argument: the marginal table for the corresponding dimension. } \seealso{ \code{\link{pairs.table}}, \code{\link{pairs_assoc}}, \code{\link{pairs_mosaic}} } \author{ David Meyer \email{David.Meyer@R-project.org} } \examples{ data("UCBAdmissions") pairs(UCBAdmissions) # pairs_barplot is default pairs(UCBAdmissions, diag_panel = pairs_text) pairs(UCBAdmissions, diag_panel = pairs_diagonal_text) pairs(Titanic, diag_panel = pairs_diagonal_text) pairs(Titanic, diag_panel = pairs_diagonal_text(distribute = "margin")) pairs(Titanic, diag_panel = pairs_diagonal_text(distribute = "margin", rot = 45)) } \keyword{hplot} vcd/man/Saxony.Rd0000755000175100001440000000176511150520606013377 0ustar hornikusers\name{Saxony} \alias{Saxony} \docType{data} \title{Families in Saxony} \description{ Data from Geissler, cited in Sokal & Rohlf (1969) and Lindsey (1995) on gender distributions in families in Saxony in the 19th century. } \usage{ data("Saxony") } \format{ A 1-way table giving the number of male children in 6115 families of size 12. The variable and its levels are \tabular{rll}{ No \tab Name \tab Levels \cr 1 \tab nMales \tab 0, 1, \dots, 12 \cr } } \references{ J. K. Lindsey (1995), \emph{Analysis of Frequency and Count Data}. Oxford University Press, Oxford, UK. R. R. Sokal & F. J. Rohlf (1969), \emph{Biometry. The Principles and Practice of Statistics}. W. H. Freeman, San Francisco, CA. M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \source{ M. Friendly (2000), Visualizing Categorical Data, pages 40--42. } \examples{ data("Saxony") gf <- goodfit(Saxony, type = "binomial") summary(gf) plot(gf) } \keyword{datasets} vcd/man/Bundesliga.Rd0000755000175100001440000000415113731736014014174 0ustar hornikusers\name{Bundesliga} \alias{Bundesliga} \title{Ergebnisse der Fussball-Bundesliga} \description{ Results from the first German soccer league (1963-2008). } \usage{ data("Bundesliga") } \format{A data frame with 14018 observations and 7 variables. \describe{ \item{HomeTeam}{factor. Name of the home team.} \item{AwayTeam}{factor. Name of the away team.} \item{HomeGoals}{number of goals scored by the home team.} \item{AwayGoals}{number of goals scored by the away team.} \item{Round}{round of the game.} \item{Year}{year in which the season started.} \item{Date}{starting time of the game (in \code{"POSIXct"} format).} } } \details{ The data comprises all games in the first German soccer league since its foundation in 1963. The data have been queried online from the official Web page of the DFB and prepared as a data frame in R by Daniel Dekic, Torsten Hothorn, and Achim Zeileis (replacing earlier versions of the data in the package containing only subsets of years). Each year/season comprises 34 rounds (except 1963, 1964, 1991) so that all 18 teams play twice against each other (switching home court advantage). In 1963/64, there were only 16 teams, hence only 30 rounds. In 1991, after the German unification, there was one season with 20 teams and 38 rounds. } \source{ Homepage of the Deutscher Fussball-Bund (DFB, German Football Association): \url{https://www.dfb.de/index/} } \references{ Leonhard Knorr-Held (1999), Dynamic rating of sports teams. SFB 386 \dQuote{Statistical Analysis of Discrete Structures}, Discussion paper \bold{98}. } \seealso{ \code{\link{UKSoccer}} } \examples{ data("Bundesliga") ## number of goals per game poisson distributed? ngoals1 <- xtabs(~ HomeGoals, data = Bundesliga, subset = Year == 1995) ngoals2 <- xtabs(~ AwayGoals, data = Bundesliga, subset = Year == 1995) ngoals3 <- table(apply(subset(Bundesliga, Year == 1995)[,3:4], 1, sum)) gf1 <- goodfit(ngoals1) gf2 <- goodfit(ngoals2) gf3 <- goodfit(ngoals3) summary(gf1) summary(gf2) summary(gf3) plot(gf1) plot(gf2) plot(gf3) Ord_plot(ngoals1) distplot(ngoals1) } \keyword{datasets} vcd/man/strucplot.Rd0000644000175100001440000002662014534320114014150 0ustar hornikusers\name{strucplot} \alias{strucplot} \title{Structured Displays of Contingency Tables} \description{ This modular function visualizes certain aspects of high-dimensional contingency tables in a hierarchical way. } \usage{ strucplot(x, residuals = NULL, expected = NULL, condvars = NULL, shade = NULL, type = c("observed", "expected"), residuals_type = NULL, df = NULL, split_vertical = NULL, spacing = spacing_equal, spacing_args = list(), gp = NULL, gp_args = list(), labeling = labeling_border, labeling_args = list(), core = struc_mosaic, core_args = list(), legend = NULL, legend_args = list(), main = NULL, sub = NULL, margins = unit(3, "lines"), title_margins = NULL, legend_width = NULL, main_gp = gpar(fontsize = 20), sub_gp = gpar(fontsize = 15), newpage = TRUE, pop = TRUE, return_grob = FALSE, keep_aspect_ratio = NULL, prefix = "", \dots) } \arguments{ \item{x}{a contingency table in array form, with optional category labels specified in the \code{dimnames} attribute.} \item{residuals}{optionally, an array of residuals of the same dimension as \code{x} (see details).} \item{expected}{optionally, an array of expected values of the same dimension as \code{x}, or alternatively the corresponding independence model specification as used by \code{\link[stats]{loglin}} or \code{\link[MASS]{loglm}} (see details).} \item{df}{degrees of freedom passed to the shading functions used for inference. Will be calculated (and overwritten if specified) if both \code{expected} and \code{residuals} are \code{NULL}, or if \code{expected} is given a formula.} \item{condvars}{number of conditioning variables, if any; those are expected to be ordered first in the table. This information is used for computing the expected values, and is also passed to the spacing functions (see \code{\link{spacings}}).} \item{shade}{logical specifying whether \code{gp} should be used or not (see \code{gp}). If \code{TRUE} and \code{expected} is unspecified, a default model is fitted: if \code{condvars} is specified, a corresponding conditional independence model, and else the total independence model.} \item{residuals_type}{a character string indicating the type of residuals to be computed when none are supplied. If \code{residuals} is \code{NULL}, \code{residuals_type} must be one of \code{"pearson"} (default; giving components of Pearson's chi-squared), \code{"deviance"} (giving components of the likelihood ratio chi-squared), or \code{"FT"} for the Freeman-Tukey residuals. The value of this argument can be abbreviated. If \code{residuals} are specified, the value of \code{residuals_type} is just passed \dQuote{as is} to the legend function.} \item{type}{a character string indicating whether the observed or the expected values of the table should be visualized.} \item{split_vertical}{vector of logicals of length \eqn{k}, where \eqn{k} is the number of margins of \code{x} (values are recycled as needed). A \code{TRUE} component indicates that the tile(s) of the corresponding dimension should be split vertically, \code{FALSE} means horizontal splits. Default is \code{FALSE.}} \item{spacing}{spacing object, spacing function, or a corresponding generating function (see details and \code{\link{spacings}}).} \item{spacing_args}{list of arguments for the spacing-generating function, if specified.} \item{gp}{object of class \code{"gpar"}, shading function or a corresponding generating function (see details and \code{\link{shadings}}). Components of \code{"gpar"} objects are recycled as needed along the last splitting dimension. Ignored if \code{shade = FALSE}.} \item{gp_args}{list of arguments for the shading-generating function, if specified.} \item{labeling}{either a logical, or a labeling function, or a corresponding generating function (see details and \code{\link{labelings}}. If \code{FALSE} or \code{NULL}, no labeling is produced.} \item{labeling_args}{list of arguments for the labeling-generating function, if specified.} \item{core}{either a core function, or a corresponding generating function (see details). Currently, generating functions for mosaic plots (\code{\link{struc_mosaic}}), association plots (\code{\link{struc_assoc}}), and sieve plots (\code{\link{struc_sieve}}) are provided.} \item{core_args}{list of arguments for the core-generating function, if specified.} \item{legend}{either a legend-generating function, or a legend function (see details and \code{\link{legends}}), or a logical. If \code{legend} is \code{NULL} or \code{TRUE} and \code{gp} is a function, legend defaults to \code{\link{legend_resbased}}.} \item{legend_args}{list of arguments for the legend-generating function, if specified.} \item{main}{either a logical, or a character string used for plotting the main title. If \code{main} is a logical and \code{TRUE}, the name of the object supplied as \code{x} is used.} \item{sub}{a character string used for plotting the subtitle. If \code{sub} is a logical and \code{TRUE} and \code{main} is unspecified, the name of the object supplied as \code{x} is used.} \item{margins}{either an object of class \code{"unit"} of length 4, or a numeric vector of length 4. The elements are recycled as needed. The four components specify the top, right, bottom, and left margin of the plot, respectively. When a numeric vector is supplied, the numbers are interpreted as \code{"lines"} units. In addition, the unit or numeric vector may have named arguments (\samp{top}, \samp{right}, \samp{bottom}, and \samp{left}), in which case the non-named arguments specify the default values (recycled as needed), overloaded by the named arguments.} \item{title_margins}{either an object of class \code{"unit"} of length 2, or a numeric vector of length 2. The elements are recycled as needed. The two components specify the top and bottom \emph{title} margin of the plot, respectively. The default for each \emph{specified} title are 2 lines (and 0 else), except when a legend is plotted and \code{keep_aspect_ratio} is \code{TRUE}: in this case, the default values of both margins are set as to align the heights of legend and actual plot. When a numeric vector is supplied, the numbers are interpreted as \code{"lines"} units. In addition, the unit or numeric vector may have named arguments (\samp{top} and \samp{bottom}), in which case the non-named argument specify the default value (recycled as needed), overloaded by the named arguments.} \item{legend_width}{An object of class \code{"unit"} of length 1 specifying the width of the legend (if any). Default: 5 lines.} \item{pop}{logical indicating whether the generated viewport tree should be removed at the end of the drawing or not.} \item{main_gp, sub_gp}{object of class \code{"gpar"} containing the graphical parameters used for the main (sub) title, if specified.} \item{newpage}{logical indicating whether a new page should be created for the plot or not.} \item{return_grob}{logical. Should a snapshot of the display be returned as a grid grob?} \item{keep_aspect_ratio}{logical indicating whether the aspect ratio should be fixed or not. If unspecified, the default is \code{TRUE} for two-dimensional tables and \code{FALSE} otherwise.} \item{prefix}{optional character string used as a prefix for the generated viewport and grob names.} \item{\dots}{For convenience, list of arguments passed to the labeling-generating function used.} } \details{ This function---usually called by higher-level functions such as \code{\link{assoc}} and \code{\link{mosaic}}---generates conditioning plots of contingency tables. First, it sets up a set of viewports for main- and subtitles, legend, and the actual plot region. Then, residuals are computed as needed from observed and expected frequencies, where the expected frequencies are optionally computed for a specified independence model. Finally, the specified functions for spacing, gp, main plot, legend, and labeling are called to produce the plot. The function invisibly returns the \code{"structable"} object visualized. Most elements of the plot, such as the core function, the spacing between the tiles, the shading of the tiles, the labeling, and the legend, are modularized in graphical appearance control (``grapcon'') functions and specified as parameters. For each element \emph{foo} (= \code{spacing}, \code{labeling}, \code{core}, or \code{legend}), \code{strucplot} takes two arguments: \var{foo} and \var{foo_args}, which can be used to specify the parameters in the following alternative ways: \enumerate{ \item Passing a suitable function to \var{foo} which subsequently will be called from \code{strucplot} to compute shadings, labelings, etc. \item Passing a corresponding \emph{generating} function to \var{foo}, along with parameters passed to \var{foo_args}, that generates such a function. Generating functions must inherit from classes \code{"grapcon_generator"} and \code{"\var{foo}"}. \item Except for the shading functions (\var{shading_bar}), passing \var{foo(foo_args)} to the \var{foo} argument. \item For shadings and spacings, passing the final parameter object itself; see the corresponding help pages for more details on the data structures. } If legends are drawn, a \sQuote{cinemascope}-like layout is used for the plot to preserve the 1:1 aspect ratio. If \code{type = "expected"}, the expected values are passed to the \code{observed} argument of the core function, and the observed values to the \code{expected} argument. Although the \code{gp} argument is typically used for shading, it can be used for arbitrary modifications of the tiles' graphics parameters (e.g., for highlighting particular cells, etc.). } \note{ The created viewports, as well as the tiles and bullets, are named and thus can conveniently be modified after a plot has been drawn (and \code{pop = FALSE}). } \value{ Invisibly, an object of class \code{"structable"} corresponding to the plot. If \code{return_grob} is \code{TRUE}, additionally, the plot as a grob object is returned in a \code{grob} attribute. } \author{ David Meyer \email{David.Meyer@R-project.org} } \references{ Meyer, D., Zeileis, A., and Hornik, K. (2006), The strucplot framework: Visualizing multi-way contingency tables with \pkg{vcd}. \emph{Journal of Statistical Software}, \bold{17(3)}, 1-48. \doi{10.18637/jss.v017.i03} and available as \code{vignette("strucplot")}. } \seealso{ \code{\link{assoc}}, \code{\link{mosaic}}, \code{\link{sieve}}, \code{\link{struc_assoc}}, \code{\link{struc_sieve}}, \code{\link{struc_mosaic}}, \code{\link{structable}}, \code{\link{doubledecker}}, \code{\link{labelings}}, \code{\link{shadings}}, \code{\link{legends}}, \code{\link{spacings}} } \examples{ data("Titanic") strucplot(Titanic) strucplot(Titanic, core = struc_assoc) strucplot(Titanic, spacing = spacing_increase, spacing_args = list(start = 0.5, rate = 1.5)) strucplot(Titanic, spacing = spacing_increase(start = 0.5, rate = 1.5)) ## modify a tile's color strucplot(Titanic, pop = FALSE) grid.edit("rect:Class=1st,Sex=Male,Age=Adult,Survived=Yes", gp = gpar(fill = "red")) } \keyword{hplot} vcd/man/coindep_test.Rd0000644000175100001440000000753714541401400014573 0ustar hornikusers\name{coindep_test} \alias{coindep_test} \alias{fitted.coindep_test} \title{Test for (Conditional) Independence} \description{ Performs a test of (conditional) independence of 2 margins in a contingency table by simulation from the marginal distribution of the input table under (conditional) independence. } \usage{ coindep_test(x, margin = NULL, n = 1000, indepfun = function(x) max(abs(x)), aggfun = max, alternative = c("greater", "less"), pearson = TRUE) } \arguments{ \item{x}{a contingency table.} \item{margin}{margin index(es) or corresponding name(s) of the conditioning variables. Each resulting conditional table has to be a 2-way table.} \item{n}{number of (conditional) independence tables to be drawn.} \item{indepfun}{aggregation function capturing independence in (each conditional) 2-way table.} \item{aggfun}{aggregation function aggregating the test statistics computed by \code{indepfun}.} \item{alternative}{a character string specifying the alternative hypothesis; must be either \code{"greater"} (default) or \code{"less"} (and may be abbreviated.)} \item{pearson}{logical. Should the table of Pearson residuals under independence be computed and passed to \code{indepfun} (default) or the raw table of observed frequencies?} } \details{ If \code{margin} is \code{NULL} this computes a simple independence statistic in a 2-way table. Alternatively, \code{margin} can give several conditioning variables and then conditional independence in the resulting conditional table is tested. By default, this uses a (double) maximum statistic of Pearson residuals. By changing \code{indepfun} or \code{aggfun} a (maximum of) Pearson Chi-squared statistic(s) can be computed or just the usual Pearson Chi-squared statistics and so on. Other statistics can be computed by changing \code{pearson} to \code{FALSE}. The function uses \code{\link{r2dtable}} to simulate the distribution of the test statistic under the null. } \value{ A list of class \code{"coindep_test"} inheriting from \code{"htest"} with following components: \item{statistic}{the value of the test statistic.} \item{p.value}{the \eqn{p} value for the test.} \item{method}{a character string indicating the type of the test.} \item{data.name}{a character string giving the name(s) of the data.} \item{observed}{observed table of frequencies} \item{expctd}{expected table of frequencies} \item{residuals}{corresponding Pearson residuals} \item{margin}{the \code{margin} used} \item{dist}{a vector of size \code{n} with simulated values of the distribution of the statistic under the null.} \item{qdist}{the corresponding quantile function (for computing critical values).} \item{pdist}{the corresponding distribution function (for computing \eqn{p} values).} } \author{ Achim Zeileis \email{Achim.Zeileis@R-project.org} } \seealso{ \code{\link{chisq.test}}, \code{\link{fisher.test}}, \code{\link{r2dtable}} } \examples{ library(MASS) TeaTasting <- matrix(c(3, 1, 1, 3), nrow = 2, dimnames = list(Guess = c("Milk", "Tea"), Truth = c("Milk", "Tea")) ) ## compute maximum statistic coindep_test(TeaTasting) ## compute Chi-squared statistic coindep_test(TeaTasting, indepfun = function(x) sum(x^2)) ## use unconditional asymptotic distribution chisq.test(TeaTasting, correct = FALSE) chisq.test(TeaTasting) data("UCBAdmissions") ## double maximum statistic coindep_test(UCBAdmissions, margin = "Dept") ## maximum of Chi-squared statistics coindep_test(UCBAdmissions, margin = "Dept", indepfun = function(x) sum(x^2)) ## Pearson Chi-squared statistic coindep_test(UCBAdmissions, margin = "Dept", indepfun = function(x) sum(x^2), aggfun = sum) ## use unconditional asymptotic distribution loglm(~ Dept * (Gender + Admit), data = UCBAdmissions) } \keyword{htest} vcd/man/Butterfly.Rd0000755000175100001440000000163511150520606014072 0ustar hornikusers\name{Butterfly} \alias{Butterfly} \docType{data} \title{Butterfly Species in Malaya} \description{ Data from Fisher et al. (1943) giving the number of tokens found for each of 501 species of butterflies collected in Malaya. } \usage{ data("Butterfly") } \format{ A 1-way table giving the number of tokens for 501 species of butterflies. The variable and its levels are \tabular{rll}{ No \tab Name \tab Levels \cr 1 \tab nTokens \tab 0, 1, \dots, 24 \cr } } \references{ R. A. Fisher, A. S. Corbet, C. B. Williams (1943), The relation between the number of species and the number of individuals, \emph{Journal of Animal Ecology}, \bold{12}, 42--58. M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \source{ Michael Friendly (2000), Visualizing Categorical Data, pages 21--22. } \examples{ data("Butterfly") Ord_plot(Butterfly) } \keyword{datasets} vcd/man/ternaryplot.Rd0000755000175100001440000001067613210517334014505 0ustar hornikusers\name{ternaryplot} \alias{ternaryplot} \title{Ternary Diagram} \description{ Visualizes compositional, 3-dimensional data in an equilateral triangle. } \usage{ ternaryplot(x, scale = 1, dimnames = NULL, dimnames_position = c("corner","edge","none"), dimnames_color = "black", dimnames_rot = c(-60, 60, 0), id = NULL, id_color = "black", id_just = c("center", "center"), coordinates = FALSE, grid = TRUE, grid_color = "gray", labels = c("inside", "outside", "none"), labels_color = "darkgray", labels_rot = c(120, -120, 0), border = "black", bg = "white", pch = 19, cex = 1, prop_size = FALSE, col = "red", main = "ternary plot", newpage = TRUE, pop = TRUE, return_grob = FALSE, \dots) } \arguments{ \item{x}{a matrix with three columns.} \item{scale}{row sums scale to be used.} \item{dimnames}{dimension labels (defaults to the column names of \code{x}).} \item{dimnames_position, dimnames_color}{position and color of dimension labels.} \item{dimnames_rot}{Numeric vector of length 3, specifying the angle of the dimension labels.} \item{id}{optional labels to be plotted below the plot symbols. \code{coordinates} and \code{id} are mutual exclusive.} \item{id_color}{color of these labels.} \item{id_just}{character vector of length 1 or 2 indicating the justification of these labels.} \item{coordinates}{if \code{TRUE}, the coordinates of the points are plotted below them. \code{coordinates} and \code{id} are mutual exclusive.} \item{grid}{if \code{TRUE}, a grid is plotted. May optionally be a string indicating the line type (default: \code{"dotted"}).} \item{grid_color}{grid color.} \item{labels, labels_color}{position and color of the grid labels.} \item{labels_rot}{Numeric vector of length 3, specifying the angle of the grid labels.} \item{border}{color of the triangle border.} \item{bg}{triangle background.} \item{pch}{plotting character. Defaults to filled dots.} \item{cex}{a numerical value giving the amount by which plotting text and symbols should be scaled relative to the default. Ignored for the symbol size if \code{prop_size} is not \code{FALSE}.} \item{prop_size}{if \code{TRUE}, the symbol size is plotted proportional to the row sum of the three variables, i.e., represents the weight of the observation.} \item{col}{plotting color.} \item{main}{main title.} \item{newpage}{if \code{TRUE}, the plot will appear on a new graphics page.} \item{pop}{logical; if \code{TRUE}, all newly generated viewports are popped after plotting.} \item{return_grob}{logical. Should a snapshot of the display be returned as a grid grob?} \item{\dots}{additional graphics parameters (see \code{par})} } \details{ A points' coordinates are found by computing the gravity center of mass points using the data entries as weights. Thus, the coordinates of a point \eqn{P(a,b,c)}, \eqn{a + b + c = 1}, are: \eqn{P(b + c/2, c \sqrt{3}/2)}{P(b + c/2, c * sqrt(3)/2)}. } \references{ M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \author{ David Meyer \email{David.Meyer@R-project.org} } \examples{ data("Arthritis") ## Build table by crossing Treatment and Sex tab <- as.table(xtabs(~ I(Sex:Treatment) + Improved, data = Arthritis)) ## Mark groups col <- c("red", "red", "blue", "blue") pch <- c(1, 19, 1, 19) ## plot ternaryplot( tab, col = col, pch = pch, prop_size = TRUE, bg = "lightgray", grid_color = "white", labels_color = "white", main = "Arthritis Treatment Data" ) ## legend grid_legend(0.8, 0.7, pch, col, rownames(tab), title = "GROUP") ## Titanic data("Lifeboats") attach(Lifeboats) ternaryplot( Lifeboats[,4:6], pch = ifelse(side == "Port", 1, 19), col = ifelse(side == "Port", "red", "blue"), id = ifelse(men / total > 0.1, as.character(boat), NA), prop_size = 2, dimnames_position = "edge", main = "Lifeboats on Titanic" ) grid_legend(0.8, 0.9, c(1, 19), c("red", "blue"), c("Port", "Starboard"), title = "SIDE") ## Hitters data("Hitters") attach(Hitters) colors <- c("black","red","green","blue","red","black","blue") pch <- substr(levels(Positions), 1, 1) ternaryplot( Hitters[,2:4], pch = as.character(Positions), col = colors[as.numeric(Positions)], main = "Baseball Hitters Data" ) grid_legend(0.8, 0.9, pch, colors, levels(Positions), title = "POSITION(S)") } \keyword{hplot} vcd/man/Arthritis.Rd0000644000175100001440000000235514246371504014072 0ustar hornikusers\name{Arthritis} \alias{Arthritis} \docType{data} \title{Arthritis Treatment Data} \description{ Data from Koch & Edwards (1988) from a double-blind clinical trial investigating a new treatment for rheumatoid arthritis. } \usage{data("Arthritis")} \format{ A data frame with 84 observations and 5 variables. \describe{ \item{ID}{patient ID.} \item{Treatment}{factor indicating treatment (Placebo, Treated).} \item{Sex}{factor indicating sex (Female, Male).} \item{Age}{age of patient.} \item{Improved}{ordered factor indicating treatment outcome (None, Some, Marked).} } } \references{ G. Koch & S. Edwards (1988), Clinical efficiency trials with categorical data. In K. E. Peace (ed.), \emph{Biopharmaceutical Statistics for Drug Development}, 403--451. Marcel Dekker, New York. M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \source{ Michael Friendly (2000), Visualizing Categorical Data: \url{http://euclid.psych.yorku.ca/ftp/sas/vcd/catdata/arthrit.sas} } \examples{ data("Arthritis") art <- xtabs(~ Treatment + Improved, data = Arthritis, subset = Sex == "Female") art mosaic(art, gp = shading_Friendly) mosaic(art, gp = shading_max) } \keyword{datasets} vcd/man/Rochdale.Rd0000755000175100001440000000233011150520606013624 0ustar hornikusers\name{Rochdale} \alias{Rochdale} \docType{data} \title{Rochdale Data} \description{ Information on 665 households of Rochdale, Lancashire, UK. The study was conducted to identify influence factors on economical activity of wives. } \usage{ data("Rochdale") } \format{ A 8-dimensional array resulting from cross-tabulating 665 observations on 8 variables. The variables and their levels are as follows: \tabular{rll}{ No \tab Name \tab Levels \cr 1 \tab EconActive \tab yes, no \cr 2 \tab Age \tab <38, >38 \cr 3 \tab HusbandEmployed \tab yes, no \cr 4 \tab Child \tab yes, no \cr 5 \tab Education \tab yes, no \cr 6 \tab HusbandEducation \tab yes, no \cr 7 \tab Asian \tab yes, no \cr 8 \tab HouseholdWorking \tab yes, no \cr } } \note{ Many observations are missing: only 91 out of all 256 combinations contain information. } \source{ Whittaker (1990). } \references{ H. Hofmann (2003). Constructing and reading mosaicplots. \emph{Computational Statistics & Data Analysis}, \bold{43}, 4, 565--580. J. Whittaker (1990), \emph{Graphical Models on Applied Multivariate Statistics}, Wiley, New York. } \examples{ data("Rochdale") mosaic(Rochdale) } \keyword{datasets} vcd/man/pairs.table.Rd0000644000175100001440000001454114250300456014316 0ustar hornikusers\name{pairs.table} \alias{pairs.table} \alias{pairs.structable} \title{Pairs Plot for Contingency Tables} \description{ Produces a matrix of strucplot displays. } \usage{ \method{pairs}{table}(x, upper_panel = pairs_mosaic, upper_panel_args = list(), lower_panel = pairs_mosaic, lower_panel_args = list(), diag_panel = pairs_diagonal_mosaic, diag_panel_args = list(), main = NULL, sub = NULL, main_gp = gpar(fontsize = 20), sub_gp = gpar(fontsize = 15), space = 0.3, newpage = TRUE, pop = TRUE, return_grob = FALSE, margins = unit(1, "lines"), \dots) } \arguments{ \item{x}{a contingency table in array form, with optional category labels specified in the \code{dimnames(x)} attribute.} \item{upper_panel}{function for the upper triangle of the matrix, or corresponding generating function. If \code{NULL}, no panel is drawn.} \item{upper_panel_args}{list of arguments for the generating function, if specified.} \item{lower_panel}{function for the lower triangle of the matrix, or corresponding generating function. If \code{NULL}, no panel is drawn.} \item{lower_panel_args}{list of arguments for the panel-generating function, if specified.} \item{diag_panel}{function for the diagonal of the matrix, or corresponding generating function. If \code{NULL}, no panel is drawn.} \item{diag_panel_args}{list of arguments for the generating function, if specified.} \item{main}{either a logical, or a character string used for plotting the main title. If \code{main} is a logical and \code{TRUE}, the name of the object supplied as \code{x} is used.} \item{sub}{a character string used for plotting the subtitle. If \code{sub} is a logical and \code{TRUE} and \code{main} is unspecified, the name of the object supplied as \code{x} is used.} \item{main_gp, sub_gp}{object of class \code{"gpar"} containing the graphical parameters used for the main (sub) title, if specified.} \item{space}{double specifying the distance between the cells.} \item{newpage}{logical controlling whether a new grid page should be created.} \item{pop}{logical indicating whether all viewports should be popped after the plot has been drawn.} \item{return_grob}{logical. Should a snapshot of the display be returned as a grid grob?} \item{margins}{either an object of class \code{"unit"} of length 4, or a numeric vector of length 4. The elements are recycled as needed. The four components specify the top, right, bottom, and left margin of the plot, respectively. When a numeric vector is supplied, the numbers are interpreted as \code{"lines"} units. In addition, the unit or numeric vector may have named arguments (\samp{top}, \samp{right}, \samp{bottom}, and \samp{left}), in which case the non-named arguments specify the default values (recycled as needed), overloaded by the named arguments.} \item{\dots}{For convenience, list of arguments for the panel-generating functions of upper and lower panels, if specified.} } \details{ This is a \code{\link[graphics]{pairs}} method for objects inheriting from class \code{"table"} or \code{"structable"}. It plots a matrix of pairwise mosaic plots. Four independence types are distinguished: \code{"pairwise"}, \code{"total"}, \code{"conditional"} and \code{"joint"}. The pairwise mosaic matrix shows bivariate marginal relations, collapsed over all other variables. The total independence mosaic matrix shows mosaic plots for mutual independence, i.e., for marginal and conditional independence among all pairs of variables. The conditional independence mosaic matrix shows mosaic plots for conditional independence for each pair of variables, given all other variables. The joint independence mosaic matrix shows mosaic plots for joint independence of all pairs of variables from the others. This method uses panel functions called for each cell of the matrix which can be different for upper matrix, lower matrix, and diagonal cells. Correspondingly, for each panel parameter \var{foo} (= \samp{upper}, \samp{lower}, or \samp{diag}), \code{pairs.table} takes two arguments: \var{foo_panel} and \var{foo_panel_args}, which can be used to specify the parameters as follows: \enumerate{ \item Passing a suitable panel function to \var{foo_panel} which subsequently is called for each cell with the corresponding coordinates. \item Passing a corresponding \emph{generating function} (of class \code{"panel_generator"}) to \var{foo_panel}, along with parameters passed to \var{foo_panel_args}, that generates such a function. } Hence, the second approach is equivalent to the first if \var{foo_panel(foo_panel_args)} is passed to \var{foo_panel}. } \seealso{ \code{\link{pairs_mosaic}}, \code{\link{pairs_assoc}}, \code{\link{pairs_sieve}}, \code{\link{pairs_diagonal_text}}, \code{\link{pairs_diagonal_mosaic}}, \code{\link{pairs_text}}, \code{\link{pairs_barplot}}, \code{\link{assoc}}, \code{\link{sieve}}, \code{\link{mosaic}} } \references{ Cohen, A. (1980), On the graphical display of the significant components in a two-way contingency table. \emph{Communications in Statistics---Theory and Methods}, \bold{A9}, 1025--1041. Friendly, M. (1992), Graphical methods for categorical data. \emph{SAS User Group International Conference Proceedings}, \bold{17}, 190--200. \url{http://datavis.ca/papers/sugi/sugi17.pdf} Meyer, D., Zeileis, A., and Hornik, K. (2006), The strucplot framework: Visualizing multi-way contingency tables with \pkg{vcd}. \emph{Journal of Statistical Software}, \bold{17(3)}, 1-48. \doi{10.18637/jss.v017.i03} and available as \code{vignette("strucplot")}. } \author{ David Meyer \email{David.Meyer@R-project.org} } \examples{ data("UCBAdmissions") data("PreSex") data(HairEyeColor) hec = structable(Eye ~ Sex + Hair, data = HairEyeColor) pairs(PreSex) pairs(UCBAdmissions) pairs(UCBAdmissions, upper_panel_args = list(shade = TRUE)) pairs(UCBAdmissions, lower_panel = pairs_mosaic(type = "conditional")) pairs(UCBAdmissions, diag_panel = pairs_text) pairs(UCBAdmissions, upper_panel = pairs_assoc, shade = TRUE) pairs(hec, highlighting = 2, diag_panel_args = list(fill = grey.colors)) pairs(hec, highlighting = 2, diag_panel = pairs_diagonal_mosaic, diag_panel_args = list(fill = grey.colors, alternate_labels =TRUE)) } \keyword{hplot} vcd/man/mplot.Rd0000755000175100001440000000404112535317336013253 0ustar hornikusers\name{mplot} \alias{mplot} \title{Multiple Grid plots} \description{ combines severals grid-based plots in a multi-panel-layout. } \usage{ mplot(..., .list = list(), layout = NULL, cex = NULL, main = NULL, gp_main = gpar(fontsize = 20), sub = NULL, gp_sub = gpar(fontsize = 15), keep_aspect_ratio = TRUE) } \arguments{ \item{\dots, .list}{A list of objects inheriting from class \code{"grob"}, or having a \code{"grob"} attribute containing such an object.} \item{layout}{integer vector of length 2 giving the number of rows and columns. If \code{NULL}, the values will be guessed using some heuristics from the number of objects supplied in \dots.} \item{cex}{Scaling factor for the fonts in the subplots. If \code{NULL}, the value is calculated as the inverse square root of the row number.} \item{main, sub}{Optional main and sub title, respectively.} \item{gp_main, gp_sub}{Optional objects of class \code{"gpar"} specifying the graphical parameters for the main and sub title, respectively.} \item{keep_aspect_ratio}{logical; should the aspect ratio of the plots be fixed?} } \value{ None. } \details{ This is a convenience function for producing multi-panel plots from grid-based displays, especially those produced by the vcd methods. The layout (number of rows and columns) is guessed from the amount of supplied objects, if not supplied. Currently, the vcd plotting functions do not return grob objects by default---this might change in the future. Also, some of them will return the grob object as a \code{"grob"} attribute, attached to the currently returned object. } \author{ David Meyer \email{David.Meyer@R-project.org} } \examples{ mplot(mosaic(Titanic, return_grob = TRUE), assoc(Titanic), return_grob = TRUE) A = mosaic(Titanic, return_grob = TRUE) B = mosaic(Titanic, type = "expected", return_grob = TRUE) mplot(A, B) mplot(sieve(SexualFun, return_grob = TRUE), agreementplot(SexualFun, return_grob = TRUE), main = "Sexual Fun") mplot(A, grid.circle()) }vcd/man/distplot.Rd0000755000175100001440000000763012610700606013757 0ustar hornikusers\name{distplot} \alias{distplot} \title{Diagnostic Distribution Plots} \description{ Diagnostic distribution plots: poissonness, binomialness and negative binomialness plots. } \usage{ distplot(x, type = c("poisson", "binomial", "nbinomial"), size = NULL, lambda = NULL, legend = TRUE, xlim = NULL, ylim = NULL, conf_int = TRUE, conf_level = 0.95, main = NULL, xlab = "Number of occurrences", ylab = "Distribution metameter", gp = gpar(cex = 0.8), lwd=2, gp_conf_int = gpar(lty = 2), name = "distplot", newpage = TRUE, pop =TRUE, return_grob = FALSE, \dots) } \arguments{ \item{x}{either a vector of counts, a 1-way table of frequencies of counts or a data frame or matrix with frequencies in the first column and the corresponding counts in the second column.} \item{type}{a character string indicating the distribution.} \item{size}{the size argument for the binomial and negative binomial distribution. If set to \code{NULL} and \code{type} is \code{"binomial"}, then \code{size} is taken to be the maximum count. If set to \code{NULL} and \code{type} is \code{"nbinomial"}, then \code{size} is estimated from the data.} \item{lambda}{parameter of the poisson distribution. If type is \code{"poisson"} and \code{lambda} is specified a leveled poissonness plot is produced.} \item{legend}{logical. Should a legend be plotted?} \item{xlim}{limits for the x axis.} \item{ylim}{limits for the y axis.} \item{conf_int}{logical. Should confidence intervals be plotted?} \item{conf_level}{confidence level for confidence intervals.} \item{main}{a title for the plot.} \item{xlab}{a label for the x axis.} \item{ylab}{a label for the y axis.} \item{gp}{a \code{"gpar"} object controlling the grid graphical parameters of the points.} \item{gp_conf_int}{a \code{"gpar"} object controlling the grid graphical parameters of the confidence intervals.} \item{lwd}{line width for the fitted line} \item{name}{name of the plotting viewport.} \item{newpage}{logical. Should \code{\link{grid.newpage}} be called before plotting?} \item{pop}{logical. Should the viewport created be popped?} \item{return_grob}{logical. Should a snapshot of the display be returned as a grid grob?} \item{\dots}{further arguments passed to \code{\link{grid.points}}.} } \details{ \code{distplot} plots the number of occurrences (counts) against the distribution metameter of the specified distribution. If the distribution fits the data, the plot should show a straight line. See Friendly (2000) for details. In these plots, the open points show the observed count metameters; the filled points show the confidence interval centers, and the dashed lines show the \code{conf_level} confidence intervals for each point. } \value{ Returns invisibly a data frame containing the counts (\code{Counts}), frequencies (\code{Freq}) and other details of the computations used to construct the plot. } \author{ Achim Zeileis \email{Achim.Zeileis@R-project.org} } \references{ D. C. Hoaglin (1980), A poissonness plot, \emph{The American Statistican}, \bold{34}, 146--149. D. C. Hoaglin & J. W. Tukey (1985), Checking the shape of discrete distributions. In D. C. Hoaglin, F. Mosteller, J. W. Tukey (eds.), \emph{Exploring Data Tables, Trends and Shapes}, chapter 9. John Wiley & Sons, New York. M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \examples{ ## Simulated data examples: dummy <- rnbinom(1000, size = 1.5, prob = 0.8) distplot(dummy, type = "nbinomial") ## Real data examples: data("HorseKicks") data("Federalist") data("Saxony") distplot(HorseKicks, type = "poisson") distplot(HorseKicks, type = "poisson", lambda = 0.61) distplot(Federalist, type = "poisson") distplot(Federalist, type = "nbinomial", size = 1) distplot(Federalist, type = "nbinomial") distplot(Saxony, type = "binomial", size = 12) } \keyword{category} vcd/man/independence_table.Rd0000755000175100001440000000126111150520606015675 0ustar hornikusers\name{independence_table} \alias{independence_table} \title{Independence Table} \description{ Computes table of expected frequencies (under the null hypotheses of independence) from an \eqn{n}-way table. } \usage{ independence_table(x, frequency = c("absolute", "relative")) } \arguments{ \item{x}{a table.} \item{frequency}{indicates whether absolute or relative frequencies should be computed.} } \value{ A table with either absolute or relative frequencies. } \author{ David Meyer \email{David.Meyer@R-project.org} } \examples{ data("MSPatients") independence_table(MSPatients) independence_table(MSPatients, frequency = "relative") } \keyword{category} \keyword{array} vcd/man/loddsratio.Rd0000755000175100001440000002426312535321266014271 0ustar hornikusers\name{loddsratio} \alias{loddsratio} \alias{oddsratio} \alias{loddsratio.default} \alias{loddsratio.formula} \alias{coef.loddsratio} \alias{confint.loddsratio} \alias{dim.loddsratio} \alias{dimnames.loddsratio} \alias{print.loddsratio} \alias{vcov.loddsratio} \alias{as.matrix.loddsratio} \alias{as.array.loddsratio} \alias{aperm.loddsratio} \alias{t.loddsratio} \alias{as.data.frame.loddsratio} \title{ Calculate Generalized Log Odds Ratios for Frequency Tables } \description{ Computes (log) odds ratios and their asymptotic variance covariance matrix for R x C (x strata) tables. Odds ratios are calculated for two array dimensions, separately for each level of all stratifying dimensions. See Friendly et al. (2011) for a sketch of a general theory. } \usage{ loddsratio(x, \dots) \method{loddsratio}{default}(x, strata = NULL, log = TRUE, ref = NULL, correct = any(x == 0L), \dots) \method{loddsratio}{formula}(formula, data = NULL, \dots, subset = NULL, na.action = NULL) oddsratio(x, stratum = NULL, log = TRUE) \method{coef}{loddsratio}(object, log = object$log, \dots) \method{vcov}{loddsratio}(object, log = object$log, \dots) \method{print}{loddsratio}(x, log = x$log, \dots) \method{confint}{loddsratio}(object, parm, level = 0.95, log = object$log, \dots) %as.array(x, \dots) \method{as.array}{loddsratio}(x, log=x$log, \dots) \method{t}{loddsratio}(x) \method{aperm}{loddsratio}(a, perm, \dots) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{an object. For the default method a k-way matrix/table/array of frequencies. The number of margins has to be at least 2.} \item{strata, stratum}{Numeric or character indicating the margins of a $k$-way table \code{x} (with $k$ greater than 2) that should be employed as strata. By default all dimensions except the first two are used.} \item{ref}{numeric or character. Reference categories for the (non-stratum) row and column dimensions that should be employed for computing the odds ratios. By default, odds ratios for profile contrasts (or sequential contrasts, i.e., successive differences of adjacent categories) are used. See details below.} \item{formula}{a formula specifying the variables used to create a contingency table from \code{data}. A conditioning formula can be specified; the conditioning variables will then be used as strata variables.} \item{data}{either a data frame, or an object of class \code{"table"} or \code{"ftable"}.} \item{subset}{an optional vector specifying a subset of observations to be used.} \item{na.action}{a function which indicates what should happen when the data contain \code{NA}s. Ignored if \code{data} is a contingency table.} \item{log}{logical. Should the results be displayed on a log scale or not? All internal computations are always on the log-scale but the results are transformed by default if \code{log = TRUE}.} \item{correct}{logical or numeric. Should a continuity correction be applied before computing odds ratios? If \code{TRUE}, 0.5 is added to all cells; if numeric (or an array conforming to the data) that value is added to all cells. By default, this not employed unless there are any zero cells in the table, but this correction is often recommended to reduce bias when some frequencies are small (Fleiss, 1981).} \item{a, object}{an object of class \code{loddsratio} as computed by \code{loddsratio}.} \item{perm}{numeric or character vector specifying a permutation of strata.} \item{\dots}{arguments passed to methods.} \item{parm}{a specification of which parameters are to be given confidence intervals, either a vector of numbers or a vector of names. If missing, all parameters are considered.} \item{level}{the confidence level required for the \code{confint} method.} } \details{ For an R x C table, (log) odds ratios are formed for the set of (R-1) x (C-1) 2 x 2 tables, corresponding to some set of contrasts among the row and column variables. The \code{ref} argument allows these to be specified in a general way. \code{ref = NULL} (default) corresponds to \dQuote{profile contrasts} (or sequential contrasts or successive differences) for ordered categories, i.e., R1--R2, R2--R3, R3--R4, etc., and similarly for the column categories. These are sometimes called \dQuote{local odds ratios}. \code{ref = 1} gives contrasts with the first category; \code{ref = dim(x)} gives contrasts with the last category; \code{ref = c(2, 4)} or \code{ref = list(2, 4)} corresponds to the reference being the second category in rows and the fourth in columns. Combinations like \code{ref = list(NULL, 3)} are also possible, as are character vectors, e.g., \code{ref = c("foo", "bar")} also works ("foo" pertaining again to the row reference and "bar" to column reference). Note that all such parameterizations are equivalent, in that one can derive all other possible odds ratios from any non-redundant set, but the interpretation of these values depends on the parameterization. Note also that these reference level parameterizations only have meaning when the primary (non-strata) table dimensions are larger than 2x2. In the 2x2 case, the odds ratios are defined by the order of levels of those variables in the table, so you can achieve a desired interpretation by manipulating the table. See the help page of \code{\link{plot.loddsratio}} for visualization methods. } \value{ An object of class \code{loddsratio}, with the following components: \item{coefficients}{A named vector, of length (R-1) x (C-1) x \code{prod(dim(x)[strata])} containing the log odds ratios. Use the \code{coef} method to extract these from the object, and the \code{confint} method for confidence intervals. For a two-way table, the names for the log odds ratios are constructed in the form Ri:Rj/Ci:Cj using the table names for rows and columns. For a stratified table, the names are constructed in the form Ri:Rj/Ci:Cj|Lk. } \item{vcov}{Variance covariance matrix of the log odds ratios.} \item{dimnames}{Dimension names for the log odds ratios, considered as a table of size (R-1, C-1, \code{dim(x)[strata]}). Use the \code{dim} and \code{dimnames} methods to extract these and manipulate the log odds ratios in relation to the original table.} \item{dim}{Corresponding dimension vector.} \item{contrasts}{A matrix C, such that \code{C \%*\% as.vector(log(x))} gives the log odds ratios. Each row corresponds to one log odds ratio, and is all zero, except for 4 elements of \code{c(1, -1, -1, 1)} for a given 2 x 2 subtable.} \item{log}{A logical, indicating the value of \code{log} in the original call.} } \references{ A. Agresti (2013), \emph{Categorical Data Analysis}, 3rd Ed. New York: Wiley. Fleiss, J. L. (1981). \emph{Statistical Methods for Rates and Proportions}. 2nd Edition. New York: Wiley. M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. Friendly, M., Turner, H,, Firth, D., Zeileis, A. (2011). \emph{Advances in Visualizing Categorical Data Using the vcd, gnm and vcdExtra Packages in R}. Correspondence Analysis and Related Methods (CARME 2011). \url{http://www.datavis.ca/papers/adv-vcd-4up.pdf} } \author{ Achim Zeileis, Michael Friendly and David Meyer. } \note{ The method of calculation is an example of the use of the delta method described by Agresti (2013), Section 16.1.6, giving estimates of log odds ratios and their asymptotic covariance matrix. The \code{coef} method returns the \code{coefficients} component as a vector of length (R-1) x (C-1) x \code{prod(dim(x)[strata])}. The \code{dim} and \code{dimnames} methods provide the proper attributes for treating the \code{coefficients} vector as an (R-1) x (C-1) x strata array. \code{as.matrix} and \code{as.array} methods are also provided for this purpose. The \code{confint} method computes confidence intervals for the log odds ratios (or for odds ratios, with \code{log = FALSE}). The \code{\link[lmtest]{coeftest}} method (\code{summary} is an alias) prints the asymptotic standard errors, z tests (standardized log odds ratios), and the corresponding p values. \emph{Structural zeros}: In addition to the options for zero cells provided by \code{correct}, the function allows for structural zeros to be represented as \code{NA} in the data argument. \code{NA} in the data yields \code{NA} as the \code{LOR} estimate, but does not affect other cells. \code{oddsratio} is just an alias to \code{loddsratio} for backward compatibility. } %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ %%\code{\link[vcd]{oddsratio}}, \code{\link{plot.loddsratio}} for some plotting methods; \code{\link[stats]{confint}} for confidence intervals; \code{\link[lmtest]{coeftest}} for z-tests of significance } \examples{ ## artificial example set.seed(1) x <- matrix(rpois(5 * 3, 7), ncol = 5, nrow = 3) dimnames(x) <- list(Row = head(letters, 3), Col = tail(letters, 5)) x_lor <- loddsratio(x) coef(x_lor) x_lor confint(x_lor) summary(x_lor) ## 2 x 2 x k cases #data(CoalMiners, package = "vcd") lor_CM <- loddsratio(CoalMiners) lor_CM coef(lor_CM) confint(lor_CM) confint(lor_CM, log = FALSE) ## 2 x k x 2 lor_Emp <-loddsratio(Employment) lor_Emp confint(lor_Emp) ## 4 way tables data(Punishment, package = "vcd") lor_pun <- loddsratio(Freq ~ memory + attitude | age + education, data = Punishment) lor_pun confint(lor_pun) summary(lor_pun) # fit linear model using WLS lor_pun_df <- as.data.frame(lor_pun) pun_mod1 <- lm(LOR ~ as.numeric(age) * as.numeric(education), data = lor_pun_df, weights = 1 / ASE^2) anova(pun_mod1) ## illustrate ref levels VA.fem <- xtabs(Freq ~ left + right, subset=gender=="female", data=VisualAcuity) VA.fem loddsratio(VA.fem) # profile contrasts loddsratio(VA.fem, ref=1) # contrasts against level 1 loddsratio(VA.fem, ref=dim(VA.fem)) # contrasts against level 4 } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{category} %\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line vcd/man/Employment.Rd0000755000175100001440000000342011150520606014235 0ustar hornikusers\name{Employment} \alias{Employment} \docType{data} \title{Employment Status} \description{ Data from a 1974 Danish study given by Andersen (1991) on the employees who had been laid off. The workers are classified by their employment status on 1975-01-01, the cause of their layoff and the length of employment before they were laid off. } \usage{ data("Employment") } \format{ A 3-dimensional array resulting from cross-tabulating variables for 1314 employees. The variables and their levels are as follows: \tabular{rll}{ No \tab Name \tab Levels \cr 1 \tab EmploymentStatus \tab NewJob, Unemployed \cr 2 \tab EmploymentLength \tab <1Mo, 1-3Mo, 3-12Mo, 1-2Yr, 2-5Yr, >5Yr \cr 3 \tab LayoffCause \tab Closure, Replaced } } \references{ E. B. Andersen (1991), \emph{The Statistical Analysis of Categorical Data}. Springer-Verlag, Berlin. M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \source{ Michael Friendly (2000), Visualizing Categorical Data, pages 126--129. } \examples{ data("Employment") ## Employment Status mosaic(Employment, expected = ~ LayoffCause * EmploymentLength + EmploymentStatus, main = "Layoff*EmployLength + EmployStatus") mosaic(Employment, expected = ~ LayoffCause * EmploymentLength + LayoffCause * EmploymentStatus, main = "Layoff*EmployLength + Layoff*EmployStatus") ## Stratified view grid.newpage() pushViewport(viewport(layout = grid.layout(ncol = 2))) pushViewport(viewport(layout.pos.col = 1)) ## Closure mosaic(Employment[,,1], main = "Layoff: Closure", newpage = FALSE) popViewport(1) pushViewport(viewport(layout.pos.col = 2)) ## Replaced mosaic(Employment[,,2], main = "Layoff: Replaced", newpage = FALSE) popViewport(2) } \keyword{datasets} vcd/man/WomenQueue.Rd0000644000175100001440000000231014246371504014202 0ustar hornikusers\name{WomenQueue} \alias{WomenQueue} \docType{data} \title{Women in Queues} \description{ Data from Jinkinson & Slater (1981) and Hoaglin & Tukey (1985) reporting the frequency distribution of females in 100 queues of length 10 in a London Underground station. } \usage{ data("WomenQueue") } \format{ A 1-way table giving the number of women in 100 queues of length 10. The variable and its levels are \tabular{rll}{ No \tab Name \tab Levels \cr 1 \tab nWomen \tab 0, 1, \dots, 10 \cr } } \references{ D. C. Hoaglin & J. W. Tukey (1985), Checking the shape of discrete distributions. In D. C. Hoaglin, F. Mosteller, J. W. Tukey (eds.), \emph{Exploring Data Tables, Trends and Shapes}, chapter 9. John Wiley & Sons, New York. R. A. Jinkinson & M. Slater (1981), Critical discussion of a graphical method for identifying discrete distributions, \emph{The Statistician}, \bold{30}, 239--248. M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \source{ M. Friendly (2000), Visualizing Categorical Data, pages 19--20. } \examples{ data("WomenQueue") gf <- goodfit(WomenQueue, type = "binomial") summary(gf) plot(gf) } \keyword{datasets} vcd/man/JointSports.Rd0000755000175100001440000000233412214055144014407 0ustar hornikusers\name{JointSports} \alias{JointSports} \docType{data} \title{Opinions About Joint Sports} \description{ Data from a Danish study in 1983 and 1985 about sports activities and the opinion about joint sports with the other gender among 16--19 year old high school students. } \usage{ data("JointSports") } \format{ A data frame with 40 observations and 5 variables. \describe{ \item{Freq}{frequency.} \item{opinion}{factor indicating opinion about sports joint with the other gender (very good, good, indifferent, bad, very bad).} \item{year}{factor indicating year of study (1983, 1985).} \item{grade}{factor indicating school grade (1st, 3rd).} \item{gender}{factor indicating gender (Boy, Girl).} } } \references{ E. B. Andersen (1991), \emph{The Statistical Analysis of Categorical Data}. 2nd edition. Springer-Verlag, Berlin. } \source{ E. B. Andersen (1991), The Statistical Analysis of Categorical Data, page 210. } \examples{ library(MASS) data("JointSports") tab <- xtabs(Freq ~ gender + opinion + grade + year, data = JointSports) doubledecker(opinion ~ gender + year + grade, data = tab) loglm(~ opinion* (gender + grade+ year) + gender*year*grade, data = tab) } \keyword{datasets} vcd/man/CoalMiners.Rd0000755000175100001440000000420312475151440014147 0ustar hornikusers\name{CoalMiners} \alias{CoalMiners} \title{Breathlessness and Wheeze in Coal Miners} \description{ Data from Ashford & Sowden (1970) given by Agresti (1990) on the association between two pulmonary conditions, breathlessness and wheeze, in a large sample of coal miners who were smokers with no radiological evidence of pneumoconlosis, aged between 20--64 when examined. This data is frequently used as an example of fitting models for bivariate, binary responses. } \usage{ data("CoalMiners") } \format{ A 3-dimensional table of size 2 x 2 x 9 resulting from cross-tabulating variables for 18,282 coal miners. The variables and their levels are as follows: \tabular{rll}{ No \tab Name \tab Levels \cr 1 \tab Breathlessness \tab B, NoB \cr 2 \tab Wheeze \tab W, NoW \cr 3 \tab Age \tab 20-24, 25-29, 30-34, \dots, 60-64 } } \details{ In an earlier version of this data set, the first group, aged 20-24, was inadvertently omitted from this data table and the breathlessness variable was called wheeze and vice versa. } \references{ A. Agresti (1990), \emph{Categorical Data Analysis}. Wiley-Interscience, New York, Table 7.11, p. 237 J. R. Ashford and R. D. Sowdon (1970), Multivariate probit analysis, \emph{Biometrics}, \bold{26}, 535--546. M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \source{ Michael Friendly (2000), Visualizing Categorical Data, pages 82--83, 319--322. } \examples{ data("CoalMiners") ftable(CoalMiners, row.vars = 3) ## Fourfold display, both margins equated fourfold(CoalMiners[,,2:9], mfcol = c(2,4)) ## Fourfold display, strata equated fourfold(CoalMiners[,,2:9], std = "ind.max", mfcol = c(2,4)) ## Log Odds Ratio Plot lor_CM <- loddsratio(CoalMiners) summary(lor_CM) plot(lor_CM) lor_CM_df <- as.data.frame(lor_CM) # fit linear models using WLS age <- seq(20, 60, by = 5) lmod <- lm(LOR ~ age, weights = 1 / ASE^2, data = lor_CM_df) grid.lines(age, fitted(lmod), gp = gpar(col = "blue")) qmod <- lm(LOR ~ poly(age, 2), weights = 1 / ASE^2, data = lor_CM_df) grid.lines(age, fitted(qmod), gp = gpar(col = "red")) } \keyword{datasets} vcd/man/NonResponse.Rd0000755000175100001440000000164511150520606014364 0ustar hornikusers\name{NonResponse} \alias{NonResponse} \docType{data} \title{Non-Response Survey Data} \description{ Data about non-response for a Danish survey in 1965. } \usage{ data("NonResponse") } \format{ A data frame with 12 observations and 4 variables. \describe{ \item{Freq}{frequency.} \item{residence}{factor indicating whether residence was in Copenhagen, in a city outside Copenhagen or at the countryside (Copenhagen, City, Country).} \item{response}{factor indicating whether a response was given (yes, no).} \item{gender}{factor indicating gender (male, female).} } } \references{ E. B. Andersen (1991), \emph{The Statistical Analysis of Categorical Data}. 2nd edition. Springer-Verlag, Berlin. } \source{ E. B. Andersen (1991), The Statistical Analysis of Categorical Data, Table 5.17. } \examples{ data("NonResponse") structable(~ ., data = NonResponse) } \keyword{datasets} vcd/man/labeling_cells_list.Rd0000755000175100001440000001204014133457305016105 0ustar hornikusers\name{labeling_cells_list} \alias{labeling_list} \alias{labeling_cells} \title{Labeling Functions for Strucplots} \description{ These functions generate labeling functions that produce labels for strucplots. } \usage{ labeling_cells(labels = TRUE, varnames = TRUE, abbreviate_labels = FALSE, abbreviate_varnames = FALSE, gp_text = gpar(), lsep = ": ", lcollapse = "\n", just = "center", pos = "center", rot = 0, margin = unit(0.5, "lines"), clip_cells = TRUE, text = NULL, \dots) labeling_list(gp_text = gpar(), just = "left", pos = "left", lsep = ": ", sep = " ", offset = unit(c(2, 2), "lines"), varnames = TRUE, cols = 2, \dots) } \arguments{ \item{labels}{vector of logicals indicating, for each dimension, whether labels for the factor levels should be drawn or not. Values are recycled as needed.} \item{varnames}{vector of logicals indicating, for each dimension, whether variable names should be drawn. Values are recycled as needed.} \item{abbreviate_labels}{vector of integers or logicals indicating, for each dimension, the number of characters the labels should be abbreviated to. \code{TRUE} means 1 character, \code{FALSE} causes no abbreviation. Values are recycled as needed.} \item{abbreviate_varnames}{vector of integers or logicals indicating, for each dimension, the number of characters the variable (i.e., dimension) names should be abbreviated to. \code{TRUE} means 1 character, \code{FALSE} causes no abbreviation. Values are recycled as needed.} \item{gp_text}{object of class \code{"gpar"} used for the text drawn.} \item{lsep}{character that separates variable names from the factor levels.} \item{sep}{character that separates the factor levels (only used for \code{labeling_list}).} \item{offset}{object of class \code{"unit"} of length 2 specifying the offset in x- and y-direction of the text block drawn under the strucplot (only used for \code{labeling_list}).} \item{cols}{number of text columns (only used for \code{labeling_list}).} \item{lcollapse}{character that separates several variable name/factor level-combinations. Typically a line break. (Only used for \code{labeling_cells}.)} \item{just, pos}{character string of length 1 (\code{labeling_list}) or at most 2 (\code{labeling_cells}) specifying the labels' horizontal position and justification (horizontal and vertical for \code{labeling_cells}).} \item{rot}{rotation angle in degrees, used for all labels (only used for \code{labeling_cells}).} \item{margin}{object of class \code{"unit"} (a numeric value is converted to \code{"lines"}) specifying an offset from the cell borders (only used for \code{labeling_cells}).} \item{clip_cells}{logical indicating whether text should be clipped at the cell borders (only used for \code{labeling_cells}).} \item{text}{Optionally, a character table of the same dimensions than the contingency table whose entries will then be used instead of the labels. \code{NA} entries are not drawn. This allows custom cell annotations (see examples). Only used for \code{labeling_cells}.} \item{\dots}{Currently not used.} } \details{ These functions generate labeling functions that can add different kinds of labels to an existing plot. Typically they are supplied to \code{\link{strucplot}} which then generates and calls the labeling function. They assume that a strucplot has been drawn and the corresponding viewport structure is pushed, so that by navigating through the viewport tree the labels can be positioned appropriately. This help page only documents \code{labeling_list} and \code{labeling_cells}; more functions are described on the help page for \code{\link{labeling_border}}. The functions can also be used \sQuote{stand-alone} as shown in the examples. Using \code{labeling_list} will typically necessitate a bottom margin adjustment. } \value{ A function with arguments: \item{d}{\code{"dimnames"} attribute from the visualized contingency table, or the visualized table itself from which the \code{"dimnames"} attributes will then be extracted.} \item{split_vertical}{vector of logicals indicating the split directions.} \item{condvars}{integer vector of conditioning dimensions} } \author{ David Meyer \email{David.Meyer@R-project.org} } \references{ Meyer, D., Zeileis, A., and Hornik, K. (2006), The strucplot framework: Visualizing multi-way contingency tables with \pkg{vcd}. \emph{Journal of Statistical Software}, \bold{17(3)}, 1-48. \doi{10.18637/jss.v017.i03} and available as \code{vignette("strucplot")}. } \seealso{ \code{\link{labeling_border}}, \code{\link{structable}}, \code{\link[grid]{grid.text}} } \examples{ data("Titanic") mosaic(Titanic, labeling = labeling_cells) mosaic(Titanic, labeling = labeling_list) ## A more complex example, adding the observed frequencies ## to a mosaic plot: tab <- ifelse(Titanic < 6, NA, Titanic) mosaic(Titanic, pop = FALSE) labeling_cells(text = tab, margin = 0)(Titanic) } \keyword{hplot} vcd/man/hls.Rd0000755000175100001440000000132111150520606012670 0ustar hornikusers\name{hls} \alias{hls} \title{HLS Color Specification} \description{ Create a HLS color from specifying hue, luminance and saturation. } \usage{ hls(h = 1, l = 0.5, s = 1) } \arguments{ \item{h}{hue value in [0, 1].} \item{l}{luminance value in [0, 1].} \item{s}{saturation value in [0, 1].} } \details{ HLS colors are a similar specification of colors as HSV colors, but using hue/luminance/saturation rather that hue/saturation/value. } \author{ Achim Zeileis \email{Achim.Zeileis@R-project.org} } \seealso{ \code{\link{hsv}}, \code{\link{hcl2hex}}, \code{\link[colorspace]{polarLUV}} } \examples{ ## an HLS color wheel pie(rep(1, 12), col = sapply(1:12/12, function(x) hls(x))) } \keyword{hplot} vcd/man/Hitters.Rd0000755000175100001440000000327611150520606013537 0ustar hornikusers\name{Hitters} \alias{Hitters} \docType{data} \title{Hitters Data} \description{ This data set is deduced from the \code{\link{Baseball}} fielding data set: fielding performance basically includes the numbers of Errors, Putouts and Assists made by each player. In order to reduce the number of observations, the was compressed by calculating the mean number of errors, putouts and assists for each team and for only 6 positions (1B, 2B, 3B, C, OF, SS and UT). In addition, each of these three variables was scaled to a common range by dividing each variable by the maximum of the variable. } \usage{data("Hitters")} \format{ A data frame with 154 observations and 4 variables. \describe{ \item{Positions}{factor indicating the field position (1B=first baseman, 2B=second baseman, 3B=third baseman, C=catcher, OF=outfielder, SS=Short Stop, UT=Utility Players).} \item{Putouts}{occur when a fielder causes an opposing player to be tagged or forced out.} \item{Assists}{are credited to other fielders involved in making that putout.} \item{Errors}{count the errors made by a player.} } } \references{ M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \source{ SAS System for Statistical Graphics, First Edition, Page A2.3 } \examples{ data("Hitters") attach(Hitters) colors <- c("black","red","green","blue","red","black","blue") pch <- substr(levels(Positions), 1, 1) ternaryplot(Hitters[,2:4], pch = as.character(Positions), col = colors[as.numeric(Positions)], main = "Baseball Hitters Data") grid_legend(0.8, 0.9, pch, colors, levels(Positions), title = "POSITION(S)") detach(Hitters) } \keyword{datasets} vcd/man/WeldonDice.Rd0000755000175100001440000000223611150520606014125 0ustar hornikusers\name{WeldonDice} \alias{WeldonDice} \docType{data} \title{Weldon's Dice Data} \description{ Data from Pearson (1900) about the frequency of 5s and 6s in throws of 12 dice. Weldon tossed the dice 26,306 times and reported his results in a letter to Francis Galton on 1894-02-02. } \usage{ data("WeldonDice") } \format{ A 1-way table giving the frequency of a 5 or a 6 in 26,306 throws of 12 dice where 10 indicates \sQuote{10 or more} 5s or 6s. The variable and its levels are \tabular{rll}{ No \tab Name \tab Levels \cr 1 \tab n56 \tab 0, 1, \dots, 10 \cr } } \references{ K. Pearson (1900), On the criterion that a given system of deviations from the probable in the case of a correlated system of variables is such that it can be reasonably supposed to have arisen by random sampling, \emph{Philosophical Magazine}, \bold{50} (5th series), 157--175. M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \source{ M. Friendly (2000), Visualizing Categorical Data, pages 20--21. } \examples{ data("WeldonDice") gf <- goodfit(WeldonDice, type = "binomial") summary(gf) plot(gf) } \keyword{datasets} vcd/man/OvaryCancer.Rd0000644000175100001440000000401214541401667014327 0ustar hornikusers\name{OvaryCancer} \alias{OvaryCancer} \docType{data} \title{Ovary Cancer Data} \description{ Data from Obel (1975) about a retrospective study of ovary cancer carried out in 1973. Information was obtained from 299 women, who were operated for ovary cancer 10 years before. } \usage{ data("OvaryCancer") } \format{ A data frame with 16 observations and 5 variables. \describe{ \item{Freq}{frequency.} \item{stage}{factor indicating the stage of the cancer at the time of operation (early, advanced).} \item{operation}{factor indicating type of operation (radical, limited).} \item{survival}{factor indicating survival status after 10 years (yes, no).} \item{xray}{factor indicating whether X-ray treatment was received (yes, no).} } } \references{ E. B. Obel (1975), A Comparative Study of Patients with Cancer of the Ovary Who Have Survived More or Less Than 10 Years. \emph{Acta Obstetricia et Gynecologica Scandinavica}, \bold{55}, 429-439. E. B. Andersen (1991), \emph{The Statistical Analysis of Categorical Data}. 2nd edition. Springer-Verlag, Berlin. } \source{ E. B. Andersen (1991), The Statistical Analysis of Categorical Data, Table 6.4. } \examples{ data("OvaryCancer") tab <- xtabs(Freq ~ xray + survival + stage + operation, data = OvaryCancer) ftable(tab, col.vars = "survival", row.vars = c("stage", "operation", "xray")) ## model: ~ xray * operation * stage + survival * stage ## interpretation: treat xray, operation, stage as fixed margins, ## the survival depends on stage, but not xray and operation. doubledecker(survival ~ stage + operation + xray, data = tab) mosaic(~ stage + operation + xray + survival, split_vertical = c(FALSE, TRUE, TRUE, FALSE), data = tab, keep_aspect_ratio = FALSE, gp = gpar(fill = rev(grey.colors(2)))) mosaic(~ stage + operation + xray + survival, split_vertical = c(FALSE, TRUE, TRUE, FALSE), data = tab, keep_aspect_ratio = FALSE, expected = ~ xray * operation * stage + survival*stage) } \keyword{datasets} vcd/man/plot.loglm.Rd0000644000175100001440000000507314671767244014224 0ustar hornikusers\name{plot.loglm} \alias{plot.loglm} \alias{assoc.loglm} \alias{mosaic.loglm} \title{Visualize Fitted Log-linear Models} \description{ Visualize fitted \code{"loglm"} objects by mosaic or association plots. } \usage{ \method{plot}{loglm}(x, panel = mosaic, type = c("observed", "expected"), residuals_type = c("pearson", "deviance"), gp = shading_hcl, gp_args = list(), \dots) } \arguments{ \item{x}{a fitted \code{"loglm"} object, see \code{\link[MASS]{loglm}}.} \item{panel}{a panel function for visualizing the observed values, residuals and expected values. Currently, \code{\link{mosaic}} and \code{\link{assoc}} in \pkg{vcd}.} \item{type}{a character string indicating whether the observed or the expected values of the table should be visualized.} \item{residuals_type}{a character string indicating the type of residuals to be computed.} \item{gp}{object of class \code{"gpar"}, shading function or a corresponding generating function (see details and \code{\link{shadings}}). Ignored if \code{shade = FALSE}.} \item{gp_args}{list of arguments for the shading-generating function, if specified.} \item{\dots}{Other arguments passed to the \code{panel} function.} } \details{ The \code{plot} method for \code{"loglm"} objects by default visualizes the model using a mosaic plot (can be changed to an association plot by setting \code{panel = assoc}) with a shading based on the residuals of this model. The legend also reports the corresponding p value of the associated goodness-of-fit test. The \code{mosaic} and \code{assoc} methods are simple convenience interfaces to this \code{plot} method, setting the \code{panel} argument accordingly. } \value{ The \code{"structable"} visualized is returned invisibly. } \author{ Achim Zeileis \email{Achim.Zeileis@R-project.org} } \seealso{ \code{\link[MASS]{loglm}}, \code{\link{assoc}}, \code{\link{mosaic}}, \code{\link{strucplot}} } \examples{ library(MASS) ## mosaic display for PreSex model data("PreSex") fm <- loglm(~ PremaritalSex * ExtramaritalSex * (Gender + MaritalStatus), data = aperm(PreSex, c(3, 2, 4, 1))) fm ## visualize Pearson statistic plot(fm, split_vertical = TRUE) ## visualize LR statistic plot(fm, split_vertical = TRUE, residuals_type = "deviance") ## conditional independence in UCB admissions data data("UCBAdmissions") fm <- loglm(~ Dept * (Gender + Admit), data = aperm(UCBAdmissions)) ## use mosaic display plot(fm, labeling_args = list(abbreviate_labs = c(Admit = 3))) ## and association plot plot(fm, panel = assoc) assoc(fm) } \keyword{hplot} vcd/man/woolf_test.Rd0000755000175100001440000000214611150520606014275 0ustar hornikusers\name{woolf_test} \alias{woolf_test} \title{Woolf Test} \description{ Test for homogeneity on \eqn{2 \times 2 \times k}{2 x 2 x k} tables over strata (i.e., whether the log odds ratios are the same in all strata). } \usage{ woolf_test(x) } \arguments{ \item{x}{A \eqn{2 \times 2 \times k}{2 x 2 x k} table.} } \value{ A list of class \code{"htest"} containing the following components: \item{statistic}{the chi-squared test statistic.} \item{parameter}{degrees of freedom of the approximate chi-squared distribution of the test statistic.} \item{p.value}{\eqn{p}-value for the test.} \item{method}{a character string indicating the type of test performed.} \item{data.name}{a character string giving the name(s) of the data.} \item{observed}{the observed counts.} \item{expected}{the expected counts under the null hypothesis.} } \seealso{ \code{\link{mantelhaen.test}} } \references{ Woolf, B. 1955. On estimating the relation between blood group and disease. \emph{Ann. Human Genet.} (London) \bold{19}, 251-253. } \examples{ data("CoalMiners") woolf_test(CoalMiners) } \keyword{htest} vcd/man/SexualFun.Rd0000755000175100001440000000276611150520606014032 0ustar hornikusers\name{SexualFun} \alias{SexualFun} \docType{data} \title{Sex is Fun} \description{ Data from Hout et al. (1987) given by Agresti (1990) summarizing the responses of married couples to the questionnaire item: Sex is fun for me and my partner: (a) never or occasionally, (b) fairly often, (c) very often, (d) almost always. } \usage{ data("SexualFun") } \format{ A 2-dimensional array resulting from cross-tabulating the ratings of 91 married couples. The variables and their levels are as follows: \tabular{rll}{ No \tab Name \tab Levels \cr 1 \tab Husband \tab Never Fun, Fairly Often, Very Often, Always Fun \cr 2 \tab Wife \tab Never Fun, Fairly Often, Very Often, Always Fun } } \references{ A. Agresti (1990), \emph{Categorical Data Analysis}. Wiley-Interscience, New York. M. Hout, O. D. Duncan, M. E. Sobel (1987), Association and heterogeneity: Structural models of similarities and differences, \emph{Sociological Methodology}, \bold{17}, 145-184. M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \source{ M. Friendly (2000), Visualizing Categorical Data, page 91. } \examples{ data("SexualFun") ## Kappa statistics Kappa(SexualFun) ## Agreement Chart agreementplot(t(SexualFun), weights = 1) ## Partial Agreement Chart and B-Statistics agreementplot(t(SexualFun), xlab = "Husband's Rating", ylab = "Wife's Rating", main = "Husband's and Wife's Sexual Fun") } \keyword{datasets} vcd/man/fourfold.Rd0000755000175100001440000001517512531710554013745 0ustar hornikusers\name{fourfold} \alias{fourfold} \title{Fourfold Plots} \description{ Creates an (extended) fourfold display of a \eqn{2 \times 2 \times k}{2 x 2 x k} contingency table, allowing for the visual inspection of the association between two dichotomous variables in one or several populations (strata). } \usage{ fourfold(x, color = c("#99CCFF", "#6699CC", "#FFA0A0", "#A0A0FF", "#FF0000", "#000080"), conf_level = 0.95, std = c("margins", "ind.max", "all.max"), margin = c(1, 2), space = 0.2, main = NULL, sub = NULL, mfrow = NULL, mfcol = NULL, extended = TRUE, ticks = 0.15, p_adjust_method = p.adjust.methods, newpage = TRUE, fontsize = 12, default_prefix = c("Row", "Col", "Strata"), sep = ": ", varnames = TRUE, return_grob = FALSE) } \arguments{ \item{x}{a \eqn{2 \times 2 \times k}{2 x 2 x k} contingency table in array form, or a \eqn{2 \times 2}{2 x 2} matrix if \eqn{k} is 1. If \code{length(dim(x)>3}, dimensions \code{3:length(dim(x)} are silently raveled into a combined strata dimension with \code{k=prod(dim(x)[-(1:2)]))}.} \item{color}{a vector of length 6 specifying the colors to use for the smaller and larger diagonals of each \eqn{2 \times 2}{2 x 2} table. The first pair is used for the standard (non-extended) plots, the other two for the extended version: the second/third pair is used for tables with non-significant/significant log-odds ratios, respectively, the latter being visualized in brighter colors.} \item{conf_level}{confidence level used for the confidence rings on the odds ratios. Must be a single non-negative number less than 1; if set to 0, confidence rings are suppressed.} \item{std}{a character string specifying how to standardize the table. Must be one of \code{"margins"}, \code{"ind.max"}, or \code{"all.max"}, and can be abbreviated by the initial letter. If set to \code{"margins"}, each \eqn{2 \times 2}{2 x 2} table is standardized to equate the margins specified by \code{margin} while preserving the odds ratio. If \code{"ind.max"} or \code{"all.max"}, the tables are either individually or simultaneously standardized to a maximal cell frequency of 1.} \item{margin}{a numeric vector with the margins to equate. Must be one of \code{1}, \code{2}, or \code{c(1, 2)} (the default), which corresponds to standardizing only the row, only column, or both row and column in each \eqn{2 \times 2}{2 x 2} table. Only used if \code{std} equals \code{"margins"}.} \item{space}{the amount of space (as a fraction of the maximal radius of the quarter circles) used for the row and column labels.} \item{main, sub}{character string for the fourfold plot title/subtitle.} \item{mfrow, mfcol}{a numeric vector with two components: \var{nr} and \var{nc}, indicating that the displays for the \eqn{2 \times 2}{2 x 2} tables should be arranged in an \var{nr} by \var{nc} layout, filled by rows/columns. The defaults are calculated to give a collection of plots in landscape orientation when \var{k} is not a perfect square.} \item{extended}{logical; if \code{TRUE}, extended plots are plotted, i.e., colors are brighter for significant log-odds ratios, and ticks are plotted showing the direction of association for positive log-odds.} \item{ticks}{the length of the ticks. If set to 0, no ticks are plotted.} \item{p_adjust_method}{method to be used for p-value adjustments for multi-stratum plots, as provided by \code{link[stats]{p.adjust}}. Use \code{p_adjust_method="none"} to disable this adjustment. The p-values are used for the \sQuote{visual} significance tests of the odds ratios.} \item{newpage}{logical; if \code{TRUE}, \code{grid.newpage()} is called before plotting.} \item{fontsize}{fontsize of main title. Other labels are scaled relative to this.} \item{default_prefix}{character vector of length 3 with default labels for possibly missing row/column/strata variable names.} \item{sep}{default separator between variable names and levels for labels.} \item{varnames}{Logical; should the variable names be printed in the labeling of stratifed plots?} \item{return_grob}{Logical; shall a snapshot of the display be returned as a grob object?} } \details{ The fourfold display is designed for the display of \eqn{2 \times 2 \times k}{2 x 2 x k} tables. Following suitable standardization, the cell frequencies \eqn{f_{ij}}{f[i,j]} of each \eqn{2 \times 2}{2 x 2} table are shown as a quarter circle whose radius is proportional to \eqn{\sqrt{f_{ij}}}{sqrt(f[i,j])} so that its area is proportional to the cell frequency. An association (odds ratio different from 1) between the binary row and column variables is indicated by the tendency of diagonally opposite cells in one direction to differ in size from those in the other direction; color is used to show this direction. Confidence rings for the odds ratio allow a visual test of the null of no association; the rings for adjacent quadrants overlap iff the observed counts are consistent with the null hypothesis. Typically, the number \eqn{k} corresponds to the number of levels of a stratifying variable, and it is of interest to see whether the association is homogeneous across strata. The fourfold display visualizes the pattern of association. Note that the confidence rings for the individual odds ratios are not adjusted for multiple testing. } \references{ Friendly, M. (1994), \emph{A fourfold display for 2 by 2 by \eqn{k} tables}. Technical Report 217, York University, Psychology Department, \url{http://datavis.ca/papers/4fold/4fold.pdf}. Friendly, M. (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \seealso{ \code{\link{mosaic}}, \code{\link{assoc}} \code{link[stats]{p.adjust}} for methods of p value adjustment } \examples{ data("UCBAdmissions") ## Use the Berkeley admission data as in Friendly (1995). x <- aperm(UCBAdmissions, c(2, 1, 3)) dimnames(x)[[2]] <- c("Yes", "No") names(dimnames(x)) <- c("Sex", "Admit?", "Department") ftable(x) ## Fourfold display of data aggregated over departments, with ## frequencies standardized to equate the margins for admission ## and sex. ## Figure 1 in Friendly (1994). fourfold(margin.table(x, c(1, 2))) ## Fourfold display of x, with frequencies in each table ## standardized to equate the margins for admission and sex. ## Figure 2 in Friendly (1994). fourfold(x) cotabplot(x, panel = cotab_fourfold) ## Fourfold display of x, with frequencies in each table ## standardized to equate the margins for admission. but not ## for sex. ## Figure 3 in Friendly (1994). fourfold(x, margin = 2) } \keyword{hplot} vcd/man/grid_legend.Rd0000755000175100001440000001164212535260462014365 0ustar hornikusers\name{grid_legend} \alias{grid_legend} \title{Legend Function for grid Graphics} \description{ This function can be used to add legends to \emph{grid-based} plots. } \usage{ grid_legend(x, y, pch = NA, col = par('col'), labels, frame = TRUE, hgap = unit(0.8, "lines"), vgap = unit(0.8, "lines"), default_units = "lines", gp = gpar(), draw = TRUE, title = NULL, just = 'center', lwd = NA, lty = NA, size = 1, gp_title = NULL, gp_labels = NULL, gp_frame = gpar(fill = "transparent"), inset = c(0, 0)) } \arguments{ \item{x}{character string \code{"topright"}, \code{"topleft"}, \code{"bottomright"}, \code{"bottomleft"}, \code{"top"}, \code{"bottom"}, \code{"left"}, \code{"right"}, \code{"center"} or x coordinate of the legend.} \item{y}{y coordinates of the legend.} \item{pch}{integer vector of plotting symbols, if any.} \item{col}{character vector of colors for the symbols.} \item{labels}{character vector of labels corresponding to the symbols.} \item{frame}{logical indicating whether the legend should have a border or not.} \item{hgap}{object of class \code{"unit"} specifying the space between symbols and labels.} \item{vgap}{object of class \code{"unit"} specifying the space between the lines.} \item{default_units}{character string indicating the default unit.} \item{gp}{object of class \code{"gpar"} used for the legend.} \item{draw}{logical indicating whether the legend be drawn or not.} \item{title}{character string indicating the plot's title.} \item{just}{justification of the legend relative to its (x, y) location. see ?viewport for more details.} \item{lwd}{positive number to set the line width. if specified lines are drawn.} \item{lty}{line type. if specified lines are drawn.} \item{size}{size of the group symbols (in char units).} \item{gp_title}{object of class \code{"gpar"} used for the title.} \item{gp_labels}{object of class \code{"gpar"} used for the labels.} \item{gp_frame}{object of class \code{"gpar"} used for the frame.} \item{inset}{numeric vector of length 2 specifying the inset of the legend in npc units, relative to the specified x and y coordinates.} } \value{ Invisibly, the legend as a \code{"grob"} object. } \author{ David Meyer \email{David.Meyer@R-project.org} Florian Gerber \email{florian.gerber@math.uzh.ch} } \seealso{ \code{\link[graphics]{legend}} } \examples{ data("Lifeboats") attach(Lifeboats) ternaryplot(Lifeboats[,4:6], pch = ifelse(side == "Port", 1, 19), col = ifelse(side == "Port", "red", "blue"), id = ifelse(men / total > 0.1, as.character(boat), NA), prop_size = 2, dimnames_position = "edge", main = "Lifeboats on Titanic") grid_legend(0.8, 0.9, c(1, 19), c("red", "blue"), c("Port", "Starboard"), title = "SIDE") grid.newpage() pushViewport(viewport(height = .9, width = .9 )) grid.rect(gp = gpar(lwd = 2, lty = 2)) grid_legend(x = unit(.05,'npc'), y = unit(.05,'npc'), just = c(0,0), pch = c(1,2,3), col = c(1,2,3), lwd=NA, lty=NA, labels = c("b",'r','g'), title = NULL, gp=gpar(lwd=2, cex=1), hgap = unit(.8, "lines"), vgap = unit(.9, "lines")) grid_legend(x = unit(1,'npc'), y = unit(1,'npc'), just = c(1,1), pch = NA, col = c(1,2,3,4), lwd=c(1,1,1,3), lty=c(1,2,1,3), labels = c("black",'red','green','blue'), gp_labels = list(gpar(col = 1), gpar(col = 2), gpar(col = 3), gpar(col = 4)), title = NULL, gp=gpar(lwd=2, cex=1), hgap = unit(.8, "lines"), vgap = unit(.9, "lines")) grid_legend(x = 'topleft', pch = c(1,NA,2,NA), col = c(1,2,3,4), lwd=NA, lty=c(NA,2,NA,3), labels = c("black",'red','green','blue'), title = 'Some LONG Title', gp_title = gpar(col = 3), gp_frame = gpar(col = 4, lty = 2, fill = "transparent"), gp_labels = gpar(col = 6), gp=gpar(lwd=2, cex=2, col = 1), hgap = unit(.8, "lines"), vgap = unit(.9, "lines")) grid_legend(x = .7, y = .7, pch = c(1,NA,2,NA), col = c(1,2,3,4), lwd=1, lty=c(NA,2,NA,3), labels = c("black",'red','green','blue'), title = 'short T', gp=gpar(lwd=1, cex=.7,col = 1), hgap = unit(.8, "lines"), vgap = unit(.9, "lines")) grid_legend(x = 'bottomright', pch = c(1,NA,2,NA), col = c(2), lwd=NA, lty=c(NA,2,NA,3), labels = c("black",'red','green','blue'), title = NULL, gp=gpar(lwd=2, cex=1,col = 1), hgap = unit(.8, "lines"), vgap = unit(.9, "lines")) } \keyword{hplot} vcd/man/Lifeboats.Rd0000755000175100001440000000275011150520606014021 0ustar hornikusers\name{Lifeboats} \alias{Lifeboats} \docType{data} \title{Lifeboats on the Titanic} \description{ Data from Mersey (1912) about the 18 (out of 20) lifeboats launched before the sinking of the S. S. Titanic. } \usage{data("Lifeboats")} \format{ A data frame with 18 observations and 8 variables. \describe{ \item{launch}{launch time in \code{"\link{POSIXt}"} format.} \item{side}{factor. Side of the boat.} \item{boat}{factor indicating the boat.} \item{crew}{number of male crew members on board.} \item{men}{number of men on board.} \item{women}{number of women (including female crew) on board.} \item{total}{total number of passengers.} \item{cap}{capacity of the boat.} } } \references{ L. Mersey (1912), Report on the loss of the \dQuote{Titanic} (S. S.). Parliamentary command paper 6452. M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \source{ M. Friendly (2000), Visualizing Categorical Data: \url{http://euclid.psych.yorku.ca/ftp/sas/vcd/catdata/lifeboat.sas} } \examples{ data("Lifeboats") attach(Lifeboats) ternaryplot( Lifeboats[,4:6], pch = ifelse(side == "Port", 1, 19), col = ifelse(side == "Port", "red", "blue"), id = ifelse(men / total > 0.1, as.character(boat), NA), prop_size = 2, dimnames_position = "edge", main = "Lifeboats on the Titanic" ) grid_legend(0.8, 0.9, c(1, 19), c("red", "blue"), c("Port", "Starboard"), title = "SIDE") detach(Lifeboats) } \keyword{datasets} vcd/man/struc_sieve.Rd0000755000175100001440000000415014133457343014453 0ustar hornikusers\name{struc_sieve} \alias{struc_sieve} \title{Core-generating Function for Sieve Plots} \encoding{UTF-8} \description{ Core-generating function for \code{strucplot} returning a function producing sieve plots. } \usage{ struc_sieve(sievetype = c("observed","expected"), gp_tile = gpar(), scale = 1) } \arguments{ \item{sievetype}{logical indicating whether rectangles should be filled according to \code{observed} or \code{expected} frequencies.} \item{gp_tile}{object of class \code{"gpar"}, controlling the appearance of all \emph{static} elements of the cells (e.g., border and fill color).} \item{scale}{Scaling factor for the sieve.} } \details{ This function is usually called by \code{\link{strucplot}} (typically when called by \code{\link{sieve}}) and returns a function used by \code{\link{strucplot}} to produce sieve plots. } \value{ A function with arguments: \item{residuals}{table of residuals.} \item{observed}{table of observed values.} \item{expected}{not used by \code{struc_sieve}.} \item{spacing}{object of class \code{"unit"} specifying the space between the tiles.} \item{gp}{list of \code{gpar} objects used for the drawing the tiles.} \item{split_vertical}{vector of logicals indicating, for each dimension of the table, the split direction.} } \author{ David Meyer \email{David.Meyer@R-project.org} } \seealso{ \code{\link{sieve}}, \code{\link{strucplot}}, \code{\link{structable}} } \references{ Riedwyl, H., and Schüpbach, M. (1994), Parquet diagram to plot contingency tables. In F. Faulbaum (ed.), \emph{Softstat '93: Advances in Statistical Software}, 293--299. Gustav Fischer, New York. Friendly, M. (2000), Visualizing Categorical Data, SAS Institute, Cary, NC. Meyer, D., Zeileis, A., and Hornik, K. (2006), The strucplot framework: Visualizing multi-way contingency tables with \pkg{vcd}. \emph{Journal of Statistical Software}, \bold{17(3)}, 1-48. \doi{10.18637/jss.v017.i03} and available as \code{vignette("strucplot")}. } \examples{ ## Titanic data data("Titanic") strucplot(Titanic, core = struc_sieve) } \keyword{hplot} vcd/man/doubledecker.Rd0000755000175100001440000000621614133457276014562 0ustar hornikusers\name{doubledecker} \alias{doubledecker.default} \alias{doubledecker.formula} \alias{doubledecker} \title{Doubledecker Plot} \description{ This function creates a doubledecker plot visualizing a classification rule. } \usage{ \method{doubledecker}{formula}(formula, data = NULL, \dots, main = NULL) \method{doubledecker}{default}(x, depvar = length(dim(x)), margins = c(1,4, length(dim(x)) + 1, 1), gp = gpar(fill = rev(gray.colors(tail(dim(x), 1)))), labeling = labeling_doubledecker, spacing = spacing_highlighting, main = NULL, keep_aspect_ratio = FALSE, \dots) } \arguments{ \item{formula}{a formula specifying the variables used to create a contingency table from \code{data}. The dependent variable is used last for splitting.} \item{data}{either a data frame, or an object of class \code{"table"} or \code{"ftable"}.} \item{x}{a contingency table in array form, with optional category labels specified in the \code{dimnames(x)} attribute.} \item{depvar}{dimension index or character string specifying the dependent variable. That will be sorted last in the table.} \item{margins}{margins of the plot. Note that by default, all factor names (except the last one) and their levels are visualized \emph{as a block} under the plot.} \item{gp}{object of class \code{"gpar"} used for the tiles of the last variable.} \item{labeling}{labeling function or corresponding generating generating function (see \code{\link{strucplot}} for details).} \item{spacing}{spacing object, spacing function or corresponding generating function (see \code{\link{strucplot}} for details).} \item{main}{either a logical, or a character string used for plotting the main title. If \code{main} is \code{TRUE}, the name of the \code{data} object is used.} \item{keep_aspect_ratio}{logical indicating whether the aspect ratio should be maintained or not.} \item{\dots}{Further parameters passed to \code{mosaic}.} } \details{ Doubledecker plots visualize the the dependence of one categorical (typically binary) variable on further categorical variables. Formally, they are mosaic plots with vertical splits for all dimensions (antecedents) except the last one, which represents the dependent variable (consequent). The last variable is visualized by horizontal splits, no space between the tiles, and separate colors for the levels. } \value{ The \code{"structable"} visualized is returned invisibly. } \references{ H. Hoffmann (2001), Generalized odds ratios for visual modeling. \emph{Journal of Computational and Graphical Statistics}, \bold{10}, 4, 628--640. Meyer, D., Zeileis, A., and Hornik, K. (2006), The strucplot framework: Visualizing multi-way contingency tables with \pkg{vcd}. \emph{Journal of Statistical Software}, \bold{17(3)}, 1-48. \doi{10.18637/jss.v017.i03} and available as \code{vignette("strucplot")}. } \author{ David Meyer \email{David.Meyer@R-project.org} } \seealso{ \code{\link{strucplot}}, \code{\link{mosaic}} } \examples{ data("Titanic") doubledecker(Titanic) doubledecker(Titanic, depvar = "Survived") doubledecker(Survived ~ ., data = Titanic) } \keyword{hplot} vcd/man/shadings.Rd0000755000175100001440000002556614133457316013736 0ustar hornikusers\name{shadings} \alias{shadings} \alias{shading_hsv} \alias{shading_hcl} \alias{shading_max} \alias{shading_Friendly} \alias{shading_Friendly2} \alias{shading_Marimekko} \alias{shading_diagonal} \alias{shading_sieve} \alias{shading_binary} \alias{hcl2hex} \encoding{UTF-8} \title{Shading-generating Functions for Residual-based Shadings} \description{ Shading-generating functions for computing residual-based shadings for mosaic and association plots. } \usage{ shading_hcl(observed, residuals = NULL, expected = NULL, df = NULL, h = NULL, c = NULL, l = NULL, interpolate = c(2, 4), lty = 1, eps = NULL, line_col = "black", p.value = NULL, level = 0.95, \dots) shading_hsv(observed, residuals = NULL, expected = NULL, df = NULL, h = c(2/3, 0), s = c(1, 0), v = c(1, 0.5), interpolate = c(2, 4), lty = 1, eps = NULL, line_col = "black", p.value = NULL, level = 0.95, \dots) shading_max(observed = NULL, residuals = NULL, expected = NULL, df = NULL, h = NULL, c = NULL, l = NULL, lty = 1, eps = NULL, line_col = "black", level = c(0.9, 0.99), n = 1000, \dots) shading_Friendly(observed = NULL, residuals = NULL, expected = NULL, df = NULL, h = c(2/3, 0), lty = 1:2, interpolate = c(2, 4), eps = 0.01, line_col = "black", \dots) shading_Friendly2(observed = NULL, residuals = NULL, expected = NULL, df = NULL, lty = 1:2, interpolate = c(2, 4), eps = 0.01, line_col = "black", \dots) shading_sieve(observed = NULL, residuals = NULL, expected = NULL, df = NULL, h = c(260, 0), lty = 1:2, interpolate = c(2, 4), eps = 0.01, line_col = "black", \dots) shading_binary(observed = NULL, residuals = NULL, expected = NULL, df = NULL, col = NULL) shading_Marimekko(x, fill = NULL, byrow = FALSE) shading_diagonal(x, fill = NULL) hcl2hex(h = 0, c = 35, l = 85, fixup = TRUE) } \arguments{ \item{observed}{contingency table of observed values} \item{residuals}{contingency table of residuals} \item{expected}{contingency table of expected values} \item{df}{degrees of freedom of the associated independence model.} \item{h}{hue value in the HCL or HSV color description, has to be in [0, 360] for HCL and in [0, 1] for HSV colors. The default is to use blue and red for positive and negative residuals respectively. In the HCL specification it is \code{c(260, 0)} by default and for HSV \code{c(2/3, 0)}.} \item{c}{chroma value in the HCL color description. This controls the maximum chroma for significant and non-significant results respectively and defaults to \code{c(100, 20)}.} \item{l}{luminance value in the HCL color description. Defaults to \code{c(90, 50)} for small and large residuals respectively.} \item{s}{saturation value in the HSV color description. Defaults to \code{c(1, 0)} for large and small residuals respectively.} \item{v}{saturation value in the HSV color description. Defaults to \code{c(1, 0.5)} for significant and non-significant results respectively.} \item{interpolate}{a specification for mapping the absolute size of the residuals to a value in [0, 1]. This can be either a function or a numeric vector. In the latter case, a step function with steps of equal size going from 0 to 1 is used.} \item{lty}{a vector of two line types for positive and negative residuals respectively. Recycled if necessary.} \item{eps}{numeric tolerance value below which absolute residuals are considered to be zero, which is used for coding the border color and line type. If set to \code{NULL} (default), all borders have the default color specified by \code{line\_col}. If set to a numeric value, all border colors corresponding to residuals with a larger absolute value are set to the full positive or negative color, respectively; borders corresponding to smaller residuals are are drawn with \code{line\_col} and \code{lty[1]}}. This is used principally in \code{shading\_Friendly}. \item{line_col}{default border color (for \code{shading_sieve}: default sieve color).} \item{p.value}{the \eqn{p} value associated with the independence model. By default, this is computed from a Chi-squared distribution with \code{df} degrees of freedom. \code{p.value} can be either a scalar or a \code{function(observed, residuals, expected, df)} that computes the \eqn{p} value from the data. If set to \code{NA} no inference is performed.} \item{level}{confidence level of the test used. If \code{p.value} is smaller than \code{1 - level}, bright colors are used, otherwise dark colors are employed. For \code{shading_max} a vector of levels can be supplied. The corresponding critical values are then used as \code{interpolate} cut-offs.} \item{n}{number of permutations used in the call to \code{coindep_test}.} \item{col}{a vector of two colors for positive and negative residuals respectively.} \item{fixup}{logical. Should the color be corrected to a valid RGB value before correction?} \item{x}{object of class \code{table} used to determine the dimension.} \item{fill}{Either a character vector of color codes, or a palette function that generates such a vector. Defaults to \code{\link[colorspace]{rainbow_hcl}}} \item{byrow}{logical; shall tiles be filled by row or by column?} \item{\dots}{Other arguments passed to \code{\link{hcl2hex}} or \code{\link{hsv}}, respectively.} } \details{ These shading-generating functions can be passed to \code{strucplot} to generate residual-based shadings for contingency tables. \code{strucplot} calls these functions with the arguments \code{observed}, \code{residuals}, \code{expected}, \code{df} which give the observed values, residuals, expected values and associated degrees of freedom for a particular contingency table and associated independence model. The shadings \code{shading_hcl} and \code{shading_hsv} do the same thing conceptually, but use HCL or HSV colors respectively. The former is usually preferred because they are perceptually based. Both shadings visualize the \emph{sign} of the residuals of an independence model using two hues (by default: blue and red). The \emph{absolute size} of the residuals is visualized by the colorfulness and the amount of grey, by default in three categories: very colorful for large residuals (> 4), less colorful for medium sized residuals (< 4 and > 2), grey/white for small residuals (< 2). More categories or a continuous scale can be specified by setting \code{interpolate}. Furthermore, the result of a significance test can be visualized by the amount of grey in the colors. If significant, a colorful palette is used, if not, the amount of color is reduced. See Zeileis, Meyer, and Hornik (2007) and \code{\link[colorspace]{diverge_hcl}} for more details. The shading \code{shading_max} is applicable in 2-way contingency tables and uses a similar strategy as \code{shading_hcl}. But instead of using the cut-offs 2 and 4, it employs the critical values for the maximum statistic (by default at 90\% and 99\%). Consequently, color in the plot signals a significant result at 90\% or 99\% significance level, respectively. The test is carried out by calling \code{\link{coindep_test}}. The shading \code{shading_Friendly} is very similar to \code{shading_hsv}, but additionally codes the sign of the residuals by different line types. See Friendly (1994) for more details. \code{shading_Friendly2} and \code{shading_sieve} are similar, but use HCL colors. The shading \code{shading_binary} just visualizes the sign of the residuals by using two different colors (default: blue HCL(260, 50, 70) and red HCL(0, 50, 70)). \code{shading_Marimekko} is a simple generating function for producing, in conjunction with \code{\link{mosaic}}, so-called \emph{Marimekko-charts}, which paint the tiles of each columns of a mosaic display in the same color to better display departures from independence. \code{shading_diagonal} generates a color shading for basically square matrices (or arrays having the first two dimensons of same length) visualizing the diagonal cells, and the off-diagonal cells 1, 2, \dots steps removed. The color implementations employed are \code{\link{hsv}} from base R and \code{\link[colorspace]{polarLUV}} from the \pkg{colorspace} package, respectively. To transform the HCL coordinates to a hexadecimal color string (as returned by \code{hsv}), the function \code{\link[colorspace]{hex}} is employed. A convenience wrapper \code{hcl2hex} is provided. } \references{ Friendly M. (1994), Mosaic Displays for Multi-Way Contingency Tables. \emph{Journal of the American Statistical Association}, \bold{89}, 190--200. Meyer D., Zeileis A., and Hornik K. (2006), The Strucplot Framework: Visualizing Multi-Way Contingency Tables with \pkg{vcd}. \emph{Journal of Statistical Software}, \bold{17}(3), 1--48. \doi{10.18637/jss.v017.i03}. See also \code{vignette("strucplot", package = "vcd")}. Zeileis A., Meyer D., Hornik K. (2007), Residual-Based Shadings for Visualizing (Conditional) Independence. \emph{Journal of Computational and Graphical Statistics}, \bold{16}, 507--525. Zeileis A., Hornik K. and Murrell P. (2008), Escaping RGBland: Selecting Colors for Statistical Graphics. \emph{Computational Statistics & Data Analysis}, \bold{53}, 3259--3270. Preprint available from \url{https://www.zeileis.org/papers/Zeileis+Hornik+Murrell-2009.pdf}. } \value{A shading function which takes only a single argument, interpreted as a vector/table of residuals, and returns a \code{"gpar"} object with the corresponding vector(s)/table(s) of graphical parameter(s). } \author{ Achim Zeileis \email{Achim.Zeileis@R-project.org} } \seealso{ \code{\link[colorspace]{hex}}, \code{\link[colorspace]{polarLUV}}, \code{\link{hsv}}, \code{\link{mosaic}}, \code{\link{assoc}}, \code{\link{strucplot}}, \code{\link[colorspace]{diverge_hcl}} } \examples{ ## load Arthritis data data("Arthritis") art <- xtabs(~Treatment + Improved, data = Arthritis) ## plain mosaic display without shading mosaic(art) ## with shading for independence model mosaic(art, shade = TRUE) ## which uses the HCL shading mosaic(art, gp = shading_hcl) ## the residuals are too small to have color, ## hence the cut-offs can be modified mosaic(art, gp = shading_hcl, gp_args = list(interpolate = c(1, 1.8))) ## the same with the Friendly palette ## (without significance testing) mosaic(art, gp = shading_Friendly, gp_args = list(interpolate = c(1, 1.8))) ## assess independence using the maximum statistic ## cut-offs are now critical values for the test statistic mosaic(art, gp = shading_max) ## association plot with shading as in base R assoc(art, gp = shading_binary(col = c(1, 2))) ## Marimekko Chart hec <- margin.table(HairEyeColor, 1:2) mosaic(hec, gp = shading_Marimekko(hec)) mosaic(HairEyeColor, gp = shading_Marimekko(HairEyeColor)) ## Diagonal cells shading ac <- xtabs(VisualAcuity) mosaic(ac, gp = shading_diagonal(ac)) } \keyword{hplot} vcd/man/Hospital.Rd0000755000175100001440000000241611235655730013706 0ustar hornikusers\name{Hospital} \alias{Hospital} \docType{data} \title{Hospital data} \description{ The table relates the length of stay (in years) of 132 long-term schizophrenic patients in two London mental hospitals with the frequency of visits. } \usage{ data("Hospital") } \format{ A 2-dimensional array resulting from cross-tabulating 132 patients. The variables and their levels are as follows: \tabular{rll}{ No \tab Name \tab Levels \cr 1 \tab Visit Frequency \tab Regular, Less than monthly, Never \cr 2 \tab Length of Stay \tab 2--9 years, 10--19 years, 20+ years } } \references{ J.K. Wing (1962): Institutionalism in mental hospitals. British Journal of Social Clinical Psychology, 1:38--51. } \source{ S.J Haberman (1974): Log-linear models for frequency tables with ordered classifications. Biometrics, 30:689--700. } \details{ Wing (1962) who collected this data concludes that the longer the length of stay in hospital, the less frequent the visits. Haberman (1974) notes that this pattern does not increase from the "Less than monthly" to the "Never" group, which are homogeneous. } \examples{ data("Hospital") mosaic(t(Hospital), shade = TRUE) mosaic(Hospital, shade = TRUE) sieve(Hospital, shade = TRUE) assoc(Hospital, shade = TRUE) } \keyword{datasets} vcd/man/struc_assoc.Rd0000644000175100001440000000755514541372245014461 0ustar hornikusers\name{struc_assoc} \alias{struc_assoc} \title{Core-generating Function for Association Plots} \description{ Core-generating function for \code{strucplot} returning a function producing association plots. } \usage{ struc_assoc(compress = TRUE, xlim = NULL, ylim = NULL, yspace = unit(0.5, "lines"), xscale = 0.9, gp_axis = gpar(lty = 3)) } \arguments{ \item{compress}{logical; if \code{FALSE}, the space between the rows (columns) are chosen such that the \emph{total} heights (widths) of the rows (column) are all equal. If \code{TRUE}, the space between the rows and columns is fixed and hence the plot is more \dQuote{compressed}.} \item{xlim}{either a \eqn{2 \times k}{2 x k} matrix of doubles, \eqn{k} the number of total columns of the plot, or a recycled vector from which such a matrix will be constructed. The columns of \code{xlim} correspond to the columns of the association plot, the rows describe the column ranges (minimums in the first row, maximums in the second row). If \code{xlim} is \code{NULL}, the ranges are determined from the residuals according to \code{compress} (if \code{TRUE}: widest range from each column, if \code{FALSE}: from the whole association plot matrix).} \item{ylim}{either a \eqn{2 \times k}{2 x k} matrix of doubles, \eqn{k} the number of total rows of the plot, or a recycled vector from which such a matrix will be constructed. The columns of \code{ylim} correspond to the rows of the association plot, the rows describe the column ranges (minimums in the first row, maximums in the second row). If \code{ylim} is \code{NULL}, the ranges are determined from the residuals according to \code{compress} (if \code{TRUE}: widest range from each row, if \code{FALSE}: from the whole association plot matrix).} \item{xscale}{scale factor resizing the tile's width, thus adding additional space between the tiles. } \item{yspace}{object of class \code{"unit"} specifying additional space separating the rows.} \item{gp_axis}{object of class \code{"gpar"} specifying the visual aspects of the tiles' baseline.} } \details{ This function is usually called by \code{strucplot} (typically when called by \code{assoc}) and returns a function used by \code{strucplot} to produce association plots. } \value{ A function with arguments: \item{residuals}{table of residuals.} \item{observed}{not used by \code{struc_assoc}.} \item{expected}{table of expected frequencies.} \item{spacing}{object of class \code{"unit"} specifying the space between the tiles.} \item{gp}{list of \code{gpar} objects used for the drawing the tiles.} \item{split_vertical}{vector of logicals indicating, for each dimension of the table, the split direction.} } \author{ David Meyer \email{David.Meyer@R-project.org} } \seealso{ \code{\link{assoc}}, \code{\link{strucplot}}, \code{\link{structable}} } \references{ Cohen, A. (1980), On the graphical display of the significant components in a two-way contingency table. \emph{Communications in Statistics---Theory and Methods}, \bold{A9}, 1025--1041. Friendly, M. (1992), Graphical methods for categorical data. \emph{SAS User Group International Conference Proceedings}, \bold{17}, 190--200. \url{http://datavis.ca/papers/sugi/sugi17.pdf} Meyer, D., Zeileis, A., and Hornik, K. (2006), The strucplot framework: Visualizing multi-way contingency tables with \pkg{vcd}. \emph{Journal of Statistical Software}, \bold{17(3)}, 1-48. \doi{10.18637/jss.v017.i03} and available as \code{vignette("strucplot")}. } \examples{ ## UCB Admissions data("UCBAdmissions") ucb <- aperm(UCBAdmissions) ## association plot for conditional independence strucplot(ucb, expected = ~ Dept * (Admit + Gender), core = struc_assoc(ylim = c(-4, 4)), labeling_args = list(abbreviate_labs = c(Admit = 3))) } \keyword{hplot} vcd/man/spine.Rd0000755000175100001440000001073711235655676013257 0ustar hornikusers\name{spine} \alias{spine} \alias{spine.default} \alias{spine.formula} \title{Spine Plots and Spinograms} \description{ Spine plots are a special cases of mosaic plots, and can be seen as a generalization of stacked (or highlighted) bar plots. Analogously, spinograms are an extension of histograms. } \usage{ spine(x, \dots) \method{spine}{default}(x, y = NULL, breaks = NULL, ylab_tol = 0.05, off = NULL, main = "", xlab = NULL, ylab = NULL, ylim = c(0, 1), margins = c(5.1, 4.1, 4.1, 3.1), gp = gpar(), name = "spineplot", newpage = TRUE, pop = TRUE, \dots) \method{spine}{formula}(formula, data = list(), breaks = NULL, ylab_tol = 0.05, off = NULL, main = "", xlab = NULL, ylab = NULL, ylim = c(0, 1), margins = c(5.1, 4.1, 4.1, 3.1), gp = gpar(), name = "spineplot", newpage = TRUE, pop = TRUE, \dots) } \arguments{ \item{x}{an object, the default method expects either a single variable (interpreted to be the explanatory variable) or a 2-way table. See details.} \item{y}{a \code{"factor"} interpreted to be the dependent variable} \item{formula}{a \code{"formula"} of type \code{y ~ x} with a single dependent \code{"factor"} and a single explanatory variable.} \item{data}{an optional data frame.} \item{breaks}{if the explanatory variable is numeric, this controls how it is discretized. \code{breaks} is passed to \code{\link{hist}} and can be a list of arguments.} \item{ylab_tol}{convenience tolerance parameter for y-axis annotation. If the distance between two labels drops under this threshold, they are plotted equidistantly.} \item{off}{vertical offset between the bars (in per cent). It is fixed to \code{0} for spinograms and defaults to \code{2} for spine plots.} \item{main, xlab, ylab}{character strings for annotation} \item{ylim}{limits for the y axis} \item{margins}{margins when calling \code{\link{plotViewport}}} \item{gp}{a \code{"gpar"} object controlling the grid graphical parameters of the rectangles. It should specify in particular a vector of \code{fill} colors of the same length as \code{levels(y)}. The default is to call \code{\link{gray.colors}}.} \item{name}{name of the plotting viewport.} \item{newpage}{logical. Should \code{\link{grid.newpage}} be called before plotting?} \item{pop}{logical. Should the viewport created be popped?} \item{\dots}{additional arguments passed to \code{\link{plotViewport}}.} } \details{ \code{spine} creates either a spinogram or a spine plot. It can be called via \code{spine(x, y)} or \code{spine(y ~ x)} where \code{y} is interpreted to be the dependent variable (and has to be categorical) and \code{x} the explanatory variable. \code{x} can be either categorical (then a spine plot is created) or numerical (then a spinogram is plotted). Additionally, \code{spine} can also be called with only a single argument which then has to be a 2-way table, interpreted to correspond to \code{table(x, y)}. Spine plots are a generalization of stacked bar plots where not the heights but the widths of the bars corresponds to the relative frequencies of \code{x}. The heights of the bars then correspond to the conditional relative frequencies of \code{y} in every \code{x} group. This is a special case of a mosaic plot with specific spacing and shading. Analogously, spinograms extend stacked histograms. As for the histogram, \code{x} is first discretized (using \code{\link{hist}}) and then for the discretized data a spine plot is created. } \value{ The table visualized is returned invisibly. } \seealso{ \code{\link{cd_plot}}, \code{\link{mosaic}}, \code{\link{hist}} } \references{ Hummel, J. (1996), Linked bar charts: Analysing categorical data graphically. \emph{Computational Statistics}, \bold{11}, 23--33. Hofmann, H., Theus, M. (2005), \emph{Interactive graphics for visualizing conditional distributions}, Unpublished Manuscript. } \author{ Achim Zeileis \email{Achim.Zeileis@R-project.org} } \examples{ ## Arthritis data (dependence on a categorical variable) data("Arthritis") (spine(Improved ~ Treatment, data = Arthritis)) ## Arthritis data (dependence on a numerical variable) (spine(Improved ~ Age, data = Arthritis, breaks = 5)) (spine(Improved ~ Age, data = Arthritis, breaks = quantile(Arthritis$Age))) (spine(Improved ~ Age, data = Arthritis, breaks = "Scott")) ## Space shuttle data (dependence on a numerical variable) data("SpaceShuttle") (spine(Fail ~ Temperature, data = SpaceShuttle, breaks = 3)) } \keyword{hplot} vcd/man/co_table.Rd0000755000175100001440000000162011264574714013673 0ustar hornikusers\name{co_table} \alias{co_table} \title{Compute Conditional Tables} \description{ For a contingency table in array form, compute a list of conditional tables given some margins. } \usage{ co_table(x, margin, collapse = ".") } \arguments{ \item{x}{a contingency table in array form.} \item{margin}{margin index(es) or corresponding name(s) of the conditioning variables.} \item{collapse}{character used when collapsing level names (if more than 1 \code{margin} is specified).} } \details{ This is essentially an interface to \code{\link[base]{[}} which is more convenient for arrays of arbitrary dimension. } \value{ A list of the resulting conditional tables. } \author{ Achim Zeileis \email{Achim.Zeileis@R-project.org} } \examples{ data("HairEyeColor") co_table(HairEyeColor, 1) co_table(HairEyeColor, c("Hair", "Eye")) co_table(HairEyeColor, 1:2, collapse = "") } \keyword{array} vcd/man/DanishWelfare.Rd0000755000175100001440000000230011150520606014614 0ustar hornikusers\name{DanishWelfare} \alias{DanishWelfare} \docType{data} \title{Danish Welfare Study Data} \description{ Data from the Danish Welfare Study. } \usage{data("DanishWelfare")} \format{ A data frame with 180 observations and 5 variables. \describe{ \item{Freq}{frequency.} \item{Alcohol}{factor indicating daily alcohol consumption: less than 1 unit (<1), 1-2 units (1-2) or more than 2 units (>2). 1 unit is approximately 1 bottle of beer or 4cl 40\% alcohol.} \item{Income}{factor indicating income group in 1000 DKK (0-50, 50-100, 100-150, >150).} \item{Status}{factor indicating marriage status (Widow, Married, Unmarried).} \item{Urban}{factor indicating urbanization: Copenhagen (Copenhagen), Suburbian Copenhagen (SubCopenhagen), three largest cities (LargeCity), other cities (City), countryside (Country).} } } \references{ E. B. Andersen (1991), \emph{The Statistical Analysis of Categorical Data}. 2nd edition. Springer-Verlag, Berlin. } \source{ E. B. Andersen (1991), The Statistical Analysis of Categorical Data, page 205. } \examples{ data("DanishWelfare") ftable(xtabs(Freq ~ ., data = DanishWelfare)) } \keyword{datasets} vcd/man/rootogram.Rd0000755000175100001440000001531412511045112014116 0ustar hornikusers\name{rootogram} \alias{rootogram} \alias{rootogram.default} \alias{rootogram.goodfit} \title{Rootograms} \description{ Rootograms of observed and fitted values. } \usage{ \method{rootogram}{default}(x, fitted, names = NULL, scale = c("sqrt", "raw"), type = c("hanging", "standing", "deviation"), shade = FALSE, legend = TRUE, legend_args = list(x = 0, y = 0.2, height = 0.6), df = NULL, rect_gp = NULL, rect_gp_args = list(), lines_gp = gpar(col = "red", lwd = 2), points_gp = gpar(col = "red"), pch = 19, xlab = NULL, ylab = NULL, ylim = NULL, main = NULL, sub = NULL, margins = unit(0, "lines"), title_margins = NULL, legend_width = NULL, main_gp = gpar(fontsize = 20), sub_gp = gpar(fontsize = 15), name = "rootogram", prefix = "", keep_aspect_ratio = FALSE, newpage = TRUE, pop = TRUE, return_grob = FALSE, \dots) } \arguments{ \item{x}{either a vector or a 1-way table of frequencies.} \item{fitted}{a vector of fitted frequencies.} \item{names}{a vector of names passed to \code{\link{grid_barplot}}, if set to \code{NULL} the names of \code{x} are used.} \item{scale}{a character string indicating whether the values should be plotted on the raw or square root scale.} \item{type}{a character string indicating if the bars for the observed frequencies should be \code{hanging} or \code{standing} or indicate the \code{deviation} between observed and fitted frequencies.} \item{shade}{logical specifying whether \code{rect_gp} should be set to colors corresponding to the pearson residuals, i.e., if a residual-based shading should be applied to the bars.} \item{legend}{either a legend-generating function, or a legend function (see details and \code{\link{legends}}), or a logical. If \code{legend} is \code{NULL} or \code{TRUE} and \code{gp} is a function, legend defaults to \code{\link{legend_resbased}}.} \item{legend_args}{list of arguments for the legend-generating function, if specified.} \item{df}{degrees of freedom passed to the shading functions used for inference.} \item{rect_gp}{a \code{"gpar"} object controlling the grid graphical parameters of the rectangles, shading function or a corresponding generating function (see \code{\link{shadings}}). If unspecified and no shading is applied, defaults to light grey fill color for the bars.} \item{rect_gp_args}{list of arguments for the shading-generating function, if specified for \code{rect_gp}.} \item{lines_gp}{a \code{"gpar"} object controlling the grid graphical parameters of the lines.} \item{points_gp}{a \code{"gpar"} object controlling the grid graphical parameters of the points.} \item{pch}{plotting character for the points.} \item{xlab}{a label for the x axis.} \item{ylab}{a label for the y axis.} \item{ylim}{limits for the y axis.} \item{main}{either a logical, or a character string used for plotting the main title. If \code{main} is a logical and \code{TRUE}, the name of the object supplied as \code{x} is used.} \item{sub}{a character string used for plotting the subtitle. If \code{sub} is a logical and \code{TRUE} and \code{main} is unspecified, the name of the object supplied as \code{x} is used.} \item{margins}{either an object of class \code{"unit"} of length 4, or a numeric vector of length 4. The elements are recycled as needed. The four components specify the top, right, bottom, and left margin of the plot, respectively. When a numeric vector is supplied, the numbers are interpreted as \code{"lines"} units. In addition, the unit or numeric vector may have named arguments (\samp{top}, \samp{right}, \samp{bottom}, and \samp{left}), in which case the non-named arguments specify the default values (recycled as needed), overloaded by the named arguments.} \item{title_margins}{either an object of class \code{"unit"} of length 2, or a numeric vector of length 2. The elements are recycled as needed. The two components specify the top and bottom \emph{title} margin of the plot, respectively. The default for each \emph{specified} title are 2 lines (and 0 else), except when a legend is plotted and \code{keep_aspect_ratio} is \code{TRUE}: in this case, the default values of both margins are set as to align the heights of legend and actual plot. When a numeric vector is supplied, the numbers are interpreted as \code{"lines"} units. In addition, the unit or numeric vector may have named arguments (\samp{top} and \samp{bottom}), in which case the non-named argument specify the default value (recycled as needed), overloaded by the named arguments.} \item{legend_width}{An object of class \code{"unit"} of length 1 specifying the width of the legend (if any). Default: 5 lines.} \item{main_gp, sub_gp}{object of class \code{"gpar"} containing the graphical parameters used for the main (sub) title, if specified.} \item{name}{name of the plotting viewport.} \item{keep_aspect_ratio}{logical indicating whether the aspect ratio should be fixed or not.} \item{prefix}{optional character string used as a prefix for the generated viewport and grob names.} \item{newpage}{logical. Should \code{\link{grid.newpage}} be called before plotting?} \item{pop}{logical. Should the viewport created be popped?} \item{return_grob}{logical. Should a snapshot of the display be returned as a grid grob?} \item{\dots}{further arguments passed to \code{\link{grid_barplot}}.} } \details{ The observed frequencies are displayed as bars and the fitted frequencies as a line. By default a sqrt scale is used to make the smaller frequencies more visible. } \author{ Achim Zeileis \email{Achim.Zeileis@R-project.org}, David Meyer \email{David.Meyer@R-project.org} } \references{ J. W. Tukey (1977), \emph{Exploratory Data Analysis}. Addison Wesley, Reading, MA. M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \seealso{\code{\link{grid_barplot}}} \examples{ ## Simulated data examples: dummy <- rnbinom(200, size = 1.5, prob = 0.8) observed <- table(dummy) fitted1 <- dnbinom(as.numeric(names(observed)), size = 1.5, prob = 0.8) * sum(observed) fitted2 <- dnbinom(as.numeric(names(observed)), size = 2, prob = 0.6) * sum(observed) rootogram(observed, fitted1) rootogram(observed, fitted2) ## Real data examples: data("HorseKicks") HK.fit <- goodfit(HorseKicks) summary(HK.fit) plot(HK.fit) ## or equivalently rootogram(HK.fit) data("Federalist") F.fit <- goodfit(Federalist, type = "nbinomial") summary(F.fit) plot(F.fit) ## (Pearson) residual-based shading data("Federalist") Fed_fit0 <- goodfit(Federalist, type = "poisson") plot(Fed_fit0, shade = TRUE) } \keyword{hplot} vcd/man/Federalist.Rd0000755000175100001440000000204311150520606014166 0ustar hornikusers\name{Federalist} \alias{Federalist} \docType{data} \title{`May' in Federalist Papers} \description{ Data from Mosteller & Wallace (1984) investigating the use of certain keywords (\sQuote{may} in this data set) to identify the author of 12 disputed \sQuote{Federalist Papers} by Alexander Hamilton, John Jay and James Madison. } \usage{ data("Federalist") } \format{ A 1-way table giving the number of occurrences of \sQuote{may} in 262 blocks of text. The variable and its levels are \tabular{rll}{ No \tab Name \tab Levels \cr 1 \tab nMay \tab 0, 1, \dots, 6 \cr } } \references{ F. Mosteller & D. L. Wallace (1984), \emph{Applied Bayesian and Classical Inference: The Case of the Federalist Papers}. Springer-Verlag, New York, NY. M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \source{ Michael Friendly (2000), Visualizing Categorical Data, page 19. } \examples{ data("Federalist") gf <- goodfit(Federalist, type = "nbinomial") summary(gf) plot(gf) } \keyword{datasets} vcd/man/PreSex.Rd0000644000175100001440000000346514246371504013332 0ustar hornikusers\name{PreSex} \alias{PreSex} \docType{data} \title{Pre-marital Sex and Divorce} \description{ Data from Thornes & Collard (1979), reported in Gilbert (1981), on pre- and extra-marital sex and divorce. } \usage{ data("PreSex") } \format{ A 4-dimensional array resulting from cross-tabulating 1036 observations on 4 variables. The variables and their levels are as follows: \tabular{rll}{ No \tab Name \tab Levels \cr 1 \tab MaritalStatus \tab Divorced, Married \cr 2 \tab ExtramaritalSex \tab Yes, No \cr 3 \tab PremaritalSex \tab Yes, No \cr 4 \tab Gender \tab Women, Men } } \references{ G. N. Gilbert (1981), \emph{Modelling Society: An Introduction to Loglinear Analysis for Social Researchers}. Allen and Unwin, London. B. Thornes & J. Collard (1979), \emph{Who Divorces?}. Routledge & Kegan, London. M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \source{ Michael Friendly (2000), Visualizing Categorical Data: \url{http://euclid.psych.yorku.ca/ftp/sas/vcd/catdata/marital.sas} } \examples{ data("PreSex") ## Mosaic display for Gender and Premarital Sexual Experience ## (Gender Pre) mosaic(margin.table(PreSex, c(3,4)), main = "Gender and Premarital Sex") ## (Gender Pre)(Extra) mosaic(margin.table(PreSex, c(2,3,4)), expected = ~Gender * PremaritalSex + ExtramaritalSex , main = "PreMaritalSex*Gender +Sex") ## (Gender Pre Extra)(Marital) mosaic(PreSex, expected = ~Gender*PremaritalSex*ExtramaritalSex + MaritalStatus, main = "PreMarital*ExtraMarital + MaritalStatus") ## (GPE)(PEM) mosaic(PreSex, expected = ~ Gender * PremaritalSex * ExtramaritalSex + MaritalStatus * PremaritalSex * ExtramaritalSex, main = "G*P*E + P*E*M") } \keyword{datasets} vcd/man/cd_plot.Rd0000755000175100001440000000760312445056524013552 0ustar hornikusers\name{cd_plot} \alias{cd_plot} \alias{cd_plot.default} \alias{cd_plot.formula} \title{Conditional Density Plots} \description{ Computes and plots conditional densities describing how the distribution of a categorical variable \code{y} changes over a numerical variable \code{x}. } \usage{ cd_plot(x, \dots) \method{cd_plot}{default}(x, y, plot = TRUE, ylab_tol = 0.05, bw = "nrd0", n = 512, from = NULL, to = NULL, main = "", xlab = NULL, ylab = NULL, margins = c(5.1, 4.1, 4.1, 3.1), gp = gpar(), name = "cd_plot", newpage = TRUE, pop = TRUE, return_grob = FALSE, \dots) \method{cd_plot}{formula}(formula, data = list(), plot = TRUE, ylab_tol = 0.05, bw = "nrd0", n = 512, from = NULL, to = NULL, main = "", xlab = NULL, ylab = NULL, margins = c(5.1, 4.1, 4.1, 3.1), gp = gpar(), name = "cd_plot", newpage = TRUE, pop = TRUE, return_grob = FALSE, \dots) } \arguments{ \item{x}{an object, the default method expects either a single numerical variable.} \item{y}{a \code{"factor"} interpreted to be the dependent variable} \item{formula}{a \code{"formula"} of type \code{y ~ x} with a single dependent \code{"factor"} and a single numerical explanatory variable.} \item{data}{an optional data frame.} \item{plot}{logical. Should the computed conditional densities be plotted?} \item{ylab_tol}{convenience tolerance parameter for y-axis annotation. If the distance between two labels drops under this threshold, they are plotted equidistantly.} \item{bw, n, from, to, \dots}{arguments passed to \code{\link{density}}} \item{main, xlab, ylab}{character strings for annotation} \item{margins}{margins when calling \code{\link{plotViewport}}} \item{gp}{a \code{"gpar"} object controlling the grid graphical parameters of the rectangles. It should specify in particular a vector of \code{fill} colors of the same length as \code{levels(y)}. The default is to call \code{\link{gray.colors}}.} \item{name}{name of the plotting viewport.} \item{newpage}{logical. Should \code{\link{grid.newpage}} be called before plotting?} \item{return_grob}{logical. Should a snapshot of the display be returned as a grid grob?} \item{pop}{logical. Should the viewport created be popped?} } \details{ \code{cd_plot} computes the conditional densities of \code{x} given the levels of \code{y} weighted by the marginal distribution of \code{y}. The densities are derived cumulatively over the levels of \code{y}. This visualization technique is similar to spinograms (see \code{\link{spine}}) but they do not discretize the explanatory variable, but rather use a smoothing approach. Furthermore, the original x axis and not a distorted x axis (as for spinograms) is used. This typically results in conditional densities that are based on very few observations in the margins: hence, the estimates are less reliable there. } \value{ The conditional density functions (cumulative over the levels of \code{y}) are returned invisibly. } \seealso{ \code{\link{spine}}, \code{\link{density}} } \references{ Hofmann, H., Theus, M. (2005), \emph{Interactive graphics for visualizing conditional distributions}, Unpublished Manuscript. } \author{ Achim Zeileis \email{Achim.Zeileis@R-project.org} } \examples{ ## Arthritis data data("Arthritis") cd_plot(Improved ~ Age, data = Arthritis) cd_plot(Improved ~ Age, data = Arthritis, bw = 3) cd_plot(Improved ~ Age, data = Arthritis, bw = "SJ") ## compare with spinogram spine(Improved ~ Age, data = Arthritis, breaks = 3) ## Space shuttle data data("SpaceShuttle") cd_plot(Fail ~ Temperature, data = SpaceShuttle, bw = 2) ## scatter plot with conditional density cdens <- cd_plot(Fail ~ Temperature, data = SpaceShuttle, bw = 2, plot = FALSE) plot(I(-1 * (as.numeric(Fail) - 2)) ~ jitter(Temperature, factor = 2), data = SpaceShuttle, xlab = "Temperature", ylab = "Failure") lines(53:81, cdens[[1]](53:81), col = 2) } \keyword{hplot} vcd/man/Bundestag2005.Rd0000755000175100001440000000565614671771601014362 0ustar hornikusers\name{Bundestag2005} \alias{Bundestag2005} \title{Votes in German Bundestag Election 2005} \description{ Number of votes by province in the German Bundestag election 2005 (for the parties that eventually entered the parliament). } \usage{ data("Bundestag2005") } \format{ A 2-way \code{"table"} giving the number of votes for each party (\code{Fraktion}) in each of the 16 German provinces (\code{Bundesland}): \tabular{rll}{ No \tab Name \tab Levels \cr 1 \tab Bundesland \tab Schleswig-Holstein, Mecklenburg-Vorpommern, \dots \cr 2 \tab Fraktion \tab SPD, CDU/CSU, Gruene, FDP, Linke } } \details{ In the election for the German parliament \dQuote{Bundestag}, five parties obtained enough votes to enter the parliament: the social democrats SPD, the conservative CDU/CSU, the liberal FDP, the green party \dQuote{Die Gruenen} and the leftist party \dQuote{Die Linke}. The table \code{Bundestag2005} gives the number of votes for each party (\code{Fraktion}) in each of the 16 German provinces (\code{Bundesland}). The provinces are ordered from North to South. The data have been obtained from the German statistical office (Statistisches Bundesamt) from the Web page given below. Note that the number of seats in the parliament cannot be computed from the number of votes alone. The examples below show the distribution of seats that resulted from the election. } \source{ Die Bundeswahlleiterin, Statistisches Bundesamt. \url{https://www.bundeswahlleiterin.de/bundestagswahlen/2005.html} } \examples{ library(colorspace) ## The outcome of the election in terms of seats in the ## parliament was: seats <- structure(c(226, 61, 54, 51, 222), .Names = c("CDU/CSU", "FDP", "Linke", "Gruene", "SPD")) ## Hues are chosen as metaphors for the political parties ## CDU/CSU: blue, FDP: yellow, Linke: purple, Gruene: green, SPD: red ## using the respective hues from a color wheel with ## chroma = 60 and luminance = 75 parties <- rainbow_hcl(6, c = 60, l = 75)[c(5, 2, 6, 3, 1)] names(parties) <- names(seats) parties ## The pie chart shows that neither the SPD+Gruene coalition nor ## the opposition of CDU/CSU+FDP could assemble a majority. ## No party would enter a coalition with the leftists, leading to a ## big coalition. pie(seats, clockwise = TRUE, col = parties) ## The regional distribution of the votes, stratified by province, ## is shown in a mosaic display: first for the 10 Western then the ## 6 Eastern provinces. data("Bundestag2005") votes <- Bundestag2005[c(1, 3:5, 9, 11, 13:16, 2, 6:8, 10, 12), c("CDU/CSU", "FDP", "SPD", "Gruene", "Linke")] mosaic(votes, gp = gpar(fill = parties[colnames(votes)]), spacing = spacing_highlighting, labeling = labeling_left, labeling_args = list(rot_labels = c(0, 90, 0, 0), pos_labels = "center", just_labels = c("center","center","center","right"), varnames = FALSE), margins = unit(c(2.5, 1, 1, 12), "lines"), keep_aspect_ratio = FALSE) } \keyword{datasets} vcd/man/Kappa.Rd0000755000175100001440000000556412445040314013154 0ustar hornikusers\name{Kappa} \alias{Kappa} \alias{print.Kappa} \alias{confint.Kappa} \alias{summary.Kappa} \alias{print.summary.Kappa} \title{Cohen's Kappa and Weighted Kappa} \description{ Computes two agreement rates: Cohen's kappa and weighted kappa, and confidence bands. } \usage{ Kappa(x, weights = c("Equal-Spacing", "Fleiss-Cohen")) \S3method{print}{Kappa}(x, digits=max(getOption("digits") - 3, 3), CI=FALSE, level=0.95, ...) \S3method{confint}{Kappa}(object, parm, level = 0.95, ...) \S3method{summary}{Kappa}(object, ...) \S3method{print}{summary.Kappa}(x, ...) } \arguments{ \item{x}{For \code{Kappa}: a confusion matrix. For the print methods: object of class \code{"Kappa"} or \code{"summary.Kappa"}} \item{weights}{either one of the character strings given in the default value, or a user-specified matrix with same dimensions as \code{x}.} \item{digits}{minimal number of significant digits.} \item{CI}{logical; shall confidence limits be added to the output?} \item{level}{confidence level between 0 and 1 used for the confidence interval.} \item{object}{object of class \code{"Kappa"}.} \item{parm}{Currently, ignored.} \item{\dots}{Further arguments passed to the default print method.} } \details{ Cohen's kappa is the diagonal sum of the (possibly weighted) relative frequencies, corrected for expected values and standardized by its maximum value. The equal-spacing weights are defined by \eqn{1 - |i - j| / (r - 1)}{1 - abs(i - j) / (r - 1)}, \eqn{r} number of columns/rows, and the Fleiss-Cohen weights by \eqn{1 - |i - j|^2 / (r - 1)^2}{1 - abs(i - j)^2 / (r - 1)^2}. The latter one attaches greater importance to near disagreements. } \value{ An object of class \code{"Kappa"} with three components: \item{Unweighted}{numeric vector of length 2 with the kappa statistic (\code{value} component), along with Approximate Standard Error (\code{ASE} component)} \item{Weighted}{idem for the weighted kappa.} \item{Weights}{numeric matrix with weights used.} } \note{ The \code{summary} method also prints the weights. There is a \code{confint} method for computing approximate confidence intervals. } \references{ Cohen, J. (1960), A coefficient of agreement for nominal scales. \emph{Educational and Psychological Measurement}, \bold{20}, 37--46. Everitt, B.S. (1968), Moments of statistics kappa and weighted kappa. \emph{The British Journal of Mathematical and Statistical Psychology}, \bold{21}, 97--103. Fleiss, J.L., Cohen, J., and Everitt, B.S. (1969), Large sample standard errors of kappa and weighted kappa. \emph{Psychological Bulletin}, \bold{72}, 332--327. } \author{ David Meyer \email{David.Meyer@R-project.org} } \seealso{ \code{\link{agreementplot}}, \code{\link{confint}} } \examples{ data("SexualFun") K <- Kappa(SexualFun) K confint(K) summary(K) print(K, CI = TRUE) } \keyword{category} vcd/man/mosaic.Rd0000755000175100001440000002405314133457311013372 0ustar hornikusers\name{mosaic} \alias{mosaic} \alias{mosaic.default} \alias{mosaic.formula} \title{Extended Mosaic Plots} \description{ Plots (extended) mosaic displays. } \usage{ \method{mosaic}{default}(x, condvars = NULL, split_vertical = NULL, direction = NULL, spacing = NULL, spacing_args = list(), gp = NULL, expected = NULL, shade = NULL, highlighting = NULL, highlighting_fill = rev(gray.colors(tail(dim(x), 1))), highlighting_direction = NULL, zero_size = 0.5, zero_split = FALSE, zero_shade = NULL, zero_gp = gpar(col = 0), panel = NULL, main = NULL, sub = NULL, \dots) \method{mosaic}{formula}(formula, data, highlighting = NULL, \dots, main = NULL, sub = NULL, subset = NULL, na.action = NULL) } \arguments{ \item{x}{a contingency table in array form, with optional category labels specified in the \code{dimnames(x)} attribute, or an object of class \code{"structable"}.} \item{condvars}{vector of integers or character strings indicating conditioning variables, if any. The table will be permuted to order them first.} \item{formula}{a formula specifying the variables used to create a contingency table from \code{data}. For convenience, conditioning formulas can be specified; the conditioning variables will then be used first for splitting. If any, a specified response variable will be highlighted in the cells.} \item{data}{either a data frame, or an object of class \code{"table"} or \code{"ftable"}.} \item{subset}{an optional vector specifying a subset of observations to be used.} \item{na.action}{a function which indicates what should happen when the data contain \code{NA}s. Ignored if \code{data} is a contingency table.} \item{zero_size}{size of the bullets used for zero entries (if 0, no bullets are drawn).} \item{zero_split}{logical controlling whether zero cells should be further split. If \code{FALSE} and \code{zero_shade} is \code{FALSE}, only one bullet is drawn (centered) for unsplit zero cells. If \code{FALSE} and \code{zero_shade} is \code{TRUE}, a bullet for each zero cell is drawn to allow, e.g., residual-based shadings to be effective also for zero cells.} \item{zero_shade}{logical controlling whether zero bullets should be shaded. The default is \code{TRUE} if \code{shade} is \code{TRUE} or \code{expected} is not null or \code{gp} is not null, and \code{FALSE} otherwise.} \item{zero_gp}{object of class \code{"gpar"} used for zero bullets in case they are \emph{not} shaded.} \item{split_vertical}{vector of logicals of length \eqn{k}, where \eqn{k} is the number of margins of \code{x} (default: \code{FALSE}). Values are recycled as needed. A \code{TRUE} component indicates that the tile(s) of the corresponding dimension should be split vertically, \code{FALSE} means horizontal splits. Ignored if \code{direction} is not \code{NULL}.} \item{direction}{character vector of length \eqn{k}, where \eqn{k} is the number of margins of \code{x} (values are recycled as needed). For each component, a value of \code{"h"} indicates that the tile(s) of the corresponding dimension should be split horizontally, whereas \code{"v"} indicates vertical split(s).} \item{spacing}{spacing object, spacing function, or corresponding generating function (see \code{\link{strucplot}} for more information). The default is \code{spacing_equal} if \code{x} has two dimensions, \code{spacing_increase} for more dimensions, and \code{spacing_conditional} if conditioning variables are specified using \code{condvars} or the formula interface.} \item{spacing_args}{list of arguments for the generating function, if specified (see \code{\link{strucplot}} for more information).} \item{gp}{object of class \code{"gpar"}, shading function or a corresponding generating function (see details and \code{\link{shadings}}). Components of \code{"gpar"} objects are recycled as needed along the last splitting dimension. Ignored if \code{shade = FALSE}.} \item{shade}{logical specifying whether \code{gp} should be used or not (see \code{gp}). If \code{TRUE} and \code{expected} is unspecified, a default model is fitted: if \code{condvars} (see \code{\link{strucplot}}) is specified, a corresponding conditional independence model, and else the total independence model.} \item{expected}{optionally, an array of expected values of the same dimension as \code{x}, or alternatively the corresponding independence model specification as used by \code{\link[stats]{loglin}} or \code{\link[MASS]{loglm}} (see \code{\link{strucplot}}).} \item{highlighting}{character vector or integer specifying a variable to be highlighted in the cells.} \item{highlighting_fill}{color vector or palette function used for a highlighted variable, if any.} \item{highlighting_direction}{Either \code{"left"}, \code{"right"}, \code{"top"}, or \code{"bottom"} specifying the direction of highlighting in the cells.} \item{panel}{Optional function with arguments: \code{residuals}, \code{observed}, \code{expected}, \code{index}, \code{gp}, and \code{name} called by the \code{struc_mosaic} workhorse for each tile that is drawn in the mosaic. \code{index} is an integer vector with the tile's coordinates in the contingency table, \code{gp} a \code{gpar} object for the tile, and \code{name} a label to be assigned to the drawn grid object.} \item{main, sub}{either a logical, or a character string used for plotting the main (sub) title. If logical and \code{TRUE}, the name of the \code{data} object is used.} \item{\dots}{Other arguments passed to \code{\link{strucplot}}} } \details{ Mosaic displays have been suggested in the statistical literature by Hartigan and Kleiner (1984) and have been extended by Friendly (1994). \code{\link[graphics]{mosaicplot}} is a base graphics implementation and \code{mosaic} is a much more flexible and extensible grid implementation. \code{mosaic} is a generic function which currently has a default method and a formula interface. Both are high-level interfaces to the \code{\link{strucplot}} function, and produce (extended) mosaic displays. Most of the functionality is described there, such as specification of the independence model, labeling, legend, spacing, shading, and other graphical parameters. A mosaic plot is an area proportional visualization of a (possibly higher-dimensional) table of expected frequencies. It is composed of tiles (corresponding to the cells) created by recursive vertical and horizontal splits of a square. The area of each tile is proportional to the corresponding cell entry, \emph{given} the dimensions of previous splits. An \emph{extended} mosaic plot, in addition, visualizes the fit of a particular log-linear model. Typically, this is done by residual-based shadings where color and/or outline of the tiles visualize sign, size and possibly significance of the corresponding residual. The layout is very flexible: the specification of shading, labeling, spacing, and legend is modularized (see \code{\link{strucplot}} for details). In contrast to the \code{\link[graphics]{mosaicplot}} function in \pkg{graphics}, the splits start with the \emph{horizontal} direction by default to match the printed output of \code{\link{structable}}. } \value{ The \code{"structable"} visualized is returned invisibly. } \references{ Hartigan, J.A., and Kleiner, B. (1984), A mosaic of television ratings. \emph{The American Statistician}, \bold{38}, 32--35. Emerson, J. W. (1998), Mosaic displays in S-PLUS: A general implementation and a case study. \emph{Statistical Computing and Graphics Newsletter (ASA)}, \bold{9}, 1, 17--23. Friendly, M. (1994), Mosaic displays for multi-way contingency tables. \emph{Journal of the American Statistical Association}, \bold{89}, 190--200. Meyer, D., Zeileis, A., and Hornik, K. (2006), The strucplot framework: Visualizing multi-way contingency tables with \pkg{vcd}. \emph{Journal of Statistical Software}, \bold{17(3)}, 1-48. \doi{10.18637/jss.v017.i03} and available as \code{vignette("strucplot", package = "vcd")}. The home page of Michael Friendly (\url{http://datavis.ca}) provides information on various aspects of graphical methods for analyzing categorical data, including mosaic plots. In particular, there are many materials for his course \dQuote{Visualizing Categorical Data with SAS and R} at \url{http://datavis.ca/courses/VCD/}. } \author{ David Meyer \email{David.Meyer@R-project.org} } \seealso{ \code{\link{assoc}}, \code{\link{strucplot}}, \code{\link{mosaicplot}}, \code{\link{structable}}, \code{\link{doubledecker}} } \examples{ library(MASS) data("Titanic") mosaic(Titanic) ## Formula interface for tabulated data plus shading and legend: mosaic(~ Sex + Age + Survived, data = Titanic, main = "Survival on the Titanic", shade = TRUE, legend = TRUE) data("HairEyeColor") mosaic(HairEyeColor, shade = TRUE) ## Independence model of hair and eye color and sex. Indicates that ## there are significantly more blue eyed blond females than expected ## in the case of independence (and too few brown eyed blond females). mosaic(HairEyeColor, shade = TRUE, expected = list(c(1,2), 3)) ## Model of joint independence of sex from hair and eye color. Males ## are underrepresented among people with brown hair and eyes, and are ## overrepresented among people with brown hair and blue eyes, but not ## "significantly". ## Formula interface for raw data: visualize crosstabulation of numbers ## of gears and carburettors in Motor Trend car data. data("mtcars") mosaic(~ gear + carb, data = mtcars, shade = TRUE) data("PreSex") mosaic(PreSex, condvars = c(1,4)) mosaic(~ ExtramaritalSex + PremaritalSex | MaritalStatus + Gender, data = PreSex) ## Highlighting: mosaic(Survived ~ ., data = Titanic) data("Arthritis") mosaic(Improved ~ Treatment | Sex, data = Arthritis, zero_size = 0) mosaic(Improved ~ Treatment | Sex, data = Arthritis, zero_size = 0, highlighting_direction = "right") } \keyword{hplot} vcd/man/grid_barplot.Rd0000755000175100001440000000301112444613362014561 0ustar hornikusers\name{grid_barplot} \alias{grid_barplot} \title{Barplot} \description{ Bar plots of 1-way tables in grid. } \usage{ grid_barplot(height, width = 0.8, offset = 0, names = NULL, xlim = NULL, ylim = NULL, xlab = "", ylab = "", main = "", gp = gpar(fill = "lightgray"), name = "grid_barplot", newpage = TRUE, pop = FALSE, return_grob = FALSE) } \arguments{ \item{height}{either a vector or a 1-way table of frequencies.} \item{width}{width of the bars (recycled if needed to the number of bars).} \item{offset}{offset of the bars (recycled if needed to the number of bars).} \item{names}{a vector of names for the bars, if set to \code{NULL} the names of \code{height} are used.} \item{xlim}{limits for the x axis.} \item{ylim}{limits for the y axis.} \item{xlab}{a label for the x axis.} \item{ylab}{a label for the y axis.} \item{main}{a title for the plot.} \item{gp}{a \code{"gpar"} object controlling the grid graphical parameters of the rectangles.} \item{name}{name of the plotting viewport.} \item{newpage}{logical. Should \code{\link{grid.newpage}} be called before plotting?} \item{pop}{logical. Should the viewport created be popped?} \item{return_grob}{logical. Shall the plot be returned as a grob object?} } \details{ \code{grid_barplot} mimics (some of) the features of \code{\link{barplot}}, but currently it only supports 1-way tables. } \author{ Achim Zeileis \email{Achim.Zeileis@R-project.org} } \examples{ grid_barplot(sample(1:6), names = letters[1:6]) } \keyword{hplot} vcd/man/assocstats.Rd0000755000175100001440000000300012504622200014262 0ustar hornikusers\name{assocstats} \alias{assocstats} \alias{summary.assocstats} \alias{print.assocstats} \alias{print.summary.assocstats} \title{Association Statistics} \description{ Computes the Pearson chi-Squared test, the Likelihood Ratio chi-Squared test, the phi coefficient, the contingency coefficient and Cramer's V for possibly stratified contingency tables. } \usage{ assocstats(x) } \arguments{ \item{x}{a contingency table, with possibly more than 2 dimensions. In this case, all dimensions except the first two ones are considered as strata.} } \value{ In case of a 2-dimensional table, a list with components: \item{chisq_tests}{a \eqn{2 \times 3}{2 x 3} table with the chi-squared statistics.} \item{phi}{The \emph{absolute value} of the phi coefficient (only defined for \eqn{2 \times 2}{2 x 2} tables).} \item{cont}{The contingency coefficient.} \item{cramer}{Cramer's V.} In case of higher-dimensional tables, a list of the above mentioned structure, each list component representing one stratum defined by the combinations of all levels of the stratum dimensions. } \references{ Michael Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. Fleiss, J. L. (1981). \emph{Statistical methods for rates and proportions} (2nd ed). New York: Wiley } \author{ David Meyer \email{David.Meyer@R-project.org} } \examples{ data("Arthritis") tab <- xtabs(~Improved + Treatment, data = Arthritis) summary(assocstats(tab)) assocstats(UCBAdmissions) } \keyword{category} vcd/man/cotabplot.Rd0000755000175100001440000001242514133457273014115 0ustar hornikusers\name{cotabplot} \alias{cotabplot} \alias{cotabplot.default} \alias{cotabplot.formula} \title{Coplot for Contingency Tables} \description{ \code{cotabplot} is a generic function for creating trellis-like coplots (conditional plots) for contingency tables. } \usage{ cotabplot(x, \dots) \method{cotabplot}{default}(x, cond = NULL, panel = cotab_mosaic, panel_args = list(), margins = rep(1, 4), layout = NULL, text_gp = gpar(fontsize = 12), rect_gp = gpar(fill = grey(0.9)), pop = TRUE, newpage = TRUE, return_grob = FALSE, \dots) \method{cotabplot}{formula}(formula, data = NULL, \dots) } \arguments{ \item{x}{an object. The default method can deal with contingency tables in array form.} \item{cond}{margin index(es) or corresponding name(s) of the conditioning variables.} \item{panel}{panel function applied for each conditioned plot, see details.} \item{panel_args}{list of arguments passed to \code{panel} if this is a panel-generating function inheriting from class \code{"grapcon_generator"}.} \item{margins}{either an object of class \code{"unit"} of length 4, or a numeric vector of length 4. The elements are recycled as needed. giving the margins around the whole plot.} \item{layout}{integer vector (of length two), giving the number of rows and columns for the panel.} \item{text_gp}{object of class \code{"gpar"} used for the text in the panel titles.} \item{rect_gp}{object of class \code{"gpar"} used for the rectangles with the panel titles.} \item{pop}{logical indicating whether the generated viewport tree should be removed at the end of the drawing or not.} \item{newpage}{logical controlling whether a new grid page should be created.} \item{return_grob}{logical. Should a snapshot of the display be returned as a grid grob?} \item{\dots}{further arguments passed to the panel-generating function.} \item{formula}{a formula specifying the variables used to create a contingency table from \code{data}. It has to be of type \code{~ x + y | z} where \code{z} is/are the conditioning variable(s) used.} \item{data}{either a data frame, or an object of class \code{"table"} or \code{"ftable"}.} } \details{ \code{cotabplot} is a generic function designed to create coplots or conditional plots (see Cleveland, 1993, and Becker, Cleveland, Shyu, 1996) similar to \code{\link{coplot}} but for contingency tables. \code{cotabplot} takes on computing the conditioning information and setting up the trellis display, and then relies on a panel function to create plots from the full table and the conditioning information. A simple example would be a contingency table \code{tab} with margin names \code{"x"}, \code{"y"} and \code{"z"}. To produce this plot either the default interface can be used or the formula interface via \code{cotabplot(tab, "z")} \code{cotabplot(~ x + y | z, data = tab)} The panel function needs to be of the form \code{panel(x, condlevels)} where \code{x} is the \emph{full} table (\code{tab} in the example above) and \code{condlevels} is a named vector with the levels (e.g., \code{c(z = "z1")} in the example above). Alternatively, \code{panel} can also be a panel-generating function of class \code{"grapcon_generator"} which creates a function with the interface described above. The panel-generating function is called with the interface \code{panel(x, condvars, \dots)} where again \code{x} is the full table, \code{condvars} is now only a vector with the names of the conditioning variables (and not their levels, e.g., \code{"z"} in the example above). Further arguments can be passed to the panel-generating function via \code{\dots} which also includes the arguments set in \code{panel_args}. Suitable panel-generating functions for mosaic, association and sieve plots can be found at \code{\link{cotab_mosaic}}. A description of the underlying ideas is given in Zeileis, Meyer, Hornik (2005). } \seealso{ \code{\link{cotab_mosaic}}, \code{\link{cotab_coindep}}, \code{\link{co_table}}, \code{\link{coindep_test}} } \references{ Becker, R.A., Cleveland, W.S., Shyu, M.-J. (1996), The visual design and control of trellis display. \emph{Journal of Computational and Graphical Statistics}, \bold{5}, 123--155. Cleveland, W.S. (1993), \emph{Visualizing Data}, Summit, New Jersey: Hobart Press. Meyer, D., Zeileis, A., and Hornik, K. (2006), The strucplot framework: Visualizing multi-way contingency tables with \pkg{vcd}. \emph{Journal of Statistical Software}, \bold{17(3)}, 1-48. \doi{10.18637/jss.v017.i03} and available as \code{vignette("strucplot")}. Zeileis, A., Meyer, D., Hornik K. (2007), \emph{Residual-based shadings for visualizing (conditional) independence}, \emph{Journal of Computational and Graphical Statistics}, \bold{16}, 507--525. } \author{ Achim Zeileis \email{Achim.Zeileis@R-project.org} } \examples{ data("UCBAdmissions") cotabplot(~ Admit + Gender | Dept, data = UCBAdmissions) cotabplot(~ Admit + Gender | Dept, data = UCBAdmissions, panel = cotab_assoc) ucb <- cotab_coindep(UCBAdmissions, condvars = "Dept", type = "assoc", n = 5000, margins = c(3, 1, 1, 3)) cotabplot(~ Admit + Gender | Dept, data = UCBAdmissions, panel = ucb) } \keyword{hplot} vcd/man/goodfit.Rd0000755000175100001440000001217412511041104013536 0ustar hornikusers\name{goodfit} \alias{goodfit} \alias{summary.goodfit} \alias{plot.goodfit} \alias{predict.goodfit} \alias{fitted.goodfit} \alias{residuals.goodfit} \alias{print.goodfit} \title{Goodness-of-fit Tests for Discrete Data} \description{ Fits a discrete (count data) distribution for goodness-of-fit tests. } \usage{ goodfit(x, type = c("poisson", "binomial", "nbinomial"), method = c("ML", "MinChisq"), par = NULL) \method{predict}{goodfit}(object, newcount = NULL, type = c("response", "prob"), \dots) \method{residuals}{goodfit}(object, type = c("pearson", "deviance", "raw"), \dots) \method{print}{goodfit}(x, residuals_type = c("pearson", "deviance", "raw"), \dots) } \arguments{ \item{x}{either a vector of counts, a 1-way table of frequencies of counts or a data frame or matrix with frequencies in the first column and the corresponding counts in the second column.} \item{type}{character string indicating: for \code{goodfit}, which distribution should be fit; for \code{predict}, the type of prediction (fitted response or probabilities); for \code{residuals}, either \code{"pearson"}, \code{"deviance"} or \code{"raw"}.} \item{residuals_type}{character string indicating the type of residuals: either \code{"pearson"}, \code{"deviance"} or \code{"raw"}.} \item{method}{a character string indicating whether the distribution should be fit via ML (Maximum Likelihood) or Minimum Chi-squared.} \item{par}{a named list giving the distribution parameters (named as in the corresponding density function), if set to \code{NULL}, the default, the parameters are estimated. If the parameter \code{size} is not specified if \code{type} is \code{"binomial"} it is taken to be the maximum count. If \code{type} is \code{"nbinomial"}, then parameter \code{size} can be specified to fix it so that only the parameter \code{prob} will be estimated (see the examples below).} \item{object}{an object of class \code{"goodfit"}.} \item{newcount}{a vector of counts. By default the counts stored in \code{object} are used, i.e., the fitted values are computed. These can also be extracted by \code{fitted(object)}.} \item{\dots}{\emph{currently not used}.} } \details{ \code{goodfit} essentially computes the fitted values of a discrete distribution (either Poisson, binomial or negative binomial) to the count data given in \code{x}. If the parameters are not specified they are estimated either by ML or Minimum Chi-squared. To fix parameters, \code{par} should be a named list specifying the parameters \code{lambda} for \code{"poisson"} and \code{prob} and \code{size} for \code{"binomial"} or \code{"nbinomial"}, respectively. If for \code{"binomial"}, \code{size} is not specified it is not estimated but taken as the maximum count. The corresponding Pearson Chi-squared or likelihood ratio statistic, respectively, is computed and given with their \eqn{p} values by the \code{summary} method. The \code{summary} method always prints this information and returns a matrix with the printed information invisibly. The \code{plot} method produces a \code{\link{rootogram}} of the observed and fitted values. In case of count distribtions (Poisson and negative binomial), the minimum Chi-squared approach is somewhat ad hoc. Strictly speaking, the Chi-squared asymptotics would only hold if the number of cells were fixed or did not increase too quickly with the sample size. However, in \code{goodfit} the number of cells is data-driven: Each count is a cell of its own. All counts larger than the maximal count are merged into the cell with the last count for computing the test statistic. } \value{ A list of class \code{"goodfit"} with elements: \item{observed}{observed frequencies.} \item{count}{corresponding counts.} \item{fitted}{expected frequencies (fitted by ML).} \item{type}{a character string indicating the distribution fitted.} \item{method}{a character string indicating the fitting method (can be either \code{"ML"}, \code{"MinChisq"} or \code{"fixed"} if the parameters were specified).} \item{df}{degrees of freedom.} \item{par}{a named list of the (estimated) distribution parameters.} } \author{ Achim Zeileis \email{Achim.Zeileis@R-project.org} } \references{ M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \seealso{\code{\link{rootogram}}} \examples{ ## Simulated data examples: dummy <- rnbinom(200, size = 1.5, prob = 0.8) gf <- goodfit(dummy, type = "nbinomial", method = "MinChisq") summary(gf) plot(gf) dummy <- rbinom(100, size = 6, prob = 0.5) gf1 <- goodfit(dummy, type = "binomial", par = list(size = 6)) gf2 <- goodfit(dummy, type = "binomial", par = list(prob = 0.6, size = 6)) summary(gf1) plot(gf1) summary(gf2) plot(gf2) ## Real data examples: data("HorseKicks") HK.fit <- goodfit(HorseKicks) summary(HK.fit) plot(HK.fit) data("Federalist") ## try geometric and full negative binomial distribution F.fit <- goodfit(Federalist, type = "nbinomial", par = list(size = 1)) F.fit2 <- goodfit(Federalist, type = "nbinomial") summary(F.fit) summary(F.fit2) plot(F.fit) plot(F.fit2) } \keyword{category} vcd/man/JobSatisfaction.Rd0000755000175100001440000000224211150520606015167 0ustar hornikusers\name{JobSatisfaction} \alias{JobSatisfaction} \docType{data} \title{Job Satisfaction Data} \description{ Data from Petersen (1968) about the job satisfaction of 715 blue collar workers, selected from Danish Industry in 1968. } \usage{ data("JobSatisfaction") } \format{ A data frame with 8 observations and 4 variables. \describe{ \item{Freq}{frequency.} \item{management}{factor indicating quality of management (bad, good).} \item{supervisor}{factor indicating supervisor's job satisfaction (low, high).} \item{own}{factor indicating worker's own job satisfaction (low, high).} } } \references{ E. B. Andersen (1991), \emph{The Statistical Analysis of Categorical Data}. 2nd edition. Springer-Verlag, Berlin. E. Petersen (1968), \emph{Job Satisfaction in Denmark}. (In Danish). Mentalhygiejnisk Forlag, Copenhagen. } \source{ E. B. Andersen (1991), The Statistical Analysis of Categorical Data, Table 5.4. } \examples{ data("JobSatisfaction") structable(~ ., data = JobSatisfaction) mantelhaen.test(xtabs(Freq ~ own + supervisor + management, data = JobSatisfaction)) } \keyword{datasets} vcd/man/Baseball.Rd0000755000175100001440000000455111235655776013644 0ustar hornikusers\name{Baseball} \alias{Baseball} \docType{data} \title{Baseball Data} \description{ Baseball data. } \usage{ data("Baseball") } \format{ A data frame with 322 observations and 25 variables. \describe{ \item{name1}{player's first name.} \item{name2}{player's last name.} \item{atbat86}{times at Bat: number of official plate appearances by a hitter. It counts as an official at-bat as long as the batter does not walk, sacrifice, get hit by a pitch or reach base due to catcher's interference.} \item{hits86}{hits.} \item{homer86}{home runs.} \item{runs86}{the number of runs scored by a player. A run is scored by an offensive player who advances from batter to runner and touches first, second, third and home base in that order without being put out.} \item{rbi86}{Runs Batted In: A hitter earns a run batted in when he drives in a run via a hit, walk, sacrifice (bunt or fly) fielder's choice, hit-batsman or on an error (when the official scorer rules that the run would have scored anyway).} \item{walks86}{A \dQuote{walk} (or \dQuote{base on balls}) is an award of first base granted to a batter who receives four pitches outside the strike zone.} \item{years}{Years in the Major Leagues. Seems to count all years a player has actually played in the Major Leagues, not necessarily consecutive.} \item{atbat}{career times at bat.} \item{hits}{career hits.} \item{homeruns}{career home runs.} \item{runs}{career runs.} \item{rbi}{career runs batted in.} \item{walks}{career walks.} \item{league86}{player's league.} \item{div86}{player's division.} \item{team86}{player's team.} \item{posit86}{player's position (see \code{\link{Hitters}}).} \item{outs86}{number of putouts (see \code{\link{Hitters}})} \item{assist86}{number of assists (see \code{\link{Hitters}})} \item{error86}{number of assists (see \code{\link{Hitters}})} \item{sal87}{annual salary on opening day (in USD 1000).} \item{league87}{league in 1987.} \item{team87}{team in 1987.} } } \references{ M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \source{ SAS System for Statistical Graphics, First Edition, page A2.3 } \seealso{\code{\link{Hitters}}} \examples{ data("Baseball") } \keyword{datasets} vcd/man/Trucks.Rd0000755000175100001440000000313012214055644013364 0ustar hornikusers\name{Trucks} \alias{Trucks} \docType{data} \title{Truck Accidents Data} \description{ Data from a study in England in two periods from November 1969 to October 1971 and November 1971 to October 1973. A new compulsory safety measure for trucks was introduced in October 1971. Therefore, the question is whether the safety measure had an effect on the number of accidents and on the point of collision on the truck. } \usage{ data("Trucks") } \format{ A data frame with 24 observations on 5 variables. \describe{ \item{Freq}{frequency of accidents involving trucks.} \item{period}{factor indicating time period (before, after) 1971-11-01.} \item{collision}{factor indicating whether the collision was in the back or forward (including the front and the sides) of the truck (back, forward).} \item{parked}{factor indicating whether the truck was parked (yes, no).} \item{light}{factor indicating light conditions: day light (daylight), night on an illuminated road (night, illuminate), night on a dark road (night, dark).} } } \references{ E. B. Andersen (1991), \emph{The Statistical Analysis of Categorical Data}. 2nd edition. Springer-Verlag, Berlin. } \source{ E. B. Andersen (1991), The Statistical Analysis of Categorical Data, Table 6.8. } \examples{ library(MASS) data("Trucks") tab <- xtabs(Freq ~ period + collision + light + parked, data = Trucks) loglm(~ (collision + period) * parked * light, data = tab) doubledecker(collision ~ parked + light + period, data = tab) cotabplot(tab, panel = cotab_coindep) } \keyword{datasets} vcd/man/RepVict.Rd0000755000175100001440000000264411150520606013467 0ustar hornikusers\name{RepVict} \alias{RepVict} \docType{data} \title{Repeat Victimization Data} \description{ Data from Reiss (1980) given by Fienberg (1980) about instances of repeat victimization for households in the U.S. National Crime Survey. } \usage{ data("RepVict") } \format{ A 2-dimensional array resulting from cross-tabulating victimization. The variables and their levels are as follows: \tabular{rll}{ No \tab Name \tab Levels \cr 1 \tab First Victimization \tab Rape, Assault, Robbery, Pickpocket, Personal Larceny, \cr \tab \tab Burglary, Household Larceny, Auto Theft \cr 2 \tab Second Victimization \tab Rape, Assault, Robbery, Pickpocket, Personal Larceny,\cr \tab \tab Burglary, Household Larceny, Auto Theft } } \references{ S. E. Fienberg (1980), \emph{The Analysis of Cross-Classified Categorical Data}, MIT Press, Cambridge, 2nd edition. A. J. J. Reiss (1980), Victim proneness by type of crime in repeat victimization. In S. E. Fienberg & A. J. J. Reiss (eds.), \emph{Indicators of Crime and Criminal Justice}. U.S. Government Printing Office, Washington, DC. M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \source{ Michael Friendly (2000), Visualizing Categorical Data, page 113. } \examples{ data("RepVict") mosaic(RepVict[-c(4,7),-c(4,7)], gp = shading_max, main = "Repeat Victimization Data") } \keyword{datasets} vcd/man/legends.Rd0000755000175100001440000000741414133457307013547 0ustar hornikusers\name{legends} \alias{legends} \alias{legend_resbased} \alias{legend_fixed} \title{Legend Functions for Strucplots} \description{ These functions generate legend functions for residual-based shadings. } \usage{ legend_resbased(fontsize = 12, fontfamily = "", x = unit(1, "lines"), y = unit(0.1,"npc"), height = unit(0.8, "npc"), width = unit(0.7, "lines"), digits = 2, pdigits = max(1, getOption("digits") - 2), check_overlap = TRUE, text = NULL, steps = 200, ticks = 10, pvalue = TRUE, range = NULL) legend_fixed(fontsize = 12, fontfamily = "", x = unit(1, "lines"), y = NULL, height = NULL, width = unit(1.5, "lines"), steps = 200, digits = 1, space = 0.05, text = NULL, range = NULL) } \arguments{ \item{fontsize}{fontsize of title and p-value text.} \item{fontfamily}{fontfamily of all text.} \item{x, y}{objects of class \code{"unit"} indicating the coordinates of the title. For \code{legend_fixed}, the default for \code{y} is computed as to leave enough space for the specified \code{text}.} \item{height, width}{object of class \code{"unit"} indicating the height/width of the legend. For \code{legend_fixed}, the default for \code{y} is computed as to align upper margins of legend and actual plot.} \item{digits}{number of digits for the scale labels.} \item{pdigits}{number of digits for the p-value.} \item{check_overlap}{logical indicating whether overlap of scale labels should be inhibited or not.} \item{space}{For \code{legend_fixed} only: proportion of space between the tiles.} \item{text}{character string indicating the title of the legend.} \item{steps}{granularity of the color gradient.} \item{ticks}{number of scale ticks.} \item{pvalue}{logical indicating whether the \eqn{p}-value should be visualized under the scale or not.} \item{range}{Numeric vector of length 2 for setting the legend range. Computed from the residuals if omitted. \code{NA} values are replaced by the corresponding minimum / maximum of the residuals.} } \value{ A function with arguments: \item{residuals}{residuals from the fitted independence model to be visualized.} \item{shading}{shading function computing colors from residuals (see details).} \item{autotext}{character vector indicating the title to be used when no \code{text} argument is specified. Allows strucplot to generate sensible defaults depending on the residuals type.} } \details{ These functions generate legend functions for residual-based shadings, visualizing deviations from expected values of an hypothesized independence model. Therefore, the legend uses a supplied shading function to visualize the color gradient for the residuals range. \code{legend_fixed} is inspired by the legend used in \code{\link[graphics]{mosaicplot}}. For more details on the shading functions and their return values, see \code{\link{shadings}}. } \references{ Meyer, D., Zeileis, A., and Hornik, K. (2006), The strucplot framework: Visualizing multi-way contingency tables with \pkg{vcd}. \emph{Journal of Statistical Software}, \bold{17(3)}, 1-48. \doi{10.18637/jss.v017.i03} and available as \code{vignette("strucplot")}. Meyer, D., Zeileis, A., Hornik, K. (2003), Visualizing independence using extended association plots. \emph{Proceedings of the 3rd International Workshop on Distributed Statistical Computing}, K. Hornik, F. Leisch, A. Zeileis (eds.), ISSN 1609-395X. \url{https://www.R-project.org/conferences/DSC-2003/Proceedings/} } \author{ David Meyer \email{David.Meyer@R-project.org} } \seealso{ \code{\link{structable}}, \code{\link{shadings}} } \examples{ data("Titanic") mosaic(Titanic, shade = TRUE, legend = legend_resbased) mosaic(Titanic, shade = TRUE, legend = legend_fixed, gp = shading_Friendly) } \keyword{hplot} vcd/man/panel_pairs_off-diagonal.Rd0000755000175100001440000000464512532005530017020 0ustar hornikusers\name{Pairs plot panel functions for off-diagonal cells} \alias{pairs_strucplot} \alias{pairs_mosaic} \alias{pairs_assoc} \alias{pairs_sieve} \title{Off-diagonal Panel Functions for Table Pairs Plot} \description{ Off-diagonal panel functions for \code{\link{pairs.table}}. } \usage{ pairs_strucplot(panel = mosaic, type = c("pairwise", "total", "conditional", "joint"), legend = FALSE, margins = c(0, 0, 0, 0), labeling = NULL, \dots) pairs_assoc(\dots) pairs_mosaic(\dots) pairs_sieve(\dots) } \arguments{ \item{panel}{function to be used for the plots in each cell, such as \code{\link{pairs_assoc}}, \code{\link{pairs_mosaic}}, and \code{\link{pairs_sieve}}.} \item{type}{character string specifying the type of independence model visualized in the cells.} \item{legend}{logical specifying whether a legend should be displayed in the cells or not.} \item{margins}{margins inside each cell (see \code{\link{strucplot}}).} \item{labeling}{labeling function or labeling-generating function (see \code{\link{strucplot}}).} \item{\dots}{\code{pairs_mosaic}, \code{\link{pairs_assoc}}, and \code{pairs_sieve}: parameters passed to \code{pairs_strucplot}. \code{pairs_strucplot}: other parameters passed to panel function.} } \details{ These functions really just wrap \code{\link{assoc}}, \code{\link{sieve}}, and \code{\link{mosaic}} by basically inhibiting labeling and legend-drawing and setting the margins to 0. } \value{ A function with arguments: \item{x}{contingency table.} \item{i, j}{cell coordinates.} } \seealso{ \code{\link{pairs.table}}, \code{\link{pairs_text}}, \code{\link{pairs_barplot}}, \code{\link{assoc}}, \code{\link{mosaic}} } \references{ Cohen, A. (1980), On the graphical display of the significant components in a two-way contingency table. \emph{Communications in Statistics---Theory and Methods}, \bold{A9}, 1025--1041. Friendly, M. (1992), Graphical methods for categorical data. \emph{SAS User Group International Conference Proceedings}, \bold{17}, 190--200. \url{http://datavis.ca/papers/sugi/sugi17.pdf} } \author{ David Meyer \email{David.Meyer@R-project.org} } \examples{ data("UCBAdmissions") data("PreSex") pairs(PreSex) pairs(UCBAdmissions) pairs(UCBAdmissions, upper_panel_args = list(shade = FALSE)) pairs(UCBAdmissions, lower_panel = pairs_mosaic(type = "conditional")) pairs(UCBAdmissions, upper_panel = pairs_assoc) } \keyword{hplot} vcd/man/SpaceShuttle.Rd0000755000175100001440000000335611150520606014520 0ustar hornikusers\name{SpaceShuttle} \alias{SpaceShuttle} \docType{data} \title{Space Shuttle O-ring Failures} \description{ Data from Dalal et al. (1989) about O-ring failures in the NASA space shuttle program. The damage index comes from a discussion of the data by Tufte (1997). } \usage{ data("SpaceShuttle") } \format{ A data frame with 24 observations and 6 variables. \describe{ \item{FlightNumber}{Number of space shuttle flight.} \item{Temperature}{temperature during start (in degrees F).} \item{Pressure}{pressure.} \item{Fail}{did any O-ring failures occur? (no, yes).} \item{nFailures}{how many (of six) 0-rings failed?.} \item{Damage}{damage index.} } } \references{ S. Dalal, E. B. Fowlkes, B. Hoadly (1989), Risk analysis of the space shuttle: Pre-Challenger prediction of failure, \emph{Journal of the American Statistical Association}, \bold{84}, 945--957. E. R. Tufte (1997), \emph{Visual Explanations: Images and Quantities, Evidence and Narrative}. Graphics Press, Cheshire, CT. M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. } \source{ Michael Friendly (2000), Visualizing Categorical Data: \url{http://euclid.psych.yorku.ca/ftp/sas/vcd/catdata/orings.sas} } \examples{ data("SpaceShuttle") plot(nFailures/6 ~ Temperature, data = SpaceShuttle, xlim = c(30, 81), ylim = c(0,1), main = "NASA Space Shuttle O-Ring Failures", ylab = "Estimated failure probability", pch = 19, col = 4) fm <- glm(cbind(nFailures, 6 - nFailures) ~ Temperature, data = SpaceShuttle, family = binomial) lines(30 : 81, predict(fm, data.frame(Temperature = 30 : 81), type = "re"), lwd = 2) abline(v = 31, lty = 3) } \keyword{datasets} vcd/man/lodds.Rd0000755000175100001440000002472112566042766013242 0ustar hornikusers\name{lodds} \alias{lodds} \alias{odds} \alias{lodds.default} \alias{lodds.formula} \alias{coef.lodds} \alias{confint.lodds} \alias{dim.lodds} \alias{dimnames.lodds} \alias{print.lodds} \alias{vcov.lodds} \alias{as.matrix.lodds} \alias{as.array.lodds} \alias{aperm.lodds} \alias{t.lodds} \alias{as.data.frame.lodds} \title{ Calculate Generalized Log Odds for Frequency Tables } \description{ Computes (log) odds and their asymptotic variance covariance matrix for R (by strata) tables. Odds are calculated for pairs of levels of one array dimension (typically a response or focal variable) separately for each level of all stratifying dimensions. See Friendly et al. (2011) for a sketch of a general theory. } \usage{ lodds(x, \dots) \method{lodds}{default}(x, response = NULL, strata = NULL, log = TRUE, ref = NULL, correct = any(x == 0), \dots) \method{lodds}{formula}(formula, data = NULL, \dots, subset = NULL, na.action = NULL) odds(x, log = FALSE, \dots) \method{coef}{lodds}(object, log = object$log, \dots) \method{vcov}{lodds}(object, log = object$log, \dots) \method{print}{lodds}(x, log = x$log, \dots) \method{confint}{lodds}(object, parm, level = 0.95, log = object$log, \dots) \method{dim}{lodds}(x, ...) \method{dimnames}{lodds}(x, ...) %as.array(x, \dots) \method{as.array}{lodds}(x, log=x$log, \dots) \method{t}{lodds}(x) \method{aperm}{lodds}(a, perm, \dots) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{an object. For the default method a k-way matrix/table/array of frequencies. The number of margins has to be at least 2.} \item{response}{Numeric or character indicating the margin of a $k$-way table \code{x} (with $k$ greater than 2) that should be employed as the response variable. By default the first dimension is used.} \item{strata}{Numeric or character indicating the margins of a $k$-way table \code{x} (with $k$ greater than 2) that should be employed as strata. Ignored if \code{response} is specified. By default all dimensions except the first are used as strata.} \item{ref}{numeric or character. Reference categories for the (non-stratum) row and column dimensions that should be employed for computing the odds. By default, odds for profile contrasts (or sequential contrasts, i.e., successive differences of adjacent categories) are used. See details below.} \item{formula}{a formula specifying the variables used to create a contingency table from \code{data}. A conditioning formula can be specified; the conditioning variables will then be used as strata variables.} \item{data}{either a data frame, or an object of class \code{"table"} or \code{"ftable"}.} \item{subset}{an optional vector specifying a subset of observations to be used.} \item{na.action}{a function which indicates what should happen when the data contain \code{NA}s. Ignored if \code{data} is a contingency table.} \item{log}{logical. Should the results be displayed on a log scale or not? All internal computations are always on the log-scale but the results are transformed by default if \code{log = TRUE}.} \item{correct}{logical or numeric. Should a continuity correction be applied before computing odds? If \code{TRUE}, 0.5 is added to all cells; if numeric (or an array conforming to the data) that value is added to all cells. By default, this not employed unless there are any zero cells in the table, but this correction is often recommended to reduce bias when some frequencies are small (Fleiss, 1981).} \item{a, object}{an object of class \code{lodds} as computed by \code{lodds}.} \item{perm}{numeric or character vector specifying a permutation of strata.} \item{\dots}{arguments passed to methods.} \item{parm}{a specification of which parameters are to be given confidence intervals, either a vector of numbers or a vector of names. If missing, all parameters are considered.} \item{level}{the confidence level required for the \code{confint} method.} } \details{ For an n-way table with the \code{response} variable containing R levels, (log) odds are formed (by default) for the set of (R-1) contrasts among the response levels. The \code{ref} argument allows these to be specified in a general way. \code{ref = NULL} (default) corresponds to \dQuote{profile contrasts} (or sequential contrasts or successive differences) for ordered categories, i.e., R1--R2, R2--R3, R3--R4, etc., and similarly for the column categories. These are sometimes called \dQuote{local odds} or \dQuote{adjacent odds}. \code{ref = 1} gives contrasts with the first category; \code{ref = dim(x)} gives contrasts with the last category. %\code{ref = c(2, 4)} or \code{ref = list(2, 4)} %corresponds to the reference being the second category in rows and %the fourth in columns. %Combinations like \code{ref = list(NULL, 3)} are also possible, as are character %vectors, e.g., \code{ref = c("foo", "bar")} also works ("foo" pertaining again to the % row reference and "bar" to column reference). Note that all such parameterizations are equivalent, in that one can derive all other possible odds from any non-redundant set, but the interpretation of these values depends on the parameterization. %Note also that these reference level parameterizations only have meaning when the %primary (non-strata) table dimensions are larger than 2x2. In the 2x2 case, %the odds are defined by the order of levels of those variables in the table, %so you can achieve a desired interpretation by manipulating the table. See the help page of \code{\link{plot.loddsratio}} for related visualization methods. There is as yet no plot method for \code{lodds} objects. } \value{ An object of class \code{lodds}, with the following components: \item{coefficients}{A named vector, of length (R-1) x (C-1) x \code{prod(dim(x)[strata])} containing the log odds. Use the \code{coef} method to extract these from the object, and the \code{confint} method for confidence intervals. For a two-way table, the names for the log oddsare constructed in the form Ri:Rj using the table names for rows and columns. For a stratified table, the names are constructed in the form Ri:Rj|Lk. } \item{vcov}{Variance covariance matrix of the log odds.} \item{dimnames}{Dimension names for the log odds, considered as a table of size (R-1, C-1, \code{dim(x)[strata]}). Use the \code{dim} and \code{dimnames} methods to extract these and manipulate the log odds in relation to the original table.} \item{dim}{Corresponding dimension vector.} \item{contrasts}{A matrix C, such that \code{C \%*\% as.vector(log(x))} gives the log odds ratios. Each row corresponds to one log odds, and is all zero, except for 2 elements of \code{c(1, -1)} for a given 2 x 1 subtable.} \item{log}{A logical, indicating the value of \code{log} in the original call.} } \references{ A. Agresti (2013), \emph{Categorical Data Analysis}, 3rd Ed. New York: Wiley. Fleiss, J. L. (1981). \emph{Statistical Methods for Rates and Proportions}. 2nd Edition. New York: Wiley. M. Friendly (2000), \emph{Visualizing Categorical Data}. SAS Institute, Cary, NC. Friendly, M., Turner, H,, Firth, D., Zeileis, A. (2011). \emph{Advances in Visualizing Categorical Data Using the vcd, gnm and vcdExtra Packages in R}. Correspondence Analysis and Related Methods (CARME 2011). \url{http://www.datavis.ca/papers/adv-vcd-4up.pdf} } \author{ Achim Zeileis, Michael Friendly and David Meyer. } \note{ The method of calculation is an example of the use of the delta method described by Agresti (2013), Section 16.1.6, giving estimates of log odds ratios and their asymptotic covariance matrix. The \code{coef} method returns the \code{coefficients} component as a vector of length (R-1) x \code{prod(dim(x)[strata])}. The \code{dim} and \code{dimnames} methods provide the proper attributes for treating the \code{coefficients} vector as an (R-1) x strata array. \code{as.matrix} and \code{as.array} methods are also provided for this purpose. The \code{confint} method computes confidence intervals for the log odds (or for odds, with \code{log = FALSE}). The \code{\link[lmtest]{coeftest}} method (\code{summary} is an alias) prints the asymptotic standard errors, z tests (standardized log odds), and the corresponding p values. \emph{Structural zeros}: In addition to the options for zero cells provided by \code{correct}, the function allows for structural zeros to be represented as \code{NA} in the data argument. \code{NA} in the data yields \code{NA} as the \code{LOR} estimate, but does not affect other cells. \code{odds} is just an alias to \code{lodds} with the default \code{log=FALSE} for convenience. } %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ %%\code{\link[vcd]{oddsratio}}, \code{\link{loddsratio}} for log odds \emph{ratios}; %\code{\link{plot.lodds}} for some plotting methods; \code{\link[stats]{confint}} for confidence intervals; \code{\link[lmtest]{coeftest}} for z-tests of significance } \examples{ ## artificial example set.seed(1) x <- matrix(rpois(5 * 3, 7), ncol = 5, nrow = 3) dimnames(x) <- list(Row = head(letters, 3), Col = tail(letters, 5)) x_lodds <- lodds(x) coef(x_lodds) x_lodds confint(x_lodds) summary(x_lodds) ### 2 x 2 x k cases ##data(CoalMiners, package = "vcd") #lor_CM <- loddsratio(CoalMiners) #lor_CM #coef(lor_CM) #confint(lor_CM) #confint(lor_CM, log = FALSE) # ### 2 x k x 2 #lor_Emp <-loddsratio(Employment) #lor_Emp #confint(lor_Emp) # ### 4 way tables #data(Punishment, package = "vcd") #lor_pun <- loddsratio(Freq ~ memory + attitude | age + education, data = Punishment) #lor_pun #confint(lor_pun) #summary(lor_pun) # ## fit linear model using WLS #lor_pun_df <- as.data.frame(lor_pun) #pun_mod1 <- lm(LOR ~ as.numeric(age) * as.numeric(education), # data = lor_pun_df, weights = 1 / ASE^2) #anova(pun_mod1) # ### illustrate ref levels #VA.fem <- xtabs(Freq ~ left + right, subset=gender=="female", data=VisualAcuity) #VA.fem #loddsratio(VA.fem) # profile contrasts #loddsratio(VA.fem, ref=1) # contrasts against level 1 #loddsratio(VA.fem, ref=dim(VA.fem)) # contrasts against level 4 # } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{category} %\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line vcd/man/structable.Rd0000755000175100001440000001222114133457346014271 0ustar hornikusers\name{structable} \alias{structable.default} \alias{structable.formula} \alias{structable} \alias{Extract.structable} \alias{aperm.structable} \alias{t.structable} \alias{is.structable} \alias{cbind.structable} \alias{rbind.structable} \alias{length.structable} \alias{is.na.structable} \alias{as.matrix.structable} \alias{as.vector.structable} \alias{dim.structable} \alias{dimnames.structable} \alias{as.table.structable} \title{Structured Contingency Tables} \description{ This function produces a \sQuote{flat} representation of a high-dimensional contingency table constructed by recursive splits (similar to the construction of mosaic displays). } \usage{ \method{structable}{formula}(formula, data, direction = NULL, split_vertical = NULL, \dots, subset, na.action) \method{structable}{default}(\dots, direction = NULL, split_vertical = FALSE) } \arguments{ \item{formula}{a formula object with possibly both left and right hand sides specifying the column and row variables of the flat table.} \item{data}{a data frame, list or environment containing the variables to be cross-tabulated, or an object inheriting from class \code{table}.} \item{subset}{an optional vector specifying a subset of observations to be used. Ignored if \code{data} is a contingency table.} \item{na.action}{a function which indicates what should happen when the data contain \code{NA}s. Ignored if \code{data} is a contingency table} \item{\dots}{\R objects which can be interpreted as factors (including character strings), or a list (or data frame) whose components can be so interpreted, or a contingency table object of class \code{"table"} or \code{"ftable"}.} \item{split_vertical}{logical vector indicating, for each dimension, whether it should be split vertically or not (default: \code{FALSE}). Values are recycled as needed. If the argument is of length 1, the value is alternated for all dimensions. Ignored if \code{direction} is provided.} \item{direction}{character vector alternatively specifying the splitting direction (\code{"h"} for horizontal and \code{"v"} for vertical splits). Values are recycled as needed. If the argument is of length 1, the value is alternated for all dimensions.} } \details{ This function produces textual representations of mosaic displays, and thus \sQuote{flat} contingency tables. The formula interface is quite similar to the one of \code{\link{ftable}}, but also accepts the \code{\link{mosaic}}-like formula interface (empty left-hand side). Note that even if the \code{\link{ftable}} interface is used, the \code{split_vertical} or \code{direction} argument is needed to specify the \emph{order} of the horizontal and vertical splits. If pretabulated data with a \code{Freq} column is used, than the left-hand side should be left empty---the \code{Freq} column will be handled correctly. \code{"structable"} objects can be subset using the \code{[} and \code{[[} operators, using either level indices or names (see examples). The corresponding replacement functions are available as well. In addition, appropriate \code{\link{aperm}}, \code{\link{cbind}}, \code{\link{rbind}}, \code{\link{length}}, \code{\link{dim}}, and \code{\link{is.na}} methods do exist. } \value{ An object of class \code{"structable"}, inheriting from class \code{"ftable"}, with the splitting information (\code{"split_vertical"}) as additional attribute. } \author{ David Meyer \email{David.Meyer@R-project.org} } \references{ Meyer, D., Zeileis, A., and Hornik, K. (2006), The strucplot framework: Visualizing multi-way contingency tables with \pkg{vcd}. \emph{Journal of Statistical Software}, \bold{17(3)}, 1-48. \doi{10.18637/jss.v017.i03} and available as \code{vignette("strucplot")}. } \seealso{ \code{\link{strucplot}}, \code{\link{mosaic}}, \code{\link[stats]{ftable}} } \examples{ structable(Titanic) structable(Titanic, split_vertical = c(TRUE, TRUE, FALSE, FALSE)) structable(Titanic, direction = c("h","h","v","v")) structable(Sex + Class ~ Survived + Age, data = Titanic) ## subsetting of structable objects (hec <- structable(aperm(HairEyeColor))) ## The "[" operator treats structables as a block-matrix and selects parts of the matrix: hec[1] hec[2] hec[1,c(2,4)] hec["Male",c("Blue","Green")] ## replacement funcion: tmp <- hec (tmp[1,2:3] <- tmp[2,c(1,4)]) ## In contrast, the "[[" operator treats structables as two-dimensional ## lists. Indexing conditions on specified levels and thus reduces the dimensionality: ## seek subtables conditioning on levels of the first dimension: hec[[1]] hec[[2]] ## Seek subtable from the first two dimensions, given the level "Male" ## of the first variable, and "Brown" from the second ## (the following two commands are equivalent): hec[["Male"]][["Brown"]] hec[[c("Male","Brown")]] ## Seeking subtables by conditioning on row and/or column variables: hec[["Male","Hazel"]] hec[[c("Male","Brown"),]] hec[[c("Male","Brown"),"Hazel"]] ## a few other operations t(hec) dim(hec) dimnames(hec) as.matrix(hec) length(hec) cbind(hec[,1],hec[,3]) as.vector(hec) ## computed on the _multiway_ table as.vector(unclass(hec)) } \keyword{hplot} vcd/man/sieve.Rd0000755000175100001440000001546714133457323013246 0ustar hornikusers\name{sieve} \alias{sieve} \alias{sieve.default} \alias{sieve.formula} \title{Extended Sieve Plots} \encoding{UTF-8} \description{ (Extended) sieve displays for n-way contingency tables: plots rectangles with areas proportional to the expected cell frequencies and filled with a number of squares equal to the observed frequencies. Thus, the densities visualize the deviations of the observed from the expected values. } \usage{ \method{sieve}{default}(x, condvars = NULL, gp = NULL, shade = NULL, legend = FALSE, split_vertical = NULL, direction = NULL, spacing = NULL, spacing_args = list(), sievetype = c("observed","expected"), gp_tile = gpar(), scale = 1, main = NULL, sub = NULL, \dots) \method{sieve}{formula}(formula, data, \dots, main = NULL, sub = NULL, subset = NULL) } \arguments{ \item{x}{a contingency table in array form, with optional category labels specified in the \code{dimnames(x)} attribute.} \item{condvars}{vector of integers or character strings indicating conditioning variables, if any. The table will be permuted to order them first.} \item{formula}{a formula specifying the variables used to create a contingency table from \code{data}. For convenience, conditioning formulas can be specified; the conditioning variables will then be used first for splitting. Formulas for sieve displays (unlike those for doubledecker plots) have no response variable.} \item{data}{either a data frame, or an object of class \code{"table"} or \code{"ftable"}.} \item{subset}{an optional vector specifying a subset of observations to be used.} \item{shade}{logical specifying whether \code{gp} should be used or not (see \code{gp}). If \code{TRUE} and \code{expected} is unspecified, a default model is fitted: if \code{condvars} is specified, a corresponding conditional independence model, and else the total independence model. If \code{shade} is \code{NULL} (default), \code{gp} is used if specified.} \item{sievetype}{logical indicating whether rectangles should be filled according to \code{observed} or \code{expected} frequencies.} \item{gp}{object of class \code{"gpar"}, shading function or a corresponding generating function (see details of \code{\link{strucplot}} and \code{\link{shadings}}). Components of \code{"gpar"} objects are recycled as needed along the last splitting dimension. The default is a modified version of \code{\link{shading_Friendly}}: if \code{sievetype} is \code{"observed"}, cells with positive residuals are painted with a red sieve, and cells with negative residuals with a blue one. If \code{sievetype} is \code{"expected"}, the sieves' color is gray. Ignored if \code{shade = FALSE}.} \item{gp_tile}{object of class \code{"gpar"}, controlling the appearance of all \emph{static} elements of the cells (e.g., border and fill color).} \item{scale}{scaling factor for the sieve.} \item{legend}{either a legend-generating function, a legend function (see details of \code{\link{strucplot}} and \code{\link{legends}}), or a logical value. If \code{legend} is \code{NULL} or \code{TRUE} and \code{gp} is a function, legend defaults to \code{\link{legend_resbased}}.} \item{split_vertical}{vector of logicals of length \eqn{k}, where \eqn{k} is the number of margins of \code{x} (default: \code{FALSE}). Values are recycled as needed. A \code{TRUE} component indicates that the tile(s) of the corresponding dimension should be split vertically, \code{FALSE} means horizontal splits. Ignored if \code{direction} is not \code{NULL}.} \item{direction}{character vector of length \eqn{k}, where \eqn{k} is the number of margins of \code{x} (values are recycled as needed). For each component, a value of \code{"h"} indicates that the tile(s) of the corresponding dimension should be split horizontally, whereas \code{"v"} indicates vertical split(s).} \item{spacing}{spacing object, spacing function, or corresponding generating function (see \code{\link{strucplot}} for more information). The default is no spacing at all if \code{x} has two dimensions, and \code{spacing_increase} for more dimensions.} \item{spacing_args}{list of arguments for the generating function, if specified (see \code{\link{strucplot}} for more information).} \item{main, sub}{either a logical, or a character string used for plotting the main (sub) title. If logical and \code{TRUE}, the name of the \code{data} object is used.} \item{\dots}{Other arguments passed to \code{\link{strucplot}}} } \details{ \code{sieve} is a generic function which currently has a default method and a formula interface. Both are high-level interfaces to the \code{\link{strucplot}} function, and produce (extended) sieve displays. Most of the functionality is described there, such as specification of the independence model, labeling, legend, spacing, shading, and other graphical parameters. The layout is very flexible: the specification of shading, labeling, spacing, and legend is modularized (see \code{\link{strucplot}} for details). } \value{ The \code{"structable"} visualized is returned invisibly. } \note{To be faithful to the original definition by Riedwyl & Schüpbach, the default is to have no spacing between the tiles for two-way tables.} \references{ H. Riedwyl & M. Schüpbach (1994), Parquet diagram to plot contingency tables. In F. Faulbaum (ed.), \emph{Softstat '93: Advances in Statistical Software}, 293--299. Gustav Fischer, New York. M. Friendly (2000), Visualizing Categorical Data, SAS Institute, Cary, NC. Meyer, D., Zeileis, A., and Hornik, K. (2006), The strucplot framework: Visualizing multi-way contingency tables with \pkg{vcd}. \emph{Journal of Statistical Software}, \bold{17(3)}, 1-48. \doi{10.18637/jss.v017.i03} and available as \code{vignette("strucplot")}. } \author{ David Meyer \email{David.Meyer@R-project.org} } \seealso{ \code{\link{assoc}}, \code{\link{strucplot}}, \code{\link{mosaic}}, \code{\link{structable}}, \code{\link{doubledecker}} } \examples{ data("HairEyeColor") ## aggregate over 'sex': (haireye <- margin.table(HairEyeColor, c(2,1))) ## plot expected values: sieve(haireye, sievetype = "expected", shade = TRUE) ## plot observed table: sieve(haireye, shade = TRUE) ## plot complete diagram: sieve(HairEyeColor, shade = TRUE) ## example with observed values in the cells: sieve(haireye, shade = TRUE, labeling = labeling_values, gp_text = gpar(fontface = 2)) ## example with expected values in the cells: sieve(haireye, shade = TRUE, labeling = labeling_values, value_type = "expected", gp_text = gpar(fontface = 2)) ## an example for the formula interface: data("VisualAcuity") sieve(Freq ~ right + left, data = VisualAcuity) } \keyword{hplot} vcd/DESCRIPTION0000644000175100001440000000366614672002317012567 0ustar hornikusersPackage: vcd Version: 1.4-13 Title: Visualizing Categorical Data Authors@R: c(person(given = "David", family = "Meyer", role = c("aut", "cre"), email = "David.Meyer@R-project.org", comment = c(ORCID = "0000-0002-5196-3048")), person(given = "Achim", family = "Zeileis", role = "aut", email = "Achim.Zeileis@R-project.org", comment = c(ORCID = "0000-0003-0918-3766")), person(given = "Kurt", family = "Hornik", role = "aut", email = "Kurt.Hornik@R-project.org", comment = c(ORCID = "0000-0003-4198-9911")), person(given = "Florian", family = "Gerber", role = "ctb"), person(given = "Michael", family = "Friendly", role = "aut", email = "friendly@yorku.ca", comment = c(ORCID = "0000-0002-3237-0941"))) Description: Visualization techniques, data sets, summary and inference procedures aimed particularly at categorical data. Special emphasis is given to highly extensible grid graphics. The package was package was originally inspired by the book "Visualizing Categorical Data" by Michael Friendly and is now the main support package for a new book, "Discrete Data Analysis with R" by Michael Friendly and David Meyer (2015). LazyLoad: yes LazyData: yes Depends: R (>= 2.4.0), grid Suggests: KernSmooth, mvtnorm, kernlab, HSAUR3, coin Imports: stats, utils, MASS, grDevices, colorspace, lmtest License: GPL-2 NeedsCompilation: no Packaged: 2024-09-16 09:01:34 UTC; meyer Author: David Meyer [aut, cre] (), Achim Zeileis [aut] (), Kurt Hornik [aut] (), Florian Gerber [ctb], Michael Friendly [aut] () Maintainer: David Meyer Repository: CRAN Date/Publication: 2024-09-16 10:13:35 UTC