I have started to use shinyLP to make html elements and also make network diagrams using visNetwork. I noticed that visNetwork displays fine when placed in either a well panel or no panel at all. However, it does not display when placed in a panel div, either with shinyLP or through raw HTML. Just to be brief, I am only showing the code differences between not being in a panel and being in a panel div. Does anyone know of a way to make visNetwork appear in this specific container type? I want to use this container type because I want to keep my CSS the way it is and not change things just for this one container. Anyone know the cause of this issue?
This works when visNetworkOutput is not in a panel
library(shinyLP)
library(visNetwork)
ui <- fluidPage(
visNetworkOutput("network")
)
server <- function(input, output) {
output$network <- renderVisNetwork({
# minimal example
nodes <- data.frame(id = 1:3)
edges <- data.frame(from = c(1,2), to = c(1,3))
visNetwork(nodes, edges)
})
}
shinyApp(ui, server)
This fails to display when visNetworkOutput is in a panel
ui <- fluidPage(
panel_div("default", "", visNetworkOutput("network"))
)
server <- function(input, output) {
output$network <- renderVisNetwork({
# minimal example
nodes <- data.frame(id = 1:3)
edges <- data.frame(from = c(1,2), to = c(1,3))
visNetwork(nodes, edges)
})
}
shinyApp(ui, server)
It is a bug in shinyJS version 1.1.0. I found a (awkward) workaround and posted it as a bug in htmlwidgets and Joe Cheng saw it and give me a fix it in like 10 minutes. Awesome...
Here is the code with a better workaround (a new definition of pandel_div):
library(shiny)
library(shinyLP)
library(visNetwork)
# override the currently broken definition in shinyLP version 1.1.0
panel_div <- function(class_type, panel_title, content) {
div(class = sprintf("panel panel-%s", class_type),
div(class = "panel-heading",
h3(class = "panel-title", panel_title)
),
div(class = "panel-body", content)
)
}
ui <- fluidPage(
panel_div("default", "panel1",visNetworkOutput("network") )
)
server <- function(input, output) {
output$network <- renderVisNetwork({
# minimal network
nodes <- data.frame(id = 1:3)
edges <- data.frame(from = c(1,2), to = c(1,3))
visNetwork(nodes,edges)
})
}
shinyApp(ui, server)
And this is what that looks like:
update: Tried with another htmlwidget package (sigma) and got the same behavior. So filing this as an htmlwidget bug: panel_div htmlwidget issue
update: JC identified it as a shinyJS bug. Changed my solution above to reflect his suggestion.
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")
)
How would one go about setting the background color of multiple fileInput() progress bars in one fluidRow(). This is similar to the answer given here, however, this time it's just for multiple fileInput() objects. I want to do something like snippet below, but when I run this, instead of having the three individual colors, they are all the same color (#cfa646). (Disclaimer, my html knowledge is non-existent, so I just wanted to demonstrate the concept with the given snippet.)
library(shiny)
ui <- fluidPage(
fluidRow(column(4,
tags$head(tags$style(".progress-bar{background-color:#3c763d;}")),
fileInput("dataUpload_1","Label 1",width = "400px")),
column(4,
tags$head(tags$style(".progress-bar{background-color:#bf37a4;}")),
fileInput("dataUpload_2","Label 2",width = "400px")),
column(4,
tags$head(tags$style(".progress-bar{background-color:#cfa646;}")),
fileInput("dataUpload_3","Label 3",width = "400px")))
)
server <- function(input, output){
}
shinyApp(ui=ui, server=server)
Nice try, you are close, but as you mentioned, this does require some advanced CSS knowledge. Here is how:
:nth-of-type() selector
library(shiny)
ui <- fluidPage(
tags$head(tags$style(
'
.myfiles .col-sm-4:nth-of-type(1) .progress-bar {background-color:#3c763d;}
.myfiles .col-sm-4:nth-of-type(2) .progress-bar {background-color:#bf37a4;}
.myfiles .col-sm-4:nth-of-type(3) .progress-bar {background-color:#cfa646;}
'
)),
fluidRow(
class = "myfiles",
column(4, fileInput("dataUpload_1","Label 1",width = "400px")),
column(4, fileInput("dataUpload_2","Label 2",width = "400px")),
column(4, fileInput("dataUpload_3","Label 3",width = "400px"))
)
)
server <- function(input, output){}
shinyApp(ui=ui, server=server)
I have created an app that uploads an image and displays it but noticed that it wasn't working properly anymore. When a second image is uploaded the UI doesn't refresh and only the original image is shown. It seems that tags$img is behaving different than it did before. The idea of the app is users are able to upload an image, confirm it is the correct one and then do some things to the image. It doesn't make sense for the user to upload a new image and still have the previous image displaying.
I noticed that when I use tags$iframe it works as expected, which is that when a 2nd image is uploaded the 2nd image is then displayed in the app. I noticed if I use tags$iframe and tags$img to display the same item it works as expected where the 2nd item uploaded is displayed.
This example only uses tags$img, if you upload an image then it displays it and when you upload a 2nd image only the first image is displayed. The UI doesn't seem to update to display the 2nd image.
library(shiny)
options(shiny.maxRequestSize=12*1024^2)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
uiOutput("ui_file_input")
),
mainPanel(
uiOutput("ui_upload")
)
)
)
server <- function(input, output) {
rv <- reactiveValues(
upload_state = NULL,
img = NULL
)
output$ui_file_input <- renderUI({
fileInput("upload",
label = NULL,
accept = c(".jpg", ".jpeg")
)
})
observeEvent(input$upload, {
rv$upload_state <- "upload"
})
observe({
req(rv$upload_state)
test_file <- readBin(con = input$upload$datapath, what = "raw", n = input$upload$size)
writeBin(test_file, "www/fieldphoto.jpeg")
addResourcePath("www", "www")
})
output$ui_upload <- renderUI({
req(input$upload)
tags$img(src = "www/fieldphoto.jpeg", width = "300px")
})
}
shinyApp(ui = ui, server = server)
When I add a 2nd output that is linked to tags$iframe it behaves as expected. An image is uploaded and displays as normal and when a 2nd image is upload it updates to display the 2nd image in both the tags$img and tags$iframe outputs.
library(shiny)
options(shiny.maxRequestSize=12*1024^2)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
uiOutput("ui_file_input")
),
mainPanel(
uiOutput("ui_upload"),
uiOutput("ui_upload2")
)
)
)
server <- function(input, output) {
rv <- reactiveValues(
upload_state = NULL,
img = NULL
)
output$ui_file_input <- renderUI({
fileInput("upload",
label = NULL,
accept = c(".jpg", ".jpeg")
)
})
observeEvent(input$upload, {
rv$upload_state <- "upload"
})
observe({
req(rv$upload_state)
test_file <- readBin(
con = input$upload$datapath, what = "raw", n = input$upload$size
)
writeBin(test_file, "www/fieldphoto.jpeg")
addResourcePath("www", "www")
})
# this displays the uploaded card
output$ui_upload <- renderUI({
req(input$upload)
tags$img(src = "www/fieldphoto.jpeg", width = "300px")
})
output$ui_upload2 <- renderUI({
req(input$upload)
tags$iframe(src = "www/fieldphoto.jpeg", width = "300px")
})
}
shinyApp(ui = ui, server = server)
This was working as expected in the past, not sure the exact timeline but sometime with the last few months I think. The examples above are a simple reprex as the issue is part of a much larger Shiny app. I don't understand why tags$iframe causes the UI to update but not tags$img. The correct files are appearing in the www folder. It seems to be a problem with what is being displayed.
I would like to figure out how to use renderImage in Shiny with online located images (URL), and make the image clickable, so that I can hang an observeEvent() to it. I can do both these things, but not together. My approach to render an URL doesn't work with clicking, and the local image version that allows clicking doesn't render URL images.
Here are the two half working versions:
I took some inspiration from here for the
Clickable
library(shiny)
ui <- fluidPage(
imageOutput("image1", click = "MyImage")
)
server <- function(input, output, session) {
setwd(Set the directory of the image in here) #### modify to test
output$image1 <- renderImage({
list(
src = "YOUR_IMAGE.png", #### modify to test
contentType = "image/png",
width = 90,
height = 78,
alt = "This is alternate text"
)}, deleteFile = FALSE)
observeEvent(input$MyImage, { print("Hey there")})
}
shinyApp(ui, server)
if I put an URL in (and remove the deleteFile = FALSE) it shows an empty square. still clickable though.
URLable by using renderUI()
library(shiny)
ui <- fluidPage(
uiOutput("image1", click = "MyImage")
)
server <- function(input, output, session) {
setwd(AppDir)
output$image1<- renderUI({
imgurl2 <- "https://www.rstudio.com/wp-content/uploads/2014/07/RStudio-Logo-Blue-Gradient.png"
tags$img(src=imgurl2, width = 200, height = 100)
})
observeEvent(input$MyImage, { print("Hey there")})
}
shinyApp(ui, server)
shows the image, but the image isn't clickable anymore.
If I change renderUI() and uiOuput() into renderImage() and imageOutput() in example 2, it throws a 'invalid file argument' error.
htmlOuput with renderText
I also tried this version that was in the other SO post, but again, not clickable. This approach is based on the answer on this link
library(shiny)
ui <- fluidPage(
htmlOutput("image1", click = "MyImage")
)
server <- function(input, output, session) {
setwd(AppDir)
imgurl2 <- "https://www.rstudio.com/wp-content/uploads/2014/07/RStudio-Logo-Blue-Gradient.png"
output$image1<- renderText({c('<img src="',imgurl2,'">')})
observeEvent(input$MyImage, { print("Hey there")})
}
shinyApp(ui, server)
I want to move away from local images because that seems to make more sense once we publish the Shiny App. So therefore really in need of a solution that allows rendering of URL images and have them being clickable. Bonus points if somebody can explain why the click = only works local files with imageOutput.
One alternative is to use the onclick function from shinyjs library. It allows you to include click events to specific html elements (targeted by id).
Here's the documentation
In your case the code would look like this:
library(shiny)
library(shinyjs)
ui <- fluidPage(
useShinyjs(),
uiOutput("image1", click = "MyImage")
)
server <- function(input, output, session) {
output$image1<- renderUI({
imgurl2 <- "https://www.rstudio.com/wp-content/uploads/2014/07/RStudio-Logo-Blue-Gradient.png"
div(id = "myImage",
tags$img(src = imgurl2, width = 200, height = 100)
)
})
onclick(
myImage,
{
# Do whatever you want!
print("Hey there")
}
)
}
shinyApp(ui, server)
What about transforming image from url into a ggplot as:
library(magick)
library(cowplot)
library(gtools)
library(shiny)
ui <- fluidPage(
uiOutput("myplotoutput"),
uiOutput("text")
)
server <- function(input, output, session) {
output$myplotoutput = renderUI( {
plotOutput("urlimage", click=clickOpts(id="myclick") )
} )
output$text=renderUI({
validate(
need(try(!invalid(input$myclick)), "Text will appear here")
)
textOutput("reactext")
})
output$reactext<-renderText(mytext$texto)
output$urlimage<- renderPlot({
g<- ggdraw() + draw_image("https://jeroen.github.io/images/frink.png")
g
})
mytext<-reactiveValues()
observeEvent(input$myclick, {
mytext$texto<-"Hey there"
})
}
shinyApp(ui, server)
Strangely enough I am getting a scrollbar on the right side of the page when I run the below shiny app:
shinyUI(
fluidPage(
tabsetPanel(
tabPanel("Plot", htmlOutput("test")),
tabPanel("Summary"),
tabPanel("Table")
)
)
)
library(googleVis)
library(shiny)
shinyServer(function(input, output, session) {
output$test <- renderGvis({
gvisBubbleChart(Fruits, idvar="Fruit",
xvar="Sales", yvar="Expenses",
colorvar="Year", sizevar="Profit",
options=list(
hAxis='{minValue:75, maxValue:125}',
vAxis='{minValue:0, maxValue:250}'
,height=600,width=600)
)
})
})
If I change from tabsetPanel layout to a pageWithSidebar layout the plot appears normally without the scrollbars.
On a seperate note, if I do not specify the width and height in the options list I am getting two scrollbars, one vertical and one horizontal.
Is it possible to use googleVis charts within tabsetPanels without the scrollbars?
You can set the overflow to hidden by adding a style argument to the tabPanel call:
library(googleVis)
library(shiny)
runApp(
list(ui = fluidPage(
tabsetPanel(
tabPanel("Plot", htmlOutput("test"), style = "overflow:hidden;"),
tabPanel("Summary"),
tabPanel("Table")
)
)
, server = function(input, output, session) {
output$test <- renderGvis({
gvisBubbleChart(Fruits, idvar="Fruit",
xvar="Sales", yvar="Expenses",
colorvar="Year", sizevar="Profit",
options=list(
hAxis='{minValue:75, maxValue:125}',
vAxis='{minValue:0, maxValue:250}'
,height=600,width=600)
)
})
})
)