R/Report-methods.R

Defines functions createReport rnb.get.reference rnb.add.reference rnb.add.figure rnb.add.tables rnbreport.create.settings.table rnbreport.get.element.values rnb.add.table rnb.add.list rnb.add.paragraph rnb.add.section rnb.get.directory rnb.initialize.reports complete.report create.path is.valid.relative is.valid.fname

Documented in createReport rnb.add.figure rnb.add.list rnb.add.paragraph rnb.add.reference rnb.add.section rnb.add.table rnb.add.tables rnb.get.directory rnb.get.reference rnb.initialize.reports

########################################################################################################################
## Report-methods.R
## created: 2012-05-08
## creator: Yassen Assenov
## ---------------------------------------------------------------------------------------------------------------------
## Report class method definition.
########################################################################################################################

## F U N C T I O N S ###################################################################################################

#' Checks if the given strings are valid to be used as file names.
#'
#' @param fname \code{character} vector of candidate strings for names.
#' @return \code{logical} vector showing, for each element of \code{fname}, if it meets the criteria for a vaild file
#'         name.
#' @author Fabian Mueller
#' @noRd
is.valid.fname <- function(fname) {
	grepl("^[A-Za-z0-9._-]+$", fname)
}

########################################################################################################################

#' Checks if the given path is valid to be used as a relative link (file or directory) in an HTML report.
#'
#' @param dname Name of the file or directory.
#' @return \code{TRUE} if \code{dname} meets the criteria for a file or directory to be easily referenced in an HTML
#'         link, \code{FALSE} otherwise.
#' @author Yassen Assenov
#' @noRd
is.valid.relative <- function(dname) {
	if (!grepl("^[A-Za-z0-9/\\._-]+$", dname)) {
		return(FALSE)
	}
	if (grepl("^/", dname)) {
		return(FALSE)
	}
	if (grepl("/$", dname)) {
		return(FALSE)
	}
	return(TRUE)
}

########################################################################################################################

#' Creates the given directory. This function attempts to create all non-existant elements of the given path.
#'
#' @param dname           Directory to be created.
#' @param accept.existing Flag indicating if an existing empty directory should be accepted. When this is \code{TRUE}
#'                        and \code{dname} points to an existing empty directory, this function returns \code{TRUE}.
#'                        Hidden files (file names starting with \code{"."} on Unix platforms) are ignored. Thus, if
#'                        \code{dname} already exists and contains hidden files only, it is treated as empty.
#' @param showWarnings    Flag indicating if warnings should be shown.
#' @return                \code{logical} indicating if the creation was successful.
#'
#' @seealso \code{\link{dir.create}}
#' @author Yassen Assenov
#' @noRd
create.path <- function(dname, accept.existing = TRUE, showWarnings = TRUE) {
	if (file.exists(dname)) {
		if (accept.existing) {
			if (file.info(dname)[1, "isdir"]) {
				## TODO: Should invisible files also be considered?
				return(length(dir(dname)) == 0)
			}
		}
		return(FALSE)
	}
	return(dir.create(dname, showWarnings = showWarnings, recursive = TRUE))
}

########################################################################################################################

#' Completes the given HTML report by adding a footer notice and closing the \code{<body>} and \code{<html>} tags.
#'
#' @param report Report instance to close.
#' @param rtype  Contents of the HTML file. It should be \code{"report"} or \code{"index"}.
#' @author Yassen Assenov
#' @noRd
complete.report <- function(report, report.type = "report") {

	## Add list of references to the report
	if (length(report@references) != 0) {
		report <- rnb.add.section(report, "References", NULL)
		reftexts <- report@references
		reftexts <- paste0("<a id=\"ref", 1:length(reftexts), "\">", reftexts, "</a>")
		rnb.add.list(report, as.list(reftexts), type = "o")
	}

	## Close any open sub-sections and sections
	for (i in length(report@opensections):1) {
		if (report@opensections[i] != 0) {
			write.line('</div>', report@fname)
			report@opensections[i] <- 0L
		}
	}

	## Add footer to the report
	write.line("\n<div id=\"copyright\">", report@fname)
	write.line("\t<div id=\"rnbeads\">", report@fname)
	write.line(c("\tThis ", report.type, " was generated on ", format(Sys.time(), "%Y-%m-%d"), " by ",
			"<a href=\"http://rnbeads.mpi-inf.mpg.de/\">RnBeads</a> version ",
			paste(as.character(utils::packageVersion("RnBeads")), collapse = "."), "."), report@fname)
	write.line("\t</div>", report@fname)
	write.line("\t<div id=\"validlogo\">", report@fname)
	write.line(c("\t\t<a href=\"http://validator.w3.org/check?uri=referer\">",
			"<img alt=\"Valid XHTML 1.1\" height=\"31\" src=\"http://www.w3.org/Icons/valid-xhtml11-blue\"",
			" width=\"88\" /></a>"), report@fname)
	write.line(c("\t\t<a href=\"http://jigsaw.w3.org/css-validator/check/referer\">",
			"<img alt=\"Valid CSS\" height=\"31\" src=\"http://jigsaw.w3.org/css-validator/images/vcss-blue\"",
			" width=\"88\" /></a>"), report@fname)
	write.line("\t</div>", report@fname)
	write.line("</div>", report@fname)

	## Close all tags
	write.line("</body>", report@fname)
	write.line("</html>", report@fname)
	return(report)
}

########################################################################################################################

setMethod("show", "Report",
	function(object) {
		cat("Object of class Report - an XHTML Report in RnBeads\n")
		infotext <- c("Report's file" = object@fname,
			"Directory for configuration files" = object@dir.conf,
			"Directory for data files" = object@dir.data,
			"Directory for figure image files" = object@dir.pngs,
			"Directory for figure PDF files" = object@dir.pdfs,
			"Directory for high-resolution image files" = object@dir.high,
			"Number of references" = length(object@references))
		n <- max(nchar(names(infotext)))
		for (i in 1:length(infotext)) {
			cat(sprintf(paste0("%", n, "s: %s\n"), names(infotext)[i], infotext[i]))
		}
	}
)

########################################################################################################################

