Related
Thanks for taking your valuable time to pitch in into this question. :-)
I'm building a shiny app that would take user inputs through rhandsontable and save it as a .rds file for data persistence.
The code is as follows:
Global.r
library(shiny)
library(shinydashboard)
library(shinycssloaders
library(rhandsontable)
library(htmltools)
library(plotly)
library(shinyjs)
library(tidyverse)
library(DT)
# Reads the data stored already
raw_data_projects <- readRDS("Projects.rds")
# code to refresh app so as to display the newly added data
jsResetCode <- "shinyjs.reset = function() {history.go(0)}"
ui.R
dashboardPage(skin = "black",
dashboardHeader(dropdownMenuOutput("dropdownmenu"),title = "PMO Dashboard",
tags$li(div(img(src = 'TechM_logo.png',
height = "35px"),
style = "padding-top:10px; padding-bottom:10px;"),
class = "dropdown"),dropdownMenuOutput("msgOutput")) ,
dashboardSidebar(
sidebarMenu(
menuItem("Home", tabName = "home", icon = icon("home")),
menuItem("Projects", tabName = "pros", icon = icon("briefcase")),
menuItem("About Team", tabName = "teamstr", icon = icon("user-friends")),
menuItem("Training & Skills",tabName = "skills",icon = icon("book"))
)),
dashboardBody(
useShinyjs(), # Include shinyjs in the UI
extendShinyjs(text = jsResetCode),
tags$link(rel = "stylesheet", type = "text/css", href = "style_2.css"),
tabItems(
tabItem(tabName = "pros",
fluidPage(tabBox(width = "500px",
tabPanel("Metrics",
fluidRow(
valueBoxOutput("Completed", width = 3),
valueBoxOutput("WIP", width = 3),
valueBoxOutput("Delayed", width = 3),
valueBoxOutput("OnHold", width = 3)
),
fluidRow(
box(plotlyOutput("Project_category"), width = 4,solidHeader = TRUE, status = "primary", title = "Project Category", collapsible = TRUE),
box(plotlyOutput("Project_status"), width = 8,solidHeader = TRUE, status = "primary", title = "Project Status", collapsible = TRUE),
box(plotlyOutput("Complexity"), width = 4,solidHeader = TRUE, status = "primary", title = "Project Complexity", collapsible = TRUE),
box(plotlyOutput("Audits"), width = 4,solidHeader = TRUE, status = "primary", title = "Audit Status", collapsible = TRUE)
)),
tabPanel("Data",
box(withSpinner(rHandsontableOutput("Projects")), width = 12),
actionButton("saveBtnProjects", "Save Projects", icon = icon("save")),
actionButton("BtnResetProjects", "Reset Filters", icon = icon("eraser")))))
)))
server.r
shinyServer(function(input, output, session){
dt_projects <- reactive({ raw_data_projects })
vals <- reactiveValues()
output$Projects <- renderRHandsontable({
rhandsontable(dt_projects(), readOnly = FALSE, search = TRUE, selectCallback = TRUE ) %>%
hot_cols(columnSorting = TRUE, manualColumnMove = TRUE, manualColumnResize = TRUE ) %>%
hot_table(highlightRow = TRUE, highlightCol = TRUE) %>%
#hot_col("PROJECT.STATUS", renderer = text_renderer, type = "autocomplete") %>%
hot_rows(fixedRowsTop = 1)
})
# on click of button the file will be saved to the working directory
observeEvent(input$saveBtnProjects,
#write.csv(hot_to_r(input$Projects), file = "./Data/project_tracker.csv",row.names = FALSE)
saveRDS(hot_to_r(input$Projects),"Projects.rds")
)
# refresh the page
observeEvent(input$saveBtnProjects, {js$reset()})
})
So when I run the app I get the table I desire as below:
As we can see, as I was inserting values to the first column, all the other columns greyed out and I couldn't insert any values into it. Please help me with this issue.
Also please suggest if my code will display the data reactively as soon as I save the data by pressing Save Projects button.
Thanks a ton in advance!!
P.S : I have included the server code only for the table considering the length of the question leaving the code of other tabs. But still this code is reproducible.
I'm trying to build an interactive UI by rendering it inside an output with renderUI. The thing is: I have inputs created inside this rendering function whose behavior should change according to the answers provided. But when I do it, the reactivity updates the entire output and erases the answers provided, resetting the inputs to original state. Is there a way to determine which inputs I want to update? Or is there a better way of building this structure?
EDIT: Just to clarify: I want to change the label of the textInput without updating the radioButtons. The second radioButton answer should affect the behaviour of the textInput only.
ui <- miniPage(
miniTabstripPanel(id = 'tabs',
miniTabPanel("Data",
miniContentPanel(
selectInput(inputId = 'indicator', label = "Select indicator:",
choices = c('Select an indicator' = 'none',
"Water" = 'iwater',
'Antenatal care 4+ visits' = 'anc4',
'Institutional delivery' = 'ideliv')),
)
),
miniTabPanel("Second tab",
miniContentPanel(
uiOutput(outputId = "indicarea")
)
)
)
)
server <- function(input, output, session) {
iwater_vartype = reactiveVal(value= "Example label 1")
observeEvent(input$iwater_variabletype,{
if (input$iwater_variabletype == 'codes') {
iwater_vartype("Example label 1")
}
else {
iwater_vartype("Example label 2")
}
})
observeEvent(input$indicator,{
output$indicarea = renderUI({
buildUI(input$indicator)
})
})
buildUI = function(indic) {
switch(indic,
'none' = {
h3("Please select an indicator to proceed.")
},
'iwater' = {
tagList(
h3("Improved source of drinking water"),
br(), hr(), br(),
radioButtons(inputId = 'iwater_subsample', label = "Asked it in all?",
choices = c('Yes' = 'yes', 'No' = 'no')),
radioButtons(inputId = 'iwater_variabletype', label = "How was the info collected?",
choices = c('One variable' = 'codes', 'Several variables' = 'variables')),
textInput(inputId = 'iwater_sourcevariable', label= iwater_vartype())
)
},
'anc4' = {
tagList(
textInput(inputId = 'test', label= 'testing')
)
}
)
}
}
runGadget(ui, server)
Thanks in advance!
you could try adding an observeEvent to you server code with something like this.
observeEvent(input$iwater_variabletype,{
updateTextInput(
session = session,
inputId = "iwater_sourcevariable",
label = "new Label for text Input"
)
})
hope this helps!
I want to place a help text for check-box label as a tooltip.
In the following example I use the shinyBS package - but I only get it to work for the title of the checkbox input group.
Any ideas how it could work after the "Lernerfolg" or "Enthusiasmus" labels?
library(shiny)
library(shinyBS)
server <- function(input, output) {
output$distPlot <- renderPlot({
hist(rnorm(input$obs), col = 'darkgray', border = 'white')
output$rendered <- renderUI({
checkboxGroupInput("qualdim", tags$span("Auswahl der Qualitätsdimension",
tipify(bsButton("pB2", "?", style = "inverse", size = "extra-small"),
"Here, I can place some help")),
c("Lernerfolg" = "Lernerfolg" ,
"Enthusiasmus" = "Enthusiasmus"
),
selected = c("Lernerfolg"))
})
})
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput("obs", "Number of observations:", min = 10, max = 500, value = 100),
uiOutput("rendered")
),
mainPanel(plotOutput("distPlot"))
)
)
shinyApp(ui = ui, server = server)
Sadly, this is one of these moments, where shiny hides most of the construction, which makes it hard to get what you want into the right places.
But like most of the time, some JavaScript will do the trick. I wrote you a function that inserts the bsButton in the right place and calls a shinyBS function to insert the tooltip. (I mainly reconstructed what tipify and bdButton would have done.) With the function you can modifify your tooltip easily without further knowledge about JavaScript.
If you'd like to know more of the details, just ask in comments.
Note: When you refer to the checkbox, use the value of it (the value that is sent to input$qualdim)
library(shiny)
library(shinyBS)
server <- function(input, output) {
makeCheckboxTooltip <- function(checkboxValue, buttonLabel, Tooltip){
script <- tags$script(HTML(paste0("
$(document).ready(function() {
var inputElements = document.getElementsByTagName('input');
for(var i = 0; i < inputElements.length; i++){
var input = inputElements[i];
if(input.getAttribute('value') == '", checkboxValue, "'){
var buttonID = 'button_' + Math.floor(Math.random()*1000);
var button = document.createElement('button');
button.setAttribute('id', buttonID);
button.setAttribute('type', 'button');
button.setAttribute('class', 'btn action-button btn-inverse btn-xs');
button.appendChild(document.createTextNode('", buttonLabel, "'));
input.parentElement.parentElement.appendChild(button);
shinyBS.addTooltip(buttonID, \"tooltip\", {\"placement\": \"bottom\", \"trigger\": \"hover\", \"title\": \"", Tooltip, "\"})
};
}
});
")))
htmltools::attachDependencies(script, shinyBS:::shinyBSDep)
}
output$distPlot <- renderPlot({
hist(rnorm(input$obs), col = 'darkgray', border = 'white')
output$rendered <- renderUI({
list(
checkboxGroupInput("qualdim", tags$span("Auswahl der Qualitätsdimension",
tipify(bsButton("pB2", "?", style = "inverse", size = "extra-small"), "Here, I can place some help")),
choices = c("Lernerfolg" = "Lernerfolg", "Enthusiasmus" = "Enthusiasmus"),
selected = c("Lernerfolg")),
makeCheckboxTooltip(checkboxValue = "Lernerfolg", buttonLabel = "?", Tooltip = "Look! I can produce a tooltip!")
)
})
})
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
sliderInput("obs", "Number of observations:", min = 10, max = 500, value = 100),
uiOutput("rendered")
),
mainPanel(plotOutput("distPlot"))
)
)
shinyApp(ui = ui, server = server)
Edit:
Added the ShinyBS Dependencies such that the JavaScript API for shinyBS is loaded into the WebSite. Before, this was (more or less accidentally) happening because of the other call to bsButton.
Edit Nr.2: Much more In-Shiny
So this JavaScript thing is quite nice, but is kinda prone to errors and demands the developer to have some additional language skills.
Here, I present another answer, inspired by #CharlFrancoisMarais , that works only from within R and makes things more integrated than before.
Main things are: An extension function to the checkboxGrouInput that allows for adding any element to each of the Checkbox elements. There, one can freely place the bsButton and tooltips, like you would in normal markup, with all function arguments supported.
Second, an extension to the bsButton to place it right. This is more of a custom thing only for #CharlFrancoisMarais request.
I'd suggest you read the Shiny-element manipulation carefully, because this offers so much customization on R level. I'm kinda exited.
Full Code below:
library(shiny)
library(shinyBS)
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
}
bsButtonRight <- function(...) {
btn <- bsButton(...)
# Directly inject the style into the shiny element.
btn$attribs$style <- "float: right;"
btn
}
server <- function(input, output) {
output$distPlot <- renderPlot({
hist(rnorm(input$obs), col = 'darkgray', border = 'white')
output$rendered <- renderUI({
extendedCheckboxGroup("qualdim", label = "Checkbox", choiceNames = c("cb1", "cb2"), choiceValues = c("check1", "check2"), selected = c("check2"),
extensions = list(
tipify(bsButtonRight("pB1", "?", style = "inverse", size = "extra-small"),
"Here, I can place some help"),
tipify(bsButtonRight("pB2", "?", style = "inverse", size = "extra-small"),
"Here, I can place some other help")
))
})
})
}
ui <- fluidPage(
shinyjs::useShinyjs(),
tags$head(HTML("<script type='text/javascript' src='sbs/shinyBS.js'></script>")),
# useShinyBS
sidebarLayout(
sidebarPanel(
sliderInput("obs", "Number of observations:", min = 10, max = 500, value = 100),
uiOutput("rendered")
),
mainPanel(plotOutput("distPlot"))
)
)
shinyApp(ui = ui, server = server)
Here is slight change - to add tooltips only to the checkboxes.
library(shiny)
library(shinyBS)
server <- function(input, output) {
makeCheckboxTooltip <- function(checkboxValue, buttonLabel, buttonId, Tooltip){
tags$script(HTML(paste0("
$(document).ready(function() {
var inputElements = document.getElementsByTagName('input');
for(var i = 0; i < inputElements.length; i++) {
var input = inputElements[i];
if(input.getAttribute('value') == '", checkboxValue, "' && input.getAttribute('value') != 'null') {
var button = document.createElement('button');
button.setAttribute('id', '", buttonId, "');
button.setAttribute('type', 'button');
button.setAttribute('class', 'btn action-button btn-inverse btn-xs');
button.style.float = 'right';
button.appendChild(document.createTextNode('", buttonLabel, "'));
input.parentElement.parentElement.appendChild(button);
shinyBS.addTooltip('", buttonId, "', \"tooltip\", {\"placement\": \"right\", \"trigger\": \"click\", \"title\": \"", Tooltip, "\"})
};
}
});
")))
}
output$distPlot <- renderPlot({
hist(rnorm(input$obs), col = 'darkgray', border = 'white')
output$rendered <- renderUI({
checkboxGroupInput("qualdim",
label = "Checkbox",
choiceNames = c("cb1", "cb2"),
choiceValues = c("check1", "check2"),
selected = c("check2"))
})
output$tooltips <- renderUI({
list(
makeCheckboxTooltip(checkboxValue = "check1", buttonLabel = "?", buttonId = "btn1", Tooltip = "tt1!"),
makeCheckboxTooltip(checkboxValue = "check2", buttonLabel = "?", buttonId = "btn2", Tooltip = "tt2!")
)
})
})
}
ui <- fluidPage(
shinyjs::useShinyjs(),
tags$head(HTML("<script type='text/javascript' src='sbs/shinyBS.js'></script>")),
# useShinyBS
sidebarLayout(
sidebarPanel(
sliderInput("obs", "Number of observations:", min = 10, max = 500, value = 100),
uiOutput("rendered"),
uiOutput("tooltips")
),
mainPanel(plotOutput("distPlot"))
)
)
shinyApp(ui = ui, server = server)
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'm making an app and I need to add a button to refresh page (same function to press F5). Is there anyone can share a piece of code to implement it?
Thanks a lot!
I do have a very simple and nice solution but it won't work for a file input.
Here's a solution that'll work for all inputs except a file input:
UPDATE 2017: this solution did not work on file inputs for the first 2 years, but it does now.
library(shiny)
library(shinyjs)
runApp(shinyApp(
ui = fluidPage(
shinyjs::useShinyjs(),
div(
id = "form",
textInput("text", "Text", ""),
selectInput("select", "Select", 1:5),
actionButton("refresh", "Refresh")
)
),
server = function(input, output, session) {
observeEvent(input$refresh, {
shinyjs::reset("form")
})
}
))
When you press "Refresh", all inputs will be reset to their initial values. This is what the poster said in a comment that they actually want to do.
But file inputs are very strange and it's hard to "reset" them. See here. You could hack some JavaScript together to try to almost kind of reset an input field if you want.
However, for completeness, you can also refresh the entire page. The easiest way to do that is with session$reload(). You can also do it with {shinyjs}:
library(shiny)
library(shinyjs)
runApp(shinyApp(
ui = fluidPage(
shinyjs::useShinyjs(),
shinyjs::extendShinyjs(text = "shinyjs.refresh_page = function() { location.reload(); }", functions = "refresh_page"),
textInput("text", "Text", ""),
actionButton("refresh", "Refresh")
),
server = function(input, output, session) {
observeEvent(input$refresh, {
shinyjs::js$refresh_page()
})
}
))
Disclaimer: both these solutions use a package I wrote, shinyjs
I have a drop-down list input:
selectInput("domain", label = h4("Domain:"), choices = Domain, selected = CurrentDomain)
The choices set is based on a table in the database. It should change after I add or delete record from the table.
When I was experimenting with your reset or refresh function, the choice set could not reflect the changes and always stay the same. However, when I use the "reload" button provided by the browser, the choice set will update immediately. I am wondering whether you have a reset/refresh solution that is equivalent to the "reload" button of the browser.
I provided my code here, which will not work but will give you an idea what I want to do.
conn<-odbcDriverConnect(connString)
SystemInfo<-sqlQuery(conn, 'SELECT * FROM [DQ].[DQSystemInfo]', stringsAsFactors = FALSE)
close(conn)
Domain<-unique(SystemInfo$Domain)
Domain<-c(Domain,'NEW')
SubDomain<-unique(SystemInfo$SubDomain[SystemInfo$Domain==Domain[1]])
SubDomain<-c(SubDomain,'NEW')
CurrentDomain<-Domain[1]
CurrentSubDomain<-SubDomain[1]
SystemInfo1<-SystemInfo[SystemInfo$Domain==CurrentDomain & SystemInfo$SubDomain==CurrentSubDomain,]
jsResetCode <- "shinyjs.reset = function() {history.go(0)}"
shinyApp(
ui = fluidPage(
shinyjs::useShinyjs(),
shinyjs::extendShinyjs(text = "shinyjs.refresh = function() { location.reload(); }"),
# div(
# id = "form",
fluidRow(
column(6, selectInput("domain", label = h4("Domain:"),
choices = Domain, selected = CurrentDomain)),
column(6,uiOutput("Condition2"))
),
# fluidRow(column(2, verbatimTextOutput("value"))),
fluidRow(
column(6, uiOutput("Condition1")),
column(6,uiOutput("Condition3"))
),
extendShinyjs(text = jsResetCode),
fluidRow(
column(2, actionButton("submit", "Save", class="btn btn-primary btn-lg")),
column(2, actionButton("cancel", "Cancel", class="btn btn-primary btn-
lg")),
column(2, actionButton("delete", "Delete", class="btn btn-primary btn-lg"))
)
#)
),
server = function(input, output) {
observeEvent(input$domain, {
if (input$domain=='NEW') {
shinyjs::disable("domain")
shinyjs::disable("delete")
CurrentSubDomain<-'NEW'
output$Condition1 = renderUI({
textInput("domainT",label = "", value = "")
})
output$Condition3 = renderUI({
textInput("subdomainT", label = "",value = "")
})
})
} else {
CurrentDomain<-input$domain
SubDomain<-unique(SystemInfo$SubDomain[SystemInfo$Domain==input$domain])
SubDomain<-c(SubDomain,'NEW')}
output$Condition2 = renderUI({
selectInput("subdomain", label = h4("SubDomain:"),
choices = SubDomain, selected =CurrentSubDomain)
})
})
observeEvent(input$subdomain, {
if (input$subdomain=='NEW') {
shinyjs::disable("domain")
shinyjs::disable("subdomain")
shinyjs::disable("delete")
output$Condition3 = renderUI({
textInput("subdomainT", label = "", value = "")
})
} else {
CurrentSubDomain<-input$subdomain
conn<-odbcDriverConnect(connString)
SystemInfo<-sqlQuery(conn, 'SELECT * FROM [DQ].[DQSystemInfo]', stringsAsFactors = FALSE)
close(conn)
SystemInfo1<-SystemInfo[SystemInfo$Domain==input$domain & SystemInfo$SubDomain==input$subdomain,]
}
})
observeEvent(input$submit, {
conn<-odbcDriverConnect(connString)
DQ.DQSystemInfo<-SystemInfo[FALSE,c("Domain","SubDomain")]
DQ.DQSystemInfo[1,]<-c("","","","","","","",0,48)
DQ.DQSystemInfo$Domain<-ifelse(input$domain=='NEW',input$domainT,input$domain)
DQ.DQSystemInfo$SubDomain<-input$subdomainT
varType1 <- c("varchar(20)", "varchar(20)" )
names(varType1)<-colnames(DQ.DQSystemInfo)
sqlSave(conn, DQ.DQSystemInfo, append = TRUE, rownames = FALSE, varTypes = varType1)
close(conn)
# js$reset()
#shinyjs::reset("form")
# js$reset("form")
conn<-odbcDriverConnect(connString)
SystemInfo<-sqlQuery(conn, 'SELECT * FROM [DQ].[DQSystemInfo]', stringsAsFactors = FALSE)
close(conn)
Domain<-unique(SystemInfo$Domain)
Domain<-c(Domain,'NEW')
SubDomain<-unique(SystemInfo$SubDomain[SystemInfo$Domain==Domain[1]])
SubDomain<-c(SubDomain,'NEW')
CurrentDomain<-Domain[1]
CurrentSubDomain<-SubDomain[1]
SystemInfo1<-SystemInfo[SystemInfo$Domain==CurrentDomain & SystemInfo$SubDomain==CurrentSubDomain,]
shinyjs::js$refresh()
})
observeEvent(input$cancel, {
#js$reset()
#shinyjs::reset("form")
#js$reset("form")
shinyjs::js$refresh()
})
observeEvent(input$delete, {
conn<-odbcDriverConnect(connString)
delete.query <- paste0("DELETE DQ.DQSystemInfo WHERE Domain='",
input$domain,"' and SubDomain='",input$subdomain,"'")
sqlQuery(conn, delete.query)
close(conn)
#js$reset()
# shinyjs::reset("form")
# js$reset("form")
conn<-odbcDriverConnect(connString)
SystemInfo<-sqlQuery(conn, 'SELECT * FROM [DQ].[DQSystemInfo]', stringsAsFactors = FALSE)
close(conn)
Domain<-unique(SystemInfo$Domain)
Domain<-c(Domain,'NEW')
SubDomain<-unique(SystemInfo$SubDomain[SystemInfo$Domain==Domain[1]])
SubDomain<-c(SubDomain,'NEW')
CurrentDomain<-Domain[1]
CurrentSubDomain<-SubDomain[1]
SystemInfo1<-SystemInfo[SystemInfo$Domain==CurrentDomain & SystemInfo$SubDomain==CurrentSubDomain,]
shinyjs::js$refresh()
})
},options = list(height = 520))