#' Common data retrieval
#'
#' Query Reactome database objects.
#' @usage rtQuery(id, attributeName, ...)
#' rtQuery(id, type = "summary", ...)
#'
#' @param id string. A comma separated list of DbIds or StIds or character vector.
#' @param type Data of type: \code{summary}, \code{detail}, \code{extended}, \code{more},
#' or \code{withmapping}.
#' @param attributeName string. Attribute(s) of Reactome
#' knowledgebase to be filtered.
#' @param directParticipants logical. Include direct participants
#' (proteins or molecules directly involved in Reactions)
#' @param silent logical. Run quitely.
#'
#' @details
#' \itemize{
#' \item \code{detail}: Query for an entry in Reactome knowledgebase based on
#' the given identifier, i.e. stable id or database id. It is worth mentioning
#' that the retrieved database object has all its properties and direct
#' relationships (relationships of depth 1) filled.
#' \item \code{summary}: Only requests containing up to 20 ids are processed.
#' \item \code{extended}: ContentDetails contains: componentsOf,
#' other forms of the entry, locationsTree,except DatabaseObject.
#' \item \code{more}: Query for an entry in Reactome knowledgebase
#' providing more information. In particular, the retrieved database object
#' has all its properties and direct relationships (relationships of depth 1)
#' filled, while it also includes any second level relationships regarding
#' regulations and catalysts.
#' \item \code{withmapping}: This method is particularly useful for users
#' that still rely on the previous version of stable identifiers to query
#' this API. Please note that those are no longer part of the retrieved objects.
#' Only requests containing up to 20 ids are processed.
#' }
#' @return A dataframe.
#' @examples
#' # detailed info
#' dt.detail = rtQuery('R-HSA-1640170', type = 'detail')
#'
#' # summary of multiple ids and attributes
#' dt.mul = rtQuery(id = c('R-DME-1640170,R-HSA-1640170'),
#' attributeName = c('displayname', 'figure'))
#' @export
#' @include list2dataframe.R
#' @include url2dataframe.R
#' @include POST_Method.R
#' @include error.R
#'
#' @rdname query
#'
rtQuery <- function(id,
type = "summary",
attributeName = NULL,
directParticipants = FALSE,
silent = FALSE){
# split ids to atomic vector
if(1 == length(id)){
id = str_split(id, '[,;\\s]')[[1]]
}
# query_attribute
if(!is.null(attributeName))
return(query_attribute(id, attributeName, silent))
dt = switch(type,
summary = query_summary(id, silent),
detail = query_detail(id, silent),
extended = query_extended(id, directParticipants, silent),
more = query_more(id, silent),
withmapping = query_withmapping(id, silent)
)
return(dt)
}
query_summary <- function(id, silent){
url = list(GETURL(), 'ids')
id = str_c(id, collapse = ',')
POST_Method(url = url, body = id, silent = silent)
}
query_detail <- function(id, silent){
GET_multiIDs(id, silent, NULL)
# LST = lapply(id, function(x) url2dataframe(list(GETURL(), x), FALSE, silent))
# list2dataframe(LST, NULL,NULL,NULL)
}
query_extended <- function(id, directParticipants, silent){
url_last = NULL
if(is.logical(directParticipants)){
if(directParticipants)
url_last = 'extended?directParticipants=true'
else
url_last = 'extended?directParticipants=false'
}
LST = lapply(id, function(x) url2dataframe(list(GETURL(), x, url_last), FALSE, silent)[-1])
list2dataframe(LST, NULL,NULL,NULL)
}
query_more <- function(id, silent){
GET_multiIDs(id, silent, "more")
# LST = lapply(id, function(x) url2dataframe(list(GETURL(), x, "more"), FALSE, silent))
# list2dataframe(LST, NULL, NULL,NULL)
}
query_withmapping <- function(id, silent){
url = list(GETURL(), "ids/map")
id = str_c(id, collapse = ',')
LST = POST_Method(url = url, body = id, silent = silent)
list2dataframe(LST, NULL,NULL,NULL)
}
GET_multiIDs <- function(id, silent, url0){
if(is.null(url0)) url = str_c(GETURL(), id, sep = '/')
else url = str_c(GETURL(), id, url0, sep = '/')
LST = lapply(url, function(x) url2dataframe(x, FALSE, silent))
list2dataframe(LST, NULL,NULL,NULL)
}
GETURL <- function(){
'http://www.reactome.org/ContentService/data/query'
}
# for multiple ids and attrs
query_attribute <- function(id, attributeName, silent){
dt_right = data.frame(t(1:length(attributeName)))
names(dt_right) = attributeName
dt_tmp = lapply(attributeName, function(x) query_single_attr(id, x, silent))
dt_right = do.call(cbind, dt_tmp)
# dt_right[] = lapply(attributeName, function(x) query_single_attr(id, x, silent))
# supplement 'inputId'
dt_left = data.frame(inputId = id, stringsAsFactors = F)
return(cbind(dt_left, dt_right))
}
# for single attr multiple ids
query_single_attr <- function(id, attributeName, silent){
# attrs with dbid
dbid_ns = c('created','modified','evidenceType','species',
'summation','hasEvent','edited','figure','orthologousEvent')
# attrs with stid
stid_ns = c('inferredFrom')
# attrs witch are column vector
col_ns = c('name')
# attrs which are dataframe
dt_ns = c('hasEvent', 'orthologousEvent')
# default attr names
ns = c('dbId','displayName','className')
# which name set attr belongs to
attr_which_set = sapply(list(dbid_ns, stid_ns, col_ns, dt_ns),
function(x) attributeName %in% x)
names(attr_which_set) = c('dbid_ns', 'stid_ns', 'col_ns', 'dt_ns')
if(any(attributeName %in% stid_ns))
ns[1] = 'stId'
if(!any(attributeName %in% c(dbid_ns, stid_ns)))
ns = NULL
dt = lapply(id, function(x)
query_attr_atom(str_c(GETURL(), x, attributeName, sep = '/'),
ns, attr_which_set, silent))
# dataframe is different to bind
if(!is.null(ns))
dt = list2col_dt(dt)
else
dt = data.frame(unlist(dt), stringsAsFactors = FALSE)
names(dt) = attributeName
return(dt)
}
list2col_dt <- function(LST){
N = length(LST)
dt = data.frame(1:N)
for(n in 1:N)
dt[n,1] = LST[n]
return(dt)
}
# for single id single attr
query_attr_atom <- function(url, ns, attr_which_set, silent){
GET_object = GET(url)
str = content(GET_object)
if(!GET_object$status_code == 200){
tmp = errorMessage(str, silent)
return(NA)
}
# error
if(is.logical(str)) return(NA)
# no colnames
if(is.null(ns)){
# attr: name
if(attr_which_set['col_ns'])
return(str_split(str, '\\s'))
# scalar
else return(str)
}
# with names
if(!is.null(ns)){
# vector
if(!any(attr_which_set['dt_ns'])){
dt = data.frame(t(str_split(str, '\\t')[[1]]), stringsAsFactors = FALSE)
}
# dataframe
else{
s1 = str_split(str, '\\n')[[1]]
s2 = str_split(s1, '\\t', simplify = T)
dt = data.frame(s2, stringsAsFactors = F)
}
names(dt) = ns
return(list(dt))
}
}
#' @details \code{rtGetImage} gets images of reactome objects to directory
#' \code{~/ReacromeImage/}.
#' @rdname query
#' @export
#' @include tools.R
#' @examples
#' # download images
#' # NA means no figure.
#' images = rtGetImage(c('R-DMA-1640170','R-HSA-1640170', 'R-HSA-69620'))
#'
rtGetImage <- function(id){
# creat directory if doesn't exist
dir = str_c(getwd(), "/ReactomeImage/")
validateAndCreatDir(dir)
addr = rtQuery(id, attributeName = 'figure', silent = T)
addr['url'] = sapply(addr[['figure']], extract_url)
addr['figureName'] = str_match(addr[['url']], '/([^/]+\\.[^/]+)$')[,2]
# download
for(n in 1:nrow(addr)){
if(is.na(addr[n, 'url']))
next
download.file( url = addr[n,'url'],
destfile = str_c(dir, addr[n,'figureName']),
mode = 'wb')
}
return(addr[c('inputId', 'figureName')])
}
extract_url = function(dt){
if(all(is.na(dt))) return(NA)
url = dt[1,'displayName']
return(str_c('http://www.reactome.org', url))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.