How do I dynamically change label text color of R Shiny radioButtons widget when users select an option? - dynamic

I am building a Shiny App where users have to complete several mandatory questions in the form of radioButtons, numericInputs, and textInputs in order to generate an output. To highlight which questions still need to be completed, I would like the label text to initially be rendered as "red", but then switch to "black" once a value has been selected and/or inputted into the widgets.
library(shiny)
ui <- fluidPage(
sidebarPanel(
radioButtons("my_radio_button", tags$p("Choose an Option", style = "color:red;"), choices = c("Option 1", "Option 2"), selected = character(0)),
)
)
server <- function(input, output, session) {
observeEvent(input$val, {
x <- input$my_radio_button
if (x == "Option 1" | x == "Option 2") {
## MAKE "Choose an Option" LABEL TURN BLACK
}
})
}
shinyApp(ui, server)
I found this example on stack exchange (R shiny conditionally change numericInput background colour) where they conditionally changed the background colour of the widget, but I don't know enough about programming to modify it to change the label text instead.
Any help would be greatly appreciated. Thanks!

You can use shinyjs
add shinyjs::useShinyjs() to the beginning of ui
add an id to the label param of the radioButtons ui element. I've used r_label in the example below
Observe for changes to input$my_radio_button, which trigger calls to shinyjs::html()
Full code below:
library(shiny)
library(shinyjs)
ui <- fluidPage(
shinyjs::useShinyjs(),
sidebarPanel(
radioButtons("my_radio_button",
label=tags$p("Choose an Option", style = "color:red;", id="r_label"),
choices = c("Option 1", "Option 2"), selected = character(0)),
)
)
server <- function(input, output, session) {
observeEvent(input$my_radio_button, {
shinyjs::html("r_label", "<p style='color:black'>Choose an Option</p>")
})
}
shinyApp(ui, server)

Related

Drop-down menu in pine script to choose differents fills background

I'm trying to do a simple thing in my mind, but really I don't know the correct syntax or if it's possible with pine script.
I created the following drop-down menu with 4 options using input.string:
choose_bg= input.string(title = "Choose background", options = ["RVGI", "MACD", "STOCH", "COLOR"], defval="RVGI")
For every option I want to choose a different kind of background fill between two plots, defined as plots, with the conditions I declared. I'll like e.g. if I choose the first option, the background will fill between two plots, as follow:
colors_rvgi= rvgi_value>rvgi_signal ? color.rgb(55, 255, 72, 90) : rvgi_value<rvgi_signal ? color.rgb(255, 0, 0, 90) : na
fill( OBline, OSline , color=colors_rvgi , title="RVGI Background" )
Usually I saw that in pine scrip is possible to do the opposite: when the condition is true, then the program apply the option choosen before by the dip-down menu. I want to do the opposite, that it's simple in a boolean input between two condition (false and true).So how can I specify to pine script the rule "if choose_bg=="RVGI" then fill(as I want)?
thank you in advance
You can test for choose_bg == "RVGI" for the first field in fill() and return na if false :
fill( hline1 = choose_bg == "RVGI" ? OBline : na, hline2 = OSline , color = colors_rvgi , title = "RVGI Background" )

RShiny Limit for Dropdown [duplicate]

