如何在ggplot2中正确绘制投影网格数据?

23

多年来,我一直使用 ggplot2 绘制气候栅格数据。这些数据通常是投影的 NetCDF 文件。在模型坐标中,单元格是正方形的,但取决于模型使用的投影方式,在真实世界中可能并非如此。

我的常规做法是首先将数据重新映射到适当的规则网格上,然后再绘制。这会对数据进行小的修改,通常是可以接受的。

然而,我已经决定这不再足够好:我想直接绘制投影数据,而不需要重新映射,就像其他程序(例如 ncl)可以做到的那样,如果我没有弄错,而不会接触模型输出值。

但是,我遇到了一些问题。我将从最简单到最复杂地逐步讲解可能的解决方案及其问题。我们能克服它们吗?

编辑:感谢 @lbusett 的回答,我得到了这个很棒的函数(链接),它包含了解决方案。如果您喜欢它,请为@lbusett 的回答点赞!

初始设置

#Load packages
library(raster)
library(ggplot2)

#This gives you the starting data, 's'
load(url('https://files.fm/down.php?i=kew5pxw7&n=loadme.Rdata'))
#If you cannot download the data, maybe you can try to manually download it from http://s000.tinyupload.com/index.php?file_id=04134338934836605121

#Check the data projection, it's Lambert Conformal Conic
projection(s)
#The data (precipitation) has a 'model' grid (125x125, units are integers from 1 to 125)
#for each point a lat-lon value is also assigned
pr <- s[[1]]
lon <- s[[2]]
lat <- s[[3]]

#Lets get the data into data.frames
#Gridded in model units:
pr_df_basic <- as.data.frame(pr, xy=TRUE)
colnames(pr_df_basic) <- c('lon', 'lat', 'pr')
#Projected points:
pr_df <- data.frame(lat=lat[], lon=lon[], pr=pr[])

我们创建了两个数据框,一个包含模型坐标,另一个包含每个模型单元格的实际纬度-经度交点(中心)。

可选:使用较小的域

如果您想更清楚地看到单元格的形状,可以对数据进行子集并仅提取少量的模型单元格。只要小心,您可能需要调整点大小、绘图限制和其他参数。您可以像这样对数据进行子集,然后重新执行上面的代码部分(减去 load() 部分):

s <- crop(s, extent(c(100,120,30,50)))

如果你想完全理解问题,也许你想尝试大区域和小区域。代码是相同的,只有点的大小和地图限制不同。下面的值是针对大完整领域的。

好的,现在让我们绘制!

从瓷砖开始

最显而易见的解决方案是使用瓷砖。让我们来尝试一下。

my_theme <- theme_bw() + theme(panel.ontop=TRUE, panel.background=element_blank())
my_cols <- scale_color_distiller(palette='Spectral')
my_fill <- scale_fill_distiller(palette='Spectral')

#Really unprojected square plot:
ggplot(pr_df_basic, aes(y=lat, x=lon, fill=pr)) + geom_tile() + my_theme + my_fill

这就是结果: 在此输入图片描述

现在更进一步:我们使用真实的LAT-LON,使用方形瓦片

ggplot(pr_df, aes(y=lat, x=lon, fill=pr)) + geom_tile(width=1.2, height=1.2) +
    borders('world', xlim=range(pr_df$lon), ylim=range(pr_df$lat), colour='black') + my_theme + my_fill +
    coord_quickmap(xlim=range(pr_df$lon), ylim=range(pr_df$lat)) #the result is weird boxes...

输入图像描述

好的,但那些不是真正的模型正方形,这只是一个hack。而且,模型框在域的顶部发散,并且都以相同的方式定向。不好看。让我们投影正方形自己,即使我们已经知道这不是正确的做法...也许看起来不错。

