Help with tipify used in a loop
Hi,
This could seems an easy task but I spent several hours without any solution. Here, I made a code to conduct a survey where there are 3 hierarchical aspects displayed at tabset panels: sectors, pressures and ecological pressures. First the sectors are choosen, then a button allow the user to go to sectors in the second tabset panel. For each sector choosen a list with pressures are displayed to be choosen again. Also for each pressure a toogle button with help information is displayed. Currently, the buttons and help information in the pressure section works but if there are more than 2 sectors were previously choosen, the help information is displayed only for the first sector. The problem is bigger for the third tabsetpanel as only one information is displayed. Could be a problem of the tipify function?
library(shiny)
library(stringr)
library(shinyBS)
#Extension of checkboxGroupInput
extendedCheckboxGroup <- function(..., extensions = list()) {
cbg <- checkboxGroupInput(...)
nExtensions <- length(extensions)
nChoices <- length(cbg$children[[2]]$children[[1]])
if (nExtensions > 0 && nChoices > 0) {
lapply(1:min(nExtensions, nChoices), function(i) {
# For each Extension, add the element as a child (to one of the checkboxes)
cbg$children[[2]]$children[[1]][[i]]$children[[2]] <<- extensions[[i]]
})
}
cbg
}
#function for putting the botton to right
bsButtonRight <- function(...) {
btn <- bsButton(...)
# Directly inject the style into the shiny element.
btn$attribs$style <- "float: right;"
btn
}
# Define a function to generate checkbox extensions
checkbox_extensions <- function(cbid, help_text) {
extensionsList <- tipify(
bsButtonRight(inputId = cbid, label= "?", placement= "bottom", style = "info", size = "extra-small"),
title=help_text)
return(extensionsList)
}
# Define UI
ui <- fluidPage(
titlePanel("Tool for ODEMM selection"),
sidebarLayout(
sidebarPanel(
textInput("user_name", "Your Name:"),
actionButton("go_to_pressures_button", "Go to Pressures"),
actionButton("go_to_eco_components_button", "Go to Ecological Components"),
actionButton("save_all_button", "Save all")
),
mainPanel(
uiOutput("sector_selection"),
uiOutput("pressure_selection"),
uiOutput("ecological_component_selection")
)
)
)
# Define server logic
server <- function(input, output, session) {
sectors <- c("Aquaculture (Scallops, Fishes)", "Fishing (nets, diving, traps, angling for sell)", "Shipping (Cargo_tankers, transport passengers)", "Renewable_energy (Wind farms)")
selected_sectors <- reactiveVal(character(0))
selected_pressures <- reactiveVal(list())
selected_ecological_components <- reactiveVal(list())
selected_sector_pressure_combos <- reactiveVal(list())
current_section <- reactiveVal("sectors")
#Sector
checkbox_choicessec <- data.frame(
cbid = c("Aquaculture", "Fishing", "Shipping", "Renewable_energy"),
choice_names = c("Aquaculture", "Fishing", "Shipping", "Renewable_energy"))
# Create a dataset with help information for each option
help_infosec <- data.frame(
cbid = c("Aquaculture", "Fishing", "Shipping", "Renewable_energy"),
help_text = c("Scallops, Fishes", "nets, diving, traps, angling for sell",
"Cargo_tankers, transport passengers", "Wind farms"))
# Create a list of checkbox extensions using the datasets
extensions_listsec <- mapply(checkbox_extensions, checkbox_choicessec$cbid, help_infosec$help_text, SIMPLIFY = FALSE)
output$sector_selection <- renderUI({
if (current_section() == "sectors") {
extendedCheckboxGroup(inputId="selected_sectors", label = "1. Please according to your experience choose the largest sectors influencing the marine system:",
choiceNames = checkbox_choicessec$choice_names,
choiceValues = checkbox_choicessec$cbid,
selected = NULL, extensions = extensions_listsec)
} else {
NULL
}
})
#Pressures
# Create a dataset with checkbox choices
checkbox_choicesp <- data.frame(
cbid = c("Smoothering", "Sealing", "Siltation_changes", "Abrasion"),
choice_names = c("Smoothering", "Sealing", "Siltation_changes", "Abrasion")
)
# Create a dataset with help information for each option
help_infop <- data.frame(
cbid = c("Smoothering", "Sealing", "Siltation_changes", "Abrasion"),
help_text = c("Cover habitat surface with materials falling to the seafloor from activities in the water column",
"Physical loss of habitat from sealing by permanent construction (e.g. Coastal defences, ports, houses)",
"Change in the concentration or distribution of suspended sediments in the water column from runoff, dredging etc",
"Physical interaction of human activities with the seafloor and with seabed faunaflora causing physical damage or mortality (e.g. from trawling or anchoring)"))
# Create a list of checkbox extensions using the datasets
extensions_listp <- mapply(checkbox_extensions, checkbox_choicesp$cbid, help_infop$help_text, SIMPLIFY = FALSE)
output$pressure_selection <- renderUI({
if (current_section() == "pressures") {
req(length(selected_sectors()) > 0)
pressure_widgets <- lapply(selected_sectors(), function(sector) {
sector_id <- gsub("\\W", "_", sector)
pressures_id <- paste0("pressures_", sector_id)
extendedCheckboxGroup(inputId = pressures_id, label= sector,
choiceNames = checkbox_choicesp$choice_names,
choiceValues = checkbox_choicesp$cbid,
selected = NULL, extensions = extensions_listp)
})
tagList(
do.call(tagList, pressure_widgets)
)
} else {
NULL
}
})
#Ecological components#####
# Create a dataset with checkbox choices
checkbox_choicec <- data.frame(cbid = c("Jumbo squid", "Peruvian anchovy", "Scallops", "Seabirds and littoral birds"),
choice_names = c("Jumbo squid", "Peruvian anchovy", "Scallops", "Seabirds and littoral birds"))
# Create a dataset with help information for each option
help_infoec <- data.frame(
cbid = c("Jumbo squid", "Peruvian anchovy", "Scallops", "Seabirds and littoral birds"),
help_text = c("Doscidiscus gigas", "Engraulis ringens", "Argopecten purpuratus", "(e.g. guano birds, oceanic birds)"))
# Create a list of checkbox extensions using the datasets
extensions_listec <- mapply(checkbox_extensions, checkbox_choicec$cbid, help_infoec$help_text, SIMPLIFY = FALSE)
output$ecological_component_selection <- renderUI({
print(selected_pressures())
print(extensions_listec)
if (current_section() == "eco_components") {
req(length(selected_pressures()) > 0)
unique_pressures <- unique(unlist(selected_pressures()))
ecological_component_widgets <- lapply(unique_pressures, function(pressure) {
pressure_id <- gsub("\\W", "_", pressure)
ecological_components_id <- paste0("ecological_components_", pressure_id)
# Only display the pressure name in the title
pressure_name <- gsub("\\s\\(.*\\)", "", pressure)
# Create a list of checkbox extensions using the datasets
extendedCheckboxGroup(inputId=ecological_components_id, label=pressure_name,
choiceNames = checkbox_choicec$choice_names,
choiceValues = checkbox_choicec$cbid,
selected = NULL, extensions = extensions_listec)
})
tagList(
do.call(tagList, ecological_component_widgets)
)
} else {
NULL
}
})
observeEvent(input$go_to_pressures_button, {
req(input$user_name)
selected_sectors(input$selected_sectors)
current_section("pressures")
})
observeEvent(input$go_to_eco_components_button, {
req(input$user_name)
selected_pressures(unlist(lapply(selected_sectors(), function(sector) {
sector_id <- gsub("\\W", "_", sector)
pressures_id <- paste0("pressures_", sector_id)
input[[pressures_id]]
})))
current_section("eco_components")
})
observeEvent(input$save_all_button, {
save_data <- list(
Name = input$user_name,
Sectors = selected_sectors(),
Pressures = selected_pressures(),
Ecological_Components = selected_ecological_components(),
Sector_Pressure_Combinations = selected_sector_pressure_combos()
)
saveRDS(save_data, paste0(input$user_name, "_qualitativeODEMM.rds"))
showModal(modalDialog(
title = "Selection Saved",
"Selection saved successfully!",
footer = NULL
))
})
observe({
if (length(selected_sectors()) > 0 && length(selected_pressures()) > 0) {
selected_sector_pressure_combos_list <- lapply(selected_sectors(), function(sector) {
sector_id <- gsub("\\W", "_", sector)
pressures_id <- paste0("pressures_", sector_id)
sector_pressures <- input[[pressures_id]]
sector_pressure_combo <- paste(sector, "/", sector_pressures, collapse = "; ")
sector_pressure_combo
})
selected_sector_pressure_combos(unlist(selected_sector_pressure_combos_list))
}
})
observe({
if (current_section() == "eco_components") {
req(length(selected_pressures()) > 0)
selected_ecological_components(unlist(lapply(selected_pressures(), function(pressure) {
pressure_id <- gsub("\\W", "_", pressure)
ecological_components_id <- paste0("ecological_components_", pressure_id)
paste(pressure, input[[ecological_components_id]], sep = " - ")
})))
}
})
}
# Run the application
shinyApp(ui = ui, server = server)