

NC图表复现|样本空间分布图(基础入门版)

R语言数据分析指南

2025-06-04

欢迎关注R语言数据分析指南

❝
本节来通过NC上的一篇新论文来介绍样本分布世界地图绘制，数据为论文提供数据，小编根据个人对图形的进行代码编写，结果与原文有所不同，个人观点仅供参考。有需要学习R语言绘图的朋友可关注文末介绍购买小编的R绘图文档。购买前请咨询，零基础不要买。

论文信息

Interspecies hydrogen transfer between cyanobacteria and symbiotic bacteria drives nitrogen lossKong, L., Feng, Y., Zheng, R. et al. Interspecies hydrogen transfer between cyanobacteria and symbiotic bacteria drives nitrogen loss. Nat Commun 16, 5078 (2025). https://doi.org/10.1038/s41467-025-60327-x

论文原图

仿图

图形解读

该图作为传统常规地图内容上无特别之处，其主要点在于图例的绘制及图例细节的调整。开始尝试通过不同分类通过多个geom_point来绘制图例，后期发现一些细节无法在theme内完美定义调整，改为单独绘制图例添加的方式，代码量加大了一些，整体难度系数较低，适合基础入门学习。

代码展示

library(tidyverse)
library(ggspatial)
library(sf)
library(terra)
library(ggtext)
library(ggnewscale)
library(ComplexHeatmap)

df <- read_tsv("data.tsv")

dff <- df %>%
  mutate(CA_type=str_remove_all(CA_type,"_|[0-9]+")) %>% 
  mutate(group=case_when(
    CA_type=="Engineered system" ~ "Photogranules<br>(Engineered<br>system)",
    CA_type=="Lake" ~ "Bloom<br>colonies<br>(Lake)",
    CA_type=="Marine" ~ "Trichodesmium<br>aggregates<br>(Marine)",
    CA_type=="Hot spring" ~ "Phototrophic<br>mats<br>(Hot spring)",
    CA_type=="Glacier" ~"Cryoconite<br>(Glacier)",
    TRUE ~ NA)) %>% 
  mutate(group2=case_when(CA_type=="Seawater-DCM" ~ "Seawater-DCM",
                          CA_type=="Seawater-SRF" ~ "Seawater-SRF",
                          TRUE ~ NA))

dff$group <- factor(dff$group,levels = unique(dff$group))  

map_data("world") %>% 
  ggplot()+
  geom_polygon(aes(x = long, y = lat,group = group),
               fill ="grey90",color="grey90",
               show.legend = F)+
  geom_point(data = dff %>% select(-group2) %>% drop_na(),
             aes(x = Longitude, y = Latitude,color = group),
             pch=19,size=3)+
  scale_color_manual(values = c("#7294d4","#8E44ADFF","#C6CDF7","#97c584",
                                "#71D0F5FF")) +
  guides(color=guide_legend(override.aes = list(size=4))) +
  new_scale_color()+
  geom_point(data = dff %>% select(-group) %>% drop_na(),
           pch=1,size=3,stroke = 1,
           aes(x = Longitude, y = Latitude,color=group2),
           show.legend = F)+ 
  scale_color_manual(values = c("Seawater-SRF"="#FAD77B",
                                "Seawater-DCM"="#EC7A05")) +
  annotate(geom="text",x=I(0.1),y=I(0.2),label="Detected ratio in\nfree-living microbe:0%",
           size=4,color="black",fontface="bold")+
  annotate(geom="text",x=I(0.7),y=I(0.2),label="Detected ratio in cyanobacrterial aggregates:83%",
           size=4,color="black",fontface="bold")+
  labs(x=NULL,y=NULL,
       title="Genomes of H<sub>2</sub>-evolving cyanobacteria and hydrogenotrophic denitrifers") +
  theme_test() +
  theme(legend.direction = "horizontal",
        legend.text.position = "bottom",
        legend.text=element_markdown(size=10,color="black"),
        legend.title = element_blank(),
        legend.background = element_blank(),
        legend.key = element_blank(),
        legend.position =  c(0.7,0.1),
        legend.key.spacing.x = unit(0.7,"cm"),
        axis.text=element_blank(),
        axis.ticks = element_blank(),
        plot.title = element_markdown(color="black",face="bold",vjust=0.5,hjust=0.5))

color_map <- tibble::tribble(
  ~name,             ~color,
"Seawater-SRF",           "#FAD77B",
"Seawater-DCM",           "#EC7A05",
"Both detected",          "black",
"Not detected",          "black")

lab <- color_map %>% head(2) %>% deframe()
# 定义函数
graphics_list <- lapply(seq_along(lab), function(i) { 
# 遍历 lab 的每个元素
# 为每个扇区创建绘制点的函数，点的颜色来自 rowname数据
function(x,y,w,h) grid.points(
    x,y,gp=gpar(col=lab[i],cex=1),pch=19)
})

lgd <- Legend(labels = names(lab), # 创建图例
              # 使用 graphics_list 中的绘图函数
              graphics = graphics_list, 
              row_gap = unit(3, "mm")) # 设置图例行间距为 3 毫米
# 绘制图例，位置在画布的 x=0.1, y=0.05，底部对齐
draw(lgd, x = unit(0.1, "npc"),y = unit(0.05, "npc"),
     just = c("bottom"))

# 得到带名字的颜色向量
lab <- color_map %>% tail(2) %>% deframe()  

# 指定形状，与 lab 顺序对应
pch_vec <- c(19,1)  #实心圆,空心圆
graphics_list <- lapply(seq_along(lab), function(i) {
function(x, y, w, h) {
    grid.points(x, y,
                pch = pch_vec[i], 
                gp = gpar(col = lab[i], cex = 1))
  }
})

lgd <- Legend(labels = names(lab), 
              graphics = graphics_list, 
              row_gap = unit(3, "mm"))
draw(lgd, x = unit(0.91, "npc"),y = unit(0.81, "npc"),
     just = c("bottom"))

# width=8.94,height=5.02