Using the inputs of a dynamic select box in R Shiny - r

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?

Related

R Shiny - Operation not allowed without an active reactive context

This is my first time creating a shiny application, and I am getting this error message:
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.)
I suspect it has something to do with using the slider's value to do my calculation. Please assist, and thanks in advance!
UI Start
header = dashboardHeader(title = "Fifa player valuation")
sidebar = dashboardSidebar(
sidebarMenu(
menuSubItem("Player Valuation - Striker", tabName = "StrikerTab"),
menuSubItem("Player Valuation - Midfielder", tabName = "MidfielderTab"),
menuSubItem("Player valuation - Goalkeeper", tabName = "GkTab")
)
)
ageSlider = sliderInput('age', 'Enter your age in years', min = 0, max = 150, value = 25)
dribblingSlider = sliderInput('dribbling_skills', 'Enter your dribbling skills', min = 0, max = 100, value = 70)
tacklingSlider = sliderInput('tackling_skills', 'Enter your tackling skills', min = 0, max = 100, value = 70)
shootingSlider= sliderInput("shooting_skills", "Enter your shooting skills", min = 0, max = 100, value = 70)
body = dashboardBody(
tabItems(
tabItem(tabName = "StrikerTab",ageSlider,dribblingSlider, tacklingSlider, shootingSlider,verbatimTextOutput("strikerValue")),
tabItem(tabName = "MidfielderTab",ageSlider,dribblingSlider, tacklingSlider),
tabItem(tabName = "GkTab", ageSlider, gkSlider)
),
verbatimTextOutput("playerValueTxt")
)
ui = dashboardPage(header, sidebar, body, skin = "green")
UI end
Server Start
strikerProjectedValue = function(age, dribbling, tackling = 0, shooting = 0){
return (-250.19*age) + (1987.33*dribbling) + (4439.32*tackling) + (3232.44*shooting)
}
server = function(input, output) {
predictedStrikerValue = strikerProjectedValue(input$age, 150)
output$strikerValue = renderPrint(predictedStrikerValue)
}
Probably someone with more programming, and especially shiny programming, can give you a better answer. Your question can use quite some clarification in my opinion, it is a bit unclear to me what the exact results is that you want / what your rational is behind this code. Despite that I will try to give some answer. Maybe some of the things I mention are 'personal' as I would not program a shiny like this.
Personally, I would not use a function in Shiny, rather use the reactive({}) statement. I do not know why you would prefer the function over reactive, especially as you have a lot of sliders that you do not use anywhere. So what is the point of having all these expressions in your function?
In addition I do not really understand why you want every step to be written into a separate vector. Specifically, I mean the part of
predictedStrikerValue = strikerProjectedValue(input$age, 150)
output$strikerValue = renderPrint(predictedStrikerValue)
Maybe you have some plans to use them later but again that is not clear from your description. Why not putting renderPrint(strikerProjectedValue(input$age, 150))? (this is why I stated in the beginning your question might need some extra explanation ;), because there could be a good rational to do this).
In order to get your code working I replaced everything in your code of server with
output$strikerValue = renderText((-250.19*input$age) +
(1987.33*input$dribbling_skills) +
(4439.32*input$tackling_skills) +
(3232.44*input$shooting_skills))
In order to get exactly the same as in your function you will have to put the sliders initially on 0.
Another way to do it, which is more like your initial function:
predictedStrikerValue<- reactive({(-250.19*input$age) + (1987.33*input$dribbling_skills)
})
output$strikerValue = renderText(predictedStrikerValue())
Similar to the code above you can add all the other parts of the function to get it completely reactive.

Shiny observeEvent on different actions

