## ----echo=FALSE--------------------------------------------------------------- library(BiocStyle) self <- Githubpkg("ArtifactDB/alabaster.base"); knitr::opts_chunk$set(error=FALSE, warning=FALSE, message=FALSE) ## ----------------------------------------------------------------------------- library(alabaster.base) setClass("RemoteDownloadHandler", slots=c(host="character", id="character")) setMethod("acquireFile", "RemoteDownloadHandler", function(project, path) { # Download a file here, possibly with some application-specific caching. demo.url <- paste0(project@host, "/projects/", project@id, "/file", path) target <- tempfile() download.file(demo.url, target) target }) setMethod("acquireMetadata", "RemoteDownloadHandler", function(project, path) { # Pull down JSON metadata, possibly with some application-specific caching. demo.url <- paste0(project@host, "/projects/", project@id, "/file", path) target <- tempfile() download.file(demo.url, target) jsonlite::fromJSON(target, simplifyVector=FALSE) }) ## ----------------------------------------------------------------------------- proj <- new("RemoteDownloadHandler", host="https://my.institute.org/downloads", id="PROJECT_ID") ## ----eval=FALSE--------------------------------------------------------------- # # Demonstration only. # meta <- acquireMetadata(proj, "some/file/path.csv") # obj <- loadObject(meta, proj) ## ----------------------------------------------------------------------------- setGeneric("appStageObject", function(x, dir, path, child=FALSE, ...) standardGeneric("appStageObject")) setMethod("appStageObject", "ANY", function(x, dir, path, child=FALSE, ...) { meta <- stageObject(x, dir, path, child=child, ...) # Creating a fallback that adds authorship to all non-child objects. if (!child) { meta$authors <- I(Sys.info()[["user"]]) } # Pointing writeMetadata to the application package storing the schemas. attr(meta[["$schema"]], "package") <- "APPLICATION_NAME_HERE" meta }) ## ----------------------------------------------------------------------------- appSave <- function(x, dir, path, child=FALSE) { olds <- altStageObjectFunction(appStageObject) on.exit(altStageObjectFunction(olds)) meta <- appStageObject(x, dir, path, child=child) written <- writeMetadata(meta, dir) written$path } ## ----------------------------------------------------------------------------- setMethod("appStageObject", "DFrame", function(x, dir, path, child=FALSE, ...) { # Extracting details from the metadata. clinical.trial.id <- metadata(x)$trial_id treatment <- metadata(x)$treatment study.design <- metadata(x)$study # Calling the ANY method, which eventually just calls stageObject... meta <- callNextMethod() # Adding some metadata for data frames, assuming these properties are # listed in the schema. meta[["clinical_trail_details"]] <- list( trial_id = trail.id, treatment = treatment, design = study.design ) meta }) ## ----------------------------------------------------------------------------- # Memorize schema look-up in the R session, to avoid having to repeatedly query # the R package directory on the file system at every loadObject request. memory <- new.env() memory$cache <- list() appLoadObject <- function(info, project, ...) { # customLoadObjectHelper is a helper function that handles loading with # different schema location and memory store. output <- customLoadObjectHelper(info, project, ..., .locations="APPLCATION_NAME_HERE", .memory=memory ) if ("authors" %in% names(info) && is(output, "Annotated")) { metadata(output)$authors <- info$authors } output } ## ----------------------------------------------------------------------------- appLoad <- function(project, path) { oldl <- altLoadObjectFunction(appLoadObject) on.exit(altLoadObjectFunction(oldl)) info <- acquireMetadata(project, path) appLoadObject(info, project, child=child) } ## ----------------------------------------------------------------------------- sessionInfo()