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
92
93
94
95
96
97
98
|
### =========================================================================
### Common operations on DelayedMatrix objects
### -------------------------------------------------------------------------
###
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Matrix multiplication
###
### We only support multiplication of an ordinary matrix (typically
### small) by a DelayedMatrix object (typically big). Multiplication of 2
### DelayedMatrix objects is not supported.
###
.BLOCK_mult_by_left_matrix <- function(x, y)
{
stopifnot(is.matrix(x),
is(y, "DelayedMatrix") || is.matrix(y),
ncol(x) == nrow(y))
ans_dim <- c(nrow(x), ncol(y))
ans_dimnames <- simplify_NULL_dimnames(list(rownames(x), colnames(y)))
ans_type <- typeof(vector(type(x), 1L) * vector(type(y), 1L))
sink <- RealizationSink(ans_dim, ans_dimnames, ans_type)
on.exit(close(sink))
y_grid <- colGrid(y)
ans_spacings <- c(ans_dim[[1L]], ncol(y_grid[[1L]]))
ans_grid <- RegularArrayGrid(ans_dim, ans_spacings) # parallel to 'y_grid'
nblock <- length(y_grid) # same as 'length(ans_grid)'
for (b in seq_len(nblock)) {
if (get_verbose_block_processing())
message("Processing block ", b, "/", nblock, " ... ",
appendLF=FALSE)
y_viewport <- y_grid[[b]]
block <- read_block(y, y_viewport)
block_ans <- x %*% block
write_block(sink, ans_grid[[b]], block_ans)
if (get_verbose_block_processing())
message("OK")
}
as(sink, "DelayedArray")
}
setMethod("%*%", c("ANY", "DelayedMatrix"),
function(x, y)
{
if (!is.matrix(x)) {
if (!is.vector(x))
stop(wmsg("matrix multiplication of a ", class(x), " object ",
"by a ", class(y), " object is not supported"))
x_len <- length(x)
y_nrow <- nrow(y)
if (x_len != 0L && x_len != y_nrow)
stop(wmsg("non-conformable arguments"))
x <- matrix(x, ncol=y_nrow)
}
.BLOCK_mult_by_left_matrix(x, y)
}
)
setMethod("%*%", c("DelayedMatrix", "ANY"),
function(x, y)
{
if (!is.matrix(y)) {
if (!is.vector(y))
stop(wmsg("matrix multiplication of a ", class(x), " object ",
"by a ", class(y), " object is not supported"))
y_len <- length(y)
x_ncol <- ncol(x)
if (y_len != 0L && y_len != x_ncol)
stop(wmsg("non-conformable arguments"))
y <- matrix(y, nrow=x_ncol)
}
t(t(y) %*% t(x))
}
)
.BLOCK_matrix_mult <- function(x, y)
{
stop(wmsg("Matrix multiplication of 2 DelayedMatrix derivatives is not ",
"supported at the moment. Only matrix multiplication between ",
"a DelayedMatrix derivative and an ordinary matrix or vector ",
"is supported for now."))
x_dim <- dim(x)
y_dim <- dim(y)
stopifnot(length(x_dim) == 2L, length(y_dim) == 2L, ncol(x) == nrow(y))
ans_dim <- c(nrow(x), ncol(y))
ans_dimnames <- simplify_NULL_dimnames(list(rownames(x), colnames(y)))
ans_type <- typeof(vector(type(x), 1L) * vector(type(y), 1L))
sink <- RealizationSink(ans_dim, ans_dimnames, ans_type)
on.exit(close(sink))
}
setMethod("%*%", c("DelayedMatrix", "DelayedMatrix"), .BLOCK_matrix_mult)
|
