I have a shiny app where a user filters the article column of my dataset depending on the articles he wants to see. Those articles are then displayed in a table. The articles react as actionbutton with a custom function on a click.
I want that whenever a user clicks on a certain article, this article is selected in selectInput. Nevertheless I have no idea which value to pass to the selected attribute of updateSelectInput.
I have put three question marks in the place where I am stuck. By removing the three questionmarks the code is executable.
Any help appreciated
library(shiny)
library(tidyverse)
library(kableExtra)
library(formattable)
df = tibble(article=c("one", "two", "three", "four", "five", "six"),
group=c("a", "a", "a", "b", "b", "b"),
sales=c(12,13,14,43,50,45))
ui = fluidPage(
sidebarPanel(
radioButtons(inputId = "select_a", label = "Choose a group", choices = unique(df$group), selected = "a"),
htmlOutput(outputId = "table")),
sidebarPanel(
selectInput(inputId = "select_b", label = "Choose an article", choices = df$article, selected = "one")
)
)
server = function(input, output, session){
shinyInput <- function(FUN, len, id, labels, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), label = labels[i], ...))
}
inputs
}
df_reactive = reactive({
df %>% filter(group == input$select_a) %>%
mutate(article = shinyInput(actionButton, n(), 'button_', labels = article, onclick = 'Shiny.onInputChange(\"select_button\", this.id)'))
})
output$table = function(){
df_reactive() %>%
kable("html", escape = F, align = "c") %>%
kable_styling(bootstrap_options = c("striped", "condensed", "responsive"), full_width = F, position = "center") %>%
scroll_box(width = "100%", height = "auto")
}
observeEvent(input$select_button, {
updateSelectInput(session = session, inputId = "select_b", selected = ???)
})
}
shinyApp(ui = ui, server = server)
Perhaps you can use this.innerText to retrieve the article here:
mutate(article = shinyInput(actionButton, n(), 'button_', labels = article,
onclick = 'Shiny.onInputChange(\"select_button\", this.innerText)'))
And then input$select_button will contain the text string to select:
updateSelectInput(session = session, inputId = "select_b", selected = input$select_button)
Related
I would like to select one sample from my dataset in a dropdown menu.
As there are many samples to choose from, I would like to narrow down the selectable samples by selecting the values of additional data columns in checkbox dropdown menus.
I can successfully create the checkbox dropdown menus and and print the selections made there.
I am struggling with feeding these same selected values into the dropdown menu that chooses the sample. I want to make the choices of the selectInput reactive but can't access the variables the same way as inside renderText().
See comments in the code for where I am stuck.
Thanks!
library(shiny)
library(dplyr)
##################################
#### checkbox dropdown module ####
##################################
mod_ui_checkbox_dropdown_ui <- function(id){
ns <- NS(id)
tagList(
uiOutput(ns("choice_dropdown"))
)
}
mod_ui_checkbox_dropdown_server <- function(id, dropdown_label = "Items", menu_choices = c("item1", "item2", "item3"), dropdown_status = "default"){
dropdownButton <- function(label = "", status = c("default", "primary", "success", "info", "warning", "danger"), ..., width = NULL) {
status <- match.arg(status)
# dropdown button content
html_ul <- list(
class = "dropdown-menu",
style = "max-width: 300px;",
#style = if (!is.null(width))
# paste0("width: ", validateCssUnit(width), ";"),
lapply(X = list(...), FUN = tags$li, style = "margin-left: 10px; margin-right: 10px;")
)
# dropdown button appearance
html_button <- list(
class = paste0("btn btn-", status," dropdown-toggle"),
style = "width: 100%; max-width: 300px; display: flex; justify-content: space-between;",
type = "button",
`data-toggle` = "dropdown"
)
html_button <- c(html_button, list(label))
html_button <- c(html_button, list(tags$span(class = "caret", style = "margin-top: 8px;")))
# final result
tags$div(
class = "dropdown",
do.call(tags$button, html_button),
do.call(tags$ul, html_ul),
tags$script(
"$('.dropdown-menu').click(function(e) {
e.stopPropagation();
});")
)
}
moduleServer( id, function(input, output, session){
ns <- session$ns
# output$selected_items <- renderPrint({
# input$dropdown_checkboxes
# })
output$choice_dropdown <- renderUI({
dropdownButton(
label = dropdown_label, status = dropdown_status, width = "100%",
actionButton(inputId = ns("all"), label = "all/none", class = "btn btn-sm", style = "margin-bottom: 8px;"),
checkboxGroupInput(inputId = ns("dropdown_checkboxes"), label = NULL, choices = menu_choices, selected = menu_choices)
)
})
# Select all / Unselect all
observeEvent(input$all, {
if (is.null(input$dropdown_checkboxes)) {
updateCheckboxGroupInput(
session = session, inputId = "dropdown_checkboxes", selected = menu_choices
)
} else {
updateCheckboxGroupInput(
session = session, inputId = "dropdown_checkboxes", selected = ""
)
}
})
# return selected values
return(reactive(input$dropdown_checkboxes))
})
}
##################
#### main app ####
##################
ui <- fluidPage(
textOutput("text"),
uiOutput("sample_dropdown"),
#uiOutput("manual_checks"),
br(),
br(),
uiOutput("sample_filters"),
)
server <- function(input, output, session) {
data <- tibble::tibble("Sample ID" = c("Sample1", "Sample2", "Sample3", "Sample4", "Sample5", "Sample6"),
"Group" = c("group1", "group1", "group2", "group2", "group3", "group3"),
"Name" = c("Aime", "Balthasar", "Charlotte", "Daniel", "Emilie", "Fiona"))
ns <- session$ns
# helper function. filters dataframe columns for only the entries listed in selected_values
# selected_values is a list with an entry for each filter dropdown that holds a reactive vector with the selected items from each dropdown
filter_selection <- function(data, selected_values){
# loop through list by names of the list items
for (val in names(selected_values)){
if(!is.null(val)){
data <- dplyr::filter(data, .data[[val]] %in% selected_values[[val]]())
}
}
return(data)
}
### select sample ###
# get selectable samples from study data
selectable_samples <- reactive({
##### HERE BE DRAGONS
##### THIS DOES NOT WORK: When I try to access the values from the checkboxes here in this reactive element, I only get the empty list().
##### How do I make this reactive element respond to the selected values?
### ONLY PRINTS EMPTY LIST ###
print(selected_values)
### THIS GIVES AN ERROR ###
#print(selected_values$Name())
data %>%
# filter the choices based on the selected values here
{if(length(selected_values) != 0) filter_selection(., selected_values) else .} %>%
dplyr::select(any_of("Sample ID")) %>%
unique() %>%
pull() %>%
sort()
})
output$sample_dropdown <- renderUI({
selectInput("sample_dropdown", label = NULL, choices = selectable_samples())
})
## ---- sample filters ##
## this dynamically creates checkbox dropdown menus for selected filter columns
sample_filter_cols <- c("Group", "Name")
# create filter module UI elements
output$sample_filters <- renderUI(
sapply(sample_filter_cols, function(fav){
mod_ui_checkbox_dropdown_ui(stringr::str_replace_all(fav, " ", "-")) #IDs don't like spaces
})
)
# capture filter module outputs in list
# solution using a list and observe() adapted from here
# https://stackoverflow.com/questions/57802428/looping-shiny-callmodule-only-exports-last-value
selected_values <- list()
observe(
selected_values <<- sapply(sample_filter_cols, function(x){
choices <- data %>%
select(any_of(x)) %>%
unique() %>%
pull() %>%
sort()
mod_ui_checkbox_dropdown_server(stringr::str_replace_all(x, " ", "-"), dropdown_label = x, menu_choices = choices)
}, USE.NAMES = TRUE)
)
##### THIS WORKS: I can access the selected values of the filter columns here and print them as text.
##### So why won't this propagate to the reactive element above?
output$text <- renderText(paste("selected values:",
paste(selected_values$Name(), collapse = " "),
paste(selected_values$Group(), collapse = " ")
))
}
shinyApp(ui, server)
Try this code. I built it without modules and it is a little bit simple, but it works.
I changed the 2nd SAMPLE ID -> to Sample 3 because I need to prove one sample with more than one group.
I hope this can help you.
library(shiny)
library(shinyWidgets)
require(tibble)
data_read <<-
tibble::tibble(
"Sample ID" = c("Sample1", "Sample3", "Sample3", "Sample4", "Sample5", "Sample6"),
"Group" = c("group1", "group1", "group2", "group2", "group3", "group3"),
"Name" = c("Aime", "Balthasar", "Charlotte", "Daniel", "Emilie", "Fiona"))
if (interactive()) {
reactive_data <- reactiveValues(
data_all = data_read,
data_sample_filter = data_read[0,],
vector_groups = NULL,
group_selected = c(),
vector_names = NULL,
)
ui <- fluidPage(
selectInput(
"sample_dropdown",
label = NULL,
choices = data_read$`Sample ID` %>% unique
),
uiOutput("group_dropdown"),
uiOutput("names_dropdown"),
verbatimTextOutput("texto"),
tableOutput("table")
)
server <- function(input, output) {
observe({
data_filter_group <<-
data_read %>%
filter(
`Sample ID` %in% input$sample_dropdown
)
output$group_dropdown <- renderUI({
pickerInput(
inputId = "group_dropdown",
label = "select group(s)",
choices = isolate(reactive_data$vector_groups),
options =
list(
`actions-box` = TRUE
),
multiple = TRUE
)
})
# Change reactive values
reactive_data$data_sample_filter <- data_filter_group
reactive_data$vector_groups <- data_filter_group$Group %>% unique
},
label = "group_dropdown UI"
)
observe({
# save reactive values input group
reactive_data$group_selected <- input[["group_dropdown"]]
data_filter_names <<-
isolate(reactive_data$data_sample_filter) %>%
filter(
Group %in% isolate(reactive_data$group_selected)
)
# Change reactive values
reactive_data$vector_names <- data_filter_names$Name %>% unique
output$names_dropdown <- renderUI({
pickerInput(
inputId = "names_dropdown",
label = "select group(s)",
choices = isolate(reactive_data$vector_names),
options = list(
`actions-box` = TRUE),
multiple = TRUE
)
})
},
label = "names_dropdown UI"
)
# example all data output
output$table <-
renderTable({
data_read
})
output$texto <-
renderText({
paste("selected values:\n",
input$sample_dropdown,"\n\t",
paste( input[["group_dropdown"]],sep="" ,collapse = "\n\t"),"\n\t\t",
paste( input[["names_dropdown"]],sep="" ,collapse = "\n \t\t")
)
})
}
shinyApp(ui, server)
}
SOLVED: Thanks to Yeyo's suggestion of using pickerInput I was able to do away with my monstrosity of a custom widget module and get this to work nicely with much less code!
library(shiny)
library(shinyWidgets)
library(dplyr)
#' Helper Function
#'
#' #description helper function to filter the choices of a dropdown menu based on selected data
#'
#' #return character vector with choices that remain after filtering the data
#'
#' #param data data frame to be filtered
#' #param choice_col name of the column that holds all possible values for the dropdown menu. e.g. if the dropdown menu chooses sample ids, this may be the "Sample ID" column
#' #param filter_selections list with selected values from all filter dropdown menus. e.g. list("Group" = c("group1", "group2), "Names" = c("Aime", "Balthasar")), will produce all samples that are in these two groups and belong to these two names.
#'
#' #noRd
filter_choices <- function(data, choice_col, filter_selections){
choices <- data
for (filter_col in names(filter_selections)){
choices <- choices %>%
dplyr::filter(., .data[[filter_col]] %in% filter_selections[[filter_col]])
}
choices <- choices %>%
dplyr::select(any_of(choice_col)) %>%
unique() %>%
pull() %>%
sort()
return(choices)
}
##################
#### main app ####
##################
ui <- fluidPage(
uiOutput("sample_dropdown"),
h3("Filters"),
uiOutput("sample_filters")
)
server <- function(input, output, session) {
data <- tibble::tibble("Sample ID" = c("Sample1", "Sample2", "Sample3", "Sample4", "Sample5", "Sample6"),
"Group" = c("group1", "group1", "group2", "group2", "group3", "group3"),
"Name" = c("Aime", "Balthasar", "Charlotte", "Daniel", "Emilie", "Fiona"))
### dropdown to select a sample from the data ###
selectable_samples <- reactive({
filter_choices(data, choice_col = "Sample ID", filter_selections = selected_values())
})
output$sample_dropdown <- renderUI({
shinyWidgets::pickerInput("sample_dropdown", label = "Select Sample", choices = selectable_samples())
})
### ---- dropdowns to narrow down choices of samples I am interested in ###
# specify which data columns you want to be able to filter by
sample_filter_cols <- c("Group", "Name")
# create picker UI elements for these columns
output$sample_filters <- renderUI(
div(
lapply(sample_filter_cols, function(x){
choices <- data %>%
select(any_of(x)) %>%
unique() %>%
pull() %>%
sort()
shinyWidgets::pickerInput(stringr::str_replace_all(x, " ", "-"),
label = x,
choices = choices,
multiple = TRUE,
selected = choices,
options = list(`actions-box` = TRUE))
})
)
)
# collect output of filter dropdown menus in a reactive list
selected_values <- reactive({
sapply(sample_filter_cols, function(x){
input[[stringr::str_replace_all(x, " ", "-")]]
}, USE.NAMES = TRUE)
})
}
shinyApp(ui, server)
I have created the following shiny App
library(shiny)
library(rhandsontable)
ui <- fluidPage(
sidebarLayout(sidebarPanel = "Inputparameter",
selectInput(inputId = "Name", label = "Name", choices = c("A", "B", "C"))),
mainPanel (rHandsontableOutput(outputId = 'Adjusttable', width ='100%', height = 100%')))
server <- function(input, output, session) {
output$Adjusttable<-renderRHandsontable({
DF = data.frame(ID = 1:7,'Column2' = 0, Start = "D",FM="",stringsAsFactors = FALSE)
names(DF)[names(DF)=='Column2']<- input$Name
names(DF)[names(DF)=='FM']<-'FM'
DF$ID<-NULL
rhandsontable(DF, width = 280, height = 677,stretchH = "all") %>%
hot_col(col = "Start", type = "dropdown", source = c("Fw", "Sw"), fillHandle =
list(direction='vertical', autoInsertRow=TRUE))%>%
hot_context_menu(allowRowEdit = TRUE, allowColEdit = FALSE)
}, quoted = FALSE )}
shinyApp(ui, server)
The following results in an app with an editable table. When we fill values in the table,, and change the item in the name drop down, the values get reset to 0 and the table defaults to its default state. Is there a way to fill the table, change the number of rows, etc , change the name input and avoid resetting the table. I request someone to take a look.
Try this
library(shiny)
library(rhandsontable)
library(DT)
DF <- data.frame(ID = 1:7,Column2 = 0, Start = "D",FM="",stringsAsFactors = FALSE)
names(DF)[names(DF)=='FM']<-'FM'
DF$ID<-NULL
ui <- fluidPage(
sidebarLayout(
sidebarPanel( "Inputparameter",
selectInput(inputId = "Name", label = "Name", choices = c("A", "B", "C"))),
mainPanel( rHandsontableOutput(outputId = 'hot', width ='100%', height = '100%')
, DTOutput("t1")
)
)
)
server <- function(input, output, session) {
DF1 <- reactiveValues(data=DF)
observe({
input$Name
names(DF1$data)[1] <- input$Name
})
output$hot<-renderRHandsontable({
rhandsontable(DF1$data, width = 280, height = 677,stretchH = "all") %>%
hot_col(col = "Start", type = "dropdown", source = c("Fw", "Sw"), fillHandle =
list(direction='vertical', autoInsertRow=TRUE)) %>%
hot_context_menu(allowRowEdit = TRUE, allowColEdit = FALSE)
}, quoted = FALSE )
observe({
if (!is.null(input$hot)){
DF1$data <- (hot_to_r(input$hot))
}
})
output$t1 <- renderDT(DF1$data)
}
shinyApp(ui, server)
I am building a Shiny app which generates a dataframe through a specific function. I want to use an eventReactive() to attribute the result of this function depending on a reactive input.
I tried to follow this answer : Working with a reactive() dataframe inside eventReactive()? but when I want to use an observeEvent, it always generate an error Warning: Error in $.shinyoutput: Reading objects from shinyoutput object not allowed.
My first try was as follows with an example :
DATA and LIBRAIRIES
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(dplyr)
df <- data.frame(c1 = c(rep("A", 3), rep("B", 4), "on"),
c2 = 1:8,
c3 = c(2002,2003,2002,2004,2002,2003,2005, 2005))
my_function <- function(arg1, arg2)
{
df = data.frame(
v1 = mean(df %>% filter(c1 == arg1) %>% select(c2) %>% pull()),
v2 = arg2
)
return(df)
}
UI
ui <- fluidPage(
selectInput(inputId = "input1", label = NULL,
choices = c("A", "B"),
selected = "A"),
selectInput(inputId = "input2", label = NULL,
choices = c("on", "off"),
selected = "on"),
uiOutput("ui_year"),
uiOutput("fct_extract"),
actionButton(inputId = "extraction", label = "Go", icon = icon("play")),
uiOutput("col_visu")
)
SERVER
server <- function(input, output) {
output$ui_year <- renderUI({
checkboxGroupInput(inputId = "year1", label = NULL, choices = df %>% filter(c1 == "A") %>% select(c3) %>% pull())
})
output$fct_extract <- renderUI({
shinyWidgets::radioGroupButtons(
inputId = "fct_extract",
label = NULL,
selected = "B1",
choices = c("B0", "B1"),
status = "warning")
})
fct_extr <- reactive(output$fct_extract)
df2 <- eventReactive(input$extraction, {
if (fct_extr() == "B0")
{
my_function(arg1 = input$input1,
arg2 = input$input1)
} else if (fct_extr() == "B1")
{
my_function(arg1 = input$input2,
arg2 = input$input1)
}
})
columns <- reactive(colnames(df2()))
output$col_visu <- renderUI({
shinyWidgets::multiInput(
inputId = "col_visu", width = "400px",
label = h2("Selection :"),
choices = columns())
})
}
When I put the actionButton, it generates the message : Reading objects from shinyoutput object not allowed. and nothing else happened
So I tried in the SERVER :
fct_extr <- reactive(output$fct_extract)
df2 <- observeEvent(input$extraction, {
if (fct_extr() == "B0")
{
my_function(arg1 = input$input1,
arg2 = input$input1)
} else if (fct_extr() == "B1")
{
my_function(arg1 = input$input2,
arg2 = input$input1)
}
})
}
Here I got the message : argument "x" is missing, with no default instead of the result of col_visu and when I put the actionButton, the app closed
In addition, when I don't try to add the choice with fct_extra, it works :
df2 <- eventReactive(input$extraction, {
my_function(arg1 = input$input1,
arg2 = input$input1)
})
columns <- reactive(colnames(df2()))
output$col_visu <- renderUI({
shinyWidgets::multiInput(
inputId = "col_visu", width = "400px",
label = h2("Selection :"),
choices = columns())
})
Thank you to the one of you who will explain how to include a reactive inside an eventReactive :)
You define the following dynamic radioGroupButton:
output$fct_extract <- renderUI({
shinyWidgets::radioGroupButtons(
inputId = "fct_extract",
label = NULL,
selected = "B1",
choices = c("B0", "B1"),
status = "warning")
})
This defines a UI element whose value is accessible in input with the key set to the element's inputId. So, in this case, the value is under input$fct_extract
Note that this is independent of the name of your UI object in the output, which just happens to also be fct_extract. This naming is confusing and probably caused your error: trying to access the value of the widget in output$fct_extract when it is actually in input$fct_extract.
To fix your code, replace the illegal line (fct_extr <- reactive(output$fct_extract)) with the correct:
fct_extr <- reactive(input$fct_extract)
In fact, this reactive is redundant since input$fct_extract is already a reactive value. So just ditch your reactive entirely and use input$fct_extract (without brackets) where you would have used fct_extr()
I made a few edits to your code to get it working. Here are the actual code changes though for your question:
mean(df... instead of mean(a...
my_function <- function(arg1, arg2)
{
df = data.frame(
v1 = mean(df %>% filter(c1 == arg1) %>% select(c2) %>% pull()),
v2 = arg2
)
return(df)
}
and then removing the line fct_extr <- reactive(output$fct_extract). I think you meant to use reactiveVal but it's unnecessary here. I just replaced:
if (fct_extr() == "B0")... else if (fct_extr() == "B1") with
if (input$fct_extr == "B0")... else if (input$fct_extr == "B1")
Full code below.
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(dplyr)
df <- data.frame(c1 = c(rep("A", 3), rep("B", 4), "on"),
c2 = 1:8,
c3 = c(2002,2003,2002,2004,2002,2003,2005, 2005))
my_function <- function(arg1, arg2)
{
df = data.frame(
v1 = mean(df %>% filter(c1 == arg1) %>% select(c2) %>% pull()),
v2 = arg2
)
return(df)
}
ui <- fluidPage(
selectInput(inputId = "input1", label = NULL,
choices = c("A", "B"),
selected = "A"),
selectInput(inputId = "input2", label = NULL,
choices = c("on", "off"),
selected = "on"),
uiOutput("ui_year"),
uiOutput("fct_extract"),
actionButton(inputId = "extraction", label = "Go", icon = icon("play")),
uiOutput("col_visu")
)
server <- function(input, output) {
output$ui_year <- renderUI({
checkboxGroupInput(inputId = "year1", label = NULL, choices = df %>% filter(c1 == "A") %>% select(c3) %>% pull())
})
output$fct_extract <- renderUI({
shinyWidgets::radioGroupButtons(
inputId = "fct_extract",
label = NULL,
selected = "B1",
choices = c("B0", "B1"),
status = "warning")
})
# fct_extr <- reactiveVal(input$fct_extract)
df2 <- eventReactive(input$extraction, {
if (input$fct_extract == "B0")
{
my_function(arg1 = input$input1,
arg2 = input$input1)
} else if (input$fct_extract == "B1")
{
my_function(arg1 = input$input2,
arg2 = input$input1)
}
})
columns <- reactive(colnames(df2()))
output$col_visu <- renderUI({
shinyWidgets::multiInput(
inputId = "col_visu", width = "400px",
label = h2("Selection :"),
choices = columns())
})
}
shinyApp(ui, server)
I know that there is a very similar question on StackExchange (pickerInput default select all choices), however, the solution can not be applied to my problem.
I have a updatePickerInput which is based on two Inputs. on the updatePickerInput I have the selectAll and clearAll buttons from shinyWidgets. I want selectAll to be the default, but since it is dynamically, I dont know how to pass my choices into the selected option.
Here is my relevant ui code:
radioButtons(inputId = 'selected_group', label = 'group', choices = '')
This is my observeEvent code:
observeEvent(c(input$selected_tab,input$selected_group),{
req(input$selected_group)
updatePickerInput(
session,
'selected_subgroup',
choices = df %>%
filter(tab == input$selected_tab) %>%
filter(group == input$selected_group) %>%
select(subgroup) %>%
distinct(subgroup) %>%
arrange(subgroup) %>%
.[[1]]
)
})
To have all options selected dynamically you'll need to pass the same information to updatePickerInput's choices and selected arguments:
library(shiny)
library(datasets)
library(shinyWidgets)
statesDF <- data.frame(region = state.region, name = state.name, area = state.area, stringsAsFactors = FALSE)
ui <- fluidPage(
radioButtons(inputId = 'selected_group', label = 'group', choices = unique(statesDF$region)),
pickerInput(inputId = 'selected_subgroup', label = 'subgroup', choices = NULL, selected = NULL, multiple = TRUE)
)
server <- function(input, output, session) {
filteredChoices <- reactive({
statesDF$name[statesDF$region == input$selected_group]
})
observeEvent(filteredChoices(), {
updatePickerInput(session, inputId = 'selected_subgroup', label = 'subgroup', choices = filteredChoices(), selected = filteredChoices())
})
}
shinyApp(ui = ui, server = server)
I am developing one app in shiny dashboard in that I want to dynamically populate dropdown box once csv is uploaded. Dropdown will contain top 10 cities by user registrations which I get from following code.
final_data %>%
group_by(registrant_city) %>%
summarise(Total = n()) %>%
arrange(desc(Total)) %>%
top_n(n = 10)
These cities should go into dropdown box.
tabItem("email",
fluidRow(
box(
width = 4, status = "info",solidHeader = TRUE,
title = "Send Emails",
selectInput("email_select",
"Select Email Content",
choices = c("Price" = "price",
"Services" = "service"
)),
selectInput("cities",
"Select City",
choices = ??
))
))
Please help..
Use updateSelectInput in your server like below and set choices = NULL in your ui :
function(input, output, session) {
# If this isn't reactive you can put it in your global
choices_cities <- final_data %>%
group_by(registrant_city) %>%
summarise(Total = n()) %>%
arrange(desc(Total)) %>%
top_n(n = 10)
updateSelectInput(session = session, inputId = "cities", choices = choices_cities$registrant_city)
}
Or if final_data is reactive something like this :
function(input, output, session) {
choices_cities <- reactive({
final_data %>%
group_by(registrant_city) %>%
summarise(Total = n()) %>%
arrange(desc(Total)) %>%
top_n(n = 10)
})
observeEvent(choices_cities(), {
updateSelectInput(session = session, inputId = "cities", choices = choices_cities()$registrant_city)
})
}
A working example :
library("dplyr")
library("shiny")
data("world.cities", package = "maps")
ui <- fluidPage(
sliderInput(inputId = "n", label = "n", min = 10, max = 30, value = 10),
selectInput(inputId = "cities", label = "Select City", choices = NULL)
)
server <- function(input, output, session) {
choices_cities <- reactive({
choices_cities <- world.cities %>%
arrange(desc(pop)) %>%
top_n(n = input$n, wt = pop)
})
observe({
updateSelectInput(session = session, inputId = "cities", choices = choices_cities()$name)
})
}
shinyApp(ui = ui, server = server)
I got the answer for above. Here is what I did.
ui.R
uiOutput("city_dropdown")
And my server.R looks like following
output$city_dropdown <- renderUI({
city <- reg_city(final_data)
city <- city$registrant_city
city <- as.list(city)
selectInput("email_select",
"Select Email Content",
choices = city
)
})
reg_city() gives me the top 10 cities which I want to populate into drop down box,then converting it to a list gives me desired output.