如何整理标准水文交换格式数据

Question

美国国家海洋和大气管理局(NOAA)有大量的标准水文交换格式(SHEF)数据(如下面的链接)。链接的数据包含四个主要信息:位置名称、位置ID、报告的值(数字或"NE“-未估计)和海拔区域。我希望将SHEF数据转换成四列data.frame，虽然它的名字中包含了"exchange“，但使用起来似乎并不简单，但我可能遗漏了一些东西。

下面两页的链接数据都有1137行雪数据，用于相同的位置和时间，但针对不同的雪参数。

有两段代码，每个网页一段。它们是相同的，除非它们的urls指向各自的参数。

下面的代码输出了一个几乎预期的data.frame，用于其中一个参数swe，但是对于另一个参数，sub，得到的结果对于原始数据和错误的值显然是部分完成的(参见底部的tibbles )。我在想，因为SHEF格式至少是一致的，而且可能只是为了这类事情而存在函数/库，所以转换可能需要一个完全不同的角度/更少的步骤？

雪参数1 ("swe") (雪水当量)：archive/index.html?rfc=cnrfc&product=swe&year=2019&month=3&day=27&hour=12 (灰色框中的数据)

雪参数2(“子”)(升华)：archive/index.html?rfc=cnrfc&product=sb&year=2019&month=3&day=27&hour=12 (灰色框中的数据)

我希望有两个data.frames，swe和sub，每个列4列。下面是工作示例。

library(tidyverse)
library(rvest)
library(lubridate)


# webpage to scrape data from, March27's parameter "swe"      
march27_param_swe <- 
 "https://www.nohrsc.noaa.gov/shef_archive/index.html?rfc=cnrfc&product=swe&year=2019&month=3&day=27&hour=12"

####### snow water equivalent (swe) [inches] ##########

# scrape
scrapedtext <- read_html(march27_param_swe) %>% html_node(".notes") %>%
               html_text() 



swe <- tibble(txt = read_lines(scrapedtext)) %>%

 mutate(
         row = row_number(),
         with_code = str_extract(txt, "^[A-z0-9]{5}\\s+\\d+(\\.)?\\d"),
         wo_code = str_extract(txt, "^:?\\s+\\d+(\\.)?\\d") %>% 
         str_extract("[:digit:]+\\.?[:digit:]"),
         basin_desc = if_else(!is.na(with_code), lag(txt, 1), NA_character_) %>% 
         str_sub(start = 2)
       ) 

swe <- swe %>% separate(with_code, c("code", "val"), sep = "\\s+") %>%  
       mutate(value = case_when(
                                !is.na(val) ~ val,
                                !is.na(wo_code) ~ wo_code,
                                TRUE ~ NA_character_) %>%
                                as.numeric) %>% filter(!is.na(value)) 

swe <- swe %>% mutate(code = zoo::na.locf(code), basin_desc = zoo::na.locf(basin_desc) ,
                      elevz = gsub(".*(inches))","",txt))  %>%
                      select(code, value, basin_desc, elevz) %>%
                      mutate(elevz = trimws(elevz))

 dim(swe) 
 #[1] 643   4

 head(swe)  
 # # A tibble: 6 x 4
 # code    value basin_desc               elevz             
 # <chr>   <dbl> <chr>                    <chr>             
 # 1 ACSC1   0   San Antonio Ck - Sunol   "Entire Basin"   
 # 2 ADLC1   0   Arroyo De La Laguna      "Entire Basin"   
 # 3 ADOC1   0   Santa Ana R - Prado Dam  "Entire Basin"   
 # 4 AHOC1   0   Arroyo Honda nr San Jose "Entire Basin"   
 # 5 AKYC1  41.8 SF American nr Kyburz    "Entire Basin"   
 # 6 AKYC1   3.9 SF American nr Kyburz    "Base  to 5000'"

 #which is what I'm hoping for, except that I'd like the `value` to be 
 #<chr> to be able to accommodate the numbers and "NE" values reported, like this:

 # # A tibble: 6 x 4
 # code  value basin_desc               elevz             
 # <chr> <chr> <chr>                    <chr>          

 #######  surface sublimation (sub) ##########

# same locations and day, different parameter, "sb", blowing snow 
# sublimation [inches]

march27_param_temp <- "https://www.nohrsc.noaa.gov/shef_archive/index.html?rfc=cnrfc&product=sb&year=2019&month=3&day=27&hour=12"

scrapedtext <- read_html(march27_param_temp) %>%
               html_node(".notes") %>% html_text() 

sub <- tibble(txt = read_lines(scrapedtext)) %>%
  mutate(
         row = row_number(),
         with_code = str_extract(txt, "^[A-z0-9]{5}\\s+\\d+(\\.)?\\d"),
         wo_code = str_extract(txt, "^:?\\s+\\d+(\\.)?\\d") %>% 
         str_extract("[:digit:]+\\.?[:digit:]"),
         basin_desc = if_else(!is.na(with_code), lag(txt, 1), NA_character_) %>%
         str_sub(start = 2)
) 

sub <- sub %>% separate(with_code, c("code", "val"), sep = "\\s+") %>%  
        mutate(value = case_when(
                                 !is.na(val) ~ val,
                                 !is.na(wo_code) ~ wo_code,
                                 TRUE ~ NA_character_) %>%
                                 as.numeric) %>% filter(!is.na(value)) 

sub <- sub %>% mutate(code = zoo::na.locf(code), basin_desc = zoo::na.locf(basin_desc) ,
                      elevz = gsub(".*(inches))","",txt))  %>%
                      select(code, value, basin_desc, elevz)  %>%
                      mutate(elevz = trimws(elevz))

dim(sub)
#[1] 263   4    #dim[swe] was 643x4

head(sub)

 # A tibble: 6 x 4
 #code     value   basin_desc                elevz             
 #<chr>    <dbl>   <chr>                     <chr>             
 #1 ADOC1     0    Santa Ana R - Prado Dam   "Entire Basin"   
 #2 ADOC1     0    Santa Ana R - Prado Dam   "Base  to 5000'"
 #3 ARCC1     0    Mad River - Arcata        "Entire Basin"   
 #4 ARCC1     0    Mad River - Arcata        "Base  to 5000'"
 #5 BCAC1     0    Little Truckee - Boca Dam "Entire Basin"   

#So `sub` should be the same size `data.frame` as swe, and 
#sub$value's are supposed to be (as per the source page above: 
# https://www.nohrsc.noaa.gov/shef_archive/index.html?rfc=cnrfc&product=sb&year=2019&month=3&day=27&hour=12 ):

 #head(desired_sub)
 # A tibble: 6 x 4
 #code        value  basin_desc                elevz             
 #<chr>       <chr>  <chr>                     <chr>             
 #1 ADOC1     NE     Santa Ana R - Prado Dam   "Entire Basin"   
 #2 ADOC1     NE     Santa Ana R - Prado Dam   "Base  to 5000'"
 #3 ARCC1     0.000  Mad River - Arcata        "Entire Basin"   
 #4 ARCC1     NE     Mad River - Arcata        "Base  to 5000'"
 #5 BCAC1    -0.016  Little Truckee - Boca Dam "Entire Basin"   

Answer 1

我认为您的问题可能是由于数据输出不一致:代码行可以以冒号开头，也可以不带冒号。

我编写了一个新代码，通过搜索以代码(或：+代码)开头的行来标识数据块，然后将每个块读入数据帧。

试试这个：

library(rvest)
library(stringr)

# Read an individual block
readBlock = function(text){
  basin = str_replace(string = text[1], pattern = "^:", replacement = "")
  block = text[-1]
  code = str_match(block[1], "[A-Z0-9]{5}")[1]
  block = str_replace(block, "^(:?[^ ]+|:)", "")
  block = str_replace(block, "%", "(%)")
  block = str_replace_all(block, "[;():]", "|")
  block = trimws(block)
  block = str_split(block,"\\|")
  block = as.data.frame(do.call(rbind, block))
  colnames(block) = c("Value","Calc", "Units", "Location")
  block$Code = code
  block$Basin = basin
  return(block)
}

# Find blocks starting index
findBlocks = function(text){
  index = which(str_detect(text,"^:?[A-Z0-9]{5}"))
  index = index[index > 10]
  index = index - 1
  index = c(index, 1 + which(str_detect(text,"\\.END")))
  return(index)
}

# return a data frame with all blocks
readAllBlocks = function(index, text){
  blocks = lapply(1:(length(index)-1), function(x){
    blockText = text[index[x]:(index[x+1]-2)]
    readBlock(blockText)
  })
  blocks = do.call(rbind, blocks)
  return(blocks)
}


####### snow water equivalent (swe) [inches] ##########
march27_param_swe = "https://www.nohrsc.noaa.gov/shef_archive/index.html?rfc=cnrfc&product=swe&year=2019&month=3&day=27&hour=12"
# scrape
scrapedtext = html_text(html_node(read_html(march27_param_swe),".notes"))
scrapedtext = unlist(str_split(scrapedtext,"\n"))
block_index = findBlocks(scrapedtext)
swe = readAllBlocks(block_index, scrapedtext)



#######  surface sublimation (sub) ##########
march27_param_temp = "https://www.nohrsc.noaa.gov/shef_archive/index.html?rfc=cnrfc&product=sb&year=2019&month=3&day=27&hour=12"
scrapedtext = html_text(html_node(read_html(march27_param_temp),".notes"))
scrapedtext = unlist(str_split(scrapedtext,"\n"))
block_index = findBlocks(scrapedtext)
sub = readAllBlocks(block_index, scrapedtext)

编辑：如果单元%没有括号，那么在替换它们之前包围它。这一行应该能做到这一点：

block = str_replace(block, "%", "(%)")

我编辑了上面的代码，以便在需要时包含它。