1
#' Validates User Entered dsn value
2
#'
3
#' @param dsn User provided value for checking
4
#'
5
#' @noRd
6
.validate_dsn <- function(dsn) {
7 1
  if (is.null(dsn)) {
8 1
    stop(
9 1
      "\nYou must define the dsn where you have stored the local files\n",
10 1
      "for import. If you want to download files using R, use one of the\n",
11 1
      "'get_CRU_*()' functions provided.\n",
12 1
      call. = FALSE
13
    )
14
  } else {
15 1
    dsn <- trimws(dsn)
16 1
    if (substr(dsn, nchar(dsn) - 1, nchar(dsn)) == "//") {
17 0
      p <- substr(dsn, 1, nchar(dsn) - 2)
18 1
    } else if (substr(dsn, nchar(dsn), nchar(dsn)) == "/" |
19 1
               substr(dsn, nchar(dsn), nchar(dsn)) == "\\") {
20 0
      p <- substr(dsn, 1, nchar(dsn) - 1)
21
    } else {
22 1
      p <- dsn
23
    }
24 1
    if (!file.exists(p) & !file.exists(dsn)) {
25 1
      stop("\nFile directory does not exist: ", dsn, ".\n",
26 1
           call. = FALSE)
27
    }
28
  }
29
}
30

31
#' Creates a Data Frame from the CRU Data
32
#'
33
#' @param tmn Is tmn to be calculated? Boolean
34
#' @param tmn Is tmx to be calculated? Boolean
35
#' @param dtr Is dtr to be returned? Boolean
36
#' @param pre Is pre to be returned? Boolean
37
#' @param pre_cv Is pre_cv to be returned? Boolean
38
#' @param elv Is elv to be returned? Boolean
39
#' @param files File list to be used for creating data frame
40
#'
41
#' @return Data frame of all requested values
42
#'
43
#' @importFrom data.table :=
44
#' @noRd
45
.create_df <-
46
  function(tmn, tmx, tmp, dtr, pre, pre_cv, elv, files) {
47 1
    month <- NULL
48

49 1
    CRU_df <-
50 1
      .tidy_df(pre_cv, elv, tmn, tmx, .files = files)
51

52 1
    if (isTRUE(tmx)) {
53 1
      CRU_df[, tmx := tmp + (0.5 * dtr)]
54
    }
55

56 1
    if (isTRUE(tmn)) {
57 1
      CRU_df[, tmn := tmp - (0.5 * dtr)]
58
    }
59

60
    # Remove tmp/dtr if they aren't specified (necessary for tmn/tmx)
61 1
    if (isTRUE(tmx) | isTRUE(tmn)) {
62 1
      if (!isTRUE(tmp)) {
63 1
        CRU_df <- subset(CRU_df, select = -tmp)
64
      }
65

66 1
      if (!isTRUE(dtr)) {
67 1
        CRU_df <- subset(CRU_df, select = -dtr)
68
      }
69
    }
70 1
    CRU_df$month <- factor(
71 1
      CRU_df$month,
72 1
      levels = c(
73 1
        "jan",
74 1
        "feb",
75 1
        "mar",
76 1
        "apr",
77 1
        "may",
78 1
        "jun",
79 1
        "jul",
80 1
        "aug",
81 1
        "sep",
82 1
        "oct",
83 1
        "nov",
84 1
        "dec"
85
      )
86
    )
87

88 1
    data.table::setorder(CRU_df, month)
89

90 1
    return(CRU_df)
91
  }
92

