ca/0000755000177400001440000000000013024225327011027 5ustar murdochusersca/inst/0000755000177400001440000000000013024052132011774 5ustar murdochusersca/inst/CITATION0000644000177400001440000000127612306757343013161 0ustar murdochuserscitHeader("To cite the package 'ca' in publications please use:") citEntry(entry = "Article", title = "Correspondence Analysis in R, with two- and three-dimensional graphics: The ca package", journal = "Journal of Statistical Software", volume = "20", number = "3", pages = "1-13", year = "2007", author = personList(as.person("O. Nenadic"), as.person("M. Greenacre")), url = "http://www.jstatsoft.org", textVersion = "Nenadic, O., Greenacre, M. (2007) Correspondence Analysis in R, with two- and three-dimensional graphics: The ca package. Journal of Statistical Software 20(3):1-13. " ) ca/NAMESPACE0000644000177400001440000000114612646724144012262 0ustar murdochusersimport(stats) import(graphics) importFrom("grDevices", "col2rgb", "palette", "rgb") importFrom("utils", "type.convert") export(ca, iterate.mjca, mjca, pchlist, plot3d.ca, plot.ca, plot.mjca, cacoord, caconv, multilines) S3method(plot, ca) S3method(plot, mjca) S3method(print, ca) S3method(print, mjca) S3method(print, summary.ca) S3method(print, summary.mjca) S3method(summary, ca) S3method(summary, mjca) S3method(ca, matrix) S3method(ca, data.frame) S3method(ca, formula) S3method(ca, table) S3method(ca, xtabs) S3method(mjca, table) S3method(mjca, array) S3method(mjca, data.frame) ca/NEWS0000644000177400001440000001004313024050660011520 0ustar murdochusersVersion 0.70 (2016-12-11) o Fixed a number of issues with supplementary points/subset analyses Version 0.65 (2016-05-15) o Fixed issue wirth subset MCA (computing row coordinates gave an error 'Error in (Z/Q) %*% col.sc [...]') o Added row-and columnnames for returned matrices (indicator, Burt, 'subinertia') in MCA o Fixed a (rare) issue with JCA and a subset not containing columns from all original factors Version 0.64 (2016-01-17) o mjca() with 'supcol!=NA': - Fixed Mass, ChiDist and Inertia values in print method. - Fixed contributions in summary method. o mjca() with 'subsetcol!=NA' and 'lambda=JCA': - Fixed warnings message ('In rep(1:Q.sub ...)') o Fixed row output for 'lambda!="indicator"' in mjca (rows were previously referring to the Burt matrix, now rows are from the original data) o Added cacoord() for extracting CA/MCA coordinates (standard/principal coordinates, and row-/column configurations for plotting) o Added caconv() for converting between CA/MCA data types (frequency tables, indicator/response pattern/Burt matrices) o mjca() has been made an S3 generic, with data.frame, table, and array methods o added .arrows() to draw nicer arrows with arrows=TRUE in plot.ca() and plot.mjca() o plot.ca() gains a lwd= argument for arrows and lines o Updated mjca.Rd with details of lambda= argument o Added multilines() for nicer mjca plots o plot.mcja gains a collabels= argument determining the form of column labels Version 0.61 (2015-05-18) o Fixed problem with nd='fixed value' in ca Version 0.60 (2015-03-01) o Temporarily enabled plotting rows in plot.mjca o Use requireNamespace("rgl") in plot3d.ca.r to avoid NOTE in R CMD check Version 0.59 (2015-01-29) Version 0.58 (2014-12-31) o mjca(): Added option 'reti' (logical, if TRUE returns the indicator matrix as $indmat). o mjca(): Fixed potentially negative eigenvalues (numerical issue; negative ev's are set to zero). o mjca(): Burt matrices ($Burt) now with row- and columnnames. o print.summary.ca(): Fixed scree plot. Version 0.57 (2014-12-30) o Fixed bug in print.summary.mcja re columns o In plot.ca() and plot.mjca(), for labels=(1,1), don't offset the labels from the points Version 0.56 (2014-11-04) o Begin to assign dimnames to matrices from ca() and mjca()--- for now, just the coordinates matrices o mjca() now returns an additional component, factors, containing factor names and levels, to facilitate plotting and manipulation. This can be used to customize the color, symbols, and labels in plots. o summary.ca() gains rows= and columns= arguments that can be used like scree= to suppress parts of the output. o summary.mjca() gains a similar columns= argument o Fixed calls to rgl functions in plot3d.ca.r to avoid 'no global binding' warnings. o Fixed bug in plot.mcja() with dimension percentages for lambda="adjusted" Version 0.55 (2014-03-09) o plot.ca() and plot.mjca() now provide sensible default xlab and ylab o mjca() now accepts a table object as input, using internal expand.dft o ca() has been made generic, accepting input in the form of matrices, data frames (coerced to frequency tables), objects of class "xtabs" or "table" and one-sided formulae of the form ~ F1 + F2, where F1 and F2 are factors. Version 0.54 (2014-01-05) o Added xlab=, ylab= and lines= arguments to plot.ca(). The function now returns an invisible result containing the row and column coordinates calculated internally for the plot, for use in additional plot annotation. o Added xlab=, ylab= arguments to plot.mjca(). The function now returns an invisible result containing the row and column coordinates calculated internally for the plot, for use in additional plot annotation. o For plot.ca(), the defaults for xlab= and ylab= were changed from "" to "_auto_", meaning that the axis labels are auto-generated to be of the form "Dimension X (xx.xx%)" in conformance with other dimension reduction plots. o Added col.lab argument to plot.ca(), to provide colors for the point labels, similar to col for points. ca/data/0000755000177400001440000000000013024052205011731 5ustar murdochusersca/data/smoke.rda0000644000177400001440000000032213024052205013534 0ustar murdochusers r0b```b`ffb`b2Y# 'f-Ne``1HA %6* 0Q8p;X@i 40u2PZJ;4c.-( W깼b C9 K^~^*LANfzF ÖY HM,D3(\PVS/g`gt7&$Ì r$$m0Ɠ!ca/data/author.rda0000644000177400001440000000203613024052205013724 0ustar murdochusersmoUƧI܊ T.FB!TT[*R3cc3ۓ8IEPy-Yfɒ%K/Yv2K Drsǵol\>8kƜ1??g)q׬4¨ Y,^O/|;:XACOT}%7okzu{+f.c?6<{ ?#x1yZbO>c?KuO%~}:/Km!~홚ĿƺzAo%gjCUφoo:uIcdcogl?"Gg`x23s4y ^^ ~"/п9~]p}Fs{=#75;uG9hq^^PӇuw/2zua_vI\DC܇O}Jmsm/?R]5'/|Vyr[wR_xߝs%r~r?j+}|QϊfGLDMTטI]2ǿ|nwn82ILŽ#UȹOd}xv{s\xwCyOՃ~ kee!O M94xwUvn]}??TkG5c//j},ؚߋomΪwFE{w!O5}?Lݼ x@x,jJA[=7.xNEk:V7Z+`]p"].|sn$sA'(ǬفTucwTgV 0д^s{~32i*>4ZJ)W^,nl킔ŸA ܾFo0H xl(%BK[GW<|!'B_P"D""$"" E0!]-T ca/data/wg93.rda0000644000177400001440000001211513024052205013212 0ustar murdochusersnƑaA `#.3'n$;L;O"{FUk,nYbO?]w_oѿǽė_}(//?ߎWo_o?N;+Z ]tzp?tma;oO+=i#=kN11gxȝw TϢRn7'oq~FQ(+pu 9څvIi{<9zvg9[Dp_fNW^w^)M˺($vo︕ڍ~ҮVVnQ{}$?[P~dWTP+ew?OpN :]/MwjN߽9H}u #NgɦpW9^vvNhF=pQAi^_Xm ooq{VR_.m?E^jl rF;?k0C`/7m}eRƹlzSq8=ǴŐ^$`7`aҾ6;~v?Խ~䏃qP?vo?}qu?~?NàXXD:ZRz%/]4fIx4FRG!Aɦ;6aA$EP^(B;qJKfҨ0-nH#(V/$#K2I&+{Y ʌ) #}4}69 _qRZEv-NFG[=fN,rP3FQ<: ¨#;g[$QS\ݟHW^sNyF{;ꖶ’៶U 6ʊf6ۏA(#k0 #|.IgqWgPf QYMB{ B]Z͓ݟaTfysSRVTMƸ& 돂"+/ֽxFe=^(C/[PesBەW}H󈠌˼֓0ssWANpʘpc?L?`)`4*a'QaJS gL+2C=],G) (mz@2**&-?(q /V17VŊ-_[[79㞭gnL:tgn^U~W;UY=]ݓ^wo^i{k7ql_܏Keq\ݍ{v7u=QwۿCwϝkF[O[ܓm,wwv_`?cQgS<~_׻'٫]gơf6ywOSͱK.ԟL0|v'mY%e:],%!P{=wameshwAI>}_ˊUpa꾃~_t(d/yeN[pKnW,y%eY[n;x}zw - y%=ʒS{A,6W^xʋ$ZJ] ʋ6[Ix}!4,c%^:[!, kҧB¸+/&lhp{+}NByE%5ښPC_>@JC;]zI)=+z ܇07Re4ml)3VǬ`m- z7G:%}þz(ut=~rD/?yPa{?SyVA:3^d!{yJzSP?A1ȎKFݱ?Z,~ɿ 9-)%\'%!0(x_c텱Gf7"x&\ҸsFqe}XVSrqW^DL>qݶ=CX/ [fK7ݬy6/ޘRТ2V J}sL-zAH獇rw%e]ok#AυuPܰ>N*PKy=e5"fvqIYa,*+3 7Fv(kINjxE8H)/R]:7?2/GD+ ^XGۺ& y&}j"եCR݋@Zھ>I^\IXJzDI#?\<88A??}\WOwokwۯO6Q?~_^G(:j먯:Z1Wb#y+F^1Wbe(+FY1ʊQVbuŨ+F]1QWbuh+F[1ڊVbmh+F[1Wb}+F_1Wbcc+X1Ɗ1VbcsŘ+\11Wbcsxb 0) { xoff1 <- if(labels[1]>1) .5 * strwidth(x.names, cex = .75) + .5 * strwidth("o", cex = .75) else 0 xoff2 <- if(labels[1]>1) .5 * strheight(x.names, cex = .75) + .5 * strheight("o", cex = .75) else 0 text(x[,1] + xoff1, x[,2] + xoff2, x.names, cex = 0.75, xpd = TRUE, col = col.lab[1]) } # columns if (!is.na(y[1]) & labels[2] != 1 ) { if (arrows[2]) { .arrows(rep(0, length(y[,1])), rep(0, length(y[,1])), y[,1], y[,2], col = col.y, lwd=lwd, length = 0.1) } else { points(y[,1], y[,2], cex = cex.y, col = col.y, pch = y.pch) } } if (labels[2] > 0) { yoff1 <- if(labels[2]>1) .5 * strwidth(y.names, cex = 0.75) + .5 * strwidth("o", cex = .75) else 0 yoff2 <- if(labels[2]>1) .5 * strheight(y.names, cex = 0.75) + .5 * strheight("o", cex = .75) else 0 text(y[,1] + yoff1, y[,2] + yoff2, y.names, cex = 0.75, xpd = TRUE, col = col.lab[2]) } # plot connecting lines (sorted by X value) if (lines[1]) lines(x[order(x[,1]),], col = col.x, lwd=lwd) if (lines[2]) lines(y[order(y[,1]),], col = col.y, lwd=lwd) par(pty = pty.backup) # return a result for further plot annotation rownames(x) <- x.names; colnames(x) <- paste0("Dim", dim) rownames(y) <- y.names; colnames(y) <- paste0("Dim", dim) result <- list(rows = x, cols = y) invisible(result) } ################################################################################ # the following function isn't exported # Provides a simple way to make more attractive arrows .arrows <- function(..., angle=15){ angles <- seq(1, angle, by=2) for (ang in angles) arrows(..., angle=ang) } ca/R/plot3d.ca.r0000644000177400001440000003102212643540551013205 0ustar murdochusers################################################################################ # plot3d.ca(): 3D-Plotting of ca objects (ca package 0.70) ################################################################################ plot3d.ca <- function(x, dim = c(1,2,3), map = "symmetric", what = c("all","all"), contrib = c("none","none"), col = c("#6666FF","#FF6666"), labcol = c("#0000FF","#FF0000"), pch = c(16,1,18,9), labels = c(2,2), sf = 0.00001, arrows = c(FALSE,FALSE), axiscol = "#333333", axislcol = "#333333", laboffset = list(x = 0, y = 0.075, z = 0.05), ...){ #require(rgl) requireNamespace("rgl") ########## RGLPLOT0: temporary solution for using 'pch' within RGL ########## rglplot0 <- function(x = 0, y = 0, z = 0, v = 1, pch = 1, segments = 16, size = 1, ...) { # coordinates for circles/tetraeders etc i <- seq(0, 360, length = segments) xc <- rep(sin(pi*i/180), each = 2) yc <- rep(cos(pi*i/180), each = 2) xc <- xc[c(-1,-length(xc))] yc <- yc[c(-1,-length(yc))] i0 <- c(0,109.5,109.5,0,109.5,109.5,0,109.5,109.5,109.5,109.5,109.5) j0 <- c(0,0,-120,0,-120,120,0,120,0,-120,0,120)+90 i1 <- c(0,109.5,0,109.5,0,109.5,109.5,109.5,109.5,109.5,109.5,109.5) j1 <- c(0,0,0,-120,0,120,120,0,0,-120,-120,120)+90 i2 <- c(rep(c(180,81.5), 4), rep(81.5, 8)) j2 <- c(0,-45,0,45,0,135,0,-135,-135,-45,-45,45,45,135,135,-135) i3 <- c(i1, 180-i1) j3 <- c(j1, j1-60) r <- v # 'base-matrices' for primitives c01 <- list(x = c(xc, yc, rep(0, length(xc))), z = c(yc, rep(0, length(xc)), xc), y = c(rep(0, length(xc)), xc, yc)) c02 <- list(x = r*sin(pi*i1/180)*cos(pi*j1/180), z = r*cos(pi*i1/180), y = r*sin(pi*i1/180)*sin(pi*j1/180)) c03 <- list(x = c(-1,1,0,0,0,0), z = c(0,0,-1,1,0,0), y = c(0,0,0,0,-1,1)) c04 <- list(x = c(-1,1,1,-1,1,-1,-1,1), z = c(1,-1,-1,1,1,-1,-1,1), y = c(1,-1,1,-1,-1,1,-1,1) ) c05 <- list(x = c(-1,0,0,0,1,0,0,0,-1,0,-1,0,1,0,1,0,0,0,-1,0,0,0,1,0), z = c(0,1,1,0,0,1,1,0,0,0,0,0,0,0,0,0,-1,0,0,-1,-1,0,0,-1), y = c(0,0,0,1,0,0,0,-1,0,-1,0,1,0,1,0,-1,0,-1,0,0,0,1,0,0) ) c06 <- list(x = r*sin(pi*i2/180)*cos(pi*j2/180), z = r*cos(pi*i2/180), y = r*sin(pi*i2/180)*sin(pi*j2/180)) c11 <- list(x = r*sin(pi*i3/180)*cos(pi*j3/180), z = r*cos(pi*i3/180), y = r*sin(pi*i3/180)*sin(pi*j3/180)) c15 <- list(x = c(-1, -1, rep(1, 8), rep(-1,8), 1, 1, -1, 1, 1, -1), z = c(1, 1, 1, 1, rep(c(-1,1,1,-1,1,-1,-1,1), 2), rep(-1, 4)), y = c(-1,1,1,-1,-1,-1,1,1,-1,-1,-1,-1,1,1,-1,-1,1,1,1,1,-1,-1,1,1)) c16 <- list(x = 0, z = 0, y = 0) c17 <- list(x = r*sin(pi*i0/180)*cos(pi*j0/180), z = r*cos(pi*i0/180), y = r*sin(pi*i0/180)*sin(pi*j0/180)) c18 <- list(x = 0.8*c(-1,0,1,1,0,1,1,0,-1,-1,0,-1,1,0,-1,1,0,1,-1,0,1,-1,0,-1), z = c(rep(c(0,1,0), 4), rep(c(0,-1,0), 4)), y = 0.8*c(-1,0,-1,-1,0,1,1,0,1,1,0,-1,-1,0,-1,1,0,-1,1,0,1,-1,0,1)) c19 <- list(x = 0, z = 0, y = 0) c20 <- list(x = 0, z = 0, y = 0) c22 <- list(x = c(-1,1,1,1,-1,1,rep(c(-1,1), each=4),rep(-1,5),1,1,1,-1,1), z = c(rep(1,9),-1,1,-1,1,-1,1,rep(-1,9)), y = c(-1,-1,-1,1,1,1,-1,1,rep(c(-1,1),each=4),-1,1,-1,-1,-1,1,1,1)) c07 <- list(x = c(c22$x, c04$x), z = c(c22$z, c04$z), y = c(c22$y, c04$y)) c08 <- list(x = c(c03$x, c04$x), z = c(c03$z, c04$z), y = c(c03$y, c04$y)) c09 <- list(x = c(c05$x, c03$x), z = c(c05$z, c03$z), y = c(c05$y, c03$y)) c10 <- list(x = c(c01$x, c03$x), z = c(c01$z, c03$z), y = c(c01$y, c03$y)) c12 <- list(x = c(c22$x, c03$x), z = c(c22$z, c03$z), y = c(c22$y, c03$y)) c13 <- list(x = c(c01$x, c04$x), z = c(c01$z, c04$z), y = c(c01$y, c04$y)) c14 <- list(x = c(c22$x,1,0,1,0,-1,0,-1,0), z = c(c22$z,1,-1,1,-1,1,-1,1,-1), y = c(c22$y,-1,0,1,0,1,0,-1,0)) c21 <- c01; c23 <- c05; c24 <- c02; c25 <- c06 # rgl-function/scaling "lookup-table" cc <- list(c01, c02, c03, c04, c05, c06, c07, c08, c09, c10, c11, c12, c13, c14, c15, c16, c17, c18, c19, c20, c21, c22, c23, c24, c25) cc.scale <- c( 3*v/(4*pi), 4*v/sqrt(32), 3*v/8, v/8, 3*v/8, 3*v/4, v/8, v/8, 3*v/8, 3*v/(4*pi), 9*v/(4*sqrt(50)), v/8, 3*v/(4*pi), v/8, v/8, 3*v/(4*pi), 4*v/sqrt(32), 3*v/8, 3*v/(4*pi), 3*v/(4*pi), 3*v/(4*pi), v/8, v*3/8, 4*v/sqrt(32), 3*v/4 )^(1/3) pchlevels <- as.numeric(levels(as.factor(pch))) for (k in 1:length(pchlevels)) { coord <- cc[[pchlevels[k]]] coord.scale <- cc.scale[pchlevels[k]] fm <- c(rep("rgl::lines3d", 14), "rgl::quads3d", "rgl::spheres3d", rep("rgl::triangles3d", 2), rep("rgl::spheres3d", 2), rep("rgl::lines3d", 5)) fm.suffix <- c(rep("",15),paste(coord.scale,",",sep=""),"","", rep(paste(coord.scale,",",sep=""),2),rep("",5)) x0 <- rep(x[pch==pchlevels[k]], each = length(coord$x)) + coord$x * coord.scale z0 <- rep(z[pch==pchlevels[k]], each = length(coord$z)) + coord$z * coord.scale y0 <- rep(y[pch==pchlevels[k]], each = length(coord$y)) + coord$y * coord.scale eval(parse(text = paste(fm[pchlevels[k]], "(x0, y0, z0,", fm.suffix[pchlevels[k]], "size = size, ...)", sep = ""))) } } rglarrows0 <- function(x, y, z, col = "white"){ x.new <- as.vector(rbind(rep(0,length(x)),x)) y.new <- as.vector(rbind(rep(0,length(y)),y)) z.new <- as.vector(rbind(rep(0,length(z)),z)) rgl::rgl.lines(x.new, y.new, z.new, color = col) } ########## END OF RGLPLOT0 # recycling input: if (length(what) != 2){ what <- rep(what, length = 2) } if (length(contrib) != 2){ contrib <- rep(contrib, length = 2) } if (length(col) != 2){ col <- rep(col, length = 2) } if (length(labels) != 2){ labels <- rep(labels, length = 2) } if (length(pch) != 4){ pch <- rep(pch, length = 4) } obj <- x # principal coordinates: K <- dim(obj$rowcoord)[2] I <- dim(obj$rowcoord)[1] ; J <- dim(obj$colcoord)[1] svF <- matrix(rep(obj$sv[1:K], I), I, K, byrow = TRUE) svG <- matrix(rep(obj$sv[1:K], J), J, K, byrow = TRUE) rpc <- obj$rowcoord * svF cpc <- obj$colcoord * svG symrpc <- obj$rowcoord * sqrt(svF) symcpc <- obj$colcoord * sqrt(svG) # maptype mt <- c("symmetric", "rowprincipal", "colprincipal", "symbiplot", "rowgab", "colgab", "rowgreen", "colgreen") mti <- 1:length(mt) mtlut <- list(symmetric = list(x = rpc, y = cpc), rowprincipal = list(x = rpc, y = obj$colcoord), colprincipal = list(x = obj$rowcoord, y = cpc), symbiplot = list(x = symrpc, y = symcpc), rowgab = list(x = rpc, y = obj$colcoord * obj$colmass), colgab = list(x = obj$rowcoord * obj$rowmass, y = cpc), rowgreen = list(x = rpc, y = obj$colcoord * sqrt(obj$colmass)), colgreen = list(x = obj$rowcoord * sqrt(obj$rowmass), y = cpc) ) x <- mtlut[[mti[mt==map]]][[1]] y <- mtlut[[mti[mt==map]]][[2]] x.names <- obj$rownames y.names <- obj$colnames rm(mt, mti, mtlut) # profiles to plot indx <- dim(x)[1] indy <- dim(y)[1] pch.x <- rep(pch[1],dim(x)[1]) pch.y <- rep(pch[3],dim(y)[1]) pr <- c("none", "active", "passive", "all") pri <- 1:4 if (is.na(obj$rowsup[1])) { sup.x <- NA act.x <- x xn.sup <- NA xn.act <- x.names } else { sup.x <- x[obj$rowsup,] act.x <- x[-obj$rowsup,] pch.x[obj$rowsup] <- pch[2] xn.sup <- x.names[obj$rowsup] xn.act <- x.names[-obj$rowsup] } if (is.na(obj$colsup[1])) { sup.y <- NA act.y <- y yn.sup <- NA yn.act <- y.names } else { sup.y <- y[obj$colsup,] act.y <- y[-obj$colsup,] pch.y[obj$colsup] <- pch[4] yn.sup <- y.names[obj$colsup] yn.act <- y.names[-obj$colsup] } prlut <- list(none = list(x = NA, y = NA), active = list(x = act.x, y = act.y), supplementary = list(x = sup.x, y = sup.y), all = list(x = x, y = y)) nameslut <- list(none = list(x.names = NA, y.names = NA), active = list(x.names = xn.act, y.names = yn.act), supplementary = list(x.names = xn.sup, y.names = yn.sup), all = list(x.names = x.names, y.names = y.names) ) pchlut <- list(none = list(x.pch = NA, y.pch = NA), active = list(x.pch = rep(pch[1],dim(x)[1]), y.pch = rep(pch[3],dim(y)[1])), supplementary = list (x.pch = rep(pch[2],dim(x)[1]), y.pch = rep(pch[4],dim(y)[1])), all = list(x.pch = pch.x, y.pch = pch.y) ) x <- prlut[[pri[pr == what[1]]]][[1]] y <- prlut[[pri[pr == what[2]]]][[2]] x.names <- nameslut[[pri[pr == what[1]]]][[1]] y.names <- nameslut[[pri[pr == what[2]]]][[2]] x.pch <- pchlut[[pri[pr == what[1]]]][[1]] y.pch <- pchlut[[pri[pr == what[2]]]][[2]] # dimensions to plot if(is.matrix(x)){ x <- x[,dim] } else { x <- matrix(x[dim], ncol = length(dim), nrow = 1) } if(is.matrix(y)){ y <- y[,dim] } else { y <- matrix(y[dim], ncol = length(dim), nrow = 1) } ## plot setup # radius/mass cex.x <- cex.y <- sf # contributions/colour intensities calpha.x <- 1 calpha.y <- 1 if (contrib[1] == "relative") { calpha.x <- obj$rowmass*(rpc[,dim[1]]^2 + rpc[,dim[2]]^2) / obj$rowinertia } else { if (contrib[1] == "absolute") { calpha.x <- obj$rowmass*(rpc[,dim[1]]^2 + rpc[,dim[2]]^2) / (obj$sv[dim[1]]^2 + obj$sv[dim[2]]^2) } } if (contrib[2] == "relative") { calpha.y <- obj$colmass*(cpc[,dim[1]]^2 + cpc[,dim[2]]^2) / obj$colinertia } else { if (contrib[2] == "absolute") { calpha.y <- obj$colmass*(cpc[,dim[1]]^2 + cpc[,dim[2]]^2) / (obj$sv[dim[1]]^2 + obj$sv[dim[2]]^2) } } ## plotting: rgl::plot3d(0, 0, 0, xlab = "", ylab = "", zlab = "", type = "n", box = FALSE, axes = FALSE, aspect = TRUE) xt.1 <- c(x[,1], y[,1]) xt.2 <- c(x[,2], y[,2]) xt.3 <- c(x[,3], y[,3]) x001 <- range(xt.1[!is.na(xt.1)]) x002 <- range(xt.2[!is.na(xt.2)]) x003 <- range(xt.3[!is.na(xt.3)]) laboffset$x <- laboffset$x * abs(diff(range(x001))) laboffset$y <- laboffset$y * abs(diff(range(x002))) laboffset$z <- laboffset$z * abs(diff(range(x003))) rgl::lines3d(x001, c(0, 0), c(0, 0), col = axiscol) rgl::lines3d(c(0, 0), x002, c(0, 0), col = axiscol) rgl::lines3d(c(0, 0), c(0, 0), x003, col = axiscol) # axis labels rgl::texts3d(x001[2]+0.01*abs(diff(range(x001))), 0, 0, dim[1], col = axislcol, cex = 0.75) rgl::texts3d(0, x002[2]+0.01*abs(diff(range(x001))), 0, dim[2], col = axislcol, cex = 0.75) rgl::texts3d(0, 0, x003[2]+0.01*abs(diff(range(x001))), dim[3], col = axislcol, cex = 0.75) # rows if (!is.na(x[1])) { if (labels[1] != 1) { if (arrows[1]) { rglarrows0(x[,1], x[,2], x[,3], col = col[1]) } else { rglplot0(x[,1], x[,2], x[,3], col = col[1], v = cex.x, alpha = calpha.x, pch = x.pch) } } if (labels[1] > 0) { rgl::texts3d(x[,1]+laboffset$x, x[,2]+laboffset$y, x[,3]+laboffset$z, x.names, cex = 0.95, col = labcol[1]) } } # columns if (!is.na(y[1])) { if (labels[2] != 1 ) { if (arrows[2]) { rglarrows0(y[,1], y[,2], y[,3], col = col[2]) } else { rglplot0(y[,1], y[,2], y[,3], col = col[2], v = cex.y, alpha = calpha.y, pch = y.pch) } } if (labels[2] > 0) { rgl::texts3d(y[,1]+laboffset$x, y[,2]+laboffset$y, y[,3]+laboffset$z, y.names, cex = 0.95, col = labcol[2]) } } } ################################################################################ ca/R/caconv.r0000644000177400001440000001522212646724144012700 0ustar murdochusers################################################################################ # caconv(): Converting between CA/MCA data types (ca 0.64) # Arguments # - x : A matrix or data frame. # - from: The type of input data in 'x': a frequency table ("freq"), or a # response pattern matrix ("rpm"), or an indicator matrix ("ind"), or # a Burt matrix ("Burt"). # - to : The data type into which 'x' should be converted. (Note: Conversion # from "Burt" to "ind" or "rpm" is not supported). # - nlev: A vector containing the number of levels for each categorical # variable (for 'from=ind' or 'from="Burt"'). If NA, 'nlev' is # computed from the data. # - vars: A vector of length 2 specifying the index of the variables to use # for converting to "freq" (i.e. to a regular two-way frequency table). # - ...: Further arguments (ignored). # Value # - A matrix or data frame containing the converted data (with the type # specified in 'to'). ################################################################################ caconv <- function(x, from = c("freq", "rpm", "ind", "Burt"), to = c("rpm", "ind", "Burt", "freq"), nlev = NA, vars = c(1,2), ...){ ##### Input check: from <- match.arg(from) to <- match.arg(to) out <- NA # Reset factor levels for 'from="rpm"': if (from == "rpm"){ x <- data.frame(lapply(x, factor)) } # Fix row-/columnames: if (is.null(rownames(x))){ rownames(x) <- 1:nrow(x) } if (is.null(colnames(x))){ colnames(x) <- 1:ncol(x) } # Get nlev for 'nlev=NA & from="ind"|"Burt"': if (is.na(nlev)[1] & (from == "ind" | from == "Burt")){ if (from == "ind"){ B0 <- x %*% t(x) } else { B0 <- x } diag(B0) <- 0 n <- length(diag(B0)) ind.lo <- 1 nlev <- numeric(0) for (i in 2:n){ B1 <- B0[ind.lo:i, ind.lo:i] if ((sum(B1 == 0) != (i-ind.lo+1)^2) | (i == n)){ nlev <- c(nlev, i - ind.lo + ifelse(i == n, 1, 0)) ind.lo <- i } } } ##### Conversion: ### Source: Frequency matrix if (from == "freq"){ # "freq" => "freq": if (to == "freq"){ out <- x } else { var1 <- factor(rep(rownames(x), apply(x, 1, sum)), levels = rownames(x)) var2 <- factor(rep(rep(colnames(x), nrow(x)), as.vector(t(as.matrix(x)))), levels = colnames(x)) foo <- data.frame(V1 = var1, V2 = var2) # "freq" => "rpm": if (to == "rpm"){ out <- foo } else { n.0 <- unlist(lapply(foo, nlevels)) I.0 <- nrow(foo) out0 <- matrix(0, nrow = I.0, ncol = sum(n.0)) foo1 <- lapply(foo, as.numeric) offset.b <- c(0, cumsum(n.0)) offset <- c(0, n.0[-length(n.0)]) for (i in 1:ncol(foo)){ out0[1:I.0 + (I.0 * (offset[i] + foo1[[i]] - 1))] <- 1 } rownames(out0) <- rownames(foo) colnames(out0) <- paste(rep(colnames(foo), n.0), unlist(lapply(foo, levels)), sep = ".") # "freq" => "ind": if (to == "ind"){ out <- out0 } else { # "freq" => "Burt": if (to == "Burt"){ out <- t(out0)%*%out0 } } } } } else { ### Source: Response pattern matrix if (from == "rpm"){ # "rpm" => "rpm": if (to == "rpm"){ out <- x } else { foo <- x n.0 <- unlist(lapply(foo, nlevels)) I.0 <- nrow(foo) out0 <- matrix(0, nrow = I.0, ncol = sum(n.0)) foo1 <- lapply(foo, as.numeric) offset.b <- c(0, cumsum(n.0)) offset <- c(0, n.0[-length(n.0)]) for (i in 1:ncol(foo)){ out0[1:I.0 + (I.0 * (offset[i] + foo1[[i]] - 1))] <- 1 } rownames(out0) <- rownames(foo) colnames(out0) <- paste(rep(colnames(foo), n.0), unlist(lapply(foo, levels)), sep = ".") # "rpm" => "ind": if (to == "ind"){ out <- out0 } else { out1 <- t(out0)%*%out0 # "rpm" => "Burt": if (to == "Burt"){ out <- out1 } else { # "rpm" => "freq": if (to == "freq"){ lo <- cumsum(c(1,n.0)) hi <- cumsum(c(n.0,0)) lut <- rbind(lo,hi) out <- out1[lut[,vars[1]][1]:lut[,vars[1]][2],lut[,vars[2]][1]:lut[,vars[2]][2]] } } } } } else { ### Source: Indicator matrix if (from == "ind"){ # "ind" => "ind": if (to == "ind"){ out <- x } else { # "ind" => "rpm": if (to == "rpm"){ nn <- length(nlev) mat <- matrix(NA, nrow = sum(nlev), ncol = nn) for (i in 1:nn){ lo <- rep(0, sum(nlev[(1:nn)[(1:nn) < i]])) mid <- 1:nlev[i] up <- rep(0, sum(nlev[(1:nn)[(1:nn) > i]])) mat[,i] <- c(lo,mid,up) } out0 <- data.frame(x %*% mat) out0 <- data.frame(lapply(out0, as.factor)) foo0 <- matrix(unlist(strsplit(colnames(x), ".", fixed = TRUE)), ncol = 2, byrow = TRUE) lut0 <- cumsum(c(1,nlev)) for (i in 1:ncol(out0)){ colnames(out0)[i] <- foo0[lut0[i],1] levels(out0[,i]) <- foo0[lut0[i]:(lut0[i+1]-1),2] } out <- out0 } else { # "ind" => "Burt": out0 <- x %*% t(x) if (to == "Burt"){ out <- out0 } else { # "ind" => "freq": if (to == "freq"){ lo <- cumsum(c(1,nlev)) hi <- cumsum(c(nlev,0)) lut <- rbind(lo,hi) out <- out0[lut[,vars[1]][1]:lut[,vars[1]][2],lut[,vars[2]][1]:lut[,vars[2]][2]] } } } } } else { ### Source: Burt matrix if (from == "Burt"){ # "Burt" => "Burt": if (to == "Burt"){ out <- x } else { # "Burt" => "freq": if (to == "freq"){ lo <- cumsum(c(1,nlev)) hi <- cumsum(c(nlev,0)) lut <- rbind(lo,hi) out <- x[lut[,vars[1]][1]:lut[,vars[1]][2],lut[,vars[2]][1]:lut[,vars[2]][2]] } else { # "Burt" => "ind": if (to == "ind"){ stop("Option 'Burt'=>'ind' not implemented.") } else { # "Burt" => "rpm": if (to == "rpm"){ stop("Option 'Burt'=>'rpm' not implemented.") } } } }}}}} return(out) } ################################################################################ ca/R/mjca.r0000644000177400001440000007211013024050660012322 0ustar murdochusers################################################################################ # mjca(): Computation of MCA & JCA (ca package 0.70) ################################################################################ # generic mjca() mjca <- function(obj, ...){ UseMethod("mjca") } mjca.table <- function(obj, ...){ obj <- expand.dft(obj) mjca.default(obj, ...) } mjca.array <- function(obj, ...){ if (!all(floor(obj) == obj, na.rm = TRUE)) stop("Input object must contain integers") obj <- expand.dft(as.table(obj)) mjca.default(obj, ...) } mjca.data.frame <- function(obj, ...){ mjca.default(obj, ...) } mjca.default <- function(obj, nd = 2, lambda = c("adjusted", "indicator", "Burt", "JCA"), supcol = NA, subsetcat = NA, ps = ":", maxit = 50, epsilon = 0.0001, reti = FALSE, ...){ ##### Part 1: Input checks: lambda <- match.arg(lambda) obj <- data.frame(lapply(data.frame(obj), factor)) subsetcol <- subsetcat ##### Part 2: Data preparation # Indicator and Burt matrix: levels.n.0 <- unlist(lapply(obj, nlevels)) rn.0 <- dimnames(obj)[[1]] cn.0 <- dimnames(obj)[[2]] n.0 <- cumsum(levels.n.0) I.0 <- dim(obj)[1] Q.0 <- dim(obj)[2] Q.sup <- NA J.0 <- sum(levels.n.0) J.sup <- NA Qind.0 <- 1:Q.0 Qind <- Qind.0 Qind.sup <- NA ind.0 <- 1:J.0 ind.sub <- NA ind.sup.foo <- NA ind.sup <- NA cn <- dimnames(obj)[[2]] fn <- rep(names(obj), unlist(lapply(obj, nlevels))) ln <- unlist(lapply(obj,levels)) col.names <- paste(fn, ln, sep = ps) # Subsets, supplementary check: if (!(is.na(subsetcol)[1] & length(subsetcol) == 1)){ # check if given as vector if (mode(subsetcol) != "list"){ if (sum(subsetcol < 0) == length(subsetcol)){ # check for negative indexes subsetcol <- (1:sum(levels.n))[subsetcol] } lut <- cumsum(levels.n.0) - unlist(levels.n.0) s0 <- (1:sum(levels.n.0))[subsetcol] } # end subset-vector if (mode(subsetcol) == "list"){ s0 <- list() if (length(subsetcol) < length(obj)){ for (i in (length(subsetcol)+1):length(obj)){ subsetcol[[i]] <- NA } } for (i in 1:length(obj)){ if (is.na(subsetcol[[i]])[1]){ s0[[i]] <- NA } else { s0[[i]] <- (1:nlevels(obj[[i]]))[subsetcol[[i]]] } } } # end subset-list subsetcol <- s0 } # end subset # Supplementary points: if (!is.na(supcol)[1]){ Qind <- Qind.0[-supcol] Qind.sup <- supcol # get indices for Burt matrix: for (k in 1:length(supcol)){ ind.sup <- c(ind.sup, (c(0,n.0)[supcol[k]] + 1):(c(0,n.0)[supcol[k]+1])) } ind.sup <- ind.sup[-1] ind <- ind.0[-ind.sup] Q.sup <- length(supcol) Q <- Q.0 - Q.sup J.sup <- sum(levels.n.0[Qind.sup]) J <- sum(levels.n.0[Qind]) # check: subset and supplementary? ind.sup.foo <- ind.sup if (!(is.na(subsetcol)[1] & length(subsetcol) == 1)){ ind.sup.foo <- ind.sup.foo - (length(ind) - length(subsetcol)) } } else { ind.sup <- NA ind <- ind.0 Q.sup <- NA Q <- Q.0 J.sup <- NA J <- J.0 } # end supplementary levels.n <- levels.n.0[Qind] # Subset indexes: if (!(is.na(subsetcol)[1] & length(subsetcol) == 1)){ ind.sub <- subsetcol # Levels in Subset: levels.n.sub <- table(rep(1:Q, levels.n)[subsetcol]) # names(levels.n.sub) <- names(levels.n) foo <- rep(names(levels.n), levels.n)[subsetcol] if (is.na(supcol)[1]){ names(levels.n.sub) <- foo[!duplicated(foo)] } else { names(levels.n.sub) <- (foo[!duplicated(foo)])[-supcol] } Q.sub <- Q - sum(levels.n.sub == 0) levels.n.sub <- levels.n.sub[levels.n.sub != 0] } ##### Part 3: 'Core' Computation ### Set up data # Indicator and Burt matrix: Z.0 <- matrix(0, nrow = I.0, ncol = J.0) newdat <- lapply(obj, as.numeric) offset.b <- c(0, n.0) offset <- c(0, n.0[-length(n.0)]) for (i in 1:Q.0){ Z.0[1:I.0 + (I.0 * (offset[i] + newdat[[i]] - 1))] <- 1 } fn <- rep(names(obj), unlist(lapply(obj, nlevels))) ln <- unlist(lapply(obj,levels)) B.0 <- t(Z.0) %*% Z.0 B <- B.0[ind, ind] Z <- Z.0[,ind] P <- B / sum(B) cm <- apply(P, 2, sum) rm <- apply(Z.0/sum(Z.0), 1, sum) S <- diag(sqrt(1/cm)) %*% (P - cm %*% t(cm)) %*% diag(sqrt(1/cm)) evd.S <- eigen(S) evd.S$values[evd.S$values < 0] <- 0 obj.num <- as.matrix(data.frame(lapply(obj[,Qind], as.numeric))) rowmass <- rep(1/I.0, I.0) #NA # rep(1/I.0, I.0) # rowinertia <- apply(((Z.0/sum(Z.0)) - rm %*% t(cm))^2, 1, sum) #NA # apply(S^2, 1, sum) rowinertia <- apply(((Z/sum(Z)) - rm %*% t(cm))^2, 1, sum) #NA # apply(S^2, 1, sum) rowdist <- sqrt(rowinertia / rm) #NA # sqrt(rowinertia / rm) colinertia <- apply(S^2, 2, sum) coldist <- sqrt(colinertia / cm) # Burt bits for supplementary variables: if (!is.na(ind.sup[1])){ B.sup <- B.0[ind.sup, ind] } if(!is.na(subsetcol[1])){ if(!is.na(ind.sup[1])){ ind.sub <- c(ind.sup,ind.sub) ind.sub <- (ind.sub[!duplicated(ind.sub)])[-(1:length(ind.sup))] subsetcol <- ind.sub ind.sup.foo <- ind.sup - (length(ind.0)-length(c(ind.sub,ind.sup))) } # B.sub <- B[ind.sub,ind.sub] B.sub <- B.0[ind.sub,ind.sub] } # some placeholders for adjusted/JCA B.star <- NA lambda.adj <- NA JCA.it <- list(NA, c(NA, NA)) subin <- subinr(B, levels.n) # placeholders for rows: row.ctr <- NA row.cor <- NA ##### 3.1: 'lambda' = "indicator" if (lambda == "indicator"){ nd.max <- J - Q col.sc <- diag(1 / sqrt(cm)) %*% evd.S$vectors[,1:(J-Q)] col.pc <- col.sc %*% diag(sqrt(evd.S$values[1:(J-Q)])) # Computations for rows: if (!is.na(supcol)[1]){ offset.shift <- rep(0, length(Qind)) for (i in 1:length(Qind.sup)){ offset.shift[offset[Qind] > offset[Qind.sup[i]]] <- -offset[Qind.sup[i]] } indices <- t(t(obj.num) + offset[Qind] + offset.shift) row.pc <- matrix(0, nrow = nrow(obj.num), ncol = J-Q) for(i in 1:nrow(obj.num)){ row.pc[i,] <- apply(col.sc[indices[i,],], 2, sum) / Q } } else { indices <- t(t(obj.num) + offset[Qind]) row.pc <- matrix(0, nrow = nrow(obj.num), ncol = J-Q) for(i in 1:nrow(obj.num)){ row.pc[i,] <- apply(col.sc[indices[i,],], 2, sum) / Q } } row.sc <- row.pc %*% diag(1/sqrt(evd.S$values[1:(J-Q)])) col.ctr <- evd.S$vectors[,1:(J-Q)]^2 row.ctr <- (1/nrow(obj.num)) * row.pc^2 %*% diag(1/evd.S$values[1:(J-Q)]) col.cor <- col.pc^2 / apply(col.pc^2, 1, sum) row.cor <- row.pc^2 / apply(row.pc^2, 1, sum) lambda0 <- evd.S$values[1:nd.max] lambda.t <- sum(lambda0) lambda.e <- lambda0 / lambda.t lambda.et <- 1 # Subset analysis: if (!is.na(subsetcol)[1]){ nd.max <- min(length(ind.sub), J-Q) if (!is.na(supcol)[1]){ subsetcol.shift <- rep(0, length(subsetcol)) subsetcol.ranka <- rank(c(ind.sup,subsetcol))[1:length(ind.sup)] subsetcol.rankb <- rank(c(ind.sup,subsetcol))[-(1:length(ind.sup))] for (i in 1:length(ind.sup)){ subsetcol.shift[subsetcol.rankb > subsetcol.ranka[1]] <- subsetcol.shift[subsetcol.rankb > subsetcol.ranka[1]] - 1 } evd.S <- eigen(S[subsetcol+subsetcol.shift,subsetcol+subsetcol.shift]) } else { evd.S <- eigen(S[subsetcol,subsetcol]) } col.sc <- diag(1 / sqrt(cm[subsetcol])) %*% evd.S$vectors[,1:nd.max] col.pc <- col.sc %*% diag(sqrt(evd.S$values[1:nd.max])) col.ctr <- evd.S$vectors[,1:nd.max]^2 col.cor <- col.pc^2 / apply(col.pc^2, 1, sum) lookup <- offset[1:Q] rpm <- as.matrix(data.frame(newdat))[,1:Q] indices <- t(t(rpm) + lookup) row.pc <- matrix(0, nrow = I.0, ncol = nd.max) for(i in 1:(I.0)) { profile <- -cm profile[indices[i,]] <- profile[indices[i,]]+1/Q profile <- profile[subsetcol] row.pc[i,] <- t(profile) %*% col.sc } row.sc <- row.pc %*% diag(1/sqrt(evd.S$values[1:nd.max])) row.ctr <- (1/I.0) * row.pc^2 %*% diag(1/evd.S$values[1:nd.max]) row.cor <- row.pc^2 / apply(row.pc^2, 1, sum) # Subset & Supplementary variables: if(!is.na(supcol)[1]){ cols.pc <- sweep((B.sup / apply(B.sup, 1, sum))[,subsetcol+subsetcol.shift], 2, cm[subsetcol+subsetcol.shift]) %*% col.sc cols.sc <- cols.pc %*% diag(1/sqrt(evd.S$values[1:nd.max])) cols.cor <- cols.pc^2 / apply(cols.pc^2,1,sum) } } # END Subset # Supplementary points: if (!is.na(supcol)[1] & is.na(subsetcol)[1]){ cols.pc <- (B.sup / apply(B.sup, 1, sum)) %*% col.sc cols.sc <- cols.pc %*% diag(1 / evd.S$values[1:nd.max]) cols.sqd <- apply((sweep(sweep((B.sup / apply(B.sup,1,sum)), 2, cm), 2, sqrt(cm), FUN = "/"))^2, 1, sum) cols.cor <- cols.pc^2 / apply(cols.pc^2, 1, sum) } # End supplementary } else { # END if "indicator" ##### 3.2: 'lambda' = "Burt" col.sc <- diag(1/sqrt(cm)) %*% evd.S$vectors[,1:(J-Q)] col.pc <- col.sc %*% diag(evd.S$values[1:(J-Q)]) ### row.sc <- col.sc ### row.pc <- col.pc #mjca2# row.pc <- t(t(Z) %*% diag(1/apply(Z, 1, sum))) %*% col.sc row.pc <- (Z/Q) %*% col.sc row.sc <- row.pc %*% diag(1/evd.S$values[1:(J-Q)]) col.ctr <- evd.S$vectors[,1:(J-Q)]^2 col.cor <- col.pc^2 / apply(col.pc^2, 1, sum) # Subset analysis: if (!is.na(subsetcol)[1]){ nd.max <- min(length(ind.sub), J-Q) # evd.S <- eigen(S[subsetcol,subsetcol]) if (!is.na(supcol)[1]){ subsetcol.shift <- rep(0, length(subsetcol)) subsetcol.ranka <- rank(c(ind.sup,subsetcol))[1:length(ind.sup)] subsetcol.rankb <- rank(c(ind.sup,subsetcol))[-(1:length(ind.sup))] for (i in 1:length(ind.sup)){ subsetcol.shift[subsetcol.rankb > subsetcol.ranka[1]] <- subsetcol.shift[subsetcol.rankb > subsetcol.ranka[1]] - 1 } evd.S <- eigen(S[subsetcol+subsetcol.shift,subsetcol+subsetcol.shift]) } else { evd.S <- eigen(S[subsetcol,subsetcol]) } col.sc <- diag(1/sqrt(cm[subsetcol])) %*% evd.S$vectors[,1:nd.max] col.pc <- col.sc %*% diag(evd.S$values[1:nd.max]) ### row.sc <- col.sc ### row.pc <- col.pc #mjca2# row.pc <- t(t(Z[,subsetcol]) %*% diag(1/apply(Z[,subsetcol], 1, sum))) %*% col.sc # 0.65: row.pc <- (Z/Q) %*% col.sc if (!is.na(subsetcol)[1]){ row.pc <- (Z[,subsetcol]/Q) %*% col.sc } else { row.pc <- (Z/Q) %*% col.sc } ## 0.65 row.sc <- row.pc %*% diag(1/evd.S$values[1:nd.max]) col.ctr <- evd.S$vectors[,1:nd.max]^2 col.cor <- col.pc^2 / apply(col.pc^2, 1, sum) # Subset & Supplementary variables: if(!is.na(supcol)[1]){ cols.pc <- sweep((B.sup / apply(B.sup, 1, sum))[,subsetcol+subsetcol.shift], 2, cm[subsetcol+subsetcol.shift]) %*% col.sc # cols.pc <- sweep((B.sup / apply(B.sup, 1, sum))[,subsetcol], 2, cm[subsetcol]) %*% col.sc cols.sc <- cols.pc %*% diag(1 / evd.S$values[1:nd.max]) cols.cor <- cols.pc^2 / apply(cols.pc^2, 1, sum) } } # End Subset # Supplementary points: if (!is.na(supcol)[1] & is.na(subsetcol)[1]){ B.sup <- B.0[ind.sup, 1:J] cols.pc <- (B.sup / apply(B.sup, 1, sum)) %*% col.sc cols.sc <- cols.pc %*% diag(1/evd.S$values[1:(J-Q)]) cols.cor <- cols.pc^2 / apply(cols.pc^2, 1, sum) } # End supplementary nd.max <- J - Q lambda0 <- (evd.S$values[1:nd.max])^2 # remove NAs in lambda: lambda0 <- lambda0[!is.na(lambda0)] nd.max <- min(nd.max, length(lambda0)) lambda.t <- sum(lambda0) lambda.e <- lambda0 / lambda.t lambda.et <- 1 ##### 3.3: 'lambda' = "adjusted" if (lambda != "Burt"){ nd.max <- sum(sqrt(lambda0) >= 1/Q, na.rm = TRUE) B.null <- B - diag(diag(B)) P.null <- B.null / sum(B.null) S.null <- diag(sqrt(1/cm)) %*% (P.null - cm %*% t(cm)) %*% diag(sqrt(1/cm)) evd.S.null <- eigen(S.null) K0 <- length(which(evd.S.null$values > 1e-8)) Pe <- P for(q in 1:Q){ Pe[(offset.b[q]+1):offset.b[q+1],(offset.b[q]+1):offset.b[q+1]] <- cm[(offset.b[q]+1):offset.b[q+1]] %*% t(cm[(offset.b[q]+1):offset.b[q+1]]) } Se <- diag(sqrt(1/cm)) %*% (Pe-cm%*%t(cm)) %*% diag(sqrt(1/cm)) inertia.adj <- sum(Se^2) * Q / (Q-1) col.sc <- diag(1/sqrt(cm)) %*% evd.S.null$vectors[,1:K0] col.pc <- col.sc %*% diag(evd.S.null$values[1:K0]) ### row.sc <- col.sc ### row.pc <- col.pc #mjca2# row.pc <- t(t(Z) %*% diag(1/apply(Z, 1, sum))) %*% col.sc row.pc <- (Z/Q) %*% col.sc row.sc <- row.pc %*% diag(1/evd.S.null$values[1:K0]) col.ctr <- evd.S.null$vectors[,1:K0]^2 col.inr.adj <- apply(Se^2,2,sum) * Q/(Q-1) col.cor <- diag(cm) %*% col.pc^2 / col.inr.adj lambda.adj <- ((Q/(Q-1))^2 * (sqrt(lambda0)[1:nd.max] - 1/Q)^2) lambda.t <- (Q/(Q-1)) * (sum(lambda0) - ((J - Q) / Q^2)) lambda.e <- lambda.adj / lambda.t lambda.et <- NA lambda0 <- lambda.adj # Subset analysis: if (!is.na(subsetcol)[1]){ if (!is.na(supcol)[1]){ evd.S0 <- eigen(S.null[subsetcol+subsetcol.shift,subsetcol+subsetcol.shift]) } else { evd.S0 <- eigen(S.null[subsetcol,subsetcol]) } K0 <- length(which(evd.S0$values>1e-8)) nd.max <- K0 lookup <- offset.b[1:(Q+1)] Pe <- P for(q in 1:Q){ Pe[(lookup[q]+1):lookup[q+1],(lookup[q]+1):lookup[q+1]] <- cm[(lookup[q]+1):lookup[q+1]] %*% t(cm[(lookup[q]+1):lookup[q+1]]) } Se <- diag(sqrt(1/cm))%*%(Pe-cm%*%t(cm))%*%diag(sqrt(1/cm)) lambda.adj <- evd.S0$values[1:K0]^2 lambda0 <- lambda.adj if (!is.na(supcol)[1]){ lambda.t <- sum(Se[subsetcol+subsetcol.shift,subsetcol+subsetcol.shift]^2)*Q / (Q-1) lambda.e <- lambda.adj / lambda.t col.sc <- diag(1/sqrt(cm[subsetcol+subsetcol.shift])) %*% evd.S0$vectors[,1:K0] } else { lambda.t <- sum(Se[subsetcol,subsetcol]^2)*Q / (Q-1) lambda.e <- lambda.adj / lambda.t col.sc <- diag(1/sqrt(cm[subsetcol])) %*% evd.S0$vectors[,1:K0] } # fix: if (K0 > 1){ col.pc <- col.sc %*% diag(evd.S0$values[1:K0]) } else{ col.pc <- col.sc %*% matrix(evd.S0$values[1:K0]) } ### row.sc <- col.sc ### row.pc <- col.pc #mjca2# row.pc <- t(t(Z[,subsetcol]) %*% diag(1/apply(Z[,subsetcol], 1, sum))) %*% col.sc # 0.65: if (!is.na(subsetcol)[1]){ row.pc <- (Z[,subsetcol]/Q) %*% col.sc } else { row.pc <- (Z/Q) %*% col.sc } # row.pc <- (Z/Q) %*% col.sc ## 0.65: row.sc <- row.pc %*% diag(1/evd.S0$values[1:K0]) # Subset & Supplementary variables: if(!is.na(supcol)[1]){ col.ctr <- evd.S0$vectors[,1:K0]^2 col.inr.adj.subset <- apply(Se[subsetcol+subsetcol.shift,subsetcol+subsetcol.shift]^2, 2, sum) * Q/(Q-1) cols.pc <- sweep((B.sup / apply(B.sup, 1, sum))[,subsetcol+subsetcol.shift], 2, cm[subsetcol+subsetcol.shift]) %*% col.sc cols.sc <- cols.pc %*% diag(1/evd.S0$values[1:K0]) cols.sqd <- apply((sweep(sweep((B.sup/apply(B.sup, 1, sum))[,subsetcol+subsetcol.shift], 2, cm[subsetcol+subsetcol.shift]), 2, sqrt(cm[subsetcol+subsetcol.shift]), FUN="/"))^2, 1, sum) cols.cor <- cols.pc^2 / cols.sqd } else { col.ctr <- evd.S0$vectors[,1:K0]^2 col.inr.adj.subset <- apply(Se[subsetcol,subsetcol]^2, 2, sum) * Q/(Q-1) col.cor <- diag(cm[subsetcol]) %*% col.pc^2 / col.inr.adj.subset } } # End Subset # Supplementary points: if (!is.na(supcol)[1] & is.na(subsetcol)[1]){ B.sup <- B.0[ind.sup, 1:J] cols.pc <- (B.sup / apply(B.sup, 1, sum)) %*% col.sc cols.sc <- cols.pc %*% diag(1/evd.S.null$values[1:K0]) cols.cor <- cols.pc^2 / apply(cols.pc^2, 1, sum) } ##### 3.4: 'lambda' = "JCA" if (lambda == "JCA"){ if (is.na(nd) | nd > nd.max){ nd <- nd.max } B.it <- iterate.mjca(B, lev.n = levels.n, nd = nd, maxit = maxit, epsilon = epsilon) B.star <- B.it[[1]] JCA.it <- B.it[[2]] subin <- subinr(B.star, levels.n) # 0.65: # colnames(B.star) <- col.names # rownames(B.star) <- col.names ##0.65: P <- B.star / sum(B.star) cm <- apply(P, 2, sum) eP <- cm %*% t(cm) S <- (P - eP) / sqrt(eP) dec <- eigen(S) lambda0 <- (dec$values[1:nd.max])^2 col.sc <- as.matrix(dec$vectors[,1:nd.max]) / sqrt(cm) col.pc <- col.sc %*% diag(sqrt(lambda0)) ### row.sc <- col.sc ### row.pc <- col.pc #mjca2# row.pc <- t(t(Z) %*% diag(1/apply(Z, 1, sum))) %*% col.sc # 0.65: # if (!is.na(subsetcol)[1]){ # row.pc <- (Z[,subsetcol]/Q) %*% col.sc # } else { row.pc <- (Z/Q) %*% col.sc # } # row.pc <- (Z/Q) %*% col.sc ## 0.65: row.sc <- row.pc %*% diag(1/sqrt(lambda0)) inertia.mod <- sum(subin - diag(diag(subin))) inertia.discount <- sum(diag(subin)) inertia.expl <- (sum(lambda0[1:nd]) - inertia.discount) / inertia.adj lambda.e <- rep(NA, nd.max) lambda.t <- sum(subin) lambda.et <- (sum(lambda0[1:nd]) - sum(diag(subin))) / (sum(subin)-sum(diag(subin))) Pm <- B.star / sum(B.star) Sm <- diag(sqrt(1/cm))%*%(Pm-cm%*%t(cm))%*%diag(sqrt(1/cm)) inertia.col.discount <- rep(0, J) for(q in 1:Q){ inertia.col.discount[(offset.b[q]+1):(offset.b[q+1])] <- apply(Sm[(offset.b[q]+1):(offset.b[q+1]), (offset.b[q]+1):(offset.b[q+1])]^2, 2, sum) } inertia.col.adj <- apply(Sm^2, 2, sum) - inertia.col.discount col.ctr <- (apply(cm*col.pc[,1:nd]^2, 1, sum) - inertia.col.discount)/ (sum(lambda0[1:nd])-inertia.discount) col.cor <- (apply(cm*col.pc[,1:nd]^2, 1, sum) - inertia.col.discount) / inertia.col.adj # Subset analysis: if (!is.na(subsetcol)[1]){ # template matrix: # foo0 <- rep(1:Q.sub, each = levels.n.sub) # 0.65: qstmp.out <- rep(0, length(levels.n.sub)) qstmp <- matrix(1:Q.sub, nrow = 1) colnames(qstmp) <- cn.0 for (qstmp0 in 1:length(levels.n.sub)){ qstmp.out[qstmp0] <- qstmp[,grep(names(levels.n.sub)[qstmp0], colnames(qstmp))] } foo0 <- rep(qstmp.out, levels.n.sub) ## 0.65 # foo0 <- rep(1:Q.sub, levels.n.sub) foo1 <- (foo0) %*% t(rep(1, sum(levels.n.sub))) - t((foo0) %*% t(rep(1, sum(levels.n.sub)))) upd.template <- ifelse(foo1 == 0, TRUE, FALSE) cat.template <- rep(FALSE, J) if (!is.na(supcol)[1]){ cat.template[subsetcol + subsetcol.shift] <- TRUE } else { cat.template[subsetcol] <- TRUE } Bsub.margin <- apply(B.star, 1, sum) / sum(B.star) Bsub.red.margin <- Bsub.margin[cat.template] Bsub.red <- B.star[cat.template,cat.template] Bsub.red.P <- Bsub.red / sum(B.star) Bsub.red.S <- diag(1/sqrt(Bsub.red.margin)) %*% (Bsub.red.P - Bsub.red.margin %*% t(Bsub.red.margin)) %*% diag(1/sqrt(Bsub.red.margin)) Bsub.red.SVD <- svd(Bsub.red.S) Bsub.red.est <- Bsub.red.margin %*% t(Bsub.red.margin) + diag(sqrt(Bsub.red.margin)) %*% (Bsub.red.SVD$u[,1:nd] %*% diag(Bsub.red.SVD$d[1:nd]) %*% t(Bsub.red.SVD$v[,1:nd])) %*% diag(sqrt(Bsub.red.margin)) Bsub.red.P.mod <- (1-upd.template) * Bsub.red.P + upd.template * Bsub.red.est Bsub.red.S <- diag(1/sqrt(Bsub.red.margin)) %*% (Bsub.red.P.mod - Bsub.red.margin %*% t(Bsub.red.margin)) %*% diag(1/sqrt(Bsub.red.margin)) Bsub.red.SVD <- svd(Bsub.red.S) # iterations: it <- TRUE k <- 0 while (it){ Bsub.red.P.previous <- Bsub.red.P.mod Bsub.red.est <- Bsub.red.margin %*% t(Bsub.red.margin) + diag(sqrt(Bsub.red.margin)) %*% (Bsub.red.SVD$u[,1:nd] %*% diag(Bsub.red.SVD$d[1:nd]) %*% t(Bsub.red.SVD$v[,1:nd])) %*% diag(sqrt(Bsub.red.margin)) Bsub.red.P.mod <- (1 - upd.template) * Bsub.red.P + upd.template * Bsub.red.est Bsub.red.S <- diag(1/sqrt(Bsub.red.margin)) %*% (Bsub.red.P.mod - Bsub.red.margin %*% t(Bsub.red.margin)) %*% diag(1/sqrt(Bsub.red.margin)) Bsub.red.SVD <- svd(Bsub.red.S) if (max(abs(Bsub.red.P.mod - Bsub.red.P.previous)) < epsilon | k >= maxit){ it <- FALSE } k <- k + 1 } inertia.adj.red.discount <- sum((upd.template * Bsub.red.S)^2) inertia.adj.red.subset <- sum(Bsub.red.S^2) - inertia.adj.red.discount col.sc <- sqrt(1/cm[cat.template]) * Bsub.red.SVD$v[,1:nd] col.pc <- col.sc %*% diag(Bsub.red.SVD$d[1:nd]) ### row.sc <- col.sc ### row.pc <- col.pc #mjca2# row.pc <- t(t(Z[,subsetcol]) %*% diag(1/apply(Z[,subsetcol], 1, sum))) %*% col.sc # 0.65: # row.pc <- (Z/Q) %*% col.sc if (!is.na(subsetcol)[1]){ row.pc <- (Z[,subsetcol]/Q) %*% col.sc } else { row.pc <- (Z/Q) %*% col.sc } ## 0.65: row.sc <- row.pc %*% diag(1/Bsub.red.SVD$d[1:nd]) Sm <- Bsub.red.S inertia.col.red.discount <- apply((upd.template * Sm)^2, 2, sum ) inertia.col.red.adj <- apply(Sm^2, 2, sum) - inertia.col.red.discount col.ctr <- (apply(cm[cat.template]*col.pc[,1:nd]^2, 1, sum) - inertia.col.red.discount) / (sum(Bsub.red.SVD$d[1:nd]^2) - inertia.adj.red.discount) col.cor <- (apply(cm[cat.template]*col.pc[,1:nd]^2, 1, sum) - inertia.col.red.discount) / inertia.col.red.adj # Subset & Supplementary variables: if(!is.na(supcol)[1]){ cols.pc <- sweep((B.sup / apply(B.sup, 1, sum))[,cat.template], 2, cm[cat.template]) %*% col.sc cols.sc <- cols.pc %*% diag(1 / Bsub.red.SVD$d[1:nd]) cols.sqd <- apply((sweep(sweep((B.sup / apply(B.sup, 1, sum))[,cat.template], 2, cm[cat.template]), 2, sqrt(cm[cat.template]), FUN = "/"))^2, 1, sum) cols.cor <- apply(cols.pc[,1:nd]^2, 1, sum) / cols.sqd } } # End Subset # Supplementary points: if (!is.na(supcol)[1] & is.na(subsetcol)[1]){ B.sup <- B.0[ind.sup, 1:J] cols.pc <- (B.sup / apply(B.sup, 1, sum)) %*% col.sc cols.sc <- cols.pc %*% diag(1 / lambda0) cols.sqd <- apply((sweep(sweep((B.sup/apply(B.sup,1,sum)), 2, cm), 2, sqrt(cm), FUN="/"))^2, 1, sum) cols.cor <- apply(cols.pc[,1:nd]^2, 1, sum) / cols.sqd } } # END if "JCA" } # END if !"Burt" } # END else if "indicator" if (!is.na(supcol)[1]){ # colcoord <- rbind(col.sc, cols.sc) # colpcoord <- rbind(col.pc, cols.pc) colcoord <- rbind(col.sc, cols.sc) colcoord[ind.sup,] <- cols.sc colcoord[-ind.sup,] <- col.sc colpcoord <- rbind(col.pc, cols.pc) colpcoord[ind.sup,] <- cols.pc colpcoord[-ind.sup,] <- col.pc if (lambda != "JCA"){ colctr <- rbind(col.ctr, matrix(NA, nrow = length(ind.sup), ncol = ncol(col.ctr))) colctr[ind.sup,] <- matrix(NA, nrow = length(ind.sup), ncol = ncol(col.ctr)) colctr[-ind.sup,] <- col.ctr col.ctr <- colctr colcor <- rbind(col.cor, cols.cor) colcor[ind.sup,] <- cols.cor colcor[-ind.sup,] <- col.cor } else { colctr <- c(col.ctr, rep(NA, length(ind.sup))) colctr[ind.sup] <- rep(NA, length(ind.sup)) colctr[-ind.sup] <- col.ctr col.ctr <- colctr colcor <- c(col.cor, cols.cor) colcor[ind.sup] <- cols.cor colcor[-ind.sup] <- col.cor } } else { colcoord <- col.sc colpcoord <- col.pc colcor <- col.cor } col.names0 <- col.names if (!is.na(subsetcol[1])){ cm <- cm[ind.sub] coldist <- coldist[ind.sub] colinertia <- colinertia[ind.sub] col.names0 <- col.names[ind.sub] if(!is.na(supcol)[1]){ col.names0 <- c(col.names0,col.names[ind.sup]) } B.out <- B.sub } else { B.out <- B.0 } colctr <- col.ctr rowcoord <- row.sc rowpcoord <- row.pc if(!is.na(supcol)[1]){ # colinertia <- c(colinertia, rep(NA, J.sup)) # coldist <- c(coldist, rep(NA, J.sup)) # cm <- c(cm, rep(NA, J.sup)) colinertia0 <- rep(0, length(ind.0)) colinertia0[ind] <- colinertia colinertia0[ind.sup] <- NA colinertia <- colinertia0 coldist0 <- rep(0, length(ind.0)) coldist0[ind] <- coldist coldist0[ind.sup] <- NA coldist <- coldist0 cm0 <- rep(0, length(ind.0)) cm0[ind] <- cm cm0[ind.sup] <- NA cm <- cm0 } col.names <- col.names0 # (2014-10, returning Indicator matrix) if (reti == TRUE){ indmat <- Z.0 # 0.65: colnames(indmat) <- col.names rownames(indmat) <- rn.0 ##0.65: } else { indmat <- NA } # balkan solution for colcor > 1 (2011-09): # adjusted analysis only! if (lambda == "adjusted"){ foo0 <- apply(colcor, 1, max) > 1 if (sum(foo0) > 0){ insert <- c(1, rep(0, dim(colcor)[2]-1)) colcor[foo0,] <- matrix(insert, nrow = sum(foo0), ncol = dim(colcor)[2], byrow = TRUE) } } factors <- cbind(factor = fn, level = ln) # add row- and columnnames to Burt matrix if (!is.na(subsetcol[1]) & !is.na(ind.sup.foo[1]) ){ dimnames(B.out) <- list(col.names[-ind.sup.foo], col.names[-ind.sup.foo]) } else { dimnames(B.out) <- list(col.names, col.names) } ### 0.70 fix # colnames(subin) <- cn.0 # rownames(subin) <- cn.0 if (is.na(supcol[1])){ colnames(subin) <- cn.0 rownames(subin) <- cn.0 } else { colnames(subin) <- cn.0[-supcol] rownames(subin) <- cn.0[-supcol] } # wrap up results mjca.output <- list(sv = sqrt(lambda0), lambda = lambda, inertia.e = lambda.e, inertia.t = lambda.t, inertia.et = lambda.et, levelnames = col.names, factors = factors, levels.n = levels.n.0, nd = nd, nd.max = nd.max, rownames = rn.0, rowmass = rowmass, rowdist = rowdist, rowinertia = rowinertia, rowcoord = rowcoord, rowpcoord = rowpcoord, rowctr = row.ctr, rowcor = row.cor, colnames = cn.0, colmass = cm, coldist = coldist, colinertia = colinertia, colcoord = colcoord, colpcoord = colpcoord, colctr = col.ctr, colcor = colcor, colsup = ind.sup.foo, subsetcol = subsetcol, Burt = B.out, Burt.upd = B.star, subinertia = subin, JCA.iter = JCA.it, indmat = indmat, call = match.call()) class(mjca.output) <- "mjca" return(mjca.output) } ################################################################################ ca/R/summary.ca.r0000644000177400001440000001050613024050660013470 0ustar murdochusers################################################################################ # summary.ca(): Summarizing ca objects (ca package 0.70) ################################################################################ summary.ca <- function(object, scree = TRUE, rows = TRUE, columns = TRUE, ...){ obj <- object nd <- obj$nd if (is.na(nd)){ nd <- 2 } else { if (nd > length(obj$sv)){ nd <- length(obj$sv) } } # principal coordinates: K <- nd I <- dim(obj$rowcoord)[1] ; J <- dim(obj$colcoord)[1] svF <- matrix(rep(obj$sv[1:K], I), I, K, byrow = TRUE) svG <- matrix(rep(obj$sv[1:K], J), J, K, byrow = TRUE) rpc <- obj$rowcoord[,1:K] * svF cpc <- obj$colcoord[,1:K] * svG # rows: strnascii <- function(x){ foo1 <- unlist(strsplit(x, "")) foo2 <- grep('\\w', foo1) foo <- paste(foo1[foo2], collapse = "") return(foo) } if(!rows) { r.out <- NULL } else { rnames.temp <- unlist(lapply(obj$rownames, strnascii)) r.names <- abbreviate(rnames.temp, 4) sr <- obj$rowsup if (!is.na(sr[1])){ r.names[sr] <- paste("(*)", r.names[sr], sep = "") } r.mass <- obj$rowmass if (length(obj$rowsup)>0){ i0 <- obj$rowsup r.mass[i0] <- NA } r.inr <- obj$rowinertia / sum(obj$rowinertia, na.rm = TRUE) r.ccc <- matrix(NA, nrow = length(r.names), ncol = nd * 3) for (i in 1:nd){ r.ccc[,3 * (i - 1) + 1] <- rpc[,i] # r.ccc[,3 * (i - 1) + 2] <- rpc[,i]^2 / obj$rowdist^2 rpc0 <- cacoord(obj, type = "principal", rows = TRUE) r.ccc[,3 * (i - 1) + 2] <- rpc0[,i]^2 / apply(rpc0^2, 1, sum) r.ccc[,3 * (i - 1) + 3] <- obj$rowmass * rpc[,i]^2 /obj$sv[i]^2 } if (nd > 1) { r.qlt <- apply(r.ccc[,((1:nd-1) * 3 + 2)], 1, sum) } else { r.qlt <- r.ccc[,((1:nd-1) * 3 + 2)] } r1 <- paste(" k=", 1:nd, sep = "") r2 <- rep("cor", nd) r3 <- rep("ctr", nd) rcclab <- as.vector(rbind(r1, r2, r3)) dimnames(r.ccc) <- list(r.names, rcclab) r.out <- data.frame(r.names, round(1000 * r.mass, 0), round(1000 * r.qlt, 0), round(1000 * r.inr, 0), round(1000 * r.ccc, 0)) dimnames(r.out) <- list(as.character(1:length(r.names)), c("name", "mass", " qlt", " inr", rcclab)) } # columns: if(!columns) { c.out <- NULL } else { cnames.temp <- unlist(lapply(obj$colnames, strnascii)) c.names <- abbreviate(cnames.temp, 4) sc <- obj$colsup if (!is.na(sc[1])){ c.names[sc] <- paste("(*)", c.names[sc], sep = "") } c.mass <- obj$colmass if (length(obj$colsup) > 0){ i0 <- obj$colsup c.mass[i0] <- NA } c.inr <- obj$colinertia / sum(obj$colinertia, na.rm = TRUE) c.ccc <- matrix(NA, nrow = length(c.names), ncol = nd * 3) for (i in 1:nd){ c.ccc[,3 * (i - 1) + 1] <- cpc[,i] # c.ccc[,3 * (i - 1) + 2] <- cpc[,i]^2 / obj$coldist^2 cpc0 <- cacoord(obj, type = "principal", cols = TRUE) c.ccc[,3 * (i - 1) + 2] <- cpc0[,i]^2 / apply(cpc0^2, 1, sum) c.ccc[,3 * (i - 1) + 3] <- obj$colmass * cpc[,i]^2 / obj$sv[i]^2 } if (nd > 1) { c.qlt <- apply(c.ccc[,((1:nd - 1) * 3 + 2)], 1, sum) } else { c.qlt <- c.ccc[,((1:nd - 1) * 3 + 2)] } c1 <- paste(" k=", 1:nd, sep = "") c2 <- rep("cor", nd) c3 <- rep("ctr", nd) ccclab <- as.vector(rbind(c1, c2, c3)) dimnames(c.ccc) <- list(c.names, ccclab) c.out <- data.frame(c.names, round(1000 * c.mass, 0), round(1000 * c.qlt, 0), round(1000 * c.inr, 0), round(1000 * c.ccc, 0)) dimnames(c.out) <- list(as.character(1:length(c.names)), c("name", "mass", " qlt", " inr", ccclab)) } # scree plot: if (scree) { values <- obj$sv^2 values2 <- 100*(obj$sv^2)/sum(obj$sv^2) values3 <- cumsum(100*(obj$sv^2)/sum(obj$sv^2)) scree.out <- cbind(1:length(obj$sv), values, values2, values3) } else { scree.out <- NULL } # output: out <- list(scree = scree.out, rows = r.out, columns = c.out) class(out) <- "summary.ca" return(out) } ################################################################################ ca/R/cacoord.r0000644000177400001440000001246312652430027013034 0ustar murdochusers################################################################################ # cacoord(): Extracting CA/MCA coordinates (ca 0.64) # Arguments # - obj : A 'ca' or 'mjca' object. # - type: The type of coordinates ("standard" or "principal"); the remaining # options ("symmetric", ..., "colgreen") return the corresponding # row/column configuration for the map scaling options in plot.ca(). # - dim : The dimensions to return; if NA, all available dimensions are # returned. # - rows: If TRUE, the row coordinates are returned (see below for details). # - cols: If TRUE, the column coordinates are returned (see below for details). # - ...: Further arguments (ignored). # Value # - A list with the entries 'rows' and 'columns' containing the corresponding # row and column coordinates (for (rows=NA&cols=NA)|(rows=TRUE&cols=TRUE)). # For 'rows=TRUE' (and cols=NA or cols=FALSE) a matrix with the row # coordinates is returned; and for 'cols=TRUE' (and cols=NA or cols=FALSE) # a matrix with the column coordinates is returned. ################################################################################ cacoord <- function(obj, type = c("standard", "principal", "symmetric", "rowprincipal", "colprincipal", "symbiplot", "rowgab", "colgab", "rowgreen", "colgreen"), dim = NA, rows = NA, cols = NA, ...){ if (!inherits(obj, c("ca", "mjca"))){ stop("'obj' must be a 'ca' or 'mjca' object") } map <- match.arg(type) if (is.na(rows) & is.na(cols)){ rows <- TRUE cols <- TRUE } else{ if (is.na(rows) | !rows){ rows <- FALSE cols <- TRUE obj$rowcoord <- matrix(rep(0, ncol(obj$colcoord)), nrow = 1) obj$rowmass <- 1 } if (is.na(cols) | !cols){ cols <- FALSE rows <- TRUE obj$colcoord <- matrix(rep(0, ncol(obj$rowcoord)), nrow = 1) obj$colmass <- 1 } } # Check row-/columnnames: if (is.null(rownames(obj$rowcoord))){ x.rnames <- 1:nrow(obj$rowcoord) rownames(obj$rowcoord) <- x.rnames } else { x.rnames <- rownames(obj$rowcoord) } if (is.null(colnames(obj$rowcoord))){ x.cnames <- paste("Dim", 1:ncol(obj$rowcoord), sep = "") colnames(obj$rowcoord) <- x.cnames } else { x.cnames <- colnames(obj$rowcoord) } if (is.null(rownames(obj$colcoord))){ y.rnames <- 1:nrow(obj$colcoord) rownames(obj$colcoord) <- y.rnames } else { y.rnames <- rownames(obj$colcoord) } if (is.null(colnames(obj$colcoord))){ y.cnames <- paste("Dim", 1:ncol(obj$colcoord), sep = "") colnames(obj$colcoord) <- y.cnames } else { y.cnames <- colnames(obj$colcoord) } # Extract dimensions if (is.na(dim)[1]){ sv <- obj$sv rsc <- obj$rowcoord csc <- obj$colcoord } else { sv <- obj$sv[dim] rsc <- matrix(obj$rowcoord[,dim], ncol = length(dim)) csc <- matrix(obj$colcoord[,dim], ncol = length(dim)) rownames(rsc) <- x.rnames colnames(rsc) <- x.cnames[dim] rownames(csc) <- y.rnames colnames(csc) <- y.cnames[dim] } # Coordinates ([r,c]sc: standard; [r,c]pc: principal; sym[r,c]pc: biplot; [r,c]gab: gabriel; [r,c]green: greenacre): if (map == "standard"){ x <- rsc y <- csc } else { I <- nrow(rsc) J <- nrow(csc) K <- ncol(rsc) rpc <- rsc %*% diag(sv) cpc <- csc %*% diag(sv) if (map == "principal"){ x <- rpc y <- cpc } else { symrpc <- rsc %*% diag(sqrt(sv)) symcpc <- csc %*% diag(sqrt(sv)) rgab <- rsc * matrix(obj$rowmass, ncol = ncol(rsc), nrow = nrow(rsc)) cgab <- csc * matrix(obj$colmass, ncol = ncol(csc), nrow = nrow(csc)) rgreen <- rsc * matrix(sqrt(obj$rowmass), ncol = ncol(rsc), nrow = nrow(rsc)) cgreen <- csc * matrix(sqrt(obj$colmass), ncol = ncol(csc), nrow = nrow(csc)) # Maptype LUT mt <- c("symmetric", "rowprincipal", "colprincipal", "symbiplot", "rowgab", "colgab", "rowgreen", "colgreen") mti <- 1:length(mt) mtlut <- list(symmetric = list(x = rpc, y = cpc), rowprincipal = list(x = rpc, y = csc), colprincipal = list(x = rsc, y = cpc), symbiplot = list(x = symrpc, y = symcpc), rowgab = list(x = rpc, y = cgab), colgab = list(x = rgab, y = cpc), rowgreen = list(x = rpc, y = cgreen), rowgreen = list(x = rgreen, y = cpc) ) x <- mtlut[[mti[mt == map]]][[1]] y <- mtlut[[mti[mt == map]]][[2]] } # End !"principal" } # End !"standard" # Fix row-/columnnames rownames(x) <- rownames(rsc) colnames(x) <- colnames(rsc) rownames(y) <- rownames(csc) colnames(y) <- colnames(csc) # Return rows and/or columns: if (rows & cols){ out <- list(rows = x, columns = y) } else { if (rows){ out <- x } else { out <- y } } return(out) } ################################################################################ ca/R/ca.r0000644000177400001440000002231013024050660011770 0ustar murdochusers################################################################################ # ca(): Computation of Simple CA ################################################################################ # ca.matrix() # ca methods below ca.matrix <- function(obj, nd = NA, suprow = NA, supcol = NA, subsetrow = NA, subsetcol = NA, ...){ nd0 <- nd I <- dim(obj)[1] ; J <- dim(obj)[2] rn <- dimnames(obj)[[1]] cn <- dimnames(obj)[[2]] N <- matrix(as.matrix(obj), nrow = I, ncol = J) # Temporary remove supplementray rows/columns: Ntemp <- N ; NtempC <- NtempR <- N suprow <- sort(suprow) ; supcol <- sort(supcol) # back to supplementary profiles: if (!is.na(supcol[1]) & !is.na(suprow[1])) { NtempC <- Ntemp[-suprow,] NtempR <- Ntemp[,-supcol] } if (!is.na(supcol[1])) { SC <- as.matrix(NtempC[,supcol]) Ntemp <- Ntemp[,-supcol] cs.sum <- apply(SC, 2, sum) } if (!is.na(suprow[1])) { SR <- matrix(as.matrix(NtempR[suprow,]), nrow = length(suprow)) Ntemp <- Ntemp[-suprow,] rs.sum <- apply(SR, 1, sum) } N <- matrix(as.matrix(Ntemp), nrow = dim(Ntemp)[1], ncol = dim(Ntemp)[2]) # Adjustment for subset CA subsetrowt <- subsetrow if (!is.na(subsetrow[1]) & !is.na(suprow[1])) { subsetrowi <- subsetrow subsetrowt <- sort(c(subsetrow, suprow)) subsetrowt <- subsetrowt[!duplicated(subsetrowt)] I <- length(subsetrowt) # adjust subset index for (q in length(suprow):1) { subsetrow <- subsetrow[subsetrow != suprow[q]] subsetrow <- subsetrow - as.numeric(suprow[q] < subsetrow) } # adjust supplementary row indexes: for (q in 1:length(suprow)) suprow[q] <- (1:length(subsetrowt))[subsetrowt == suprow[q]] } subsetcolt <- subsetcol if (!is.na(subsetcol[1]) & !is.na(supcol[1])) { subsetcoli <- subsetcol subsetcolt <- sort(c(subsetcol, supcol)) subsetcolt <- subsetcolt[!duplicated(subsetcolt)] J <- length(subsetcolt) # adjust subset index for (q in length(supcol):1) { subsetcol <- subsetcol[subsetcol != supcol[q]] subsetcol <- subsetcol - as.numeric(supcol[q] < subsetcol) } # adjust supplementary column indexes: for (q in 1:length(supcol)) supcol[q] <- (1:length(subsetcolt))[subsetcolt == supcol[q]] } # check for subset CA dim.N <- dim(N) if (!is.na(subsetrow[1])) { if (!is.na(supcol[1])) SC <- as.matrix(SC[subsetrow,]) } if (!is.na(subsetcol[1])) { if (!is.na(suprow[1])) SR <- matrix(as.matrix(SR[,subsetcol]), nrow = length(suprow)) } # end subset CA if (is.na(subsetrow[1]) & is.na(subsetcol[1])) { nd.max <- min(dim.N) - 1 } else { # subset-case below: N00 <- N if (!is.na(subsetrow[1])) N00 <- N00[subsetrow,] if (!is.na(subsetcol[1])) N00 <- N00[,subsetcol] dim.N <- dim(N00) nd.max <- min(dim.N) if (!is.na(subsetrow[1]) & is.na(subsetcol[1])){ if (dim.N[1] > dim.N[2]) nd.max <- min(dim.N) - 1 } else { if (is.na(subsetrow[1]) & !is.na(subsetcol[1])){ if (dim.N[2] > dim.N[1]){ nd.max <- min(dim.N) - 1 } } } } if (is.na(nd) | nd > nd.max ) nd <- nd.max # Init: n <- sum(N) ; P <- N/n rm <- apply(P, 1, sum) ; cm <- apply(P, 2, sum) # SVD: eP <- rm %*% t(cm) eN <- eP * n S <- (P-eP)/sqrt(eP) # subset CA if (!is.na(subsetcol[1])) { S <- S[,subsetcol] cm <- cm[subsetcol] cn <- cn[subsetcolt] } if (!is.na(subsetrow[1])) { S <- S[subsetrow,] rm <- rm[subsetrow] rn <- rn[subsetrowt] } # end sCA chimat <- S^2 * n dec <- svd(S) sv <- dec$d[1:nd.max] u <- dec$u v <- dec$v ev <- sv^2 cumev <- cumsum(ev) # Inertia: totin <- sum(ev) rin <- apply(S^2, 1, sum) cin <- apply(S^2, 2, sum) # chidist rachidist <- sqrt(rin / rm) cachidist <- sqrt(cin / cm) rchidist <- rep(NA, I) cchidist <- rep(NA, J) if (!is.na(subsetrow[1])) { obj <- obj[subsetrowt,] } if (!is.na(subsetcol[1])) { obj <- obj[,subsetcolt] } # supplementary rows/columns: if (!is.na(suprow[1])) { if (is.na(supcol[1])) { P.stemp <- matrix(as.matrix(obj[suprow,]), nrow = length(suprow)) } else{ P.stemp <- matrix(as.matrix(obj[suprow, -supcol]), nrow = length(suprow)) } P.stemp <- P.stemp / apply(P.stemp, 1, sum) P.stemp <- t((t(P.stemp) - cm) / sqrt(cm)) rschidist <- sqrt(apply(P.stemp^2, 1, sum)) rchidist[-suprow] <- rachidist rchidist[suprow] <- rschidist } else rchidist <- rachidist if (!is.na(supcol[1])) { if (is.na(suprow[1])) { P.stemp <- as.matrix(obj[, supcol]) } else { P.stemp <- as.matrix(obj[-suprow, supcol]) } P.stemp <- t(t(P.stemp) / apply(P.stemp, 2, sum)) P.stemp <- (P.stemp - rm) / sqrt(rm) cschidist <- sqrt(apply(P.stemp^2, 2, sum)) cchidist[-supcol] <- cachidist cchidist[supcol] <- cschidist } else { cchidist <- cachidist } # Standard coordinates: phi <- as.matrix(u[,1:nd]) / sqrt(rm) gam <- as.matrix(v[,1:nd]) / sqrt(cm) # Standard coordinates for supplementary rows/columns if (!is.na(suprow[1])) { cs <- cm gam.00 <- gam base2 <- SR / matrix(rs.sum, nrow = nrow(SR), ncol = ncol(SR)) base2 <- t(base2) cs.0 <- matrix(cs, nrow = nrow(base2), ncol = ncol(base2)) svphi <- matrix(sv[1:nd], nrow = length(suprow), ncol = nd, byrow = TRUE) base2 <- base2 - cs.0 phi2 <- (t(as.matrix(base2)) %*% gam.00) / svphi phi3 <- matrix(NA, ncol = nd, nrow = I) phi3[suprow,] <- phi2 phi3[-suprow,] <- phi rm0 <- rep(NA, I) rm0[-suprow] <- rm P.star <- SR / n rm0[suprow] <- NA # apply(P.star, 1, sum) rin0 <- rep(NA, I) rin0[-suprow] <- rin rin <- rin0 rm.old <- rm rm <- rm0 } if (!is.na(supcol[1])) { if (!is.na(suprow[1])) { rs <- rm.old } else { rs <- rm } phi.00 <- phi base2 <- SC / matrix(cs.sum, nrow = nrow(SC), ncol = ncol(SC), byrow = TRUE) rs.0 <- matrix(rs, nrow = nrow(base2), ncol = ncol(base2)) svgam <- matrix(sv[1:nd], nrow = length(supcol), ncol = nd, byrow = TRUE) base2 <- base2 - rs.0 gam2 <- (as.matrix(t(base2)) %*% phi.00) / svgam gam3 <- matrix(NA, ncol = nd, nrow = J) gam3[supcol,] <- gam2 gam3[-supcol,] <- gam cm0 <- rep(NA, J) cm0[-supcol] <- cm P.star <- SC / n cm0[supcol] <- NA cin0 <- rep(NA, J) cin0[-supcol] <- cin cin <- cin0 cm <- cm0 } if (exists("phi3")){ phi <- phi3 } if (exists("gam3")){ gam <- gam3 } # if (exists("rm0")){ # rm <- rm0 # } # if (exists("cm0")){ # cm <- cm0 # } dims <- paste0("Dim", seq_along(sv))[1:nd] dimnames(phi) <- list(rn, dims) dimnames(gam) <- list(cn, dims) ca.output <- list(sv = sv, nd = nd0, rownames = rn, rowmass = rm, rowdist = rchidist, rowinertia = rin, rowcoord = phi, rowsup = suprow, colnames = cn, colmass = cm, coldist = cchidist, colinertia = cin, colcoord = gam, colsup = supcol, N = N, call = match.call()) class(ca.output) <- "ca" return(ca.output) } ################################################################################ # generic ca() ca <- function(obj, ...){ UseMethod("ca") } # ca.xtabs() ca.xtabs <- function(obj, ...){ if ((m <- length(dim(obj))) > 2L){ stop(gettextf("Frequency table is %d-dimensional", m), domain = NA) } ca.matrix(obj, ...) } # ca.formula() ca.formula <- function (formula, data = parent.frame(), ...){ rhs <- formula[[length(formula)]] if (length(rhs[[2L]]) > 1L || length(rhs[[3L]]) > 1L){ stop("Higher-way table requested. Only 2-way allowed") } tab <- table(eval(rhs[[2L]], data), eval(rhs[[3L]], data)) names(dimnames(tab)) <- as.character(c(rhs[[2L]], rhs[[3L]])) ca.matrix(tab, ...) } # ca.data.frame() ca.data.frame <- function (obj, ...){ ca.matrix(as.matrix(obj), ...) } # ca.table() ca.table <- function (obj, ...){ if ((m <- length(dim(obj))) > 2L){ stop(gettextf("Frequency table is %d-dimensional", m), domain = NA) } class(obj) <- "matrix" ca.matrix(obj, ...) } # ca.default() ca.default <- function (obj, ...){ stop(paste("class", class(obj), "Objects are not valid for ca" )) } ################################################################################ ca/R/pchlist.r0000644000177400001440000000070712643540551013072 0ustar murdochusers################################################################################ # pchlist(): Plotting an overview of available pch values (ca package 0.70) ################################################################################ pchlist <- function(){ plot(rep(1:16, each = 16), rep(1:16, 16), pch = 1:256, axes = FALSE, xlab = "", ylab = "") box() } ################################################################################ ca/R/iterate.mjca.r0000644000177400001440000000346212643540551013773 0ustar murdochusers################################################################################ # iterate.mjca(): Iterative updating of the main diagonal sub-matrices (Burt) ################################################################################ iterate.mjca <- function(B, lev.n, nd = 2, maxit = 50, epsilon = 0.0001) { if (is.na(maxit) & is.na(epsilon)){ maxit <- 50 epsilon <- 0.0001 } coord <- NA lev <- lev.n n <- sum(B) J <- sum(lev) Q <- length(lev) foo0 <- rep(1:Q, lev.n) foo1 <- (foo0) %*% t(rep(1, sum(lev.n))) - t((foo0) %*% t(rep(1, sum(lev.n)))) dummy <- ifelse(foo1 == 0, 1, 0) iterate <- function(obj, dummy, nd, adj = FALSE) { Bp <- obj / n cm <- apply(Bp, 2, sum) eP <- cm %*% t(cm) cm.mat <- diag(cm^(-0.5)) S <- cm.mat %*% (Bp - eP) %*% cm.mat dec <- eigen(S) lam <- dec$values u <- dec$vectors phi <- u[,1:nd] / matrix(rep(sqrt(cm), nd), ncol = nd) if (adj){ lam <- (Q/(Q-1))^2 * (lam[lam >= 1/Q]-1/Q)^2 } for (s in 1:nd) { if (!is.na(coord[1])) { coord <- coord + lam[s] * (phi[,s] %*% t(phi[,s])) } else { coord <- lam[s] * (phi[,s] %*% t(phi[,s])) } } return(obj * (1 - dummy) + n * eP * dummy * (1 + coord)) } # first iteration (adjusted lambda) B.star <- iterate(B, dummy, nd, adj = TRUE) # subsequent iterations k <- 1 it <- TRUE while (it) { temp <- iterate(B.star, dummy, nd) delta.B <- max(abs(B.star - temp)) B.star <- temp if (delta.B <= epsilon | k >= maxit){ it <- FALSE } k <- k + 1 } return(list(B.star, crit = c(k-1, delta.B))) } ################################################################################ ca/R/print.ca.r0000644000177400001440000000334312643540551013141 0ustar murdochusers################################################################################ # print.ca(): Printing ca objects (ca package 0.70) ################################################################################ print.ca <- function(x, ...){ obj <- x nd0 <- length(obj$sv) nd <- obj$nd if (is.na(nd)){ nd <- 2 } else { if (nd > length(obj$sv)) nd <- length(obj$sv) } # Eigenvalues: Dimension <- 1:nd0 Value <- round(obj$sv^2, 6) Percentage <- paste(as.character(round(100 * Value / sum(Value), 2)), "%", sep = "") tmp <- rbind(Value = as.character(Value), Percentage = as.character(Percentage)) dimnames(tmp)[[2]] <- Dimension Eigenvalues <- tmp # Row Profiles: tmp <- rbind(obj$rowmass, obj$rowdist, obj$rowinertia, t(obj$rowcoord[,1:nd])) tmpnames <- obj$rownames if (!is.na(obj$rowsup[1])){ tmpnames[obj$rowsup] <- paste(tmpnames[obj$rowsup],"(*)") } dimnames(tmp)[[2]] <- tmpnames dn <- paste("Dim.", 1:nd) dimnames(tmp)[[1]] <- c("Mass", "ChiDist", "Inertia", dn) Row.profiles <- tmp # Column Profiles: tmp <- rbind(obj$colmass, obj$coldist, obj$colinertia, t(obj$colcoord[,1:nd])) tmpnames <- obj$colnames if (!is.na(obj$colsup[1])){ tmpnames[obj$colsup] <- paste(tmpnames[obj$colsup],"(*)") } dimnames(tmp)[[2]] <- tmpnames dn <- paste("Dim.", 1:nd) dimnames(tmp)[[1]] <- c("Mass", "ChiDist", "Inertia", dn) Column.profiles <- tmp cat("\n Principal inertias (eigenvalues):\n") print.table(Eigenvalues, width = 4) cat("\n\n Rows:\n") print(round(Row.profiles, 6)) cat("\n\n Columns:\n") print(round(Column.profiles, 6)) } ################################################################################ ca/R/plot.mjca.r0000644000177400001440000002526012644542020013306 0ustar murdochusers################################################################################ # plot.mjca(): Plotting mjca objects (ca package 0.70) ################################################################################ plot.mjca <- function(x, dim = c(1,2), map = "symmetric", centroids = FALSE, what = c("none", "all"), mass = c(FALSE, FALSE), contrib = c("none", "none"), col = c("#000000", "#FF0000"), pch = c(16, 1, 17, 24), labels = c(2, 2), collabels = c("both", "level", "factor"), arrows = c(FALSE, FALSE), xlab = "_auto_", ylab = "_auto_", ...){ obj <- x # recycling input: if (length(what) != 2){ what <- rep(what, length = 2) } if (length(mass) != 2){ mass <- rep(mass, length = 2) } if (length(contrib) != 2){ contrib <- rep(contrib, length = 2) } if (length(labels) != 2){ labels <- rep(labels, length = 2) } if (length(pch) != 4){ pch <- rep(pch, length = 4) } col.temp <- length(obj$colnames) if (length(col) < col.temp + 1){ col <- c(col[1], rep(col[-1], length = col.temp)) } col <- col[1:(1 + col.temp)] # check for suprow/-col and 'row-/col.gab/-green' if (!is.numeric(x$suprow)) { if (map == "colgab" | map == "colgreen") { if (what[1] != "none") what[1] <- "active" } } if (!is.numeric(x$supcol)) { if (map == "rowgab" | map == "rowgreen") { if (what[2] != "none") what[2] <- "active" } } # principal coordinates: K <- dim(obj$rowcoord)[2] I <- dim(obj$rowcoord)[1] ; J <- dim(obj$colcoord)[1] evF <- matrix(rep(obj$sv[1:K], I), I, K, byrow = TRUE) evG <- matrix(rep(obj$sv[1:K], J), J, K, byrow = TRUE) rpc <- obj$rowcoord * evF cpc <- obj$colcoord * evG symrpc <- obj$rowcoord * sqrt(evF) symcpc <- obj$colcoord * sqrt(evG) # maptype mt <- c("symmetric", "rowprincipal", "colprincipal", "symbiplot", "rowgab", "colgab", "rowgreen", "colgreen") mti <- 1:length(mt) mtlut <- list(symmetric = list(x = rpc, y = cpc), rowprincipal = list(x = rpc, y = obj$colcoord), colprincipal = list(x = obj$rowcoord, y = cpc), symbiplot = list(x = symrpc, y = symcpc), rowgab = list(x = rpc, y = obj$colcoord * obj$colmass), colgab = list(x = obj$rowcoord * obj$rowmass, y = cpc), rowgreen = list(x = rpc, y = obj$colcoord * sqrt(obj$colmass)), rowgreen = list(x = obj$rowcoord * sqrt(obj$rowmass), y = cpc) ) x <- mtlut[[mti[mt==map]]][[1]] y <- mtlut[[mti[mt==map]]][[2]] x.names <- obj$rownames collabels <- match.arg(collabels) y.names <- switch(collabels, both = obj$levelnames, level = obj$factors[,"level"], factor = obj$factors[,"factor"] ) # y.names <- obj$levelnames # profiles to plot indx <- dim(x)[1] indy <- dim(y)[1] pch.x <- rep(pch[1],dim(x)[1]) pch.y <- rep(pch[3],dim(y)[1]) pr <- c("none", "active", "passive", "all") pri <- 1:4 sup.x <- NA act.x <- x xn.sup <- NA xn.act <- x.names if (is.na(obj$colsup[1])) { sup.y <- NA act.y <- y yn.sup <- NA yn.act <- y.names } else { sup.y <- y[obj$colsup,] act.y <- y[-obj$colsup,] pch.y[obj$colsup] <- pch[4] yn.sup <- y.names[obj$colsup] yn.act <- y.names[-obj$colsup] } prlut <- list(none = list(x = NA, y = NA), active = list(x = act.x, y = act.y), supplementary = list(x = sup.x, y = sup.y), all = list(x = x, y = y)) nameslut <- list(none = list(x.names = NA, y.names = NA), active = list(x.names = xn.act, y.names = yn.act), supplementary = list (x.names = xn.sup, y.names = yn.sup), all = list(x.names = x.names, y.names = y.names) ) pchlut <- list(none = list(x.pch = NA, y.pch = NA), active = list(x.pch = rep(pch[1],dim(x)[1]), y.pch = rep(pch[3],dim(y)[1])), supplementary = list (x.pch = rep(pch[2],dim(x)[1]), y.pch = rep(pch[4],dim(y)[1])), all = list(x.pch = pch.x, y.pch = pch.y) ) x <- prlut[[pri[pr == what[1]]]][[1]] y <- prlut[[pri[pr == what[2]]]][[2]] x.names <- nameslut[[pri[pr == what[1]]]][[1]] y.names <- nameslut[[pri[pr == what[2]]]][[2]] x.pch <- pchlut[[pri[pr == what[1]]]][[1]] y.pch <- pchlut[[pri[pr == what[2]]]][[2]] # dimensions to plot if(is.matrix(x)){ x <- x[,dim] } else { x <- matrix(x[dim], ncol = length(dim), nrow = 1) } if(is.matrix(y)){ y <- y[,dim] } else { y <- matrix(y[dim], ncol = length(dim), nrow = 1) } ## plot setup # radius/mass if (mass[1]){ cex.x <- 0.5 + obj$rowmass^(1/3) / max(obj$rowmass^(1/3)) } else { cex.x <- 0.5 } if (mass[2]){ cex.y <- 0.5 + obj$colmass^(1/3) / max(obj$colmass^(1/3)) } else { cex.y <- 1 } # contributions/colour intensities nc0 <- 50 cst <- 230 col.x <- col[1] col.y <- rep(col[-1], obj$levels.n) if (contrib[1] == "relative") { cind <- obj$rowmass*(rpc[,dim[1]]^2 + rpc[,dim[2]]^2) / obj$rowinertia cb.x <- col2rgb(col[1]) collut.x <- rgb(seq(cst, cb.x[1, 1], length = nc0), seq(cst, cb.x[2, 1], length = nc0), seq(cst, cb.x[3, 1], length = nc0), maxColorValue = 255 ) xtemp <- nc0*(cind) col.x <- collut.x[xtemp] } else { if (contrib[1] == "absolute") { cind <- obj$rowmass*(rpc[,dim[1]]^2 + rpc[,dim[2]]^2) / (obj$sv[dim[1]]^2 + obj$sv[dim[2]]^2) cb.x <- col2rgb(col[1]) p.x <- cb.x[,1] + (cst - cb.x[,1])/indx collut.x1 <- rgb(seq(cst, p.x[1], length = nc0/2), seq(cst, p.x[2], length = nc0/2), seq(cst, p.x[3], length = nc0/2), maxColorValue = 255 ) collut.x2 <- rgb(seq(p.x[1], cb.x[1, 1], length = nc0/2), seq(p.x[2], cb.x[2, 1], length = nc0/2), seq(p.x[3], cb.x[3, 1], length = nc0/2), maxColorValue = 255 ) collut.x <- c(collut.x1, collut.x2) xtemp <- nc0*(cind) col.x <- collut.x[xtemp] } } if (contrib[2] == "relative") { cind <- obj$colmass*(cpc[,dim[1]]^2 + cpc[,dim[2]]^2) / obj$colinertia cb.y <- col2rgb(col[2]) collut.y <- rgb(seq(cst, cb.y[1, 1], length = nc0), seq(cst, cb.y[2, 1], length = nc0), seq(cst, cb.y[3, 1], length = nc0), maxColorValue = 255 ) ytemp <- nc0 * cind col.y <- collut.y[ytemp] } if (contrib[2] == "absolute") { cind <- obj$colmass*(cpc[,dim[1]]^2 + cpc[,dim[2]]^2) / (obj$sv[dim[1]]^2 + obj$sv[dim[2]]^2) cb.y <- col2rgb(col[2]) p.y <- cb.y[,1] + (cst - cb.y[,1])/indy collut.y1 <- rgb(seq(cst, p.y[1], length = nc0/2), seq(cst, p.y[2], length = nc0/2), seq(cst, p.y[3], length = nc0/2), maxColorValue = 255 ) collut.y2 <- rgb(seq(p.y[1], cb.y[1, 1], length = nc0/2), seq(p.y[2], cb.y[2, 1], length = nc0/2), seq(p.y[3], cb.y[3, 1], length = nc0/2), maxColorValue = 255 ) collut.y <- c(collut.y1, collut.y2) ytemp <- nc0 * cind col.y <- collut.y[ytemp] } ## plotting: # determine margins q1 <- (1:dim(x)[1]) q2 <- (1:dim(y)[1]) l1 <- c(x[q1,1], y[q2,1]) ; l1 <- l1[!is.na(l1)] l2 <- c(x[q1,2], y[q2,2]) ; l2 <- l2[!is.na(l2)] if (length(l1) == 0){ l1 <- c(-.1, .1) } if (length(l2) == 0){ l2 <- c(-.1, .1) } lim1 <- range(l1) + c(-.05, .05) * diff(range(l1)) lim2 <- range(l2) + c(-.05, .05) * diff(range(l2)) # axis labels # calculate the axis percent values trying to match the output from summary() values <- obj$sv^2 if (obj$lambda == "JCA"){ pct <- rep(NULL, 2) } else { if (obj$lambda == "adjusted") { values <- obj$inertia.e pct <- round(100 * values, 1) pct <- paste0(" (", pct[dim], "%)") } else { pct <- round(100 * values / sum(values), 1) pct <- paste0(" (", pct[dim], "%)") } } # Check:? do these pct values match the output from summary() if (xlab == "_auto_"){ xlab = paste0("Dimension ", dim[1], pct[1]) } if (ylab == "_auto_"){ ylab = paste0("Dimension ", dim[2], pct[2]) } pty.backup <- par()$pty # plot: # par(pty = "s") # replaces by asp=1 below plot(c(x[,1],y[,1]), c(x[,2],y[,2]), xlab = xlab, ylab = ylab, type = "n", axes = FALSE, asp = 1, ...) box() abline(h = 0, v = 0, lty = 3) axis(1, col = col[1]) axis(2, col = col[1]) # rows if (!is.na(x[1]) & labels[1] != 1) { if (arrows[1]) { .arrows(rep(0, length(x[,1])), rep(0, length(x[,1])), x[,1], x[,2], col = col.x, length = 0.1) } else { points(x[,1], x[,2], cex = cex.x, col = col.x, pch = x.pch) } } if (labels[1] > 0) { xoff1 <- if(labels[1]>1) .5 * strwidth(x.names, cex = .75) + .5 * strwidth("o", cex = .75) else 0 xoff2 <- if(labels[1]>1) .5 * strheight(x.names, cex = .75) + .5 * strheight("o", cex = .75) else 0 text(x[,1] + xoff1, x[,2] + xoff2, x.names, cex = 0.75, xpd = TRUE) } # columns if (!is.na(y[1]) & labels[2] != 1 ) { if (arrows[2]) { .arrows(rep(0, length(y[,1])), rep(0, length(y[,1])), y[,1], y[,2], col = col.y, length = 0.1) } else { points(y[,1], y[,2], cex = cex.y, col = col.y, pch = y.pch) } } if (labels[2] > 0) { yoff1 <- if(labels[2]>1) .5 * strwidth(y.names, cex = 0.75) + .5 * strwidth("o", cex = .75) else 0 yoff2 <- if(labels[2]>1) .5 * strheight(y.names, cex = 0.75) + .5 * strheight("o", cex = .75) else 0 text(y[,1] + yoff1, y[,2] + yoff2, y.names, cex = 0.75, xpd = TRUE) } par(pty = pty.backup) # return a result for further plot annotation rownames(x) <- x.names; colnames(x) <- paste0("Dim", dim) rownames(y) <- y.names; colnames(y) <- paste0("Dim", dim) result <- list(rows = x, cols = y) invisible(result) } ################################################################################ ca/R/expand.dft.R0000644000177400001440000000301512643540551013412 0ustar murdochusers################################################################################ # expand.dft(): Expand data frames/tables ################################################################################ # Author: Marc Schwarz # Ref: http://tolstoy.newcastle.edu.au/R/e6/help/09/01/1873.html # This version copied from the vcdExtra package, Michael Friendly ################################################################################ expand.dft <- function(x, var.names = NULL, freq = "Freq", ...){ # allow: a table object, or a data frame in frequency form if(inherits(x, "table")){ x <- as.data.frame.table(x, responseName = freq) } freq.col <- which(colnames(x) == freq) if (length(freq.col) == 0){ stop(paste(sQuote("freq"), "not found in column names")) } DF <- sapply(1:nrow(x), function(i) x[rep(i, each = x[i, freq.col]), ], simplify = FALSE) DF <- do.call("rbind", DF)[, -freq.col] for (i in 1:ncol(DF)){ DF[[i]] <- type.convert(as.character(DF[[i]]), ...) } rownames(DF) <- NULL if (!is.null(var.names)){ if (length(var.names) < dim(DF)[2]){ stop(paste("Too few", sQuote("var.names"), "given.")) } else if (length(var.names) > dim(DF)[2]){ stop(paste("Too many", sQuote("var.names"), "given.")) } else { names(DF) <- var.names } } return(DF) } # make this a synonym expand.table <- expand.dft ################################################################################ ca/R/multilines.R0000644000177400001440000000106412652470263013550 0ustar murdochusers# plot with multi lines by group multilines <- function(XY, group=NULL, which=1:nf, sort=1, type='l', col=palette(), lwd=1, ...) { if (is.null(group)) group <- rep(1, nrow(XY)) fact <- as.character(group) fact <- fact[!duplicated(fact)] nf <- length(fact) col <- rep(col, out.length=nf) lwd <- rep(lwd, out.length=nf) for (i in which) { xy <- subset(XY, subset=group==fact[i]) if (sort %in% 1:2) { ord <- order(xy[, sort]) xy <- xy[ ord, ] } lines(xy, type=type, col=col[i], lwd=lwd[i], ...) } } ca/R/print.summary.mjca.r0000644000177400001440000001372712654725601015176 0ustar murdochusers################################################################################ # print.summary.mjca(): Printing summarized mjca objects (ca package 0.70) ################################################################################ print.summary.mjca <- function(x, ...){ object <- x if (!is.null(object$scree)){ cat("\n") # init: nchars <- 25 Dim <- object$scree[,1] ev <- object$scree[,2] rev <- object$scree[,3] crev <- object$scree[,4] Value <- ev[Dim] EV <- rev[Dim] CUMEV <- crev[Dim] sev <- object$sev if (length(rev)>1) { st <- round(nchars * rev/sum(rev), 0) } else { st <- nchars } scree <- character(length(Dim)) for (q in Dim) { if (!is.na(st[q])){ s1 <- paste(rep("*", st[q]), collapse = "") s2 <- paste(rep(" ", nchars - st[q]), collapse = "") scree[q] <- paste(" ", s1, s2, sep = "") } else { scree[q] <- " " } } temp0 <- c(" "," ------"," "," "," ") temp1 <- c("Total:", sev, "", "", "") valuesum <- round(object$tin, 6) gluezero <- function(item, dig = 8, point = NA){ item0 <- paste(item, paste(rep(0, dig), collapse=""), sep = "") item1 <- strsplit(item0,"", fixed = TRUE) pastebit <- function(x, digits = dig, poin = point){ if(!is.na(poin)) { x[poin] <- "." } paste(x[1:dig], collapse = "") } unlist(lapply(item1, pastebit)) } remzero <- function(x, doub = FALSE){ x0 <- strsplit(x, "", fixed = TRUE) pastebit2 <- function(x, doubl = doub){ if (doubl){ if (x[1]==0 & x[2]==0){ x[1] <- " " x[2] <- " " } } if (x[1]==0) x[1] <- " " paste(x, collapse = "") } unlist(lapply(x0, pastebit2)) } if (!is.na(EV[1])){ EV.1 <- floor(log(EV, base = 10)) EV.1[EV.1 < 0] <- 0 EV.2 <- as.character(EV.1) EV.2[EV.1 == 1] <- "" EV.2[EV.1 == 0] <- "0" EV <- remzero(gluezero(paste(EV.2, EV, sep = ""), 4, 3)) EV.sp <- paste(rep(" ", ifelse(max(EV.1==2), 0, 1)), collapse = "", sep = "") EV <- paste(EV.sp, EV, sep = "") } # add leading space: if (!is.na(CUMEV[1])){ CUMEV.1 <- floor(log(CUMEV, base = 10)) CUMEV.1[CUMEV.1 < 0] <- 0 CUMEV.2 <- as.character(CUMEV.1) CUMEV.2[CUMEV.1 == 2] <- "" CUMEV.2[CUMEV.1 == 1] <- "0" CUMEV.2[CUMEV.1 == 0] <- "00" CUMEV <- remzero(gluezero(paste(CUMEV.2, CUMEV, sep = ""), 5, 4), doub = TRUE) } scree.out <- data.frame(Dim = c(Dim, "", "Total:"), Value = c(gluezero(as.character(Value)), "--------", gluezero(as.character(valuesum), 8, 2)), EV = c(EV, "-----", ifelse(!is.na(sev), gluezero(sev,5,4), "")), CUMEV = c(CUMEV, "", ""), scree = c(scree, "", "")) colnames(scree.out) <- c("dim", "value", " %", "cum%", " scree plot") if (is.na(object$JCA.nit[1])){ cat("Principal inertias (eigenvalues):\n\n") scree.out <- as.matrix(scree.out) rownames(scree.out) <- rep("", nrow(scree.out)) print(as.matrix(scree.out), quote = FALSE) cat("\n") } else { cat("Principal inertias (eigenvalues):\n\n") scree.out <- as.matrix(scree.out[,1:2]) # dimnames(scree.out)[[1]] <- rep("", length(dimnames(scree.out)[[1]])) rownames(scree.out) <- rep("", nrow(scree.out)) print(as.matrix(scree.out), quote = FALSE) cat(paste("\n Diagonal inertia discounted from eigenvalues: ", round(object$JCA.ind, 7), sep = "")) cat(paste("\n Percentage explained by JCA in ", object$JCA.nd, " dimensions: ", sev, "%", sep = "")) cat("\n (Eigenvalues are not nested)") cat(paste("\n [Iterations in JCA: ", object$JCA.nit, " , epsilon = ", round(object$JCA.eps, 7), "]\n\n", sep = "")) } } # print row/column summary: if (!is.null(object$rows)){ r.out <- object$rows n1 <- dim(r.out)[1] n2 <- dim(r.out)[2] r.names <- dimnames(r.out)[[2]] r.dummy <- rep("|", n1) r.new <- cbind(r.dummy, r.out[,1], r.dummy, r.out[,2:4]) r.nn <- c("", r.names[1], "", r.names[2:4]) for (q in 1:((n2 - 4) / 3)){ r.new <- cbind(r.new, r.dummy, r.out[,(5 + (q - 1) * 3):(5 + q * 3 - 1)]) r.nn <- c(r.nn, "", r.names[(5 + (q - 1) * 3):(5 + q * 3 - 1)]) } r.new <- cbind(r.new, r.dummy) r.nn <- c(r.nn, "") colnames(r.new) <- r.nn rownames(r.new) <- 1:n1 # print rows cat("\nRows:\n") print(as.matrix(r.new), quote = FALSE, right = TRUE) } ### COLUMNS: if (!is.null(object$columns)){ c.out <- object$columns n1 <- dim(c.out)[1] n2 <- dim(c.out)[2] c.names <- dimnames(c.out)[[2]] c.dummy <- rep("|", n1) if (is.na(object$JCA.nit[1])){ c.new <- cbind(c.dummy, c.out[,1], c.dummy, c.out[,2:4]) c.nn <- c("", c.names[1], "", c.names[2:4]) for (q in 1:((n2 - 4) / 3)){ c.new <- cbind(c.new, c.dummy, c.out[,(5 + (q - 1) * 3):(5 + q * 3 - 1)]) c.nn <- c(c.nn, "", c.names[(5 + (q - 1) * 3):(5 + q * 3 - 1)]) } } else { #JCA BELOW: c.new <- cbind(c.dummy, c.out[,1], c.dummy, c.out[,2:3], c.dummy, c.out[,4:(4+object$JCA.nd-1)], c.dummy, c.out[,(n2-1):n2]) c.nn <- c("", c.names[1], "", c.names[2:3], "", c.names[4:(4+object$JCA.nd-1)], "", c.names[(n2-1):n2]) } c.new <- cbind(c.new, c.dummy) c.nn <- c(c.nn, "") colnames(c.new) <- c.nn rownames(c.new) <- 1:n1 ### PRINT COLUMNS: cat("\nColumns:\n") print(as.matrix(c.new), quote = FALSE, right = TRUE) cat("\n") } } ################################################################################ ca/R/print.summary.ca.r0000644000177400001440000001123612643540551014635 0ustar murdochusers################################################################################ # print.summary.ca(): Printing summarized ca objects (ca package 0.70) ################################################################################ print.summary.ca <- function(x, ...){ object <- x r.out <- object$rows c.out <- object$columns if (!is.null(object$scree)){ cat("\n") # init: nchars <- 25 Dim <- object$scree[,1] ev <- object$scree[,2] rev <- object$scree[,3] crev <- object$scree[,4] Value <- ev[Dim] EV <- rev[Dim] CUMEV <- crev[Dim] if (length(rev)>1) { st <- round(nchars * rev/sum(rev), 0) } else { st <- nchars } scree <- character(length(Dim)) for (q in Dim) { s1 <- paste(rep("*", st[q]), collapse = "") s2 <- paste(rep(" ", nchars - st[q]), collapse = "") scree[q] <- paste(" ", s1, s2, sep = "") } temp0 <- c(" "," ------"," "," "," ") temp1 <- c("Total:", sum(EV), "", "", "") Value0 <- round(Value, 6) Value1 <- round(sum(Value), 6) EV1 <- round(EV, 1) EV2 <- round(sum(EV), 1) gluezero <- function(item, dig = 8, point = NA){ item0 <- paste(item, paste(rep(0, dig), collapse=""), sep = "") item1 <- strsplit(item0,"", fixed = TRUE) pastebit <- function(x, digits = dig, poin = point){ if(!is.na(poin)) { x[poin] <- "." } paste(x[1:dig], collapse = "") } unlist(lapply(item1, pastebit)) } remzero <- function(x, doub = FALSE){ x0 <- strsplit(x, "", fixed = TRUE) pastebit2 <- function(x, doubl = doub){ if (doubl){ if (x[1]==0 & x[2]==0){ x[1] <- " " x[2] <- " " } } if (x[1]==0) x[1] <- " " paste(x, collapse = "") } unlist(lapply(x0, pastebit2)) } EV.1 <- floor(log(EV1, base = 10)) EV.1[EV.1 < 0] <- 0 EV.2 <- as.character(EV.1) EV.2[EV.1 == 1] <- "" EV.2[EV.1 == 0] <- "0" EV1 <- remzero(gluezero(paste(EV.2, EV1, sep = ""), 4, 3)) EV.sp <- paste(rep(" ", ifelse(max(EV.1==2), 0, 1)), collapse = "", sep = "") EV1 <- paste(EV.sp, EV1, sep = "") CUMEV1 <- round(CUMEV, 1) CUMEV.1 <- floor(log(CUMEV1, base = 10)) CUMEV.1[CUMEV.1 < 0] <- 0 CUMEV.2 <- as.character(CUMEV.1) CUMEV.2[CUMEV.1 == 2] <- "" CUMEV.2[CUMEV.1 == 1] <- "0" CUMEV.2[CUMEV.1 == 0] <- "00" CUMEV1 <- remzero(gluezero(paste(CUMEV.2, CUMEV1, sep = ""), 5, 4), doub = TRUE) scree.out <- data.frame(Dim = c(Dim, "", "Total:"), Value = c(gluezero(Value0), "--------", gluezero(Value1)), EV = c(EV1, "-----", gluezero(EV2, 5, 4)), CUMEV = c(CUMEV1, "", ""), scree = c(scree, "", "")) colnames(scree.out) <- c("dim", "value", " %", "cum%", " scree plot") cat("Principal inertias (eigenvalues):\n\n") scree.out <- as.matrix(scree.out) rownames(scree.out) <- rep("", nrow(scree.out)) print(scree.out, quote = FALSE) cat("\n") } # print row/column summary: if (!is.null(object$rows)){ n1 <- dim(r.out)[1] n2 <- dim(r.out)[2] r.names <- dimnames(r.out)[[2]] r.dummy <- rep("|", n1) r.new <- cbind(r.dummy, r.out[,1], r.dummy, r.out[,2:4]) r.nn <- c("", r.names[1], "", r.names[2:4]) for (q in 1:((n2 - 4) / 3)){ r.new <- cbind(r.new, r.dummy, r.out[,(5 + (q - 1) * 3):(5 + q * 3 - 1)]) r.nn <- c(r.nn, "", r.names[(5 + (q - 1) * 3):(5 + q * 3 - 1)]) } r.new <- cbind(r.new, r.dummy) r.nn <- c(r.nn, "") colnames(r.new) <- r.nn rownames(r.new) <- 1:n1 cat("\nRows:\n") print(as.matrix(r.new), quote = FALSE, right = TRUE) } if (!is.null(object$columns)){ n1 <- dim(c.out)[1] n2 <- dim(c.out)[2] c.names <- dimnames(c.out)[[2]] c.dummy <- rep("|", n1) c.new <- cbind(c.dummy, c.out[,1], c.dummy, c.out[,2:4]) c.nn <- c("", c.names[1], "", c.names[2:4]) for (q in 1:((n2 - 4) / 3)){ c.new <- cbind(c.new, c.dummy, c.out[,(5 + (q - 1) * 3):(5 + q * 3 - 1)]) c.nn <- c(c.nn, "", c.names[(5 + (q - 1) * 3):(5 + q * 3 - 1)]) } c.new <- cbind(c.new, c.dummy) c.nn <- c(c.nn, "") colnames(c.new) <- c.nn rownames(c.new) <- 1:n1 cat("\nColumns:\n") print(as.matrix(c.new), quote = FALSE, right = TRUE) } } ################################################################################ ca/R/summary.mjca.r0000644000177400001440000001153712646724144014042 0ustar murdochusers################################################################################ # summary.mjca(): Summarizing mjca objects (ca package 0.70) ################################################################################ summary.mjca <- function(object, scree = TRUE, rows = FALSE, columns = TRUE, ...){ obj <- object nd <- obj$nd if (is.na(nd)){ nd <- 2 } else { if (nd > length(obj$sv)){ nd <- length(obj$sv) } } if (obj$lambda != "JCA"){ K <- obj$nd.max } else { K <- obj$nd } I <- length(obj$rownames) J <- dim(obj$colcoord)[1] cpc <- obj$colpcoord # row profiles: if (rows){ rpc <- obj$rowpcoord r.names <- abbreviate(obj$rownames, 3) sr <- obj$rowsup r.mass <- obj$rowmass r.inr <- obj$rowinertia / sum(obj$rowinertia, na.rm = TRUE) r.ccc <- matrix(NA, nrow = length(r.names), ncol = nd * 3) for (i in 1:nd) { r.ccc[,3 * (i - 1) + 1] <- rpc[,i] r.ccc[,3 * (i - 1) + 2] <- obj$rowmass * rpc[,i]^2 / obj$rowinertia r.ccc[,3 * (i - 1) + 3] <- obj$rowmass * rpc[,i]^2 / obj$sv[i] if (obj$lambda == "indicator"){ r.ccc[,3 * (i - 1) + 3] <- obj$rowmass * rpc[,i]^2 / sqrt(obj$sv[i]) } } if (nd > 1) { r.qlt <- apply(r.ccc[,((1:nd-1) * 3 + 2)], 1, sum) } else { r.qlt <- r.ccc[,((1:nd-1) * 3 + 2)] } r1 <- paste(" k=", 1:nd, sep = "") r2 <- rep("cor", nd) r3 <- rep("ctr", nd) rcclab <- as.vector(rbind(r1, r2, r3)) dimnames(r.ccc) <- list(r.names, rcclab) r.out <- data.frame(r.names, round(1000 * r.mass, 0), round(1000 * r.qlt, 0), round(1000 * r.inr, 0), round(1000 * r.ccc, 0)) dimnames(r.out) <- list(as.character(1:length(r.names)), c("name", "mass", " qlt", " inr", rcclab)) } else { r.out <- NULL } ### COLUMNS: if (columns){ c.names <- obj$levelnames sc <- obj$colsup if (!is.na(sc[1])){ c.names[sc] <- paste("(*)", c.names[sc], sep = "") } c.mass <- obj$colmass c.inr <- obj$colinertia / sum(obj$colinertia, na.rm = TRUE) if (obj$lambda != "JCA"){ c.ccc <- matrix(NA, nrow = length(c.names), ncol = nd * 3) for (i in 1:nd){ c.ccc[,3 * (i - 1) + 1] <- cpc[,i] c.ccc[,3 * (i - 1) + 2] <- obj$colcor[,i] c.ccc[,3 * (i - 1) + 3] <- obj$colctr[,i] } if (nd > 1) { c.qlt <- apply(c.ccc[,((1:nd - 1) * 3 + 2)], 1, sum) } else { c.qlt <- c.ccc[,((1:nd - 1) * 3 + 2)] } c1 <- paste(" k=", 1:nd, sep = "") c2 <- rep("cor", nd) c3 <- rep("ctr", nd) ccclab <- as.vector(rbind(c1, c2, c3)) dimnames(c.ccc) <- list(c.names, ccclab) c.out <- data.frame(c.names, round(1000 * c.mass, 0), round(1000 * c.qlt, 0), round(1000 * c.inr, 0), round(1000 * c.ccc, 0)) dimnames(c.out) <- list(as.character(1:length(c.names)), c("name", "mass", " qlt", " inr", ccclab)) } else { #JCA CASE BELOW: c.ccc <- cpc[,1:nd] ccclab <- paste(" k=", 1:nd, sep = "") dimnames(c.ccc) <- list(c.names, ccclab) c.out <- data.frame(c.names, round(1000 * c.mass, 0), round(1000 * c.inr, 0), round(1000 * c.ccc, 0),round(1000 * obj$colcor, 0), round(1000 * obj$colctr, 0) ) dimnames(c.out) <- list(as.character(1:length(c.names)), c("name", "mass", " inr", ccclab, "cor", "ctr")) } } else { c.out <- NULL } # END COLUMNS ### SCREE PLOT: sev.0 <- round(100*obj$inertia.et, 1) if (scree) { values <- obj$sv^2 values2 <- round(100*values/sum(values), 1) scree.out <- cbind(1:length(obj$sv), round(values, 6), values2, round(cumsum(100*values/sum(values)), 1)) if (obj$lambda == "adjusted"){ values <- round(obj$sv^2, 6) values2 <- round(100*obj$inertia.e, 1) values3 <- round(cumsum(100*obj$inertia.e), 1) scree.out <- cbind(1:length(obj$sv), round(values, 6), values2, values3) } if (obj$lambda == "JCA"){ values <- round(obj$sv^2, 6) values2 <- rep(NA, length(values)) values3 <- rep(NA, length(values)) scree.out <- cbind(1:length(obj$sv), round(values, 6), values2, values3) } } else { scree.out <- NULL } ### OUTPUT: out <- list(scree = scree.out, rows = r.out, columns = c.out, sev = sev.0, JCA = obj$JCA.iter, tin = obj$inertia.t, JCA.nd = obj$nd, JCA.ind = sum(diag(obj$subinertia)), JCA.nit = obj$JCA.iter[1], JCA.eps = obj$JCA.iter[2]) class(out) <- "summary.mjca" return(out) } ca/R/print.mjca.r0000644000177400001440000000326212643540551013470 0ustar murdochusers################################################################################ # print.mjca(): Printing mjca objects (ca package 0.70) ################################################################################ print.mjca <- function(x, ...){ obj <- x nd <- obj$nd if (is.na(nd)){ nd <- 2 } else { if (nd > length(obj$sv)) nd <- length(obj$sv) } # Eigenvalues: Dimension <- 1:length(obj$sv) Value <- round(obj$sv^2, 6) Percentage <- paste(as.character(round(100*obj$inertia.e, 2)), "%", sep = "") tmp <- rbind(Value = as.character(Value), Percentage = as.character(Percentage)) dimnames(tmp)[[2]] <- Dimension Eigenvalues <- tmp # Row Profiles: # tmp <- rbind(obj$rowmass, obj$rowdist, obj$rowinertia, t(obj$rowcoord[,1:nd])) # tmpnames <- obj$rownames # if (!is.na(obj$rowsup[1])) # { # tmpnames[obj$rowsup] <- paste(tmpnames[obj$rowsup],"(*)") # } # dimnames(tmp)[[2]] <- tmpnames # dn <- paste("Dim.", 1:nd) # dimnames(tmp)[[1]] <- c("Mass", "ChiDist", "Inertia", dn) # Row.profiles <- tmp # Column Profiles: tmp <- rbind(obj$colmass, obj$coldist, obj$colinertia, t(obj$colcoord[,1:nd])) tmpnames <- obj$levelnames if (!is.na(obj$colsup[1])){ tmpnames[obj$colsup] <- paste(tmpnames[obj$colsup],"(*)",sep="") } dimnames(tmp)[[2]] <- tmpnames dn <- paste("Dim.", 1:nd) dimnames(tmp)[[1]] <- c("Mass", "ChiDist", "Inertia", dn) Column.profiles <- tmp cat("\n Eigenvalues:\n") print.table(Eigenvalues, width = 4) cat("\n\n Columns:\n") print(round(Column.profiles, 6)) } ################################################################################ ca/R/subinr.r0000644000177400001440000000144312643540551012724 0ustar murdochusers################################################################################ # subinr(): Computing inertia of 'sub-matrices' (ca package 0.70) ################################################################################ subinr <- function(B, ind) { nn <- length(ind) subi <- matrix(NA, nrow = nn, ncol = nn) ind2 <- c(0,cumsum(ind)) for (i in 1:nn) { for (j in 1:nn) { tempmat <- B[(ind2[i]+1):(ind2[i+1]), (ind2[j]+1):(ind2[j+1])] tempmat <- tempmat / sum(tempmat) er <- apply(tempmat, 1, sum) ec <- apply(tempmat, 2, sum) ex <- er%*%t(ec) subi[i,j] <- sum((tempmat - ex)^2 / ex) } } return(subi/nn^2) } ################################################################################ ca/MD50000644000177400001440000000421513024225327011341 0ustar murdochusersc52bf1088ef402b80ee90ed72a8855ac *DESCRIPTION f5daa04e0460fe0fd3f9b7c331dbdd68 *INDEX 95dcef42c11559ac8083834c1c4bf6b2 *NAMESPACE 4e4433f36c95ea39a1683679b9144793 *NEWS fe7ee288de1f2528f99762eef37e6bda *R/ca.r 688525218e264cef56102b97f7125d11 *R/caconv.r 42fc5cd52f991ff1f3127713d36469e5 *R/cacoord.r 8be57ed27a190a6788c0181e836427fa *R/expand.dft.R 1b6cfe3804ff56591fd904502638de4f *R/iterate.mjca.r 07bb92973808b61fe78980d892d0d41d *R/mjca.r 0f03ba68ea369483abeb37d13a722780 *R/multilines.R 06b47e49f360a7c0e88b2bf60e4027a0 *R/pchlist.r 5d116296784df1b385eddc6107c8ab08 *R/plot.ca.r f0e5c9fe233917b04a8d64d847378a46 *R/plot.mjca.r 02c88c031d0c0161fa814c29e0cda722 *R/plot3d.ca.r cad666f7fbb684b6fdb1c1d260ec3681 *R/print.ca.r 84966b1a20e580506e19d29b56d5da6a *R/print.mjca.r 4466d6e3b3967a28bda057a4488d49c3 *R/print.summary.ca.r 30d56a0023c9cf71cb2a91a7faefa5aa *R/print.summary.mjca.r 0d53e66ca9374b51d9fce0c2a6417e2a *R/subinr.r ee51ea3af89459cc83449e1abbf545fa *R/summary.ca.r 14071705c58c1e2f76e2074c95db87b3 *R/summary.mjca.r df5e998a266fae6f6cc0c9dee6e7d6e9 *data/author.rda 7450fecaf725210594988ba1f54fb46c *data/smoke.rda 6c66f3fe82316a99d4863774d942b58c *data/wg93.rda 6f3dee332c42d379ade5295bc18ab91c *inst/CITATION 9db527c094d1ca925dbaf2fc0b01d251 *man/author.rd 4c4c2c09ec2166aac6aca1d3db6e62a4 *man/ca.rd c19b6b01e279490abedc88a4dcbef9db *man/caconv.rd e17da10d87f48e5f958050a238ad03f5 *man/cacoord.rd f2b2e5db81d0d3c4173073bca18c5fb5 *man/iterate.mjca.rd 01f7f82dfb3f961f7ba8ff81d378337b *man/mjca.rd d7e847d63fd2ec248249a0a1eb0a6a8d *man/multilines.Rd 29721f4bfd91d0c99f2073f6d9e44c7b *man/pchlist.rd d2024a46392b57b19464bad05f04363a *man/plot.ca.rd f17bd8487aeb58f29b8e70c4bf0cb4a9 *man/plot.mjca.rd eae8495f65fc99d4c57593bbd3d53855 *man/plot3d.ca.rd b06190e177afc42ec27da34c6a2a747a *man/print.ca.rd 99f9063cd946841f0dabfb5144af064e *man/print.mjca.rd 419eaefef599f2704726f61f25c13a75 *man/print.summary.ca.rd 537c1af963be3fb9a5b70f1a706dd341 *man/print.summary.mjca.rd ade149ed6a29d9b5b322b8693cb892c9 *man/smoke.rd 05402987cb6dedc745c2006793f2a98c *man/summary.ca.rd 0c887fe33b71502c78e5630ddea10f9c *man/summary.mjca.rd c9d0ff81bb362997e17385cf356afc89 *man/wg93.rd ca/DESCRIPTION0000644000177400001440000000174713024225327012546 0ustar murdochusersPackage: ca Version: 0.70 Date: 2016-12-11 Title: Simple, Multiple and Joint Correspondence Analysis Authors@R: c(person(given = "Michael", family = "Greenacre", role = "aut", email = "michael.greenacre@upf.edu"), person(given = "Oleg", family = "Nenadic", role = c("aut", "cre"), email = "onenadi@uni-goettingen.de"), person(given = "Michael", family = "Friendly", role = "ctb")) Author: Michael Greenacre [aut], Oleg Nenadic [aut, cre], Michael Friendly [ctb] Maintainer: Oleg Nenadic Depends: R (>= 3.0.0) Suggests: rgl (>= 0.64-10), vcd Description: Computation and visualization of simple, multiple and joint correspondence analysis. LazyLoad: yes LazyData: yes License: GPL URL: http://www.carme-n.org/ Repository: CRAN Repository/R-Forge/Project: ca0 Repository/R-Forge/Revision: 38 Repository/R-Forge/DateTimeStamp: 2016-12-13 19:53:20 Date/Publication: 2016-12-14 12:19:51 NeedsCompilation: no Packaged: 2016-12-13 20:05:25 UTC; rforge ca/man/0000755000177400001440000000000013024052132011572 5ustar murdochusersca/man/mjca.rd0000644000177400001440000001534312654725601013061 0ustar murdochusers\name{mjca} \alias{mjca} \alias{mjca.data.frame} \alias{mjca.table} \alias{mjca.array} \alias{mjca.default} \title{Multiple and joint correspondence analysis} \description{Computation of multiple and joint correspondence analysis.} \usage{ mjca(obj, ...) \method{mjca}{data.frame}(obj, ...) \method{mjca}{table}(obj, ...) \method{mjca}{array}(obj, ...) \method{mjca}{default}(obj, nd = 2, lambda = c("adjusted", "indicator", "Burt", "JCA"), supcol = NA, subsetcat = NA, ps = ":", maxit = 50, epsilon = 0.0001, reti = FALSE, ...) } \arguments{ \item{obj }{A response pattern matrix (data frame containing factors), or a frequency table (a \dQuote{table} object) or an integer array.} \item{nd }{Number of dimensions to be included in the output; if NA the maximum possible dimensions are included.} \item{lambda }{Gives the scaling method. Possible values include \kbd{"indicator"}, \kbd{"Burt"}, \kbd{"adjusted"} and \kbd{"JCA"}. Using \kbd{lambda = "JCA"} results in a joint correspondence analysis using iterative adjusment of the Burt matrix in the solution space. See Details for descriptions of these options.} \item{supcol }{Indices of supplementary columns.} \item{subsetcat}{Indices of subset categories (previously \kbd{subsetcol}).} \item{ps }{Separator used for combining variable and category names.} \item{maxit }{The maximum number of iterations (Joint Correspondence Analysis).} \item{epsilon }{A convergence criterion (Joint Correspondence Analysis).} \item{reti }{Logical indicating whether the indicator matrix should be included in the output.} \item{... }{Arguments passed to \code{mjca.default}} } \details{ The function \code{mjca} computes a multiple or joint correspondence analysis based on the eigenvalue decomposition of the Burt matrix. The \code{lambda} option selects the scaling variant desired for reporting inertias. \itemize{ \item \code{lambda="indicator"} gives multiple correspondence analysis based on the correspondence analysis of the indicator matrix, with corresponding inertias (eigenvalues). \item \code{lambda="Burt"} gives the version of multiple correspondence analysis based on the correspondence analysis of the Burt matrix, the inertias of which are the squares of those for the indicator option. \item \code{lambda="adjusted"} is the default option, giving improved percentages of inertia based on fitting the off-diagonal submatrices of the Burt matrix by rescaling the multiple correspondence analysis solution. All these first three options give the same standard coordinates of the categories. \item \code{lambda="JCA"} gives a joint correspondence analysis, which uses an iterative algorithm that optimally fits the off-diagonal submatrices of the Burt matrix. The JCA solution does not have strictly nested dimensions, so the percentage of inertia explained is given for the whole solution of chosen dimensionality, not for each dimension, but this percentage is optimal. } } \value{ \item{sv }{Eigenvalues (\kbd{lambda = "indicator"}) or singular values (\kbd{lambda = "Burt"}, \kbd{"adjusted"} or \kbd{"JCA"}) } \item{lambda }{Scaling method} \item{inertia.e }{Percentages of explained inertia} \item{inertia.t }{Total inertia} \item{inertia.et }{Total percentage of explained inertia with the \code{nd}-dimensional solution} \item{levelnames }{Names of the factor/level combinations, joined using \code{ps}} \item{factors }{A matrix containing the names of the factors and the names of the factor levels} \item{levels.n }{Number of levels in each factor} \item{nd }{User-specified dimensionality of the solution} \item{nd.max }{Maximum possible dimensionality of the solution} \item{rownames }{Row names} \item{rowmass }{Row masses} \item{rowdist }{Row chi-square distances to centroid} \item{rowinertia }{Row inertias} \item{rowcoord }{Row standard coordinates} \item{rowpcoord }{Row principal coordinates} \item{rowctr }{Row contributions} \item{rowcor }{Row squared correlations} \item{colnames }{Column names} \item{colmass }{Column masses} \item{coldist }{Column chi-square distances to centroid} \item{colinertia }{Column inertias} \item{colcoord }{Column standard coordinates} \item{colpcoord }{Column principal coordinates} \item{colctr }{column contributions} \item{colcor }{Column squared correlations} \item{colsup }{Indices of column supplementary points (of the Burt and Indicator matrix)} \item{subsetcol }{Indices of subset columns (\kbd{subsetcat})} \item{Burt }{Burt matrix} \item{Burt.upd }{The updated Burt matrix (JCA only)} \item{subinertia }{Inertias of sub-matrices} \item{JCA.iter }{Vector of length two containing the number of iterations and the epsilon (JCA only)} \item{indmat }{Indicator matrix if \code{reti} was set to \code{TRUE}} \item{call }{Return of \code{match.call}} } \references{Nenadic, O. and Greenacre, M. (2007), Correspondence analysis in R, with two- and three-dimensional graphics: The ca package. \emph{Journal of Statistical Software}, \bold{20 (3)}, \url{http://www.jstatsoft.org/v20/i03/}\cr Nenadic, O. and Greenacre, M. (2007), Computation of Multiple Correspondence Analysis, with Code in R, in \emph{Multiple Correspondence Analysis and Related Methods} (eds. M. Greenacre and J. Blasius), Boca Raton: Chapmann & Hall / CRC, pp. 523-551.\cr Greenacre, M.J. and Pardo, R. (2006), Subset correspondence analysis: visualizing relationships among a selected set of response categories from a questionnaire survey. \emph{Sociological Methods and Research}, \bold{35}, pp. 193-218.} \seealso{\code{\link{eigen}}, \code{\link{plot.mjca}}, \code{\link{summary.mjca}}, \code{\link{print.mjca}} } \examples{ data("wg93") mjca(wg93[,1:4]) # table input data(UCBAdmissions) mjca(UCBAdmissions) \dontrun{plot(mjca(UCBAdmissions))} ### Different approaches to multiple correspondence analysis: # Multiple correspondence analysis based on the indicator matrix: \dontrun{mjca(wg93[,1:4], lambda = "indicator")} # Multiple correspondence analysis based on the Burt matrix: \dontrun{mjca(wg93[,1:4], lambda = "Burt")} # "Adjusted" multiple correspondence analysis (default setting): \dontrun{mjca(wg93[,1:4], lambda = "adjusted")} # Joint correspondence analysis: \dontrun{mjca(wg93[,1:4], lambda = "JCA")} ### Subset analysis and supplementary variables: # Subset analysis: \dontrun{mjca(wg93[,1:4], subsetcat = (1:20)[-seq(3,18,5)])} # Supplementary variables: \dontrun{mjca(wg93, supcol = 5:7)} } \keyword{multivariate} ca/man/summary.mjca.rd0000644000177400001440000000376612426435545014565 0ustar murdochusers\name{summary.mjca} \alias{summary.mjca} \title{Summarizing multiple and joint correspondence analysis} \description{Textual output summarizing the results of \code{\link{mjca}}, including a scree-plot of the principal inertias and row and column contributions.} \usage{\method{summary}{mjca}(object, scree = TRUE, rows = FALSE, columns = TRUE, ...)} \arguments{ \item{object}{Multiple or joint correspondence analysis object returned by \code{\link{mjca}}.} \item{scree}{Logical flag specifying if a scree-plot should be included in the output.} \item{rows}{Logical specifying whether the results for the rows should be included in the output (default = \kbd{FALSE}). } \item{columns}{Logical specifying whether the results for the columns should be included in the output (default = \kbd{TRUE}). } \item{...}{Further arguments (ignored)} } \details{ The function \code{summary.mjca} gives the detailed numerical results of the \code{\link{mjca}} function. All the eigenvalues (principal inertias) are listed, their percentages with respect to total inertia, and a bar chart (also known as a scree plot). Then for the set of rows and columns a table of results is given in a standard format, where quantities are either multiplied by 1000 or expressed in permills (thousandths): the mass of each point (x1000), the quality of display in the solution subspace of \code{nd} dimensions, the inertia of the point (in permills of the total inertia), and then for each dimension of the solution the principal coordinate (x1000), the (relative) contribution COR of the principal axis to the point inertia (x1000) and the (absolute) contribution CTR of the point to the inertia of the axis (in permills of the principal inertia). \cr For supplementary points, masses, inertias and absolute contributions (CTR) are not applicable, but the relative contributions (COR) are valid as well as their sum over the set of chosen \code{nd} dimensions (QLT). } \examples{ data("wg93") summary(mjca(wg93[,1:4])) } ca/man/wg93.rd0000644000177400001440000000102412306757343012731 0ustar murdochusers\name{wg93} \docType{data} \alias{wg93} \title{International Social Survey Program on Environment 1993 - western German sample} \description{This data frame contains records of four questions on attitude towards science with responses on a five-point scale (1=agree strongly to 5=disagree strongly) and three demographic variables (sex, age and education).} \usage{data(wg93)} \format{Data frame (871x7).} \source{ISSP (1993). International Social Survey Program: Environment. \url{http://www.issp.org}} \keyword{datasets} ca/man/pchlist.rd0000644000177400001440000000066212306757343013615 0ustar murdochusers\name{pchlist} \alias{pchlist} \title{Listing the set of available symbols.} \description{A plot of the available symbols for use with the option \code{pch}.} \usage{pchlist() } \details{ This function generates a numbered list of the plotting symbols available for use in the functions \code{\link{plot.ca}} and \code{\link{plot3d.ca}}. } \seealso{\code{\link{plot.ca}}, \code{\link{plot3d.ca}}} \examples{ pchlist() } ca/man/print.summary.mjca.rd0000644000177400001440000000075012306757343015706 0ustar murdochusers\name{print.summary.mjca} \alias{print.summary.mjca} \title{Printing summeries of mjca objects} \description{Printing method for summaries of multiple and joint correspondence analysis objects} \usage{\method{print}{summary.mjca}(x, ...) } \arguments{ \item{x}{summary of a multiple or joint correspondence analysis object returned by \code{\link{summary.mjca}}} \item{...}{Further arguments are ignored} } \seealso{\code{\link{mjca}}, \code{\link{summary.mjca}}} ca/man/summary.ca.rd0000644000177400001440000000352712426435545014231 0ustar murdochusers\name{summary.ca} \alias{summary.ca} \title{Summarizing simple correspondence analysis} \description{Printed output summarizing the results of \code{\link{ca}}, including a scree-plot of the principal inertias and row and column contributions.} \usage{\method{summary}{ca}(object, scree = TRUE, rows=TRUE, columns=TRUE, ...)} \arguments{ \item{object}{Simple correspondence analysis object returned by \code{\link{ca}}.} \item{scree}{Logical flag specifying if a scree-plot should be included in the output.} \item{rows}{Logical: should row contribution summaries be included?} \item{columns}{Logical: should column contribution summaries be included?} \item{...}{Further arguments (ignored)} } \details{ The function \code{summary.ca} gives the detailed numerical results of the \code{\link{ca}} function. All the eigenvalues (principal inertias) are listed, their percentages with respect to total inertia, and a bar chart (also known as a scree plot). Then for the set of rows and columns a table of results is given in a standard format, where quantities are either multiplied by 1000 or expressed in permills (thousandths): the mass of each point (x1000), the quality of display in the solution subspace of \code{nd} dimensions, the inertia of the point (in permills of the total inertia), and then for each dimension of the solution the principal coordinate (x1000), the (relative) contribution COR of the principal axis to the point inertia (x1000) and the (absolute) contribution CTR of the point to the inertia of the axis (in permills of the principal inertia). \cr For supplementary points, masses, inertias and absolute contributions (CTR) are not applicable, but the relative contributions (COR) are valid as well as their sum over the set of chosen \code{nd} dimensions (QLT). } \examples{ data("smoke") summary(ca(smoke)) } ca/man/multilines.Rd0000644000177400001440000000523312652470263014270 0ustar murdochusers\name{multilines} \alias{multilines} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Draw lines for groups distinguished by a factor } \description{ This is a convenience function for drawing a set of lines distinguished by the levels of a factor. It can be used to make more attractive plots than available via \code{\link{plot.mjca}}. } \usage{ multilines(XY, group=NULL, which=1:nf, sort=1, type='l', col=palette(), lwd=1, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{XY}{ A two-column data frame or matrix } \item{group}{ A factor; a separate line is drawn for each level included in \code{which} } \item{which}{ An integer vector used to select the factors for which lines are drawn. By default, all lines are drawn. } \item{sort}{ Column of \code{XY} to sort upon before drawing the line for each group } \item{type}{ Line type: \code{"l"} for line, \code{"b"} for line and points } \item{col}{ A vector of colors to be used for the various lines, in the order of the levels in \code{group}; recycled as necessary. } \item{lwd}{ A vector of line widths to be used for the various lines; recycled as necessary } \item{\dots}{ Other graphic parameters passed to \code{\link[graphics]{lines}}, e.g., \code{lty} } } %\details{ %%% ~~ If necessary, more details than the description above ~~ %} \value{ none %% ~Describe the value returned %% If it is a LIST, use %% \item{comp1 }{Description of 'comp1'} %% \item{comp2 }{Description of 'comp2'} %% ... } %\references{ %%% ~put references to the literature/web site here ~ %} \author{ Michael Friendly } %\note{ %% ~~further notes~~ %} %% ~Make other sections like Warning with \section{Warning }{....} ~ \seealso{ \code{\link[graphics]{lines}} } \examples{ if (require(vcd)) { data(PreSex, package="vcd") presex.mca <- mjca(PreSex) res <- plot(presex.mca, labels=0, pch='.', cex.lab=1.2) coords <- data.frame(res$cols, presex.mca$factors) nlev <- rle(as.character(coords$factor))$lengths fact <- unique(as.character(coords$factor)) cols <- c("blue", "red", "brown", "black") lwd <- c(2, 2, 2, 4) plot(Dim2 ~ Dim1, type='n', data=coords) points(coords[,1:2], pch=rep(16:19, nlev), col=rep(cols, nlev), cex=1.2) text(coords[,1:2], labels=coords$level, col=rep(cols, nlev), pos=3, cex=1.2, xpd=TRUE) multilines(coords[, c("Dim1", "Dim2")], group=coords$factor, col=cols, lwd=lwd) } } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{aplot} %\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line ca/man/ca.rd0000644000177400001440000000721212643757663012541 0ustar murdochusers\name{ca} \alias{ca} \alias{ca.matrix} \alias{ca.data.frame} \alias{ca.formula} \alias{ca.table} \alias{ca.xtabs} \alias{ca.default} \title{Simple correspondence analysis} \description{Computation of simple correspondence analysis.} \usage{ ca(obj, ...) \method{ca}{matrix}(obj, nd = NA, suprow = NA, supcol = NA, subsetrow = NA, subsetcol = NA, ...) \method{ca}{data.frame}(obj, ...) \method{ca}{table}(obj, ...) \method{ca}{xtabs}(obj, ...) \method{ca}{formula}(formula, data, ...) } \arguments{ \item{obj,formula}{The function is generic, accepting various forms of the principal argument for specifying a two-way frequency table. Currently accepted forms are matrices, data frames (coerced to frequency tables), objects of class \code{"xtabs"} or \code{"table"} and one-sided formulae of the form \code{~ F1 + F2}, where \code{F1} and \code{F2} are factors. } \item{nd }{Number of dimensions to be included in the output; if NA the maximum possible dimensions are included.} \item{suprow }{Indices of supplementary rows.} \item{supcol }{Indices of supplementary columns.} \item{subsetrow}{Row indices of subset.} \item{subsetcol}{Column indices of subset.} \item{data }{A data frame against which to preferentially resolve variables in the \code{formula}} \item{... }{Other arguments passed to the \code{ca.matrix} method} } \details{The function \code{ca} computes a simple correspondence analysis based on the singular value decomposition.\cr The options \code{suprow} and \code{supcol} allow supplementary (passive) rows and columns to be specified. Using the options \code{subsetrow} and/or \code{subsetcol} result in a subset CA being performed.} \value{ \item{sv }{Singular values} \item{nd }{Dimenson of the solution} \item{rownames }{Row names} \item{rowmass }{Row masses} \item{rowdist }{Row chi-square distances to centroid} \item{rowinertia}{Row inertias} \item{rowcoord }{Row standard coordinates} \item{rowsup }{Indices of row supplementary points} \item{colnames }{Column names} \item{colmass }{Column masses} \item{coldist }{Column chi-square distances to centroid} \item{colinertia}{Column inertias} \item{colcoord }{Column standard coordinates} \item{colsup }{Indices of column supplementary points} \item{N }{The frequency table} } \references{ Nenadic, O. and Greenacre, M. (2007). Correspondence analysis in R, with two- and three-dimensional graphics: The ca package. \emph{Journal of Statistical Software}, \bold{20 (3)}, \url{http://www.jstatsoft.org/v20/i03/} Greenacre, M. (2007). \emph{Correspondence Analysis in Practice}. Second Edition. London: Chapman & Hall / CRC. Blasius, J. and Greenacre, M. J. (1994), Computation of correspondence analysis, in \emph{Correspondence Analysis in the Social Sciences}, pp. 53-75, London: Academic Press. Greenacre, M.J. and Pardo, R. (2006), Subset correspondence analysis: visualizing relationships among a selected set of response categories from a questionnaire survey. \emph{Sociological Methods and Research}, \bold{35}, pp. 193-218. } \seealso{\code{\link{svd}}, \code{\link{plot.ca}}, \code{\link{plot3d.ca}}, \code{\link{summary.ca}}, \code{\link{print.ca}} } \examples{ data("author") ca(author) plot(ca(author)) # table method haireye <- margin.table(HairEyeColor, 1:2) haireye.ca <- ca(haireye) haireye.ca plot(haireye.ca) # some plot options plot(haireye.ca, lines=TRUE) plot(haireye.ca, arrows=c(TRUE, FALSE)) } \keyword{multivariate} ca/man/cacoord.rd0000644000177400001440000000440212654725601013553 0ustar murdochusers\name{cacoord} \alias{cacoord} \title{Extracting coordinates from ca and mjca objects.} \description{Extracting standard and principal coordinates as well as various row and column scaling configurations for visual display from \kbd{ca} and \kbd{mjca} objects.} \usage{cacoord(obj, type = c("standard", "principal", "symmetric", "rowprincipal", "colprincipal", "symbiplot", "rowgab", "colgab", "rowgreen", "colgreen"), dim = NA, rows = NA, cols = NA, ...)} \arguments{ \item{obj }{A \kbd{ca} or \kbd{mjca} object returned by \code{\link{ca}} or \code{\link{mjca}}.} \item{type}{The type of coordinates to extract (\kbd{"standard"} or \kbd{"principal"}). The remaining options (\kbd{"symmetric"}, ..., \kbd{"colgreen"}) return the corresponding row/column coordinate configuration for the map scaling options described in \code{\link{plot.ca}} where the corresponding argument is \kbd{map}.} \item{dim }{The dimensions to return. If \kbd{NA}, all available dimensions are returned.} \item{rows}{Logical indicating whether to return the row coordinates (see below for details).} \item{cols}{Logical indicating whether to return the column coordinates (see below for details).} \item{... }{Further arguments (ignored).} } \details{The function \code{cacoord} returns the standard or principal coordinates of a CA or MCA solution. Additionally, row and column scaling configurations for plotting methods can be computed (see \code{\link{plot.ca}} for details).\cr Note that by default row and column coordinates are computed (i.e. for \kbd{(rows=NA&cols=NA)|(rows=TRUE&cols=TRUE)}). Using \kbd{rows=TRUE} (and \kbd{cols=NA} or \kbd{cols=FALSE}) returns a matrix with the row coordinates, and for \kbd{cols=TRUE} (and \kbd{cols=NA} or \kbd{cols=FALSE}) a matrix with the column coordinates is returned.} \value{A list with the slots \kbd{rows} (row coordinates) and \kbd{columns} (column coordinates). When computing only row or only column coordinates, a matrix (with the corresponding row or column coordinates) is returned.} \seealso{\code{\link{ca}},\code{\link{mjca}},\code{\link{plot.ca}},\code{\link{plot.mjca}}} \keyword{multivariate} ca/man/plot.mjca.rd0000644000177400001440000001651612644542020014030 0ustar murdochusers\name{plot.mjca} \alias{plot.mjca} \title{Plotting 2D maps in multiple and joint correspondence analysis} \description{Graphical display of multiple and joint correspondence analysis results in two dimensions} \usage{\method{plot}{mjca}(x, dim = c(1,2), map = "symmetric", centroids = FALSE, what = c("none", "all"), mass = c(FALSE, FALSE), contrib = c("none", "none"), col = c("#000000", "#FF0000"), pch = c(16, 1, 17, 24), labels = c(2, 2), collabels = c("both", "level", "factor"), arrows = c(FALSE, FALSE), xlab = "_auto_", ylab = "_auto_", ...) } \arguments{ \item{x}{Multiple or joint correspondence analysis object returned by \code{\link{mjca}}} \item{dim}{Numerical vector of length 2 indicating the dimensions to plot on horizontal and vertical axes respectively; default is first dimension horizontal and second dimension vertical.} \item{map}{Character string specifying the map type. Allowed options include \cr \kbd{"symmetric"} (default) \cr \kbd{"rowprincipal"} \cr \kbd{"colprincipal"} \cr \kbd{"symbiplot"} \cr \kbd{"rowgab"} \cr \kbd{"colgab"} \cr \kbd{"rowgreen"} \cr \kbd{"colgreen"} } \item{centroids}{Logical indicating if column centroids should be added to the plot} \item{what}{Vector of two character strings specifying the contents of the plot. First entry sets the rows and the second entry the columns. Allowed values are \cr \kbd{"all"} (all available points, default) \cr \kbd{"active"} (only active points are displayed) \cr \kbd{"passive"} (only supplementary points are displayed) \cr \kbd{"none"} (no points are displayed) \cr The status (active or supplementary) of columns is set in \code{\link{mjca}} using the option \code{supcol}.} \item{mass}{Vector of two logicals specifying if the mass should be represented by the area of the point symbols (first entry for rows, second one for columns)} \item{contrib}{Vector of two character strings specifying if contributions (relative or absolute) should be represented by different colour intensities. Available options are\cr \kbd{"none"} (contributions are not indicated in the plot).\cr \kbd{"absolute"} (absolute contributions are indicated by colour intensities).\cr \kbd{"relative"} (relative contributions are indicated by colour intensities).\cr If set to \kbd{"absolute"} or \kbd{"relative"}, points with zero contribution are displayed in white. The higher the contribution of a point, the closer the corresponding colour to the one specified by the \code{col} option. } \item{col}{Vector of length 2 specifying the colours of row and column point symbols, by default black for rows and red for columns. Colours can be entered in hexadecimal (e.g. \kbd{"#FF0000"}), rgb (e.g. \kbd{rgb(1,0,0)}) values or by R-name (e.g. \kbd{"red"}). } \item{pch}{Vector of length 4 giving the type of points to be used for row active and supplementary, column active and supplementary points. See \code{\link{pchlist}} for a list of symbols. } \item{labels}{Vector of length two specifying if the plot should contain symbols only (\kbd{0}), labels only (\kbd{1}) or both symbols and labels (\kbd{2}). Setting \code{labels} to \kbd{2} results in the symbols being plotted at the coordinates and the labels with an offset. } \item{collabels}{Determines the format used for column labels, when the columns are labeled in the plot. \cr \code{"both"} uses the factor names and level value, in the form \code{"factor:level"}\cr \code{"level"} uses the factor level value only\cr \code{"factor"} uses the factor name only } \item{arrows}{Vector of two logicals specifying if the plot should contain points (\kbd{FALSE}, default) or arrows (\kbd{TRUE}). First value sets the rows and the second value sets the columns.} \item{xlab, ylab}{Labels for horizontal and vertical axes. The default, \code{"_auto_"} means that the function auto-generates a label of the form \code{Dimension X (xx.xx \%)}} \item{...}{Further arguments passed to \code{\link{plot}} and \code{\link{points}}.} } \details{ The function \code{plot.mjca} makes a two-dimensional map of the object created by \code{mjca} with respect to two selected dimensions. By default the scaling option of the map is \kbd{"symmetric"}, that is the so-called \emph{symmetric map}. In this map both the row and column points are scaled to have inertias (weighted variances) equal to the principal inertia (eigenvalue) along the principal axes, that is both rows and columns are in pricipal coordinates. Other options are as follows: \itemize{ \item{-}{\kbd{"rowprincipal"} or \kbd{"colprincipal"} - these are the so-called \emph{asymmetric maps}, with either rows in principal coordinates and columns in standard coordinates, or vice versa (also known as row-metric-preserving or column-metric-preserving respectively). These maps are biplots;} } \itemize{ \item{-}{\kbd{"symbiplot"} - this scales both rows and columns to have variances equal to the singular values (square roots of eigenvalues), which gives a symmetric biplot but does not preserve row or column metrics;} } \itemize{ \item{-}{\kbd{"rowgab"} or \kbd{"colgab"} - these are asymmetric maps (see above) with rows (respectively, columns) in principal coordinates and columns (respectively, rows) in standard coordinates multiplied by the mass of the corresponding point. These are also biplots and were proposed by Gabriel & Odoroff (1990);} } \itemize{ \item{-}{\kbd{"rowgreen"} or \kbd{"colgreen"} - these are similar to \kbd{"rowgab"} and \kbd{"colgab"} except that the points in standard coordinates are multiplied by the square root of the corresponding masses, giving reconstructions of the standardized residuals.} } This function has options for sizing and shading the points. If the option \code{mass} is \kbd{TRUE} for a set of points, the size of the point symbol is proportional to the relative frequency (mass) of each point. If the option \code{contrib} is \kbd{"absolute"} or \kbd{"relative"} for a set of points, the colour intensity of the point symbol is proportional to the absolute contribution of the points to the planar display or, respectively, the quality of representation of the points in the display. To globally resize all the points (and text labels), use \code{par("cex"=)} before the plot. } \value{ In addition to the side effect of producing the plot, the function invisibly returns the coordinates of the plotted points, a list of two components, with names \code{rows} and \code{cols}. These can be used to further annotate the plot using base R plotting functions. } \references{ Gabriel, K.R. and Odoroff, C. (1990). Biplots in biomedical research. \emph{Statistics in Medicine}, \bold{9}, pp. 469-485. \cr Greenacre, M.J. (1993) \emph{Correspondence Analysis in Practice}. London: Academic Press. \cr Greenacre, M.J. (1993) Biplots in correspondence Analysis, \emph{Journal of Applied Statistics}, \bold{20}, pp. 251 - 269. } \seealso{\code{\link{mjca}}, \code{\link{summary.mjca}}, \code{\link{print.mjca}}, \code{\link{pchlist}}} \examples{ data("wg93") # A two-dimensional map with standard settings plot(mjca(wg93[,1:4])) } ca/man/print.mjca.rd0000644000177400001440000000227712306757343014220 0ustar murdochusers\name{print.mjca} \alias{print.mjca} \title{Printing mjca objects} \description{Printing method for multiple and joint correspondence analysis objects} \usage{\method{print}{mjca}(x, ...) } \arguments{ \item{x}{Multiple or joint correspondence analysis object returned by \code{\link{mjca}}} \item{...}{Further arguments are ignored} } \details{ The function \code{print.mjca} gives the basic statistics of the \code{mjca} object. First the eigenvalues (that is, principal inertias) and their percentages with respect to total inertia are printed. Then for the rows and columns respectively, the following are printed: the masses, chi-square distances of the points to the centroid (i.e., centroid of the active points), point inertias (for active points only) and principal coordinates on the first \code{nd} dimensions requested (default = 2 dimensions). The function \code{\link{summary.mjca}} gives more detailed results about the inertia contributions of each point on each principal axis.\cr For supplementary points, masses and inertias are not applicable. } \seealso{\code{\link{mjca}}} \examples{ data("wg93") print(mjca(wg93[,1:4])) # equivalent to: mjca(wg93[,1:4]) } ca/man/iterate.mjca.rd0000644000177400001440000000227512306757343014517 0ustar murdochusers\name{iterate.mjca} \alias{iterate.mjca} \title{Updating a Burt matrix in Joint Correspondence Analysis} \description{Updating a Burt matrix in Joint Correspondence Analysis based on iteratively weighted least squares.} \usage{iterate.mjca(B, lev.n, nd = 2, maxit = 50, epsilon = 0.0001)} \arguments{ \item{B }{A Burt matrix.} \item{lev.n }{The number of levels for each factor from the original response pattern matrix.} \item{nd }{The required dimensionality of the solution.} \item{maxit }{The maximum number of iterations.} \item{epsilon}{A convergence criterion for the maximum absolute difference of updated values compared to the previous values. The iteration is completed when all differences are smaller than \code{epsilon}.} } \details{The function \code{iterate.mjca} computes the updated Burt matrix. This function is called from the function \code{\link{mjca}} when the option \kbd{lambda="JCA"}, i.e. when a Joint Correspondence Analysis is performed.} \value{ \item{B.star}{The updated Burt matrix} \item{crit }{Vector of length 2 containing the number of iterations and epsilon} } \seealso{\code{\link{mjca}}} \keyword{multivariate} ca/man/plot3d.ca.rd0000644000177400001440000000702112643540551013725 0ustar murdochusers\name{plot3d.ca} \alias{plot3d.ca} \title{Plotting 3D maps in correspondence analysis} \description{Graphical display of correspondence analysis in three dimensions} \usage{\method{plot3d}{ca}(x, dim = c(1, 2, 3), map = "symmetric", what = c("all", "all"), contrib = c("none", "none"), col = c("#6666FF","#FF6666"), labcol = c("#0000FF", "#FF0000"), pch = c(16, 1, 18, 9), labels = c(2, 2), sf = 0.00001, arrows = c(FALSE, FALSE), axiscol = "#333333", axislcol = "#333333", laboffset = list(x = 0, y = 0.075, z = 0.05), ...) } \arguments{ \item{x}{Simple correspondence analysis object returned by ca} \item{dim}{Numerical vector of length 2 indicating the dimensions to plot} \item{map}{Character string specifying the map type. Allowed options include \cr \kbd{"symmetric"} (default) \cr \kbd{"rowprincipal"} \cr \kbd{"colprincipal"} \cr \kbd{"symbiplot"} \cr \kbd{"rowgab"} \cr \kbd{"colgab"} \cr \kbd{"rowgreen"} \cr \kbd{"colgreen"} } \item{what}{Vector of two character strings specifying the contents of the plot. First entry sets the rows and the second entry the columns. Allowed values are \cr \kbd{"none"} (no points are displayed) \cr \kbd{"active"} (only active points are displayed, default) \cr \kbd{"supplementary"} (only supplementary points are displayed) \cr \kbd{"all"} (all available points) \cr The status (active or supplementary) is set in \code{\link{ca}}.} \item{contrib}{Vector of two character strings specifying if contributions (relative or absolute) should be indicated by different colour intensities. Available options are\cr \kbd{"none"} (contributions are not indicated in the plot).\cr \kbd{"absolute"} (absolute contributions are indicated by colour intensities).\cr \kbd{"relative"} (relative conrributions are indicated by colour intensities).\cr If set to \kbd{"absolute"} or \kbd{"relative"}, points with zero contribution are displayed in white. The higher the contribution of a point, the closer the corresponding colour to the one specified by the \code{col} option.} \item{col}{Vector of length 2 specifying the colours of row and column profiles. Colours can be entered in hexadecimal (e.g. \kbd{"\#FF0000"}), rgb (e.g. \kbd{rgb(1,0,0)}) values or by R-name (e.g. \kbd{"red"}). } \item{labcol}{Vector of length 2 specifying the colours of row and column labels. } \item{pch}{Vector of length 2 giving the type of points to be used for rows and columns.} \item{labels}{Vector of length two specifying if the plot should contain symbols only (\kbd{0}), labels only (\kbd{1}) or both symbols and labels (\kbd{2}). Setting \code{labels} to \kbd{2} results in the symbols being plotted at the coordinates and the labels with an offset.} \item{sf}{A scaling factor for the volume of the 3d primitives.} \item{arrows}{Vector of two logicals specifying if the plot should contain points (FALSE, default) or arrows (TRUE). First value sets the rows and the second value sets the columns.} \item{axiscol}{Colour of the axis line.} \item{axislcol}{Colour of the axis labels.} \item{laboffset}{List with 3 slots specifying the label offset in x, y, and z direction.} \item{...}{Further arguments passed to the rgl functions.} } \seealso{\code{\link{ca}}} ca/man/author.rd0000644000177400001440000000074212306757343013450 0ustar murdochusers\name{author} \docType{data} \alias{author} \title{Author dataset} \description{This data matrix contains the counts of the 26 letters of the alphabet (columns of matrix) for 12 different novels (rows of matrix). Each row contains letter counts in a sample of text from each work, excluding proper nouns.} \usage{data("author")} \format{Data frame containing the 12 x 26 matrix.} \source{Larsen, W.A. and McGill, R., unpublished data collected in 1973.} \keyword{datasets} ca/man/smoke.rd0000644000177400001440000000071612306757343013265 0ustar murdochusers\name{smoke} \docType{data} \alias{smoke} \title{Smoke dataset} \description{Artificial dataset in Greenacre (1984)} \usage{data(smoke)} \format{Table containing 5 rows (staff group) and 4 columns (smoking categories), giving the frequencies of smoking categories in each staff group in a fictional organization.} \references{Greenacre, M.J. (1984). \emph{Theory and Applications of Correspondence Analysis}. London: Academic Press.} \keyword{datasets} ca/man/print.ca.rd0000644000177400001440000000214712306757343013665 0ustar murdochusers\name{print.ca} \alias{print.ca} \title{Printing ca objects} \description{Printing method for correspondence analysis objects} \usage{\method{print}{ca}(x, ...) } \arguments{ \item{x}{Simple correspondence analysis object returned by \code{\link{ca}}} \item{...}{Further arguments are ignored} } \details{ The function \code{print.ca} gives the basic statistics of the \code{ca} object. First the eigenvalues (that is, principal inertias) and their percentages with respect to total inertia are printed. Then for the rows and columns respectively, the following are printed: the masses, chi-square distances of the points to the centroid (i.e., centroid of the active points), point inertias (for active points only) and principal coordinates on the first \code{nd} dimensions requested (default = 2 dimensions). The function \code{\link{summary.ca}} gives more detailed results about the inertia contributions of each point on each principal axis.\cr For supplementary points, masses and inertias are not applicable. } \seealso{\code{\link{ca}}} \examples{ data("smoke") print(ca(smoke)) } ca/man/caconv.rd0000644000177400001440000000303512646724144013415 0ustar murdochusers\name{caconv} \alias{caconv} \title{Converting data types in CA and MCA} \description{Conversion from and to a number of different data types commonly used in CA and MCA (frequency tables, response pattern matrices, indicator matrices and Burt matrices).} \usage{caconv(x, from = c("freq", "rpm", "ind", "Burt"), to = c("rpm", "ind", "Burt", "freq"), nlev = NA, vars = c(1,2), ...)} \arguments{ \item{x }{A matrix (two-way frequency table, indicator matrix, or Burt matrix) or data frame (response pattern matrix).} \item{from}{The type of input data in \kbd{x}: a frequency table (\kbd{"freq"}), or a response pattern matrix (\kbd{"rpm"}), or an indicator matrix (\kbd{"ind"}), or a Burt matrix (\kbd{"Burt"}).} \item{to }{The data type into which \kbd{x} should be converted.} \item{nlev}{A vector containing the number of levels for each categorical variable (for \kbd{from="ind"} or \kbd{from="Burt"}). If \kbd{NA}, \kbd{nlev} is computed from the data.} \item{vars}{A vector of length 2 specifying the index of the variables to use for converting to \kbd{"freq"} (i.e. to a regular two-way frequency table).} \item{... }{Further arguments (ignored).} } \details{The function \code{caconv} converts between data types in CA and MCA. Note that a conversion from \kbd{from="Burt"} to \kbd{to="ind"} or \kbd{to="rpm"} is not supported.} \value{A matrix or data frame containing the converted data (with the type specified in \kbd{to}).} \seealso{\code{\link{ca}},\code{\link{mjca}}} \keyword{multivariate} ca/man/print.summary.ca.rd0000644000177400001440000000067412306757343015364 0ustar murdochusers\name{print.summary.ca} \alias{print.summary.ca} \title{Printing summeries of ca objects} \description{Printing method for summaries of correspondence analysis objects} \usage{\method{print}{summary.ca}(x, ...) } \arguments{ \item{x}{Summary of a simple correspondence analysis object returned by \code{\link{summary.ca}}} \item{...}{Further arguments are ignored} } \seealso{\code{\link{ca}}, \code{\link{summary.ca}}} ca/man/plot.ca.rd0000644000177400001440000001754312643763451013516 0ustar murdochusers\name{plot.ca} \alias{plot.ca} \title{Plotting 2D maps in correspondence analysis} \description{Graphical display of correspondence analysis results in two dimensions} \usage{\method{plot}{ca}(x, dim = c(1,2), map = "symmetric", what = c("all", "all"), mass = c(FALSE, FALSE), contrib = c("none", "none"), col = c("blue", "red"), pch = c(16, 21, 17, 24), labels = c(2, 2), arrows = c(FALSE, FALSE), lines = c(FALSE, FALSE), lwd=1, xlab = "_auto_", ylab = "_auto_", col.lab = c("blue", "red"), ...) } \arguments{ \item{x}{Simple correspondence analysis object returned by \code{\link{ca}}} \item{dim}{Numerical vector of length 2 indicating the dimensions to plot on horizontal and vertical axes respectively; default is first dimension horizontal and second dimension vertical.} \item{map}{Character string specifying the map type. Allowed options include \cr \kbd{"symmetric"} (default) \cr \kbd{"rowprincipal"} \cr \kbd{"colprincipal"} \cr \kbd{"symbiplot"} \cr \kbd{"rowgab"} \cr \kbd{"colgab"} \cr \kbd{"rowgreen"} \cr \kbd{"colgreen"} } \item{what}{Vector of two character strings specifying the contents of the plot. First entry sets the rows and the second entry the columns. Allowed values are \cr \kbd{"all"} (all available points, default) \cr \kbd{"active"} (only active points are displayed) \cr \kbd{"passive"} (only supplementary points are displayed) \cr \kbd{"none"} (no points are displayed) \cr The status (active or supplementary) of rows and columns is set in \code{\link{ca}} using the options \code{suprow} and \code{supcol}.} \item{mass}{Vector of two logicals specifying if the mass should be represented by the area of the point symbols (first entry for rows, second one for columns)} \item{contrib}{Vector of two character strings specifying if contributions (relative or absolute) should be represented by different colour intensities. Available options are\cr \kbd{"none"} (contributions are not indicated in the plot).\cr \kbd{"absolute"} (absolute contributions are indicated by colour intensities).\cr \kbd{"relative"} (relative contributions are indicated by colour intensities).\cr If set to \kbd{"absolute"} or \kbd{"relative"}, points with zero contribution are displayed in white. The higher the contribution of a point, the closer the corresponding colour to the one specified by the \code{col} option.} \item{col}{Vector of length 2 specifying the colours of row and column point symbols, by default blue for rows and red for columns. Colours can be entered in hexadecimal (e.g. \kbd{"\#FF0000"}), rgb (e.g. \kbd{rgb(1,0,0)}) values or by R-name (e.g. \kbd{"red"}). } \item{pch}{Vector of length 4 giving the type of points to be used for row active and supplementary, column active and supplementary points. See \code{\link{pchlist}} for a list of symbols.} \item{labels}{Vector of length two specifying if the plot should contain symbols only (\kbd{0}), labels only (\kbd{1}) or both symbols and labels (\kbd{2}). Setting \code{labels} to \kbd{2} results in the symbols being plotted at the coordinates and the labels with an offset.} \item{arrows}{Vector of two logicals specifying if the plot should contain points (\kbd{FALSE}, default) or arrows (\kbd{TRUE}). First value sets the rows and the second value sets the columns.} \item{lines}{Vector of two logicals specifying if the plot should join the points with lines (\kbd{FALSE}, default) or arrows (\kbd{TRUE}). First value sets the rows and the second value sets the columns.} \item{lwd}{Line width for \code{arrows} and \code{lines}} \item{xlab, ylab}{Labels for horizontal and vertical axes. The default, \code{"_auto_"} means that the function auto-generates a label of the form \code{Dimension X (xx.xx \%}} \item{col.lab}{Vector of length 2 specifying the colours of row and column point labels} \item{...}{Further arguments passed to \code{\link{plot}} and \code{\link{points}}.} } \details{ The function \code{plot.ca} makes a two-dimensional map of the object created by \code{ca} with respect to two selected dimensions. By default the scaling option of the map is \kbd{"symmetric"}, that is the so-called \emph{symmetric map}. In this map both the row and column points are scaled to have inertias (weighted variances) equal to the principal inertia (eigenvalue or squared singular value) along the principal axes, that is both rows and columns are in pricipal coordinates. Other options are as follows: \itemize{ \item{-}{\kbd{"rowprincipal"} or \kbd{"colprincipal"} - these are the so-called \emph{asymmetric maps}, with either rows in principal coordinates and columns in standard coordinates, or vice versa (also known as row-metric-preserving or column-metric-preserving respectively). These maps are biplots;} } \itemize{ \item{-}{\kbd{"symbiplot"} - this scales both rows and columns to have variances equal to the singular values (square roots of eigenvalues), which gives a symmetric biplot but does not preserve row or column metrics;} } \itemize{ \item{-}{\kbd{"rowgab"} or \kbd{"colgab"} - these are asymmetric maps (see above) with rows (respectively, columns) in principal coordinates and columns (respectively, rows) in standard coordinates multiplied by the mass of the corresponding point. These are also biplots and were proposed by Gabriel & Odoroff (1990);} } \itemize{ \item{-}{\kbd{"rowgreen"} or \kbd{"colgreen"} - these are similar to \kbd{"rowgab"} and \kbd{"colgab"} except that the points in standard coordinates are multiplied by the square root of the corresponding masses, giving reconstructions of the standardized residuals.} } This function has options for sizing and shading the points. If the option \code{mass} is \kbd{TRUE} for a set of points, the size of the point symbol is proportional to the relative frequency (mass) of each point. If the option \code{contrib} is \kbd{"absolute"} or \kbd{"relative"} for a set of points, the colour intensity of the point symbol is proportional to the absolute contribution of the points to the planar display or, respectively, the quality of representation of the points in the display. To globally resize all the points (and text labels), use \code{par("cex"=)} before the plot. } \value{ In addition to the side effect of producing the plot, the function invisibly returns the coordinates of the plotted points, a list of two components, with names \code{rows} and \code{cols}. These can be used to further annotate the plot using base R plotting functions. } \references{ Gabriel, K.R. and Odoroff, C. (1990). Biplots in biomedical research. \emph{Statistics in Medicine}, \bold{9}, pp. 469-485. \cr Greenacre, M.J. (1993) \emph{Correspondence Analysis in Practice}. London: Academic Press. \cr Greenacre, M.J. (1993) Biplots in correspondence Analysis, \emph{Journal of Applied Statistics}, \bold{20}, pp. 251 - 269. } \seealso{\code{\link{ca}}, \code{\link{summary.ca}}, \code{\link{print.ca}}, \code{\link{plot3d.ca}}, \code{\link{pchlist}}} \examples{ data("smoke") # A two-dimensional map with standard settings plot(ca(smoke)) # Mass for rows and columns represented by the size of the point symbols plot(ca(smoke), mass = c(TRUE, TRUE)) # Displaying the column profiles only with masses represented by size of point # symbols and relative contributions by colour intensity. # Since the arguments are recycled it is sufficient to give only one argument # for mass and contrib. data("author") plot(ca(author), what = c("none", "all"), mass = TRUE, contrib = "relative") } ca/INDEX0000644000177400001440000000216012306757343011632 0ustar murdochusersauthor Author dataset ca Simple correspondence analysis iterate.mjca Updating a Burt matrix in Joint Correspondence Analysis mjca Multiple and joint correspondence analysis pchlist Listing the set of available symbols. plot.ca Plotting 2D maps in correspondence analysis plot.mjca Plotting 2D maps in multiple and joint correspondence analysis plot3d.ca Plotting 3D maps in correspondence analysis print.ca Printing ca objects print.mjca Printing mjca objects print.summary.ca Printing summeries of ca objects print.summary.mjca Printing summeries of mjca objects smoke Smoke dataset summary.ca Summarizing simple correspondence analysis summary.mjca Summarizing multiple and joint correspondence analysis wg93 International Social Survey Program on Environment 1993 - western German sample