ca/0000755000176000001440000000000013612512751010670 5ustar ripleyusersca/NAMESPACE0000644000176000001440000000124613357431376012123 0ustar ripleyusersimport(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) if(getRversion() >= "3.6.0") { S3method(rgl::plot3d, ca) }ca/data/0000755000176000001440000000000013357433461011607 5ustar ripleyusersca/data/author.rda0000644000176000001440000000203613357433461013602 0ustar ripleyusersmoU'IAa5UQAU-v*)1iz<3L=8=iꌓTגe,Ye,d1NM$;{y\峍a / xf7g1^)e+M0*֧z~ASk砡*.;ћf75{uTzUVDxڇαJ z  ~-1EO_C'C⿏1˟%w?:~@~ %Hc6O L=_ge}#W7Uǻ35wg÷d}:"SM~2!ط{q ~3m~NvD>O+gE|#{I"&dkLRWG>;wKJuʤo? Gy K<{Ľ9.~< {;T!`_PW'|[Fu+2 q\wu'wjPog5C//j},ؚߋomΚ-wFE{w!4}?4OZJs딏_, nl킔ŸA ܾFoW s$byÊ}Ll(c%-#+B[E/B(@M"bR"Dp{G ca/data/wg93.rda0000644000176000001440000001211513357433461013070 0ustar ripleyusersnƑ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 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/ NeedsCompilation: no Packaged: 2020-01-23 13:25:58 UTC; ripley Repository: CRAN Date/Publication: 2020-01-24 06:59:53 UTC ca/NEWS0000644000176000001440000001015013357431376011375 0ustar ripleyusersVersion 0.71 (2018-10-10) o S3 method issue with plot3d.ca fixed Version 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/R/0000755000176000001440000000000013612317330011065 5ustar ripleyusersca/R/plot.mjca.r0000644000176000001440000002526012644542020013144 0ustar ripleyusers################################################################################ # 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/subinr.r0000644000176000001440000000144312643540551012562 0ustar ripleyusers################################################################################ # 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/R/print.ca.r0000644000176000001440000000334513612317330012773 0ustar ripleyusers################################################################################ # 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/cacoord.r0000644000176000001440000001246312652430027012672 0ustar ripleyusers################################################################################ # 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/print.summary.ca.r0000644000176000001440000001123612643540551014473 0ustar ripleyusers################################################################################ # 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.r0000644000176000001440000001153712646724144013700 0ustar ripleyusers################################################################################ # 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/expand.dft.R0000644000176000001440000000301512643540551013250 0ustar ripleyusers################################################################################ # 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/ca.r0000644000176000001440000002231013024050660011626 0ustar ripleyusers################################################################################ # 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/multilines.R0000644000176000001440000000106412652470263013406 0ustar ripleyusers# 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/pchlist.r0000644000176000001440000000070712643540551012730 0ustar ripleyusers################################################################################ # 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/print.summary.mjca.r0000644000176000001440000001372712654725601015034 0ustar ripleyusers################################################################################ # 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/plot.ca.r0000644000176000001440000002560512643763451012634 0ustar ripleyusers################################################################################ # plot.ca(): Plotting ca objects (ca package 0.70) ################################################################################ plot.ca <- function(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"), ...){ 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(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) } if (length(lines) != 2){ lines <- rep(lines, length = 2) } if (length(col.lab) != 2){ col.lab <- rep(col.lab, length = 2) } # 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" } } # sign switching: if (min(dim) < 0){ swisign <- ifelse(dim < 0, -1, 1) dim.c <- dim(obj$rowcoord)[2] signmat <- diag(rep(swisign, length = dim.c)) obj$rowcoord <- obj$rowcoord%*%signmat obj$colcoord <- obj$colcoord%*%signmat dim <- abs(dim) } # 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)), 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 y.names <- obj$colnames # 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 if (mass[1]){ cex.x <- 0.5 + obj$rowmass^(1/3) / max(obj$rowmass^(1/3)) } else { cex.x <- 1 } 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 <- col[2] 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 pct <- round(100* (obj$sv^2) / sum(obj$sv^2), 1) pct <- paste0(" (", pct[dim], "%)") 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: 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) axis(2) # 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, lwd=lwd, 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, 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/mjca.r0000644000176000001440000007211013024050660012160 0ustar ripleyusers################################################################################ # 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.r0000644000176000001440000001050613024050660013326 0ustar ripleyusers################################################################################ # 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/iterate.mjca.r0000644000176000001440000000346212643540551013631 0ustar ripleyusers################################################################################ # 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/plot3d.ca.r0000644000176000001440000003102212643540551013043 0ustar ripleyusers################################################################################ # 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/print.mjca.r0000644000176000001440000000326513612317276013334 0ustar ripleyusers################################################################################ # 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/caconv.r0000644000176000001440000001522212646724144012536 0ustar ripleyusers################################################################################ # 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/MD50000644000176000001440000000421513612512751011202 0ustar ripleyusers83a8ca165e01349089826b6f5cd0ec82 *DESCRIPTION f5daa04e0460fe0fd3f9b7c331dbdd68 *INDEX aec1da716bcdd1dd3aeae14f62510783 *NAMESPACE 93e00716f883e2f7aa893feae3814f12 *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 c058a0d2d6dec9a3d216a01eb85b9a89 *R/print.ca.r 5fdf5731913dbd41d984de3fd2d1587a *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 2c26952e02f3349c933580a7c9ad73a3 *data/author.rda 346e33082c91d398451a8374159ee770 *data/smoke.rda efc3a4413d6925d9edfea36df891adc0 *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/INDEX0000644000176000001440000000216012306757343011470 0ustar ripleyusersauthor 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 ca/inst/0000755000176000001440000000000013357433231011646 5ustar ripleyusersca/inst/CITATION0000644000176000001440000000127612306757343013017 0ustar ripleyuserscitHeader("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. " )