report.R

KNITR_TAB_ENV = new.env()
KNITR_TAB_ENV$current_tab_index = 0
KNITR_TAB_ENV$current_div_index = 0
KNITR_TAB_ENV$header = NULL
KNITR_TAB_ENV$current_html = ""
KNITR_TAB_ENV$random_str = round(runif(1, min = 1, max = 1e8))
KNITR_TAB_ENV$css_added = FALSE

# == title
# Add one JavaScript tab in the report
#
# == param
# -code R code to execute.
# -header header or the title for the tab.
# -desc decription in the tab.
# -opt options for the knitr chunk.
# -message message to print.
#
# == details
# Each tab contains the R source code and results generated from it (figure, tables, text, ...).
#
# This function in only for internal use.
#
# == value
# No value is returned.
#
# == seealso
# `knitr_insert_tabs` produces a complete HTML fragment.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
knitr_add_tab_item = function(code, header, desc = "", opt = NULL, message = NULL) {
	KNITR_TAB_ENV$current_tab_index = KNITR_TAB_ENV$current_tab_index + 1
	tab = qq("tab-@{KNITR_TAB_ENV$random_str}-@{KNITR_TAB_ENV$current_tab_index}")
	knitr_text = qq(
"@{strrep('`', 3)}{r @{tab}@{ifelse(is.null(opt), '', paste0(', ', opt))}}
@{code}
@{strrep('`', 3)}

@{desc}
")	

	if(!is.null(message)) {
		knitr_text = qq(
"@{strrep('`', 3)}{r, echo = FALSE, message = FALSE, fig.keep = 'none'}
message('@{message}')
@{strrep('`', 3)}

@{knitr_text}"
)
	}

	# while(dev.cur() > 1) dev.off()

	op1 = getOption("markdown.HTML.options")
	op2 = getOption("width")
	options(markdown.HTML.options = setdiff(op1, c("base64_images", "toc")), width = 100)
	md = knit(text = knitr_text, quiet = TRUE, envir = parent.frame())
	html = markdownToHTML(text = md, fragment.only = TRUE)
	html = qq("<div id='@{tab}'>\n@{html}\n</div>\n")
	options(markdown.HTML.options = op1, width = op2)
	KNITR_TAB_ENV$header = c(KNITR_TAB_ENV$header, header)
	KNITR_TAB_ENV$current_html = paste0(KNITR_TAB_ENV$current_html, html)
	return(invisible(NULL))
}

TEMPLATE_DIR = system.file("extdata", package = "cola")
# TEMPLATE_DIR = "~/project/development/cola/inst/extdata"

# == title
# Generate the HTML code for the JavaScript tabs.
#
# == details
# The jQuery UI is used to generate html tabs (https://jqueryui.com/tabs/ ).
#
# ``knitr_insert_tabs`` should be used after several callings of `knitr_add_tab_item`
# to generate a complete HTML fragment for all tabs with all necessary Javascript and css code.
#
# This function is only for internal use.
#
# == value
# No value is returned.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
knitr_insert_tabs = function() {
	KNITR_TAB_ENV$current_div_index = KNITR_TAB_ENV$current_div_index + 1

	if(!KNITR_TAB_ENV$css_added) {
		css = paste(readLines(paste0(TEMPLATE_DIR, "/jquery-ui.css")), collapse = "\n")
		# remove comments
		css = gsub("\\/\\*.*?\\*\\/", '', css)
		cat("\n<style type='text/css'>\n")
		cat(css, "\n")
		cat("</style>\n")
		cat("<script src='js/jquery-1.12.4.js'></script>\n")
		cat("<script src='js/jquery-ui.js'></script>\n")
	}
	qqcat("
<script>
$( function() {
	$( '#tabs@{KNITR_TAB_ENV$current_div_index}' ).tabs();
} );
</script>
")
	qqcat("<div id='tabs@{KNITR_TAB_ENV$current_div_index}'>\n")
	cat("<ul>\n")
	qqcat("<li><a href='#tab-@{KNITR_TAB_ENV$random_str}-@{seq_len(KNITR_TAB_ENV$current_tab_index)}'>@{KNITR_TAB_ENV$header}</a></li>\n")
	cat("</ul>\n")
	cat(KNITR_TAB_ENV$current_html)
	cat("</div>\n")

	KNITR_TAB_ENV$current_tab_index = 0
	KNITR_TAB_ENV$header = NULL
	KNITR_TAB_ENV$current_html = ""
	KNITR_TAB_ENV$random_str = round(runif(1, min = 1, max = 1e8))
	KNITR_TAB_ENV$css_added = TRUE
	
	return(invisible(NULL))
}

# == title
# Make report for the ConsensusPartitionList object
#
# == param
# -object a `ConsensusPartitionList-class` object.
# -output_dir the output directory where the report is put.
# -env where the objects in the report are found, internally used.
#
# == details
# The `ConsensusPartitionList-class` object contains results for all top-value methods and all partition methods.
# This function generates a HTML report which contains all plots for every combination
# of top-value method and partition method. The report generation may take a while.
#
# == value
# No value is returned.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
# == example
# \dontrun{
# data(cola_rl)
# cola_report(cola_rl[c("sd", "MAD"), c("hclust", "skmeans")], output_dir = "~/test")
# }
setMethod(f = "cola_report",
	signature = "ConsensusPartitionList",
	definition = function(object, output_dir = getwd(), env = parent.frame()) {

	var_name = deparse(substitute(object, env = env))
	make_report(var_name, object, output_dir, class = "ConsensusPartitionList")

})


# == title
# Make report for the ConsensusPartition object
#
# == param
# -object a `ConsensusPartition-class` object.
# -output_dir the output directory where the report is put.
#
# == details
# Please generate report on the `ConsensusPartitionList-class` object directly.
#
# If you want to make report only for one single method, you can subset the 
# `ConsensusPartitionList-class` object and then call ``cola_report``, e.g.
#
#     cola_report(res_list["sd", "hclust"], output_dir = ...)
#
#
# == value
# No value is returned.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
setMethod(f = "cola_report",
	signature = "ConsensusPartition",
	definition = function(object, output_dir) {

	qqcat("Please call `cola_report()` on `ConsensusPartitionList` object directly.\n")
	return(invisible(NULL))
})


# == title
# Make report for the HierarchicalPartition object
#
# == param
# -object a `HierarchicalPartition-class` object.
# -output_dir the output directory where the report is put.
# -env where the objects in the report are found, internally used.
#
# == details
# This function generates a HTML report which contains all plots for all nodes
# in the partition hierarchy.
#
# == value
# No value is returned.
#
# == author
# Zuguang Gu <z.gu@dkfz.de>
#
# == example
# \dontrun{
# data(cola_rh)
# cola_report(cola_rh, output_dir = "~/test2")
# }
setMethod(f = "cola_report",
	signature = "HierarchicalPartition",
	definition = function(object, output_dir, env = parent.frame()) {

	if(nrow(object@hierarchy) == 1) {
		cat("No hierarchy detected, won't generate the report.\n")
		return(invisible(NULL))
	}
	var_name = deparse(substitute(object, env = env))
	make_report(var_name, object, output_dir, class = "HierarchicalPartition")

})


make_report = function(var_name, object, output_dir, class) {

	.t1 = Sys.time()
	template_file = c("HierarchicalPartition" = "cola_hc_template.Rmd-template",
		              "ConsensusPartitionList" = "cola_report_template.Rmd-template")
	html_file = c("HierarchicalPartition" = "cola_hc.html",
		          "ConsensusPartitionList" = "cola_report.html")

	cola_opt$raster_resize = TRUE

	od = getOption("digits")
	wd = getwd()
	on.exit({
		options(digits = od)
		setwd(wd)
		if(!is.null(.ENV$TEMP_DIR)) {
			unlink(.ENV$TEMP_DIR, recursive = TRUE, force = TRUE)
			.ENV$TEMP_DIR = NULL
		}
		cola_opt$raster_resize = FALSE
	})

	options(digits = 3)
	
	report_template = paste0(TEMPLATE_DIR, "/", template_file[class])

	dir.create(output_dir, recursive = TRUE, showWarnings = FALSE)
	output_dir = normalizePath(output_dir, mustWork = FALSE)

	if(file.exists(output_dir)) {
		fileinfo = file.info(output_dir)
		if(!fileinfo$isdir) {
			output_dir = dirname(output_dir)
		}
	}

	message(qq("* generating cola report for `@{var_name}` (a @{class} object)"))
	message(qq("* the report is available at @{output_dir}/"))

	if(dir.exists(paste0(output_dir, "/figure_cola"))) {
		fl = list.files(paste0(output_dir, "/figure_cola"), pattern = "\\.png$", full.names = TRUE)
		if(length(fl)) {
			message(qq("* removing @{length(fl)} figures which were generated by previous report"))
			file.remove(fl)
		}
	}

	temp_dir = paste0(output_dir, "/_cola_temp")
	if(file.exists(temp_dir)) {
		fl = list.files(temp_dir, full.names = TRUE)
		if(length(fl)) {
			message(qq("* removing @{length(fl)} figures in the temp dir."))
			file.remove(fl)
		}
	}
	dir.create(temp_dir, showWarnings = FALSE)
	.ENV$TEMP_DIR = temp_dir

	message("* generating R markdown file based on template report")
	tempfile = tempfile(tmpdir = output_dir, pattern = "cola_", fileext = ".Rmd")
	brew(report_template, output = tempfile)
	op = getOption("markdown.HTML.options")
	options(markdown.HTML.options = setdiff(op, "base64_images"))
	md_file = gsub("Rmd$", "md", tempfile)
	owd = getwd()
	setwd(output_dir)
	message("* rendering R markdown file to html by knitr")
	knit(tempfile, md_file, quiet = TRUE)
	markdownToHTML(md_file, paste0(output_dir, "/", html_file[class]))
	options(markdown.HTML.options = op)
	setwd(owd)

	dir.create(paste0(output_dir, "/js"), showWarnings = FALSE)
	file.copy(paste0(TEMPLATE_DIR, "/jquery-ui.js"), paste0(output_dir, "/js/"))
	file.copy(paste0(TEMPLATE_DIR, "/jquery-1.12.4.js"), paste0(output_dir, "/js/"))

	message("* removing temporary files")
	file.remove(c(tempfile, md_file))

	message(qq("* report is at @{output_dir}/@{html_file[class]}"))

	KNITR_TAB_ENV$current_tab_index = 0
	KNITR_TAB_ENV$current_div_index = 0
	KNITR_TAB_ENV$header = NULL
	KNITR_TAB_ENV$current_html = ""
	KNITR_TAB_ENV$random_str = round(runif(1, min = 1, max = 1e8))
	KNITR_TAB_ENV$css_added = FALSE

	.t2 = Sys.time()

	message(qq("* In total, the report uses @{gsub('^ +', '', format(.t2 - .t1))}."))

	return(invisible(NULL))
}