VisNetwork: Use VisConfigure argument container to move parameters to dropdownBlock (shinydashboardPlus) - html

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.

Related

sankeyNetwork is invisible in Shiny R

[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)

How can I change color of text on basis of ifelse condition in R shiny?

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

How to remove the first column (index) from data table in R Shiny

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)

R/Shiny : RenderUI in a loop to generate multiple objects

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)

Shiny - Control Widgets Inside Leaflet Map

I have a simple shiny-app with just a dropdown listing districts of Afghanistan and a leaflet map of the same.
The shape file can be accessed at this link - using AFG_adm2.shp from http://www.gadm.org/download
here's the app code:
library(shiny)
library(leaflet)
library(rgdal)
library(sp)
afg <- readOGR(dsn = "data", layer ="AFG_adm2", verbose = FALSE, stringsAsFactors = FALSE)
ui <- fluidPage(
titlePanel("Test App"),
selectInput("yours", choices = c("",afg$NAME_2), label = "Select Country:"),
actionButton("zoomer","reset zoom"),
leafletOutput("mymap")
)
server <- function(input, output){
initial_lat = 33.93
initial_lng = 67.71
initial_zoom = 5
output$mymap <- renderLeaflet({
leaflet(afg) %>% #addTiles() %>%
addPolylines(stroke=TRUE, color = "#00000", weight = 1)
})
proxy <- leafletProxy("mymap")
observe({
if(input$yours!=""){
#get the selected polygon and extract the label point
selected_polygon <- subset(afg,afg$NAME_2==input$yours)
polygon_labelPt <- selected_polygon#polygons[[1]]#labpt
#remove any previously highlighted polygon
proxy %>% removeShape("highlighted_polygon")
#center the view on the polygon
proxy %>% setView(lng=polygon_labelPt[1],lat=polygon_labelPt[2],zoom=7)
#add a slightly thicker red polygon on top of the selected one
proxy %>% addPolylines(stroke=TRUE, weight = 2,color="red",data=selected_polygon,layerId="highlighted_polygon")
}
})
observeEvent(input$zoomer, {
leafletProxy("mymap") %>% setView(lat = initial_lat, lng = initial_lng, zoom = initial_zoom) %>% removeShape("highlighted_polygon")
})
}
# Run the application
shinyApp(ui = ui, server = server)
EDIT: I'm actually trying to add an action button which resets zoom to a default value (using leafletproxy and setview) and I want to put this button on the top-right corner of the map instead of it being above the map.
Can I use addLayersControl to do this?
EDIT2:
Code in full-app:
# Create the map
output$mymap <- renderLeaflet({
leaflet(afg) %>% addTiles() %>%
addPolygons(fill = TRUE,
fillColor = ~factpal(acdf$WP_2012), #which color for which attribute
stroke = TRUE,
fillOpacity = 1, #how dark/saturation the fill color should be
color = "black", #color of attribute boundaries
weight = 1, #weight of attribute boundaies
smoothFactor = 1,
layerId = aid
#popup = ac_popup
) %>% addPolylines(stroke=TRUE, color = "#000000", weight = 1) %>%
addLegend("bottomleft", pal = factpal, values = ~WP_2012,
title = "Party",
opacity = 1
) %>% setView(lng = initial_lng, lat = initial_lat, zoom = initial_zoom) %>%
addControl(html = actionButton("zoomer1","Reset", icon = icon("arrows-alt")), position = "topright")
})
I can't see the map tiles from addTiles or the zoom reset button from addControl. Any ideas why this might be happening?
You can use the addControl function directly:
output$mymap <- renderLeaflet({
leaflet(afg) %>% #addTiles() %>%
addPolylines(stroke=TRUE, color = "#00000", weight = 1) %>%
addControl(actionButton("zoomer","Reset"),position="topright")
})
You can achieve this by using the shiny absolutePanel() function in your UI, E.g.
library(shiny)
library(leaflet)
library(rgdal)
library(sp)
afg <- readOGR(dsn = "data", layer ="AFG_adm2", verbose = FALSE, stringsAsFactors = FALSE)
ui <- fluidPage(
tags$head(
tags$style(
HTML(
'
.outer {
position: fixed;
top: 80px;
left: 0;
right: 0;
bottom: 0;
overflow: hidden;
padding: 0;
}
#controls-filters {
background-color: white;
border:none;
padding: 10px 10px 10px 10px;
z-index:150;
}
'
)
)
),
titlePanel("Test App"),
absolutePanel(
id = "controls-filters",
class = "panel panel-default",
fixed = TRUE,
draggable = TRUE,
top = 100,
left = "auto",
right = 20,
bottom = "auto",
width = 330,
height = "auto",
selectInput("yours", choices = c("", afg$NAME_2), label = "Select Country:"),
actionButton("zoomer", "reset zoom")
),
div(class = "outer", leafletOutput("mymap"))
)
server <- function(input, output){
initial_lat = 33.93
initial_lng = 67.71
initial_zoom = 5
output$mymap <- renderLeaflet({
leaflet(afg) %>% #addTiles() %>%
addPolylines(stroke=TRUE, color = "#00000", weight = 1)
})
proxy <- leafletProxy("mymap")
observe({
if(input$yours!=""){
#get the selected polygon and extract the label point
selected_polygon <- subset(afg,afg$NAME_2==input$yours)
polygon_labelPt <- selected_polygon#polygons[[1]]#labpt
#remove any previously highlighted polygon
proxy %>% removeShape("highlighted_polygon")
#center the view on the polygon
proxy %>% setView(lng=polygon_labelPt[1],lat=polygon_labelPt[2],zoom=7)
#add a slightly thicker red polygon on top of the selected one
proxy %>% addPolylines(stroke=TRUE, weight = 2,color="red",data=selected_polygon,layerId="highlighted_polygon")
}
})
observeEvent(input$zoomer, {
leafletProxy("mymap") %>% setView(lat = initial_lat, lng = initial_lng, zoom = initial_zoom) %>% removeShape("highlighted_polygon")
})
}
# Run the application
shinyApp(ui = ui, server = server)
This should get you started but I would recommend structuring your app in such a way that it has a stand alone CSS file.