|
| 1 | +# Internal function to read reservoir input file. Called by read_io(). |
| 2 | +read_io_reservoir <- function(filename, meta_data, subset, silent) { |
| 3 | + if (is.null(meta_data$nbands) || meta_data$nbands != length(band_names_reservoir)) { |
| 4 | + stop( |
| 5 | + "Invalid number of bands ", default(meta_data$nbands, 1), |
| 6 | + " in reservoir file ", filename, ". Expected ", |
| 7 | + length(band_names_reservoir), "." |
| 8 | + ) |
| 9 | + } |
| 10 | + if (!is.null(meta_data$nyear) && meta_data$nyear != 1) { |
| 11 | + stop( |
| 12 | + "Invalid number of years ", meta_data$nyear, |
| 13 | + " in reservoir file ", filename, ". Expected 1." |
| 14 | + ) |
| 15 | + } |
| 16 | + if (!is.null(meta_data$nstep) && meta_data$nstep != 1) { |
| 17 | + stop( |
| 18 | + "Invalid number of time steps per year ", meta_data$nstep, |
| 19 | + " in reservoir file ", filename, ". Expected 1." |
| 20 | + ) |
| 21 | + } |
| 22 | + if (!silent) { |
| 23 | + message( |
| 24 | + "Note: Reservoir file detected, which uses a special file structure. ", |
| 25 | + "Time axis in returned LPJmLData object is not meaningful." |
| 26 | + ) |
| 27 | + } |
| 28 | + if (!silent && !is.null(meta_data$band_names) && |
| 29 | + !all(tolower(meta_data$band_names) == tolower(band_names_reservoir)) |
| 30 | + ) { |
| 31 | + warning( |
| 32 | + "Supplied band_names attribute c(", |
| 33 | + toString(dQuote(meta_data$band_names, q = FALSE)), |
| 34 | + ") does not seem to match implemented reservoir file structure. ", |
| 35 | + "Implemented band order: c(", |
| 36 | + toString(dQuote(band_names_reservoir, q = FALSE)), ").", |
| 37 | + immediate. = TRUE, call. = FALSE |
| 38 | + ) |
| 39 | + } |
| 40 | + # Determine all years in the file |
| 41 | + years <- seq( |
| 42 | + from = default(meta_data$firstyear, 1901), |
| 43 | + by = default(meta_data$timestep, 1), |
| 44 | + length.out = default(meta_data$nyear, 1) |
| 45 | + ) |
| 46 | + # Subsetting by year does not work for restart files |
| 47 | + if ("year" %in% names(subset)) { |
| 48 | + warning( |
| 49 | + "Subsetting by year not possible for reservoir files", |
| 50 | + immediate. = TRUE, call. = FALSE |
| 51 | + ) |
| 52 | + } |
| 53 | + |
| 54 | + # Open binary file connection |
| 55 | + file_connection <- file(filename, "rb") |
| 56 | + # Ensure that file connection is closed even if function is terminated with an |
| 57 | + # error |
| 58 | + on.exit(if (exists("file_connection")) close(file_connection)) # nolint:undesirable_function_linter. |
| 59 | + |
| 60 | + # Dimension order during reading. Note: Must be 3 dimensions in total, with |
| 61 | + # "time" being last dimension for code below to work. |
| 62 | + read_band_order <- c("cell", "band", "time") |
| 63 | + |
| 64 | + # Seek to start position of data |
| 65 | + seek(file_connection, default(meta_data$offset, 0)) |
| 66 | + |
| 67 | + year_data <- array( |
| 68 | + dim = switch( |
| 69 | + default(meta_data$order, "cellyear"), |
| 70 | + cellyear = c( |
| 71 | + band = unname(default(meta_data$nbands, 1)), |
| 72 | + time = unname(default(meta_data$nstep, 1)), |
| 73 | + cell = unname(meta_data$ncell) |
| 74 | + ), |
| 75 | + yearcell = stop("Order yearcell not supported"), |
| 76 | + cellindex = stop("Order cellindex not supported"), |
| 77 | + cellseq = stop("Order cellindex not supported") |
| 78 | + ) |
| 79 | + ) |
| 80 | + |
| 81 | + # Assign dimension names to array. |
| 82 | + band_names <- default( |
| 83 | + meta_data$band_names, |
| 84 | + band_names_reservoir |
| 85 | + ) |
| 86 | + cell_dimnames <- seq( |
| 87 | + default(meta_data$firstcell, 0), |
| 88 | + length.out = meta_data$ncell |
| 89 | + ) |
| 90 | + dimnames(year_data) <- switch( |
| 91 | + default(meta_data$order, "cellyear"), |
| 92 | + cellyear = list( # order 1 |
| 93 | + band = band_names, |
| 94 | + time = NULL, # Assign dates later |
| 95 | + cell = cell_dimnames |
| 96 | + ), |
| 97 | + yearcell = stop("Order yearcell not supported"), # order 2 |
| 98 | + cellindex = stop("Order cellindex not supported"), # order 3 |
| 99 | + cellseq = stop("Order cellindex not supported") # order 4 |
| 100 | + ) |
| 101 | + # Read data |
| 102 | + for (cell in seq_len(meta_data$ncell)) { |
| 103 | + year_data[1, 1, cell] <- readBin( |
| 104 | + file_connection, |
| 105 | + n = 1, |
| 106 | + what = integer(), |
| 107 | + size = 4, |
| 108 | + endian = ifelse(meta_data$bigendian, "big", "little") |
| 109 | + ) |
| 110 | + year_data[c(2, 3), 1, cell] <- readBin( |
| 111 | + file_connection, |
| 112 | + n = 2, |
| 113 | + what = double(), |
| 114 | + size = 4, |
| 115 | + endian = ifelse(meta_data$bigendian, "big", "little") |
| 116 | + ) |
| 117 | + year_data[seq(4, 10), 1, cell] <- readBin( |
| 118 | + file_connection, |
| 119 | + n = 7, |
| 120 | + what = integer(), |
| 121 | + size = 4, |
| 122 | + endian = ifelse(meta_data$bigendian, "big", "little") |
| 123 | + ) |
| 124 | + } |
| 125 | + # Close binary file connection |
| 126 | + close(file_connection) |
| 127 | + # Delete file_connection to prevent triggering on.exit expression |
| 128 | + rm(file_connection) |
| 129 | + |
| 130 | + # Convert to read_band_order and apply subsetting along bands or cells |
| 131 | + year_data <- aperm(year_data, perm = read_band_order) |
| 132 | + |
| 133 | + # Apply any subsetting along bands or cells |
| 134 | + index <- which(!names(subset) %in% c("day", "month", "year", "time")) |
| 135 | + year_data <- subset_array( |
| 136 | + year_data, |
| 137 | + subset[index], |
| 138 | + drop = FALSE, |
| 139 | + silent = silent |
| 140 | + ) |
| 141 | + |
| 142 | + # Create and assign time dimension names |
| 143 | + time_dimnames <- create_time_names( |
| 144 | + nstep = default(meta_data$nstep, 1), |
| 145 | + years = years |
| 146 | + ) |
| 147 | + dimnames(year_data)$time <- time_dimnames |
| 148 | + |
| 149 | + year_data |
| 150 | +} |
0 commit comments