Independent reactions are interacting in a Shiny App - r

I'm using the sliderInput function with the animate argument to perform an automatic calculation in my shinyApp. However, using animate is affecting other reactions in my app. I would like to stop this side effect that is occurring in other reactivities.
For example, I have a dropdownMenu inside an if else structure. But, because of the animate argument, I can't click the option in the top right corner when I start the animation. It is disappearing with each calculation that the animate is doing. See:
I tried use isolate() in pred_1() but it stop the valueBox and the conditional structure (if else structure).
I'd like to just make animate not affect other reactivity in the app.
My app:
library(shiny)
library(shinydashboard)
header <- dashboardHeader(
title = "Dashboard",
titleWidth = 300,
dropdownMenuOutput(
outputId = "drop1"
)
)
sidebar <- dashboardSidebar(
width = 300
)
body <- dashboardBody(
sliderInput(
inputId = "one",
label = "Registro 1",
value = 1,
animate = animationOptions(
interval = 500, loop = TRUE
),
min = 1,
max = 10,
step = 1,
ticks = TRUE
),
sliderInput(
inputId = "two",
label = "Registro 2",
value = 1,
animate = animationOptions(
interval = 500, loop = TRUE
),
min = 1,
max = 10,
step = 1,
ticks = TRUE
),
sliderInput(
inputId = "three",
label = "Sum 3",
value = 1,
animate = animationOptions(
interval = 500, loop = TRUE
),
min = 1,
max = 10,
step = 1,
ticks = TRUE
),
valueBoxOutput(
outputId = "box1"
)
)
ui <- dashboardPage(
header = header,
sidebar = sidebar,
body = body
)
server <- function(session, input, output) {
fx <- function(x, y) {
x + y
}
fy <- function(x) {
x
}
reac_0 <- reactive({
tibble::tibble(
one = input$one,
two = input$two,
three = input$three
)
})
chuveiro <- reactive({
temp <- reac_0()
fx(
x = temp$one,
y = temp$two
)
})
luz <- reactive({
temp <- reac_0()
fy(
x = temp$three
)
})
fdrop <- function(x) {
if (x <= 5) {
dropdownMenu(
type = "notifications",
badgeStatus = NULL,
headerText = "Not 1",
notificationItem(
text = HTML(
"<text style='color:#020202;'>Without.</text>"
),
status = "danger",
icon = icon("times"),
href = NULL
)
)
} else (
dropdownMenu(
type = "notifications",
badgeStatus = "danger",
headerText = "Not 2",
notificationItem(
text = HTML(
"<a style='color:#020202;'
href='https://www.instagram.com' target='_blank' title='A'>
With</a>"
),
status = "success",
icon = icon("tags")
)
)
)
}
output$drop1 <- renderMenu({
expr = fdrop(x = luz())
})
output$box1 <- renderValueBox({
expr = valueBox(
value = chuveiro(),
subtitle = "Sum"
)
})
}
shinyApp(ui, server)
So how can I make one reactivity effect another in a shinyApp?
I would like to click normally on the dropdownMenu notification with the sliderInput working with animate.
I tried isolating each argument of sliderInput, but not work.

The reac0() reactive is triggered whenever an input changes. Then it triggers every reactive that includes it, even if the value used in that reactive has not changed.
Your code :
reac_0 <- reactive({
tibble::tibble(
one = input$one,
two = input$two,
three = input$three
)
})
luz <- reactive({
temp <- reac_0()
fy(
x = temp$three
)
})
triggers luz() whenever one, two or three changes.
An alternative would be to use input$three directly:
luz <- reactive({
fy(
x = input$three
)
})
This way, the change or animation of slider one and two won't trigger luz() which won't trigger the menu rendering.
Of course, since the value of slider three is used to render the menu, any update of its value has to trigger the menu rendering.

Related

R Shiny click on table field

