From 4c9331cadfd47d5875f6fa545020989bdd8a21ec Mon Sep 17 00:00:00 2001 From: Garrick Aden-Buie Date: Mon, 31 Dec 2018 12:43:03 -0500 Subject: [PATCH 1/8] Add script template and download script button --- global.R | 22 ++ server.R | 25 ++ template/epiTAD_script.template.R | 391 ++++++++++++++++++++++++++++++ ui.R | 3 +- 4 files changed, 440 insertions(+), 1 deletion(-) create mode 100644 template/epiTAD_script.template.R diff --git a/global.R b/global.R index 06cbe79..57ca34f 100644 --- a/global.R +++ b/global.R @@ -48,3 +48,25 @@ EXAMPLES <- list( input_id = NULL ) ) + +# Functions to render template script +epitad_input_prepare <- function(input, need_escaped = c("snpList", "pop", "tissue")) { + as_valid_r_code <- function(x, deparse_opts = c("keepNA", "keepInteger", "niceNames")) { + capture.output(dput(x, control = deparse_opts)) + } + for (inp in intersect(need_escaped, names(input))) { + if (is.null(input[[inp]])) input[[inp]] <- "" + input[[inp]] <- paste(as_valid_r_code(input[[inp]]), collapse = "") + } + input +} + +write_analysis_script <- function(file, inputs, char_or_vec_cols, template = "template/epiTAD_script.template.R") { + template <- paste(readLines(template), collapse = "\n") + + inputs$timestamp <- strftime(Sys.time(), "%F %T %Z", tz = "UTC") + + x <- whisker::whisker.render(template, data = epitad_input_prepare(inputs, char_or_vec_cols)) + writeLines(x, file) +} + diff --git a/server.R b/server.R index 10f1214..dd72935 100644 --- a/server.R +++ b/server.R @@ -620,6 +620,31 @@ function(input, output, session) { footer = modalButton("OK"), easyClose = TRUE)) }) + output$download_script <- downloadHandler( + filename = function() { + paste0("epiTAD_script_", Sys.Date(), ".R") + }, + content = function(file) { + input_names <- setNames(nm = names(input)) + inputs <- lapply(input_names, function(n) input[[n]]) + + # Inputs that are used in the template and match any of the following: + # - Are character strings + # - Are vectors of length > 1 + # need to be explicitly declared so that they can be properly rendered. + char_or_vec_cols <- c("snpList", "pop", "tissue", + paste0("oncoParameters", 1:4), "plotColor", + "parameters", "parameters2") + + write_analysis_script(file, inputs, char_or_vec_cols) + } + ) + + output$download_button_ui <- renderUI({ + req(dat(), snps()) + downloadButton("download_script", "R", class = "pull-right") + }) + observe({ req(r_trigger_queried()) r_trigger_queried() diff --git a/template/epiTAD_script.template.R b/template/epiTAD_script.template.R new file mode 100644 index 0000000..f12255f --- /dev/null +++ b/template/epiTAD_script.template.R @@ -0,0 +1,391 @@ + +# epiTAD ------------------------------------------------------------------ +# +# epiTAD Analysis Script +# Generated on {{timestamp}} +# +# Visit https://gerkelab.com/project/epiTAD for more information +# +# ------------------------------------------------------------------------- + + +# Load Required Packages -------------------------------------------------- +# Uses the pacman library to load or install packages as needed +if (!suppressPackageStartupMessages(require(pacman))) install.packages("pacman") +pacman::p_load(data.table, jsonlite, colorspace, + haploR, biomaRt, Sushi, HiTC) + + +# Parameters -------------------------------------------------------------- + +# snpList... (describe required structure) +snpList <- {{{snpList}}} +# value... +value <- {{{value}}} +# pop... +pop <- {{{pop}}} +# tissue... +tissue <- {{{tissue}}} + + +## Onco Table Parameters +## TODO These need more descriptive names +oncoParameters1 <- {{{oncoParameters1}}} +oncoParameters2 <- {{{oncoParameters2}}} +oncoParameters3 <- {{{oncoParameters3}}} +oncoParameters4 <- {{{oncoParameters4}}} + +## Other Table Parameters +## TODO: These need more descriptive names +parameters <- {{{parameters}}} +parameters2 <- {{{parameters2}}} + +## Plot Parameters +possible_colors <- c("topo", "rainbow", "heat", "terrain", "cm", + "viridis", "viridis rev", "magma", "magma rev", + "plasma", "plasma rev", "inferno", "inferno rev", + "cividis", "cividis rev") + +plotColor <- {{{plotColor}}} +# was values$tmp_min +plotStartBP <- {{{plotStartBP}}} +# was values$tmp_max +plotEndBP <- {{{plotEndBP}}} + + +# Download Needed Data ---------------------------------------------------- + +ensembl54 <- useMart("ensembl", dataset = "hsapiens_gene_ensembl") + +hic_file <- "hicData.Rdata" +if (!file.exists(hic_file)) { + download.file("https://github.com/GerkeLab/epiTAD/raw/master/data/hicData.Rdata", hic_file) +} + +tad <- fread("http://compbio.med.harvard.edu/modencode/webpage/hic/IMR90_domains_hg19.bed") +colnames(tad) <- c("chr", "start_position", "end_position") +tad$chr <- gsub("chr", "", tad$chr) +tad$chr <- as.numeric(tad$chr) +tad <- tad[!is.na(tad$chr), ] + +lad <- fread("http://compbio.med.harvard.edu/modencode/webpage/lad/human.fibroblast.DamID.hg19.bed") +colnames(lad) <- c("chr", "start", "end", "dunno") +lad$chr <- gsub("chr", "", lad$chr) +lad$chr <- as.numeric(lad$chr) +lad <- lad[!is.na(lad$chr), ] + + +# Prepare SNPs ------------------------------------------------------------ + +# reactive: dat +snps <- as.character(unlist(strsplit(snpList, ","))) +snps <- trimws(snps) +dat <- queryHaploreg(query = snps, ldThresh = value, ldPop = pop) +dat$chr <- as.numeric(as.character(dat$chr)) +dat$pos_hg38 <- as.numeric(as.character(dat$pos_hg38)) + + +# Choose Tissues ---------------------------------------------------------- + +etest <- unlist(strsplit(as.character(dat$eQTL), ";")) +etest <- etest[!etest %in% c(".")] +etest2 <- unlist(strsplit(etest, ",")) +if (length(etest2)) { + etest3 <- matrix(etest2, nrow = length(etest), ncol = 4, byrow = TRUE) + etest3 <- as.data.frame(etest3) + etest3 <- etest3[!duplicated(etest3$V2), ] + tissues_avail <- etest3$V2 + tissue_missing <- setdiff(tissue, tissues_avail) + if (length(tissue_missing)) { + warning("Ignoring eQTLs ", paste(tissue_missing, collapse = ", "), + " as these were not associated with the requested SNPs") + } + tissue <- intersect(tissue, tissues_avail) +} else { + message("No statistically significant eQTLs were reported with these SNPs.") +} + + +# Dat2 -------------------------------------------------------------------- +# TODO GAB: dat2 and associated function need more descriptive names +dat2_function <- function(snpList) { + snps <- as.character(unlist(strsplit(snpList, ","))) + snps <- trimws(snps) + x <- queryRegulome(query = snps) + if (nrow(x$res.table) < 1) { + stop("The queried SNP may not be valid. Please check your input.") + } + x <- as.data.frame(x$res.table) + x$score <- as.character(x$score) + x$score_anno <- NA + for (i in 1:nrow(x)) { + if (x$score[i] == "1a") { + x$score_anno[i] <- "eQTL + TF binding + matched TF motif + matched DNase Footprint + DNase peak" + } + else if (x$score[i] == "1b") { + x$score_anno[i] <- "eQTL + TF binding + any motif + DNase Footprint + DNase peak" + } + else if (x$score[i] == "1c") { + x$score_anno[i] <- "eQTL + TF binding + matched TF motif + DNase peak" + } + else if (x$score[i] == "1d") { + x$score_anno[i] <- "eQTL + TF binding + any motif + DNase peak" + } + else if (x$score[i] == "1e") { + x$score_anno[i] <- "eQTL + TF binding + matched TF motif" + } + else if (x$score[i] == "1f") { + x$score_anno[i] <- "eQTL + TF binding / DNase peak" + } + else if (x$score[i] == "2a") { + x$score_anno[i] <- "TF binding + matched TF motif + matched DNase Footprint + DNase peak" + } + else if (x$score[i] == "2b") { + x$score_anno[i] <- "TF binding + any motif + DNase Footprint + DNase peak" + } + else if (x$score[i] == "2c") { + x$score_anno[i] <- "TF binding + matched TF motif + DNase peak" + } + else if (x$score[i] == "3a") { + x$score_anno[i] <- "TF binding + any motif + DNase peak" + } + else if (x$score[i] == "3b") { + x$score_anno[i] <- "TF binding + matched TF motif" + } + else if (x$score[i] == "4") { + x$score_anno[i] <- "TF binding + DNase peak" + } + else if (x$score[i] == "5") { + x$score_anno[i] <- "TF binding or DNase peak" + } + else { + x$score_anno[i] <- "Other" + } + } + x +} + +dat2 <- dat2_function(snpList) +dat2 + + +# In TAD or LAD ----------------------------------------------------------- + +in_tad <- function(dat, snps, tad) { + dat <- dat[dat$rsID %in% snps, ] + snp_pos <- dat$pos_hg38 + tad <- tad[tad$chr == max(dat$chr, na.rm = TRUE), ] + tad[tad$start_position <= snp_pos & tad$end_position >= snp_pos, ] +} + +in_lad <- function(dat, sps, lad) { + dat <- dat[dat$rsID %in% snps, ] + snp_pos <- dat$pos_hg38 + lad[lad$chr == max(dat$chr, na.rm = TRUE), ] +} + +# TAD boundaries +tad_boundaries <- in_tad(dat, snps, tad) +if (nrow(tad_boundaries) < 1) { + message("Not in a TAD!") +} else { + message("In a TAD! The TAD ranges from ", tad_boundaries$start_position, " to ", tad_boundaries$end_position) +} + + +# eQTL table -------------------------------------------------------------- +# TODO better descriptions +# output$eTable1 <- +eqtl_table <- function(dat, tissue) { + etest <- unlist(strsplit(as.character(dat$eQTL), ";")) + etest <- etest[!etest %in% c(".")] + etest2 <- unlist(strsplit(etest, ",")) + + # Check inputs and that there are eQTLs for these SNPs + if (!length(etest2)) { + warning("No statistically significant eQTLs were reported with these SNPs.") + return(NULL) + } + + # Return table + etest3 <- matrix(etest2, nrow = length(etest), ncol = 4, byrow = TRUE) + etest3 <- as.data.frame(etest3) + colnames(etest3) <- c("Source", "Tissue", "Gene", "p") + etest3[etest3$Tissue %in% tissue, ] +} + +eqtl_table(dat, tissue) + + + +# Total Min and Max ------------------------------------------------------- + +total_min <- function(dat, snps, tad) { + tad <- in_tad(dat, snps, tad) + if (nrow(tad) >= 1) { + total_min <- min(c(min(dat$pos_hg38, na.rm = TRUE), tad$start_position)) + return(as.numeric(total_min)) + } + else if (nrow(tad) < 1 & nrow(dat) > 1) { + total_min <- min(dat$pos_hg38, na.rm = TRUE) + return(as.numeric(total_min)) + } + else { + total_min <- min(dat$pos_hg38, na.rm = TRUE) - 53500 + return(as.numeric(total_min)) + } +} + +total_max <- function(dat, snps, tad) { + tad <- in_tad(dat, snps, tad) + if (nrow(tad) >= 1) { + total_max <- max(c(max(dat$pos_hg38, na.rm = TRUE), tad$end_position)) + return(as.numeric(total_max)) + } + else if (nrow(tad) < 1 & nrow(dat) > 1) { + total_max <- max(dat$pos_hg38, na.rm = TRUE) + return(as.numeric(total_max)) + } + else { + total_max <- max(dat$pos_hg38, na.rm = TRUE) + 53500 + return(as.numeric(total_max)) + } +} + + +# Tables ------------------------------------------------------------------ + +#### LD Table 1 #### +dat[, c("rsID", parameters)] + + +#### LD Table 2 ##### +dat2[, c("rsid", parameters2)] + +#### Gene Table #### +chr <- max(dat$chr, na.rm = TRUE) +getBM( + attributes = c("hgnc_symbol", "start_position", "end_position"), + filters = c("chromosomal_region"), + values = paste0(chr, ":", total_min(dat, snps, tad), ":", total_max(dat, snps, tad)), + mart = ensembl54 +) + +#### oncoTable + +chr <- max(as.numeric(dat$chr), na.rm = TRUE) +oncotable_res <- fromJSON(paste0( + "http://portals.broadinstitute.org/oncotator/genes/", chr, "_", + total_min(dat, snps, tad), "_", total_max(dat, snps, tad), "/" +)) +if (!length(oncotable_res)) { + warning("Oncotator did not return valid results") +} else { + oncotable <- as.data.frame(oncotable_res[[1]]) + for (i in seq_along(oncotable_res)[-1]) { + oncotable_dat <- as.data.frame(oncotable_res[[i]]) + oncotable <- rbind(oncotable, oncotable_dat) + } + + oncotable_cols <- Reduce(union, c("gene", oncoParameters1, oncoParameters2, oncoParameters3, oncoParameters4)) + oncotable_cols <- oncotable_cols[!oncotable_cols == ""] + oncotable <- oncotable[, oncotable_cols, drop = FALSE] +} + +oncotable + + +# Plot -------------------------------------------------------------------- + +pick_plot_color <- function(plotColor) { + switch( + tolower(plotColor), + "topo" = topo.colors, + "rainbow" = rainbow, + "heat" = heat.colors, + "terrain" = terrain.colors, + "cm" = cm.colors, + "viridis" = viridisLite::viridis, + "viridis rev" = function(n, ...) viridisLite::viridis(n, direction = -1, ...), + "magma" = viridisLite::magma, + "magma rev" = function(n, ...) viridisLite::magma(n, direction = -1, ...), + "plasma" = viridisLite::plasma, + "plasma rev" = function(n, ...) viridisLite::plasma(n, direction = -1, ...), + "inferno" = viridisLite::inferno, + "inferno rev" = function(n, ...) viridisLite::inferno(n, direction = -1, ...), + "cividis" = viridisLite::cividis, + "cividis rev" = function(n, ...) viridisLite::cividis(n, direction = -1, ...) + ) +} + + +megaplot <- function(ld, plot_color = pick_plot_color("topo"), + hic_file = "hicData.Rdata", + minBP = total_min(dat, snps, tad), + maxBP = total_max(dat, snps, tad)) { + if (!exists("hiC")) load(hic_file) + + chrX <- max(ld$chr, na.rm = TRUE) + + hic_dat <- extractRegion(hiC[[paste0("chr", chrX, "chr", chrX)]], + chr = paste0("chr", chrX), + from = minBP, to = maxBP + ) + hic_matrix <- as.matrix(intdata(hic_dat)) + + genes <- getBM( + attributes = c("hgnc_symbol", "start_position", "end_position"), + filters = c("chromosomal_region"), values = paste0(chrX, ":", minBP, ":", maxBP), mart = ensembl54 + ) + colnames(genes) <- c("Symbol", "Start", "End") + + tads <- as.data.frame(tads_imr90) + + + # Create Plot ----------------------------------------------------------- + + mat_layout <- matrix(c(1, 2, 3, 4, 1, 2, 3, 4), nrow = 4, ncol = 2) + layout(mat_layout, c(4, 4, 4, 4), c(2.25, 1.25, 0.5, 0.5)) + par(mar = c(0.5, 4.5, 0.5, 0.5)) + + phic <- plotHic(hic_matrix, + chrom = paste0("chr", chrX), + chromstart = min(as.numeric(colnames(hic_matrix))), + chromend = max(as.numeric(colnames(hic_matrix))), + max_y = 20, zrange = c(0, 28), + palette = plot_color, + flip = FALSE + ) + labelgenome( + chrom = paste0("chr", chrX), chromstart = minBP, chromend = maxBP, + side = 1, scipen = 40, n = 1, scale = "bp" + ) + addlegend(phic[[1]], + palette = phic[[2]], title = "score", side = "right", bottominset = 0.4, + topinset = 0, xoffset = -.035, labelside = "left", width = 0.025, title.offset = 0.035 + ) + mtext("HIC Intensities", side = 2, line = 1.75, cex = .75, font = 2) + + plot(c(1, 1), xlim = c(minBP, maxBP), ylim = c(0, 1), type = "n", bty = "n", xaxt = "n", yaxt = "n", ylab = "", xlab = "", xaxs = "i") + segments(x0 = genes$Start, y0 = 0.5, x1 = genes$End, y1 = 0.5, lwd = 30, col = plot_color(n = nrow(genes), alpha = 0.7), lend = 1) + text(x = (genes$Start + genes$End) / 2, y = c(0.7, 0.3, 0.8, 0.2), labels = genes$Symbol, col = plot_color(n = nrow(genes), alpha = 0.7)) + mtext("Genes", side = 2, line = 1.75, cex = .75, font = 2) + + plot(c(1, 1), xlim = c(minBP, maxBP), ylim = c(0, 1), type = "n", bty = "n", xaxt = "n", yaxt = "n", ylab = "", xlab = "", xaxs = "i") + abline(v = ld[ld$is_query_snp == 0, ]$pos_hg38, col = "grey", lend = 1) # lwd=6 + abline(v = ld[ld$is_query_snp == 1, ]$pos_hg38, col = plot_color(n = nrow(genes), alpha = 0.7), lend = 1) + mtext("LD", side = 2, line = 1.75, cex = .75, font = 2) + + plot(c(1, 1), xlim = c(minBP, maxBP), ylim = c(0, 1), type = "n", bty = "n", xaxt = "n", yaxt = "n", ylab = "", xlab = "", xaxs = "i") + segments( + x0 = tads[tads$seqnames == paste0("chr", chrX), ]$start, + y0 = 0.5, + x1 = tads[tads$seqnames == paste0("chr", chrX), ]$end, + y1 = 0.5, lwd = 30, + col = plot_color(n = nrow(genes), alpha = 0.7), + lend = 1 + ) + mtext("TADs", side = 2, line = 1.75, cex = .75, font = 2) +} + +megaplot(dat, pick_plot_color(plotColor)) diff --git a/ui.R b/ui.R index feaa863..2434b20 100644 --- a/ui.R +++ b/ui.R @@ -187,7 +187,8 @@ function(request) { actionButton("btn_info", "", icon = icon("info"), "data-toggle" = "tooltip", "data-placement" = "right", title = "Learn more about epiTAD"), - bookmarkButton(class = "pull-right") + bookmarkButton(class = "pull-right"), + uiOutput("download_button_ui") ) ), tabBox( From 078fbfa1ef6adbae9df7a5c8fbb0c1fed9ae53e9 Mon Sep 17 00:00:00 2001 From: Garrick Aden-Buie Date: Mon, 31 Dec 2018 17:53:43 +0000 Subject: [PATCH 2/8] Refactor regulome score annotation recoding --- server.R | 125 +++++++----------------------- template/epiTAD_script.template.R | 2 +- 2 files changed, 27 insertions(+), 100 deletions(-) diff --git a/server.R b/server.R index dd72935..29ff848 100644 --- a/server.R +++ b/server.R @@ -103,113 +103,40 @@ function(input, output, session) { }) dat2 <- eventReactive(input$update1, { + regulome_recode <- c( + "1a" = "eQTL + TF binding + matched TF motif + matched DNase Footprint + DNase peak", + "1b" = "eQTL + TF binding + any motif + DNase Footprint + DNase peak", + "1c" = "eQTL + TF binding + matched TF motif + DNase peak", + "1d" = "eQTL + TF binding + any motif + DNase peak", + "1e" = "eQTL + TF binding + matched TF motif", + "1f" = "eQTL + TF binding / DNase peak", + "2a" = "TF binding + matched TF motif + matched DNase Footprint + DNase peak", + "2b" = "TF binding + any motif + DNase Footprint + DNase peak", + "2c" = "TF binding + matched TF motif + DNase peak", + "3a" = "TF binding + any motif + DNase peak", + "3b" = "TF binding + matched TF motif", + "4" = "TF binding + DNase peak", + "5" = "TF binding or DNase peak" + ) + if (input$snpList == "") { dat <- sample() snps <- dat[, 1] x <- queryRegulome(query = snps) - x <- as.data.frame(x$res.table) - x$score <- as.character(x$score) - x$score_anno <- NA - for (i in nrow(x)) { - if (x$score[i] == "1a") { - x$score_anno[i] <- "eQTL + TF binding + matched TF motif + matched DNase Footprint + DNase peak" - } - else if (x$score[i] == "1b") { - x$score_anno[i] <- "eQTL + TF binding + any motif + DNase Footprint + DNase peak" - } - else if (x$score[i] == "1c") { - x$score_anno[i] <- "eQTL + TF binding + matched TF motif + DNase peak" - } - else if (x$score[i] == "1d") { - x$score_anno[i] <- "eQTL + TF binding + any motif + DNase peak" - } - else if (x$score[i] == "1e") { - x$score_anno[i] <- "eQTL + TF binding + matched TF motif" - } - else if (x$score[i] == "1f") { - x$score_anno[i] <- "eQTL + TF binding / DNase peak" - } - else if (x$score[i] == "2a") { - x$score_anno[i] <- "TF binding + matched TF motif + matched DNase Footprint + DNase peak" - } - else if (x$score[i] == "2b") { - x$score_anno[i] <- "TF binding + any motif + DNase Footprint + DNase peak" - } - else if (x$score[i] == "2c") { - x$score_anno[i] <- "TF binding + matched TF motif + DNase peak" - } - else if (x$score[i] == "3a") { - x$score_anno[i] <- "TF binding + any motif + DNase peak" - } - else if (x$score[i] == "3b") { - x$score_anno[i] <- "TF binding + matched TF motif" - } - else if (x$score[i] == "4") { - x$score_anno[i] <- "TF binding + DNase peak" - } - else if (x$score[i] == "5") { - x$score_anno[i] <- "TF binding or DNase peak" - } - else { - x$score_anno[i] <- "Other" - } - } - return(x) - } - if (input$snpList != "") { + } else { snps <- as.character(unlist(strsplit(input$snpList, ","))) snps <- trimws(snps) x <- queryRegulome(query = snps) - shiny::validate(need(nrow(x$res.table) > 0, SNP_QUERY_ERROR)) - x <- as.data.frame(x$res.table) - x$score <- as.character(x$score) - x$score_anno <- NA - for (i in 1:nrow(x)) { - if (x$score[i] == "1a") { - x$score_anno[i] <- "eQTL + TF binding + matched TF motif + matched DNase Footprint + DNase peak" - } - else if (x$score[i] == "1b") { - x$score_anno[i] <- "eQTL + TF binding + any motif + DNase Footprint + DNase peak" - } - else if (x$score[i] == "1c") { - x$score_anno[i] <- "eQTL + TF binding + matched TF motif + DNase peak" - } - else if (x$score[i] == "1d") { - x$score_anno[i] <- "eQTL + TF binding + any motif + DNase peak" - } - else if (x$score[i] == "1e") { - x$score_anno[i] <- "eQTL + TF binding + matched TF motif" - } - else if (x$score[i] == "1f") { - x$score_anno[i] <- "eQTL + TF binding / DNase peak" - } - else if (x$score[i] == "2a") { - x$score_anno[i] <- "TF binding + matched TF motif + matched DNase Footprint + DNase peak" - } - else if (x$score[i] == "2b") { - x$score_anno[i] <- "TF binding + any motif + DNase Footprint + DNase peak" - } - else if (x$score[i] == "2c") { - x$score_anno[i] <- "TF binding + matched TF motif + DNase peak" - } - else if (x$score[i] == "3a") { - x$score_anno[i] <- "TF binding + any motif + DNase peak" - } - else if (x$score[i] == "3b") { - x$score_anno[i] <- "TF binding + matched TF motif" - } - else if (x$score[i] == "4") { - x$score_anno[i] <- "TF binding + DNase peak" - } - else if (x$score[i] == "5") { - x$score_anno[i] <- "TF binding or DNase peak" - } - else { - x$score_anno[i] <- "Other" - } - } - return(x) } + + shiny::validate(need(nrow(x$res.table) > 0, SNP_QUERY_ERROR)) + x <- as.data.frame(x$res.table) + x$score <- as.character(x$score) + x$score_anno <- ifelse(x$score %in% names(regulome_recode), + regulome_recode[x$score], + "Other") + + x }) snps <- eventReactive(input$update1, { diff --git a/template/epiTAD_script.template.R b/template/epiTAD_script.template.R index f12255f..5094efa 100644 --- a/template/epiTAD_script.template.R +++ b/template/epiTAD_script.template.R @@ -107,7 +107,7 @@ if (length(etest2)) { # Dat2 -------------------------------------------------------------------- -# TODO GAB: dat2 and associated function need more descriptive names +# TODO: dat2 and associated function need more descriptive names dat2_function <- function(snpList) { snps <- as.character(unlist(strsplit(snpList, ","))) snps <- trimws(snps) From 1d117bbf647fcc3bdb80db3afb8e203e9e6d277c Mon Sep 17 00:00:00 2001 From: Garrick Aden-Buie Date: Mon, 31 Dec 2018 12:43:03 -0500 Subject: [PATCH 3/8] Add script template and download script button --- global.R | 22 ++ server.R | 25 ++ template/epiTAD_script.template.R | 391 ++++++++++++++++++++++++++++++ ui.R | 3 +- 4 files changed, 440 insertions(+), 1 deletion(-) create mode 100644 template/epiTAD_script.template.R diff --git a/global.R b/global.R index 06cbe79..57ca34f 100644 --- a/global.R +++ b/global.R @@ -48,3 +48,25 @@ EXAMPLES <- list( input_id = NULL ) ) + +# Functions to render template script +epitad_input_prepare <- function(input, need_escaped = c("snpList", "pop", "tissue")) { + as_valid_r_code <- function(x, deparse_opts = c("keepNA", "keepInteger", "niceNames")) { + capture.output(dput(x, control = deparse_opts)) + } + for (inp in intersect(need_escaped, names(input))) { + if (is.null(input[[inp]])) input[[inp]] <- "" + input[[inp]] <- paste(as_valid_r_code(input[[inp]]), collapse = "") + } + input +} + +write_analysis_script <- function(file, inputs, char_or_vec_cols, template = "template/epiTAD_script.template.R") { + template <- paste(readLines(template), collapse = "\n") + + inputs$timestamp <- strftime(Sys.time(), "%F %T %Z", tz = "UTC") + + x <- whisker::whisker.render(template, data = epitad_input_prepare(inputs, char_or_vec_cols)) + writeLines(x, file) +} + diff --git a/server.R b/server.R index 10f1214..dd72935 100644 --- a/server.R +++ b/server.R @@ -620,6 +620,31 @@ function(input, output, session) { footer = modalButton("OK"), easyClose = TRUE)) }) + output$download_script <- downloadHandler( + filename = function() { + paste0("epiTAD_script_", Sys.Date(), ".R") + }, + content = function(file) { + input_names <- setNames(nm = names(input)) + inputs <- lapply(input_names, function(n) input[[n]]) + + # Inputs that are used in the template and match any of the following: + # - Are character strings + # - Are vectors of length > 1 + # need to be explicitly declared so that they can be properly rendered. + char_or_vec_cols <- c("snpList", "pop", "tissue", + paste0("oncoParameters", 1:4), "plotColor", + "parameters", "parameters2") + + write_analysis_script(file, inputs, char_or_vec_cols) + } + ) + + output$download_button_ui <- renderUI({ + req(dat(), snps()) + downloadButton("download_script", "R", class = "pull-right") + }) + observe({ req(r_trigger_queried()) r_trigger_queried() diff --git a/template/epiTAD_script.template.R b/template/epiTAD_script.template.R new file mode 100644 index 0000000..f12255f --- /dev/null +++ b/template/epiTAD_script.template.R @@ -0,0 +1,391 @@ + +# epiTAD ------------------------------------------------------------------ +# +# epiTAD Analysis Script +# Generated on {{timestamp}} +# +# Visit https://gerkelab.com/project/epiTAD for more information +# +# ------------------------------------------------------------------------- + + +# Load Required Packages -------------------------------------------------- +# Uses the pacman library to load or install packages as needed +if (!suppressPackageStartupMessages(require(pacman))) install.packages("pacman") +pacman::p_load(data.table, jsonlite, colorspace, + haploR, biomaRt, Sushi, HiTC) + + +# Parameters -------------------------------------------------------------- + +# snpList... (describe required structure) +snpList <- {{{snpList}}} +# value... +value <- {{{value}}} +# pop... +pop <- {{{pop}}} +# tissue... +tissue <- {{{tissue}}} + + +## Onco Table Parameters +## TODO These need more descriptive names +oncoParameters1 <- {{{oncoParameters1}}} +oncoParameters2 <- {{{oncoParameters2}}} +oncoParameters3 <- {{{oncoParameters3}}} +oncoParameters4 <- {{{oncoParameters4}}} + +## Other Table Parameters +## TODO: These need more descriptive names +parameters <- {{{parameters}}} +parameters2 <- {{{parameters2}}} + +## Plot Parameters +possible_colors <- c("topo", "rainbow", "heat", "terrain", "cm", + "viridis", "viridis rev", "magma", "magma rev", + "plasma", "plasma rev", "inferno", "inferno rev", + "cividis", "cividis rev") + +plotColor <- {{{plotColor}}} +# was values$tmp_min +plotStartBP <- {{{plotStartBP}}} +# was values$tmp_max +plotEndBP <- {{{plotEndBP}}} + + +# Download Needed Data ---------------------------------------------------- + +ensembl54 <- useMart("ensembl", dataset = "hsapiens_gene_ensembl") + +hic_file <- "hicData.Rdata" +if (!file.exists(hic_file)) { + download.file("https://github.com/GerkeLab/epiTAD/raw/master/data/hicData.Rdata", hic_file) +} + +tad <- fread("http://compbio.med.harvard.edu/modencode/webpage/hic/IMR90_domains_hg19.bed") +colnames(tad) <- c("chr", "start_position", "end_position") +tad$chr <- gsub("chr", "", tad$chr) +tad$chr <- as.numeric(tad$chr) +tad <- tad[!is.na(tad$chr), ] + +lad <- fread("http://compbio.med.harvard.edu/modencode/webpage/lad/human.fibroblast.DamID.hg19.bed") +colnames(lad) <- c("chr", "start", "end", "dunno") +lad$chr <- gsub("chr", "", lad$chr) +lad$chr <- as.numeric(lad$chr) +lad <- lad[!is.na(lad$chr), ] + + +# Prepare SNPs ------------------------------------------------------------ + +# reactive: dat +snps <- as.character(unlist(strsplit(snpList, ","))) +snps <- trimws(snps) +dat <- queryHaploreg(query = snps, ldThresh = value, ldPop = pop) +dat$chr <- as.numeric(as.character(dat$chr)) +dat$pos_hg38 <- as.numeric(as.character(dat$pos_hg38)) + + +# Choose Tissues ---------------------------------------------------------- + +etest <- unlist(strsplit(as.character(dat$eQTL), ";")) +etest <- etest[!etest %in% c(".")] +etest2 <- unlist(strsplit(etest, ",")) +if (length(etest2)) { + etest3 <- matrix(etest2, nrow = length(etest), ncol = 4, byrow = TRUE) + etest3 <- as.data.frame(etest3) + etest3 <- etest3[!duplicated(etest3$V2), ] + tissues_avail <- etest3$V2 + tissue_missing <- setdiff(tissue, tissues_avail) + if (length(tissue_missing)) { + warning("Ignoring eQTLs ", paste(tissue_missing, collapse = ", "), + " as these were not associated with the requested SNPs") + } + tissue <- intersect(tissue, tissues_avail) +} else { + message("No statistically significant eQTLs were reported with these SNPs.") +} + + +# Dat2 -------------------------------------------------------------------- +# TODO GAB: dat2 and associated function need more descriptive names +dat2_function <- function(snpList) { + snps <- as.character(unlist(strsplit(snpList, ","))) + snps <- trimws(snps) + x <- queryRegulome(query = snps) + if (nrow(x$res.table) < 1) { + stop("The queried SNP may not be valid. Please check your input.") + } + x <- as.data.frame(x$res.table) + x$score <- as.character(x$score) + x$score_anno <- NA + for (i in 1:nrow(x)) { + if (x$score[i] == "1a") { + x$score_anno[i] <- "eQTL + TF binding + matched TF motif + matched DNase Footprint + DNase peak" + } + else if (x$score[i] == "1b") { + x$score_anno[i] <- "eQTL + TF binding + any motif + DNase Footprint + DNase peak" + } + else if (x$score[i] == "1c") { + x$score_anno[i] <- "eQTL + TF binding + matched TF motif + DNase peak" + } + else if (x$score[i] == "1d") { + x$score_anno[i] <- "eQTL + TF binding + any motif + DNase peak" + } + else if (x$score[i] == "1e") { + x$score_anno[i] <- "eQTL + TF binding + matched TF motif" + } + else if (x$score[i] == "1f") { + x$score_anno[i] <- "eQTL + TF binding / DNase peak" + } + else if (x$score[i] == "2a") { + x$score_anno[i] <- "TF binding + matched TF motif + matched DNase Footprint + DNase peak" + } + else if (x$score[i] == "2b") { + x$score_anno[i] <- "TF binding + any motif + DNase Footprint + DNase peak" + } + else if (x$score[i] == "2c") { + x$score_anno[i] <- "TF binding + matched TF motif + DNase peak" + } + else if (x$score[i] == "3a") { + x$score_anno[i] <- "TF binding + any motif + DNase peak" + } + else if (x$score[i] == "3b") { + x$score_anno[i] <- "TF binding + matched TF motif" + } + else if (x$score[i] == "4") { + x$score_anno[i] <- "TF binding + DNase peak" + } + else if (x$score[i] == "5") { + x$score_anno[i] <- "TF binding or DNase peak" + } + else { + x$score_anno[i] <- "Other" + } + } + x +} + +dat2 <- dat2_function(snpList) +dat2 + + +# In TAD or LAD ----------------------------------------------------------- + +in_tad <- function(dat, snps, tad) { + dat <- dat[dat$rsID %in% snps, ] + snp_pos <- dat$pos_hg38 + tad <- tad[tad$chr == max(dat$chr, na.rm = TRUE), ] + tad[tad$start_position <= snp_pos & tad$end_position >= snp_pos, ] +} + +in_lad <- function(dat, sps, lad) { + dat <- dat[dat$rsID %in% snps, ] + snp_pos <- dat$pos_hg38 + lad[lad$chr == max(dat$chr, na.rm = TRUE), ] +} + +# TAD boundaries +tad_boundaries <- in_tad(dat, snps, tad) +if (nrow(tad_boundaries) < 1) { + message("Not in a TAD!") +} else { + message("In a TAD! The TAD ranges from ", tad_boundaries$start_position, " to ", tad_boundaries$end_position) +} + + +# eQTL table -------------------------------------------------------------- +# TODO better descriptions +# output$eTable1 <- +eqtl_table <- function(dat, tissue) { + etest <- unlist(strsplit(as.character(dat$eQTL), ";")) + etest <- etest[!etest %in% c(".")] + etest2 <- unlist(strsplit(etest, ",")) + + # Check inputs and that there are eQTLs for these SNPs + if (!length(etest2)) { + warning("No statistically significant eQTLs were reported with these SNPs.") + return(NULL) + } + + # Return table + etest3 <- matrix(etest2, nrow = length(etest), ncol = 4, byrow = TRUE) + etest3 <- as.data.frame(etest3) + colnames(etest3) <- c("Source", "Tissue", "Gene", "p") + etest3[etest3$Tissue %in% tissue, ] +} + +eqtl_table(dat, tissue) + + + +# Total Min and Max ------------------------------------------------------- + +total_min <- function(dat, snps, tad) { + tad <- in_tad(dat, snps, tad) + if (nrow(tad) >= 1) { + total_min <- min(c(min(dat$pos_hg38, na.rm = TRUE), tad$start_position)) + return(as.numeric(total_min)) + } + else if (nrow(tad) < 1 & nrow(dat) > 1) { + total_min <- min(dat$pos_hg38, na.rm = TRUE) + return(as.numeric(total_min)) + } + else { + total_min <- min(dat$pos_hg38, na.rm = TRUE) - 53500 + return(as.numeric(total_min)) + } +} + +total_max <- function(dat, snps, tad) { + tad <- in_tad(dat, snps, tad) + if (nrow(tad) >= 1) { + total_max <- max(c(max(dat$pos_hg38, na.rm = TRUE), tad$end_position)) + return(as.numeric(total_max)) + } + else if (nrow(tad) < 1 & nrow(dat) > 1) { + total_max <- max(dat$pos_hg38, na.rm = TRUE) + return(as.numeric(total_max)) + } + else { + total_max <- max(dat$pos_hg38, na.rm = TRUE) + 53500 + return(as.numeric(total_max)) + } +} + + +# Tables ------------------------------------------------------------------ + +#### LD Table 1 #### +dat[, c("rsID", parameters)] + + +#### LD Table 2 ##### +dat2[, c("rsid", parameters2)] + +#### Gene Table #### +chr <- max(dat$chr, na.rm = TRUE) +getBM( + attributes = c("hgnc_symbol", "start_position", "end_position"), + filters = c("chromosomal_region"), + values = paste0(chr, ":", total_min(dat, snps, tad), ":", total_max(dat, snps, tad)), + mart = ensembl54 +) + +#### oncoTable + +chr <- max(as.numeric(dat$chr), na.rm = TRUE) +oncotable_res <- fromJSON(paste0( + "http://portals.broadinstitute.org/oncotator/genes/", chr, "_", + total_min(dat, snps, tad), "_", total_max(dat, snps, tad), "/" +)) +if (!length(oncotable_res)) { + warning("Oncotator did not return valid results") +} else { + oncotable <- as.data.frame(oncotable_res[[1]]) + for (i in seq_along(oncotable_res)[-1]) { + oncotable_dat <- as.data.frame(oncotable_res[[i]]) + oncotable <- rbind(oncotable, oncotable_dat) + } + + oncotable_cols <- Reduce(union, c("gene", oncoParameters1, oncoParameters2, oncoParameters3, oncoParameters4)) + oncotable_cols <- oncotable_cols[!oncotable_cols == ""] + oncotable <- oncotable[, oncotable_cols, drop = FALSE] +} + +oncotable + + +# Plot -------------------------------------------------------------------- + +pick_plot_color <- function(plotColor) { + switch( + tolower(plotColor), + "topo" = topo.colors, + "rainbow" = rainbow, + "heat" = heat.colors, + "terrain" = terrain.colors, + "cm" = cm.colors, + "viridis" = viridisLite::viridis, + "viridis rev" = function(n, ...) viridisLite::viridis(n, direction = -1, ...), + "magma" = viridisLite::magma, + "magma rev" = function(n, ...) viridisLite::magma(n, direction = -1, ...), + "plasma" = viridisLite::plasma, + "plasma rev" = function(n, ...) viridisLite::plasma(n, direction = -1, ...), + "inferno" = viridisLite::inferno, + "inferno rev" = function(n, ...) viridisLite::inferno(n, direction = -1, ...), + "cividis" = viridisLite::cividis, + "cividis rev" = function(n, ...) viridisLite::cividis(n, direction = -1, ...) + ) +} + + +megaplot <- function(ld, plot_color = pick_plot_color("topo"), + hic_file = "hicData.Rdata", + minBP = total_min(dat, snps, tad), + maxBP = total_max(dat, snps, tad)) { + if (!exists("hiC")) load(hic_file) + + chrX <- max(ld$chr, na.rm = TRUE) + + hic_dat <- extractRegion(hiC[[paste0("chr", chrX, "chr", chrX)]], + chr = paste0("chr", chrX), + from = minBP, to = maxBP + ) + hic_matrix <- as.matrix(intdata(hic_dat)) + + genes <- getBM( + attributes = c("hgnc_symbol", "start_position", "end_position"), + filters = c("chromosomal_region"), values = paste0(chrX, ":", minBP, ":", maxBP), mart = ensembl54 + ) + colnames(genes) <- c("Symbol", "Start", "End") + + tads <- as.data.frame(tads_imr90) + + + # Create Plot ----------------------------------------------------------- + + mat_layout <- matrix(c(1, 2, 3, 4, 1, 2, 3, 4), nrow = 4, ncol = 2) + layout(mat_layout, c(4, 4, 4, 4), c(2.25, 1.25, 0.5, 0.5)) + par(mar = c(0.5, 4.5, 0.5, 0.5)) + + phic <- plotHic(hic_matrix, + chrom = paste0("chr", chrX), + chromstart = min(as.numeric(colnames(hic_matrix))), + chromend = max(as.numeric(colnames(hic_matrix))), + max_y = 20, zrange = c(0, 28), + palette = plot_color, + flip = FALSE + ) + labelgenome( + chrom = paste0("chr", chrX), chromstart = minBP, chromend = maxBP, + side = 1, scipen = 40, n = 1, scale = "bp" + ) + addlegend(phic[[1]], + palette = phic[[2]], title = "score", side = "right", bottominset = 0.4, + topinset = 0, xoffset = -.035, labelside = "left", width = 0.025, title.offset = 0.035 + ) + mtext("HIC Intensities", side = 2, line = 1.75, cex = .75, font = 2) + + plot(c(1, 1), xlim = c(minBP, maxBP), ylim = c(0, 1), type = "n", bty = "n", xaxt = "n", yaxt = "n", ylab = "", xlab = "", xaxs = "i") + segments(x0 = genes$Start, y0 = 0.5, x1 = genes$End, y1 = 0.5, lwd = 30, col = plot_color(n = nrow(genes), alpha = 0.7), lend = 1) + text(x = (genes$Start + genes$End) / 2, y = c(0.7, 0.3, 0.8, 0.2), labels = genes$Symbol, col = plot_color(n = nrow(genes), alpha = 0.7)) + mtext("Genes", side = 2, line = 1.75, cex = .75, font = 2) + + plot(c(1, 1), xlim = c(minBP, maxBP), ylim = c(0, 1), type = "n", bty = "n", xaxt = "n", yaxt = "n", ylab = "", xlab = "", xaxs = "i") + abline(v = ld[ld$is_query_snp == 0, ]$pos_hg38, col = "grey", lend = 1) # lwd=6 + abline(v = ld[ld$is_query_snp == 1, ]$pos_hg38, col = plot_color(n = nrow(genes), alpha = 0.7), lend = 1) + mtext("LD", side = 2, line = 1.75, cex = .75, font = 2) + + plot(c(1, 1), xlim = c(minBP, maxBP), ylim = c(0, 1), type = "n", bty = "n", xaxt = "n", yaxt = "n", ylab = "", xlab = "", xaxs = "i") + segments( + x0 = tads[tads$seqnames == paste0("chr", chrX), ]$start, + y0 = 0.5, + x1 = tads[tads$seqnames == paste0("chr", chrX), ]$end, + y1 = 0.5, lwd = 30, + col = plot_color(n = nrow(genes), alpha = 0.7), + lend = 1 + ) + mtext("TADs", side = 2, line = 1.75, cex = .75, font = 2) +} + +megaplot(dat, pick_plot_color(plotColor)) diff --git a/ui.R b/ui.R index feaa863..2434b20 100644 --- a/ui.R +++ b/ui.R @@ -187,7 +187,8 @@ function(request) { actionButton("btn_info", "", icon = icon("info"), "data-toggle" = "tooltip", "data-placement" = "right", title = "Learn more about epiTAD"), - bookmarkButton(class = "pull-right") + bookmarkButton(class = "pull-right"), + uiOutput("download_button_ui") ) ), tabBox( From 05931ac2955b68b8255b799c728e81ba29cb1111 Mon Sep 17 00:00:00 2001 From: Garrick Aden-Buie Date: Mon, 31 Dec 2018 17:53:43 +0000 Subject: [PATCH 4/8] Refactor regulome score annotation recoding --- template/epiTAD_script.template.R | 64 +++++++++---------------------- 1 file changed, 19 insertions(+), 45 deletions(-) diff --git a/template/epiTAD_script.template.R b/template/epiTAD_script.template.R index f12255f..76664f7 100644 --- a/template/epiTAD_script.template.R +++ b/template/epiTAD_script.template.R @@ -109,6 +109,22 @@ if (length(etest2)) { # Dat2 -------------------------------------------------------------------- # TODO GAB: dat2 and associated function need more descriptive names dat2_function <- function(snpList) { + regulome_recode <- c( + "1a" = "eQTL + TF binding + matched TF motif + matched DNase Footprint + DNase peak", + "1b" = "eQTL + TF binding + any motif + DNase Footprint + DNase peak", + "1c" = "eQTL + TF binding + matched TF motif + DNase peak", + "1d" = "eQTL + TF binding + any motif + DNase peak", + "1e" = "eQTL + TF binding + matched TF motif", + "1f" = "eQTL + TF binding / DNase peak", + "2a" = "TF binding + matched TF motif + matched DNase Footprint + DNase peak", + "2b" = "TF binding + any motif + DNase Footprint + DNase peak", + "2c" = "TF binding + matched TF motif + DNase peak", + "3a" = "TF binding + any motif + DNase peak", + "3b" = "TF binding + matched TF motif", + "4" = "TF binding + DNase peak", + "5" = "TF binding or DNase peak" + ) + snps <- as.character(unlist(strsplit(snpList, ","))) snps <- trimws(snps) x <- queryRegulome(query = snps) @@ -117,51 +133,9 @@ dat2_function <- function(snpList) { } x <- as.data.frame(x$res.table) x$score <- as.character(x$score) - x$score_anno <- NA - for (i in 1:nrow(x)) { - if (x$score[i] == "1a") { - x$score_anno[i] <- "eQTL + TF binding + matched TF motif + matched DNase Footprint + DNase peak" - } - else if (x$score[i] == "1b") { - x$score_anno[i] <- "eQTL + TF binding + any motif + DNase Footprint + DNase peak" - } - else if (x$score[i] == "1c") { - x$score_anno[i] <- "eQTL + TF binding + matched TF motif + DNase peak" - } - else if (x$score[i] == "1d") { - x$score_anno[i] <- "eQTL + TF binding + any motif + DNase peak" - } - else if (x$score[i] == "1e") { - x$score_anno[i] <- "eQTL + TF binding + matched TF motif" - } - else if (x$score[i] == "1f") { - x$score_anno[i] <- "eQTL + TF binding / DNase peak" - } - else if (x$score[i] == "2a") { - x$score_anno[i] <- "TF binding + matched TF motif + matched DNase Footprint + DNase peak" - } - else if (x$score[i] == "2b") { - x$score_anno[i] <- "TF binding + any motif + DNase Footprint + DNase peak" - } - else if (x$score[i] == "2c") { - x$score_anno[i] <- "TF binding + matched TF motif + DNase peak" - } - else if (x$score[i] == "3a") { - x$score_anno[i] <- "TF binding + any motif + DNase peak" - } - else if (x$score[i] == "3b") { - x$score_anno[i] <- "TF binding + matched TF motif" - } - else if (x$score[i] == "4") { - x$score_anno[i] <- "TF binding + DNase peak" - } - else if (x$score[i] == "5") { - x$score_anno[i] <- "TF binding or DNase peak" - } - else { - x$score_anno[i] <- "Other" - } - } + x$score_anno <- ifelse(x$score %in% names(regulome_recode), + regulome_recode[x$score], + "Other") x } From 1b174c3e156ee1fc7b6cda986a73711ef3255102 Mon Sep 17 00:00:00 2001 From: Garrick Aden-Buie Date: Mon, 31 Dec 2018 18:01:39 +0000 Subject: [PATCH 5/8] Support SNP list from file in script download --- server.R | 3 +++ 1 file changed, 3 insertions(+) diff --git a/server.R b/server.R index dd72935..95a737d 100644 --- a/server.R +++ b/server.R @@ -628,6 +628,9 @@ function(input, output, session) { input_names <- setNames(nm = names(input)) inputs <- lapply(input_names, function(n) input[[n]]) + # use snps() to support either source of snps + inputs$snpList <- paste(snps(), collapse = ",") + # Inputs that are used in the template and match any of the following: # - Are character strings # - Are vectors of length > 1 From f3796bacf36016028dcab6849ba238b67bab75f4 Mon Sep 17 00:00:00 2001 From: Garrick Aden-Buie Date: Mon, 31 Dec 2018 18:06:21 +0000 Subject: [PATCH 6/8] Force inclusion of template variables --- global.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/global.R b/global.R index 57ca34f..de2fb26 100644 --- a/global.R +++ b/global.R @@ -54,7 +54,7 @@ epitad_input_prepare <- function(input, need_escaped = c("snpList", "pop", "tiss as_valid_r_code <- function(x, deparse_opts = c("keepNA", "keepInteger", "niceNames")) { capture.output(dput(x, control = deparse_opts)) } - for (inp in intersect(need_escaped, names(input))) { + for (inp in need_escaped) { if (is.null(input[[inp]])) input[[inp]] <- "" input[[inp]] <- paste(as_valid_r_code(input[[inp]]), collapse = "") } From a0cc3ac02ad40b0d579eed9d3d322eee61587084 Mon Sep 17 00:00:00 2001 From: Garrick Aden-Buie Date: Wed, 2 Jan 2019 14:03:58 +0000 Subject: [PATCH 7/8] Remove bookmark button and add bookmark link to exported script --- server.R | 11 +++++++++-- template/epiTAD_script.template.R | 2 ++ ui.R | 1 - 3 files changed, 11 insertions(+), 3 deletions(-) diff --git a/server.R b/server.R index 045ca9b..c6c06a5 100644 --- a/server.R +++ b/server.R @@ -30,10 +30,14 @@ epitad_datatable <- function( } function(input, output, session) { - # Enable bookmarking button and update URL on bookmark + # Enable bookmarking updated on every change setBookmarkExclude("file1") + observe({ + # Trigger this observer every time an input changes + reactiveValuesToList(input) + session$doBookmark() + }) onBookmarked(function(url) { - showModal(urlModal(url, subtitle = "This link stores the current state of epiTAD.")) updateQueryString(url) }) @@ -555,6 +559,9 @@ function(input, output, session) { input_names <- setNames(nm = names(input)) inputs <- lapply(input_names, function(n) input[[n]]) + # Get bookmark url string + inputs$epitad_bookmark_url <- session$clientData$url_search + # use snps() to support either source of snps inputs$snpList <- paste(snps(), collapse = ",") diff --git a/template/epiTAD_script.template.R b/template/epiTAD_script.template.R index 76664f7..9fe1696 100644 --- a/template/epiTAD_script.template.R +++ b/template/epiTAD_script.template.R @@ -3,6 +3,8 @@ # # epiTAD Analysis Script # Generated on {{timestamp}} +# View online at +# - https://apps.gerkelab.com/epiTAD/{{epitad_bookmark_url}} # # Visit https://gerkelab.com/project/epiTAD for more information # diff --git a/ui.R b/ui.R index 2434b20..9bdea5e 100644 --- a/ui.R +++ b/ui.R @@ -187,7 +187,6 @@ function(request) { actionButton("btn_info", "", icon = icon("info"), "data-toggle" = "tooltip", "data-placement" = "right", title = "Learn more about epiTAD"), - bookmarkButton(class = "pull-right"), uiOutput("download_button_ui") ) ), From a503c339b13d314f2f2ffe0393fdc82c99c26f75 Mon Sep 17 00:00:00 2001 From: Garrick Aden-Buie Date: Wed, 2 Jan 2019 14:06:38 +0000 Subject: [PATCH 8/8] Move info button to the right side --- ui.R | 1 + 1 file changed, 1 insertion(+) diff --git a/ui.R b/ui.R index 9bdea5e..7fb2909 100644 --- a/ui.R +++ b/ui.R @@ -186,6 +186,7 @@ function(request) { ), actionButton("btn_info", "", icon = icon("info"), "data-toggle" = "tooltip", "data-placement" = "right", + class = "pull-right", title = "Learn more about epiTAD"), uiOutput("download_button_ui") )