Merge pull request #2 from dipterix/mmap

Replaced fopen with boost memory mapping

Author: dipterix

.gitignore

@@ -20,3 +20,9 @@ tests2/
 docs
 CRAN-RELEASE
 inst/doc
+# C++ related
+*.a
+*.dll
+*.o
+*.so
+*.dll

DESCRIPTION

@@ -25,6 +25,7 @@ Suggests:
     testthat (>= 3.0.0)
 RoxygenNote: 7.1.1
 LinkingTo: 
+    BH,
     Rcpp
 Config/testthat/edition: 3
 VignetteBuilder: knitr

NAMESPACE

@@ -21,6 +21,7 @@ export(filearray_create)
 export(filearray_load)
 export(filearray_threads)
 export(fmap)
+export(fmap2)
 export(fmap_element_wise)
 export(fwhich)
 export(mapreduce)

R/RcppExports.R

@@ -69,8 +69,8 @@ filearray_subset <- function(filebase, position_indices, drop = TRUE, use_dimnam
     .Call(`_filearray_filearray_subset`, filebase, position_indices, drop, use_dimnames, reshape)
 }
 
-FARR_subset_sequential <- function(filebase, unit_partlen, cum_partsizes, array_type, file_buffer, ret, from = 0L, len = 1L) {
-    .Call(`_filearray_FARR_subset_sequential`, filebase, unit_partlen, cum_partsizes, array_type, file_buffer, ret, from, len)
+FARR_subset_sequential <- function(filebase, unit_partlen, cum_partsizes, array_type, ret, from = 0L, len = 1L) {
+    .Call(`_filearray_FARR_subset_sequential`, filebase, unit_partlen, cum_partsizes, array_type, ret, from, len)
 }
 
 FARR_subset2 <- function(filebase, listOrEnv, reshape = NULL, drop = FALSE, use_dimnames = TRUE, thread_buffer = 2097152L, split_dim = 0L, strict = 1L) {
@@ -81,6 +81,10 @@ FARR_buffer_map <- function(input_filebases, output_filebase, map, buffer_nelems
     .Call(`_filearray_FARR_buffer_map`, input_filebases, output_filebase, map, buffer_nelems, result_nelems)
 }
 
+FARR_buffer_map2 <- function(input_filebases, map, buffer_nelems) {
+    .Call(`_filearray_FARR_buffer_map2`, input_filebases, map, buffer_nelems)
+}
+
 FARR_buffer_mapreduce <- function(filebase, map, reduce, buffer_nelems) {
     .Call(`_filearray_FARR_buffer_mapreduce`, filebase, map, reduce, buffer_nelems)
 }
@@ -97,6 +101,10 @@ hasOpenMP <- function() {
     .Call(`_filearray_hasOpenMP`)
 }
 
+FARR_subset_assign_sequential <- function(filebase, unit_partlen, cum_partsizes, array_type, value, from) {
+    .Call(`_filearray_FARR_subset_assign_sequential`, filebase, unit_partlen, cum_partsizes, array_type, value, from)
+}
+
 FARR_subset_assign2 <- function(filebase, value, listOrEnv, thread_buffer = 2097152L, split_dim = 0L) {
     .Call(`_filearray_FARR_subset_assign2`, filebase, value, listOrEnv, thread_buffer, split_dim)
 }

R/header.R

@@ -42,7 +42,7 @@ read_header <- function(fid){
             endian <- 'big'
             stop("The file endianess is not little?")
         } else {
-            endian <- 'little'
+            endian <- "little"
         }
     }
 

R/map.R

@@ -1,5 +1,7 @@
 #' @title Map multiple file arrays and save results
-#' @description Advanced mapping function for multiple file arrays. This 
+#' @description Advanced mapping function for multiple file arrays. \code{fmap}
+#' runs the mapping functions and stores the results in file arrays. 
+#' \code{fmap2} stores results in memory. This 
 #' feature is experimental. There are several constraints to the input. 
 #' Failure to meet these constraints may result in undefined results, or 
 #' even crashes. Please read Section 'Details' carefully before using 
@@ -10,6 +12,8 @@
 #' @param .y a file array object, used to save results
 #' @param .input_size number of elements to read from each array of \code{x}
 #' @param .output_size \code{fun} output vector length
+#' @param .simplify whether to apply \code{\link[base]{simplify2array}} to 
+#' the result
 #' @param ... other arguments passing to \code{fun}
 #' @return File array instance \code{.y}
 #' @details 
@@ -190,6 +194,56 @@ fmap <- function(x, fun, .y, .input_size = NA, .output_size = NA, ...){
     .y
 }
 
+#' @rdname fmap
+#' @export
+fmap2 <- function(x, fun, .input_size = NA, .simplify = TRUE, ...){
+    if(!length(x)){
+        stop("`x` must be a list of file arrays")
+    }
+    
+    if(inherits(x, "FileArray")){
+        x <- list(x)
+    }
+    
+    dims <- sapply(x, dim)
+    dim <- dims[,1, drop = TRUE]
+    
+    if(any(dims - dim != 0)){
+        stop("Input `x` array dimensions must match")
+    }
+    
+    fbases <- sapply(x, function(el){
+        if( !is_filearray(el) ){
+            stop("Input `x` must only contains file arrays")
+        }
+        el$initialize_partition()
+        el$.filebase
+    })
+    
+    if(is.na(.input_size)){
+        .input_size <- get_buffer_size() / 8L
+    }
+    if(.input_size <= 0){
+        stop("`.input_size` must be postive")
+    }
+    .input_size <- as.integer(.input_size)
+    
+    args <- list(quote(input), ...)
+    map <- function(input){
+        do.call(fun, args)
+    }
+    
+    res <- FARR_buffer_map2(
+        input_filebases = fbases,
+        map = map,
+        buffer_nelems = .input_size
+    )
+    if(.simplify){
+        res <- simplify2array(res)
+    }
+    res
+}
+
 is_filearray <- function(object){
     if(!isS4(object)){ return(FALSE) }
     cls <- class(object)