#' @import methods
#' @import utils
NULL
#' Function to initialize logging
#'
#' @param log_level One of 'TRACE', 'DEBUG', 'INFO', 'SUCCESS'
#' @param log_file Desired path/name of log file
#' @export
#' @importFrom logger log_threshold
#' @importFrom logger log_layout
#' @importFrom logger log_debug
#' @importFrom logger log_error
#' @importFrom logger log_appender
#' @importFrom logger appender_file
#' @importFrom logger appender_console
#' @importFrom logger layout_glue_generator
#' @importFrom logger layout_glue
initLogging <- function(log_level,log_file=NULL) {
log_threshold(log_level)
if (!is.null(log_file)) {
log_appender(appender_file(log_file))
log_layout(layout_glue_generator(format = paste(
'{level}',
'[{format(time, "%Y-%m-%d %H:%M:%S")}]',
'{fn}',
'{msg}')))
log_info('Writing log to file: ',log_file)
} else {
log_appender(appender_console)
log_layout(layout_glue_generator(format = paste(
'{crayon::bold(colorize_by_log_level(level, levelr))}',
'[{crayon::italic(format(time, "%Y-%m-%d %H:%M:%S"))}]',
'{crayon::blue(fn)}',
'{grayscale_by_log_level(msg, levelr)}')))
}
log_debug('Set log level to ',log_level)
}
systemCheck <- function (command, ...) {
# Execute the specified command and halt execution with an error
# message if it fails.
status <- system (command, ...)
if (status != 0) {
stop ('Error encountered executing system command: ', command)
}
}
# Returns TRUE if object has any of the specified classes.
#
isany <- function (object, classes) {
any (vapply (classes, function(cls) is(object, cls), TRUE))
};
# Returns the class(es) of object as a single string.
#
classstr <- function (object) {
paste (class (object), collapse=",")
};
#' Register an ngchmServer.
#'
#' This function registers an ngchmServer that can be used when
#' making and installing a Next Generation Clustered Heat Map.
#'
#' @param uuid A string that identifies the server namespace.
#' @param server The ngchmServer to register.
#'
#' @return the server that was registered
#' @export
#'
#' @seealso [chmInstall()]
#' @seealso [chmUninstall()]
#' @seealso [ngchmUnregisterServer()]
#' @seealso [ngchmServer-class]
#'
ngchmRegisterServer <- function (uuid, server) {
obj <- list (uuid=uuid, name=server@name, server=server);
matches <- which (vapply (ngchm.env$servers, function(srv) ((srv$uuid == uuid) && (srv$name == server@name)), TRUE));
if (length (matches) > 0) {
ngchm.env$servers[[matches]] <- obj;
} else {
ngchm.env$servers <- append (ngchm.env$servers, list(obj));
}
server
}
#' Unregister ngchmServer(s).
#'
#' This function unregisters one or more ngchmServer(s).
#'
#' @param uuid A string that identifies the server namespace.
#' @param name The names(s) of the ngchmServer(s) to unregister. If not specified, all ngchmServers in the
#' namespace are unregistered.
#'
#' @export
#'
#' @seealso [ngchmRegisterServer()]
#' @seealso [ngchmServer-class]
#'
ngchmUnregisterServer <- function (uuid, name=NULL) {
if (length(name) == 0) {
matches <- vapply (ngchm.env$servers, function(srv) (srv$uuid == uuid), TRUE);
} else {
matches <- vapply (ngchm.env$servers, function(srv) ((srv$uuid == uuid) && (srv$name %in% name)), TRUE);
}
if (sum (matches) > 0) {
ngchm.env$servers <- ngchm.env$servers[!matches];
}
}
#' Get a registered ngchmServer object for use in making and installing NGCHMs
#'
#' This function returns a ngchmServer object that can be used when
#' making and installing a Next Generation Clustered Heat Map.
#'
#' @param name The name of the ngchmServer desired.
#'
#' @return An object of class ngchmServer if found, NULL otherwise. If multiple servers of the same
#' name have been defined (in different namespaces), the most recently defined is returned.
#'
#' @export
#'
#' @seealso [chmInstall()]
#' @seealso [chmUninstall()]
#' @seealso [ngchmServer-class]
#'
chmServer <- function (name) {
matches <- which (vapply (ngchm.env$servers, function(srv) (srv$name == name), TRUE));
if (length (matches) > 0) {
return (ngchm.env$servers[[matches[length(matches)]]]$server);
} else {
return (NULL);
}
}
#' Get the ngchm environment (for debugging only).
#'
#' Get the library's internal ngchm environment to help debugging.
#'
#' @export
ngchmGetEnv <- function () {
return (ngchm.env);
}
#' Create a new NGCHM.
#'
#' This function creates a Next Generation Clustered Heat Map (NGCHM) object in memory.
#' Additional parameters will be added to the new NGCHM (see chmAdd).
#' The bare NGCHM needs at least one data layer added to it before it can be compiled.
#'
#' @param name The name under which the NGCHM will be saved to the NGCHM server.
#' @param ... Zero or more initial objects to include in the NGCHM (see chmAdd).
#' @param rowOrder A vector, dendrogram, or function specifying the CHM row order.
#' @param rowDist Distance method to use by default RowOrder
#' @param rowAgglom Agglomeration method to use by default RowOrder
#' @param colOrder A vector, dendrogram, or function specifying the CHM column order.
#' @param colDist Distance method to use by default ColOrder
#' @param colAgglom Agglomeration method to use by default ColOrder
#' @param rowAxisType The type(s) of the row labels (default: None).
#' @param colAxisType The type(s) of the column labels (default: None).
#' @param rowCovariates Covariate(Bar)(s) to add to the rows (default: None).
#' @param colCovariates Covariate(Bar)(s) to add to the columns (default: None).
#' @param format The format of NGCHM to produce (default: 'original').
#' @param rowGapLocations Locations for row gaps. Specify as a list of integers or [chmTreeGaps()] function.
#' @param colGapLocations Locations for col gaps. Specify as a list of integers or [chmTreeGaps()] function.
#' @param rowGapWidth Width of row gaps (default: 5 rows)
#' @param colGapWidth Width of col gaps (default: 5 cols)
#' @param overview The format(s) of overview image(s) to create (default: None).
#' @importFrom logger log_debug
#' @importFrom logger log_error
#'
#' @return An object of class ngchm
#'
#' @export
#'
#' @examples
#' mychm <- chmNew ("test_chm")
#' mychm <- chmNew("test_chm", rowGapLocations=c(3,5))
#' mychm <- chmNew("test_chm", rowGapLocations=chmTreeGaps(4))
#' mychm <- chmNew("test_chm", rowGapWidth=3)
#'
#' @seealso [ngchm-class]
#' @seealso [ngchmServer-class]
#' @seealso [chmAdd()]
#' @seealso [chmAddAxisType()]
#' @seealso [chmAddCovariateBar()]
#' @seealso [chmAddProperty()]
#' @seealso [chmAddOverview()]
#' @seealso [chmInstall()]
#' @seealso [chmExportToFile()]
#' @seealso [chmExportToPDF()]
#' @seealso [chmExportToHTML()]
chmNew <- function (name, ...,
rowOrder=chmDefaultRowOrder, rowDist="correlation", rowAgglom="ward.D2",
colOrder=chmDefaultColOrder, colDist="correlation", colAgglom="ward.D2",
rowAxisType=NULL, colAxisType=NULL,
rowCovariates=NULL, colCovariates=NULL,
format="original",
rowGapLocations=NULL,
rowGapWidth=5,
colGapLocations=NULL,
colGapWidth=5,
overview=c(),
logLevel='INFO', logFile=NULL) {
initLogging(logLevel, logFile)
chm <- new (Class="ngchmVersion2",
name=name,
format=format,
inpDir=utempfile("ngchm.input"),
outDir=utempfile("ngchm.output"),
rowDist=rowDist,
rowAgglom=rowAgglom,
colDist=colDist,
colAgglom=colAgglom,
rowOrderMethod="",
colOrderMethod="",
rowCutLocations=rowGapLocations,
rowCutWidth=rowGapWidth,
colCutLocations=colGapLocations,
colCutWidth=colGapWidth
);
chmRowOrder(chm) <- rowOrder;
chmColOrder(chm) <- colOrder;
chm@uuid <- getuuid (name);
chm <- chmAddCSS (chm, 'div.overlay { border: 2px solid yellow; }');
chm <- chmAddList (chm, list(...));
if (!is.null(rowAxisType)) chm <- chmAddAxisType (chm, 'row', rowAxisType);
if (!is.null(colAxisType)) chm <- chmAddAxisType (chm, 'column', colAxisType);
if (!is.null(rowCovariates)) {
if (is.list (rowCovariates)) {
for (cov in rowCovariates) chm <- chmAddCovariateBar (chm, 'row', cov);
} else {
chm <- chmAddCovariateBar (chm, 'row', cov);
}
}
if (!is.null(colCovariates)) {
if (is.list (colCovariates)) {
for (cov in colCovariates) chm <- chmAddCovariateBar (chm, 'column', cov);
} else {
chm <- chmAddCovariateBar (chm, 'col', cov);
}
}
for (ov in overview) chm <- chmAddOverview (chm, ov, NULL, NULL);
chm
}
#' Compute cosine (angular) distance matrix
#'
#' @param data A numeric matrix
cos.dist1 <- function (data) {
dmat <- matrix (0.0, nrow=nrow(data), ncol=nrow(data))
sumrowsqr <- sqrt (apply (data*data, 1, sum))
inner <- data %*% t(data)
dmat <- inner / (sumrowsqr %*% t(sumrowsqr))
# Adjust distance matrix to avoid clustering error with identical rows.
rrr <- matrix (abs(rnorm(length(dmat), sd=1e-10)), nrow=nrow(dmat));
dmat <- (1-rrr) * dmat;
return (2/pi*acos(as.dist(dmat)));
}
#' Return default column order of an NGCHM
#'
#' @param chm An NGCHM containing at least one layer
#'
#' @return Shaid of a dendrogram suitable for use as the
#' chm's column order.
#'
#' @export
chmDefaultColOrder <- function (chm) {
chm <- chmFixVersion (chm);
if (length (chm@layers) == 0) stop ("chm requires at least one layer");
shaidyRepo <- ngchm.env$tmpShaidy;
shaid <- chm@layers[[1]]@data;
provid <- shaidyProvenance (shaidyRepo, name="chmDefaultColOrder",
shaid=shaid@value, dist=chm@colDist,
agglom=chm@colAgglom);
res <- shaidyRepo$provenanceDB$get ('dendrogram', provid);
if (length(res) == 0) {
mat <- ngchmLoadDatasetBlob (shaidyRepo, shaid)$mat;
if (chm@colDist == "correlation") {
dd <- as.dist(1-cor(mat, use="pairwise"));
} else if (chm@colDist == "cosine") {
dd <- cos.dist1 (t(mat));
} else {
dd <- dist (t(mat), method=chm@colDist);
}
ddg <- stats::as.dendrogram(stats::hclust(dd, method=chm@colAgglom))
res <- list(ngchmSaveAsDendrogramBlob (shaidyRepo, ddg));
shaidyRepo$provenanceDB$insert (provid, res[[1]]);
}
res[[1]]
}
#' Convert a user specified dendrogram to a shaid
#'
#' @param ddg The dendrogram to convert.
chmUserDendrogramToShaid <- function (ddg) {
shaidyRepo <- ngchm.env$tmpShaidy;
ngchmSaveAsDendrogramBlob (shaidyRepo, ddg)
}
#' Convert user specified labels to a shaid
#'
#' @param labels A string vector containing axis labels.
chmUserLabelsToShaid <- function (labels) {
shaidyRepo <- ngchm.env$tmpShaidy;
ngchmSaveLabelsAsBlob (shaidyRepo, labels)
}
#' Return default row order of an NGCHM
#'
#' @param chm An NGCHM containing at least one layer
#'
#' @return Shaid of a dendrogram suitable for use as the
#' chm's row order.
#'
#' @export
chmDefaultRowOrder <- function (chm) {
chm <- chmFixVersion (chm);
if (length (chm@layers) == 0) stop ("chm requires at least one layer");
shaidyRepo <- ngchm.env$tmpShaidy;
shaid <- chm@layers[[1]]@data;
provid <- shaidyProvenance (shaidyRepo, name="chmDefaultRowOrder",
shaid=shaid@value, dist=chm@rowDist,
agglom=chm@rowAgglom);
res <- shaidyRepo$provenanceDB$get ('dendrogram',provid);
if (length(res) == 0) {
mat <- ngchmLoadDatasetBlob (shaidyRepo, shaid)$mat;
if (chm@rowDist == "correlation") {
dd <- as.dist(1-cor(t(mat), use="pairwise"))
} else if (chm@rowDist == "cosine") {
dd <- cos.dist1 (mat);
} else {
dd <- dist (mat, method=chm@rowDist);
}
ddg <- stats::as.dendrogram(stats::hclust(dd, method=chm@rowAgglom));
res <- list(ngchmSaveAsDendrogramBlob (shaidyRepo, ddg));
shaidyRepo$provenanceDB$insert (provid, res[[1]]);
}
res[[1]]
}
#' Return original row order of an NGCHM
#'
#' @param chm An NGCHM containing at least one layer
#'
#' @return Shaid of a label order suitable for use as the
#' chm's row order.
#'
#' @export
chmOriginalRowOrder <- function (chm) {
chm <- chmFixVersion (chm);
if (length (chm@layers) == 0) stop ("chm requires at least one layer");
shaidyRepo <- ngchm.env$tmpShaidy;
shaid <- chm@layers[[1]]@data;
provid <- shaidyProvenance (shaidyRepo, name="chmOriginalRowOrder",
shaid=shaid@value);
res <- shaidyRepo$provenanceDB$get ('label',provid);
if (length(res) == 0) {
mat <- ngchmLoadDatasetBlob (shaidyRepo, shaid)$mat;
labels <- rownames(mat);
labels.shaid <- ngchmSaveLabelsAsBlob (shaidyRepo, labels);
shaidyRepo$provenanceDB$insert (provid, labels.shaid);
res <- list(labels.shaid);
}
res[[1]]
}
#' Return random row order of an NGCHM
#'
#' @param chm An NGCHM containing at least one layer
#'
#' @return Shaid of a label order suitable for use as the
#' chm's row order.
#'
#' @export
chmRandomRowOrder <- function (chm) {
chm <- chmFixVersion (chm);
if (length (chm@layers) == 0) stop ("chm requires at least one layer");
shaidyRepo <- ngchm.env$tmpShaidy;
shaid <- chm@layers[[1]]@data;
provid <- shaidyProvenance (shaidyRepo, name="chmRandomRowOrder",
shaid=shaid@value);
res <- shaidyRepo$provenanceDB$get ('label',provid);
if (length(res) == 0) {
mat <- ngchmLoadDatasetBlob (shaidyRepo, shaid)$mat;
labels <- rownames(mat)[sample.int(nrow(mat),nrow(mat))];
labels.shaid <- ngchmSaveLabelsAsBlob (shaidyRepo, labels);
shaidyRepo$provenanceDB$insert (provid, labels.shaid);
res <- list(labels.shaid);
}
res[[1]]
}
#' Return original column order of an NGCHM
#'
#' @param chm An NGCHM containing at least one layer
#'
#' @return Shaid of a label order suitable for use as the
#' chm's column order.
#'
#' @export
chmOriginalColOrder <- function (chm) {
chm <- chmFixVersion (chm);
if (length (chm@layers) == 0) stop ("chm requires at least one layer");
shaidyRepo <- ngchm.env$tmpShaidy;
shaid <- chm@layers[[1]]@data;
provid <- shaidyProvenance (shaidyRepo, name="chmOriginalColOrder",
shaid=shaid@value);
res <- shaidyRepo$provenanceDB$get ('label',provid);
if (length(res) == 0) {
mat <- ngchmLoadDatasetBlob (shaidyRepo, shaid)$mat;
labels <- colnames(mat);
labels.shaid <- ngchmSaveLabelsAsBlob (shaidyRepo, labels);
shaidyRepo$provenanceDB$insert (provid, labels.shaid);
res <- list(labels.shaid);
}
res[[1]]
}
#' Return random column order of an NGCHM
#'
#' @param chm An NGCHM containing at least one layer
#'
#' @return Shaid of a label order suitable for use as the
#' chm's column order.
#'
#' @export
chmRandomColOrder <- function (chm) {
chm <- chmFixVersion (chm);
if (length (chm@layers) == 0) stop ("chm requires at least one layer");
shaidyRepo <- ngchm.env$tmpShaidy;
shaid <- chm@layers[[1]]@data;
provid <- shaidyProvenance (shaidyRepo, name="chmRandomColOrder",
shaid=shaid@value);
res <- shaidyRepo$provenanceDB$get ('label',provid);
if (length(res) == 0) {
mat <- ngchmLoadDatasetBlob (shaidyRepo, shaid)$mat;
labels <- colnames(mat)[sample.int(ncol(mat),ncol(mat))];
labels.shaid <- ngchmSaveLabelsAsBlob (shaidyRepo, labels);
shaidyRepo$provenanceDB$insert (provid, labels.shaid);
res <- list(labels.shaid);
}
res[[1]]
}
chmAddAxis <- function (chm, axis) {
stopifnot (is(chm, "ngchm") && is(axis,"ngchmAxis"));
where <- match.arg (axis@axis, c("row", "column", "both"));
chm <- chmFixVersion (chm);
for (item in axis@objects) {
if (is(item, "ngchmAxisType")) {
item@where <- where;
chm@axisTypes <- append (chm@axisTypes, item);
chm <- chmAddProperty (chm, paste('!axistype', where, sep='.'), item@type)
} else if (isany (item, c("ngchmBar", "ngchmCovariate"))) {
chm <- chmAddCovariateBar (chm, where, item);
} else {
stop (sprintf ("Unable to add item of class '%s' to ngchm axis\n", classstr(item)));
}
}
chm
}
# Function used by chmNew and chmAdd:
chmAddList <- function (chm, args) {
#cat (sprintf ("chmAdd: %d items to add\n", length(args)), file=stderr());
for (item in args) {
if (is(item, "ngchmLayer")) { chm <- chmAddLayer (chm, item); }
else if (is(item, "matrix") && (mode(item) == "numeric")) { chm <- chmAddLayer (chm, item); }
else if (is(item, "ngchmDataset")) { chm <- chmAddDataset (chm, item); }
else if (is(item, "ngchmColormap")) { chm <- chmAddColormap (chm, item); }
else if (is(item, "ngchmDialog")) { chm <- chmAddDialog (chm, item); }
else if (is(item, "ngchmProperty")) { chmProperty(chm, item@label) <- item; }
else if (is(item, "ngchmAxis")) { chm <- chmAddAxis (chm, item); }
else if (is(item, "list")) { chm <- chmAddList (chm, item); }
else {
stop (sprintf ("Unable to add item of class '%s' to ngchm\n", classstr(item)));
}
}
chm
}
#' Create a new Data Layer for a NGCHM.
#'
#' This function creates a new Data Layer suitable for adding to a Next Generation Clustered Heat Map.
#'
#' @param label The name under which the data layer will be displayed to the user.
#' @param data A matrix containing the data to display. Must have rownames and colnames.
#' @param colors A color map specifying how the data should be rendered. If omitted or NULL,
#' a default green-black-red color map will be estimated from the data.
#' @param summarizationMethod The method to use when summarizing multiple data points per pixel. Possible values are average (default), sample, and mode.
#' @param cuts_color color of cuts
#'
#' @return An object of class ngchmLayer
#'
#' @export
#'
#' @examples
#' noise <- matrix (runif(1000) + runif(1000*1000), nrow=1000)
#' rownames(noise) <- sprintf ("Row%d", 1:nrow(noise))
#' colnames(noise) <- sprintf ("Col%d", 1:ncol(noise))
#' noise.colors <- chmNewColorMap (c(0,1,2),
#' c("green", "black", "red"), missing.color="yellow")
#' layer <- chmNewDataLayer ("Noisy Data", noise, noise.colors)
#'
#' @seealso [ngchmLayer-class]
#' @seealso [chmNewColorMap()]
#' @seealso [chmAddLayer()]
#'
chmNewDataLayer <- function (label, data, colors, summarizationMethod, cuts_color) {
if (typeof (label) != "character") {
stop (sprintf ("Parameter 'label' must have type 'character', not '%s'", typeof(label)));
}
if (length (label) != 1) {
stop (sprintf ("Parameter 'label' must have a single value, not %d", length(label)));
}
if (nchar (label) == 0) {
stop ("Parameter 'label' cannot be the empty string");
}
if (missing(colors)) colors <- NULL;
if (missing(summarizationMethod)) summarizationMethod <- "average";
if (missing(cuts_color)) cuts_color <- "#4c4c4c";
if (typeof (summarizationMethod) != "character") {
stop (sprintf ("Parameter 'summarizationMethod' must have type 'character', not '%s'", typeof(summarizationMethod)));
}
if (length (summarizationMethod) != 1) {
stop (sprintf ("Parameter 'summarizationMethod' must have a single value, not %d", length(summarizationMethod)));
}
if (typeof (cuts_color) != "character") {
stop (sprintf ("Parameter 'cuts_color' must have type 'character', not '%s'", typeof(cuts_color)));
}
if (length (cuts_color) != 1) {
stop (sprintf ("Parameter 'cuts_color' must have a single value, not %d", length(cuts_color)));
}
summarizationMethod = match.arg (summarizationMethod, c("average", "sample", "mode"));
data <- ngchmSaveAsDatasetBlob (ngchm.env$tmpShaidy, 'tsv', data);
if (length(colors) == 0)
colors <- chmNewColorMap (data, c("#0010a0", "#f0f0f0", "#a01000"), missing='#ff00ff'); # Blue, Off-white, Red. Missing=bright magenta.
new (Class="ngchmLayer", name=label, data=data, colors=colors, summarizationMethod=summarizationMethod, cuts_color=cuts_color)
};
#' Get a specified Data Layer from an NG-CHM.
#'
#' This function returns a Data Layer contained in a Next Generation Clustered Heat Map.
#'
#' @param hm The NG-CHM object to get the data layer from.
#' @param label The name or index of the data layer to get. If a name, return the layer with
#' that name. If no layer with that name exists or if the index is out of range,
#' return NULL.
#'
#' @return An object of class ngchmLayer or NULL.
#'
#' @export
#'
#' @examples
#' layer <- chmLayer (hm, "Layer 1")
#' layer <- chmLayer (hm, 1)
#'
#' @seealso [ngchmLayer-class]
#'
chmLayer <- function (hm, label) {
stopifnot (!missing(hm), is(hm, "ngchm"));
stopifnot (missing(label) || length(label) == 1);
if (length(hm@layers) == 0) return (NULL);
# Determine numeric layeridx from specified label
if (missing (label)) {
layeridx <- 1;
} else if (mode(label) == "character") {
layernames <- vapply (hm@layers, function(x)x@name, "");
layeridx <- which(label == layernames);
if (length(layeridx) == 0) return (NULL);
if (length(layeridx) > 1) stop ("NGCHM contains multiple layers with that name");
} else if (mode(label) == "numeric") {
if ((label < 1) || (label > length(hm@layers))) return (NULL);
layeridx <- label;
} else {
stop ("mode of label must be character or numeric");
}
hm@layers[[layeridx]]
};
#' Set (or append) a specified Data Layer in an NG-CHM.
#'
#' This function sets a Data Layer in a Next Generation Clustered Heat Map.
#'
#' @param x The NG-CHM object to set the data layer of
#' @param label The name or index of the data layer to set. If a name, replace the layer with
#' that name. Append a new layer if no layer with that name exists. If an index,
#' replace the specified layer. If zero (0), prepend the new layer. If minus one (-1)
#' or N+1 (for an NG-CHM with N layers), appends a new layer.
#' @param colors A colormap for the new layer. If missing, defaults to the color map of the
#' layer being replaced, or to the default new layer color map for a new layer.
#' @param summarizationMethod The summarization method for the new layer. If
#' missing, defaults to the summarization method of the layer being
#' replaced, or to the default new layer summarization method for a new layer.
#' @param cuts_color The cuts color for the new layer. If
#' missing, defaults to the cuts color of the layer being
#' replaced, or to the default cuts color for a new layer.
#' @param value Either a matrix or a data layer to set in the NG-CHM. If value is a matrix,
#' the other data layer parameters (label, colors, summarizationMethod,
#' and cuts_color) are set from the parameters if specified, from the old
#' data layer (if any), or the defaults for a new data layer (see chmNewDataLayer).
#' If value is a data layer, any other data layer parameters specified will
#' override those in the replacement layer.
#'
#' @return An object of class ngchm.
#'
#' @export
#'
#' @examples
#' chmLayer (hm, "Layer 1") <- matrix;
#' chmLayer (hm, 1, cuts_color = "#fefefe") <- chmNewDataLayer ("New data layer", matrix);
#'
#' @seealso [ngchmLayer-class]
#' @seealso chmNewDataLayer
#'
assign('chmLayer<-', function (x, label, colors, summarizationMethod, cuts_color, value) {
stopifnot (!missing(x), is(x, "ngchm"));
stopifnot (missing(label) || length(label) == 1);
stopifnot (!missing(value), isany(value, c("matrix", "ngchmLayer")));
hm <- NGCHM:::chmFixVersion (x);
# Convert label into a numeric layeridx and a character label
if (missing(label)) {
layeridx <- length(hm@layers)+1;
label <- sprintf ("Layer %d", layeridx);
} else if (mode(label) == "character") {
layernames <- vapply (hm@layers, function(x)x@name, "");
layeridx <- which(label == layernames);
if (length(layeridx) > 1) stop ("NGCHM contains multiple layers with that name");
if (length(layeridx) == 0) layeridx <- length(hm@layers) + 1;
} else if (mode(label) == "numeric") {
if ((label < -1) || (label > length(hm@layers)+1)) stop("Invalid label");
if (label < 0) {
layeridx <- length(hm@layers) + 1;
} else {
layeridx <- label;
}
if (label == 0) {
label <- "Layer 0";
} else if (label > length(hm@layers)) {
label <- sprintf ("Layer %d", length(hm@layers)+1);
} else {
label <- hm@layers[[layeridx]]@name;
}
} else {
stop ("mode of label must be either character or numeric")
}
if (is (value, "matrix")) {
if (layeridx <= length(hm@layers)) {
tmp <- hm@layers[[layeridx]];
if (missing(colors)) colors <- tmp@colors;
if (missing(summarizationMethod)) summarizationMethod <- tmp@summarizationMethod;
if (missing(cuts_color)) cuts_color <- tmp@cuts_color;
}
newlayer <- chmNewDataLayer (label, data=value, colors=colors, summarizationMethod=summarizationMethod, cuts_color=cuts_color);
} else if (is (value, "ngchmLayer")) {
newlayer <- value;
if (!missing(colors)) newlayer@colors <- colors;
if (!missing(summarizationMethod)) newlayer@summarizationMethod <- summarizationMethod;
if (!missing(cuts_color)) newlayer@cuts_color <- cuts_color;
}
NGCHM:::validateNewLayer (hm, newlayer);
if (layeridx == 0) {
hm@layers <- c (newlayer, hm@layers);
} else {
hm@layers[[layeridx]] <- newlayer;
}
chmAddColormap (hm, newlayer@colors)
});
#' Create a new Dataset for a NGCHM.
#'
#' This function creates a new Dataset suitable for attaching to a Next Generation Clustered Heat Map.
#'
#' @param name The filename prefix under which the dataset will be saved to the ngchm.
#' @param description A description of the dataset.
#' @param data A matrix containing the data in the dataset. Must have rownames and colnames.
#' @param row.covariates An optional list of row covariates.
#' @param column.covariates An optional list of column covariates.
#' @param row.type The type, if any, of the dataset rows.
#' @param column.type The type, if any, of the dataset columns.
#'
#' @return An object of class ngchmDataset
#'
#' @export
#'
#' @seealso [ngchmDataset-class]
#' @seealso [ngchmCovariate-class]
#' @seealso [chmAddDataset()]
#'
chmNewDataset <- function (name, description, data,
row.type = NULL,
column.type = NULL,
row.covariates = NULL,
column.covariates = NULL) {
if (typeof (name) != "character") {
stop (sprintf ("Parameter 'name' must have type 'character', not '%s'", typeof(name)));
}
if (length (name) != 1) {
stop (sprintf ("Parameter 'name' must have a single value, not %d", length(name)));
}
if (nchar (name) == 0) {
stop ("Parameter 'name' cannot be the empty string");
}
if (typeof (description) != "character") {
stop (sprintf ("Parameter 'description' must have type 'character', not '%s'", typeof(description)));
}
if (length (description) != 1) {
stop (sprintf ("Parameter 'description' must have a single value, not %d", length(description)));
}
if (nchar (description) == 0) {
warning ("Parameter 'description' should not be the empty string");
}
data <- ngchmSaveAsDatasetBlob (ngchm.env$tmpShaidy, 'tsv', data);
if (length (row.covariates) > 0) {
if (is(row.covariates, "ngchmCovariate")) {
row.covariates <- list (row.covariates);
} else if (is(row.covariates, "list")) {
stopifnot (all (vapply (row.covariates, function(cov)is(cov,"ngchmCovariate"), TRUE)));
} else {
stop (sprintf ("Parameter 'row.covariates' for dataset '%s' must be either a covariate or list of covariates, not a '%s'",
name, classstr(row.covariates)));
}
}
if (length (column.covariates) > 0) {
if (is(column.covariates, "ngchmCovariate")) {
column.covariates <- list (column.covariates);
} else if (is(column.covariates, "list")) {
stopifnot (all (vapply (column.covariates, function(cov)is(cov,"ngchmCovariate"), TRUE)));
} else {
stop (sprintf ("Parameter 'column.covariates' for dataset '%s' must be either a covariate or list of covariates, not a '%s'",
name, classstr(column.covariates)));
}
}
new (Class="ngchmDataset", name=name, description=description, data=data,
row.type = row.type,
column.type = column.type,
row.covariates = row.covariates,
column.covariates=column.covariates);
}
#' Create a new Covariate for adding to an NGCHM auxilary dataset.
#'
#' This function creates a new Covariate suitable for a covariate bar or attaching to an NGCHM auxilary dataset.
#'
#' @param fullname The full (human readable) name of the covariate.
#' @param values A named vector of values (character, logical, or numeric).
#' @param value.properties An ngchmColormap mapping values to properties.
#' @param type The string "discrete" or the string "continuous". (Defaults to continuous for numeric values, to discrete otherwise.)
#' @param covabbv The short R-compatible identifier used to identify the covariate (derived from fullname if not specified).
#'
#' @return An object of class ngchmCovariate.
#'
#' @export
#'
#' @seealso [ngchmCovariate-class]
#' @seealso [chmAddCovariate()]
#' @seealso [chmNewColorMap()]
#'
chmNewCovariate <- function (fullname, values, value.properties=NULL, type=NULL, covabbv=NULL)
{
# Validate basic properties of 'fullname'.
if (typeof (fullname) != "character") {
stop (sprintf ("Parameter 'fullname' must have type 'character', not '%s'", typeof(fullname)));
}
if (length (fullname) != 1) {
stop (sprintf ("Parameter 'fullname' must have a single value, not %d", length(fullname)));
}
if (nchar (fullname) == 0) {
stop (sprintf ("Parameter 'fullname' cannot be the empty string"));
}
# Validate basic properties of 'type'.
if (length(type) == 0) {
if (mode(values) == "numeric") {
type <- "continuous";
} else {
type <- "discrete";
}
} else {
if (typeof (type) != "character") {
stop (sprintf ("Parameter 'type' for covariate '%s' must have type 'character', not '%s'", fullname, typeof(type)));
}
if (length (type) != 1) {
stop (sprintf ("Parameter 'type' for covariate '%s' must have a single value, not %d", fullname, length(type)));
}
if (!(type %in% c("discrete", "continuous"))) {
stop (sprintf ("Parameter 'type' for covariate '%s' must be either 'discrete' or 'continuous', not '%s'", fullname, type));
}
}
if ((length (value.properties) > 0) && (!is(value.properties, "ngchmColormap"))) {
stop (sprintf ("value.properties for covariate '%s' must have class ngchmColormap, not '%s'",
fullname, classstr(value.properties)));
}
if (type == "continuous") {
if (mode(values) != "numeric") {
stop (sprintf ("Covariate '%s' has type continuous, so values must have mode numeric, not '%s'", fullname, mode(values)));
}
if (length (value.properties) == 0) {
value.properties <- chmNewColorMap (as.matrix(values,ncol=1));
}
} else if (length (value.properties) == 0) {
if (mode(values) == "numeric") {
value.properties <- chmNewColorMap (sort (unique (values)));
} else if (mode(values) == "logical") {
value.properties <- chmNewColorMap (c (FALSE, TRUE));
} else {
# We start with human-readable values
# We convert these into machine-readable codes
unames <- sort (unique (values));
uvals <- make.names(unames);
# The properties map uses codes, but maps to the original values.
value.properties <- chmNewColorMap (uvals, names=unames);
# Replace values with the corresponding codes.
values <- values[!is.na(values)];
idx <- vapply(values,function(vv)which(unames==vv),1);
values[] <- uvals[idx];
}
}
# Validate type of 'values'
if (mode (values) %in% c("numeric","logical"))
mode(values) <- "character";
if (length (covabbv) == 0) {
covabbv <- make.names(fullname);
} else {
if (typeof (covabbv) != "character") {
stop (sprintf ("Parameter 'covabbv' must have type 'character', not '%s'", typeof(covabbv)));
}
if (length (covabbv) != 1) {
stop (sprintf ("Parameter 'covabbv' must have a single value, not %d", length(covabbv)));
}
if (nchar (covabbv) == 0) {
stop ("Parameter 'covabbv' cannot be the empty string");
}
}
values <- values[order(names(values))];
mat <- matrix (values, ncol=1, dimnames=list(names(values),'Value'));
shaid <- ngchmSaveAsDatasetBlob (ngchm.env$tmpShaidy, 'tsv', mat);
new (Class="ngchmCovariate", label=covabbv, fullname=fullname, type=type,
label.series = shaid, series.properties=value.properties);
};
#' Get a covariate attached to an NG-CHM dataset.
#'
#' @param dataset The NG-CHM dataset to get the covariate from.
#' @param fullname The full name of the covariate to get.
#' If no covariate with that name exists, return NULL.
#' @param where The axis or axes on which to look for the covariate Can be "row", "column", or "both" (default).
#'
#' @return A ngchmCovariate or NULL.
#'
#' @export
#'
#' @examples
#' chmCovariate (dataset, "Age")
#'
#' @seealso [ngchmCovariate-class]
#' @seealso chmNewCovariate
#' @seealso chmCovariateBar
#'
chmCovariate <- function (dataset, fullname, where) {
stopifnot (is (dataset, "ngchmDataset"));
checkLabel (fullname, "fullname");
where <- if (missing(where)) "both" else match.arg (where, c("row", "column", "both"));
if (where %in% c("row", "both")) {
names <- lapply (dataset@row.covariates, function(cv) cv@fullname);
idx <- which (names == fullname);
if (length(idx) > 0) {
stopifnot (length(idx) == 1);
return (dataset@row.covariates[[idx]]);
}
if (where == "row") return(NULL);
}
# where must be either "column" or "both".
names <- lapply (dataset@column.covariates, function(cv) cv@fullname);
idx <- which (names == fullname);
if (length(idx) > 0) {
stopifnot (length(idx) == 1);
return (dataset@column.covariates[[idx]]);
}
return(NULL);
};
#' Create a new Classification Bar for a NGCHM
#'
#' This function is deprecated and will be removed in a future version. Please use chmNewCovariateBar.
#' This function creates a new Classification Bar suitable for adding to a Next Generation Clustered Heat Map.
#'
#' @param label The name by which the classification bar will be known.
#' @param type The string "discrete" or the string "continuous".
#' @param data A vector of the data to be displayed in the classification bar. names(data) must be defined.
#' @param colors A color map specifying how the data should be rendered.
#' @param display Whether the classification bar will be "hidden" or "visible" (default).
#' @param thickness The thickness of the classification bar in pixels. (Default 10).
#' @param merge Algorithm for merging classifications when necessary ("average", "peakColor", "specialColor", or "mostCommon").
#' @param barType Type of covariate bar ("color_plot", "scatter_plot", "bar_plot"). Default "color_plot".
#' @param loBound Low bound for bar and scatter plots. Default minimum data value.
#' @param hiBound High bound for bar and scatter plots. Default maximum data value.
#' @param fgColor Foreground color for bar and scatter plots. Default black.
#' @param bgColor Background color for bar and scatter plots. Default white.
#'
#' @return An object of class ngchmBar
#'
#' @seealso [ngchmBar-class]
#' @seealso [chmNewColorMap()]
#' @seealso [chmNewCovariateBar()]
#' @seealso [chmAddCovariateBar()]
#'
ngchmNewBar <- function (label, type, data, colors=NULL, display="visible", thickness=as.integer(10), merge, barType,
loBound, hiBound, fgColor, bgColor) {
if (typeof (label) != "character") {
stop (sprintf ("Parameter 'label' must have type 'character', not '%s'", typeof(label)));
}
if (length (label) != 1) {
stop (sprintf ("Parameter 'label' must have a single value, not %d", length(label)));
}
if (nchar (label) == 0) {
stop ("Parameter 'label' cannot be the empty string");
}
if (typeof (type) != "character") {
stop (sprintf ("Parameter 'type' for covariate bar '%s' must have type 'character', not '%s'", label, typeof(type)));
}
if (length (type) != 1) {
stop (sprintf ("Parameter 'type' for covariate bar '%s' must have a single value, not %d", label, length(type)));
}
if (!(type %in% c("discrete", "continuous"))) {
stop (sprintf ("Parameter 'type' for covariate bar '%s' must be either 'discrete' or 'continuous', not '%s'", label, type));
}
if (typeof (display) != "character") {
stop (sprintf ("Parameter 'display' for covariate bar '%s' must have type 'character', not '%s'", label, typeof(display)));
}
if (length (display) != 1) {
stop (sprintf ("Parameter 'display' for covariate bar '%s' must have a single value, not %d", label, length(display)));
}
if (!(display %in% c("visible", "hidden"))) {
stop (sprintf ("Parameter 'display' for covariate bar '%s' must be either 'visible' or 'hidden', not '%s'", label, display));
}
if (missing(barType)) {
barType <- "color_plot";
}
if (typeof (barType) != "character") {
stop (sprintf ("Parameter 'barType' for covariate bar '%s' must have type 'character', not '%s'", label, typeof(barType)));
}
if (length (barType) != 1) {
stop (sprintf ("Parameter 'barType' for covariate bar '%s' must have a single value, not %d", label, length(barType)));
}
if (!(barType %in% c("color_plot", "scatter_plot", "bar_plot"))) {
stop (sprintf ("Parameter 'barType' for covariate bar '%s' must be either 'visible' or 'hidden', not '%s'", label, barType));
}
if (is (data, "shaid")) {
shaid <- data;
repo <- ngchmFindRepo (shaid);
data <- ngchmLoadDatasetBlob (repo, shaid, if(type=='discrete') "" else 0.0)$mat[,'Value'];
} else {
shaid <- NULL;
}
if ((display == "visible") && (length(colors) == 0)) {
if (type == "discrete") {
qq <- sort (unique (data));
} else {
qq <- quantile (data);
}
colors <- grDevices::rainbow(length(qq),start=2/6,end=0);
colors <- vapply (colors, function(cc)substr(cc,1,7), "");
colors <- chmNewColorMap (qq, colors);
}
if (missing(merge)) {
merge <- "average";
}
if ((length(merge) != 1) || !(merge %in% c("average", "peakColor", "specialColor", "mostCommon")))
stop (sprintf ("Unknown covariate bar merge value '%s'. Must be 'average', 'peakColor', 'specialColor' or 'mostCommon'", merge));
if (length(shaid)==0) {
if (length(names(data)) == 0)
stop (sprintf ("Parameter 'data' for covariate bar '%s' must have defined names that match those of the CHM axis to which it will be attached", label));
if (anyDuplicated(names(data)) != 0) {
dups <- unique(names(data)[which(duplicated(names(data)))]);
stop (sprintf ("Parameter 'data' for covariate bar '%s' has multiple entries for label(s) %s", label, paste (dups, collapse=', ')));
}
data <- data[order(names(data))];
mat <- matrix (data, ncol=1, dimnames=list(names(data),'Value'));
shaid <- ngchmSaveAsDatasetBlob (ngchm.env$tmpShaidy, 'tsv', mat);
}
if (missing(loBound)) {
loBound <- if (type == "continuous") min(data,na.rm=TRUE) else 0;
}
if (missing(hiBound)) {
hiBound <- if (type == "continuous") max(data,na.rm=TRUE) else 1;
}
if (missing(fgColor)) {
fgColor <- "#000000";
}
if (missing(bgColor)) {
bgColor <- "#ffffff";
}
new (Class="ngchmBar", label=label, type=type, data=shaid, thickness=thickness, colors=colors, display=display, merge=merge, barType=barType, loBound=loBound, hiBound=hiBound, fgColor=fgColor, bgColor=bgColor)
};
#' Get a covariate bar attached to an NG-CHM.
#'
#' @param hm The NG-CHM to get the covariate bar from.
#' @param fullname The full name of the covariate bar to get.
#' If no covariate bar with that name exists, return NULL.
#' @param where The axis or axes on which to look for the covariate bar Can be "row", "column", or "both" (default).
#'
#' @return An ngchmBar or NULL.
#'
#' @export
#'
#' @examples
#' chmCovariateBar (hm, "Age")
#'
#' @seealso [ngchmBar-class]
#' @seealso chmNewCovariateBar
#' @seealso chmCovariate
#'
chmCovariateBar <- function (hm, fullname, where) {
stopifnot (is (hm, "ngchm"));
checkLabel (fullname, "fullname");
where <- if (missing(where)) "both" else match.arg (where, c("row", "column", "both"));
if (where %in% c("row", "both")) {
names <- lapply (hm@rowCovariateBars, function(cvb) cvb@label);
idx <- which (names == fullname);
if (length(idx) > 0) {
stopifnot (length(idx) == 1);
return (hm@rowCovariateBars[[idx]]);
}
if (where == "row") return(NULL);
}
# where must be either "column" or "both".
names <- lapply (hm@colCovariateBars, function(cvb) cvb@label);
idx <- which (names == fullname);
if (length(idx) > 0) {
stopifnot (length(idx) == 1);
return (hm@colCovariateBars[[idx]]);
}
return(NULL);
};
#' Create a new covariate Bar for a NGCHM
#'
#' This function creates a new covariate bar suitable for adding to a Next Generation Clustered Heat Map.
#'
#' @param covar The covariate to be displayed in the bar.
#' @param display Whether the covariate bar will be "hidden" or "visible" (default).
#' @param thickness The thickness of the covariate bar in pixels. (Default 10).
#' @param merge Algorithm for merging covariates when necessary ("average", "peakColor", "specialColor", or "mostCommon").
#' @param barType Type of covariate bar ("color_plot", "scatter_plot", "bar_plot"). Default "color_plot".
#' @param loBound Low bound for bar and scatter plots. Default minimum data value.
#' @param hiBound High bound for bar and scatter plots. Default maximum data value.
#' @param fgColor Foreground color for bar and scatter plots. Default black.
#' @param bgColor Background color for bar and scatter plots. Default white.
#'
#' @return An object of class ngchmBar
#'
#' @export
#'
#' @examples
#' bar.data <- ifelse (rnorm(1000) < 0, "negative", "non-negative")
#' names(bar.data) <- sprintf ("Sample%d", 1:length(bar.data))
#' bar.colors <- chmNewColorMap (c("negative", "non-negative"),
#' c("white", "black"), missing.color='red')
#' covar <- chmNewCovariate ("Group", bar.data, bar.colors, "discrete")
#' bar <- chmNewCovariateBar (covar)
#'
#' @seealso [ngchmBar-class]
#' @seealso [chmNewColorMap()]
#' @seealso [chmAddCovariateBar()]
#'
chmNewCovariateBar <- function (covar, display="visible", thickness=as.integer(10), merge, barType,
loBound, hiBound, fgColor, bgColor)
{
ngchmNewBar (covar@fullname, covar@type, covar@label.series, covar@series.properties,
display=display, thickness=thickness, merge=merge, barType=barType,
loBound=loBound, hiBound=hiBound, fgColor=fgColor, bgColor=bgColor)
}
#' Create a new Color Map for use in constructing a NGCHM
#'
#' This function creates a new Color Map suitable for use in constructing Data Layers and Covariates
#' in Next Generation Clustered Heat Maps. Color maps can be used in both discrete and continuous
#' contents. In a discrete context, values specifies the properties of series. In a continuous context,
#' values specifies the break points.
#'
#' If values is a matrix, the function will estimate a suitable sequence of color break points. For a quantile
#' color map, the matrix data is ignored. For a linear color map, it will use equispaced values between a low value and
#' a high value. The low value is the median of the minima of each row in the matrix, and the high value is the median
#' of the row maxima. If the low and high values have different signs, the values will be symmetric about zero.
#'
#' @param values A vector specifying the series / break points for which the following colors are defined, or a data matrix.
#' @param colors Either a string vector specifying the color to use for each series / break point, or a single integer.
#' @param names A string vector specifying 'human-readable' names for each series / break point.
#' @param shapes A string vector specifying the shape to use for each series.
#' @param zs A numeric vector specifying the z order to use for each series.
#' @param type The string "linear" (default) or "quantile" (or unique abbreviation thereof).
#' @param missing.color A string specifying the color to use for missing data.
#' @param palette A function(n) that returns a vector of n colors.
#'
#' @return An object of class ngchmColormap
#'
#' @export
#'
#' @examples
#' noise.colors <- chmNewColorMap (c(0,1,2),
#' c("green", "black", "red"),
#' missing.color="yellow")
#' bar.colors <- chmNewColorMap (c("small", "big"),
#' c("#00FFFF", "#FF00FF"),
#' type="quantile")
#'
#' @seealso [ngchmColormap-class]
#' @seealso [chmNewDataLayer()]
#' @seealso [chmNewCovariateBar()]
#'
chmNewColorMap <- function (values, colors=NULL, names=NULL, shapes=NULL, zs=NULL, type="linear", missing.color=NULL, palette=NULL) {
# Validate parameter 'type'
if (typeof (type) != "character") {
stop (sprintf ("Parameter 'type' must have type 'character', not '%s'", typeof(type)));
}
if (length (type) != 1) {
stop (sprintf ("Parameter 'type' must have a single value, not %d", length(type)));
}
allowedTypes = c("linear", "quantile");
mtype = pmatch (type, allowedTypes);
if (is.na(mtype)) {
stop (sprintf ("Unknown color map type '%s'. Allowed types are %s.", type,
paste ("'", allowedTypes, "'", sep="", collapse=", ")));
}
type = allowedTypes[mtype];
# Determine number of colors and whether auto-picking.
NC <- length(colors);
if ((NC == 1) && (mode(colors)=="numeric") && (as.integer(colors)==colors)) {
if (colors < 2) {
stop (sprintf ('"%d" colors requested. At least two are required.', colors));
}
NC <- colors;
colors <- NULL;
}
# Validate 'values'. Auto-pick values if appropriate.
if (isany(values,c('matrix','shaid'))) {
# User just supplied a data matrix.
if (NC == 0) NC <- 3;
if (type == "quantile") {
values <- (1.0/(NC-1)) * (0:(NC-1));
} else if (type == "linear") {
if (is(values,"shaid")){
# FIXME: redoing calculation is inefficient
repo <- ngchmFindRepo (values);
values <- ngchmLoadDatasetBlob (repo, values)$mat;
}
if ((nrow(values)==1) || (ncol(values)==1)) {
minv <- min (values, na.rm=TRUE);
maxv <- max (values, na.rm=TRUE);
} else {
minv = median (apply (values, 1, function(v) min (v, na.rm=TRUE)), na.rm=TRUE);
maxv = median (apply (values, 1, function(v) max (v, na.rm=TRUE)), na.rm=TRUE);
}
if ((minv < 0.0) && (maxv > 0.0)) {
maxv <- max (maxv, -minv);
minv <- -maxv;
}
values <- minv + (maxv - minv) * (1.0/(NC-1)) * (0:(NC-1));
} else {
stop (sprintf ("chmNewColorMap: unable to derive color map breaks from matrix for map type '%s'", type));
}
} else if (isany(values, c('character', 'numeric', 'integer', 'logical'))) {
# User supplied a vector of values.
if (anyDuplicated(values) != 0) {
stop ("chmNewColorMap: values contains duplicates");
}
if (NC == 0) {
NC <- length (values);
}
if (length(values) != NC)
stop (sprintf ("chmNewColorMap: number of values (%d) does not equal number of color (%d). It should.", length(values), NC));
if (isany(values, c('numeric','integer')) && !all(is.finite(values))) {
stop('chmNewColorMap: values contains non-finite values');
}
} else {
# Don't know what the user provided.
stop (sprintf ("chmNewColorMap: values vector has unknown class '%s'. It must be either a vector or a matrix.",
classstr (values)));
}
# values is now a length NC vector of cut points
stopifnot (length(values) == NC);
# Auto-pick colors if needed.
if (length(colors) == 0) {
if (length(palette) > 0) {
colors <- palette(NC);
} else {
colors <- grDevices::rainbow(NC,start=2/6,end=0);
}
colors <- vapply (colors, function(cc)substr(cc,1,7), "");
}
stopifnot (length(colors) == NC);
# Validate other parameters.
if (!is.null(names) && length(names)!=NC)
stop (sprintf ("chmNewColorMap: number of names (%d) does not equal number of colors (%d). It should.", length(names), NC));
if (!is.null(shapes) && length(shapes)!=NC)
stop (sprintf ("chmNewColorMap: number of shapes (%d) does not equal number of colors (%d). It should.", length(shapes), NC));
if (!is.null(zs) && length(zs)!=NC)
stop (sprintf ("chmNewColorMap: number of zindices (%d) does not equal number of colors (%d). It should.", length(zs), NC));
grDevices::col2rgb (missing.color); # error check
# Construct ValueMap
pts <- chmAddValueProperty (NULL, value=values, color=colors, name=names, shape=shapes, z=zs);
new (Class="ngchmColormap", type=type, missing=missing.color, points=pts)
}
chmAddValueProperty <- function (vps, value, color, name=NULL, shape=NULL, z=NULL) {
some.shapes <- c("circle", "square", "diamond", "triangle");
all.shapes <- c(some.shapes, "triangle-down", "line");
if (is.null (name)) name <- as.character(value);
if (is.null (shape)) shape <- some.shapes[1+(0:(length(value)-1)) %% length(some.shapes)];
if (is.null (z)) z <- rep(9,length(value));
if (!all(shape %in% all.shapes))
stop ("unknown shape ", shape);
if (any(z < 0))
stop ("z must be non-negative");
grDevices::col2rgb (color); # error check
for (ii in 1:length(value))
vps <- append (vps, new (Class="ngchmValueProp", value=value[ii], color=color[ii], name=name[ii], shape=shape[ii], z=z[ii]));
vps
}
#' Create a new Javascript function for adding to a NGCHM menu.
#'
#' This function creates a new Javascript function object for adding to
#' a Next Generation Clustered Heat Map menu.
#'
#' @param name The name of the Javascript function
#' @param description A short description of the Javascript function
#' @param implementation A string containing the javascript code required to define the function. When called the function
#' is passed a list of selected values (e.g. labels). Additional parameters can be declared before the values
#' parameter and must be resolved through currying (binding) before the function is used in menus.
#' @param extraParams An optional list of extra parameters. (Default NULL.)
#' @param requires An optional vector of (custom) Javascript function names that this function requires.
#' @param global A logical: TRUE if should be defined globally, not within a customization section. (Default FALSE.)
#'
#' @return An object of class ngchmJS
#'
#' @export
#'
#' @examples
#' alertFn <- chmNewFunction ("showAlert", "Display the parameter in an alert box",
#' "function showAlert(label) { alert(label); }", global=TRUE)
#' dbLookup <- chmNewFunction ("dbLookup", "Lookup the parameter in a database",
#' "function showAlert(database, label) { alert(database[label]); }",
#' c("database"))
#'
#' @seealso [ngchmJS-class]
#' @seealso [chmAddMenuItem()]
#' @seealso [chmBindFunction()]
#' @seealso [chmRegisterFunction()]
#'
chmNewFunction <- function (name, description, implementation, extraParams=NULL, requires=NULL, global=FALSE) {
if (typeof (name) != "character") {
stop (sprintf ("Parameter 'name' must have type 'character', not '%s'", typeof(name)));
}
if (length (name) != 1) {
stop (sprintf ("Parameter 'name' must have a single value, not %d", length(name)));
}
# We declare "" to be a simple value reference
if (typeof (description) != "character") {
stop (sprintf ("Parameter 'description' for JS function '%s' must have type 'character', not '%s'", name, typeof(description)));
}
if (length (description) != 1) {
stop (sprintf ("Parameter 'description' for JS function '%s' must have a single value, not %d", name, length(description)));
}
if (nchar (description) == 0) {
warning (sprintf ("Parameter 'description' for JS function '%s' should not be the empty string", name));
}
if (typeof (implementation) != "character") {
stop (sprintf ("Parameter 'implementation' for JS function '%s' must have type 'character', not '%s'", name, typeof(implementation)));
}
if (length (implementation) != 1) {
stop (sprintf ("Parameter 'implementation' for JS function '%s' must have a single value, not %d", name, length(implementation)));
}
# We might have an empty implementation if we are making R aware of a Javascript builtin
if (length (extraParams) > 0) {
if (typeof (extraParams) != "character") {
stop (sprintf ("Parameter 'extraParams' for JS function '%s' must have type 'character', not '%s'", name, typeof(extraParams)));
}
}
if (length (requires) > 0) {
if (typeof (requires) != "character") {
stop (sprintf ("Parameter 'requires' for JS function '%s' must have type 'character', not '%s'", name, typeof(requires)));
}
}
fn <- new (Class="ngchmJS", name=name, description=description, script=implementation, requires=requires, extraParams=extraParams, global=global);
chmRegisterFunction (fn)
}
checkLabel <- function (label, paramName = "label") {
if (typeof (label) != "character") {
stop (sprintf ("Parameter '%s' must have type 'character', not '%s'", paramName, typeof(label)));
}
if (length (label) != 1) {
stop (sprintf ("Parameter '%s' must have a single value, not %d", paramName, length(label)));
}
if (nchar (label) == 0) {
stop (sprintf ("Parameter '%s' cannot be the empty string", paramName));
}
};
checkPropertyValue <- function (label, value) {
if (!typeof (value) %in% c("character","double","integer","logical")) {
stop (sprintf ("Parameter 'value' for property '%s' must have type 'character', 'double', 'integer', or 'logical', not '%s'", label, typeof(value)));
}
if (length (value) < 1) {
stop (sprintf ("Parameter 'value' for property '%s' must have at least one value", label));
}
};
#' Create a new Property for adding to a NGCHM.
#'
#' This function creates a new Property object for adding to
#' a Next Generation Clustered Heat Map.
#'
#' @param label The property label
#' @param value The property value
#'
#' @return An object of class ngchmProperty
#'
#' @export
#'
#' @examples
#' prop <- chmNewProperty ("chm.info.caption",
#' "This is a nifty new CHM.")
#'
#' @seealso [ngchm-class]
#' @seealso [chmAddProperty()]
#'
chmNewProperty <- function (label, value) {
checkLabel(label);
checkPropertyValue(label, value);
new (Class="ngchmProperty", label=label, value=as.character(value))
}
#' Get the value of an NG-CHM property.
#'
#' @param hm The NG-CHM object to get the property value from.
#' @param label The name of the property to get.
#' If no property with that name exists, return NULL.
#'
#' Well-known property labels used by the NG-CHM system include:
#'
#' * "chm.info.caption" A paragraph describing the NG-CHM's contents (set by user).
#' * "chm.info.built.time" The date and time the NG-CHM was saved (set by system).
#'
#' @return A property value or NULL.
#'
#' @export
#'
#' @examples
#' chmProperty (hm, "chm.info.caption")
#'
#' @seealso [ngchm-class]
#'
chmProperty <- function (hm, label) {
stopifnot (is (hm, "ngchm"));
checkLabel(label);
labels <- lapply (hm@properties, function(p) p@label);
idx <- which (label == labels);
if (length(idx) == 0) return(NULL);
stopifnot (length(idx) == 1);
hm@properties[[idx]]@value
};
#' Set the value of an NG-CHM property.
#'
#' @param x The NG-CHM object on which to set the property.
#' @param label The name of the property to set.
#' If no property with that name exists, a new property with that name is appended.
#' @param value A non-empty vector of character, logical, or numeric values.
#'
#' @return The modified NG-CHM object.
#'
#' @export
#'
#' @examples
#' chmProperty (hm, "chm.info.caption") <- "Nothing to see here";
#'
#' @seealso [ngchm-class]
#'
"chmProperty<-" <- function (x, label, value) {
stopifnot (is (x, "ngchm"));
checkLabel(label);
checkPropertyValue(label, value);
labels <- lapply (x@properties, function(p) p@label);
idx <- which (label == labels);
if (length(idx) == 0) {
x@properties <- append (x@properties, new(Class="ngchmProperty", label=label, value=as.character(value)));
} else {
stopifnot (length(idx) == 1);
x@properties[[idx]]@value <- as.character(value);
}
x
};
#' Create a list of NGCHM properties.
#'
#' Create a list of NGCHM properties.
#'
#' @param ... A named list of property values.
#'
#' @export
#' @seealso [chmAdd()]
chmProperties <- function (...) {
props <- list(...);
if (length(props) > 0) {
if (is.null(names(props)) || any(names(props)=="")) {
stop ("All properties must be named");
}
props <- lapply(1:length(props), function(idx) {
label <- names(props)[idx];
value <- props[[idx]];
if (!typeof(value) %in% c("character","double","integer","logical")) {
stop (sprintf ("Property %s has invalid type %s", label, typeof(value)));
}
if (length(value) != 1) {
stop (sprintf ("Property %s has length %d", label, length(value)));
}
chmNewProperty (label, as.character(value))
});
}
props
};
#' Get the label/name of an NG-CHM object.
#'
#' @param hm The NG-CHM object to get the label/name of. Can be:
#'
#' * An object of class ngchm
#' * An object of class ngchmLayer
#' * An object of class ngchmDataset
#' * An object of class ngchmBar
#' * An object of class ngchmCovariate
#' * An object of class ngchmColormap
#'
#' @return A character string (or a vector of strings for an ngchmColormap)
#'
#' @export
#'
#' @examples
#' chmLabel (chmNew('New CHM'))
#'
#' @seealso [ngchm-class]
#'
chmLabel <- function (x) {
if (isany (x, c("ngchm", "ngchmLayer", "ngchmDataset"))) {
return (x@name);
}
if (isany (x, c("ngchmBar", "ngchmCovariate"))) {
return (x@label);
}
if (is (x, "ngchmColormap")) {
return (vapply (x@points, function(p) p@name, ""));
}
stop ("Unknown object class");
};
#' Set the label/name of an NG-CHM object
#'
#' @param x The NG-CHM object on which to set the label/name.
#' @param value The new name (a single character string).
#'
#' @return The modified NG-CHM object.
#'
#' @export
#'
#' @examples
#' chmLabel (hm) <- "A new name";
#'
#' @seealso [chmLabel]
#'
"chmLabel<-" <- function (x, value) {
stopifnot (isany (value, c("character", "numeric", "logical")),
length(value) == 1 || is(x,"ngchmColormap"));
value <- as.character (value);
if (isany (x, c("ngchm", "ngchmLayer", "ngchmDataset"))) {
x@name <- value;
} else if (isany (x, c("ngchmBar", "ngchmCovariate"))) {
x@label <- value;
} else if (is (x, "ngchmColormap")) {
stopifnot (length(x@points) == length(value));
for (idx in 1:length(x@points)) x@points[[idx]]@name <- value[idx];
} else {
stop ("unknown object class");
}
x
};
#' Get the color map of an NG-CHM object.
#'
#' @param hm The NG-CHM object to get the color map of. Can be:
#'
#' * An object of class ngchmLayer
#' * An object of class ngchmBar
#' * An object of class ngchmCovariate
#'
#' @return An ngchmColormap
#'
#' @export
#'
#' @examples
#' chmColorMap (chmNewDataLayer('New layer', TCGA.BRCA.ExpressionData[1:3,1:3]))
#'
#' @seealso [chmNewColorMap]
#'
chmColorMap <- function (x) {
if (isany(x, c("ngchmLayer", "ngchmBar"))) {
return (x@colors);
}
if (is(x, "ngchmCovariate")) {
return (x@series.properties);
}
stop ("Unknown object class");
};
#' Set the color map of an NG-CHM object
#'
#' @param x The NG-CHM object on which to set the color map.
#' @param value The ngchmColormap value to set.
#'
#' @return The modified NG-CHM object.
#'
#' @export
#'
#' @examples
#' chmColorMap (chmNewDataLayer('New layer', TCGA.BRCA.ExpressionData[1:3,1:3]), chmNewColormap (c(2,14));
#'
#' @seealso [chmColorMap]
#'
"chmColorMap<-" <- function (x, value) {
stopifnot (is (value, "ngchmColormap"));
if (isany(x, c("ngchmLayer", "ngchmBar"))) {
x@colors <- value;
} else if (is(x, "ngchmCovariate")) {
x@series.properties <- value;
} else {
stop ("Unknown object class");
}
x
};
#' Get the colors of an ngchmColormap, ngchmLayer, ngchmBar, or ngchmCovariate.
#'
#' @param x The object to get the colors of.
#'
#' @return A character string vector of the map colors.
#'
#' @export
#'
#' @examples
#' chmColors (chmNewDataLayer('New Layer', TCGA.BRCA.ExpressionData[1:50,1:50))
#'
#' @seealso [ngchm-class]
#'
chmColors <- function (x) {
if (!is(x, "ngchmColormap")) x <- chmColorMap(x);
vapply (x@points, function(p) p@color, "")
};
#' Set the colors of an ngchmColormap, ngchmLayer, ngchmBar, or ngchmCovariate.
#'
#' @param x The NG-CHM object on which to set the colors.
#' @param value A character string vector of colors. The vector length must equal
#' the number of data points in the color map.
#'
#' @return The modified NG-CHM object.
#'
#' @export
#'
#' @examples
#' chmColors (layer) <- c("blue", "white", "red")
#'
#' @seealso [chmColors]
#'
"chmColors<-" <- function (x, value) {
stopifnot (is (value, "character"));
cm <- if (is(x,"ngchmColormap")) x else chmColorMap(x);
stopifnot (length(cm@points) == length(value));
for (idx in 1:length(cm@points)) cm@points[[idx]]@color <- value[idx];
if (is(x, "ngchmColormap")) {
return (cm);
} else {
chmColorMap(x) <- cm;
x
}
};
#' Create a new object representing a NGCHM server.
#'
#' This function creates a new object that represents a NGCHM server.
#'
#' @param serverName The DNS name of the NGCHM server.
#' @param serverPort The port on which the server is listening.
#' @param deployServer The DNS name to use when deploying a NGCHM (defaults to serverName).
#' @param protoOpts A list of protocol-specific parameters
#' @param jarFile The location of the heatmap build jar file to use when making a NGCHM (defaults to jar file on serverURL WS).
#' @param serverURL The URL used to access the NGCHM server (defaults to serverName:serverPort/chm).
#'
#' @return An object of class ngchmServer
#'
#' @export
#'
#' @examples
#' cloudServ <- chmNewServer ("dnsname.domain")
#'
#' @seealso [ngchmServer-class]
#' @seealso [chmInstall()]
#' @seealso [chmUninstall()]
#'
chmNewServer <- function (serverName, serverPort=8080, deployServer=NULL, protoOpts=NULL,
jarFile=NULL, serverURL=NULL)
{
if (is.null (deployServer)) deployServer = serverName;
if (is.null (serverURL)) serverURL = paste ("http://", serverName, ":", serverPort, "/chm", sep="");
new (Class="ngchmServer",
deployServer = deployServer,
protoOpts = protoOpts,
jarFile = jarFile,
serverURL = serverURL);
}
#############################################################################################
#
# Javascript Customization.
#
#' Get a predefined Javascript function for use in NGCHM menus
#'
#' This function returns a predefined Javascript function that can be used when
#' building a Next Generation Clustered Heat Map.
#'
#' @param name The name of the predefined Javascript function desired.
#'
#' @return An object of class ngchmFunction if found, NULL otherwise.
#'
#' @export
#'
#' @seealso [chmAddMenuItem()]
#' @seealso [chmNewFunction()]
#' @seealso [ngchmAxisFunction-class]
#' @seealso [ngchmMatrixFunction-class]
#'
chmGetFunction <- function (name) {
if (typeof (name) != "character") {
stop (sprintf ("Parameter 'name' must have type 'character', not '%s'", typeof(name)));
}
if (length (name) != 1) {
stop (sprintf ("Parameter 'name' must have a single value, not %d", length(name)));
}
if (is.list (ngchm.env$scripts)) {
for (ii in 1:length(ngchm.env$scripts))
if (ngchm.env$scripts[[ii]]@name == name)
return (ngchm.env$scripts[[ii]]);
}
return (NULL);
}
#' Register a predefined Javascript function for use in NGCHM Axis menus.
#'
#' This function registers a Javascript function that will be automatically
#' added to the appropriate axis menu(s) when building a Next Generation
#' Clustered Heat Map for axes that match the function's axis type.
#' This function is intended for use by NGCHM system developers.
#'
#' @param type The axis type required by this function.
#' @param label The name of the axis menu entry to be used for this function.
#' @param fn The Javascript function to register.
#'
#' @return NULL
#'
#' @export
#'
#' @seealso [chmAddAxisType()]
#' @seealso [chmRegisterMatrixFunction()]
#' @seealso [chmRegisterTypeMapper()]
#' @seealso [chmNewFunction()]
chmRegisterAxisFunction <- function (type, label, fn) {
if (typeof (label) != "character") {
stop (sprintf ("Parameter 'label' must have type 'character', not '%s'", typeof(label)));
}
if (length (label) != 1) {
stop (sprintf ("Parameter 'label' must have a single value, not %d", length(label)));
}
if (nchar (label) == 0) {
stop ("Parameter 'label' cannot be the empty string");
}
if (typeof (type) != "character") {
stop (sprintf ("Parameter 'type' for axis function '%s' must have type 'character', not '%s'", label, typeof(type)));
}
if (length (type) < 1) {
stop (sprintf ("Parameter 'type' for axis function '%s' must have at least one value", label));
}
for (ii in 1:length(type)) {
if (nchar (type[ii]) == 0) {
stop (sprintf ("Parameter 'type[%d]' for axis function '%s' cannot be the empty string", ii, label));
}
}
if (!is(type, "character"))
stop (sprintf ("chmRegisterAxisFunction: error registering axis function '%s'. Specified type is '%', not string.", label, classstr(type)));
if (!is(label, "character"))
stop (sprintf ("chmRegisterAxisFunction: error registering axis function. Type of specified label is '%', not string.", classstr(type)));
if (is(fn, "character"))
fn <- chmGetFunction (fn);
af <- new ("ngchmAxisFunction", type=type, label=label, func=fn);
matches <- which (vapply (ngchm.env$axisFunctions, function(af) (af@label == label) && (af@type == type), TRUE));
if (length (matches) > 0) {
ngchm.env$axisFunctions[[matches]] <- af;
} else {
ngchm.env$axisFunctions <- append (ngchm.env$axisFunctions, af);
}
NULL
}
getAllAxisTypes <- function (chm, where) {
w <- vapply (chm@axisTypes, function(at)at@where, "");
locs <- (w == where) | (w == "both");
# types is a list of character vectors (since an axistype can have > 1 type)
types <- lapply (chm@axisTypes[locs], function(at)at@type);
uu <- !duplicated(types);
types <- types[uu];
builders <- chm@axisTypes[locs][uu];
# fromtypes is a list of character vectors (since a mapper can have > 1 fromtype)
fromtypes <- lapply (ngchm.env$typeMappers, function(mm)mm@fromtype);
# totypes is a character vector (since each mapper has exactly 1 totype)
totypes <- vapply (ngchm.env$typeMappers, function(mm)mm@totype, "");
ii <- 0;
while (ii < length(types)) {
ii = ii + 1;
# Find those fromtypes that match the current type.
extra <- vapply (fromtypes, function(ft)any(vapply(types[[ii]], function(tt)any(tt==ft), TRUE)), TRUE);
# Append types of matching mappers, but exclude any duplicates.
# FIXME: only excludes exact duplicate type lists. Does not exclude a mapper if all its types can
# be obtained from a collection of the current types.
types <- append (types, totypes[extra]);
uu <- !duplicated(types);
types <- types[uu];
builders <- append(builders, ngchm.env$typeMappers[extra])[uu];
}
return (list(types=types, builders=builders));
}
getAllAxisFunctions <- function (chm, where) {
w <- vapply (chm@axisTypes, function(at)at@where, "");
locs <- (w == where) | (w == "both");
fns <- lapply (chm@axisTypes[locs], function(at)at@func);
return (fns);
}
# axistypes is a list of character vectors (since an axis type can have > 1 type)
getAllAxisTypeFunctions <- function (chmSpecificFns, axistypes) {
fnList <- append (chmSpecificFns, ngchm.env$axisFunctions);
matches <- vapply (fnList,
function(af)any(vapply (axistypes, function(at)any(at==af@type), TRUE)),
TRUE);
return (fnList[matches]);
}
getAllMatrixTypeFunctions <- function (chm, rowtypes, columntypes) {
matches <- vapply (ngchm.env$matrixFunctions,
function(mf) {
rowm <- any(vapply (rowtypes, function(at)any(at==mf@rowtype), TRUE));
colm <- any(vapply (columntypes, function(at)any(at==mf@columntype), TRUE));
cat ("getAllMatrixTypeFunctions for ", mf@label, ":\n", file=stderr());
cat (" row matches: ", rowm, "\n", file=stderr());
cat (" col matches: ", colm, "\n", file=stderr());
rowm && colm
},
TRUE);
cat ("getAllMatrixTypeFunctions: found ", sum(matches), " matches.\n", file=stderr());
return (ngchm.env$matrixFunctions[matches]);
}
#' Register a predefined Javascript function for use in NGCHM Matrix menus.
#'
#' This function registers a Javascript function that will be automatically
#' added to the matrix menu when building a Next Generation
#' Clustered Heat Map for matrices whose rows and columns match then function's
#' axes types.
#' This function is intended for use by NGCHM system developers.
#'
#' @param rowtype The row type required by this function.
#' @param columntype The column type required by this function.
#' @param label The name of the axis menu entry to be used for this function.
#' @param fn The Javascript function to register.
#'
#' @return NULL
#'
#' @export
#'
#' @seealso [chmAddAxisType()]
#' @seealso [chmRegisterAxisFunction()]
#' @seealso [chmRegisterTypeMapper()]
#' @seealso [chmNewFunction()]
chmRegisterMatrixFunction <- function (rowtype, columntype, label, fn) {
if (typeof (label) != "character") {
stop (sprintf ("Parameter 'label' must have type 'character', not '%s'", typeof(label)));
}
if (length (label) != 1) {
stop (sprintf ("Parameter 'label' must have a single value, not %d", length(label)));
}
if (nchar (label) == 0) {
stop ("Parameter 'label' cannot be the empty string");
}
if (typeof (rowtype) != "character") {
stop (sprintf ("Parameter 'rowtype' for matrix function '%s' must have type 'character', not '%s'", label, typeof(rowtype)));
}
if (length (rowtype) < 1) {
stop (sprintf ("Parameter 'rowtype' for matrix function '%s' must have at least one value", label));
}
if (typeof (columntype) != "character") {
stop (sprintf ("Parameter 'columntype' for matrix function '%s' must have type 'character', not '%s'", label, typeof(columntype)));
}
if (length (columntype) < 1) {
stop (sprintf ("Parameter 'columntype' for matrix function '%s' must have at least one value", label));
}
if (is(fn, "character"))
fn <- chmGetFunction (fn);
newmf <- new ("ngchmMatrixFunction", rowtype=rowtype, columntype=columntype, label=label, func=fn);
matches <- which (vapply (ngchm.env$matrixFunctions, function(mf) (mf@label == label) && (mf@rowtype == rowtype) && (mf@columntype == columntype), TRUE));
if (length (matches) > 0) {
ngchm.env$matrixFunctions[[matches]] <- newmf;
} else {
ngchm.env$matrixFunctions <- append (ngchm.env$matrixFunctions, newmf);
}
NULL
}
#' Register a type name.
#'
#' This function registers a type name used for determining row and column
#' linkouts.
#' This function is intended to be used by NGCHM system developers to record
#' basic information about the semantic interpretation of a type name. Registration
#' of a typename is (currently) not required in order to use it.
#'
#' @param typename The name of the type.
#' @param description A description of the type.
#'
#' @return NULL
#'
#' @export
#'
#' @seealso [chmListTypes()]
#' @seealso [chmGetTypeInfo()]
#' @seealso [chmRegisterTypeMapper()]
chmRegisterType <- function (typename, description) {
if (typeof (typename) != "character") {
stop (sprintf ("Parameter 'typename' must have type 'character', not '%s'", typeof(typename)));
}
if (typeof (description) != "character") {
stop (sprintf ("Parameter 'description' must have type 'character', not '%s'", typeof(description)));
}
if (length(typename) < 1)
stop ("chmRegisterType: at least one typename must be specified.");
if (length(description) != 1)
stop (sprintf ("chmRegisterType: description must be exactly a single string, not %d.", length(description)));
for (ii in 1:length(typename)) {
tt <- data.frame (name=typename[ii], description=description, stringsAsFactors=FALSE);
if (typename[ii] %in% ngchm.env$typeInfo$name) {
warning (sprintf ('Replacing definition of typename "%s"', typename[ii]));
idx <- which (ngchm.env$typeInfo$name == typename[ii]);
ngchm.env$typeInfo[idx,] <- tt;
} else {
ngchm.env$typeInfo <- rbind (ngchm.env$typeInfo, tt);
}
}
NULL
}
#' Get information about a type name.
#'
#' This function gets any registered information about a type name used for determining row and column
#' linkouts.
#' Registration of a typename is (currently) not required in order to use it, so it's possible for
#' valid type name not to have any registered information.
#'
#' @param typename The name of the type.
#'
#' @return A list containing basic information about the type.
#'
#' @export
#'
#' @seealso [chmListTypes()]
#' @seealso [chmRegisterType()]
chmGetTypeInfo <- function (typename) {
if (typeof (typename) != "character") {
stop (sprintf ("Parameter 'typename' must have type 'character', not '%s'", typeof(typename)));
}
if (length(typename) != 1) {
stop ("chmGetTypeInfo: exactly one typename must be specified.");
}
if (!(typename %in% ngchm.env$typeInfo$name)) {
typeinfo <- list (name=typename, description=NULL);
} else {
idx <- which (ngchm.env$typeInfo$name == typename);
typeinfo <- as.list (ngchm.env$typeInfo[idx,]);
}
# Find any axis functions that match
matches <- which (vapply (ngchm.env$axisFunctions, function(af) any(af@type == typename), TRUE));
if (length (matches) > 0) {
typeinfo$axisFunctions <- ngchm.env$axisFunctions[matches];
} else {
typeinfo$axisFunctions <- NULL;
}
# Find any matrix functions that match
matches <- which (vapply (ngchm.env$matrixFunctions, function(af) any(af@rowtype == typename) || any(af@columntype == typename), TRUE));
if (length (matches) > 0) {
typeinfo$matrixFunctions <- ngchm.env$matrixFunctions[matches];
} else {
typeinfo$matrixFunctions <- NULL;
}
# Find any type mappers that match
matches <- which (vapply (ngchm.env$typeMappers, function(af) any(af@fromtype == typename), TRUE));
if (length (matches) > 0) {
typeinfo$typeMappers <- ngchm.env$typeMappers[matches];
} else {
typeinfo$typeMappers <- NULL;
}
class(typeinfo) <- "ngchm.type.info";
typeinfo
}
#' Pretty print the result returned by chmGetTypeInfo.
#'
#' @param x Type information about an NGCHM type name as return by chmGetTypeInfo.
#' @param ... Generic function accepts additional parameters
#'
#' @export
#'
#' @seealso [chmGetTypeInfo()]
print.ngchm.type.info <- function (x, ...) {
cat (sprintf ("NGCHM type %s: %s\n", x$name, x$description));
if (length (x$axisFunctions) > 0) {
fns <- paste (vapply (x$axisFunctions, function(af)af@label, ""), collapse=", ");
cat (sprintf ("matches axis functions %s.\n", fns));
}
if (length (x$matrixFunctions) > 0) {
fns <- paste (vapply (x$matrixFunctions, function(af)af@label, ""), collapse=", ");
cat (sprintf ("matches matrix functions %s.\n", fns));
}
if (length (x$typeMappers) > 0) {
types <- paste (vapply (x$typeMappers, function(af)af@totype, ""), collapse=", ");
cat (sprintf ("maps to types %s.\n", types));
}
}
#' Register a predefined Javascript function for converting values from
#' one type to another.
#'
#' This function registers a Javascript function that will be automatically
#' added to a Next Generation Clustered Heat Map as required for converting
#' values from one type into another more basic type.
#' This function is intended for use by NGCHM system developers.
#'
#' @param fromtype The type of values the function expects as input.
#' @param totype The type of values the function will produce. The length of
#' totype must be shorter than fromtype.
#' @param op The operation code for performing the conversion
#' @param ... Additional parameters required for specifying the conversion (op specific)
#'
#' @return NULL
#'
#' op can have the following values:
#' + 'field' Split source into fields separated by 'separator' and select field 'num' (0 origin)
#' + 'expr' Compute string expression 'expr'. 'return' value is a vector or a scalar (default)
#' + 'javascript' Evaluate javascript function 'fn' (deprecated)
#'
#' @export
#'
#' @seealso [chmAddAxisType()]
#' @seealso [chmRegisterAxisFunction()]
#' @seealso [chmRegisterMatrixFunction()]
#' @seealso [chmNewFunction()]
chmRegisterTypeMapper <- function (fromtype, totype, op, ...) {
if (typeof (fromtype) != "character") {
stop (sprintf ("Parameter 'fromtype' must have type 'character', not '%s'", typeof(fromtype)));
}
if (typeof (totype) != "character") {
stop (sprintf ("Parameter 'totype' must have type 'character', not '%s'", typeof(totype)));
}
if (length(fromtype) < 1)
stop ("chmRegisterTypeMapper: at least one fromtype must be specified.");
if (length(totype) != 1)
stop (sprintf ("chmRegisterTypeMapper: totype must be exactly a single string, not %d.", length(totype)));
for (ii in 1:length(fromtype))
if (nchar(totype) >= nchar(fromtype[ii]))
stop (sprintf ("chmRegisterTypeMapper: totype ('%s') must be shorter than fromtype ('%s').", totype, fromtype[ii]));
stopifnot (is(op, "character") && length(op)==1);
pp <- list (...);
if (op == "field") {
stopifnot ("separator" %in% names(pp));
stopifnot (is(pp$separator,"character") && length(pp$separator)==1);
if (!"num" %in% names(pp)) pp$num <- 0;
params <- list(separator=pp$separator, num=pp$num);
} else if (op == "expr") {
stopifnot ("expr" %in% names(pp));
stopifnot (is(pp$expr,"character") && length(pp$expr)==1);
if (!"return" %in% names(pp)) pp$return <- 'scalar';
params <- list(expr=pp$expr, return=pp$return);
} else if (op == "javascript") {
stopifnot ("fn" %in% names(pp));
if (is(pp$fn, "character")) {
pp$fn <- chmGetFunction (pp$fn);
}
params <- list(fn=pp$fn);
} else {
stop ("unknown type mapper op");
}
newtm <- new ("ngchmTypeMapper", fromtype=fromtype, totype=totype, op=op, params=params);
matches <- which (vapply (ngchm.env$typeMappers, function(tm) (length(intersect (tm@fromtype, fromtype)) > 0) && (tm@totype == totype), TRUE));
if (length(matches) > 0) {
matches <- sort (matches, decreasing=TRUE);
for (idx in matches) {
ftype <- ngchm.env$typeMappers[[idx]]@fromtype;
common <- intersect(ftype, fromtype);
if (length(common) == length(ftype)) {
# All fromtypes are replaced: remove mapping.
ngchm.env$typeMappers <- ngchm.env$typeMappers[-idx];
} else {
ngchm.env$typeMappers[[idx]]@fromtype <- setdiff (ftype, common);
}
}
}
ngchm.env$typeMappers <- append (ngchm.env$typeMappers, newtm);
NULL
}
#' Register a predefined Javascript function for use in NGCHM menus.
#'
#' This function registers a Javascript function that can be used when
#' building a Next Generation Clustered Heat Map. This function is
#' intended for use by NGCHM system developers.
#'
#' @param fn The Javascript function to register.
#'
#' @return NULL
#'
#' @export
#'
#' @seealso [chmAddMenuItem()]
#' @seealso [chmNewFunction()]
#' @seealso [ngchmAxisFunction-class]
#' @seealso [ngchmMatrixFunction-class]
#'
chmRegisterFunction <- function (fn) {
if (!is(fn, "ngchmJS")) {
stop (sprintf ("Parameter 'fn' must have type 'ngchmJS', not '%s'", classstr(fn)));
}
matches <- which (vapply (ngchm.env$scripts, function(ss) (ss@name == fn@name), TRUE));
if (length (matches) > 0) {
ngchm.env$scripts[[matches]] <- fn;
} else {
ngchm.env$scripts <- append (ngchm.env$scripts, fn);
}
fn
}
#' Create and register an NGCHM server protocol implementation.
#'
#' This function creates and registers a protocol implementation for manipulating
#' an NGCHM server.
#'
#' @param protocolName The name of this protocol implementation.
#' @param chmFormat The chm format required by this protocol. Defaults to original format.
#' @param requiredParams The protocol's required parameters, if any.
#' @param optionalParams The protocol's optional parameters, if any.
#' @param paramValidator A function(list) for validating the parameters specified for a new server.
#' @param findCollection A function(server,collection,path) for finding a collection.
#' @param createCollection A function(server,collection,name) for creating a collection.
#' @param installMethod A function(server,chm) for installing an NG-CHM.
#' @param uninstallMethod A function(server,chmname) for uninstalling an NG-CHM.
#' @param makePrivate A function(server,chmname) for hiding an NG-CHM.
#' @param makePublic A function(server,chmname) for showing an NG-CHM.
#' @param setCredentials A function(server,credentialstring) for setting credentials.
#'
#' @export
ngchmCreateServerProtocol <- function (protocolName, chmFormat,
requiredParams, optionalParams,
paramValidator,
findCollection, createCollection,
installMethod, uninstallMethod,
makePrivate, makePublic,
setCredentials) {
if (missing(chmFormat)) chmFormat <- "original";
if (typeof (chmFormat) != "character") {
stop (sprintf ("Parameter 'chmFormat' must have type 'character', not '%s'", typeof(chmFormat)));
}
if (length (chmFormat) != 1) {
stop (sprintf ("Parameter 'chmFormat' must have a single value, not %d", length(chmFormat)));
}
if (nchar (chmFormat) == 0) {
stop ("Parameter 'chmFormat' cannot be the empty string");
}
if (typeof (protocolName) != "character") {
stop (sprintf ("Parameter 'protocolName' must have type 'character', not '%s'", typeof(protocolName)));
}
if (length (protocolName) != 1) {
stop (sprintf ("Parameter 'protocolName' must have a single value, not %d", length(protocolName)));
}
if (nchar (protocolName) == 0) {
stop ("Parameter 'protocolName' cannot be the empty string");
}
if (missing (requiredParams)) {
requiredParams <- NULL;
}
if (!is.null(requiredParams) && typeof (requiredParams) != "character") {
stop (sprintf ("Parameter 'requiredParams' must have type 'character', not '%s'", typeof(requiredParams)));
}
if (missing (optionalParams)) {
optionalParams <- NULL;
}
if (!is.null(optionalParams) && typeof (optionalParams) != "character") {
stop (sprintf ("Parameter 'optionalParams' must have type 'character', not '%s'", typeof(optionalParams)));
}
if (missing (paramValidator)) {
paramValidator <- function (params) {
};
}
if (missing (findCollection)) {
findCollection <- function (server, collectionId, path) {
return (NULL);
};
}
if (missing (createCollection)) {
createCollection <- function (server, collectionId, name) {
return (NULL);
};
}
if (missing (installMethod)) {
installMethod <- function (server, chm) {
stop ("NGCHMs cannot be automatically installed on this server. Please obtain installation instructions from the server administrator.");
};
}
if (missing (uninstallMethod)) {
uninstallMethod <- function (server, chmname) {
stop ("NGCHMs cannot be automatically uninstalled from this server. Please obtain instructions from the server administrator.");
};
}
if (missing (makePrivate)) {
makePrivate <- function (server, chmname) {
stop ("NGCHMs cannot be automatically made private on this server. Please obtain instructions from the server administrator.");
};
}
if (missing (makePublic)) {
makePublic <- function (server, chmname) {
stop ("NGCHMs cannot be automatically made public on this server. Please obtain instructions from the server administrator.");
}
}
if (missing (setCredentials)) {
setCredentials <- function (server, credentialstring) {
stop ("You cannot set credentials for this server. Please obtain instructions from the server administrator.");
}
}
dm <- new (Class="ngchmServerProtocol", protocolName=protocolName, chmFormat=chmFormat,
requiredParams = requiredParams,
optionalParams = optionalParams,
paramValidator = paramValidator,
setCredentials = setCredentials,
findCollection = findCollection, createCollection = createCollection,
installMethod = installMethod, uninstallMethod = uninstallMethod,
makePrivate = makePrivate, makePublic = makePublic);
matches <- which (vapply (ngchm.env$serverProtocols, function(ss) (ss@protocolName == protocolName), TRUE));
if (length (matches) > 0) {
ngchm.env$serverProtocols[[matches]] <- dm;
} else {
ngchm.env$serverProtocols <- append (ngchm.env$serverProtocols, dm);
}
dm
}
#' List defined server protocols
#'
#' @export
#'
#' @return A character vector
ngchmListServerProtocols <- function () {
vapply (ngchm.env$serverProtocols, function(sp) sp@protocolName, '')
}
#' Lookup a Server Protocol
#'
#' @export
#'
#' @param protocolName The name of the server protocol to lookup
ngchmGetServerProtocol <- function (protocolName) {
if (typeof (protocolName) != "character") {
stop (sprintf ("Parameter 'protocolName' must have type 'character', not '%s'", typeof(protocolName)));
}
if (length (protocolName) != 1) {
stop (sprintf ("Parameter 'protocolName' must have a single value, not %d", length(protocolName)));
}
if (nchar (protocolName) == 0) {
stop ("Parameter 'protocolName' cannot be the empty string");
}
matches <- which (vapply (ngchm.env$serverProtocols, function(sp) (sp@protocolName == protocolName), TRUE));
if (length(matches) == 0) {
stop (sprintf ("No server protocol found with name '%s'", protocolName));
} else {
return (ngchm.env$serverProtocols[[matches]]);
}
}
#' Get a server protocol parameter
#'
#' @export
#'
#' @param server The NGCHM server
#' @param option The name of the protocol parameter to get
#' @param default The default value of the option (default NULL)
ngchmGetProtoParam <- function (server, option, default=NULL) {
stopifnot (is (server, "ngchmServer"));
stopifnot (is (option, "character"));
stopifnot (length(option) == 1);
if (is.null (server@protoOpts)) return (default);
if (option %in% names(server@protoOpts)) return (server@protoOpts[[option]]);
return (default);
}
#' List the predefined Javascript functions available for use in NGCHM menus.
#'
#' This function lists the predefined Javascript functions available for use in NGCHM menus.
#'
#' @param re Only functions with names matching re are printed (default ".*")
#'
#' @export
#'
#' @seealso [chmAddMenuItem()]
#' @seealso [chmGetFunction()]
#' @seealso [chmRegisterFunction()]
#' @seealso [grep()]
#'
chmListFunctions <- function (re=".*") {
if (typeof (re) != "character") {
stop (sprintf ("Parameter 're' must have type 'character', not '%s'", typeof(re)));
}
for (ii in 1:length(ngchm.env$scripts)) {
fn <- ngchm.env$scripts[[ii]];
if (length (grep (re, fn@name)) > 0) {
cat (sprintf ("%s\t%s\n", fn@name, fn@description));
}
}
}
#' Define and register a Javascript function for obtaining a specific metadata value.
#'
#' This function defines and registers a Javascript function for obtaining a specific
#' metadata value and returning it as a javascript list. The function is suitable for
#' use as an axis type accessor function.
#'
#' @param functionName The name given to the Javascript function.
#' @param metadataColumnName The name of the metadata column to access.
#'
#' @export
#'
#' @seealso [chmAddAxisType()]
#' @seealso [chmGetFunction()]
#' @seealso [chmListFunctions()]
#'
chmRegisterGetMetadataFunction <- function (functionName, metadataColumnName) {
if (typeof (functionName) != "character") {
stop (sprintf ("Parameter 'functionName' must have type 'character', not '%s'", typeof(functionName)));
}
if (length (functionName) != 1) {
stop (sprintf ("Parameter 'functionName' must have a single value, not %d", length(functionName)));
}
if (nchar (functionName) == 0) {
stop ("Parameter 'functionName' cannot be the empty string");
}
if (typeof (metadataColumnName) != "character") {
stop (sprintf ("Parameter 'metadataColumnName' must have type 'character', not '%s'", typeof(metadataColumnName)));
}
if (length (metadataColumnName) != 1) {
stop (sprintf ("Parameter 'metadataColumnName' must have a single value, not %d", length(metadataColumnName)));
}
if (nchar (metadataColumnName) == 0) {
stop ("Parameter 'metadataColumnName' cannot be the empty string");
}
chmNewFunction (functionName,
"This returns the label at the specified index as a list of values. Can be used whenever the label itself is of the correct type.",
paste (sprintf ("function %s (axis, idx) {", functionName),
sprintf (" return [axis.labels.getMetaData (idx).%s];", metadataColumnName),
"};", sep="\n"));
}
#' Define and register a Javascript function for converting a lists of type values into single values.
#'
#' This function defines and registers a Javascript function for converting a list of type values
#' separated by the specified separator into the single values, and registers it as a type mapper.
#'
#' @param functionName The name given to the Javascript function.
#' @param listtype The name of the list type.
#' @param itemtype The name of the individual values.
#' @param separator The string that separates items within the list.
#'
#' @export
#'
#' @seealso [chmGetFunction()]
#' @seealso [chmListFunctions()]
#' @seealso [chmRegisterTypeMapper()]
#'
chmRegisterTypeSplitter <- function (functionName, listtype, itemtype, separator) {
if (typeof (functionName) != "character") {
stop (sprintf ("Parameter 'functionName' must have type 'character', not '%s'", typeof(functionName)));
}
if (length (functionName) != 1) {
stop (sprintf ("Parameter 'functionName' must have a single value, not %d", length(functionName)));
}
if (nchar (functionName) == 0) {
stop ("Parameter 'functionName' cannot be the empty string");
}
if (typeof (separator) != "character") {
stop (sprintf ("Parameter 'separator' for typesplitter '%s' must have type 'character', not '%s'", functionName, typeof(separator)));
}
if (length (separator) != 1) {
stop (sprintf ("Parameter 'separator' for typesplitter '%s' must have a single value, not %d", functionName, length(separator)));
}
if (nchar (separator) == 0) {
stop (sprintf ("Parameter 'separator' for typesplitter '%s' cannot be the empty string", functionName));
}
fn <- chmNewFunction (functionName,
sprintf ("Convert %s to %s by splitting on '%s'", listtype, itemtype, separator),
paste (sprintf ("function %s (names) {", functionName),
sprintf (" return names.map(function(nm){return nm.split('%s');}).reduce(function(a,b){return a.concat(b);});", separator),
"}", sep="\n"));
chmRegisterTypeMapper (listtype, itemtype, 'javascript', fn=fn);
}
#' List known axis types.
#'
#' This function returns a list of the axis types for which axis- or matrix- menu entries may be defined.
#'
#' @param re Only types with names matching re are returned (default ".*")
#'
#' @return a character vector of axis type names
#'
#' @export
#'
#' @seealso [chmAddAxisType()]
chmListTypes <- function (re=".*") {
if (typeof (re) != "character") {
stop (sprintf ("Parameter 're' must have type 'character', not '%s'", typeof(re)));
}
if (length (re) != 1) {
stop (sprintf ("Parameter 're' must have a single value, not %d", length(re)));
}
at <- lapply (ngchm.env$axisFunctions, function(x)x@type);
rt <- lapply (ngchm.env$matrixFunctions, function(x)x@rowtype);
ct <- lapply (ngchm.env$matrixFunctions, function(x)x@columntype);
tt <- lapply (ngchm.env$typeMappers, function(x)x@fromtype);
allt <- c(at, rt, ct, tt, recursive = TRUE);
allt <- allt[!duplicated(allt)];
mm <- vapply (allt, function(x)length(grep(re,x)) > 0, TRUE)
return (allt[mm]);
}
#' Register a Javascript function for use in the NGCHM toolbox.
#'
#' This function registers a Javascript function that can included in
#' the toolbox of an NGCHM. This function is
#' intended for use by NGCHM system developers.
#'
#' @param tbtype The toolbox type.
#' @param menulabel The base menu label for the toolbox operation.
#' @param jsfn The Javascript function that implements the toolbox operation.
#'
#' @return NULL
#'
#' @export
#'
#' @seealso [chmNewFunction()]
#' @seealso [ngchmAxisFunction-class]
#' @seealso [ngchmMatrixFunction-class]
#'
chmRegisterToolboxFunction <- function (tbtype, menulabel, jsfn) {
if (typeof (menulabel) != "character") {
stop (sprintf ("Parameter 'menulabel' must have type 'character', not '%s'", typeof(menulabel)));
}
if (length (menulabel) != 1) {
stop (sprintf ("Parameter 'menulabel' must have a single value, not %d", length(menulabel)));
}
if (nchar (menulabel) == 0) {
stop ("Parameter 'menulabel' cannot be the empty string");
}
if (typeof (tbtype) != "character") {
stop (sprintf ("Parameter 'tbtype' of toolbox function '%s' must have type 'character', not '%s'", menulabel, typeof(tbtype)));
}
if (length (tbtype) != 1) {
stop (sprintf ("Parameter 'tbtype' of toolbox function '%s' must have a single value, not %d", menulabel, length(tbtype)));
}
if (nchar (tbtype) == 0) {
stop (sprintf ("Parameter 'tbtype' of toolbox function '%s' cannot be the empty string", menulabel));
}
if (!is(jsfn, "ngchmJS")) {
stop (sprintf ("a toolbox function must be of class ngchmJS (see chmNewFunction) not '%s'",
classstr(jsfn)));
}
if (length(jsfn@extraParams) != 1) {
stop (sprintf ("a toolbox function requires exactly 1 extra parameter (called 'dataset'), not %d",
length(jsfn@extraParams)));
}
if (jsfn@extraParams != "dataset") {
stop (sprintf ("a toolbox function requires exactly 1 extra parameter called 'dataset', not '%s'",
jsfn@extraParams));
}
matches <- NULL;
if (length(ngchm.env$toolbox) > 0) {
matches <- which (apply (ngchm.env$toolbox, 1, function(tbf) (tbf$label == menulabel)&&(tbf$type==tbtype)));
}
if (length (matches) > 0) {
ngchm.env$toolbox[[matches,"fn"]] <- jsfn;
} else {
ngchm.env$toolbox <- rbind (ngchm.env$toolbox, list(type=tbtype, label=menulabel, fn=jsfn));
}
NULL
}
#' Check that the specified layer can be added to the specificed NGCHM.
#'
#' Stops with an error if the specified layer cannot be added to the specified NGCHM.
#'
#' @param chm The CHM to which the new layer is being added.
#' @param layer The new layer is being added.
#'
#' @return NULL
#'
validateNewLayer <- function (chm, layer)
{
newnames <- dimnames (layer);
if (length (chm@layers) > 0) {
# Check new layer is compatible with first layer.
oldnames <- dimnames (chm@layers[[1]]);
layer1 <- chm@layers[[1]];
if (any (vapply(newnames,length,0) != vapply(oldnames,length,0))) {
stop (sprintf ('Dimensions of new layer "%s" (%dx%d) for CHM "%s" differ from those of existing layers (%dx%d)',
layer@name, nrow(layer), ncol(layer), chm@name, nrow(layer1), ncol(layer1)));
}
nm <- newnames[[1]];
nm1 <- oldnames[[1]];
if (!setequal (nm, nm1)) {
m <- sprintf ('Row names of new layer "%s" for CHM "%s" differ from those of existing layers',
layer@name, chm@name);
errs <- namesdifferror ('new layer', nm, 'existing layers', nm1);
stop (paste (c (m, errs), collapse="\n"));
}
nm <- newnames[[2]];
nm1 <- oldnames[[2]];
if (!setequal (nm, nm1)) {
m <- sprintf ('Column names of new layer "%s" for CHM "%s" differ from those of existing layers',
layer@name, chm@name);
errs <- namesdifferror ('new layer', nm, 'existing layers', nm1);
stop (paste (c (m, errs), collapse="\n"));
}
} else {
# First layer. Check names are compatible with class bars, if any.
layername <- sprintf ('new layer "%s"', layer@name);
if (length (chm@rowCovariateBars) > 0) {
for (ii in 1:length(chm@rowCovariateBars)) {
validateCovariateBar (chm, "Row", layername, newnames[[1]], chm@rowCovariateBars[[ii]]);
}
}
if (length (chm@colCovariateBars) > 0) {
for (ii in 1:length(chm@colCovariateBars)) {
validateCovariateBar (chm, "Column", layername, newnames[[2]], chm@colCovariateBars[[ii]]);
}
}
# Check names are compatible with row/column orders, if any.
if (!is(chm@rowOrder,"function")) {
validateAxisOrder (chm, "Row", layername, newnames[[1]], chm@rowOrder);
}
if (!is(chm@colOrder,"function")) {
validateAxisOrder (chm, "Column", layername, newnames[[2]], chm@colOrder);
}
}
}
validateNewCovariateBar <- function (chm, where, bar)
{
if (length (chm@layers) > 0) {
layer <- chm@layers[[1]];
layername <- sprintf ('layer "%s"', layer@name);
if (where %in% c("row", "both")) {
labels <- ngchmGetLabelsStr (layer@data, "row");
validateCovariateBar (chm, "Row", layername, labels, bar);
}
if (where %in% c("column", "both")) {
labels <- ngchmGetLabelsStr (layer@data, "column");
validateCovariateBar (chm, "Column", layername, labels, bar);
}
}
};
validateCovariateBar <- function (chm, where, layername, labels, bar)
{
repo <- ngchmFindRepo (bar@data);
barData <- ngchmLoadDatasetBlob (repo, bar@data, if(bar@type=='discrete')"" else 0.0)$mat;
if (length (intersect (labels, rownames(barData))) == 0) {
m <- sprintf ('%s names of %s for CHM "%s" are completely different from those of covariate bar "%s"',
where, layername, chm@name, bar@label);
errs <- namesdifferror (layername, labels, sprintf ('covariate bar "%s"', bar@label), rownames(barData));
stop (paste (c (m, errs), collapse="\n"));
}
};
validateNewAxisOrder <- function (chm, where, order)
{
if (length (chm@layers) > 0) {
layer <- chm@layers[[1]];
layername <- sprintf ('layer "%s"', layer@name);
if (where %in% c("row", "both")) {
labels <- ngchmGetLabelsStr (layer@data, "row");
validateAxisOrder (chm, "Row", layername, labels, order);
}
if (where %in% c("column", "both")) {
labels <- ngchmGetLabelsStr (layer@data, "column");
validateAxisOrder (chm, "Column", layername, labels, order);
}
}
};
validateAxisOrder <- function (chm, where, layername, labels, order)
{
# NULL order allowed.
if (length(order) == 0) return;
# Convert other order types in a label vector.
if (is(order, "dendrogram")) {
order <- labels(order);
} else if (is(order,"hclust")) {
order <- labels(as.dendrogram(order));
} else {
stopifnot (mode(order) == "character")
}
# Order must be a permutation of labels.
# so lengths must match
if (length(labels) != length(order)) {
m <- sprintf ('Number of %s names of %s for CHM "%s" (%d) differs from number of labels in order (%d)',
where, layername, chm@name, length(labels), length(order));
errs <- namesdifferror (layername, labels, 'order', order);
stop (paste (c (m, errs), collapse="\n"));
}
# and intersection must have the same length as well.
if (length (intersect (labels, order)) != length(labels)) {
m <- sprintf ('%s names of %s for CHM "%s" differ from those of the specified order',
where, layername, chm@name);
errs <- namesdifferror (layername, labels, 'order', order);
stop (paste (c (m, errs), collapse="\n"));
}
};
namesdifferror <- function (desc1, names1, desc2, names2)
{
msg <- c();
#msg <- c(msg,sprintf ("Names in %s: %s", desc1, shortnameslist (names1)));
#msg <- c(msg,sprintf ("Names in %s: %s", desc2, shortnameslist (names2)));
only1 <- setdiff (names1, names2);
if (length(only1) == 0) {
msg <- c(msg,sprintf ("No names in %s but not %s", desc1, desc2));
} else {
msg <- c(msg,sprintf ("%d name(s) in %s but not %s: %s", length(only1), desc1, desc2, shortnameslist (only1)));
}
only2 <- setdiff (names2, names1);
if (length(only2) == 0) {
msg <- c(msg,sprintf ("No names in %s but not %s", desc2, desc1));
} else {
msg <- c(msg,sprintf ("%d name(s) in %s but not %s: %s", length(only2), desc2, desc1, shortnameslist (only2)));
}
msg
}
shortnameslist <- function (names, maxnames=5)
{
if (length(names) > maxnames) {
qnames <- c(sprintf ('"%s"', names[1:maxnames]),'...');
} else {
qnames <- sprintf ('"%s"', names);
}
paste (qnames, collapse=", ")
}
#' Create a new Dialog for a NGCHM.
#'
#' This function creates a new Dialog suitable for adding to a Next Generation Clustered Heat Map.
#'
#' @param id The html id for the dialog.
#' @param title The dialog title / menu entry name.
#' @param fn The javascript function for customizing the dialog's contents.
#'
#' @return An object of class ngchmDialog
#'
#' @export
#'
#' @seealso [chmAdd()]
#' @seealso [chmAddDialog()]
#'
chmNewDialog <- function (id, title, fn) {
if (is(fn, "character")) {
fn <- chmGetFunction (fn);
}
dialog <- new (Class="ngchmDialog", id=id, title=title, fn=fn);
dialog
};
#' Create a new Axis for adding to an NG-CHM.
#'
#' This function creates a new Axis for adding to a Next Generation Clustered Heat Map. You can specify any
#' axis name here, but chmAdd only accepts row, column, and both.
#'
#' @param axis The name of the axis
#' @param ... Objects to add to the axis
#'
#' @return An object of class ngchmAxis
#'
#' @export
#'
#' @seealso [chmAdd()]
chmAxis <- function (axis, ...) {
new ("ngchmAxis", axis=axis, objects=list(...))
}
#' Create a new AxisType for adding to an ngchmAxis.
#'
#' This function creates a new AxisType for adding to an ngchmAxis.
#'
#' @param typename The name of the axis type
#' @param func A javascript function (optional) for obtaining a value of that type from the axis
#'
#' @return An object of class ngchmAxisType
#'
#' @export
#'
#' @seealso [chmAxis()]
chmAxisType <- function (typename, func) {
stopifnot (typeof(typename) == "character" && length(typename)==1);
if (missing(func)) {
func <- chmGetFunction ("getLabelValue");
} else if (typeof(func) == "character" && length(func)==1) {
func <- chmGetFunction (func);
} else {
stopifnot (is(func,"ngchmJS"))
}
new (Class="ngchmAxisType", where="", type=typename, func=func)
};
#' Return the names of the NGCHM servers defined to date in this session.
#'
#' @export
chmListServers <- function () {
vapply (ngchm.env$servers, function (svr) svr$name, "")
}
#' Get a HTTR handle for the server's view/WS URL
#'
#' This function returns a 'handle' suitable for use with the server's view/WS URL
#'
#' @param server An object of class ngchmServer
#'
#' @return An HTTR handle
#'
#' @import httr
#' @import jsonlite
#'
#' @export
#'
ngchmGetHandleHTTR <- function (server) {
ws <- if (is (server, "ngchmServer")) server@serverURL else server;
if (!exists (ws, ngchm.env$handledb)) {
assign (ws, httr::handle(ws), ngchm.env$handledb);
}
get (ws, ngchm.env$handledb)
}
#' Return response content interpreted as JSON
#'
#' @param httrResponse The httr response object
#'
#' @return The response parsed as JSON and returned as an R object
#'
#' @export
ngchmResponseJSON <- function (httrResponse) {
stopifnot (httr::status_code(httrResponse) >= 200 && httr::status_code(httrResponse) < 300);
jsonlite::fromJSON(content(httrResponse,'text',encoding='UTF-8'), simplifyVector = FALSE)
}
getServerVersion <- function (server) {
url <- if (is (server, "ngchmServer")) server@serverURL else server;
ws <- sprintf("%s/gdacws/servermetadata", url);
res <- httr::GET (ws, handle=ngchmGetHandleHTTR (server));
as.numeric(ngchmResponseJSON(res)$Build_Number)
}
testExternalProgram <- function (program) {
res <- NULL;
suppressWarnings(try ({res <- system2(program, NULL, stdout=TRUE, stderr=TRUE);}, silent=TRUE));
if (is.null(res)) warning (sprintf("Unable to execute external program '%s'. Some functionality not available.", program));
!is.null(res)
}
testJava <- function (jarfile) {
res <- NULL;
suppressWarnings(try ({res <- system2("java", c("-jar", jarfile), stdout=TRUE, stderr=TRUE);}, silent=TRUE));
if (is.null(res)) stop ("Unable to execute Java");
if (length(res) == 0 || res[length(res)] != "WRONG_NUMBER_OF_PARAMETERS_ERROR") stop ("Bad Java version");
}
getBuilderJar <- function (server) {
if (is.null (server@jarFile)) {
vvv <- sprintf ("version%d", getServerVersion (server));
if (!exists (vvv, ngchm.env$jarCache)) {
ws <- sprintf("%s/resources/heatmappipeline.jar", server@serverURL);
res <- httr::GET (ws, handle=ngchmGetHandleHTTR (server));
tmpJarFile <- utempfile ("hmt", fileext=".jar");
writeBin (res$content, tmpJarFile);
testJava (tmpJarFile);
assign (vvv, tmpJarFile, ngchm.env$jarCache);
}
return (get (vvv, ngchm.env$jarCache))
}
if (!exists (server@jarFile, ngchm.env$jarCache)) {
# Load server@jarFile into jarCache
if (length(grep("^scp://", server@jarFile)) > 0) {
tmpJarFile <- utempfile ("hmt", fileext=".jar");
parts <- URLparts (server@jarFile);
if (parts[3] == "") {
systemCheck (sprintf ("scp %s:%s %s",
shQuote (parts[2]), shQuote(parts[4]), tmpJarFile));
} else {
systemCheck (sprintf ("scp -P %s %s:%s %s",
shQuote(parts[3]), shQuote (parts[2]), shQuote(parts[4]), tmpJarFile));
}
ngchm.env$jarCache[[server@jarFile]] <- tmpJarFile;
}
else if (length(grep("^http://", server@jarFile)) > 0) {
tmpJarFile <- utempfile ("hmt", fileext=".jar");
download.file (server@jarFile, tmpJarFile);
ngchm.env$jarCache[[server@jarFile]] <- tmpJarFile;
}
else if (length(grep("^https://", server@jarFile)) > 0) {
tmpJarFile <- utempfile ("hmt", fileext=".jar");
download.file (server@jarFile, tmpJarFile);
ngchm.env$jarCache[[server@jarFile]] <- tmpJarFile;
}
else if (length(grep("^file://", server@jarFile)) > 0) {
ngchm.env$jarCache[[server@jarFile]] <- substring (server@jarFile, 8);
} else {
stop (sprintf ("Unknown retrieval method for jarFile '%s' for NGCHM server '%s'", server@jarFile, server@name));
}
testJava (ngchm.env$jarCache[[server@jarFile]]);
}
ngchm.env$jarCache[[server@jarFile]]
}
#' Create an ngchmServer object from a specification.
#'
#' Create an ngchmServer object called 'serverName' from the specification 'serverSpec' (see details).
#' serverOptions override those in the specification files option by option.
#' The new ngchmServer object is returned and registered so that it can be
#' referenced by name, including retrieval using chmServer.
#'
#' @param serverName The name of the new server object.
#' @param serverSpec The specification for the server (defaults to servername).
#' @param serverOptions A named list of server options.
#'
#' @return The created (and registered) ngchmServer object.
#' @export
#'
#' @details serverSpec can be any of:
#' \itemize{
#' \item{A configuration directory path. }{The specification will be read from a file 'config.txt' in that directory.}
#' \item{An NGCHM server URL (ending in '/chm' or '/Viewer' for instance). }{A minimal specification will be inferred.
#' Known methods for uploading NGCHMs to the server will be autoprobed unless specified manually.}
#' \item{A URL referencing a configuration file (must end in '/config.txt'). }{The specification will be read from the
#' specified URL.}
#' }
#' serverOptions can include both protocol-specific options and the following generic options:
#' \itemize{
#' \item{'serverURL'. }{The URL for the NGCHM server.}
#' \item{'serverProtocol'. }{The protocol to be used for uploading etc. NGCHMs to the server.}
#' \item{'jarFile'. }{The jarFile used to build NGCHMs.}
#' \item{'traceLevel'. }{The amount of trace to output. Defaults to "PROGRESS".}
#' }
#'
#' @seealso [chmServer()]
#' @seealso [ngchmServer-class]
#' @seealso [ngchmGetServerProtocol()]
#' @seealso [ngchmServerProtocol-class]
chmCreateServer <- function (serverName,
serverSpec = NULL,
serverOptions = NULL)
{
defaultOptions <- list (traceLevel="PROGRESS", serverProtocol="manual", jarFile=NULL);
if (is.null(serverSpec)) serverSpec <- serverName;
cfg <- new.env();
if (substr (serverSpec, 1, 2) == "//") {
serverSpec <- paste ("http:", serverSpec, sep="");
}
hasProto <- grepl ("^[^/]*:", serverSpec);
if (!hasProto) {
# No protocol, so try to interpret as a server configuration directory
if (file.exists (file.path (serverSpec, 'config.txt'))) {
readConfigFile (cfg, file.path (serverSpec, "config.txt"), '=');
} else {
stop (sprintf ("'%s' is not a server configuration directory", serverSpec));
}
} else {
proto <- sub (":.*", "", serverSpec);
if (!(proto %in% c('http', 'https', 'scp', 'file'))) {
stop (sprintf ("Unknown protocol in serverSpec '%s'", serverSpec));
}
if (proto == 'file') {
serverSpec <- sub("file:","",serverSpec);
if (file.exists (file.path (serverSpec, 'config.txt'))) {
readConfigFile (cfg, file.path (serverSpec, "config.txt"), '=');
} else {
stop (sprintf ("'%s' is not a server configuration directory", serverSpec));
}
}
else if (proto %in% c('http', 'https')) {
if (substring(serverSpec,nchar(serverSpec)-10) == "/config.txt") {
readConfigFile (cfg, serverSpec, '=');
} else {
# Assume a URL that refers to an NGCHM server.
cfg$serverURL <- serverSpec;
# If protocol not specified, probe to see if API available.
if (!'serverProtocol' %in% names(serverOptions)) {
foundAPI <- FALSE;
# try manager API
ws <- sprintf("%s/manager/rest/chmservers", serverSpec);
res <- httr::GET (ws, handle=ngchmGetHandleHTTR (serverSpec));
if (res$status_code >= 200 && res$status_code < 300) {
content <- try(ngchmResponseJSON(res), silent=TRUE);
if ((!is(content, 'try-error')) && (length(content) > 0)) {
cfg$serverProtocol <- 'manager';
cfg$deployServer <- sprintf ("%s/manager/rest", serverSpec);
cfg$serviceName <- names(content)[1];
foundAPI <- TRUE;
}
}
if (!foundAPI) {
# try shaidy API
ws <- sprintf("%s/api/", serverSpec);
res <- httr::GET (ws, handle=ngchmGetHandleHTTR (serverSpec));
if (res$status_code >= 200 && res$status_code < 300) {
content <- try(ngchmResponseJSON(res), silent=TRUE);
if ((!is(content, 'try-error')) && (length(content) > 0)) {
cfg$serverProtocol <- 'shaidy';
cfg$basePath <- sprintf ("%s/api", serverSpec);
cfg$viewServer <- sprintf ("%s/NGCHM", serverSpec);
cfg$accessMethod <- 'api';
foundAPI <- TRUE;
}
}
}
}
}
}
else if (proto == "scp") {
defaultOptions$serverProtocol <- "mds2";
spec <- sub ("^[^/]*:", "", serverSpec);
if (substr (spec, 1, 2) != "//") stop (sprintf ("Malformed server spec '%s'", serverSpec));
spec <- substring (spec, 3);
cfgServer <- sub ("/.*", "", spec);
cfgDir <- sub ("^[^/]*", "", spec);
if (nchar (defaultOptions$deployServer) == 0) stop (sprintf ("Malformed server spec '%s'", serverSpec));
if (nchar (defaultOptions$deployDir) == 0) stop (sprintf ("Malformed server spec '%s'", serverSpec));
defaultOptions$deployServer <- cfgServer;
defaultOptions$deployDir <- cfgDir;
cfgFile <- utempfile ("cfg", fileext=".txt");
rcfg <- new.env();
if (system2 ("scp", args=c(sprintf ("%s:%s/%s", cfgServer, cfgDir, "config.txt"), cfgFile)) == 0) {
readConfigFile (rcfg, cfgFile, '=');
}
rcfg <- as.list (rcfg);
if (!("jarFile" %in% names(serverOptions))) {
# No user specified jarFile, so let's see what the remote config says.
if (length (rcfg$jarFile) == 0) {
# No jarFile specified in remote config, so peek to see if there's a remote jarFile in .mds subdirectory.
jarFile <- paste (cfgDir, ".mds", "heatmappipeline.jar", sep="");
found <- system2 ("ssh", args=c(cfgServer, sprintf ("[ -r %s ]", jarFile)));
if (found == 0) {
# Shell command above succeeded.
rcfg$jarFile <- paste ("scp://", cfgServer, jarFile, sep="");
}
}
else if (substr (rcfg$jarFile, 1, 7) == "file://") {
# Remote specified jarFile using file://, so convert to an scp://
jarFile <- substr (rcfg$jarFile, 8, nchar (rcfg$jarFile));
if (substr (jarFile, 1, 1) != '/') {
jarFile <- paste ('', cfgDir, jarFile, sep="/");
}
found <- system2 ("ssh", args=c(cfgServer, sprintf ("[ -r %s ]", jarFile)));
if (found == 0) {
rcfg$jarFile <- paste ("scp://", cfgServer, jarFile, sep="");
} else {
stop (sprintf ("Unable to access remote mds2 jarfile scp://%s%s", cfgServer, jarFile));
}
}
else {
# We assume network based addresses will work equally well from the current machine.
}
}
for (field in names(rcfg)) {
cfg[[field]] <- rcfg[[field]];
}
}
}
fileOptions <- as.list (cfg);
if ("jarFile" %in% names(serverOptions)) {
# the user explicitly specified the jarFile to use. Use it or fail.
if (file.exists (serverOptions$jarFile)) {
serverOptions$jarFile <- paste ("file://", serverOptions$jarFile, sep="");
}
else {
stop (sprintf ("Specified jarFile '%s' does not exist", serverOptions$jarFile));
}
}
classFields <- c('traceLevel', 'serverProtocol', 'deployServer', 'jarFile', 'serverURL', 'viewServer')
# defaultOptions, overridden by file options, overridden by explicit serverOptions.
cfg <- defaultOptions;
for (field in names(fileOptions)) {
cfg[[field]] <- fileOptions[[field]];
}
for (field in names(serverOptions)) {
cfg[[field]] <- serverOptions[[field]];
}
stopifnot ('serverProtocol' %in% names(cfg));
protocol <- ngchmGetServerProtocol (cfg$serverProtocol);
protoOpts <- cfg[setdiff(names(cfg),classFields)];
ngchmProtoParamCheck (protoOpts, protocol@requiredParams, protocol@optionalParams);
protocol@paramValidator (protoOpts);
ngchmRegisterServer("base", new(Class="ngchmServer",
name = serverName,
serverURL = cfg$serverURL,
serverProtocol = protocol,
traceLevel = cfg$traceLevel,
jarFile = cfg$jarFile,
deployServer = cfg$deployServer,
viewServer = cfg$viewServer,
protoOpts = protoOpts));
}
#' Create an ngchmServer object for a managed NG-CHM server
#'
#' Create an ngchmServer object called 'serverName' (see details).
#' The new ngchmServer object is returned and registered so that it can be
#' referenced by name, including retrieval using chmServer.
#' This library will communicate with the NG-CHM using the private address.
#' Returned URLs for viewing NG-CHMs will use the public address.
#'
#' @param serverName The name of the new server object.
#' @param privateAddr Private IP name/address of the server.
#' @param publicAddr Public IP name/address of the server.
#' @param chmPort Port on which the chm viewer is listening.
#' @param managerPort Port on which the chm manager is listening.
#' @param serviceName Name of the chmManager service
#' @param ... Additional options passed to chmCreateServer
#'
#' @return The created (and registered) ngchmServer object.
#' @export
#'
#' @seealso [chmServer()]
#' @seealso [chmCreateServer()]
chmCreateManagedServer <- function (serverName, privateAddr, publicAddr=NULL, chmPort=80, managerPort=18080, serviceName="default", ...) {
if (is.null(publicAddr)) publicAddr <- privateAddr;
chmCreateServer (serverName,
sprintf ("http://%s:%d/chm", privateAddr, chmPort),
list (serverProtocol="manager",
deployServer=sprintf("http://%s:%d/chm/manager/rest", privateAddr, managerPort),
serviceName=serviceName,
viewServer=sprintf("http://%s:%d/chm", publicAddr, chmPort),
...))
}
#' Check that all required parameters are specified, and all specified parameters are either required or optional.
#'
#' @param params A list of named parameters.
#' @param required A character vector of required parameter names
#' @param optional A character vector of optional parameter names
#'
#' @export
#'
ngchmProtoParamCheck <- function (params, required, optional) {
nm <- names(params);
need <- setdiff (required, nm);
if (length(need) != 0) stop (sprintf ("Required protocol parameter(s) %s not specified", paste(need,collapse=',')));
unknown <- setdiff (nm, c(required,optional));
if (length(unknown) != 0) stop (sprintf ("Unknown protocol parameter(s) %s specified", paste(unknown,collapse=',')));
}
readConfigFile <- function (cfg, filename, sep=':') {
lines <- NULL;
try (suppressWarnings(lines <- readLines (filename)), silent=TRUE);
if (length (lines) > 0) {
for (line in strsplit (lines, sep)) {
if (length(line) != 2) stop (sprintf ('Malformed configuration line "%s" in %s: should be option%svalue', paste(line,sep=sep), filename, sep));
cfg[[line[1]]] <- line[2];
}
}
}
getExtraParams <- function (props) {
# Collect extraparams.
pat <- "^!extraparam:";
idx <- which (vapply (props, function(x)regexpr(pat,x@label)!=-1, TRUE));
params <- new.env();
for (pp in props[idx]) {
match <- regexpr (pat, pp@label);
paramname <- substring (pp@label, attr(match,'match.length')+1);
params[[paramname]] <- pp@value;
}
cat ('Found extra params ', paste(ls(params),collapse=" "), "\n")
params
}
bindExtraParams <- function (funcs, params, props) {
hasep <- vapply (funcs, function(fn)length(fn@func@extraParams)>0, TRUE);
epfuncs <- funcs[which(hasep)];
funcs <- funcs[which(!hasep)];
for (fn in epfuncs) {
extra <- fn@func@extraParams;
cat ('Function ', fn@func@name, ' requires extra params ', paste(extra,collapse=" "), "\n");
if (all (vapply (extra, function(p) exists(p, params), TRUE))) {
vals <- vapply (extra, function(p)params[[p]], "");
names(vals) <- extra;
tmpname <- paste(c('f',sample(c(letters,toupper(letters),as.character(0:9)),15,replace=TRUE)), collapse="");
chmBindFunction (tmpname, fn@func@name, as.list(vals));
if (is(fn, "ngchmAxisFunction"))
newfn <- new(class(fn), type=fn@type, label=fn@label, func=chmGetFunction(tmpname))
else if (is(fn, "ngchmMatrixFunction"))
newfn <- new(class(fn), rowtype=fn@rowtype, coltype=fn@coltype, label=fn@label, func=chmGetFunction(tmpname))
else
stop (sprintf ("Unknown function class '%s'", classstr(fn)));
funcs <- append (funcs, newfn);
}
}
funcs
}
chmAddAutoMenuItems <- function (chm) {
params <- getExtraParams (chm@properties);
# Add row menu items for types we know about.
genSpecFeedback (10, "adding row menu items");
rowtypes <- getAllAxisTypes (chm, "row");
rowTypeFnsReqd <- rep(FALSE,length(rowtypes));
rowfns <- getAllAxisTypeFunctions (chm@rowTypeFunctions, rowtypes$types);
rowfns <- bindExtraParams (rowfns, params, chm@properties);
if (length(rowfns) > 0)
for (ii in 1:length(rowfns)) {
fn <- rowfns[[ii]];
rowTypeFnsReqd[getFnsRqrd(rowtypes,fn@type)] <- TRUE;
entry <- new (Class="ngchmMenuItem", label=fn@label, description=fn@func@description,
fun = sprintf ("function(s,a,e){%s(%s);}", fn@func@name, getValueExpr(rowtypes,fn@type,"axis")));
chm@rowMenu <- append (chm@rowMenu, entry);
}
# Add column menu items for types we know about.
genSpecFeedback (20, "adding column menu items");
coltypes <- getAllAxisTypes (chm, "column");
colTypeFnsReqd <- rep(FALSE,length(coltypes));
colfns <- getAllAxisTypeFunctions (chm@colTypeFunctions, coltypes$types);
colfns <- bindExtraParams (colfns, params, chm@properties);
if (length(colfns) > 0)
for (ii in 1:length(colfns)) {
fn <- colfns[[ii]];
colTypeFnsReqd[getFnsRqrd(coltypes,fn@type)] <- TRUE;
entry <- new (Class="ngchmMenuItem", label=fn@label, description=fn@func@description,
fun = sprintf ("function(s,a,e){%s(%s);}", fn@func@name, getValueExpr(coltypes,fn@type,"axis")));
chm@colMenu <- append (chm@colMenu, entry);
}
# Add matrix element menu items for types we know about.
genSpecFeedback (30, "adding matrix menu items");
matfns <- getAllMatrixTypeFunctions (chm, rowtypes$types, coltypes$types);
matfns <- bindExtraParams (matfns, params, chm@properties);
if (length(matfns) > 0)
for (ii in 1:length(matfns)) {
fn <- matfns[[ii]];
rowTypeFnsReqd[getFnsRqrd(rowtypes,fn@rowtype)] <- TRUE;
colTypeFnsReqd[getFnsRqrd(coltypes,fn@columntype)] <- TRUE;
entry <- new (Class="ngchmMenuItem", label=fn@label, description=fn@func@description,
fun = sprintf ("function(rs,cs,e){%s(%s,%s);}", fn@func@name,
getValueExpr(rowtypes,fn@rowtype,"row"), getValueExpr(coltypes,fn@columntype,"column")));
chm@elementMenu <- append (chm@elementMenu, entry);
cat ("chmMake: added elementMenu entry ", entry@label, "\n", file=stderr());
}
# Add functions for getting type values from selections.
genSpecFeedback (40, "adding type selector functions");
cat ("chmMake: matfns contains ", length(matfns), " entries\n", file=stderr());
fns <- append (matfns, unique (append (rowfns, colfns)));
if (length(fns) > 0)
for (ii in 1:length(fns)) {
if (length(fns[[ii]]) == 0) {
cat ("chmMake: axis/mat fn entry is NULL\n", file=stderr());
} else if (is (fns[[ii]], "ngchmAxisType")) {
chm <- chmAddMenuItem (chm, "nowhere", "unused", fns[[ii]]@func);
} else if (is (fns[[ii]], "ngchmAxisFunction")) {
chm <- chmAddMenuItem (chm, "nowhere", "unused", fns[[ii]]@func);
} else if (is (fns[[ii]], "ngchmMatrixFunction")) {
chm <- chmAddMenuItem (chm, "nowhere", "unused", fns[[ii]]@func);
} else if (fns[[ii]]@op != "javascript"){
cat ("chmMake: axis/mat fn op is not javascript\n", file=stderr());
} else {
chm <- chmAddMenuItem (chm, "nowhere", "unused", fns[[ii]]@params$func);
}
}
fns <- unique (append (rowtypes$builders[rowTypeFnsReqd], coltypes$builders[colTypeFnsReqd]));
if (length(fns) > 0)
for (ii in 1:length(fns))
if (length(fns[[ii]]) == 0) {
cat ("chmMake: builders fn entry is NULL\n", file=stderr());
} else if (is (fns[[ii]], "ngchmAxisType")) {
chm <- chmAddMenuItem (chm, "nowhere", "unused", fns[[ii]]@func);
} else if (is (fns[[ii]], "ngchmAxisFunction")) {
chm <- chmAddMenuItem (chm, "nowhere", "unused", fns[[ii]]@func);
} else if (fns[[ii]]@op != "javascript"){
cat ("chmMake: builders fn op is not javascript\n", file=stderr());
} else {
chm <- chmAddMenuItem (chm, "nowhere", "unused", fns[[ii]]@params$func);
}
chmUU (chm)
}
#' Output Javascript code required to customize an NGCHM.
#'
#' This function outputs the Javascript required to customize an NGCHM.
#'
#' @param chm An NGCHM
#' @param filename The file to which the customization code will be written.
#'
#' @export
#'
chmWriteCustomJS <- function (chm, filename) {
chm <- chmFixVersion (chm);
if (length (chm@datasets) > 0) {
#genSpecFeedback (8, "adding toolbox(es)");
chm <- addToolBoxes (chm);
}
chm <- chmAddAutoMenuItems (chm);
writeCustomJS (chm, filename);
}
#' Get the file path to the specified overview file.
#'
#' This function returns the file path to the specified overview image of the CHM. The CHM must be
#' made before the file can be accessed.
#' If idx is specified, format if given must equal that of the overview image, and the path to that overview image is returned.
#' If idx is not specified, the file path to the first overview of the given format (default 'png') is returned.
#'
#' @param chm An NGCHM.
#' @param format The format of overview image desired (defaults to 'png' if idx is not specified).
#' @param idx The index of the overview image desired (defaults to first image of the specified format).
#'
#' @export
chmGetOverview <- function (chm, format=NULL, idx=NULL) {
chm <- chmFixVersion (chm);
if (is.null(idx)) {
if (is.null (format)) format <- 'png';
idx <- which(vapply (chm@overviews, function(ov)ov@format, '')==format);
if (is.null(idx)) stop (sprintf ('CHM "%s" has no overview with format "%s"', chm@name, format));
idx <- idx[1];
} else {
if ((idx < 1) || (idx > length(chm@overviews)))
stop (sprintf ('Invalid index (%d) for overview of CHM "%s"', idx, chm@name));
if (is.null (format)) {
format <- chm@overviews[[idx]]@format;
}
else if (format != chm@overviews[[idx]]@format) {
stop (sprintf ('Overview #%d of CHM "%s" does not have format "%s"', idx, chm@name, format));
}
}
file.path(chm@outDir, chm@name, 'overview', sprintf('overview%d.%s', idx, format))
}
#' @import digest
getuuid <- function(prev="") {
digest::digest(paste(c(Sys.info(),Sys.time(),rnorm(1),prev,collapse=""),recursive=TRUE),algo="sha256")
}
chmFixCovariateVersion <- function (covariate) {
if (!is(covariate@label.series,'shaid')) {
values <- covariate@label.series;
stopifnot (is (values, 'character'));
values <- values[order(names(values))];
mat <- matrix (values, ncol=1, dimnames=list(names(values),'Value'));
covariate@label.series <- ngchmSaveAsDatasetBlob (ngchm.env$tmpShaidy, 'tsv', mat);
}
covariate
}
chmFixDatasetVersion <- function (dataset) {
dataset@row.covariates <- lapply (dataset@row.covariates, chmFixCovariateVersion);
dataset@column.covariates <- lapply (dataset@column.covariates, chmFixCovariateVersion);
dataset
}
chmFixVersion <- function (chm) {
if (chm@version < 2) {
warning ("Upgrading chm ", chm@name, " from version ", chm@version, " to version 2");
v2 <- new ("ngchmVersion2");
for (name in slotNames("ngchmVersion1")) {
if (!name %in% c("version", "rowClassbars", "colClassbars")) {
slot (v2, name) <- slot (chm, name);
}
}
v2@rowCovariateBars <- chm@rowClassbars;
v2@colCovariateBars <- chm@colClassbars;
for (ii in 1:length(chm@layers)) {
if (is(chm@layers[[ii]]@data,"matrix")) {
v2@layers[[ii]]@data <- ngchmSaveAsDatasetBlob (ngchm.env$tmpShaidy, 'tsv', v2@layers[[ii]]@data);
}
}
chm <- v2;
}
if (chm@version == 2) {
if (length(chm@layers) > 0) {
# Early version2 did not have summarizationMethod slot
for (ii in 1:length(chm@layers)) {
if (!.hasSlot(chm@layers[[ii]],"summarizationMethod")) {
chm@layers[[ii]]@summarizationMethod <- 'average';
}
}
}
if (length(chm@templates) > 0) {
# Early version2 did not have dest.blob slot
for (ii in 1:length(chm@templates)) {
if (!.hasSlot(chm@templates[[ii]],"dest.blob")) {
t <- chm@templates[[ii]];
# FIXME: will not work if source.path is a file that is either no longer available or different
# It might be possible to find original template where CHM came from???
chm@templates[[ii]]@dest.blob <-
ngchmSaveTemplateAsBlob(ngchm.env$tmpShaidy, t@source.path, t@dest.path, t@substitutions);
}
}
}
chm@datasets <- lapply (chm@datasets, chmFixDatasetVersion);
}
if (length(chm@rowOrder)>0 && is(chm@rowOrder,"function")) {
if (!identical(chm@rowOrder,chmDefaultRowOrder) &&
!identical(chm@rowOrder,chmOriginalRowOrder) &&
!identical(chm@rowOrder,chmRandomRowOrder)) {
if (chm@rowOrderMethod=="Random") {
chm@rowOrder <- chmRandomRowOrder;
} else if (chm@rowOrderMethod=="Original") {
chm@rowOrder <- chmOriginalRowOrder;
} else {
chm@rowOrder <- chmDefaultRowOrder;
chm@rowOrderMethod <- "Hierarchical";
}
}
}
if (length(chm@colOrder)>0 && is(chm@colOrder,"function")) {
if (!identical(chm@colOrder,chmDefaultColOrder) &&
!identical(chm@colOrder,chmOriginalColOrder) &&
!identical(chm@colOrder,chmRandomColOrder)) {
if (chm@colOrderMethod=="Random") {
chm@colOrder <- chmRandomColOrder;
} else if (chm@colOrderMethod=="Original") {
chm@colOrder <- chmOriginalColOrder;
} else {
chm@colOrder <- chmDefaultColOrder;
chm@colOrderMethod <- "Hierarchical";
}
}
}
chm
}
chmUU <- function (chm) {
chm@uuid <- getuuid(chm@uuid)
chm
}
#' @import digest
gitSha <- function (data) {
stopifnot (typeof(data) %in% c("character","raw"));
if (typeof(data) == "character") {
data <- charToRaw (paste (data, collapse=''));
}
head <- sprintf ("blob %d", length(data));
digest::digest (c(charToRaw(head),raw(1),data),"sha1",serialize=FALSE)
}
utempfile <- function (...) {
# On Windows, file.path separates files by / , tempfile (and tempdir) separate them by backslashes
# We need consistency, so convert to canonical separator / here, rather than complicate all other uses
filename <- tempfile (...);
if (Sys.info()[['sysname']] == "Windows") {
filename <- gsub ("\\\\", "/", filename);
}
filename
}
#' Browse the NGCHMs on the specified server in the viewer.
#'
#' Opens the NG-CHM browser page in the viewer.
#'
#' @param server The server to browse. Defaults to option "NGCHM.Server" or the first server.
#' @param viewer The viewer to use. Defaults to option "viewer" or browseURL.
#' @export
#'
#' @seealso [utils::browseURL()]
chmBrowse <- function (server=NULL, viewer=NULL) {
if (is.null(server)) server <- getOption("NGCHM.Server", chmListServers()[1]);
if (!is(server,"ngchmServer")) server <- chmServer(server);
if (is.null(viewer)) viewer <- getOption("viewer", browseURL);
viewer (server@viewServer)
}
#' Manage the NGCHMs on the specified server in the viewer.
#'
#' Opens the NG-CHM manager page in the viewer.
#'
#' @param server The server to browse. Defaults to option "NGCHM.Server" or the first server.
#' The server must be managed.
#' @param viewer The viewer to use. Defaults to option "viewer" or browseURL.
#' @export
#'
#' @seealso [utils::browseURL()]
chmManager <- function (server=NULL, viewer=NULL) {
if (is.null(server)) server <- getOption("NGCHM.Server", chmListServers()[1]);
if (!is(server,"ngchmServer")) server <- chmServer(server);
stopifnot (server@serverProtocol@protocolName == "manager");
if (is.null(viewer)) viewer <- getOption("viewer", browseURL);
viewer (paste(server@viewServer, "manager", sep="/"))
}
#' Open the NG-CHM on the specified server in the viewer.
#'
#' @param x The NGCHM to view.
#' @param server The server containing the NG-CHM. Defaults to option "NGCHM.Server" or the first server.
#' @param viewer The viewer to use. Defaults to option "viewer" or browseURL.
#' @param ... Ignored.
#' @export
plot.ngchmVersion2 <- function(x, server=NULL, viewer=NULL, ...) {
if (is.null(server)) server <- getOption("NGCHM.Server", chmListServers()[1]);
if (!is(server,"ngchmServer")) server <- chmServer(server);
if (is.null(viewer)) viewer <- getOption("viewer", browseURL);
viewer(chmGetURL(x,server=server))
}
#' Write a matrix as a binary viewer tile
#'
#' Write the matrix as a vector of 32-bit little-endian floats to the specified file.
#'
#' @param mat The matrix to output
#' @param filename The name of the file to write the tile to
writeTile <- function (mat, filename) {
vec <- t (mat);
dim(vec) <- NULL;
writeBin (vec, filename, size=4, endian="little");
}
#' Read a binary viewer tile as a matrix
#'
#' Read a vector of little-endian 32-bit floats from the specified file and return
#' as a matrix with nrow rows and ncol columns.
#'
#' @param filename The name of the file to read the tile from
#' @param nrow Number of rows in the tile
#' @param ncol Number of columns in the tile
readTile <- function (filename, nrow, ncol) {
vec <- readBin (filename, "double", nrow*ncol, size=4, endian="little");
return (matrix (vec, nrow=nrow, byrow=TRUE));
}
#' Export a standalone NGCHM to a file.
#'
#' Create a standalone viewer for the NGCHM in the specified file.
#'
#' @export
#' @rdname chmExportToFile-method
#'
#' @param chm The NGCHM to export
#' @param filename The file in which to save the rendered NGCHM
#' @param overwrite Overwrite file iff true (default false)
#' @param shaidyMapGen Path to shaidyMapGen jar file (default to value of environment variable SHAIDYMAPGEN)
#' @param shaidyMapGenJava Path to java executable with which to run shaidyMapGen (default to value of environment variable SHAIDYMAPGENJAVA or java)
#' @param shaidyMapGenArgs Additional arguments to pass to java when running shaidyMapGen (default to value of environment variable SHAIDYMAPGENARGS)
#'
#' @return the rendered NGCHM
chmExportToFile <- function(chm,filename,overwrite=FALSE,shaidyMapGen, shaidyMapGenJava, shaidyMapGenArgs) {
if( !overwrite && file.exists(filename) ) stop ("'filename' already exists");
if (missing(shaidyMapGen)) shaidyMapGen <- Sys.getenv("SHAIDYMAPGEN");
if (missing(shaidyMapGenJava)) shaidyMapGenJava <- Sys.getenv("SHAIDYMAPGENJAVA");
if (shaidyMapGenJava == "") shaidyMapGenJava <- "java";
if (missing(shaidyMapGenArgs)) shaidyMapGenArgs <- strsplit(Sys.getenv("SHAIDYMAPGENARGS"),",")[[1]];
if (shaidyMapGen == "") stop ("shaidyMapGen not specified or set in environment");
chm@format <- "shaidy";
chm <- chmAddProperty (chm, "chm.info.build.time", format(Sys.time(), "%F %H:%M:%S"));
chm <- chmMake (chm);
shaidyRepo <- ngchm.env$tmpShaidy;
shaid <- shaidyGetShaid (chm);
status <- system2(shaidyMapGenJava, c(shaidyMapGenArgs, "-jar", shaidyMapGen, shaidyRepo$basepath, shaid@value, shaid@value, "NO_PDF"));
if (status != 0) stop("export to ngchm failed");
if (!file.copy (shaidyRepo$blob.path ("viewer", shaid@value, chm@name, paste(chm@name,"ngchm",sep=".")), filename, TRUE)) {
stop("export to ngchm failed");
}
chm
}
#' Export a PDF of the NGCHM to a file.
#'
#' Create a PDF of the NGCHM in the specified file.
#'
#' @export
#' @rdname chmExportToPDF-method
#'
#' @param chm The NGCHM to generate the PDF for
#' @param filename The file in which to save the PDF
#' @param overwrite Overwrite file iff true (default false)
#' @param shaidyMapGen Path to shaidyMapGen jar file (default to value of environment variable SHAIDYMAPGEN)
#' @param shaidyMapGenJava Path to java executable with which to run shaidyMapGen (default to value of environment variable SHAIDYMAPGENJAVA or java)
#' @param shaidyMapGenArgs Additional arguments to pass to java when running shaidyMapGen (default to value of environment variable SHAIDYMAPGENARGS)
#'
#' @return filename
chmExportToPDF <- function(chm,filename,overwrite=FALSE,shaidyMapGen, shaidyMapGenJava, shaidyMapGenArgs) {
if( !overwrite && file.exists(filename) ) stop ("'filename' already exists");
if (missing(shaidyMapGen)) shaidyMapGen <- Sys.getenv("SHAIDYMAPGEN");
if (missing(shaidyMapGenJava)) shaidyMapGenJava <- Sys.getenv("SHAIDYMAPGENJAVA");
if (shaidyMapGenJava == "") shaidyMapGenJava <- "java";
if (missing(shaidyMapGenArgs)) shaidyMapGenArgs <- strsplit(Sys.getenv("SHAIDYMAPGENARGS"),",")[[1]];
if (length(chmProperty(chm, "chm.info.build.time"))==0) {
chm@format <- "shaidy";
chmProperty (chm, "chm.info.build.time") <- format(Sys.time(), "%F %H:%M:%S");
chm <- chmMake (chm);
}
shaidyRepo <- ngchm.env$tmpShaidy;
shaid <- shaidyGetShaid (chm);
pdfpath <- shaidyRepo$blob.path ("viewer", shaid@value, chm@name, paste(chm@name,".pdf",sep=""));
if (!file.exists(pdfpath)) {
if (shaidyMapGen == "") stop ("shaidyMapGen required but not specified or set in environment");
status <- system2(shaidyMapGenJava, c(shaidyMapGenArgs, "-jar", shaidyMapGen, shaidyRepo$basepath, shaid@value, shaid@value));
if (status != 0 || !file.exists(pdfpath)) stop("export to pdf failed");
}
if (!file.copy (pdfpath, filename, TRUE)) {
stop("export to pdf failed");
}
filename
};
#' Export a standalone HTML containing the NGCHM to a file.
#'
#' Create a standalone HTML containing the NGCHM in the specified file.
#'
#' @export
#' @rdname chmExportToHTML-method
#'
#' @param chm The NGCHM to generate the PDF for
#' @param filename The file in which to save the PDF
#' @param overwrite Overwrite file iff true (default false)
#' @param shaidyMapGen Path to shaidyMapGen jar file (default to value of environment variable SHAIDYMAPGEN)
#' @param shaidyMapGenJava Path to java executable with which to run shaidyMapGen (default to value of environment variable SHAIDYMAPGENJAVA or java)
#' @param shaidyMapGenArgs Additional arguments to pass to java when running shaidyMapGen (default to value of environment variable SHAIDYMAPGENARGS)
#' @param ngchmWidgetPath Path to location of ngchm Widget (ngchmWidget-min.js). Defaults to environment variable NGCHMWIDGETPATH.
#'
#' @return filename
chmExportToHTML <- function(chm,filename,overwrite=FALSE,shaidyMapGen, shaidyMapGenJava, shaidyMapGenArgs, ngchmWidgetPath) {
if( !overwrite && file.exists(filename) ) stop ("'filename' already exists");
if (missing(shaidyMapGen)) shaidyMapGen <- Sys.getenv("SHAIDYMAPGEN");
if (missing(shaidyMapGenJava)) shaidyMapGenJava <- Sys.getenv("SHAIDYMAPGENJAVA");
if (shaidyMapGenJava == "") shaidyMapGenJava <- "java";
if (missing(shaidyMapGenArgs)) shaidyMapGenArgs <- strsplit(Sys.getenv("SHAIDYMAPGENARGS"),",")[[1]];
if (missing(ngchmWidgetPath)) {
stopifnot (Sys.getenv("NGCHMWIDGETPATH") != "");
} else {
Sys.setenv(NGCHMWIDGETPATH=ngchmWidgetPath);
}
if (length(chmProperty(chm, "chm.info.build.time"))==0) {
chm@format <- "shaidy";
chmProperty (chm, "chm.info.build.time") <- format(Sys.time(), "%F %H:%M:%S");
chm <- chmMake (chm);
}
shaidyRepo <- ngchm.env$tmpShaidy;
shaid <- shaidyGetShaid (chm);
htmlpath <- shaidyRepo$blob.path ("viewer", shaid@value, chm@name, paste(chm@name,".html",sep=""));
if (!file.exists(htmlpath)) {
if (shaidyMapGen == "") stop ("shaidyMapGen required but not specified or set in environment");
status <- system2(shaidyMapGenJava, c(shaidyMapGenArgs, "-jar", shaidyMapGen, shaidyRepo$basepath, shaid@value, shaid@value, "NO_PDF", "-HTML"));
if (status != 0 || !file.exists(htmlpath)) stop("export to html failed");
}
if (!file.copy (htmlpath, filename, TRUE)) {
stop("export to html failed");
}
filename
};
writeBinLines <- function(text, con) {
openit <- is.character(con);
if (openit) con <- file(con, "wb");
writeLines (text, con, "\n");
if (openit) close (con);
}
#' Add TSNE coordinates to an NG-CHM.
#'
#' Add TSNE coordinates as hidden covariate bars to an axis of an NG-CHM. One hidden
#' covariate bar is added for each TSNE coordinate. Coordinates have names 'BASENAME.coordinate.N',
#' where BASENAME is specified by the parameter basename (default TSNE) and N ranges from 1 to the number of
#' added covariate bars.
#'
#' pointIds is required because [Rtsne::Rtsne()] does not preserve the rownames of the data matrix it was applied to.
#' Their values must match those on that axis of the NGCHM, but their order must match those in the data
#' matrix passed to [Rtsne::Rtsne()].
#'
#' @examples
#' rtc <- Rtsne::Rtsne(t(TCGA.BRCA.ExpressionData));
#' hm <- chmNew ("brca", TCGA.BRCA.ExpressionData);
#' hm <- chmAddTSNE(hm, "column", rtc, colnames(TCGA.BRCA.ExpressionData));
#'
#' @export
#'
#' @param hm The NGCHM to add the coordinates to
#' @param axis The NGCHM axis ("row" or "column") to add the coordinates to
#' @param tsne TSNE coordinates (output of [Rtsne::Rtsne()]) for the specified NGCHM axis
#' @param pointIds The NGCHM names for the data points in tsne
#' @param baseName The prefix to use for the coordinate names.
#'
#' @return The NGCHM with added coordinates.
#' @seealso [chmAddPCA()]
#' @seealso [chmAddUMAP()]
#' @seealso [chmAddUWOT()]
#' @seealso [chmAddReducedDim()]
chmAddTSNE <- function (hm, axis, tsne, pointIds, basename = "TSNE") {
stopifnot (is(hm, "ngchmVersion2"));
stopifnot (mode(axis) == "character" && length(axis) == 1);
stopifnot (axis == "row" || axis == "column");
stopifnot (mode(pointIds) == "character" && length(pointIds) == nrow(tsne$Y));
stopifnot (mode(basename) == "character" && length(basename) == 1);
for (idx in 1:ncol(tsne$Y)) {
coordname <- sprintf ("%s.coordinate.%d", basename, idx);
vals <- tsne$Y[,idx];
names(vals) <- pointIds;
minv <- min (vals, na.rm=TRUE);
maxv <- max (vals, na.rm=TRUE);
midv <- if (minv*maxv < 0) 0.0 else (minv+maxv)/2.0;
cmap <- chmNewColorMap(c(minv,midv,maxv), colors=c("#00007f","#d0d0d0","#7f0000"));
cv <- chmNewCovariate(coordname, vals, cmap);
hm <- chmAddCovariateBar(hm, axis, cv, display = "hidden");
}
return (hm);
}
#' Add PCA coordinates to an NG-CHM.
#'
#' Add PCA coordinates as hidden covariate bars to an axis of an NG-CHM.
#' One hidden covariate bar is added for each PCA coordinate (up to ndim coordinates).
#' Coordinates are given names 'BASENAME.coordinate.N', where BASENAME is specified by the
#' parameter basename (default "PC") and N ranges from 1 to the number of added covariate bars.
#'
#' @examples
#' prc <- prcomp(TCGA.BRCA.ExpressionData);
#' hm <- chmNew ("brca", TCGA.BRCA.ExpressionData);
#' hm <- chmAddPCA(hm, "column", prc);
#'
#' @export
#'
#' @param hm The NGCHM to add the coordinates to.
#' @param axis The NGCHM axis ("row" or "column") to add the coordinates to.
#' @param prc Principal component coordinates (output of [stats::prcomp()]) for the specified NGCHM axis.
#' @param baseName The prefix to use for the coordinate names.
#' @param ndim The maximum number of coordinates to add.
#'
#' @return The NGCHM with added coordinates.
#' @seealso [chmAddTSNE()]
#' @seealso [chmAddUMAP()]
#' @seealso [chmAddUWOT()]
#' @seealso [chmAddReducedDim()]
chmAddPCA <- function (hm, axis, prc, basename = "PC", ndim=2) {
stopifnot (is(hm, "ngchmVersion2"));
stopifnot (mode(axis) == "character" && length(axis) == 1);
stopifnot (axis == "row" || axis == "column");
stopifnot (mode(basename) == "character" && length(basename) == 1);
stopifnot (mode(ndim) == "numeric" && length(basename) == 1);
pointIds <- rownames(prc$rotation);
for (idx in 1:min(ncol(prc$rotation),ndim)) {
coordname <- sprintf ("%s.coordinate.%d", basename, idx);
vals <- prc$rotation[,idx];
names(vals) <- pointIds;
minv <- min (vals, na.rm=TRUE);
maxv <- max (vals, na.rm=TRUE);
midv <- if (minv*maxv < 0) 0.0 else (minv+maxv)/2.0;
cmap <- chmNewColorMap(c(minv,midv,maxv), colors=c("#00007f","#d0d0d0","#7f0000"));
cv <- chmNewCovariate(coordname, vals, cmap);
hm <- chmAddCovariateBar(hm, axis, cv, display = "hidden");
}
return (hm);
}
#' Add UMAP coordinates to an NG-CHM.
#'
#' Add UMAP coordinates as hidden covariate bars to an axis of an NG-CHM. One hidden
#' covariate bar is added for each UMAP coordinate. Coordinates have names 'BASENAME.coordinate.N',
#' where BASENAME is specified by the parameter basename (default UMAP) and N ranges from 1 to the number of
#' added covariate bars.
#'
#' @examples
#' umc <- umap::umap(t(TCGA.BRCA.ExpressionData));
#' hm <- chmNew ("brca", TCGA.BRCA.ExpressionData);
#' hm <- chmAddUMAP(hm, "column", umc);
#'
#' @export
#'
#' @param hm The NGCHM to add the coordinates to.
#' @param axis The NGCHM axis ("row" or "column") to add the coordinates to.
#' @param umap TSNE coordinates (output of [umap::umap()]) for the specified NGCHM axis.
#' @param baseName The prefix to use for the coordinate names.
#'
#' @return The NGCHM with added coordinates.
#' @seealso [chmAddPCA()]
#' @seealso [chmAddTSNE()]
#' @seealso [chmAddUWOT()]
#' @seealso [chmAddReducedDim()]
chmAddUMAP <- function (hm, axis, umap, basename = "UMAP") {
stopifnot (is(hm, "ngchmVersion2"));
stopifnot (mode(axis) == "character" && length(axis) == 1);
stopifnot (axis == "row" || axis == "column");
stopifnot (mode(basename) == "character" && length(basename) == 1);
pointIds <- rownames(umap$layout);
for (idx in 1:ncol(umap$layout)) {
coordname <- sprintf ("%s.coordinate.%d", basename, idx);
vals <- umap$layout[,idx];
names(vals) <- pointIds;
minv <- min (vals, na.rm=TRUE);
maxv <- max (vals, na.rm=TRUE);
midv <- if (minv*maxv < 0) 0.0 else (minv+maxv)/2.0;
cmap <- chmNewColorMap(c(minv,midv,maxv), colors=c("#00007f","#d0d0d0","#7f0000"));
cv <- chmNewCovariate(coordname, vals, cmap);
hm <- chmAddCovariateBar(hm, axis, cv, display = "hidden");
}
return (hm);
}
#' Add UWOT::UMAP coordinates to an NG-CHM.
#'
#' Add UWOT::UMAP coordinates as hidden covariate bars to an axis of an NG-CHM. One hidden
#' covariate bar is added for each UMAP coordinate. Coordinates have names 'BASENAME.coordinate.N',
#' where BASENAME is specified by the parameter basename (default UMAP) and N ranges from 1 to the number of
#' added covariate bars.
#'
#' pointIds is required because [uwot::umap()] does not preserve the rownames of the data matrix it was applied to.
#' Their values must match those on that axis of the NGCHM, but their order must match those in the data
#' matrix passed to [uwot::umap()].
#'
#' @examples
#' umc <- uwot::umap(t(TCGA.BRCA.ExpressionData));
#' hm <- chmNew ("brca", TCGA.BRCA.ExpressionData);
#' hm <- chmAddUWOT(hm, "column", umc, colnames(TCGA.BRCA.ExpressionData));
#'
#' @export
#'
#' @param hm The NGCHM to add the coordinates to.
#' @param axis The NGCHM axis ("row" or "column") to add the coordinates to.
#' @param uwot UMAP coordinates (output of [uwot::umap()]) for the specified NGCHM axis.
#' @param pointIds The NGCHM names for the data points in uwot
#' @param basename The prefix to use for the coordinate names.
#'
#' @return The NGCHM with added coordinates.
#' @seealso [chmAddPCA()]
#' @seealso [chmAddTSNE()]
#' @seealso [chmAddUMAP()]
#' @seealso [chmAddReducedDim()]
chmAddUWOT <- function (hm, axis, uwot, pointIds, basename = "UMAP") {
stopifnot (is(hm, "ngchmVersion2"));
stopifnot (mode(axis) == "character" && length(axis) == 1);
stopifnot (axis == "row" || axis == "column");
stopifnot (mode(pointIds) == "character" && length(pointIds) == nrow(uwot));
stopifnot (mode(basename) == "character" && length(basename) == 1);
for (idx in 1:ncol(uwot)) {
coordname <- sprintf ("%s.coordinate.%d", basename, idx);
vals <- uwot[,idx];
names(vals) <- pointIds;
minv <- min (vals, na.rm=TRUE);
maxv <- max (vals, na.rm=TRUE);
midv <- if (minv*maxv < 0) 0.0 else (minv+maxv)/2.0;
cmap <- chmNewColorMap(c(minv,midv,maxv), colors=c("#00007f","#d0d0d0","#7f0000"));
cv <- chmNewCovariate(coordname, vals, cmap);
hm <- chmAddCovariateBar(hm, axis, cv, display = "hidden");
}
return (hm);
};
#' Add Single Cell reduced dimension coordinates to an NG-CHM.
#'
#' Add SingleCellExperiment::reducedDim or Seurat reduced dimension coordinates from a single cell object sce
#' as hidden covariate bars to an axis of an NG-CHM. dimName specifies the name of the reduced
#' dimension of interest in sce. One hidden covariate bar is added for each coordinate.
#' If specified, maxDim limits the maximum number of covariate bars added to the chm.
#' Coordinates have names 'BASENAME.coordinate.N', where BASENAME is specified by the parameter
#' basename (defaults to dimName if omitted) and N ranges from 1 to the number of added covariate bars.
#'
#' @examples
#' hm <- chmAddReducedDim(hm, "column", sce, "PCA", 3, "PC");
#' hm <- chmAddReducedDim(hm, "column", sce, "TSNE");
#'
#' @export
#'
#' @param hm The NGCHM to add the coordinates to.
#' @param axis The NGCHM axis ("row" or "column") to add the coordinates to.
#' @param sce An object containing the reduced dimension.
#' @param dimName The name of the reduced dimension to create covariate bars for.
#' @param maxDim The maximum number of coordinates to add (default all).
#' @param basename The prefix to use for the coordinate names (defaults to dimName).
#' @param dimAxis The axis on the sce object containing the named dimension.
#'
#' @return The NGCHM with added coordinates.
#' @seealso [chmAddPCA()]
#' @seealso [chmAddTSNE()]
#' @seealso [chmAddUMAP()]
#' @seealso [chmAddUWOT()]
chmAddReducedDim <- function (hm, axis, sce, dimName, maxDim, basename, dimAxis) {
layout <- NULL;
# Try hard to find an applicable reducedDim method
if (is (sce, "SingleCellExperiment")) {
layout <- SingleCellExperiment::reducedDim (sce, dimName);
} else if (is (sce, "Seurat")) {
layout <- sce@reductions[[dimName]]@cell.embeddings;
} else {
pkg <- attr(class(sce), 'package');
if (length(pkg) != 0) {
ns <- tryCatch (loadNamespace(pkg), error = function(e) e);
if (!is(ns, 'error') && exists('reducedDim',ns)) {
if (missing(dimAxis)) {
layout <- get('reducedDim',ns) (sce, dimName);
} else {
layout <- get('reducedDim',ns) (sce, dimName, axis=dimAxis);
}
}
}
}
if (length(layout) == 0) {
# Last chance: try .GlobalEnv
if (exists ('reducedDim')) {
if (missing(dimAxis)) {
layout <- get('reducedDim') (sce, dimName);
} else {
layout <- get('reducedDim') (sce, dimName, axis=dimAxis);
}
} else {
stop ("Unable to get reduced dimension from single cell object");
}
}
if (missing(maxDim)) maxDim <- ncol (layout);
if (missing(basename)) basename <- dimName;
for (idx in 1:maxDim) {
coordname <- sprintf ("%s.coordinate.%d", basename, idx);
vals <- layout[,idx];
minv <- min (vals, na.rm = TRUE);
maxv <- max (vals, na.rm = TRUE);
midv <- if (minv*maxv < 0) 0 else (minv+maxv)/2.0;
cmap <- chmNewColorMap (c(minv, midv, maxv), colors=c("#00007f", "#d0d0d0", "#7f0000"));
cv <- chmNewCovariate (coordname, vals, cmap)
hm <- chmAddCovariateBar (hm, axis, cv, display="hidden");
}
return (hm);
};
#' Helper function to cast variables as integers.
#'
#' If variable value is far from integer, print error message and stop.
#'
#' @param variableToCast Variable to cast as integer
#' @return integer value of variableToCast
castAsInteger <- function(variableToCast) {
roundTolerance = 0.01
if (abs(round(variableToCast) - variableToCast) > roundTolerance) {
log_error("Variable '",deparse(substitute(variableToCast)),"' must be integer")
stop("Variable '",deparse(substitute(variableToCast)),"' must be integer")
} else {
return (as.integer(round(variableToCast)))
}
}
#' Helper function to cast list as integer
#'
#' If variable value is far from integer, print error message and stop.
#'
#' @param listToCast List to cast as integer
#' @return list with members cast to integers
castListAsInteger <- function(listToCast) {
roundTolerance = 0.01
lapply(listToCast, function(elem) {
if ((abs(round(elem) - elem)) > roundTolerance) {
log_error("Entries of '",deparse(substitute(listToCast)),"' must be integer")
stop("Entries of '",deparse(substitute(listToCast)),"' must be integer")
}
})
return (as.integer(round(listToCast)))
}
#' Helper function to verify if variable is numeric.
#'
#' If not numeric, print error message and stop.
#'
#' @param listToCast List to cast as integer
#' @return list with members cast to integers
verifyNumeric <- function(variableToCheck) {
if (!is.numeric(variableToCheck)) {
log_error("Variable '",deparse(substitute(variableToCheck)),"' must be numeric.")
stop("Variable '",deparse(substitute(variableToCheck)),"' must be numeric.")
} else {
return (TRUE)
}
}
#' Creates new treeCuts object
#'
#' This function was designed to facilitate setting rowGapLocations and colGapLocations in the
#' [chmNew()] function. See examples section.
#'
#' @param numberOfCuts Number of tree cuts
#' @return [treeCuts-class] object with specified number of tree cuts
#' @export
#'
#' @examples
#' mychm <- chmNew("test_chm", rowGapLocations=chmTreeGaps(5))
chmTreeGaps <- function(numberOfCuts) {
return (new (Class="treeCuts", numberOfCuts=as.integer(numberOfCuts)))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.