วิธีเพิ่มความเร็วการพล็อตรูปหลายเหลี่ยมใน R


24

ฉันต้องการพล็อตเส้นขอบประเทศของทวีปอเมริกาเหนือผ่านภาพแรสเตอร์ที่แสดงถึงตัวแปรบางส่วนจากนั้นจึงวางทับรูปทรงที่ด้านบนของพล็อตโดยใช้อาร์ฉันประสบความสำเร็จในการทำเช่นนี้โดยใช้กราฟิกพื้นฐานและขัดแตะ ช้าเกินไป! ฉันยังไม่ได้ทำใน ggplot2 แต่ฉันสงสัยว่ามันจะดีขึ้นในแง่ของความเร็ว

ฉันมีข้อมูลในไฟล์ netcdf ที่สร้างจากไฟล์ grib ตอนนี้ฉันดาวน์โหลดเส้นขอบประเทศสำหรับแคนาดาสหรัฐอเมริกาและเม็กซิโกซึ่งมีอยู่ในไฟล์RDataจากGADMซึ่งอ่านเป็น R เป็นวัตถุ SpatialPolygonsDataFrame

นี่คือรหัสบางส่วน:

# Load packages
library(raster)
#library(ncdf) # If you cannot install ncdf4
library(ncdf4)

# Read in the file, get the 13th layer
# fn <- 'path_to_file'
r <- raster(fn, band=13)

# Set the projection and extent
p4 <- "+proj=lcc +lat_1=50.0 +lat_2=50.0 +units=km +x_0=32.46341 +y_0=32.46341 +lon_0=-107 +lat_0=1.0"
projection(r) <- CRS(p4)
extent(r) <- c(-5648.71, 5680.72, 1481.40, 10430.62)

# Get the country borders
# This will download the RData files to your working directory
can<-getData('GADM', country="CAN", level=1)
usa<-getData('GADM', country="USA", level=1)
mex<-getData('GADM', country="MEX", level=1)

# Project to model grid
can_p <- spTransform(can, CRS(p4))
usa_p <- spTransform(usa, CRS(p4))
mex_p <- spTransform(mex, CRS(p4))

### USING BASE GRAPHICS
par(mar=c(0,0,0,0))
# Plot the raster
bins <- 100
plot(r, axes=FALSE, box=FALSE, legend=FALSE,
     col=rev( rainbow(bins,start=0,end=1) ),
     breaks=seq(4500,6000,length.out=bins))
plot(r, legend.only=TRUE, col=rev( rainbow(bins,start=0,end=1)),
     legend.width=0.5, legend.shrink=0.75, 
     breaks=seq(4500,6000,length.out=bins),
     axis.args=list(at=seq(4500,6000,length.out=11),
                labels=seq(4500,6000,length.out=11),
                cex.axis=0.5),
     legend.args=list(text='Height (m)', side=4, font=2, 
                      line=2, cex=0.8))
# Plot the borders
# These are so slow!!
plot(can_p, add=TRUE, border='white', lwd=2)
plot(usa_p, add=TRUE, border='white', lwd=2)
plot(mex_p, add=TRUE, border='white', lwd=2)
# Add the contours
contour(r, add=TRUE, nlevel=5)

### USING LATTICE
library(rasterVis)

# Some settings for our themes
myTheme <- RdBuTheme()
myTheme$axis.line$col<-"transparent"
myTheme$add.line$alpha <- 1
myTheme2 <- myTheme
myTheme2$regions$col <- 'transparent'
myTheme2$add.text$cex <- 0.7
myTheme2$add.line$lwd <- 1
myTheme2$add.line$alpha <- 0.8

# Get JUST the contour lines
contours <- contourplot(r, margin=FALSE, scales=list(draw=FALSE),
                        par.settings=myTheme2, pretty=TRUE, key=NULL, cuts=5,
                        labels=TRUE)

# Plot the colour
levels <- levelplot(r, contour=FALSE, margin=FALSE, scales=list(draw=FALSE),
                    par.settings = myTheme, cuts=100)

# Plot!
levels +  
  layer(sp.polygons(can_p, col='green', lwd=2)) +
  layer(sp.polygons(usa_p, col='green', lwd=2)) +
  layer(sp.polygons(mex_p, col='green', lwd=2)) +
  contours

