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)
Related
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 have a list object that I would like to update with a reactive input. The object has to be a list.
Below is my minimal code. Thanks in advance.
library(shiny)
shinyApp(
ui = fluidPage(
fluidRow(
numericInput("number", "Change number", 10, min = 1, max = 100),
verbatimTextOutput('show')
)
),
server = function(input, output, session) {
QG <- list(a = c(1:10),
b = LETTERS[1:10])
#How to update reactiveVal from reactive input
#QG$a[2] <- input$number
output$show <- renderPrint({
QG$a[2]
})
}
)
Something like this?
library(shiny)
QG <- list(a = c(1:10),b = LETTERS[1:10])
shinyApp(
ui = fluidPage(
fluidRow(
numericInput("number", "Change number", 10, min = 1, max = 100),
verbatimTextOutput('show')
)
),
server = function(input, output, session) {
Values <- reactive({
QG$a[2] <- as.numeric(input$number)
QG
})
output$show <- renderPrint({
Values()
})
}
)
I have a data table with filter enabled and i want to read selected rows from this data table.
input$table_rows_selected works fine if the filter is not applied however once i apply filter on data then correct rowindex is not returned.
ui <- function(id) {
fluidPage(
title = "Job Tracker",
fluidRow(
column(width=6,
selectInput("pickvalue", label = "Pick a Value", choices = unique(iris$Species))
)
),
br(),
fluidRow(
column(12,
DT::dataTableOutput("job_data")
)
),
br(),
fluidRow(
column(12,DT::dataTableOutput("x4"))
)
)
}
server <- function(input, output, session)
{
output$job_data <- DT::renderDataTable({
datatable(iris[iris$Species==input$pickvalue,],selection = "single")
})
output$x4 <- DT::renderDataTable({
s <- input$job_data_rows_selected
datatable(iris[s,])
})
}
To return previously selected row index you can add some reactiveValues to track the index like so, please note that the index is subject to data so if you select index = 4 and switch the data, the index = 4 will be applied to new data:
library(shiny)
library(DT)
ui <- function(id) {
fluidPage(
title = "Job Tracker",
fluidRow(
column(width=6,
selectInput("pickvalue", label = "Pick a Value", choices = unique(iris$Species))
)
),
br(),
fluidRow(
column(12,
DT::dataTableOutput("job_data")
)
),
br(),
fluidRow(
column(12,DT::dataTableOutput("x4"))
)
)
}
server <- function(input, output, session){
v <- reactiveValues()
v$s <- NULL
data <- reactive({
iris[iris$Species==input$pickvalue,]
})
output$job_data <- DT::renderDataTable({
datatable(data(),selection = "single")
})
observe({
if(!is.null(input$job_data_rows_selected)){
v$s <- input$job_data_rows_selected
}
})
output$x4 <- DT::renderDataTable({
datatable(data()[v$s,])
})
}
shinyApp(ui, server)
If you want to keep the index correctly, remove rownames:
data <- reactive({
data <- (iris[iris$Species==input$pickvalue,])
rownames(data) <- NULL
data
})
I created a Shiny dashboard in line of below codes :
library(shinydashboard)
library(shiny)
sidebar <- dashboardSidebar(
sidebarMenuOutput("menu"),
conditionalPanel("input.tabs == 'ABC'",
fluidRow(
column(11, offset = 1, h5((' Note')))
)
),
conditionalPanel("input.tabs == 'ABC1'",
fluidRow(
column(11, offset = 1, style = "height:20px; color:rgb(30,144,255);", h1((' Update')))
)
))
body <- dashboardBody(
tabItems(
tabItem(tabName = "ABC1",br())
),
tabItems(
tabItem(tabName = "ABC",br(),
fixedRow(column(10, offset = 1, wellPanel()))
)
)
)
ui = dashboardPage(
dashboardHeader(title = "ABC"),
sidebar,
body
)
server = function(input, output){
output$menu <- renderMenu({
sidebarMenu(id="tabs",
menuItem("ABC", tabName="ABC", icon=icon("line-chart"), selected=TRUE),
menuItem("ABC1", tabName="ABC1", icon=icon("line-chart"))
)
})
}
shinyApp(ui = ui, server = server)
With above setup, the width of WellPanel getting changed if I resize my Browser. Therefore, this looks ugly when I see my App in bigger screen (e.g. 2560 x 1080). I want entire size of WellPanel will remain fixed. If Browser size is smaller than WellPanel then, some horizontal/vertical scroll bar will appear. And if bigger then, Wellpanel will stay in the top-middle part of the Browser.
Any idea what setting needs to be changed in my above code to achieve this.
Thanks,
I think this works:
library(shinydashboard)
library(shiny)
sidebar <- dashboardSidebar(
sidebarMenuOutput("menu"),
conditionalPanel("input.tabs == 'ABC'",
fluidRow(
column(11, offset = 1, h5((' Note')))
)
),
conditionalPanel("input.tabs == 'ABC1'",
fluidRow(
column(11, offset = 1, style = "height:20px; color:rgb(30,144,255);", h1((' Update')))
)
))
body <- dashboardBody(
tags$head(tags$style(type = "text/css"
, '#plotUI {min-width: 570px; max-width: 570px;overflow:auto;}'
)
)
,tabItems(
tabItem(tabName = "ABC1",br())
),
tabItems(
tabItem(tabName = "ABC",br(),
fluidRow(column(10, offset = 1
,div(class="thiswell"
, wellPanel(
style= "min-width: 600px;max-width: 600px;overflow:auto",
,uiOutput("plotUI")
)
)
) )
)
)
)
ui = dashboardPage(
dashboardHeader(title = "ABC"),
sidebar,
body
)
server = function(input, output){
output$menu <- renderMenu({
sidebarMenu(id="tabs",
menuItem("ABC", tabName="ABC", icon=icon("line-chart"), selected=TRUE),
menuItem("ABC1", tabName="ABC1", icon=icon("line-chart"))
)
})
output$plotUI<- renderUI({
plotOutput("thePlot")
})
output$thePlot<- renderPlot({
plot(1:10)
})
}
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)