I am currently learning R. I have a small project where a timetable is displayed and the user has the option to enter a subject.
After adding the subject to the timetable, it should be possible to click on it to open the modalDialog.
Unfortunately my code does not work. I have tried it here:
observeEvent(input$mytable_cells_selected, {
showModal(modalDialog(
title = "Somewhat important message",
"This is a somewhat important message.",
easyClose = TRUE,
footer = NULL))
})
Can someone help me and tell where my error is?
ui <- fluidPage(
theme = bs_theme(version = 4, bootswatch = "minty"),
titlePanel(h1("My timetable", align = "center" )),
sidebarLayout(
position = c("left"),
sidebarPanel(
width = 4,
selectInput("select1", label = h5("Event:"),
choices = c("math" , "sience", "sport") ,
selected = 1,
width = 400),
actionButton("action", label = "Add")),
mainPanel(
width = 8,
tableOutput('mytable')),
),
)
and server:
server <- function(input, output, session) {
timetable <- reactiveVal(
data.frame(monday = c("","","","",""),
tuesday = c("","","","",""),
wednesday = c("","","","",""),
thursday = c("","","","",""),
friday = c("","","","",""))
)
output$mytable <- renderTable(timetable(),
bordered = TRUE,
spacing = c('l'),
width = "100%",
striped = TRUE,
align = 'c',
rownames = TRUE,
selection = list(target = 'cell'))
observeEvent(input$action, {
tmp <- timetable()
tmp[1, "monday"] <- input$select1
timetable(tmp)
})
observeEvent(input$mytable_cells_selected, {
showModal(modalDialog(
title = "message",
"This is a somewhat important message.",
easyClose = TRUE,
footer = NULL))
})
}
shinyApp(ui, server)
As mentioned in the comment, you can use the DT library. Here is a complete example.
Use dataTableOutput in your ui for your data table.
In server, you can include renderDataTable and customize here. In this case, selection is set for single cells.
You can capture the selection event (or can capture clicked event) with input$my_table_cells_selected. In my version I used an underscore for my_table. This information will include the row and column values of the cell selected.
Note that the DT data table could be editable and allow for other interactivity, depending on your needs.
library(shiny)
library(bslib)
library(DT)
ui <- fluidPage(
theme = bs_theme(version = 4, bootswatch = "minty"),
titlePanel(h1("My timetable", align = "center" )),
sidebarLayout(
position = c("left"),
sidebarPanel(
width = 4,
selectInput("select1", label = h5("Event:"),
choices = c("math" , "sience", "sport") ,
selected = 1,
width = 400),
actionButton("action", label = "Add")),
mainPanel(
width = 8,
dataTableOutput('my_table')
)
)
)
server <- function(input, output, session) {
timetable <- reactiveVal(
data.frame(monday = c("","","","",""),
tuesday = c("","","","",""),
wednesday = c("","","","",""),
thursday = c("","","","",""),
friday = c("","","","",""))
)
output$my_table = renderDataTable(timetable(), selection = list(mode = "single", target = "cell"))
observeEvent(input$action, {
tmp <- timetable()
tmp[1, "monday"] <- input$select1
timetable(tmp)
})
observeEvent(input$my_table_cells_selected, {
req(input$my_table_cells_selected)
showModal(modalDialog(
title = "message",
paste("This is a somewhat important message:",
input$my_table_cells_selected[1],
input$my_table_cells_selected[2]),
easyClose = TRUE,
footer = NULL))
})
}
shinyApp(ui, server)

Pass reactive table to function to be printed via action button

