## ----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()

