R Shiny data table images not updating when running in browser - r

I'm creating a Shiny app which displays images and text in a data table. This table will need to update depending on the user's input. When I run the app in a window the table updates as expected. However, when I run it in a browser the text updates but the image does not. How do I make it work in a browser?
EDIT: For clarity, the below example is just to reproduce the issue. The real app could display any number of different pictures, which aren't saved locally until the user makes a selection (they're pulled from a database). I was hoping to avoid having different filenames because I could potentially end up with hundreds of thousands of pictures saved locally, but if that's the only solution then I will have to cleanup the folder periodically
Reproducible example (requires 2 local images)
library(shiny)
library(imager)
library(DT)
# Define UI
ui <- fluidPage(
# Application title
titlePanel("Tables to export"),
sidebarLayout(
sidebarPanel(
actionButton("pic1","Pic1"),
actionButton("pic2","Pic2")
),
# Show tables
mainPanel(
fluidRow(
dataTableOutput('tab1')
)
)
)
)
# Define server logic
server <- function(input, output) {
observeEvent(input$pic1, {
pic <- load.image("www/pic1.png")
save.image(pic,"www/picToShow.png")
tab1 <- datatable(t(data.frame("Pic"='<img src="picToShow.png" width=150 height=100>',x1=1,x2=2,x3=3,row.names="p1")),
escape = F, options = list(dom = 't',pageLength = 20))
output$tab1 <- renderDataTable(tab1)
})
observeEvent(input$pic2, {
pic <- load.image("www/pic2.png")
save.image(pic,"www/picToShow.png")
tab1 <- datatable(t(data.frame("Pic"='<img src="picToShow.png" width=150 height=100>',x1=4,x2=5,x3=6,row.names="p1")),
escape = F, options = list(dom = 't',pageLength = 20))
output$tab1 <- renderDataTable(tab1)
})
}
# Run the application
shinyApp(ui = ui, server = server)
Expected behaviour (behaviour in window)
Behaviour in the browser

I agree with #MrFlick's comment. Why do you load both images and resave them with the same name? The browser will think that it knows the image already and will re-use the already loaded image.
Why not just include pic1.png and pic2.png directly?
server <- function(input, output) {
observeEvent(input$pic1, {
tab1 <- datatable(t(data.frame("Pic"='<img src="pic1.png" width=150 height=100>',x1=1,x2=2,x3=3,row.names="p1")),
escape = F, options = list(dom = 't',pageLength = 20))
output$tab1 <- renderDataTable(tab1)
})
observeEvent(input$pic2, {
tab1 <- datatable(t(data.frame("Pic"='<img src="pic2.png" width=150 height=100>',x1=4,x2=5,x3=6,row.names="p1")),
escape = F, options = list(dom = 't',pageLength = 20))
output$tab1 <- renderDataTable(tab1)
})
}

library(shiny)
library(imager)
library(DT)
# Define UI
ui <- fluidPage(
# Application title
titlePanel("Tables to export"),
sidebarLayout(
sidebarPanel(
actionButton("pic1","Pic1"),
actionButton("pic2","Pic2")
),
# Show tables
mainPanel(
fluidRow(
DT::dataTableOutput('tab1')
)
)
)
)
# Define server logic
server <- function(input, output) {
vals = reactiveValues(pic1 = 0, pic2 = 0)
observeEvent(input$pic1, {
vals$pic1 <- 1
vals$pic2 <- 0
})
observeEvent(input$pic2, {
print(vals$pic1)
print(vals$pic2)
vals$pic1 <- 0
vals$pic2 <- 1
})
dynamicdf <- reactive({
if(vals$pic1 == 1) {
df <- data.frame(
pic = c('<img src="http://flaglane.com/download/american-flag/american-flag-large.png" height="52"></img>'),
x1 = c(1),
x2 = c(2),
x3 = c(3)
)
} else {
df <- data.frame(
pic = c('<img src="img2.jpg" width=150 height=100></img>'),
x1 = c(4),
x2 = c(5),
x3 = c(6)
)
}
print(df)
return(df)
})
output$tab1 <- DT::renderDataTable({
DT::datatable(dynamicdf(), escape = FALSE)
})
}
# Run the application
shinyApp(ui = ui, server = server)
In Shiny Apps you do not load or saves images. You display them by using a path to the folder, where your pictures are stored. This can be a Link on the internet or a path on your machine.
Do it like this. I use a reactiveValue to track the last click of your button. This is a good solution if you have a large number of pictures you may want to render. (I adopted that style from the modern JS Library ReactJS) Based on the state you display your pictures. Do NOT use the www path, this is already expected by shiny. Leave it as in the example2 in the App.
For me it also only worked with the escape = FALSE parameter in the App. Try that if it does not work without it.

