Setting a "Reset Values" button on Shiny - r

I have put together a Shiny app that reactively creates lists while simultaneously removing those selections from the list you're selecting from. I'm trying to put together a feature where you click a reset button and it does the following:
1.) Deselects all input options
2.) Sets the Age Range to 18 - 104 (so it captures all values)
3.) Moves the other two sliders to zero
I'm trying to use the shinyjs::reset function, but it doesn't appear to be working. Take a look:
df <- read.csv('https://raw.githubusercontent.com/gooponyagrinch/sample_data/master/datasheet.csv')
library(shiny)
library(shinyWidgets)
library(shinyjs)
library(tidyverse)
library(DT)
ui <- fluidPage(
div(id = "myapp",
fluidRow(
column("",
width = 10, offset = 1,
tags$h3("Select Area"),
panel(
sliderInput("current", "Current Score",
min = 0, max = 100, value = 20),
sliderInput("projected", "Projected Score",
min = 0, max = 100, value = 20),
sliderInput("age", "Age",
min = 18, max = max(df$age), value = c(18,24)),
checkboxGroupInput("ethnicity",label = "Ethnicity",
choices = list("Caucasian"="Caucasian",
"African-American"="African-American",
"Hispanic"="Hispanic",
"Other"="Other")),
checkboxInput('previous', label = "Previous Sale"),
checkboxInput('warm', label = "Warm Lead"),
actionButton("button", "Add to List"),
actionButton("reset", "Reset form")),
textOutput("counter"),
tags$h2("Data to filter"),
DT::dataTableOutput("table"),
tags$h2("IDs added to list"),
DT::dataTableOutput("addedToList")
)
)
)
)
server <- function(input, output, session) {
filterData = reactiveVal(df %>% mutate(key = 1:nrow(df)))
addedToList = reactiveVal(data.frame())
filtered_df <- reactive({
res <- filterData() %>% filter(current_grade >= input$current)
res <- res %>% filter(projected_grade >= input$projected)
res <- res %>% filter(age >= input$age[1] & age <= input$age[2])
res <- res %>% filter(ethnicity %in% input$ethnicity | is.null(input$ethnicity))
if(input$previous == TRUE)
res <- res %>% filter(previous_sale == 1)
if(input$warm == TRUE)
res <- res %>% filter(warm_lead == 1)
res
})
output$counter <- renderText({
res <- filtered_df() %>% select(customer_id) %>% n_distinct()
res
})
output$table <- renderDataTable({
res <- filtered_df() %>% distinct(customer_id)
res
})
observeEvent(input$button, {
addedToList(rbind(addedToList(),
filterData() %>% filter(key %in% filtered_df()$key) %>%
select(customer_id) %>% distinct() ))
filterData(filterData() %>% filter(!key %in% filtered_df()$key))
})
observeEvent(input$reset, {
shinyjs::reset("myapp")
})
output$addedToList <- renderDataTable({
addedToList()
})
}
shinyApp(ui,server)
Am I missing something?

