修复图表上混乱的标题
Fixing Cluttered Titles on Graphs
我制作了以下 25 个网络图（为简单起见，所有这些图都是副本 - 实际上，它们都会有所不同）：
library(tidyverse)
library(igraph)
set.seed(123)
n=15
data = data.frame(tibble(d = paste(1:n)))
relations = data.frame(tibble(
from = sample(data$d),
to = lead(from, default=from[1]),
))
data$name = c("new york", "chicago", "los angeles", "orlando", "houston", "seattle", "washington", "baltimore", "atlanta", "las vegas", "oakland", "phoenix", "kansas", "miami", "newark" )
graph = graph_from_data_frame(relations, directed=T, vertices = data)
V(graph)$color <- ifelse(data$d == relations$from[1], "red", "orange")
plot(graph, layout=layout.circle, edge.arrow.size = 0.2, main = "my_graph")
library(visNetwork)
a = visIgraph(graph)
m_1 = 1
m_2 = 23.6
a = toVisNetworkData(graph) %>%
c(., list(main = paste0("Trip ", m_1, " : "), submain = paste0 (m_2, "KM") )) %>%
do.call(visNetwork, .) %>%
visIgraphLayout(layout = "layout_in_circle") %>%
visEdges(arrows = 'to')
y = x = w = v = u = t = s = r = q = p = o = n = m = l = k = j = i = h = g = f = e = d = c = b = a
我想将它们“平铺”为 5 x 5：因为这些是交互式 html 图 - 我使用了以下命令：
library(manipulateWidget)
library(htmltools)
ff = combineWidgets(y , x , w , v , u , t , s , r , q , p , o , n , m , l , k , j , i , h , g , f , e , d , c , b , a)
htmltools::save_html(html = ff, file = "widgets.html")
我发现了如何为每个单独的图表添加缩放选项：
a = toVisNetworkData(graph) %>%
c(., list(main = paste0("Trip ", m_1, " : "), submain = paste0 (m_2, "KM") )) %>%
do.call(visNetwork, .) %>%
visIgraphLayout(layout = "layout_in_circle") %>%
visInteraction(navigationButtons = TRUE) %>%
visEdges(arrows = 'to')
y = x = w = v = u = t = s = r = q = p = o = n = m = l = k = j = i = h = g = f = e = d = c = b = a
ff = combineWidgets(y , x , w , v , u , t , s , r , q , p , o , n , m , l , k , j , i , h , g , f , e , d , c , b , a)
htmltools::save_html(html = ff, file = "widgets.html")
但是现在“缩放”选项和“标题”已经“弄乱”了所有图表！
我认为将所有这些图表“堆叠”在一起并将每个图表保存为“组类型”可能会更好 - 然后 hide/unhide 如我们所愿：
visNetwork(data, relations) %>%
visOptions(selectedBy = "group")
我们能否将所有 25 个图表放在一页上，然后“放大”每个单独的图表以更好地查看它（例如，在页面的角落只有一组 zoom/navigation 按钮适用于所有图形的屏幕）？
有没有办法阻止标题与图表重叠？
我们能否将所有 25 个图表放在一页上，然后通过“选中”选项菜单按钮来“隐藏”各个图表？ （如本页最后一个示例：https://datastorm-open.github.io/visNetwork/options.html）
针对这个问题，我想到了以下可能的解决方案：
- 选项 1：（一个 zoom/navigation 选项适用于所有图表，没有混乱的标签）
- 选项2：（以后，每个“行程”都会不同-“行程”将包含相同的节点，但具有不同的边连接和不同的titles/subtitles。）
我知道可以使用以下代码制作这种 selection（“选项 2”）样式：
nodes <- data.frame(id = 1:15, label = paste("Label", 1:15),
group = sample(LETTERS[1:3], 15, replace = TRUE))
edges <- data.frame(from = trunc(runif(15)*(15-1))+1,
to = trunc(runif(15)*(15-1))+1)
visNetwork(nodes, edges) %>%
visOptions(selectedBy = "group")
但我不确定如何将上述代码改编为 pre-existing 组“visNetwork”图。例如，假设我已经有了“visNetwork”图“a、b、c、d、e”——我如何“将它们堆叠在一起”并使用“select 菜单”“随机播放” " 就像上面的代码一样？
有人可以告诉我使用选项 1 和选项 2 解决这个混乱问题的方法吗？
谢谢！
虽然我的解决方案与您在 Option 2 下描述的不完全相同，但也很接近。我们使用 combineWidgets() 创建一个单列单行高的网格，其中一张图表覆盖了大部分屏幕高度。我们在每个小部件实例之间挤入一个 link，在单击时向下滚动浏览器 window 以显示下图。
让我知道这是否适合您。应该可以根据浏览器window大小自动调整行大小。目前，这取决于浏览器 window 高度在 1000px 左右。
我稍微修改了您创建图形的代码并将其包装在一个函数中。这使我们能够轻松创建 25 different-looking 个图表。这样测试生成的 HTML 文件会更有趣！函数定义之后是创建 list 个 HTML 个对象的代码，然后我们将这些对象输入 combineWidgets().
library(visNetwork)
library(tidyverse)
library(igraph)
library(manipulateWidget)
library(htmltools)
create_trip_graph <-
function(x, distance = NULL) {
n <- 15
data <- tibble(d = 1:n,
name =
c(
"new york",
"chicago",
"los angeles",
"orlando",
"houston",
"seattle",
"washington",
"baltimore",
"atlanta",
"las vegas",
"oakland",
"phoenix",
"kansas",
"miami",
"newark"
))
relations <- tibble(from = sample(data$d),
to = lead(from, default = from[1]))
graph <-
graph_from_data_frame(relations, directed = TRUE, vertices = data)
V(graph)$color <-
ifelse(data$d == relations$from[1], "red", "orange")
if (is.null(distance))
# This generates a random distance value if none is
# specified in the function call. Values are just for
# demonstration, no actual distances are calculated.
distance <- sample(seq(19, 25, .1), 1)
toVisNetworkData(graph) %>%
c(., list(
main = paste0("Trip ", x, " : "),
submain = paste0(distance, "KM")
)) %>%
do.call(visNetwork, .) %>%
visIgraphLayout(layout = "layout_in_circle") %>%
visInteraction(navigationButtons = TRUE) %>%
visEdges(arrows = 'to')
}
comb_vgraphs <- lapply(1:25, function (x) list(
create_trip_graph(x),
htmltools::a("NEXT TRIP",
onclick = 'window.scrollBy(0,950)',
style = 'color:blue; text-decoration:underline;'))) %>%
unlist(recursive = FALSE)
ff <-
combineWidgets(
list = comb_vgraphs,
ncol = 1,
height = 25 * 950,
rowsize = c(24, 1)
)
htmltools::save_html(html = ff, file = "widgets.html")
如果你想每行有 5 个网络地图，代码会变得有点复杂，它也可能导致用户可能必须进行水平滚动才能看到所有内容的情况，这是你通常会做的事情在创建 HTML 页面时要避免。这是每行 5 个地图解决方案的代码：
comb_vgraphs2 <- lapply(1:25, function(x) {
a <- list(create_trip_graph(x))
# We detect whenever we are creating the 5th, 10th, 15th etc. network map
# and add the link after that one.
if (x %% 5 == 0 & x < 25) a[[2]] <- htmltools::a("NEXT 5 TRIPS",
onclick = 'window.scrollBy(0,500)',
style = 'color:blue; text-decoration:underline;')
a
}) %>%
unlist(recursive = FALSE)
ff2 <-
combineWidgets(
list = comb_vgraphs2,
ncol = 6, # We need six columns, 5 for the network maps
# and 1 for the link to scroll the page.
height = 6 * 500,
width = 1700
#rowsize = c(24, 1)
)
# We need to add some white space in for the scrolling by clicking the link to
# still work for the last row.
ff2$widgets[[length(ff2$widgets) + 1]] <- htmltools::div(style = "height: 1000px;")
htmltools::save_html(html = ff2, file = "widgets2.html")
一般来说，我建议您尝试使用 combineWidgets() 的 height 和 width、ncol 和 nrow 参数以获得令人满意的效果解决方案。我在构建它时的策略是首先创建一个没有滚动条的网格 link 并在正确设置网格后添加它。
尺码有效，但乍一看似乎无效。不过还没有准备好。
When you select options, it doesn't trigger the auto-resize functionality within the canvases.
图形对象的 auto-resize 工作得很好。 （您会在 gif 中看到。）
RStudio 中的查看器窗格不是检查编织文件的最佳方式。编织后在浏览器中查看它......特别是如果你想进行更改。似乎有时它认为所有 RStudio 都是容器大小，并且您会在屏幕上看到图表 运行。我确定这是我的编码方式，但这在 Safari 或 Chrome（我没有检查其他浏览器）中似乎不是问题。
我尝试过以多种不同的方式触发 canvas 的大小调整。此代码可能因尝试触发 canvases 的 resize/zoom 范围而存在一些冗余。 （我想我删除了所有不起作用的东西。）也许有了这个，其他人可以弄清楚那部分。
我使用了一些 Shiny 代码，但这是 而不是 使用 Shiny 运行 时间。本质上，静态工作是 R，但动态元素不能在 R 中（即调整事件大小、读取 selections 等）。
在我使用的库中，我调用了shinyRPG。我添加并注释掉了包安装代码，因为该包不是 Cran 包。 （它在 Github。）
我在编码（和这个答案）中所做的假设：
- 您具有 Rmarkdown 的应用知识。
- 这些网络图有 25 张。
- 脚本中没有其他 HTML 小部件。
如果这些不是真的，请告诉我。
YAML
输出选项
---
title: "Just for antonoyaro8"
output:
flexdashboard::flex_dashboard:
orientation: columns
vertical_layout: fill
---
风格
此代码位于 YAML 和第一个 R 代码块之间。在 RMD 的常规文本区域——而不是在 R 块中。
<style>
select {
// A reset of styles, including removing the default dropdown arrow
appearance: none;
background-color: transparent;
border: none;
padding: 0 1em 0 0;
margin: 0;
width: 100%;
font-family: inherit;
font-size: inherit;
cursor: inherit;
line-height: inherit;
}
.select {
display: grid;
grid-template-areas: "select";
align-items: center;
position: relative;
min-width: 15ch;
max-width: 100ch;
border: 1px solid var(--select-border);
border-radius: 0.25em;
padding: 0.25em 0.5em;
font-size: 1.25rem;
cursor: pointer;
line-height: 1.1;
background-color: #fff;
background-image: linear-gradient(to top, #f9f9f9, #fff 33%);
}
select[multiple] {
padding-right: 0;
/* Safari will not show options unless labels fit */
height: 50rem; // how many options show at one time
font-size: 1rem;
}
#column-1 > div.containIt > div.visNetwork canvas {
width: 100%;
height: 80%;
}
.containIt {
display: flex;
flex-flow: row wrap;
flex-grow: 1;
justify-content: space-around;
align-items: flex-start;
align-content: space-around;
overflow: hidden;
height: 100%;
width: 100%;
margin-top: 2vw;
height: 80vh;
widhth: 80vw;
overflow: hidden;
}
</style>
图书馆
接下来是第一个 R 块。您不必在 flexdashboard.
中设置 echo = F
```{r setup, include=FALSE}
library(flexdashboard)
library(visNetwork)
library(htmltools)
library(igraph)
library(tidyverse)
library(shinyRPG) # remotes::install_github("RinteRface/shinyRPG")
```
创建图表的 R 代码
下一部分基本上是您的代码。我在调用的最终版本中更改了一些内容以创建 vizNetwork.
```{r dataStuff}
set.seed(123)
n=15
data = data.frame(tibble(d = paste(1:n)))
relations = data.frame(tibble(
from = sample(data$d),
to = lead(from, default=from[1]),
))
data$name = c("new york", "chicago", "los angeles", "orlando", "houston", "seattle", "washington", "baltimore", "atlanta", "las vegas", "oakland", "phoenix", "kansas", "miami", "newark" )
graph = graph_from_data_frame(relations, directed=T, vertices = data)
#red circle: starting point and final point
V(graph)$color <- ifelse(data$d == relations$from[1], "red", "orange")
a = visIgraph(graph)
m_1 = 1
m_2 = 23.6
a = toVisNetworkData(graph) %>%
c(., list(main = paste0("Trip ", m_1, " : "),
submain = paste0 (m_2, "KM") )) %>%
do.call(visNetwork, .) %>%
visIgraphLayout(layout = "layout_in_circle") %>%
visEdges(arrows = 'to')
# collect the correct order
df2 <- data %>%
mutate(d = as.numeric(d),
nuname = factor(a$x$edges$from,
levels = unlist(data$name))) %>%
arrange(nuname) %>%
select(d) %>% unlist(use.names = F)
# [1] 11 5 2 8 7 6 10 14 15 4 12 9 13 3 1
V(graph)$name = data$label = paste0(df2, "\n", data$name)
a = visIgraph(graph)
m_1 = 1
m_2 = 23.6
a = toVisNetworkData(graph) %>%
c(., list(main = list(text = paste0("Trip ", m_1, " : "),
style = "font-family: Georgia; font-size: 100%; font-weight: bold; text-align:center;"),
submain = list(text = paste0(m_2, "KM"),
style = "font-family: Georgia; font-size: 100%; text-align:center;"))) %>%
do.call(visNetwork, .) %>%
visInteraction(navigationButtons = TRUE) %>%
visIgraphLayout(layout = "layout_in_circle") %>%
visEdges(arrows = 'to') %>%
visOptions(width = "100%", height = "80%", autoResize = T)
a[["sizingPolicy"]][["knitr"]][["figure"]] <- FALSE
y = x = w = v = u = t = s = r = q = p = o = n = m = l = k = j = i = h = g = f = e = d = c = b = a
```
Multi-Select 盒子
在最后一个代码块和下一个代码块之前是下一部分的位置。这将创建左列，multi-select 框所在的位置。 （这不在代码块中。）
Column {data-width=200}
-----------------------------------------------------------------------
### Select Options
You can select one or more options from the list.
否构建 select 框并附加将触发更改的函数。这部分将需要修改。 在此处命名用户在屏幕上看到的选项。（此代码中的letters[1:25]。）
您的对象名称不必与您在此处的名称相匹配。不过，它们确实需要以相同的顺序排列。
```{r selectiver}
tagSel <- rpgSelect(
"selectBox", # don't change this (connected)
"Selections:", # visible on HTML; change away or set to ""
c(setNames(1:25, letters[1:25])), # left is values, right is labels
multiple = T # all multiple selections
) # other attributes controlled by css at the top
tagSel$attribs$class <- 'select select--multiple' # connect styles
tagSel$children[[2]]$attribs$class <- "mutli-select" # connect styles
tagSel$children[[2]]$attribs$onchange <- "getOps(this)" # connect the JS function
tagSel
```
网络图
然后在前一个chunk和下一个chunk之间（不在一个chunk中）：
Column
-----------------------------------------------------------------------
<div class="containIt">
现在调用你的图表。
```{r notNow, include=T}
a
b
c
d
e
f
g
h
i
j
k
l
m
n
o
p
q
r
s
t
u
v
w
x
y
```
关闭该块之后的 div 标签：
</div>
最后一个区块：Javascript
这开始的时候很好很整洁...但经过大量的试验和错误后——所见即所得。
在此过程中，有效的评论也逐渐消失了。如果对什么功能有疑问，请告诉我。
如果您 运行 R Markdown 中的块（在源代码窗格中），则该块不会执行任何操作。要执行JS，你必须knit.
```{r pickMe,results='asis',engine='js'}
//remove inherent knitr element-- after using mutlti-select starts harboring space
byeknit = document.querySelector('#column-1 > div.containIt > div.knitr-options');
byeknit.remove(1);
// Reset Sizing of Widgets
h = document.querySelector('#column-1 > div.containIt').clientHeight;
w = document.querySelector('#column-1 > div.containIt').clientWidth;
hw = h * w;
cont = document.querySelectorAll('#column-1 > div.containIt > div');
newHeight = Math.floor(Math.sqrt(hw/cont.length)) * .85;
for(i = 0; i < cont.length; ++i){
cont[i].style.height = newHeight + 'px';
cont[i].style.width = newHeight + 'px';
cn = cont[i].childNodes;
if(cn.length > 0){
th = cn[0].clientHeight + cn[1].clientHeight;
console.log("canvas found");
mb = newheight - th;
cn[5].style.height = mb + 'px'; //canvas control attempt
}
}
function resizePlease(count) { //resize plots based on selections
// screen may have resized**
h = document.querySelector('#column-1 > div.containIt').clientHeight;
w = document.querySelector('#column-1 > div.containIt').clientWidth;
hw = h * w; // get the area
// based on selected count** these should fit---
// RStudio!
newHeight = Math.floor(Math.sqrt(hw/count)) * .85;
for(i = 0; i < graphy.length; ++i){
graphy[i].style.height = newHeight + 'px';
graphy[i].style.width = newHeight + 'px';
gcn = graphy[i].childNodes;
if(cn.length > 0){
th = gcn[0].clientHeight + gcn[1].clientHeight;
mb = newHeight - th;
gcn[5].style.height = mb + 'px'; //canvas control attempt
canYouPLEASElisten = graphy[i].querySelector('canvas');
canYouPLEASElisten.style.height = mb + 'px'; //trigger zoom extent!!
canYouPLEASElisten.style.height = '100%';
}
}
}
// Something selected triggers this function
function getOps(sel) {
//get ref to select list and display text box
graphy = document.querySelectorAll('#column-1 div.visNetwork');
count = 0; // reset count of selected vis
// loop through selections
for(i = 0; i < sel.length; i++) {
opt = sel.options[i];
if ( opt.selected ) {
count++
graphy[i].style.display = 'block';
console.log(opt + "selected");
console.log(count + " options selected");
} else {
graphy[i].style.display = 'none';
}
}
resizePlease(count);
}
```
开发者工具控制台
如果您转到开发人员工具控制台，您将能够看到在制作 select 离子时 select 编辑了多少选项和哪些选项。这样，如果有一些奇怪的事情，比如倒序（我怀疑但无法验证），你会看到你可能预期的发生了什么或没有发生什么。你在哪里看到 console.log，它正在向控制台发送消息，这样你就可以看到发生了什么。
仪表板颜色
如果背景中有任何颜色、自定义或其他颜色，请告诉我。我也可以在这方面提供帮助。现在，仪表板的颜色是默认颜色。
我制作了以下 25 个网络图（为简单起见，所有这些图都是副本 - 实际上，它们都会有所不同）：
library(tidyverse)
library(igraph)
set.seed(123)
n=15
data = data.frame(tibble(d = paste(1:n)))
relations = data.frame(tibble(
from = sample(data$d),
to = lead(from, default=from[1]),
))
data$name = c("new york", "chicago", "los angeles", "orlando", "houston", "seattle", "washington", "baltimore", "atlanta", "las vegas", "oakland", "phoenix", "kansas", "miami", "newark" )
graph = graph_from_data_frame(relations, directed=T, vertices = data)
V(graph)$color <- ifelse(data$d == relations$from[1], "red", "orange")
plot(graph, layout=layout.circle, edge.arrow.size = 0.2, main = "my_graph")
library(visNetwork)
a = visIgraph(graph)
m_1 = 1
m_2 = 23.6
a = toVisNetworkData(graph) %>%
c(., list(main = paste0("Trip ", m_1, " : "), submain = paste0 (m_2, "KM") )) %>%
do.call(visNetwork, .) %>%
visIgraphLayout(layout = "layout_in_circle") %>%
visEdges(arrows = 'to')
y = x = w = v = u = t = s = r = q = p = o = n = m = l = k = j = i = h = g = f = e = d = c = b = a
我想将它们“平铺”为 5 x 5：因为这些是交互式 html 图 - 我使用了以下命令：
library(manipulateWidget)
library(htmltools)
ff = combineWidgets(y , x , w , v , u , t , s , r , q , p , o , n , m , l , k , j , i , h , g , f , e , d , c , b , a)
htmltools::save_html(html = ff, file = "widgets.html")
我发现了如何为每个单独的图表添加缩放选项：
a = toVisNetworkData(graph) %>%
c(., list(main = paste0("Trip ", m_1, " : "), submain = paste0 (m_2, "KM") )) %>%
do.call(visNetwork, .) %>%
visIgraphLayout(layout = "layout_in_circle") %>%
visInteraction(navigationButtons = TRUE) %>%
visEdges(arrows = 'to')
y = x = w = v = u = t = s = r = q = p = o = n = m = l = k = j = i = h = g = f = e = d = c = b = a
ff = combineWidgets(y , x , w , v , u , t , s , r , q , p , o , n , m , l , k , j , i , h , g , f , e , d , c , b , a)
htmltools::save_html(html = ff, file = "widgets.html")
但是现在“缩放”选项和“标题”已经“弄乱”了所有图表！
我认为将所有这些图表“堆叠”在一起并将每个图表保存为“组类型”可能会更好 - 然后 hide/unhide 如我们所愿：
visNetwork(data, relations) %>%
visOptions(selectedBy = "group")
我们能否将所有 25 个图表放在一页上，然后“放大”每个单独的图表以更好地查看它（例如，在页面的角落只有一组 zoom/navigation 按钮适用于所有图形的屏幕）？
有没有办法阻止标题与图表重叠？
我们能否将所有 25 个图表放在一页上，然后通过“选中”选项菜单按钮来“隐藏”各个图表？ （如本页最后一个示例：https://datastorm-open.github.io/visNetwork/options.html）
针对这个问题，我想到了以下可能的解决方案：
- 选项 1：（一个 zoom/navigation 选项适用于所有图表，没有混乱的标签）
- 选项2：（以后，每个“行程”都会不同-“行程”将包含相同的节点，但具有不同的边连接和不同的titles/subtitles。）
我知道可以使用以下代码制作这种 selection（“选项 2”）样式：
nodes <- data.frame(id = 1:15, label = paste("Label", 1:15),
group = sample(LETTERS[1:3], 15, replace = TRUE))
edges <- data.frame(from = trunc(runif(15)*(15-1))+1,
to = trunc(runif(15)*(15-1))+1)
visNetwork(nodes, edges) %>%
visOptions(selectedBy = "group")
但我不确定如何将上述代码改编为 pre-existing 组“visNetwork”图。例如，假设我已经有了“visNetwork”图“a、b、c、d、e”——我如何“将它们堆叠在一起”并使用“select 菜单”“随机播放” " 就像上面的代码一样？
有人可以告诉我使用选项 1 和选项 2 解决这个混乱问题的方法吗？
谢谢！
虽然我的解决方案与您在 Option 2 下描述的不完全相同，但也很接近。我们使用 combineWidgets() 创建一个单列单行高的网格，其中一张图表覆盖了大部分屏幕高度。我们在每个小部件实例之间挤入一个 link，在单击时向下滚动浏览器 window 以显示下图。
让我知道这是否适合您。应该可以根据浏览器window大小自动调整行大小。目前，这取决于浏览器 window 高度在 1000px 左右。
我稍微修改了您创建图形的代码并将其包装在一个函数中。这使我们能够轻松创建 25 different-looking 个图表。这样测试生成的 HTML 文件会更有趣！函数定义之后是创建 list 个 HTML 个对象的代码，然后我们将这些对象输入 combineWidgets().
library(visNetwork)
library(tidyverse)
library(igraph)
library(manipulateWidget)
library(htmltools)
create_trip_graph <-
function(x, distance = NULL) {
n <- 15
data <- tibble(d = 1:n,
name =
c(
"new york",
"chicago",
"los angeles",
"orlando",
"houston",
"seattle",
"washington",
"baltimore",
"atlanta",
"las vegas",
"oakland",
"phoenix",
"kansas",
"miami",
"newark"
))
relations <- tibble(from = sample(data$d),
to = lead(from, default = from[1]))
graph <-
graph_from_data_frame(relations, directed = TRUE, vertices = data)
V(graph)$color <-
ifelse(data$d == relations$from[1], "red", "orange")
if (is.null(distance))
# This generates a random distance value if none is
# specified in the function call. Values are just for
# demonstration, no actual distances are calculated.
distance <- sample(seq(19, 25, .1), 1)
toVisNetworkData(graph) %>%
c(., list(
main = paste0("Trip ", x, " : "),
submain = paste0(distance, "KM")
)) %>%
do.call(visNetwork, .) %>%
visIgraphLayout(layout = "layout_in_circle") %>%
visInteraction(navigationButtons = TRUE) %>%
visEdges(arrows = 'to')
}
comb_vgraphs <- lapply(1:25, function (x) list(
create_trip_graph(x),
htmltools::a("NEXT TRIP",
onclick = 'window.scrollBy(0,950)',
style = 'color:blue; text-decoration:underline;'))) %>%
unlist(recursive = FALSE)
ff <-
combineWidgets(
list = comb_vgraphs,
ncol = 1,
height = 25 * 950,
rowsize = c(24, 1)
)
htmltools::save_html(html = ff, file = "widgets.html")
如果你想每行有 5 个网络地图，代码会变得有点复杂，它也可能导致用户可能必须进行水平滚动才能看到所有内容的情况，这是你通常会做的事情在创建 HTML 页面时要避免。这是每行 5 个地图解决方案的代码：
comb_vgraphs2 <- lapply(1:25, function(x) {
a <- list(create_trip_graph(x))
# We detect whenever we are creating the 5th, 10th, 15th etc. network map
# and add the link after that one.
if (x %% 5 == 0 & x < 25) a[[2]] <- htmltools::a("NEXT 5 TRIPS",
onclick = 'window.scrollBy(0,500)',
style = 'color:blue; text-decoration:underline;')
a
}) %>%
unlist(recursive = FALSE)
ff2 <-
combineWidgets(
list = comb_vgraphs2,
ncol = 6, # We need six columns, 5 for the network maps
# and 1 for the link to scroll the page.
height = 6 * 500,
width = 1700
#rowsize = c(24, 1)
)
# We need to add some white space in for the scrolling by clicking the link to
# still work for the last row.
ff2$widgets[[length(ff2$widgets) + 1]] <- htmltools::div(style = "height: 1000px;")
htmltools::save_html(html = ff2, file = "widgets2.html")
一般来说，我建议您尝试使用 combineWidgets() 的 height 和 width、ncol 和 nrow 参数以获得令人满意的效果解决方案。我在构建它时的策略是首先创建一个没有滚动条的网格 link 并在正确设置网格后添加它。
尺码有效，但乍一看似乎无效。不过还没有准备好。
When you select options, it doesn't trigger the auto-resize functionality within the canvases.
图形对象的 auto-resize 工作得很好。 （您会在 gif 中看到。）
RStudio 中的查看器窗格不是检查编织文件的最佳方式。编织后在浏览器中查看它......特别是如果你想进行更改。似乎有时它认为所有 RStudio 都是容器大小，并且您会在屏幕上看到图表 运行。我确定这是我的编码方式，但这在 Safari 或 Chrome（我没有检查其他浏览器）中似乎不是问题。
我尝试过以多种不同的方式触发 canvas 的大小调整。此代码可能因尝试触发 canvases 的 resize/zoom 范围而存在一些冗余。 （我想我删除了所有不起作用的东西。）也许有了这个，其他人可以弄清楚那部分。
我使用了一些 Shiny 代码，但这是 而不是 使用 Shiny 运行 时间。本质上，静态工作是 R，但动态元素不能在 R 中（即调整事件大小、读取 selections 等）。
在我使用的库中，我调用了shinyRPG。我添加并注释掉了包安装代码，因为该包不是 Cran 包。 （它在 Github。）
我在编码（和这个答案）中所做的假设：
- 您具有 Rmarkdown 的应用知识。
- 这些网络图有 25 张。
- 脚本中没有其他 HTML 小部件。
如果这些不是真的，请告诉我。
YAML
输出选项
---
title: "Just for antonoyaro8"
output:
flexdashboard::flex_dashboard:
orientation: columns
vertical_layout: fill
---
风格
此代码位于 YAML 和第一个 R 代码块之间。在 RMD 的常规文本区域——而不是在 R 块中。
<style>
select {
// A reset of styles, including removing the default dropdown arrow
appearance: none;
background-color: transparent;
border: none;
padding: 0 1em 0 0;
margin: 0;
width: 100%;
font-family: inherit;
font-size: inherit;
cursor: inherit;
line-height: inherit;
}
.select {
display: grid;
grid-template-areas: "select";
align-items: center;
position: relative;
min-width: 15ch;
max-width: 100ch;
border: 1px solid var(--select-border);
border-radius: 0.25em;
padding: 0.25em 0.5em;
font-size: 1.25rem;
cursor: pointer;
line-height: 1.1;
background-color: #fff;
background-image: linear-gradient(to top, #f9f9f9, #fff 33%);
}
select[multiple] {
padding-right: 0;
/* Safari will not show options unless labels fit */
height: 50rem; // how many options show at one time
font-size: 1rem;
}
#column-1 > div.containIt > div.visNetwork canvas {
width: 100%;
height: 80%;
}
.containIt {
display: flex;
flex-flow: row wrap;
flex-grow: 1;
justify-content: space-around;
align-items: flex-start;
align-content: space-around;
overflow: hidden;
height: 100%;
width: 100%;
margin-top: 2vw;
height: 80vh;
widhth: 80vw;
overflow: hidden;
}
</style>
图书馆
接下来是第一个 R 块。您不必在 flexdashboard.
echo = F
```{r setup, include=FALSE}
library(flexdashboard)
library(visNetwork)
library(htmltools)
library(igraph)
library(tidyverse)
library(shinyRPG) # remotes::install_github("RinteRface/shinyRPG")
```
创建图表的 R 代码
下一部分基本上是您的代码。我在调用的最终版本中更改了一些内容以创建 vizNetwork.
```{r dataStuff}
set.seed(123)
n=15
data = data.frame(tibble(d = paste(1:n)))
relations = data.frame(tibble(
from = sample(data$d),
to = lead(from, default=from[1]),
))
data$name = c("new york", "chicago", "los angeles", "orlando", "houston", "seattle", "washington", "baltimore", "atlanta", "las vegas", "oakland", "phoenix", "kansas", "miami", "newark" )
graph = graph_from_data_frame(relations, directed=T, vertices = data)
#red circle: starting point and final point
V(graph)$color <- ifelse(data$d == relations$from[1], "red", "orange")
a = visIgraph(graph)
m_1 = 1
m_2 = 23.6
a = toVisNetworkData(graph) %>%
c(., list(main = paste0("Trip ", m_1, " : "),
submain = paste0 (m_2, "KM") )) %>%
do.call(visNetwork, .) %>%
visIgraphLayout(layout = "layout_in_circle") %>%
visEdges(arrows = 'to')
# collect the correct order
df2 <- data %>%
mutate(d = as.numeric(d),
nuname = factor(a$x$edges$from,
levels = unlist(data$name))) %>%
arrange(nuname) %>%
select(d) %>% unlist(use.names = F)
# [1] 11 5 2 8 7 6 10 14 15 4 12 9 13 3 1
V(graph)$name = data$label = paste0(df2, "\n", data$name)
a = visIgraph(graph)
m_1 = 1
m_2 = 23.6
a = toVisNetworkData(graph) %>%
c(., list(main = list(text = paste0("Trip ", m_1, " : "),
style = "font-family: Georgia; font-size: 100%; font-weight: bold; text-align:center;"),
submain = list(text = paste0(m_2, "KM"),
style = "font-family: Georgia; font-size: 100%; text-align:center;"))) %>%
do.call(visNetwork, .) %>%
visInteraction(navigationButtons = TRUE) %>%
visIgraphLayout(layout = "layout_in_circle") %>%
visEdges(arrows = 'to') %>%
visOptions(width = "100%", height = "80%", autoResize = T)
a[["sizingPolicy"]][["knitr"]][["figure"]] <- FALSE
y = x = w = v = u = t = s = r = q = p = o = n = m = l = k = j = i = h = g = f = e = d = c = b = a
```
Multi-Select 盒子
在最后一个代码块和下一个代码块之前是下一部分的位置。这将创建左列，multi-select 框所在的位置。 （这不在代码块中。）
Column {data-width=200}
-----------------------------------------------------------------------
### Select Options
You can select one or more options from the list.
否构建 select 框并附加将触发更改的函数。这部分将需要修改。 在此处命名用户在屏幕上看到的选项。（此代码中的letters[1:25]。）
您的对象名称不必与您在此处的名称相匹配。不过，它们确实需要以相同的顺序排列。
```{r selectiver}
tagSel <- rpgSelect(
"selectBox", # don't change this (connected)
"Selections:", # visible on HTML; change away or set to ""
c(setNames(1:25, letters[1:25])), # left is values, right is labels
multiple = T # all multiple selections
) # other attributes controlled by css at the top
tagSel$attribs$class <- 'select select--multiple' # connect styles
tagSel$children[[2]]$attribs$class <- "mutli-select" # connect styles
tagSel$children[[2]]$attribs$onchange <- "getOps(this)" # connect the JS function
tagSel
```
网络图
然后在前一个chunk和下一个chunk之间（不在一个chunk中）：
Column
-----------------------------------------------------------------------
<div class="containIt">
现在调用你的图表。
```{r notNow, include=T}
a
b
c
d
e
f
g
h
i
j
k
l
m
n
o
p
q
r
s
t
u
v
w
x
y
```
关闭该块之后的 div 标签：
</div>
最后一个区块：Javascript
这开始的时候很好很整洁...但经过大量的试验和错误后——所见即所得。 在此过程中，有效的评论也逐渐消失了。如果对什么功能有疑问，请告诉我。
如果您 运行 R Markdown 中的块（在源代码窗格中），则该块不会执行任何操作。要执行JS，你必须knit.
```{r pickMe,results='asis',engine='js'}
//remove inherent knitr element-- after using mutlti-select starts harboring space
byeknit = document.querySelector('#column-1 > div.containIt > div.knitr-options');
byeknit.remove(1);
// Reset Sizing of Widgets
h = document.querySelector('#column-1 > div.containIt').clientHeight;
w = document.querySelector('#column-1 > div.containIt').clientWidth;
hw = h * w;
cont = document.querySelectorAll('#column-1 > div.containIt > div');
newHeight = Math.floor(Math.sqrt(hw/cont.length)) * .85;
for(i = 0; i < cont.length; ++i){
cont[i].style.height = newHeight + 'px';
cont[i].style.width = newHeight + 'px';
cn = cont[i].childNodes;
if(cn.length > 0){
th = cn[0].clientHeight + cn[1].clientHeight;
console.log("canvas found");
mb = newheight - th;
cn[5].style.height = mb + 'px'; //canvas control attempt
}
}
function resizePlease(count) { //resize plots based on selections
// screen may have resized**
h = document.querySelector('#column-1 > div.containIt').clientHeight;
w = document.querySelector('#column-1 > div.containIt').clientWidth;
hw = h * w; // get the area
// based on selected count** these should fit---
// RStudio!
newHeight = Math.floor(Math.sqrt(hw/count)) * .85;
for(i = 0; i < graphy.length; ++i){
graphy[i].style.height = newHeight + 'px';
graphy[i].style.width = newHeight + 'px';
gcn = graphy[i].childNodes;
if(cn.length > 0){
th = gcn[0].clientHeight + gcn[1].clientHeight;
mb = newHeight - th;
gcn[5].style.height = mb + 'px'; //canvas control attempt
canYouPLEASElisten = graphy[i].querySelector('canvas');
canYouPLEASElisten.style.height = mb + 'px'; //trigger zoom extent!!
canYouPLEASElisten.style.height = '100%';
}
}
}
// Something selected triggers this function
function getOps(sel) {
//get ref to select list and display text box
graphy = document.querySelectorAll('#column-1 div.visNetwork');
count = 0; // reset count of selected vis
// loop through selections
for(i = 0; i < sel.length; i++) {
opt = sel.options[i];
if ( opt.selected ) {
count++
graphy[i].style.display = 'block';
console.log(opt + "selected");
console.log(count + " options selected");
} else {
graphy[i].style.display = 'none';
}
}
resizePlease(count);
}
```
开发者工具控制台
如果您转到开发人员工具控制台，您将能够看到在制作 select 离子时 select 编辑了多少选项和哪些选项。这样，如果有一些奇怪的事情，比如倒序（我怀疑但无法验证），你会看到你可能预期的发生了什么或没有发生什么。你在哪里看到 console.log，它正在向控制台发送消息，这样你就可以看到发生了什么。
仪表板颜色
如果背景中有任何颜色、自定义或其他颜色，请告诉我。我也可以在这方面提供帮助。现在，仪表板的颜色是默认颜色。