看起来您是 SO 新手；欢迎来到社区！如果您想快速获得很好的答案，最好让您的问题可重现。这包括示例数据，例如来自 dput(head(dataObject)) 的输出以及您正在使用的任何库（如果不是很明显的话）。看看：making R reproducible questions。
现在来回答这个问题...
这个很棘手！突出显示功能并非旨在更改迹线的可见性（ggplot 中的图层 == Plotly 中的迹线）。
首先，我开始识别用于此答案的数据。我使用了 zenplots 包中的数据集 happiness。 （这是《世界幸福报告》几年来的数据。）
我试图坚持你在绘制什么以及你是如何绘制它的一般概念，但其中一些本质上是不同的，因为我没有你的数据。我注意到它破坏了stat_cor 层。让我知道您是否仍想要该层，因为它出现在您的 ggplot 对象中。我可能可以帮忙。不过，你没有在你的问题中提到它。
library(tidyverse)
library(plotly)
library(ggpubr)
data("happiness", package = "zenplots")
d <- highlight_key(happiness,
~Region)
p <-ggplot(d, aes(x = Family, y = Happiness, group = Region,
color = Region, text = Country)) +
labs(y= "Happiness Score", x = "Family", title = "Family and Happiness") +
geom_smooth(aes(group = Region), method = "lm", se = FALSE, size = 0.5) +
geom_point(aes(size = GDP)) +
theme_bw() +
scale_color_manual(values = rainbow(10, alpha = 0.6)) +
scale_size_continuous(range = c(0, 10), name = '')
gg <- ggplotly(p, tooltip = "text") %>%
highlight(on = 'plotly_click', off = 'plotly_doubleclick',
opacityDim = .05)
此时，该图看起来与您在问题中的图比较相似。 （不过，这要忙得多。）
现在我已经密切确定了您结束的情节，我必须隐藏线条，更改图例（因为它只显示线条），然后设置功能以在您更改突出显示时使线条可见你逃脱了亮点。
去除线条可见性；更改图例以反映点。
# First, make the lines invisible (because no groups are highlighted)
# Remove the line legend; add the point legend
invisible(
lapply(1:length(gg$x$data),
function(j){
nm <- gg$x$data[[j]]$name
md <- gg$x$data[[j]]$mode
if(md == "lines") {
gg$x$data[[j]]$visible <<- FALSE
gg$x$data[[j]]$showlegend <<- FALSE
} else {
gg$x$data[[j]]$visible <<- TRUE
gg$x$data[[j]]$showlegend <<- TRUE
}
}
))
此时您可以查看绘图，发现线条不再可见，图例也发生了一些变化。
要为突出显示添加可见性更改，您可以使用 Plotly 事件。如果您对 HTML 或 Javascript 有所了解，这与浏览器中的事件相同。这使用包htmlwidgets。我没有用其他库调用该库，我只是将它附加到函数中。
关于 JS 的一些附加信息：/* */ 的内容是 Javascript 中的注释。我已经添加了这些，所以你可以关注正在发生的事情（如果你愿意的话）。 JS中的curveNumber是Plotly对象的trace号。虽然它在渲染之前只有 20 条迹线；之后有22个。 R 编号元素从 1 开始，而 JS（如大多数语言）从 0 开始。
gg %>% htmlwidgets::onRender(
"function(el, x){
v = [] /* establish outside of the events; used for both */
for (i = 0; i < 22; i++) { /*1st 11 are lines; 2nd 11 are points */
if(i < 12){
v[i] = false;
} else {
v[i] = true;
}
}
console.log(x);
el.on('plotly_click', function(d) {
cn = d.points[0].curveNumber - 10; /*if [8] is the lines, [18] is the points*/
v2 = JSON.parse(JSON.stringify(v)); /*create a deep copy*/
v2[cn] = true;
update = {visible: v2};
Plotly.restyle(el.id, update); /* in case 1 click to diff highlight */
});
el.on('plotly_doubleclick', function(d) {
console.log('out ', d);
update = {visible: v}
console.log('dbl click ' + v);
Plotly.restyle(el.id, update);
});
}")
渲染视图：
从渲染中单击
单击一次单击
单击一次双击
更新以管理文本
要将文本添加到情节中，或者更确切地说修复文本，需要发生几件事。
假设后面的代码是在初始创建ggplotly 对象或gg 之后。
目前，文本跟踪都具有相同的x 和y 值，它们没有key、legendgroup 或name，并且它们是无序的。这也需要对 JS 进行更改。
为了确定它们的顺序以及应该分配的键，我使用了ggplot 对象中的颜色和组分配以及plotly 对象中的颜色。
# collect color order for text
pp <- ggplot_build(p)$data[[3]] %>%
select(colour, group)
k = vector()
invisible( # collect the order they appear in Plotly
lapply(1:length(gg$x$data),
function(q) {
md <- gg$x$data[[q]]$mode
if(md == "text") {
k[q - 20] <<- gg$x$data[[q]]$textfont$color
}
})
)
# they're HEX in ggplot and rgb in Plotly, set up to convert all to hex
k <- str_replace(k, 'rgba\((.*)\)', "\1") %>%
str_replace_all(., ",", " ")
k <- sapply(strsplit(k, " "), function(i){
rgb(i[1], i[2], i[3], maxColorValue = 255)}) %>%
as.data.frame() %>% setNames(., "colour")
现在plotly 颜色是十六进制的，我将加入帧以获取顺序，然后重新排序ggplotly 对象中的轨迹。
colJ = left_join(k, pp) # join and reorder
gg$x$data[21:30] <- gg$x$data[21:30][order(colJ$group)]
接下来，我为文本轨迹创建了一个 y 值向量。我在我的情节中使用了代表y 的变量。
# new vals for y in text traces; use var that is `y` in plot
txy = seq(max(happiness$Happiness, na.rm = T),
min(happiness$Happiness, na.rm = T), # min, max Y in plot
length.out = nrow(happiness %>%
group_by(Region) %>%
summarise(n()))) # no of traces
现在我只需要一个键列表（名称或图例组）。
reg <- happiness$Region %>% unique()
现在，我将使用我用来更新原始答案中可见性的方法的扩展版本。现在，此方法还将用于更新文本格式、添加缺失内容、更新 y 值和添加对齐方式。你应该像我的例子一样有 30 条痕迹，所以这些数字有效。
invisible(
lapply(1:length(gg$x$data),
function(j){
nm <- gg$x$data[[j]]$name
md <- gg$x$data[[j]]$mode
if(md == "lines") {
gg$x$data[[j]]$visible <<- FALSE
gg$x$data[[j]]$showlegend <<- FALSE
}
if(md == "markers") {
gg$x$data[[j]]$visible <<- TRUE
gg$x$data[[j]]$showlegend <<- TRUE
}
if(md == "text") {
tx = gg$x$data[[j]]$text
message(nm)
tx = str_replace(tx, "italic\((.*)\)", "<i>\1</i>") %>%
str_replace_all(., "`", "") %>% str_replace_all(., "~", " ") %>%
str_replace(., "\^2", "<sup>2</sup>")
gg$x$data[[j]]$text <<- tx
gg$x$data[[j]]$y <<- txy[j - 20]
gg$x$data[[j]]$textposition <<- "middle right"
gg$x$data[[j]]$visible <<- TRUE
gg$x$data[[j]]$key <<- list(reg[j - 20]) # for highlighting
gg$x$data[[j]]$name <<- reg[j - 20] # for highlighting
gg$x$data[[j]]$legendgroup <<- reg[j - 20] # for highlighting
}
}
))
现在为JS。我试图让它更有活力。
gg %>% htmlwidgets::onRender(
"function(el, x){
v = [] /* establish outside of the events; used for both */
for (i = 0; i < x.data.length; i++) { /* data doesn't necessarily equate to traces here*/
if(x.data[i].mode === 'lines'){
v[i] = false;
} else if (x.data[i].mode === 'markers' || x.data[i].mode === 'text') {
v[i] = true;
} else {
v[i] = true;
}
}
const gimme = x.data.map(elem => elem.name);
el.on('plotly_click', function(d) {
var nn = d.points[0].data.name
v2 = JSON.parse(JSON.stringify(v)); /*create a deep copy*/
for(i = 0; i < gimme.length; i++){
if(gimme[i] === nn){ /*matching keys visible*/
v2[i] = true;
}
}
var chk = d.points[0].yaxis._traceIndices.length
if(v2.length !== chk) { /*validate the trace count every time*/
tellMe = chk - v2.length;
more = Array(tellMe).fill(true);
v2 = v2.concat(more); /*make any new traces visible*/
}
update = {visible: v2};
Plotly.restyle(el.id, update); /* in case 1 click to diff highlight */
});
el.on('plotly_doubleclick', function(d) {
update = {visible: v} /*reset styles*/
Plotly.restyle(el.id, update);
});
}")