1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
|
#' @include dpt.r
NULL
#' DPT methods
#'
#' Methods for the \link{DPT} class. \code{branch_divide} subdivides branches for plotting (see the examples).
#'
#' @param dpt,object DPT object
#' @param divide Vector of branch numbers to use for division
#' @param value Value of slot to set
#'
#' @return \code{branch_divide} and \code{dataset<-} return the changed object, \code{dataset} the extracted data, and \code{tips} the tip indices.
#'
#' @examples
#' data(guo_norm)
#' dpt <- DPT(DiffusionMap(guo_norm))
#' dpt_9_branches <- branch_divide(dpt, 1:3)
#' plot(dpt_9_branches, col_by = 'branch')
#'
#' @seealso \link{plot.DPT} uses \code{branch_divide} for its \code{divide} argument.
#'
#' @aliases dataset.DPT
#' @name DPT methods
#' @rdname DPT-methods
NULL
#' @importFrom stats na.omit
#' @rdname DPT-methods
#' @export
branch_divide <- function(dpt, divide = integer(0L)) {
check_dpt(dpt)
if (length(divide) == 0L) return(dpt)
for (b in divide) {
super_rows <- dpt@branch[, 1] == b & !is.na(dpt@branch[, 1])
if (!any(super_rows)) {
available <- na.omit(unique(dpt@branch[, 1]))
stop('invalid branch to divide ', b, ' not in ', available)
}
# shift sub branches/tips to the left
dpt@branch[super_rows, ] <- cbind(dpt@branch[super_rows, -1], NA)
dpt@tips [super_rows, ] <- cbind(dpt@tips [super_rows, -1], NA)
# TODO: maybe also modify DPT?
}
vacant_levels <- apply(dpt@branch, 2L, function(col) all(is.na(col)))
dpt@branch <- dpt@branch[, !vacant_levels]
dpt@tips <- dpt@tips [, !vacant_levels]
dpt
}
#' @rdname DPT-methods
#' @export
tips <- function(dpt) {
check_dpt(dpt)
tip_idx <- dpt@tips[, 1]
branch_order <- order(dpt@branch[tip_idx, 1])
which(tip_idx)[branch_order]
}
#' @rdname DPT-methods
#' @export
setMethod('dataset', 'DPT', function(object) dataset(object@dm))
#' @rdname DPT-methods
#' @export
setMethod('dataset<-', 'DPT', function(object, value) {
dataset(object@dm) <- value
validObject(object)
object
})
check_dpt <- function(dpt) if (!is(dpt, 'DPT')) stop('branch_divide needs to be called on a DPT object, not a ', class(dpt))
|
