# ##############################################################################################
#
# Methods for class NGCHM.SERVER
#
chmServerCheck <- function(name) {
server <- chmServer(name)
if (length(server) == 0) {
stop(sprintf("Unknown CHM server '%s'", name))
}
server
}
#' @rdname chmDeployServer-method
#' @aliases chmDeployServer,ngchmServer-method
#'
setMethod("chmDeployServer",
signature = c(server = "ngchmServer"),
definition = function(server) server@deployServer
)
#' @rdname chmUrlBase-method
#' @aliases chmUrlBase,ngchmServer-method
#'
setMethod("chmUrlBase",
signature = c(server = "ngchmServer"),
definition = function(server) sprintf("%s/chm.html", server@serverURL)
)
#' @rdname chmInstall-method
#' @aliases chmInstall,ngchm-method
setMethod("chmInstall",
signature = c(chm = "ngchm"),
definition = function(chm, path, ...) {
if (missing(path)) {
dest <- list(server = chmCurrentServer(), collection = chmCurrentCollection())
} else {
dest <- parsePathSpec(path)
}
if (typeof(dest$server) == "character") dest$server <- chmServerCheck(dest$server)
stopifnot(length(dest$server) > 0)
maker <- get(sprintf("ngchmMakeFormat.%s", dest$server@serverProtocol@chmFormat))
installer <- dest$server@serverProtocol@installMethod
args <- list(...)
make.args <- list()
install.args <- list()
if ("server" %in% names(formals(maker))) {
make.args <- list(server = dest$server)
}
if ("collection" %in% names(formals(installer))) {
install.args <- list(collection = dest$collection)
}
if (length(args) > 0) {
stopifnot(!is.null(names(args)))
for (ii in 1:length(args)) {
if (names(args)[ii] %in% names(formals(maker))) {
make.args <- c(make.args, args[[ii]])
} else if (names(args)[ii] %in% names(formals(installer))) {
install.args <- c(install.args, args[[ii]])
} else {
stop("unknown parameter ", names(args)[ii])
}
}
}
chm <- chmAddProperty(chm, "chm.info.build.time", format(Sys.time(), "%F %H:%M:%S"))
chm <- chmMake(chm)
chm@format <- dest$server@serverProtocol@chmFormat
chm <- do.call(maker, c(chm, make.args))
do.call(installer, c(dest$server, chm, install.args))
chm
}
)
#' @rdname chmUninstall-method
#' @aliases chmUninstall,character-method
setMethod("chmUninstall",
signature = c(chm = "character"),
definition = function(chm, server = NULL, ...) {
if (length(server) == 0) server <- chmCurrentServer()
stopifnot(length(server) > 0)
if (typeof(server) == "character") server <- chmServerCheck(server)
server@serverProtocol@uninstallMethod(server, chm, ...)
}
)
#' @rdname chmUninstall-method
#' @aliases chmUninstall,ngchm-method
setMethod("chmUninstall",
signature = c(chm = "ngchm"),
definition = function(chm, ...) {
chmUninstall(chmName(chm), ...)
}
)
#' @rdname chmMakePrivate-method
#' @aliases chmMakePrivate,ngchmServer,character-method
setMethod("chmMakePrivate",
signature = c(server = "ngchmServer", chm = "character"),
definition = function(server, chm) {
server@serverProtocol@makePrivate(server, chm)
}
)
#' @rdname chmMakePrivate-method
#' @aliases chmMakePrivate,ngchmServer,ngchm-method
setMethod("chmMakePrivate",
signature = c(server = "ngchmServer", chm = "ngchm"),
definition = function(server, chm) {
chmMakePrivate(server, chmName(chm))
}
)
#' @rdname chmMakePrivate-method
#' @aliases chmMakePrivate,character,ngchm-method
setMethod("chmMakePrivate",
signature = c(server = "character", chm = "ngchm"),
definition = function(server, chm) {
chmMakePrivate(chmServerCheck(server), chmName(chm))
}
)
#' @rdname chmMakePrivate-method
#' @aliases chmMakePrivate,character,character-method
setMethod("chmMakePrivate",
signature = c(server = "character", chm = "character"),
definition = function(server, chm) {
chmMakePrivate(chmServerCheck(server), chm)
}
)
#' @rdname chmMakePublic-method
#' @aliases chmMakePublic,ngchmServer,character-method
setMethod("chmMakePublic",
signature = c(server = "ngchmServer", chm = "character"),
definition = function(server, chm) {
server@serverProtocol@makePublic(server, chm)
}
)
#' @rdname chmMakePublic-method
#' @aliases chmMakePublic,ngchmServer,ngchm-method
setMethod("chmMakePublic",
signature = c(server = "ngchmServer", chm = "ngchm"),
definition = function(server, chm) {
chmMakePublic(server, chmName(chm))
}
)
#' @rdname chmMakePublic-method
#' @aliases chmMakePublic,character,ngchm-method
setMethod("chmMakePublic",
signature = c(server = "character", chm = "ngchm"),
definition = function(server, chm) {
chmMakePublic(chmServerCheck(server), chmName(chm))
}
)
#' @rdname chmMakePublic-method
#' @aliases chmMakePublic,character,character-method
setMethod("chmMakePublic",
signature = c(server = "character", chm = "character"),
definition = function(server, chm) {
chmMakePublic(chmServerCheck(server), chm)
}
)
#' @rdname chmSetCredentials-method
#' @aliases chmSetCredentials,ngchmServer,character-method
setMethod("chmSetCredentials",
signature = c(resource = "ngchmServer", credentials = "character"),
definition = function(resource, credentials) {
resource@serverProtocol@setCredentials(resource, credentials)
}
)
#' @rdname chmSetCredentials-method
#' @aliases chmSetCredentials,character,character-method
setMethod("chmSetCredentials",
signature = c(resource = "character", credentials = "character"),
definition = function(resource, credentials) {
resource <- chmServer(resource)
resource@serverProtocol@setCredentials(resource, credentials)
}
)
#' @rdname chmLoadCHM-method
#' @aliases chmLoadCHM,ngchmServer,character-method
setMethod("chmLoadCHM",
signature = c(serverOrURL = "ngchmServer", name = "character"),
definition = function(serverOrURL, name) {
loadChmFromURL(chmGetURL(name, server = serverOrURL))
}
)
#' @rdname chmLoadCHM-method
#' @aliases chmLoadCHM,character,character-method
setMethod("chmLoadCHM",
signature = c(serverOrURL = "character", name = "character"),
definition = function(serverOrURL, name) {
if (serverOrURL %in% chmListServers()) {
loadChmFromURL(chmGetURL(name, server = serverOrURL))
} else {
stop(sprintf("Unknown server '%s'", serverOrURL))
}
}
)
#' @rdname chmLoadCHM-method
#' @aliases chmLoadCHM,character,missing-method
setMethod("chmLoadCHM",
signature = c(serverOrURL = "character", name = "missing"),
definition = function(serverOrURL, name) {
loadChmFromURL(serverOrURL)
}
)
# ##############################################################################################
#
# Methods for class NGCHM
#
loadChmFromURL <- function(chmurl) {
params <- strsplit(chmurl, "?", fixed = TRUE)[[1]]
if (substring(params[1], nchar(params[1]) - 8) != "/chm.html") {
stop(sprintf("url '%s' does not look like an NG-CHM url", chmurl))
} else {
baseurl <- substr(params[1], 1, nchar(params[1]) - 8)
}
params <- strsplit(params[2:length(params)], "=")
idx <- which(vapply(params, function(x) x[1] == "name", TRUE))
if (length(idx) != 1) {
stop(sprintf("url '%s' does not look like an NG-CHM url", chmurl))
}
chmname <- params[[idx]][2]
ee <- new.env()
load(url(paste(baseurl, "data/", chmname, "/undefined/chm.Rdata", sep = "")), ee)
chm <- chmFixVersion(ee$chm)
chm@inpDir <- utempfile("ngchm.input")
chm@outDir <- utempfile("ngchm.output")
chm@saveDir <- tempdir()
try(ngchmPushSourceRepository(paste(baseurl, "data/", chmname, "/undefined/shaidyRepo.tar", sep = ""), "http"), TRUE)
chm
}
writeColorMap <- function(context, cmap, prefix, suffix, chan) {
stopifnot(length(cmap@missing) > 0)
colorstr <- c("[")
thresstr <- c("[")
if (is.list(cmap@points)) {
for (ii in 1:length(cmap@points)) {
if (ii > 1) {
colorstr <- append(colorstr, ";")
thresstr <- append(thresstr, ";")
}
colorstr <- append(colorstr, cmap@points[[ii]]@color)
thresstr <- append(thresstr, cmap@points[[ii]]@value)
}
}
colorstr <- append(colorstr, "]")
thresstr <- append(thresstr, "]")
cat(sprintf("%s.color.type%s=%s\n", prefix, suffix, cmap@type), file = chan)
cat(sprintf("%s.missing.color%s=%s\n", prefix, suffix, cmap@missing), file = chan)
cat(sprintf("%s.colors%s=%s\n", prefix, suffix, paste(colorstr, collapse = "")), file = chan)
if (context == "class") {
cat(sprintf("%s.values%s=%s\n", prefix, suffix, paste(thresstr, collapse = "")), file = chan)
} else {
cat(sprintf("%s.thresholds%s=%s\n", prefix, suffix, paste(thresstr, collapse = "")), file = chan)
}
}
jsonColorMap <- function(context, cmap) {
stopifnot(length(cmap@missing) > 0)
list(
type = cmap@type,
missing = cmap@missing,
colors = vapply(cmap@points, function(p) p@color, ""),
values = vapply(cmap@points, function(p) as.character(p@value), "")
)
}
writeMenu <- function(menu, prefix, chan) {
if (is.list(menu)) {
for (ii in 1:length(menu)) {
cat(sprintf(" chm.%s.addMenuItem ('%s', %s)\n", prefix, menu[[ii]]@label, menu[[ii]]@fun), file = chan)
}
}
}
writeCSS <- function(css, inpDir) {
chan <- file(file.path(inpDir, "custom.css"), "wb")
for (ii in 1:length(css)) {
cat(css[[ii]]@css, sep = "\n", file = chan)
}
close(chan)
}
hasSpecialProperties <- function(chm) {
any(vapply(chm@properties, function(p) substr(p@label, 1, 1) == "!", TRUE))
}
writeProperties <- function(inpDir, format, props, chan, writeSpecial = FALSE) {
if (writeSpecial) {
for (ii in 1:length(props)) {
l <- props[[ii]]@label
if (substr(l, 1, 1) == "!") {
cat(sprintf("%s=%s", substring(l, 2), props[[ii]]@value), sep = "\n", file = chan)
}
}
} else {
for (ii in 1:length(props)) {
l <- props[[ii]]@label
if (substr(l, 1, 1) != "!") {
if (l != "hidden" && l != "hidden.tags") {
cat(sprintf("%s=%s", l, props[[ii]]@value), sep = "\n", file = chan)
}
}
}
}
}
writePropertiesPost <- function(outDir, format, props) {
hidden.tags <- NULL
for (ii in 1:length(props)) {
if (props[[ii]]@label == "hidden.tags") {
hidden.tags <- sprintf("%s\n", props[[ii]]@value)
}
}
for (ii in 1:length(props)) {
if ((props[[ii]]@label == "hidden") && (props[[ii]]@value == "TRUE")) {
if (format == "original") {
cat(hidden.tags, sep = "", file = file.path(outDir, "hidden.txt"))
} else {
hidden.tags <- sub("\n", "", hidden.tags)
writeBinLines(jsonlite::toJSON(hidden.tags, pretty = TRUE), file.path(outDir, "hidden.json"))
}
}
}
}
writeChmPost <- function(chm, outdir = NULL) {
if (length(outdir) == 0) outdir <- file.path(chm@outDir, chm@name)
if (is.list(chm@properties)) writePropertiesPost(outdir, chm@format, chm@properties)
if (chm@format == "original") {
shaids <- shaidyGetComponents(chm)
chmRepo <- file.path(outdir, "shaidyRepo")
ngchmInitShaidyRepository(chmRepo)
repo <- shaidyLoadRepository("file", chmRepo)
lapply(shaids, function(shaid) {
src <- ngchmFindRepo(shaid)
shaidyCopyBlob(src, shaid, repo)
})
systemCheck(sprintf("tar cf %s.tar -C %s .", chmRepo, chmRepo))
unlink(chmRepo, recursive = TRUE)
}
}
startcust <- paste("(function(chm){",
"function _chm_ad(id,tit,fn){var td=fn($('<div></div>').attr('title',tit).attr('id',id));",
" $('body').append(td); $('#'+id).dialog({position:[0,200],autoOpen:false});",
" chm.menubar.addDialogsMenuItem(id,tit,function(tlmc,mi){td.dialog();});",
"}",
"function _chm_as(src){var s=document.createElement('script');",
" s.setAttribute('type','text/javascript'); s.setAttribute('src',src);",
" $('head').append(s);",
"}",
"function _chm_e(sr,ax,fn){function c2(a,b){return a.concat(b);};",
" return sr.map(function(r){var v=[];for(var ii=r.start;ii<=r.end;ii++)v.push(ii);",
" return v.map(function(i){return fn(ax,i);}).reduce(c2);}).reduce(c2);",
"}",
"",
sep = "\n"
)
# Returns list of all functions in requires and jsfuns. Required functions come
# before the function(s) needing them.
requiredFunctions <- function(requires, jsfuns) {
if (length(jsfuns) > 0) {
for (ff in 1:length(jsfuns)) {
fn <- jsfuns[[ff]]
if (all(vapply(requires, function(rqfn) rqfn@name != fn@name, TRUE))) {
# This fn is not already included
# First include any of this functions requires.
rqs <- lapply(fn@requires, function(rq) chmGetFunction(rq))
requires <- append(requiredFunctions(requires, rqs), fn)
}
}
}
requires
}
writeDialogs <- function(dialogs, chan) {
for (dialog in dialogs) {
cat(sprintf(" _chm_ad('%s', '%s', %s);\n", dialog@id, dialog@title, dialog@fn@name), file = chan)
}
}
writeCustomJS <- function(chm, filename) {
rqJSfuns <- requiredFunctions(list(), chm@javascript)
chan <- file(filename, "wb")
if (length(rqJSfuns) > 0) writeJS(rqJSfuns, chan, TRUE)
cat(startcust, file = chan)
if (length(rqJSfuns) > 0) writeJS(rqJSfuns, chan, FALSE)
# cat ("chm.addCustomization(function(){\n", file=chan);
writeMenu(chm@rowMenu, "row.labels", chan)
writeMenu(chm@rowMenu, "row.dendrogram", chan)
writeMenu(chm@colMenu, "column.labels", chan)
writeMenu(chm@colMenu, "column.dendrogram", chan)
writeMenu(chm@elementMenu, "matrix", chan)
writeDialogs(chm@dialogs, chan)
# cat ("});\n", file=chan);
cat("})(MDACC_GLOBAL_NAMESPACE.namespace('tcga').chm);\n", file = chan)
close(chan)
}
writeJS <- function(js, chan, writeGlobals) {
for (ii in 1:length(js)) {
if (js[[ii]]@global == writeGlobals) {
cat(sprintf("%s\n", js[[ii]]@script), file = chan)
}
}
}
sameColormap <- function(cmap1, cmap2) {
if (!is(cmap1, "ngchmColormap") || !is(cmap2, "ngchmColormap")) {
stop("Internal error detected: cmap1 or cmap2 is not a colormap. Please report.")
}
if (cmap1@type != cmap2@type) {
return(FALSE)
}
if (length(cmap1@missing) != length(cmap2@missing)) {
return(FALSE)
}
if ((length(cmap1@missing) > 0) && (cmap1@missing != cmap2@missing)) {
return(FALSE)
}
if (length(cmap1@points) != length(cmap2@points)) {
return(FALSE)
}
if (length(cmap1@points) > 0) {
for (ii in 1:length(cmap1@points)) {
if ((cmap1@points[[ii]]@value != cmap2@points[[ii]]@value) ||
(cmap1@points[[ii]]@color != cmap2@points[[ii]]@color)) {
return(FALSE)
}
}
}
return(TRUE)
}
# create list representation of layer for output by toJSON
#
prepDataLayer <- function(chm, layer) {
cmid <- which(vapply(chm@colormaps, function(cmap) sameColormap(cmap, layer@colors), TRUE))
if (length(cmid) == 0) {
stop(sprintf("Internal error detected: no color map found for data layer %s. Please report.", layer@name))
}
l <- list(name = layer@name, renderer = cmid[[1]] - 1, data = layer@data, summary_method = layer@summarizationMethod, cuts_color = layer@cuts_color)
singleElements <- c("name", "renderer", "summary_method", "cuts_color")
for (elem in singleElements) {
class(l[[elem]]) <- "singleElement"
}
l
}
writeDataLayer <- function(chm, layer, dir, index, chan) {
prefix <- sprintf("data%d", index)
cat(sprintf("%s.file.name=%s.data.tsv\n", prefix, prefix), file = chan)
cat(sprintf("%s.label.name=%s\n", prefix, layer@name), file = chan)
cmid <- 0
if (length(chm@colormaps) > 0) {
for (ii in 1:length(chm@colormaps)) {
if (sameColormap(chm@colormaps[[ii]], layer@colors)) {
cmid <- ii
break
}
}
}
if (cmid == 0) {
stop(sprintf("Internal error detected: no color map found for data layer %d (%s). Please report.", index, layer@name))
}
cat(sprintf("%s.defaultCM=cm%d\n", prefix, cmid), file = chan)
repo <- ngchmFindRepo(layer@data)
layerData <- ngchmLoadDatasetBlob(repo, layer@data)$mat
write.table(layerData,
file = paste(dir, sprintf("%s.data.tsv", prefix), sep = "/"),
sep = "\t", quote = FALSE, eol = "\n"
)
}
writeCovariateBar <- function(cbar, inpDir, type, index, chan) {
cat(sprintf("classification.type%d=%s\n", index, cbar@type), file = chan)
cat(sprintf("classification.label%d=%s\n", index, cbar@label), file = chan)
cat(sprintf("classification.display%d=%s\n", index, cbar@display), file = chan)
cat(sprintf("classification.thickness%d=%d\n", index, cbar@thickness), file = chan)
if (length(cbar@merge) > 0) {
cat(sprintf("classification.mergingAlgorithm%d=%s\n", index, cbar@merge), file = chan)
}
if (length(cbar@colors) > 0) {
if (length(cbar@colors@missing) == 0) {
cbar@colors@missing <- "white"
}
writeColorMap("class", cbar@colors, "classification", sprintf("%d", index), chan)
}
chan2 <- file(paste(inpDir, sprintf("%sClassificationData%d.txt", type, index), sep = "/"), "wb")
repo <- ngchmFindRepo(cbar@data)
barData <- ngchmLoadDatasetBlob(repo, cbar@data, "")$mat
nm <- rownames(barData)
for (ii in 1:nrow(barData)) {
cat(nm[ii], "\t", barData[ii, 1], "\n", sep = "", file = chan2)
}
close(chan2)
}
addDefaultCovariate <- function(covariates, labels) {
if (!("None" %in% vapply(covariates, function(cov) cov@label, ""))) {
series <- rep("default", length(labels))
names(series) <- labels
cmap <- chmNewColorMap("default", colors = "black", names = "Point")
cov <- chmNewCovariate("Nothing", series, value.properties = cmap, type = "discrete", covabbv = "None")
covariates <- append(covariates, cov)
}
covariates
}
#' @import tsvio
writeDataset <- function(chm, dataset, dir) {
chm@extrafiles <- c(chm@extrafiles, sprintf("%s.tsv", dataset@name))
chm@extrafiles <- c(chm@extrafiles, sprintf("%s-index.tsv", dataset@name))
write.table(dataset@data, file.path(dir, sprintf("%s.tsv", dataset@name)), sep = "\t", quote = FALSE, eol = "\n")
tsvio::tsvGenIndex(
file.path(dir, sprintf("%s.tsv", dataset@name)),
file.path(dir, sprintf("%s-index.tsv", dataset@name))
)
row.covars <- addDefaultCovariate(dataset@row.covariates, rownames(dataset@data))
col.covars <- addDefaultCovariate(dataset@column.covariates, colnames(dataset@data))
if (TRUE) {
chm@extrafiles <- c(chm@extrafiles, sprintf("%s-covariates.tsv", dataset@name))
cov.table <- list(
Covariate = vapply(col.covars, function(cov) cov@label, ""),
Fullname = vapply(col.covars, function(cov) cov@fullname, "")
)
write.table(cov.table,
file.path(dir, sprintf("%s-covariates.tsv", dataset@name)),
sep = "\t", quote = FALSE, row.names = FALSE, eol = "\n"
)
}
if (TRUE) {
chm@extrafiles <- c(chm@extrafiles, sprintf("%s-rowcovariates.tsv", dataset@name))
cov.table <- list(
Covariate = vapply(row.covars, function(cov) cov@label, ""),
Fullname = vapply(row.covars, function(cov) cov@fullname, "")
)
write.table(cov.table,
file.path(dir, sprintf("%s-row-covariates.tsv", dataset@name)),
sep = "\t", quote = FALSE, row.names = FALSE, eol = "\n"
)
}
if (TRUE) {
first.rowser <- TRUE
first.serprop <- TRUE
for (cov in row.covars) {
repo <- ngchmFindRepo(cov@label.series)
label.series <- ngchmLoadDatasetBlob(repo, cov@label.series)$mat[, "Value"]
rowser <- list(Sample = names(label.series), Series = label.series, Covariate = rep(cov@label, length(label.series)))
if (first.rowser) {
first.rowser <- FALSE
chm@extrafiles <- c(chm@extrafiles, sprintf("%s-row-series.tsv", dataset@name))
fd.rowser <- file(file.path(dir, sprintf("%s-row-series.tsv", dataset@name)), "wb")
write.table(rowser, file = fd.rowser, sep = "\t", quote = FALSE, row.names = FALSE, col.names = TRUE, eol = "\n")
} else {
write.table(rowser, file = fd.rowser, sep = "\t", quote = FALSE, row.names = FALSE, col.names = FALSE, eol = "\n")
}
if (length(cov@series.properties) > 0) {
serprop <- getSeriesProps(cov@label, cov@series.properties)
if (first.serprop) {
first.serprop <- FALSE
chm@extrafiles <- c(chm@extrafiles, sprintf("%s-row-series-properties.tsv", dataset@name))
fd.serprop <- file(file.path(dir, sprintf("%s-row-series-properties.tsv", dataset@name)), "wb")
write.table(serprop, file = fd.serprop, sep = "\t", quote = FALSE, row.names = FALSE, col.names = TRUE, eol = "\n")
} else {
write.table(serprop, file = fd.serprop, sep = "\t", quote = FALSE, row.names = FALSE, col.names = FALSE, eol = "\n")
}
}
}
if (!first.rowser) close(fd.rowser)
if (!first.serprop) close(fd.serprop)
}
if (TRUE > 0) {
first.colser <- TRUE
first.serprop <- TRUE
for (cov in col.covars) {
repo <- ngchmFindRepo(cov@label.series)
label.series <- ngchmLoadDatasetBlob(repo, cov@label.series)$mat[, "Value"]
colser <- list(Sample = names(label.series), Series = label.series, Covariate = rep(cov@label, length(label.series)))
if (first.colser) {
first.colser <- FALSE
chm@extrafiles <- c(chm@extrafiles, sprintf("%s-sample-series.tsv", dataset@name))
fd.colser <- file(file.path(dir, sprintf("%s-sample-series.tsv", dataset@name)), "wb")
write.table(colser, file = fd.colser, sep = "\t", quote = FALSE, row.names = FALSE, col.names = TRUE, eol = "\n")
} else {
write.table(colser, file = fd.colser, sep = "\t", quote = FALSE, row.names = FALSE, col.names = FALSE, eol = "\n")
}
if (length(cov@series.properties) > 0) {
serprop <- getSeriesProps(cov@label, cov@series.properties)
if (first.serprop) {
first.serprop <- FALSE
chm@extrafiles <- c(chm@extrafiles, sprintf("%s-series-properties.tsv", dataset@name))
fd.serprop <- file(file.path(dir, sprintf("%s-series-properties.tsv", dataset@name)), "wb")
write.table(serprop, file = fd.serprop, sep = "\t", quote = FALSE, row.names = FALSE, col.names = TRUE, eol = "\n")
} else {
write.table(serprop, file = fd.serprop, sep = "\t", quote = FALSE, row.names = FALSE, col.names = FALSE, eol = "\n")
}
}
}
if (!first.colser) close(fd.colser)
if (!first.serprop) close(fd.serprop)
}
chm
}
hasSeries <- function(props, value) {
value %in% vapply(props, function(p) as.character(p@value), "")
}
addDefaultCovariateProperties <- function(props, missing.color, default.missing.color) {
if (!hasSeries(props, "unspecified")) {
if (length(missing.color) == 0) missing.color <- default.missing.color
props <- chmAddValueProperty(props, value = "unspecified", name = "Unspecified", color = missing.color, shape = "triangle-down", z = 1)
}
if (!hasSeries(props, "regression")) {
props <- chmAddValueProperty(props, value = "regression", name = "Regression", color = "red", shape = "line", z = 1000)
}
props
}
getSeriesProps <- function(label, props) {
if (is(props, "ngchmColormap")) {
pts <- addDefaultCovariateProperties(props@points, props@missing, "black")
list(
Covariate = vapply(pts, function(pt) label, ""),
Series = vapply(pts, function(pt) as.character(pt@value), ""),
Description = vapply(pts, function(pt) pt@name, ""),
Color = vapply(pts, function(pt) pt@color, ""),
Shape = vapply(pts, function(pt) pt@shape, ""),
zIndex = vapply(pts, function(pt) pt@z, 1)
)
} else {
append(list(Covariate = rep(label, length(props[[1]]))), props)
}
}
writeTemplate <- function(source.path, dest.path, substitutions, outDir) {
if ((is(source.path, "character")) && (length(substitutions) == 0)) {
if (!file.copy(source.path, file.path(outDir, dest.path))) {
stop(sprintf(
"Unable to copy template file '%s' to '%s'", source.path,
file.path(outDir, dest.path)
))
}
# systemCheck (sprintf ("/bin/cp %s %s",
# shQuote (source.path),
# shQuote (file.path (outDir, dest.path))));
} else {
if (is(source.path, "character")) {
data <- readLines(source.path)
} else {
data <- source.path()
}
for (ss in substitutions) {
data <- gsub(ss[1], ss[2], data)
}
writeBinLines(data, con = file.path(outDir, dest.path))
}
}
writeRelatedGroup <- function(group, links, chan) {
cat(sprintf(" { header: '%s',\n", group@header), file = chan)
if (length(group@blurb) > 0) {
cat(sprintf(" blurb: '%s',\n", group@blurb), file = chan)
}
cat(sprintf(" %s: [\n", group@linktype), file = chan)
for (ii in 1:length(links)) {
if (links[[ii]]@group == group@name) {
cat(' { link: "', links[[ii]]@link, '", description: "', links[[ii]]@description, '" },\n', sep = "", file = chan)
}
}
cat(" ]\n", file = chan)
cat(" },\n", file = chan)
}
writeRelated <- function(groups, links, outdir) {
chan <- file(file.path(outdir, "relatedlinks.js"), "wb")
cat("linkoutData = { groups: [\n", file = chan)
for (ii in 1:length(groups)) {
writeRelatedGroup(groups[[ii]], links, chan)
}
cat("]};\n", file = chan)
close(chan)
NULL
}
# Write extra support files to the specified directory
writeChmExtraSupport <- function(chm, chmSaveDir) {
if ((length(chm@relatedLinks) + length(chm@relatedGroups)) > 0) {
writeRelated(chm@relatedGroups, chm@relatedLinks, chmSaveDir)
}
if (chm@format == "original" && length(chm@datasets) > 0) {
chan <- file(file.path(chmSaveDir, "datasets.tsv"), "wb")
writeBinLines("Dataset\tDescription", con = chan)
for (ii in 1:length(chm@datasets)) {
ds <- chm@datasets[[ii]]
chm <- writeDataset(chm, ds, chmSaveDir)
writeBinLines(sprintf("%s\t%s", ds@name, ds@description), con = chan)
}
close(chan)
}
if (chm@format == "original" && length(chm@templates) > 0) {
for (t in chm@templates) {
writeTemplate(t@source.path, t@dest.path, t@substitutions, chmSaveDir)
}
}
chm
}
getTypeMatches <- function(tflist, type) {
# tflist$types is a list of character vectors.
# type is a list of character vectors.
# Returns the indices of the elements of tflist whose types match at least one type.
idx <- which(vapply(tflist$types, function(tt) any(tt == type), TRUE))
}
getValueExpr <- function(tflist, type, where) {
idx <- getTypeMatches(tflist, type)
if (length(idx) == 0) {
stop(sprintf("chmMake: internal error detected: unable to find value expression for type '%s'. Please report.", type))
}
b <- tflist$builders[[idx[1]]]
if (is(b, "ngchmAxisType")) {
if (where == "axis") {
return(sprintf("_chm_e(s,a,%s)", b@func@name))
} else if (where == "row") {
return(sprintf("_chm_e(rs,chm.row,%s)", b@func@name))
} else if (where == "column") {
return(sprintf("_chm_e(cs,chm.column,%s)", b@func@name))
} else {
stop(sprintf("chmMake: internal error detected: unknown getValueExpr location '%s'. Please report.", where))
}
} else if (is(b, "ngchmTypeMapper")) {
if (b@op == "expr") {
return(sprintf("%s.%s", getValueExpr(tflist, b@fromtype, where), b@params$expr))
} else if (b@op == "field") {
return(sprintf("%s.split(%s)[%s]", getValueExpr(tflist, b@fromtype, where), b@params$separator, b@params$num))
} else if (b@op == "javascript") {
return(sprintf("%s(%s)", b@func@name, getValueExpr(tflist, b@fromtype, where)))
} else {
stop("unknown ngchmTypeMapper op ", b@op)
}
} else {
stop(sprintf("chmMake: internal error detected: unknown value builder class '%s'. Please report.", class(b)))
}
}
getFnsRqrd <- function(tflist, type) {
idx <- getTypeMatches(tflist, type)
if (length(idx) == 0) {
stop(sprintf("chmMake: internal error detected: unable to find value expression for type '%s'. Please report.", type))
}
b <- tflist$builders[[idx[1]]]
if (is(b, "ngchmTypeMapper")) {
return(c(idx, getFnsRqrd(tflist, b@fromtype)))
} else {
return(idx)
}
}
writeChm <- function(chm, saveDir = NULL) {
if (length(chm@layers) == 0) {
stop("The NGCHM has no data layers. You must add at least one.")
}
if (length(chm@colormaps) == 0) {
stop("Internal error detected: the NGCHM has no color maps. Please report.")
}
# chm <- chmAddAutoMenuItems (chm);
genSpecFeedback(50, "creating specification directory")
if (length(saveDir) == 0) {
unlink(chm@inpDir, recursive = TRUE)
if (!dir.create(chm@inpDir, recursive = TRUE)) {
stop(sprintf("Unable to create directory '%s' in which to save CHM specification", chm@inpDir))
}
saveDir <- chm@inpDir
}
if (chm@format == "original") {
genSpecFeedback(55, "saving user's CHM")
orig.chm <- chm
chm@inpDir <- tempdir()
chm@outDir <- tempdir()
chm@saveDir <- tempdir()
save(chm, file = file.path(saveDir, "chm.Rdata"))
chm <- orig.chm
chm@extrafiles <- c(chm@extrafiles, "chm.Rdata")
}
if (chm@format == "original") {
genSpecFeedback(60, "writing specification")
props <- file(file.path(saveDir, chm@propFile), "wb")
cat(sprintf(
"# This NGCHM property description was produced using the R NGCHM library version %s at %s\n",
packageDescription("NGCHM")$Version, date()
), file = props)
cat(sprintf("data.set.name=%s\n", chm@name), file = props)
cat(sprintf("chm.main.image.height=%d\n", chm@height), file = props)
cat(sprintf("chm.main.image.width=%d\n", chm@width), file = props)
} else {
props <- list(name = chm@name)
}
if (length(chm@tags) > 0) {
if (chm@format == "original") {
cat(sprintf("tags=%s\n", paste(chm@tags, sep = ",", collapse = ",")), file = props)
} else {
props$tags <- chm@tags
}
}
if (chm@format == "original") {
genSpecFeedback(65, "writing color schemes")
for (ii in 1:length(chm@colormaps)) {
cmap <- chm@colormaps[[ii]]
if (length(cmap@missing) == 0) {
cmap@missing <- "white"
}
writeColorMap("main", cmap, sprintf("colormap%d", ii), "", props)
}
} else {
props$colormaps <- lapply(chm@colormaps, function(cmap) {
if (length(cmap@missing) == 0) {
cmap@missing <- "white"
}
jsonColorMap("main", cmap)
})
names(props$colormaps) <- sprintf("colormap%d", 1:length(chm@colormaps))
}
if (chm@format == "original") {
genSpecFeedback(70, "writing data layers")
for (ii in 1:length(chm@layers)) {
writeDataLayer(chm, chm@layers[[ii]], saveDir, ii, props)
}
}
if (is.list(chm@properties)) {
if (chm@format == "original") {
writeProperties(saveDir, chm@format, chm@properties, props)
}
if (chm@format == "original" && hasSpecialProperties(chm)) {
fname <- if (chm@format == "original") "extra.properties" else "extra-properties.json"
chm@extrafiles <- c(chm@extrafiles, fname)
extraprops <- file(file.path(saveDir, fname), "wb")
writeProperties(saveDir, chm@format, chm@properties, extraprops, TRUE)
close(extraprops)
}
}
if (chm@format == "original") {
if (is.list(chm@overviews)) {
for (ii in 1:length(chm@overviews)) {
ov <- chm@overviews[[ii]]
cat(sprintf("overview%d.format=%s\n", ii, ov@format), file = props)
if (!is.null(ov@width)) {
cat(sprintf("overview%d.width=%d\n", ii, ov@width), file = props)
}
if (!is.null(ov@height)) {
cat(sprintf("overview%d.height=%d\n", ii, ov@height), file = props)
}
}
}
}
genSpecFeedback(80, "writing extra support files")
chm <- writeChmExtraSupport(chm, saveDir)
chm@extrafiles <- c(chm@extrafiles, "custom-backup.js")
if (chm@format == "original") {
if (length(chm@extrafiles) > 0) {
cat(sprintf("additional.input=%s\n", paste(chm@extrafiles, sep = "", collapse = ",")), file = props)
}
close(props)
}
if (chm@format == "original") {
genSpecFeedback(90, "writing covariate bar data")
if (!is.null(chm@rowOrder)) {
writeOrder(saveDir, "row", chm@rowOrder)
}
if (!is.null(chm@colOrder)) {
writeOrder(saveDir, "column", chm@colOrder)
}
if (!is.null(chm@rowMeta)) {
writeMeta(saveDir, "row", chm@rowMeta)
}
if (!is.null(chm@colMeta)) {
writeMeta(saveDir, "column", chm@colMeta)
}
if (is.list(chm@rowCovariateBars)) {
chan <- file(paste(saveDir, "rowClassification1.txt", sep = "/"), "wb")
for (ii in 1:length(chm@rowCovariateBars)) {
writeCovariateBar(chm@rowCovariateBars[[ii]], saveDir, "row", ii, chan)
}
close(chan)
}
if (is.list(chm@colCovariateBars)) {
chan <- file(paste(saveDir, "columnClassification1.txt", sep = "/"), "wb")
for (ii in 1:length(chm@colCovariateBars)) {
writeCovariateBar(chm@colCovariateBars[[ii]], saveDir, "column", ii, chan)
}
close(chan)
}
}
if (chm@format == "original") {
genSpecFeedback(95, "writing custom CSS and Javascript")
if (is.list(chm@css)) writeCSS(chm@css, saveDir)
chmWriteCustomJS(chm, file.path(saveDir, "custom-backup.js"))
jsloader <- readLines(system.file("extdata", "custom.js", package = "NGCHM"))
jsfile <- file(file.path(saveDir, "custom.js"), "wb")
writeBinLines(jsloader, jsfile)
close(jsfile)
}
if (chm@format == "shaidy") {
writeBinLines(jsonlite::toJSON(chm), file.path(saveDir, "chm.json"))
}
}
#' @rdname chmName-method
#' @aliases chmName,ngchm-method
#'
setMethod("chmName",
signature = c(chm = "ngchm"),
definition = function(chm) chm@name
)
writeOrder <- function(inpDir, type, ord) {
# Write the order/dendrogram out as a column dendrogram to the inpDir
if (is(ord, "shaid")) {
repo <- ngchmFindRepo(ord)
if (ord@type == "dendrogram") {
blobfile <- repo$blob.path(ord, "dendrogram-data.tsv")
filename <- file.path(inpDir, sprintf("dendrogram-data_%s.tsv", type))
stopifnot(file.copy(blobfile, filename))
blobfile <- repo$blob.path(ord, "dendrogram-order.tsv")
filename <- file.path(inpDir, sprintf("dendrogram-order_%s.tsv", type))
stopifnot(file.copy(blobfile, filename))
# For legacy
blobfile <- repo$blob.path(ord, "dendrogram.str")
filename <- file.path(inpDir, sprintf("dendro_%s.str", type))
stopifnot(file.copy(blobfile, filename))
} else if (ord@type == "label") {
blobfile <- repo$blob.path(ord, "labels.txt")
filename <- file.path(inpDir, sprintf("%s.txt", type))
stopifnot(file.copy(blobfile, filename))
} else {
stop("Unexpected shaid type: ", ord@type)
}
} else if (is(ord, "character")) {
filename <- file.path(inpDir, sprintf("%s.txt", type))
write.table(ord, filename, quote = FALSE, row.names = FALSE, col.names = FALSE, eol = "\n")
} else if (is(ord, "dendrogram") || is(ord, "hclust")) {
sink(file.path(inpDir, sprintf("dendro_%s.str", type)))
if (is(ord, "hclust")) {
ord <- stats::as.dendrogram(ord)
}
nr.str.dendrogram(ord)
sink(NULL)
} else if (is(ord, "fileContent")) {
filename <- (paste(inpDir, sprintf("dendro_%s.str", type), sep = "/"))
ff <- file(filename, "wb")
writeBinLines(ord, ff)
close(ff)
} else if (is(ord, "file")) {
stop("Internal error detected: axis order type file should not be here. Please report.")
filename <- (paste(inpDir, sprintf("dendro_%s.str", type), sep = "/"))
content <- readLines(ord)
ff <- file(filename, "wb")
writeBinLines(content, ff)
close(ff)
} else if (is(ord, "NULL")) {
# Do nothing.
} else {
stop(sprintf("chmWriteOrder: unknown class of %s order: '%s'", type, class(ord)))
}
}
writeMeta <- function(inpDir, type, metadata) {
# Write the metadata out to the inpDir
data <- lapply(metadata, function(shaid) {
stopifnot(is(shaid, "shaid"))
repo <- ngchmFindRepo(shaid)
meta <- ngchmLoadDatasetBlob(repo, shaid)$mat
meta[, "Value"]
})
labels <- sort(unique(do.call(c, lapply(data, function(x) names(x)))))
proto <- rep(NA, length(labels))
names(proto) <- labels
data <- do.call(rbind, lapply(data, function(cv) {
p <- proto
p[names(cv)] <- cv
p
}))
filename <- sprintf("%s/%s_meta.txt", inpDir, type)
write.table(data, filename, quote = FALSE, row.names = FALSE, col.names = TRUE, sep = "\t", eol = "\n")
}
prepChmOrderings <- function(chm, l) {
# Fix row order
if (length(chm@rowOrder) == 0) {
l$rowOrder <- ngchmGetLabels(chm@layers[[1]]@data, "row")
} else if (!is(chm@rowOrder, "shaid")) {
stop(sprintf("For chm %s unknown class for row order: %s", chm@name, class(chm@rowOrder)))
} else if (chm@rowOrder@type == "label") {
# Nothing to do.
} else if (chm@rowOrder@type == "dendrogram") {
l$rowDendrogram <- l$rowOrder
l$rowOrder <- ngchmGetLabels(chm@rowOrder)[[1]]
} else {
stop(sprintf("For chm %s unknown shaid type for row order: %s", chm@name, chm@rowOrder@type))
}
# Repeat for col order
if (length(chm@colOrder) == 0) {
l$colOrder <- ngchmGetLabels(chm@layers[[1]]@data, "column")
} else if (!is(chm@colOrder, "shaid")) {
stop(sprintf("For chm %s unknown class for column order: %s", chm@name, class(chm@colOrder)))
} else if (chm@colOrder@type == "label") {
# Nothing to do.
} else if (chm@colOrder@type == "dendrogram") {
l$colDendrogram <- l$colOrder
l$colOrder <- ngchmGetLabels(chm@colOrder)[[1]]
} else {
stop(sprintf("For chm %s unknown shaid type for column order: %s", chm@name, chm@colOrder@type))
}
l
}
#' @rdname chmGetURL-method
#' @param server The server on which to view the NGCHM
#' @param ... Ignored.
#' @aliases chmGetURL,character-method
setMethod("chmGetURL",
signature = c(chm = "character"),
definition = function(chm, server = NULL, ...) {
if (length(server) == 0) server <- chmCurrentServer()
stopifnot(length(server) > 0)
if (typeof(server) == "character") server <- chmServerCheck(server)
sprintf(
"%s/chm.html?name=%s",
if (length(server@viewServer) > 0) server@viewServer else server@serverURL,
chm
)
}
)
#' @rdname chmGetURL-method
#' @param server The server on which to view the NGCHM
#' @aliases chmGetURL,ngchm-method
setMethod("chmGetURL",
signature = c(chm = "ngchm"),
definition = function(chm, server = NULL, ...) {
if (length(server) == 0) server <- chmCurrentServer()
stopifnot(length(server) > 0)
if (typeof(server) == "character") server <- chmServerCheck(server)
if (server@serverProtocol@chmFormat == "shaidy") {
sprintf(
"%s/chm.html?map=%s",
if (length(server@viewServer) > 0) server@viewServer else server@serverURL,
shaidyGetShaid(chm)@value
)
} else {
chmGetURL(chmName(chm), server = server, ...)
}
}
)
URLparts <- function(x) {
m <- regexec("^(([^:]+)://)?([^:/]+)(:([0-9]+))?(/.*)", x)
parts <- do.call(
rbind,
lapply(regmatches(x, m), `[`, c(3L, 4L, 6L, 7L))
)
colnames(parts) <- c("protocol", "host", "port", "path")
parts
}
datestamp <- function() {
format(Sys.time(), "%a %b %d %X %Y")
}
progressFeedback <- function(progress, mode, what) {
message(sprintf("%s\t%s\t:%s:\t%g\t%s", datestamp(), "PROGRESS", mode, progress, what))
}
genSpecFeedback <- function(progress, what) {
progressFeedback(progress, "Writing specification", what)
}
postBuildFeedback <- function(progress, what) {
progressFeedback(progress, "Post build", what)
}
addToolBoxes <- function(chm) {
type.matches <- function(dstype, chmtype) {
length(intersect(dstype, chmtype)) > 0
}
type.matches2 <- function(dstype, chmtype1, chmtype2) {
length(intersect(intersect(dstype, chmtype1), chmtype2)) > 0
}
t2s <- function(ty) {
paste(ty, collapse = "/")
}
rowtypes <- getAllAxisTypes(chm, "row")
matches <- vapply(chm@datasets, function(ds) type.matches(ds@row.type, rowtypes$types), TRUE)
message(sprintf("addToolBoxes: found %d R datasets matching row types:", sum(matches)))
if (sum(matches) > 0) {
if (sum(matches) == 1) {
extra <- ""
} else {
extra <- sprintf(" (%s)", vapply(chm@datasets[matches], function(ds) ds@name, ""))
}
for (ds in chm@datasets[matches]) {
message(sprintf("dataset '%s' row.type '%s'", ds@name, t2s(ds@row.type)))
chm <- chmAddToolboxR(chm, "row", ds@row.type, ds@name, extra[1])
extra <- tail(extra, -1)
}
}
coltypes <- getAllAxisTypes(chm, "column")
matches <- vapply(chm@datasets, function(ds) type.matches(ds@row.type, coltypes$types), TRUE)
message(sprintf("addToolBoxes: found %d R datasets matching column types:", sum(matches)))
if (sum(matches) > 0) {
if (sum(matches) == 1) {
extra <- ""
} else {
extra <- sprintf(" (%s)", vapply(chm@datasets[matches], function(ds) ds@name, ""))
}
for (ds in chm@datasets[matches]) {
message(sprintf("dataset '%s' row.type '%s'", ds@name, t2s(ds@row.type)))
chm <- chmAddToolboxR(chm, "column", ds@row.type, ds@name, extra[1])
extra <- tail(extra, -1)
}
}
matches <- vapply(chm@datasets, function(ds) type.matches2(ds@row.type, coltypes$types, rowtypes$types), TRUE)
message(sprintf("addToolBoxes: found %d R2 datasets matching row and column types:", sum(matches)))
if (sum(matches) > 0) {
if (sum(matches) == 1) {
extra <- ""
} else {
extra <- sprintf(" (%s)", vapply(chm@datasets[matches], function(ds) ds@name, ""))
}
for (ds in chm@datasets[matches]) {
message(sprintf("dataset '%s' row.type '%s'", ds@name, t2s(ds@row.type)))
chm <- chmAddToolboxR2(chm, ds@row.type, ds@name, extra[1])
extra <- tail(extra, -1)
}
}
matches <- vapply(chm@datasets, function(ds) type.matches(ds@column.type, coltypes$types) && type.matches(ds@row.type, rowtypes$types), TRUE)
message(sprintf("addToolBoxes: found %d RC datasets matching row and column types:", sum(matches)))
if (sum(matches) > 0) {
if (sum(matches) == 1) {
extra <- ""
} else {
extra <- sprintf(" (%s)", vapply(chm@datasets[matches], function(ds) ds@name, ""))
}
for (ds in chm@datasets[matches]) {
message(sprintf("dataset '%s' row.type '%s' col.type '%s'", ds@name, t2s(ds@row.type), t2s(ds@column.type)))
chm <- chmAddToolboxRC(chm, ds@row.type, ds@column.type, ds@name, extra[1])
extra <- tail(extra, -1)
}
}
chm
}
#' @rdname chmMake-method
#' @aliases chmMake,ngchm-method
#'
setMethod("chmMake",
signature = c(chm = "ngchm"),
definition = function(chm, ...) {
chm <- chmFixVersion(chm)
# Compute row and column orders if required.
while ((length(chm@rowOrder) > 0) && (is(chm@rowOrder, "function"))) {
genSpecFeedback(0, "determining row order")
chm@rowOrder <- chm@rowOrder(chm)
}
if (length(chm@rowOrder) == 0) {
chm@rowOrder <- chmOriginalRowOrder(chm)
} else if (is(chm@rowOrder, "dendrogram")) {
chm@rowOrder <- chmUserDendrogramToShaid(chm@rowOrder)
} else if (is(chm@rowOrder, "hclust")) {
chm@rowOrder <- chmUserDendrogramToShaid(as.dendrogram(chm@rowOrder))
} else if (is(chm@rowOrder, "character")) {
chm@rowOrder <- chmUserLabelsToShaid(chm@rowOrder)
}
while ((length(chm@colOrder) > 0) && (is(chm@colOrder, "function"))) {
genSpecFeedback(10, "determining column order")
chm@colOrder <- chm@colOrder(chm)
}
if (length(chm@colOrder) == 0) {
chm@colOrder <- chmOriginalColOrder(chm)
} else if (is(chm@colOrder, "dendrogram")) {
chm@colOrder <- chmUserDendrogramToShaid(chm@colOrder)
} else if (is(chm@colOrder, "hclust")) {
chm@colOrder <- chmUserDendrogramToShaid(as.dendrogram(chm@colOrder))
} else if (is(chm@colOrder, "character")) {
chm@colOrder <- chmUserLabelsToShaid(chm@colOrder)
}
chm
}
)
#' Make an original format NGCHM.
#'
#' @param chm The original format CHM to compile.
#' @param server The server for which to compile the NGCHM.
#' Default `getOption("NGCHM.Server",chmListServers()[1])`.
#' Required iff useJar is not defined.
#' @param deleteOld If TRUE, delete any old CHM of this name before beginning build. (Default is TRUE.)
#' @param useJAR If defined, the location (filename) of the chmbuilder jar file. The package will not download
#' a current jar file from the server. It is the caller's responsibility to ensure the builder jar file
#' is compatible with the server on which the NGCHM will be installed. (Default is not defined.)
#' @param javaOptions Additional options to pass to the Java process.
#' Default is getOption('NGCHM.Java.Options','-Xmx2G').
#' @param javaTraceLevel Trace level option passed to the Java process.
#' Default is getOption("NGCHM.Java.Trace','PROGRESS').
#' @param buildArchive If TRUE, build a tar archive of the generated NGCHM.
#' Default is getOption('NGCHM.Build.Archive',TRUE).
#'
#' @return The CHM
ngchmMakeFormat.original <- function(chm,
server,
deleteOld = TRUE,
useJAR = NULL,
javaTraceLevel = NULL,
javaOptions = NULL,
buildArchive = NULL) {
if (length(javaTraceLevel) == 0) javaTraceLevel <- getOption("NGCHM.Java.Trace", "PROGRESS")
if (length(javaOptions) == 0) javaOptions <- getOption("NGCHM.Java.Options", "-Xmx2G")
if (length(server) == 0) server <- chmCurrentServer()
if (length(buildArchive) == 0) buildArchive <- getOption("NGCHM.Build.Archive", TRUE)
genSpecFeedback(20, "writing NGCHM specification")
writeChm(chm)
genSpecFeedback(96, "preparing output directory")
dir.create(chm@outDir, recursive = TRUE, showWarnings = FALSE)
if (deleteOld) {
unlink(file.path(chm@outDir, chm@name), recursive = TRUE)
}
if (length(useJAR) == 0) {
genSpecFeedback(97, "retrieving NGCHM rendering software")
useJAR <- getBuilderJar(server)
}
genSpecFeedback(100, "rendering NGCHM")
#
javaTraceOpts <- ""
if ((length(javaTraceLevel) > 0) && (is.null(server) || (length(server@traceLevel) > 0))) {
javaTraceOpts <- sprintf("-l %s -p", shQuote(javaTraceLevel))
}
systemCheck(sprintf(
"java -Djava.awt.headless=true %s -jar %s %s %s %s/%s %s",
paste(vapply(javaOptions, shQuote, ""), collapse = " "),
shQuote(useJAR),
javaTraceOpts,
shQuote(chm@inpDir),
shQuote(chm@inpDir),
shQuote(chm@propFile),
shQuote(chm@outDir)
))
message("chmMake: Java process completed")
postBuildFeedback(0, "writing post build files")
writeChmPost(chm)
if (buildArchive) {
postBuildFeedback(50, "creating compressed NGCHM file")
systemCheck(sprintf(
"tar czf %s/%s.ngchm.gz -C %s %s",
shQuote(chm@saveDir),
shQuote(chm@name),
shQuote(chm@outDir),
shQuote(chm@name)
))
}
postBuildFeedback(100, "post build completed")
chm
}
#' @rdname chmAdd-method
#' @aliases chmAdd,ngchm-method
#'
setMethod("chmAdd",
signature = c(chm = "ngchm"),
definition = function(chm, ...) {
chm <- chmFixVersion(chm)
chmAddList(chm, list(...))
}
)
chmOperatorAdd <- function(left, right) {
if (is(left, "ngchm")) {
chmAdd(left, right)
} else if (is(right, "ngchm")) {
chmAdd(right, left)
} else if (is(left, "ngchmAxis")) {
if (is(right, "ngchmAxis")) {
stopifnot(left@axis == right@axis)
left@objects <- append(left@objects, right@objects)
} else {
left@objects <- append(left@objects, right)
}
left
} else if (is(right, "ngchmAxis")) {
right@objects <- append(right@objects, left)
right
} else {
stop("unknown object class")
}
}
#' Add an Axis to an NG-CHM Version 2
#'
#' This function adds an 'ngchmAxis' to an 'ngchmVersion2' object.
#'
#' @name +
#' @docType methods
#' @rdname addition-methods
#' @aliases +,ngchmVersion2,ngchmAxis-method
#' @param e1 An object of class 'ngchmVersion2' to which the axis is to be added.
#' @param e2 An object of class 'ngchmAxis' representing the axis to be added.
#'
#' @return An updated 'ngchmVersion2' object with the added axis.
#'
#' @export
setMethod("+",
signature = c(e1 = "ngchmVersion2", e2 = "ngchmAxis"),
definition = function(e1, e2) chmOperatorAdd(e1, e2)
)
#' @method + ngchmVersion2
#' @export
"+.ngchmVersion2" <- chmOperatorAdd
#' @method + ngchmAxis
#' @export
"+.ngchmAxis" <- chmOperatorAdd
#' @method dimnames ngchmVersion2
#' @export
dimnames.ngchmVersion2 <- function(x) {
if (length(x@layers) == 0) {
NULL
} else {
dimnames(x@layers[[1]])
}
}
#' @method dim ngchmVersion2
#' @export
dim.ngchmVersion2 <- function(x) {
vapply(dimnames(x), length, 0)
}
#' @method dimnames ngchmLayer
#' @export
dimnames.ngchmLayer <- function(x) {
list(ngchmGetLabelsStr(x@data, "row"), ngchmGetLabelsStr(x@data, "column"))
}
#' @method dim ngchmLayer
#' @export
dim.ngchmLayer <- function(x) {
vapply(dimnames(x), length, 0)
}
#' @rdname chmAddLayer-method
#' @aliases chmAddLayer,ngchm,ngchmLayer-method
#'
setMethod("chmAddLayer",
signature = c(chm = "ngchm", layer = "ngchmLayer"),
definition = function(chm, layer) {
chm <- chmFixVersion(chm)
validateNewLayer(chm, layer)
chm@layers <- append(chm@layers, layer)
chmAddColormap(chm, layer@colors)
}
)
#' @rdname chmAddLayer-method
#' @aliases chmAddLayer,ngchm,matrix-method
#'
setMethod("chmAddLayer",
signature = c(chm = "ngchm", layer = "matrix"),
definition = function(chm, layer) {
chm <- chmFixVersion(chm)
layer <- chmNewDataLayer(sprintf("Layer %d", length(chm@layers) + 1), layer)
validateNewLayer(chm, layer)
chm@layers <- append(chm@layers, layer)
chmAddColormap(chm, layer@colors)
}
)
#' @rdname chmAddCSS-method
#' @aliases chmAddCSS,ngchm,character,character-method
setMethod("chmAddCSS",
signature = c(chm = "ngchm", css = "character"),
definition = function(chm, css) {
chm <- chmFixVersion(chm)
chm@css <- append(chm@css, new(Class = "ngchmCSS", css = css))
chmUU(chm)
}
)
#' @rdname chmAddTag-method
#' @aliases chmAddTag,ngchm,character,character-method
setMethod("chmAddTag",
signature = c(chm = "ngchm", tag = "character"),
definition = function(chm, tag) {
chm <- chmFixVersion(chm)
chm@tags <- c(chm@tags, tag)
chmUU(chm)
}
)
#' @rdname chmAddDataset-method
#' @aliases chmAddDataset,ngchm,ngchmDataset-method
setMethod("chmAddDataset",
signature = c(chm = "ngchm", dataset = "ngchmDataset"),
definition = function(chm, dataset) {
chm <- chmFixVersion(chm)
if (length(chm@datasets) == 0) {
chm@extrafiles <- c(chm@extrafiles, "datasets.tsv")
}
chm@datasets <- append(chm@datasets, dataset)
if (length(dataset@row.type) > 0) {
chm <- chmAddProperty(chm, sprintf("!datasettype:%s-row", make.names(dataset@name)), dataset@row.type)
}
if (length(dataset@column.type) > 0) {
chm <- chmAddProperty(chm, sprintf("!datasettype:%s-column", make.names(dataset@name)), dataset@column.type)
}
chmUU(chm)
}
)
#' @rdname chmAddDialog-method
#' @aliases chmAddDialog,ngchm,ngchmDialog-method
setMethod("chmAddDialog",
signature = c(chm = "ngchm", dialog = "ngchmDialog"),
definition = function(chm, dialog) {
chm <- chmFixVersion(chm)
if (dialog@id %in% vapply(chm@dialogs, function(d) d@id, "")) {
stop(sprintf("A dialog with id '%s' already exists", dialog@id))
}
if (dialog@title %in% vapply(chm@dialogs, function(d) d@title, "")) {
stop(sprintf("A dialog with title '%s' already exists", dialog@title))
}
chm@dialogs <- append(chm@dialogs, dialog)
chmUU(addFunDefine(chm, dialog@fn))
}
)
#' @rdname chmAddCovariate-method
#' @aliases chmAddCovariate,ngchmDataset,character,ngchmCovariate-method
setMethod("chmAddCovariate",
signature = c(dataset = "ngchmDataset", where = "character", covariate = "ngchmCovariate"),
definition = function(dataset, where, covariate) {
if (!(where %in% c("row", "column", "both"))) {
stop(sprintf("chmAddCovariate: unknown where '%s'. Should be row, column, or both.", where))
}
if (where %in% c("row", "both")) {
dataset@row.covariates <- append(dataset@row.covariates, covariate)
}
if (where %in% c("column", "both")) {
dataset@column.covariates <- append(dataset@column.covariates, covariate)
}
dataset
}
)
appendRendererIfNew <- function(colormaps, newmap) {
for (cm in colormaps) {
if (sameColormap(cm, newmap)) {
return(colormaps)
}
}
append(colormaps, newmap)
}
#' @rdname chmAddColormap-method
#' @aliases chmAddColormap,ngchm,ngchmColormap-method
setMethod("chmAddColormap",
signature = c(chm = "ngchm", colormap = "ngchmColormap"),
definition = function(chm, colormap) {
chm <- chmFixVersion(chm)
chm@colormaps <- appendRendererIfNew(chm@colormaps, colormap)
chmUU(chm)
}
)
#' @rdname chmAddRelatedGroup-method
#' @aliases chmAddRelatedGroup,ngchm,character,character,character,character-method
setMethod("chmAddRelatedGroup",
signature = c(chm = "ngchm", name = "character", header = "character", linktype = "character", blurb = "character"),
definition = function(chm, name, header, linktype, blurb) {
chm <- chmFixVersion(chm)
related <- new(Class = "ngchmRelatedGroup", name = name, header = header, linktype = linktype, blurb = blurb)
if ((length(chm@relatedGroups) + length(chm@relatedLinks)) == 0) {
chm@extrafiles <- c(chm@extrafiles, "relatedlinks.js")
}
chm@relatedGroups <- append(chm@relatedGroups, related)
chmUU(chm)
}
)
#' @rdname chmAddRelatedGroup-method
#' @aliases chmAddRelatedGroup,ngchm,character,character,character,missing-method
setMethod("chmAddRelatedGroup",
signature = c(chm = "ngchm", name = "character", header = "character", linktype = "character", blurb = "missing"),
definition = function(chm, name, header, linktype) {
chm <- chmFixVersion(chm)
related <- new(Class = "ngchmRelatedGroup", name = name, header = header, linktype = linktype, blurb = NULL)
if ((length(chm@relatedGroups) + length(chm@relatedLinks)) == 0) {
chm@extrafiles <- c(chm@extrafiles, "relatedlinks.js")
}
chm@relatedGroups <- append(chm@relatedGroups, related)
chmUU(chm)
}
)
#' @rdname chmAddRelated-method
#' @aliases chmAddRelated,ngchm,character,character,character-method
setMethod("chmAddRelated",
signature = c(chm = "ngchm", group = "character", link = "character", description = "character"),
definition = function(chm, group, link, description) {
chm <- chmFixVersion(chm)
related <- new(Class = "ngchmRelated", group = group, link = link, description = description)
if ((length(chm@relatedGroups) + length(chm@relatedLinks)) == 0) {
chm@extrafiles <- c(chm@extrafiles, "relatedlinks.js")
}
chm@relatedLinks <- append(chm@relatedLinks, related)
chmUU(chm)
}
)
#' @rdname chmAddOverview-method
#' @aliases chmAddOverview,ngchm,character,numeric,numeric-method
setMethod("chmAddOverview",
signature = c(chm = "ngchm", format = "character", width = "optNumeric", height = "optNumeric"),
definition = function(chm, format, width, height) {
chm <- chmFixVersion(chm)
known.formats <- c("pdf", "png", "svg")
if (length(format) != 1) {
stop(sprintf("chmAddOverview: format has length %d. Exactly one format string is required.", length(format)))
}
if (!(format %in% known.formats)) {
stop(sprintf(
"chmAddOverview: unknown overview format '%s'. Acceptable formats are %s", format,
paste(sprintf("'%s'", known.formats), collapse = ", ")
))
}
if (length(width) > 1) {
stop(sprintf("chmAddOverview: width has length %d. At most one width can be specified.", length(width)))
}
if (length(height) > 1) {
stop(sprintf("chmAddOverview: height has length %d. At most one height can be specified.", length(height)))
}
# if ((length(width) + length(height)) == 0)
# stop (sprintf ("chmAddOverview: at least width or height must be specified."));
if (!is.null(width)) {
width <- as.integer(width)
}
if (!is.null(height)) {
height <- as.integer(height)
}
ov <- new(Class = "ngchmOverview", format = format, width = width, height = height)
chm@overviews <- append(chm@overviews, ov)
chmUU(chm)
}
)
#' @rdname chmAddTemplate-method
#' @aliases chmAddTemplate,ngchm,charOrFunction,character,optList-method
#'
setMethod("chmAddTemplate",
signature = c(chm = "ngchm", source.path = "charOrFunction", dest.path = "character", substitutions = "optList"),
definition = function(chm, source.path, dest.path, substitutions) {
chm <- chmFixVersion(chm)
blob <- ngchmSaveTemplateAsBlob(ngchm.env$tmpShaidy, source.path, dest.path, substitutions)
template <- new(Class = "ngchmTemplate", source.path = source.path, dest.blob = blob, dest.path = dest.path, substitutions = substitutions)
chm@extrafiles <- c(chm@extrafiles, dest.path)
chm@templates <- append(chm@templates, template)
chmUU(chm)
}
)
#' @rdname chmAddProperty-method
#' @aliases chmAddProperty,ngchm,character,character-method
#'
setMethod("chmAddProperty",
signature = c(chm = "ngchm", label = "character", value = "character"),
definition = function(chm, label, value) {
chm <- chmFixVersion(chm)
chmProperty(chm, label) <- value
chmUU(chm)
}
)
#' @rdname chmAddSpecificAxisTypeFunction-method
#' @aliases chmAddSpecificAxisTypeFunction,ngchm,character,character,character,ngchmJS-method
#'
setMethod("chmAddSpecificAxisTypeFunction",
signature = c(chm = "ngchm", where = "character", type = "character", label = "character", func = "ngchmJS"),
definition = function(chm, where, type, label, func) {
chm <- chmFixVersion(chm)
af <- new("ngchmAxisFunction", type = type, label = label, func = func)
if ((length(where) != 1) || (!where %in% c("row", "column", "both"))) {
stop(sprintf("chmAddSpecificAxisTypeFunction: unknown where '%s'. Should be row, column, or both.", where))
}
if ((where == "row") || (where == "both")) {
matches <- which(vapply(chm@rowTypeFunctions, function(af) (af@label == label) && (af@type == type), TRUE))
if (length(matches) > 0) {
chm@rowTypeFunctions[[matches]] <- af
} else {
chm@rowTypeFunctions <- append(chm@rowTypeFunctions, af)
}
}
if ((where == "column") || (where == "both")) {
matches <- which(vapply(chm@colTypeFunctions, function(af) (af@label == label) && (af@type == type), TRUE))
if (length(matches) > 0) {
chm@colTypeFunctions[[matches]] <- af
} else {
chm@colTypeFunctions <- append(chm@colTypeFunctions, af)
}
}
chmUU(chm)
}
)
#' @rdname chmAddSpecificAxisTypeFunction-method
#' @aliases chmAddSpecificAxisTypeFunction,ngchm,character,character,character,character-method
#'
setMethod("chmAddSpecificAxisTypeFunction",
signature = c(chm = "ngchm", where = "character", type = "character", label = "character", func = "character"),
definition = function(chm, where, type, label, func) {
chmAddSpecificAxisTypeFunction(chm, where, type, label, chmGetFunction(func))
}
)
addFunDefine <- function(chm, func) {
dup <- 0
if (is.list(chm@javascript)) {
for (ii in 1:length(chm@javascript)) {
if (chm@javascript[[ii]]@name == func@name) {
dup <- ii
if (chm@javascript[[ii]]@script != func@script) {
stop(sprintf("Duplicate definition of function '%s' differs from first definition", func@name))
}
}
}
}
if (dup == 0) {
chm@javascript <- append(chm@javascript, func)
}
chm
}
#' @rdname chmAddMenuItem-method
#' @aliases chmAddMenuItem,ngchm,character,character,ngchmJS-method
#'
setMethod("chmAddMenuItem",
signature = c(chm = "ngchm", where = "character", label = "character", func = "ngchmJS"),
definition = function(chm, where, label, func) {
chm <- chmFixVersion(chm)
if (length(func@extraParams) > 0) {
stop(sprintf("Error adding menu item: function '%s' has unbound extra parameters", func@name))
}
entry <- new(Class = "ngchmMenuItem", label = label, description = func@description, fun = func@name)
if (where == "row" || where == "both") {
chm@rowMenu <- append(chm@rowMenu, entry)
if (where == "both") {
chm@colMenu <- append(chm@colMenu, entry)
}
} else if (where == "column") {
chm@colMenu <- append(chm@colMenu, entry)
} else if (where == "element") {
chm@elementMenu <- append(chm@elementMenu, entry)
} else if (where != "nowhere") {
stop(sprintf("chmAddMenuItem: unknown where '%s'. Should be row, column, both, or element (or nowhere).", where))
}
chmUU(addFunDefine(chm, func))
}
)
#' @rdname chmAddMenuItem-method
#' @aliases chmAddMenuItem,ngchm,character,character,character-method
#'
setMethod("chmAddMenuItem",
signature = c(chm = "ngchm", where = "character", label = "character", func = "character"),
definition = function(chm, where, label, func) {
chmAddMenuItem(chm, where, label, chmGetFunction(func))
}
)
#' @rdname chmAddAxisType-method
#' @aliases chmAddAxisType,ngchm,character,character,ngchmJS-method
#'
setMethod("chmAddAxisType",
signature = c(chm = "ngchm", where = "character", type = "character", func = "ngchmJS"),
definition = function(chm, where, type, func) {
chm <- chmFixVersion(chm)
if (length(type) > 1) type <- paste(type, collapse = ".bar.")
at <- new(Class = "ngchmAxisType", where = where, type = type, func = func)
chm@axisTypes <- append(chm@axisTypes, at)
chmAddProperty(chm, paste("!axistype", where, sep = "."), type)
}
)
#' @rdname chmAddAxisType-method
#' @aliases chmAddAxisType,ngchm,character,character,character-method
#'
setMethod("chmAddAxisType",
signature = c(chm = "ngchm", where = "character", type = "character", func = "character"),
definition = function(chm, where, type, func) {
chmAddAxisType(chm, where, type, chmGetFunction(func))
}
)
#' @rdname chmAddAxisType-method
#' @aliases chmAddAxisType,ngchm,character,character,missing-method
#'
setMethod("chmAddAxisType",
signature = c(chm = "ngchm", where = "character", type = "character", func = "missing"),
definition = function(chm, where, type, func) {
chmAddAxisType(chm, where, type, chmGetFunction("getLabelValue"))
}
)
#' @rdname chmAddCovariateBar-method
#' @aliases chmAddCovariateBar,ngchm,character,ngchmCovariateBar-method
#'
setMethod("chmAddCovariateBar",
signature = c(chm = "ngchm", where = "character", covar = "ngchmBar"),
definition = function(chm, where, covar) {
chm <- chmFixVersion(chm)
where <- match.arg(where, c("row", "column", "both"))
bar <- covar
validateNewCovariateBar(chm, where, bar)
if (where == "row" || where == "both") {
idx <- which(bar@label == lapply(chm@rowCovariateBars, function(cvb) cvb@label))
if (length(idx) == 0) {
chm@rowCovariateBars <- append(chm@rowCovariateBars, bar)
} else if (length(idx) == 1) {
chm@rowCovariateBars[[idx]] <- bar
} else {
stop("chm contains multiple copies of covariate bar")
}
}
if (where == "column" || where == "both") {
idx <- which(bar@label == lapply(chm@colCovariateBars, function(cvb) cvb@label))
if (length(idx) == 0) {
chm@colCovariateBars <- append(chm@colCovariateBars, bar)
} else if (length(idx) == 1) {
chm@colCovariateBars[[idx]] <- bar
} else {
stop("chm contains multiple copies of covariate bar")
}
}
chmUU(chm)
}
)
#' @rdname chmAddCovariateBar-method
#' @aliases chmAddCovariateBar,ngchm,character,ngchmCovariate-method
#'
setMethod("chmAddCovariateBar",
signature = c(chm = "ngchm", where = "character", covar = "ngchmCovariate"),
definition = function(chm, where, covar, ...) {
bar <- chmNewCovariateBar(covar, ...)
chmAddCovariateBar(chm, where, bar)
}
)
#' @rdname chmAddCovariateBar-method
#' @aliases chmAddCovariateBar,ngchm,character,list-method
#'
setMethod("chmAddCovariateBar",
signature = c(chm = "ngchm", where = "character", covar = "list"),
definition = function(chm, where, covar, ...) {
chm <- chmFixVersion(chm)
for (item in covar) {
if (is(item, "ngchmBar")) {
bar <- item
} else if (is(item, "ngchmCovariate")) {
bar <- chmNewCovariateBar(item, ...)
} else {
stop(sprintf('adding unknown object of unknown class "%s"', class(item)))
}
chm <- chmAddCovariateBar(chm, where, bar)
}
chm
}
)
#' @rdname chmBindFunction-method
#' @aliases chmBindFunction,character,ngchmJS,list-method
setMethod("chmBindFunction",
signature = c(name = "character", fn = "ngchmJS", bindings = "list"),
definition = function(name, fn, bindings) {
if (is.null(fn@extraParams) || (length(bindings) > length(fn@extraParams))) {
extra <- c()
if (!is.null(fn@extraParams)) extra <- fn@extraParams
stop(sprintf("chmBindFunction: %s more bindings (%d) than optional parameters (%d)", fn@name, length(bindings), length(extra)))
}
for (ii in 1:length(bindings)) {
if (names(bindings)[ii] != fn@extraParams[ii]) {
stop(sprintf("binding name '%s' does not match corresponding parameter '%s'", names(bindings)[ii], fn@extraParams[ii]))
}
}
newdesc <- sprintf("function %s bound to %d values", fn@name, length(bindings))
params <- vapply(bindings, function(x) {
if (length(x) != 1) stop("each parameter binding requires exact one value")
if (typeof(x) == "integer") {
sprintf("%d", x)
} else if (typeof(x) == "double") {
sprintf("%.10g", x)
} else if (typeof(x) == "logical") {
c("false", "true")[x + 1]
} else if (typeof(x) == "character") {
sprintf("'%s'", x)
} else {
stop("unknown type of parameter binding")
}
}, "")
params <- paste(params, collapse = ",")
if (length(bindings) == length(fn@extraParams)) {
newextra <- NULL
} else {
newextra <- fn@extraParams[(1 + length(bindings)):length(fn@extraParams)]
}
impl <- sprintf("var %s = %s.bind (undefined, %s);", name, fn@name, params)
chmNewFunction(name, newdesc, impl, extraParams = newextra, requires = c(fn@name), global = fn@global)
}
)
#' @rdname chmBindFunction-method
#' @aliases chmBindFunction,character,character,list-method
setMethod("chmBindFunction",
signature = c(name = "character", fn = "character", bindings = "list"),
definition = function(name, fn, bindings) {
fndef <- chmGetFunction(fn)
if (length(fndef) == 0) {
stop(sprintf("Unable to create binding '%s': function '%s' does not exist", name, fn))
}
chmBindFunction(name, fndef, bindings)
}
)
orderMethod <- function(v) {
if (length(v) == 0) {
return("Original")
}
if (is(v, "function")) {
if (identical(v, chmDefaultRowOrder) || identical(v, chmDefaultColOrder)) {
return("Hierarchical")
}
if (identical(v, chmRandomRowOrder) || identical(v, chmRandomColOrder)) {
return("Random")
}
if (identical(v, chmOriginalRowOrder) || identical(v, chmOriginalColOrder)) {
return("Original")
}
}
return("User")
}
#' @rdname chmRowOrder-method
#' @aliases chmRowOrder<-,ngchm,optDendrogram-method
setReplaceMethod("chmRowOrder",
signature = c(chm = "ngchm", value = "optDendrogram"),
definition = function(chm, value) {
chm <- chmFixVersion(chm)
if (is(value, "file")) {
value <- readLines(value)
class(value) <- "fileContent"
}
validateNewAxisOrder(chm, "row", value)
chm@rowOrder <- value
chm@rowOrderMethod <- orderMethod(value)
chmUU(chm)
}
)
#' @rdname chmColOrder-method
#' @aliases chmColOrder<-,ngchm,optDendrogram-method
setReplaceMethod("chmColOrder",
signature = c(chm = "ngchm", value = "optDendrogram"),
definition = function(chm, value) {
chm <- chmFixVersion(chm)
if (is(value, "file")) {
value <- readLines(value)
class(value) <- "fileContent"
}
validateNewAxisOrder(chm, "column", value)
chm@colOrder <- value
chm@colOrderMethod <- orderMethod(value)
chmUU(chm)
}
)
metaToShaid <- function(metadata) {
stopifnot(!identical(names(metadata), NULL))
metadata <- metadata[order(names(metadata))]
mat <- matrix(metadata, ncol = 1, dimnames = list(names(metadata), "Value"))
shaid <- ngchmSaveAsDatasetBlob(ngchm.env$tmpShaidy, "tsv", mat)
shaid
}
#' @rdname chmAddMetaData-method
#' @aliases chmAddMetaData,ngchm,character,character,character-method
setMethod("chmAddMetaData",
signature = c(chm = "ngchm", where = "character", type = "character", value = "character"),
definition = function(chm, where, type, value) {
stopifnot(length(where) == 1, typeof(where) == "character", where %in% c("row", "column", "both"))
stopifnot(length(type) == 1, typeof(type) == "character", type != "")
stopifnot(length(value) > 0, typeof(value) == "character", all(value != ""))
chm <- chmFixVersion(chm)
meta <- new("ngchmMetaData", type = type, value = metaToShaid(value))
if (where %in% c("row", "both")) {
chm@rowMeta <- append(chm@rowMeta, meta)
}
if (where %in% c("column", "both")) {
chm@colMeta <- append(chm@colMeta, meta)
}
chmUU(chm)
}
)
make.js.names <- function(sss) {
sss <- make.names(sss)
vapply(sss, function(ss) gsub(".", "_", ss, fixed = TRUE), "")
}
#' @rdname chmAddToolboxR-method
#' @aliases chmAddToolboxR,ngchm,character,character,character,character-method
setMethod("chmAddToolboxR",
signature = c(CHM = "ngchm", axis = "character", axistype = "character", datasetname = "character", idstr = "character"),
definition = function(CHM, axis, axistype, datasetname, idstr) {
CHM <- chmFixVersion(CHM)
toolbox <- ngchm.env$toolbox
if (length(toolbox) > 0) {
for (ii in 1:nrow(toolbox)) {
if (toolbox[ii, ]$type == "R") {
fnname <- sprintf("%s%s", toolbox[ii, ]$fn@name, make.js.names(datasetname))
fndef <- chmGetFunction(fnname)
if (length(fndef) == 0) {
chmBindFunction(fnname, toolbox[ii, ]$fn@name, list(dataset = datasetname))
}
fnlabel <- sprintf("%s%s", toolbox[ii, ]$label, idstr)
CHM <- chmAddSpecificAxisTypeFunction(CHM, axis, axistype, fnlabel, fnname)
}
}
}
CHM
}
)
#' @rdname chmAddToolboxR2-method
#' @aliases chmAddToolboxR2,ngchm,character,character,character-method
setMethod("chmAddToolboxR2",
signature = c(CHM = "ngchm", axistype = "character", datasetname = "character", idstr = "character"),
definition = function(CHM, axistype, datasetname, idstr) {
CHM <- chmFixVersion(CHM)
toolbox <- ngchm.env$toolbox
if (length(toolbox) > 0) {
for (ii in 1:nrow(toolbox)) {
if (toolbox[ii, ]$type == "R2") {
fnname <- sprintf("%s%s", toolbox[ii, ]$fn@name, make.js.names(datasetname))
fndef <- chmGetFunction(fnname)
if (length(fndef) == 0) {
chmBindFunction(fnname, toolbox[ii, ]$fn@name, list(dataset = datasetname))
}
fnlabel <- sprintf("%s%s", toolbox[ii, ]$label, idstr)
CHM <- chmAddMenuItem(CHM, "element", fnlabel, chmGetFunction(fnname))
}
}
}
CHM
}
)
#' @rdname chmAddToolboxRC-method
#' @aliases chmAddToolboxRC,ngchm,character,character,character-method
setMethod("chmAddToolboxRC",
signature = c(CHM = "ngchm", rowtype = "character", coltype = "character", datasetname = "character", idstr = "character"),
definition = function(CHM, rowtype, coltype, datasetname, idstr) {
CHM <- chmFixVersion(CHM)
toolbox <- ngchm.env$toolbox
if (length(toolbox) > 0) {
for (ii in 1:nrow(toolbox)) {
if (toolbox[ii, ]$type == "RC") {
fnname <- sprintf("%s%s", toolbox[ii, ]$fn@name, make.js.names(datasetname))
fndef <- chmGetFunction(fnname)
if (length(fndef) == 0) {
chmBindFunction(fnname, toolbox[ii, ]$fn@name, list(dataset = datasetname))
}
fnlabel <- sprintf("%s%s", toolbox[ii, ]$label, idstr)
CHM <- chmAddMenuItem(CHM, "element", fnlabel, chmGetFunction(fnname))
}
}
}
CHM
}
)
#' @rdname shaidyGetShaid-method
#' @aliases shaidyGetShaid,ngchm-method
setMethod("shaidyGetShaid",
signature = c(object = "ngchm"),
definition = function(object) {
ngchmSaveChmAsBlob(ngchm.env$tmpShaidy, object)
}
)
#' @rdname shaidyGetComponents-method
#' @aliases shaidyGetComponents,ngchm-method
setMethod("shaidyGetComponents",
signature = c(object = "ngchm"),
definition = function(object) {
if (is(object@rowOrder, "function")) object@rowOrder <- object@rowOrder(object)
if (is(object@colOrder, "function")) object@colOrder <- object@colOrder(object)
unique(c(object@rowOrder, object@colOrder,
if (is(object@rowOrder, "shaid") && object@rowOrder@type == "dendrogram") ngchmGetLabels(object@rowOrder)[[1]] else NULL,
if (is(object@colOrder, "shaid") && object@colOrder@type == "dendrogram") ngchmGetLabels(object@colOrder)[[1]] else NULL,
lapply(object@layers, function(x) x@data),
lapply(object@colCovariateBars, function(x) x@data),
lapply(object@rowCovariateBars, function(x) x@data),
lapply(object@templates, function(x) x@dest.blob),
lapply(object@rowMeta, function(x) x@value),
lapply(object@colMeta, function(x) x@value),
lapply(object@datasets, shaidyGetComponents),
recursive = TRUE
))
}
)
#' @rdname shaidyGetComponents-method
#' @aliases shaidyGetComponents,ngchmDataset-method
setMethod("shaidyGetComponents",
signature = c(object = "ngchmDataset"),
definition = function(object) {
unique(c(object@data,
lapply(object@row.covariates, shaidyGetComponents),
lapply(object@column.covariates, shaidyGetComponents),
recursive = TRUE
))
}
)
#' @rdname shaidyGetComponents-method
#' @aliases shaidyGetComponents,ngchmCovariate-method
setMethod("shaidyGetComponents",
signature = c(object = "ngchmCovariate"),
definition = function(object) {
object@label.series
}
)
#' @rdname chmGetDataset-method
#' @aliases chmGetDataset,ngchmLayer-method
setMethod("chmGetDataset",
signature = c(object = "ngchmLayer"),
definition = function(object) {
shaid <- object@data
repo <- ngchmFindRepo(shaid)
ngchmLoadDatasetBlob(repo, shaid)
}
)
#' @rdname chmHasProperty-method
#' @aliases chmHasProperty,ngchmVersion2-method
setMethod("chmHasProperty",
signature = c(object = "ngchmVersion2", label = "character"),
definition = function(object, label) {
matches <- vapply(object@properties, function(p) p@label == label, rep(TRUE, length(label)))
if (length(label) == 1) any(matches) else apply(matches, 1, any)
}
)
#' @rdname chmGetProperty-method
#' @aliases chmGetProperty,ngchmVersion2-method
setMethod("chmGetProperty",
signature = c(object = "ngchmVersion2", label = "character"),
definition = function(object, label) {
checkLabel(label)
chmProperty(object, label)
}
)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.