R/zzz.R

In MD-Anderson-Bioinformatics/NGCHM-R: Next Generation Clustered Heat Maps

#' Javascript extensions for the Next Generation Clustered Heat Map (NGCHM) Construction Library
#'
#' Currently:
#' \itemize{
#'   \item Axis function View Ideogram is added for the appropriate axis types.
#' }
#'
#' @seealso [chmGetFunction()]
#' @seealso [chmListFunctions()]
#'
#' @name NGCHM-functions
#' @rdname NGCHM-functions
#' @aliases NGCHM-functions
NULL

ngchm.env <- new.env(parent = emptyenv())
.initNGCHM <- function() {
  # Populate library environment.
  ngchm.env$uuid <- paste(sample(c(letters, 0:9, toupper(letters)), 50, replace = TRUE), collapse = "")
  ngchm.env$scripts <- c()
  ngchm.env$axisFunctions <- NULL
  ngchm.env$matrixFunctions <- NULL
  ngchm.env$typeInfo <- NULL
  ngchm.env$typeMappers <- NULL
  ngchm.env$serverProtocols <- NULL
  ngchm.env$toolbox <- NULL
  ngchm.env$servers <- list()
  ngchm.env$deployServerConfigs <- new.env(parent = emptyenv())
  ngchm.env$parseFns <- new.env(parent = emptyenv())
  ngchm.env$jarCache <- new.env(parent = emptyenv())
  ngchm.env$handledb <- new.env(hash = TRUE, parent = emptyenv())
  ngchm.env$nextId <- 0
  shaidyInit()
  ngchmShaidyInit()
}

#' Specify per-user configuration for a specific deploy Server.
#'
#' @param server An object of class 'chmServer' or a character string specifying the
#' name of the server.
#' @param config A list specifying the configuration to be set for the server.
#'
#' @return None. This function is used for its side effects of setting the deployment server configuration.
#' @export
chmSetDeployServerConfig <- function(server, config) {
  if (is(server, "character")) server <- chmServer(server)
  assign(server@deployServer, config, ngchm.env$deployServerConfigs)
  NULL
}

#' Get per-user configuration for a specific deploy Server.
#'
#' This function retrieves the configuration of a specified NG-CHM
#' (Next-Generation Clustered Heat Map) deployment server.
#'
#' @param server The server for which the configuration is to be retrieved.
#' This can be either a character string representing the server name or an object
#' of class 'ngchmServer'.
#'
#' @export
#'
#' @return The configuration of the specified server if it exists, otherwise NULL.
chmGetDeployServerConfig <- function(server) {
  if (is(server, "character")) server <- chmServer(server)
  if (exists(server@deployServer, ngchm.env$deployServerConfigs)) {
    get(server@deployServer, ngchm.env$deployServerConfigs)
  } else {
    NULL
  }
}


# Get the list of configuration directories.
#
getConfigDirs <- function() {
  configpath <- Sys.getenv("NGCHMCONFIGPATH")
  sep <- if (Sys.info()[["sysname"]] == "Windows") ";" else ":"
  if (nzchar(configpath) == 0) {
    configpath <- paste("/etc/ngchm", "/usr/local/ngchm", "/opt/ngchm",
      file.path(Sys.getenv("HOME"), ".ngchm"),
      sep = sep
    )
  }

  ngchm.env$configdirs <- strsplit(configpath, sep)[[1]]
}

# Remove leading and trailing spaces from s.
#
spstrip <- function(s) {
  sub("^ *", "", sub(" *$", "", s))
}