มีวิธีใดที่จะเร่งการวางแผนรูปหลายเหลี่ยมได้เร็วขึ้นหรือไม่ ในระบบที่ฉันทำงานอยู่การวางแผนจะใช้เวลาหลายนาที ในที่สุดฉันต้องการสร้างฟังก์ชั่นที่จะสร้างจำนวนแปลงเหล่านี้เพื่อตรวจสอบได้อย่างง่ายดายและฉันคิดว่าฉันจะวางแผนแผนที่เหล่านี้จำนวนมากดังนั้นฉันต้องการเพิ่มความเร็วของแผนการ!

ขอบคุณ!


แค่ความคิดเช่นนั้นคุณสามารถสร้างดัชนีในฟิลด์รูปหลายเหลี่ยมเรขาคณิตของคุณได้หรือไม่?
ใต้ Radar

@ Burton449 ขออภัยฉันยังใหม่กับสิ่งที่เกี่ยวข้องกับการทำแผนที่ใน R รวมถึงรูปหลายเหลี่ยมการคาดการณ์ ฯลฯ .. ฉันไม่เข้าใจคำถามของคุณ
ialm

2
คุณสามารถลองลงจุดไปยังอุปกรณ์อื่นนอกเหนือจากหน้าต่างลงจุด ล้อมรอบฟังก์ชันพล็อตใน pdf หรือ jpeg (พร้อมอาร์กิวเมนต์ที่เกี่ยวข้อง) และส่งออกหนึ่งในรูปแบบเหล่านี้ ฉันพบว่าสิ่งนี้เร็วกว่ามาก
Jeffrey Evans

@JeffreyEvans ว้าวใช่ ฉันไม่ได้พิจารณาเรื่องนั้น การพล็อตไฟล์รูปร่างสามไฟล์ลงในหน้าต่างการพล็อตใช้เวลาประมาณ 60 วินาที แต่การพล็อตไปยังไฟล์ใช้เวลาเพียง 14 วินาที ยังช้าเกินไปสำหรับภารกิจในมือ แต่อาจพิสูจน์ได้ว่ามีประโยชน์เมื่อรวมกับวิธีการบางอย่างในคำตอบด้านล่าง ขอบคุณ!
ialm

คำตอบ:


30

ผมพบว่า 3 วิธีในการเพิ่มความเร็วของการวางแผนพรมแดนของประเทศจากไฟล์รูปสำหรับการอาร์ผมพบแรงบันดาลใจบางอย่างและรหัสจากที่นี่และที่นี่

(1) เราสามารถดึงพิกัดจากไฟล์รูปร่างเพื่อรับลองจิจูดและละติจูดของรูปหลายเหลี่ยม จากนั้นเราสามารถใส่ลงในกรอบข้อมูลที่มีคอลัมน์แรกที่มีลองจิจูดและคอลัมน์ที่สองที่มีละติจูด รูปร่างที่แตกต่างจะถูกคั่นด้วย NAs

(2) เราสามารถลบรูปหลายเหลี่ยมออกจากไฟล์รูปร่างของเรา ไฟล์รูปร่างมีรายละเอียดมาก แต่รูปร่างบางอย่างเป็นเกาะเล็ก ๆ ที่ไม่สำคัญ (สำหรับแผนการของฉันยังไงก็ตาม) เราสามารถตั้งค่าขีด จำกัด พื้นที่รูปหลายเหลี่ยมขั้นต่ำเพื่อรักษารูปหลายเหลี่ยมที่ใหญ่กว่าได้

(3) เราสามารถลดความซับซ้อนของรูปทรงเรขาคณิตของรูปทรงของเราโดยใช้อัลกอริทึมดักลาส Peuker ขอบของรูปหลายเหลี่ยมของเราสามารถลดความซับซ้อนลงได้เนื่องจากมีความซับซ้อนมากในไฟล์ต้นฉบับ โชคดีที่มีแพ็คเกจrgeosที่ใช้สิ่งนี้

ติดตั้ง:

# Load packages
library(rgdal)
library(raster)
library(sp)
library(rgeos)

# Load the shape files
can<-getData('GADM', country="CAN", level=0)
usa<-getData('GADM', country="USA", level=0)
mex<-getData('GADM', country="MEX", level=0)

วิธีที่ 1:แยกพิกัดจากไฟล์รูปร่างลงในกรอบข้อมูลและเส้นการลงจุด

