v0.5.2 improvements to reshape_peaktable

* Added `metadata` argument to `reshape_peaktable` for filtering metadata fields.
* Added option to for renaming peaks via `reshape_peaktable` by providing a named list.

Author: ethanbass

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: chromatographR
 Title: Chromatographic Data Analysis Toolset
-Version: 0.5.1
+Version: 0.5.2
 Authors@R: c(
     person("Ethan", "Bass", , "[email protected]", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0002-6175-6739")),

NEWS.md

@@ -1,3 +1,8 @@
+# chromatographR 0.5.2
+
+* Added `metadata` argument to `reshape_peaktable` for filtering metadata fields.
+* Added option to for renaming peaks via `reshape_peaktable` by providing a named list.
+
 # chromatographR 0.5.1
 
 * In `plot_chroms`, `show_legend` now defaults to FALSE to prevent overloading of the plot.

R/correct_rt.R

@@ -191,17 +191,18 @@ correct_rt <- function(chrom_list, lambdas, models = NULL, reference = 'best',
         })
       })
         # fix times
-        old_ts <- c(rep(NA,short), get_times(chrom_list_og, index = reference))
+        old_ts <- c(rep(NA, short), get_times(chrom_list_og, index = reference))
         times <- suppressWarnings(stats::approx(x = jset[,reference],
                                                 y = old_ts, 1:jmax)$y)
         idx_start <- which.min(times)
         if (idx_start > 1){
-          beg <- sort(seq(from = times[idx_start]-res, by = -res, length.out = idx_start-1),
-                    decreasing = FALSE)
+          beg <- sort(seq(from = times[idx_start] - res, by = -res,
+                          length.out = idx_start - 1), decreasing = FALSE)
         } else beg <- NULL
         idx_end <- which.max(times)
         if (idx_end < length(times)){
-          end <- seq(from = times[idx_end]+res, length.out = length(times) - idx_end, by = res)
+          end <- seq(from = times[idx_end] + res,
+                     length.out = length(times) - idx_end, by = res)
         } else end <- NULL
         new.times <- c(beg, times[!is.na(times)], end)
         result <- mapply(function(x,idx){
@@ -248,16 +249,15 @@ correct_rt <- function(chrom_list, lambdas, models = NULL, reference = 'best',
 #' @export correct_peaks
 correct_peaks <- function(peak_list, mod_list){
   mapply(function(samp, mod){
-    lapply(samp,
-           function(profile){
-             if (nrow(profile) > 0) {
+    lapply(samp, function(profile){
+             if (nrow(profile) > 0){
                cbind(profile,
                      rt.cor = c(predict(mod, profile[,1], what = "time")))
              } else {
                cbind(profile, rt.cor = rep(0, 0))
              }
-           })},
-    peak_list, mod_list, SIMPLIFY = FALSE)
+           }
+        )}, peak_list, mod_list, SIMPLIFY = FALSE)
 }
 
 #' Plot PTW alignments
@@ -278,29 +278,33 @@ plot.ptw_list <- function(x, lambdas, legend = TRUE, ...){
   ts <- as.numeric(colnames(x[[1]]$sample))
 
   if (missing(lambdas)){
-    lambdas<-all.lambdas
+    lambdas <- all.lambdas
   }
   if (any(!(lambdas %in% all.lambdas))){
     stop("Lambdas not found. Please check argument and try again")
   }
 
   lambda.idx <- which(lambdas %in% all.lambdas)
-  
+  # plot warped samples
   plot.new()
   plot.window(xlim=c(head(ts,1), tail(ts,1)),
-              ylim=c(0, max(sapply(x, function(xx) xx$warped.sample), na.rm=TRUE)*1.2))
+              ylim=c(0, max(sapply(x, function(xx) xx$warped.sample), na.rm = TRUE)*1.2))
   for (i in seq_along(x)){
-    matplot(ts, t(x[[i]]$warped.sample[lambda.idx,, drop=FALSE]), type='l',add=TRUE)
+    matplot(ts, t(x[[i]]$warped.sample[lambda.idx, , drop = FALSE]),
+            type = 'l', add = TRUE)
   }
-  if (legend)
-    legend("topright", legend="ptw", bty = "n")
-  
+  if (legend){
+    legend("topright", legend = "ptw", bty = "n")
+  }
+  # plot reference
   plot.new()
-  plot.window(xlim=c(head(ts,1),tail(ts,1)),
-              ylim=c(0, max(x[[i]]$reference, na.rm = TRUE)*1.2))
+  plot.window(xlim = c(head(ts,1), tail(ts,1)),
+              ylim = c(0, max(x[[i]]$reference, na.rm = TRUE)*1.2))
   for (i in seq_along(x)){
-    matplot(ts, t(x[[i]]$sample[lambda.idx,, drop=FALSE]), type='l', add=TRUE)
+    matplot(ts, t(x[[i]]$sample[lambda.idx, , drop = FALSE]),
+            type = 'l', add = TRUE)
+  }
+  if (legend){
+    legend("topright", legend = "queries", bty = "n")
   }
-  if (legend)
-    legend("topright", legend="queries", bty = "n")
 }

R/filter_peaks.R

@@ -139,9 +139,9 @@ filter_peaktable <- function(peak_table, rts, min_rt, max_rt, min_value, lambda,
   } else (idx.lambda <- seq_along(peak_table$tab))
   idx <- Reduce(intersect, list(idx.rt, idx.val, idx.lambda))
   peak_table$tab <- peak_table$tab[,idx, drop = FALSE]
-  peak_table$pk_meta <- peak_table$pk_meta[,idx, drop = FALSE]
+  peak_table$pk_meta <- peak_table$pk_meta[, idx, drop = FALSE]
   if (inherits(peak_table$ref_spectra, c("data.frame", "matrix"))){
-    peak_table$ref_spectra <- peak_table$ref_spectra[,idx, drop = FALSE]
+    peak_table$ref_spectra <- peak_table$ref_spectra[, idx, drop = FALSE]
   }
   peak_table
 }

