Gemma2 compat

R/body.R

@@ -116,11 +116,25 @@ setGemmaPath <- function(path){
     ## Uncomment for debugging
     # print(response$url)
 
-    # if 429. wait a bit and re-try.
+    # if 429, 500 or 503. wait a bit and re-try. a 503 that tells us when to come
+    # back is server-directed, so it doesn't count towards the retry limit
     i <- 0
-    while(i<3 && (is.null(response$status_code) || response$status_code  %in% c(429,500))){
-        i <- i + 1
-        Sys.sleep(5)
+    while(is.null(response$status_code) || response$status_code %in% c(429,500,503)){
+        directed <- if(isTRUE(response$status_code == 503)) retryAfter(response) else NULL
+        if(is.null(directed)){
+            if(i >= 3) break
+            i <- i + 1
+        }
+        wait <- if(is.null(directed)) 5 else directed
+        if(!is.null(directed)){
+            message('High traffic in Gemma. Retrying in ', wait, ' seconds.')
+        } else{
+            message('No valid response from Gemma',
+             if(is.null(response$status_code)) '' else paste0(' (',response$status_code ,')'),
+             '. Retrying in ',
+              wait, ' seconds.')
+        }
+        Sys.sleep(wait)
         response <- eval(requestExpr)
     }
 
@@ -209,6 +223,30 @@ setGemmaPath <- function(path){
     }
 }
 
+#' Seconds the server asked us to wait before re-trying
+#'
+#' Reads the \code{Retry-After} response header, accepting both the delay in
+#' seconds and the HTTP-date forms. The delay is rounded to whole seconds and
+#' floored at one so a server-directed re-try can't spin.
+#'
+#' @param response An httr response object
+#' @return Number of seconds to wait, or NULL if the header is absent or unusable
+#' @keywords internal
+retryAfter <- function(response){
+    header <- tryCatch(httr::headers(response)[['retry-after']], error = function(e) NULL)
+    if(is.null(header)){
+        return(NULL)
+    }
+    seconds <- suppressWarnings(as.numeric(header))
+    if(is.na(seconds)){
+        seconds <- as.numeric(difftime(httr::parse_http_date(header), Sys.time(), units = 'secs'))
+    }
+    if(is.na(seconds)){
+        return(NULL)
+    }
+    max(round(seconds), 1)
+}
+
 #' URL encode a string safely
 #'
 #' @param url The string to URL encode. Vectors are delimited by a comma.

R/convenience.R

@@ -19,151 +19,9 @@ set_gemma_user <- function(username = NULL, password = NULL) {
     }
 }
 