#This takes a while, maybe you can trust me with the result
ggplot(pr_df, aes(y=lat, x=lon, fill=pr)) + geom_tile(width=1.5, height=1.5) +
    borders('world', xlim=range(pr_df$lon), ylim=range(pr_df$lat), colour='black') + my_theme + my_fill +
    coord_map('lambert', lat0=30, lat1=65, xlim=c(-20, 39), ylim=c(19, 75))

输入图像描述

首先,这需要很多时间。这是不可接受的。而且,再次强调:这些不是正确的模型单元。

尝试使用点而不是瓷砖

也许我们可以使用圆形或正方形的点来代替瓷砖,并进行投影!

#Basic 'unprojected' point plot
ggplot(pr_df, aes(y=lat, x=lon, color=pr)) + geom_point(size=2) +
    borders('world', xlim=range(pr_df$lon), ylim=range(pr_df$lat), colour='black') + my_cols + my_theme +
    coord_quickmap(xlim=range(pr_df$lon), ylim=range(pr_df$lat))

图片描述

我们可以使用方形点...和投影!我们会更接近,尽管我们知道它仍然不正确。

#In the following plot pointsize, xlim and ylim were manually set. Setting the wrong values leads to bad results.
#Also the lambert projection values were tired and guessed from the model CRS
ggplot(pr_df, aes(y=lat, x=lon, color=pr)) +
    geom_point(size=2, shape=15) +
    borders('world', xlim=range(pr_df$lon), ylim=range(pr_df$lat), colour='black') + my_theme + my_cols +
    coord_map('lambert', lat0=30, lat1=65, xlim=c(-20, 39), ylim=c(19, 75))

enter image description here

虽然结果还不错,但并不完全是自动化的,而且绘制点也不够好。我需要真正的模型单元格,并在投影中改变它们的形状!

多边形,也许?

所以,正如您所见,我正在寻找一种正确地绘制模型框作为正确形状和位置的投影的方法。当然,模型框,在模型中是正方形,一旦投影后就变成了不规则的形状。所以也许我可以使用多边形,并对它们进行投影?我尝试使用 rasterToPolygonsfortify,并遵循这篇文章,但我没有成功。我已经尝试过这个:

pr2poly <- rasterToPolygons(pr)
#http://mazamascience.com/WorkingWithData/?p=1494
pr2poly@data$id <- rownames(pr2poly@data)
tmp <- fortify(pr2poly, region = "id")
tmp2 <- merge(tmp, pr2poly@data, by = "id")
ggplot(tmp2, aes(x=long, y=lat, group = group, fill=Total.precipitation.flux)) + geom_polygon() + my_fill

这里输入图片描述

好的,让我们尝试替换lat-lon...

tmp2$long <- lon[]
tmp2$lat <- lat[]
#Mh, does not work! See below:
ggplot(tmp2, aes(x=long, y=lat, group = group, fill=Total.precipitation.flux)) + geom_polygon() + my_fill

这里输入图片描述

唉,即使用投影方式也不值得尝试。也许我应该尝试计算模型单元格角落处的纬度和经度,并为其创建多边形,然后重新投影?

结论

  1. 我想在本地网格上绘制投影模型数据,但我无法做到。使用瓷砖是不正确的,使用点是hackish的,而使用多边形似乎由于原因不明而无法正常工作。
  2. 通过 coord_map() 进行投影时,网格线和轴标签是错误的。这使得经过投影的ggplots无法用于出版物。

