我如何在R中绘制下图?
Red = 30
Yellow = 40
Green = 30
Needle at 52.
Run Code Online (Sandbox Code Playgroud)
请帮助我,因为我非常需要.
谢谢
jlh*_*ard 28
所以这是一个完全ggplot
解决方案.
注意:从原始帖子编辑,在规格中断处添加数字指示符和标签,这似乎是OP在评论中要求的.如果不需要指示,请删除该annotate(...)
行.如果不需要标签,请删除geom_text(...)
行.
gg.gauge <- function(pos,breaks=c(0,30,70,100)) {
require(ggplot2)
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)))
return(data.frame(x,y))
}
ggplot()+
geom_polygon(data=get.poly(breaks[1],breaks[2]),aes(x,y),fill="red")+
geom_polygon(data=get.poly(breaks[2],breaks[3]),aes(x,y),fill="gold")+
geom_polygon(data=get.poly(breaks[3],breaks[4]),aes(x,y),fill="forestgreen")+
geom_polygon(data=get.poly(pos-1,pos+1,0.2),aes(x,y))+
geom_text(data=as.data.frame(breaks), size=5, fontface="bold", vjust=0,
aes(x=1.1*cos(pi*(1-breaks/100)),y=1.1*sin(pi*(1-breaks/100)),label=paste0(breaks,"%")))+
annotate("text",x=0,y=0,label=pos,vjust=0,size=8,fontface="bold")+
coord_fixed()+
theme_bw()+
theme(axis.text=element_blank(),
axis.title=element_blank(),
axis.ticks=element_blank(),
panel.grid=element_blank(),
panel.border=element_blank())
}
gg.gauge(52,breaks=c(0,35,70,100))
Run Code Online (Sandbox Code Playgroud)
## multiple guages
library(gridExtra)
grid.newpage()
grid.draw(arrangeGrob(gg.gauge(10),gg.gauge(20),
gg.gauge(52),gg.gauge(90),ncol=2))
Run Code Online (Sandbox Code Playgroud)
你可能需要调整size=...
参数geom_text(...)
,并annotate(...)
根据您的仪表的实际大小.
IMO段标签是一个非常糟糕的主意:它们使图像混乱并破坏了图形的目的(一目了然地指示度量标准是在"安全","警告"还是"危险"区域).
这是使用网格图形的非常快速和脏的实现
library(grid)
draw.gauge<-function(x, from=0, to=100, breaks=3,
label=NULL, axis=TRUE, cols=c("red","yellow","green")) {
if (length(breaks)==1) {
breaks <- seq(0, 1, length.out=breaks+1)
} else {
breaks <- (breaks-from)/(to-from)
}
stopifnot(length(breaks) == (length(cols)+1))
arch<-function(theta.start, theta.end, r1=1, r2=.5, col="grey", n=100) {
t<-seq(theta.start, theta.end, length.out=n)
t<-(1-t)*pi
x<-c(r1*cos(t), r2*cos(rev(t)))
y<-c(r1*sin(t), r2*sin(rev(t)))
grid.polygon(x,y, default.units="native", gp=gpar(fill=col))
}
tick<-function(theta, r, w=.01) {
t<-(1-theta)*pi
x<-c(r*cos(t-w), r*cos(t+w), 0)
y<-c(r*sin(t-w), r*sin(t+w), 0)
grid.polygon(x,y, default.units="native", gp=gpar(fill="grey"))
}
addlabel<-function(m, theta, r) {
t<-(1-theta)*pi
x<-r*cos(t)
y<-r*sin(t)
grid.text(m,x,y, default.units="native")
}
pushViewport(viewport(w=.8, h=.40, xscale=c(-1,1), yscale=c(0,1)))
bp <- split(t(embed(breaks, 2)), 1:2)
do.call(Map, list(arch, theta.start=bp[[1]],theta.end=bp[[2]], col=cols))
p<-(x-from)/(to-from)
if (!is.null(axis)) {
if(is.logical(axis) && axis) {
m <- round(breaks*(to-from)+from,0)
} else if (is.function(axis)) {
m <- axis(breaks, from, to)
} else if(is.character(axis)) {
m <- axis
} else {
m <- character(0)
}
if(length(m)>0) addlabel(m, breaks, 1.10)
}
tick(p, 1.03)
if(!is.null(label)) {
if(is.logical(label) && label) {
m <- x
} else if (is.function(label)) {
m <- label(x)
} else {
m <- label
}
addlabel(m, p, 1.15)
}
upViewport()
}
Run Code Online (Sandbox Code Playgroud)
此功能可用于绘制一个仪表
grid.newpage()
draw.gauge(100*runif(1))
Run Code Online (Sandbox Code Playgroud)
或许多仪表
grid.newpage()
pushViewport(viewport(layout=grid.layout(2,2)))
for(i in 1:4) {
pushViewport(viewport(layout.pos.col=(i-1) %/%2 +1, layout.pos.row=(i-1) %% 2 + 1))
draw.gauge(100*runif(1))
upViewport()
}
popViewport()
Run Code Online (Sandbox Code Playgroud)
这不是太花哨,所以应该很容易定制.
您现在还可以添加标签
draw.gauge(75, label="75%")
Run Code Online (Sandbox Code Playgroud)
我添加了另一个更新以允许绘制"轴".您可以将其设置为TRUE以使用默认值,或者您可以传入一个字符向量来提供您想要的任何标签,或者您可以传入一个将中断(缩放0-1)和from/to值的函数并应返回一个字符值.
grid.newpage()
draw.gauge(100*runif(1), breaks=c(0,30,70,100), axis=T)
Run Code Online (Sandbox Code Playgroud)