R/ngchmshaidy.R

Defines functions writeHCDataTSVs ngchmShaidyInit

Documented in ngchmShaidyInit

#' 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];
        }
    }
}
bmbroom/NGCHMR documentation built on April 18, 2022, 6:52 p.m.