comparison w4m_general_purpose_routines.R @ 2:c415b7dc6f37 draft default tip

planemo upload for repository https://github.com/HegemanLab/w4mkmeans_galaxy_wrapper/tree/master commit 3e916537da6bb37e6f3927d7a11e98e0ab6ef5ec

1:02cafb660b72

# prepare.data.matrix - Prepare x.datamatrix for multivariate statistical analaysis (MVA)
#   - Motivation:
#     - Selection:
#       - You may want to exclude several samples from your analysis:
#         - If so, set the argument 'exclude.samples' to a vector of sample names
#       - You may want to exclude several features or features from your analysis:
#         - If so, set the argument 'exclude.features' to a vector of feature names
#     - Renaming samples:
#       - You may want to rename several samples from your analysis:
#         - If so, set the argument 'sample.rename.function' to a function accepting a vector 
#           of sample names and producing a vector of strings of equivalent length
#     - MVA is confounded by missing values.
#       - By default, this function imputes missing values as zero.
#       - For a different imputation, set the 'data.imputation' argument to a function
#         accepting a single matrix argument and returning  a matrix of the same

#     - Transformation
#       - It may be desirable to transform the intensity data to reduce the range.
#       - By default, this function performs an eigth-root transformation:
#         - Any root-tranformation has the advantage of never being negative.
#         - Calculation of the eight-root is four times faster in my hands than log10.
#         - However, it has the disadvantage that calculation of fold-differences 
#           is not additive as with log-transformation.
#           - Rather, you must divide the values and raise to the eighth power.
#       - For a different transformation, set the 'data.transformation' argument
#           to a function accepting a single matrix argument.
#         - The function should be written to return a matrix of the same dimensions

, data.transformation = function(x) {
    sqrt( sqrt( sqrt(x) ) )
  }