I have a R shinydashboard where a table can be edited and then I'd like the new table to be passed to the function agree() to calculate a statistic to be printed upon clicking an action button. I'm getting the following error in my renderPrint box on the app and assume a few things may be off in my code:
Error message in renderPrint box on app:
structure(function (...) ,{, if (length(outputArgs) != 0 && !hasExecuted$get()) {, warning("Unused argument: outputArgs. The argument outputArgs is only ", , "meant to be used when embedding snippets of Shiny code in an ", , "R Markdown code chunk (using runtime: shiny). When running a ", , "full Shiny app, please set the output arguments directly in ", , "the corresponding output function of your UI code."), hasExecuted$set(TRUE), }, if (is.null(formals(renderFunc))) , renderFunc(), else renderFunc(...),}, class = "function", outputFunc = function (outputId, placeholder = FALSE) ,{, pre(id = outputId, class = "shiny-text-output", class = if (!placeholder) , "noplaceholder"),}, outputArgs = list(), hasExecuted = <environment>, cacheHint = list(, label = "renderPrint", origUserExpr = agree(as.data.frame(table1))))
Below is my code (I have 3 tabItems but am just focusing on getting the first tab: tabName = "2int" to work. Issue lies in the sever code of output$irr1. Can use the baseR cor() function in replace of agree() from the irr package for testing purposes. Just need the updated table to be saved as a dataframe with all numbers or matrix to function correctly with the agree() function.
library(shiny)
library(irr)
library(DT)
library(dplyr)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "Interview Reliability"),
dashboardSidebar(
sidebarMenu(
menuItem("Two Interviewers",
tabName = "2int",
icon = icon("glass-whiskey")),
menuItem("Three Interviewers",
tabName = "3int",
icon = icon("glass-whiskey")),
menuItem("Four Interviewers",
tabName = "4int",
icon = icon("glass-whiskey"))
)
),
dashboardBody(
tabItems(
tabItem(tabName = "2int",
fluidRow(box(sliderInput("obs1", "Number of Interview Questions:",
value = 4,
min = 4,
max = 12,
step = 1))),
box(dataTableOutput("table1")),
box(verbatimTextOutput("irr1")),
box(actionButton("calc1", "Calculate"))
),
tabItem(tabName = "3int",
box(sliderInput("obs2", "Number of Interview Questions:",
value = 4,
min = 4,
max = 12,
step = 1))
),
tabItem(tabName = "4int",
box(sliderInput("obs3", "Number of Interview Questions:",
value = 4,
min = 4,
max = 12,
step = 1)),
)
)
)
)
server <- function(input, output) {
tablevalues <- reactiveValues(df = NULL)
observeEvent(input$obs1, {
tablevalues$df <- matrix(NA, nrow = input$obs1, ncol = 2,
dimnames = list(1:input$obs1, c("Interviewer 1", "Interviewer 2")))
})
output$table1 <- renderDT(tablevalues$df, escape = FALSE, selection = 'none', editable=TRUE)
output$irr1 <- eventReactive(input$calc1, {
renderPrint(agree(as.data.frame(table1)))
})
}
shinyApp(ui = ui, server = server)
You are mixing things here, and therefore your syntax is incorrect. Try this
server <- function(input, output) {
tablevalues <- reactiveValues(df = NULL)
observeEvent(input$obs1, {
tablevalues$df <- matrix(NA, nrow = input$obs1, ncol = 2,
dimnames = list(1:input$obs1, c("Interviewer 1", "Interviewer 2")))
})
output$table1 <- renderDT(tablevalues$df, escape = FALSE, selection = 'none', editable=TRUE)
### update tablevalues$df with all the edits
observeEvent(input$table1_cell_edit,{
info = input$table1_cell_edit
str(info)
i = info$row
j = info$col
v = as.numeric(info$value) ### change it to info$value if your function does not need it to be numeric
tablevalues$df[i, j] <<- DT::coerceValue(v, tablevalues$df[i, j])
})
mycor <- eventReactive(input$calc1, {
cor(tablevalues$df)
})
output$irr1 <- renderPrint({mycor()})
}

Navbar/Tabset with reactive Panel number but NOT rendering everything

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.

shiny sliderInput from max to min

