Support staging of a base R factor.

R/loadBaseFactor.R

@@ -0,0 +1,38 @@
+#' Load a factor
+#'
+#' Load a base R \link{factor} from file.
+#'
+#' @inheritParams loadDataFrame
+#' @param ... Further arguments, ignored.
+#'
+#' @return The vector described by \code{info}, possibly with names.
+#'
+#' @seealso
+#' \code{"\link{stageObject,factor-method}"}, for the staging method.
+#'
+#' @author Aaron Lun
+#' 
+#' @examples
+#' tmp <- tempfile()
+#' dir.create(tmp)
+#' meta <- stageObject(factor(letters[1:10], letters), tmp, path="bar")
+#' loadBaseFactor(meta, tmp)
+#' 
+#' @export
+loadBaseFactor <- function(info, project, ...) {
+    fpath <- acquireFile(project, info$path)
+    meta <- info$factor
+
+    df <- read.csv3(fpath, compression=meta$compression, nrows=meta$length)
+    codes <- df[,ncol(df)]
+
+    smeta <- info$string_factor
+    level_meta <- acquireMetadata(project, smeta$levels$resource$path)
+    levels <- altLoadObject(level_meta, project=project)
+
+    output <- factor(levels[codes], levels=levels, ordered=isTRUE(smeta$ordered))
+    if (isTRUE(meta$names)) {
+        names(output) <- df[,1]
+    }
+    output 
+}

R/stageBaseFactor.R

@@ -0,0 +1,51 @@
+#' Stage factors
+#'
+#' Pretty much as it says, let's stage a base R \link{factor}.
+#'
+#' @param x Any of the assorted simple vector types.
+#' @inheritParams stageObject
+#' @param ... Further arguments that are ignored.
+#'
+#' @return
+#' A named list containing the metadata for \code{x}.
+#' \code{x} itself is written to a file inside \code{path}, along with the various levels.
+#'
+#' @author Aaron Lun
+#' 
+#' @examples
+#' tmp <- tempfile()
+#' dir.create(tmp)
+#' stageObject(factor(1:10, 1:30), tmp, path="foo")
+#' list.files(tmp, recursive=TRUE)
+#' 
+#' @name stageBaseFactor
+#' @importFrom S4Vectors DataFrame
+setMethod("stageObject", "factor", function(x, dir, path, child = FALSE, ...) {
+    dir.create(file.path(dir, path), showWarnings=FALSE)
+    new_path <- paste0(path, "/indices.txt.gz")
+
+    contents <- as.integer(x)
+    mock <- DataFrame(values=contents)
+    if (!is.null(names(x))) {
+        mock <- cbind(names=names(x), mock)
+    }
+    quickWriteCsv(mock, file.path(dir, new_path), row.names=FALSE, compression="gzip")
+
+    level_meta <- stageObject(levels(x), dir, paste0(path, "/levels"), child=TRUE)
+    level_stub <- writeMetadata(level_meta, dir)
+
+    list(
+        `$schema` = "string_factor/v1.json",
+        path = new_path,
+        is_child = child,
+        factor = list(
+            length = length(x),
+            names = !is.null(names(x)),
+            compression = "gzip"
+        ),
+        string_factor = list(
+            levels = list(resource = level_stub),
+            ordered = is.ordered(x)
+        )
+    )
+})

tests/testthat/test-factor.R

@@ -0,0 +1,37 @@
+# Test stageObject on factors.
+# library(testthat); library(alabaster.base); source("test-factor.R")
+
+test_that("factors work correctly without names", {
+    tmp <- tempfile()
+    dir.create(tmp, recursive=TRUE)
+
+    input <- factor(LETTERS)
+    meta <- stageObject(input, tmp, path="foo")
+    writeMetadata(meta, tmp)
+    expect_identical(loadBaseFactor(meta, tmp), input)
+
+    vals <- factor(LETTERS[5:20], LETTERS)
+    meta <- stageObject(vals, tmp, path="bar")
+    writeMetadata(meta, tmp)
+    expect_identical(loadBaseFactor(meta, tmp), vals)
+
+    vals <- factor(LETTERS, LETTERS[2:24])
+    meta <- stageObject(vals, tmp, path="stuff")
+    writeMetadata(meta, tmp)
+    expect_identical(loadBaseFactor(meta, tmp), vals)
+
+    vals <- factor(LETTERS, rev(LETTERS), ordered=TRUE)
+    meta <- stageObject(vals, tmp, path="whee")
+    writeMetadata(meta, tmp)
+    expect_identical(loadBaseFactor(meta, tmp), vals)
+})
+
+test_that("factors work correctly with names", {
+    tmp <- tempfile()
+    dir.create(tmp, recursive=TRUE)
+
+    vals <- setNames(factor(LETTERS, rev(LETTERS)), letters)
+    meta <- stageObject(vals, tmp, path="bar")
+    writeMetadata(meta, tmp)
+    expect_identical(loadBaseFactor(meta, tmp), vals)
+})