93
#' Read Files from Disk Directory and Tidy Them
94
#' @noRd
95
.tidy_df <- function(pre_cv, elv, tmn, tmx, .files) {
96
  # create list of tidied data frames ----------------------------------------
97 1
  CRU_list <-
98 1
    lapply(X = .files,
99 1
           FUN = .read_cache,
100 1
           .pre_cv = pre_cv)
101

102
  # name the items in the list for the data that they contain ----------------
103 1
  names(CRU_list) <- substr(basename(.files), 12, 14)
104

105
  # rename the columns in the data frames within the list --------------------
106 1
  for (i in seq_along(CRU_list)) {
107 1
    wvars <- as.list(substr(basename(.files), 12, 14))
108 1
    names(CRU_list[[i]])[names(CRU_list[[i]]) == "wvar"] <-
109 1
      wvars[[i]]
110
  }
111

112
  # lastly merge the data frames into one tidy (large) data frame --------------
113

114 1
  if (!isTRUE(elv)) {
115 1
    CRU_df <- Reduce(function(...)
116 1
      merge(..., by = c("lat", "lon", "month")), CRU_list)
117

118 1
  } else if (isTRUE(elv) & length(CRU_list) > 1) {
119 1
    elv_df <- CRU_list[which(names(CRU_list) %in% "elv")]
120 1
    CRU_list[which(names(CRU_list) %in% "elv")] <- NULL
121 1
    CRU_df <- Reduce(function(...)
122 1
      merge(..., by = c("lat", "lon", "month")), CRU_list)
123

124 1
    CRU_df <- CRU_df[elv_df$elv, on = c("lat", "lon")]
125

126 0
  } else if (isTRUE(elv)) {
127 0
    CRU_df <- CRU_list["elv"]
128
  }
129 1
  return(CRU_df)
130

131
  # cleanup before we go -----------------------------------------------------
132 0
  rm(c(CRU_list))
133
}
134

135
#' @noRd
136
.read_cache <- function(.files, .pre_cv) {
137 1
  pre_cv <- i.pre_cv <- elv <- NULL
138 1
  month_names <-
139 1
    c("jan",
140 1
      "feb",
141 1
      "mar",
142 1
      "apr",
143 1
      "may",
144 1
      "jun",
145 1
      "jul",
146 1
      "aug",
147 1
      "sep",
148 1
      "oct",
149 1
      "nov",
150 1
      "dec")
151

152 1
  x <-
153 1
    data.table::fread(cmd = paste0("gzip -dc ", .files),
154 1
                      header = FALSE)
155

156 1
  if (ncol(x) == 14) {
157 1
    data.table::setnames(x, c("lat", "lon", month_names))
158 1
    x_df <-
159 1
      data.table::melt(
160 1
        data = x,
161 1
        measure.vars = month_names,
162 1
        variable.name = "month"
163
      )
164 1
    data.table::setnames(x_df, c("lat", "lon", "month", "wvar"))
165

166 1
  } else if (ncol(x) == 26) {
167 1
    if (isTRUE(.pre_cv)) {
168 1
      x_df <- x[, c(1:14)]
169 1
      data.table::setnames(x_df, c("lat", "lon", month_names))
170 1
      x_df <- data.table::melt(
171 1
        data = x_df,
172 1
        id.vars = c("lat", "lon"),
173 1
        measure.vars = month_names,
174 1
        variable.name = "month"
175
      )
176 1
      data.table::setnames(x_df, c("lat", "lon", "month", "pre"))
177

178 1
      x_df2 <- x[, c(1:2, 15:26)]
179 1
      data.table::setnames(x_df2, c("lat", "lon", month_names))
180

181 1
      x_df2 <- data.table::melt(
182 1
        data = x_df2,
183 1
        measure.vars = month_names,
184 1
        variable.name = "month"
185
      )
186 1
      data.table::setnames(x_df2, c("lat", "lon", "month", "pre_cv"))
187

188 1
      keycols <- c("lat", "lon", "month")
189 1
      data.table::setkeyv(x_df, cols = keycols)
190 1
      data.table::setkeyv(x_df2, cols = keycols)
191 1
      x_df[x_df2, on = c("lat", "lon", "month"), pre_cv := i.pre_cv]
192

193
    } else {
194 1
      x_df <- x[, c(1:14)]
195 1
      names(x_df) <- c("lat", "lon", month_names)
196 1
      x_df <- data.table::melt(
197 1
        data = x_df,
198 1
        id.vars = c("lat", "lon"),
199 1
        measure.vars = month_names,
200 1
        variable.name = "month"
201
      )
202 1
      data.table::setnames(x_df, c("lat", "lon", "month", "pre"))
203
    }
204 1
  } else  if (ncol(x) == 3) {
205 1
    x_df <- x
206 1
    data.table::setnames(x_df, c("lat", "lon", "elv"))
207 1
    x_df[, elv := (elv * 1000)]
208
  }
209 1
  return(x_df)
210
}
211

