R/dist.gene.R

   1 ## dist.gene.R (2012-04-02)
   2
   3 ##   Pairwise Distances from Genetic Data
   4
   5 ## Copyright 2002-2012 Emmanuel Paradis
   6
   7 ## This file is part of the R-package `ape'.
   8 ## See the file ../COPYING for licensing issues.
   9
  10 dist.gene <-
  11     function(x, method = "pairwise", pairwise.deletion = FALSE,
  12              variance = FALSE)
  13 {
  14     if (is.data.frame(x)) x <- as.matrix(x) else { # suggestion by Markus Schlegel
  15         if (!is.matrix(x))
  16             stop("'x' should be a matrix or a data.frame")
  17     }
  18     method <- match.arg(method, c("pairwise", "percentage"))
  19
  20     if (!pairwise.deletion) {
  21         ## delete the columns with at least one NA:
  22         del <- apply(x, 2, function(xx) any(is.na(xx)))
  23         x <- x[, !del]
  24     }
  25     n <- dim(x)
  26     L <- n[2]
  27     n <- n[1]
  28     D <- double(n * (n - 1)/2)
  29     if (pairwise.deletion) L <- D
  30     k <- 1L
  31     for (i in 1:(n - 1)) {
  32         for (j in (i + 1):n) {
  33             y <- x[i, ] != x[j, ]
  34             if (pairwise.deletion) L[k] <- sum(!is.na(y))
  35             D[k] <-  sum(y, na.rm = TRUE)
  36             k <- k + 1L
  37         }
  38     }
  39     ## L is either a single integer value if pairwise.deletion = FALSE,
  40     ## or a vector of integers if pairwise.deletion = TRUE
  41
  42     if (method == "percentage") D <- D/L
  43
  44     attr(D, "Size") <- n
  45     attr(D, "Labels") <-  dimnames(x)[[1]]
  46     attr(D, "Diag") <- attr(D, "Upper") <- FALSE
  47     attr(D, "call") <- match.call()
  48     attr(D, "method") <- method
  49     class(D) <- "dist"
  50
  51     if (variance) {
  52         y <- if (method == "pairwise") L else 1
  53         attr(D, "variance") <- D * (y - D)/L
  54     }
  55     D
  56 }