Я создаю блестящее приложение, которое динамически создает реактивные элементы bs4Box
из фрейма данных. Я хочу сделать эти поля доступными для пользователя, чтобы происходило автоматическое перенаправление на другой элемент меню. Я читал и следил за подобными предыдущими вопросами SO, такими как этот или этот выпуск , но безуспешно. JavaScript-решение , подобное этому, тоже может работать?
Вот моя попытка использовать функцию updatebs4ControlbarMenu
:
library(shiny)
#> Warning: package 'shiny' was built under R version 3.6.3
library(shinyWidgets)
#> Warning: package 'shinyWidgets' was built under R version 3.6.3
library(bs4Dash)
#>
#> Attaching package: 'bs4Dash'
#> The following objects are masked from 'package:shiny':
#>
#> column, tabPanel, tabsetPanel, updateTabsetPanel
#> The following object is masked from 'package:graphics':
#>
#> box
library(tidyverse)
#> Warning: package 'ggplot2' was built under R version 3.6.3
#> Warning: package 'tibble' was built under R version 3.6.3
#> Warning: package 'tidyr' was built under R version 3.6.3
#> Warning: package 'readr' was built under R version 3.6.3
#> Warning: package 'purrr' was built under R version 3.6.3
#> Warning: package 'dplyr' was built under R version 3.6.3
shinyApp(
ui = bs4DashPage(
sidebar_collapsed = FALSE,
controlbar_collapsed = TRUE,
enable_preloader = FALSE,
navbar = bs4DashNavbar(skin = "dark"),
sidebar = bs4DashSidebar(
inputId = "sidebarState",
bs4SidebarMenu(
id = "sidebr",
bs4SidebarMenuItem(
"Tab 1",
tabName = "tab1"
),
bs4SidebarMenuItem(
"Tab 2",
tabName = "tab2"
)
)
),
bs4DashBody(
bs4TabItems(
bs4TabItem(
tabName = "tab1",
h1("Welcome!"),
fluidRow(
pickerInput(
inputId = "car",
label = "Car",
choices = row.names(mtcars),
selected = head(row.names(mtcars), 3),
multiple = TRUE,
options = list(
`actions-box` = TRUE)
),
pickerInput(
inputId = "gear",
label = "Gear",
choices = unique(mtcars$gear),
selected = unique(mtcars$gear),
multiple = TRUE,
options = list(
`actions-box` = TRUE)
)
),
fluidRow(
column(6,
uiOutput("uiboxes")
)
)
),
bs4TabItem(
tabName = "tab2",
h4("Yuhuuu! You've been directed automatically in Tab 2!")
)
)
)
),
server = function(input, output, session) {
submtcars <- reactive({
req(input$car, input$gear)
mtcars %>%
mutate(
carnames = rownames(mtcars)) %>%
filter(
carnames %in% input$car &
gear %in% input$gear
)
})
observeEvent( submtcars(), {
output$uiboxes <- renderUI({
n_ex <- nrow(submtcars())
lapply(1:n_ex, FUN = function(j) {
print(paste("j is ", j))
bs4Box(
title = submtcars()$carnames[j],
width = 12,
str_c("Number of gears:", submtcars()$gear[j]),
btnID <- paste0("btnID", j),
print(btnID),
fluidRow(
column(
2,
actionBttn(
inputId = btnID,
icon("search-plus")
)
)
)
)
})
})
})
observeEvent( input$btnID , {
updatebs4ControlbarMenu(
session,
inputId = "sidebr",
selected = "tab2"
)
})
}
)
#>
#> Listening on http://127.0.0.1:5851
#> [1] "j is 1"
#> [1] "btnID1"
#> [1] "j is 2"
#> [1] "btnID2"
#> [1] "j is 3"
#> [1] "btnID3"
Created on 2020-12-10 by the reprex package (v0.3.0)
Ваша проблема в том, как вы настроили observeEvent
. Вы регистрируете только одного наблюдателя, который слушает input$btnID
. Однако btnID
— это всего лишь переменная, в которой вы определяете разные идентификаторы для кнопок действий (в вашем случае от «btnID1» до «btnID3». Поэтому вы должны зарегистрировать observeEvent
с этими идентификаторами. Для этого вы можете снова использовать lapply
как в моем решении ниже.
library(shiny)
library(shinyWidgets)
library(bs4Dash)
library(tidyverse)
shinyApp(
ui = bs4DashPage(
sidebar_collapsed = FALSE,
controlbar_collapsed = TRUE,
enable_preloader = FALSE,
navbar = bs4DashNavbar(skin = "dark"),
sidebar = bs4DashSidebar(
inputId = "sidebarState",
bs4SidebarMenu(
id = "sidebr",
bs4SidebarMenuItem(
"Tab 1",
tabName = "tab1"
),
bs4SidebarMenuItem(
"Tab 2",
tabName = "tab2"
)
)
),
bs4DashBody(
bs4TabItems(
bs4TabItem(
tabName = "tab1",
h1("Welcome!"),
fluidRow(
pickerInput(
inputId = "car",
label = "Car",
choices = row.names(mtcars),
selected = head(row.names(mtcars), 3),
multiple = TRUE,
options = list(
`actions-box` = TRUE)
),
pickerInput(
inputId = "gear",
label = "Gear",
choices = unique(mtcars$gear),
selected = unique(mtcars$gear),
multiple = TRUE,
options = list(
`actions-box` = TRUE)
)
),
fluidRow(
column(6,
uiOutput("uiboxes")
)
)
),
bs4TabItem(
tabName = "tab2",
h4("Yuhuuu! You've been directed automatically in Tab 2!")
)
)
)
),
server = function(input, output, session) {
submtcars <- reactive({
req(input$car, input$gear)
mtcars %>%
mutate(
carnames = rownames(mtcars)) %>%
filter(
carnames %in% input$car &
gear %in% input$gear
)
})
observeEvent( submtcars(), {
n_ex <- nrow(submtcars())
output$uiboxes <- renderUI({
lapply(1:n_ex, FUN = function(j) {
print(paste("j is ", j))
bs4Box(
title = submtcars()$carnames[j],
width = 12,
str_c("Number of gears:", submtcars()$gear[j]),
btnID <- paste0("btnID", j),
print(btnID),
fluidRow(
column(
2,
actionBttn(
inputId = btnID,
icon("search-plus")
)
)
)
)
})
})
lapply(1:n_ex, function(j) {
btnID <- paste0("btnID", j)
observeEvent(input[[btnID]] , {
updatebs4ControlbarMenu(
session,
inputId = "sidebr",
selected = "tab2"
)
})
})
})
}
)
Тем не менее, я думаю, что подходы с lapply
и renderUI
не очень хороши, так как все блоки отрисовываются заново, если один из ваших входных данных изменится, в то время как, возможно, некоторые блоки останутся прежними. Поэтому я рекомендую подход с insertUI
/removeUI
. Посмотрите на некоторые из моих старых ответов, например. https://stackoverflow.com/a/63758952/12647315
Спасибо @starja. Хотя это работает, мое приложение модульное, и я изо всех сил пытаюсь реализовать это решение, как описано в другом вопросе здесь: stackoverflow.com/q/65262056/7375944