# Simple Javascript parser for extracting JSDoc components.
# Returns a list of JSDoc components.
# Each JSDoc Component is a list of two fields:
#     tags: a list of JSDoc tag fields
#     src: a string containing Javascript source code.
parseJSDoc <- function(filename, lines) {
  alldocs <- list()

  sources <- c()
  jstags <- list()
  incomment <- FALSE
  inJSDoc <- FALSE
  for (line in lines) {
    if (!inJSDoc) sources <- append(sources, line)
    line <- sub("^  *", "", line)
    while (nchar(line) > 0) {
      if (incomment) {
        if (substr(line, 1, 2) == "*/") {
          line <- substring(line, 3)
          incomment <- FALSE
          inJSDoc <- FALSE
        } else if (inJSDoc && (substr(line, 1, 1) == "@")) {
          line <- substring(line, 2)
          fields <- strsplit(line, " ")[[1]]
          jstags <- append(jstags, list(fields))
          line <- ""
        } else {
          line <- sub("^[*@]*", "", substring(line, 2))
        }
      } else if (substr(line, 1, 2) == "/*") {
        line <- substring(line, 3)
        incomment <- TRUE
        inJSDoc <- FALSE
        if ((nchar(line) > 0) && (substr(line, 1, 1) == "*")) {
          if ((nchar(line) == 1) || (substr(line, 2, 1) != "*")) {
            inJSDoc <- TRUE
            src <- paste(sources[-length(sources)], collapse = "\n")
            if (length(jstags) > 0) {
              alldocs <- append(alldocs, list(list(tags = jstags, src = src)))
            }
            jstags <- list()
            sources <- c()
          }
        }
      } else if (substr(line, 1, 2) == "//") {
        line <- ""
      } else if (substr(line, 1, 1) == "'") {
        tmp <- sub("^'[^']*'", "", line)
        if (line == tmp) stop(sprintf("In Javascript file %s, unterminated string: %s", filename, line))
        line <- tmp
      } else if (substr(line, 1, 1) == '"') {
        tmp <- sub('^"[^"]*"', "", line)
        if (line == tmp) stop(sprintf("In Javascript file %s, unterminated string %s", filename, line))
        line <- tmp
      } else {
        line <- sub("^[^'\"/]*", "", substring(line, 2))
      }
      line <- sub("^  *", "", line)
    }
  }
  if (incomment) {
    stop(sprintf("Encountered EOF while parsing comment in Javascript file '%s'", filename))
  }
  if (length(jstags) > 0) {
    src <- paste(sources, collapse = "\n")
    alldocs <- append(alldocs, list(list(tags = jstags, src = src)))
  }
  return(alldocs)
}

jsTagExists <- function(jsdoc, tag) {
  any(vapply(jsdoc, function(x) x[1] == tag, TRUE))
}

jsGetTag <- function(jsdoc, tag) {
  idx <- which(vapply(jsdoc, function(x) x[1] == tag, TRUE))
  if (length(idx) == 0) stop(sprintf("Required tag '%s' not found in Javascript JSDoc", tag))
  jsdoc[[idx[length(idx)]]]
}

jsGetOptTag <- function(jsdoc, tag) {
  idx <- which(vapply(jsdoc, function(x) x[1] == tag, TRUE))
  if (length(idx) == 0) NULL else jsdoc[[idx[length(idx)]]]
}

# Load a Javascript file.
#
loadJavascript <- function(filename) {
  # Load configuration from text file.
  lines <- NULL
  try(suppressWarnings(lines <- readLines(filename)), silent = TRUE)
  if (length(lines) > 0) {
    jsdocs <- parseJSDoc(filename, lines)
    for (jsdoc in jsdocs) {
      jsTags <- jsdoc$tags
      if (jsTagExists(jsTags, "axisfunction")) {
        name <- jsGetTag(jsTags, "name")[2]
        desc <- paste(jsGetTag(jsTags, "description")[-1], collapse = " ")
        atype <- jsGetTag(jsTags, "axisfunction")[2]
        menue <- paste(jsGetTag(jsTags, "menuentry")[-1], collapse = " ")
        extras <- jsGetOptTag(jsTags, "extraparams")[-1]
        requires <- jsGetOptTag(jsTags, "requires")[-1]
        fn <- chmNewFunction(name, desc, jsdoc$src, extraParams = extras, requires = requires)
        chmRegisterAxisFunction(atype, menue, fn)
      } else if (jsTagExists(jsTags, "matrixfunction")) {
        name <- jsGetTag(jsTags, "name")[2]
        desc <- paste(jsGetTag(jsTags, "description")[-1], collapse = " ")
        rtype <- jsGetTag(jsTags, "matrixfunction")[2]
        ctype <- jsGetTag(jsTags, "matrixfunction")[3]
        menue <- paste(jsGetTag(jsTags, "menuentry")[-1], collapse = " ")
        extras <- jsGetOptTag(jsTags, "extraparams")[-1]
        requires <- jsGetOptTag(jsTags, "requires")[-1]
        fn <- chmNewFunction(name, desc, jsdoc$src, extraParams = extras, requires = requires)
        chmRegisterMatrixFunction(rtype, ctype, menue, fn)
      } else if (jsTagExists(jsTags, "toolboxfunction")) {
        name <- jsGetTag(jsTags, "name")[2]
        desc <- paste(jsGetTag(jsTags, "description")[-1], collapse = " ")
        tooltype <- jsGetTag(jsTags, "toolboxfunction")[2]
        menue <- paste(jsGetTag(jsTags, "menuentry")[-1], collapse = " ")
        extras <- jsGetTag(jsTags, "extraparams")[-1]
        requires <- jsGetOptTag(jsTags, "requires")[-1]
        fn <- chmNewFunction(name, desc, jsdoc$src, extraParams = extras, requires = requires)
        chmRegisterToolboxFunction(tooltype, menue, fn)
      } else if (jsTagExists(jsTags, "globalfunction")) {
        name <- jsGetTag(jsTags, "name")[2]
        desc <- paste(jsGetTag(jsTags, "description")[-1], collapse = " ")
        requires <- jsGetOptTag(jsTags, "requires")[-1]
        fn <- chmNewFunction(name, desc, jsdoc$src, requires = requires, global = TRUE)
      } else {
        stop(sprintf("Unknown type of Javascript function in file '%s'", filename))
      }
    }
  }
}

