Began adding an R-native writer.

NAMESPACE

@@ -18,8 +18,18 @@ importFrom(DelayedArray,type)
 importFrom(Matrix,sparseMatrix)
 importFrom(Matrix,t)
 importFrom(S4Vectors,DataFrame)
+importFrom(S4Vectors,I)
 importFrom(S4Vectors,make_zero_col_DFrame)
 importFrom(S4Vectors,metadata)
+importFrom(S4Vectors,wmsg)
+importFrom(SingleCellExperiment,"colPairs<-")
+importFrom(SingleCellExperiment,"reducedDims<-")
+importFrom(SingleCellExperiment,"rowPairs<-")
+importFrom(SingleCellExperiment,SingleCellExperiment)
+importFrom(SummarizedExperiment,"colData<-")
+importFrom(SummarizedExperiment,"rowData<-")
+importFrom(SummarizedExperiment,colData)
+importFrom(SummarizedExperiment,rowData)
 importFrom(basilisk,basiliskRun)
 importFrom(methods,as)
 importFrom(methods,is)

R/read.R

@@ -57,3 +57,182 @@
     adata <- anndata$read_h5ad(file, backed = if (backed) "r" else FALSE)
     AnnData2SCE(adata, hdf5_backed = backed)
 }
+
+#' @importFrom S4Vectors I DataFrame wmsg
+#' @importFrom SummarizedExperiment rowData colData rowData<- colData<-
+#' @importFrom SingleCellExperiment SingleCellExperiment reducedDims<- colPairs<- rowPairs<-
+.native_reader <- function(file, backed=FALSE) {
+    contents <- .list_contents(file)
+
+    # Let's read in the X matrix first... if it's there.
+    if (!"X" %in% names(contents)) {
+        stop("missing an 'X' entry in '", file, "'")
+    }
+    all.assays <- list(X = .read_matrix(file, "X", contents[["X"]], backed=backed))
+
+    for (l in names(contents[["layers"]])) {
+        tryCatch({
+            all.assays[[l]] <- .read_matrix(file, file.path("layers", l), contents[["layers"]][[l]], backed=backed)
+        }, error=function(e) {
+            warning(wmsg("setting additional assays from 'layers' failed for '", file, "':\n  ", conditionMessage(e)))
+        })
+    }
+
+    sce <- SingleCellExperiment(all.assays)
+
+    # Adding the various pieces of data.
+    tryCatch({
+        cd <- .read_dim_data(file, "obs", contents[["obs"]])
+        if (!is.null(cd)) {
+            colData(sce) <- cd
+        }
+    }, error=function(e) {
+        warning(wmsg("setting 'colData' failed for '", file, "':\n  ", conditionMessage(e)))
+    })
+
+    tryCatch({
+        rd <- .read_dim_data(file, "var", contents[["var"]])
+        if (!is.null(rd)) {
+            rowData(sce) <- rd
+        }
+    }, error=function(e) {
+        warning(wmsg("setting 'rowData' failed for '", file, "':\n  ", conditionMessage(e)))
+    })
+
+    # Adding the reduced dimensions and other bits and pieces.
+    tryCatch({
+        reducedDims(sce) <- .read_dim_mats(file, "obsm", contents[["obsm"]]) 
+    }, error=function(e) {
+        warning(wmsg("setting 'reducedDims' failed for '", file, "':\n  ", conditionMessage(e)))
+    })
+
+    tryCatch({
+        row.mat <- .read_dim_mats(file, "varm", contents[["varm"]])
+        if (length(row.mat)) {
+            row.mat.df <- do.call(DataFrame, lapply(row.mat, I))
+            rowData(sce) <- cbind(rowData(sce), row.mat.df)
+        }
+    }, error=function(e) {
+        warning(wmsg("extracting 'varm' failed for '", file, "':\n  ", conditionMessage(e)))
+    })
+
+    # Adding pairings, if any exist.
+    tryCatch({
+        rowPairs(sce) <- .read_dim_pairs(file, "varp", contents[["varp"]])
+    }, error=function(e) {
+        warning(wmsg("setting 'rowPairs' failed for '", file, "':\n  ", conditionMessage(e)))
+    })
+
+    tryCatch({
+        colPairs(sce) <- .read_dim_pairs(file, "obsp", contents[["obsp"]])
+    }, error=function(e) {
+        warning(wmsg("setting 'colPairs' failed for '", file, "':\n  ", conditionMessage(e)))
+    })
+
+    if ("uns" %in% names(contents)) {
+        tryCatch({
+            metadata(sce) <- rhdf5::h5read(file, "uns")
+        }, error=function(e) {
+            warning(wmsg("setting 'metadata' failed for '", file, "':\n  ", conditionMessage(e)))
+        })
+    }
+
+    sce
+}
+
+.list_contents <- function(file) {
+    manifest <- rhdf5::h5ls(file)
+
+    set_myself <- function(x, series, value) {
+        if (length(series)!=1) {
+            value <- set_myself(x[[series[1]]], series[-1], value)
+        }
+        if (is.null(x)) {
+            x <- list()
+        }
+        x[[series[1]]] <- value
+        x
+    }
+
+    contents <- list()
+    for (i in seq_len(nrow(manifest))) {
+        components <- c(strsplit(manifest[i, "group"], "/")[[1]], manifest[i, "name"])
+        if (components[1] == "") {
+            components <- components[-1]
+        }
+
+        info <- manifest[i, c('otype', 'dclass', 'dim')]
+        if (info$otype=="H5I_GROUP") {
+            info <- list()
+        }
+        contents <- set_myself(contents, components, info)
+    }
+
+    contents
+}
+
+.read_matrix <- function(file, path, fields, backed) {
+    if (is.data.frame(fields)) {
+        mat <- HDF5Array::HDF5Array(file, path)
+    } else {
+        mat <- HDF5Array::H5SparseMatrix(file, path)
+    }
+    if (!backed) {
+         if (DelayedArray::is_sparse(mat)) {
+             mat <- as(mat, "sparseMatrix")
+         } else {
+             mat <- as.matrix(mat)
+         }
+    }
+    mat
+}
+
+#' @importFrom S4Vectors DataFrame
+.read_dim_data <- function(file, path, fields) {
+    col.names <- setdiff(names(fields), c("__categories", "_index"))
+    out.cols <- list()
+    for (i in col.names) {
+        out.cols[[i]] <- as.vector(rhdf5::h5read(file, file.path(path, i)))
+    }
+
+    cat.names <- names(fields[["__categories"]])
+    for (i in cat.names) {
+        levels <- as.vector(rhdf5::h5read(file, file.path(path, "__categories", i)))
+        out.cols[[i]] <- factor(out.cols[[i]], levels)
+    }
+
+    if (!is.null(fields[["_index"]])) {
+        indices <- as.vector(rhdf5::h5read(file, file.path(path, "_index")))
+    } else {
+        indices <- NULL
+    }
+
+    if (length(out.cols)) {
+        df <- do.call(DataFrame, out.cols)
+        rownames(df) <- indices
+    } else if (!is.null(indices)) {
+        df <- DataFrame(row.names=indices)
+    } else {
+        df <- NULL
+    }
+
+    df
+}
+
+.read_dim_mats <- function(file, path, fields) {
+    all.contents <- list()
+    for (i in names(fields)) {
+        # because everything's transposed.
+        all.contents[[i]] <- t(rhdf5::h5read(file, file.path(path, i)))
+    }
+    all.contents
+}
+
+.read_dim_pairs <- function(file, path, fields) {
+    all.pairs <- list()
+    for (i in names(fields)) {
+        mat <- HDF5Array::H5SparseMatrix(file, file.path(path, i))
+        all.pairs[[i]] <- as(mat, "sparseMatrix")
+    }
+    all.pairs
+}

