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
|
### =========================================================================
### ConstantArraySeed and ConstantArray objects
### -------------------------------------------------------------------------
###
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### ConstantArraySeed objects
###
setClass("ConstantArraySeed",
contains="Array",
representation(
dim="integer", # This gives us dim() for free!
value="vector"
),
prototype(
dim=0L,
value=NA
)
)
setValidity2("ConstantArraySeed",
function(object)
{
msg <- validate_dim_slot(object, "dim")
if (!isTRUE(msg))
return(msg)
if (length(object@value) != 1L)
return("'value' must be a vector (atomic or list) of length 1")
TRUE
}
)
setMethod("extract_array", "ConstantArraySeed",
function(x, index) array(x@value, get_Nindex_lengths(index, dim(x)))
)
setMethod("extract_sparse_array", "ConstantArraySeed",
function(x, index)
{
ans_dim <- get_Nindex_lengths(index, dim(x))
ans_nzdata <- rep.int(x@value, 0L)
SparseArraySeed(ans_dim, nzdata=ans_nzdata, check=FALSE)
}
)
setMethod("is_sparse", "ConstantArraySeed",
function(x)
{
zero <- vector(type(x), length=1L)
identical(x@value, zero)
}
)
ConstantArraySeed <- function(dim, value=NA)
{
new2("ConstantArraySeed", dim=as.integer(dim), value=value)
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### ConstantArray and ConstantMatrix objects
###
setClass("ConstantArray",
contains="DelayedArray",
representation(seed="ConstantArraySeed")
)
setClass("ConstantMatrix", contains=c("ConstantArray", "DelayedMatrix"))
setMethod("matrixClass", "ConstantArray", function(x) "ConstantMatrix")
setMethod("DelayedArray", "ConstantArraySeed",
function(seed) new_DelayedArray(seed, Class="ConstantArray")
)
ConstantArray <- function(dim, value=NA)
{
DelayedArray(ConstantArraySeed(dim, value=value))
}
### Automatic coercion method from ConstantArray to ConstantMatrix silently
### returns a broken object (unfortunately these dummy automatic coercion
### methods don't bother to validate the object they return). So we overwrite
### it.
setAs("ConstantArray", "ConstantMatrix",
function(from) new2("ConstantMatrix", from)
)
### The user should not be able to degrade a ConstantMatrix object to
### a ConstantArray object so 'as(x, "ConstantArray", strict=TRUE)' should
### fail or be a no-op when 'x' is ConstantMatrix object. Making this
### coercion a no-op seems to be the easiest (and safest) way to go.
setAs("ConstantMatrix", "ConstantArray", function(from) from) # no-op
|
