# R/PSTr-methods.R In PST: Probabilistic Suffix Trees and Variable Length Markov Chains

```## Initialize method

setMethod("initialize", "PSTr", function(.Object, path, counts, n, order, ymin, index, ...) {

idx <- NULL

if (all(is.na(index[,"group"])) & all(is.na(index[,"position"]))) {
idx <- "S1"
} else {
if (!all(is.na(index[,"group"]))) { idx <- paste("G", index[,"group"], sep="") }
if (!all(is.na(index[,"position"]))) { idx <- paste(idx, paste("P", index[,"position"], sep=""), sep="") }
}

rownames(index) <- idx
.Object@index <- index

nd <- nrow(counts)
.Object@leaf <- matrix(FALSE, nrow=nd, dimnames=list(idx, ""))
.Object@pruned <- matrix(FALSE, nrow=nd, dimnames=list(idx, ""))
rownames(counts) <- idx
rownames(n) <- idx

counts <- as.matrix(counts)
.Object@prob <- counts/rowSums(counts)

## Smoothing
if (!is.null(ymin) & any(.Object@prob==0)) {
ids <- which(rowSums(.Object@prob==0)>0)
.Object@prob[ids,] <- ((1-(ncol(counts)*ymin)) * .Object@prob[ids,]) + ymin
}
callNextMethod(.Object, path=path, counts=counts, n=n, order=order, ...)
}
)

## TAKEN FROM dengrogram method
## The ``generic'' method for "[["  (identical to e.g., "[[.POSIXct"):
## --> subbranches are pstrees as well!
setMethod("[[", "PSTr", function(x, i, drop = TRUE, root.attr=FALSE) {
## cl <- class(x)
alphabet <- x@alphabet
cpal <- x@cpal
labels <- x@labels

x <- unclass(x)
x <- x[[i]]

if (!is.null(x) & root.attr) {
x@alphabet <- alphabet
x@cpal <- cpal
x@labels <- labels
}

x
}
)

## Summary
setMethod("summary", "PSTr", function(object, max.level=NULL, segmented=TRUE) {

stats <- PSTr.stats(object, max.level=max.level, segmented=segmented)

res <- new("PST.summary",
alphabet=object@alphabet,
labels=object@labels,
cpal=object@cpal,
ns=as.integer(object@n),
depth=as.integer(stats\$depth),
nodes=as.integer(stats\$nodes),
leaves=as.integer(stats\$leaves),
freepar=as.integer((stats\$nodes+stats\$leaves)*(length(object@alphabet)-1))
)

return(res)
}
)

PSTr.stats <- function(PST, max.level, segmented=TRUE) {
stats <- list(leaves=as.integer(0), nodes=as.integer(0), depth=as.integer(0))

childrens <- which.child(PST)

stats\$depth <- attr(PST,"order")

if (!is.null(max.level) && PST@order==max.level) {
PST@leaf[] <- TRUE
}

if (segmented) {
stats\$leaves <- stats\$leaves+sum(PST@leaf)
} else {
stats\$leaves <- stats\$leaves+all(PST@leaf)
}

if (any(!PST@leaf)) {
stats\$depth <- stats\$depth+1
if (segmented) {
stats\$nodes <- stats\$nodes+sum(!PST@leaf)
} else {
stats\$nodes <- stats\$nodes+1
}

for (i in childrens) {
tmp <- PSTr.stats(PST[[i]], max.level=max.level, segmented=segmented)
stats\$leaves <- stats\$leaves+tmp\$leaves
stats\$nodes <- stats\$nodes+tmp\$nodes
if (tmp\$depth>stats\$depth) (stats\$depth  <- tmp\$depth)
}
}

return(stats)
}

setMethod("show", "PST.summary", function(object) {
alphabet <- object@alphabet
nbstates <- length(alphabet)
cpal <- object@cpal
labels <- object@labels
ns <- object@ns

cat(" [>] alphabet (state labels): ","\n")
maxstatedisplay <- 12
for (i in 1:min(nbstates,maxstatedisplay))
cat("     ",i, "=", object@alphabet[i], " (", labels[i], ")","\n", sep="")
if (nbstates>12) message("      ...")
cat(" [>] PST fitted on", ns, "symbols \n")
cat(" [>] max. depth:", object@depth,"\n")
cat(" [>] ", object@nodes, " internal node(s), ", object@leaves, " leave(s)\n", sep="")
cat(" [>] (", object@nodes,"+",object@leaves,") * (",nbstates, "-1) = ", object@freepar, " free parameters \n", sep="")
}
)

which.child <- function(PST) {
class <- class(PST)
child.list <- names(PST)[unlist(lapply(PST, is, class))]
return(child.list)
}
```

## Try the PST package in your browser

Any scripts or data that you put into this service are public.

PST documentation built on May 2, 2019, 5:14 p.m.