-#' Retrieve Platform Annotations by Gemma
-#'
-#' Gets Gemma's platform annotations including mappings of microarray probes to genes.
-#'
-#' @param platform A platform numerical identifiers or platform short name.
-#' @param annotType Which GO terms should the output include
-#' @param file Where to save the annotation file to, or empty to just load into memory
-#' @param overwrite Whether or not to overwrite an existing file
-#' @inheritParams memoise
-#' @param unzip Whether or not to unzip the file (if @param file is not empty)
-#'
-#' @return A table of annotations
-#' \itemize{
-#'     \item \code{ElementName}: Probeset names provided by the platform.
-#'     Gene symbols for generic annotations typicall used for RNA-seq experiments.
-#'     \item \code{GeneSymbols}: Genes that were found to be aligned to
-#'     the probe sequence. Note that it is possible for probes to be
-#'     non-specific. Alignment to multiple genes are indicated with gene
-#'     symbols separated by "|"s
-#'     \item \code{GeneNames}: Name of the gene
-#'     \item \code{GOTerms}: GO Terms associated with the genes. \code{annotType}
-#'     argument can be used to choose which terms should be included.
-#'     \item \code{GemmaIDs} and \code{NCBIids}: respective IDs for the genes.
-#' }
-#' @keywords platform
-#' @export
-#' @examples
-#' head(get_platform_annotations("GPL96"))
-#' head(get_platform_annotations('Generic_human_ncbiIds'))
-get_platform_annotations <- function(platform,
-                                     annotType = c("noParents","allParents","bioProcess"),
-                                     file = getOption("gemma.file", NA_character_),
-                                     overwrite = getOption("gemma.overwrite", FALSE),
-                                     memoised = getOption("gemma.memoise", FALSE),
-                                     unzip = FALSE){
-
-    if (memoised){
-        if (!is.na(file)){
-            warning("Saving to files is not supported with memoisation.")
-        }
-        if ("character" %in% class(gemmaCache()) && gemmaCache() ==
-            "cache_in_memory") {
-            return(mem_in_memory_cache("get_platform_annotations",
-                                       platform = platform,
-                                       annotType = annotType,
-                                       file = NA,
-                                       overwrite = overwrite,
-                                       memoised = FALSE,
-                                       unzip = unzip
-            ))
-        } else{
-            out <- memget_platform_annotations(
-                platform = platform,
-                annotType = annotType,
-                file = NA,
-                overwrite = overwrite,
-                memoised = FALSE,
-                unzip = unzip
-            )
-            return(out)
-        }
-
-    }
-
-    if (!is.numeric(platform)) {
-        platforms <- get_platforms_by_ids(platform)
-        if (!isTRUE(nrow(platforms) == 1)) {
-            stop(platform, " is not a valid single platform.")
-        }
-        platform <- platforms[, "platform.ID"]
-    }
-
-    annotType <- match.arg(annotType)
-
-
-    is.tmp = is.null(file) || is.na(file) || unzip
-
-    if (is.tmp) {
-        file_path <- tempfile(fileext = ".gz")
-    } else{
-        file_path <- file
-    }
-
-    doReadFile <- function(file_path) {
-        tmp <- gzfile(file_path)
-        ret <- tmp %>%
-            readLines() %>%
-            .[which(!startsWith(., "#"))[1]:length(.)] %>%
-            # Strip comments
-            paste0(collapse = "\n") %>%
-            {
-                fread(text = .)
-            }
-        close(tmp)
-
-        if (unzip && !is.na(file)) {
-            utils::write.table(ret, file,
-                               sep = "\t", quote = FALSE, row.names = FALSE)
-        }
-
-        if (is.tmp || unzip) {
-            unlink(file_path)
-        }
-
-        ret
-    }
-
-    if(!(is.null(file) || is.na(file)) && (file.exists(file) && !overwrite)){
-        warning(file, " exists. Not overwriting.")
-    } else {
-        response <- httr::GET(glue::glue(
-            paste0(dirname(dirname(gemmaPath())),
-                   "/arrays/downloadAnnotationFile.html?id={platform}&fileType={annotType}")),
-            httr::write_disk(file_path,overwrite = overwrite),handle = httr::handle(""))
-        if (response$status_code!=200){
-            warning(glue::glue("Unable to access annotation file for {platform}. Can get more information about the platform at https://gemma.msl.ubc.ca/arrays/showArrayDesign.html?id={platform}"))
-            return(NULL)
-        }
-    }
-
-    frame <- doReadFile(file_path)
-
-    # currently Gemma includes files mixed with ElementName and ProbeName
-    # we just return ElementName
-
-    names(frame)[names(frame) == 'ProbeName'] = 'ElementName'
-
-    return(frame)
-}
-
-#' Memoise get_platform_annotations
-#'
-#' @noRd
-memget_platform_annotations <- function(platform,
-                                     annotType = c("bioProcess", "noParents", "allParents"),
-                                     file = getOption("gemma.file", NA_character_),
-                                     overwrite = getOption("gemma.overwrite", FALSE),
-                                     memoised = getOption("gemma.memoise", FALSE),
-                                     unzip = FALSE) {
-    mem_call <- memoise::memoise(get_platform_annotations, cache = gemmaCache())
-    mem_call(
-        platform = platform, annotType = annotType, memoised = FALSE, file = file,
-        overwrite = overwrite, unzip=unzip
-    )
-}
+# get_platform_annotations is now generated from inst/script/registry.R, using
+# the platforms/{platform}/annotations REST endpoint instead of the
+# arrays/downloadAnnotationFile.html page of the web interface.
 
 
 #' Make simplified design frames
