#' Initialize shaidy subsystem for NGCHMs
#'
ngchmShaidyInit <- function() {
checkStatusCode <- function (resp, code) {
if (resp$status_code != code) {
print (sprintf ("Unexpected HTTP Response Code. Expected: %d", code));
print (resp);
stop ();
}
};
shaidyRegisterRepoAPI ("http", (function(fileMethods) list(
"__super__" = fileMethods,
blobPath = function (repo, repoBase) {
resp <- GET (repoBase);
checkStatusCode (resp, 200);
tarfile <- utempfile ("shaidcache", fileext='.tar');
local <- utempfile ("shaidcache");
stopifnot (dir.create (local, recursive=TRUE));
writeBin (resp$content, tarfile);
systemCheck (sprintf ("tar xf %s -C %s", tarfile, local));
unlink (tarfile);
fileMethods$blobPath (repo, local)
}
)) (shaidyRepoAPI('file')));
tokenStash <- new.env (parent=emptyenv());
setToken <- function( repo, token ) {
bp <- repo$blob.path("");
tokenStash[[repo$blob.path("")]] <- token;
tokenStash[[repo$blob.path("")]]
};
shaidyRegisterRepoAPI ("api", list (
"__super__" = "__generic__",
isLocal = function(repo) FALSE,
getToken = function (repo) {
bp <- repo$blob.path("");
if (exists (bp, envir=tokenStash)) {
tokenStash[[bp]]
} else {
repo$getNewToken ();
}
},
setToken = setToken,
getNewToken = function (repo) {
if (interactive()) {
cat ("Enter access token: ", file=stderr());
setToken( repo, readLines (n=1) )
} else {
stop ("Access token required. Try setting using chmSetCredentials.");
}
},
addObjectToCollection = function (repo, collection, shaid) {
uri <- collection$repo$blob.path('insert', shaid, collection$shaid);
resp <- POST (uri, add_headers(Authorization=repo$getToken()));
while (resp$status_code == 401) {
resp <- POST (uri, add_headers(Authorization=repo$getNewToken()));
}
checkStatusCode (resp, 200);
collection$repo$loadCollection(collection$uuid)
},
renderChm = function (repo, shaid) {
uri <- repo$blob.path('render', shaid);
resp <- POST (uri, add_headers(Authorization=repo$getToken()));
while (resp$status_code == 401 || resp$status_code == 504) {
if (resp$status_code == 504) {
cat ("Waiting for render to complete.\n", file=stderr());
resp <- POST (uri, add_headers(Authorization=repo$getToken()));
} else {
resp <- POST (uri, add_headers(Authorization=repo$getNewToken()));
}
}
cat ('Render', shaid@type, shaid@value, 'status:', resp$status_code, '\n', file=stderr());
},
blobPath = function (repo, repoBase) {
return (function (first, ...) {
type <- if (is(first,"shaid")) first@type else first;
uri <- paste (repoBase, type, sep='/');
if(is(first,"shaid")) uri <- paste (uri, first@value, sep='/');
others <- c(lapply(list(...),function(item) {
if (is (item, "shaid")) {
return (c(item@type, item@value));
} else {
return (item);
}
}), recursive=TRUE);
paste (c(uri, others), sep='/', collapse='/')
});
},
copyLocalDirToBlob = function (repo, localDir, shaid) {
dstblob <- repo$blob.path('tar', shaid);
tarfile <- utempfile ("shaidcache", fileext='.tar');
systemCheck (sprintf ("tar cf %s -C %s .", tarfile, localDir));
resp <- PUT (dstblob, add_headers(Authorization=repo$getToken()), body=upload_file(tarfile));
while (resp$status_code == 401) {
resp <- PUT (dstblob, add_headers(Authorization=repo$getNewToken()), body=upload_file(tarfile));
}
checkStatusCode (resp, 200);
unlink (tarfile);
},
copyBlobToLocalDir = function (repo, shaid, localDir) {
srcblob <- repo$blob.path('tar', shaid);
resp <- GET (srcblob);
if (resp$status_code == 401) {
resp <- GET (srcblob, add_headers(Authorization=repo$getToken()));
}
while (resp$status_code == 401) {
resp <- GET (srcblob, add_headers(Authorization=repo$getNewToken()));
}
checkStatusCode (resp, 200);
tarfile <- utempfile ("shaidcache", fileext='.tar');
writeBin (resp$content, tarfile);
systemCheck (sprintf ("tar xf %s -C %s", tarfile, localDir));
unlink (tarfile);
},
exists = function (repo, shaid) {
uri <- repo$blob.path (shaid);
uri <- sub ('api/', 'api/exists?ids=', uri);
resp <- GET (uri);
if (resp$status_code == 401) {
resp <- GET (uri, add_headers(Authorization=repo$getToken()));
}
while (resp$status_code == 401) {
resp <- GET (uri, add_headers(Authorization=repo$getNewToken()));
}
return (length (ngchmResponseJSON(resp)$data) > 0);
},
loadProperty = function (repo, shaid, propname) {
uri <- repo$blob.path ('prop', propname, shaid);
resp <- GET (uri);
if (resp$status_code == 401) {
resp <- GET (uri, add_headers(Authorization=repo$getToken()));
}
while (resp$status_code == 401) {
resp <- GET (uri, add_headers(Authorization=repo$getNewToken()));
}
if (status_code(resp) == 200) ngchmResponseJSON(resp)$data else c()
},
createCollection = function (repo, labels) {
uri <- repo$blob.path ('create', 'collection');
resp <- POST (uri, add_headers(Authorization=repo$getToken()), body=list(labels=labels), encode="json");
while (resp$status_code == 401) {
resp <- POST (uri, add_headers(Authorization=repo$getNewToken()), body=list(labels=labels), encode="json");
}
if (status_code(resp) == 200) ngchmResponseJSON(resp)$data else c()
},
# Add a collection reference to a collection
#
# The collection graph must be acyclic.
#
# @param collection A list containing details of a collection
# @param uuid The uuid of the collection to add
#
# @return An updated list containing details of the collection
#
# @import jsonlite
#
# @export
addCollectionToCollection = function (repo, collection, uuid) {
repo$addObjectToCollection (collection, new('shaid',type="collection",value=uuid))
}
));
shaidyDir <- utempfile ("shaidy");
ngchmInitShaidyRepository (shaidyDir);
ngchm.env$tmpShaidy <- shaidyLoadRepository ('file', shaidyDir);
ngchm.env$tmpShaidyStack <- c();
ngchm.env$shaidyStack <- c();
}
#' Create a shaidy repository for NG-CHMS
#'
#' @param shaidyDir Basepath of local shaidy repository to create
#'
#' @export
ngchmInitShaidyRepository <- function (shaidyDir) {
shaidyInitRepository (shaidyDir, c("collection", "chm", "dataset", "dendrogram", "label", "tile", "viewer", "file"))
}
#' Push a shaidy repository onto the stack of temporary repositories
#'
#' @param shaidyDir Basepath of local shaidy repository to use as a temporary repository
#'
#' @export
ngchmPushTempRepository <- function (shaidyDir) {
newrepo <- shaidyLoadRepository ('file', shaidyDir);
ngchm.env$tmpShaidyStack <- c(list(ngchm.env$tmpShaidy), ngchm.env$tmpShaidyStack);
ngchm.env$tmpShaidy <- newrepo
}
#' Push a local shaidy repository onto the stack of source repositories
#'
#' @param shaidyDir Basepath of local shaidy repository to use as a source repository
#' @param accessMethod Method for accessing repository
#'
#' @export
ngchmPushSourceRepository <- function (shaidyDir, accessMethod='file') {
newrepo <- shaidyLoadRepository (accessMethod, shaidyDir);
assign(envir=ngchm.env, 'shaidyStack', c(list(newrepo), ngchm.env$shaidyStack));
}
#' Push a shaidy server onto the stack of source repositories
#'
#' @param server An ngchmServer or the name of one.
#'
#' @seealso [chmLoadShaidyCHM()]
#' @seealso [chmCreateServer()]
#'
#' @export
ngchmPushSourceServer <- function (server) {
if (is(server, "character")) {
stopifnot (length(server) == 1);
server <- chmServer(server);
} else {
stopifnot (is(server, "ngchmServer"));
}
sr <- shaidyLoadRepository(server@protoOpts$accessMethod, server@protoOpts$basePath);
assign(envir=ngchm.env, 'shaidyStack', c(list(sr), ngchm.env$shaidyStack));
};
#' Find a repository, if any, that contains the requested shaid
#'
#' @param shaid The shaid to search for
#' @param required Abort if requireed and shaid not found in a known repo
#'
#' @return The first repository containing the shaid, otherwise NULL. The
#' temporary repositories are searched before source repositories.
#'
#' @export
ngchmFindRepo <- function (shaid, required=TRUE) {
repo <- shaidyFindRepo (c(list(ngchm.env$tmpShaidy),ngchm.env$tmpShaidyStack,ngchm.env$shaidyStack), shaid);
if (required && length(repo)==0) {
stop (sprintf ("Shaid %s %s not found in any known repository", shaid@type, shaid@value));
}
repo
}
#' Create a new collection in a local shaidy repository
#'
#' @param shaidyRepo The shaidy repository
#' @param labels Initial labels for collection (a data.frame of (Name,Value) tuples)
#'
#' @return a string containing the UUID of the newly created repository
#'
#' @import jsonlite
#'
#' @export
ngchmNewCollection <- function (shaidyRepo, labels=data.frame()) {
labels <- as.data.frame (labels);
if (nrow (labels) > 0) {
stopifnot ("Name" %in% colnames(labels));
stopifnot ("Value" %in% colnames(labels));
}
shaidyRepo$createCollection (labels)
};
#' Recursively determine if collection uuid is contained in collection
#' A collecton always contains itself.
#'
#' @param collection A list containing details of a collection
#' @param uuid A string containing the UUID to check
#'
#' @return TRUE iff collection contains uuid, otherwise FALSE
#'
#' @export
ngchmCollectionInCollection <- function (collection, uuid) {
if (collection$uuid == uuid) return (TRUE);
if (uuid %in% collection$collections) return (TRUE);
shaidyRepo <- collection$repo;
todo <- collection$collections;
done <- collection$uuid;
while (length (todo) > 0) {
collect.uuid <- todo[[1]];
todo <- todo[-1];
if (!collect.uuid %in% done) {
collection <- shaidyRepo$loadCollection(collect.uuid);
if (uuid %in% collection$collections) return (TRUE);
todo <- append (collection$collections, todo);
done <- append (done, collection$uuid);
}
}
return (FALSE);
}
#' Add a matrix reference to a collection
#'
#' @param collection A list containing details of a collection
#' @param name The name to associate with the matrix reference
#' @param shaid The shaid of the matrix to add to the collection
#'
#' @return An updated list contaiing details of the collection
#'
#' @import jsonlite
#'
#' @export
ngchmAddMatrixToCollection <- function (collection, name, shaid) {
mats <- collection$matrices;
if (!any(mats$Name==name)) {
mats <- rbind (mats, data.frame(Name=name, Shaid=shaid@value));
writeBinLines(jsonlite::toJSON(mats,pretty=TRUE),
file.path (collection$basepath, "matrices.json"));
collection$matrices <- mats;
}
collection
};
#' Add an object reference to a collection
#'
#' @param repo The repository containing the collection
#' @param uuid A collection uuid
#' @param shaid The shaid of the object to add to the collection
#'
#' @return An updated list containing details of the collection
#'
#' @import jsonlite
#'
#' @export
ngchmAddObjectToCollection <- function (repo, uuid, shaid) {
stopifnot (is(shaid,"shaid"),
shaid@type %in% c('chm','dataset','label','collection'));
collection <- repo$loadCollection(uuid);
repo$addObjectToCollection (collection, shaid)
};
#' Render a shaidy NGCHM
#'
#' @param repo The repository containing the chm
#' @param shaid The shaid of the chm to render
#'
#' @return Nothing
#'
#' @export
ngchmRenderChm <- function (repo, shaid) {
stopifnot (is(shaid,"shaid"),
shaid@type %in% c('chm'));
repo$renderChm (shaid)
};
#' Create a recursive description of a collection
#'
#' @param collection A list containing details of a collection
#' @param depth The indentation depth to use
#'
#' @return a string vector describing the contents of the collection
#'
#' @export
ngchmCollectionTree <- function (collection, depth=0) {
indent <- paste0 (rep (" ", depth), collapse='');
c(sprintf ("%scollection %s", indent, collection$uuid),
sprintf ("%s label %s=%s", indent, collection$labels$Name, collection$labels$Value),
sprintf ("%s matrix %s=%s", indent, collection$matrices$Name, collection$matrices$Shaid),
sprintf ("%s ngchm %s", indent, collection$chms),
lapply (collection$collections, function(uuid) {
ngchmCollectionTree (collection$repo$loadCollection(uuid), depth+1)
}),
recursive=TRUE)
}
#' Compute shaid for a data file
#'
#' @param format The format of the data file
#' @param filename The filesystem path to the data file
#'
#' @return The shaid of the data file
#'
#' @import jsonlite
#'
#' @export
ngchmGetDataFileShaid <- function (format, filename) {
stopifnot (format == 'tsv');
gid <- gitHashObject (filename);
coreproperties <- list (format=format);
props.json <- jsonlite::toJSON(coreproperties);
new ('shaid', type='dataset', value=gitSha (paste('dataset',props.json,gid,sep='',collapse='')))
}
#' Add a data file to a local shaidy repository
#'
#' @param shaidyRepo The shaidy repository
#' @param format The format of the data file
#' @param filename The filesystem path to the data file
#' @param properties A list of additional properties to save with file
#'
#' @return The file's shaid
#'
#' @import jsonlite
#'
#' @export
ngchmAddDatasetBlob <- function (shaidyRepo, format, filename, properties=NULL) {
stopifnot (format == 'tsv');
if (format == 'tsv') {
index.filename <- utempfile ("index", fileext='.tsv');
tsvio::tsvGenIndex (filename, index.filename);
blobfiles = c('matrix.tsv', 'index.tsv');
filenames = c(filename, index.filename);
}
shaidyAddFileBlob (shaidyRepo, 'dataset', blobfiles, filenames,
properties=c(list(format=format),properties))
}
#' Save a numeric matrix as a blob in a shaidy repository
#'
#' @param shaidyRepo The shaidy repository
#' @param format The format in which to save the matrix
#' @param mat The data matrix
#'
#' @return The shaid of the saved blob
#'
#' @export
ngchmSaveAsDatasetBlob <- function (shaidyRepo, format, mat) {
if (is (mat, 'shaid')) return (mat);
stopifnot (format == 'tsv',
is (mat, 'matrix'),
length (dim(mat)) == 2,
length (rownames(mat)) > 0,
length (colnames(mat)) > 0);
stopifnot (sum(duplicated(rownames(mat))) == 0,
sum(duplicated(colnames(mat))) == 0);
filename <- utempfile ("matrix", fileext='.tsv');
con <- file (filename, "wb");
write.table (mat, con, quote=FALSE, sep='\t', eol='\n');
close(con);
class(format) <- 'singleElement';
props <- list(nrow=nrow(mat),ncol=ncol(mat));
class(props[[1]]) <- 'singleElement';
class(props[[2]]) <- 'singleElement';
shaid <- ngchmAddDatasetBlob (shaidyRepo, format, filename, props);
unlink (filename);
shaid
}
#' Load a data matrix from a local shaidy repository
#'
#' @param shaidyRepo The shaidy repository
#' @param shaid The shaid of the dataset blob to load
#' @param datatype Prototype of matrix data elements (defaults to 0.0)
#'
#' @return a list containing details of the loaded dataset
#'
#' @import jsonlite
#'
#' @export
ngchmLoadDatasetBlob <- function (shaidyRepo, shaid, datatype) {
blobdir <- shaidyRepo$blob.path ('dataset', shaid@value);
props <- jsonlite::fromJSON (readLines (file.path (blobdir, "properties.json")));
mat <- suppressWarnings (tsvio::tsvGetData (file.path (blobdir, "matrix.tsv"), file.path (blobdir, "index.tsv"),
NULL, NULL, if (missing(datatype)) 0.0 else datatype));
list (shaid=shaid, properties=props, mat=mat)
}
writeHCDataTSVs <- function(uDend, theOutputHCDataFileName, theOutputHCOrderFileName)
{
if (is(uDend,'dendrogram')) uDend <- nr.as.hclust.dendrogram(dendfixh(uDend));
stopifnot (is (uDend, 'hclust'));
data <- cbind(uDend$merge, uDend$height, deparse.level=0);
colnames(data)<-c("A", "B", "Height")
###Write out the data as a Tab separated file to the specified location
write.table(data, file = theOutputHCDataFileName, append = FALSE, quote = FALSE, sep = "\t", row.names=FALSE, eol='\n')
data <- t(vapply(1:length(uDend$labels),function(i)c(uDend$labels[i],which(uDend$order==i)),c("a",1)));
colnames(data) <- c("Id", "Order")
###Write out the order data as a Tab separated file to the specified location (1 more row than data file)
write.table(data, file = theOutputHCOrderFileName, append = FALSE, quote = FALSE, sep = "\t", row.names=FALSE, eol='\n')
}
ngchmSaveTemplateAsBlob <- function (shaidyRepo, source.path, dest.path, substitutions) {
blobdir <- shaidyCreateProtoBlob(shaidyRepo,'file');
writeTemplate(source.path, dest.path, substitutions, blobdir);
shaid <- shaidyHashProtoBlob('file', blobdir);
shaidyFinalizeProtoBlob(shaidyRepo, shaid, blobdir)
}
#' Save a dendrogram as a blob in a shaidy repository
#'
#' @param shaidyRepo The shaidy repository
#' @param ddg The dendrogram
#'
#' @return The shaid of the saved blob
#'
#' @export
ngchmSaveAsDendrogramBlob <- function (shaidyRepo, ddg) {
if (is (ddg, 'shaid')) return (ddg);
stopifnot (is (ddg, 'dendrogram'));
datafilename <- utempfile ("ddg", fileext='.txt');
orderfilename <- utempfile ("ddg", fileext='.txt');
writeHCDataTSVs (ddg, datafilename, orderfilename);
ddgfilename <- utempfile ("ddg", fileext='.str');
sink(ddgfilename);
nr.str.dendrogram(ddg);
sink(NULL);
rdafilename <- utempfile ("ddg", fileext='.rda');
save (ddg, file=rdafilename);
shaid <- shaidyAddFileBlob (shaidyRepo, 'dendrogram',
c('dendrogram-data.tsv', 'dendrogram-order.tsv', 'dendrogram.str', 'dendrogram.rda'),
c(datafilename, orderfilename, ddgfilename, rdafilename));
unlink (datafilename);
unlink (orderfilename);
unlink (ddgfilename);
unlink (rdafilename);
shaid
}
#' @import stats
#' @export
as.dendrogram.shaid <- function (object, ...) {
stopifnot (is(object,"shaid"), object@type=='dendrogram');
repo <- ngchmFindRepo (object);
ee <- new.env();
load (repo$blob.path (object, 'dendrogram.rda'), ee);
stopifnot (exists ('ddg', ee));
return (get ('ddg', ee));
}
#' @export
as.hclust.shaid <- function (x, ...) {
nr.as.hclust.dendrogram (dendfixh (stats::as.dendrogram (x)));
}
#' Row center a shaidy dataset
#'
#' @param shaidyRepo The shaidy repository
#' @param shaid The shaid of the dataset to row center
#'
#' @return A list of shaids for the row centered dataset
ngchmRowCenter <- function (shaidyRepo, shaid) {
provid <- shaidyProvenance (shaidyRepo, name="ngchmRowCenter", shaid=shaid@value);
res <- shaidyRepo$provenanceDB$get ('dataset',provid);
if (length(res) == 0) {
ds <- ngchmLoadDatasetBlob (shaidyRepo, shaid);
mm <- rowMeans (ds$mat, na.rm=TRUE);
res <- list(ngchmSaveAsDatasetBlob (shaidyRepo, 'tsv', ds$mat-mm));
shaidyRepo$provenanceDB$insert (provid, res[[1]]);
}
res
}
#' Make a shaidy format NGCHM.
#'
#' @param chm The shaidy format CHM to compile.
#' @return The CHM
ngchmMakeFormat.shaidy <- function (chm) {
chm
}
#' Get the axis labels of a shaidy dataset or dendrogram
#'
#' @param shaid The shaid of the dataset or dendrogram to get the labels of
#' @param axis For datasets, the axis of the labels to get
#'
#' @return a list of shaids containing the labels
#'
#' @export
ngchmGetLabels <- function (shaid, axis=NULL) {
stopifnot (is(shaid,"shaid"),
(shaid@type=='dendrogram') || (axis %in% c("row","column")));
shaidyRepo <- ngchm.env$tmpShaidy;
provid <- shaidyProvenance (shaidyRepo, name="ngchmGetLabels", type=shaid@type, shaid=shaid@value, axis=axis);
res <- shaidyRepo$provenanceDB$get ('label', provid);
if (length(res) == 0) {
srcRepo <- ngchmFindRepo (shaid);
if (srcRepo$accessMethod == "api") {
if (shaid@type == 'dataset' && axis == 'row') {
labels <- jsonlite::fromJSON(readLines(srcRepo$blob.path ('rowlabels', shaid@type, shaid@value), warn=FALSE))[[1]];
} else if (shaid@type == 'dataset' && axis == 'column') {
labels <- readLines(srcRepo$blob.path ('bylabel', shaid@type, shaid@value))[[1]];
labels <- strsplit (labels, '\t')[[1]];
} else {
stop ("Not implemented");
}
} else if (shaid@type == 'dataset') {
ds <- ngchmLoadDatasetBlob (srcRepo, shaid);
labels <- (if (axis=="row") rownames else colnames)(ds$mat);
} else if (shaid@type == 'dendrogram') {
oo <- read.delim (srcRepo$blob.path(shaid@type,shaid@value,"dendrogram-order.tsv"), header=TRUE, colClasses=c('character','numeric'));
labels <- oo$Id[order(oo$Order)]
} else {
stop (sprintf ("Unknown shaid type %s", shaid@type));
}
res <- list(ngchmSaveLabelsAsBlob (shaidyRepo, labels));
shaidyRepo$provenanceDB$insert (provid, res[[1]]);
}
res
}
ngchmSaveLabelsAsBlob <- function (shaidyRepo, labels) {
filename <- utempfile ("label", fileext='.txt');
writeBinLines (labels, filename);
res <- shaidyAddFileBlob (shaidyRepo, 'label', 'labels.txt', filename);
unlink (filename);
res
}
#' Get the axis labels of a shaidy dataset or dendrogram
#'
#' @param shaid The shaid of the dataset or dendrogram to get the labels of
#' @param axis For datasets, the axis of the labels to get
#'
#' @return A string vector containing the axis labels of the dataset or dendrogram
#'
#' @export
ngchmGetLabelsStr <- function (shaid, axis=NULL) {
res <- ngchmGetLabels (shaid, axis);
blobfile <- ngchm.env$tmpShaidy$blob.path (res[[1]]@type, res[[1]]@value, 'labels.txt');
readLines (blobfile)
}
#' Save an NGCHM as a shaidy blob
#'
#' @param shaidyRepo The shaidy repository to write to
#' @param chm The NGCHM to write
#'
#' @return The shaid of the saved NGCHM
ngchmSaveChmAsBlob <- function (shaidyRepo, chm) {
stopifnot (is(shaidyRepo,"shaidyRepo"),
is(chm,"ngchm"));
blob <- shaidyCreateProtoBlob (shaidyRepo, 'chm');
writeChm (chm, blob);
writeChmPost (chm, blob);
shaid <- shaidyHashProtoBlob ('chm', blob);
shaidyFinalizeProtoBlob (shaidyRepo, shaid, blob)
}
#' Get the tiles for a shaidy dataset
#'
#' @param repo The shaidy repository in which to create the tile
#' @param dataset The shaid of the dataset to tile
#' @param rowOrder The row order of the tiles
#' @param colOrder The column order of the tiles
#'
#' @return a list of shaids containing the tiles
#'
#' @export
ngchmTileDataset <- function (repo, dataset, rowOrder, colOrder) {
stopifnot (is(repo,"shaidyRepo"),
is(dataset,"shaid"), is(rowOrder,"shaid"), is(colOrder,"shaid"),
rowOrder@type %in% c("label","dendrogram"),
colOrder@type %in% c("label","dendrogram"));
if (rowOrder@type=="dendrogram") rowOrder <- ngchmGetLabels(rowOrder,"row")[[1]];
if (colOrder@type=="dendrogram") colOrder <- ngchmGetLabels(colOrder,"column")[[1]];
provid <- shaidyProvenance (repo, name="tileDataset", dataset=dataset@value, rowOrder=rowOrder@value, colOrder=colOrder@value);
res <- repo$provenanceDB$get ('tile', provid);
if (length(res) == 0) {
blob <- shaidyCreateProtoBlob (repo, 'tile');
stopifnot (system2 ("tiledata", args=c(vapply(c(dataset,rowOrder,colOrder),repo$blob.path,""),blob)) == 0);
shaid <- shaidyHashProtoBlob ('tile', blob);
shaidyFinalizeProtoBlob (repo, shaid, blob)
repo$provenanceDB$insert (provid, shaid);
res <- list(shaid)
}
res
}
#' Get the user's current collection
#'
#' @return the identity of the current collection
#'
#' @export
#'
#' @seealso [chmSetCollection()]
chmCurrentCollection <- function () {
if (length(ngchm.env$currentServer) == 0 && length(ngchm.env$servers) > 0) {
chmSetCollection (getOption("NGCHM.Collection", "//"));
}
return (ngchm.env$currentCollection);
}
#' Get the user's current server
#'
#' @return the identity of the current server
#'
#' @export
#' @seealso [chmListServers()]
#' @seealso [chmServer()]
#' @seealso [chmSetCollection()]
chmCurrentServer <- function () {
if (length(ngchm.env$currentServer) == 0 && length(ngchm.env$servers) > 0) {
chmSetCollection (getOption("NGCHM.Collection", "//"));
}
return (ngchm.env$currentServer);
}
#' Set the user's current server and/or collection
#'
#' The path is a sequence of components separated by slashes (/).
#' If the path begins with a double slash (//) the following
#' component is interpreted as a server name. If the server name is
#' omitted (i.e. empty) the default server will be used. If the path
#' does not begin with a double slash, the current server will be used.
#'
#' If the path begins with a slash, the components (following the
#' server, if specified) are interpreted relative to
#' the root collection of the server concerned. Otherwise, they
#' are interpreted relative to the current collection.
#'
#' The interpretation of each path component is server specific.
#'
#' @param path A path specifying a server and/or collection
#'
#' @export
#'
#' @seealso [chmCurrentCollection()]
#' @seealso [chmServer()]
#' @seealso [chmListServers()]
chmSetCollection <- function (path) {
stopifnot (!missing(path) && typeof(path)=="character" && length(path)==1);
res <- parsePathSpec (path);
ngchm.env$currentServer <- res$server;
ngchm.env$currentCollection <- res$collection;
}
parsePathSpec <- function (path) {
newServer <- ngchm.env$currentServer;
if (length(newServer) == 0 || newServer=="") {
newServer <- chmListServers()[1];
}
newCollection <- ngchm.env$currentCollection;
if (length(newCollection) == 0) {
newCollection <- "";
}
parts <- strsplit (path, "/")[[1]];
if (length(parts) > 1 && parts[1]=="" && parts[2]=="") {
parts <- parts[c(-1,-2)];
if (length(parts) > 0 && parts[1]!="") {
newServer <- parts[1];
}
if (is.na(newServer) || !(newServer %in% chmListServers())) {
stop ("cannot set server: ", newServer);
}
if (length(parts) > 0) parts <- parts[-1];
newCollection <- "";
} else if (length(parts) > 0 && parts[1] == "") {
parts <- parts[-1];
newCollection <- "";
}
if (length(parts) > 0) {
server <- chmServer (newServer);
newCollection <- server@serverProtocol@findCollection (server, newCollection, parts);
if (length(newCollection)==0) {
stop ("cannot find collection: ", path);
}
}
list (server=newServer, collection=newCollection)
}
#' Create a new collection
#'
#' The path is a sequence of components separated by slashes (/).
#' If the path begins with a double slash (//) the following
#' component is interpreted as a server name. If the server name is
#' omitted (i.e. empty) the default server will be used. If the path
#' does not begin with a double slash, the current server will be used.
#'
#' If the path begins with a slash, the components (following the
#' server, if specified) are interpreted relative to
#' the root collection of the server concerned. Otherwise, they
#' are interpreted relative to the current collection.
#'
#' The interpretation of each path component is server specific.
#'
#' @param path A path specifying a collection to be created
#' @param recursive If TRUE, create intermediate collections as required
#'
#' @export
#'
#' @seealso [chmCurrentCollection()]
chmCreateCollection <- function (path, recursive=FALSE) {
stopifnot (!missing(path) && typeof(path)=="character" && length(path)==1);
server <- ngchm.env$currentServer;
collection <- ngchm.env$currentCollection;
parts <- strsplit (path, "/")[[1]];
if (length(parts) > 1 && parts[1]=="" && parts[2]=="") {
parts <- parts[c(-1,-2)];
if (length(parts) == 0 || parts[1]=="") {
server <- chmListServers()[1];
} else {
server <- parts[1];
}
if (is.na(server) || !(server %in% chmListServers())) {
stop ("cannot find server: ", server);
}
if (length(parts) > 0) parts <- parts[-1];
collection <- "";
} else if (length(parts) > 0 && parts[1] == "") {
parts <- parts[-1];
collection <- "";
}
if (length(parts) > 0) {
server <- chmServer (server);
subCollection <- server@serverProtocol@findCollection (server, collection, parts[1]);
while (length(subCollection) != 0) {
parts <- parts[-1];
collection <- subCollection;
if (length(parts) == 0) {
subCollection <- NULL;
} else {
subCollection <- server@serverProtocol@findCollection (server, collection, parts[1]);
}
}
}
if (length(parts) == 0) {
stop ("collection ", path, " exists");
} else if (!recursive && (length(parts) > 1)) {
stop ("collection ", path, " does not exist");
} else {
while (length (parts) > 0) {
collection <- server@serverProtocol@createCollection (server, collection, parts[1]);
if (length(collection) == 0) {
stop ("cannot create collection ", path);
}
parts <- parts[-1];
}
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.