R语言中能否为Plotly有效前沿图添加饼图式图形提示框？

要在Plotly的提示框中展示资产配置的饼图，核心思路是利用Plotly支持HTML格式提示框的特性，为每个有效前沿上的点生成对应资产配置的迷你饼图SVG代码，将其嵌入提示框的HTML内容中。以下是完整的实现方案：

1. 编写生成迷你饼图SVG的函数 #

这个函数接收资产权重向量，输出可直接嵌入HTML的SVG代码，控制饼图的大小、颜色和标签样式：

generate_pie_tooltip <- function(weights, assets, colors = NULL) {
  if (is.null(colors)) {
    colors <- scales::hue_pal()(length(assets))
  }
  
  angles <- c(0, cumsum(weights) * 2 * pi)
  svg_width <- 120
  svg_height <- 120
  center_x <- svg_width / 2
  center_y <- svg_height / 2
  radius <- min(svg_width, svg_height) / 2.5
  
  path_strings <- lapply(seq_along(weights), function(i) {
    start_angle <- angles[i]
    end_angle <- angles[i+1]
    start_x <- center_x + radius * cos(start_angle)
    start_y <- center_y + radius * sin(start_angle)
    end_x <- center_x + radius * cos(end_angle)
    end_y <- center_y + radius * sin(end_angle)
    large_arc <- ifelse(end_angle - start_angle > pi, 1, 0)
    
    sprintf(
      '<path d="M %f %f L %f %f A %f %f 0 %d 1 %f %f Z" fill="%s"/>',
      center_x, center_y, start_x, start_y, radius, radius, large_arc, end_x, end_y, colors[i]
    )
  })
  
  svg <- sprintf(
    '<svg width="%d" height="%d" viewBox="0 0 %d %d">%s</svg>',
    svg_width, svg_height, svg_width, svg_height, paste(path_strings, collapse = "")
  )
  
  label_strings <- lapply(seq_along(assets), function(i) {
    sprintf("<div>%s: %s</div>", assets[i], scales::percent(weights[i], 0.01))
  })
  
  paste0(svg, "<div style='text-align:center;'>", paste(label_strings, collapse = ""), "</div>")
}

2. 修正原代码的循环逻辑 #

原循环中重复向同一个portfolio对象添加约束会导致错误，每次循环需重新初始化portfolio：

# 初始化基础portfolio，避免循环中累积约束
base_p <- portfolio.spec(assets = colnames(returns.data))
base_p <- add.constraint(base_p, type = "box", min = 0.05, max = 0.8)
base_p <- add.constraint(base_p, type = "full_investment")
base_p <- add.constraint(base_p, type="long_only")

for(i in 1:length(vec)){
  # 每次循环创建新的portfolio副本
  p <- base_p
  p <- add.constraint(p, type = "return", name = "mean", return_target = vec[i])
  p <- add.objective(p, type = "risk", name = "var")
  
  eff.opt <- optimize.portfolio(returns.data, p, optimize_method = "ROI")
  
  eff.frontier$Risk[i] <- sqrt(t(eff.opt$weights) %*% covMat %*% eff.opt$weights)
  eff.frontier$Return[i] <- eff.opt$weights %*% meanReturns
  frontier.weights[i,] = eff.opt$weights
}

3. 生成每个点的饼图提示框内容 #

将权重数据转换为带饼图的HTML提示框：

all.efficient<-as.data.frame(cbind(eff.frontier,frontier.weights))

# 为每一行生成饼图提示框
all.efficient$tooltip <- apply(all.efficient[,c("MSFT","NVDA","IBM","AAPL","AMZN")], 1, function(row) {
  generate_pie_tooltip(row, colnames(returns.data))
})

4. 构建ggplot并转换为Plotly图表 #

在ggplot的aes中指定text=tooltip，并在ggplotly中启用HTML渲染：

p<-ggplot(NULL, aes(x,y)) +
  geom_point(data=all.efficient, aes(x=Risk, y = Return, text=tooltip),color='red') +
  scale_y_continuous(labels = scales::percent) +
  scale_x_continuous(labels = scales::percent) +
  ggtitle("Efficient frontier") +
  theme(plot.title = element_text(hjust = 0.5))

# 转换为Plotly并启用HTML提示框
ggplotly(p, tooltip = "text") %>%
  config(tooltip = "text") %>%
  layout(hovermode = "closest")

完整可运行代码 #

library(PortfolioAnalytics)
library(quantmod)
library(PerformanceAnalytics)
library(zoo)
library(plotly)
library(scales)