Related

Is there a way to just read an edited DT?

I'm trying to make an app where users can edit some tables and run a calculation, and using DT. Is there a way to just read in what's currently in a DT table? This would simplify things a lot for me. All the solutions I've been able to find involve detecting when the table is edited, and then updating the data accordingly. This seems clunky and also might cause problems for my use case later.
Here's an example: after editing the data zTable, I'd like something that just returns what is now in zTable after clicking the calculate button aside from just watching every edit and updating z$data.
library(shiny)
library(DT)
ui <- fluidPage(
DT::dataTableOutput("zTable"),
actionButton("calcButton","Calculate!")
)
server <- function(input, output) {
z<-reactiveValues(data={data.frame(x=c(0,1),
y=c(0,1))
})
output$zTable <- DT::renderDT(z$data,editable=T)
observeEvent(input$calcButton,{
print(z$data)
})
observeEvent(input$zTable_cell_edit, {
info = input$zTable_cell_edit
z$data[as.numeric(info$row),as.numeric(info$col)] <- as.numeric(info$value)
})
}
shinyApp(ui = ui, server = server)
You can do as follows. There's a problem with the current version of DT: when you edit a numeric cell, the new value is stored as a string instead of a number. I've just done a pull request which fixes this issue. With the next version of DT the .map(Number) in the JavaScript callback will not be needed anymore. If you are ok to adopt my solution, tell me if you want to use it with non-numeric cells, and I'll have to improve the code in order to handle this situation. Or you can install my fork of DT in which I fixed the issue: remotes::install_github("stla/DT#numericvalue").
library(shiny)
library(DT)
callback <- c(
'$("#show").on("click", function(){',
' var headers = Array.from(table.columns().header()).map(x => x.innerText);',
' var arrayOfColumns = Array.from(table.columns().data());',
' var rownames = arrayOfColumns[0]',
' headers.shift(); arrayOfColumns.shift();',
' var entries = headers.map((h, i) => [h, arrayOfColumns[i].map(Number)]);',
' var columns = Object.fromEntries(entries);',
' Shiny.setInputValue(',
' "tabledata", {rownames: rownames, columns: columns}, {priority: "event"}',
' );',
'});'
)
ui <- fluidPage(
br(),
DTOutput("dtable"),
br(),
tags$h3("Edit a cell and click"),
actionButton("show", "Print data")
)
server <- function(input, output) {
dat <- data.frame(x=c(0,1),
y=c(0,1))
output[["dtable"]] <- renderDT({
datatable(
dat,
editable = TRUE,
callback = JS(callback)
)
}, server = FALSE)
observeEvent(input[["tabledata"]], {
columns <- lapply(input[["tabledata"]][["columns"]], unlist)
df <- as.data.frame(columns)
rownames(df) <- input[["tabledata"]][["rownames"]]
print(df)
})
}
shinyApp(ui = ui, server = server)
You can rely on JavaScript to get the data via the DataTable api:
library(shiny)
library(DT)
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
DT::dataTableOutput("zTable"),
actionButton("calcButton","Calculate!")
)
server <- function(input, output) {
z <- reactiveValues(data = data.frame(x = 0:1, y = 0:1))
output$zTable <- renderDT(z$data, editable = TRUE)
observeEvent(input$calcButton, {
runjs('Shiny.setInputValue("mydata", $("#zTable table").DataTable().rows().data())')
})
observeEvent(input$mydata, {
dat <- req(input$mydata)
## remove chunk from .data()
dat[c("length", "selector", "ajax", "context")] <- NULL
print(do.call(rbind, dat))
})
}
shinyApp(ui = ui, server = server)
However, as you need to some data wrangling to back-transfrom the data, I am not sure whether this is eventually such a good idea.
What is your general issue with the _cell_edit approach? (which I would prefer because no need to additional data wrangling other than storing it in the right spot?

Dataframe - R - Shiny

i have a question regarding Shiny and the usage of Data frames.
I think i understood that i need to create isolated or reactive environmentes to interact with, but if i try to work with the Dataframe i get an error message:
Error in pfData: konnte Funktion "pfData" nicht finden
i tried to manipulate the dataframe by this code:
server <- function(input, output) {
observeEvent(input$go,
{
pf_name <- reactive({input$pfID})
pf_date <- reactive({input$pfDate})
if (pf_name()!="please select a PF") {
pfData <- reactive(read.csv(file =paste(pf_name(),".csv",sep=""),sep=";",dec=","))
MDur <- pfData()[1,15]
pfData <- pfData()[3:nrow(pfData()),]
Total = sum(pfData()$Eco.Exp...Value.long)
}
})
}
If i manipulate my Dataframe in the console it works just fine:
pfData <- pfData[3:nrow(pfData),]
Total = sum(pfData$Eco.Exp...Value.long)
Assets = sum(as.numeric(gsub(",",".",gsub(".","",pfData$Value,fixed=TRUE),fixed=TRUE)))
pfData$Exposure <- with(pfData, Eco.Exp...Value.long /Total)
can you help me?
Edit:
library(shiny)
ui <- fluidPage(
fluidRow(
column(6, offset =3,
wellPanel(
"Choose Mandate and Date",
fluidRow(
column(4,selectInput("pfID",label = "",
choices = list("please select a PF","GF25",
"FPM"),
selected = "please select a PF") ),
column(4, dateInput("pfDate",label="",value = Sys.Date()) ),
column(2, actionButton("go","Submit")),column(2,textOutput("selected_var"))
)
)
)
)
)
# Define server logic ----
server <- function(input, output) {
pfDataReactive <- reactive({
input$go
if (pf_name()!="please select a PF") {
pfData <- read.csv(file =paste(pf_name(),".csv",sep=""),sep=";",dec=",")
MDur <- pfData[1,15]
pfData <- pfData[3:nrow(pfData),]
Total = sum(pfData$Eco.Exp...Value.long)
Assets = sum(as.numeric(gsub(",",".",gsub(".","",pfData$Value,fixed=TRUE),fixed=TRUE)))
pfData$Exposure <- with(pfData, Eco.Exp...Value.long /Total)
pfData
output$selected_var <- renderText({paste(MDur)})
}
})
}
# Run the app ----
shinyApp(ui = ui, server = server)
Thank you
Stefan
Without a working example, it's imposible to be sure what you're trying to do, but it sounds like you need a reactive rather than using observeEvent.
Try something like
pfDataReactive <- reactive({
input$go
pfData <- read.csv(file =paste(pf_name(),".csv",sep=""),sep=";",dec=",")
Total = sum(pfData$Eco.Exp...Value.long)
Assets = sum(as.numeric(gsub(",",".",gsub(".","",pfData$Value,fixed=TRUE),fixed=TRUE)))
pfData$Exposure <- with(pfData, Eco.Exp...Value.long /Total)
pfData
})
And then use pfDataReactive() in your Shiny app's server function wherever you would refer to pfData in your console code.
The standalone reference to input$go ensures the reactive will update whenever input$go changes/is clicked/etc.
Update
There are still significant issues with your code. You've added an assignment to an output object as the last line of the reactive I gave you, so the reactive always returns NULL. That's not helpful and is one of the reasons why it "doesn't active at all"...
Second, you test for the existence of an reactive/function called pf_name when the relevant input object appears to be input$pfID. That's another reason why the reactive is never updated.
Note the change to the definition of input$pfID that I've made to improve the readability of the pfDataReactive object. (This change also probably means that you can do away with input$go entirely.)
As you say, I don't have access to your csv file, so I can't test your code completely. I've modified the body of the pfDataReactive to simply return the mtcars dataset as a string. I've also edited the code I've commented out to hopefully run correctly when you use it with the real csv file.
This code appears to give the behaviour you want,. Though, if I may make a subjective comment, I think the layout of your GUI is appaling. ;=)
library(shiny)
ui <- fluidPage(
fluidRow(
column(6, offset =3,
wellPanel(
"Choose Mandate and Date",
fluidRow(
column(4,selectInput("pfID",label = "",
# Modified to that "Pleaseselect a PF" returns NULL
choices = list("please select a PF"="","GF25", "FPM"),
selected = "please select a PF") ),
column(4, dateInput("pfDate",label="",value = Sys.Date()) ),
column(2, actionButton("go","Submit")),column(2,textOutput("selected_var"))
)
)
)
)
)
# Define server logic ----
server <- function(input, output) {
pfDataReactive <- reactive({
# Don't do anything until we have a PF csv file
req(input$pfID)
input$go
# Note the change to the creation of the file name
# pfData <- read.csv(file =paste(input$pfID,".csv",sep=""),sep=";",dec=",")
# pfData <- pfData[3:nrow(pfData),]
# Total = sum(pfData$Eco.Exp...Value.long)
# Assets = sum(as.numeric(gsub(",",".",gsub(".","",pfData$Value,fixed=TRUE),fixed=TRUE)))
# pfData$Exposure <- with(pfData, Eco.Exp...Value.long /Total)
# MDur <- pfData[1,15]
# If you want to print MDur in the selected_var output, MDur should be the retrun value from this reactive
# MDur
mtcars
})
output$selected_var <- renderText({
print("Yep!")
as.character(pfDataReactive())
})
}
# Run the app ----
shinyApp(ui = ui, server = server)
Next time, please, please, make more effort to provide a MWE. This post may help.
This is a good introduction to Shiny.

