diff w4mcorcov_input.R @ 0:23f9fad4edfc draft

planemo upload for repository https://github.com/HegemanLab/w4mcorcov_galaxy_wrapper/tree/master commit bd26542b811de06c1a877337a2840a9f899c2b94

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/w4mcorcov_input.R	Mon Oct 16 14:56:52 2017 -0400
@@ -0,0 +1,201 @@
+# read_data_frame - read a w4m data frame, with error handling
+#   e.g., data_matrix_input_env <- read_data_frame(dataMatrix_in, "data matrix input")
+read_data_frame <- function(file_path, kind_string, failure_action = failure_action) {
+  my.env <- new.env()
+  my.env$success <- FALSE
+  my.env$msg <- sprintf("no message reading %s", kind_string)
+  tryCatch(
+    expr = {
+      my.env$data    <- utils::read.delim( fill = FALSE, file = file_path )
+      my.env$success <- TRUE
+    }
+  , error = function(e) {
+     my.env$ msg <- sprintf("%s read failed", kind_string)
+    }
+  )
+  if (!my.env$success) {
+    failure_action(my.env$msg)
+    return ( FALSE )
+  }
+  return (my.env)
+}
+
+# read one of three XCMS data elements: dataMatrix, sampleMetadata, variableMetadata
+# returns respectively: matrix, data.frame, data.frame, or FALSE if there is a failure
+read_xcms_data_element <- function(xcms_data_in, xcms_data_type, failure_action = stop) {
+  # note that 'stop' effectively means 'throw'; if 'warning' and 'message' are caught, they mean 'throw' as well
+  my_failure_action <- function(...) { failure_action("read_xcms_data_element: ", ...) }
+  # xcms_data_type must be in c("sampleMetadata", "variableMetadata", "dataMatrix")
+  if ( ! is.character(xcms_data_type) ) {
+    my_failure_action(sprintf("bad parameter xcms_data_type '%s'", deparse(xcms_data_type)))
+    return ( FALSE )
+  }
+  if ( 1 != length(xcms_data_type)
+       || ! ( xcms_data_type %in% c("sampleMetadata", "variableMetadata", "dataMatrix") ) 
+  ) {
+    my_failure_action( sprintf("bad parameter xcms_data_type '%s'", xcms_data_type) )
+    return ( FALSE )
+  }
+  if ( is.character(xcms_data_in) ){
+    # case: xcms_data_in is a path to a file
+    xcms_data_input_env <- read_data_frame( xcms_data_in, sprintf("%s input", xcms_data_type) )
+    if (!xcms_data_input_env$success) {
+      my_failure_action(xcms_data_input_env$msg)
+      return ( FALSE )
+    }
+    return ( xcms_data_input_env$data )
+    # commenting out pasted code that is not tested here
+    # } else if ( is.data.frame(xcms_data_in) || is.matrix(xcms_data_in) ) {
+    #   # case: xcms_data_in is a data.frame or matrix
+    #   return(xcms_data_in)
+    # } else if ( is.list(xcms_data_in) || is.environment(xcms_data_in) ) {
+    #   # NOTE WELL: is.list succeeds for data.frame, so the is.data.frame test must appear before the is.list test
+    #   # case: xcms_data_in is a list
+    #   if ( ! exists(xcms_data_type, where = xcms_data_in) ) {
+    #     my_failure_action(sprintf("%s xcms_data_in is missing member '%s'"), ifelse(is.environment(xcms_data_in),"environment","list"), xcms_data_type)
+    #     return ( FALSE )
+    #   }
+    #   prospect <- getElement(name = xcms_data_type, object = xcms_data_in)
+    #   if ( ! is.data.frame(prospect) && ! is.matrix(prospect) ) {
+    #     utils::str("list - str(prospect)")
+    #     utils::str(prospect)
+    #     if ( is.list(xcms_data_in) ) {
+    #       my_failure_action(sprintf("the first member of xcms_data_in['%s'] is neither a data.frame nor a matrix but is a %s", xcms_data_type, typeof(prospect)))
+    #     } else {
+    #       my_failure_action(sprintf("the first member of xcms_data_in$%s is neither a data.frame nor a matrix but is a %s", xcms_data_type, typeof(prospect)))
+    #     }
+    #     return ( prospect )
+    #   }
+    #   # stop("stopping here for a snapshot")
+    #   return ( prospect ) 
+  } else {
+    # case: xcms_data_in is invalid
+    my_failure_action( sprintf("xcms_data_in has unexpected type %s", typeof(xcms_data_in)) )
+    return ( FALSE )
+  }
+}
+
+read_inputs <- function(input_env, failure_action = print) {
+  if ( ! is.environment(input_env) ) {
+    failure_action("read_inputs: fatal error - 'input_env' is not an environment")
+    return ( FALSE )
+  }
+
+  if (!is.null(sampleMetadata_in <- input_env$sampleMetadata_in)) {
+    # ---
+    # read in the sample metadata
+    read_data_result <- tryCatchFunc(
+      expr = {
+        read_xcms_data_element(xcms_data_in = sampleMetadata_in, xcms_data_type = "sampleMetadata")
+      }
+    )
+    if ( read_data_result$success ) {
+      smpl_metadata <- read_data_result$value
+    } else {
+      failure_action(read_data_result$msg)
+      return ( FALSE )
+    }
+
+    # extract rownames
+    rownames(smpl_metadata) <- smpl_metadata[,1]
+    
+    input_env$smpl_metadata <- smpl_metadata
+    # ...
+  } else {
+    failure_action("read_inputs: fatal error - 'sampleMetadata_in' is missing from 'input_env'")
+    return ( FALSE )
+  }
+
+  if (!is.null(variableMetadata_in <- input_env$variableMetadata_in)) {
+    # ---
+    # read in the variable metadata
+    read_data_result <- tryCatchFunc(
+      expr = {
+        read_xcms_data_element(xcms_data_in = variableMetadata_in, xcms_data_type = "variableMetadata")
+      }
+    )
+    if ( read_data_result$success ) {
+      vrbl_metadata <- read_data_result$value
+    } else {
+      failure_action(read_data_result$msg)
+      return (FALSE)
+    }
+    
+
+    # extract rownames (using make.names to handle degenerate feature names)
+    err.env <- new.env()
+    err.env$success <- FALSE
+    err.env$msg <- "no message setting vrbl_metadata rownames"
+    tryCatch(
+      expr = {
+        rownames(vrbl_metadata) <- make.names( vrbl_metadata[,1], unique = TRUE )
+        vrbl_metadata[,1] <- rownames(vrbl_metadata)
+        err.env$success     <- TRUE
+      }
+    , error = function(e) {
+       err.env$ msg <- sprintf("failed to set rownames for vrbl_metadata read because '%s'", e$message) 
+      }
+    )
+    if (!err.env$success) {
+      failure_action(err.env$msg)
+      return ( FALSE )
+    }
+
+    input_env$vrbl_metadata <- vrbl_metadata
+    # ...
+  } else {
+    failure_action("read_inputs: fatal error - 'variableMetadata_in' is missing from 'input_env'")
+    return ( FALSE )
+  }
+
+  if (!is.null(dataMatrix_in <- input_env$dataMatrix_in)) {
+    # ---
+    # read in the data matrix
+    read_data_result <- tryCatchFunc(
+      expr = {
+        read_xcms_data_element(xcms_data_in = dataMatrix_in, xcms_data_type = "dataMatrix")
+      }
+    )
+    if ( read_data_result$success ) {
+      data_matrix <- read_data_result$value
+    } else {
+      failure_action(read_data_result$msg)
+      return (FALSE)
+    }
+
+    if ( ! is.matrix(data_matrix) ) {
+      # extract rownames (using make.names to handle degenerate feature names)
+      err.env <- new.env()
+      err.env$success <- FALSE
+      err.env$msg <- "no message setting data_matrix rownames"
+      tryCatch(
+        expr = {
+          rownames(data_matrix) <- make.names( data_matrix[,1], unique = TRUE )
+          err.env$success     <- TRUE
+        }
+      , error = function(e) {
+         err.env$msg <- sprintf("failed to set rownames for data_matrix read because '%s'", e$message) 
+        }
+      )
+      if (!err.env$success) {
+        failure_action(err.env$msg)
+        return ( FALSE )
+      }
+
+      # remove rownames column
+      data_matrix <- data_matrix[,2:ncol(data_matrix)]
+
+      # convert data_matrix to matrix from data.frame
+      data_matrix <- as.matrix(data_matrix)
+    }
+
+    input_env$data_matrix <- data_matrix
+    # ...
+  } else {
+    failure_action("read_inputs: fatal error - 'dataMatrix_in' is missing from 'input_env'")
+    return ( FALSE )
+  }
+
+  return ( TRUE )
+}
+