@Marcelo 正如之前所述,问题的重点在于我不想对数据值进行任何修改。因此,我不能重新映射,这通常是我制作此类图表时所做的事情。 - AF7
@LoBu 我不明白。当然,你最终会得到错误的坐标系,因为x-y坐标只是模型坐标,范围从1到125。这就是为什么要有单独的变量进行纬度-经度映射的原因。 - AF7
@AF7 我的意思只是,那么你就不应该将数据集保存为 RasterStack 对象。这可能会导致混淆,因为例如标准的 raster 处理例程,如 projectRaster,将无法正常工作。以我的看法,将其保存为 SpatialPixelsDataFrame 会更好。 - lbusett
@LoBu 原始数据集是netCDF格式,我通常使用raster包读取。如果需要在R内部进行投影,则可以按照以下出色的说明操作:https://gis.stackexchange.com/questions/120900/plotting-netcdf-file-using-lat-and-lon-contained-in-variables - AF7
@JacobSocolar 如果您将多边形绘制到PDF中,则图形设备的分辨率并不重要。我想要这样做的主要原因是我想达到其他软件具有的同样精度水平。我喜欢用R和ggplot绘图,但知道相当糟糕的“NCL”可以绘制更精确的图表真的很烦人 :) 另一方面,其他NetCDF绘图软件(如GrADS和我认为Ferret)会自动重新映射到其内部高分辨率LAT-LON网格上,而不让用户知道它。这些图被认为是可以接受的,但我希望做得更好。 - AF7
显示剩余13条评论
2个回答

19

经过进一步了解,您的模型似乎是基于“兰伯特圆锥投影”中50公里常规网格构建的。然而,netcdf中的坐标是“单元格”中心的纬度-经度WGS84坐标。

鉴于此,更简单的方法是在原始投影中重建单元格,然后将其转换为sf对象并绘制多边形,最终进行投影变换。类似这样的代码应该可以工作(请注意,您需要从github安装ggplot2devel版本才能使其正常工作):

load(url('https://files.fm/down.php?i=kew5pxw7&n=loadme.Rdata'))
library(raster)
library(sf)
library(tidyverse)
library(maps)
devtools::install_github("hadley/ggplot2")

#   ____________________________________________________________________________
#   Transform original data to a SpatialPointsDataFrame in 4326 proj        ####

coords = data.frame(lat = values(s[[2]]), lon = values(s[[3]]))
spPoints <- SpatialPointsDataFrame(coords, 
                                   data = data.frame(data = values(s[[1]])), 
                                   proj4string = CRS("+init=epsg:4326"))

#   ____________________________________________________________________________
#   Convert back the lat-lon coordinates of the points to the original      ###
#   projection of the model (lcc), then convert the points to polygons in lcc
#   projection and convert to an `sf` object to facilitate plotting

orig_grid = spTransform(spPoints, projection(s))
polys = as(SpatialPixelsDataFrame(orig_grid, orig_grid@data, tolerance = 0.149842),"SpatialPolygonsDataFrame")
polys_sf = as(polys, "sf")
points_sf = as(orig_grid, "sf")

#   ____________________________________________________________________________
#   Plot using ggplot - note that now you can reproject on the fly to any    ###
#   projection using `coord_sf`

# Plot in original  projection (note that in this case the cells are squared): 
my_theme <- theme_bw() + theme(panel.ontop=TRUE, panel.background=element_blank())

ggplot(polys_sf) +
  geom_sf(aes(fill = data)) + 
  scale_fill_distiller(palette='Spectral') +
  ggtitle("Precipitations") +
  coord_sf() + 
  my_theme 

enter image description here

# Now Plot in WGS84 latlon projection and add borders: 

ggplot(polys_sf) +
  geom_sf(aes(fill = data)) + 
  scale_fill_distiller(palette='Spectral') +
  ggtitle("Precipitations")  +
  borders('world', colour='black')+
  coord_sf(crs = st_crs(4326), xlim = c(-60, 80), ylim = c(15, 75))+
  my_theme 

enter image description here

如果在原始投影中绘制时想要添加边框,您需要提供多边形边界作为sf对象。可以参考以下代码:

将“map”对象转换为“SpatialPolygon”对象

类似以下代码即可实现:

library(maptools)
borders  <- map("world", fill = T, plot = F)
IDs      <- seq(1,1627,1)
borders  <- map2SpatialPolygons(borders, IDs=borders$names, 
                               proj4string=CRS("+proj=longlat +datum=WGS84")) %>% 
            as("sf")