@@ -617,7 +475,7 @@ get_dataset_object <- function(datasets,
 #'
 #' Retrieves the differential expression result set(s) associated with the dataset.
 #' To get more information about the contrasts in individual resultSets and
-#' annotation terms associated them, use [get_dataset_differential_expression_analyses()]
+#' annotation terms associated them, use \code{\link{get_dataset_differential_expression_analyses}}
 #'
 #' In Gemma each result set corresponds to
 #' the estimated effects associated with a single factor in the design, and each can have multiple contrasts (for each level compared to baseline).

R/processors.R

@@ -550,16 +550,23 @@ processDatasetResultSets <- function(d) {
 #'     \item \code{object.class}: Class of object that the term originated from.
 #' }
 #'
-#'
+#' Against Gemma 2.0, \code{term.name} on a row originating from a factor value
+#' is the label of the annotated term. Older Gemma versions returned a composed
+#' sentence there instead (e.g. "wild type genotype has background APP/PS1"
+#' rather than "wild type genotype"). Rows originating from plain tags, subset
+#' tags and sample characteristics are unaffected; they carry the term label on
+#' either version.
 #'
 #' @keywords internal
 processAnnotations <- function(d) {
 
     data.table(
-        class.name = accessField(d,"className",NA_character_),
-        class.URI = accessField(d,"classUri",NA_character_),
-        term.name = accessField(d,"termName",NA_character_),
-        term.URI = accessField(d,"termUri",NA_character_),
+        # Gemma 2.0 renamed these; accessRenamedField reads the old spelling
+        # from Gemma 1.x servers. See accessRenamedField.
+        class.name = accessRenamedField(d,"category","className",NA_character_),
+        class.URI = accessRenamedField(d,"categoryUri","classUri",NA_character_),
+        term.name = accessRenamedField(d,"value","termName",NA_character_),
+        term.URI = accessRenamedField(d,"valueUri","termUri",NA_character_),
         object.class = accessField(d,'objectClass',NA_character_)
     )
 }
@@ -585,6 +592,37 @@ processFile <- function(content) {
     return(ret)
 }
 
+#' Processes a platform annotation file
+#'
+#' @param content The content from an `http_get` request
+#'
+#' @return A table of annotations
+#' \itemize{
+#'     \item \code{ElementName}: Probeset names provided by the platform.
+#'     Gene symbols for generic annotations typically used for RNA-seq experiments.
+#'     \item \code{GeneSymbols}: Genes that were found to be aligned to
+#'     the probe sequence. Note that it is possible for probes to be
+#'     non-specific. Alignment to multiple genes are indicated with gene
+#'     symbols separated by "|"s
+#'     \item \code{GeneNames}: Name of the gene
+#'     \item \code{GOTerms}: GO Terms associated with the genes.
+#'     \item \code{GemmaIDs} and \code{NCBIids}: respective IDs for the genes.
+#' }
+#'
+#' @keywords internal
+processAnnotationFile <- function(content) {
+    attr <- attributes(content)
+    attributes(content) <- NULL
+    ret <- read_gzipped_tsv(content)
+
+    # older annotation files use ProbeName instead of ElementName. we always
+    # return ElementName
+    names(ret)[names(ret) == "ProbeName"] <- "ElementName"
+
+    attributes(ret) <- c(attributes(ret), attr)
+    return(ret)
+}
+
 #' Processes JSON as a vector of samples
 #'
 #' @param d The JSON to process

R/subProcessors.R

@@ -71,6 +71,37 @@ accessField <- function(d, field, natype = NA){
     return(field)
 }
 
+#' Access a field that Gemma has renamed
+#'
+#' Reads \code{field}, falling back to \code{legacy} when no element of the
+#' payload carries \code{field}. Gemma 2.0 renamed the annotation fields
+#' \code{className}/\code{classUri}/\code{termName}/\code{termUri} to
+#' \code{category}/\code{categoryUri}/\code{value}/\code{valueUri} with no
+#' aliases, while \code{gemmaPath} still defaults to a Gemma 1.x server, so both
+#' spellings have to be readable. The two spellings are mutually exclusive on a
+#' given server, so the choice is made once per payload rather than per element.
+#'
+#' Drop this helper and read \code{field} directly once gemma.R no longer
+#' supports Gemma 1.x.
+#'
+#' @param d Input data list
+#' @param field Field name used by current Gemma versions
+#' @param legacy Field name used by older Gemma versions
+#' @param natype What to fill in when neither field is available
+#' @return A vector of elements
+#' @keywords internal
+accessRenamedField <- function(d, field, legacy, natype = NA){
+    hasField <- vapply(d, function(e){
+        is.list(e) && field %in% names(e)
+    }, logical(1))
+
+    if(any(hasField)){
+        accessField(d, field, natype)
+    } else{
+        accessField(d, legacy, natype)
+    }
+}
+
 #' Avoid NULLS as data.table columns
 #'
 #' @param x A value that might be null