ข้อเสียที่สำคัญคือเราสูญเสียข้อมูลบางส่วนที่นี่เมื่อเปรียบเทียบกับการรักษาวัตถุเป็นวัตถุ SpatialPolygonsDataFrame เช่นการฉาย อย่างไรก็ตามเราสามารถเปลี่ยนกลับเป็นวัตถุ sp และเพิ่มข้อมูลการฉายกลับได้และมันยังเร็วกว่าการวางแผนข้อมูลดั้งเดิม

โปรดทราบว่ารหัสนี้ทำงานช้ามากในไฟล์ต้นฉบับเนื่องจากมีรูปร่างจำนวนมากและเฟรมข้อมูลที่ได้มีความยาว ~ 2 ล้านแถว

รหัส:

# Convert the polygons into data frames so we can make lines
poly2df <- function(poly) {
  # Convert the polygons into data frames so we can make lines
  # Number of regions
  n_regions <- length(poly@polygons)

  # Get the coords into a data frame
  poly_df <- c()
  for(i in 1:n_regions) {
    # Number of polygons for first region
    n_poly <- length(poly@polygons[[i]]@Polygons)
    print(paste("There are",n_poly,"polygons"))
    # Create progress bar
    pb <- txtProgressBar(min = 0, max = n_poly, style = 3)
    for(j in 1:n_poly) {
      poly_df <- rbind(poly_df, NA, 
                       poly@polygons[[i]]@Polygons[[j]]@coords)
      # Update progress bar
      setTxtProgressBar(pb, j)
    }
    close(pb)
    print(paste("Finished region",i,"of",n_regions))
  }
  poly_df <- data.frame(poly_df)
  names(poly_df) <- c('lon','lat')
  return(poly_df)
}

วิธีที่ 2:เอารูปหลายเหลี่ยมขนาดเล็กออก

มีเกาะเล็ก ๆ หลายแห่งที่ไม่สำคัญมาก หากคุณตรวจสอบควอนไทล์บางส่วนของพื้นที่สำหรับรูปหลายเหลี่ยมเราจะเห็นว่าส่วนใหญ่มีขนาดเล็ก สำหรับพล็อตของแคนาดาฉันลงจากการวางแผนมากกว่าหนึ่งพันรูปหลายเหลี่ยมไปเป็นรูปหลายร้อยหลายร้อยเท่านั้น

Quantiles สำหรับขนาดของรูปหลายเหลี่ยมสำหรับแคนาดา:

          0%          25%          50%          75%         100% 
4.335000e-10 8.780845e-06 2.666822e-05 1.800103e-04 2.104909e+02 

รหัส:

# Get the main polygons, will determine by area.
getSmallPolys <- function(poly, minarea=0.01) {
  # Get the areas
  areas <- lapply(poly@polygons, 
                  function(x) sapply(x@Polygons, function(y) y@area))

  # Quick summary of the areas
  print(quantile(unlist(areas)))

  # Which are the big polygons?
  bigpolys <- lapply(areas, function(x) which(x > minarea))
  length(unlist(bigpolys))

  # Get only the big polygons and extract them
  for(i in 1:length(bigpolys)){
    if(length(bigpolys[[i]]) >= 1 && bigpolys[[i]] >= 1){
      poly@polygons[[i]]@Polygons <- poly@polygons[[i]]@Polygons[bigpolys[[i]]]
      poly@polygons[[i]]@plotOrder <- 1:length(poly@polygons[[i]]@Polygons)
    }
  }
  return(poly)
}

วิธีที่ 3:ลดความซับซ้อนของรูปทรงเรขาคณิตของรูปหลายเหลี่ยม

เราสามารถลดจำนวนจุดยอดในรูปหลายเหลี่ยมของเราโดยใช้gSimplifyฟังก์ชั่นจากrgeosแพคเกจ

รหัส:

can <- getData('GADM', country="CAN", level=0)
can <- gSimplify(can, tol=0.01, topologyPreserve=TRUE)

มาตรฐานบางอย่าง:

ฉันใช้system.timeการเปรียบเทียบเวลาในการวางแผนของฉัน โปรดทราบว่าสิ่งเหล่านี้เป็นเพียงเวลาสำหรับการวางแผนประเทศโดยไม่ต้องมีเส้นชั้นความสูงและสิ่งพิเศษอื่น ๆ สำหรับวัตถุ sp ฉันเพิ่งใช้plotฟังก์ชัน สำหรับวัตถุเฟรมข้อมูลฉันใช้plotฟังก์ชั่นด้วยtype='l'และlinesฟังก์ชั่น

