This is a minimal app that reproduces my problem:
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput("input1", "input1", min = as.Date("2020-02-03"), max = as.Date("2020-12-30"),
value = c(as.Date(Sys.Date()), as.Date("2020-12-30"))),
hr(),
splitLayout(checkboxGroupInput("input2", "input2", choices = c("a", "b")),
verticalLayout(checkboxInput("input3", "input3")))),
mainPanel()))
server <- function(input, output, session) {
}
shinyApp(ui, server)
The app generated gives an horizontal scrollbar for input3, even when the screen size allows it to have more than enough space. Lurking on other similar questions, people recommend giving it a css property with overflow:hidden, but I can't find where to put this piece of code. Other approaches are obviously welcome.
You need to include custom CSS instructions at the head of the UI part.
library(shiny)
ui <- fluidPage(
# Include custom CSS
tags$head(
tags$style(HTML('.shiny-split-layout>div {overflow: hidden;}')),
),
sidebarLayout(
sidebarPanel(
sliderInput("input1", "input1", min = as.Date("2020-02-03"), max = as.Date("2020-12-30"),
value = c(as.Date(Sys.Date()), as.Date("2020-12-30"))),
hr(),
splitLayout(checkboxGroupInput("input2", "input2", choices = c("a", "b")),
verticalLayout(checkboxInput("input3", "input3")))),
mainPanel()))
server <- function(input, output, session) {
}
shinyApp(ui, server)
Related
Is there a way to fix the top section of the dashboard here. Right now, the widgets (selectinput) are fixed, but when the user scroll down, it gets covered by the datatable. Can we not make sure this does not get covered and only datatable moves down?
library(shiny)
library(DT)
ui <- shinyUI(fluidPage(
titlePanel(fluidRow(
div(column(12, align="center",
selectInput("rmd1", "RMDw", choices = c(1,2)),
selectInput("rmd2", "RMD2", choices = c(1,2))
), style = "position:fixed; width:inherit;")
)),
br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),
dataTableOutput("uioutput", height = "2000px")
))
server <- function(input, output, session) {
output$uioutput <- renderDataTable({
datatable(iris)
})
}
shinyApp(ui, server)
You can use the CSS z-index property to control the stack order the HTML elements:
library(shiny)
library(DT)
ui <- shinyUI(fluidPage(
titlePanel(fluidRow(
div(column(12, align="center",
selectInput("rmd1", "RMDw", choices = c(1,2)),
selectInput("rmd2", "RMD2", choices = c(1,2))
), style = "position:fixed; width:inherit; z-index: 1; background-color: white;")
)),
br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),
dataTableOutput("uioutput", height = "2000px")
))
server <- function(input, output, session) {
output$uioutput <- renderDataTable({
datatable(iris)
})
}
shinyApp(ui, server)
Another approach is using position: sticky;.
Changing the style line to position:absolute makes it so that the selection boxes scroll up and out of the page when you scroll down, if that's what you were looking for.
library(shiny)
library(DT)
ui <- shinyUI(fluidPage(
titlePanel(fluidRow(
div(column(12, align="center",
selectInput("rmd1", "RMDw", choices = c(1,2)),
selectInput("rmd2", "RMD2", choices = c(1,2))
), style = "position:absolute; width:inherit;")
)),
br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),
dataTableOutput("uioutput", height = "2000px")
))
server <- function(input, output, session) {
output$uioutput <- renderDataTable({
datatable(iris)
})
}
shinyApp(ui, server)
If you're trying to make the table stay in place and scroll down through the table, use DTOutput() and renderDataTable() instead of dataTableOutput() and renderDataTable(). Then, get rid of datatable() inside renderDT() and just use 'iris'. Finally, you can add the Scroller extension and an options list with scrollY and scroller. Others may be able to explain the difference between DT and DataTable (this page might help as well: https://rstudio.github.io/DT/shiny.html), but I believe DTOutput and renderDT are more flexible. Note: you can add horizontal scrollbars as well with scrollX if you use a table with more fields in the future.
Updated code is below.
Hope either of these helps!
library(shiny)
library(DT)
ui <- shinyUI(fluidPage(
titlePanel(fluidRow(
div(column(12, align="center",
selectInput("rmd1", "RMDw", choices = c(1,2)),
selectInput("rmd2", "RMD2", choices = c(1,2))
), style = "position:absolute; width:inherit;")
)),
br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),br(),
DTOutput("uioutput", height = "600px")
))
server <- function(input, output, session) {
output$uioutput <- renderDT({
iris
},
extensions = c('Scroller'),
fillContainer = T,
options = list(deferRender = T,
scrollY = 400,
scroller = T)
)
}
shinyApp(ui, server)
In my current application I am using a navlistPanel similar to the one below and I was wondering whether it would be possible to add a selectInput UI element to the navlist?
I have tried this in my ui.R but it doesn't work:
fluidPage(
titlePanel("Application Title"),
navlistPanel(
"Header",
tabPanel("First"),
tabPanel("Second"),
tabPanel("Third")
# selectInput(inputId, label, choices, selected = NULL) <- I've tried this but it doesn't work
)
)
Any solutions/workarounds are welcome.
I was wondering whether using sidebarLayout + sidebarPanel would work where the sidebarPanel imitates the behaviour of a navlistPanel but wasn't able to implement it.
A clean solution will be difficult, but how about something like this:
library(shiny)
shinyApp(
ui <- fluidPage(
titlePanel("Application Title"),
navlistPanel("Header", id = "navOut",
tabPanel("First", "First"),
tabPanel(selectInput("navSel", "Selection:", c("b", "c")), textOutput("txt"))
)
),
server <- shinyServer(function(input, output){
output$txt <- renderText(input$navSel)
})
)
If you are okay with using shinydashboard, it is fairly simple.
library(shiny)
library(shinydashboard)
rm(list=ls)
######/ UI Side/######
header <- dashboardHeader(title = "Test")
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("First Tab",tabName = "FTab", icon = icon("globe")),
menuItem("Second Tab",tabName = "STab", icon = icon("star"))
),
selectInput("navSel", "Selection:", c("b","c"))
)
body <- dashboardBody()
ui <- dashboardPage(header, sidebar, body)
######/ SERVER Side/######
server <- function(input, output, session) {
}
shinyApp(ui, server)
I have an existing Shiny script with standard widgets from the Shiny library. Now I wish to add something to show temperature on a graphical scale? This would be a read-only value, so it wouldn't make sense to use a slider unless the slider can be locked and only changed programatically. Is that possible? If not, what are other suggestions?
To clarify:
Is it possible to have a Shiny slider as read only. The user can not slide it but it can be programmatically changed. Here is a Shiny slider:
library(shiny)
ui <- fluidPage(
sliderInput("aa", "Temp",
min = -20, max = 20,
value = 10, step = 10)
)
server <- function(input, output) { }
shinyApp(ui, server)
I'm not familiar with Shiny Dashboard but I saw taskItem. Can these be "dropped in" and used with a normal Shiny app that uses fluidPage, sidebarPanel, mainPanel? How does one remove the bullet point and the percentage? Here is an example of a taskItem.
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(),
dashboardBody(
taskItem(value = temp <- 89, color = "red",
"Temp"
))
)
server <- function(input, output) { }
temp <- 89
shinyApp(ui, server)
AFAIK, sliderInput cannot be used as an output. However here's a potential solution using progressBar from shinyWidgets package
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
h3("Sidebar")
),
mainPanel(
br(), br(), br(),
progressBar("tempbar", value = 0, title = "Temperature", status = "danger")
)
)
)
server <- function(input, output, session) {
temp <- 89
updateProgressBar(session, id = "tempbar", value = temp)
}
shinyApp(ui, server)
shiny app with temperature bar
Replace temp in server with whatever calculated value you might have. For fixed temperature value just set it in ui, no need to use updateProgressBar. By default progressBar is scaled from 0-100. To modify see documentation for it.
You can use updateSliderInput to achieve such an behaviour. Couple this with shinyjs::disabled and you get what you want. I would however look for a less hackish solution:
library(shiny)
library(shinyjs)
ui <- fluidPage(
## add style to remove the opacity effect of disabled elements
tags$head(
tags$style(HTML("
.irs-disabled {
opacity: 1
}")
)
),
useShinyjs(),
disabled(sliderInput("aa", "Temp",
min = -20, max = 20,
value = 10, step = 10)),
actionButton("Change", "Change")
)
server <- function(input, output, session) {
observeEvent(input$Change, {
new_temp <- sample(seq(-20, 20, 10), 1)
updateSliderInput(session, "aa", value = new_temp)
})
}
shinyApp(ui, server)
I am trying to write a script in shiny, which has two inputs and stores the inputs in two different variables and runs a code using these input variables.But i am getting an error which says :Error in .getReactiveEnvironment()$currentContext() :
Operation not allowed without an active reactive context. (You tried to do something that can only be done from inside a reactive expression or observer.)
The following is my ui code:
ui <- fluidPage(
titlePanel("Network Model"),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "origin",
label = "Origin:",
choices = milk_runs$Origin),
selectInput(inputId = "destination",
label = "Destination:",
choices = milk_runs$Dest),
actionButton("go", "")
),
mainPanel(
tableOutput(
"view"))
)
)
server code :
server<- function(input, output){
origin <- input$origin
destination <- input$destination
observeEvent(input$go,source("nr9.R"))
output$summary <- renderPrint({
#dataset <- datasetInput()
summary(Tnetwork)
})
Can you please tell me how to get correct results.
I think (it would help if you provided a fully reproducible example) that the error is occurring because you are trying to run input$origin without reactive(). The input$origin will not invalidate and update based on user input unless put inside reactive. Based on the example you provided:
library(shiny)
ui <- fluidPage(
titlePanel("Network Model"),
sidebarLayout(
sidebarPanel(
selectInput(inputId = "origin", label = "Origin:", choices = c("A","B","C","D","E","F")),
selectInput(inputId = "destination", label = "Destination:", choices = c("A","B","C","D","E","F")),
actionButton("go", "GO")
),
mainPanel( tableOutput( "view"))
)
)
server<- function(input, output){
origin <- reactive(input$origin)
destination<-reactive(input$destination)
observeEvent(input$go,{
cat(origin(),'nextword',destination(),sep="-")
})
output$view <- renderTable({data.frame(origin=origin(),destination=destination())})
}
shinyApp(ui, server)
should print 'origin-nextword-destination' to the console when 'go' is activated, and the table should update. I changed a few bits in your example because it was not reproducible but hopefully it helps.
My problem is that I told shiny to take all the line (12 columns) to print c7 box but it only uses half of it. Can anyone figure out what is the problem? Following is my code:
library(shinydashboard)
library(shiny)
library(readr)
library(rsconnect)
header=dashboardHeader(title="App")
sidebar=dashboardSidebar(sidebarMenu(
menuItem("Stack", tabName = "a", icon = icon("dashboard"))))
c7=column(12,box(title="Prediction Box",status="warning",solidHeader=FALSE,
textInput("text", label = h3("Write something :"), value = ""),actionButton("do","Go")))
body=dashboardBody(tabItems(tabItem(tabName="a",fluidRow(c7))))
ui <- dashboardPage(header,sidebar,body)
server <- function(input, output){
}
shinyApp(ui,server)
By default, if you're not specifying the width of the box it will be set to 6. Have a look at ?box
E.g.:
library(shinydashboard)
library(shiny)
header=dashboardHeader(title="App")
sidebar=dashboardSidebar(sidebarMenu(menuItem("Stack", tabName = "a", icon = icon("dashboard"))))
?box
c7=column(12,box(width=12,title="Prediction Box",status="warning",solidHeader=FALSE,
textInput("text", label = h3("Write something :"), value = ""),actionButton("do","Go")))
body=dashboardBody(tabItems(tabItem(tabName="a",fluidRow(c7))))
ui <- dashboardPage(header,sidebar,body)
server <- function(input, output){
}
shinyApp(ui,server)