I want the user of my Shiny app to be able to choose between two types of plots by clicking on radiobuttons in the Events panel. The code I have written works, but the page leaves a huge white space when going from "Map" to "Plot". Is there any way to get rid of the white space and position the plot at the very top?
# Load R packages
library(shiny)
library(shinythemes)
library(tidyverse)
library(leaflet)
set.seed(123)
year <- 2001:2020
event <- sample(1:100, size = 20, replace = TRUE)
dat <- as.data.frame(cbind(year, event))
# Define UI
ui <- fluidPage(
shinyjs::useShinyjs(),
theme = shinytheme("journal"),
navbarPage(
"Title",
tabPanel("About",
),
tabPanel("Events",
fluidPage(
titlePanel("Title"),
sliderInput("range", label = "Move slider to select time period", min(2001), max(2020),
value = range(2001:2002), step = 1, sep = "", width = "65%"),
sidebarLayout(
sidebarPanel(
radioButtons("plotType", "Plot type", choices = c("Map" = "m", "Chart" = "l"))),
mainPanel(
leafletOutput("map"),
plotOutput("plot"))
)
)
)
)
)
# Define server function
server <- function(input, output, session) {
observeEvent(input$plotType, {
if(input$plotType == "l"){
shinyjs::disable("range")
}else{
shinyjs::enable("range")
}
})
output$plot <- renderPlot({
if (input$plotType == "l") {
ggplot(dat, aes(year, event)) +
geom_line() +
labs(x = "Year", y = "Events") +
theme_bw()
}
})
output$map <- renderLeaflet({
if ( input$plotType == "m") {
leaflet(dat) %>% addTiles() %>%
fitBounds(~min(11), ~min(54), ~max(67), ~max(24))
}
})
} # server
# Create Shiny object
shinyApp(ui = ui, server = server)
There is a big space because the map html object still exists, but is empty. To avoid this, I created and observeEvent that hides or show the map output depending on input value. I did the same thing with the plot, in cas you need to add others elements below it.
Please note that there are others solutions (conditionalPanel for example), I am just giving you the one I think is the simpliest here.
# Load R packages
library(shiny)
library(shinythemes)
library(tidyverse)
library(leaflet)
set.seed(123)
year <- 2001:2020
event <- sample(1:100, size = 20, replace = TRUE)
dat <- as.data.frame(cbind(year, event))
# Define UI
ui <- fluidPage(
shinyjs::useShinyjs(),
theme = shinytheme("journal"),
navbarPage(
"Title",
tabPanel("About",
),
tabPanel("Events",
fluidPage(
titlePanel("Title"),
sliderInput("range", label = "Move slider to select time period", min(2001), max(2020),
value = range(2001:2002), step = 1, sep = "", width = "65%"),
sidebarLayout(
sidebarPanel(
radioButtons("plotType", "Plot type", choices = c("Map" = "m", "Chart" = "l"))),
mainPanel(
leafletOutput("map"),
plotOutput("plot"))
)
)
)
)
)
# Define server function
server <- function(input, output, session) {
# hide or show map and plot
observeEvent(input$plotType, {
if(input$plotType == "l"){
shinyjs::disable("range")
shinyjs::hide("map")
shinyjs::show("plot")
}
if(input$plotType == "m"){
shinyjs::enable("range")
shinyjs::show("map")
shinyjs::hide("plot")
}
})
output$plot <- renderPlot({
req(input$plotType == "l") # good practice to use req instead of if
ggplot(dat, aes(year, event)) +
geom_line() +
labs(x = "Year", y = "Events") +
theme_bw()
})
output$map <- renderLeaflet({
req(input$plotType == "m")
leaflet(dat) %>% addTiles() %>%
fitBounds(~min(11), ~min(54), ~max(67), ~max(24))
})
} # server
# Create Shiny object
shinyApp(ui = ui, server = server)
Related
So a plotly plot has an embedded rangeslider however I do not like the looks of it. The rangeslider in R Shiny looks much better and professional, however how do i connect the two?
Lets say you have a dataframe with some values and a daterange like:
library(lubridate)
df <- data.frame(
"Date" = c(seq(ymd('2015-09-15'), ymd('2015-09-24'), by = "1 days")),
"values" = c(3,6,5,3,5,6,7,7,4,2)
)
Code for the plotly plot
library(plotly)
plot_df <- plot_ly(df)
plot_df <- plot_df %>% add_lines(type = 'scatter', mode = "lines",
x = ~Date, y = ~values)
Code Shiny
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Basic dashboard"),
dashboardSidebar(),
dashboardBody(
# Boxes need to be put in a row (or column)
fluidRow(
box(plotlyOutput("plotdf", height = 250)),
box(
title = "Controls",
sliderInput("Date", "", min = df$Date[1], tail(df$Date, 1), value = tail(df$Date, 1)
)
)
)
)
)
server <- function(input, output) {
output$plotdf<-renderPlotly({
plot_df
})
}
shinyApp(ui, server)
We can use dplyr::filter and pipe it to plot_ly().
output$plotdf<-renderPlotly({
filter(df, Date <= input$Date) %>%
plot_ly() %>%
add_lines(type = 'scatter', mode = "lines",
x = ~Date, y = ~values)
})
Edit: Below is the plot code separated from the app with a sliderInput to select a range of dates.
library(shiny)
library(dplyr)
library(lubridate)
library(plotly)
source(file = 'my_functions_script.R', local = TRUE)
df <- data.frame(
"Date" = c(seq(ymd('2015-09-15'), ymd('2015-09-24'), by = "1 days")),
"values" = c(3,6,5,3,5,6,7,7,4,2)
)
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Basic dashboard"),
dashboardSidebar(),
dashboardBody(
# Boxes need to be put in a row (or column)
fluidRow(
box(plotlyOutput("plotdf", height = 250)),
box(
title = "Controls",
shiny::sliderInput("Date", "", min = df$Date[1], tail(df$Date, 1), value = c(df$Date[1],tail(df$Date, 1))
)
)
)
)
)
server <- function(input, output) {
output$plotdf<-renderPlotly({
filter(df,Date >= input$Date[[1]], Date <= input$Date[[2]]) %>%
plt()
})
}
shinyApp(ui, server)
I would like to update column headers in an R Shiny proxy table. The app should:
Launch with original column header names (e.g. "Do","Re","Mi","Fa","So")
Change those column headers in the proxy table to something else when the user clicks an action button (e.g. "y1","y2","y3","y4","y5")
Shiny has a convenient updateCaption() method that allows for a similar behavior for proxy table captions. I'd like to do something similar with table column headers for proxy tables. Here's my attempt.
library(shiny)
library(DT)
ui <- fluidPage(
fluidRow(
actionButton(
"updatebutton",
label = "Update Table",
style = "margin-right: 5px;"
),
DT::dataTableOutput("myplot")
),
)
server <- function(input, output) {
mycolumnnames <-c("Do","Re","Mi","Fa","So")
myothercolumnnames <- c("y1","y2","y3","y4","y5")
output$myplot <- DT::renderDataTable({
DF <- data.frame(replicate(5, sample(rnorm(5), 10, rep = TRUE)))
datatable(DF, colnames = mycolumnnames,
caption="Original caption")
})
proxy <- DT::dataTableProxy("myplot")
observeEvent(input$updatebutton, {
updateCaption(proxy, caption="Look, I am a NEW caption!")
DF <- data.frame(replicate(5, sample(rnorm(5), 10, rep = TRUE)))
# names(DF) <- myothercolumnnames # This doesn't work
proxy %>% replaceData(DF)
})
}
shinyApp(ui = ui, server = server)
Edit1: Now uses dataTableProxy()
I took away all the things related to color background so I could focus on your problem.
First, I declare some values outside shiny: your data.frame and two vectors for the column names. Then I assign the column names as the first vector.
Inside the app, I retrieve the data as a reactiveVal(), and update its colnames whenever the button is pressed
library(shiny)
library(DT)
mycolumnnames <-c("Do","Re","Mi","Fa","So")
myothercolumnnames <- c("y1","y2","y3","y4","y5")
DF <- data.frame(replicate(5, sample(rnorm(5), 10, rep = TRUE)))
colnames(DF) <- mycolumnnames
ui <- fluidPage(
fluidRow(
actionButton(
"updatebutton",
label = "Update Table",
style = "margin-right: 5px;"
),
DT::dataTableOutput("myplot")
),
)
server <- function(input, output) {
df <- reactiveVal(DF)
output$myplot <- DT::renderDataTable({
datatable(df(), caption="Original caption")
})
observeEvent(input$updatebutton, {
new_data <- data.frame(replicate(5, sample(rnorm(5), 10, rep = TRUE)))
if(!input$updatebutton %% 2 == 0 ){
colnames(new_data) <- myothercolumnnames
} else {
colnames(new_data) <- mycolumnnames
}
df(new_data)
proxy1 <- DT::dataTableProxy("myplot")
updateCaption(proxy1, caption="Look, I am a NEW caption!")
replaceData(proxy1, df())
})
}
shinyApp(ui = ui, server = server)
So whenever you press the button, the colnames are changed between the two vectors.
I have been trying to merge data with another data set based on input from a drop down. I have just started learning R and have run into some problems and want to know if there is a better way of going about this.
I am getting an error that it cannot coerce class c(ReactiveExpr, reactive) to a data frame.
library(shiny)
library(plyr)
library(dplyr)
library(xlsx)
server <- function(input, output){
annotation1 <- read.xlsx("input1.xlsx", sheetIndex = 1, header = TRUE)
annotation2 <- read.xlsx("input2.xlsx", sheetIndex = 1, header = TRUE)
data_input <- eventReactive(input$userfile, {
df <- read.xlsx(input$userfile$datapath, sheetIndex = 1, header = TRUE)
})
output$data_input <- renderTable(data_input())
output$annotation <- renderTable(annotation)
data_species <- c("Set1", "Set2")
# Drop-down selection box for which data set
output$choose_species <- renderUI ({
selectInput("species", "Species", as.list(data_species))
})
output$mergeddata <- renderTable({
if(input$species == "Set1"){
eventReactive("Set1",({left_join(data_input(), annotation1, by = c("Column1" = "Column1"))}))
}
else if(input$species == "Set2"){
eventReactive("Set2",({left_join(data_input(), annotation2, by = c("Column1" = "Column1"))}))
}
})
}
ui <- fluidPage(
titlePanel(
div("Test")
),
sidebarLayout(
sidebarPanel(
fileInput("userfile", "Input File", multiple =FALSE,
buttonLabel = "Browse Files", placeholder = "Select File"),
uiOutput("choose_species"),
uiOutput("choose_annotations"),
),
mainPanel(
tableOutput("mergeddata"),
br()
),
),
)
# Run the application
shinyApp(ui = ui, server = server)
In general, you approach seems ok. The error you get is from the line
eventReactive("Set1",({left_join(data_input(), annotation1, by = c("Column1" = "Column1"))}))
An eventReactive returns an (unevaluated) reactive expression which you try to render as data.frame with renderTable. To circumvent this, you could use:
eventReactive("Set1",({left_join(data_input(), annotation1, by = c("Column1" = "Column1"))}))()
However, here you don't need eventReactive, because your reactivity comes from input$species (you want to change the table output based on this input). Therefore, you can just use:
output$mergeddata <- renderTable({
if(input$species == "Set1"){
merge_data <- annotation1
} else {
merge_data <- annotation2
}
left_join(data_input(), merge_data, by = c("Column1"))
})
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.
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)