Below is the part of UI code.I am not able to see all the selectinput in the sidebarpanel,
i suspect,it is not able to scroll further or may be if the font size of the
sidebarpanel has to be reduced.Any different approach which can be implemented to solve the problem?
dashboardPage(title = "title",
dashboardHeader(title="title1"
),
dashboardSidebar(tags$head(tags$style(HTML("
.selectize-input, .selectize-dropdown {
font-size:40%;
} }
"))),
radioButtons("filetype", "Select file type",choices=c("csv file","xlsx file")),
tags$div(title="Date format should be mm/dd/YYYY",fileInput("file1", "Upload Data File", accept = c("text/csv","text/comma-separated-values,text/plain",".csv",".xlsx",".xls"))),
uiOutput("col"),
uiOutput("covariate"),
uiOutput("dimensions1"),
uiOutput("levels1"),
uiOutput("dimensions2"),
uiOutput("level2"),
uiOutput("dimensions3"),
uiOutput("level3"),
uiOutput("dimensions4"),
uiOutput("level4")
),
dashboardBody(tags$head(
tags$style(HTML(".my_class {
font-weight: bold;
color:white;
}")
))
,uiOutput("All_tab_Display")
)
)
You'd better provide a reproducible example of your work.
test this and notify me whether it helped or not:
tags$head(
tags$style(HTML("
.sidebar { height: 90vh; overflow-y: auto; font-size: 10px;}
" )
)
)
Related
I would like to simply add a hovering window over an icon after a simple line of text.
I have found the shinyBS package, which seems to make this possible but it is linked to shiny outputs.
Having something like the code below in the "ui" of the shiny app makes the buttons work but they are linked to the radioButtons in this case.
CVI <- c("Hello1", "Hello2", "Hello3")
CNI <- c("Peter1", "Peter2", "Peter3")
radioButtons(inputId = "Attribute", label="Attribute", choiceValues = CVI,
choiceNames = list(
tagList(
tags$span(CNI[1]), #DoS
tags$span(icon("info-circle"), id = "1_info", style = "color: gray;")
),
tagList(
tags$span(CNI[2]), #DoO
tags$span(icon("info-circle"), id = "2_info", style = "color: gray;")
),
tagList(
tags$span(CNI[3]), #Ratio
tags$span(icon("info-circle"), id = "3_info", style = "color: gray;")
))
),# radiobuttons end
Popover buttons
bsPopover(id="1_info", title=NULL, content="Test1", trigger="hover", placement="right", options=list(container="body")),
bsPopover(id="2_info", title=NULL, content="Test2", trigger="hover", placement="right", options=list(container="body")),
bsPopover(id="3_info", title=NULL, content="Test3", trigger="hover", placement="right", options=list(container="body"))
How can I achieve something similar but without the radioButtons, simply like the word "Example" and then an icon where I hover and get a popup with some information (see picture).
I would create it somewhat like this:
Example_Text <- "Example_text" # This is what comes in the popup
"Example", span(icon("info-circle"), id = "Example_Popup", style = "color: gray;")
The native HTML tooltips are not customizable. Bootstrap tooltips are.
library(shiny)
library(bslib)
css <- '
.tooltip {
pointer-events: none;
}
.tooltip > .tooltip-inner {
pointer-events: none;
background-color: #73AD21;
color: #FFFFFF;
border: 1px solid green;
padding: 10px;
font-size: 25px;
font-style: italic;
text-align: justify;
margin-left: 0;
max-width: 1000px;
}
.tooltip > .arrow::before {
border-right-color: #73AD21;
}
'
js <- "
$(function () {
$('[data-toggle=tooltip]').tooltip()
})
"
shinyApp(
server = function(input,output,session){},
ui = fluidPage(
theme = bs_theme(version = 4),
tags$head(
tags$style(HTML(css)),
tags$script(HTML(js))
),
br(),
span(
"Example",
span(
`data-toggle` = "tooltip", `data-placement` = "right",
title = "A tooltip",
icon("info-circle")
)
)
)
)
This can be done with div(title=, style=, ...).
shinyApp(
server = function(input,output,session){},
ui = fluidPage(
span(
"Example",
div(style = "display:inline-block;",
title = "A tooltip",
icon("info-circle")))
)
)
Pause your mouse over the icon and you'll see A tooltip. It isn't styled like the directional callout you have in your page, perhaps it's sufficient.
I'm wondering whether these is any option to include math mode in tooltip title using bsTooltip() from shinyBS package.
Small example:
rm(list = ls())
library(shiny)
library(shinyBS)
ui <- basicPage(
headerPanel("Tooltip test"),
bsTooltip(id = "Equation", title = "\\(\\bar{X} = \\frac{1}{n}\\sum_{p = 1}^{n}X_p\\)", placement = "bottom", trigger = "hover", options = NULL),
mainPanel(
p("some text", htmlOutput("Equation", inline = TRUE))
)
)
server <- shinyServer(function(input, output,session) {
output$Equation <- renderUI({HTML("<font color='blue'><u>something which needs equation</u></font>")})
})
shinyApp(ui = ui, server = server)
The result (math mode) is not satisfactory:
No way with 'shinyBS'.
Here is a way using the qTip2 JavaScript library.
In order to use it, you have to download the files jquery.qtip.min.css and jquery.qtip.min.js, and put these two files in the www subfolder of the Shiny app.
library(shiny)
js <- "
$(document).ready(function() {
$('#Equation').qtip({
overwrite: true,
content: {
text: $('#tooltip')
},
position: {
my: 'top left',
at: 'bottom right'
},
show: {
ready: false
},
hide: {
event: 'unfocus'
},
style: {
classes: 'qtip-youtube qtip-rounded'
},
events: {
blur: function(event, api) {
api.elements.tooltip.hide();
}
}
});
});
"
library(shiny)
ui <- basicPage(
tags$head(
tags$link(rel = "stylesheet", href = "jquery.qtip.min.css"),
tags$script(src = "jquery.qtip.min.js"),
tags$script(HTML(js)),
),
withMathJax(),
headerPanel("Tooltip test"),
mainPanel(
p("some text", htmlOutput("Equation", inline = TRUE)),
div(
id = "tooltip", style = "display: none;",
HTML("$$\\int_0^1 f(x) dx = \\pi$$")
)
)
)
server <- shinyServer(function(input, output,session) {
output$Equation <-
renderUI({HTML("<font color='blue'><u>something which needs equation</u></font>")})
})
shinyApp(ui = ui, server = server)
Just to add another option, we could create our own tooltip class following the example from W3 here. Then we can use {shiny}'s withMathJax() function to render the tooltip as formula.
I usually use custom tooltips in cases where I only have a few tooltips that I want to customize. It has the advantage that it comes with no additional dependencies. The major drawbacks of this custom tooltip are that (1) it is displayed as child element and not in a separate container on the top layer like tooltips generated with javascript and that (2) you have to create css classes for each arrow direction. So if you have many tooltips pointing in different directions an additional javascript library like qTip2 should be definitely worth the dependency.
library(shiny)
ui <- fluidPage(
tags$head(
tags$style(HTML(
# tooltip implementation from:
# https://www.w3schools.com/css/tryit.asp?filename=trycss_tooltip_arrow_top
# just added a `t` to make classes unique
".ttooltip {
position: relative;
display: inline-block;
border-bottom: 1px dotted black;
}
.ttooltip .ttooltiptext {
visibility: hidden;
width: 120px;
background-color: black;
color: #fff;
text-align: center;
border-radius: 6px;
padding: 5px 0;
position: absolute;
z-index: 1;
top: 150%;
left: 50%;
margin-left: -60px;
}
.ttooltip .ttooltiptext::after {
content: '';
position: absolute;
bottom: 100%;
left: 50%;
margin-left: -5px;
border-width: 5px;
border-style: solid;
border-color: transparent transparent black transparent;
}
.ttooltip:hover .ttooltiptext {
visibility: visible;
}")
)
),
headerPanel("Tooltip test"),
mainPanel(
p("some text", htmlOutput("Equation", inline = TRUE)),
))
server <- shinyServer(function(input, output,session) {
output$Equation <- renderUI({
span(class = "ttooltip",
style = "color: blue",
"something which needs equation",
span(class = "ttooltiptext",
withMathJax("$$\\bar{X} = \\frac{1}{n}\\sum_{p = 1}$$"))
)
})
})
shinyApp(ui = ui, server = server)
I would like some inputs to have their label inline with the input box, and others to exhibit the standard Shiny standard behaviour. Consider the answer (and minimal example) given by SBista here: How to put a box and its label in the same row? (shiny package)
library(shiny)
ui <- fluidPage(
fluidRow(
tags$head(
tags$style(type="text/css", "label{ display: table-cell; text-align: center; vertical-align: middle; }
.form-group { display: table-row;}")
),
textInput(inputId = "txtInp", label = "Label:"),
textInput(inputId = "txtInp2", label = "A_longer_label:"),
numericInput(inputId = "numInp", label = "Third_label:", value = 0)
)
)
server <- function(input, output){}
shinyApp(ui, server)
This gives the very neat output like so:
Here the input boxes are neatly aligned. If I only want some of the labels to exhibit this behaviour (and others to do the normal Shiny thing), I can create the id "inline" and add it to divs around the labels in question, like so:
library(shiny)
ui <- fluidPage(
fluidRow(
tags$head(
tags$style(type="text/css", "#inline label{ display: table-cell; text-align: left; vertical-align: middle; }
#inline .form-group { display: table-row;}")
),
tags$div(id = "inline", textInput(inputId = "txtInp", label = "Label:")),
tags$div(id = "inline", textInput(inputId = "txtInp2", label = "Label2_not_inline:")),
numericInput(inputId = "numInp", label = "Third_label:", value = 0)
)
)
server <- function(input, output){}
shinyApp(ui, server)
Now the third label behaves as expected, but the first two labels are not neatly aligned. I guess this is because an id can only be used once. How can a class be used to achieve the desired result for multiple inputs?
To achieve what you want you could modify the css as follows:
tags$style(type="text/css", ".inline label{ display: table-cell; text-align: left; vertical-align: middle; }
.inline .form-group{display: table-row;}")
The code would look something like this:
library(shiny)
ui <- fluidPage(
fluidRow(
tags$head(
tags$style(type="text/css", ".inline label{ display: table-cell; text-align: left; vertical-align: middle; }
.inline .form-group{display: table-row;}")
),
tags$div(class = "inline", textInput(inputId = "txtInp", label = "Label:"),
textInput(inputId = "txtInp2", label = "Label2:")),
numericInput(inputId = "numInp", label = "Third_label:", value = 0)
)
)
server <- function(input, output){}
shinyApp(ui, server)
With this code you will get the labels which looks a lot cleaner, something like this:
Hope it helps!
How do I add text to the right of a dashboard header sidebar icon? It seems that previous similar solutions no longer work under updates to dashboardHeader().
This is what I am trying to do in a basic shinydashboard setting:
I can use the strategy from this answer to get text in the header, but it's right-justified (which I can likely fix custom css) and also feels pretty hacky.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(dashboardHeader(title = "demo",
tags$li(class = "dropdown",
tags$p("foo")
)
), dashboardSidebar(), dashboardBody())
server <- function(input, output) { }
shinyApp(ui, server)
Is there a better way to do this?
The dashboardHeader is expecting elements of type dropdownMenu. So it will be hard to find a not hacky solution. The possible (hacky) options are: a) Modify the dashboardHeader function, or b) use some JavaScript code to add the text after creating the header. Below is my attempt to solve your problem using JavaScript, maybe it could help you.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(
title = "demo"
),
dashboardSidebar(),
dashboardBody(
tags$head(tags$style(HTML(
'.myClass {
font-size: 20px;
line-height: 50px;
text-align: left;
font-family: "Helvetica Neue",Helvetica,Arial,sans-serif;
padding: 0 15px;
overflow: hidden;
color: white;
}
'))),
tags$script(HTML('
$(document).ready(function() {
$("header").find("nav").append(\'<span class="myClass"> Text Here </span>\');
})
'))
)
)
server <- function(input, output) { }
shinyApp(ui, server)
Adding to Geovany & Tiffany's answers, if you'd like the text content to be dynamic, you can have it change based on user input with the shinyjs::html function.
For example, I'm using it to display the name of the selected tab in the header. You can access the selected tab name in the server function as long as you have given the sidebar menu an id, in my case this is tabs.
I also had to add an id to the div that is appended to the header in Geovany's code, in this case pageHeader.
Then adding this to the server function will change the header text to display the selected tab, with switch being used to create a more presentable header format. Note the useShinyJs() in dashboardPage parameters:
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(
title = "demo"
),
dashboardSidebar(),
dashboardBody(
tags$head(tags$style(HTML(
'.myClass {
font-size: 20px;
line-height: 50px;
text-align: left;
font-family: "Helvetica Neue",Helvetica,Arial,sans-serif;
padding: 0 15px;
overflow: hidden;
color: white;
}
'))),
tags$script(HTML('
$(document).ready(function() {
$("header").find("nav").append(\'<div id="pageHeader" class="myClass"></div>\');
})
'))
),
useShinyjs()
)
server <- function(input, output) {
observeEvent(input$tabs, {
header <- switch(input$tabs,
tab1 = "Tab 1",
tab2 = "Tab 2",
tab3 = "Tab 3")
# you can use any other dynamic content you like
shinyjs::html("pageHeader", header)
})
}
shinyApp(ui, server)
A slightly modified version of Geovany's code to customize font auto-sizing, placement etc. would be:
ui.R file in directory1 containing:
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(
title = "demo"
),
dashboardSidebar(),
dashboardBody(
tags$script(HTML('
$(document).ready(function() {
$("header").find("nav").append(\'<div class="myClass"> Text Here </div>\');
})
')),
tags$head(
# Include our custom CSS
includeCSS("styles.css"),
)
)
)
server.R file in directory1 containing:
library(shiny)
library(shinydashboard)
server <- function(input, output) { }
a css style sheet (style.css in directory1) that controls the text parameters on resizing windows with a defined maximum size and unlimited shrink with the following code:
.myClass {
line-height: 50px;
text-align: center;
font-family: "Arial";
padding: 0 15px;
color: black;
font-size: 2vw;
}
#media (min-width: 1200px) {
.myClass {
line-height: 50px;
text-align: center;
font-family: "Arial";
padding: 0 15px;
color: black;
font-size: x-large
}
}
run using:
shiny::runApp("path to directory1")
Adding the padding properties can be a possible fix. Other options such as width, border and margin can be explored based on your requirements.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(dashboardHeader(title = "demo",
tags$li(class = "dropdown",
style = "padding: 10px 1200px 0px 0px;",
tags$p("foo")
)
), dashboardSidebar(), dashboardBody())
server <- function(input, output) { }
shinyApp(ui, server)
Hope this helps!
I have a problem with my shinyapp. I want to upload data for my calculations. When I do so the app automatically runs through the whole script the moment the upload is complete, so I implemented an action button. When I start the app and upload the data I have to click on the action button, the program executes and everything works fine. But when I start the app and click on the action Button first and then upload data, the program executes without having to click on the run button again. I made an example here. Because my actual app is ways bigger I need this feature that the programs is not executing automatically after uploading new data once the action button was clicked for the data I uploaded in the first place. I know that there is isolate() and I tried to implement it in every position possible but without any result. Can somebody help me out here?
Here the code. with example data.
Mydata<-data.frame(A=1:1100,B=rnorm(1100, 50, 5))
write.csv(Mydata, file = "MyData.csv")
and the app:
ui <- fluidPage(
titlePanel("Uploading Files"),
sidebarLayout(
sidebarPanel(
fileInput('files1', 'Choose CSV File',
accept=c('text/csv',
'text/comma-separated-values,text/plain',
'.csv'), multiple = TRUE),
tags$hr(),
radioButtons('sep', 'Separator',
c(Comma=',',
Semicolon=';',
Tab='\t'),
','),
actionButton("go","run",class = "btn-primary"),br()
),
mainPanel(tags$head(tags$style(type="text/css", "
#loadmessage {
position: fixed;
top: 95%;
left: 0px;
width: 100%;
padding: 5px 0px 5px 0px;
text-align: center;
font-weight: bold;
font-size: 100%;
color: #000000;
background-color: #CCFF66;
z-index: 105;
}
")),
conditionalPanel(condition="$('html').hasClass('shiny-busy')",
tags$div("Loading...",id="loadmessage")),
verbatimTextOutput('text1')
)
)
)
server <- function(input, output) {
observeEvent(input$go,{
mapz <- reactive({
inFiles <- input$files1
if (is.null(inFiles))
return(NULL)
Q <- read.csv(input$files1[[1, 'datapath']],sep=input$sep,dec="." )
names(Q)<-c("A","B")
Q<-Q[Q$A<1000,]
nom<-seq(round(min(Q$A)),floor(max(Q$A)),by=1)
counts<-matrix(NA,nrow=length(nom),ncol=length(input$files1[,1]))
return(list(as.matrix(nom),counts))
})
output$text1 <-renderPrint(if(is.null(input$files1)==FALSE) as.data.frame(mapz()[[1]]))
})}
shinyApp(ui, server)
Many thanks!
One very quick and effective way you can do this is to make that part of the UI unavailable until the file or files are uploaded. Basically make a uiOutput() call in place of the actionButton() call and move the actionButton() into a renderUI() function in server that has a conditional looking for a not NULL return for mapz(). The button isnt available to be pressed unless there is a non NULL return for mapz(). You should also move the reactive that creates mapz() outside of the observeEvent() so that it becomes usable to the app regardless of whether the button is pressed or not. Now as a caveat this never resets the button so as long as there is a file uploaded the button is pressable. It is functionally the same so the ! operator works like the ==FALSE conditional. Heres the code with the suggested changes :
ui <- fluidPage(
titlePanel("Uploading Files"),
sidebarLayout(
sidebarPanel(
fileInput('files1', 'Choose CSV File',
accept=c('text/csv',
'text/comma-separated-values,text/plain',
'.csv'), multiple = TRUE),
tags$hr(),
radioButtons('sep', 'Separator',
c(Comma=',',
Semicolon=';',
Tab='\t'),
','),
uiOutput("runbutton"),br()
),
mainPanel(tags$head(tags$style(type="text/css", "
#loadmessage {
position: fixed;
top: 95%;
left: 0px;
width: 100%;
padding: 5px 0px 5px 0px;
text-align: center;
font-weight: bold;
font-size: 100%;
color: #000000;
background-color: #CCFF66;
z-index: 105;
}
")),
conditionalPanel(condition="$('html').hasClass('shiny-busy')",
tags$div("Loading...",id="loadmessage")),
verbatimTextOutput('text1')
)
)
)
server <- function(input, output) {
output$runbutton <- renderUI({
if(!is.null(mapz()){
actionButton("go","run",class = "btn-primary")
}
})
mapz <- reactive({
inFiles <- input$files1
if (is.null(inFiles))
return(NULL)
Q <- read.csv(input$files1[[1, 'datapath']],sep=input$sep,dec="." )
names(Q)<-c("A","B")
Q<-Q[Q$A<1000,]
nom<-seq(round(min(Q$A)),floor(max(Q$A)),by=1)
counts<-matrix(NA,nrow=length(nom),ncol=length(input$files1[,1]))
return(list(as.matrix(nom),counts))
})
observeEvent(input$go,{
output$text1 <-renderPrint(if(is.null(mapz())==FALSE) as.data.frame(mapz()[[1]]))
})}
shinyApp(ui, server)
dont know why exactly, but this seems to work:
ui <- fluidPage(
titlePanel("Uploading Files"),
sidebarLayout(
sidebarPanel(
fileInput('files1', 'Choose CSV File',
accept=c('text/csv',
'text/comma-separated-values,text/plain',
'.csv'), multiple = TRUE),
tags$hr(),
radioButtons('sep', 'Separator',
c(Comma=',',
Semicolon=';',
Tab='\t'),
','),
actionButton("go","run",class = "btn-primary"),br()
),
mainPanel(tags$head(tags$style(type="text/css", "
#loadmessage {
position: fixed;
top: 95%;
left: 0px;
width: 100%;
padding: 5px 0px 5px 0px;
text-align: center;
font-weight: bold;
font-size: 100%;
color: #000000;
background-color: #CCFF66;
z-index: 105;
}
")),
conditionalPanel(condition="$('html').hasClass('shiny-busy')",
tags$div("Loading...",id="loadmessage")),
verbatimTextOutput('text1')
)
)
)
server <- function(input, output) {
observeEvent(input$go,{
mapz1 <- reactive({
inFiles <- input$files1
if (is.null(inFiles))
return(NULL)
Q <- read.csv(input$files1[[1, 'datapath']],sep=input$sep,dec="." )
names(Q)<-c("A","B")
Q<-Q[Q$A<1000,]
nom<-seq(round(min(Q$A)),floor(max(Q$A)),by=1)
counts<-matrix(NA,nrow=length(nom),ncol=length(input$files1[,1]))
return(list(as.matrix(nom),counts))
})
mapz<-reactive({isolate(mapz1())})
output$text1 <-renderPrint(as.data.frame(mapz()[[1]]))
})}
shinyApp(ui, server)