Newer
Older
#' The Apply function is an extension of the mapply function, which instead of taking lists of unidimensional objects as input, takes lists of multidimensional objects as input, which may have different numbers of dimensions and dimension lengths. The user can specify which dimensions of each array (or matrix) the function is to be applied over with the margins option.
#' @param data A single object (vector, matrix or array) or a list of objects. They must be in the same order as expected by AtomicFun.
#' @param target_dims List of vectors containing the dimensions to be input into AtomicFun for each of the objects in the data. These vectors can contain either integers specifying the dimension position, or characters corresponding to the dimension names. If both margins and target_dims are specified, margins takes priority over target_dims.
#' @param AtomicFun Function to be applied to the arrays.
#' @param ... Additional arguments to be used in the AtomicFun.
#' @param margins List of vectors containing the margins for the input objects to be split by. Or, if there is a single vector of margins specified and a list of objects in data, then the single set of margins is applied over all objects. These vectors can contain either integers specifying the dimension position, or characters corresponding to the dimension names. If both margins and target_dims are specified, margins takes priority over target_dims.
#' @param parallel Logical, should the function be applied in parallel.
#' @param ncores The number of cores to use for parallel computation.
#' @details When using a single object as input, Apply is almost identical to the apply function. For multiple input objects, the output array will have dimensions equal to the dimensions specified in 'margins'.
#' @return Array or matrix or vector resulting from AtomicFun.
#' @references Wickham, H (2011), The Split-Apply-Combine Strategy for Data Analysis, Journal of Statistical Software.
#' @export
#' @examples
#' #Change in the rate of exceedance for two arrays, with different
#' #dimensions, for some matrix of exceedances.
#' data = list(array(rnorm(2000), c(10,10,20)), array(rnorm(1000), c(10,10,10)),
#' array(rnorm(100), c(10, 10)))
#' test_fun <- function(x, y, z) {((sum(x > z) / (length(x))) /
#' (sum(y > z) / (length(y)))) * 100}
#' margins = list(c(1, 2), c(1, 2), c(1,2))
#' test <- Apply(data, margins, AtomicFun = "test_fun")
Apply <- function(data, target_dims = NULL, AtomicFun, ..., margins = NULL, parallel = FALSE, ncores = NULL) {
if (any(!sapply(data, is.numeric))) {
stop("Parameter 'data' must be one or a list of numeric objects.")
}
is_vector <- rep(FALSE, length(data))
for (i in 1 : length(data)) {
if (is.null(dim(data[[i]]))) {
is_vector[i] <- TRUE
dim(data[[i]]) <- length(data[[i]])
}
}
# Check target_dims and margins
if (is.null(margins) && is.null(target_dims)) {
stop("One of 'margins' or 'target_dims' must be specified.")
}
margins_names <- vector('list', length(data))
target_dims_names <- vector('list', length(data))
# Check margins and build target_dims accordingly
if (!is.list(margins)) {
margins <- rep(list(margins), length(data))
}
if (any(!sapply(margins,
function(x) is.character(x) || is.numeric(x) || is.null(x)))) {
stop("Parameter 'margins' must be one or a list of numeric or ",
"character vectors.")
}
duplicate_dim_specs <- sapply(margins,
function(x) {
length(unique(x)) != length(x)
})
if (any(duplicate_dim_specs)) {
stop("Parameter 'margins' must not contain duplicated dimension ",
"specifications.")
}
target_dims <- vector('list', length(data))
for (i in 1 : length(data)) {
if (length(margins[[i]]) > 0) {
if (is.character(unlist(margins[i]))) {
if (is.null(names(dim(data[[i]])))) {
stop("Parameter 'margins' contains dimension names, but ",
"some of the corresponding objects in 'data' do not have ",
"dimension names.")
}
margins2 <- margins[[i]]
margins2_new_num <- c()
for (j in 1 : length(margins2)) {
matches <- which(names(dim(data[[i]])) == margins2[j])
stop("Could not find dimension '", margins2[j], "' in ", i,
}
if (!is.null(names(dim(data[[i]])))) {
target_dims_names[[i]] <- names(dim(data[[i]]))[- margins[[i]]]
}
target_dims[[i]] <- (1 : length(dim(data[[i]])))[- margins[[i]]]
} else {
target_dims[[i]] <- 1 : length(dim(data[[i]]))
if (!is.null(names(dim(data[[i]])))) {
target_dims_names[[i]] <- names(dim(data[[i]]))
}
} else {
# Check target_dims and build margins accordingly
if (!is.list(target_dims)) {
target_dims <- rep(list(target_dims), length(data))
}
if (any(!sapply(target_dims,
function(x) is.character(x) || is.numeric(x)))) {
stop("Parameter 'target_dims' must be one or a list of numeric or ",
"character vectors.")
}
if (any(sapply(target_dims, length) == 0)) {
stop("Parameter 'target_dims' must not contain length-0 vectors.")
duplicate_dim_specs <- sapply(target_dims,
function(x) {
length(unique(x)) != length(x)
})
if (any(duplicate_dim_specs)) {
stop("Parameter 'target_dims' must not contain duplicated dimension ",
"specifications.")
}
margins <- vector('list', length(data))
for (i in 1 : length(data)) {
if (is.character(unlist(target_dims[i]))) {
if (is.null(names(dim(data[[i]])))) {
stop("Parameter 'target_dims' contains dimension names, but ",
"some of the corresponding objects in 'data' do not have ",
"dimension names.")
}
targs2 <- target_dims[[i]]
targs2_new_num <- c()
for (j in 1 : length(targs2)) {
matches <- which(names(dim(data[[i]])) == targs2[j])
stop("Could not find dimension '", targs2[j], "' in ", i,
}
if (!is.null(names(dim(data[[i]])))) {
margins_names[[i]] <- names(dim(data[[i]]))[- target_dims[[i]]]
}
margins[[i]] <- (1 : length(dim(data[[i]])))[- target_dims[[i]]]
# Reorder dimensions of input data for target dims to be left-most
for (i in 1 : length(data)) {
if (is.unsorted(target_dims[[i]]) ||
(max(target_dims[[i]]) > length(target_dims[[i]]))) {
marg_dims <- (1 : length(dim(data[[i]])))[- target_dims[[i]]]
data[[i]] <- .aperm2(data[[i]], c(target_dims[[i]], marg_dims))
target_dims[[i]] <- 1 : length(target_dims[[i]])
margins[[i]] <- (length(target_dims[[i]]) + 1) : length(dim(data[[i]]))
# Check AtomicFun
if (is.character(AtomicFun)) {
try({AtomicFun <- get(AtomicFun)}, silent = TRUE)
if (!is.function(AtomicFun)) {
stop("Could not find the function '", AtomicFun, "'.")
if (!is.function(AtomicFun)) {
stop("Parameter 'AtomicFun' must be a function or a character string ",
"with the name of a function.")
}
stop("Parameter 'parallel' must be logical.")
# Check ncores
if (parallel) {
if (is.null(ncores)) {
ncores <- availableCores() - 1
}
if (!is.numeric(ncores)) {
stop("Parameter 'ncores' must be numeric.")
}
ncores <- round(ncores)
ncores <- min(availableCores() - 1, ncores)
}
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
# Consistency checks of margins of all input objects
# for each data array, add its margins to the list if not present.
# if there are unnamed margins in the list, check their size matches the margins being added
# and simply assing them a name
# those margins present, check that they match
# if unnamed margins, check consistency with found margins
# if more mrgins than found, add numbers to the list, without names
# with this we end up with a named list of margin sizes
# for data arrays with unnamed margins, we can assume their margins names are those of the first entries in the resulting list
accumulated_found_margins <- afm <- list()
for (i in 1:length(data)) {
if (!is.null(margins_names[[i]])) {
if (length(afm) > 0) {
matches <- which(margins_names[[i]] %in% names(afm))
if (length(matches) > 0) {
margs_to_add <- as.list(dim(data[[i]])[margins[[i]]][- matches])
if (any(dim(data[[i]])[margins[[i]][matches]] != unlist(afm[margins_names[[i]][matches]]))) {
stop("Found one or more margin dimensions with the same name and ",
"different length in some of the input objects in 'data'.")
}
} else {
margs_to_add <- as.list(dim(data[[i]])[margins[[i]]])
}
unnamed_margins <- which(sapply(names(afm), nchar) == 0)
if (length(unnamed_margins) > 0) {
stop_with_error <- FALSE
if (length(unnamed_margins) <= length(margs_to_add)) {
if (any(unlist(afm[unnamed_margins]) != unlist(margs_to_add[1:length(unnamed_margins)]))) {
stop_with_error <- TRUE
}
names(afm)[unnamed_margins] <- names(margs_to_add)[1:length(unnamed_margins)]
margs_to_add <- margs_to_add[- (1:length(margs_to_add))]
} else {
if (any(unlist(afm[unnamed_margins[1:length(margs_to_add)]]) != unlist(margs_to_add))) {
stop_with_error <- TRUE
}
names(afm)[unnamed_margins[1:length(margs_to_add)]] <- names(margs_to_add)
margs_to_add <- list()
}
if (stop_with_error) {
stop("Found unnamed margins (for some objects in parameter ",
"'data') that have been associated by their position to ",
"named margins in other objects in 'data' and do not have ",
"matching length. It could also be that the unnamed ",
"margins don not follow the same order as the named ",
"margins. In that case, either put the corresponding names ",
"to the dimensions of the objects in 'data', or put them ",
"in a consistent order.")
}
}
afm <- c(afm, margs_to_add)
} else {
afm <- as.list(dim(data[[i]])[margins[[i]]])
}
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
margs_to_add <- as.list(dim(data[[i]])[margins[[i]]])
names(margs_to_add) <- rep('', length(margs_to_add))
if (length(afm) > 0) {
stop_with_error <- FALSE
if (length(afm) >= length(margs_to_add)) {
if (any(unlist(margs_to_add) != unlist(afm[1:length(margs_to_add)]))) {
stop_with_error <- TRUE
}
} else {
if (any(unlist(margs_to_add)[1:length(afm)] != unlist(afm))) {
stop_with_error <- TRUE
}
margs_to_add <- margs_to_add[- (1:length(afm))]
afm <- c(afm, margs_to_add)
}
if (stop_with_error) {
stop("Found unnamed margins (for some objects in parameter ",
"'data') that have been associated by their position to ",
"named margins in other objects in 'data' and do not have ",
"matching length. It could also be that the unnamed ",
"margins don not follow the same order as in other ",
"objects. In that case, either put the corresponding names ",
"to the dimensions of the objects in 'data', or put them ",
"in a consistent order.")
}
} else {
afm <- margs_to_add
}
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
# Now need to check which margins are common for all the data arrays.
# Those will be used by llply.
# For the margins that are not common, we will need to iterate manually
# across them, and use data arrays repeatedly as needed.
common_margs <- c()
# names <- names(dim(data[[1]]))[margins[[1]]]
# input <- list()
#
# splatted_f <- splat(AtomicFun)
#
# if (any(!sapply(margins, is.null))) {
# #Check margins match for input objects
# all_dims <- c(sapply(1 : length(data),
# function(x) sum(dim(data[[x]])[margins[[x]]])))
# print(all_dims)
# pos_dim <- which.max(all_dims)[1]
# dim_template <- dim(data[[pos_dim]])[margins[[pos_dim]]]
# print(pos_dim)
# print(dim_template)
# for (i in 1 : length(data)) {
# if (identical(dim(data[[i]])[margins[[i]]], dim_template) == FALSE) {
# for (j in 1 : (length(dim(data[[i]])[margins[[i]]]))) {
# print("OK")
# print(c(dim(data[[i]])[margins[[i]]])[j] != dim_template[j])
# if (c(dim(data[[i]])[margins[[i]]])[j] != dim_template[j]) {
# print(class(data[[i]]))
# data[[i]] <- InsertDim(data[[i]], posdim = margins[[i]][j], lendim = dim_template[j])
# data[[i]] <- adrop(data[[i]], drop = (margins[[i]][j] + 1))
# print(class(data[[i]]))
# }
# }
# }
# }
# print(dim(data)[[2]])
# .isolate <- function(data, margin_length, drop = TRUE) {
# eval(dim(environment()$data))
# structure(list(env = environment(), index = margin_length, subs = as.name("[")),
# class = c("indexed_array"))
# }
# for (i in 1 : length(data)) {
# margin_length <- lapply(dim(data[[i]]), function(x) 1 : x)
# margin_length[-margins[[i]]] <- ""
# margin_length <- expand.grid(margin_length, KEEP.OUT.ATTRS = FALSE,
# stringsAsFactors = FALSE)
# input[[i]] <- .isolate(data[[i]], margin_length)
# }
# dims <- dim(data[[1]])[margins[[1]]]
# i_max <- length(input[[1]])[1] / dims[[1]]
# k <- length(input[[1]]) / i_max
# if (parallel == TRUE) {
# registerDoParallel(ncores)
# }
# WrapperFun <- llply(1 : i_max, function(i)
# sapply((k * i - (k - 1)) : (k * i), function(x) splatted_f(lapply(input, `[[`, x),...), simplify = FALSE),
# .parallel = parallel)
# if (parallel == TRUE) {
# registerDoSEQ()
# }
# if (is.null(dim(WrapperFun[[1]][[1]]))) {
# WrapperFun <- array(as.numeric(unlist(WrapperFun)), dim=c(c(length((WrapperFun[[1]])[[1]])),
# dim(data[[1]])[margins[[1]]]))
# } else {
# WrapperFun <- array(as.numeric(unlist(WrapperFun)), dim=c(c(dim(WrapperFun[[1]][[1]])),
# dim(data[[1]])[margins[[1]]]))
# }
# } else {
# WrapperFun <- splatted_f(data, ...)
# }
# if (!is.null(dim(WrapperFun))) {
# names(dim(WrapperFun))[(length(dim(WrapperFun)) - length(names) + 1) : length(dim(WrapperFun))] <- c(names)
# }
#
# out <- WrapperFun