R/mvr.R

   1 ## mvr.R (2012-03-30)
   2
   3 ##   Minimum Variance Reduction
   4
   5 ## Copyright 2011 Andrei-Alin Popescu
   6
   7 ## This file is part of the R-package `ape'.
   8 ## See the file ../COPYING for licensing issues.
   9
  10 mvr <- function(X, V)
  11 {
  12     if (is.matrix(X)) X <- as.dist(X)
  13     if (is.matrix(V)) V <- as.dist(V)
  14     if (any(is.na(X)))
  15         stop("missing values are not allowed in the distance matrix")
  16     if (any(is.na(V)))
  17         stop("missing values are not allowed in the variance matrix")
  18     N <- attr(X, "Size")
  19     labels <- attr(X, "Labels")
  20     if (is.null(labels)) labels <- as.character(1:N)
  21     ans <- .C("mvr", as.double(X), as.double(V), as.integer(N),
  22               integer(2*N - 3), integer(2*N - 3), double(2*N - 3),
  23               DUP = FALSE, NAOK = TRUE, PACKAGE = "ape")
  24     obj <- list(edge = cbind(ans[[4]], ans[[5]]), edge.length = ans[[6]],
  25                 tip.label = labels, Nnode = N - 2L)
  26     class(obj) <- "phylo"
  27     reorder(obj)
  28 }
  29
  30 mvrs <- function(X, V, fs = 15)
  31 {
  32     if (fs < 1)
  33         stop("argument 'fs' must be a non-zero positive integer")
  34
  35     if (is.matrix(X)) X <- as.dist(X)
  36     if (is.matrix(V)) V <- as.dist(V)
  37
  38     X[is.na(X)] <- -1
  39     X[X < 0] <- -1
  40     X[is.nan(X)] <- -1
  41
  42     N <- attr(X, "Size")
  43     labels <- attr(X, "Labels")
  44     if (is.null(labels)) labels <- as.character(1:N)
  45     ans <- .C("mvrs", as.double(X), as.double(V), as.integer(N),
  46               integer(2*N - 3), integer(2*N - 3), double(2*N - 3),
  47               as.integer(fs), DUP = FALSE, NAOK = TRUE, PACKAGE = "ape")
  48     obj <- list(edge = cbind(ans[[4]], ans[[5]]), edge.length = ans[[6]],
  49                 tip.label = labels, Nnode = N - 2L)
  50     class(obj) <- "phylo"
  51     reorder(obj)
  52 }