# 生成饼图提示框的函数
generate_pie_tooltip <- function(weights, assets, colors = NULL) {
  if (is.null(colors)) {
    colors <- scales::hue_pal()(length(assets))
  }
  
  angles <- c(0, cumsum(weights) * 2 * pi)
  svg_width <- 120
  svg_height <- 120
  center_x <- svg_width / 2
  center_y <- svg_height / 2
  radius <- min(svg_width, svg_height) / 2.5
  
  path_strings <- lapply(seq_along(weights), function(i) {
    start_angle <- angles[i]
    end_angle <- angles[i+1]
    start_x <- center_x + radius * cos(start_angle)
    start_y <- center_y + radius * sin(start_angle)
    end_x <- center_x + radius * cos(end_angle)
    end_y <- center_y + radius * sin(end_angle)
    large_arc <- ifelse(end_angle - start_angle > pi, 1, 0)
    
    sprintf(
      '<path d="M %f %f L %f %f A %f %f 0 %d 1 %f %f Z" fill="%s"/>',
      center_x, center_y, start_x, start_y, radius, radius, large_arc, end_x, end_y, colors[i]
    )
  })
  
  svg <- sprintf(
    '<svg width="%d" height="%d" viewBox="0 0 %d %d">%s</svg>',
    svg_width, svg_height, svg_width, svg_height, paste(path_strings, collapse = "")
  )
  
  label_strings <- lapply(seq_along(assets), function(i) {
    sprintf("<div>%s: %s</div>", assets[i], scales::percent(weights[i], 0.01))
  })
  
  paste0(svg, "<div style='text-align:center;'>", paste(label_strings, collapse = ""), "</div>")
}

# 获取数据
getSymbols(c("MSFT", "NVDA", "IBM", "AAPL", "AMZN"),from = "2015-01-01",src = 'yahoo')

# 处理价格和收益数据
prices.data <- merge.zoo(MSFT[,6], NVDA[,6], IBM[,6], AAPL[,6], AMZN[,6])
returns.data <- sapply(prices.data, CalculateReturns)
returns.data <- na.omit(returns.data)
colnames(returns.data) <- c("MSFT", "NVDA", "IBM", "AAPL", "AMZN")

meanReturns <- colMeans(returns.data)
covMat <- cov(returns.data)

# 初始化基础portfolio
base_p <- portfolio.spec(assets = colnames(returns.data))
base_p <- add.constraint(base_p, type = "box", min = 0.05, max = 0.8)
base_p <- add.constraint(base_p, type = "full_investment")
base_p <- add.constraint(base_p, type="long_only")

randomport<- random_portfolios(base_p, permutations = 50000, rp_method = "sample")

# 计算有效前沿
minret <- min(meanReturns)
maxret <- max(meanReturns)
vec <- seq(minret, maxret, length.out = 100)

eff.frontier <- data.frame(Risk =vector("numeric", length(vec)) ,
                           Return = vector("numeric", length(vec)))

frontier.weights <- mat.or.vec(nr = length(vec), nc = ncol(returns.data))
colnames(frontier.weights) <- colnames(returns.data)

for(i in 1:length(vec)){
  p <- base_p
  p <- add.constraint(p, type = "return", name = "mean", return_target = vec[i])
  p <- add.objective(p, type = "risk", name = "var")
  
  eff.opt <- optimize.portfolio(returns.data, p, optimize_method = "ROI")
  
  eff.frontier$Risk[i] <- sqrt(t(eff.opt$weights) %*% covMat %*% eff.opt$weights)
  eff.frontier$Return[i] <- eff.opt$weights %*% meanReturns
  frontier.weights[i,] = eff.opt$weights
}

eff.frontier$Sharperatio <- eff.frontier$Return / eff.frontier$Risk
all.efficient<-as.data.frame(cbind(eff.frontier,frontier.weights))

# 生成每个点的饼图提示框
all.efficient$tooltip <- apply(all.efficient[,c("MSFT","NVDA","IBM","AAPL","AMZN")], 1, function(row) {
  generate_pie_tooltip(row, colnames(returns.data))
})

# 绘制图表
p<-ggplot(NULL, aes(x,y)) +
  geom_point(data=all.efficient, aes(x=Risk, y = Return, text=tooltip),color='red') +
  scale_y_continuous(labels = scales::percent) +
  scale_x_continuous(labels = scales::percent) +
  ggtitle("Efficient frontier") +
  theme(plot.title = element_text(hjust = 0.5))

ggplotly(p, tooltip = "text") %>%
  config(tooltip = "text") %>%
  layout(hovermode = "closest")

关键说明 #

• generate_pie_tooltip函数直接生成SVG代码，无需额外依赖包，兼容性强
• 修正了原循环中重复添加约束的问题，避免portfolio对象累积无效配置
• Plotly通过tooltip="text"指定使用自定义HTML内容，自动渲染SVG饼图和资产占比标签

内容的提问来源于stack exchange，提问作者WorkingJoe