ggplot(polys_sf) +
  geom_sf(aes(fill = data), color = "transparent") + 
  geom_sf(data = borders, fill = "transparent", color = "black") +
  scale_fill_distiller(palette='Spectral') +
  ggtitle("Precipitations") +
  coord_sf(crs = st_crs(projection(s)), 
           xlim = st_bbox(polys_sf)[c(1,3)],
           ylim = st_bbox(polys_sf)[c(2,4)]) +
  my_theme

enter image description here

作为一个旁注,现在我们“恢复”了正确的空间参考,也可以构建一个正确的光栅数据集。例如:
r <- s[[1]]
extent(r) <- extent(orig_grid) + 50000

会在 r 中为您提供一个适当的 栅格

r
class       : RasterLayer 
band        : 1  (of  36  bands)
dimensions  : 125, 125, 15625  (nrow, ncol, ncell)
resolution  : 50000, 50000  (x, y)
extent      : -3150000, 3100000, -3150000, 3100000  (xmin, xmax, ymin, ymax)
coord. ref. : +proj=lcc +lat_1=30. +lat_2=65. +lat_0=48. +lon_0=9.75 +x_0=-25000. +y_0=-25000. +ellps=sphere +a=6371229. +b=6371229. +units=m +no_defs 
data source : in memory
names       : Total.precipitation.flux 
values      : 0, 0.0002373317  (min, max)
z-value     : 1998-01-16 10:30:00 
zvar        : pr 

现在分辨率为50公里,范围以公制坐标表示。因此,您可以使用 raster 数据的函数来绘制/处理 r,例如:

library(rasterVis)
gplot(r) + geom_tile(aes(fill = value)) + 
  scale_fill_distiller(palette="Spectral", na.value = "transparent") +
  my_theme  

library(mapview)
mapview(r, legend = TRUE)  

1
对象'transf'未找到。您是如何得到“公差”的?为什么有必要执行到epsg:4326的remap?这会引入(虽然很小的)误差吗? - AF7
1
这是因为borders("world",...)不是一个sf对象,因此显然没有应用“重投影”。请参阅更新的答案以获取解决方法。 - lbusett
谢谢。我在Github上提交了一个ggplot问题,因为这似乎是一个bug。https://github.com/tidyverse/ggplot2/issues/2118 - AF7
1
你需要将范围增加半个像素,因为raster对象的范围是计算在单元格的角落上的。我使用50000,因为当“求和”到一个extent对象时,范围会向所有方向扩展半个值(我通过试错发现了这一点)。 - lbusett
1
好主意。我会在答案中加入这个。另外,在你添加到问题中的函数中,考虑一下是否可以删除points_sf = as(orig_grid, "sf")这行代码。这是测试单元格多边形是否与点正确对齐时留下的痕迹。 - lbusett
显示剩余7条评论

5

通过“缩放”查看细胞中心点。您可以看到它们位于矩形网格中。

Wales Points

我按以下方式计算多边形的顶点。

  • 将125x125个纬度和经度转换为矩阵

  • 初始化126x126单元格的顶点矩阵(角落)。

  • 计算单元格顶点,即每个2x2点组的平均位置。

  • 添加边和角的单元格顶点(假设单元格的宽度和高度等于相邻单元格的宽度和高度)。

  • 生成数据框,其中每个单元格都有四个顶点,因此我们最终拥有4x125x125行。

代码如下:

 pr <- s[[1]]
lon <- s[[2]]
lat <- s[[3]]

#Lets get the data into data.frames
#Gridded in model units:
#Projected points:
lat_m <- as.matrix(lat)
lon_m <- as.matrix(lon)
pr_m <- as.matrix(pr)

#Initialize emptry matrix for vertices
lat_mv <- matrix(,nrow = 126,ncol = 126)
lon_mv <- matrix(,nrow = 126,ncol = 126)