I have written a simple example of what I am doing. I have 3000 numbers that I want to show in a selectInput. The numbers have to be in a reactive function, since in my original work, the data is from a file.
My problem is that when I run the app it only appears 1000 numbers, not the entire data (3000 numbers).
I have seen this post Updating selection of server-side selectize input with >1000 choices fails but I don't know how can I do it using uiOutput and renderUI.
Can anyone help me?
Thanks very much in advance
The code:
library(shiny)
ui <- fluidPage(
titlePanel("Numbers"),
sidebarLayout(
sidebarPanel(
uiOutput('selectUI')
),
mainPanel(
)
)
)
server <- function(input, output) {
num <- reactive({
data = c(1:3000)
return(data)
})
output$selectUI <- renderUI({
selectInput(inputId = 'options', "Select one", choices = num())
})
}
# Run the application
shinyApp(ui = ui, server = server)
Use selectizeInput instead of selectInput with the argument options = list(maxOptions = 3000).
Thanks to Stéphane Laurent's answer, the example will be solved like this:
library(shiny)
ui <- fluidPage(
titlePanel("Numbers"),
sidebarLayout(
sidebarPanel(
selectizeInput(inputId = "options", label = "Select one", choices=character(0)),
),
mainPanel(
)
)
)
server <- function(input, output, session) {
num <- reactive({
data = c(1:3000)
return(data)
})
observe({
updateSelectizeInput(
session = session,
inputId = "options",
label = "Select one",
choices= num(), options=list(maxOptions = length(num())),
server = TRUE)
})
}
# Run the application
shinyApp(ui = ui, server = server)
This code will work if you have more than 3000 entries. It will show you ALL the choices that you have. However, if you have a long list of choices (e.g. 60000) it will decrease the speed of your app.

How can one dynamically update a progress indicator while a calculation started by changing an InputField value is running?