# Define a specified type mapper.
defineMapper <- function(filename, fields) {
  if (!"srctype" %in% names(fields)) {
    stop(sprintf("srctype not specified in typemap in file '%s'", filename))
  }
  if (!"dsttype" %in% names(fields)) {
    stop(sprintf("dsttype not specified in typemap in file '%s'", filename))
  }
  srctype <- fields$srctype
  dsttype <- fields$dsttype
  if ("field" %in% names(fields)) {
    if ("fieldsep" %in% names(fields)) {
      fieldsep <- fields$fieldsep
    } else {
      fieldsep <- ","
    }
    chmRegisterTypeMapper(strsplit(srctype, ",")[[1]], dsttype, "field", separator = fieldsep, num = fields$field)
  } else if ("stringop" %in% names(fields)) {
    if (fields$stringop == "substring(0)") {
      fn <- ""
    } else {
      fn <- chmStringopFunction(fields$stringop)
    }
    chmRegisterTypeMapper(strsplit(srctype, ",")[[1]], dsttype, "expr", expr = fields$stringop)
  } else {
    stop(sprintf("No known converter for %s --> %s specified in typemap in file '%s'", srctype, dsttype, filename))
  }
}

# Load a text configuration file.
#
loadTextConfig <- function(filename) {
  # Load configuration from text file.
  lines <- NULL
  try(suppressWarnings(lines <- readLines(filename)), silent = TRUE)
  thismap <- list()
  section <- ""
  fieldsep <- "="
  for (line in lines) {
    if (grepl("^ *#", line) || grepl("^ *$", line)) {
      # Comment.
    } else if (grepl("^\\[", line)) {
      # Section definition.
      if (section == "typemap") {
        defineMapper(filename, thismap)
        thismap <- list()
      }
      sectionline <- line
      section <- sub("^\\[(.*)].*$", "\\1", tolower(line))
      section <- gsub("  *", " ", spstrip(section))
    } else if (section == "typedefs") {
      # name fieldsep definition
      parts <- sub(" *#.*$", "", line)
      parts <- strsplit(parts, fieldsep)[[1]]
      if (length(parts) != 2) stop(sprintf('Malformed type definition "%s" in %s: should be name%sdescription', paste(parts, sep = fieldsep), filename, fieldsep))
      chmRegisterType(spstrip(parts[1]), spstrip(parts[2]))
    } else if (section == "servers") {
      # name fieldsep directory
      parts <- sub(" *#.*$", "", line)
      parts <- strsplit(parts, fieldsep)[[1]]
      if (length(parts) != 2) stop(sprintf('Malformed server definition "%s" in %s: should be name%sdirectory', paste(parts, sep = fieldsep), filename, fieldsep))
      chmCreateServer(spstrip(parts[1]), spstrip(parts[2]))
    } else if (section == "typemap") {
      # name fieldsep definition
      parts <- sub(" *#.*$", "", line)
      parts <- strsplit(parts, fieldsep)[[1]]
      if (length(parts) != 2) stop(sprintf('Malformed typemap line "%s" in %s: should be field%svalue', paste(parts, sep = fieldsep), filename, fieldsep))
      thismap[[spstrip(parts[1])]] <- spstrip(parts[2])
    } else if (section == "") {
      stop("section must be set before definitions")
    } else {
      stop(sprintf("Unknown section definition '%s' in file '%s'", section, filename))
    }
  }
  if (section == "typemap") {
    defineMapper(filename, thismap)
    thismap <- list()
  }
}

