I created a simple app which includes a selectInput widget and a bar plot in rCharts. What I want to accomplish is to create the plot with a legend with all three books but by default show only a book which is chosen by the widget. So when I change from Book1 to Book2 the plot will show initially only info about Book2 but legend plot will include Book1 and Book3 (both disabled by default) - if I want to I could choose Book1 or Book3 anytime. I believe it is JS problem so I tried to solve it but nothing changed. Any ideas how to handle it? Thanks.
library(shiny)
library(rCharts)
books <- c('Book1','Book2','Book3')
df <- data.frame(book = rep(books, each = 10),
year = rep(2000:2009,3),
sale = sample(100:1000, 30, replace = T))
ui <- shinyUI(
fluidPage(
HTML("
<script>
$( document ).ready(function() {
if ( $(\"select#book div.selectize-dropdown div[data-value='Book1']\").hasClass('selected')) {
console.log('true');
$('#nvd3Plot .nv-legend g.nv-series').eq(1).addClass('disabled');
$('#nvd3Plot .nv-legend g.nv-series').eq(2).addClass('disabled');
}
else {
console.log('false');
}
});
</script>"),
selectInput('book', 'Select a book', choices = books, selected = 'Book1'),
showOutput("nvd3Plot", "nvd3")
)
)
server <- function(input, output, session) {
output$nvd3Plot <- renderChart2({
chartObject <- nPlot(sale ~ year, group = "book", data = df, type = "multiBarChart")
chartObject$chart(
showControls = FALSE
)
return(chartObject)
})
}
shinyApp(ui, server)
Update
I found this solution but actually I don't have any idea how to implement it in R.
Using the answer from here, you could use a custom message handler to programatically click on the legend.
You could add, in your ui.R:
tags$script('
Shiny.addCustomMessageHandler("change_selected_book",
function(book) {
d3.select("g.nv-legendWrap").selectAll("g.nv-series.disabled")
.each(function(d) {
this.dispatchEvent(new Event("click"));
});
d3.select("g.nv-legendWrap").selectAll("g.nv-series").filter(
function(d) { return d.key != book; })
.each(function(d) {
this.dispatchEvent(new Event("click"));
});
});
')
and in your server.R:
observe({
session$sendCustomMessage(type = "change_selected_book", input$book)
})
The code clicks on all of the disabled series, and once all series are enabled, it clicks on the legend of all the books except the one the user has selected to disable them.
One drawback is that the selectInput element is created before the graph so it initially displays all three books until the user selects one.
Related
Summary: When I put a shinyTree (from the R package of the same name) in a dropdownButton (from the shinyWidgets package), it seems that the tree in question is not accessible from the input variable until the user has interacted with the tree in some way. Is there a way I can force the tree to load when the app is loaded at the start?
Here is a minimal (almost) example:
library(shiny)
library(shinyWidgets)
library(shinyTree)
library(magrittr)
render.as.text <- function(t) {
if (is.null(t)) {
'argument is NULL'
} else {
q <- get_selected(t)
if (length(q) == 0) {
'none selected'
} else {
paste(q, sep=', ', collapse=', ')
}
}
}
ui <- fluidPage(
dropdownButton(shinyTree('tree', checkbox=TRUE), circle=FALSE, inputId='dd')
)
server <- function(input, output, session) {
output$tree <- renderTree({ list(OptionA = structure(list(OptionAA='', OptionAB=''), stopened=TRUE), OptionB='') })
updateActionButton(session, 'dd', label='initial label')
observe({
updateActionButton(session, 'dd', label=render.as.text(input$tree))
}) %>% bindEvent(input$dd_state)
}
shinyApp(ui = ui, server = server)
When I run this app, the button begins with the text 'initial label' (as expected), then when I click on it the first time the text changes to 'argument is NULL' (showing that the variable input$tree has a NULL value), but the tree displays correctly in the dropdown. If I then click the button again to close the dropdown, the text 'argument is NULL' remains - it remains until I actually select one or more of the tree's checkboxes after which (and after clicking the button again) it will display either a comma-separated list of selected options or 'none selected' as expected.
I would very much like to be able to refer to input$tree beginning with the first time the user takes any action in the app - ideally I am looking for some command to insert in either the server or ui code (or both) which will mean that the first time the user clicks the button its text will change directly to 'none selected' because input$tree is no longer NULL. Is this possible?
Would just changing the default of your render.as.text function work for your purpose?
library(shiny)
library(shinyWidgets)
library(shinyTree)
library(magrittr)
render.as.text <- function(t) {
if (is.null(t)) {
'none selected'
} else {
q <- get_selected(t)
if (length(q) == 0) {
'none selected'
} else {
paste(q, sep=', ', collapse=', ')
}
}
}
ui <- fluidPage(
dropdownButton(shinyTree('tree', checkbox=TRUE), circle=FALSE, inputId='dd')
)
server <- function(input, output, session) {
output$tree <- renderTree({ list(OptionA = structure(list(OptionAA='', OptionAB=''), stopened=TRUE), OptionB='') })
updateActionButton(session, 'dd', label='initial label')
observe({
updateActionButton(session, 'dd', label=render.as.text(input$tree))
}) %>% bindEvent(input$dd_state)
}
shinyApp(ui = ui, server = server)
I've searched stackoverflow and the complete web, but I can't find to seem a good answer to this, seemingly simple, problem.
The situation is as follows:
I have a Shiny application, connected with a database
I have several user inputs (Pickerinputs), where a user can select multiple arguments
The user inputs are all dependent on each other
The problem that arises is the following:
If a user ticks multiple car brands (for example, Renault, Peugeot and BMW) then the pickerinput that is linked to this selection (specific car models for these brands) gets updated three times. With many pickerinputs that are linked to each other, this creates messy UX.
Solution needed
I think the solution is simple: the pickerinput only needs to send the selected values after the input has been closed; it does not need to send values (and trigger updates) after every pick a user makes. The AirdatePickerInput from Shinywidgets has this specific feature (update_on=c('change', 'close'). What I need is that my pickerInput gets updated only on 'close'. So that the resulting values are send only once back to the server.
Example:
UI
ui <- fluidPage(
# Title panel
fluidRow(
column(2,
wellPanel(
h3("Filters"),
uiOutput("picker_a"),
uiOutput("picker_b"),
)
),
)
)
Server
server <- function(input, output, session) {
# Start values for each filter
all_values_for_a <- tbl(conn, "table") %>%
distinct(a) %>%
collect()
all_values_for_b <- tbl(conn, "table") %>%
distinct(b) %>%
collect()
output$picker_a <- renderUI({
pickerInput(
inputId = "picker_a",
label = "a:",
choices = all_values_for_a,
selected = all_values_for_a,
multiple = TRUE,
options = list("live-search" = TRUE, "actions-box" = TRUE))
})
output$picker_b <- renderUI({
pickerInput(
inputId = "picker_b",
label = "b:",
choices = all_values_for_b,
selected = all_values_for_b,
multiple = TRUE,
options = list("live-search" = TRUE, "actions-box" = TRUE))
})
#I want this code to be executed ONLY when
#picker_a is closed, not everytime when the user
#picks an item in picker_a
observeEvent(
input$picker_a,
{
all_values_for_b <- tbl(conn, "table") %>%
filter(a %in% !!input$picker_a) %>%
distinct(b) %>%
collect()
updatePickerInput(session, "picker_b", choices = all_values_for_b, selected = all_values_for_b)
})
)
)
}
You can probably use an actionButton to delay the execution of the update once all values have been picked by the user.
Or use a debounce function, see this other post.
EDIT
The update_on = c("change", "close") feature was asked for the pickerInput widget to the shinyWidgets developer (Victor Perrier) on GitHub.
Victor's answer was:
there's no similar argument for pickerInput, but there's a special input to know if menu is open or not. So you can use an intermediate reactiveValue to achieve same result.
and he provided the following code:
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
fluidRow(
column(
width = 4,
pickerInput(
inputId = "ID",
label = "Select:",
choices = month.name,
multiple = TRUE
)
),
column(
width = 4,
"Immediate:",
verbatimTextOutput("value1"),
"Updated after close:",
verbatimTextOutput("value2")
),
column(
width = 4,
"Is picker open ?",
verbatimTextOutput("state")
)
)
)
server <- function(input, output) {
output$value1 <- renderPrint(input$ID)
output$value2 <- renderPrint(rv$ID_delayed)
output$state <- renderPrint(input$ID_open)
rv <- reactiveValues()
observeEvent(input$ID_open, {
if (!isTRUE(input$ID_open)) {
rv$ID_delayed <- input$ID
}
})
}
shinyApp(ui, server)
In your case you could try:
observeEvent(
input$picker_a_open,
{
if (!isTRUE(input$picker_a_open)) {
all_values_for_b <- tbl(conn, "table") %>%
filter(a %in% !!input$picker_a) %>%
distinct(b) %>%
collect()
updatePickerInput(session, "picker_b", choices = all_values_for_b, selected = all_values_for_b)
}
})
Hello I am new to RShiny, and I'm trying to build an application for a project.
I have 5 images in my UserInterface I would like to make them clickable : When you click on image, it displays a subset of the dataframe in the mainPanel.
My Dataframe contains a column called "Mood",and there are 5 moods ("Party and Dance", "Rap","Happy vibes" , "Sunday Chillout" and "Roadtrip music"). Each image should display rows of one of the moods.
This is the code I have used for now :
UI.R
shinyUI(
fluidPage( useShinyjs(),
headerPanel(
h1(img(src="logo.png",height = 70, width = 70),"Quelle est votre humeur du moment ?",
style = "font-weight: 500; color: #FFFFFF;")),
dashboardSidebar(
fluidRow(
column(width=11.9, align="center",
selectInput("Mood", label= "Choose your Mood : ",
choices = test$Mood),
img(id="my_img1",src="party.jfif",width="19.5%",style="cursor:pointer;"),
img(id="my_img2",src="cluster 2.jpg",width="19.5%",style="cursor:pointer;"),
img(id="my_img3",src="roadtrip.jpg",width="19.5%",style="cursor:pointer;"),
img(id="my_img4",src="rap.jfif",width="19.5%",style="cursor:pointer;"),
img(id="my_img5",src="sunday.jpg",width="19.5%",style="cursor:pointer;")),
column(11.2, align="center",
mainPanel(br(),br(),DT::dataTableOutput("dynamic"), width = "100%"))
))))
Server.R
For now I have just managed to link the Select box to the subset dataframe, but I would like to get rid of it and only use the images instead.
shinyServer(function(input,output){
output$dynamic<- DT::renderDataTable({
data <- DT::datatable(test[test$Mood ==input$Mood, c("Song","Artist","Mood","Listen to song"), drop = FALSE], escape = FALSE)
data
})
})
I have tried lots of combinations but all of them failed, because I don't have basic skills of how Shinyjs works.
My last attempt: (I thought about doing this manually for each image but it's not working of course)
shinyServer(function(input,output){
onclick("my_img1", { print(datatable(test[test$Mood =="Party and dance", c("Song","Artist","Mood","Listen to song"), drop = FALSE], escape = FALSE))})
})
Any feedback would be much appreciated !! Thank you !
This is what my interface looks like
It has been a while since I used Shiny so I may be a bit rusty. But here is a possible approach to tackling your issue: You could use a reactiveValue to keep track of which mood is selected, and update that variable whenever one of the images is clicked. Then use that reactiveValue in subsetting your dataframe, as shown below. Hope this helps!
library(shiny)
library(shinyjs)
df = data.frame(mood = c('mood1','mood1','mood1','mood2','mood2','mood2'),
example = c('dog',' cat','bunny','elephant','t-rex','not dog'))
ui <- shinyUI(
fluidPage(
useShinyjs(),
img(id="my_img1",src="img1.png",width="19.5%",style="cursor:pointer;"),
img(id="my_img2",src="img1.png",width="19.5%",style="cursor:pointer;"),
DT::dataTableOutput("dynamic")
)
)
server <- shinyServer(function(input,output){
selected_mood <- reactiveVal()
shinyjs::onclick("my_img1", selected_mood('mood1'))
shinyjs::onclick("my_img2", selected_mood('mood2'))
output$dynamic<- DT::renderDataTable({
req(selected_mood())
df[df$mood == selected_mood(),]
})
})
shinyApp(ui, server)
I've been trying to add a row (basically a row of check boxes) on my data table, so that users will be able to decide which column they like to keep/delete. And here is what my Shiny App looks like so far. Anyone who knows any hints please help!
Any help would be appreciated!
ui <- dashboardPage(dashboardHeader(disable = T),
dashboardSidebar(disable = T),
dashboardBody(uiOutput("MainBody")))
server <- shinyServer(function(input, output){
vals <- reactiveValues()
vals$data <- data.table(vals$Data<-data.table(
Brands=paste0("Brand",1:10),
Forecasted_Growth=sample(1:20,10),
Last_Year_Purchase=round(rnorm(10,1000,1000)^2),
Contact=paste0("Brand",1:10,"#email.com")
))
output$MainBody <- renderUI({
fluidPage(
box(width = 12,
h3(strong("Template"), align = "center"),
hr(),
column(6, offset = 6,
actionButton(inputId = "Del_Col", label = "Delete Select Column"))),
column(12, dataTableOutput("MainTable")),
tags$script()
)
})
I agree with Pork Chop that you should rethink your layout. I couldn't get my head around it so I reworked it into a minimal fluidpage.
The code below should get you close. It renders buttons (you could make these checkboxes though) directly into the table using a helper function described here. The code below uses these buttons to subset and update the dataframe which I term reactiveTable. Here's the functionality:
Good luck!
library(data.table)
library(DT)
## Nice helper function to make the buttons from:
## https://github.com/rstudio/DT/issues/178
shinyInput <- function(FUN, len, id, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
inputs[i] <- as.character(FUN(paste0(id, i), ...))
}
inputs
}
## Basic UI with a reset button
ui <- fluidPage(
mainPanel(
h1('Table Subsetter'),
actionButton('reset', 'Reset!'),
DT::dataTableOutput('mytable')
)
)
server <- function(input, output){
#This is the table you provided in your question
tableA <- data.table(
Brands=paste0("Brand",1:10),
Forecasted_Growth=sample(1:20,10),
Last_Year_Purchase=round(rnorm(10,1000,1000)^2),
Contact=paste0("Brand",1:10,"#email.com")
)
#make a reactive value for the table and columns to delete
reactiveTable <- reactiveValues(tab=tableA)
columnToDelete <- reactiveValues(col=NULL)
#Logic to make the buttons, reruns everytime the table is updated
tableOut <- reactive({
buttons <- shinyInput(actionButton, length(reactiveTable$tab[1,]), 'button_', label = "Delete!", onclick = 'Shiny.onInputChange(\"select_button\", this.id)' )
buttons <- t(as.data.frame(buttons, stringsAsFactors = FALSE))
colnames(buttons) = colnames(reactiveTable$tab)
rbind(buttons, reactiveTable$tab)
})
#reset button replaces the table
observeEvent(input$reset, {
reactiveTable$tab <- tableA
})
#listener to for the delete button
observeEvent(input$select_button, {
columnToDelete$col <-as.numeric(strsplit(input$select_button, "_")[[1]][2])
reactiveTable$tab <- subset( reactiveTable$tab, select = -columnToDelete$col )
})
#output the table with DT. use escape=F so it renders the html
output$mytable <- DT::renderDataTable({
tableOut()
},server = FALSE, escape = FALSE, selection = 'none')
}
shinyApp(ui = ui, server = server)
Using a ShinyR and data table we can create an interactive plot. When a user select a row in the data table it displayed with specific color and shape in the graph. When we un-select the row, point gain normal conditions.
Example modified from (Shiny apps).
Additionally, we can identify particular points (we are interested in) on the graph (Using nearPoints)
I would like a user to be able un-select the row by clicking on particular point on the graph. Once user clicked the point on the graph it will gain normal appearance.
However, I can’t find function to make it work.
There is a proxy and selectRows function in new DT library (the DT-package)(but for Mac it is unavailable). Example
Another option would be to write and option javascript code in callback, however my knowledge is limited in that area.
Will be thankful for any comments and suggestions.
UI
library(shiny)
library(DT)
fluidPage(
title = 'Select Table Rows',
fluidRow(
column(6, DT::dataTableOutput('x1')),
column(6, plotOutput('x2', height = 500,click = "plot_click"),
verbatimTextOutput("info"))
)
)
Server
shinyServer(function(input, output, session) {
output$x1 = DT::renderDataTable(cars, server = FALSE)
# highlight selected rows in the scatterplot
output$x2 = renderPlot({
s = input$x1_rows_selected
par(mar = c(4, 4, 1, .1))
plot(cars)
if (length(s)) points(cars[s, , drop = FALSE], pch = 19, cex = 2)
})
output$info <- renderPrint({
paste("Selected point row.name - ", row.names(nearPoints(cars, input$plot_click, xvar = "speed", yvar = "dist")), sep="")
})
})
With a new version of DT it works perfect with proxy
proxy = dataTableProxy('x1')
observeEvent(input$plot_click, {
removeRow <- as.numeric(row.names(nearPoints(cars, input$plot_click, xvar = "speed", yvar = "dist")))
selectRows(proxy, input$x1_rows_selected[!input$x1_rows_selected %in% removeRow])
})