#Calculate centre of each set of (2x2) points to use as vertices
lat_mv[2:125,2:125] <- (lat_m[1:124,1:124] + lat_m[2:125,1:124] + lat_m[2:125,2:125] + lat_m[1:124,2:125])/4
lon_mv[2:125,2:125] <- (lon_m[1:124,1:124] + lon_m[2:125,1:124] + lon_m[2:125,2:125] + lon_m[1:124,2:125])/4

#Top edge
lat_mv[1,2:125] <- lat_mv[2,2:125] - (lat_mv[3,2:125] - lat_mv[2,2:125])
lon_mv[1,2:125] <- lon_mv[2,2:125] - (lon_mv[3,2:125] - lon_mv[2,2:125])

#Bottom Edge
lat_mv[126,2:125] <- lat_mv[125,2:125] + (lat_mv[125,2:125] - lat_mv[124,2:125])
lon_mv[126,2:125] <- lon_mv[125,2:125] + (lon_mv[125,2:125] - lon_mv[124,2:125])

#Left Edge
lat_mv[2:125,1] <- lat_mv[2:125,2] + (lat_mv[2:125,2] - lat_mv[2:125,3])
lon_mv[2:125,1] <- lon_mv[2:125,2] + (lon_mv[2:125,2] - lon_mv[2:125,3])

#Right Edge
lat_mv[2:125,126] <- lat_mv[2:125,125] + (lat_mv[2:125,125] - lat_mv[2:125,124])
lon_mv[2:125,126] <- lon_mv[2:125,125] + (lon_mv[2:125,125] - lon_mv[2:125,124])

#Corners
lat_mv[c(1,126),1] <- lat_mv[c(1,126),2] + (lat_mv[c(1,126),2] - lat_mv[c(1,126),3])
lon_mv[c(1,126),1] <- lon_mv[c(1,126),2] + (lon_mv[c(1,126),2] - lon_mv[c(1,126),3])

lat_mv[c(1,126),126] <- lat_mv[c(1,126),125] + (lat_mv[c(1,126),125] - lat_mv[c(1,126),124])
lon_mv[c(1,126),126] <- lon_mv[c(1,126),125] + (lon_mv[c(1,126),125] - lon_mv[c(1,126),124])


pr_df_orig <- data.frame(lat=lat[], lon=lon[], pr=pr[])

pr_df <- data.frame(lat=as.vector(lat_mv[1:125,1:125]), lon=as.vector(lon_mv[1:125,1:125]), pr=as.vector(pr_m))
pr_df$id <- row.names(pr_df)

pr_df <- rbind(pr_df,
               data.frame(lat=as.vector(lat_mv[1:125,2:126]), lon=as.vector(lon_mv[1:125,2:126]), pr = pr_df$pr, id = pr_df$id),
               data.frame(lat=as.vector(lat_mv[2:126,2:126]), lon=as.vector(lon_mv[2:126,2:126]), pr = pr_df$pr, id = pr_df$id),
               data.frame(lat=as.vector(lat_mv[2:126,1:125]), lon=as.vector(lon_mv[2:126,1:125]), pr = pr_df$pr, id= pr_df$id))

带有多边形单元的缩放图像

Wales Cells

标签修复

ewbrks <- seq(-180,180,20)
nsbrks <- seq(-90,90,10)
ewlbls <- unlist(lapply(ewbrks, function(x) ifelse(x < 0, paste(abs(x), "°W"), ifelse(x > 0, paste(abs(x), "°E"),x))))
nslbls <- unlist(lapply(nsbrks, function(x) ifelse(x < 0, paste(abs(x), "°S"), ifelse(x > 0, paste(abs(x), "°N"),x))))

使用geom_polygon替换geom_tile和geom_point

ggplot(pr_df, aes(y=lat, x=lon, fill=pr, group = id)) + geom_polygon() +
    borders('world', xlim=range(pr_df$lon), ylim=range(pr_df$lat), colour='black') + my_theme + my_fill +
    coord_quickmap(xlim=range(pr_df$lon), ylim=range(pr_df$lat)) +