I would like to do something as: there are actionLink a and actionLink b. And they can trigger the UpdateNumericInput() which assigns some weights. I can also manually change the weights on the numericInput() in UI. What I want to realize is when clicking on the actionLink a, the textoutput would be "click on a", and same thing happened with actionLink b as "click on b". I also want want the textoutput to show up as "manually changed the weights" when I actually edit the weights on UI. Is there any way to realize this?
#triggered by actionLink a
apply_a_weights = observeEvent(input$a_weight_link, {
v_a = get_a_weights()
v_a = setNames(as.double(unname(v_a)), names(v_a))
for (nm in names(v_a)) {
updateNumericInput(session, nm, value = v_a[[nm]])
}
output$selected_weight <- renderUI({HTML("You have changed to <B>a weight</B>")}) }, priority = 1)
# triggered by actionLink b
apply_b_weights = observeEvent(input$b_weight_link, {
v_b = df_dmd$b_weights
names(v_b) = df_dmd$input_id
for (nm in names(v_b)) {
updateNumericInput(session, nm, value = v_b[[nm]])
}
output$selected_weight <- renderUI({HTML("You have changed to <B>b weight</B>")})}, priority = 1)
I also tried to put this part in the server.R as the default textoutput:
output$selected_weight <- renderUI({HTML("<B>manually</B> changed the weights")})
But those codes doesn't work. When I change the weights on my own, the "manually changed the weights" doesn't show up.
Many Thanks
You don't provide a reproducible code so it's hard to guess. Possibly, the problem is the duplicated output$selected_weight.
Define a reactiveVal to store the text do be displayed, for example at the beginning of server:
Text <- reactiveVal()
Then in your two observeEvent, remove output$selected_weight, and do:
#triggered by actionLink a
apply_a_weights = observeEvent(input$a_weight_link, {
v_a = get_a_weights()
v_a = setNames(as.double(unname(v_a)), names(v_a))
for (nm in names(v_a)) {
updateNumericInput(session, nm, value = v_a[[nm]])
}
Text("You have changed to <B>a weight</B>")
}, priority = 1)
# triggered by actionLink b
apply_b_weights = observeEvent(input$b_weight_link, {
v_b = df_dmd$b_weights
names(v_b) = df_dmd$input_id
for (nm in names(v_b)) {
updateNumericInput(session, nm, value = v_b[[nm]])
}
Text("You have changed to <B>b weight</B>")
}, priority = 1)
Finally, outside the observeEvents, do
output$selected_weight <- renderUI({HTML(Text()})
Again, your don't provide a minimal reproducible code, so I'm not sure my answer provides what you want.

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.

Double Click in R-shiny

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))

sliderInput for date