I have a Mathematica notebook that employs a fairly complicated user interface for controlling a long-running calculation. Among other things, the interface takes liberal advantage of Button, RadioButtonBar, Checkbox, and InputField.
When the effect of clicking a Button is an intermediate calculation that may take more than a couple seconds to complete, I like to provide a visual indication that the code hasn't crashed and is, in fact, doing something useful. A good way to do this is to start up a ProgressIndicator just before the intermediate calculation starts and then turn it off once the calculation is done. I have found this to be straightforward for calculations started by a Button click.
The same method does not work, however, for calculations that are initiated by changes to an InputField value. The simplified code below was written to do this but fails. The last two rows of the Grid are supposed to change automatically when updatingQ changes to True in the inner Dynamic command and then change back when updatingQ reverts to True, but it never happens. It appears that the outer Dynamic code is being blocked while the inner Dynamic code runs so it never even notices the changes to updatingQ.
On the other hand, the last two lines of the Grid respond as expected if one manually sets updatingQ=True on a separate input line.
(BTW, i) Pause[2] is just a stand-in for the intermediate calculation and ii) I multiply the input value by Pi is just to make it more obvious when the stand-in calculation is done.)
Apparently, the action portion of a Button behaves differently. Other pieces of code within the same Dynamic block can see and quickly respond when flags are changed there. It may be notable that I use Method->"Queued" in such cases. I tried the same with InputField (for which it is not a documented option) but to no effect.
I've tried various other things not shown here also without success.
A way to make this work would be much appreciated.
Clear[ProgressIndicatorTest]
updatingQ = False;
ProgressIndicatorTest = {
TextCell["ProgressIndicatorTest", "Subsubsection", Background -> LightBlue],
DynamicModule[
{filterTypes = {"Max energy", "Max length"}, filterValue, workingOn = "", iter = 0},
Scan[(filterValue[#[[1]]] = #[[2]]) &, Transpose#{filterTypes, {0.1, 100.}}];
Dynamic[
Grid[
Join[
Map[
Function[
filterType,
{filterType,
Dynamic#
InputField[
Dynamic[
filterValue[filterType],
Function[
value,
If[value > 0,
updatingQ = True;
Pause[2];
filterValue[filterType] = \[Pi] value;
updatingQ = False
]
]
], FieldSize -> 5, Alignment -> Right
]
}
], filterTypes
],
{{updatingQ, "-------"}},
{If[updatingQ,
{"Updating ... ",
ProgressIndicator[Appearance -> "Indeterminate"]},
Nothing
]}
], Alignment -> Left,
Background -> {None, {LightGreen, LightGreen, LightYellow, LightYellow}}
]
]
]
};
CellGroup[ProgressIndicatorTest]
As Forrest Gump never said, "Stackoverflow/Stackexchange is like a box of chocolates ... you never know what you'll get". And so today I found this answer which solves my problem.
Adapted to my particular case, the resulting code is as follows:
Clear[ProgressIndicatorTest]
calculation[n_] := Module[{a = .3}, Do[a = a (1 - a), {i, n 10^6}]]
updatingQ = False;
ProgressIndicatorTest = {
TextCell["ProgressIndicatorTest", "Subsubsection", Background -> LightBlue],
DynamicModule[{filterTypes = {"Max energy", "Max length"}, filterValue, upToDateQ = True},
Scan[(filterValue[#[[1]]] = #[[2]]) &, Transpose#{filterTypes, {0.1, 100.}}];
Dynamic[
Grid[
Join[
Map[
Function[
filterType,
{filterType,
DynamicWrapper[
InputField[
Dynamic[
filterValue[filterType],
Function[
value,
If[value > 0,
upToDateQ = False;
filterValue[filterType] = value
]
]
], FieldSize -> 5, Alignment -> Right
],
If[! upToDateQ,
Refresh[
updatingQ = True; calculation[2]; updatingQ = False;
upToDateQ = True,
None
]
],
SynchronousUpdating -> False
]
}
], filterTypes
],
{
If[updatingQ,
{"Updating ... ",
ProgressIndicator[Appearance -> "Indeterminate", ImageSize -> 80]},
Nothing
]
}
], Alignment -> Left,
Background -> {None, {LightGreen, LightGreen, LightYellow,}}]
]]
};
CellGroup[ProgressIndicatorTest]
This code does exactly what I want.
The key to success is wrapping DynamicWrapper around InputField and inserting a cleverly constructed second argument that performs the flag reset (upToDate=False in my case) that triggers the ProgressIndicator located elsewhere.
A couple more points.
Pause turns out not to be a good stand-in for a calculation. You may observe that the code behaves differently with a real function such as calculation.
It is interesting to note that upToDateQ can be a local variable whereas updatingQ cannot.
Kudos to Albert Retey for providing the code back in 2013.
The documentation for InputField says
"An InputField of type Expression [the default] replaces its
contents with the fully evaluated form every time the contents are
updated".
This seems to mean that InputField privately evaluates its content and all connected dynamics before releasing value changes, probably to prevent circular evaluations.
The following example condenses the problem. The first part works ok ...
changed = processing = False;
Column[{InputField[Dynamic[x, (changed = True; x = 2 #) &], FieldSize -> 5],
Dynamic[changed],
Dynamic[processing]}]
... until the dynamic below is also evaluated. Then changed never shows True because it is changed back to False before the update concludes.
Dynamic[If[changed,
processing = True;
Pause[2];
changed = processing = False]]
A alternative strategy would be to use a Button, e.g.
changed = False;
processing = Spacer[0];
Column[{InputField[Dynamic[y, (changed = True; y = #) &], FieldSize -> 5],
Button["Enter",
If[changed,
processing = ProgressIndicator[Appearance -> "Indeterminate", ImageSize -> 120];
Pause[2];
y = 2 y;
changed = False;
processing = Spacer[0]], Method -> "Queued", Enabled -> Dynamic[changed]],
Dynamic[changed],
Dynamic[processing]}]
This shorter version avoids the need to tab out of the input field.
changed = False;
processing = Spacer[0];
Column[{InputField[Dynamic[y], FieldSize -> 5],
Button["Enter",
processing = ProgressIndicator[Appearance -> "Indeterminate", ImageSize -> 120];
Pause[2];
y = 2 y;
processing = Spacer[0], Method -> "Queued"], Dynamic[processing]}]
Note the use of Method -> "Queued" gives Button the advantage over InputField. Without it Button appears to have the same problem.

How to make a table of icons and text in Rmarkdown

In several web pages for courses I have a Resources page that lists some recommended
books, using icons of the cover and text that contains links to related materials.
I can do this, as shown below, but the code in my .Rmd file is unnecessarily complex, making it
a chore to add new books.
How can I simplify this code in the chunks? I use several functions defined below
```{r do-books, echo=FALSE}
width <- "160px"
tab(class="cellpadding", width="800px",
tr(
tabfig("fox", "images/books/car-3e.jpg",
"https://us.sagepub.com/en-us/nam/an-r-companion-to-applied-regression/book246125", width=width),
tabtxt("Fox & Weisberg,", a("An R Companion to Applied Regression",
href="https://us.sagepub.com/en-us/nam/an-r-companion-to-applied-regression/book246125"),
". A comprehensive introduction to linear models, regression diagnostics, etc.", br()
# "Course notes at", aself("http://ccom.unh.edu/vislab/VisCourse/index.html")
)
),
tr(
tabfig("Wickham", "images/books/ggplot-book-2ndEd.jpg",
"https://www.springer.com/gp/book/9780387981413", width=width),
tabtxt("Hadley Wickham,", a("ggplot2: Elegant Graphics for Data Analysis",
href="https://www.springer.com/gp/book/9780387981413"),
". The printed version of the ggplot2 book. The 3rd edition is online at",
a("https://ggplot2-book.org/", href= "https://ggplot2-book.org/")
)
)
)
```
The functions tabfig and tabtext are defined in a sourced file:
library(htmltools)
# table tags
tab <- function (...)
tags$table(...)
td <- function (...)
tags$td(...)
tr <- function (...)
tags$tr(...)
# an <a> tag with href as the text to be displayed
aself <- function (href, ...)
a(href, href=href, ...)
# thumnail figure with href in a table column / row
tabfig <- function(name, img, href, ...) {
td(
a(class = "thumbnail", title = name, href = href,
img(src = img, ...)
)
)
}
tabtxt <- function(text, ...) {
td(text, ...)
}

How to add/remove input fields dynamically by a button in shiny

I've been trying to find a solution how to add and remove input fields with a button in shiny. I don't have a source code since I haven't made that much progress, but this jQuery example (http://www.mkyong.com/jquery/how-to-add-remove-textbox-dynamically-with-jquery/) gives a good idea on what I'm trying to accomplish. Is this possible in shiny or should I use shinyjs to do this? Thank you in advance!
EDIT: I read the jQuery example a bit more, and added a code snippet doing what I think you were looking for.
I don't know jQuery, so I couldn't make much out of the example link. I took a guess on what you wanted, but I think the key idea is the use of renderUI and uiOutput even if my suggestion here misses the point.
To toggle a ui element:
If you specifically don't want to use shinyjs, you could do something like this:
library(shiny)
ui <- shinyUI(fluidPage(
actionButton("btn", "Toggle Textbox"),
textOutput("btn_val"),
uiOutput("textbox_ui")
))
server <- shinyServer(function(input, output, session) {
output$btn_val <- renderPrint(print(input$btn))
textboxToggle <- reactive({
if (input$btn %% 2 == 1) {
textInput("textin", "Write something:", value = "Hello World!")
}
})
output$textbox_ui <- renderUI({ textboxToggle() })
})
shinyApp(ui, server)
To add and remove elements:
After reading a bit of the jQuery example, I think this is similar to what you were looking for:
library(shiny)
ui <- shinyUI(fluidPage(
sidebarPanel(
actionButton("add_btn", "Add Textbox"),
actionButton("rm_btn", "Remove Textbox"),
textOutput("counter")
),
mainPanel(uiOutput("textbox_ui"))
))
server <- shinyServer(function(input, output, session) {
# Track the number of input boxes to render
counter <- reactiveValues(n = 0)
observeEvent(input$add_btn, {counter$n <- counter$n + 1})
observeEvent(input$rm_btn, {
if (counter$n > 0) counter$n <- counter$n - 1
})
output$counter <- renderPrint(print(counter$n))
textboxes <- reactive({
n <- counter$n
if (n > 0) {
lapply(seq_len(n), function(i) {
textInput(inputId = paste0("textin", i),
label = paste0("Textbox", i), value = "Hello World!")
})
}
})
output$textbox_ui <- renderUI({ textboxes() })
})
shinyApp(ui, server)
The problem with this approach is that each time you press the add or remove button, all of the input boxes get re-rendered. This means that any input you might have had on them disappears.
I think you could get around that by also saving the current input values of the input boxes into a reactiveValues object, and setting the values from the object as the starting values of the re-rendered input boxes by using the value option in textInput. I'll leave the implementation of that for now, though.
Thank you #Mikko Marttila for your answer. I was able to use it for my purpose. Also, referring to the issue of all input boxes getting re-rendered here I found a solution worked from this answer. You can save all user inputs using reactiveValuesToList(), then call the reactive list accordingly to set every value to the corresponding user's input in the lapply() statement.
library(shiny)
ui <- shinyUI(fluidPage(
sidebarPanel(
actionButton("add_btn", "Add Textbox"),
actionButton("rm_btn", "Remove Textbox"),
textOutput("counter")
),
mainPanel(uiOutput("textbox_ui"))
))
server <- shinyServer(function(input, output, session) {
# Track the number of input boxes to render
counter <- reactiveValues(n = 0)
# Track all user inputs
AllInputs <- reactive({
x <- reactiveValuesToList(input)
})
observeEvent(input$add_btn, {counter$n <- counter$n + 1})
observeEvent(input$rm_btn, {
if (counter$n > 0) counter$n <- counter$n - 1
})
output$counter <- renderPrint(print(counter$n))
textboxes <- reactive({
n <- counter$n
if (n > 0) {
isolate({
lapply(seq_len(n), function(i) {
textInput(inputId = paste0("textin", i),
label = paste0("Textbox", i),
value = AllInputs()[[paste0("textin", i)]])
})
})
}
})
output$textbox_ui <- renderUI({ textboxes() })
})
shinyApp(ui, server)
EDIT: I wrapped the lapply() statement in isolate() because it gets annoying when boxes are being re-rendered as you're trying to type in the field
Instead of re-rendering the entire list of inputs, try the following
I keep track of all the ids that are created, I remove the last one created, and I reuse the ids of the deleted ones.
I start with an initial box (there is no real need for that, but I guess in a real work scenario you would expect at least 1 textBox to appear and increase thereafter). It is straightforward to start without the initial box.
Also, I keep track of the values of the textInput boxes that are currently active, in a reactive List. You would definitely need this
Lastly, I think for the two reactiveValues I have [inserted and counter], one of them is possibly redundant, but hey...
Hope it helps!
library(shiny)
ui <- fluidPage(
actionButton("insertBtn", "Insert"),
actionButton("deleteBtn", "Delete"),
h4("My boxes"),
# Initial box here to start with. Not needed but it is nice to have one :)
div(id = "box-1", textInput(inputId = "box-1", label = "box-1")),
div(id = "placeholder"),
h4('Box contents'),
verbatimTextOutput("my_inputs")
)
server <- function(input, output, session) {
## keep track of elements inserted and a counter of the elements
rv <- reactiveValues(
inserted = c("box-1"),
counter = 1
)
observeEvent(input$insertBtn, {
rv$counter <- rv$counter+1
serial <- rv$counter
id <- paste0('box-', serial)
rv$inserted <- c(rv$inserted, id)
insertUI(
selector = '#placeholder',
## wrap element in a div with id for ease of removal
ui = div(id = id,
textInput(inputId = id, label = paste0("box-", serial))
)
)
})
observeEvent(input$deleteBtn, {
req(rv$counter>0)
# removes the last one
id_to_remove <- rv$inserted[length(rv$inserted)]
removeUI(
## pass it in as JQuery selector
selector = paste0('#', id_to_remove)
)
rv$inserted <- rv$inserted[-length(rv$inserted)]
rv$counter <- rv$counter - 1
})
my_inputs <- reactive({
req(rv$inserted) # need to have some inputs
l <- reactiveValuesToList(input)
# regex of the union of all inputs. Note the starting input box-1
ids_regex <- paste(c("box-1", rv$inserted), collapse = "|")
l[grepl(ids_regex, names(l))]
})
output$my_inputs <- renderPrint({
my_inputs()
})
}
shinyApp(ui, server)
Many thanks to
this post
and this
and these SO posts one, two