I'm trying to use awesomeCheckbox from the shinyWidgets package and am running into an issue where I can't check/uncheck the box that a server rendered.
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
awesomeCheckbox(inputId = "checkboxA",
label = "A checkbox",
value = TRUE),
uiOutput("checkboxB"),
uiOutput("FS1")
)
server <- function(input, output) {
output$checkboxB <- renderUI({
awesomeCheckbox(inputId = "checkboxB",
label = "B checkbox",
value = TRUE)
})
output[[paste0("FS", 1)]] <- renderUI({
awesomeCheckbox(inputId = paste0("FS", 1),label = "FS", value = FALSE)
})
}
shinyApp(ui= ui, server=server)
I need this piece of code as part of a larger Shiny App where checkboxes are generated dynamically in the server (hence the weird paste0 naming).
I've checked my version of R and have tried using both Chrome and Safari but can't seem to get the FS checkbox to check/uncheck. I also can't seem to find anything out of the ordinary when I use "Inspect element" in my browser.
You have outputids checkboxB and FS1 respectively already rendered once, yet you create other components with the same names, hence they wont work, change the names as you cant have duplicate divs like so:
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
awesomeCheckbox(inputId = "checkboxA",label = "A checkbox",value = TRUE),
uiOutput("checkboxB"),
uiOutput("FS1")
)
server <- function(input, output) {
output$checkboxB <- renderUI({
awesomeCheckbox(inputId = "checkboxBx",label = "B checkbox", value = TRUE)
})
output[[paste0("FS", 1)]] <- renderUI({
awesomeCheckbox(inputId = paste0("FSx", 1),label = "FS", value = FALSE)
})
}
shinyApp(ui= ui, server=server)
Related
I have a selectizeInput with some grouped elements with multiple selection. Is there an elegant way (e.g. using the options argument) of allowing just one element per group, so that a whole group will discarded (or disabled) when an element of this specific group is selected?
So far I tried it programmatically, but than the dropdown menu of the selectizeInput will be closed when updating the selectizeInput.
Minimal example:
library(shiny)
ui <- fluidPage(
selectizeInput("selInput", "Default",
choices=list(g1 = c(A="A",B="B"),
g2 = c(C="C",D="D")),
multiple=T),
selectizeInput("oneElementPerGroup", "One element per group",
choices=list(g1 = c(A="A",B="B"),
g2 = c(C="C",D="D")),
multiple=T)
)
server <- function(session, input, output) {
#Removes the corresponding groups of selected items
observeEvent(input$oneElementPerGroup, ignoreNULL = F, {
plusChoice <- input$oneElementPerGroup
names(plusChoice) <- input$oneElementPerGroup
choices <- list(g1 = c(A="A",B="B"),
g2 = c(C="C",D="D"))
if(any(input$oneElementPerGroup %in% c("A", "B"))){
choices[["g1"]] <- NULL
}
if(any(input$oneElementPerGroup %in% c("C", "D"))){
choices[["g2"]] <- NULL
}
choices$we <- plusChoice
updateSelectizeInput(session,"oneElementPerGroup",
choices = choices,
selected=input$oneElementPerGroup)
})
}
shinyApp(ui = ui, server = server)
You can use pickerInput from {shinyWidgets}. Then we can add a little javascript to do what you want. No server code is needed, very simple. Read more about the data-max-options option: https://developer.snapappointments.com/bootstrap-select/options/.
We need to add the limit to each group, not an overall limit, so we can't add it through the options argument in pickerInput, have to do it in raw HTML or use some js code to inject like what I do.
Be sure your inputId="pick" matches the id in the script #pick. Rename pick to whatever you want.
ui <- fluidPage(
shinyWidgets::pickerInput(
inputId = "pick", label = "Selected",
choices =list(g1 = c(A="A",B="B"), g2 = c(C="C",D="D")),
multiple = TRUE
),
tags$script(
'
$(function(){
$("#pick optgroup").attr("data-max-options", "1");
})
'
)
)
server <- function(input, output, session){}
shinyApp(ui, server)
updates:
If you need to update, we need to run the script again but from server. We can send js by using {shinyjs}. Imagine an observer triggers the update event.
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
shinyWidgets::pickerInput(
inputId = "pick", label = "Selected",
choices =NULL,
multiple = TRUE
)
)
server <- function(input, output, session){
observe({
shinyWidgets::updatePickerInput(session, "pick", choices = list(g1 = c(A="A",B="B"), g2 = c(C="C",D="D")))
observeEvent(once = TRUE, reactiveValuesToList(session$input), {
runjs('$("#pick optgroup").attr("data-max-options", "1");')
}, ignoreInit = TRUE)
})
}
shinyApp(ui, server)
I have a Shiny app with a datatable. I would like to implement a button at the top of this datatable (but below its title) so that, when I click on it, the LaTeX code necessary to build this table is copied to clipboard.
Basically, this button would work the same way that the "copy" or "csv" buttons (see here part 2) but with LaTeX code.
Here's a reproducible example :
library(DT)
library(shiny)
library(shinydashboard)
library(data.table)
library(stargazer)
library(clipr)
ui <- dashboardPage(
dashboardHeader(title = "test with mtcars", titleWidth = 1000),
dashboardSidebar(
selectizeInput("var.cor", label = "Correlation",
choices = names(mtcars),
selected = c("mpg", "cyl"),
multiple = TRUE)
),
dashboardBody(
tabsetPanel(
tabPanel("test with mtcars",
br(),
box(dataTableOutput("cor"),
width = NULL),
actionButton("copy.latex", label = "Copy to LaTeX")
)
)
)
)
server <- function(input, output) {
var.selected <- reactive({
out <- input$var.cor
out
})
user.selection <- reactive({
mtcars <- mtcars[, var.selected()]
})
output$cor <- renderDataTable({
dtable <- user.selection()
tmp <- datatable(cor(dtable),
extensions = 'Buttons',
options = list(
dom = 'Bfrtip',
buttons = list(
"copy",
list(
extend = "collection",
text = 'test',
action = DT::JS("function ( e, dt, node, config ) {
Shiny.setInputValue('test', true, {priority: 'event'});
}")
)
)
)
)
observeEvent(input$test, {
write_clip(stargazer(tmp),
object_type = "auto")
})
tmp
})
observeEvent(input$copy.latex, {
write_clip(stargazer(input$cor),
object_type = "character")
})
}
shinyApp(ui, server)
I tested two things in this code :
firstly, I inspired from here. This is the code of observeEvent nested in renderDataTable. However, either the text in the clipboard is % Error: Unrecognized object type, either I have an error : Error in : Clipboard on X11 requires that the DISPLAY envvar be configured.
secondly, I created a button outside the datatable but it doesn't work because I have Error in : $ operator is invalid for atomic vectors
Does somebody know how to do it ?
To copy the dataframe to clipboard in server:
library(shiny)
library(shinyjs)
library(DT)
table <- iris[1:10,]
ui <- fluidPage(
useShinyjs(),
actionButton("latex","Copy Latex to Clipboard"),
DT::dataTableOutput("table")
)
server <- function(input, output, session) {
output$table <- DT::renderDT(table)
observeEvent(input$latex,{
writeClipboard(paste0(capture.output(xtable(table))[-c(1:2)],collapse = "\n"))
shinyjs::alert("table copied to latex")
})
}
shinyApp(ui, server)
I won't recommend you to do it using DT's button. In order to do it using DT, there are at least 3 steps:
read entire table in the UI of datatable by writing Javascript in action, use Shiny.setInputValue to send the value from UI to server.
use R to parse the list(json) into data frame.
convert the data frame to latex string.
It's much easier to just do the conversion using the source data for datatable.
I'm trying to get debounce to work without using dplyr or magrittr as my server (at work) seems unable to render output when I load these libraries. I'm sure I'm missing something basic here but I can't seem to get my head around getting debounce to work for me.
ui.R
library(shiny)
fluidPage(
titlePanel("Debounce Test")
,selectizeInput("rweek", "Select number(s):"
,c(1,2,3)
,multiple = TRUE
,selected = "1"
,width = '100%')
,textInput(inputId = "abctext", label = "Type anything")
,textOutput(outputId = "finalText")
)
server.R
server <- function (input, output) {
finalSelections <- reactive ({
typedtext <- input$abctext
weeklist<- input$rweek
countt <- length(weeklist)
typedtextd <- debounce(typedtext,2000)
weeklistd <- debounce(weeklist,2000)
counttd <- length(weeklistd)
final_data <- c(typedtextd, counttd)
#final_data <- c(typedtext, countt)
return(final_data)
})
output$finalText <- renderText({
paste0("You have typed: ", finalSelections()[1], "; You have selected ", finalSelections()[2], " item(s)")
})
}
The code works fine when I comment out the debounce sections. I want to be able to wait a bit for the user to select inputs (especially SelectizeInput) before printing out the output.
Welcome to Stackoverflow!
debounce() needs a reactive expression to work - Please see ?debounce(). In your code you are passing strings (inside a reactive expression).
I guess this is what you are after:
library(shiny)
ui <- fluidPage(
titlePanel("Debounce Test"),
selectizeInput("rweek", "Select number(s):", c(1, 2, 3), multiple = TRUE, selected = "1", width = '100%'),
textInput(inputId = "abctext", label = "Type anything"),
textOutput(outputId = "finalText")
)
server <- function(input, output, session) {
typedtext <- reactive({input$abctext})
weeklist <- reactive({input$rweek})
typedtextd <- debounce(typedtext, 2000)
weeklistd <- debounce(weeklist, 2000)
finalSelections <- reactive ({
countt <- length(weeklist())
counttd <- length(weeklistd())
final_data <- c(typedtextd(), counttd)
#final_data <- c(typedtext(), countt)
return(final_data)
})
output$finalText <- renderText({
paste0(
"You have typed: ",
finalSelections()[1],
"; You have selected ",
finalSelections()[2],
" item(s)"
)
})
}
shinyApp(ui = ui, server = server)
I have output of data.tree package as follows in the console :
print(acme, "cost", "p")
#Out of Data.tree print JPEG
I want to render the same output structure in the shiny UI.
I have tried paste(console.output(print(acme, "cost", "p")),collapse = ""), but the output structure is not same.
ui <- fluidPage(
sliderInput(inputId = "slider",
label = "My number",
min = 300,
max = 19000,
value = 5000),
htmlOutput("mytext")
)
server <- function(input, output) {
output$mytext <- renderText({
paste(capture.output(print(acme, "cost", "p")),collapse = "<br/>")
})
}
shinyApp(ui = ui, server = server)
Please suggest me any render functions , that will print the output exactly like the above in the Shiny UI.
TL:DR; Replace renderText() with renderPrint() in server and htmlOutput() with verbatimTextOutput() in ui.
The issue is with how renderText() works. It concatenates all the text input with cat() which will fail when using against the data.tree object, which is a list. You should use renderPrint() to capture the output of your print statement. No capture.output() required. The renderPrint() will not work with various output methods, the safest one to use is verbatimTextOutput(). I base that recommendation from experimentation, not actual documentation research. htmlOutput might work but I an not sure.
Updated code:
ui <- fluidPage(
sliderInput(inputId = "slider",
label = "My number",
min = 300,
max = 19000,
value = 5000),
verbatimTextOutput("mytext")
)
server <- function(input, output) {
output$mytext <- renderPrint({
print(acme, "cost", "p"))
})
}
shinyApp(ui = ui, server = server)
Is it possible to capture the label of an actionButton once it is clicked?
Imagine I have 3 buttons on my ui.R and depending on which one I click I want to perform a different action on the server.R.
One caveat is that the buttons are created dynamically on the server.R with dynamic labels (thus the necessity of capturing the label on click)
Thanks
Something like that ?
library(shiny)
server <- function(input, session, output) {
output$printLabel <- renderPrint({input$btnLabel})
}
ui <- fluidPage(
actionButton("btn1", "Label1",
onclick = "Shiny.setInputValue('btnLabel', this.innerText);"),
actionButton("btn2", "Label2",
onclick = "Shiny.setInputValue('btnLabel', this.innerText);"),
verbatimTextOutput("printLabel")
)
shinyApp(ui = ui, server = server)
1) What button was clicked last by the user?
To answer this you can user observeEvent function and by setting up a a variable using reactiveValues function. Make sure you update your libraries and work in the latest version of R (version 3.1.3) as shiny is dependant on this version. Working on windows you can follow example on how to update here
rm(list = ls())
library(shiny)
ui =fluidPage(
sidebarPanel(
textInput("sample1", "Name1", value = "A"),
textInput("sample2", "Name2", value = "B"),
textInput("sample3", "Name3", value = "C"),
div(style="display:inline-block",uiOutput("my_button1")),
div(style="display:inline-block",uiOutput("my_button2")),
div(style="display:inline-block",uiOutput("my_button3"))),
mainPanel(textOutput("text1"))
)
server = function(input, output, session){
output$my_button1 <- renderUI({actionButton("action1", label = input$sample1)})
output$my_button2 <- renderUI({actionButton("action2", label = input$sample2)})
output$my_button3 <- renderUI({actionButton("action3", label = input$sample3)})
my_clicks <- reactiveValues(data = NULL)
observeEvent(input$action1, {
my_clicks$data <- input$sample1
})
observeEvent(input$action2, {
my_clicks$data <- input$sample2
})
observeEvent(input$action3, {
my_clicks$data <- input$sample3
})
output$text1 <- renderText({
if (is.null(my_clicks$data)) return()
my_clicks$data
})
}
runApp(list(ui = ui, server = server))
2) Save the clicks for further manipulation is below
Here's small example based on the work of jdharrison from Shiny UI: Save the Changes in the Inputs and the shinyStorage package.
rm(list = ls())
#devtools::install_github("johndharrison/shinyStorage")
library(shinyStorage)
library(shiny)
my_clicks <- NULL
ui =fluidPage(
#
addSS(),
sidebarPanel(
textInput("sample_text", "test", value = "0"),
uiOutput("my_button")),
mainPanel(uiOutput("text1"))
)
server = function(input, output, session){
ss <- shinyStore(session = session)
output$my_button <- renderUI({
actionButton("action", label = input$sample_text)
})
observe({
if(!is.null(input$sample_text)){
if(input$sample_text != ""){
ss$set("myVar", input$sample_text)
}
}
})
output$text1 <- renderUI({
input$action
myVar <- ss$get("myVar")
if(is.null(myVar)){
textInput("text1", "You button Name")
}else{
textInput("text1", "You button Name", myVar)
}
})
}
runApp(list(ui = ui, server = server))