scale_x_continuous(breaks = ewbrks, labels = ewlbls, expand = c(0, 0)) +
scale_y_continuous(breaks = nsbrks, labels = nslbls, expand = c(0, 0)) + 
labs(x = "Longitude", y = "Latitude")

enter image description here

ggplot(pr_df, aes(y=lat, x=lon, fill=pr, group = id)) + geom_polygon() +
    borders('world', xlim=range(pr_df$lon), ylim=range(pr_df$lat), colour='black') + my_theme + my_fill +
    coord_map('lambert', lat0=30, lat1=65, xlim=c(-20, 39), ylim=c(19, 75)) +
scale_x_continuous(breaks = ewbrks, labels = ewlbls, expand = c(0, 0)) +
scale_y_continuous(breaks = nsbrks, labels = nslbls, expand = c(0, 0)) + 
labs(x = "Longitude", y = "Latitude")

在这里输入图片描述

编辑 - 坐标轴刻度的解决方法

我无法找到任何快速解决纬度网格线和标签问题的方法。可能有一个R包能够以更少的代码解决你的问题!

需要手动设置nsbreaks并创建data.frame。

ewbrks <- seq(-180,180,20)
nsbrks <- c(20,30,40,50,60,70)
nsbrks_posn <- c(-16,-17,-16,-15,-14.5,-13)
ewlbls <- unlist(lapply(ewbrks, function(x) ifelse(x < 0, paste0(abs(x), "° W"), ifelse(x > 0, paste0(abs(x), "° E"),x))))
nslbls <- unlist(lapply(nsbrks, function(x) ifelse(x < 0, paste0(abs(x), "° S"), ifelse(x > 0, paste0(abs(x), "° N"),x))))
latsdf <- data.frame(lon = rep(c(-100,100),length(nsbrks)), lat = rep(nsbrks, each =2), label = rep(nslbls, each =2), posn = rep(nsbrks_posn, each =2))

删除y轴刻度标签和相应的网格线,然后使用geom_linegeom_text手动添加回来。

ggplot(pr_df, aes(y=lat, x=lon, fill=pr, group = id)) + geom_polygon() +
    borders('world', xlim=range(pr_df$lon), ylim=range(pr_df$lat), colour='black') + my_theme + my_fill +
    coord_map('lambert', lat0=30, lat1=65, xlim=c(-20, 40), ylim=c(19, 75)) +
    scale_x_continuous(breaks = ewbrks, labels = ewlbls, expand = c(0, 0)) +
    scale_y_continuous(expand = c(0, 0), breaks = NULL) + 
    geom_line(data = latsdf, aes(x=lon, y=lat, group = lat), colour = "white", size = 0.5, inherit.aes = FALSE) +
    geom_text(data = latsdf, aes(x = posn, y = (lat-1), label = label), angle = -13, size = 4, inherit.aes = FALSE) +
    labs(x = "Longitude", y = "Latitude") +
    theme( axis.text.y=element_blank(),axis.ticks.y=element_blank())

enter image description here


1
让我们在聊天中继续这个讨论 - Jeremy Voisey
1
我已经修复了这个错误。 - Jeremy Voisey
1
我明白您的意思。这些标签实际上与-20E经线的截距水平对齐,从某种意义上讲是有道理的,因为这是该轴上指定的限制。但显然不适用于Lambert投影。 - Jeremy Voisey
1
@LoBu 搞混了东西方向,真是尴尬。我从stackoverflow上找到了这段代码,以为它很可靠,结果我错了。 - Jeremy Voisey
1
我已经为网格线(OK)和标签(需要更多工作)添加了修复。我认为@LoBu提出了一个更好的答案! - Jeremy Voisey
显示剩余11条评论

网页内容由stack overflow 提供, 点击上面的
可以查看英文原文,
原文链接