I am making animation using animationOptions in sliderInput(). I want to use date/daterange in a slider, but sliderInput() does not accept date. There was a post in the shiny group. As of March, 2013, there was no solution yet. So I searched around and learned that one can achieve this using JavaScript. Here is the post. Unfortunately, I cannot write in JS. So, I searched around more and came up with this link and wrote the following codes. This works, but the numbers on the slider are confusing. Is this the only way one can move around and use date in sliderInput()? Thank you very much for taking your time.
server.R
library(shiny)
shinyServer(function(input, output, session) {
observe({
updateDateInput(session, "ana", value = as.Date("2014-07-01") + input$foo)
})
output$preImage <- renderImage({
filename <- normalizePath(file.path('./www',
paste(input$ana, '.png', sep='')))
list(src = filename,
alt = paste("There is no image for ", input$ana, ".", sep = ""))
}, deleteFile = FALSE)
})
ui.R
shinyUI(pageWithSidebar(
headerPanel("renderImage example"),
sidebarPanel(
sliderInput("foo", "Animation duration", min = -30,
max = 30, value = 0, step = 1,
animate = animationOptions(loop = TRUE, interval = 1000)),
dateInput("ana", "Choose a date:", value = as.Date("2014-07-01"))
),
mainPanel(
# Use imageOutput to place the image on the page
imageOutput("preImage")
)
))
I don't know when this feature was added, but now date values are automatically recognized in sliderInput(). And some related parameters are timeFormat and step (1-day by default)
sliderInput("date_range",
"Choose Date Range:",
min = as.Date("2016-02-01"), max = Sys.Date(),
value = c(as.Date("2016-02-25"), Sys.Date())
)
Reference: http://shiny.rstudio.com/reference/shiny/latest/sliderInput.html
The sliderInput control offers some limited formatting options. You can add a format parameter to your sliderInput to change the displayed text for the slider.
Ideally, you would want the sliderInput to offer a custom mapping function that maps the current value to an exact date. But since that is not the option, the only wiggle room for improvement is to slightly change the text a little bit with the format parameter.
Accepted format can be found in this document.
Based on the above document, probably you can change your sliderInput into:
sliderInput("foo", "Animation duration", min = -30,
max = 30, value = 0, step = 1,
format="## Days",
animate = animationOptions(loop = TRUE, interval = 1000)),
This will display as +10 Days, when originally it was "+10".
It may not be what you want exactly, but this is what you can do without writing Javascript.
EDIT: show customized slider value using Javascript
Say if you really want to change the current value label for the slider to indicate a somewhat sophisticated value (date, transformed values etc.), you can write some small Javascript snippet to do that.
One example provided by the jslider control (which is what Shiny uses for your sliderInput) indicates that by calling the constructor of a slider with a calculate function, you can manually change the mapping from the current value (numeric) to a custom string (in this case, a date).
Without being too verbose, let's just say that the slider's Javascript object is called slider. Which you can always get by calling:
$(select).slider()
where select is a jQuery selector. Again, in this case it is #foo because the slider has an id foo set in ui.R.
When initiated, the slider.settings.calculate function appeared in the example will be bound to be the slider.nice function. So, we can simply override the nice function to achieve our goal.
Below is a modified ui.R with a piece of Javascript to do exactly the nice function overriding.
ui.R
shinyUI(pageWithSidebar(
headerPanel("renderImage example"),
sidebarPanel(
sliderInput("foo", "Animation duration", min = -30,
max = 30, value = 0, step = 1,
animate = animationOptions(loop = TRUE, interval = 1000)),
dateInput("ana", "Choose a date:", value = as.Date("2014-07-01"))
),
mainPanel(
singleton(tags$head(HTML(
'
<script type="text/javascript">
$(document).ready(function() {
var slider = $("#foo").slider();
// override the default "nice" function.
slider.nice = function(value) {
var ref_date = new Date("2014-07-01");
// each slider step is 1 day, translating to 24 * 3600 * 1000 milliseconds
var slider_date = new Date(ref_date.getTime() + value * 24 * 3600 * 1000);
return [slider_date.getUTCFullYear(),
slider_date.getUTCMonth() + 1,
slider_date.getUTCDate()].join("-");
}
})
</script>
'))),
# Use imageOutput to place the image on the page
imageOutput("preImage")
)
))
Another detail we might want to tweak is the label on both ends of the slider. To achieve this we could:
replace the entire slider.domNode by calling slider.generateScales();
directly modify the two <span>'s with class jslider-label.
For example if we take approach 2, we can modify the HTML() part of ui.R as:
singleton(tags$head(HTML(
'
<script type="text/javascript">
$(document).ready(function() {
var slider = $("#foo").slider();
// override the default "nice" function.
var labels = slider.domNode.find(".jslider-label span");
labels.eq(0).text("2014-06-01");
labels.eq(1).text("2014-07-31");
slider.nice = function(value) {
var ref_date = new Date("2014-07-01");
// each slider step is 1 day, translating to 24 * 3600 * 1000 milliseconds
var slider_date = new Date(ref_date.getTime() + value * 24 * 3600 * 1000);
return [slider_date.getUTCFullYear(),
slider_date.getUTCMonth() + 1,
slider_date.getUTCDate()].join("-");
}
})
</script>
'))),
And the labels will display the dates as expected.
This is of course some quick hacking and may not work if some other customization is made to the slider.
I think somehow the Shiny team should consider adding a calculate option in sliderInput which directly maps to slider.settings.calculate, just to make things like this easier.

Resources