R/get_peaktable.R

@@ -89,7 +89,7 @@
 #' get_peaktable(pks, response = "area")
 #' @seealso \code{\link{attach_ref_spectra}} \code{\link{attach_metadata}}
 #' @export get_peaktable
- 
+
 get_peaktable <- function(peak_list, chrom_list, response = c("area", "height"),
                           use.cor = FALSE, hmax = 0.2, plot_it = FALSE,
                           ask = plot_it, clust = c("rt","sp.rt"),

R/reshape_chroms.R

@@ -64,17 +64,26 @@ reshape_chrom <- function(x, lambdas = NULL, rts = NULL){
 #' Reshapes peak table from wide to long format
 #' @name reshape_peaktable
 #' @param x A \code{peak_table} object.
-#' @param peaks A character vector specifying peaks to include.
+#' @param peaks A character vector specifying the peaks to include. If the
+#' character vector is named, the names of the vector elements will be used in
+#' place of the original peak names.
+#' @param metadata A character vector specifying the metadata fields to include.
 #' @return A data.frame containing the information for the specified peaks in
 #' long format.
 #' @author Ethan Bass
 #' @export
 
-reshape_peaktable <- function(x, peaks){
+reshape_peaktable <- function(x, peaks, metadata){
   if (!missing(peaks)){
-    x$tab <- x$tab[,which(colnames(x$tab) %in% peaks), drop=FALSE]
+    x$tab <- x$tab[,which(colnames(x$tab) %in% peaks), drop = FALSE]
+    if (!is.null(names(peaks))){
+      colnames(x$tab) <- names(peaks)
+    }
+  }
+  if (!missing(metadata)){
+    x$sample_meta <- x$sample_meta[,which(colnames(x$sample_meta) %in% metadata), drop = FALSE]
   }
-  xx <- reshape(as.data.frame(chr=rownames(x$tab), x$tab), direction = "long",
+  xx <- reshape(as.data.frame(chr = rownames(x$tab), x$tab), direction = "long",
     varying = list(1:ncol(x$tab)), v.names = x$args[["response"]],
     times = colnames(x$tab), timevar = "peak",
     idvar = "sample", ids = rownames(x$tab))

README.md

@@ -57,5 +57,5 @@ Also see the [contributing.md](https://github.com/ethanbass/chromatographR/blob/
 
 If you use chromatographR in published work, please cite it as follows:
 
-Bass, E. (2023). chromatographR: chromatographic data analysis toolset (version 0.5.1).
+Bass, E. (2023). chromatographR: chromatographic data analysis toolset (version 0.5.2).
 http://doi.org/10.5281/zenodo.6944334

inst/CITATION

@@ -5,11 +5,11 @@ citEntry(
   title    = "chromatographR: chromatographic data analysis toolset",
   author   = "Ethan Bass",
   year     = "2023",
-  note     = "version 0.5.1",
+  note     = "version 0.5.2",
   url      = "https://ethanbass.github.io/chromatographR/",
   doi      = "10.5281/zenodo.6944334",
   textVersion = paste("Bass, E. (2023).",
-        "chromatographR: chromatographic data analysis toolset (version 0.5.1).",
+        "chromatographR: chromatographic data analysis toolset (version 0.5.2).",
         "http://doi.org/10.5281/zenodo.6944334"
         )
   )

man/reshape_peaktable.Rd

@@ -97,7 +97,7 @@ test_that("check_for_pkg functions as expected",{
 
 test_that("reshape_peaktable works as expected",{
   data(pk_tab)
-  pktab_long<-reshape_peaktable(pk_tab)
+  pktab_long <- reshape_peaktable(pk_tab)
   expect_equal(ncol(pktab_long),4)
   expect_equal(nrow(pktab_long), nrow(pk_tab)*ncol(pk_tab))
 })