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
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
|
### =========================================================================
### Utilities to make capped volume boxes
### -------------------------------------------------------------------------
###
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### makeCappedVolumeBox()
###
### 'maxvol' is assumed to be a single integer >= 2 and < 'prod(maxdim)'.
.make_capped_volume_hypercube_box <- function(maxvol, maxdim)
{
ans <- maxdim
L <- max(ans)
while (TRUE) {
is_max <- ans == L
not_max_ans <- ans[!is_max]
L <- (maxvol / prod(not_max_ans)) ^ (1 / sum(is_max))
if (length(not_max_ans) == 0L)
break
L2 <- max(not_max_ans)
if (L >= L2)
break
L <- L2
ans[is_max] <- L
}
ans[is_max] <- as.integer(L)
q <- get_RegularArrayGrid_dim(maxdim, ans + 1L) /
get_RegularArrayGrid_dim(maxdim, ans)
for (along in which(is_max)[order(q[is_max])]) {
ans[[along]] <- ans[[along]] + 1L
p <- prod(ans)
if (p == maxvol)
break
if (p > maxvol) {
ans[[along]] <- ans[[along]] - 1L
break
}
}
ans
}
### 'maxvol' is assumed to be a single integer >= 2 and < 'prod(maxdim)'.
### The algo used below could be improved. For exampe it does some weird
### things like:
### > .make_capped_volume_scale_box(11, c(3, 50, 10))
### [1] 1 9 1
### > .make_capped_volume_scale_box(12, c(3, 50, 10))
### [1] 1 8 1
.make_capped_volume_scale_box <- function(maxvol, maxdim)
{
## Some good properties of shrinkbox():
## - The output dims are always >= 1.
## - If r is < 1, then input dims that are > 1 will decrease and those
## at 1 will remain at 1.
shrinkbox <- function(bdim, r) pmax(as.integer(bdim * r), 1L)
p <- 1 / length(maxdim)
bdim <- maxdim # all(maxdim >= 1) is TRUE
## Loop will typically go thru 2 to 18 iterations before it breaks.
## An example that requires 18 iterations:
## - maxvol <- 70000
## - maxdim <- c(30, 15000000)
while (TRUE) {
bvol <- prod(bdim) # can't be 0
if (bvol <= maxvol)
break
r <- (maxvol / bvol)^p # < 1
bdim <- shrinkbox(bdim, r) # reduce all dims (except those already
# at 1) so volume is guaranteed to reduce
# at each loop
}
bdim
}
### 'maxvol' is assumed to be a single integer >= 2 and < 'prod(maxdim)'.
.make_capped_volume_FDGF_box <- function(maxvol, maxdim)
{
p <- cumprod(maxdim)
w <- which(p <= maxvol)
N <- if (length(w) == 0L) 1L else w[[length(w)]] + 1L
if (N == 1L) {
by <- maxvol
} else {
by <- maxvol %/% as.integer(p[[N - 1L]])
}
c(head(maxdim, n=N-1L), by, rep.int(1L, length(maxdim)-N))
}
.make_capped_volume_LDGF_box <- function(maxvol, maxdim)
{
rev(.make_capped_volume_FDGF_box(maxvol, rev(maxdim)))
}
### Return the dimensions of a box that satisfies the following properties:
### 1. Has a volume as close as possibe to (but not bigger than) 'maxvol'.
### 2. Fits in the "constraining box" i.e. in the box of dimensions 'maxdim'.
### 3. Has a non-zero volume if the "constraining box" has a non-zero volume.
### 4. Has a shape that is as close as possible to the requested shape.
makeCappedVolumeBox <- function(maxvol, maxdim, shape=c("hypercube",
"scale",
"first-dim-grows-first",
"last-dim-grows-first"))
{
if (!isSingleNumber(maxvol))
stop("'maxvol' must be a single integer")
if (!is.integer(maxvol))
maxvol <- as.integer(maxvol)
if (maxvol < 0L)
stop("'maxvol' must be a non-negative integer")
if (!is.numeric(maxdim))
stop(wmsg("'maxdim' must be an integer vector"))
if (!is.integer(maxdim))
maxdim <- as.integer(maxdim)
shape <- match.arg(shape)
if (maxvol >= prod(maxdim))
return(maxdim)
if (maxvol == 0L)
return(integer(length(maxdim)))
if (maxvol == 1L)
return(rep.int(1L, length(maxdim)))
FUN <- switch(shape,
hypercube=.make_capped_volume_hypercube_box,
scale=.make_capped_volume_scale_box,
`first-dim-grows-first`=.make_capped_volume_FDGF_box,
`last-dim-grows-first`=.make_capped_volume_LDGF_box,
stop("unsupported 'shape'"))
FUN(maxvol, maxdim)
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### makeRegularArrayGridOfCappedLengthViewports()
###
### A capped-volume box related utility.
### If 'viewport_shape' is "first-dim-grows-first", return a linear grid.
makeRegularArrayGridOfCappedLengthViewports <-
function(refdim, viewport_len, viewport_shape=c("hypercube",
"scale",
"first-dim-grows-first",
"last-dim-grows-first"))
{
spacings <- makeCappedVolumeBox(viewport_len, refdim, viewport_shape)
RegularArrayGrid(refdim, spacings)
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Linear viewports and grids
###
### An array viewport is "linear" if it is made of reference array elements
### that would be contiguous in memory if the reference array was an ordinary
### R array (where the fastest changing dimension is the first one).
###
setGeneric("isLinear", function(x) standardGeneric("isLinear"))
setMethod("isLinear", "ArrayViewport",
function(x)
{
x_width <- width(x)
idx <- which(x_width != refdim(x))
if (length(idx) == 0L)
return(TRUE)
all(tail(x_width, n=-idx[[1L]]) == 1L)
}
)
### If the 1st grid element is linear, then they all are.
setMethod("isLinear", "ArrayGrid",
function(x)
{
if (length(x) == 0L)
return(TRUE)
isLinear(x[[1L]])
}
)
|
