Merge pull request #13 from EMSL-Computing/develop

Develop

Author: lmbramer

R/assign_class.R

@@ -74,7 +74,8 @@ assign_class <- function(ftmsObj, boundary_set = "bs1", calc_ratios = TRUE){
 
   comp_class = rep(NA, nrow(temp))
   comp_class[forms] = classes
-  class_colname = paste(boundary_set, "_class", sep = "")
+  class_colname = make.unique(c(colnames(ftmsObj$e_meta), paste(boundary_set, "_class", sep = "")))
+  class_colname = class_colname[length(class_colname)]
 
   # add the column to e_meta #
   temp[,class_colname] = comp_class

R/attributes_methods.R

@@ -74,6 +74,32 @@ setGroupDF <- function(ftmsObj, group_df) {
   invisible(ftmsObj)
 }
 
+#' Set the valence_DF attribute
+#' 
+#' Stores a dataframe of various valence combinations in the valence_DF attribute of the ftmsObject 
+#'
+#' @param ftmsObj an object of type ftmsData
+#' @param valences a dataframe with columns C, H, N, O, S, P and values representing valences for each element
+#' @return updated ftmsObj
+#' 
+setDBEValenceDF <- function(ftmsObj, valences) {
+  if (!inherits(ftmsObj, "ftmsData")) {
+    stop("ftmsObj must be of type ftmsData")
+  } 
+  if (!inherits(valences, "data.frame")){
+    stop("valence_DF must be a data frame")
+  }
+  if(!all(colnames(valences) %in% c('C', 'H', 'N', 'O', 'S', 'P'))){
+    stop("valence_DF must have column names: 'C, H, N, O, S, P'")
+  }
+  if(!all(sapply(valences, is.numeric))){
+    stop("valence_DF must have numeric columns")
+  }
+  
+  attr(ftmsObj, "valence_DF") <- valences
+  return(ftmsObj)
+}
+
 #' Get data scale 
 #' 
 #' Get the data scale (e.g. 'abundance', 'pres', 'log2', 'log10', 'log')

R/calc_dbe.R

@@ -3,7 +3,7 @@
 #' Calculate double bond equivalent (DBE) and double bond equivalent minus Oxygen (DBE-O) values for peaks where empirical formula is available
 #' 
 #' @param ftmsObj an object of class 'peakData' or 'compoundData', typically a result of \code{\link{as.peakData}} or \code{\link{mapPeaksToCompounds}}.
-#' @param valences a named list with the valence for each element.  Names must be any of 'C', 'H', 'N', 'O', 'S', 'P'. Values must be integers corresponding to the valence for each element.  Defaults to NULL, in which case the valences that result in the formula given in the details section are used.
+#' @param valences a dataframe with columns giving the valence for each element.  Names must be any of 'C', 'H', 'N', 'O', 'S', 'P'. Values must be integers corresponding to the valence for each element.  Defaults to NULL, in which case the valences that result in the formula given in the details section are used.
 #' 
 #' @details 
 #' \tabular{ll}{
@@ -27,14 +27,13 @@ calc_dbe <- function(ftmsObj, valences = NULL){
 
   # get coefficients that will multiply each elemental count.  Each coefficient is equal to {valence}-2
   if(is.null(valences)){
-    # coefficients that result in the equation given in @details
-    coefs <- list('C' = 2, 'H' = -1, 'N' = 1, 'O' = 0, 'S' = 0, 'P' = 1)
+    coefs <- data.frame('C' = 2, 'H' = -1, 'N' = 1, 'O' = 0, 'S' = 0, 'P' = 1) # coefficients that result in the equation given in @details
   }
   else{
-    cond1 <- inherits(valences, 'list')
-    cond2 <- all(names(valences) %in% c('C', 'H', 'N', 'O', 'S', 'P'))
-    if(!all(cond1, cond2)) stop("argument valences must be a named list of integers with names 'C', 'H', 'N', 'O', 'S', 'P' and values representing the valence for each element.")
-    coefs <- lapply(c('C', 'H', 'N', 'O', 'S', 'P'), function(x) if(!is.null(valences[[x]])) valences[[x]]-2 else 2)
+    if(!inherits(valences, 'data.frame')) stop('valences must be a data frame')
+    if(!all(names(valences) %in% c('C', 'H', 'N', 'O', 'S', 'P'))) stop("valences dataframe must have column names column names 'C', 'H', 'N', 'O', 'S', 'P'")
+    if(!all(sapply(valences, is.numeric)) | any(is.na(rowSums(valences)))) stop('valences dataframe must contain all numeric, nonmissing values')
+    coefs <- lapply(c('C', 'H', 'N', 'O', 'S', 'P'), function(x) if(!is.null(valences[[x]])) valences[[x]]-2 else 0) %>% data.frame()
     names(coefs) <- c('C', 'H', 'N', 'O', 'S', 'P')
   }
 
@@ -49,23 +48,36 @@ calc_dbe <- function(ftmsObj, valences = NULL){
   S_counts = if(getSulfurColName(ftmsObj) %in% colnames(temp)) temp[,getSulfurColName(ftmsObj)] else 0
   P_counts = if(getPhosphorusColName(ftmsObj) %in% colnames(temp)) temp[,getPhosphorusColName(ftmsObj)] else 0
 
-  temp$DBE = 1 + 0.5*(coefs[['C']]*C_counts + coefs[['H']]*H_counts + coefs[['N']]*N_counts + coefs[['O']]*O_counts + coefs[['S']]*S_counts + coefs[['P']]*P_counts)
+  dbe_cols <- NULL
 
-  temp$DBE_O = 1 + 0.5*(2*C_counts - H_counts + N_counts + P_counts) - O_counts
+  for(i in 1:nrow(coefs)){
+    row <- coefs[i,]
+    DBE_id <- make.unique(c(colnames(temp$e_meta), paste0('DBE_', i)))[length(colnames(temp$e_meta)) + 1] #makes DBE_id unique if column already exists
+    dbe_cols <- c(dbe_cols, DBE_id)
+    
+    temp[DBE_id] = 1 + 0.5*(row[['C']]*C_counts + row[['H']]*H_counts + row[['N']]*N_counts + row[['O']]*O_counts + row[['S']]*S_counts + row[['P']]*P_counts)
+  }
+  
+  # reassign valences in case they input one with missing columns and it was fixed in the first if-else statement
+  valences <- coefs + 2
+  rownames(valences) = dbe_cols
 
+  # DBE_O and DBE_AI have fixed valences
+  temp$DBE_O = 1 + 0.5*(2*C_counts - H_counts + N_counts + P_counts) - O_counts
   temp$DBE_AI = 1 + C_counts - O_counts - S_counts - 0.5*(N_counts + P_counts + H_counts)
 
   if(length(which(is.na(temp[,getMFColName(ftmsObj)]))) > 0){
-    temp$DBE[which(is.na(temp[,getMFColName(ftmsObj)]))] = NA
+    temp[which(is.na(temp[,getMFColName(ftmsObj)])), dbe_cols] = NA
     temp$DBE_O[which(is.na(temp[,getMFColName(ftmsObj)]))] = NA
     temp$DBE_AI[which(is.na(temp[,getMFColName(ftmsObj)]))] = NA
   }
-
+  
   ftmsObj$e_meta = temp
 
-  ftmsObj = setDBEColName(ftmsObj, "DBE")
+  ftmsObj = setDBEColName(ftmsObj, dbe_cols)
   ftmsObj = setDBEoColName(ftmsObj, "DBE_O")
   ftmsObj = setDBEAIColName(ftmsObj, "DBE_AI")
+  ftmsObj = setDBEValenceDF(ftmsObj, valences)
 
   return(ftmsObj)
 }

R/colname_methods.R

@@ -601,7 +601,7 @@ getKendrickMassColName <- function(ftmsObj) {
 #' contains Kendrick mass data for Kendrick plots.
 #'
 #' @param ftmsObj an object of type ftmsData
-#' @param cnames column name
+#' @param cnames column names
 #' @return updated ftmsObj
 #' 
 #' 
@@ -637,7 +637,7 @@ getKendrickDefectColName <- function(ftmsObj) {
 #' contains Kendrick defect data for Kendrick plots.
 #'
 #' @param ftmsObj an object of type ftmsData
-#' @param cnames column name
+#' @param cnames column names
 #' @return updated ftmsObj
 #' 
 #' 
@@ -867,7 +867,7 @@ setGibbsColName <- function(ftmsObj, cname) {
 
 #' Get the name of the double-bond equivalent column
 #' 
-#' Gets the name of the column in the e\_meta element that contains double-bond equivalent values
+#' Gets the name of the column in the e_meta element that contains double-bond equivalent values
 #' 
 #' @param ftmsObj an object of type ftmsData
 #' @return name of double-bond equivalent column
@@ -885,18 +885,18 @@ getDBEColName <- function(ftmsObj){
 #' contains double-bond equivalent information.
 #'
 #' @param ftmsObj an object of type ftmsData
-#' @param cname column name
+#' @param cnames column names
 #' @return updated ftmsObj
 #' 
 #' 
-setDBEColName <- function(ftmsObj, cname) {
+setDBEColName <- function(ftmsObj, cnames) {
   if (!inherits(ftmsObj, "ftmsData")) {
     stop("ftmsObj must be of type ftmsData")
   } 
-  if (!(cname %in% names(ftmsObj$e_meta))) {
-    stop(sprintf("Column '%s' is not found in the e_meta data", cname))
+  if (!all(cnames %in% names(ftmsObj$e_meta))) {
+    stop(sprintf("Columns '%s' are not found in the e_meta data", paste(cnames, collapse = ',')))
   }
-  attr(ftmsObj, "cnames")$dbe_cname <- cname
+  attr(ftmsObj, "cnames")$dbe_cname <- cnames
   return(ftmsObj)
 }
 

R/compound_calcs.R

@@ -51,7 +51,7 @@
 #' 
 #' # Specify extra arguments for calc_kendrick and calc_dbe.  
 #' calc_args = list('calc_kendrick' = list('base_compounds' = c('CH2', 'CO2', 'H2')), 
-#'                  'calc_dbe' = list('valences' = list('C'=5, 'H' = 4, 'S' = 5)))
+#'                  'calc_dbe' = list('valences' = data.frame('C'=5, 'H' = 4, 'S' = 5)))
 #' 
 #' peakdata_processed <- compound_calcs(examplePeakData, calc_args = calc_args)
 #' 

R/group_summary_functions.R

@@ -7,15 +7,15 @@
 n_present <- function(x, data_scale) {
   if (data_scale %in% c('pres', 'abundance')) {
     if (identical(dim(x), NULL)) { # vector
-      res <- as.integer(x>0)
+      res <- as.integer(x>0 & !is.na(x))
     } else { # 2-dimensional
-      res <- as.integer(rowSums(x>0))
+      res <- as.integer(rowSums(x>0, na.rm = TRUE))
     }
   } else {
     if (identical(dim(x), NULL)) { # vector
       res <- as.integer(!is.na(x))
     } else { # 2-dimensional
-      res <- as.integer(rowSums(!is.na(x)))
+      res <- as.integer(rowSums(!is.na(x), na.rm = TRUE))
     }
   }
   return(data.frame(n_present=res))

R/kendrickPlot.R

@@ -105,9 +105,6 @@ kendrickPlot <- function(ftmsObj, title=NA, colorPal=NA, colorCName=NA, vkBounda
     colorCName <- "Class"
   }
 
-  xrange <- nice_axis_limits(ftmsObj$e_meta[, km_col])
-  yrange <- nice_axis_limits(ftmsObj$e_meta[, kd_col])
-  
   # if ftmsObj is a comparison summary object, remove all NA rows from e_data/e_meta
   if (inherits(ftmsObj, "comparisonSummary")) {
     ind <- !is.na(dplyr::pull(ftmsObj$e_data, colorCName))
@@ -122,7 +119,7 @@ kendrickPlot <- function(ftmsObj, title=NA, colorPal=NA, colorCName=NA, vkBounda
   ftmsObj$e_meta$Hover <- hovertext
 
   p <- scatterPlot(ftmsObj, km_col, kd_col, colorCName = colorCName, colorPal=colorPal, xlabel=xlabel, ylabel=ylabel,
-                          legendTitle=legendTitle, title=title, xrange=xrange, yrange=yrange, logColorCol=logColorCol, hoverTextCName="Hover")
+                          legendTitle=legendTitle, title=title, logColorCol=logColorCol, hoverTextCName="Hover")
 
   p
 

R/scatterPlot.R

@@ -13,6 +13,7 @@
 #' @param yrange y-axis bounds
 #' @param logColorCol TRUE/FALSE, should the color column be log-transformed? Default is FALSE.
 #' @param hoverTextCName column name for hover (mouseover) text, must be a column of \code{ftmsObj$e_data} or \code{ftmsObj$e_meta}
+#' @param zero.min TRUE/FALSE, if an axis range is not provided, should the automatic range minimum be set to 0?
 #'
 #' @return plotly object
 #' @export
@@ -22,7 +23,7 @@
 #' scatterPlot(exampleProcessedPeakData, "NOSC", "DBE", colorCName="HtoC_ratio", legendTitle="H:C Ratio", title="DBE vs NOSC for exampleProcessedPeakData")
 #' }
 scatterPlot <- function(ftmsObj, xCName, yCName, colorCName=NA, colorPal=NA, xlabel=xCName, ylabel=yCName, 
-                        legendTitle=colorCName, title=NA, xrange=NA, yrange=NA, logColorCol=FALSE, hoverTextCName=NA) {
+                        legendTitle=colorCName, title=NA, xrange=NA, yrange=NA, logColorCol=FALSE, hoverTextCName=NA, zero.min=FALSE) {
 
   if (missing(ftmsObj)) stop("ftmsObj must be provided")
   if (missing(xCName)) stop("xCName must be provided")
@@ -156,10 +157,10 @@ scatterPlot <- function(ftmsObj, xCName, yCName, colorCName=NA, colorPal=NA, xla
   plot_data <- plot_data[!ind.na, ]
 
   if (identical(xrange, NA)) {
-    xrange <- ftmsRanalysis:::nice_axis_limits(plot_data[, xCName])
+    xrange <- ftmsRanalysis:::nice_axis_limits(plot_data[, xCName], zero.min = zero.min)
   }
   if (identical(yrange, NA)) {
-    yrange <- ftmsRanalysis:::nice_axis_limits(plot_data[, yCName])
+    yrange <- ftmsRanalysis:::nice_axis_limits(plot_data[, yCName], zero.min = zero.min)
   }
 
   p <- plotly::plot_ly(plot_data, x=plot_data[,xCName], y=plot_data[,yCName]) 

R/vanKrevelenPlot.R

@@ -90,9 +90,6 @@ vanKrevelenPlot <- function(ftmsObj, title=NA, colorPal=NA, colorCName=NA, vkBou
 
   }
 
-  xrange <- nice_axis_limits(ftmsObj$e_meta[, OC.col], zero.min=TRUE)
-  yrange <- nice_axis_limits(ftmsObj$e_meta[, HC.col], zero.min=TRUE)
-
   # if ftmsObj is a comparison summary object, remove all NA rows from e_data/e_meta
   if (inherits(ftmsObj, "comparisonSummary")) {
     ind <- !is.na(dplyr::pull(ftmsObj$e_data, colorCName))
@@ -107,7 +104,7 @@ vanKrevelenPlot <- function(ftmsObj, title=NA, colorPal=NA, colorCName=NA, vkBou
   ftmsObj$e_meta$Hover <- hovertext
 
   p <- scatterPlot(ftmsObj, OC.col, HC.col, colorCName = colorCName, colorPal=colorPal, xlabel=xlabel, ylabel=ylabel,
-                   legendTitle=legendTitle, title=title, xrange=xrange, yrange=yrange, logColorCol=logColorCol, hoverTextCName="Hover")
+                   legendTitle=legendTitle, title=title, logColorCol=logColorCol, hoverTextCName="Hover", zero.min=TRUE)
 
   if (showVKBounds) {
     if (vk_color_different_than_pts) {