I'm able to export a DT table generated in R/RStudio to HTML using the htmlWidget:saveWidget method. However, the FixedColumns feature is not preserved and becomes very narrow when a term is entered in the search bar.
xyz_search_dt <- datatable(
xyz_search_table_d,
rownames = FALSE, extensions = 'Buttons',
options = list(autoWidth = TRUE,
extensions = 'FixedColumns',
options = list(dom = 't',scrollX = TRUE,
fixedColumns = TRUE),
columnDefs = list(list(width= '200px',
targets = "feedback")),
dom=('Bfrtip'), buttons = c('excel'),
pageLength = table_rows,
searchHighlight = TRUE),
filter = list(position="top"))
htmlwidgets::saveWidget(xyz_search_dt, "xyz_search_dt.html")
The solution that I found and seems to work well is to address the widget sizing policy after the fact.
dow_search_dt[["sizingPolicy"]][["defaultWidth"]] <- "100%"
htmlwidgets::saveWidget(dow_search_dt, "dow_search_dt.html")
Reference:
How to resize HTML widget using saveWidget in htmlwidgets R (reopened question)?
You can try this. I use the mtcars dataset and everything works well.
xyz_search_dt <- DT::datatable((mtcars),
rownames = FALSE,
extensions = 'Buttons',
options = list(autoWidth = TRUE,
extensions = 'FixedColumns',
options = list(dom = 't',
scrollX = TRUE,
fixedColumns = TRUE),
columnDefs = list(list(width= '200px',
targets = "feedback")),
dom=('Bfrtip'),
buttons = c('excel'),
#pageLength = table_rows,
searchHighlight = TRUE),
filter=list(position="top"))
htmlwidgets::saveWidget(xyz_search_dt, "xyz_search_dt.html")
OUTPUT:
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.
[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)
I want when I click on the search button show the result on a separate page, not on the same page.
I have tried two codes the first one:
UI:
ui = fluidPage(
theme = shinytheme("cerulean"),
mainPanel(
div(align = "center", style="margin-left:500px",
radioButtons("typeInput", "Extract tweets by: ",list("Hashtag" = "hashtag", "Twitter Username"= "username"),inline=T),
textInput("hashtagInput", "Enter search string","", placeholder = "input search string"),
conditionalPanel(
condition = "input.typeInput == 'username'",
textInput("usernameInput", "Username", placeholder = "input username")),
sliderInput("numberInput", "Select number of tweets",min = 0, max = 3000, value = 100),
br(),
actionButton("goButton", "Search", icon("twitter"),
style="color: #fff; background-color: #337ab7"),
uiOutput("pageStub")
)))
server:
server = function(input, output){
data = eventReactive(input$goButton, {
if (input$typeInput == "hashtag") {
tweetOutput = searchThis(search_string = input$hashtagInput,
number.of.tweets = input$numberInput)}
else if (input$typeInput == "username") {
tweetOutput = userTL(user.name = input$usernameInput,number.of.tweets = input$numberInput)}
else {}
library(twitteR)
df.tweets = data.frame(tweetOutput)
tweetOutput = df.tweets})
uiOutput(
output$pageStub <- renderUI(
fluidPage(
fluidRow(
renderDataTable({data()}, options = list(lengthMenu = c(10, 30, 50), pageLength = 5))))))}
but it shows the result on the same page as shown here
the second code I tried shinyBS library but I think the window is too small
UI:
ui = fluidPage(
theme = shinytheme("cerulean"),
mainPanel(
div(align = "center", style="margin-left:500px",
radioButtons("typeInput", "Extract tweets by: ",list("Hashtag" = "hashtag", "Twitter Username"= "username"),inline=T),
textInput("hashtagInput", "Enter search string","", placeholder = "input search string"),
conditionalPanel(
condition = "input.typeInput == 'username'",
textInput("usernameInput", "Username", placeholder = "input username")),
sliderInput("numberInput", "Select number of tweets",min = 0, max = 3000, value = 100),
br(),
actionButton("goButton", "Search", icon("twitter"),
style="color: #fff; background-color: #337ab7"),
bsModal("modalExample", "Your result", "goButton", size = "large",dataTableOutput("tweetTable"))
)))
server:
server = function(input, output)
{
data = eventReactive(input$goButton, {
if (input$typeInput == "hashtag")
{
tweetOutput = searchThis(search_string = input$hashtagInput,
number.of.tweets = input$numberInput)
}
else if (input$typeInput == "username")
{
tweetOutput = userTL(user.name = input$usernameInput,number.of.tweets = input$numberInput)
}
else {}
library(twitteR)
df.tweets = data.frame(tweetOutput)
tweetOutput = df.tweets
})
output$tweetTable =renderDataTable({data()}, options = list(lengthMenu = c(10, 30, 50), pageLength = 5))
}
as shown here:
and here is the search function that I called:
searchThis = function(search_string,number.of.tweets = 100)
{
search_tweets(search_string,n = number.of.tweets, lang = "en")
}
userTL = function(user.name,number.of.tweets = 100)
{
userTimeline(user.name,n = number.of.tweets)
}
is there any other way to do this?
thank you
If you want to use modals, you can modify the width so it's full-screen with the following line in the UI :
tags$head(tags$style(".modal-dialog{ width:100%; overflow-x: scroll;}"))
# width :100% enables you to choose the width of the modal, it could be 95%,50% ...
# overflow-x:scroll displays a horizontal scrollbar if the content is too large for the modal
You UI would be
ui = fluidPage(
theme = shinytheme("cerulean"),
mainPanel(
tags$head(tags$style(".modal-dialog{ width:100%; overflow-x: scroll;}")),
div(align = "center", style="margin-left:500px",
radioButtons("typeInput", "Extract tweets by: ",list("Hashtag" = "hashtag", "Twitter Username"= "username"),inline=T),
textInput("hashtagInput", "Enter search string","", placeholder = "input search string"),
conditionalPanel(
condition = "input.typeInput == 'username'",
textInput("usernameInput", "Username", placeholder = "input username")),
sliderInput("numberInput", "Select number of tweets",min = 0, max = 3000, value = 100),
br(),
actionButton("goButton", "Search", icon("twitter"),
style="color: #fff; background-color: #337ab7"),
bsModal("modalExample", "Your result", "goButton", size = "large",dataTableOutput("tweetTable"))
)))
I want to position a dropdown menu under the legend. However depending on how big the plot in terms of resolution is, plotly changes the position of this dropdown (cf. uploaded pictures).
The first plot shows the output like it appears in the little Rstudio
plot tab. The second shows how far the dropdown goes to the right if I switch to fullscreen.
How can I fix the position of the dropdown menu? Any solution is appreciated whether it is html, R or anything else
Below you can find the code which I used to create the plots:
library(plotly)
x <- seq(-2 * pi, 2 * pi, length.out = 1000)
df <- data.frame(x, y1 = sin(x), y2 = cos(x),tan_h=tanh(x))
p <- plot_ly(df, x = ~x) %>%
add_lines(y = ~y1, name = "sin") %>%
add_lines(y = ~y2, name = "cos") %>%
add_lines(y = ~tan_h, name='tanh',visible=FALSE) %>%
layout(
title = "Drop down menus - Styling",
xaxis = list(domain = c(0.1, 1)),
yaxis = list(title = "y"),
updatemenus = list(
list(
y = 0.7,
x = 1.1,
buttons = list(
list(method = "restyle",
args = list("visible", list(TRUE, TRUE, FALSE)),
label = "Cos"),
list(method = "restyle",
args = list("visible", list(TRUE, FALSE, TRUE)),
label = "Tanh"),
list(method = "restyle",
args = list("visible", list(TRUE, TRUE, TRUE)),
label = "All")
))
)
)
This question is old now, but for Python you now at least can position this via the plotly API, as per: https://plotly.com/python/v3/dropdowns/#style-dropdown
You can pass the arguments x, y, xanchor and yanchor to the updatemenus argument of the plotly graphobjects Figure's update_layout method:
import plotly.graph_objects as go
fig = go.Figure()
fig.update_layout(
title="Demo",
updatemenus=[go.layout.Updatemenu(
active=0,
buttons=[{"label": "Demo button...", "args": [{"showlegend": False}]}],
x = 0.3,
xanchor = 'left',
y = 1.2,
yanchor = 'top',
)
]
)
fig.show()
I have created a Network of protein mutations using the forceNetwork() function of the networkD3 package. It get's rendered on the RStudio's "Viewer" pane.
I can then save this as an HTML file, for sharing, with the dynamic nature (like clicking nodes, highlighting connections etc) preserved.
A png version of my network plot looks like below:
This is a representation of a top 20% in my original data, and the complete data looks even more huge and complex.
I need to be able to add a search to this forceNetwork, so that then specific nodes can be located in a complex network. The javascript or jquery part of this can be easily achieved by editing the copy of package networkD3 and repackaging. But my main challenge is adding the html code for including a search box.
My main R code looks like this:
library(networkD3)
library(XLConnect)
wb <- loadWorkbook("input.xlsx")
nodes <- readWorksheet(wb, sheet="Node", startRow = 1, startCol = 1, header = TRUE)
links <- readWorksheet(wb, sheet="Edges", startRow = 1, startCol = 1, header = TRUE)
fn <- forceNetwork(Links = links, Nodes = nodes,
Source = "Source", Target = "ID", Value = "Combo",
NodeID = "Mutation", linkDistance = JS('function(d){return d.value * 50;}'),
Nodesize = "IF", Group = "Combo", radiusCalculation = JS("d.nodesize+6"),
zoom = T, bounded = F, legend = T,
opacity = 0.8,
fontSize = 16 )
fn
My inspiration has come from the jsfiddle by Simon Raper.
What would be the best way to include a search in this situation? The option I have thought of is to first save the rendering as an html. Then read and edit the html and insert the piece of code for the search.
I tried to use Rhtml for this, but it doesn't seem trivial. Any pointers would be greatly appreciated.
Although I'm not crazy about this interactivity, I thought it would be a good opportunity for demonstrating how to use htmltools with htmlwidgets. Later, I will recreate with crosstalk, but for now, here is how I would replicate the example provided.
direct replication
library(htmltools)
library(networkD3)
data(MisLinks)
data(MisNodes)
# make a forceNetwork as shown in ?forceNetwork
fn <- forceNetwork(
Links = MisLinks, Nodes = MisNodes, Source = "source",
Target = "target", Value = "value", NodeID = "name",
Group = "group", opacity = 0.4, zoom = TRUE
)
fn <- htmlwidgets::onRender(
fn,
'
function(el,x){
debugger;
var optArray = [];
for (var i = 0; i < x.nodes.name.length - 1; i++) {
optArray.push(x.nodes.name[i]);
}
optArray = optArray.sort();
$(function () {
$("#search").autocomplete({
source: optArray
});
});
d3.select(".ui-widget button").node().onclick=searchNode;
function searchNode() {
debugger;
//find the node
var selectedVal = document.getElementById("search").value;
var svg = d3.select(el).select("svg");
var node = d3.select(el).selectAll(".node");
if (selectedVal == "none") {
node.style("stroke", "white").style("stroke-width", "1");
} else {
var selected = node.filter(function (d, i) {
return d.name != selectedVal;
});
selected.style("opacity", "0");
var link = svg.selectAll(".link")
link.style("opacity", "0");
d3.selectAll(".node, .link").transition()
.duration(5000)
.style("opacity", 1);
}
}
}
'
)
browsable(
attachDependencies(
tagList(
tags$head(
tags$link(
href="http://code.jquery.com/ui/1.11.0/themes/smoothness/jquery-ui.css",
rel="stylesheet"
)
),
HTML(
'
<div class="ui-widget">
<input id="search">
<button type="button">Search</button>
</div>
'
),
fn
),
list(
rmarkdown::html_dependency_jquery(),
rmarkdown::html_dependency_jqueryui()
)
)
)
crosstalk version
note: crosstalk is experimental, so this might change
I did not spend time to optimize and perfect, but here is a version that sort-of does the same thing as the example but using crosstalk instead of custom code and a jquery-ui autocomplete.
library(htmltools)
library(networkD3)
# demonstrate with experimental crosstalk
# this will get much easier once we start converting
# htmlwidgets to work natively with crosstalk
#devtoools::install_github("rstudio/crosstalk")
library(crosstalk)
data(MisLinks)
data(MisNodes)
# make a forceNetwork as shown in ?forceNetwork
fn <- forceNetwork(
Links = MisLinks, Nodes = MisNodes, Source = "source",
Target = "target", Value = "value", NodeID = "name",
Group = "group", opacity = 0.4, zoom = TRUE
)
sd <- SharedData$new(MisNodes, key=~name, group="grp1" )
# no autocomplete so not the same
# but will use this instead of writing something new
fs <- filter_select(
id = "filter-node",
label = "Search Nodes",
sharedData = sd,
group = ~name
)
fn <- htmlwidgets::onRender(
fn,
'
function(el,x){
// get the crosstalk group
// we used grp1 in the SharedData from R
var ct_grp = crosstalk.group("grp1");
debugger;
ct_grp
.var("filter")
.on("change", function(val){searchNode(val.value)});
function searchNode(filter_nodes) {
debugger;
//find the node
var selectedVal = filter_nodes? filter_nodes : [];
var svg = d3.select(el).select("svg");
var node = d3.select(el).selectAll(".node");
if (selectedVal.length===0) {
node.style("opacity", "1");
svg.selectAll(".link").style("opacity","1");
} else {
var selected = node.filter(function (d, i) {
return selectedVal.indexOf(d.name) >= 0;
});
node.style("opacity","0");
selected.style("opacity", "1");
var link = svg.selectAll(".link").style("opacity", "0");
/*
svg.selectAll(".node, .link").transition()
.duration(5000)
.style("opacity", 1);
*/
}
}
}
'
)
browsable(
tagList(
fs,
fn
)
)