[SOLVED]
I am trying to do a ShinyApp using some examples from the internet.
As part of my app I want to plot a Sankey Diagram, however, I have been finding a problem.
My app has a navbarPage structure and uses the example from https://github.com/jienagu/D3_folded_charts as one of the primary tabs. After some tests, I figured out that the sankeyNetwork was in conflict with the code part of the bar graph in the example above (specifically with this part: lines 147-149):
output$airbar = renderD3({ bar_graphD3() })
This is the code I am using to render the Sankey diagram:
output$diagram <- networkD3::renderSankeyNetwork({
networkD3::sankeyNetwork(Links = dispersores_df,
Nodes = nodes,
Source = "IDsource",
Target = "IDtarget",
Value = "value",
fontSize = 20,
NodeID = "name",
sinksRight=FALSE)
})
Since this bar graph function is very important for my app, I can't remove it.
Also, due to the fact that the console doesn't pop up any error message, I realized the sankeyNetwork was been rendered. So, I changed my app structure to the fluidPage() and I found the Sankey graph was there (but it was not interactive) as you can see in the figure below.
Sankey visualized in the fluidPage() structure
After changing back to navbarPage() I inspected the tab the Sankey was, and it looks like it is there but invisible.
Sankey invisible in the navbarPage() structure
I found a similar report here sankeyNetwork through renderUI disappears when applying JScode to remove viewbox with htmlwidgets::onRender() but its solution didn't work for me.
Does anyone have any idea or clues that could help me?
Thanks
Full code here:
# library ------------------------------------------------------------------
if(!require("devtools")) install.packages("devtools", dependencies = TRUE)
if(!require("shiny")) install.packages("shiny", dependencies = TRUE)
if(!require("janitor")) install.packages("janitor", dependencies = TRUE)
if(!require("tidyverse")) install.packages("tidyverse", dependencies = TRUE)
if(!require("purrr")) install.packages("purrr", dependencies = TRUE)
if(!require("rlang")) install.packages("rlang", dependencies = TRUE)
#if(!require("stringr")) install.packages("stringr", dependencies = TRUE)
if(!require("noteMD")) devtools::install_github("jienagu/noteMD")
#if(!require("DT")) install.packages("DT", dependencies = TRUE)
if(!require("r2d3")) install.packages("r2d3", dependencies = TRUE)
if(!require("webshot")) install.packages("webshot", dependencies = TRUE)
if(!require("htmlwidgets")) install.packages("htmlwidgets", dependencies = TRUE)
#if(!require("memor")) install.packages("memor", dependencies = TRUE)
if(!require("shinyjs")) install.packages("shinyjs", dependencies = TRUE)
if(!require("nivopie")) devtools::install_github("jienagu/nivopie")
#if(!require("shinythemes")) install.packages("shinythemes", dependencies = TRUE)
#webshot::install_phantomjs()
#tinytex::install_tinytex()
if(!require("leaflet")) install.packages("leaflet", dependencies = TRUE)
#if(!require("performance")) install.packages("performance", dependencies = TRUE)
if(!require("shinyWidgets")) install.packages("shinyWidgets", dependencies = TRUE)
#if(!require("rmarkdown")) install.packages("rmarkdown", dependencies = TRUE)
if(!require("networkD3")) devtools::install_github("christophergandrud/networkD3")
#if(!require("stats")) install.packages("stats", dependencies = TRUE)
#if(!require("stargazer")) install.packages("stargazer", dependencies = TRUE)
#if(!require("caret")) install.packages("caret", dependencies = TRUE)
#if(!require("sjPlot")) install.packages("sjPlot", dependencies = TRUE)
#if(!require("sjlabelled")) install.packages("sjlabelled", dependencies = TRUE)
#if(!require("sjmisc")) install.packages("sjmisc", dependencies = TRUE)
# ui ----------------------------------------------------------------------
col.list <- c("white")
colors <- paste0("background:",col.list,";")
ui <- bootstrapPage(
div(style="display:inline-block", img(src="gif_trees_birds_grid_reseed.gif",
style="position: header; width: 100%; margin-left:0%; margin-top: 0%")),
shinythemes::themeSelector(),
navbarPage(
theme = shinytheme("sandstone"),
title = "Atlantic forest plant traits",
setBackgroundColor(color = c("#FFF5EE")),
#header = tagList(
# useShinydashboard()
#),
# Pie graph ---------------------------------------------------------------
tabPanel(title = "Traits Summary",
sidebarLayout(
sidebarPanel(
selectInput(
inputId = "species",
label = "Species:",
selected = "Acnistus arborescens",
choices = c(unique(plant_traits$species)),
size = 25, selectize = FALSE
)
),
# Show a plot of the generated distribution
mainPanel(
tabsetPanel(
id = "tabs",
tabPanel(
title = "Analytics Dashboard",
value = "page1",
useShinyjs(),
checkboxInput("OneMore", label = h5("Show and Report donut Chart?"), T),
fluidRow(
column(
width = 6,
d3Output("traitbar")
),
div(id='Hide',
column(
width = 6,
nivopieOutput("traitpie")
)
)
)
)
)
)
)
),
# dispersers --------------------------------------------------------------
tabPanel(title = "Dispersers",
mainPanel(
tabsetPanel(type = "hidden",
tabPanel("Animal dispersers",
networkD3::sankeyNetworkOutput("diagram",
height = "700px",
width = "100%")))
))
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
# Trait summary -----------------------------------------------------------
shinyjs::useShinyjs()
observe({
shinyjs::toggle(id = "Hide", condition = input$OneMore, anim = TRUE, animType = "fade")
})
plant_traits_filtered <- reactive({
if (input$species != "ALL") plant_traits <- dplyr::filter(plant_traits, species == input$species)
plant_traits
})
bar_graphD3 <- reactive({
grouped <- ifelse(input$species != "ALL", expr(plant_traits), expr(species))
spptraitdata <- plant_traits_filtered() %>%
dplyr::group_by(!!grouped) %>%
dplyr::tally() %>%
dplyr::collect() %>%
dplyr::mutate(
y = n,
x = !!grouped) %>%
dplyr::select(x, y)
spptraitdata <- spptraitdata %>%
dplyr::mutate(label = x)
r2d3::r2d3(spptraitdata, "bar_plot.js")
})
pie_graph <- reactive({
grouped2 <- ifelse(input$species != "ALL", expr(plant_traits), expr(species))
spptraitdata2 <- plant_traits_filtered() %>%
dplyr::group_by(!!grouped2) %>%
dplyr::tally() %>%
dplyr::collect() %>%
dplyr::mutate(
value = n,
id = !!grouped2) %>%
dplyr::select(id, value)
spptraitdata3 <- data.frame(spptraitdata2)
spptraitdata3$id <- as.factor(spptraitdata3$id)
nivopie::nivopie(spptraitdata3, innerRadius=0.5, cornerRadius=5, fit=T, sortByValue=T,
colors='paired', enableRadialLabels=F, radialLabelsLinkDiagonalLength=1,
radialLabelsLinkHorizontalLength=8,
enableSlicesLabels=T, sliceLabel='id',isInteractive=T)
})
output$traitbar = r2d3::renderD3({
bar_graphD3()
})
output$traitpie=nivopie::renderNivopie({
pie_graph()
})
# plant/trait bar click (server) ---------------------------------
observeEvent(input$bar_clicked != "", {
if (input$species == "ALL") {
updateSelectInput(session, "species", selected = input$bar_clicked)
}
}, ignoreInit = TRUE)
# sankeyNetwork diagram plot ------------------------------------------------------
output$diagram <- networkD3::renderSankeyNetwork({
networkD3::sankeyNetwork(Links = dispersores_df,
Nodes = nodes,
Source = "IDsource",
Target = "IDtarget",
Value = "value",
fontSize = 20,
NodeID = "name",
sinksRight=FALSE) #%>%
# htmlwidgets::onRender('function(el) { el.querySelector("svg").removeAttribute("viewBox") }')
})
}
# Run the application
shinyApp(ui = ui, server = server)
Related
I am having a hard time understanding how the container argument from function VisNetwork::VisConfigure works. It seems as though one can move the configuration list in another HTML container but my understanding is too limited (and I found no examples online).
My goal would be to place the configuration list in a shinydashboardPlus::dropdownBlock (i.e., in the dashboardHeader leftUI argument), see reproducible example below:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(visNetwork)
# Define the function to retrieve the parameters from VisConfigure
# See: https://github.com/datastorm-open/visNetwork/issues/333
visShinyGetOptionsFromConfigurator <- function (graph, input = paste0(graph$id, "_configurator")) {
if (!any(class(graph) %in% "visNetwork_Proxy")) {
stop("Can't use visGetPositions with visNetwork object. Only within shiny & using visNetworkProxy")
}
data <- list(id = graph$id, input = input)
graph$session$sendCustomMessage("visShinyGetOptionsFromConfigurator", data)
graph
}
ui <- dashboardPage(
dashboardHeader(title = "Test visConfigure container argument",
leftUi = tagList(
shinydashboardPlus::dropdownBlock(
id = "graphparams",
title = "Graph parameters",
icon = shiny::icon("gears"),
shinyWidgets::prettyRadioButtons(
inputId = "physics",
label = "Parameters should appear here",
choices = c("Yes","No"))))),
dashboardSidebar(width = 220),
dashboardBody(
fluidRow(box(id = "network",
title = "Network",
status = "primary",
width = 12,
solidHeader = TRUE,
collapsible = TRUE,
visNetworkOutput('network'))),
fluidRow(actionButton("ops", "Options"))))
server <- function(input, output, session) {
getDiagramPlot <- function(nodes, edges){
v <- visNetwork(
nodes,
edges) %>%
visIgraphLayout(layout = "layout_on_sphere", physics = TRUE, randomSeed = 1234) %>%
visPhysics(solver = "hierarchicalRepulsion",
hierarchicalRepulsion = list(springLength = 850, nodeDistance = 90),
stabilization = "onlyDynamicEdges") %>%
visOptions(highlightNearest = list(enabled = T, degree = 1, hover = F), autoResize = TRUE, collapse = FALSE) %>%
visEdges(color = list(highlight = "red")) %>%
visEdges(arrows = edges$arrows) %>%
visConfigure(enabled = TRUE, filter = "physics", container = NULL) %>%
visInteraction(multiselect = F)
return(v)
}
nodes <- data.frame(id = 0:20, label = LETTERS[1:21])
edges <- data.frame(from = 0, to = 1:20, value = seq(0.35, 0.5, length.out = 20))
output$network <- renderVisNetwork(
getDiagramPlot(nodes, edges)
)
# Send to console the settings from VisConfigure
# See: https://github.com/datastorm-open/visNetwork/issues/333
observeEvent(input$ops, { visNetworkProxy("network") %>% visShinyGetOptionsFromConfigurator() })
observe({ if(!is.null(input$network_configurator)) print(input$network_configurator)
})
session$onSessionEnded(stopApp)
}
shinyApp(ui, server)
Any idea?
Best,
C.
I tried to set container = input$graphparams but it didn't work.
I am trying with the below code.
library(shiny)
app <- shinyApp(
ui = fluidPage(
DT::dataTableOutput("mydatatable")
),
server = shinyServer(function(input, output, session) {
mycars <- reactive({ head(mtcars)})
output$mydatatable = DT::renderDataTable(mycars(), selection = 'single',
rownames = FALSE, options = list(dom = 't'))
selected_row <- reactiveVal(value = NULL)
observeEvent(input$mydatatable_rows_selected,{
selected_row(input$mydatatable_rows_selected)
})
observeEvent(selected_row(),
{
showModal(modalDialog(
title = "You have selected a row!",
ifelse(
mycars()$mpg[selected_row()] > 21,
tags$div(HTML(paste('cyl = ', tags$span(style = "color:red", mycars()$cyl[selected_row()]), sep = ""))),
tags$div(HTML(paste('cyl = ', tags$span(style = "color:blue", mycars()$cyl[selected_row()]), sep = "")))
)
))
})
})
)
app
Here I am trying to change color of 'cyl' value to red if 'mpg' value is greater than 21 else 'cyl' value will print in blue.
I have tried with few html codes but failed.
Thanks!
For this purpose the dataframe does not have to be reactive, so I removed that part in here. Make use of the formatStyle functionality:
app <- shinyApp(
ui = fluidPage(
DT::dataTableOutput("mydatatable")
),
server = shinyServer(function(input, output, session) {
mycars <- mtcars
output$mydatatable = DT::renderDataTable(datatable(mycars) %>%
formatStyle('cyl', 'mpg',
color = styleInterval(21.001, c('blue', 'red'))),
selection = 'single',
rownames = FALSE, options = list(dom = 't'))
})
)
app
I have generated few plots using plotly and saved them as offline html (I don't want to generate them live as it would take so long to generate them in the background). The followings are the two plots taken from plotly site and I saved them as html.
#Graph 1
Animals <- c("giraffes", "orangutans", "monkeys")
SF_Zoo <- c(20, 14, 23)
LA_Zoo <- c(12, 18, 29)
data <- data.frame(Animals, SF_Zoo, LA_Zoo)
p <- plot_ly(data, x = ~Animals, y = ~SF_Zoo, type = 'bar', name = 'SF Zoo') %>%
add_trace(y = ~LA_Zoo, name = 'LA Zoo') %>%
layout(yaxis = list(title = 'Count'), barmode = 'group')
htmlwidgets::saveWidget(p, file="zoo.html")
#Graph 2
x <- c('Product A', 'Product B', 'Product C')
y <- c(20, 14, 23)
text <- c('27% market share', '24% market share', '19% market share')
data <- data.frame(x, y, text)
p <- plot_ly(data, x = ~x, y = ~y, type = 'bar', text = text,
marker = list(color = 'rgb(158,202,225)',
line = list(color = 'rgb(8,48,107)',
width = 1.5))) %>%
layout(title = "January 2013 Sales Report",
xaxis = list(title = ""),
yaxis = list(title = ""))
htmlwidgets::saveWidget(p, file="product.html")
I have written some shiny codes that can show html output from Rmarkdown but not the html that i generated from plotly above. Note that the first choice(sample) in the selectInput() is what I generated from default Rmarkdown html and that works. I also generated multiple rmarkdown html and I could also switch between htmls in the shiny app but not for plotly html.
ui= fluidPage(
titlePanel("opening web pages"),
sidebarPanel(
selectInput(inputId='test',label=1,choices=c("sample","zoo","product"))
),
mainPanel(
htmlOutput("inc")
)
)
server = function(input, output) {
getPage<-function() {
return(includeHTML(paste0("file:///C:/Users/home/Documents/",input$test,".html")))
}
output$inc<-renderUI({getPage()})
}
shinyApp(ui, server)
You can use an iframe for this - also have a look at addResourcePath:
ui = fluidPage(
titlePanel("opening web pages"),
sidebarPanel(selectInput(
inputId = 'test',
label = 1,
choices = c("sample", "zoo", "product")
)),
mainPanel(htmlOutput("inc"))
)
server = function(input, output) {
myhtmlfilepath <- getwd() # change to your path
addResourcePath('myhtmlfiles', myhtmlfilepath)
getPage <- function() {
return(tags$iframe(src = paste0("myhtmlfiles/", input$test, ".html"), height = "100%", width = "100%", scrolling = "yes"))
}
output$inc <- renderUI({
req(input$test)
getPage()
})
}
shinyApp(ui, server)
I am wondering if there is a way to remove the index column (1st column) from the data table in Shiny.
For example, column of (1, 2, 3) before Name column as shown in the screenshot below:
Below is my code:
header <- dashboardHeader(
title = "Test"
)
sidebar <- dashboardSidebar(
)
body <- dashboardBody(
box(title = "Test", width = 7, status = "warning", DT::dataTableOutput("df"))
)
# UI
ui <- dashboardPage(header, sidebar, body)
# Server
server <- function(input, output, session) {
output$df = DT::renderDataTable(df, options = list(
autoWidth = TRUE,
columnDefs = list(list(width = '10px', targets = c(1,3)))))
}
# Shiny dashboard
shiny::shinyApp(ui, server)
Thanks in advance.
There is some excellent documentation of the package available at https://rstudio.github.io/DT/ I would highly recommend reading through.
At any rate, use the rownames = FALSE argument provided by the DT package as follows:
library(shinydashboard)
library(DT)
df <- mtcars
header <- dashboardHeader(
title = "Test"
)
sidebar <- dashboardSidebar(
)
body <- dashboardBody(
box(title = "Test", width = 7, status = "warning", DT::dataTableOutput("df"))
)
# UI
ui <- dashboardPage(header, sidebar, body)
# Server
server <- function(input, output, session) {
output$df = DT::renderDataTable(df, rownames = FALSE,
options = list(
autoWidth = TRUE,
columnDefs = list(list(width = '10px', targets = c(1,3)))))
}
# Shiny dashboard
shiny::shinyApp(ui, server)
After the success of the dynamic box in shiny here : R/Shiny : Color of boxes depend on select I need you to use these boxes but in a loop.
Example :
I have an input file which give this :
BoxA
BoxB
BoxC
I want in the renderUI loop these values as a variable to generate dynamically a Box A, B and C. (if I have 4 value, i will have 4 boxes etC.)
Here is my actually code:
for (i in 1:nrow(QRSList))
{
get(QRSOutputS[i]) <- renderUI({
column(4,
box(title = h3(QRSList[1], style = "display:inline; font-weight:bold"),
selectInput("s010102i", label = NULL,
choices = list("Non commencé" = "danger", "En cours" = "warning", "Terminé" = "success"),
selected = 1) ,width = 12, background = "blue", status = get(QRSIntputS[i])))
})
column(4,
observeEvent(input$s010102i,{
get(QRSOutputS[i]) <- renderUI({
box(title = h3(QRSList[1], style = "display:inline; font-weight:bold"),
selectInput("s010102i", label = NULL,
choices = list("Not good" = "danger", "average" = "warning", "good" = "success"),
selected = get(QRSIntputS[i])) ,width = 12, background = "blue",status = get(QRSIntputS[i]))
})
The aim is to replace these box names to a variable like input$s010102 for example. But get and assign function does not exist.
Any idea ?
Thanks a lot
Here is an example how to generate boxes dynamically
library(shinydashboard)
library(shiny)
QRSList <- c("Box1","Box2","Box3","Box4","Box5")
ui <- dashboardPage(
dashboardHeader(title = "render Boxes"),
dashboardSidebar(
sidebarMenu(
menuItem("Test", tabName = "Test")
)
),
dashboardBody(
tabItems(
tabItem(tabName = "Test",
fluidRow(
tabPanel("Boxes",uiOutput("myboxes"))
)
)
)
)
)
server <- function(input, output) {
v <- list()
for (i in 1:length(QRSList)){
v[[i]] <- box(width = 3, background = "blue",
title = h3(QRSList[i], style = "display:inline; font-weight:bold"),
selectInput(paste0("slider",i), label = NULL,choices = list("Not good" = "danger", "average" = "warning", "good" = "success"))
)
}
output$myboxes <- renderUI(v)
}
shinyApp(ui = ui, server = server)