R/write.R

@@ -120,6 +120,139 @@
     adata$write_h5ad(file)
 }
 
+.native_writer <- function(sce, file) {
+    # Save to an adjacent file and then move on success. This avoids
+    # overwriting an existing file unless the entire write was okay.
+    temp <- tempfile(dirname(file), fileext=".h5")
+    on.exit(unlink(temp))
+    rhdf5::h5createFile(temp)
+
+    # Saving the assays. 
+    # TODO: sparse array support, waiting on HDF5.
+    HDF5Array::writeHDF5Array(assay(sce, withDimnames=FALSE), temp, "X", with.dimnames = FALSE)
+
+    all.ass <- assayNames(sce)[-1]
+    if (length(all.ass)) {
+        if (any(all.ass=="") || anyDuplicated(all.ass)) {
+            stop("assay names must be non-NULL and unique")
+        }
+        rhdf5::h5createGroup("layers")
+        for (i in all.ass) {
+            HDF5Array::writeHDF5Array(assay(sce, i, withDimnames=FALSE), temp, file.path("layers", i), with.dimnames = FALSE)
+        }
+    }
+
+    # Saving the rowData with a shift of matrices.
+    row.mats <- .save_dim_data(rowData(sce), temp, "var", "rowData", ignore.mat=FALSE)
+    .save_mat_list(as.list(row.mats), temp, "varm", "rowData")
+
+    # Saving the colData.
+    col.mats <- .save_dim_data(colData(sce), temp, "obs", "colData", ignore.mat=TRUE)
+
+    # Saving the reducedDims.
+    .save_mat_list(reducedDims(sce), temp, "obsm", "reducedDims")
+
+    # Saving the metadata.
+    .save_uns_list(metadata(sce), temp, "uns", "metadata")
+
+    # TODO: skipping the pairs until we can save sparse attributes properly.
+
+    file.rename(temp, file)
+}
+
+.save_dim_data <- function(df, file, name, msg, ignore.mat) {
+    if (is.null(rownames(df)) || anyDuplicated(rownames(df))) {
+        stop("'", msg, "' should have non-NULL and unique row names")
+    }
+    if (is.null(colnames(df)) || anyDuplicated(colnames(df))) {
+        stop("'", msg, "' should have non-NULL and unique column names")
+    }
+
+    rhdf5::h5createGroup(file, name)
+    rhdf5::h5write(rownames(df), file, file.path(name, "_index"))    
+
+    is.mat <- logical(ncol(df))
+    made.factor <- FALSE
+    for (i in seq_len(ncol(df))) {
+        x <- colnames(df)[i]
+        current <- df[[x]]
+
+        if (is.matrix(current)) {
+            if (ignore.mat) {
+                warning("ignoring matrix-like column '", x, "' in the '", msg, 
+                        "':\n  ", conditionMessage(e))
+            }
+            is.mat[i] <- TRUE
+        } else if (is.factor(current)) {
+            if (!made.factor) {
+                rhdf5::h5write(current, file, file.path(name, "__categories"))
+                made.factor <- TRUE
+            }
+            rhdf5::h5write(levels(current), file, file.path(name, "__categories", x))
+            current <- as.character(current)
+        } else {
+            # Who knows what weird crap we have here.
+            tryCatch({
+                rhdf5::h5write(current, file, file.path(name, x))
+            }, error=function(e) {
+                warning("failed to save column '", x, "' from the '", msg,
+                        "':\n  ", conditionMessage(e))
+            })
+        }
+    }
+
+    df[,is.mat,drop=FALSE]
+}
+
+.save_mat_list <- function(matlist, file, name, msg) {
+    if (!length(matlist)) {
+        return(NULL)
+    }
+    if (is.null(names(matlist)) || anyDuplicated(names(matlist))) {
+        stop("'", msg, "' should have non-NULL and unique names")
+    }
+
+    rhdf5::h5createGroup(file, name)
+    for (i in seq_along(matlist)) {
+        x <- names(matlist)[i]
+        tryCatch({
+            rhdf5::h5write(matlist[[i]], file, file.path(name, x))
+        }, error=function(e) {
+            warning("failed to save matrix '", x, "' from the '", msg, 
+                    "':\n  ", conditionMessage(e))
+        })
+    }
+}
+
+.save_uns_list <- function(contents, file, name, msg) {
+    if (!length(contents)) {
+        return(NULL)
+    }
+    if (is.null(names(contents)) || anyDuplicated(names(contents))) {
+        warning(wmsg("'", msg, "' should have non-NULL and unique names"))
+        return(NULL)
+    }
+    rhdf5::h5createGroup(file, name)
+
+    for (i in names(contents)) {
+        current <- contents[[i]]
+        path <- file.path(name, i)
+        msg2 <- paste0(msg, "->", i)
+
+        if (is.data.frame(current) || is.atomic(current)) {
+            if (is.factor(current)) {
+                # TODO: save this as an HDF5 enumeration type.
+                current <- as.character(current)
+            }
+            rhdf5::h5write(current, file=file, name=path)
+        } else if (is.list(current)) {
+            .save_uns_list(current, file, path, msg2)
+        } else {
+            warning(msg("ignoring '", msg2, "' of unknown type ", class(current)[1]))
+        }
+    }
+}
+
 # nocov start
 
 # Skipping code coverage on these function because they aren't used until the