Is it possible to make a sliderInput that shows the values in decreasing order (from left to right; eg. 5 4 3 2 1)?
runApp(
list(
ui = fluidPage(
sliderInput("test","", min=5, max=1, value = 3, step=1)
),
server = function(input,output) {}
)
)
EDIT 2017-10-13: This function is now available in package shinyWidgets (with a different name : sliderTextInput()).
Hi you can write your own slider function like this (it's a little dirty...) :
sliderValues <- function (inputId, label, values, from, to = NULL, width = NULL) {
sliderProps <- shiny:::dropNulls(list(class = "js-range-slider",
id = inputId,
`data-type` = if (!is.null(to)) "double",
`data-from` = which(values == from) - 1,
`data-to` = if (!is.null(to)) which(values == to) - 1,
`data-grid` = TRUE,
`data-values` = paste(values, collapse = ", ")
))
sliderProps <- lapply(sliderProps, function(x) {
if (identical(x, TRUE))
"true"
else if (identical(x, FALSE))
"false"
else x
})
sliderTag <- div(class = "form-group shiny-input-container",
style = if (!is.null(width))
paste0("width: ", validateCssUnit(width), ";"),
if (!is.null(label))
shiny:::controlLabel(inputId, label), do.call(tags$input,
sliderProps))
dep <- list(htmltools::htmlDependency("ionrangeslider", "2.0.12", c(href = "shared/ionrangeslider"),
script = "js/ion.rangeSlider.min.js",
stylesheet = c("css/ion.rangeSlider.css",
"css/ion.rangeSlider.skinShiny.css")))
htmltools::attachDependencies(sliderTag, dep)
}
The point to do this is to use the values attribute from ionrangeslider (see section Using custom values array here)
The downside is the value of the input you retrieve server-side isn't the value of the slider but the index of the value (starting from 0).
You can use this function like this :
library("shiny")
runApp(
list(
ui = fluidPage(
# you have to pass the values you want in the slider directly to th function
sliderValues(inputId = "test", label = "", from = 5, values = 5:1),
verbatimTextOutput(outputId = "slidervalue")
),
server = function(input,output) {
output$slidervalue <- renderPrint({
# Careful ! : input$test isn't the expected value !!!
(5:1)[input$test + 1]
})
}
)
)
And bonus : it works with characters vectors too :
runApp(
list(
ui = fluidPage(
sliderValues(inputId = "test", label = "", from = "g", to = "o", values = letters),
verbatimTextOutput(outputId = "slidervalue")
),
server = function(input,output) {
output$slidervalue <- renderPrint({
# Careful ! : input$test isn't the expected value !!!
letters[input$test + 1]
})
}
)
)

R Shiny: fast reactive image display

I'm trying to display images in my shiny app reactively. I've successfully done that in the server.R script with:
output$display.image <- renderImage({
image_file <- paste("www/",input$image.type,".jpeg",sep="")
return(list(
src = image_file,
filetype = "image/jpeg",
height = 520,
width = 696
))
}, deleteFile = FALSE)
BUT it's very slow.
However, it is VERY fast to embed one of the images into the ui.R script like so:
tabPanel("Live Images", img(src = "img_type1.jpeg"))
Why is there such a difference? Is there any way to make the reactive images appear faster?
Hi you can use conditionalPanel to do this, it embed all your images but only the one which have TRUE to the condition will be displayed :
tabPanel("Live Images",
conditionalPanel(condition = "input.image_type == 'img_type1'",
img(src = "img_type1.jpeg")
),
conditionalPanel(condition = "input.image_type == 'img_type2'",
img(src = "img_type2.jpeg")
)
)
And change the name of your input from image.type to image_type because . have special meaning in Javascript (as between input and image_type).
If you have a lot of images, you can always do something like that :
tabPanel("Live Images",
lapply(X = seq_len(10), FUN = function(i) {
conditionalPanel(condition = paste0("input.image_type == 'img_type", i, "'"),
img(src = paste0("img_type", i, ".jpeg"))
)
})
)
For example, with images from this post by tsperry (you can find it on rbloggers too), you can do :
library("shiny")
ui <- fluidPage(
tabsetPanel(
tabPanel("Live Images",
# 50 images to display
lapply(X = seq_len(50), FUN = function(i) {
# condition on the slider value
conditionalPanel(condition = paste0("input.slider == ", i),
# images are on github
img(src = paste0("https://raw.githubusercontent.com/pvictor/images/master/",
sprintf("%04d", i), "plot.png"))
)
}),
sliderInput(inputId = "slider", label = "Value", min = 1, max = 50, value = 1,
animate = animationOptions(interval = 100, loop = TRUE))
)
)
)
server <- function(input, output) {
}
shinyApp(ui = ui, server = server)

Resources