R/allMethods.R

In bmbroom/NGCHMR: Utilities for Creating Next Generation Clustered Heat Maps

# ##############################################################################################
#
# 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 chmInstall-method
### ' @aliases chmInstall,character,ngchm-method
##setMethod ("chmInstall",
##    signature = c(server="character", chm="ngchm"),
##    definition = function (server, chm, ...) {
##	chmInstall (chmServerCheck (server), 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,ngchmServer,ngchm-method
##setMethod ("chmUninstall",
##    signature = c(server="ngchmServer", chm="ngchm"),
##    definition = function (server, chm, ...) {
##        chmUninstall (server, chmName(chm), ...);
##});

#' @rdname chmUninstall-method
#' @aliases chmUninstall,ngchm-method
setMethod ("chmUninstall",
    signature = c(chm="ngchm"),
    definition = function (chm, ...) {
        chmUninstall (chmName(chm), ...);
});

### ' @rdname chmUninstall-method
### ' @aliases chmUninstall,character,character-method
##setMethod ("chmUninstall",
##    signature = c(server="character", chm="character"),
##    definition = function (server, chm, ...) {
##        chmUninstall (chmServerCheck(server), 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 <- ".";
    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 ((class(cmap1) != "ngchmColormap") || (class(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 (class (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 ((class(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 (class(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 (class(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 (class(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 (class(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));
        }
        #system (sprintf ("/bin/rm -rf %s", chm@inpDir));
        #systemCheck (sprintf ("/bin/mkdir %s", chm@inpDir));
        saveDir <- chm@inpDir;
    }

    if (chm@format == "original") {
        genSpecFeedback (55, "saving user's CHM");
        orig.chm <- chm;
        chm@inpDir <- chm@outDir <- chm@saveDir <- "";
        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 (class (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 ((class (ord) == "dendrogram") || (class (ord) == "hclust")) {
	sink (file.path (inpDir, sprintf ("dendro_%s.str", type)))
	if (class (ord) == "hclust")
	    ord <- stats::as.dendrogram (ord);
	nr.str.dendrogram (ord);
	sink (NULL);
    } else if (class (ord) == "fileContent") {
	filename <- (paste (inpDir, sprintf ("dendro_%s.str", type), sep="/"));
	ff <- file (filename, "wb");
	writeBinLines (ord, ff);
	close (ff);
    } else if (class (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 (class (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)
{
    cat (sprintf ("%s\t%s\t:%s:\t%g\t%s\n", datestamp(), "PROGRESS", mode, progress, what), file=stderr());
}

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);
    cat (sprintf ("addToolBoxes: found %d R datasets matching row types:\n", sum(matches)), file=stderr());
    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]) {
	    cat (sprintf ("dataset '%s' row.type '%s'\n", ds@name, t2s(ds@row.type)), file=stderr());
	    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);
    cat (sprintf ("addToolBoxes: found %d R datasets matching column types:\n", sum(matches)), file=stderr());
    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]) {
	    cat (sprintf ("dataset '%s' row.type '%s'\n", ds@name, t2s(ds@row.type)), file=stderr());
	    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);
    cat (sprintf ("addToolBoxes: found %d R2 datasets matching row and column types:\n", sum(matches)), file=stderr());
    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]) {
	    cat (sprintf ("dataset '%s' row.type '%s'\n", ds@name, t2s(ds@row.type)), file=stderr());
	    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);
    cat (sprintf ("addToolBoxes: found %d RC datasets matching row and column types:\n", sum(matches)), file=stderr());
    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]) {
	    cat (sprintf ("dataset '%s' row.type '%s' col.type '%s'\n", ds@name, t2s(ds@row.type), t2s(ds@column.type)), file=stderr());
	    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) && (class(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) && (class(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)));
    cat ("chmMake: Java process completed\n", file=stderr());

    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")
    }
}

#' @method + ngchmVersion2,ngchmAxis
#' @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 (class(item) == "ngchmBar") {
	        bar <- item;
	    } else if (class(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 (class(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 (class(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)
    }
);