Double Click in R-shiny - r

I had a small questions. I have tried researching this a lot but I have had no luck. Is there a way R-shiny has to capture a double click on an element like a button.

Here is one way to do it. The key is to detect the dblclick event on the client side (i.e. ui), and then invoke Shiny.onInputChange to update the value of an R variable, which can then be picked up by the server.
Here is what happens when the button is double clicked.
The value is incremented by 1
The incremented value is used to update the variable x.
The server detects change in x
The server updates the textOutput.
library(shiny)
ui = bootstrapPage(
tags$button(id = 'mybutton', 'button', class='btn btn-primary', value = 0),
textOutput('x'),
# when button is double clicked increase the value by one
# and update the input variable x
tags$script("
$('#mybutton').on('dblclick', function(){
var val = +this.value
this.value = val + 1
Shiny.onInputChange('x', this.value)
console.log(this.value)
})
")
)
server = function(input, output, session){
output$x <- renderText({
input$x
})
}
runApp(list(ui = ui, server = server))

I've updated my answer based on the comment below. Here I used a threshold of time difference of 0.2 seconds to differentiate between a double clock and a regular click. I used slightly different approach in My App. I simply check how many times the button has been pressed by checking if its divisible by 2 or not.
library(shiny)
t1 <<- Sys.time()
ui =fluidPage(
actionButton("my_button", "Dont Touch it!"),
mainPanel(textOutput("x"))
)
server = function(input, output, session){
my_data <- reactive({
if(input$my_button == 0)
{
return()
}
if(input$my_button%%2!=0)
{
t1 <<- Sys.time()
}
if(input$my_button%%2==0 & (Sys.time() - t1 <= 0.2))
{
"You pushed the button twice!"
}
})
output$x <- renderText({my_data()})
}
runApp(list(ui = ui, server = server))

Related

Solving a memory leak - Shiny R

I have a memory leak with my shiny program, and I'm struggling to figure it out. The leak I have is very small with the code I'll show, but for my actual code it is magnitudes larger in loss, accumulating gigabytes in days. I've been working on simplifying this, but still showing the issue, and this is the best I could come up with. I use three packages, shiny, shinyjs to reset the page, and pryr to show memory loss.
Essentially, just input numbers, and click the submit button to reset/print out memory. If the average of the first two numbers is above 5, it creates a second box. If the average is below 5 on either box, but not 0, then you can submit and reset.
#Library Load##########################################################################################
lapply(c("shiny","shinyjs","pryr"),require,character.only = T)
#ui, shiny body#########################################################################################
ui<-fluidPage(
useShinyjs(),
#Div to reset the whole page upon submission
div(id = paste0("BOX_"),
h3("Add random numbers. If average is above 5, an additional box will be added. If below 5, click reset to reset the page and update memory"),
#lapply - Add 2 boxes with double numeric inputs and average
column(width = 5, align = "center",
lapply(seq(1,3,2),function(y){
div(id = paste0("Box_ID_","_",y),
numericInput(paste0("Number_",y), label = paste0("Number - ",y), value = 0, min = 0, max = 60, step = .1),
numericInput(paste0("Number_",y+1), label = paste0("Number - ",y+1), value = 0, min = 0, max = 60, step = .1),
h3(textOutput(paste0("Avg_",y))))
})),
column(width = 1),
#Submit and memory used#########
actionButton(paste0("Complete_"),"Reset"),
br(),
h4("Memory output - Updates on submit"),
textOutput(paste0("Memory"))
))
#######Server################
server <- function(input, output, session) {
#Reactive Average#########
Avg<-reactive({
lapply(seq(1,3,2),function(y){
req(input[[paste0("Number_",y)]],input[[paste0("Number_",y+1)]])
if(input[[paste0("Number_",y)]] == 0 | input[[paste0("Number_",y+1)]] == 0) {0} else {
(input[[paste0("Number_",y)]]+input[[paste0("Number_",y+1)]])/2}
})
})
#Average Output##########
lapply(seq(1,3,2),function(y){
output[[paste0('Avg_',y)]] <- renderText({
req(input[[paste0("Number_",y)]],input[[paste0("Number_",y+1)]])
if(input[[paste0("Number_",y)]] == 0 | input[[paste0("Number_",y+1)]] == 0) {
"Enter both numbers"} else{
paste0("Average = ",round(Avg()[[(y/2)+.5]],1))}
})
})
# Enable/Disable Submit button if average is not 0, and below 5
observe({
lapply(seq(1,3,2),function(y){
req(input[[paste0("Number_",y)]], input[[paste0("Number_",y+1)]])
if(Avg()[[1]] > 0 & Avg()[[1]] <= 5 | Avg()[[2]] > 0 & Avg()[[2]] <= 5 ) {
shinyjs::enable(paste0("Complete_"))} else{shinyjs::disable(paste0("Complete_"))}
})
})
#Show next average box if average is not below 5
observe({
lapply(seq(1,3,2),function(y){
req(input[[paste0("Number_",y)]],input[[paste0("Number_",y+1)]])
if(y == 1 & Avg()[[(y/2)+.5]] <= 5) {
shinyjs::show(paste0("Box_ID_","_",1))
shinyjs::hide(paste0("Box_ID_","_",3))
} else if(y == 1 & Avg()[[(y/2)+.5]] > 5) {
shinyjs::show(paste0("Box_ID_","_",1))
shinyjs::show(paste0("Box_ID_","_",3))
} else if(Avg()[[(y/2)+.5]] > 5) {
shinyjs::show(paste0("Box_ID_","_",y+2))
} else {shinyjs::hide(paste0("Box_ID_","_",y+2))}
})
})
#Submit Button - Reset boxes, print memory######
observeEvent(input[[paste0("Complete_")]],{
#Reset the page
reset(paste0("BOX_"))
#Garabage collect
})
#Memory used############
observeEvent(input[[paste0("Complete_")]],{
output[[paste0("Memory")]]<-renderText({
paste0(round(mem_used()/1000000,3)," mb")
})
})
}
# Run App
shinyApp(ui, server)
My best guess is the leak is from the observe/observe events.I have tried the reactlog described here: https://github.com/rstudio/shiny/issues/1591 But I'm not exactly figuring that what the issue is there. I also looked into this, but I'm not using any outputs in observe: https://github.com/rstudio/shiny/issues/1551 I had written earlier asking for ideas on how to find memory leaks: R Shiny Memory Leak - Suggestions on how to find? From that I'm still looking into modules a bit to see if that will help.
Thank you for any help.

Does anyone know how to change the color of error messages for only one output?

On my app, I want to change only the error message color for one part of my output. My error messages are currently coming up in blue because that is the way the regular output prints.
Here is the current code for the font color, (it does not work anymore since my error messages are made with "if" statements now rather than "validate"):
tags$head(
tags$style(".shiny-output-error{
color: black; font-style: italic;}"))
)
),
here are the error messages:
if(input$N_1 == "") {error_statement = 'Error. Fill in Sample Size for Group 1.'}
if(input$N_2 == "") {error_statement = 'Error. Fill in Sample Size for Group 2.'}
if(input$sigma_1 <= 0) {error_statement = 'Error. Standard devation 1 must be positive.'}
if(input$sigma_2 <= 0) {error_statement = 'Error. Standard deviation 2 must be positive.'}
if(input$N_1%%1 != 0) {error_statement = 'Error. Sample size 1 must be an integer.'}
if(input$N_2%%1 != 0) {error_statement = 'Error. Sample size 2 must be an integer.'}
if(input$N_1 <= 1) {error_statement = 'Error. Sample size 1 must be 1 or greater.'}
if(input$N_2 <= 1) {error_statemement = 'Error. Sample size 2 must be 1 or greater.'}
This is the part of the output that I want to change:
if(error == 1){
output$Power = renderText({error_statement})
}
I want the part that is "error statement" to be in black and be italicized.
This is how the output looks when an error happens
It is this color because when no error comes up, this is the color that the output should be. However, as previously mentioned, I want it to be black and italicized only when an error is made.
Does anyone know how to fix this?
Thanks in advance!
You need to refer to 'Power'. Inspired by this answer you can do the following:
library(shiny)
ui = bootstrapPage(
numericInput('n', 'Number of obs', 100),
textOutput('Power'),
tags$head(tags$style("#Power{color: black; font-style: italic;}"
)
)
)
server = function(input, output) {
output$Power <- renderText({
if (input$n<100){
paste("hello input is",input$n)
}
})
}
# Run the application
shinyApp(ui = ui, server = server)
You can also use HTML:
renderText({
if (input$n<100){
paste("<font color=\"#FF0000\">hello input is",input$n,"</font>") })
}
})