#' rnb.initialize.reports
#'
#' Creates a new directory to host HTML reports and copies the shared configuration files.
#'
#' @param dir.reports       Directory to host report files. This must be a \code{character} of length one that specifies
#'                          a non-existent path, as this methods attempts to create it.
#' @param dir.configuration Subdirectory to host configuration files shared by the reports. This must be a
#'                          \code{character} of length one that gives location as a path relative to \code{dir.reports}.
#'                          Also, strong restrictions apply to the path name. See the description of the
#'                          \code{\link{createReport}} function for more details. This method creates the directory and
#'                          copies configuration files that define cascading style sheet (CSS) definitions and
#'                          Javascript functions used by the HTML reports.
#' @return \code{TRUE} if the report directory was successfully created and the configuration files were copied to the
#'         specified location; \code{FALSE} otherwise.
#'
#' @examples
#' \donttest{
#' dir.reports <- "~/infinium_studies/cancer_study/reports"
#' if (!rnb.initialize.reports(dir.reports)) {
#'     cat("ERROR: Could not initialize configuration in ", dir.reports, "\n", sep = "")
#' }
#' }
#'
#' @seealso \code{\link{createReport}} for initializing an HTML report
#' @author Yassen Assenov
#' @export
rnb.initialize.reports <- function(dir.reports, dir.configuration = "configuration") {
	if (!(is.character(dir.reports) && length(dir.reports) == 1 && (!is.na(dir.reports[1])))) {
		stop("invalid value for dir.reports")
	}
	if (!(is.character(dir.configuration) && length(dir.configuration) == 1 && (!is.na(dir.configuration[1])))) {
		stop("invalid value for dir.configuration")
	}
	if (!is.valid.relative(dir.configuration)) {
		stop("invalid value for dir.configuration")
	}
	## Remove trailing slash or backslash in dir.reports (if it exists)
	dir.reports <- sub("^(.+)[/\\\\]$", "\\1", dir.reports[1])
	## Attempt to create dir.reports
	if (!create.path(dir.reports, FALSE, showWarnings = FALSE)) {
		return(FALSE)
	}
	## Attempt to create dir.configuration
	dname <- normalizePath(file.path(dir.reports, dir.configuration), mustWork = FALSE)
	if (!create.path(dname, showWarnings = FALSE)) {
		return(FALSE)
	}
	## Copy configuration files
	cfiles <- c("arrow_down.png", "arrow_right.png", "RnBeads.png", "pdf_active.png", "pdf_inactive.png", "report.css",
		"report.js")
	cfiles <- system.file(file.path("extdata", cfiles), package = "RnBeads", mustWork = TRUE)
	return(all(file.copy(cfiles, dname)))
}

## M E T H O D S #######################################################################################################

setValidity("Report",
	function(object) {
		res <- validate.single(object@fname, "fname")
		if (res != "ok") { return(res) }
		res <- validate.single(object@dir.conf, "dir.conf")
		if (res != "ok") { return(res) }
		res <- validate.single(object@dir.data, "dir.data")
		if (res != "ok") { return(res) }
		res <- validate.single(object@dir.pngs, "dir.pngs")
		if (res != "ok") { return(res) }
		res <- validate.single(object@dir.pdfs, "dir.pdfs")
		if (res != "ok") { return(res) }
		res <- validate.single(object@dir.high, "dir.high")
		if (res != "ok") { return(res) }
		res <- validate.single(object@figures, "figures")
		if (res != "ok") { return(res) }
		res <- validate.single(object@tables, "tables")
		if (res != "ok") { return(res) }
		regex.fname <- "^[A-Za-z0-9/\\._-]+$"
		if (!grepl(regex.fname, basename(object@fname))) {
			return("fname is invalid")
		}
		if (!grepl(".+\\.(htm|html|xhtml|xml)$", tolower(basename(object@fname)))) {
			return("fname is invalid")
		}
		if (!is.valid.relative(object@dir.data)) {
			return("dir.data is invalid")
		}
		if (!is.valid.relative(object@dir.pngs)) {
			return("dir.pngs is invalid")
		}
		if (!is.valid.relative(object@dir.pdfs)) {
			return("dir.pdfs is invalid")
		}
		if (!is.valid.relative(object@dir.high)) {
			return("dir.high is invalid")
		}
		if (object@sections < 0) {
			return("sections must be a non-negative value")
		}
		if (object@figures < 0) {
			return("figures must be a non-negative value")
		}
		if (object@tables < 0) {
			return("tables must be a non-negative value")
		}
		TRUE
	}
)

########################################################################################################################

