R/shiny.R

In jokergoo/simplifyEnrichment: Simplify Functional Enrichment Results

#' Interactively visualize the similarity heatmap
#'
#' @param mat A similarity matrix.
#' @param cl Cluster labels inferred from the similarity matrix, e.g. from [`cluster_terms()`] or [`binary_cut()`].
#' @return A shiny application.
#' @export
#' @import GO.db
#' @examples
#' if(interactive()) {
#'     mat = readRDS(system.file("extdata", "random_GO_BP_sim_mat.rds", 
#'         package = "simplifyEnrichment"))
#'     cl = binary_cut(mat)
#'     export_to_shiny_app(mat, cl)
#' }
export_to_shiny_app = function(mat, cl = binary_cut(mat)) {

	check_pkg("shiny")
	check_pkg("shinydashboard")
	check_pkg("InteractiveComplexHeatmap", bioc = TRUE)

	if(!all(is_GO_id(sample(rownames(mat), min(10, nrow(mat)))))) {
		is_GO = FALSE
	} else {
		is_GO = TRUE
	}

	get_go_term = function(go_id) {
	    term = suppressMessages(AnnotationDbi::select(GO.db, keys = go_id, columns = "TERM")$TERM)
	    term[is.na(term)] = "NA"
	    term
	}

	version = packageDescription('simplifyEnrichment', fields = "Version")

	body = shinydashboard::dashboardBody(
		shiny::div(
			shiny::htmlOutput("summary"),
			shiny::p(shiny::HTML("You can click on the similarity heatmap or select an area from it. If you cannot precisely select a cluster from the heatmap, you can manually remove extra rows and columns from the selected sub-heatmap with the tool <i>'Configure sub-heatmap'</i> (the first icon) under the sub-heatmap in <i>'Sub-Heatmap'</i> panel.")),
			style = "border: 1px solid #3c8dbc; border-radius: 3px; padding: 10px; font-size: 1.2em; margin-bottom: 10px; background-color: white;"
	    ),
	    shiny::fluidRow(
	        shiny::column(width = ifelse(is_GO, 6, 4),
	            shinydashboard::box(title = qq("@{ifelse(is_GO, 'GO', 'Functional term')} similarity heatmap"), width = NULL, solidHeader = TRUE, status = "primary",
	                InteractiveComplexHeatmap::originalHeatmapOutput("ht", width = ifelse(is_GO, 700, 500), height = 450, containment = TRUE)
	            )
	        ),
	        shiny::column(width = 4,
	            shinydashboard::box(title = "Sub-heatmap", width = NULL, solidHeader = TRUE, status = "primary",
	                InteractiveComplexHeatmap::subHeatmapOutput("ht", title = NULL, containment = TRUE)
	            ),
	            shinydashboard::box(title = "Output", width = NULL, solidHeader = TRUE, status = "primary",
	                InteractiveComplexHeatmap::HeatmapInfoOutput("ht", title = NULL, width = "100%")
	            ),
	            if(is_GO) {
		            shinydashboard::box(title = "GO description", width = NULL, solidHeader = TRUE, status = "primary",
		                shiny::uiOutput("go_desc")
		            )
		        } else {
		        	NULL
		        }
	        )
	    ),
	    shiny::hr(style="border-top: 1px solid #3c8dbc"),
	    shiny::p(shiny::HTML(qq("Generated by <a href=\"https://github.com/jokergoo/simplifyEnrichment\" target=\"_blank\">simplifyEnrichment</a> version @{version}")))
	)

	sidebar = shinydashboard::dashboardSidebar(
		shiny::numericInput("min_term", "Min #terms to form a cluster:", value = round(nrow(mat)*0.01), min = 1),
		shiny::radioButtons("order_by_size", "Order by size?", choices = c("yes" = 1, "no" = 2), inline = TRUE),
		if(is_GO) shiny::textInput("exclude_words", "Exclude words:", placeholder = "Multiple words separate by \",\"") else NULL,
		if(is_GO) shiny::numericInput("max_words", "Max #words on each cloud:", value = 10, min = 1) else NULL,
		shiny::actionButton("update", "Update heatmap"),
		shiny::tags$style(shiny::HTML("
            .left-side, .main-sidebar {
                padding-top:15px;
            }
        "))
	)

	ui = shinydashboard::dashboardPage(
		title = "simplifyEnrichment Shiny app",
	    shinydashboard::dashboardHeader(disable = TRUE),
	    sidebar,
	    body
	)

	e = new.env(parent = emptyenv())
	if(is_GO) {
		click_action = function(df, output) {
			col_fun = e$col_fun
		    output[["go_desc"]] = shiny::renderUI({
		        if(!is.null(df)) {
		            go_id1 = rownames(mat)[df$row_index]
		            go_id2 = colnames(mat)[df$column_index]

		            oe = try(term1 <- get_go_term(go_id1), silent = TRUE)
	            if(inherits(oe, "try-error")) {
	                term1 = ""
	            }
	            oe = try(term2 <- get_go_term(go_id2), silent = TRUE)
	            if(inherits(oe, "try-error")) {
	                term2 = ""
	            }

	            v = mat[go_id1, go_id2]
	            col = col_fun(v)

	            shiny::HTML(qq(
"<b>GO similarity</b>
<p>@{sprintf('%.3f', v)}  <span style='background-color:@{col};width=10px;'>&nbsp;&nbsp;&nbsp;&nbsp;</span></p>
<b>Row GO ID</b>
<p><a href='http://amigo.geneontology.org/amigo/term/@{go_id1}' target='_blank'>@{go_id1}</a>: @{term1}</p>
<b>Column GO ID</b>
<p><a href='http://amigo.geneontology.org/amigo/term/@{go_id2}' target='_blank'>@{go_id2}</a>: @{term2}</p>
"))
		        }
		    })
		}

		brush_action = function(df, output) {
		    output[["go_desc"]] = shiny::renderUI({
		        if(!is.null(df)) {
		            row_index = unique(unlist(df$row_index))
		            column_index = unique(unlist(df$column_index))
		            go_id1 = rownames(mat)[row_index]
		            go_id2 = colnames(mat)[column_index]
	           		go_id = union(go_id1, go_id2)

		            go_text = qq("<p><a href='http://amigo.geneontology.org/amigo/term/@{go_id}' target='_blank'>@{go_id}</a>: @{get_go_term(go_id)}</p>\n")
		            shiny::HTML(qq(
"<b>A list of @{length(go_id)} GO IDs</b>
@{go_text}"))
		        }
		    })
		}
	} else {
		click_action = NULL
		brush_action = NULL
	}

	server = function(input, output, session) {

		shiny::observeEvent(input$update, {

			min_term = input$min_term
			order_by_size = ifelse(input$order_by_size == "1", TRUE, FALSE)
			if(is_GO) {
				exclude_words = tolower(strsplit(input$exclude_words, "\\s*,\\s*")[[1]])
				max_words = input$max_words
			} else {
				exclude_words = character(0)
				max_words = 10
			}

			ht = ht_clusters(mat, cl, word_cloud_grob_param = list(max_width = 80), 
				min_term = min_term, order_by_size = order_by_size,
				exclude_words = exclude_words, max_words = max_words, run_draw = FALSE) + NULL
			
			e$col_fun = ht@ht_list[[1]]@matrix_color_mapping@col_fun
			n = nrow(mat)
			tb = table(cl)
			ng = length(tb)
			ng_small = sum(tb < min_term)

			output$summary = shiny::renderUI({
				shiny::p(shiny::HTML(qq("This Shiny app visualizes a similarity matrix with <b>@{nrow(mat)}</b> @{ifelse(is_GO, 'GO', 'functional')} terms. The terms are partitioned into <b>@{ng - ng_small}</b> large clusters (size &#8805;  @{min_term}, those with word cloud annotations) and <b>@{ng_small}</b> small clusters (size < @{min_term}).")))
			})

		    InteractiveComplexHeatmap::makeInteractiveComplexHeatmap(input, output, session, ht,
		        click_action = click_action, brush_action = brush_action)
		}, ignoreNULL = FALSE)
	}

	shiny::shinyApp(ui, server)
}