merge conflicts

Author: RianneJ

CHANGELOG.rst

@@ -11,9 +11,17 @@ start with 'Added', 'Changed', 'Deprecated', 'Removed', 'Fix(ed)', or
 Unreleased
 ==========
 
+
+
+[0.3.2] - 2016-07-18
+====================
+
 - Added this CHANGELOG.rst file
 - Added support for patient_id_list constraint in getHighdimData
 - Fix bugs in error handling, e.g. when no Content-Type is provided by the server
+- implement getPatientSet
+- use inTrialId as patient id: The former 'id' field of patients should not be used outside of Transmart, instead the inTrialId should be used. New versions of rest-api don't export the 'id' field anymore.
+- Change from `rCurl` to `httr` to fix authentication with new Transmart servers using an updated OAuth plugin
 
 [0.3.1] - 2016-04-06
 ====================

DESCRIPTION

@@ -1,9 +1,9 @@
 Package: transmartRClient
 Type: Package
 Title: R Client for accessing the tranSMART RESTful API
-Version: 0.3.1
-Date: 2016-04-06
-Depends: RCurl, rjson, plyr, RProtoBuf, hash, reshape, XML
+Version: 0.3.2
+Date: 2016-07-18
+Depends: httr, jsonlite, plyr, RProtoBuf, hash, reshape, XML
 Author: Tim Dorscheidt, Jan Kanis, Rianne Jansen
 Maintainer: <support@thehyve.nl>
 Description: This package exposes tranSMART's RESTful API as a set of R functions. It uses tranSMART's OAuth authentication to access the data for which the user is authorized, and allows exploring and downloading the data.

LICENSE.md

@@ -20,13 +20,14 @@ apply:
 | Dependency | License  | Reference
 | ---------- | -------- | -----------------------------------------------------------
 | Protobuf   | BSD      | <http://grails.org/License>
-| RCurl      | BSD      | <http://cran.r-project.org/web/packages/RCurl/index.html>
-| rjson      | GPL2     | <http://cran.r-project.org/web/packages/rjson/index.html>
-| RProtoBuf  | GPL2     | <http://cran.r-project.org/web/packages/RProtoBuf/index.html>
+| httr       | MIT      | <http://cran.r-project.org/web/packages/httr/index.html>
+| jsonlite   | MIT      | <http://cran.r-project.org/web/packages/jsonlite/index.html>
+| RProtoBuf  | GPL2+    | <http://cran.r-project.org/web/packages/RProtoBuf/index.html>
 | plyr       | MIT      | <http://cran.r-project.org/web/packages/plyr/index.html>
-| hash       | GPL3     | <http://cran.r-project.org/web/packages/hash/index.html>
-| bitopts    | GPL3     | <http://cran.r-project.org/web/packages/bitops/index.html>
-| RCpp       | GPL2     | <http://cran.r-project.org/web/packages/Rcpp/index.html>
+| hash       | GPL2+    | <http://cran.r-project.org/web/packages/hash/index.html>
+| reshape    | MIT      | <http://cran.r-project.org/web/packages/reshape/>
+| bitopts    | GPL2+    | <http://cran.r-project.org/web/packages/bitops/index.html>
+| RCpp       | GPL2+    | <http://cran.r-project.org/web/packages/Rcpp/index.html>
 | R overall  | Multiple | <http://www.r-project.org/Licenses/>
 
 This program is free software: you can redistribute it and/or modify it under

R/RClientConnectionManager.R

@@ -93,15 +93,13 @@ function (oauthDomain = transmartClientEnv$transmartDomain, prefetched.request.t
         return(FALSE)
     }
 
-    oauth.exchange.token.path <- paste(sep = "",
-            "/oauth/token?grant_type=authorization_code&client_id=",
-            transmartClientEnv$client_id,
-            "&client_secret=", transmartClientEnv$client_secret,
-            "&code=", URLencode(request.token, TRUE),
-            "&redirect_uri=", URLencode(transmartClientEnv$oauthDomain, TRUE),
-            URLencode("/oauth/verify", TRUE))
+    oauth.exchange.token.path <- "/oauth/token"
+    post.body <- list(
+        grant_type="authorization_code",
+        code=request.token,
+        redirect_uri=paste(transmartClientEnv$oauthDomain, "/oauth/verify", sep=""))
 
-    oauthResponse <- .transmartServerGetOauthRequest(oauth.exchange.token.path, "Authentication")
+    oauthResponse <- .transmartServerPostOauthRequest(oauth.exchange.token.path, "Authentication", post.body)
     if (is.null(oauthResponse)) return(FALSE)
 
     list2env(oauthResponse$content, envir = transmartClientEnv)
