fix R stack imbalance (#116)

* revert to c memory

* set args to void

* try write.table instead

* remove data.table and R.utils

* update docs

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: raer
 Type: Package
 Title: RNA editing tools in R
-Version: 1.1.1
+Version: 1.1.2
 Authors@R: c(
     person("Kent", "Riemondy", , "[email protected]", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0003-0750-1273")),
@@ -22,7 +22,6 @@ License: MIT + file LICENSE
 Imports: 
     stats,
     methods,
-    data.table,
     GenomicRanges,
     IRanges,
     Rsamtools,
@@ -38,7 +37,6 @@ Imports:
     BiocParallel,
     rtracklayer,
     Matrix,
-    R.utils,
     cli
 Suggests:
     testthat (>= 3.0.0),
@@ -65,7 +63,7 @@ SystemRequirements:
 VignetteBuilder: knitr
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.0
 URL: https://rnabioco.github.io/raer, https://github.com/rnabioco/raer
 BugReports: https://github.com/rnabioco/raer/issues
 biocViews:

NAMESPACE

@@ -57,7 +57,6 @@ importFrom(IRanges,extractList)
 importFrom(IRanges,subsetByOverlaps)
 importFrom(Matrix,colSums)
 importFrom(Matrix,sparseMatrix)
-importFrom(R.utils,gzip)
 importFrom(Rsamtools,BamFile)
 importFrom(Rsamtools,BamFileList)
 importFrom(Rsamtools,FaFile)
@@ -71,7 +70,6 @@ importFrom(Rsamtools,seqinfo)
 importFrom(S4Vectors,aggregate)
 importFrom(S4Vectors,unstrsplit)
 importFrom(SingleCellExperiment,SingleCellExperiment)
-importFrom(data.table,fread)
 importFrom(methods,"slot<-")
 importFrom(methods,as)
 importFrom(methods,is)
@@ -81,4 +79,6 @@ importFrom(methods,slotNames)
 importFrom(rtracklayer,export)
 importFrom(stats,model.matrix)
 importFrom(stats,pbeta)
+importFrom(utils,read.table)
+importFrom(utils,write.table)
 useDynLib(raer, .registration = TRUE)

R/sc-pileup.R

@@ -336,7 +336,8 @@ get_sc_pileup <- function(bamfn, index, id, sites, barcodes,
 #' intervals, whereas `index`` will only add row indices to the rownames.
 #' @returns a `SingleCellExperiment` object populated with `nRef` and `nAlt`
 #' assays.
-#'
+#' 
+#' @importFrom utils read.table
 #' @examples
 #' library(Rsamtools)
 #' library(GenomicRanges)
@@ -359,18 +360,16 @@ get_sc_pileup <- function(bamfn, index, id, sites, barcodes,
 #'
 #' unlink(bai)
 #'
-#' @importFrom data.table fread
 #' @importFrom Matrix sparseMatrix
 #' @importFrom SingleCellExperiment SingleCellExperiment
-#' @importFrom R.utils gzip
 #' @export
 read_sparray <- function(mtx_fn, sites_fn, bc_fn,
     site_format = c("coordinate", "index")) {
     if (!file.size(sites_fn) > 0) {
         return(SingleCellExperiment::SingleCellExperiment())
     }
 
-    rnames <- data.table::fread(sites_fn,
+    rnames <- read.table(sites_fn,
         sep = "\t",
         col.names = c(
             "index", "seqnames", "start",
@@ -380,7 +379,7 @@ read_sparray <- function(mtx_fn, sites_fn, bc_fn,
             "integer", "character", "integer",
             "integer", "character", "character"
         ),
-        data.table = FALSE
+        row.names = NULL
     )
     site_format <- match.arg(site_format)
 
@@ -404,7 +403,7 @@ read_sparray <- function(mtx_fn, sites_fn, bc_fn,
     n_sp_cols <- 2 + length(sp_mtx_names)
 
     if (file.size(mtx_fn) > 0) {
-        dt <- data.table::fread(mtx_fn,
+        dt <- read.table(mtx_fn,
             sep = " ",
             colClasses = "integer",
             skip = n_skip,
@@ -443,6 +442,7 @@ read_sparray <- function(mtx_fn, sites_fn, bc_fn,
     res
 }
 
+#' @importFrom utils write.table
 write_sparray <- function(sce, mtx_fn, sites_fn, bc_fn) {
     if (!all(c("nRef", "nAlt") %in% assayNames(sce))) {
         cli::cli_abort("missing required asssays nRef or nAlt")
@@ -464,27 +464,27 @@ write_sparray <- function(sce, mtx_fn, sites_fn, bc_fn) {
     if (!conforms) {
         cli::cli_abort("nRef and nAlt sparseMatrices triplet dimensions differ")
     }
-
+    mtx_fn <- gzfile(mtx_fn, 'w')
     writeLines(
         c(
             "%%% raer MatrixMarket-like matrix coordinate integer general",
             paste("%%% ", nref@Dim[1], nref@Dim[2], length(nref@x)),
             "%%% x y nRef nAlt"
         ),
-        gzfile(mtx_fn)
+        mtx_fn
     )
 
-    mtx <- matrix(0L, nrow = dim(nref_trpl)[1], ncol = 4L)
     mtx <- cbind(nref_trpl, nalt = nalt_trpl$x)
 
-    data.table::fwrite(mtx, mtx_fn,
-        append = TRUE,
+    write.table(mtx, 
+                mtx_fn,
         sep = " ",
         row.names = FALSE,
         col.names = FALSE,
-        showProgress = FALSE
+        quote = FALSE
     )
-
+    close(mtx_fn)
+
     sites <- data.frame(
         seq_along(sce),
         seqnames(sce),
@@ -494,11 +494,11 @@ write_sparray <- function(sce, mtx_fn, sites_fn, bc_fn) {
         rowData(sce)$ALT
     )
 
-    data.table::fwrite(sites, sites_fn,
+    write.table(sites,
+        gzfile(sites_fn),
         sep = "\t",
         row.names = FALSE,
-        col.names = FALSE,
-        showProgress = FALSE
+        col.names = FALSE
     )
 
     writeLines(colnames(sce), gzfile(bc_fn))

src/plp.c

@@ -136,7 +136,7 @@ static void clear_pall_counts(pall_counts* p) {
 /*! @function
  @abstract  allocate data
  */
-static pall_counts* init_pall_counts() {
+static pall_counts* init_pall_counts(void) {
     pall_counts* pall = R_Calloc(1, pall_counts);
     pall->p_ref_pos   = R_Calloc(NBASE_POS, int);
     pall->p_alt_pos   = R_Calloc(NBASE_POS, int);

src/plp_data.c

@@ -318,7 +318,7 @@ SEXP pileup_result_init(int n) {
 
 
 /* inner list template */
-SEXP pileup_template() {
+SEXP pileup_template(void) {
 
   SEXP tmpl = PROTECT(NEW_LIST(N_TMPL_ELTS));
   SET_VECTOR_ELT(tmpl, SEQNAME_IDX, NEW_CHARACTER(0));
@@ -344,7 +344,7 @@ SEXP pileup_template() {
 }
 
 /* site data template, data stored across all bamfiles */
-SEXP sitedata_template() {
+SEXP sitedata_template(void) {
   int nout = 3;
   SEXP tmpl = PROTECT(NEW_LIST(nout));
   SET_VECTOR_ELT(tmpl, 0, NEW_NUMERIC(0));

src/plp_utils.c

@@ -7,7 +7,7 @@
 void chkIntFn(void* dummy) {
   R_CheckUserInterrupt();
 }
-int checkInterrupt() {
+int checkInterrupt(void) {
   return (R_ToplevelExec(chkIntFn, NULL) == FALSE);
 }
 
@@ -23,7 +23,7 @@ SEXP get_region(SEXP region) {
   const char* chr_pos ;
   chr_pos = hts_parse_reg(cregion, &beg, &end) ;
   if (!chr_pos) {
-    Rf_error("could not parse region:%s", region);
+    Rf_error("could not parse region:%s", cregion);
   }
   char* chr_name = (char*) malloc(chr_pos - cregion + 1);
   memcpy(chr_name, cregion, chr_pos - cregion);

src/regfile.c

@@ -4,25 +4,16 @@
 
 static inline void free_regidx(void* payload) {
   payload_t* pld = *((payload_t**)payload);
-  if (pld->alt) R_Free(pld->alt); 
-  if (pld->ref) R_Free(pld->ref);
-  R_Free(pld);
+  if (pld->alt) free(pld->alt); 
+  if (pld->ref) free(pld->ref);
+  free(pld);
 }
 
-// use R memory handling for strdup
-static inline char * rstrdup(const char *x) {
-    char *buf;
-    size_t l = strlen(x) + 1;
-    buf = R_Calloc(l, char);
-    strcpy(buf, x);
-    return buf;
-} 
-
 static void load_payload(payload_t* pld, int strand, char* ref,
                          char* alt, int rowidx) {
   pld->strand = strand;
-  pld->alt = rstrdup(alt);
-  pld->ref = rstrdup(ref);
+  pld->alt = strdup(alt);
+  pld->ref = strdup(ref);
   pld->idx = rowidx;
 }
 
@@ -39,12 +30,14 @@ static regidx_t* regidx_load_payload(char** chroms, int* pos, int* strand,
   payload_t* pld;
   for (i = 0; i < n_sites; ++i) {
     chr_beg = chroms[i];
-    // use R memory management to avoid memory leak if index build has an error
-    pld = (payload_t*) R_Calloc(1, payload_t);
+    pld = (payload_t*) calloc(1, sizeof(payload_t));
     load_payload(pld, strand[i], ref[i], alt[i], rowidx[i]);
     hts_pos_t p = (hts_pos_t) pos[i] - 1; // convert 1 to 0 based
     ret = regidx_push(idx, chr_beg, chr_beg + strlen(chr_beg) - 1, p, p, &pld);
-    if (ret < 0) Rf_error("[raer internal] index push failed\n");
+    if (ret < 0) {
+        if(idx) regidx_destroy(idx);
+        Rf_error("[raer internal] index push failed\n");
+    }
   }
   return idx;
 }
@@ -61,7 +54,10 @@ static regidx_t* regidx_load_simple(char** chroms, int* start, int* end, int n_s
     hts_pos_t s = (hts_pos_t) start[i] - 1; // convert to 0 based
     hts_pos_t e = (hts_pos_t) end[i] - 1; // inclusive
     ret = regidx_push(idx, chr_beg, chr_beg + strlen(chr_beg) - 1, s, e, NULL);
-    if (ret < 0) Rf_error("[raer internal] index push failed\n");
+    if (ret < 0) {
+        if(idx) regidx_destroy(idx);
+        Rf_error("[raer internal] index push failed\n");
+    }
   }
   return idx;
 }

src/sc-plp.c

@@ -86,7 +86,7 @@ static void clear_cb_umiset(cbumi_map_t cbhash) {
 /*! @function
  @abstract  initialize cb_t stuct and umimap_t hashmap
  */
-static cb_t* init_umihash() {
+static cb_t* init_umihash(void) {
   cb_t* cb = calloc(1, sizeof(cb_t));
   cb->umi = kh_init(umimap);
   return cb ;

tests/testthat/test_aei.R

@@ -1,4 +1,4 @@
-pkgs <- c("Rsamtools", "data.table", "Biostrings")
+pkgs <- c("Rsamtools", "Biostrings")
 msg <- lapply(pkgs, function(x) {
     suppressPackageStartupMessages(library(x, character.only = TRUE))
 })
@@ -29,13 +29,17 @@ test_that("calc_aei basic options work", {
     expect_true(ag_aei["wt"] > ag_aei["ko"])
 
     x <- aei$AEI_per_chrom
-    setDT(x)
-    pc_aei <- x[, 100 * (sum(alt) / sum(alt + ref)), by = .(allele, bam_file)]
-    pc_aei <- dcast(pc_aei, bam_file ~ allele, value.var = "V1")
-    pc_aei <- as.data.frame(pc_aei)
-    rownames(pc_aei) <- pc_aei$bam_file
-    pc_aei$bam_file <- NULL
-    expect_true(identical(pc_aei, as.data.frame(aei$AEI)))
+    xx <- lapply(split(x, ~ allele + bam_file), function(x) {
+        xx <- 100 * (sum(x$alt) / sum(x$alt + x$ref))
+        data.frame(allele = unique(x$allele),
+                   bam_file = unique(x$bam_file),
+                   total = xx)
+    }) |> do.call(rbind, args = _)
+    xx <- reshape(xx, idvar = c("bam_file"), v.names = "total", timevar = "allele", direction = "wide")
+    rownames(xx) <- xx$bam_file
+    xx$bam_file <- NULL
+    colnames(xx) <- sub("total.", "", colnames(xx))
+    expect_true(identical(data.frame(xx), as.data.frame(aei$AEI)))
 
     aei <- calc_AEI(unname(bams), fafn, mock_alu_ranges)
     expect_true(all(rownames(aei$AEI) == unname(bams)))