Download a table created in Shiny

I need to give users a set of 60 observations. I have a master table that I want to to subset these 60 observations from. So, (1) I host the master table as a published csv file on google drive. (2) Write a shiny code to subset 60 values in R studio. The user will have to enter a group ID that I use as set.seed and ensure that the user sees the same subset every time he / she attempts to get the 60 observations. And, it also helps me keep track of the observations that the user has.
The code works fine and I am able to show the subset table. But, I am not able to get the download to work. I saw a post that says renderTable create an HTML table that cannot be downloaded and I should create the table outside it. I tried using reactive to do this, but it did not work and kept giving various errors. For example:
"cannot coerce class ‘c("reactiveExpr", "reactive", "function")’ to a data.frame"
Will appreciate any help of this - even if someone can please point out to what I should read and try to make this work.
library(shiny)
db1 <- read.csv("https://docs.google.com/spreadsheets/d/e/2PACX-1vS94xYLix6bDUNNXAgHejdQ-CcWi-G4t25nfxuhRZF57TloC8NwVgnperBB9-U-IuDvMcOnvdc9iavU/pub?gid=0&single=true&output=csv")
# Define UI
ui <- fluidPage(
# Application title
titlePanel("MnM"),
# Sidebar to take input of group ID
sidebarLayout(
sidebarPanel(
numericInput("seed","Group ID:", value = 100, min = 100, max = 999),
downloadButton("downloadData", "Download")
),
# Show the table
mainPanel(
tableOutput("table")
)
)
)
# Define server logic for the table
server <- function(input, output) {
output$table <- renderTable({
set.seed(input$seed)
zz <- sample(1:nrow(db1), size = 60, replace = TRUE)
data.frame(db1[zz,])})
output$downloadData <- downloadHandler(
filename = "test.csv",
content = function(file) {
write.csv(output$table, file, row.names = FALSE)
}
)
}
# Run the application
shinyApp(ui = ui, server = server)
Create your table once, and then use it in your renderTable and downloadHandler. Create it as a reactive, so its available everywhere.
Note that downloadHandler doesn't work in RStudio's preview, view it in a browser instead. There is a button labelled 'Open in Browser' that will do this.
Here is your code with that applied:
library(shiny)
db1 <- read.csv("https://docs.google.com/spreadsheets/d/e/2PACX-1vS94xYLix6bDUNNXAgHejdQ-CcWi-G4t25nfxuhRZF57TloC8NwVgnperBB9-U-IuDvMcOnvdc9iavU/pub?gid=0&single=true&output=csv")
# Define UI
ui <- fluidPage(
# Application title
titlePanel("MnM"),
# Sidebar to take input of group ID
sidebarLayout(
sidebarPanel(
numericInput("seed","Group ID:", value = 100, min = 100, max = 999),
downloadButton("downloadData", "Download")
),
# Show the table
mainPanel(
tableOutput("table")
)
)
)
# Define server logic for the table
server <- function(input, output) {
#Create dataframe
mytable <- reactive({
set.seed(input$seed)
zz <- sample(1:nrow(db1), size = 60, replace = TRUE)
data.frame(db1[zz,])
})
#Display dataframe in table
output$table <- renderTable({
mytable()
})
#Download dataframe
output$downloadData <- downloadHandler(
filename = "test.csv",
content = function(file) {
write.csv(mytable(), file, row.names = FALSE)
}
)
}
# Run the application
shinyApp(ui = ui, server = server)