212
#' @noRd
213
#'
214
.create_stacks <- function(tmn, tmx, tmp, dtr, pre, pre_cv, files) {
215 1
  wrld <-
216 1
    raster::raster(
217 1
      nrows = 930,
218 1
      ncols = 2160,
219 1
      ymn = -65,
220 1
      ymx = 90,
221 1
      xmn = -180,
222 1
      xmx = 180
223
    )
224

225 1
  wrld[] <- NA
226

227 1
  month_names <-
228 1
    c("jan",
229 1
      "feb",
230 1
      "mar",
231 1
      "apr",
232 1
      "may",
233 1
      "jun",
234 1
      "jul",
235 1
      "aug",
236 1
      "sep",
237 1
      "oct",
238 1
      "nov",
239 1
      "dec")
240

241
  # Create raster objects using cellFromXY and generate a raster stack
242
  # create.stack takes pre, tmp, tmn and tmx and creates a raster
243
  # object stack of 12 month data
244

245 1
  CRU_stack_list <-
246 1
    lapply(
247 1
      X = files,
248 1
      FUN = .create_stack,
249 1
      wrld = wrld,
250 1
      month_names = month_names,
251 1
      pre = pre,
252 1
      pre_cv = pre_cv
253
    )
254

255 1
  names(CRU_stack_list) <- substr(basename(files), 12, 14)
256

257
  # cacluate tmn -------------------------------------------------------------
258 1
  if (isTRUE(tmn)) {
259 1
    CRU_stack_list$tmn <-
260 1
      CRU_stack_list$tmp - (0.5 * CRU_stack_list$dtr)
261
  }
262
  # cacluate tmx -------------------------------------------------------------
263 1
  if (isTRUE(tmx)) {
264 1
    CRU_stack_list$tmx <-
265 1
      CRU_stack_list$tmp + (0.5 * CRU_stack_list$dtr)
266
  }
267

268
  # cleanup if tmn/tmx specified but tmp/dtr not -----------------------------
269 1
  if (any(c(isTRUE(tmx), isTRUE(tmn))) & !isTRUE(dtr)) {
270 1
    CRU_stack_list[which(names(CRU_stack_list) %in% "dtr")] <- NULL
271
  }
272 1
  if (any(c(isTRUE(tmx), isTRUE(tmn))) & !isTRUE(tmp)) {
273 1
    CRU_stack_list[which(names(CRU_stack_list) %in% "tmp")] <- NULL
274
  }
275 1
  return(CRU_stack_list)
276
}
277

278
#' @noRd
279
.create_stack <- function(files,
280
                          wrld,
281
                          month_names,
282
                          pre,
283
                          pre_cv) {
284 1
  wvar <-
285 1
    data.frame(data.table::fread(cmd = paste0("gzip -dc ", files[[1]]),
286 1
                                 header = FALSE))
287 1
  cells <- raster::cellFromXY(wrld, wvar[, c(2, 1)])
288 1
  if (ncol(wvar) == 14) {
289 1
    for (j in 3:14) {
290 1
      wrld[cells] <- wvar[, j]
291 1
      if (j == 3) {
292 1
        y <- wrld
293
      } else
294 1
        y <- raster::stack(y, wrld)
295
    }
296 1
    names(y) <- month_names
297 1
  } else if (ncol(wvar) == 26) {
298 1
    if (isTRUE(pre) & isTRUE(pre_cv)) {
299 1
      for (k in 3:26) {
300 1
        wrld[cells] <- wvar[, k]
301 1
        if (k == 3) {
302 1
          y <- wrld
303
        } else
304 1
          y <- raster::stack(y, wrld)
305
      }
306 1
      names(y) <- c(month_names, paste0("pre_cv_", month_names))
307 1
    } else if (isTRUE(pre)) {
308 1
      for (k in 3:14) {
309 1
        wrld[cells] <- wvar[, k]
310 1
        if (k == 3) {
311 1
          y <- wrld
312
        } else
313 1
          y <- raster::stack(y, wrld)
314
      }
315 1
      names(y) <- month_names
316 0
    } else if (isTRUE(pre_cv)) {
317 0
      for (k in 15:26) {
318 0
        wrld[cells] <- wvar[, k]
319 0
        if (k == 15) {
320 0
          y <- wrld
321
        } else
322 0
          y <- raster::stack(y, wrld)
323
      }
324 0
      names(y) <- paste0("pre_cv_", month_names)
325
    }
326

327 1
  } else if (ncol(wvar) == 3) {
328 1
    wrld[cells] <- wvar[, 3] * 1000
329 1
    y <- wrld
330 1
    names(y) <- "elv"
331
  }
332

333 1
  y <- raster::crop(y, raster::extent(-180,
334 1
                                      180,
335 1
                                      -60,
336 1
                                      85))
337 1
  return(y)
338
}
339