#' Get Javascript function name for accessing a specific string field in each element of string vector.
#'
#' This function returns the name of a Javascript function thats accepts a string vector
#' as its parameter, and for each string in the vector splits the string into fields separated by
#' fieldsep, and accesses field idx (zero origin).  The function returns a vector of these fields.
#'
#' The name of the function returned for a specific fieldsep and idx will be
#' constant within an R session, but may differ between R sessions (or if this
#' library is unloaded and reloaded).
#'
#' @param fieldsep The separator to be used for splitting the input string. This should be a single
#'                 character string.
#' @param idx The index (zero origin) of the field to be returned after splitting the input string.
#'            This should be a single integer.
#'
#' @export
#'
#' @seealso [chmGetFunction()]
#' @seealso [chmStringopFunction()]
#'
#' @return The name of the newly created field access function.
#'
#' @examples
#' # Create a new field access function that splits the input string at ',' and
#' # returns the first field.
#' chmFieldAccessFunction(',', 1)
#' # Create a new field access function that splits the input string at '-' and
#' # returns the second field.
#' chmFieldAccessFunction('-', 2)
#'
chmFieldAccessFunction <- function(fieldsep, idx) {
  key <- sprintf("fa%s%d", fieldsep, idx)
  if (!exists(key, ngchm.env$parseFns)) {
    fnname <- sprintf("chmFA%x", ngchm.env$nextId)
    ngchm.env$nextId <- ngchm.env$nextId + 1
    if (length(grep("'", fieldsep, fixed = TRUE)) > 0) {
      stop(sprintf('fieldsep "%s" cannot contain any single quotes', fieldsep))
    }
    fieldsep <- sprintf("%s", fieldsep)
    fn <- chmNewFunction(
      fnname,
      sprintf("Splits each input string at %s, and returns field %d.", fieldsep, idx),
      paste(sprintf("function %s (ns) {", fnname),
        sprintf("    return ns.map(function(s){return s.split('%s')[%d];});", fieldsep, idx),
        "}",
        sep = "\n"
      )
    )
    ngchm.env$parseFns[[key]] <- fn
  }
  ngchm.env$parseFns[[key]]@name
}

#' Get Javascript function name for performing a specific string operation on each element of a string vector.
#'
#' This function returns the name of a Javascript function thats accepts a string vector
#' as its parameter, and for each string in the vector performs the operation stringop on the string.
#' Stringop must be valid Javascript code that can be appended to a string value.
#' The function returns a vector of the resulting strings.
#'
#' The name of the function returned for a specific stringop will be
#' constant within an R session, but may differ between R sessions (or if this
#' library is unloaded and reloaded).
#'
#' @param stringop A javascript code fragment that can be applied to a string to
#' yield another string.
#' @export
#' @seealso [chmGetFunction()]
#' @seealso [chmFieldAccessFunction()]
#'
#' @return A character string specifying the name of the new function.
chmStringopFunction <- function(stringop) {
  key <- sprintf("sop%s", stringop)
  if (!exists(key, ngchm.env$parseFns)) {
    fnname <- sprintf("chmSO%x", ngchm.env$nextId)
    ngchm.env$nextId <- ngchm.env$nextId + 1
    fn <- chmNewFunction(
      fnname,
      sprintf("Transforms each input string by applying stringop '%s'.", stringop),
      paste(sprintf("function %s (ns) {", fnname),
        sprintf("    return ns.map(function(s){return s.%s;});", stringop),
        "}",
        sep = "\n"
      )
    )
    ngchm.env$parseFns[[key]] <- fn
  }
  ngchm.env$parseFns[[key]]@name
}

.onLoad <- function(libname, pkgname) {
  .initNGCHM()
}