How to block or restrict access when a user is already using a Shiny app

I have a Shiny app that uses the Ace editor. Now I would like to have it so that when a first user is using this editor, other users cannot edit the document, but only view the document.
How can this be realized?
The code is:
library(shiny)
library(shinyAce)
library(stringi)
ui <- fluidPage(
br(),
uiOutput("aceEditor1"),
downloadButton('save1', 'Save editor content')
)
server <- function(input, output, session)
{
output$aceEditor1 <- renderUI(
{
aceEditor(outputId = "ace1",
value = paste(stri_rand_lipsum(3), collapse="\n\n"),
mode = "r",
height = "500px",
fontSize = 17,
theme = "chrome",
wordWrap = TRUE)
})
output$save1 <- downloadHandler (
filename = function()
{
"result.txt"
},
content = function(file)
{
write.table(x = input$ace1, file = file, sep = "", row.names = FALSE, col.names = FALSE, quote = FALSE)
}
)
}
shinyApp(ui = ui, server = server)
You can implement this by introducing keys. Essentially, we create a global key variable which is visible to all sessions. When a session starts it takes the key and sets the global variable to be unavailable.
When a new session connects, and attempts to get the key, but it is unavailable.
Within the server function we can check before executing a "critical section" piece of code.
This is essentially the basics of how semiphore flag work.
Finally, when the session ends for the first session, it returns the key to the global variable.
We can also go a step further and use invalidateLater() to periodically check if the key is available.
To run the dummy example below first run this,
write_csv(mtcars,"~/Desktop/data.csv")
And the app is the following:
library(shiny)
key_available <- TRUE
ui <- fluidPage(
br(),
textInput(inputId = "text_input","Text Input"),
actionButton(inputId = "add_col","Add Column"),
dataTableOutput("table_output"),
downloadButton('save1', 'Save editor content')
)
server <- function(input, output, session){
onSessionEnded(function() key_available <<- TRUE)
# Session starts, Read data in
have_key <- FALSE
observe({
invalidateLater(1000)
if(key_available){
key_available <<- FALSE
have_key <<- TRUE
}
})
data_reactive <- eventReactive(c(input$add_col),{
data <- read_csv("~/Desktop/data.csv")
if(have_key){
data[[input$text_input]] <- NA
write_csv(data,"~/Desktop/data.csv")
}
return(data)
})
output$table_output <- renderDataTable({
req(data_reactive())
data_reactive()
})
}
shinyApp(ui = ui, server = server)
Open the first browser window, add a column name in the text box and click on Add Column.
You will notice the column is added. You can continue to do this as this session has the key.
Opening a new browser window simultaneously, and trying to do the above will be unsuccessful. However, if you close the first browser window, you will be able to now edit on the second browser window.