340
.set_cache <- function(cache) {
341 1
  if (isTRUE(cache)) {
342 1
    if (!dir.exists(manage_cache$cache_path_get())) {
343 1
      manage_cache$mkdir()
344
    }
345 1
    cache_dir <- manage_cache$cache_path_get()
346
  } else {
347 1
    cache_dir <- tempdir()
348
  }
349 1
  return(cache_dir)
350
}
351

352
#' @noRd
353
.get_local <- function(pre,
354
                       pre_cv,
355
                       rd0,
356
                       tmp,
357
                       dtr,
358
                       reh,
359
                       tmn,
360
                       tmx,
361
                       sunp,
362
                       frs,
363
                       wnd,
364
                       elv,
365
                       cache_dir) {
366
  # check if pre_cv or tmx/tmn (derived) are true, make sure proper ----------
367
  # parameters set TRUE
368 1
  if (isTRUE(pre_cv)) {
369 1
    pre <- TRUE
370
  }
371

372 1
  if (isTRUE(tmn) | isTRUE(tmx)) {
373 0
    dtr <- tmp <- TRUE
374
  }
375

376 1
  dtr_file <- "grid_10min_dtr.dat.gz"
377 1
  tmp_file <- "grid_10min_tmp.dat.gz"
378 1
  reh_file <- "grid_10min_reh.dat.gz"
379 1
  elv_file <- "grid_10min_elv.dat.gz"
380 1
  pre_file <- "grid_10min_pre.dat.gz"
381 1
  sun_file <- "grid_10min_sunp.dat.gz"
382 1
  wnd_file <- "grid_10min_wnd.dat.gz"
383 1
  frs_file <- "grid_10min_frs.dat.gz"
384 1
  rd0_file <- "grid_10min_rd0.dat.gz"
385

386 1
  object_list <- c(dtr, tmp, reh, elv, pre, sunp, wnd, frs, rd0)
387

388 1
  files <-
389 1
    c(
390 1
      dtr_file,
391 1
      tmp_file,
392 1
      reh_file,
393 1
      elv_file,
394 1
      pre_file,
395 1
      sun_file,
396 1
      wnd_file,
397 1
      frs_file,
398 1
      rd0_file
399
    )
400 1
  names(files) <-
401 1
    names(object_list) <-
402 1
    c(
403 1
      "dtr_file",
404 1
      "tmp_file",
405 1
      "reh_file",
406 1
      "elv_file",
407 1
      "pre_file",
408 1
      "sun_file",
409 1
      "wnd_file",
410 1
      "frs_file",
411 1
      "rd0_file"
412
    )
413

414
  # filter files -------------------------------------------------------------
415
  # which files are being requested?
416 1
  files <- files[object_list %in% !isTRUE(files)]
417

418
  # filter files from cache directory in case there are local files for which
419
  # we do not want data
420 1
  cache_dir_contents <- as.list(list.files(cache_dir,
421 1
                                           pattern = ".dat.gz$"))
422

423 1
  files <- cache_dir_contents[cache_dir_contents %in% files]
424

425 1
  if (length(files) < 0) {
426 0
    stop("\nThere are no CRU CL v. 2.0 data files available in this directory.\n",
427 0
         call. = FALSE)
428
  }
429

430
  # add full file path to the files
431 1
  files <- file.path(cache_dir, files)
432

433
  # fill the space with a "\" for R, if one exists
434 1
  files <- gsub(" ", "\\ ", files, fixed = TRUE)
435

436 1
  return(files)
437
}

Read our documentation on viewing source code .

Loading