When including a dropdown in a header with message or notification items it automatically displays the sentence "You have 1 messages" upon click. How can I only show the message but not the sentence "You have 1 messages"?
example to reproduce below:
ui <- dashboardPage(
dashboardHeader(dropdownMenu(type = "messages",
messageItem(
from = "Sales Dept",
message = "Sales are steady this month."
))),
dashboardSidebar(),
dashboardBody()
)
server <- function(input, output) { }
shinyApp(ui, server)
It appears that sentence is hardcoded in the dropdownMenu function:
function (..., type = c("messages", "notifications", "tasks"),
badgeStatus = "primary", icon = NULL, .list = NULL)
{
type <- match.arg(type)
if (!is.null(badgeStatus)) validateStatus(badgeStatus)
items <- c(list(...), .list)
lapply(items, tagAssert, type = "li")
dropdownClass <- paste0("dropdown ", type, "-menu")
if (is.null(icon)) {
icon <- switch(type, messages = shiny::icon("envelope"),
notifications = shiny::icon("warning"), tasks = shiny::icon("tasks"))
}
numItems <- length(items)
if (is.null(badgeStatus)) {
badge <- NULL
}
else {
badge <- span(class = paste0("label label-", badgeStatus),
numItems)
}
tags$li(
class = dropdownClass,
a(
href = "#",
class = "dropdown-toggle",
`data-toggle` = "dropdown",
icon,
badge
),
tags$ul(
class = "dropdown-menu",
tags$li(
class = "header",
paste("You have", numItems, type)
),
tags$li(
tags$ul(class = "menu", items)
)
)
)
}
We see that the sentence is built with paste("You have", numItems, type).
One way to change that is to write a new function which take a new parameter with the sentence you want:
customSentence <- function(numItems, type) {
paste("This is a custom message")
}
# Function to call in place of dropdownMenu
dropdownMenuCustom <- function (..., type = c("messages", "notifications", "tasks"),
badgeStatus = "primary", icon = NULL, .list = NULL, customSentence = customSentence)
{
type <- match.arg(type)
if (!is.null(badgeStatus)) shinydashboard:::validateStatus(badgeStatus)
items <- c(list(...), .list)
lapply(items, shinydashboard:::tagAssert, type = "li")
dropdownClass <- paste0("dropdown ", type, "-menu")
if (is.null(icon)) {
icon <- switch(type, messages = shiny::icon("envelope"),
notifications = shiny::icon("warning"), tasks = shiny::icon("tasks"))
}
numItems <- length(items)
if (is.null(badgeStatus)) {
badge <- NULL
}
else {
badge <- span(class = paste0("label label-", badgeStatus),
numItems)
}
tags$li(
class = dropdownClass,
a(
href = "#",
class = "dropdown-toggle",
`data-toggle` = "dropdown",
icon,
badge
),
tags$ul(
class = "dropdown-menu",
tags$li(
class = "header",
customSentence(numItems, type)
),
tags$li(
tags$ul(class = "menu", items)
)
)
)
}
An a minimal example:
ui <- dashboardPage(
dashboardHeader(dropdownMenuCustom(type = "messages",
customSentence = customSentence,
messageItem(
from = "Sales Dept",
message = "Sales are steady this month."
))),
dashboardSidebar(),
dashboardBody()
)
server <- function(input, output) { }
shinyApp(ui, server)
Related
I adapted the code from here.
This is my code:
library(shiny)
library(shinyWidgets)
library(shinydashboard)
library(shinydashboardPlus)
shinyApp(
ui = dashboardPage(
header = dashboardHeader(userOutput("user")),
sidebar = dashboardSidebar(),
body = dashboardBody(uiOutput("body")),
title = "DashboardPage"
),
server = function(input, output) {
output$user <- renderUser({
dashboardUser(
name = "Divad Nojnarg",
image = "https://adminlte.io/themes/AdminLTE/dist/img/user2-160x160.jpg",
title = "shinydashboardPlus",
subtitle = "Author",
footer = p("The footer", class = "text-center"),
fluidRow(
actionButton("btn1","Click")
)
)
})
observeEvent(input$btn1, { #Not triggering
output$body <- renderUI({print("Clicked")})
})
}
)
What I want is the user box (what is in red) not to remain active (I mean, to make it to disappear) when I click on the button.
Any suggestion?
One workaround to do this is to use shinyjs::hide() and shinyjs::show(). Targeting the action button inside the user is easy. The tricky part is to get the dashboard user to show up again when the dropdown menu is clicked. For this we can rewrite the dashboardUser() function and add an action link with id instead of the "normal" link. See comments in code:
library(shiny)
library(shinyWidgets)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyjs)
dashboardUser
myDashboardUser <- function (..., name = NULL, image = NULL, title = NULL, subtitle = NULL,
footer = NULL)
{
if (!is.null(title)) {
line_1 <- paste0(name, " - ", title)
}
else {
line_1 <- name
}
if (!is.null(subtitle)) {
user_text <- shiny::tags$p(line_1, shiny::tags$small(subtitle))
user_header_height <- NULL
}
else {
user_text <- shiny::tags$p(line_1)
user_header_height <- shiny::tags$script(
shiny::HTML("$(\".user-header\").css(\"height\", \"145px\")")
)
}
userTag <- shiny::tagList(
shiny::tags$head(
shiny::tags$script("$(function() {\n
$('.dashboard-user').on('click', function(e){\n
e.stopPropagation();\n
});\n
});\n
")),
# we need to add an id and the class `action-button` to this link
shiny::tags$a(id = "user_dropdown",
href = "#",
class = "dropdown-toggle action-button",
`data-toggle` = "dropdown",
shiny::tags$img(src = image,
class = "user-image",
alt = "User Image"),
shiny::tags$span(class = "hidden-xs",
name)
),
shiny::tags$ul(class = "dropdown-menu dashboard-user",
shiny::tags$li(class = "user-header",
if (!is.null(user_header_height)) user_header_height,
shiny::tags$img(src = image,
class = "img-circle",
alt = "User Image"),
user_text),
if (length(list(...)) > 0)
shiny::tags$li(class = "user-body", ...),
if (!is.null(footer))
shiny::tags$li(class = "user-footer", footer)
)
)
userTag
}
}
shinyApp(
ui = dashboardPage(
header = dashboardHeader(userOutput("user")),
sidebar = dashboardSidebar(),
body = dashboardBody(
# make ShinyJs available
useShinyjs(),
uiOutput("body")
),
title = "DashboardPage"
),
server = function(input, output) {
output$user <- renderUser({
myDashboardUser(
name = "Divad Nojnarg",
image = "https://adminlte.io/themes/AdminLTE/dist/img/user2-160x160.jpg",
title = "shinydashboardPlus",
subtitle = "Author",
footer = p("The footer", class = "text-center"),
fluidRow(
actionButton("btn1","Click")
)
)
})
# use shinyjs::hide on button and also remove class open from user menue
observeEvent(input$btn1, {
hide(selector = ".dropdown-menu.dashboard-user")
removeClass(id = "user", class = "open")
})
# use shinyjs::show on new link
observeEvent(input$user_dropdown, {
show(selector = ".dropdown-menu.dashboard-user")
})
}
)
As I realized that by clicking anywhere, the user box disappear, I have just used a piece of javascript code to simulate clicking over "body" element:
jscode<-
'var evt = document.createEvent("MouseEvents");
evt.initMouseEvent("click", true, true, window,
0, 0, 0, 0, 0, false, false, false, false, 0, null);
var cb = document.getElementById("body");
var simulateClick = cb.dispatchEvent(evt);'
My final version:
library(shiny)
library(shinyWidgets)
library(shinydashboard)
library(shinydashboardPlus)
shinyApp(
ui = dashboardPage(
header = dashboardHeader(userOutput("user")),
sidebar = dashboardSidebar(),
body = dashboardBody(useShinyjs(), uiOutput("body")),
title = "DashboardPage"
),
server = function(input, output) {
output$user <- renderUser({
dashboardUser(
name = "Divad Nojnarg",
image = "https://adminlte.io/themes/AdminLTE/dist/img/user2-160x160.jpg",
title = "shinydashboardPlus",
subtitle = "Author",
footer = p("The footer", class = "text-center"),
fluidRow(
actionButton("btn1","Click")
)
)
})
observeEvent(input$btn1, { #Not triggering
output$body <- renderUI({print("Clicked")})
jscode<-
'var evt = document.createEvent("MouseEvents");
evt.initMouseEvent("click", true, true, window,
0, 0, 0, 0, 0, false, false, false, false, 0, null);
var cb = document.getElementById("body");
var simulateClick = cb.dispatchEvent(evt)';
runjs(jscode)
})
}
)
when input$variable change
uiOutput(1) and uiOutput(2) are rendered at the same time?
Is there any way render step by step not synchronistically?
The following is the steps I want.
1) input variable change
2) uiOutput(1) rendering
3) uiOutput(2) rendering
when input variable change shiny page is not working properly.
but after resizing the page window, the screen appears correctly.
Each time I change the input value, i have to recalibrate the page size.
ui.R
library(shiny)
library(shinydashboard)
sidebar <- dashboardSidebar(
radioButtons(inputId = "sidebar_data_sell",
label = "",
choices = c("Sell-in" = "sell_in", "Sell-out" = "sell_out"),
selected = "sell_out",
inline = TRUE),
uiOutput("summary_sidebar_ui")
)
ui <- dashboardPage(
dashboardHeader(title = h5("Hi")),
sidebar,
uiOutput("dashboard_body")
)
server.R
convertMenuItem <- function(mi, tabName) {
mi$children[[1]]$attribs['data-toggle'] = "tab"
mi$children[[1]]$attribs['data-value'] = tabName
mi
}
out_product_main <- function() {
list(
fluidPage(h5("product")))
}
product_items <- function() {
list(
selectInput("product_product_sell",
"product",
choices = list("product1" = "prd1", "product2" = "prd2"),
selected = c("prd1"))
)
}
in_overview_main <- function() {
list(
fluidPage(h5("overview")))
}
overview_items <- function() {
list(
radioButtons("overview_period_sell",
"period",
choices = c("year","month"),
inline = TRUE,
selected = "month")
)
}
shinyServer(function(input, output) {
output$summary_sidebar_ui <- renderUI({
if (input$sidebar_data_sell == "sell_in")
{
sidebarMenu(id = "summary_item",
convertMenuItem(menuItem("Overview",
tabName = "in_overview",
icon = icon("signal", lib = 'font-awesome'),
overview_items()),
tabName = 'in_overview'))
}
else{
sidebarMenu(id = "p_analysis_item",
convertMenuItem(menuItem("Product",
tabName = "out_product",
icon = icon("product-hunt", lib='font-awesome'),
product_items()),
tabName = 'out_product')
)
}
})
output$dashboard_body <- renderUI({
if (input$sidebar_data_sell == "sell_in") {
dashboardBody(tabItems(tabItem("in_overview", in_overview_main())))
}
else {
dashboardBody(tabItems(tabItem("out_product", out_product_main())))
}
})
})
This code reads in the data, find unique values of a column (Location) and puts these values as options in the dropdown menu. My goal is to customize my data based on values that are chosen in the dropdown menu. My data looks like below:
I tried to view the data but I found it is not working properly. What should I do?
Update 1: The problem is in data()$Location == input$Locationscheck but I don't know how to fix it.
library(shiny)
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 = if (!is.null(width))
paste0("width: ", validateCssUnit(width), ";"),
lapply(X = list(...), FUN = tags$li, style = "margin-left: 10px; margin-right: 10px;")
)
# dropdown button apparence
html_button <- list(
class = paste0("btn btn-", status," dropdown-toggle"),
type = "button",
`data-toggle` = "dropdown"
)
html_button <- c(html_button, list(label))
html_button <- c(html_button, list(tags$span(class = "caret")))
# 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();
});")
)
}
ui <- fluidPage(
fileInput(inputId = "uploadedcsv","", accept = '.csv'),
dropdownButton(label = "Choose the locations",status = "default",
width = 250,actionButton(inputId = "allLocations", label = "(Un)select all"),
checkboxGroupInput(inputId = "Locationscheck",label = "Choose",choices = "")),
actionButton('Run', label = "Run!")
)
server <- function(input, output, session) {
data <- reactive({
infile <- input$uploadedcsv
if (is.null(infile))
return(NULL)
read.csv(infile$datapath, header = TRUE, sep = ",")
})
observe({
locationnames <- unique(data()$Location)
updateCheckboxGroupInput(session, "Locationscheck",
choices = locationnames,
selected = locationnames)
### selecting and de-selecting in step 2 ###
observeEvent(input$allLocations, {
if (is.null(input$Locationscheck)) {
updateCheckboxGroupInput(session = session,
inputId = "Locationscheck",
selected = locationnames)
} else {
updateCheckboxGroupInput(session = session,
inputId = "Locationscheck",
selected = "")
}
})
### End of selecting and de-selecting ###
observeEvent(input$Run, {
Newdata <- data()[data()$Location == input$Locationscheck,]
View(data())
View(Newdata)
})
})
}
shinyApp(ui = ui, server = server)
The problem in the code data()$Location == input$Locationscheck is that it only considers first element in the input$Locationscheck vector and gives you the result as the values that are matched(eg: Location1) . You should use which(data()[data()$Location %in% input$Locationscheck,]) instead. which gives the indexes and %in% compares data()$Locationwith all the values in the input$Locationscheck vector.
I have modified your code and further added a table to illustrate the working:
library(shiny)
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 = if (!is.null(width))
paste0("width: ", validateCssUnit(width), ";"),
lapply(X = list(...), FUN = tags$li, style = "margin-left: 10px; margin-right: 10px;")
)
# dropdown button apparence
html_button <- list(
class = paste0("btn btn-", status," dropdown-toggle"),
type = "button",
`data-toggle` = "dropdown"
)
html_button <- c(html_button, list(label))
html_button <- c(html_button, list(tags$span(class = "caret")))
# 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();
});")
)
}
ui <- fluidPage(
fileInput(inputId = "uploadedcsv","", accept = '.csv'),
dropdownButton(label = "Choose the locations",status = "default",
width = 250,actionButton(inputId = "allLocations", label = "(Un)select all"),
checkboxGroupInput(inputId = "Locationscheck",label = "Choose",choices = "")),
actionButton('Run', label = "Run!"),
tableOutput('table')
)
server <- function(input, output, session) {
data <- reactive({
infile <- input$uploadedcsv
if (is.null(infile))
return(NULL)
read.csv(infile$datapath, header = TRUE, sep = ",", stringsAsFactors = FALSE)
})
observe({
locationnames <- unique(data()$Location)
updateCheckboxGroupInput(session, "Locationscheck",
choices = locationnames,
selected = locationnames)
### selecting and de-selecting in step 2 ###
observeEvent(input$allLocations, {
if (is.null(input$Locationscheck)) {
updateCheckboxGroupInput(session = session,
inputId = "Locationscheck",
selected = locationnames)
} else {
updateCheckboxGroupInput(session = session,
inputId = "Locationscheck",
selected = "")
}
})
### End of selecting and de-selecting ###
observeEvent(input$Run, {
# Newdata <- data()[data()$Location == input$Locationscheck,]
Newdata <- data()[which(data()$Location %in% input$Locationscheck),]
# # View(data())
# View(Newdata)
output$table <- renderTable({
Newdata
})
})
})
}
shinyApp(ui = ui, server = server)
I suggest you useisolate when you access the value so that the reactive event is not triggered again and again, something like this Newdata <- isolate(data())[which(isolate(data())$Location %in% input$Locationscheck),]
Hope it helps!
This question might seem to be a duplicate, but let me explain why it's not.
I want to create a shiny navbarPage that has fixed elements and a reactive number of tabPanels, that reacts to other input elements. There are many questions about how to create reactive tabsetPanels/navbarPages but they mostly aim for what it has to look like. The most common answer (and the answer i don't seek) is to render the whole navbarPage with updated set of tabPanels. I am aware of that concept and I used it in the code below.
Here is what I want my app to look like:
library(shiny)
runApp(
shinyApp(
ui = shinyUI(
fluidPage(
uiOutput("navPage")
)
),
server = function(input, output, session){
MemoryValue1 <- 1
MemoryValue2 <- 1
makeReactiveBinding("MemoryValue1")
observeEvent(input$button, {
output[[paste0("plot_", input$number)]] <- renderPlot({
hist(rnorm(1000))
})
})
observeEvent(input$insidepanels, {
MemoryValue1 <<- input$insidepanels
})
observeEvent(input$number, {
MemoryValue2 <<- input$number
})
output$navPage <- renderUI({
OutsidePanel1 <- tabPanel("Outside1",
numericInput("insidepanels", label = "Number of panels inside NavMenu", value = isolate(MemoryValue1), step = 1, min = 1),
numericInput("number", label = "Panel to add Output-Element to", value = 1, step = isolate(MemoryValue2), min = 1),
actionButton("button", label = "Add Output-Element")
)
OutsidePanel2 <- tabPanel("Ouside2", "Outside 2")
InsidePanels <- lapply(1:MemoryValue1, function(x){tabPanel(paste0("Inside", x), plotOutput(paste0("plot_", x)))})
do.call(navbarPage, list("Nav", OutsidePanel1, OutsidePanel2, do.call(navbarMenu, c("Menu", InsidePanels))))
})
}
)
)
As you might have seen, it takes a lot of effort to store your input values if they are inside other panels and will be re-rendered = reset all the time. I find this solution to be illegible and slow, because of unnecessary rendering. It also interrupts the user who is clicking through values of input$insidepanels.
What I want the app to be like is that the Outside Panels are fixed and dont re-render. The main problem is that inside shiny, navbarPage on rendering distributes HTML elements to two different locations. Inside the navigation panel and to the body as tab content. That means a-posteori added elements will not be properly embedded.
So far, I have tried to create the navbarPage with custom tags and have dynamic output alter only parts of it. That works pretty well with the navigation panel, but not with tab contents. The reason is that all tabs (their div containers) are listed one after another and as soon as I want to inject multiple at once, I am offthrown by htmlOutput, since it (seemingly) has to have a container and cannot just deliver plain HTML. Thus, all custom tabs are not recongnized properly.
Here my code so far:
library(shiny)
runApp(
shinyApp(
ui = shinyUI(
fluidPage(
tags$nav(class = "navbar navbar-default navbar-static-top", role = "navigation",
tags$div(class = "container",
tags$div(class = "navbar-header",
tags$span(class = "navbar-brand", "Nav")
),
tags$ul(class = "nav navbar-nav",
tags$li(
tags$a(href = "#tab1", "data-toggle" = "tab", "data-value" = "Outside1", "Outside1")
),
tags$li(
tags$a(href = "#tab2", "data-toggle" = "tab", "data-value" = "Outside2", "Outside2")
),
tags$li(class = "dropdown",
tags$a(href = "#", class = "dropdown-toggle", "data-toggle" = "dropdown", "Menu1"),
htmlOutput("dropdownmenu", container = tags$ul, class = "dropdown-menu")
)
)
)
),
tags$div(class = "container-fluid",
tags$div(class = "tab-content", id = "tabContent",
tags$div(class = "tab-pane active", "data-value" = "Outside1", id = "tab1",
numericInput("insidepanels", label = "Number of panels inside NavMenu", value = 1, step = 1, min = 1),
numericInput("number", label = "Panel to add Output-Element to", value = 1, step = 1, min = 1),
actionButton("button", label = "Add Output-Element")
),
tags$div(class = "tab-pane", "data-value" = "Outside2", id = "tab2", "Content 2"),
htmlOutput("tabcontents")
)
)
)
),
server = function(input, output, session){
observeEvent(input$button, {
output[[paste0("plot_", input$number)]] <- renderPlot({
hist(rnorm(1000))
})
})
output$dropdownmenu <- renderUI({
lapply(1:input$insidepanels, function(x){tags$li(tags$a(href = paste0("#tab-menu-", x), "data-toggle" = "tab", "data-value" = paste0("Inside", x), paste("Inside", x)))})
})
output$tabcontents <- renderUI({
tagList(
lapply(1:input$insidepanels, function(x){div(class = "tab-pane", "data-value" = paste("Inside", x), id = paste0("tab-menu-", x), plotOutput(paste0("plot_", x)))})
)
})
}
)
)
Note: I also tried to create HTML with JavaScript-Chunks that is triggered from inside server. This works for simple tab content, but I want my tabPanels to still have shiny output elements. I don't see how I can fit that in with JavaScript. That is why I included the plotOutput content in my code.
Thanks to anybody who can help solve this issue!
Finally came up with an own answer. I hope this can be a useful reference to others who try to understand shiny reactiveness. The answer is JavaScript for custom elements (rebuilding standard shiny elements) and using Shiny.unbindAll() / Shiny.bindAll() to achieve the reactivity.
Code:
runApp(
shinyApp(
ui = shinyUI(
fluidPage(
tags$script('
Shiny.addCustomMessageHandler("createTab",
function(nr){
Shiny.unbindAll();
var dropdownContainer = document.getElementById("dropdown-menu");
var liNode = document.createElement("li");
liNode.setAttribute("id", "dropdown-element-" + nr);
var aNode = document.createElement("a");
aNode.setAttribute("href", "#tab-menu-" + nr);
aNode.setAttribute("data-toggle", "tab");
aNode.setAttribute("data-value", "Inside" + nr);
var textNode = document.createTextNode("Inside " + nr);
aNode.appendChild(textNode);
liNode.appendChild(aNode);
dropdownContainer.appendChild(liNode);
var tabContainer = document.getElementById("tabContent");
var tabNode = document.createElement("div");
tabNode.setAttribute("id", "tab-menu-" + nr);
tabNode.setAttribute("class", "tab-pane");
tabNode.setAttribute("data-value", "Inside" + nr);
var plotNode = document.createElement("div");
plotNode.setAttribute("id", "plot-" + nr);
plotNode.setAttribute("class", "shiny-plot-output");
plotNode.setAttribute("style", "width: 100% ; height: 400px");
tabNode.appendChild(document.createTextNode("Content Inside " + nr));
tabNode.appendChild(plotNode);
tabContainer.appendChild(tabNode);
Shiny.bindAll();
}
);
Shiny.addCustomMessageHandler("deleteTab",
function(nr){
var dropmenuElement = document.getElementById("dropdown-element-" + nr);
dropmenuElement.parentNode.removeChild(dropmenuElement);
var tabElement = document.getElementById("tab-menu-" + nr);
tabElement.parentNode.removeChild(tabElement);
}
);
'),
tags$nav(class = "navbar navbar-default navbar-static-top", role = "navigation",
tags$div(class = "container",
tags$div(class = "navbar-header",
tags$span(class = "navbar-brand", "Nav")
),
tags$ul(class = "nav navbar-nav",
tags$li(
tags$a(href = "#tab1", "data-toggle" = "tab", "data-value" = "Outside1", "Outside1")
),
tags$li(
tags$a(href = "#tab2", "data-toggle" = "tab", "data-value" = "Outside2", "Outside2")
),
tags$li(class = "dropdown",
tags$a(href = "#", class = "dropdown-toggle", "data-toggle" = "dropdown", "Menu1"),
tags$ul(id = "dropdown-menu", class = "dropdown-menu")
)
)
)
),
tags$div(class = "container-fluid",
tags$div(class = "tab-content", id = "tabContent",
tags$div(class = "tab-pane active", "data-value" = "Outside1", id = "tab1",
numericInput("insidepanels", label = "Number of panels inside NavMenu", value = 0, step = 1),
numericInput("number", label = "Panel to add Output-Element to", value = 0, step = 1),
actionButton("button", label = "Add Output-Element")
),
tags$div(class = "tab-pane", "data-value" = "Outside2", id = "tab2", "Content 2")
)
)
)
),
server = function(input, output, session){
allOpenTabs <- NULL
observeEvent(input$insidepanels, {
if(!is.na(input$insidepanels)){
localList <- 0:input$insidepanels
lapply(setdiff(localList, allOpenTabs), function(x){
session$sendCustomMessage(type = "createTab", message = x)
})
lapply(setdiff(allOpenTabs, localList), function(x){
session$sendCustomMessage(type = "deleteTab", message = x)
})
allOpenTabs <<- localList
}
})
observeEvent(input$button, {
output[[paste0("plot-", input$number)]] <- renderPlot({
hist(rnorm(1000))
})
})
}
), launch.browser = TRUE
)
It is basically adding the HTML Elements "by hand" and linking them to shiny listeners.
I am creating a shiny app that dynamically creates a set of input boxes, the input from those boxes is then used to further create another set of input boxes.
First I get input from the "number of questions" text box and dynamically add that number of "question panels" to the ui (example below).
Issue
The issue is that the generated objects are always attached to the output, and I can't figure out how to grab new user input from them. How could I get this input, and then generate a second round of "answer" input boxes?
ui.R
shinyUI(fluidPage(
titlePanel("RSurvey"),
numericInput("questionCountText", label = h3("Number of Questions"), value = 1),
uiOutput("questionSet")
))
server.R
shinyServer(
function(input, output) {
output[['questionSet']] <- renderUI({
outputHtml = ""
count = input$questionCountText
if(count > 0) {
for(i in 1:input$questionCountText) {
outputHtml = paste0(outputHtml, questionPanel(i))
}
}
HTML(outputHtml)
})
}
)
questionPanel = function(i)
{
return(wellPanel(div(style="display:inline-block", textInput("questionText", label = h4(paste0("Question ", i)), "Enter your question")),
numericInput1("answerCountText", label = h4("Number of Answers"), value = 3, onchange="onTextChanged(this.value)")))
}
numericInput1 = function (inputId, label, value = "", ...)
{
div(style="display:inline-block",
tags$label(label, `for` = inputId),
tags$input(id = inputId, type = "numeric", value = value, ...))
}
Hello try this for example :
#ui
ui <- fluidPage(
titlePanel("RSurvey"),
numericInput("questionCountText", label = h3("Number of Questions"), value = 1),
uiOutput("questionSet"),
verbatimTextOutput(outputId = "answers")
)
#server
server <- function(input, output) {
output[['questionSet']] <- renderUI({
outputHtml = ""
count = input$questionCountText
if(count > 0) {
for(i in 1:input$questionCountText) {
outputHtml = paste0(outputHtml, questionPanel(i))
}
}
HTML(outputHtml)
})
output$answers <- renderPrint({
invisible(
sapply(
X = seq_len(input$questionCountText),
FUN = function(i) {
cat(paste0("Question", i, "\n", input[[paste0("questionText", i)]], "\n", input[[paste0("answerCountText", i)]], "\n"))
}
)
)
})
}
#app
shinyApp(ui = ui, server = server)
#utils
questionPanel = function(i) {
wellPanel(
div(
style="display:inline-block",
textInput2(inputId = paste0("questionText", i), label = h4(paste0("Question ", i)), placeholder = "Enter your question")
),
numericInput1(inputId = paste0("answerCountText", i), label = h4("Number of Answers"), value = 3, onchange="onTextChanged(this.value)")
)
}
numericInput1 = function (inputId, label, value = "", ...) {
div(style="display:inline-block", class = "form-group shiny-input-container",
tags$label(label, `for` = inputId),
tags$input(id = inputId, type = "number", value = value, ...))
}
`%AND%` <- shiny:::`%AND%`
textInput2 <- function (inputId, label, value = "", placeholder = NULL, width = NULL)
{
if (is.null(placeholder)) {
div(class = "form-group shiny-input-container", style = if (!is.null(width))
paste0("width: ", validateCssUnit(width), ";"), label %AND%
tags$label(label, `for` = inputId), tags$input(id = inputId,
type = "text", class = "form-control", value = value))
} else {
div(class = "form-group shiny-input-container", style = if (!is.null(width))
paste0("width: ", validateCssUnit(width), ";"), label %AND%
tags$label(label, `for` = inputId), tags$input(id = inputId, placeholder = placeholder,
type = "text", class = "form-control", value = value))
}