R 用ggplot2绘制仪表盘图

仪表盘图一盘我们常见于测速、或者指示等（如温湿度计、汽车速度表等），实质上和直角坐标图一样，只是把原来的横轴画成了圆形，横轴的值就标度在圆周上，纵轴的值用不同颜色表示阶段或者提示，指针位置表示当前的数值信息。

相对来说我们较少用到，偶然发现在stackoverflow上有人提问并且有大神已经做了代码分享，简单做了调整供读者学习：

# 引用自https://www.r-bloggers.com/2020/10/multiple-gauge-plots-with-facet-wrap/
gauge_plot <- function(vals, breaks=c(0,30,70,100), ncol= NULL) {
    require(ggplot2)
    require(ggthemes)
    require(dplyr)
    require(tidyr)
    
    if (!is.data.frame(vals)) stop("Vals must be a dataframe")
    if (!dim(vals)[2]==2) stop("Vals must have two columns")
    if (!is.numeric(vals$pos)) stop("Dataframe variable pos must be numeric")
    
    
    # 生成多边形函数
    get_poly <- function(a,b,r1=0.5,r2=1.0) {
        th.start <- pi*(1-a/100)
        th.end <- pi*(1-b/100)
        th <- seq(th.start,th.end,length=100)
        x <- c(r1*cos(th),rev(r2*cos(th)))
        y <- c(r1*sin(th),rev(r2*sin(th)))
        df <- data.frame(x,y)
        return(df)
    }
    
    
    # 根据breaks参数创建segments
    segments <- list()
    seg_names <- tibble(x = c("a", "c", "e"), y = c("b", "d" ,"f"))
    
    for(n in 1:3){
        i <-breaks[n]
        j <-breaks[n+1]
        df <- get_poly(i, j)       
        names(df) <- seg_names[n,]
        segments$df[[n]] <- df
    }
    dfs <- bind_cols(segments)
    # 为每个指标创建segments 
    pnt <- tibble()
    for (name in vals$metric){
        pnt[1:nrow(dfs), name] <- name
    }
    
    dfp <- dfs %>% 
        cbind(pnt) %>% 
        pivot_longer(-c(a:f), names_to = "metric") %>% 
        select(-value)
    
    # 创建指针
    needles <- list()
    for(p in 1:nrow(vals)){
        i <-vals$pos[p] - 1
        j <-vals$pos[p] + 1
        r1 <- 0.2
        df <- get_poly(i, j, r1)  
        df$metric <- vals$metric[p]
        needles$df[[p]] <- df
    }
    
    dfn <- bind_rows(needles)
    
    
    # 绘图
    ggplot()+
        geom_polygon(data=dfp, aes(a,b), fill="red")+
        geom_polygon(data=dfp, aes(c,d), fill="gold")+
        geom_polygon(data=dfp, aes(e,f), fill="forestgreen")+
        geom_polygon(data=dfn, aes(x,y))+
        geom_text(data=as.data.frame(breaks), size=3, fontface="bold", vjust=0,
                  aes(x=1.05*cos(pi*(1-breaks/100)),y=1.05*sin(pi*(1-breaks/100)),label=breaks))+
        geom_text(data=vals, aes(x=0,y=0), label=paste0(vals$pos,"%"), vjust=0, size=4, fontface="bold")+
        # 分面
        coord_fixed()+
        theme_few()+
        theme(axis.text=element_blank(),
              axis.title=element_blank(),
              axis.ticks=element_blank(),
              panel.grid=element_blank(),
              panel.border=element_blank()) +
        facet_wrap(~metric, strip.position = "bottom", ncol = ncol) +
        labs(title = "Multiple Gauge Plots \n Facet Wrap")
}

# 示例数据
data <- data.frame(pos=c(89,56,45,54), metric=c("A", "B", "C", "D"))
gauge_plot(data)

参考资料：

1.https://www.r-bloggers.com/2020/10/multiple-gauge-plots-with-facet-wrap/