Nothing
heatmaplyGadget<-function(obj,plotHeight=800,viewerType='paneViewer',...){
viewerDots<-list(...)
if(viewerType=='dialogViewer'){
if(is.null(viewerDots$dialogName)) viewerDots$dialogName='shinyHeatmaply'
if(is.null(viewerDots$width)) viewerDots$width=1600
if(is.null(viewerDots$height)) viewerDots$height=1000
}
viewer<-do.call(eval(parse(text=paste0('shiny::',viewerType))),viewerDots)
#UI----
ui <- shiny::shinyUI(
shiny::fluidPage(
shiny::sidebarLayout(
shiny::sidebarPanel(
htmltools::h4('Data'),
shiny::uiOutput('data'),
shiny::checkboxInput('showSample','Subset Data'),
shiny::conditionalPanel('input.showSample',shiny::uiOutput('sample')),
# br(),
htmltools::hr(),htmltools::h4('Data Preprocessing'),
shiny::column(width=4,shiny::selectizeInput('transpose','Transpose',choices = c('No'=FALSE,'Yes'=TRUE),selected = FALSE)),
shiny::column(width=4,shiny::selectizeInput("transform_fun", "Transform", c(Identity=".",Sqrt='sqrt',log='log',Scale='scale',Normalize='normalize',Percentize='percentize',"Missing values"='is.na10', Correlation='cor'),selected = '.')),
shiny::uiOutput('annoVars'),
htmltools::br(),htmltools::hr(),htmltools::h4('Row dendrogram'),
shiny::column(width=6,shiny::selectizeInput("distFun_row", "Distance method", c(Euclidean="euclidean",Maximum='maximum',Manhattan='manhattan',Canberra='canberra',Binary='binary',Minkowski='minkowski'),selected = 'euclidean')),
shiny::column(width=6,shiny::selectizeInput("hclustFun_row", "Clustering linkage", c(Complete= "complete",Single= "single",Average= "average",Mcquitty= "mcquitty",Median= "median",Centroid= "centroid",Ward.D= "ward.D",Ward.D2= "ward.D2"),selected = 'complete')),
shiny::column(width=12,shiny::sliderInput("r", "Number of Clusters", min = 1, max = 15, value = 2)),
#column(width=4,numericInput("r", "Number of Clusters", min = 1, max = 20, value = 2, step = 1)),
htmltools::br(),htmltools::hr(),htmltools::h4('Column dendrogram'),
shiny::column(width=6,shiny::selectizeInput("distFun_col", "Distance method", c(Euclidean="euclidean",Maximum='maximum',Manhattan='manhattan',Canberra='canberra',Binary='binary',Minkowski='minkowski'),selected = 'euclidean')),
shiny::column(width=6,shiny::selectizeInput("hclustFun_col", "Clustering linkage", c(Complete= "complete",Single= "single",Average= "average",Mcquitty= "mcquitty",Median= "median",Centroid= "centroid",Ward.D= "ward.D",Ward.D2= "ward.D2"),selected = 'complete')),
shiny::column(width=12,shiny::sliderInput("c", "Number of Clusters", min = 1, max = 15, value = 2)),
#column(width=4,numericInput("c", "Number of Clusters", min = 1, max = 20, value = 2, step = 1)),
htmltools::br(),htmltools::hr(), htmltools::h4('Additional Parameters'),
shiny::column(3,shiny::checkboxInput('showColor','Color')),
shiny::column(3,shiny::checkboxInput('showMargin','Layout')),
shiny::column(3,shiny::checkboxInput('showDendo','Dendrogram')),
htmltools::hr(),
shiny::conditionalPanel('input.showColor==1',
htmltools::hr(),
htmltools::h4('Color Manipulation'),
shiny::uiOutput('colUI'),
shiny::sliderInput("ncol", "Set Number of Colors", min = 1, max = 256, value = 256),
shiny::checkboxInput('colRngAuto','Auto Color Range',value = TRUE),
shiny::conditionalPanel('!input.colRngAuto',shiny::uiOutput('colRng'))
),
shiny::conditionalPanel('input.showDendo==1',
htmltools::hr(),
htmltools::h4('Dendrogram Manipulation'),
shiny::selectInput('dendrogram','Dendrogram Type',choices = c("both", "row", "column", "none"),selected = 'both'),
shiny::selectizeInput("seriation", "Seriation", c(OLO="OLO",GW="GW",Mean="mean",None="none"),selected = 'OLO'),
shiny::sliderInput('branches_lwd','Dendrogram Branch Width',value = 0.6,min=0,max=5,step = 0.1)
),
shiny::conditionalPanel('input.showMargin==1',
htmltools::hr(),
htmltools::h4('Widget Layout'),
shiny::column(4,shiny::textInput('main','Title','')),
shiny::column(4,shiny::textInput('xlab','X Title','')),
shiny::column(4,shiny::textInput('ylab','Y Title','')),
shiny::sliderInput('row_text_angle','Row Text Angle',value = 0,min=0,max=180),
shiny::sliderInput('column_text_angle','Column Text Angle',value = 45,min=0,max=180),
shiny::sliderInput("l", "Set Margin Width", min = 0, max = 200, value = 130),
shiny::sliderInput("b", "Set Margin Height", min = 0, max = 200, value = 40)
)
),
shiny::mainPanel(
shiny::tabsetPanel(
shiny::tabPanel("Heatmaply",
htmltools::tags$a(id = 'downloadData', class = paste("btn btn-default shiny-download-link",'mybutton'), href = "", target = "_blank", download = NA, shiny::icon("clone"), 'Download Heatmap as HTML'),
htmltools::tags$head(htmltools::tags$style(".mybutton{color:white;background-color:blue;} .skin-black .sidebar .mybutton{color: green;}") ),
plotly::plotlyOutput("heatout",height=paste0(plotHeight,'px'))
),
shiny::tabPanel("Data",
shiny::dataTableOutput('tables')
)
)
)
)
)
)
#Server----
#' @import shiny
#' @import htmltools
#' @importFrom plotly plotlyOutput layout renderPlotly
#' @importFrom dplyr mutate_at vars
#' @import heatmaply
#' @importFrom stats cor dist hclust
#' @importFrom xtable xtable
#' @importFrom tools file_path_sans_ext
#' @importFrom rmarkdown pandoc_available pandoc_self_contained_html
server <- function(input, output,session) {
output$data=shiny::renderUI({
d<-names(obj)
selData=d[1]
shiny::selectInput("data","Select Data",d,selected = selData)
})
data.sel=shiny::eventReactive(input$data,{
as.data.frame(obj[[input$data]])
})
shiny::observeEvent(data.sel(),{
output$annoVars<-shiny::renderUI({
data.in=data.sel()
NM=NULL
if(any(sapply(data.in,class)=='factor')){
NM=names(data.in)[which(sapply(data.in,class)=='factor')]
}
shiny::column(width=4,
shiny::selectizeInput('annoVar','Annotation',choices = names(data.in),selected=NM,multiple=TRUE,options = list(placeholder = 'select columns',plugins = list("remove_button")))
)
})
#Sampling UI ----
output$sample<-shiny::renderUI({
list(
shiny::column(4,shiny::textInput(inputId = 'setSeed',label = 'Seed',value = sample(1:10000,1))),
shiny::column(4,shiny::numericInput(inputId = 'selRows',label = 'Number of Rows',min=1,max=pmin(500,nrow(data.sel())),value = pmin(500,nrow(data.sel())))),
shiny::column(4,shiny::selectizeInput('selCols','Columns Subset',choices = names(data.sel()),multiple=TRUE))
)
})
})
output$colUI<-shiny::renderUI({
colSel='Vidiris'
if(input$transform_fun=='cor') colSel='RdBu'
if(input$transform_fun=='is.na10') colSel='grey.colors'
shiny::selectizeInput(inputId ="pal", label ="Select Color Palette",
choices = c('Vidiris (Sequential)'="viridis",
'Magma (Sequential)'="magma",
'Plasma (Sequential)'="plasma",
'Inferno (Sequential)'="inferno",
'Magma (Sequential)'="magma",
'Magma (Sequential)'="magma",
'RdBu (Diverging)'="RdBu",
'RdYlBu (Diverging)'="RdYlBu",
'RdYlGn (Diverging)'="RdYlGn",
'BrBG (Diverging)'="BrBG",
'Spectral (Diverging)'="Spectral",
'BuGn (Sequential)'='BuGn',
'PuBuGn (Sequential)'='PuBuGn',
'YlOrRd (Sequential)'='YlOrRd',
'Heat (Sequential)'='heat.colors',
'Grey (Sequential)'='grey.colors'),
selected=colSel)
})
shiny::observeEvent({data.sel()},{
output$colRng=shiny::renderUI({
rng=range(data.sel(),na.rm = TRUE)
n_data = nrow(data.sel())
min_min_range = ifelse(input$transform_fun=='cor',-1,-Inf)
min_max_range = ifelse(input$transform_fun=='cor',1,rng[1])
min_value = ifelse(input$transform_fun=='cor',-1,rng[1])
max_min_range = ifelse(input$transform_fun=='cor',-1,rng[2])
max_max_range = ifelse(input$transform_fun=='cor',1,Inf)
max_value = ifelse(input$transform_fun=='cor',1,rng[2])
a_good_step = 0.1 # (max_range-min_range) / n_data
list(
shiny::numericInput("colorRng_min", "Set Color Range (min)", value = min_value, min = min_min_range, max = min_max_range, step = a_good_step),
shiny::numericInput("colorRng_max", "Set Color Range (max)", value = max_value, min = max_min_range, max = max_max_range, step = a_good_step)
)
})
})
interactiveHeatmap<- shiny::reactive({
data.in=data.sel()
if(input$showSample){
if(!is.null(input$selRows)){
set.seed(input$setSeed)
if((input$selRows >= 2) & (input$selRows < nrow(data.in))){
# if input$selRows == nrow(data.in) then we should not do anything (this save refreshing when clicking the subset button)
if(length(input$selCols)<=1) data.in=data.in[sample(1:nrow(data.in),pmin(500,input$selRows)),]
if(length(input$selCols)>1) data.in=data.in[sample(1:nrow(data.in),pmin(500,input$selRows)),input$selCols]
}
}
}
if(length(input$annoVar)>0){
if(all(input$annoVar%in%names(data.in)))
data.in <- data.in%>%dplyr::mutate_at(dplyr::vars(input$annoVar),list(factor))
}
ss_num = sapply(data.in, is.numeric) # in order to only transform the numeric values
if(input$transpose) data.in=t(data.in)
if(input$transform_fun!='.'){
if(input$transform_fun=='is.na10'){
shiny::updateCheckboxInput(session = session,inputId = 'showColor',value = TRUE)
data.in[, ss_num] = heatmaply::is.na10(data.in[, ss_num])
}
if(input$transform_fun=='cor'){
shiny::updateCheckboxInput(session = session,inputId = 'showColor',value = TRUE)
shiny::updateCheckboxInput(session = session,inputId = 'colRngAuto',value = FALSE)
data.in=stats::cor(data.in[, ss_num],use = "pairwise.complete.obs")
}
if(input$transform_fun=='log') data.in[, ss_num]= apply(data.in[, ss_num],2,log)
if(input$transform_fun=='sqrt') data.in[, ss_num]= apply(data.in[, ss_num],2,sqrt)
if(input$transform_fun=='normalize') data.in=heatmaply::normalize(data.in)
if(input$transform_fun=='scale') data.in[, ss_num] = scale(data.in[, ss_num])
if(input$transform_fun=='percentize') data.in=heatmaply::percentize(data.in)
}
#if(!is.null(input$tables_true_search_columns))
# data.in=data.in[activeRows(input$tables_true_search_columns,data.in),]
if(input$colRngAuto){
ColLimits=NULL
}else{
ColLimits=c(input$colorRng_min, input$colorRng_max)
}
distfun_row = function(x) stats::dist(x, method = input$distFun_row)
distfun_col = function(x) stats::dist(x, method = input$distFun_col)
hclustfun_row = function(x) stats::hclust(x, method = input$hclustFun_row)
hclustfun_col = function(x) stats::hclust(x, method = input$hclustFun_col)
p <- heatmaply::heatmaply(data.in,
main = input$main,xlab = input$xlab,ylab = input$ylab,
row_text_angle = input$row_text_angle,
column_text_angle = input$column_text_angle,
dendrogram = input$dendrogram,
branches_lwd = input$branches_lwd,
seriate = input$seriation,
colors=eval(parse(text=paste0(input$pal,'(',input$ncol,')'))),
distfun_row = distfun_row,
hclustfun_row = hclustfun_row,
distfun_col = distfun_col,
hclustfun_col = hclustfun_col,
k_col = input$c,
k_row = input$r,
limits = ColLimits) %>%
plotly::layout(margin = list(l = input$l, b = input$b))
p$elementId <- NULL
p
})
shiny::observeEvent(data.sel(),{
output$heatout <- plotly::renderPlotly({
interactiveHeatmap()
})
})
output$tables=shiny::renderDataTable(data.sel(),server = TRUE,filter='top',
extensions = c('Scroller','FixedHeader','FixedColumns','Buttons','ColReorder'),
options = list(
dom = 't',
buttons = c('copy', 'csv', 'excel', 'pdf', 'print','colvis'),
colReorder = TRUE,
scrollX = TRUE,
fixedColumns = TRUE,
fixedHeader = TRUE,
deferRender = TRUE,
scrollY = 500,
scroller = TRUE
))
#Clone Heatmap ----
shiny::observeEvent({interactiveHeatmap()},{
h<-interactiveHeatmap()
l<-list(main = input$main,xlab = input$xlab,ylab = input$ylab,
row_text_angle = input$row_text_angle,
column_text_angle = input$column_text_angle,
dendrogram = input$dendrogram,
branches_lwd = input$branches_lwd,
seriate = input$seriation,
colors=paste0(input$pal,'(',input$ncol,')'),
distfun_row = input$distFun_row,
hclustfun_row = input$hclustFun_row,
distfun_col = input$distFun_col,
hclustfun_col = input$hclustFun_col,
k_col = input$c,
k_row = input$r,
limits = paste(c(input$colorRng_min, input$colorRng_max),collapse=',')
)
l=data.frame(Parameter=names(l),Value=do.call('rbind',l),row.names = NULL,stringsAsFactors = FALSE)
l[which(l$Value==''),2]='NULL'
paramTbl=print(xtable::xtable(l),type = 'html',include.rownames=FALSE,print.results = FALSE,html.table.attributes = c('border=0'))
h$width='100%'
h$height='800px'
s<-htmltools::tags$div(style="position: relative; bottom: 5px;",
htmltools::HTML(paramTbl),
htmltools::tags$em('This heatmap visualization was created using',
htmltools::tags$a(href="https://github.com/yonicd/shinyHeatmaply/",target="_blank",'shinyHeatmaply'),
Sys.time()
)
)
output$downloadData <- shiny::downloadHandler(
filename = function() {
paste0("heatmaply-", strftime(Sys.time(),'%Y%m%d_%H%M%S'), ".html")
},
content = function(file) {
libdir <- paste0(tools::file_path_sans_ext(basename(file)),"_files")
htmltools::save_html(htmltools::browsable(htmltools::tagList(h,s)),file=file,libdir = libdir)
if (!rmarkdown::pandoc_available()) {
stop("Saving a widget with selfcontained = TRUE requires pandoc. For details see:\n",
"https://github.com/rstudio/rmarkdown/blob/master/PANDOC.md")
}
rmarkdown::pandoc_self_contained_html(file, file)
unlink(libdir, recursive = TRUE)
}
)
})
}
shiny::runGadget(ui, server, viewer = viewer)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.