It would be nice to see more than 18 lines of a legend.
Wrapping the output in a wellPanel( style = 'overflow-y:scroll;' ) appears like it would be the correct function, but did not work.
library(shiny)
shinyApp(
ui <- fluidPage(
splitLayout(cellWidths = c('20%', '30%', '50%'),
sliderInput('mySldr' , value = 4 , min = 1 ,
label = 'how many groups ?', max = 44 ), # max 52 > 44
plotOutput( 'myLgnd' ),
plotOutput( 'myPlt' )
)
),
server <- function(input, output, session) {
n <- reactive({ input$mySldr })
theD <- reactive({ matrix(runif( 5*n() ), nrow = 5,
dimnames = (list( 1:5, rep(letters,2)[ 1:n() ] ))) })
output$myLgnd <- renderPlot({
legend( x = 'center', legend = colnames( theD() ),
fill = rainbow( n() ) ) })
output$myPlt <- renderPlot({
matplot( x = c(2001:2005), type = 'o', xlab = '', ylab = '',
y = theD() , col = rainbow( n() ) ) })
}
)
Any help towards a scrollable legend would be appreciated. Thank you.
Not very robust but this works for your example:
div(
style = "overflow-y: auto; overflow-x: hidden",
plotOutput( 'myLgnd' )
),
and
output$myLgnd <- renderPlot({
par(mar = c(0,0,0,0))
legend( x = 'center', legend = colnames( theD() ),
fill = rainbow( n() ) ) }, height = function(){170+10*ncol(theD())})
I've found the values 170 and 10 after many trials-errors. Maybe there are better values.
It would be better to do the graphic with plotly.
Related
I am having trouble getting boxes to align in fluidRow column format when using bslib and theme bootstrap 4 and 5 with navbarPage. It works with version 3. I can't figure out how to make the version 5 (or 4) to return the right layout. Only one column is used for the later versions. I need the boxes to be arranged in rows.
library(shiny)
library(bslib)
library(shinydashboard)
ui <- navbarPage(
theme = bs_theme(version = 4), # Wrong Layout
#theme = bs_theme(version = 3), # Right Layout
title="Dynamic Boxes",
#
navbarMenu("Tab1" ,
tabPanel("Item1",
fluidPage(
fluidRow( column(12,
uiOutput("boxes")
)
)
)
)
)
)
server <- function(input, output) {
output$boxes <- renderUI({
lapply(1:10, function(a) {
x = 1:100
box(title = paste0("box ", a), renderPlot(plot(x = x, y = x^a)))
})
# )
})
}
shinyApp(ui = ui, server = server)
fluidRow() needs to be outside of the lapply function and column() inside.
library(shiny)
library(bslib)
library(shinydashboard)
ui <- navbarPage(
theme = bs_theme(version = 4), # Wrong Layout
#theme = bs_theme(version = 3), # Right Layout
title="Dynamic Boxes",
navbarMenu("Tab1" ,
tabPanel("Item1",
uiOutput("boxes")
)
)
)
server <- function(input, output) {
output$boxes <- renderUI({
fluidRow(
lapply(1:10, function(a) {
x = 1:100
column(6,
box(title = paste0("box ", a),
renderPlot(plot(x = x, y = x^a)))
)
})
)
})
}
shinyApp(ui = ui, server = server)
I wanted to create fluidPage as shown in the image above.
Here is my code for ui.R:
shinyUI(fluidPage(
fluidRow(
column(6,
selectInput(inputId="StoreName", label=h3("Choose Store"),choices = vStores),
),
column(6,
strong(h3("Latest Orders Status")),
DT::dataTableOutput('getLatestOrdStatus'),
style = "height:500px; overflow-y: scroll;"
)
),
fluidRow(
column(6,
selectInput(inputId="OrderType", label=h3("Choose Order Type"),choices = vOrdTypes)
)
),
fluidRow(
column(5, h4("Daily Orders Count By Order Type"),
dateRangeInput(inputId="daterange", label="Pick a Date Range:", start = Sys.Date()-30,
end = Sys.Date()),
plotOutput("OrdPlotByType")
)
)
)
)
The below code will give you similar layout. Further you can improve by exploring this link from shiny
library(shiny)
library(DT)
library(ggplot2)
data(mtcars)
ui <- fluidPage(
fluidRow(column(12, style = "background-color:#999999;",
fluidRow(column(6,
fluidRow( column(6, selectInput(inputId = "StoreName", label = h3("Select Input 1"),choices = c('a', 'b')))),
fluidRow(column(6, selectInput(inputId = "OrderType", label = h3("Select Input 2"),choices = c('a', 'b')))),
fluidRow(column(12, h4("Plot Output"), plotOutput('plot'))
)) ,
column(6, strong(h3("Table Output")),dataTableOutput('table')
)
)
)
)
)
server <- function(input, output) {
data <- data.frame(
name = c("A","B","C","D","E") ,
value = c(3,12,5,18,45) )
output$table <- renderDataTable(head(mtcars))
output$plot <- renderPlot(
ggplot(data, aes(x = name, y = value)) +
geom_bar(stat = "identity")
)
}
shinyApp(ui, server)
I have tried this in different ways and achieved one task, either add or delete., but i couldn't get complete solution in one, i might be missing some small concept somewhere.. I am adding the code , please help me complete my basic app.
library(shiny)
library(DT)
x<- data.frame(v1 = NA,
v2 = NA
),
ui = shinyUI(
fluidPage(
sidebarLayout(
sidebarPanel(
textInput("v1","v1","a"),
numericInput("V2","V2","1"),
# Row selection
numericInput(inputId = "row.selection", label = "Select row to be
deleted", min = 1, max = 100, value = "")
# Add button
actionButton(inputId = "add.button", label = "Add", icon =
icon("plus")),
# Delete button
actionButton(inputId = "delete.button", label = "Delete", icon =
icon("minus")),
),
mainPanel(
dataTableOutput('table')
)
)
)
),
Server side code
server = function(input, output, session) {
values <- reactiveValues()
values$df <- x
newEntry <- observe({
cat("newEntry\n")
if(input$add.button > 0) {
newRow <- data.frame(input$v1, input$v2)
isolate(values$df <- rbind(values$df,newRow))
}
})
deleteEntry <- observe({
cat("deleteEntry\n")
if(input$delete.button > 0) {
if(is.na(isolate(input$row.selection))){
values$df <- isolate(values$df[-nrow(values$df), ])
} else {
values$df <- isolate(values$df[-input$row.selection, ])
}
}
})
output$table = renderDataTable({
values$df
})
}
Try to use observeEvent rather than obser with actionbutton
and also, you have uppercase and lowercase issue with input$v2 (should be input$V2)
Try this modified code:
library(shiny)
library(DT)
x<- data.frame(v1 = NA,
v2 = NA
)
ui = shinyUI(
fluidPage(
sidebarLayout(
sidebarPanel(
textInput("v1","v1","a"),
numericInput("V2","V2","1"),
# Row selection
numericInput(inputId = "row.selection", label = "Select row to be
deleted", min = 1, max = 100, value = ""),
# Add button
actionButton(inputId = "add.button", label = "Add", icon =
icon("plus")),
# Delete button
actionButton(inputId = "delete.button", label = "Delete", icon =
icon("minus"))
),
mainPanel(
dataTableOutput('table')
)
)
)
)
server = function(input, output, session) {
values <- reactiveValues()
values$df <- x
observeEvent(input$add.button,{
cat("addEntry\n")
print(input$v1)
print(input$V2)
newRow <- data.frame(input$v1, input$V2)
colnames(newRow)<-colnames(values$df)
values$df <- rbind(values$df,newRow)
print(nrow(values$df))
})
observeEvent(input$delete.button,{
cat("deleteEntry\n")
if(is.na(input$row.selection)){
values$df <- values$df[-nrow(values$df), ]
} else {
values$df <- values$df[-input$row.selection, ]
}
})
output$table = renderDataTable({
values$df
})
}
shinyApp(ui,server)
Just run all the code above, and it should work properly.
I've spent two days trying to create a Shiny app to no avail. It's fine just running the examples but when I want to modify it for my own preference, I just get constant errors and lack of functionality.
I have a simple dataset of 100 X observations and 100 Y observations. I want to plot histograms of both X and Y with slider inputs for bins. I also want to create a scatterplot of Y on X. I'd really appreciate some help here.
I'm not new to R but I'm new to Shiny. Is there a way I can use ggplot to create the visuals?
Many thanks.
This is a quick example with two different layouts. Use one of the ui.R of course. Put global.R in the same folder with ui.R and server.R
ui.R v1
library(shiny)
library(ggplot2)
shinyUI(fluidPage(
titlePanel("Quick Shiny Example"),
sidebarLayout(
sidebarPanel(
sliderInput("xBins",
"Number of bins for X variable:",
min = 1,
max = 50,
value = 30),
sliderInput("yBins",
"Number of bins for Y variable:",
min = 1,
max = 50,
value = 30)
),
mainPanel(
plotOutput("xDistPlot"),
plotOutput("yDistPlot"),
plotOutput("xyScatterPlot")
)
)
))
ui.R v2
library(shiny)
library(ggplot2)
shinyUI(fluidPage(
titlePanel("Quick Shiny Example"),
fluidRow(
column(width = 4,
sliderInput("xBins",
"Number of bins for X variable:",
min = 1,
max = 50,
value = 30)
),
column(width = 4,
sliderInput("yBins",
"Number of bins for Y variable:",
min = 1,
max = 50,
value = 30)
),
column(width = 4)
),
fluidRow(
column(width = 4,
plotOutput("xDistPlot")
),
column(width = 4,
plotOutput("yDistPlot")
),
column(width = 4,
plotOutput("xyScatterPlot")
)
)
))
server.R
library(shiny)
library(ggplot2)
shinyServer(function(input, output) {
output$xDistPlot <- renderPlot({
g <- ggplot(df, aes(x = x))
g <- g + geom_histogram(bins = input$xBins)
g
})
output$yDistPlot <- renderPlot({
g <- ggplot(df, aes(x = y))
g <- g + geom_histogram(bins = input$yBins)
g
})
output$xyScatterPlot <- renderPlot({
g <- ggplot(df, aes(x = x, y = y))
g <- g + geom_point()
g
})
})
global.R
df <- data.frame(
x = rnorm(100),
y = rnorm(100)*2
)
Here is my answer, with random numbers for X and Y, just as a quick idea. Adding ggplot to this should be easy.
library(shiny)
ui <- shinyUI(
fluidPage(
sliderInput("nrBinsX", "Number of bins to display for X", min = 2, max = 10, value = 5),
plotOutput("histX"),
sliderInput("nrBinsY", "Number of bins to display for Y", min = 2, max = 10, value = 5),
plotOutput("histY"),
plotOutput("scatterXY")
)
)
server <- shinyServer(function(input, output, session) {
dataFrame <- data.frame (
"X" = sample(100,100,replace = T),
"Y" = sample(100,100,replace = T)
)
getHist <- function (var,nr){
return (hist(
x = var,
breaks = seq(0,100,100/nr),
freq = T
) )
}
output$histX <- renderPlot({
return(
getHist( var = dataFrame$X,
nr = input$nrBinsX
) ) })
output$histY <- renderPlot({
return( return(
getHist( var = dataFrame$Y,
nr = input$nrBinsY
)
) ) })
output$scatterXY <- renderPlot({
return(
plot(x = dataFrame$X,
y = dataFrame$Y)
)
})
})
shinyApp(ui = ui, server = server)
This app is creating a vector of standardised names which I create given some user input (number of channels and replicates). An example of the standard names given the number of channels = 4 and and replicates = 1 is as follows:
c("rep1_C0","rep1_C1","rep1_C2","rep1_C3")
I would like to allow the user to replace the value of the selection with their own custom value. For example to change the input "rep1_C0" to "Control_rep1". And then for it to then update the reactive vector in question. Here is my code:
library(shiny)
ui <- shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
fluidRow(column(5, numericInput("chans","# Channels",value = 4, min = 1)),
column(5, numericInput("reps","# Replicates",value = 1,min = 1))
),
uiOutput("selectnames")
),
mainPanel(
tableOutput("testcols")
)
)
))
server <- shinyServer(function(input, output) {
standardNames <- reactive({
paste("rep",rep(1:input$reps,each = input$chans),"_",
rep(paste("C",0:(input$chans - 1), sep = ""),input$reps),sep = "")
})
output$selectnames <- renderUI({
selectizeInput("selectnames", "Change Names", choices = standardNames(),
options = list(maxOptions = input$reps * input$chans))
})
## output
output$testcols <- renderTable({
standardNames()
})
})
shinyApp(ui = ui, server = server)
Is there some kind of option I can pass in the options sections that will allow this?
With selectizeInput you can set options = list(create = TRUE) to allow the user to add levels to the selection list, but I don't think that is what you want.
Instead, here is code that generates a text input box for each of the standard names, and allows the user to enter a label for them. It uses lapply and sapply to loop over each value and generate/read the inputs.
library(shiny)
ui <- shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
fluidRow(column(5, numericInput("chans","# Channels",value = 4, min = 1)),
column(5, numericInput("reps","# Replicates",value = 1,min = 1))
),
uiOutput("setNames")
),
mainPanel(
tableOutput("testcols")
)
)
))
server <- shinyServer(function(input, output) {
standardNames <- reactive({
paste("rep",rep(1:input$reps,each = input$chans),"_",
rep(paste("C",0:(input$chans - 1), sep = ""),input$reps),sep = "")
})
output$setNames <- renderUI({
lapply(standardNames(), function(thisName){
textInput(paste0("stdName_", thisName)
, thisName
, thisName)
})
})
labelNames <- reactive({
sapply(standardNames()
, function(thisName){
input[[paste0("stdName_", thisName)]]
})
})
## output
output$testcols <- renderTable({
data.frame(
stdName = standardNames()
, label = labelNames()
)
})
})
shinyApp(ui = ui, server = server)
If you want to hide the list unless the user wants to add labels, you can use a simple checkbox, like this, which hides the label making list until the use checks the box to show it.
library(shiny)
ui <- shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
fluidRow(column(5, numericInput("chans","# Channels",value = 4, min = 1)),
column(5, numericInput("reps","# Replicates",value = 1,min = 1))
)
, checkboxInput("customNames", "Customize names?")
, uiOutput("setNames")
),
mainPanel(
tableOutput("testcols")
)
)
))
server <- shinyServer(function(input, output) {
standardNames <- reactive({
paste("rep",rep(1:input$reps,each = input$chans),"_",
rep(paste("C",0:(input$chans - 1), sep = ""),input$reps),sep = "")
})
output$setNames <- renderUI({
if(!input$customNames){
return(NULL)
}
lapply(standardNames(), function(thisName){
textInput(paste0("stdName_", thisName)
, thisName
, thisName)
})
})
labelNames <- reactive({
if(!input$customNames){
return(standardNames())
}
sapply(standardNames()
, function(thisName){
input[[paste0("stdName_", thisName)]]
})
})
## output
output$testcols <- renderTable({
data.frame(
stdName = standardNames()
, label = labelNames()
)
})
})
shinyApp(ui = ui, server = server)
Alternatively, if you think the user may want to only change one or a small number of labels, here is a way to allow them to choose which standard name they are applying a label to:
library(shiny)
ui <- shinyUI(fluidPage(
sidebarLayout(
sidebarPanel(
fluidRow(column(5, numericInput("chans","# Channels",value = 4, min = 1)),
column(5, numericInput("reps","# Replicates",value = 1,min = 1))
)
, uiOutput("setNames")
),
mainPanel(
tableOutput("testcols")
)
)
))
server <- shinyServer(function(input, output) {
vals <- reactiveValues(
labelNames = character()
)
standardNames <- reactive({
out <- paste("rep",rep(1:input$reps,each = input$chans),"_",
rep(paste("C",0:(input$chans - 1), sep = ""),input$reps),sep = "")
vals$labelNames = setNames(out, out)
return(out)
})
output$setNames <- renderUI({
list(
h4("Add labels")
, selectInput("nameToChange", "Standard name to label"
, names(vals$labelNames))
, textInput("labelToAdd", "Label to apply")
, actionButton("makeLabel", "Set label")
)
})
observeEvent(input$makeLabel, {
vals$labelNames[input$nameToChange] <- input$labelToAdd
})
## output
output$testcols <- renderTable({
data.frame(
stdName = standardNames()
, label = vals$labelNames
)
})
})
shinyApp(ui = ui, server = server)