I have this small example app adapted from the web:
library( shiny )
library( shinyWidgets )
ui <- fluidPage(
tags$br(),
noUiSliderInput(
inputId = "noui2", label = "Slider vertical:",
min = 0, max = 1000, step = 50,
value = c(100, 400), margin = 100,
orientation = "vertical",
width = "100px", height = "300px"
),
verbatimTextOutput(outputId = "res2")
)
server <- function(input, output, session) {
output$res2 <- renderPrint(input$noui2)
}
shinyApp(ui, server)
Then I load an image as background like:
I am wondering if there is a way to color the specific area hight between 100 and 400 (given by the slider) in the borders of the figure like:
Below please find an approach using plotly's filled area plots:
library(shiny)
library(plotly)
library(shinyWidgets)
DF <- data.frame(
x = c(cos(seq(0.01, 10, 0.01)) * 1000:1 + 1000, cos(seq(0.01, 10, 0.01)) * 1000:1 + 1500),
y = rep(1:1000, 2),
id = c(rep("trace_1", 1000), rep("trace_2", 1000))
)
ui <- fluidPage(
br(),
column(
2,
noUiSliderInput(
inputId = "noui2",
label = "Slider vertical:",
min = 0,
max = 1000,
step = 50,
value = c(100, 400),
margin = 100,
orientation = "vertical",
direction = c("rtl"),
width = "100px",
height = "350px"
)
),
column(4, plotlyOutput("plot")),
verbatimTextOutput(outputId = "res2")
)
server <- function(input, output, session) {
output$res2 <- renderPrint(input$noui2)
plotDF <- reactive({
plotDF <- DF[DF$y %in% input$noui2[1]:input$noui2[2], ]
plotDF$id <- paste0("filtered_", plotDF$id)
plotDF
})
output$plot <- renderPlotly({
fig <- plot_ly(
rbind(DF, plotDF()),
x = ~ x,
y = ~ y,
split = ~ id,
type = "scatter",
mode = "lines",
color = I("black"),
fillcolor = 'red',
showlegend = FALSE
) |> style(fill = 'tonexty', traces = 2)
})
}
shinyApp(ui, server)
This is somewhat of a first attempt, the alignment is not perfect but it gets the idea across. Note the plotting box is still there to get a bit more insight what happens while aligning.
library( shiny )
library( shinyWidgets )
ui <- fluidPage(
tags$br(),
fluidRow(
column(2,noUiSliderInput(
inputId = "noui2", label = "Slider vertical:",
min = 0, max = 1000, step = 50,
value = c(100, 400), margin = 100,
orientation = "vertical",
width = "100px", height = "300px"
)),column(10,plotOutput("plot",height = "330px"))
),
verbatimTextOutput(outputId = "res2")
)
server <- function(input, output, session) {
output$res2 <- renderPrint(input$noui2)
output$plot<-renderPlot({
par(mar=c(0,0,1.5,0))
plot(type='n',0:1*1000,0:1*1000, xlab='', ylab='', xaxt='n', yaxt='n')
rect(100, 1000-input$noui2[2], 300,1000-input$noui2[1] , col='red')
})
}
shinyApp(ui, server)
This is a follow-up question to this Color an area with a sliderInput in a shiny app
Suppose I have this image:
How could I apply this solution by #ismirsehregal to this picture. I think I have to put the x and y from the esophagus to the code, but I don't know how to get the x and y of the esophagues (green in the picture):
Code from Color an area with a sliderInput in a shiny app
library(shiny)
library(plotly)
library(shinyWidgets)
DF <- data.frame(
x = c(cos(seq(0.01, 10, 0.01)) * 1000:1 + 1000, cos(seq(0.01, 10, 0.01)) * 1000:1 + 1500),
y = rep(1:1000, 2),
id = c(rep("trace_1", 1000), rep("trace_2", 1000))
)
ui <- fluidPage(
br(),
column(
2,
noUiSliderInput(
inputId = "noui2",
label = "Slider vertical:",
min = 0,
max = 1000,
step = 50,
value = c(100, 400),
margin = 100,
orientation = "vertical",
direction = c("rtl"),
width = "100px",
height = "350px"
)
),
column(4, plotlyOutput("plot")),
verbatimTextOutput(outputId = "res2")
)
server <- function(input, output, session) {
output$res2 <- renderPrint(input$noui2)
plotDF <- reactive({
plotDF <- DF[DF$y %in% input$noui2[1]:input$noui2[2], ]
plotDF$id <- paste0("filtered_", plotDF$id)
plotDF
})
output$plot <- renderPlotly({
fig <- plot_ly(
rbind(DF, plotDF()),
x = ~ x,
y = ~ y,
split = ~ id,
type = "scatter",
mode = "lines",
color = I("black"),
fillcolor = 'red',
showlegend = FALSE
) |> style(fill = 'tonexty', traces = 2)
})
}
shinyApp(ui, server)
The following approach doesn't meet the title of your question, but it shows the procedure I mentioned in your previous post.
You will need to save a modified png file (transparent esophagus - edited with gimp's "fuzzy select tool") in your apps www folder for this to work (please find it below).
I'm now using plotlyProxyInvoke to update the data without re-rendering the plot:
library(shiny)
library(plotly)
library(shinyWidgets)
slider_min <- 0
slider_max <- 45
lower_slider_value <- 5
upper_slider_value <- 18
x_position_trace_1 <- 40
x_position_trace_2 <- 50
DF <- data.frame(
x = c(rep(x_position_trace_1, 2), rep(x_position_trace_2, 2)),
y = rep(c(lower_slider_value, upper_slider_value), 2),
id = c(rep("trace_1", 2), rep("trace_2", 2))
)
ui <- fluidPage(
br(),
column(
2,
noUiSliderInput(
inputId = "noui2",
label = "Slider vertical:",
min = slider_min,
max = slider_max,
step = 1L,
value = c(lower_slider_value, upper_slider_value),
margin = 1,
orientation = "vertical",
width = "100px",
height = "350px"
)
),
column(4, plotlyOutput("myPlot", height = "800px")),
verbatimTextOutput(outputId = "res2")
)
server <- function(input, output, session) {
output$res2 <- renderPrint(input$noui2)
output$myPlot <- renderPlotly({
fig <- plot_ly(
DF,
x = ~ x,
y = ~ y,
split = ~ id,
type = "scatter",
mode = "lines",
color = I("white"),
fillcolor = 'red',
showlegend = FALSE
) |> layout(
images = list(
list(
source = "/esophagus.png",
xref = "x",
yref = "y",
x = 0,
y = -16,
sizex = 93,
sizey = 93,
sizing = "stretch",
opacity = 1,
layer = "above"
)
),
plot_bgcolor = "rgba(0, 0, 0, 0)",
paper_bgcolor = "rgba(0, 0, 0, 0)",
xaxis = list(
zerolinecolor = '#ffff',
zerolinewidth = 2,
gridcolor = 'ffff',
range = list(0, 100)),
yaxis = list(
zerolinecolor = '#ffff',
zerolinewidth = 2,
gridcolor = 'ffff',
range = list(80, -20)
# or autorange = "reversed"
)
) |> style(fill = 'tonexty', traces = 2)
})
myPlotProxy <- plotlyProxy("myPlot", session)
observe({
plotlyProxyInvoke(myPlotProxy, "restyle", list(x = list(rep(x_position_trace_1, 2), rep(x_position_trace_2, 2)), y = list(input$noui2, input$noui2)), list(0, 1))
})
}
shinyApp(ui, server)
Image for the www folder - save as "esophagus.png".
To visualize the transparent area (grey) open the image in a new browser tab (chrome):
Edit: Here is another lightweight approach without using {plotly}.
This isn't perfectly aligned yet and it might make sense to work wit % instead of px, however it shows the principle:
We can simply provide the esophagus image with a red background image and modify the css properties background-size and background-position-y:
library(shiny)
library(shinyjs)
library(shinyWidgets)
ui <- fluidPage(
useShinyjs(),
br(),
column(
2,
noUiSliderInput(
inputId = "noui2",
label = "Slider vertical:",
min = 0,
max = 1000,
step = 50,
value = c(100, 400),
margin = 100,
orientation = "vertical",
direction = c("rtl"),
width = "100px",
height = "350px"
)
),
column(
4,
tags$img(
id = "esophagus",
height = 1000,
width = "100%",
src = "/esophagus.png",
style = "background-image: url(red_background.png); background-repeat: no-repeat; background-size: 100% 30%; background-position-y: 40%;"
)
),
verbatimTextOutput(outputId = "res2")
)
server <- function(input, output, session) {
output$res2 <- renderPrint(input$noui2)
observeEvent(input$noui2, {
runjs(paste0('$("#esophagus").css("background-size", "100% ', input$noui2[2] - input$noui2[1], 'px");'))
runjs(paste0('$("#esophagus").css("background-position-y", "', 1000 - input$noui2[2], 'px");'))
})
}
shinyApp(ui, server)
Save as "red_background.png" in your www folder:
EDIT: I have simplified the application and make it all the code reproducible.
EDIT 2: I just discovered that when I use the navBarPage I must click on Additional Parameters -> Colour. Then is coloured as expected.
I'm developing a shiny app which filters my genes and then plots a heatmap of the remaining genes. Recently, I have found shinyHeatmaply package. I have download their global, UI and Server, and when I try it on my own computer they work as expected. Unfortunately, when I try to combine my filter app and their heatmap using navbarPage, the last one is not rending properly.
I have created a minimalist example adding the shinyheatmap to the second tabPanel of navbarPage in the https://shiny.rstudio.com/gallery/shiny-theme-selector.html app, but I get the same grey render anyway.
Same mistake in a simpler application
The UI:
Navbar 1 belongs to the shinytheme application, whilst the content of Navbar 2 belongs to the shinyheatmaply
tagList(
shinythemes::themeSelector(),
navbarPage(
# theme = "cerulean", # <--- To use a theme, uncomment this
"shinythemes",
tabPanel("Navbar 1",
sidebarPanel(
fileInput("file", "File input:"),
textInput("txt", "Text input:", "general"),
sliderInput("slider", "Slider input:", 1, 100, 30),
tags$h5("Deafult actionButton:"),
actionButton("action", "Search"),
tags$h5("actionButton with CSS class:"),
actionButton("action2", "Action button", class = "btn-primary")
),
mainPanel(
tabsetPanel(
tabPanel("Tab 1",
h4("Table"),
tableOutput("table"),
h4("Verbatim text output"),
verbatimTextOutput("txtout"),
h1("Header 1"),
h2("Header 2"),
h3("Header 3"),
h4("Header 4"),
h5("Header 5")
),
tabPanel("Tab 2", "This panel is intentionally left blank"),
tabPanel("Tab 3", "This panel is intentionally left blank")
)
)
),
tabPanel("Navbar 2",
fluidPage(
sidebarLayout(
sidebarPanel(width=4,
h4('Data Selection'),
fileInput(inputId="mydata", label = "Import Data",multiple = T),
uiOutput('data'),
checkboxInput('showSample','Subset Data'),
conditionalPanel('input.showSample',uiOutput('sample')),
hr(),h4('Data Preprocessing'),
column(width=4,selectizeInput('transpose','Transpose',choices = c('No'=FALSE,'Yes'=TRUE),selected = FALSE)),
column(width=4,selectizeInput("transform_fun", "Transform", c(Identity=".",Sqrt='sqrt',log='log',Scale='scale',Normalize='normalize',Percentize='percentize',"Missing values"='is.na10', Correlation='cor'),selected = '.')),
uiOutput('annoVars'),
br(),hr(),h4('Row dendrogram'),
column(width=6,selectizeInput("distFun_row", "Distance method", c(Euclidean="euclidean",Maximum='maximum',Manhattan='manhattan',Canberra='canberra',Binary='binary',Minkowski='minkowski'),selected = 'euclidean')),
column(width=6,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')),
column(width=12,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)),
br(),hr(),h4('Column dendrogram'),
column(width=6,selectizeInput("distFun_col", "Distance method", c(Euclidean="euclidean",Maximum='maximum',Manhattan='manhattan',Canberra='canberra',Binary='binary',Minkowski='minkowski'),selected = 'euclidean')),
column(width=6,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')),
column(width=12,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)),
br(),hr(), h4('Additional Parameters'),
column(3,checkboxInput('showColor','Color')),
column(3,checkboxInput('showMargin','Layout')),
column(3,checkboxInput('showDendo','Dendrogram')),
hr(),
conditionalPanel('input.showColor==1',
hr(),
h4('Color Manipulation'),
uiOutput('colUI'),
sliderInput("ncol", "Set Number of Colors", min = 1, max = 256, value = 256),
checkboxInput('colRngAuto','Auto Color Range',value = T),
conditionalPanel('!input.colRngAuto',uiOutput('colRng'))
),
conditionalPanel('input.showDendo==1',
hr(),
h4('Dendrogram Manipulation'),
selectInput('dendrogram','Dendrogram Type',choices = c("both", "row", "column", "none"),selected = 'both'),
selectizeInput("seriation", "Seriation", c(OLO="OLO",GW="GW",Mean="mean",None="none"),selected = 'OLO'),
sliderInput('branches_lwd','Dendrogram Branch Width',value = 0.6,min=0,max=5,step = 0.1)
),
conditionalPanel('input.showMargin==1',
hr(),
h4('Widget Layout'),
column(4,textInput('main','Title','')),
column(4,textInput('xlab','X Title','')),
column(4,textInput('ylab','Y Title','')),
sliderInput('row_text_angle','Row Text Angle',value = 0,min=0,max=180),
sliderInput('column_text_angle','Column Text Angle',value = 45,min=0,max=180),
sliderInput("l", "Set Margin Width", min = 0, max = 200, value = 130),
sliderInput("b", "Set Margin Height", min = 0, max = 200, value = 40)
)
),
mainPanel(
tabsetPanel(
tabPanel("Heatmaply",
tags$a(id = 'downloadData', class = paste("btn btn-default shiny-download-link",'mybutton'), href = "", target = "_blank", download = NA, icon("clone"), 'Download Heatmap as HTML'),
tags$head(tags$style(".mybutton{color:white;background-color:blue;} .skin-black .sidebar .mybutton{color: green;}") ),
plotlyOutput("heatout",height='600px')
),
tabPanel("Data",
DT::dataTableOutput('tables')
)
)
)
)
)
),
tabPanel("Navbar 3", "This panel is intentionally left blank")
)
)
The server:
Regarding to the server, first two output correspond to the shinytheme and the others belong to shinyheatmaply
d=data(package='datasets')$results[,'Item']
d=d[!grepl('[\\()]',d)]
d=d[!d%in%c('UScitiesD','eurodist','sleep','warpbreaks')]
d=d[unlist(lapply(d,function(d.in) eval(parse(text=paste0('ncol(as.data.frame(datasets::',d.in,'))')))))>1]
d=d[-which(d=='mtcars')]
d=c('mtcars',d)
server <- shinyServer(function(input, output,session) {
####This to output belongs to the shinytheme application####
output$txtout <- renderText({
paste(input$txt, input$slider, format(input$date), sep = ", ")
})
output$table <- renderTable({
head(cars, 4)
})
#######################################################
#Up to here the code belongs to shinyheatmaply
output$txtout <- renderText({
paste(input$txt, input$slider, format(input$date), sep = ", ")
})
output$table <- renderTable({
head(cars, 4)
})
TEMPLIST<-new.env()
TEMPLIST$d<-d
#Annotation Variable UI ----
observeEvent(data.sel(),{
output$annoVars<-renderUI({
data.in=data.sel()
NM=NULL
if(any(sapply(data.in,class)=='factor')){
NM=names(data.in)[which(sapply(data.in,class)=='factor')]
}
column(width=4,
selectizeInput('annoVar','Annotation',choices = names(data.in),selected=NM,multiple=T,options = list(placeholder = 'select columns',plugins = list("remove_button")))
)
})
#Sampling UI ----
output$sample<-renderUI({
list(
column(4,textInput(inputId = 'setSeed',label = 'Seed',value = sample(1:10000,1))),
column(4,numericInput(inputId = 'selRows',label = 'Number of Rows',min=1,max=pmin(500,nrow(data.sel())),value = pmin(500,nrow(data.sel())))),
column(4,selectizeInput('selCols','Columns Subset',choices = names(data.sel()),multiple=T))
)
})
})
#Data Selection UI ----
output$data=renderUI({
if(!is.null(input$mydata)) TEMPLIST$d=c(input$mydata$name,TEMPLIST$d)
selData=head(TEMPLIST$d,1)
selectInput("data","Select Data",TEMPLIST$d,selected = selData)
})
#Color Pallete UI ----
output$colUI<-renderUI({
colSel='Vidiris'
if(input$transform_fun=='cor') colSel='RdBu'
if(input$transform_fun=='is.na10') colSel='grey.colors'
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)
})
#Manual Color Range UI ----
output$colRng=renderUI({
if(!is.null(data.sel())) {
rng=range(data.sel(),na.rm = TRUE)
}else{
rng=range(mtcars) # TODO: this should probably be changed
}
# sliderInput("colorRng", "Set Color Range", min = round(rng[1],1), max = round(rng[2],1), step = .1, value = rng)
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(
numericInput("colorRng_min", "Set Color Range (min)", value = min_value, min = min_min_range, max = min_max_range, step = a_good_step),
numericInput("colorRng_max", "Set Color Range (max)", value = max_value, min = max_min_range, max = max_max_range, step = a_good_step)
)
})
#Import/Select Data ----
data.sel=eventReactive(input$data,{
if(input$data%in%d){
eval(parse(text=paste0('data.in=as.data.frame(datasets::',input$data,')')))
}else{
data.in=importSwitch(input$mydata[input$mydata$name%in%input$data,])
}
data.in=as.data.frame(data.in)
# data.in=data.in[,sapply(data.in,function(x) class(x))%in%c('numeric','integer')] # no need for this
return(data.in)
})
#Building heatmaply ----
interactiveHeatmap<- 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]
}
}
}
# ss_num = sapply(data.in,function(x) class(x)) %in% c('numeric','integer') # in order to only transform the numeric values
if(length(input$annoVar)>0){
if(all(input$annoVar%in%names(data.in)))
data.in <- data.in%>%mutate_at(funs(factor),.vars=vars(input$annoVar))
}
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'){
updateCheckboxInput(session = session,inputId = 'showColor',value = T)
data.in[, ss_num]=is.na10(data.in[, ss_num])
}
if(input$transform_fun=='cor'){
updateCheckboxInput(session = session,inputId = 'showColor',value = T)
updateCheckboxInput(session = session,inputId = 'colRngAuto',value = F)
data.in=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) dist(x, method = input$distFun_row)
distfun_col = function(x) dist(x, method = input$distFun_col)
hclustfun_row = function(x) hclust(x, method = input$hclustFun_row)
hclustfun_col = function(x) hclust(x, method = input$hclustFun_col)
p <- 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) %>%
layout(margin = list(l = input$l, b = input$b, r='0px'))
p$elementId <- NULL
p
})
#Render Plot ----
observeEvent(input$data,{
output$heatout <- renderPlotly({
if(!is.null(input$data))
interactiveHeatmap()
})
})
#Render Data Table ----
output$tables=DT::renderDataTable(data.sel(),server = T,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 ----
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=l[!l=='']
l=data.frame(Parameter=names(l),Value=do.call('rbind',l),row.names = NULL,stringsAsFactors = F)
l[which(l$Value==''),2]='NULL'
paramTbl=print(xtable::xtable(l),type = 'html',include.rownames=FALSE,print.results = F,html.table.attributes = c('border=0'))
h$width='100%'
h$height='800px'
s<-tags$div(style="position: relative; bottom: 5px;",
HTML(paramTbl),
tags$em('This heatmap visualization was created using',
tags$a(href="https://github.com/yonicd/shinyHeatmaply/",target="_blank",'shinyHeatmaply'),
Sys.time()
)
)
output$downloadData <- downloadHandler(
filename = function() {
paste("heatmaply-", gsub(' ','_',Sys.time()), ".html", sep="")
},
content = function(file) {
libdir <- paste(tools::file_path_sans_ext(basename(file)),"_files", sep = "")
htmltools::save_html(htmltools::browsable(htmltools::tagList(h,s)),file=file,libdir = libdir)
if (!htmlwidgets:::pandoc_available()) {
stop("Saving a widget with selfcontained = TRUE requires pandoc. For details see:\n",
"https://github.com/rstudio/rmarkdown/blob/master/PANDOC.md")
}
htmlwidgets:::pandoc_self_contained_html(file, file)
unlink(libdir, recursive = TRUE)
}
)
})
#End of Code ----
})
Thanks in advance to the hero who solves this problem.
Best rewards, Daniel.
The problem was a conflict between a conditional panel (which uses js) and the navbar page, for any reason default parameters were not read, thus autocoloring which should be enabled wasn't. I just removed this conditional panel and set always its options.