R/wca.R

In ade4: Analysis of Ecological Data: Exploratory and Euclidean Methods in Environmental Sciences

wca <- function (x, ...) UseMethod("wca")

"wca.dudi" <- function (x, fac, scannf = TRUE, nf = 2, ...) {
  if (!inherits(x, "dudi")) 
    stop("Object of class dudi expected")
  if (!is.factor(fac)) 
    stop("factor expected")
  lig <- nrow(x$tab)
  if (length(fac) != lig) 
    stop("Non convenient dimension")
  cla.w <- tapply(x$lw, fac, sum)
  mean.w <- function(x, w, fac, cla.w) {
    z <- x * w
    z <- tapply(z, fac, sum)/cla.w
    return(z)
  }
  tabmoy <- apply(x$tab, 2, mean.w, w = x$lw, fac = fac, 
                  cla.w = cla.w)
  tabw <- unlist(tapply(x$lw, fac, sum))
  tabw <- tabw/sum(tabw)
  tabwit <- x$tab - tabmoy[fac, ]
  res <- as.dudi(tabwit, x$cw, x$lw, scannf = scannf, nf = nf, 
                 call = match.call(), type = "wit")
  res$ratio <- sum(res$eig)/sum(x$eig)
  U <- as.matrix(res$c1) * unlist(res$cw)
  U <- data.frame(as.matrix(x$tab) %*% U)
  row.names(U) <- row.names(x$tab)
  names(U) <- names(res$li)
  res$ls <- U
  U <- as.matrix(res$c1) * unlist(res$cw)
  U <- data.frame(t(as.matrix(x$c1)) %*% U)
  row.names(U) <- names(x$li)
  names(U) <- names(res$li)
  res$as <- U
  res$tabw <- tabw
  res$fac <- fac
  class(res) <- c("within", "dudi")
  return(res)
}

"plot.within" <- function (x, xax = 1, yax = 2, ...) {
  if (!inherits(x, "within")) 
    stop("Use only with 'within' objects")
  if ((x$nf == 1) || (xax == yax)) {
    return(invisible())
  }
  if (xax > x$nf) 
    stop("Non convenient xax")
  if (yax > x$nf) 
    stop("Non convenient yax")
  fac <- x$fac
  def.par <- par(no.readonly = TRUE)
  on.exit(par(def.par))
  layout(matrix(c(1, 2, 3, 4, 4, 5, 4, 4, 6), 3, 3), 
         respect = TRUE)
  par(mar = c(0.2, 0.2, 0.2, 0.2))
  s.arrow(x$c1, xax = xax, yax = yax, sub = "Canonical weights", 
          csub = 2, clabel = 1.25)
  s.arrow(x$co, xax = xax, yax = yax, sub = "Variables", 
          csub = 2, clabel = 1.25)
  scatterutil.eigen(x$eig, wsel = c(xax, yax))
  s.class(x$ls, fac, wt = x$lw, xax = xax, yax = yax, sub = "Scores and classes", 
          csub = 2, clabel = 1.5, cpoint = 2)
  s.corcircle(x$as, xax = xax, yax = yax, sub = "Inertia axes", 
              csub = 2, cgrid = 0, clabel = 1.25)
  s.class(x$li, fac, wt = x$lw, xax = xax, yax = yax, axesell = FALSE, 
          clabel = 0, cstar = 0, sub = "Common centring", csub = 2)
}

"print.within" <- function (x, ...) {
  if (!inherits(x, "within")) 
    stop("to be used with 'within' object")
  cat("Within analysis\n")
  cat("call: ")
  print(x$call)
  cat("class: ")
  cat(class(x), "\n")
  cat("\n$nf (axis saved) :", x$nf)
  cat("\n$rank: ", x$rank)
  cat("\n$ratio: ", x$ratio)
  cat("\n\neigen values: ")
  l0 <- length(x$eig)
  cat(signif(x$eig, 4)[1:(min(5, l0))])
  if (l0 > 5) 
    cat(" ...\n\n")
  else cat("\n\n")
  sumry <- array("", c(5, 4), list(1:5, c("vector", "length", "mode", "content")))
  sumry[1, ] <- c("$eig", length(x$eig), mode(x$eig), "eigen values")
  sumry[2, ] <- c("$lw", length(x$lw), mode(x$lw), "row weigths")
  sumry[3, ] <- c("$cw", length(x$cw), mode(x$cw), "col weigths")
  sumry[4, ] <- c("$tabw", length(x$tabw), mode(x$tabw), "class weigths")
  sumry[5, ] <- c("$fac", length(x$fac), mode(x$fac), "factor for grouping")
  
  print(sumry, quote = FALSE)
  cat("\n")
  sumry <- array("", c(7, 4), list(1:7, c("data.frame", "nrow", "ncol", "content")))
  sumry[1, ] <- c("$tab", nrow(x$tab), ncol(x$tab), "array class-variables")
  sumry[2, ] <- c("$li", nrow(x$li), ncol(x$li), "row coordinates")
  sumry[3, ] <- c("$l1", nrow(x$l1), ncol(x$l1), "row normed scores")
  sumry[4, ] <- c("$co", nrow(x$co), ncol(x$co), "column coordinates")
  sumry[5, ] <- c("$c1", nrow(x$c1), ncol(x$c1), "column normed scores")
  sumry[6, ] <- c("$ls", nrow(x$ls), ncol(x$ls), "supplementary row coordinates")
  sumry[7, ] <- c("$as", nrow(x$as), ncol(x$as), "inertia axis onto within axis")
  
  print(sumry, quote = FALSE)
  cat("\n")
}

summary.within <- function(object, ...) {
  thetitle <- "Within-class analysis"
  cat(thetitle)
  cat("\n\n")
  NextMethod()
  appel <- as.list(object$call)
  dudi <- eval.parent(appel$x)
  cat(paste("Total unconstrained inertia (", deparse(appel$x), 
            "): ", sep = ""))
  cat(signif(sum(dudi$eig), 4))
  cat("\n\n")
  cat(paste("Inertia of", deparse(appel$x), "independent of", 
            deparse(appel$fac), "(%): "))
  cat(signif(object$ratio * 100, 4))
  cat("\n\n")
}