I am trying to build a form with R Shiny which will be used to populate a table once the action button at the end of the form is clicked. What I have not been able to figure out is how to pick up the data in the form and add it to a new row in the table. Right now, it just keeps updating the first row with whatever is in the form. I have reproduced a simple version of the code here:
#ui.r
library(shiny)
shinyUI(fluidPage(
# Application title
titlePanel("Test App"),
sidebarPanel(
numericInput("x", "Enter Value of X", 1),
numericInput("y", "Enter Value of Y", 1),
actionButton("add_data", "Add Data", width="100%")
),
mainPanel(
tableOutput("xy_Table")
)
)
)
#server.R
library(shiny)
library(tidyverse)
shinyServer(function(input, output) {
x <- vector("numeric")
y <- vector("numeric")
xyTable <- tibble(x, y)
e <- reactive(input$x)
f <- reactive(input$y)
eventReactive(input$add_data, {
xyTable %>% add_row(x=e(), y=f())
})
output$xy_Table <- renderTable({
xyTable
})
})
Thanks a lot for any help.
You need to use a reactive xyTable in order for the output to update. Also,
append the rows inside an observer rather than a reactive expression, and make sure to save the updated reactive value:
library(shiny)
library(tidyverse)
ui <- fluidPage(
sidebarPanel(
numericInput("x", "Enter Value of X", 1),
numericInput("y", "Enter Value of Y", 1),
actionButton("add_data", "Add Data", width = "100%")
),
mainPanel(
tableOutput("xy_Table")
)
)
server <- function(input, output, session) {
xyTable <- reactiveVal(
tibble(x = numeric(), y = numeric())
)
observeEvent(input$add_data, {
xyTable() %>%
add_row(
x = input$x,
y = input$y,
) %>%
xyTable()
})
output$xy_Table <- renderTable(xyTable())
}
shinyApp(ui, server)
Try this:
library(shiny)
library(tidyverse)
#ui.r
ui <- fluidPage(
# Application title
titlePanel("Test App"),
sidebarPanel(
numericInput("x", "Enter Value of X", 1),
numericInput("y", "Enter Value of Y", 1),
actionButton("add_data", "Add Data", width = "100%")
),
mainPanel(
tableOutput("xy_Table")
)
)
#server.R
server <- function(input, output) {
xyTable <- reactiveValues(
table1 = tibble(x = numeric(), y = numeric())
)
# what happens when `add_data` is clicked?
observeEvent(input$add_data, {
xyTable$table1 <- xyTable$table1 |>
add_row(x = input$x, y = input$y)
})
output$xy_Table <- renderTable({
xyTable$table1
})
}
shinyApp(ui, server)
#ui.r
library(shiny)
ui <- shinyUI(fluidPage(
# Application title
titlePanel("Test App"),
sidebarPanel(
numericInput("x", "Enter Value of X", 1),
numericInput("y", "Enter Value of Y", 1),
actionButton("add_data", "Add Data", width="100%")
),
mainPanel(
tableOutput("xy_Table")
)
)
)
#server.R
library(shiny)
library(tidyverse)
server <- shinyServer(function(input, output) {
x <- vector("numeric")
y <- vector("numeric")
xyTable <- reactiveValues()
xyTable$df <- tibble(x, y)
e <- reactive(input$x)
f <- reactive(input$y)
observeEvent(input$add_data, {
xyTable$df <- xyTable$df %>% add_row(x=e(), y=f())
})
output$xy_Table <- renderTable({
xyTable$df
})
})
shinyApp(ui,server)
Related
I am creating a Shiny app and I have started using the Waiter package.
When I load the app, before doing anything, we cannot see anything (at it is expected). When I generate the plot, the loading bar appears but when it finishes, it doesn't disappear. It stays a white box that it still can be seen.
Loading....
It has finished.
Does anyone know how to remove it?
Thanks in advance!
Code:
library(shiny)
library(magrittr)
library(DT)
library(ggplot2)
library(waiter)
new_choices <- setNames(names(mtcars), names(mtcars))
ui <- fluidPage(
# Application title
titlePanel("My shiny app"),
sidebarLayout(
sidebarPanel(
tabsetPanel(
tabPanel("Selection",
selectInput("x_axis", "Choose x axis",
choices = new_choices),
selectInput("y_axis", "Choose y axis",
choices = new_choices),
hr(),
),
tabPanel("Titles",
hr(),
textInput(inputId = "title", "You can write the title:", value = "This is the title"),
textInput(inputId = "xlab", "You can re-name the x-axis:", value = "x-axis...."),
textInput(inputId = "ylab", "You can re-name the y-axis:", value = "y-axis ...."),
),
tabPanel("Calculations",
hr(),
checkboxInput("log2", "Do the log2 transformation", value = F),
checkboxInput("sqrt", "Calculate the square root", value = F),
)
),
useWaitress(),
actionButton(inputId = "drawplot", label = "Show the plot")
),
# Show a plot of the generated distribution
mainPanel(
plotOutput("plot"),
)
)
)
server <- function(input, output, session) {
waitress <- Waitress$new(theme = "overlay-percent", min = 0, max = 10)
data <- reactive({
mtcars
})
filtered_data <- reactive({
data <- data()
if(input$log2 == TRUE){
data <- log2(data+1)
}
if(input$sqrt == TRUE){
data <- sqrt(data)
}
return(data)
})
v <- reactiveValues()
observeEvent(input$drawplot, {
# use notification
waitress$notify()
for(i in 1:10){
waitress$inc(1) # increase by 10%
Sys.sleep(.3)
}
v$plot <- ggplot() +
geom_point(data = filtered_data(),
aes_string(x = input$x_axis, y = input$y_axis)) +
xlab(input$xlab) +
ylab(input$ylab) +
ggtitle(input$title)
waitress$close() # hide when done
})
output$plot <- renderPlot({
if (is.null(v$plot)) return()
v$plot
})
}
shinyApp(ui, server)
Feels like a bug to me. You may file an issue to the waiter github repository and ask them to fix it. Meanwhile, a workaround we can do is to manually show and hide the bar by ourselves.
library(shiny)
library(magrittr)
library(DT)
library(ggplot2)
library(waiter)
library(shinyjs)
new_choices <- setNames(names(mtcars), names(mtcars))
ui <- fluidPage(
# Application title
titlePanel("My shiny app"),
sidebarLayout(
sidebarPanel(
tabsetPanel(
tabPanel("Selection",
selectInput("x_axis", "Choose x axis",
choices = new_choices),
selectInput("y_axis", "Choose y axis",
choices = new_choices),
hr(),
),
tabPanel("Titles",
hr(),
textInput(inputId = "title", "You can write the title:", value = "This is the title"),
textInput(inputId = "xlab", "You can re-name the x-axis:", value = "x-axis...."),
textInput(inputId = "ylab", "You can re-name the y-axis:", value = "y-axis ...."),
),
tabPanel("Calculations",
hr(),
checkboxInput("log2", "Do the log2 transformation", value = F),
checkboxInput("sqrt", "Calculate the square root", value = F),
)
),
useWaitress(),
useShinyjs(),
actionButton(inputId = "drawplot", label = "Show the plot")
),
# Show a plot of the generated distribution
mainPanel(
plotOutput("plot")
)
)
)
server <- function(input, output, session) {
waitress <- Waitress$new(theme = "overlay-percent", min = 0, max = 10)
data <- reactive({
mtcars
})
filtered_data <- reactive({
data <- data()
if(input$log2 == TRUE){
data <- log2(data+1)
}
if(input$sqrt == TRUE){
data <- sqrt(data)
}
return(data)
})
v <- reactiveValues()
observeEvent(input$drawplot, {
# use notification
show(selector = '.waitress-notification.notifications')
waitress$notify()
for(i in 1:10){
waitress$inc(1) # increase by 10%
Sys.sleep(.3)
}
v$plot <- ggplot() +
geom_point(data = filtered_data(),
aes_string(x = input$x_axis, y = input$y_axis)) +
xlab(input$xlab) +
ylab(input$ylab) +
ggtitle(input$title)
waitress$close()
hide(selector = '.waitress-notification.notifications')
})
output$plot <- renderPlot({
if (is.null(v$plot)) return()
v$plot
})
}
shinyApp(ui, server)
I have a small Shiny app that generates some data whenever the New data button is pressed. The Show plot button shows a hidden plot. I would like the plot to be hidden again automatically whenever the New data button is pressed to make a new data set. A bonus would be for the plot to be hidden also as soon as the slider is changed. I am not looking for a toggle action.
I tried adapting this example that uses conditional panel but I could not successfully figure out how to correctly change the values$show between TRUE and FALSE.
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput(inputId = "number",
label = "Pick a number",
min = 6,
max = 12,
value = 8),
actionButton("new_data",
"New data"),
actionButton("show_plot",
"Show plot")
),
mainPanel(
tableOutput("char_table"),
plotOutput(outputId = "car_plot")
)
)
)
server <- function(input, output) {
t <- eventReactive(input$new_data, {
r <- input$number
c <- r - 1
mat <- matrix(sample(0:1,r*c, replace=TRUE),r,c)
})
output$char_table <- renderTable({
t()
})
p <- eventReactive(input$show_plot, {
plot(cars)
})
output$car_plot <- renderPlot({
p()
})
}
shinyApp(ui = ui, server = server)
You can use a reactive value and a if to control the plot.
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput(inputId = "number",
label = "Pick a number",
min = 6,
max = 12,
value = 8),
actionButton("new_data",
"New data"),
actionButton("show_plot",
"Show plot")
),
mainPanel(
tableOutput("char_table"),
plotOutput(outputId = "car_plot")
)
)
)
server <- function(input, output) {
showPlot <- reactiveVal(FALSE)
t <- eventReactive(input$new_data, {
showPlot(FALSE)
r <- input$number
c <- r - 1
mat <- matrix(sample(0:1,r*c, replace=TRUE),r,c)
})
output$char_table <- renderTable({
t()
})
observeEvent(input$number, {
showPlot(FALSE)
})
observeEvent(input$show_plot, {
showPlot(TRUE)
})
output$car_plot <- renderPlot({
if (showPlot())
plot(cars)
})
}
shinyApp(ui = ui, server = server)
Alternate solution using shinyjs which is handy in these situations.
library(shiny)
library(shinyjs)
ui <- fluidPage( shinyjs::useShinyjs(),
sidebarLayout(
sidebarPanel(
sliderInput(inputId = "number",
label = "Pick a number",
min = 6,
max = 12,
value = 8),
actionButton("new_data",
"New data"),
actionButton("show_plot",
"Show plot")
),
mainPanel(
tableOutput("char_table"),
plotOutput(outputId = "car_plot")
)
)
)
server <- function(input, output) {
t <- eventReactive(input$new_data, {
hide("car_plot")
r <- input$number
c <- r - 1
mat <- matrix(sample(0:1,r*c, replace=TRUE),r,c)
})
output$char_table <- renderTable({
t()
})
observeEvent(input$show_plot, {
show("car_plot")
})
output$car_plot <- renderPlot({
plot(cars)
})
}
shinyApp(ui = ui, server = server)
I have a simple shiny app:
#ui.r
navbarPage(
"Application",
tabPanel("General",
sidebarLayout(
sidebarPanel(
uiOutput("tex2"),
uiOutput("book3")
),
mainPanel(
DT::dataTableOutput("hot3")
)
)))
#server.r
library(shiny)
library(DT)
server <- function(input, output,session) {
output$tex2<-renderUI({
numericInput("text2","#tests",
value = 1,
min=1
)
})
output$book3<-renderUI({
selectInput("bk3",
"Change Name",
choices=(rt1()[,1]))
})
rt1<-reactive({
data.frame(
Label=paste("Test",1:input$text2),
stringsAsFactors = FALSE)
})
output$hot3 <-DT::renderDataTable(
rt1(),
editable = TRUE
)
}
As you can see I have an editable datatable and I pass its label values to the selectInput() "Change Name". The problem is that when I edit the Labels in the datatable the values in the selectInput() do not change accordingly.
If I correctly understand what you want to do, I think this is not possible with DT.
This is possible with the D3TableFilter package (available on Github only so far). Please run this code and say me if this is indeed what you want to do:
library(shiny)
library(htmlwidgets)
library(D3TableFilter) # devtools::install_github("ThomasSiegmund/D3TableFilter")
ui <- navbarPage(
"Application",
tabPanel("General",
sidebarLayout(
sidebarPanel(
uiOutput("tex2"),
uiOutput("book3")
),
mainPanel(
d3tfOutput("hot3")
)
)
)
)
server <- function(input, output, session) {
output$tex2<-renderUI({
numericInput("text2", "#tests", value = 1, min=1)
})
rt1 <- reactiveVal(
data.frame(
Label = "Test 1",
stringsAsFactors = FALSE)
)
observe({
if(is.null(input$text2)) return(NULL)
rt1(
data.frame(
Label = paste("Test", 1:input$text2),
stringsAsFactors = FALSE)
)
})
output$book3 <- renderUI({
selectInput("bk3", "Change Name", choices=rt1()[,1])
})
output$hot3 <- renderD3tf({
# Define table properties. See http://tablefilter.free.fr/doc.php for a complete reference
tableProps <- list(
btn_reset = TRUE,
col_types = c("string", "string") # alphabetic sorting for the row names column
)
d3tf(rt1(),
tableProps = tableProps,
extensions = list(
list(name = "sort")
),
showRowNames = TRUE,
tableStyle = "table table-bordered",
edit = TRUE)
})
observe({
if(is.null(input$hot3_edit)) return(NULL);
edit <- input$hot3_edit;
isolate({
# need isolate, otherwise this observer would run twice for each edit
row <- as.integer(edit$row);
val <- edit$val;
dat <- rt1()
dat[,"Label"][row] <- val
rt1(dat)
})
})
}
shinyApp(ui, server)
Adapting the answer from Stéphane Laurent using DT gives the below:
library(shiny)
library(DT)
ui <- navbarPage(
"Application",
tabPanel("General",
sidebarLayout(
sidebarPanel(
uiOutput("tex2"),
uiOutput("book3")
),
mainPanel(
DTOutput("hot3")
)
)
)
)
server <- function(input, output, session) {
output$tex2<-renderUI({
numericInput("text2", "#tests", value = 1, min=1)
})
rt1 <- reactiveVal(
data.frame(
Label = "Test 1",
stringsAsFactors = FALSE)
)
observe({
if(is.null(input$text2)) return(NULL)
rt1(
data.frame(
Label = paste("Test", 1:input$text2),
stringsAsFactors = FALSE)
)
})
output$book3 <- renderUI({
selectInput("bk3", "Change Name", choices=rt1()[,1])
})
output$hot3 <- renderDT({
datatable(rt1(), editable = TRUE)
})
observe({
if(is.null(input$hot3_cell_edit)) return(NULL);
edit <- input$hot3_cell_edit;
isolate({
# need isolate, otherwise this observer would run twice for each edit
row <- as.integer(edit$row);
val <- edit$value;
dat <- rt1()
dat[,"Label"][row] <- val
rt1(dat)
})
})
}
shinyApp(ui, server)
I'm trying to make a Shiny application that display multiple plots on different rows and allow user to select the proper tendencies by using the radioButtons situated beside the graph. The problem is that I'm not able to get the radioButtons located directly beside the plots.
I want:
And I get:
My code:
server.R:
library(shiny)
shinyServer(function(input, output) {
lapply(1:3, function(iter) {
output[[paste0("g",iter)]] <- renderPlot({
set.seed(iter)
xx <- rnorm(10)
yy <- rnorm(10)
plot(xx,yy)
abline(reg=lm(yy~xx), col=2, lwd=ifelse(input[[paste0("radio",iter)]]==1,2,1))
abline(reg=lm(yy~xx+0), col=3, lwd=ifelse(input[[paste0("radio",iter)]]==2,2,1))
})
})
})
ui.R:
library(shiny)
shinyUI(fluidPage(
titlePanel("My loop test"),
fluidRow(
column(6,
lapply(1:3, function(iter) {
plotOutput(paste0("g",iter))
}
)),
column(3,
lapply(1:3, function(iter){
radioButtons(paste0("radio",iter),label = "buttons", choices = list("with intercept"=1,"without intersept"=2),selected = 1)
}
))
)
))
I hope it's clear. I'm new to Shiny (but not R) and I'm still in the steep part of the learning curve!
Thanks
Maybe something like this:
shinyUI(fluidPage(
titlePanel("My loop test"),
lapply(1:3, function(iter) {
fluidRow(
column(
6,
plotOutput( paste0("g",iter) )
),
column(
3,
radioButtons(
paste0("radio", iter),
label = "buttons",
choices = list("with intercept"=1,"without intersept"=2),
selected = 1)
)
)
})
))
This is a good use case for modules. I didn't get the buttons to line up perfectly, but that could be fixed with some CSS:
library(shiny)
myModUI <- function(id) {
ns <- NS(id)
tagList(
fluidRow(
splitLayout(cellWidths=c("75%","25%"),
plotOutput(ns("g")),
radioButtons(ns("radio"),label = "buttons",
choices = list("with intercept"=1,"without intersept"=2),
selected = 1))
)
)
}
myMod <- function(input, output, server, seed) {
output$g <- renderPlot({
set.seed(seed)
xx <- rnorm(10)
yy <- rnorm(10)
plot(xx,yy)
abline(reg=lm(yy~xx), col=2, lwd=ifelse(input$radio==1,2,1))
abline(reg=lm(yy~xx+0), col=3, lwd=ifelse(input$radio==2,2,1))
})
return(reactive(input$radio))
}
server <- shinyServer(function(input, output, server) {
lapply(1:5,function(i) {
callModule(myMod,i,seed=i)
})
})
ui <- shinyUI(fluidPage(
titlePanel("My loop test"),
mainPanel(
lapply(1:5,function(i) {
myModUI(i)
})
)
))
shinyApp(ui=ui,server=server)
Note that fluidRow isn't enough, we have to use splitLayout
I am having trouble with some code that I've written.
Here is a sample of the dataset: https://docs.google.com/spreadsheets/d/1C_P5xxzYr7HOkaZFfFiDhanqDSuSIrd2UkiC-6_G2q0/edit?usp=sharing
Objective:
I have a dataset that contains a column of Purchase_Month, candy and freq of the number of times that type of candy was purchased in that given month.
I have an rPlot which I was to change based on the chosen Candy bar in the SelectInput. And output a line chart based on the number of times that candy was purchased that month.
I have my current code below, but it tells me that candyCount is not found.
## ui.R ##
library(shinydashboard)
library(rCharts)
dashboardPage(
dashboardHeader(title = "Dashboard"),
dashboardSidebar(
width = 150,
sidebarMenu(
menuItem("Dashboard", tabName = "dashboard", icon = icon("bar-chart"))
)
),
dashboardBody(
sidebarPanel(
htmlOutput("candy")
),
mainPanel(
showOutput("plot2", "polycharts")
))
)
##server.R##
library(rCharts)
library(ggplot2)
library(ggvis)
server <- function(input, output, session) {
output$candy <- renderUI({
available2 <- dataset[(dataset$candy == input$candy), "candy"]
selectInput(
inputId = "candy",
label = "Choose a candy: ",
choices = sort(as.character(unique(available2))),
selected = unique(available2[1])
)
})
observeEvent(input$candy, {
candyChoice<- toString(input$customer_issue)
print(candyChoice)
candyCount<- dataset[dataset$candy == candyChoice, ]
})
})
output$plot2 <- renderChart2({
p2 <- rPlot(freq~purchase_month, data = candyCount, type = 'line')
p2$guides(y = list(min = 0, title = ""))
p2$guides(y = list(title = sprintf("%s Claims",input$candy)))
p2$addParams(height = 300, dom = 'chart2')
return(p2)
})
}
Updated Data: Why wouldn't this work?
candyCount<- reactive({
dataset[dataset$candy == input$candy, ]
})
output$plot2 <- renderChart2({
p2 <- rPlot(freq~purchase, data = candyCount(), type = 'line')
p2$guides(y = list(min = 0, title = ""))
p2$guides(y = list(title = ""))
p2$addParams(height = 300, dom = 'chart2')
return(p2)
})
output$candy <- renderUI({
available2 <- dataset[(dataset$candy == input$candy), "candy"]
selectInput(
inputId = "candy",
label = "Choose a candy: ",
choices = sort(as.character(unique(available2))),
selected = unique(available2[1])
)
})
In the above you are trying to subset by an input, which is inside your output. The selectInput needs to be inside UI.R.
A working basic example you may find useful.
library(shiny)
df <- read.csv("/path/to/my.csv")
ui <- shinyUI(pageWithSidebar(
headerPanel('Candy Data'),
sidebarPanel(
selectInput('candy', 'Candy', unique(as.character(df[,2])), selected = "Twix")
),
mainPanel(
plotOutput('plot1')
)
))
server <- shinyServer(function(input, output, session) {
selectedData <- reactive({
df[which(df[,2] == input$candy),3]
})
output$plot1 <- renderPlot({
barplot(selectedData())
})
})
shinyApp(ui, server)
In the above example the ui renders a selectInput which has the ID candy. The value, i.e the candy selected is now assigned to input$candy scope. In server we have a reactive function watching for any input change. When the user selects a new candy this function, df[which(df[,2] == input$candy),3] is saying "subset my data frame, df, by the new input$candy". This is now assigned to the selectedData(). Finally we render then boxplot.
EDIT
server.R
require(rCharts)
options(RCHART_WIDTH = 500)
df <- read.csv("path/to/my.csv")
shinyServer(function(input, output, session) {
selectedData <- reactive({
df[which(df[,2] == input$candy),]
})
output$plot1 <- renderChart({
p <- rPlot(freq~purchase_month, data = selectedData(), type = "line")
p$addParams(dom = 'plot1')
return(p)
})
})
ui.R
require(rCharts)
options(RCHART_LIB = 'polycharts')
shinyUI(pageWithSidebar(
headerPanel('Candy Data'),
sidebarPanel(
selectInput('candy', 'Candy', unique(as.character(df[,2])), selected = "Twix")
),
mainPanel(
showOutput('plot1', 'polycharts')
)
))
save files in directory and then runApp.
At available2 you're filtering the data about a selected candy with dataset$candy == input$candy. But you use the same available2 to determine which are the choices at selectInput. I'm guessing you wanted: available2 <- dataset[, "candy"].