I am building an app in shiny about biodiversity. The app has 2 text inputs (vernacularName and scientificName for a living being) and a select input for a year. I am struggling to;
- Link the 2 text inputs such that if the user types a vernacular name, the corresponding scientific name is populated in the scientific name text input.
- Likewise, if the user types the scientific name, the vernacular name box is automatically updated with the corresponding vernacular name.
- It would be a plus if a user starts typing a scientific or vernacular name, a list of all similar names appears that the user could pick from.
See my code I have so far.
The data is available here, please donload https://raw.githubusercontent.com/Karuitha/shiny_karuitha/master/final_data.csv
################################################################################
## Download and load packages manager pacman ----
if(!require(pacman)) {
install.packages("pacman")
library(pacman)
}
################################################################################
# Download and load required packages ----
pacman::p_load(
shiny, glue, plotly, leaflet,
shinythemes, tidyverse
)
###############################################################################
if(!require(shiny.react)){
remotes::install_github("Appsilon/shiny.react")}
if(!require(shiny.fluent)){
remotes::install_github("Appsilon/shiny.fluent")}
################################################################################
## Load the pre-processed data ----
final_data <- read_csv("final_data.csv",
col_types = 'ccddccdd')
################################################################################
## Create the UI ----
ui <- fluidPage(
## Header panel
headerPanel(HTML("<h1 style='color: grey'>Prevalence of Selected Species in Poland and Germany</h1>")),
## Add a themes selector for the app
shinythemes::themeSelector(),
## Side bar layout
sidebarLayout(
sidebarPanel(
HTML("<h3>User Input</h3>"),
## User enters vernacular name
HTML("<h4>Enter Vernacular Name</h4>"),
## Create a drop down inputs selection
textInput(inputId = "vernacularname",
label = "Choose a Vernacular Name",
value = "Box bug",
#placeholder = "Norway Maple",
width = "100%"
),
## User has the choice to enter scientific name
HTML("<h4>Enter Scientific Name</h4>"),
## Create a drop down inputs selection
textInput(inputId = "scientificname",
label = "Choose a Scientific Name",
value = "Acer platanoides",
#placeholder = "Norway Maple",
width = "100%"
),
## User has the choice to enter scientific name
HTML("<h4>Enter Year </h4>"),
## Create a slider input for the years
selectInput(inputId = "year",
label = "Choose year",
choices = sort(unique(final_data$year)),
selected = 2020,
multiple = FALSE)
),
## Main panel will contain the leaflet output
mainPanel(
leafletOutput("mymap"), width = "100%", height = "100%"
)
)
)
################################################################################
## Create the server with leaflet output ----
server <- function(input, output, session){
## Create a reactive for the current data ----
this_data <- reactive({
final_data %>%
filter(vernacularName == input$vernacularname,
year == input$year)
})
## Render an leaflet map
output$mymap <- renderLeaflet(
leaflet(
this_data()
) %>%
addProviderTiles('OpenStreetMap.HOT') %>%
##
## Stamen.Toner
addCircleMarkers(
color = "red",
radius = ~ individualCount^0.3,
stroke = TRUE,
fillOpacity = 0.8,
popup = ~paste(
"<strong> Country: </strong>", country, "<br>",
"<strong> Locality: </strong>", locality, "<br>",
"<strong> Count: </strong>", individualCount, "<br>"
)
)
)
}
################################################################################
## Run the application ----
shinyApp(ui, server)
################################################################################
CodePudding user response：
This app does the three things you wanted. However, first you must filter out the duplicated rows; so that only unique combinations of scientificNames and vernacularNames are present in data. This way, there is only one scientificName associated to the selected vernacularName and viceversa.
library(shiny)
library(shinyWidgets)
library(tidyverse)
data <- read.csv("https://raw.githubusercontent.com/Karuitha/shiny_karuitha/master/final_data.csv")
data <- data %>% group_by(vernacularName, scientificName) %>% distinct() %>% ungroup()
ui <- fluidPage(
pickerInput("text1", "Vernacular Name", choices = sort(unique(data$vernacularName)), options = list(`live-search` = TRUE)),
pickerInput("text2", "Scientific Name", choices = sort(unique(data$scientificName)), options = list(`live-search` = TRUE))
)
server <- function(input, output, session) {
observeEvent(input$text1, {
updatePickerInput(session = session, inputId = "text2",
choices = sort(unique(data$scientificName)), options = list(`live-search` = TRUE),
selected = unique(data$scientificName[data$vernacularName == input$text1]))
}, ignoreInit = TRUE)
observeEvent(input$text2, {
updatePickerInput(session = session, inputId = "text1",
choices = sort(unique(data$vernacularName)), options = list(`live-search` = TRUE),
selected = unique(data$vernacularName[data$scientificName == input$text2]))
}, ignoreInit = TRUE)
}
shinyApp(ui, server)
CodePudding user response：
The risk of having two textInput fields inter-dependent is that you can get into a cycle of self-updating. One way around this is to track the last value and note which value is changing.
Here's a simpler example with local data to demonstrate the point. With this method, there are always two reactions to an entry, but the second is always a no-op: for instance, if we update Word, then it changes Synonym, which re-triggers the observe event; in the second observation, though, nothing is different from the stored change (in lasts$...), so it quickly escapes.
library(shiny)
words <- data.frame(
word = c("apple", "pear"),
synonym = c("fuji", "bosc")
)
shinyApp(
ui = fluidPage(
textInput("word", "Word"),
textInput("synonym", "Synonym")
),
server = function(input, output, session) {
lasts <- reactiveValues(word = "", synonym = "")
observeEvent({
input$word
input$synonym
}, {
if (!identical(lasts$synonym, input$synonym)) {
# synonym changed
validate(
need(input$synonym %in% words$synonym,
paste("Synonym needs to be one of:",
paste(sQuote(words$synonym, FALSE), collapse = ", ")))
)
newword <- words$word[match(input$synonym, words$synonym)]
updateTextInput(session, "word", value = newword)
lasts$word <- newword
lasts$synonym <- input$synonym
} else if (!identical(lasts$word, input$word)) {
validate(
need(input$word %in% words$word,
paste("Word needs to be one of:",
paste(sQuote(words$word, FALSE), collapse = ", ")))
)
newsyn <- words$synonym[match(input$word, words$word)]
updateTextInput(session, "synonym", value = newsyn)
lasts$word <- input$word
lasts$synonym <- newsyn
}
}) %>% throttle(1000)
onSessionEnded(function() stopApp())
}
)