พล็อตดั้งเดิมของแคนาดา, สหรัฐอเมริกา, เม็กซิโกรูปหลายเหลี่ยม:

73.009 วินาที

ใช้วิธีที่ 1:

2.449 วินาที

ใช้วิธีที่ 2:

17.660 วินาที

ใช้วิธีที่ 3:

16.695 วินาที

ใช้วิธีที่ 2 + 1:

1.729 วินาที

ใช้วิธีที่ 2 + 3:

0.445 วินาที

ใช้วิธีที่ 2 + 3 + 1:

0.172 วินาที

ข้อสังเกตอื่น ๆ :

ดูเหมือนว่าการรวมกันของวิธีการ 2 + 3 จะให้ความเร็วที่เพียงพอในการวางแผนรูปหลายเหลี่ยม การใช้วิธีการ 2 + 3 + 1 เพิ่มปัญหาการสูญเสียคุณสมบัติที่ดีของspวัตถุและปัญหาหลักของฉันคือการใช้การคาด ฉันแฮ็กบางอย่างเข้าด้วยกันเพื่อฉายวัตถุเฟรมข้อมูล แต่มันทำงานค่อนข้างช้า ฉันคิดว่าการใช้วิธีที่ 2 + 3 ให้ความเร็วที่เพียงพอสำหรับฉันจนกว่าฉันจะได้รับข้อผิดพลาดจากการใช้วิธีที่ 2 + 3 + 1


3
+1 สำหรับการเขียนบทความซึ่งไม่ต้องสงสัยเลยว่าผู้อ่านในอนาคตจะมีประโยชน์
SlowLearner

3

ทุกคนควรดูที่การโอนไปยังแพ็คเกจ sf (คุณสมบัติเชิงพื้นที่) แทนที่จะเป็น sp มันเร็วกว่ามาก (1/60 ในกรณีนี้) และใช้งานง่ายกว่า นี่คือตัวอย่างของการอ่านใน shp และพล็อตผ่าน ggplot2

หมายเหตุ: คุณต้องติดตั้ง ggplot2 ใหม่จากบิลด์ล่าสุดบน GitHub (ดูด้านล่าง)

library(rgdal)
library(sp)
library(sf)
library(plyr)
devtools::install_github("tidyverse/ggplot2")
library(ggplot2)

# Load the shape files
can<-getData('GADM', country="CAN", level=0)
td <- file.path(tempdir(), "rgdal_examples"); dir.create(td)
st_write(st_as_sf(can),file.path(td,'can.shp'))


ptm <- proc.time()
  can = readOGR(dsn=td, layer="can")
  can@data$id = rownames(can@data)
  can.points = fortify(can, region="id")
  can.df = join(can.points, can@data, by="id")
  ggplot(can.df) +  geom_polygon(aes(long,lat,group=group,fill='NAME_ENGLISH'))
proc.time() - ptm

user  system elapsed 
683.344   0.980 684.51 

ptm <- proc.time()
  can2 = st_read(file.path(td,'can.shp'))  
  ggplot(can2)+geom_sf( aes(fill = 'NAME_ENGLISH' )) 
proc.time() - ptm

user  system elapsed 
11.340   0.096  11.433 

0

ข้อมูล GADM มีความละเอียดเชิงพื้นที่ที่สูงมากของแนวชายฝั่ง หากคุณไม่ต้องการให้คุณสามารถใช้ชุดข้อมูลทั่วไป แนวทางของ ialm นั้นน่าสนใจมาก แต่ทางเลือกง่าย ๆ คือใช้ข้อมูล 'wrld_simpl' ที่มาพร้อมกับ 'maptools'

library(maptools)
data(wrld_simpl)
plot(wrld_simpl)

ฉันต้องการรักษารูปร่างในชุดข้อมูลของฉันเพราะมันมีขอบเขตของพื้นที่ภายในของประเทศ (เช่นจังหวัดและรัฐ) มิฉะนั้นฉันจะใช้แผนที่ในแพ็คเกจข้อมูลแผนที่!
ialm
โดยการใช้ไซต์ของเรา หมายความว่าคุณได้อ่านและทำความเข้าใจนโยบายคุกกี้และนโยบายความเป็นส่วนตัวของเราแล้ว
Licensed under cc by-sa 3.0 with attribution required.