Save output from Shiny to file

I am creating function that launches shiny app.
This will allow user to make multiple selections.
From what I understand, shiny doesn't return data to the calling program (please clarify this)
Hence, I am saving to a text file, which will eventually be read by the program, then delete the text file.
Problem started when I added file.append(colorfile,output$col) within shiny
When I launch shiny app, I get error, (end of question is the code, and here is the entire R script)
> CherryPickPalette("BiryaniRice","Kulfi","Haveli2")
Listening on http://127.0.0.1:7208
Warning: Error in $.shinyoutput: Reading objects from shinyoutput object not allowed.
54: stop
53: $.shinyoutput
50: server [c:\RanglaPunjab/R/RanglaPunjab.R#230]
Error in `$.shinyoutput`(output, col) :
Reading objects from shinyoutput object not allowed.
Function CherryPicker Palette
CherryPickPalette <- function (name, name2=NULL, name3=NULL){
if ((nargs() < 2) || (nargs() > 3)){
stop("Enter 2 or 3 valid palettes. Run ListPalette() for list of palettes.")
}
if (nargs() == 2){
new_pal <- MergePalette(name,name2)
}
else if (nargs() == 3){
new_pal <- MergePalette(name,name2,name3)
}
if (interactive()){
colorfile <- paste(getwd(),"colorfile.txt",sep="/")
if (!file.exists(colorfile)){
file.create(colorfile)
}
shinyApp(
ui = fluidPage(
titlePanel("Cherry Pick Your Own Palette!"),
sidebarPanel (hr(),
selectInput('col', 'Options', new_pal, multiple=TRUE, selectize=FALSE, size = 15)
),
mainPanel(
h5('Your custom colors',style = "font-weight: bold;"),
fluidRow(column(12,verbatimTextOutput("col"))))
),
server = function(input,output,session){
output$col <- renderPrint(input$col)
file.append(colorfile,output$col)
}
)
}
}
The file.append function will append one file to the other. (not add text to a file), take a look at cat or sink functions
The following seems to work for me
server = function(input,output,session){
outuputdata<- reactive({
input$col
})
output$col <- {
renderPrint(outuputdata())
}
observe({
message <- paste(outuputdata(),"\n")
cat(message,file=colorfile, append=TRUE)
})
}

Save output to file after R shiny terminates

I have function that launches R shiny app, allowing users to select various colors.
But what if user changes their mind and deselects a color.
Hence I wish to save user output to file after R shiny terminates.
However, each time shiny is launched, the file resets so it can take in new information.
Tried session$onSessionEnded, but it gives error upon execution
Listening on http://127.0.0.1:7431
Warning: Error in .getReactiveEnvironment()$currentContext: Operation not allowed without an active reactive context. (You tried to do something that can only be done from inside a reactive expression or observer.)
42: stop
41: .getReactiveEnvironment()$currentContext
40: .dependents$register
39: outuputdata
37: callback [c:\RanglaPunjab/R/RanglaPunjab.R#237]
Below is code and sample input. This is entire R script
CherryPickPalette <- function (name, name2=NULL, name3=NULL){
if ((nargs() < 2) || (nargs() > 3)){
stop("Enter 2 or 3 valid palettes. Run ListPalette() for list of palettes.")
}
if (nargs() == 2){
new_pal <- MergePalette(name,name2)
}
else if (nargs() == 3){
new_pal <- MergePalette(name,name2,name3)
}
if (interactive()){
colorfile <- paste(getwd(),"colorfile.txt",sep="/")
if (!file.exists(colorfile)){
file.create(colorfile)
}
shinyApp(
ui = fluidPage(
titlePanel("Cherry Pick Your Own Palette!"),
sidebarPanel (hr(),
selectInput('col', 'Options', new_pal, multiple=TRUE, selectize=FALSE, size = 15)
),
mainPanel(
h5('Your custom colors',style = "font-weight: bold;"),
fluidRow(column(12,verbatimTextOutput("col"))))
),
server = function(input,output,session){
outuputdata<- reactive({
input$col
})
output$col <- {
renderPrint(outuputdata())
}
session$onSessionEnded(function(){
message <- paste(outuputdata(),"\n")
cat(message,file=colorfile, append=TRUE)
})
}
)
}
}
CherryPickPalette("BiryaniRice","Kulfi","Haveli2")
You have to use isolate to access reactive values outside of a reactive context.
The following worked for me
session$onSessionEnded(function(){
message <- paste(isolate(outuputdata()),"\n")
cat(message,file=colorfile, append=TRUE)
})

Using the inputs of a dynamic select box in R Shiny

I want to capture key-value pairs via Shiny (R) where a few widgets (keys) are selected by the user via the UI from a known but large list of possible optionss.
Corresponding to each Widget he selects a numeric input box is shown where he can then enter a value (quantity).
I posted a demo here:
https://statspot.shinyapps.io/app_upload_test/
For further processing it would be nice to have a data-frame with those key value pairs that were selected / entered by the user. That's the red table below. i.e. A dataframe with widgets selected & their corresponding quantities entered.
My problem is I haven't figured out how to get the values entered by the user dynamically in there (I've put in 999 as a static filler dummy value for now). The keys I could manage.
i.e. In the case of the input select above I'd want the following output
data.frame(widgets=c("Widget B","Widget A"),quantities=c(600,400))
Any ideas or pointers?
My code is here:
library(shiny)
widget_list<-c("WidgetA","WidgetB","WidgetC","WidgetD","WidgetE")
ui <- fluidPage(title = "Test Case for Dynamic Inputs",
headerPanel(h3("Test Case for Dynamic Inputs")),
sidebarPanel(width = 3,
selectInput("widgets","Select Widgets",choices=widget_list,multiple = TRUE)
),
sidebarPanel(title="Scoring Outputs",width = 3,
h3(textOutput("title"))
),
sidebarPanel(title="Dynamic UI",width=3,
uiOutput("widget_quantities"),
h4(tableOutput("output_table"),style="color: red")
)
)
server <- function(input, output) {
output$title<-renderText("Test dynamic inputs")
fn_run<-reactive({
count_widgets(input$widgets)
})
len_widgets<-reactive({
length(input$widgets)
})
output$output_table<-renderTable(data.frame(widgets=input$widgets,quantities=rep(999,len_widgets())))
output$widget_quantities <- renderUI({
code<-list()
for( item in input$widgets)
{
inp_name<-paste("inp",item,sep = "_")
inp_display_name<-paste("Quantity of",item,sep = " ")
code<-list(code,numericInput(inp_name, inp_display_name,value=300))
}
return(code)
})
}
count_widgets<-function(inp=c())
{
return(length(inp))
}
shinyApp(ui = ui, server = server)
Probably you want this:
You could make it cleaner not hardcoding all the widgets, but i think you can adapt it from here
also the quantities will reset when you update your widgets, but my Lunchbreak is over :D Let me know if you can solve that, the basic question should be answered.
If you need any docu let me know, I can add it later.
library(shiny)
x <- data.frame()
widget_list = c("Widget_A","Widget_B","Widget_C","Widget_D","Widget_E")
ui <- fluidPage(title = "Test Case for Dynamic Inputs",
headerPanel(h3("Test Case for Dynamic Inputs")),
sidebarPanel(width = 3,
selectInput("widgets","Select Widgets",choices=widget_list,multiple = TRUE)
),
sidebarPanel(title="Scoring Outputs",width = 3,
h3(textOutput("title"))
),
sidebarPanel(title="Dynamic UI",width=3,
uiOutput("widget_quantities"),
h4(tableOutput("output_table"),style="color: red")
)
)
server <- function(input, output) {
global <- reactiveValues(Widget_A = 300, Widget_B = 300, Widget_C = 300, Widget_D = 300, Widget_E = 300)
output$title<-renderText("Test dynamic inputs")
fn_run<-reactive({
count_widgets(input$widgets)
})
observe({
for(item in input$widgets){
global[[item]] <- input[[paste("inp",item,sep = "_")]]
}
})
output$output_table<-renderTable({
data.frame(global$Widget_A, global$Widget_B, global$Widget_C, global$Widget_D, global$Widget_E)
})
output$widget_quantities <- renderUI({
code<-list()
for( item in input$widgets)
{
inp_name<-paste("inp",item,sep = "_")
inp_display_name<-paste("Quantity of",item,sep = " ")
code<-list(code,numericInput(inp_name, inp_display_name,value=300))
}
return(code)
})
}
count_widgets<-function(inp=c())
{
return(length(inp))
}
shinyApp(ui = ui, server = server)
So I haven't gotten the final solution yet but thought I'd post some progress I made so far as a partial answer in case it clarifies what I'm trying to do.
https://statspot.shinyapps.io/app_upload_test_v2/
This new version now sets the right data frame (and hence prints the right table) which takes the values (quantities) from the input dynamically instead of static 999 as before).
output$output_table<-renderTable(data.frame(widgets=input$widgets,quantities=rep(input[["inp_WidgetA"]],len_widgets())))
Only flaw is that it is hardcoded to regurgitate whatever is entered as the quantity for Widget A.
What I'd like is to programatically have it loop and do this for whatever widgets are entered by the user.
Ideas?

Resources