X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=R%2FPGLS.R;h=df3e6b1d2601d984a3809ecacea3ac948423af42;hb=3f8df9b013dc4ed297c9b242cd833698ce7d015a;hp=8c5ab74032e3ad75e5b44d008270834c7e5023d6;hpb=9531f5a42f8783c6da5092de9e5481265da0a528;p=ape.git

diff --git a/R/PGLS.R b/R/PGLS.R
index 8c5ab74..df3e6b1 100644
--- a/R/PGLS.R
+++ b/R/PGLS.R
@@ -1,4 +1,4 @@
-## PGLS.R (2008-04-18)
+## PGLS.R (2008-05-08)
 
 ##   Phylogenetic Generalized Least Squares
 
@@ -236,3 +236,43 @@ coef.corPagel <- function(object, unconstrained = TRUE, ...)
     names(aux) <- "lambda"
     aux
 }
+
+corBlomberg <- function(value, phy, form = ~1, fixed = FALSE)
+{
+    if (value <= 0)
+        stop("the value of g must be greater than 0.")
+    if (!("phylo" %in% class(phy)))
+        stop('object "phy" is not of class "phylo"')
+    attr(value, "formula") <- form
+    attr(value, "fixed") <- fixed
+    attr(value, "tree") <- phy
+    class(value) <- c("corBlomberg", "corPhyl", "corStruct")
+    value
+}
+
+corMatrix.corBlomberg <-
+    function(object, covariate = getCovariate(object), corr = TRUE, ...)
+{
+    index <- attr(object, "index")
+    if (is.null(index))
+        stop("object has not been initialized")
+    if (object[1] <= 0)
+        stop("the optimization has reached a value <= 0 for parameter 'g':
+probably need to set 'fixed = TRUE' in corBlomberg().")
+    phy <- attr(object, "tree")
+    d <- (dist.nodes(phy)[length(phy$tip.label) + 1, ])^(1/object[1])
+    phy$edge.length <- d[phy$edge[, 2]] - d[phy$edge[, 1]]
+    mat <- vcv.phylo(phy, cor = corr)
+    mat[index, index]
+}
+
+coef.corBlomberg <- function(object, unconstrained = TRUE, ...)
+{
+    if (unconstrained) {
+        if (attr(object, "fixed")) return(numeric(0))
+        else return(object[1])
+    }
+    aux <- object[1]
+    names(aux) <- "g"
+    aux
+}