format ALL scripts

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: tidymet
 Type: Package
 Title: missing information detect and interpolate
-Version: 0.1.3
+Version: 0.1.4
 Authors@R: c(
     person("Dongdong", "Kong", role = c("aut", "cre"), email = "kongdd.sysu@gmail.com"))
 Description: Meteorological stations data detail missing information detect and interpolate with common methods. 

NAMESPACE

@@ -22,6 +22,7 @@ export(distToCentralPeriod)
 export(dtime)
 export(dtime2mat)
 export(dtime_intersect)
+export(find_near)
 export(fix_alt)
 export(get_alt)
 export(guess_variable)

R/IO.R

@@ -3,61 +3,62 @@
 #' This function is for original txt file from .
 #'
 #' @param file txt file path. The txt file is from http://data.cma.cn/. The
-#' first 7 columns should be the data of `c("site", "lat", "lon", "alt", "year",
-#' "month", "day")`.
+#' first 7 columns should be the data of `c('site', 'lat', 'lon', 'alt', 'year',
+#' 'month', 'day')`.
 #' @param ... other parameters to [fread()]
 #'
 #' @examples
-#' lst_varnames = list(
-#'     EVP = c("EVP_sm", "EVP_bg"),
-#'     PRE = c("Prcp_20-08", "Prcp_02-20", "Prcp_20-20"),
-#'     RHU = c("RH_avg", "RH_min"),
-#'     WIN = c("WIN_Avg","WIN_S_Max", "WIN_D_S_Max", "WIN_INST_Max", "WIN_D_INST_Max"),
-#'     SSD = "SSD",
-#'     GST = c("TG_avg", "TG_max", "TG_min"),
-#'     TEM = c("Tair_avg", "Tair_max", "Tair_min"),
-#'     PRS = c("Pa_avg", "Pa_max", "Pa_min")
+#' lst_varnames <- list(
+#'   EVP = c("EVP_sm", "EVP_bg"),
+#'   PRE = c("Prcp_20-08", "Prcp_02-20", "Prcp_20-20"),
+#'   RHU = c("RH_avg", "RH_min"),
+#'   WIN = c("WIN_Avg", "WIN_S_Max", "WIN_D_S_Max", "WIN_INST_Max", "WIN_D_INST_Max"),
+#'   SSD = "SSD",
+#'   GST = c("TG_avg", "TG_max", "TG_min"),
+#'   TEM = c("Tair_avg", "Tair_max", "Tair_min"),
+#'   PRS = c("Pa_avg", "Pa_max", "Pa_min")
 #' )
 #' @export
 read_mete <- function(file, lst_varnames, ...) {
-    var <- guess_variable(file)
-    varnames <- lst_varnames[[var]]
-    varnames <- c(varnames, paste0("QC.", varnames)) # add qc
-    df <- fread(file, ...)
+  var <- guess_variable(file)
+  varnames <- lst_varnames[[var]]
+  varnames <- c(varnames, paste0("QC.", varnames)) # add qc
+  df <- fread(file, ...)
 
-    vars_common <- c("site", "lat", "lon", "alt", "year", "month", "day")
-    colnames(df) <- c(vars_common, varnames)
-    df[df == 32766] <- NA_integer_
-    df %>%
-        dplyr::mutate(date = make_date(year, month, day)) %>%
-        # dplyr::select(-year, -month, -day) %>%
-        .[, -(2:7)] %>%
-        reorder_name(c("site", "date"))
+  vars_common <- c("site", "lat", "lon", "alt", "year", "month", "day")
+  colnames(df) <- c(vars_common, varnames)
+  df[df == 32766] <- NA_integer_
+  df %>%
+    dplyr::mutate(date = make_date(year, month, day)) %>%
+    # dplyr::select(-year, -month, -day) %>%
+    .[, -(2:7)] %>%
+    reorder_name(c("site", "date"))
 }
 
 #' @rdname read_mete
 #' @import data.table glue
 #' @export
 write_mete <- function(df, prefix = "", date_end = NULL, overwrite = FALSE) {
-    mkdir(dirname(prefix))
-    sites = df$site %>% unique() %>% sort()
-    # if (is.null(date_end)) {
-    #     l <- split(df, df$site)
-    # } else {
-    #     l <- split(df[date <= date_end], df[date <= date_end, site])
-    # }
-    temp <- foreach(SITE = sites, i = icount()) %do% {
-        runningId(i, 20)
-        name = st_met2481[site == SITE, name]
-        outfile <- glue("{prefix}{SITE}_{name}.csv")
-        if (!file.exists(outfile) || overwrite) {
-            d = df[site == SITE]
-            if (!is.null(date_end)) d = d[date <= date_end]
-            # site <- d$site[1]
-            fwrite(d, outfile)
-        }
+  mkdir(dirname(prefix))
+  sites <- df$site %>%
+    unique() %>%
+    sort()
+  # if (is.null(date_end)) { l <- split(df, df$site) } else { l <- split(df[date <= date_end], df[date
+  # <= date_end, site]) }
+  temp <- foreach(SITE = sites, i = icount()) %do% {
+    runningId(i, 20)
+    name <- st_met2481[site == SITE, name]
+    outfile <- glue("{prefix}{SITE}_{name}.csv")
+    if (!file.exists(outfile) || overwrite) {
+      d <- df[site == SITE]
+      if (!is.null(date_end)) {
+        d <- d[date <= date_end]
+      }
+      # site <- d$site[1]
+      fwrite(d, outfile)
     }
-    invisible()
+  }
+  invisible()
 }
 
 #' @rdname read_mete
@@ -66,4 +67,5 @@ guess_variable <- function(file) str_extract(basename(file), "(?<=_DAY_).*(?= )"
 
 #' @rdname read_mete
 #' @export
-not_select_QC <- . %>% dplyr::select(!starts_with("QC."))
+not_select_QC <- . %>%
+  dplyr::select(!starts_with("QC."))

R/date_intersect.R

@@ -6,19 +6,18 @@ origin <- as.Date("1970-01-01") # origin of date
 #'
 #' @param date_x date vector, [date_begin, date_end]
 #' @param date_y same as date_x
-#' 
+#'
 #' @export
 date_intersect <- function(date_x, date_y) {
-    # int_x <- interval(x_begin, x_end)
-    # int_y <- interval(y_begin, y_end)
-    if (date_x[1] > date_y[2] || date_y[1] > date_x[2]){
-        NULL
-    } else {
-        ubegin <- max(date_x[1], date_y[1])
-        uend   <- min(date_x[2], date_y[2])
-        # interval(ubegin, uend)
-        as.Date(ubegin:uend, origin)
-    }
+  # int_x <- interval(x_begin, x_end) int_y <- interval(y_begin, y_end)
+  if (date_x[1] > date_y[2] || date_y[1] > date_x[2]) {
+    NULL
+  } else {
+    ubegin <- max(date_x[1], date_y[1])
+    uend <- min(date_x[2], date_y[2])
+    # interval(ubegin, uend)
+    as.Date(ubegin:uend, origin)
+  }
 }
 
 #' @param int_x interval x
@@ -27,19 +26,21 @@ date_intersect <- function(date_x, date_y) {
 #' @rdname date_intersect
 #' @importFrom lubridate int_start int_end int_overlaps interval
 #' @export
-int_intersect <- function(int_x, int_y){
-    date_x <- c(int_start(int_x), int_end(int_x)) %>% as.Date()
-    date_y <- c(int_start(int_y), int_end(int_y)) %>% as.Date()
-    date_intersect(date_x, date_y)
+int_intersect <- function(int_x, int_y) {
+  date_x <- c(int_start(int_x), int_end(int_x)) %>%
+    as.Date()
+  date_y <- c(int_start(int_y), int_end(int_y)) %>%
+    as.Date()
+  date_intersect(date_x, date_y)
 }
 
 #' @param x dtime object
 #' @param y same as x
-#' 
+#'
 #' @rdname date_intersect
 #' @export
-dtime_intersect <- function(x, y){
-    date_x <- c(x$begin, x$end)
-    date_y <- c(y$begin, y$end)
-    date_intersect(date_x, date_y)
+dtime_intersect <- function(x, y) {
+  date_x <- c(x$begin, x$end)
+  date_y <- c(y$begin, y$end)
+  date_intersect(date_x, date_y)
 }

R/dtime-S3Class.R

@@ -1,15 +1,17 @@
 #' @export
 begin.Date <- function(x, ...) {
-    if (!inherits(x, "Date"))
-        return("x should be date class")
-    x[1]
+  if (!inherits(x, "Date")) {
+    return("x should be date class")
+  }
+  x[1]
 }
 
 #' @export
 end.Date <- function(x, ...) {
-    if (!inherits(x, "Date"))
-        return("x should be date class")
-    x[length(x)]
+  if (!inherits(x, "Date")) {
+    return("x should be date class")
+  }
+  x[length(x)]
 }
 
 #' @export
@@ -23,22 +25,20 @@ seq.dtime <- function(x, ...) as.Date(x$begin:x$end, origin = "1970-01-01")
 
 # seq(x$begin, x$end, by = x$by)
 #' @export
-seq_Date <- function(x, ...) as.Date(begin.Date(x):end.Date(x),
-    origin = "1970-01-01")
+seq_Date <- function(x, ...) as.Date(begin.Date(x):end.Date(x), origin = "1970-01-01")
 
 #' @export
 print.dtime <- function(x, ...) {
-    cat(paste0("site ", x$station, ":  "))
-    cat(sprintf("begin at: %s, end at: %s, %d %ss\n", x$begin,
-        x$end, x$datelen, x$by))
-    # cat('data:\n') print(head(x$data))
+  cat(paste0("site ", x$station, ":  "))
+  cat(sprintf("begin at: %s, end at: %s, %d %ss\n", x$begin, x$end, x$datelen, x$by))
+  # cat('data:\n') print(head(x$data))
 }
 
 print.missInfo <- function(x, ...) {
-    ncol <- ncol(x$info)
-    print(x$info[, 1:(ncol-2)])
-    cat("-----------------------------------------------------\n")
-    print(x$info$detailedInfo[[1]])
+  ncol <- ncol(x$info)
+  print(x$info[, 1:(ncol - 2)])
+  cat("-----------------------------------------------------\n")
+  print(x$info$detailedInfo[[1]])
 }
 
 #' dtime
@@ -50,54 +50,62 @@ print.missInfo <- function(x, ...) {
 #' @param by increment of the sequence
 #'
 #' @export
-dtime <- function(data = NULL, station = NULL, begin = Sys.Date(),
-    end = Sys.Date(), by = "day") {
-    if (!inherits(begin, "Date"))
-        begin <- as.Date(begin)
-    if (!inherits(end, "Date"))
-        end <- as.Date(end)
-    if (begin > end)
-        return("begin date should be small or equal to end date!")
-    if (!(by %in% c("month", "day")))
-        return("by only can choose 'day' or 'month'")
-    if (!is.null(data)) {
-        if (by == "day")
-            datelen <- end - begin + 1
-        if (by == "month")
-            datelen <- length(seq(begin, end, by = by))
+dtime <- function(data = NULL, station = NULL, begin = Sys.Date(), end = Sys.Date(), by = "day") {
+  if (!inherits(begin, "Date")) {
+    begin <- as.Date(begin)
+  }
+  if (!inherits(end, "Date")) {
+    end <- as.Date(end)
+  }
+  if (begin > end) {
+    return("begin date should be small or equal to end date!")
+  }
+  if (!(by %in% c("month", "day"))) {
+    return("by only can choose 'day' or 'month'")
+  }
+  if (!is.null(data)) {
+    if (by == "day") {
+      datelen <- end - begin + 1
+    }
+    if (by == "month") {
+      datelen <- length(seq(begin, end, by = by))
+    }
 
-        dims <- dim(data)
-        n <- ifelse(is.null(dims), length(data), dims[1])
-        if (datelen != n)
-            return("data length or nrow should be equal to date length!")
+    dims <- dim(data)
+    n <- ifelse(is.null(dims), length(data), dims[1])
+    if (datelen != n) {
+      return("data length or nrow should be equal to date length!")
     }
-    structure(list(data = data, station = station, begin = begin,
-        end = end, by = by, datelen = as.numeric(datelen)), class = "dtime")
+  }
+  structure(list(data = data, station = station, begin = begin, end = end, by = by, datelen = as.numeric(datelen)),
+    class = "dtime"
+  )
 }
 
 #' @importFrom stats window<- window end
 #' @export
 "window<-.dtime" <- function(x, begin, end, value) {
-    Id <- match(begin:end, seq(x))
-    if (length(value) != length(Id))
-        error("value should be equal to begin to end date!")
-    Id_nona <- Id %>% {
-        .[which(!is.na(.))]
+  Id <- match(begin:end, seq(x))
+  if (length(value) != length(Id)) {
+    error("value should be equal to begin to end date!")
+  }
+  Id_nona <- Id %>%
+    {
+      .[which(!is.na(.))]
     }
-    # data <- x$data
-    x$data[Id_nona] <- value[Id_nona]  #even if Id_nona is blank, have no side effect
-    return(x)
+  # data <- x$data
+  x$data[Id_nona] <- value[Id_nona] # even if Id_nona is blank, have no side effect
+  return(x)
 }
 
 #' @export
 window.dtime <- function(x, begin, end) {
-    Id <- match(begin:end, seq(x))
-    # if Id is all is.na then a na vector equal to x$data will be
-    # return
-    x$data[Id]  #quickly return
+  Id <- match(begin:end, seq(x))
+  # if Id is all is.na then a na vector equal to x$data will be return
+  x$data[Id] # quickly return
 }
 
 #' @export
 plot.dtime <- function(x, ...) {
-    plot(time = seq(x), value = x$data, ...)
+  plot(time = seq(x), value = x$data, ...)
 }

R/dtime2mat.R

@@ -1,17 +1,26 @@
 #' @export
-dtime2mat <- function(xx, date_begin = NULL, date_end = NULL){
-    date_begin <- map(xx, "begin") %>% unlist() %>% min() %>% as.Date(origin)
-    date_end   <- map(xx, "end") %>% unlist() %>% max() %>% as.Date(origin)
-    datenum <- date_begin:date_end
-    dates <- as.Date(datenum, origin)
+dtime2mat <- function(xx, date_begin = NULL, date_end = NULL) {
+  date_begin <- map(xx, "begin") %>%
+    unlist() %>%
+    min() %>%
+    as.Date(origin)
+  date_end <- map(xx, "end") %>%
+    unlist() %>%
+    max() %>%
+    as.Date(origin)
+  datenum <- date_begin:date_end
+  dates <- as.Date(datenum, origin)
 
-    sites <- names(xx)
-    mat <- matrix(NA_integer_, nrow = length(dates), ncol = length(sites),
-                  dimnames = list(format(dates), sites))
-    temp <- foreach(x = xx, i = icount()) %do% {
-        I <- match(x$begin:x$end, datenum)
-        mat[I, i] <- x$data
-        NULL
-    }
-    as.data.table(mat) %>% cbind(date = dates, .)
+  sites <- names(xx)
+  mat <- matrix(NA_integer_, nrow = length(dates), ncol = length(sites), dimnames = list(
+    format(dates),
+    sites
+  ))
+  temp <- foreach(x = xx, i = icount()) %do% {
+    I <- match(x$begin:x$end, datenum)
+    mat[I, i] <- x$data
+    NULL
+  }
+  as.data.table(mat) %>%
+    cbind(date = dates, .)
 }