All you need to do is ensure that your application is listening for a call to "ShinyJS" in your application. In the UI, add the useShinyJS() call!
ui <- fluidPage(
useShinyJS()
div(id = "myapp",
fluidRow(...)
)
I also should note this looks like a repeat of this question. 'Reset inputs' button in shiny app

Related

How can I render and remove UI in a Shiny App depending on a textInput and some conditions?

I want to render UI depending on a textInput() and some conditions. Like when the number of chars in my textInput() is greater than 2 and also matches a value from a variable of a dataset, i want to render the new UI. Otherwise when the number of chars is samller than 3, the UI should be removed. But somehow the UI is permanently removed/not visible even if both conditions are TRUE. What do i miss here?
library(shiny)
library(tidyverse)
data = starwars
ui = fluidPage(
textInput("txt", "Look up name"),
uiOutput(outputId = "new"),
)
server = function(input, output, session){
res = reactive({data%>%filter(str_detect(name, input$txt))%>%slice_min(order_by = birth_year, n = 3)%>%pull(name)})
observeEvent(input$txt, {
if(str_detect(paste(res(), collapse = " "), input$txt) & nchar(input$txt) > 2){
output$new <- renderUI({
div(id = "new",
map(.x = res(), .f = ~div(.x)))
})
}else if(nchar(input$txt) < 3){
removeUI(selector = "#new")
}
})
}
shinyApp(ui, server)
Perhaps you should just return(NULL) as shown below or give a different id to your div(id="new2").
library(shiny)
library(tidyverse)
#data <- starwars
ui = fluidPage(
textInput("txt", "Look up name"),
uiOutput(outputId = "new")
)
server = function(input, output, session){
res <- eventReactive(input$txt, {
req(input$txt)
starwars %>% dplyr::filter(str_detect(name, input$txt)) %>%
dplyr::slice_min(order_by = birth_year, n = 3) %>% pull(name)
})
observeEvent(input$txt, {
if(str_detect(paste(res(), collapse = " "), input$txt) & nchar(input$txt) > 2){
output$new <- renderUI({
div(id = "new",
map(.x = res(), .f = ~div(.x)))
})
}else { # if(nchar(input$txt) < 3){
output$new <- renderUI({return(NULL)})
#removeUI(selector = "#new2") ### different id also works
}
})
}
shinyApp(ui, server)

R Shiny How to create Dependent filters for Dataframe

I need to create an application where I filter multiple fields from a data frame. When the first field is filtered (using Date Range), the user then has to filter several pickerInputs before the data is displayed in a table. I'm not sure if this is the best way to create dependent filters. I cannot seem to find enough resources. I have tried the following. However, I'm not sure why I keep getting this warning::
Warning:Error in: Problem with filter() input '..1'
X Input '..1' must be of size 100 or 1, not size 0
get_data <- function(size){
longs <- seq(from=40, to =90, by = 0.01)
lats <- seq(from = 5, to= 50, by = 0.01)
LONGITUDE <- sample(longs, size, rep = TRUE)
LATITUDE <- sample(lats, size, rep = TRUE)
df <- data.frame(cbind(LONGITUDE, LATITUDE))
df$LOCATION <- sample(c("Location_A", "Location_B", "Location_C"), size, replace = T, prob = c(0.4, 0.4, 0.2))
df$EQUIPMENT <- sample(c("Equipment_A", "Equipment_B", "Equipment_C", "Equipment_D"), size, replace = TRUE)
startTime <- as.POSIXct("2016-01-01")
endTime <- as.POSIXct("2019-01-31")
df$DATE <- as.Date(sample(seq(startTime, endTime, 1), size))
df$WEEKDAY <- weekdays(as.Date(df$DATE))
return(df)
}
df <-get_data(100)
ui <- navbarPage(
id = "navBar",
title = "Data Exploration",
theme = shinytheme("cerulean"),
shinyjs::useShinyjs(),
selected = "Data",
tabPanel("Data",
fluidPage(
sidebarPanel(
div(id = "form",
uiOutput('timestamp'),
uiOutput('location'),
uiOutput('days_of_week'),
uiOutput('equipment_type'),
hr(),
HTML("<h3>Reset your filter settings here:</h3>"),
actionButton("resetAll", "Reset Entries"),
hr()),
mainPanel(
DT::DTOutput("datatable"))))
)
)#end the ui
server <- function(session, input, output){
filter_data <- reactive({
df %>%
filter(DATE >= input$timestamp[1] & DATE <= input$timestamp[2]) %>%
filter(LOCATION %in% input$location) %>%
filter(WEEKDAY %in% input$days_of_week) %>%
filter(EQUIPMENT %in% input$equipment_type)
})
output$timestamp <- renderUI({
dateRangeInput('timestamp',label = 'Date range input:',start = min(df$DATE), end = max(df$DATE))
})
output$location <- renderUI({
location <- reactive({
df %>%
filter(DATE >= input$timestamp[1] & DATE <= input$timestamp[2]) %>%
pull(LOCATION) %>%
as.character() %>% unique()
})
pickerInput('location', "Select Location:", choices = location(),selected = NULL, options = list(`actions-box` = TRUE),multiple = T)
})
output$days_of_week <- renderUI({
days_of_week <- reactive({
df %>%
filter(DATE >= input$timestamp[1] & DATE <= input$timestamp[2]) %>%
filter(LOCATION %in% input$location) %>%
pull(WEEKDAY) %>%
as.character() %>% unique()
})
pickerInput('days_of_week', 'Choose Weekdays:', choices=days_of_week(), selected = NULL, options = list(`actions-box` = TRUE),multiple = T)
})
output$equipment_type <- renderUI({
equipment <- reactive({
df %>%
filter(DATE >= input$timestamp[1] & DATE <= input$timestamp[2]) %>%
filter(LOCATION%in% input$location) %>%
filter(WEEKDAY %in% input$days_of_week) %>%
pull(EQUIPMENT) %>%
as.character() %>% unique()
})
pickerInput('equipment_type', "Choose Equipment:", choices = equipment(),selected = NULL, options = list(`actions-box` = TRUE),multiple = T)
})
output$datatable <- DT::renderDT({
filter_data()
})
#Allow the user to reset all their inputs
observeEvent(input$resetAll, {
reset("form")
})
}
shinyApp(ui, server)
I think your warnings are due to input$timestamp being NULL the first time in your reactive expressions, before you create the dateRangeInput.
You could move your input to ui, and then use updatePickerInput when the dates change to alter your other inputs accordingly.
You might want to include two separate reaction expressions. One for filtering the data based on the date range, which will be used to update the other pickers. The second will include the other filters for location, equipment, and weekday, based on the picker selections.
See if this provides something closer to what you are looking for. I included what seemed to be the relevant packages at the top. I also adjusted your parentheses in the ui a bit.
library(shinythemes)
library(shinyWidgets)
library(shinyjs)
library(shiny)
library(dplyr)
get_data <- function(size){
longs <- seq(from=40, to =90, by = 0.01)
lats <- seq(from = 5, to= 50, by = 0.01)
LONGITUDE <- sample(longs, size, rep = TRUE)
LATITUDE <- sample(lats, size, rep = TRUE)
df <- data.frame(cbind(LONGITUDE, LATITUDE))
df$LOCATION <- sample(c("Location_A", "Location_B", "Location_C"), size, replace = T, prob = c(0.4, 0.4, 0.2))
df$EQUIPMENT <- sample(c("Equipment_A", "Equipment_B", "Equipment_C", "Equipment_D"), size, replace = TRUE)
startTime <- as.POSIXct("2016-01-01")
endTime <- as.POSIXct("2019-01-31")
df$DATE <- as.Date(sample(seq(startTime, endTime, 1), size))
df$WEEKDAY <- weekdays(as.Date(df$DATE))
return(df)
}
df <-get_data(100)
ui <- navbarPage(
id = "navBar",
title = "Data Exploration",
theme = shinytheme("cerulean"),
shinyjs::useShinyjs(),
selected = "Data",
tabPanel("Data",
fluidPage(
sidebarPanel(
div(id = "form",
dateRangeInput('timestamp', label = 'Date range input:', start = min(df$DATE), end = max(df$DATE)),
pickerInput('location', "Select Location:", choices = unique(df$LOCATION), options = list(`actions-box` = TRUE), multiple = T),
pickerInput('days_of_week', 'Choose Weekdays:', choices = unique(df$WEEKDAY), options = list(`actions-box` = TRUE), multiple = T),
pickerInput('equipment_type', "Choose Equipment:", choices = unique(df$EQUIPMENT), options = list(`actions-box` = TRUE), multiple = T),
hr(),
HTML("<h3>Reset your filter settings here:</h3>"),
actionButton("resetAll", "Reset Entries"),
hr())
),
mainPanel(
DT::DTOutput("datatable")))
)
)#end the ui
server <- function(session, input, output){
filter_by_dates <- reactive({
filter(df, DATE >= input$timestamp[1] & DATE <= input$timestamp[2])
})
filter_by_all <- reactive({
fd <- filter_by_dates()
if (!is.null(input$location)) {
fd <- filter(fd, LOCATION %in% input$location)
}
if (!is.null(input$days_of_week)) {
fd <- filter(fd, WEEKDAY %in% input$days_of_week)
}
if (!is.null(input$equipment_type)) {
fd <- filter(fd, EQUIPMENT %in% input$equipment_type)
}
return(fd)
})
observeEvent(input$timestamp, {
updatePickerInput(session, 'location', "Select Location:", choices = unique(filter_by_dates()$LOCATION), selected = input$location)
updatePickerInput(session, 'days_of_week', 'Choose Weekdays:', choices = unique(filter_by_dates()$WEEKDAY), selected = input$days_of_week)
updatePickerInput(session, 'equipment_type', "Choose Equipment:", choices = unique(filter_by_dates()$EQUIPMENT), selected = input$equipment_type)
})
output$datatable <- DT::renderDT({
filter_by_all()
})
#Allow the user to reset all their inputs
observeEvent(input$resetAll, {
reset("form")
})
}
shinyApp(ui, server)
Edit (1/28/21): Based on the comment, it sounds like there is interest in updating all the input choices based on selections made.
If you substitute observeEvent with an observe, and use filter_by_all() instead of filter_by_date() in the three updatePickerInput, then all the non-date input choices will update whenever any changes are made to any input:
observe({
input$timestamp
updatePickerInput(session, 'location', "Select Location:", choices = unique(filter_by_all()$LOCATION), selected = input$location)
updatePickerInput(session, 'days_of_week', 'Choose Weekdays:', choices = unique(filter_by_all()$WEEKDAY), selected = input$days_of_week)
updatePickerInput(session, 'equipment_type', "Choose Equipment:", choices = unique(filter_by_all()$EQUIPMENT), selected = input$equipment_type)
})

isolate reactive function for displaying selections and filters after action button

I am trying to create a reactive function with the isolate command from the following code in the ui.R file into the server.R file where the data table only populates after the user has inputed their selections and filters only.
Right now the data table just populates on its own after running the filters and selections without having to click on the Run Query button.
Any help would be appreciated!
actionButton("runit", "RUN QUERY")
Thank you so much!
Code below:
ui.R
library(DT)
library(shiny)
library(shinydashboard)
ui <- function(request) {
dashboardPage(
dashboardHeader(title = "CL Pivot"),
dashboardSidebar(
actionButton("runit", "RUN QUERY"),
h4(HTML("&nbsp"), "Select Table Rows"),
uiOutput("rowSelect"),
hr(),
h4(HTML("&nbsp"), "Select Table Columns"),
uiOutput("colSelect"),
hr(),
h4(HTML("&nbsp"), "Select Table Cell Fill"),
selectizeInput(
inputId = "funChoices",
label = NULL,
multiple = FALSE,
choices = c("Count", "Average", "Median", "Sum", "Maximum", "Minimum"),
selected = c()
),
hr(),
h4(HTML("&nbsp"), "Filter Data Set"),
uiOutput("hairColorFilter"),
uiOutput("skinColorFilter")
),
dashboardBody(dataTableOutput("data"))
)
}
server.R
library(DT)
library(shiny)
library(shinydashboard)
library(dplyr)
library(dbplyr)
library(tidyverse)
library(DBI)
data <- starwars
# Convenience Function to Make Upcoming Chain Less Messy
fun_across <- function(cols, fun, fun_name) {
fun_list <- list(fun)
names(fun_list) <- fun_name
across(all_of(cols), fun_list, .names = "{fn}_{col}")
}
shinyServer(function(input, output, session) {
# Identify Measures and Dimensions -------------
dimensions <- colnames(data)[!sapply(data, is.numeric)]
measures <- colnames(data)[sapply(data, is.numeric)]
# Identify Filter Choices -----------------------------------------------
hairColorChoices <- sort(unique(data$hair_color))
skinColorChoices <- sort(unique(data$skin_color))
# Define User Inputs ----------------------------------------------------
output$rowSelect <- renderUI({
selectizeInput(
inputId = "rowChoices",
label = NULL,
multiple = TRUE,
choices = dimensions,
selected = c()
)
})
output$colSelect <- renderUI({
selectizeInput(
inputId = "colChoices",
label = NULL,
multiple = TRUE,
choices = measures,
selected = c()
)
})
output$hairColorFilter <- renderUI({
sidebarMenu(
menuItem(
text = "Hair Color",
icon = icon("briefcase"),
checkboxGroupInput(
inputId = "hairColorChoices",
label = NULL,
choices = hairColorChoices,
selected = hairColorChoices
)
)
)
})
output$skinColorFilter <- renderUI({
sidebarMenu(
menuItem(
text = "Skin Color",
icon = icon("thermometer-half"),
checkboxGroupInput(
inputId = "skinColorChoices",
label = NULL,
choices = skinColorChoices,
selected = skinColorChoices
)
)
)
})
# Define Reactive Functions ---------------------------------------------
pairColFuns <- reactive({
colChoices <- input$colChoices
names(colChoices) <- input$funChoices
return(colChoices)
})
# Construct DataFrame Based on User Inputs
output$data <- renderDataTable({
colChoices <- pairColFuns()
rowChoices <- input$rowChoices
countCols <- unname(colChoices[names(colChoices) == "Count"])
averageCols <- unname(colChoices[names(colChoices) == "Average"])
medianCols <- unname(colChoices[names(colChoices) == "Median"])
sumCols <- unname(colChoices[names(colChoices) == "Sum"])
maxCols <- unname(colChoices[names(colChoices) == "Maximum"])
minCols <- unname(colChoices[names(colChoices) == "Minimum"])
displayTable <- as_tibble(data) %>%
filter(
hair_color %in% input$hairColorChoices,
skin_color %in% input$skinColorChoices
) %>%
group_by(across(all_of(rowChoices))) %>%
summarize(
# Once again we've sacrificed a bit of elegance for clarity. This chunk will
# apply the specified function to whichever columns are included in the
# specified variable. If the variable is empty, no operation is performed.
fun_across({{countCols}}, length, "count"),
fun_across({{averageCols}}, ~mean(.x, na.rm = TRUE), "average"),
fun_across({{medianCols}}, ~median(.x, na.rm = TRUE), "median"),
fun_across({{sumCols}}, ~sum(.x, na.rm = TRUE), "total"),
fun_across({{maxCols}}, ~max(.x, na.rm = TRUE), "max"),
fun_across({{minCols}}, ~min(.x, na.rm = TRUE), "min"),
.groups = "drop"
)
return(displayTable)
})
})
I would split the table rendering and data processing, then you can use the eventReactive approach. This saves you to wrap every input into isolate.
First make an eventReactive that calculates your data. It only updates if the first reactive/input changes. Then you can use this to render your table:
table_data <- eventReactive(input$runit, {
colChoices <- pairColFuns()
rowChoices <- input$rowChoices
countCols <- unname(colChoices[names(colChoices) == "Count"])
averageCols <- unname(colChoices[names(colChoices) == "Average"])
medianCols <- unname(colChoices[names(colChoices) == "Median"])
sumCols <- unname(colChoices[names(colChoices) == "Sum"])
maxCols <- unname(colChoices[names(colChoices) == "Maximum"])
minCols <- unname(colChoices[names(colChoices) == "Minimum"])
displayTable <- as_tibble(data) %>%
filter(
hair_color %in% input$hairColorChoices,
skin_color %in% input$skinColorChoices
) %>%
group_by(across(all_of(rowChoices))) %>%
summarize(
# Once again we've sacrificed a bit of elegance for clarity. This chunk will
# apply the specified function to whichever columns are included in the
# specified variable. If the variable is empty, no operation is performed.
fun_across({{countCols}}, length, "count"),
fun_across({{averageCols}}, ~mean(.x, na.rm = TRUE), "average"),
fun_across({{medianCols}}, ~median(.x, na.rm = TRUE), "median"),
fun_across({{sumCols}}, ~sum(.x, na.rm = TRUE), "total"),
fun_across({{maxCols}}, ~max(.x, na.rm = TRUE), "max"),
fun_across({{minCols}}, ~min(.x, na.rm = TRUE), "min"),
.groups = "drop"
)
displayTable
})
output$data <- renderDataTable({
table_data()
})
You need to isolate() all inputs that shouldn't trigger the event, and you could use req() to enable the submit button:
pairColFuns <- reactive({
colChoices <- isolate(input$colChoices) #isolated
names(colChoices) <- isolate(input$funChoices) #isolated
return(colChoices)
})
# Construct DataFrame Based on User Inputs
output$data <- renderDataTable({
req(input$runit) # submit button should trigger
colChoices <- pairColFuns()
rowChoices <- isolate(input$rowChoices) #isolated
countCols <- unname(colChoices[names(colChoices) == "Count"])
averageCols <- unname(colChoices[names(colChoices) == "Average"])
medianCols <- unname(colChoices[names(colChoices) == "Median"])
sumCols <- unname(colChoices[names(colChoices) == "Sum"])
maxCols <- unname(colChoices[names(colChoices) == "Maximum"])
minCols <- unname(colChoices[names(colChoices) == "Minimum"])
displayTable <- as_tibble(data) %>%
filter(
hair_color %in% isolate(input$hairColorChoices), #isolated
skin_color %in% isolate(input$skinColorChoices) #isolated
...

DT output takes me to 1st page when i edit a reactive DT

I have a toy version of my code below. I have one of the columns (column 7) in my shiny DT output as editable. When i edit the a cell of the column it takes me back to the first row of of the column. I checked the data table object in environment, the edited cell does get update. So, that is good. But i want to stay on the same page after editing the cell. This is because a user may have applied a few filters to reach a certain page and then when he edits a cell he would like to continue from there rather than going back to start.
I am new to R so any help would be greatly appreciated.
I am using DT 0.7
My data frame has 7 columns: Continent, State, Country, Date, Rate (Pollution), Vehicles, Remark (editable column)
A user can filter the table output by select input, range and slider input. I want to make that output editable.
Thanks in advance!
library(shiny)
library(DT)
ui <- navbarPage("Hello",
tabPanel("Tab1",
sidebarLayout(
sidebarPanel( width = 4,
selectInput("continent", "Select:",
choices = ""),
selectInput("country" , "Select:",
choices = ""),
selectInput("state" , "Select:",
choices = ""),
dateRangeInput("date", "Select:",
startview = "month",
minview = "months",
maxview = "decades",
start = as.Date('1999-01-01'),
end = as.Date(today()),
separator = "-"),
sliderInput("rate", "Select:",
min = 1, max = 5, value = c(1,5),
dragRange = TRUE)),
mainPanel(
tabsetPanel(
tabPanel("Analysis",
dataTableOutput("Table1")
)))))
#server
server <- function(input, output, session)
{
observe({
updateSelectInput(session, "continent",
choices = c("All", unique(Df$Continent)))
})
observe({
updateSelectInput(session, "country",
choices = c("All", Df %>%
filter(`Continent` == input$continent) %>%
select(Country)))
})
observe({
updateSelectInput(session, "state",
choices = c("All", Df %>%
filter(`Continent` == input$continent &
`Country` == input$country) %>%
select(State)))
})
#create reactive table
RecTable <- reactive({
Df
if(input$continent != "All") {
Df <- Df[Df$Continent == input$continent,]
}
if(input$country != "All") {
Df <- Df[Df$Country == input$country,]
}
if(input$state != "All") {
Df <- Df[Df$State == input$state,]
}
Df <- Df %>%
filter(Date >= input$date[1] & Date <= input$date[2]) %>%
filter(Rate >= input$rate[1] & Rate <= input$rate[2])
Df})
output$Table1 <- DT::renderDT({
DT::datatable(RecTable(),
rownames = FALSE ,
editable = list(target = 'cell', disable = list(columns = c(0:6))))
})
proxy1 <- dataTableProxy('Table1')
observeEvent(input$Table1_cell_edit, {
Df <<- editData(Df, input$Table1_cell_edit, 'Table1', rownames = FALSE, resetPaging = FALSE)
})}
#run
shinyApp(ui = ui, server = server)

ggvis plot disappears at random Shiny

I have a strange problem in Shiny. My shiny app has one ggvis plot with layer_points() and several options to manipulate the plot . When I run my app sometimes everything works good even if I change all options, but sometimes ( I suppose there is no specific rule) plot disappers. Plot comes back when I change one of options but it is not cool.
I study this issue but I do not really know whether it is a solution for my problem.
When the plot disappears my Shiny app looks like:
This my code:
ui.R
library(ggvis)
library(markdown)
library(shiny)
library(dplyr)
library(magrittr)
shinyUI(
fluidPage(
h3("Title"),
fluidRow(
column(3,
wellPanel(
radioButtons("radio",h5("Select"),choices=list("All values","Selected values"),
selected="All values"),
conditionalPanel(
condition = "input.radio != 'All values'",
checkboxGroupInput("checkGroup",label = "",
choices,
selected = c("AT1","AT2"))
),
hr(),
radioButtons("dataset", label = h5("Drilldown"),
choices = list("2 Level" = "df1", "3 Level" = "df2")
),
hr(),
h5("Choice"),
selectInput("xvar", h6(""),
axis_vars_x,
selected = "value"),
selectInput("yvar", h6(""),
axis_vars_y,
selected = "number2"),
hr(),
uiOutput("slider")
)
),
column(9,
ggvisOutput("plot")
)
)
)
)
server.R
library(shiny)
shinyServer(function(input, output,session) {
datasetInput <- reactive({
switch(input$dataset,
df2 = df2,
df1 = df1)
})
axis_vara_y <- reactive({
switch(input$yvar,
number = 2,
number2 = 3)
})
output$slider <- renderUI({
sliderInput("inslider",h5(""), min = round(min(datasetInput()[,axis_vara_y()]),0)-1,
max = round(max(datasetInput()[,axis_vara_y()]),0)+1,
value = c(round(min(datasetInput()[,axis_vara_y()]),0)-1,
round(max(datasetInput()[,axis_vara_y()]),0)+1),
step = 0.5)
})
data <- reactive({
filteredData <- datasetInput()
axisData <- axis_vara_y()
if(!is.null(input$inslider)){
if(input$radio == "All values"){
filteredData <- filteredData %>%
filter(filteredData[,axisData] >= input$inslider[1],
filteredData[,axisData] <= input$inslider[2])
}
else {
filteredData <- filteredData %>%
filter(value %in% input$checkGroup,
filteredData[,axisData] >= input$inslider[1],
filteredData[,axisData] <= input$inslider[2])
}
}
return(filteredData)
})
data_point <- reactive({
data() %>%
mutate(id = row_number())
})
xvar <- reactive(as.symbol(input$xvar))
yvar <- reactive(as.symbol(input$yvar))
dotpoint_vis <- reactive({
xvar_name <- names(axis_vars_x)[axis_vars_x == input$xvar]
yvar_name <- names(axis_vars_y)[axis_vars_y == input$yvar]
data_point_detail <- data_point()
plot <- data_point_detail %>%
ggvis(x = xvar(),y = yvar()) %>%
layer_points(size := 120,fill = ~value) %>%
add_axis("x", title = xvar_name) %>%
add_axis("y", title = yvar_name) %>%
set_options(width = 750, height = 500, renderer = "canvas")
})
dotpoint_vis %>% bind_shiny("plot")
})
global.R
choices <- list("Value1" = "AT1", "Value2" = "AT2",
"Value3" = "AT3", "Value4" = "AT4",
"Value5" = "AT5", "Value6" = "RT1",
"Value7" = "AT6", "Value8" = "AT7",
"Value9" = "AT8", "Value10" = "AT9",
"Value11" = "AT10", "Value12" = "RT2")
levele <- c("AT1","AT2","AT3","AT4","AT5","RT1","AT6","AT7","AT8","AT9","AT10","RT2")
df1 <- data.frame(value = levele,number = seq(2,46,4), number2 = seq(2,24,2),order = 1:12)
df2 <- data.frame(value = levele,number = rep(4:15), number2 = rep(4:9,each = 2),order = 1:12)
df1$value <- factor(df1$value, levels = levele)
df2$value <- factor(df2$value, levels = levele)
axis_vars_y <- c("number","number2")
axis_vars_x <- c("value", "order","number","number2")
update
I also do not know what happened with animation in ggvis.
The problem was difficult to reproduce at first, but I found I can reproduce it by clicking back and forth between All Values and Selected Values. The graph disappears or reappears after some number of switches between the two radio buttons, but it varies seemingly randomly -- sometimes it takes 4 clicks to make the graph disappear or reappear and other times it takes 2 clicks or some other number of clicks.
There must be a bug in bind_shiny() or ggvisOutput(), because the following changes do create a graphic that does not seem to disappear:
In ui.R, make this change:
# ggvisOutput("plot")
plotOutput('plot')
In server.R, make this change:
plot(data_point_detail[ , c(input$xvar, input$yvar)], xlab=xvar_name, ylab=yvar_name)
# plot <- data_point_detail %>%
# ggvis(x = xvar(),y = yvar()) %>%
# layer_points(size := 120,fill = ~value) %>%
# add_axis("x", title = xvar_name) %>%
# add_axis("y", title = yvar_name) %>%
# set_options(width = 750, height = 500, renderer = "canvas")
# plot
and
output$plot <- renderPlot(dotpoint_vis())
# dotpoint_vis %>% bind_shiny("plot")

Resources