Hope all are safe there :slight_smile:
In the below simple application (rather my question should hold for all applications as well), is there a way to build workflow, so that we can get to know about the application well. For example
In this app,
In terms of UI.R
1) There is 1 actionbutton (So can we list the number of action buttons in the app, along with there ID's)
2) There is 1 dataTableoutput (So can we list the number of dataTableoutput in the app, along with there ID's)
So in general, can we list the number of inputs and there type(actionbutton, radiobutton etc)
Interms of Server.R
3) Can we show that dataTableOutput("Test") is dependent on actionButton("plot"). I mean can we extract a list of outputs that is dependent on observerEvents?
So basically, just by running the small chunk of code, the user should know that this output(test) is dependent on observeEvent(plot).?
library(shiny)
library(dplyr)
library(shinycssloaders)
library(DT)
ui <- fluidPage(
actionButton("plot","plot"),
dataTableOutput("Test")
)
server <- function(input, output, session) {
observeEvent(input$plot, {
output$Test <- DT::renderDT(DT::datatable(head(iris),
rownames = FALSE, options = list(dom = 't',
ordering=FALSE)))
})
}
shinyApp(ui = ui, server = server)
Related
My question is in regards to
Shiny: Add Popover to Column Name in Datatable, the package spsComps for using tooltips, when I remove the tooltip which is defined in the mainPanel, the tooltip on the datatable column also does not work anymore.
library(shiny)
library(spsComps)
library(DT)
library(dplyr)
# define the question button in a button since we need to uses multiple times
infoBtn <- function(id) {
actionButton(id,
label = "",
icon = icon("question"),
style = "info",
size = "extra-small",
class='btn action-button btn-info btn-xs shiny-bound-input'
)
}
ui <- fluidPage(
titlePanel('Making a Popover Work in DataTable'),
mainPanel(
fluidRow(dataTableOutput('myTable'))
)
)
server <- function(input, output, session) {
output$myTable <- DT::renderDataTable({
# construct the title and convert to text
hp_text <- tags$span(
"hp",
infoBtn('notWorking') %>%
bsPopover(title = "This one does not work",
content = "I'd like to give information about hp: it means horsepower. I want a popover, because my real example has lot's of text.",
placement = "top",
trigger = "hover")
) %>%
as.character()
# use !! and := to inject variable as text
datatable(mtcars %>% rename(!!hp_text:=hp),
rownames=TRUE,
selection='none',
escape=FALSE)
})
}
shinyApp(ui = ui, server = server)
However, when once a tooltip is displayed once in the UI, then it also works for the datatable (from #lz100)
library(shiny)
library(spsComps)
library(DT)
library(dplyr)
# define the question button in a button since we need to uses multiple times
infoBtn <- function(id) {
actionButton(id,
label = "",
icon = icon("question"),
style = "info",
size = "extra-small",
class='btn action-button btn-info btn-xs shiny-bound-input'
)
}
ui <- fluidPage(
titlePanel('Making a Popover Work in DataTable'),
mainPanel(
fluidRow(
#popover button
infoBtn('workingPop') %>%
bsPopover(title = "This Popover Works",
content = "It works very well",
placement = "right",
trigger = "hover"
)
),
fluidRow(dataTableOutput('myTable'))
)
)
server <- function(input, output, session) {
output$myTable <- DT::renderDataTable({
# construct the title and convert to text
hp_text <- tags$span(
"hp",
infoBtn('notWorking') %>%
bsPopover(title = "This one does not work",
content = "I'd like to give information about hp: it means horsepower. I want a popover, because my real example has lot's of text.",
placement = "top",
trigger = "hover")
) %>%
as.character()
# use !! and := to inject variable as text
datatable(mtcars %>% rename(!!hp_text:=hp),
rownames=TRUE,
selection='none',
escape=FALSE)
})
}
shinyApp(ui = ui, server = server)
Is this a bug? Or is there something I am missing?
Change this on your UI:
mainPanel(
fluidRow(dataTableOutput('myTable')),
spsDepend("pop-tip")
)
So here, we add spsDepend("pop-tip"). This means loading the dependent Javascript library when app starts. In therory, -v-, the dependency would be automatically added, users do not need to know this. However, in this case, you are using the renderDataTable function. This package does not know how to handle htmltools::htmlDependency, which is the mechanism how usually developers add JS dependencies for shiny apps.
In your case, if you only use it once in the renderDataTable, we need to manually add the dependency in UI by spsDepend. But like your second case, if it has been used at least once in the UI, the dependency is there, you don't need to worry.
You can see the question mark for the button is not working either. The same problem. renderDataTable does not know how to add the dependency for actionButton. So in general, I wouldn't call it a bug, but a feature DT package doesn't support yet.
For the question mark, even if is not a problem caused by spsComps, but we do have a solution from spsComps, adding the icon library:
mainPanel(
fluidRow(dataTableOutput('myTable')),
spsDepend("pop-tip"),
spsDepend("font-awesome")
)
I'm using the selectInput function of shiny package with option groups like this Output of the selectInput function
In the ui.r file i've something like that:
ListOfItemsWithNames = list(condition = c("KO","WT"),treatment = c("non","oui"))
selectInput("Select1_contrast",label="Compare",ListOfItemsWithNames)
In the server.R file, when i call input$Select1_contrast I only get the selected value ("oui" for instance).
Is there a way to get both the value an the name of the variable (ie, "oui" and "treatment") ?
Here is another possibility. It uses key-value pairs. Those pairs are allowed according to the documentation of selectInput
choices List of values to select from. If elements of the list are named, then that name rather than the value is displayed to the user. This can also be a named list whose elements are (either named or unnamed) lists or vectors. If this is the case, the outermost names will be used as the "optgroup" label for the elements in the respective sublist. This allows you to group and label similar choices. See the example section for a small demo of this feature.
addKeys = function(nested_list){
keyed_nl = list()
for (a in names(nested_list))
for (b in (nested_list[[a]]))
keyed_nl[[a]][[b]] = paste0(a, "-", b)
keyed_nl
}
ListOfItemsWithNames = list(condition = c("KO", "WT"),
treatment = c("non", "oui"))
keyedList = addKeys(ListOfItemsWithNames)
library(shiny)
shinyApp(
fluidPage(
selectInput("choiceKey", "choose", keyedList),
textOutput('text')
),
function(input, output, session)
output$text = renderText(input$choiceKey)
)
As you can see, input$choiceKey will give you the category and the choice seperated with -. Using strsplit, you can get both parts seperately
This should work. In this version, you have a sencond dropdown menu and therefore a second input.
library(shiny)
ListOfItemsWithNames = list(condition = c("KO","WT"),treatment = c("non","oui"))
ui = inputPanel(
selectInput("category", "choose a category", names(ListOfItemsWithNames )),
selectInput("choice", "select a choice", ListOfItemsWithNames[[1]])
)
server = function(input, output, session){
observe({
updateSelectInput(session, "choice",
choices = ListOfItemsWithNames[[input$category]])
})
}
shinyApp(ui, server)
I have a crud database application in Shiny where a user selects an object in a drop down list clicks a button and data is deleted from a mysql database. The user is able to see the data when they click review button using the code DT::dataTableOutput("reviewdata"). When the user decides they wish to delete the data they press a button and the following code executes where my_sel$mydata is a function that re-queries the table to re-populate the dropdown box
#update the selection in the drop down box
updateSelectInput(session, "dropdownbox", choices = my_sel$mydata)
As mentioned when the review button is clicked the data is displayed first on the screen to the user. When they delete it the dropdown box removes the item from the list (as its no longer available to delete)
My question is
Is there a similar feature for tables, so the table should be blank because we have deleted the data so there should be nothing to display
Thanks
Here is an example of how to use a reactive expression in Shiny. This app shows a list of available tables. If the user select one table a couple of buttons appear to Review of Delete the Table.
library(shiny)
library(DT)
ui <- fluidPage(
title = 'Empty Table Example',
fluidRow(
column(4,
uiOutput("dataAvailable_UI"),
uiOutput("controls_UI")
),
column(8, DT::dataTableOutput('reviewdata'))
)
)
server <- function(input, output, session) {
# similate the available tables in DB
availableDatasets <- c("mtcars","iris", "cars", "trees")
dataset <- reactive({
input$deleteBT # to update when data is deleted
# only return the corresponding table if user clicked on Review
if (is.null(input$ReviewBT) || input$ReviewBT == 0)
return(NULL)
dataName <- isolate(input$dropdownbox)
if (is.null(dataName) || !dataName %in% availableDatasets)
return(NULL)
# return the selected data
get(dataName)
})
output$reviewdata = DT::renderDataTable(dataset())
output$dataAvailable_UI <- renderUI({
# no data is selected
selectInput("dropdownbox", "Select a Table",
choices = c("", availableDatasets))
})
output$controls_UI <- renderUI({
# only shows the buttons if a dataset is selected
if (!is.null(input$dropdownbox) && nchar(input$dropdownbox) > 0)
div(
actionButton("ReviewBT", "Review Table"),
actionButton("deleteBT", "Delete Table")
)
})
observeEvent(input$deleteBT,{
# delete data and update the selectInput
dataName <- input$dropdownbox
if (dataName %in% availableDatasets) {
availableDatasets <<- availableDatasets[-match(dataName, availableDatasets)]
updateSelectInput(session, "dropdownbox", choices = c("",availableDatasets))
}
})
}
shinyApp(ui = ui, server = server)
I was suggested using insertUI here and found that it is a great feature. The following code allows to generate control widgets for a single or multiple elements using insertUI, but struck on incorporating removeUI related part. Tried jQuery options to remove inserted UI elements but did not work out. I found the following from Shiny dynamic UI, i.e., Note that, if you are inserting multiple elements in one call, you must wrap them in either a tagList() or a tags$div() (the latter option has the advantage that you can give it an id to make it easier to reference or remove it later on). Also, comments here gave some clues, i.e., tags$div(id="sepal.width.div", sliderInput("sepal.width.slider", ...)), but my lack of HTML/CSS knowledge stops me going forward. I'm looking at (a) wrapping multiple widget element(s) with tags$div() assigning a unique id for each variable, which will be used in removeUI; (b) calling multiple elements via removeUI.
varnames <- names(iris[,1:4]) # names
varinit <- apply(iris[,1:4],2,median) # initival value used in slider
varmin <- apply(iris[,1:4],2,min) # min.
varmax <- apply(iris[,1:4],2,max) # max.
ListofSelVars <<- vector(mode="character")
# control widgets for all elements
allControls <- lapply(setNames(varnames, varnames), function(x) {
sliderInput(x, x, varmin[x], varmax[x], c(varmin[x], varinit[x]),
round = -2)
})
ui <- navbarPage(
tabPanel("Plot",
sidebarLayout(
sidebarPanel(
checkboxGroupInput("ConditioningVariables", "Conditioning variables (choose one or more):",
varnames,inline = TRUE),
# add an action button
actionButton("add", "Update UI elements")
),
mainPanel()
)
)
)
server <- function(input, output, session) {
observeEvent(input$add, {
insertUI(
selector ='#add',
where = "afterEnd",
ui = allControls[setdiff(input$ConditioningVariables,ListofSelVars)]
)
## removeUI related goes, here
## removeUI(selector=paste0())
## setdiff(ListofSelVars,input$ConditioningVariables) gives elements to be removed
## Global variable, keep track of elements that are selected
ListofSelVars <<- input$ConditioningVariables
})
}
shinyApp(ui, server)
Here is the working code. The main issue is with the names here, i.e. Sepal.Width. I wrapped each slider with a div with id like div.Sepal.Width so that it is easier to remove. removeUI requires a jQuery selector, so it appears that something like #div.Sepal.Width would work, except that it does not, because . is itself a jQuery selector that means class, so we need to double escape the .. Of course you can also remove the . when you first create the divs, thus avoiding the trouble...
varnames <- names(iris[,1:4]) # names
varinit <- apply(iris[,1:4],2,median) # initival value used in slider
varmin <- apply(iris[,1:4],2,min) # min.
varmax <- apply(iris[,1:4],2,max) # max.
ListofSelVars <<- vector(mode="character")
# control widgets for all elements
allControls <- lapply(setNames(varnames, varnames), function(x) {
tags$div(id=paste0("div.",x), sliderInput(x, x, varmin[x], varmax[x], c(varmin[x], varinit[x]),
round = -2))
})
ui <- fluidPage(
titlePanel("Dynamic sliders"),
sidebarLayout(
sidebarPanel(
checkboxGroupInput("ConditioningVariables", "Conditioning variables (choose one or more):",
varnames,inline = TRUE),
# add an action button
actionButton("add", "Update UI elements")
),
mainPanel(
uiOutput("plot_out")
)
)
)
server <- function(input, output, session) {
observeEvent(input$add, {
insertUI(
selector ='#add',
where = "afterEnd",
ui = allControls[setdiff(input$ConditioningVariables,ListofSelVars)]
)
ListofRemoval <- setdiff(ListofSelVars,input$ConditioningVariables)
for (item in ListofRemoval) {
item = gsub(".", "\\.", item, fixed=TRUE)
item = paste0("#div\\.", item)
removeUI(item)
}
ListofSelVars <<- input$ConditioningVariables
})
}
shinyApp(ui, server)
I have a shiny application that allows my user to explore a dataset. The idea is that the user explores the dataset, and any interesting things the user finds he will share with his client via email. I don't know in advance how many things the user will find interesting. So, next to each table or chart I have an "add this item to the report" button, which isolates the current view and adds it to a reactiveValues list.
Now, what I want to do is the following:
Loop through all the items in the reactiveValues list,
Generate some explanatory text describing the item (This text should preferably be formatted HTML/markdown, rather than code comments)
Display the item
Capture the output of this loop as HTML
Display this HTML in Shiny as a preview
write this HTML to a file
knitr seems to do exactly the reverse of what I want - where knitr allows me to add interactive shiny components in an otherwise static document, I want to generate HTML in shiny (maybe using knitr, I don't know) based on static values the user has created.
I've constructed a minimum not-working example below to try to indicate what I would like to do. It doesn't work, it's just for demonstration purposes.
ui = shinyUI(fluidPage(
title = "Report generator",
sidebarLayout(
sidebarPanel(textInput("numberinput","Add a number", value = 5),
actionButton("addthischart", "Add the current chart to the report")),
mainPanel(plotOutput("numberplot"),
htmlOutput("report"))
)
))
server = shinyServer(function(input, output, session){
#ensure I can plot
library(ggplot2)
#make a holder for my stored data
values = reactiveValues()
values$Report = list()
#generate the plot
myplot = reactive({
df = data.frame(x = 1:input$numberinput, y = (1:input$numberinput)^2)
p = ggplot(df, aes(x = x, y = y)) + geom_line()
return(p)
})
#display the plot
output$numberplot = renderPlot(myplot())
# when the user clicks a button, add the current plot to the report
observeEvent(input$addthischart,{
chart = isolate(myplot)
isolate(values$Report <- c(values$Report,list(chart)))
})
#make the report
myreport = eventReactive(input$addthischart,{
reporthtml = character()
if(length(values$Report)>0){
for(i in 1:length(values$Report)){
explanatorytext = tags$h3(paste(" Now please direct your attention to plot number",i,"\n"))
chart = values$Report[[i]]()
theplot = HTML(chart) # this does not work - this is the crux of my question - what should i do here?
reporthtml = c(reporthtml, explanatorytext, theplot)
# ideally, at this point, the output would be an HTML file that includes some header text, as well as a plot
# I made this example to show what I hoped would work. Clearly, it does not work. I'm asking for advice on an alternative approach.
}
}
return(reporthtml)
})
# display the report
output$report = renderUI({
myreport()
})
})
runApp(list(ui = ui, server = server))
You could capture the HTML of your page using html2canvas and then save the captured portion of the DOM as a image using this answer, this way your client can embed this in any HTML document without worrying about the origin of the page contents