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
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
|
#' @include dpt.r s4-unions.r
NULL
#' DPT Matrix methods
#'
#' Treat DPT object as a matrix of cell-by-cell DPT distances.
#'
#' @param x \code{\link{DPT}} object.
#' @param i,j \link[=numeric]{Numeric} or \link{logical} index.
#' @param ... ignored
#' @param drop If \code{\link{TRUE}}, coerce result to a vector if it would otherwise have \code{1 \%in\% dim(result)}.
#'
#' @examples
#' data(guo_norm)
#' dm <- DiffusionMap(guo_norm)
#' dpt <- DPT(dm)
#' set.seed(1)
#' plot(dpt[random_root(dpt), ], Biobase::exprs(guo_norm)['DppaI', ])
#'
#' @seealso \code{\link{as.matrix.DPT}}
## Not [[.DPT, that is in the extraction methods
#' @aliases [.DPT nrow.DPT ncol.DPT dim.DPT
#' @name DPT matrix methods
#' @rdname DPT-matrix-methods
NULL
#' @rdname DPT-matrix-methods
#' @export
setMethod('[', c('DPT', 'index', 'index', 'logicalOrMissing'), function(x, i, j, ..., drop = TRUE) {
stopifnot(length(list(...)) == 0L)
evas <- eigenvalues(x@dm)
eves <- eigenvectors(x@dm)
# get numeric from negative or logical indices
i <- seq_len(nrow(x))[i]
j <- seq_len(nrow(x))[j]
norm <- array(NA, c(length(i), length(j), length(evas)))
ev_dist <- norm
for (e in seq_along(evas)) norm[, , e] <- evas[[e]]
norm <- norm / (1-norm)
do.call(mapply, c(list(function(ii, jj) {
ev_dist[ii, jj, ] <<- eves[i[[ii]], ] - eves[j[[jj]], ]
}), expand.grid(ii = seq_along(i), jj = seq_along(j))))
r <- sqrt(apply(norm^2 * ev_dist^2, 1:2, sum))
if (drop && 1L %in% dim(r)) dim(r) <- NULL
r
})
#' @rdname DPT-matrix-methods
#' @export
setMethod('[', c('DPT', 'index', 'missing', 'logicalOrMissing'), function(x, i, j, ..., drop = TRUE) {
x[i, seq_len(nrow(x)), ..., drop = drop]
})
#' @rdname DPT-matrix-methods
#' @export
setMethod('[', c('DPT', 'missing', 'index', 'logicalOrMissing'), function(x, i, j, ..., drop = TRUE) {
x[seq_len(nrow(x)), j, ..., drop = drop]
})
#' @rdname DPT-matrix-methods
#' @export
setMethod('[', c('DPT', 'missing', 'missing', 'logicalOrMissing'), function(x, i, j, ..., drop = TRUE) {
x[seq_len(nrow(x)), seq_len(nrow(x)), ..., drop = drop]
})
#' @rdname DPT-matrix-methods
#' @export
setMethod('[[', c('DPT', 'index', 'index'), function(x, i, j, ...) {
if (length(i) != 1L || length(j) == 1L)
stop('Can only extract one element, but i and j were of lengths ', length(i), ' and ', length(j))
x[i, j, ...]
})
#' @importFrom BiocGenerics nrow
#' @rdname DPT-matrix-methods
#' @export
setMethod('nrow', 'DPT', function(x) length(x@dm@d))
#' @importFrom BiocGenerics ncol
#' @rdname DPT-matrix-methods
#' @export
setMethod('ncol', 'DPT', function(x) length(x@dm@d))
#' @rdname DPT-matrix-methods
#' @export
setMethod('dim', 'DPT', function(x) c(nrow(x), ncol(x)))
|