setMethod("initialize", "Report",
	function(.Object, fname, title, page.title, authors, dirs, init.configuration) {
		.Object@fname <- normalizePath(fname, mustWork = FALSE)
		## Read or generate report-specific directory names
		dir.configuration <- dirs["configuration"]
		if (is.na(dir.configuration)) {
			dir.configuration <- "configuration"
		}
		if (!is.valid.relative(dir.configuration)) {
			stop("dir.configuration is invalid")
		}
		.Object@dir.conf <- dir.configuration
		dprefix <- sub("^(.*[\\\\/])*([^\\\\/]+)\\.[^\\.]+$", "\\2", fname)
		.Object@dir.data <- dirs["data"]
		if (is.na(.Object@dir.data)) {
			.Object@dir.data <- paste(dprefix, "data", sep = "_")
		}
		.Object@dir.pngs <- dirs["pngs"]
		if (is.na(.Object@dir.pngs)) {
			.Object@dir.pngs <- paste(dprefix, "images", sep = "_")
		}
		.Object@dir.pdfs <- dirs["pdfs"]
		if (is.na(.Object@dir.pdfs)) {
			.Object@dir.pdfs <- paste(dprefix, "pdfs", sep = "_")
		}
		.Object@dir.high <- dirs["high"]
		if (is.na(.Object@dir.high)) {
			.Object@dir.high <- .Object@dir.pngs
		}
		validObject(.Object)
		if (!is.null(authors) && length(authors) != 0) {
			if (!all(grepl("^[A-Za-z ,.-]+$", authors))) {
				stop("invalid value for authors")
			}
			authors <- paste(authors, collapse = ", ")
		} else {
			authors <- NULL
		}

		## Create directories
		dnames <- file.path(dirname(.Object@fname), c(.Object@dir.data, .Object@dir.pngs, .Object@dir.pdfs, .Object@dir.high))
		dnames <- setdiff(unique(normalizePath(dnames, mustWork = FALSE)), dirname(.Object@fname))
		for (dname in dnames) {
			if (!create.path(dname)) {
				stop(paste("directory", dname, "cannot be created"))
			}
		}
		rm(dnames, dname)

		## Validate configuration directory; create if it's missing
		if (init.configuration) {
			dname <- normalizePath(file.path(dirname(.Object@fname), dir.configuration), mustWork = FALSE)
			if (exists(dname)) {
				if (file.info(dname)[1, "isdir"] == FALSE) {
					stop(paste(dname, "is not a directory"))
				}
			} else if (!create.path(dname)) {
				stop(paste("directory", dname, "cannot be created"))
			}
			## Copy configuration files
			cfiles <- c("arrow_down.png", "arrow_right.png", "RnBeads.png", "pdf_active.png", "pdf_inactive.png",
				"report.css", "report.js")
			cfiles <- system.file(file.path("extdata", cfiles), package = "RnBeads", mustWork = TRUE)
			if (!all(file.copy(cfiles, dname))) {
				stop(paste("configuration could not be initialized in", dname))
			}
			rm(dname, cfiles)
		}

		## Create the HTML file and print its header
		dir.configuration <- ifelse(dir.configuration != ".", paste0(dir.configuration, "/"), "")
		wline <- function(txt, indent = 0) {
			write.line(txt, fname, indent = indent)
		}
		write.line("<?xml version=\"1.0\" encoding=\"UTF-8\"?>", fname, append = FALSE)
		wline("<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">")
		wline("<html xmlns=\"http://www.w3.org/1999/xhtml\">")
		wline("<head>")
		wline("<meta http-equiv=\"Content-Type\" content=\"text/html; charset=utf-8\" />", 1)
		if (!is.null(authors)) {
			wline(c("<meta name=\"author\" content=\"", authors, "\" />"), 1)
		}
		wline(c("<link rel=\"stylesheet\" href=\"", dir.configuration, "report.css\" type=\"text/css\" />"), 1)
		if (!is.null(page.title)) {
			wline(c("<title>", page.title[1], "</title>"), 1)
		}
		wline(c("<script src=\"", dir.configuration, "report.js\" type=\"text/javascript\"></script>"), 1)
		wline("</head>\n")
		wline(c("<body style=\"background:url(", dir.configuration, "RnBeads.png) no-repeat 5px 25px;\">\n"))
		wline(c("<h1>", title, "</h1>\n"))
		.Object
	}
)

########################################################################################################################

#' rnb.get.directory
#'
#' Gets the location of the given report-specific directory.
#'
#' @param report   Report of interest.
#' @param dir      Type of directory to get. Must be one of \code{"data"}, \code{"images"}, \code{"images-high"} or
#'                 \code{"pdfs"}.
#' @param absolute Flag indicating if the absolute path of the directory is to be returned. If this is \code{FALSE},
#'                 the directory name is returned relative to the report's HTML file location.
#' @return Path of the requested directory as a single-element \code{character} vector.
#'
#' @examples
#' \donttest{
#' report <- createReport("example.html", "Example", init.configuration = TRUE)
#' rnb.get.directory(report, "data")
#' }
#' @seealso \code{\linkS4class{Report}} for functions adding contents to an HTML report
#' @author Yassen Assenov
#' @export
rnb.get.directory <- function(report, dir = c("data", "images", "images-high", "pdfs"), absolute = FALSE) {
	if (!inherits(report, "Report")) {
		stop("invalid value for report")
	}
	if (is.null(dir) || length(dir) == 0 || (!(dir[1] %in% c("data", "images", "images-high", "pdfs")))) {
		stop("invalid value for dir")
	}
	if (!parameter.is.flag(absolute)) {
		stop("invalid value for absolute; expected TRUE or FALSE")
	}
	dir <- dir[1]
	if (dir == "data") {
		result <- report@dir.data
	} else if (dir == "pdfs") {
		result <- report@dir.pdfs
	} else if (dir == "images") {
		result <- report@dir.pngs
	} else { # dir == "images-high"
		result <- report@dir.high
	}
	if (absolute) {
		result <- normalizePath(file.path(dirname(report@fname), result), mustWork = FALSE)
	}
	return(result)
}

########################################################################################################################

#' rnb.add.section
#'
#' Generates HTML code for a new section in the specified report.
#'
#' @param report      Report to write the text to.
#' @param title       Section header. This must be a single-element \code{character} vector.
#' @param description Human-readable paragraph text of the section in the form of a \code{character} vector. Elements
#'                    of this vector are concatenated without a separator to form the full description. Set this to
#'                    \code{NULL} if the section does not (yet) contain text.
#' @param level       Section level as a single \code{integer}. It must be one of \code{1}, \code{2} or \code{3},
#'                    denoting section, subsection and sub-subsection, respectively.
#' @param collapsed   Flag indicating if the contents of this section is to be initially collapsed. Possible values are
#'                    \code{TRUE} (the section is not visible), \code{FALSE} (default, the section is expanded) and
#'                    \code{"never"} (the section cannot be collapsed or expanded).
#' @return The modified report.
#'
#' @examples
#' \donttest{
#' report <- createReport("example.html", "Example", init.configuration = TRUE)
#' report <- rnb.add.section(report, "Introduction", "This is how it's done.")
#' }
#' @seealso \code{\linkS4class{Report}} for other functions adding contents to an HTML report
#' @author Yassen Assenov
#' @export
rnb.add.section <- function(report, title, description, level = 1L, collapsed = FALSE) {
	if (!inherits(report, "Report")) {
		stop("invalid value for report")
	}
	if (!is.character(title) || validate.single(title) != "ok") {
		stop("invalid value for title")
	}
	if (!(is.null(description) || is.character(description))) {
		stop("invalid value for description")
	}
	if (is.numeric(level) && all(level == as.integer(level))) {
		level <- as.integer(level)
	}
	if (!(is.integer(level) && length(level) == 1 && 1 <= level[1] && level[1] <= 3)) {
		stop("invalid value for level")
	}
	if (is.character(collapsed)) {
		if (!(length(collapsed) == 1 && isTRUE(collapsed == "never"))) {
			stop('invalid value for collapsed; expected TRUE, FALSE or "never"')
		}
		hclass <- 'fixed'
	} else {
		if (!parameter.is.flag(collapsed)) {
			stop('invalid value for collapsed; expected TRUE, FALSE or "never"')
		}
		hclass <- ifelse(collapsed, 'collapsed', 'expanded')
	}
	## Close previous sub-sections and sections if necessary.
	for (i in length(report@opensections):level) {
		if (report@opensections[i] != 0) {
			write.line('</div>', report@fname)
			report@opensections[i] <- 0L
		}
	}

	i <- report@sections <- report@sections + 1L
	attr.text <- ifelse(is.logical(collapsed), paste0(' onclick="toggleSection(\'', i, '\')"'), '')
	attr.text <- paste0(' class="', hclass, '" id="hsection', i, '"', attr.text)
	write.line(c("\n<h", (level + 1), attr.text, ">", title, "</h", (level + 1), ">"), report@fname)

	if (is.logical(collapsed)) {
		txt <- c('<div id="section', i, '" style="display:', ifelse(collapsed, 'none', 'block'), '">')
		write.line(txt, report@fname)
		
		## Mark the newly open section
		report@opensections[level] <- i
	}
	if (!is.null(description)) {
		write.line(c("<p>", description, "</p>"), report@fname)
	}
	return(report)
}

########################################################################################################################

#' rnb.add.paragraph
#'
#' Generates HTML code for a new paragraph in the specified report.
#'
#' @param report          Report to write the text to.
#' @param txt             \code{character} vector (or array) storing the text to be written. The elements of this vector
#'                        are concatenated without a separator.
#' @param paragraph.class CSS class definition of the paragraph. This must be either \code{NULL} (default) or one of:
#'                        \describe{
#'                          \item{\code{"centered"}}{This paragraph gives a formula or a short statement. Text is
#'                               horizontally centered.}
#'                          \item{\code{"note"}}{This paragraph describes a note. Text is italic.}
#'                          \item{\code{"task"}}{This paragraph describes a task. Text is bold and bright red.}
#'                        }
#' @return The modified report, invisibly.
#'
#' @examples
#' \donttest{
#' report <- createReport("example.html", "Example", init.configuration = TRUE)
#' txt <- "A pessimist is a person who has had to listen to too many optimists."
#' txt <- c(txt, " <i>Don Marquis</i>")
#' rnb.add.paragraph(report, txt)
#' }
#' @seealso \code{\linkS4class{Report}} for other functions adding contents to an HTML report
#' @author Yassen Assenov
#' @export
rnb.add.paragraph <- function(report, txt, paragraph.class = NULL) {
	if (!inherits(report, "Report")) {
		stop("invalid value for report")
	}
	if (!is.character(txt)) {
		stop("invalid value for txt; expected character vector")
	}
	if (is.null(paragraph.class)) {
		paragraph.class <- ""
	} else {
		if (!(is.character(paragraph.class) && length(paragraph.class) == 1 && (!is.na(paragraph.class)))) {
			stop("invalid value for paragraph.class; expected single character")
		}
		paragraph.class <- paragraph.class[1]
		if (!(paragraph.class %in% c("centered", "note", "task"))) {
			stop("invalid value for paragraph.class; expected one of centered, note, task")
		}
		paragraph.class <- paste(" class=", paragraph.class, "", sep = "\"")
	}
	write.line(c("<p", paragraph.class, ">", txt, "</p>"), report@fname)
	return(invisible(report))
}

########################################################################################################################

#' rnb.add.list
#'
#' Generates HTML code for a list in the specified report.
#'
#' @param report Report to write the text to.
#' @param txt    Non-empty list of items to be written. An attribute named \code{type}, if it exists, specifies the type
#'               of the list. See the \emph{Details} section for more information. Every item must be either a nested
#'               \code{list}, denoting a sublist, or a \code{character} vector (or array), storing the text to be
#'               written. Any other objects are coerced to a character type. Elements are concatenated without a
#'               separator to form the text for a list item.
#' @param type   List type to be used for the list and/or its sublists in case the attribute \code{type} is not
#'               specified.
#' @return The modified report, invisibly.
#'
#' @details There are two ways to specify a list type: (1) setting a value for the attribute \code{type} of the list, or
#'          (2) using the function's parameter \code{type}. The value of the function's parameter is used only for lists
#'          and sublists that do not contain an attribute named \code{type}. The following types are supported:
#'          \describe{
#'            \item{\code{"o"}}{Ordered list using arabic numbers - \code{1}, \code{2}, \code{3}, etc.}
#'            \item{\code{"u"}}{Unordered list using bullet points.}
#'          }
#'          Note that every list type must be a one-element \code{character} vector containing one of the codes listed
#'          above. Specifying any other value for list type results in an error.
#'
#' @examples
#' \donttest{
#' report <- createReport("example.html", "Example", init.configuration = TRUE)
#' recipe <- list("Sift flour in a bowl", "Add sugar and mix", "Add milk and mix")
#' rnb.add.list(report, recipe, type="o")
#' }
#' @seealso \code{\linkS4class{Report}} for other functions adding contents to an HTML report
#' @author Yassen Assenov
#' @export
rnb.add.list <- function(report, txt, type = "u") {
	if (!inherits(report, "Report")) {
		stop("invalid value for report")
	}
	if (!(is.list(txt) && length(txt) != 0)) {
		stop("invalid value for txt; expected non-empty list")
	}
	if (!(is.character(type) && length(type) == 1)) {
		stop("invalid value for type; character expected")
	}
	type <- tolower(type)
	## TODO: Add support for more list types
	if (!(type %in% c("o", "u"))) {
		stop("invalid value for type; expected one of: o, u")
	}
	get.html <- function(txt, indent) {
		ltype <- attr(txt, "type")
		if (is.null(ltype)) { ltype <- type }
		if (ltype == "u") {
			tagtext <- "ul"
		} else if (ltype == "o") {
			tagtext = "ol"
		} else {
			stop("invalid list type; expected one of: o, u")
		}
		indenttext <- paste(rep("\t", times = indent), collapse = "")
		contents <- sapply(txt, function(litem) {
			if (is.list(litem)) {
				paste0("\t<li>\n", paste(get.html(litem, indent + 2), collapse = ""), "\n\t</li>\n")
			} else {
				paste0("\t<li>", paste(litem, collapse = ""), "</li>\n")
			}
		})
		paste0(indenttext, c(paste0("<", tagtext, ">\n"), contents, paste0("</", tagtext, ">")))
	}
	write.line(get.html(txt, 0L), report@fname)
	return(invisible(report))
}

########################################################################################################################

#' rnb.add.table
#'
#' Generates HTML code for a table in the specified report.
#'
#' @param report           Report to write the text to.
#' @param tdata            Matrix or data frame to be presented in HTML form. Column names, if present, are used to
#'                         define table columns. If this table contains 0 (zero) rows or 0 columns, calling this
#'                         function has no effect.
#' @param row.names        Flag indicating if row names should also be printed. If this parameter is \code{TRUE} and
#'                         \code{tdata} defines row names, these are printed in the left-most column and are displayed
#'                         as header cells. Keep in mind that \code{data.frame}s always define row names.
#' @param first.col.header Flag indicating if all cells in the first column must be displayed as header cells. Note
#'                         that, if both this parameter and \code{row.names} are \code{TRUE}, and \code{tdata} contains
#'                         row names, the constructed HTML table will have 2 columns of header cells.
#' @param indent           Default indentation, in number of tabulation characters, to apply to HTML tags. This
#'                         indentation is also applied to \code{thead}.
#' @param tag.attrs        Named \code{character} vector specifying the list of attributes to be set to the
#'                         \code{<table>} element. Setting this to \code{NULL} or an empty \code{character} vector
#'                         disables attributes.
#' @param thead            \code{character} vector storing a table header to include. This can, for example, be a
#'                         \code{character} that defines column widths. Every element in this vector is written on a
#'                         separate line, applying the indentation given by \code{indent}.
#' @param tcaption         Text to include as a caption below the table, or \code{NULL} if the table does not contain
#'                         caption.
#' @param na               \code{character} to be used for printing \code{NA} values in the table. This parameter is
#'                         not considered when printing \code{thead} or the table's column names.
#' @return The modified report, invisibly.
#'
#' @seealso \code{\link{rnb.add.tables}} for adding a listing of tables; \code{\linkS4class{Report}} for other functions
#'   adding contents to an HTML report
#' @author Yassen Assenov
#' @export
rnb.add.table <- function(report, tdata, row.names = TRUE, first.col.header = FALSE, indent = 0,
	tag.attrs = c("class" = "tabdata"), thead = NULL, tcaption = NULL, na = "<span class=\"disabled\">n/a</span>") {

	if (!inherits(report, "Report")) {
		stop("invalid value for report")
	}
	if (!(is.matrix(tdata) || is.data.frame(tdata))) {
		stop("invalid value for tdata; expected matrix or data.frame")
	}
	if (!parameter.is.flag(first.col.header)) {
		stop("invalid value for first.col.header; expected TRUE or FALSE")
	}
	if (is.numeric(indent) && all(indent == as.integer(indent))) {
		indent <- as.integer(indent)
	}
	if (!(is.integer(indent) && length(indent) == 1 && (!is.na(indent)) && 0 <= indent)) {
		stop("invalid value for indent; expected single non-negative integer")
	}
	if (!is.null(tag.attrs)) {
		if (!(is.character(tag.attrs) && length(tag.attrs) == length(names(tag.attrs)))) {
			stop("invalid value for tag.attrs; expected named character vector")
		}
		if (length(tag.attrs) != 0) {
			tag.attrs <- paste("", paste(names(tag.attrs), "=\"", tag.attrs, "\"", sep = "", collapse = " "))
		} else {
			tag.attrs <- ""
		}
	} else {
		tag.attrs <- ""
	}
	if (!is.null(thead)) {
		if (!(is.character(thead))) {
			stop("invalid value for thead; expected character")
		}
		if (length(thead) == 0) {
			thead <- NULL
		}
	}
	if (!is.null(tcaption)) {
		if (!is.character(tcaption)) {
			stop("invalid value for tcaption; expected character")
		}
	}
	if (!(is.character(na) && length(na) == 1)) {
		stop("invalid value for na; expected single character")
	}
	if (nrow(tdata) * ncol(tdata) == 0) {
		return(invisible())
	}

	## Convert factors to characters
	if (is.data.frame(tdata)) {
		for (j in 1:ncol(tdata)) {
			if (is.factor(tdata[[j]])) {
				tdata[[j]] <- as.character(tdata[[j]])
			}
		}
	}

	wline <- function(txt, indentation = indent) {
		write.line(txt, report@fname, indent = indentation)
	}
	wline(c("<div class=\"restricted\"><table", tag.attrs, ">"))
	if (!is.null(thead)) {
		mapply(wline, thead)
	}
	startcolumn <- as.integer(ifelse(row.names & (!is.null(rownames(tdata))), 0, 1))
	if (!is.null(colnames(tdata))) {
		wline("<tr>")
		if (startcolumn == 0) {
			cnames <- c("", colnames(tdata))
		} else {
			cnames <- colnames(tdata)
		}
		for (cname in cnames) {
			wline(c("<td class=\"header\">", cname, "</td>"), indent + 1)
		}
		wline("</tr>")
		rm(cnames)
	}
	if (nrow(tdata) != 0) {
		for (i in 1:nrow(tdata)) {
			wline("<tr>")
			for (j in startcolumn:ncol(tdata)) {
				value <- base::ifelse(j == 0, rownames(tdata)[i], tdata[[i, j]])
				if (is.na(value)) { value <- na }
				cclass <- ifelse(j == 0 || (j == 1 && first.col.header), "header", "centered")
				wline(c("<td class=\"", cclass, "\">", value, "</td>"), indent + 1)
			}
			wline("</tr>")
		}
	}
	wline("</table></div>")
	if (!is.null(tcaption)) {
		wline(c("<p class=\"centered\"><span class=\"note\">", tcaption, "</span></p>"))
	}
	wline("", indentation = 0)
	return(invisible(report))
}

########################################################################################################################

#' rnbreport.get.element.values
#'
#' @param elements       Observed values of element names, in the form of a \code{list} of \code{character} vectors of
#'                       equal length. The <i>i</i>-th element of this list should be extracted from the <i>i</i>-th
#'                       table identifier or plot file name.
#' @param settings.count Number of variable elements for which descriptions are provided. The is the length of
#'                       \code{setting.names}.
#' @return List of observed values per element; an empty list if no variation is observed (\code{elements} if of length
#'         one). In case the number of variable elements does not match \code{settings.count}, the return value is
#'         \code{character} containing an error message.
#' @author Yassen Assenov
#' @noRd
rnbreport.get.element.values <- function(elements, settings.count) {
	element.count <- range(sapply(elements, length))
	if (element.count[1] != element.count[2]) {
		return(NULL)
	}
	element.count <- element.count[1]
	if (element.count < settings.count) {
		return("too many entries in setting.names")
	}
	element.values <- lapply(1:element.count, function(i) { sort(unique(sapply(elements, "[", i))) })
	names(element.values) <- 1:length(element.values)
	i <- which(sapply(element.values, length) != 1)[1]
	if ((!is.na(i)) && settings.count < length(element.values) - i + 1) {
		return("too few entries in setting.names")
	}
	return(element.values)
}

########################################################################################################################

#' rnbreport.create.settings.table
#'
#' Creates the HTML code for a table of selecting settings. This is used in figures and in listings of tables.
#'
#' @param type              One of \code{"fig"} or \code{"tab"}.
#' @param n                 Index of figure or table listing in the report.
#' @param element.values    List of all observed values for each element in the identifiers. This is extracted by
#'                          \code{\link{rnbreport.get.element.values}}.
#' @param setting.names     List of element descriptors, as provided to the calling function.
#' @param selected.elements Element values that should be initially selected.
#' @param indent            Indentation, in number of tabulation characters, of the <table> tag.
#' @return One-element \code{character} containing the generated HTML code for the settings table; \code{NULL} if
#'         \code{setting.names} is incomplete, that is, not all provided \code{element.values} have descriptions.
#' @author Yassen Assenov
#' @noRd
rnbreport.create.settings.table <- function(type, n, element.values, setting.names, selected.elements, indent = 1L) {
	updatefun <- ifelse(type == "fig", "updateFigure", "updateTable")
	result <- character()
	wline <- function(txt, ind = 0L) {
		result <<- c(result, paste(c(paste(rep("\t", indent + ind), collapse = ""), txt), collapse = ""))
	}
	i <- length(element.values) - length(setting.names) + 1
	element.values <- element.values[i:length(element.values)]
	## Validate setting.names
	missing.names <- sapply(1:length(element.values), function(i) {
		length(setdiff(element.values[[i]], names(setting.names[[i]]))) != 0
	})
	if (any(missing.names)) {
		return(NULL)
	}

	## Create a table of settings
	wline("<table class=\"tabsettings\">")
	for (i in 1:length(element.values)) {
		si <- as.integer(names(element.values)[i])
		wline("<tr>")
		wline(c("<td>", names(setting.names)[i], "</td>"), 1)
		wline("<td>", 1)
		txt <- ifelse(length(element.values[[i]]) == 1, " disabled=\"disabled\"", "")
		txt <- c("<select", txt, " id=\"", type, n, "setting", si)
		wline(c(txt, "\" onchange=\"", updatefun, "(\'", type, n, "\')\">"), 2)
		s.options <- setting.names[[i]]
		s.options <- s.options[intersect(names(s.options), element.values[[i]])]
		for (j in 1:length(s.options)) {
			sv <- names(s.options)[j]
			txt <- ifelse(selected.elements[si] == sv, " selected=\"selected\"", "")
			wline(c("<option", txt, " value=\"", sv, "\">", s.options[j], "</option>"), 3)
		}
		wline("</select>", 2)
		wline("</td>", 1)
		wline("</tr>")
	}
	wline("</table>")
	wline("<br />")

	return(paste(result, collapse = "\n"))
}

########################################################################################################################

#' rnb.add.tables
#'
#' Generates HTML code for a listing of tables (of which only one is visible at any moment) in the specified report.
#'
#' @param report         Report to write the text to.
#' @param tables         Non-empty \code{list} of tables, each one represented by a \code{\link{data.frame}} or
#'                       \code{\link{matrix}}. The names of this list are used as table identifiers; each one consists
#'                       of elements separated by underscore character (\code{_}).
#' @param setting.names  List of table name element descriptors. Every variable elements in the table names must be
#'                       included in this list.
#' @param selected.table Index of the table to be initially selected in this listing.
#' @param indent         Default indentation, in number of tabulation characters, to apply to every table.
#' @param ...            Other parameters passed to \code{\link{rnb.add.table}}.
#' @return The modified report.
#'
#' @seealso \code{\link{rnb.add.table}} for adding a single table to a report; \code{\linkS4class{Report}} for other
#'   functions adding contents to an HTML report
#' @author Yassen Assenov
#' @export
rnb.add.tables <- function(report, tables, setting.names, selected.table = 1L, indent = 2L, ...) {
	
	if (!inherits(report, "Report")) {
		stop("invalid value for report")
	}
	if (!(is.list(tables) && length(tables) != 0 &&
			all(sapply(tables, function(x) { is.matrix(x) || is.data.frame(x) })))) {
		stop("invalid value for tables")
	}
	if (!(is.list(setting.names) && all(sapply(setting.names, is.vector)))) {
		stop("invalid value for setting.names")
	}
	if (is.numeric(selected.table) && all(as.integer(selected.table) == selected.table)) {
		selected.table <- as.integer(selected.table)
	}
	if (!is.integer(selected.table) && length(selected.table) == 1 && (!is.na(selected.table))) {
		stop("invalid value for selected.table")
	}
	if (selected.table < 1 || length(tables) < selected.table) {
		stop("invalid value for selected.table")
	}

	## Identify name elements
	elements <- strsplit(names(tables), "_", fixed = TRUE)
	element.values <- rnbreport.get.element.values(elements, length(setting.names))
	if (is.null(element.values)) {
		stop("inconsistent table names")
	}
	if (is.character(element.values)) {
		stop(element.values)
	}

	n <- report@tables + 1L
	wline <- function(txt, ind = 0L) {
		write.line(txt, report@fname, indent = ind)
	}

	## Create a table of settings
	wline(c("<div class=\"figure\" id=\"tab", n, "figure\">"), 0)
	if (length(setting.names) != 0) {
		txt <- rnbreport.create.settings.table("tab", n, element.values, setting.names, elements[[selected.table]])
		if (is.null(txt)) {
			stop("missing plot file element descriptors")
		}
		wline(txt, 0)
	}

	## Create tables
	for (i in 1:length(tables)) {
		txt <- c(" style=\"display:", ifelse(i == selected.table, "block", "none"), "\"")
		wline(c("<div id=\"tab", n, "_", names(tables)[i], "\"", txt, ">"), 1)
		rnb.add.table(report, tables[[i]], indent = indent, ...)
		wline("</div>\n", 1)
	}

	wline("</div>", 0)
	report@tables <- n
	return(report)
}

########################################################################################################################

#' rnb.add.figure
#'
#' Generates HTML code for a figure in the specified report. A figure is a collection of images (plots), of which only
#' one is visible at any given moment.
#'
#' @param report         Report to write the text to.
#' @param description    Human-readable description of the figure. This must be a non-empty \code{character} vector. The
#'                       elements of this vector are concatenated without a separator to form the full description.
#' @param report.plots   Object of type \code{\linkS4class{ReportPlot}}, or a list of such objects.
#' @param setting.names  List of plot file element descriptors. Every variable elements in the plot file names must be
#'                       included in this list. Set this to empty list if no variable elements are present, that is, if
#'                       the figure should present a single report plot.
#' @param selected.image Index of plot to be initially selected in the figure.
#' @return The modified report.
#'
#' @seealso \code{\link{rnb.add.tables}} for adding a listing of tables; \code{\linkS4class{Report}} for other functions
#'   adding contents to an HTML report
#' @author Yassen Assenov
#' @export
rnb.add.figure <- function(report, description, report.plots, setting.names = list(), selected.image = as.integer(1)) {

	if (!inherits(report, "Report")) {
		stop("invalid value for report")
	}
	if (!(is.character(description) && length(description) != 0)) {
		stop("invalid value for description")
	}
	if (inherits(report.plots, "ReportPlot")) {
		report.plots <- list(report.plots)
	}
	if (!(is.list(report.plots) && length(report.plots) != 0 && all(sapply(report.plots, inherits, "ReportPlot")))) {
		stop("invalid value for report.plots")
	}
	if (!(is.list(setting.names) && all(sapply(setting.names, is.vector)))) {
		stop("invalid value for setting.names")
	}
	if (is.numeric(selected.image) && all(as.integer(selected.image) == selected.image)) {
		selected.image <- as.integer(selected.image)
	}
	if (!is.integer(selected.image) && length(selected.image) == 1 && (!is.na(selected.image))) {
		stop("invalid value for selected.image")
	}
	if (selected.image < 1 || length(report.plots) < selected.image) {
		stop("invalid value for selected.image")
	}

	## The following must be synchronizes with the values in report.css
	PLOT.IMAGE.WIDTH.MAX <- 850  ## maximum visible width, in pixels, of a figure plot image
	PLOT.IMAGE.HEIGHT.MAX <- 850 ## maximum visible height, in pixels, of a figure plot image

	iheight <- range(sapply(report.plots, slot, "height"))
	iwidth <- range(sapply(report.plots, slot, "width"))
	ilow <- range(sapply(report.plots, slot, "low.png"))
	if (iheight[1] != iheight[2] || iwidth[1] != iwidth[2] || ilow[1] != ilow[2]) {
		stop("inconsistent image sizes")
	}
	iheight <- iheight[1] * ilow[1]
	iwidth <- iwidth[1] * ilow[1]
	pdfs <- NULL
	if (all(sapply(report.plots, slot, "create.pdf"))) {
		pdfs <- unique(sapply(report.plots, slot, "dir.pdf"))
		if (length(pdfs) != 1) {
			pdfs <- NULL # inconsistent directory to store the PDF files; do not create a link
		}
	}
	ihigh <- range(sapply(report.plots, slot, "high.png"))
	ihigh <- ifelse(ihigh[1] == ihigh[2] && ihigh[1] > 0, ihigh[1], 0L)

	## Get the file name elements
	fnames <- sapply(report.plots, slot, "fname")
	felements <- strsplit(fnames, "_", fixed = TRUE)
	element.values <- rnbreport.get.element.values(felements, length(setting.names))
	if (is.null(element.values)) {
		stop("inconsistent figure file names")
	}
	if (is.character(element.values)) {
		stop(element.values)
	}

	fn <- report@figures + 1L
	wline <- function(txt, indent = 1) {
		write.line(txt, report@fname, indent = indent)
	}

	## Create a table of settings if necessary
	if (length(setting.names) != 0) {
		txt <- rnbreport.create.settings.table("fig", fn, element.values, setting.names, felements[[selected.image]])
		if (is.null(txt)) {
			stop("missing plot file element descriptors")
		}
	} else {
		txt <- NULL
	}
	wline("<div class=\"figure\">", 0)
	if (!is.null(txt)) {
		wline(txt, 0)
	}

	## Create image placeholder
	txt <- paste0(report@dir.pngs, "/", fnames[selected.image], ".png")
	txt <- paste0("<img alt=\"Figure ", fn, "\" id=\"fig", fn, "image\" height=\"", iheight, "\" src=\"", txt,
		"\" width=\"", iwidth, "\" />")
	if (ihigh != 0) {
		## Add link to a high-resolution image
		fimage.high <- ifelse(report@dir.high == report@dir.pngs, "_high_resolution", "")
		fimage.high <- paste0(report@dir.high, "/", fnames[selected.image], fimage.high, ".png")
		txt <- paste0("<a href=\"", fimage.high, "\" id=\"fig", fn, "imagehigh\">", txt, "</a>")
	}
	if (iwidth > PLOT.IMAGE.WIDTH.MAX) {
		if (iheight > PLOT.IMAGE.HEIGHT.MAX) {
			txt <- paste0("<div class=\"restricted\">", txt, "</div>")
		} else {
			txt <- paste0("<div class=\"restrictedx\">", txt, "</div>")
		}
	} else if (iheight > PLOT.IMAGE.HEIGHT.MAX) {
		txt <- paste0("<div class=\"restrictedy\">", txt, "</div>")
	}
	wline(txt)

	## Create figure title and description
	wline("<p class=\"caption\">")
	if (!is.null(pdfs)) {
		## Create a link to a PDF file if applicable
		txt <- c("<span title=\"Open PDF\"><a class=\"figicon\" id=\"fig", fn, "pdf\" href=\"", report@dir.pdfs, "/",
			fnames[selected.image], ".pdf\"><img alt=\"Open PDF\" height=\"20\" onmouseout=\"pdficon(this, false)\" ",
			"onmouseover=\"pdficon(this)\" src=\"", report@dir.conf, "/pdf_inactive.png\" width=\"20\" /></a></span>")
		wline(txt, 2)
	}
	txt <- c("<a id=\"fig", fn, "caption\" onmousedown=\"showHide(\'fig", fn,
		"description\')\" onmouseout=\"doCursor()\" onmouseover=\"doCursor()\">Figure ", fn, "</a>")
	wline(txt, 2)
	wline("</p>")
	wline(c("<p class=\"figdescription\" id=\"fig", fn, "description\">", description, "</p>"))

	wline("</div>\n", 0)
	report@figures <- fn
	return(report)
}

########################################################################################################################

#' rnb.add.reference
#'
#' Adds a reference item to the given report.
#'
#' @param report Report to add a reference item to.
#' @param txt    Text of the reference in the form of a non-empty \code{character} vector. The elements of this vector
#'               are concatenated without a separator.
#' @return The modified report.
#'
#' @examples
#' \donttest{
#' report <- createReport("example.html", "Example", init.configuration = TRUE)
#' txt.reference <- c("Bird A. ", "<i>Nucleic Acids Res.</i> <b>8</b> (1980)")
#' report <- rnb.add.reference(report, txt.reference)
#' txt <- c("This was shown in ", rnb.get.reference(report, txt.reference), ".")
#' rnb.add.paragraph(report, txt)
#' }
#' @seealso \code{\link{rnb.get.reference}} for adding citations in the report's text; \code{\linkS4class{Report}} for
#'   other functions adding contents to an HTML report
#' @author Yassen Assenov
#' @export
rnb.add.reference <- function(report, txt) {
	if (!inherits(report, "Report")) {
		stop("invalid value for report")
	}
	if (!(is.character(txt) && length(txt) != 0)) {
		stop("invalid value for txt; expected character vector")
	}
	report@references <- union(report@references, paste(txt, collapse = ""))
	return(report)
}
	
########################################################################################################################

#' rnb.get.reference
#'
#' Creates a string that points to the given reference item in the specified report.
#'
#' @param report Report that contains the reference to be cited.
#' @param txt    Text of the reference in the form of a non-empty \code{character} vector. This reference must already
#'               added to the report.
#' @return Citation of the reference item (including a link) in the form of a one-element \code{character} vector. If
#'         the specified reference item is not found in the report, this method returns an empty string.
#'
#' @examples
#' \donttest{
#' report <- createReport("example.html", "Example", init.configuration = TRUE)
#' txt.reference <- c("Bird A. ", "<i>Nucleic Acids Res.</i> <b>8</b> (1980)")
#' report <- rnb.add.reference(report, txt.reference)
#' txt <- c("This was shown in ", rnb.get.reference(report, txt.reference), ".")
#' rnb.add.paragraph(report, txt)
#' }
#' @seealso \code{\link{rnb.add.reference}} for adding a reference item to a report; \code{\linkS4class{Report}} for
#'   other functions adding contents to an HTML report
#' @author Yassen Assenov
#' @export
rnb.get.reference <- function(report, txt) {
	if (!inherits(report, "Report")) {
		stop("invalid value for report")
	}
	if (!(is.character(txt) && length(txt) != 0)) {
		stop("invalid value for txt; expected character vector")
	}
	result <- which(report@references == paste(txt, collapse = ""))
	if (length(result) != 0) {
		result <- paste0("[<a href=\"#ref", result, "\">", result, "</a>]")
	} else {
		result <- ""
	}
	return(result)
}

########################################################################################################################
	
if (!isGeneric("off")) {
	if (exists("off") && typeof(get("off")) == "closure") {
		setGeneric("off")
	} else {
		setGeneric("off", function(.Object,...) standardGeneric("off"))
	}
}

#' off-methods
#'
#' Performs cleanup and/or other finishing activities and closes the specified device, connection, or document.
#'
#' @param .Object       Object to be closed.
#' @param handle.errors Flag indicating if the method should attempt to catch and process errors (e.g. I/O errors)
#'                      internally. Setting this to \code{TRUE} does not guarantee that the method never stops with an
#'                      error.
#'
#' @return The closed object, invisibly.
#'
#' @export
#' @docType methods
#' @rdname off-methods
#' @aliases off
#' @aliases off,Report-method
#' @aliases off,ReportPlot-method
setMethod("off", "Report",
	function(.Object) {
		return(invisible(complete.report(.Object)))
	}
)

########################################################################################################################
########################################################################################################################

#' createReport
#'
#' Creates a new report object.
#'
#' @param fname              Single-element \code{character} vector denoting the name of the file to contain the HTML
#'                           report. If this file already exists, it will be overwritten.
#' @param title              Title of the report in the form of a single-element \code{character} vector.
#' @param page.title         Web page title. This usually appears in the web browser's window title when the report is
#'                           open. If specified, this must be a vector. Note that only the first element is used.
#' @param authors            Optional list of authors in the form of a \code{character} vector. This list is included in
#'                           the header of the generated HTML file. Note that author names can contain only Latin leters,
#'                           space, dash (\code{-}), comma (\code{,}) or dot (\code{.}).
#' @param dirs               Location of the supporting directories, that is, paths that are expected to contain
#'                           additional files linked to from the HTML report. See the \emph{Details} section for a list
#'                           of these directories.
#' @param init.configuration Flag indicating if the report configuration data should be initialized. If this parameter
#'                           is \code{TRUE}, the method creates the respective directory and copies configuration files
#'                           that define cascading style sheet (CSS) definitions and Javascript functions used by the
#'                           HTML report. If such configuration files already exist, they will be overwritten. Since the
#'                           aforementioned files can be shared by multiple reports, it is recommended that the
#'                           configuration is initialized using the method \code{\link{rnb.initialize.reports}}, instead
#'                           of setting this flag to \code{TRUE}.
#' @return Newly created \code{\linkS4class{Report}} object.
#'
#' @details
#' If specified, the parameter \code{dirs} must be a \code{character} vector. The following names are read:
#' \itemize{
#'  \item{\code{"configuration" }}{Directory that contains the auxilliary configuration files, such as style sheets and
#'        Javascript files. If missing or \code{NA}, the default value used is \code{"configuration"}.}
#'  \item{\code{"data" }}{Directory to contain the tables, lists and other generated data files that are linked to in
#'        the HTML report. If missing or \code{NA}, the value used is formed from the file name \code{fname} (without
#'        the extension) and the suffix \code{"_data"}.}
#'  \item{\code{"pngs" }}{Directory to contain the low resolution PNG images shown in the HTML report. If missing or
#'        \code{NA}, the value used is formed from the file name \code{fname} (without the extension) and the suffix
#'        \code{"_images"}.}
#'  \item{\code{"pdfs" }}{Directory to contain the PDF images (if such are created). If not missing or \code{NA}, the
#'        value used is formed from the file name \code{fname} (without the extension) and the suffix \code{"_pdf"}.}
#'  \item{\code{"high" }}{Directory to contain the high resolution PNG images (if such are created). If missing or
#'        \code{NA}, the value used is the same as the \code{pngs} directory.}
#' }
#' Any other elements, if present, are ignored. Note that these directories are not required to point to different
#' locations. In particular, if the directories for low and for high resolution images are identical, the
#' high-resolution image files are assumed to be the ones with suffix \code{"_high_resolution.png"}. See
#' \code{\link{createReportPlot}} for creating image files.
#' In order to ensure independence of the operating system, there are strong restrictions on the names of the file and
#' directories. The name of the report's HTML file can consist of the following symbols only: Latin letters, digits, dot
#' (\code{.}), dash (\code{-}) and underline (\code{_}). The extension of the report's HTML file must be one of
#' \code{htm}, \code{html}, \code{xhtml} or \code{xml}. The supporting directories must be given as relative paths;
#' the restrictions on the path names are identical to the ones for file name. Forward slash (\code{/}) is to be used as
#' path separator. Path names cannot start or end with a slash. None of the directory names can be
#' an empty string, use \code{"."} instead. A value in the form \code{"mypath/.html"} for \code{fname} is invalid.
#' Upon initialization, the report attempts to create or overwrite the specified \code{fname}. If the path to it does
#' not exist, or if the current process does not have permissions to write to the file, report initialization will fail.
#' The report object visits each supporting directory (except \code{configuration}) and attempts to create it, unless it
#' is an existing empty directory. Report initialization will fail if any of the visited directories does not meet the
#' criteria and could not be created. Hidden files (file names starting with \code{"."} on Unix platforms) are ignored.
#' Thus, all supporting directories that already exist and contain hidden files only are considered valid.
#'
#' @examples
#' \donttest{
#' report <- createReport("example.html", "Example", init.configuration = TRUE)
#' }
#' @seealso \code{\linkS4class{Report}} for functions adding contents to an HTML report
#' @author Yassen Assenov
#' @export
createReport <- function(fname, title, page.title = "RnBeads report", authors = NULL, dirs = NULL, init.configuration = FALSE) {
	if (!(is.character(fname) && length(fname) == 1 && (!is.na(fname[1])))) {
		stop("invalid value for fname")
	}
	if (!(is.character(title) && length(title) == 1 && (!is.na(title[1])))) {
		stop("invalid value for title")
	}
	if (!(is.null(page.title) || is.vector(page.title))) {
		stop("invalid value for page.title")
	}
	if (!(is.null(authors) || is.character(authors))) {
		stop("invalid value for authors")
	}
	if (is.null(dirs)) {
		dirs <- character(0)
	} else {
		if (!is.character(dirs)) {
			stop("invalid value for dirs")
		}
		dnames <- names(dirs)
		if (is.null(dnames)) { dnames <- character(0) }
		dnames <- intersect(dnames, c("configuration", "data", "pngs", "pdfs", "high"))
		if (length(dnames) != 0 && any(is.na(dirs[dnames]))) {
			stop("missing values for dirs")
		}
	}
	if (!parameter.is.flag(init.configuration)) {
		stop("invalid value for init.configuration; expected TRUE or FALSE")
	}
	new("Report", fname, title, page.title, authors, dirs, init.configuration[1])
}

Try the RnBeads package in your browser

Any scripts or data that you put into this service are public.

RnBeads documentation built on Nov. 17, 2017, 11:58 a.m.