@@ -119,16 +117,12 @@ function (oauthDomain = transmartClientEnv$transmartDomain, prefetched.request.t
     transmartClientEnv$client_id <- "api-client"
     transmartClientEnv$client_secret <- "api-client"
     message("Trying to reauthenticate using the refresh token...")
-    refreshPath <- paste(sep = "",
-                        "/oauth/token?grant_type=refresh_token",
-                        "&client_id=", transmartClientEnv$client_id,
-                        "&client_secret=", transmartClientEnv$client_secret,
-                        "&refresh_token=", URLencode(transmartClientEnv$refresh_token, TRUE),
-                        "&redirect_uri=", URLencode(transmartClientEnv$oauthDomain, TRUE),
-                        URLencode("/oauth/verify", TRUE),
-                        "")
+    refreshPath <- "/oauth/token"
+    post.body <- list(grant_type="refresh_token",
+        refresh_token=transmartClientEnv$refresh_token,
+        redirect_uri=paste(transmartClientEnv$oauthDomain, "/oauth/verify", sep=""))
 
-    oauthResponse <- .transmartServerGetOauthRequest(refreshPath, "Refreshing access")
+    oauthResponse <- .transmartServerPostOauthRequest(refreshPath, "Refreshing access", post.body)
     if (is.null(oauthResponse)) return(FALSE)
     if (!'access_token' %in% names(oauthResponse$content)) {
         message("Refreshing access failed, server response did not contain access_token. HTTP", statusString)
@@ -139,8 +133,8 @@ function (oauthDomain = transmartClientEnv$transmartDomain, prefetched.request.t
     return(TRUE)
 }
 
-.transmartServerGetOauthRequest <- function(path, action) {
-    oauthResponse <- .transmartServerGetRequest(path, onlyContent=F)
+.transmartServerPostOauthRequest <- function(path, action, post.body) {
+    oauthResponse <- .transmartServerGetRequest(path, onlyContent=F, post.body=post.body)
     statusString <- paste("status code ", oauthResponse$status, ": ", oauthResponse$headers[['statusMessage']], sep='')
     if (!oauthResponse$JSON) {
         cat(action, " failed, could not parse server response of type ", oauthResponse$headers[['Content-Type']], ". ", statusString, "\n", sep='')
@@ -209,7 +203,7 @@ function (oauthDomain = transmartClientEnv$transmartDomain, prefetched.request.t
             "You can help fix it by contacting us. Type ?transmartRClient for contact details.\n", 
             "Optional: type options(verbose = TRUE) and replicate the bug to find out more details.")
     # If e is a condition adding the call. parameter triggers another warning
-    if(inherits(args[[1L]], "condition")) {
+    if(inherits(e, "condition")) {
         stop(e)
     } else {
         stop(e, call.=FALSE)
@@ -255,10 +249,10 @@ function (oauthDomain = transmartClientEnv$transmartDomain, prefetched.request.t
 }
 
 .contentType <- function(headers) {
-    if(! 'Content-Type' %in% names(headers)) {
-        return('Content-Type header not found')
+    if(! 'content-type' %in% names(headers)) {
+        return('content-type header not found')
     }
-    h <- headers[['Content-Type']]
+    h <- headers[['content-type']]
     if(grepl("^application/json(;|\\W|$)", h)) {
         return('json')
     }
@@ -271,70 +265,80 @@ function (oauthDomain = transmartClientEnv$transmartDomain, prefetched.request.t
     return('unknown')
 }
 
+# Wrap this in case we need to change json libraries again
+.fromJSON <- function(json) {
+	fromJSON(json, simplifyDataFrame=F, simplifyMatrix=F)
+}
+
 .serverMessageExchange <- 
-function(apiCall, httpHeaderFields, accept.type = "default", progress = .make.progresscallback.download(),
-         post.content.type = NULL, requestBody = NULL) {
+function(apiCall, httpHeaderFields, accept.type = "default", post.body = NULL, post.content.type = 'form',
+         show.progress = (accept.type == 'binary') ) {
     if (any(accept.type == c("default", "hal"))) {
-        if (accept.type == "hal") { httpHeaderFields <- c(httpHeaderFields, Accept = "application/hal+json;charset=UTF-8") }
-        curlOptions <- list()
-        if (!is.null(post.content.type)) {
-            httpHeaderFields <- c(httpHeaderFields, 'content-type' = post.content.type)
-            if(is.null(requestBody)) { stop("Missing body for POST request") }
-            curlOptions[["postfields"]] <- requestBody
+        if (accept.type == "hal") {
+            httpHeaderFields <- c(httpHeaderFields, Accept = "application/hal+json;charset=UTF-8")
         }
-        headers <- basicHeaderGatherer()
         result <- list(JSON = FALSE)
-        curlOptions <- c(curlOptions, list(httpheader = httpHeaderFields, headerfunction = headers$update))
-        result$content <- getURL(paste(sep="", transmartClientEnv$db_access_url, apiCall),
-                verbose = getOption("verbose"), .opts = curlOptions)
+        api.url <- paste0(transmartClientEnv$db_access_url, apiCall)
+        if (is.null(post.body)) {
+            req <- GET(api.url,
+                       add_headers(httpHeaderFields),
+                       authenticate(transmartClientEnv$client_id, transmartClientEnv$client_secret),
+                       config(verbose = getOption("verbose")))
+        } else {
+            req <- POST(api.url,
+                        body = post.body,
+                        add_headers(httpHeaderFields),
+                        authenticate(transmartClientEnv$client_id, transmartClientEnv$client_secret),
+                        encode = if(post.content.type == 'form') 'form' else 'raw',
+                        if(post.content.type != 'form') content_type(post.content.type),
+                        config(verbose = getOption("verbose")))
+            if (getOption("verbose")) { message("POST body:\n", .list2string(post.body), "\n") }
+        }
+        result$content <- content(req, "text")
         if (getOption("verbose")) { message("Server response:\n", result$content, "\n") }
-        if(is.null(result)) { return(NULL) }
-        result$headers <- headers$value()
-        result$status <- as.integer(result$headers[['status']])
-        result$statusMessage <- result$headers[['statusMessage']]
-        switch(.contentType(result$headers),
+        result$headers <- headers(req)
+        result$status <- req$status_code
+        result$statusMessage <- http_status(req)$message
+    	switch(.contentType(result$headers),
                json = {
-                   result$content <- fromJSON(result$content)
+                   result$content <- .fromJSON(result$content)
                    result$JSON <- TRUE
                },
                hal = {
-                   result$content <- .simplifyHalList(fromJSON(result$content))
+                   result$content <- .simplifyHalList(.fromJSON(result$content))
                    result$JSON <- TRUE
                })
         return(result)
     } else if (accept.type == "binary") {
-        progress$start(NA_integer_)
+        if(show.progress) cat("Retrieving data...\n")
         result <- list(JSON = FALSE)
-        headers <- basicHeaderGatherer()
-        result$content <- getBinaryURL(paste(sep="", transmartClientEnv$db_access_url, apiCall),
-                verbose = getOption("verbose"),
-                headerfunction = headers$update,
-                noprogress = FALSE,
-                progressfunction = function(down, up) {up[which(up == 0)] <- NA; progress$update(down, up) },
-                httpheader = httpHeaderFields)
-        progress$end()
-        result$headers <- headers$value()
-        result$status <- as.integer(result$headers[['status']])
-        result$statusMessage <- result$headers[['statusMessage']]
-        if (getOption("verbose") && .contentType(result$headers) %in% c('json', 'hal', 'html')) {
-            message("Server response:\n", result$content, "\n")
+        api.url <- paste(sep="", transmartClientEnv$db_access_url, apiCall)
+        if (is.null(post.body)) {
+            req <- GET(api.url,
+                       add_headers(httpHeaderFields),
+                       authenticate(transmartClientEnv$client_id, transmartClientEnv$client_secret),
+                       if(show.progress) progress(),
+                       config(verbose = getOption("verbose")))
+        } else {
+            req <- POST(api.url,
+                        body = post.body,
+                        add_headers(httpHeaderFields),
+                        authenticate(transmartClientEnv$client_id, transmartClientEnv$client_secret),
+                        if(show.progress) progress(),
+                        encode = if(post.content.type == 'form') 'form' else 'raw',
+                        if(post.content.type != 'form') content_type(post.content.type),
+                        config(verbose = getOption("verbose")))
         }
+        if(show.progress) cat("\nDownload complete.\n")
+        result$content <- content(req, "raw")
+        result$headers <- headers(req)
+        result$status <- req$status_code
+        result$statusMessage <- http_status(req)$message
         return(result)
     }
     return(NULL)
 }
 
-.make.progresscallback.download <- function() {
-    start <- function(.total) cat("Retrieving data: \n")
-    update <- function(current, .total) {
-        # This trick unfortunately doesn't work in RStudio if we write to stderr.
-        cat(paste("\r", format(current / 1000000, digits=3, nsmall=3), "MB downloaded."))
-    }
-    end <- function() cat("\nDownload complete.\n")
-    environment()
-}
-
-
 .listToDataFrame <- function(l) {
     # TODO: (timdo) dependency on 'plyr' package removed; figure out whether dependency is present elsewhere, or remove dependency
     # add each list-element as a new row to a matrix, in two passes
@@ -396,3 +400,10 @@ function(apiCall, httpHeaderFields, accept.type = "default", progress = .make.pr
     }
     return(halList)
 }
+
+.list2string <- function(lst) {
+    if(is.null(names(lst))) return(paste(lst, sep=", "))
+
+    final <- character(length(lst)*2)
+    paste(mapply(function(name, val) {paste0(name, ': "', encodeString(val), '"')}, names(lst), lst), collapse=", ")
+}

R/getHighdimData.R

@@ -25,17 +25,7 @@
 
 # Performance notes
 # 
-# Downloading and parsing large data sets of high dimensional data can take a 
-# significant amount of time (minutes for several 100 mb). We have attempted to 
-# optimize the process a reasonable amount.
-# 
-# The current RCurl wrapper doesn't expose functionality to download a binary 
-# url and process the chunks asynchronously as they come in (that is only 
-# supported for text urls). Doing the downloading and parsing at the same time 
-# should give a significant improvement, but that would require changes in RCurl
-# or a different way of downloading the data.
-# 
-# The parser has also been optimized up to the level that the R code itself only
+# The parser has been optimized up to the level that the R code itself only
 # takes a minority of the runtime. The most time consuming operations are the 
 # foreign function calls to retrieve the fields from messages and to construct 
 # objects to parse the varint32 preceding each message. Significant further 
@@ -45,7 +35,6 @@
 
 getHighdimData <- function(study.name, concept.match = NULL, concept.link = NULL, projection = NULL,
         data.constraints = list(), assay.constraints = list(), highdim.type = 1,
-        progress.download = .make.progresscallback.download(),
         progress.parse = .make.progresscallback.parse(),
         ...) {
 
@@ -93,7 +82,7 @@ getHighdimData <- function(study.name, concept.match = NULL, concept.link = NULL
         }
     }
 
-    serverResult <- .transmartServerGetRequest(projectionLink, accept.type = "binary", errorHandler = errorHandler, progress = progress.download)
+    serverResult <- .transmartServerGetRequest(projectionLink, accept.type = "binary", errorHandler = errorHandler)
     if (length(serverResult) == 0) {
         warning("No data could be found. The server yielded an empty dataset. Returning NULL.")
         return(NULL)
@@ -144,8 +133,9 @@ getHighdimData <- function(study.name, concept.match = NULL, concept.link = NULL
 
 # The argument is a single named list
 .expandConstraints <- function(constraints) {
-    # The JSON encoder encodes single item vectors as scalars. We need those to be lists as well sometimes.
-    j <- function(val) if (length(val) == 1) list(val) else val
+    # Previously used json packages encode length 1 vectors as scalars, we need them as lists. Jsonlite which we are using
+    # now doesn't do that so this wrapping function is now a no-op.
+    j <- function(val) val
 
     # some deep functional/lazy magic
     mapply(function(val, con) switch(con,

R/getPatientSet.R

@@ -0,0 +1,42 @@
+# Copyright 2014, 2015 The Hyve B.V.
+#
+# This file is part of tranSMART R Client: R package allowing access to
+# tranSMART's data via its RESTful API.
+#
+# This program is free software: you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by the
+# Free Software Foundation, either version 3 of the License, or (at your
+# option) any later version, along with the following terms:
+#
+#   1. You may convey a work based on this program in accordance with
+#      section 5, provided that you retain the above notices.
+#   2. You may convey verbatim copies of this program code as you receive
+#      it, in any medium, provided that you retain the above notices.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
+# Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along
+# with this program. If not, see <http://www.gnu.org/licenses/>..
+
+getPatientSet <- function(id) {
+    if (!is.numeric(id) || id %% 1 != 0 || id < 0) {
+        stop(paste(id, "is not a valid positive integer"))
+    }
+    .ensureTransmartConnection()
+
+    patientSet <- .transmartGetJSON(paste0("/patient_sets/", id))
+
+    # Don't expose id, it should not be used and will be removed from a future version of rest-api
+    # COMPAT: remove this block if support for the old rest-api is dropped.
+    if (length(patientSet$patients) && "id" %in% names(patientSet$patients[[1]])) {
+        for (i in seq_along(patientSet$patients)) {
+            patientSet$patients[[i]]$id <- NULL
+        }
+    }
+
+    names(patientSet$patients) <- sapply(patientSet$patients, function(p) {p$inTrialId})
+    patientSet
+}