#' Initialization of the NGCHM library.
#'
#' When first loaded the NGCHM library reads configuration files in
#' the configuration path specified by the NGCHMCONFIGPATH environment variable.  The
#' configuration path is a colon (:) separated list of directory names.
#' If not set it defaults to /etc/ngchm:/usr/local/ngchm:/opt/ngchm:$HOME/.ngchm.
#'
#' For each configuration directory in the configuration path, the NGCHM package
#' reads the contents of the configuration files in the conf.d subdirectory in order (as
#' determined by the R sort function).  Other subdirectories are not scanned
#' unless instructed to by an entry in a configuration file.
#'
#' Configuration files may be either text files (.txt extension), R scripts (.R extension),
#' or javascript files (.js extension).
#'
#' @section Text files:
#' A text configuration file consists of one or more sections.  Each section begins with a
#' single line containing the section type enclosed in square brackets. Subsequent lines in
#' the section are either blank or contain a definition of the form "name separator value".
#' The default separator is the equals sign (=).
#'
#' The 'servers' section defines available servers.  The name field defines the name by which
#' the server is known to the library.  The value field specifies a directory containing
#' a specification of the server's properties.  The server specification directory must contain
#' a config.txt that contains lines of the form "name separator value".  The config.txt file
#' must define the value of 'serverProtocol' to be the name of a ngchmServerProtocol.  It
#' must also define the values of any mandatory parameters required by ngchmServerProtocol, and
#' may optionally define any optional parameters.
#'
#' @details
#' Here is an example directory structruce for a server named 'my_server':
#'
#' \preformatted{
#' .
#' |-- conf.d
#' |   \-- 00-servers.txt
#' \-- my_server
#'     \-- config.txt
#' }
#'
#' Here are the contents of an example 00-servers.txt file:
#' \preformatted{
#' [servers]
#' my-server = /usr/local/ngchm/my_server
#' }
#'
#' Here are the contents of an example config.txt file:
#' \preformatted{
#' serverProtocol = shaidy
#' accessMethod = api
#' basePath = <URL to server. e.g. "https://mydomain.edu/server/api">
#' serverURL = <URL to server. e.g. "https://mydomain.edu/server">
#' }
#'
#' @section R scripts:
#' R scripts are sourced.  They can be used to define local NGCHM related functions.
#'
#' @section Javascript scripts:
#' Javascript files define context specific menu entries.
#'
#' @return None. This function is used for its side effects of loading configuration files.
#' @name NGCHM-initialization
#' @rdname NGCHM-initialization
#' @aliases NGCHM-initialization
#'
NULL

loadConfigDir <- function(dirname) {
  srcfiles <- NULL
  try(srcfiles <- dir(dirname, full.names = TRUE), silent = TRUE)
  if (length(srcfiles) > 0) {
    for (src in sort(srcfiles)) {
      if (grepl("\\.[rR]$", src)) {
        tryCatch(source(src), error = function(e) stop(sprintf("while processing R source file '%s'\n", src), e))
      } else if (grepl("\\.txt$", src)) {
        tryCatch(loadTextConfig(src), error = function(e) stop(sprintf("while processing text configuration file '%s'\n", src), e))
      } else if (grepl("\\.js$", src)) {
        tryCatch(loadJavascript(src), error = function(e) stop(sprintf("while processing Javascript file '%s'\n", src), e))
      } else if (grepl("\\.d$", src)) {
        tryCatch(loadConfigDir(src), error = function(e) stop(sprintf("while processing configuration directory '%s'\n", src), e))
      } else {
        warning(sprintf("Unknown kind of module file '%s', ignored.", src))
      }
    }
  }
}

.onAttach <- function(libname, pkgname) {
  getConfigDirs()

  checkForExternalUtilities() # Check suggested utilities are installed (e.g. git, ssh, etc. Does not check for java)
  checkForJavaVersion() # Check required version of java is installed
  checkForNGCHMSupportFiles()
  checkForNGCHMDemoData()

  chmNewFunction("", "Simple reference", "")
  chmNewFunction(
    "getLabelValue",
    "This returns the label at the specified index as a list of values.  Can be used whenever the label itself is of the correct type.",
    paste("function getLabelValue (axis, idx) {",
      "    return [axis.labels.getLabel (idx)];",
      "};",
      sep = "\n"
    )
  )

  # Load module definitions.
  for (cfgdir in c(system.file("base.config", package = "NGCHM"), ngchm.env$configdirs)) {
    loadConfigDir(file.path(cfgdir, "conf.d"))
  }
}