# SCM Repository

[matrix] View of /pkg/R/pedigree.R
 [matrix] / pkg / R / pedigree.R

# View of /pkg/R/pedigree.R

Sat Jul 22 17:59:53 2006 UTC (13 years, 8 months ago) by maechler
File size: 1763 byte(s)
`many method cleanups; notably some "dgC" -> "Csparse" generaliztations`
```#### "pedigree" class methods

## Simple constructor; main point are the 'as.*' -> prettier calls
pedigree <- function(sire, dam, label) {
n <- length(sire)
stopifnot(n == length(dam), n == length(label))
sire <- as.integer(sire); dam <- as.integer(dam)
sire[sire < 1 | sire > n] <- NA
dam[dam < 1 | dam > n] <- NA
new("pedigree", sire = sire, dam = dam,
label = as.character(label))
}

setAs("pedigree", "dtCMatrix", # representation as T^{-1}
function(from) {
sire <- from@sire
n <- length(sire)
animal <- seq(along = sire)
j <- c(sire, from@dam)
ind <- !is.na(j)
as(new("dtTMatrix", i = rep.int(animal, 2)[ind] - 1:1,
j = j[ind] - 1:1, x = rep.int(-0.5, sum(ind)),
Dim = c(n,n), Dimnames = list(from@label, NULL),
uplo = "L", diag = "U"), "dtCMatrix")
})

## these data frames are now storage efficient but print less nicely
setAs("pedigree", "data.frame",
function(from)
data.frame(sire = from@sire, dam = from@dam,
row.names = from@label))

ped2DF <- function(x) {
lab <- x@label
lev <- seq(along = lab)
data.frame(sire = factor(x@sire, levels = lev, labels = lab),
dam  = factor(x@dam,  levels = lev, labels = lab),
row.names = lab)
}

setMethod("show", signature(object = "pedigree"),
function(object) print(ped2DF(object)))

setMethod("tail", "pedigree", function(x, ...)
do.call("tail", list(x = ped2DF(x), ...)))

setMethod("chol", "pedigree",
function(x, pivot, LINPACK) {
ttrans <- solve(t(as(x, "dtCMatrix")))
.Call(pedigree_chol, x,
as(diagU2N(t(ttrans)), "dtCMatrix"))
})

```