, en = new.env()
) {
  # MatVar - Compute variance of rows or columns of a matrix
  # ref: http://stackoverflow.com/a/25100036
  # For row variance, dim == 1, for col variance, dim == 2
  MatVar <- function(x, dim = 1) {
    if (dim == 1) {

    } else stop("Please enter valid dimension, for rows, dim = 1; for colums, dim = 2")
  }

  nonzero.var <- function(x) {
    if (nrow(x) == 0) {
      print(str(x))
      stop("matrix has no rows")
    }
    if (ncol(x) == 0) {
      print(str(x))
      stop("matrix has no columns")
    }
    if ( is.numeric(x) ) {
      # exclude any rows with zero variance
      row.vars <- MatVar(x, dim = 1)

      nonzero.rows <- row.vars[nonzero.row.vars]
      if ( length(rownames(x)) != length(rownames(nonzero.rows)) ) {
        row.names <- attr(nonzero.rows,"names")
        x <- x[ row.names, , drop = FALSE ]
      }
      
      # exclude any columns with zero variance
      column.vars <- MatVar(x, dim = 2)
      nonzero.column.vars <- column.vars > 0
      nonzero.columns <- column.vars[nonzero.column.vars]
      if ( length(colnames(x)) != length(colnames(nonzero.columns)) ) {

  if (is.null(x.matrix)) {
    stop("FATAL ERROR - prepare.data.matrix was called with null x.matrix")
  }

  en$xpre <- x <- x.matrix

  # exclude any samples as indicated
  if ( !is.null(exclude.features) ) {
    my.colnames <- colnames(x)
    my.col.diff <- setdiff(my.colnames, exclude.features)
    x <- x[ , my.col.diff , drop = FALSE ]
  }

  # exclude any features as indicated
  if ( !is.null(exclude.samples) ) {
    my.rownames <- rownames(x)
    my.row.diff <- setdiff(my.rownames, exclude.samples)
    x <- x[ my.row.diff, , drop = FALSE ]
  }

  # rename rows if desired
  if ( !is.null(sample.rename.function) ) {
    renamed <- sample.rename.function(x)
    rownames(x) <- renamed
  }

  # save redacted x.datamatrix to environment
  en$redacted.data.matrix <- x

  # impute values missing from the x.datamatrix
  if ( !is.null(data.imputation) ) {
    x <- data.imputation(x)
  }

  # perform transformation if desired
  if ( !is.null(data.transformation) ) {
    x <- data.transformation(x)
  } else {
    x <- x
  }

  # purge rows and columns that have zero variance
  if ( is.numeric(x) ) {
    x <- nonzero.var(x)
  }

  # save imputed, transformed x.datamatrix to environment
  en$imputed.transformed.data.matrix <- x

  return(x)
}


##-----------------------------------------------
## helper functions for error detection/reporting
##-----------------------------------------------

# log-printing to stderr
log_print <- function(x, ...) { 
  cat(
    format(Sys.time(), "%Y-%m-%dT%H:%M:%S%z")
  , " "
  , c(x, ...)
  , "\n"
  , sep=""
  , file=stderr()
  )
}

# tryCatchFunc produces a list
#   On success of expr(), tryCatchFunc produces
#     list(success TRUE, value = expr(), msg = "")
#   On failure of expr(), tryCatchFunc produces
#     list(success = FALSE, value = NA, msg = "the error message")
tryCatchFunc <- function(expr) {
  # format error for logging
  format_error <- function(e) {
    paste(c("Error { message:", e$message, ", call:", e$call, "}"), collapse = " ")
  }
  my_expr <- expr
  retval <- NULL
  tryCatch(
    expr = {
      retval <- ( list( success = TRUE, value = my_expr(), msg = "" ) )
    }
  , error = function(e) {
      retval <<- list( success = FALSE, value = NA, msg = format_error(e) )
    }
  )
  return (retval)
}

# tryCatchProc produces a list
#   On success of expr(), tryCatchProc produces
#     list(success TRUE, msg = "")
#   On failure of expr(), tryCatchProc produces
#     list(success = FALSE, msg = "the error message")
tryCatchProc <- function(expr) {
  # format error for logging
  format_error <- function(e) {
    paste(c("Error { message:", e$message, ", call:", e$call, "}"), collapse = " ")
  }
  retval <- NULL
  tryCatch(
    expr = {
      expr()
      retval <- ( list( success = TRUE, msg = "" ) )
    }
  , error = function(e) {
      retval <<- list( success = FALSE, msg = format_error(e) )
    }
  )
  return (retval)
}

2:c415b7dc6f37

##-----------------------------------------------
## helper functions for error detection/reporting
##-----------------------------------------------

# ISO 8601 date ref: https://en.wikipedia.org/wiki/ISO_8601
iso_date <- function() {
  format(Sys.time(), "%Y-%m-%dT%H:%M:%S%z")
}

# log-printing to stderr
log_print <- function(x, ...) {
  cat(
    sep=""
  , file=stderr()
  , iso_date()
  , " "
  , c(x, ...)
  , "\n"
  )
}

# format error for logging
format_error <- function(e) {
  paste(c("Error { message:", e$message, ", call:", e$call, "}"), collapse = " ")
}

# tryCatchFunc produces a list
#   func - a function that takes no arguments
#   On success of func(), tryCatchFunc produces
#     list(success = TRUE, value = func(), msg = "")
#   On failure of func(), tryCatchFunc produces
#     list(success = FALSE, value = NA, msg = "the error message")
tryCatchFunc <- function(func) {
  retval <- NULL
  tryCatch(
    expr = {
      retval <- ( list( success = TRUE, value = func(), msg = "" ) )
    }
  , error = function(e) {
      retval <<- list( success = FALSE, value = NA, msg = format_error(e) )
    }
  )
  return (retval)
}

# prepare.data.matrix - Prepare x.datamatrix for multivariate statistical analaysis (MVA)
#   - Motivation:
#     - Selection:
#       - You may want to exclude several samples from your analysis:
#         - If so, set the argument 'exclude.samples' to a vector of sample names
#       - You may want to exclude several features or features from your analysis:
#         - If so, set the argument 'exclude.features' to a vector of feature names
#     - Renaming samples:
#       - You may want to rename several samples from your analysis:
#         - If so, set the argument 'sample.rename.function' to a function accepting a vector
#           of sample names and producing a vector of strings of equivalent length
#     - MVA is confounded by missing values.
#       - By default, this function imputes missing values as zero.
#       - For a different imputation, set the 'data.imputation' argument to a function
#         accepting a single matrix argument and returning  a matrix of the same

#     - Transformation
#       - It may be desirable to transform the intensity data to reduce the range.
#       - By default, this function performs an eigth-root transformation:
#         - Any root-tranformation has the advantage of never being negative.
#         - Calculation of the eight-root is four times faster in my hands than log10.
#         - However, it has the disadvantage that calculation of fold-differences
#           is not additive as with log-transformation.
#           - Rather, you must divide the values and raise to the eighth power.
#       - For a different transformation, set the 'data.transformation' argument
#           to a function accepting a single matrix argument.
#         - The function should be written to return a matrix of the same dimensions

, data.transformation = function(x) {
    sqrt( sqrt( sqrt(x) ) )
  }
, en = new.env()
) {
  # log to environment
  if ( !exists("log", envir = en) ) {
    en$log <- c()
  }
  enlog <- function(s) { en$log <- c(en$log, s); s }
  #enlog("foo")

  # MatVar - Compute variance of rows or columns of a matrix
  # ref: http://stackoverflow.com/a/25100036
  # For row variance, dim == 1, for col variance, dim == 2
  MatVar <- function(x, dim = 1) {
    if (dim == 1) {

    } else stop("Please enter valid dimension, for rows, dim = 1; for colums, dim = 2")
  }

  nonzero.var <- function(x) {
    if (nrow(x) == 0) {
      stop("matrix has no rows")
    }
    if (ncol(x) == 0) {
      stop("matrix has no columns")
    }
    if ( is.numeric(x) ) {
      # exclude any rows with zero variance
      row.vars <- MatVar(x, dim = 1)

      nonzero.rows <- row.vars[nonzero.row.vars]
      if ( length(rownames(x)) != length(rownames(nonzero.rows)) ) {
        row.names <- attr(nonzero.rows,"names")
        x <- x[ row.names, , drop = FALSE ]
      }

      # exclude any columns with zero variance
      column.vars <- MatVar(x, dim = 2)
      nonzero.column.vars <- column.vars > 0
      nonzero.columns <- column.vars[nonzero.column.vars]
      if ( length(colnames(x)) != length(colnames(nonzero.columns)) ) {

  if (is.null(x.matrix)) {
    stop("FATAL ERROR - prepare.data.matrix was called with null x.matrix")
  }

  enlog("prepare.data.matrix - get matrix")

  en$xpre <- x <- x.matrix

  # exclude any samples as indicated
  if ( !is.null(exclude.features) ) {
    enlog("prepare.data.matrix - exclude any samples as indicated")
    my.colnames <- colnames(x)
    my.col.diff <- setdiff(my.colnames, exclude.features)
    x <- x[ , my.col.diff , drop = FALSE ]
  }

  # exclude any features as indicated
  if ( !is.null(exclude.samples) ) {
    enlog("prepare.data.matrix - exclude any features as indicated")
    my.rownames <- rownames(x)
    my.row.diff <- setdiff(my.rownames, exclude.samples)
    x <- x[ my.row.diff, , drop = FALSE ]
  }

  # rename rows if desired
  if ( !is.null(sample.rename.function) ) {
    enlog("prepare.data.matrix - rename rows if desired")
    renamed <- sample.rename.function(x)
    rownames(x) <- renamed
  }

  enlog("prepare.data.matrix - save redacted x.datamatrix to environment")

  # save redacted x.datamatrix to environment
  en$redacted.data.matrix <- x

  # impute values missing from the x.datamatrix
  if ( !is.null(data.imputation) ) {
    enlog("prepare.data.matrix - impute values missing from the x.datamatrix")
    x <- data.imputation(x)
  }

  # perform transformation if desired
  if ( !is.null(data.transformation) ) {
    enlog("prepare.data.matrix - perform transformation")
    x <- data.transformation(x)
  } else {
    x <- x
  }

  # purge rows and columns that have zero variance
  if ( is.numeric(x) ) {
    enlog("prepare.data.matrix - purge rows and columns that have zero variance")
    x <- nonzero.var(x)
  }

  # save imputed, transformed x.datamatrix to environment
  en$imputed.transformed.data.matrix <- x

  return(x)
}

# vim: sw=2 ts=2 et :