shiny dt bookmarking state

Dear R Shiny community,
I am trying to create a bookmarking state for Shiny app where I render table with DT package. For example, in the app pasted below I want to type some text in the search field which subsets data and bookmark that state, i.e. get a URL that I can share. Another user can use the URL and see the same subset of the table without a need to type the text again into the search field. With the code below I was expecting to see the "Bookmark" button with the option 1 code or a dynamic URL with option 2, but unfortunately it does not work as expected. Does anyone know how to make a bookmarking state when rendering a table with DT?
Here is the reproducible code:
Option 1
library(shiny)
ui <- function(request) {
fluidPage(DT::dataTableOutput('tbl'))
}
server = function(input, output) {
output$tbl = DT::renderDataTable(
iris, options = list(lengthChange = FALSE)
)
}
shinyApp(ui, server, enableBookmarking = "url")
Option 2
library(shiny)
ui <- function(request) {
fluidPage(DT::dataTableOutput('tbl'))
}
server = function(input, output) {
observe({
output$tbl = DT::renderDataTable(
iris, options = list(lengthChange = FALSE)
)
})
onBookmarked(function(url) {
updateQueryString(url)
})
}
shinyApp(ui, server, enableBookmarking = "url")
Thank you so much for your time and help!
Based on the following discussion https://groups.google.com/forum/#!topic/shiny-discuss/DvWhqwZ8OKw I was able to find an answer.
I was able to modify the option 1 and here is the minimal reproducible app that works. Just type a string in a global search field, click on the bookmark button on the bottom, copy the url and share.
library(DT)
library(shiny)
ui <- function(request) {
fluidPage(
DT::dataTableOutput('tbl')
, bookmarkButton(label = "Bookmark", title = "Link to this view")
)
}
server = function(input, output) {
# exclude some values query variables from url
setBookmarkExclude(names = c("resTable_rows_all",
"resTable_cell_clicked"))
# proxy for table manipulations
tbl_proxy <- dataTableProxy("tbl")
# restore table selection and search
onRestored(function(state) {
# req(state$input$resTable_search)
DT::updateSearch(tbl_proxy,
keywords = list(global = state$input$tbl_search))
})
output$tbl <- renderDataTable(iris)
}
shinyApp(ui, server, enableBookmarking = "url")

Resources