-
Notifications
You must be signed in to change notification settings - Fork 5
/
HSwrite.R
139 lines (114 loc) · 4.5 KB
/
HSwrite.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
#' Writes an HS object to disk.
#'
#' Writes out \code{HS} objects in order to use them outside R. By default
#' the function writes the geometry using \code{\link[sf]{st_write}}, but where
#' list columns are modified since they cannot be written by st_write.
#' Alternatively the function can output a timeseries specified by the user
#' (runoff, discharge, or control).
#'
#' @param x A \code{HS} object.
#' @param filename Filename to write to.
#' @param what What to write. Accepts \code{"geometry"} for writing the river
#' network or the runoff grid, or \code{"discharge_ts", "runoff_ts",
#' "control_ts"} for writing out a .csv table of the associated timeseries.
#' @param ... options passed to \code{\link[sf]{st_write}}.
#'
#' @export
HSwrite <- function(x, filename, what = "geometry", ...) {
UseMethod("HSwrite")
}
#' @export
HSwrite.HS <- function(x, filename, what = "geometry", ...) {
Optimisation_info <- NULL
observation_ts <- NULL
##################
# WRITE OUT GEOMETRY
if (what == "geometry") {
test <- hasName(x, "NEXT")
if(test) x$PREVIOUS <- lapply(x$NEXT,
function(x) {
paste(x, collapse=" ")
}) %>% unlist()
test <- hasName(x, "PREVIOUS")
if(test) x$PREVIOUS <- lapply(x$PREVIOUS,
function(x) {
paste(x, collapse=" ")
}) %>% unlist()
test <- hasName(x, "runoff_ts")
if (test) {
x$runoff_ts <- rep(TRUE, nrow(x))
}
test <- hasName(x, "discharge_ts")
if (test) {
x$discharge_ts <- rep(TRUE, nrow(x))
}
test <- hasName(x, "Optimisation_info")
if (test) {
x <- dplyr::select(x, -Optimisation_info)
}
test <- hasName(x, "observation_ts")
if (test) {
x <- dplyr::select(x, -observation_ts)
}
test <- hasName(x, "control_ts")
if (test) {
replace <- !sapply(x$control_ts, is.null)
x$control_ts <- replace
}
sf::st_write(x, filename, ...)
######################
# WRITE OUT A TABLE OF RUNOFF_TS
} else if (what == "runoff") {
test <- hasName(x, "runoff_ts")
if(test) {
data <- collect_listc(x$runoff_ts, acc=TRUE)
for(pred in seq_along(data)) {
name <- paste0(filename, "_", names(data)[pred], ".csv")
test <- requireNamespace("readr")
if(test) {
readr::write_csv(data[[pred]], name)
} else {
write.csv(data[[pred]], file = name)
}
}
} else {
stop("No runoff timeseries in the input - no output written")
}
######################
# WRITE OUT A TABLE OF DISCHARGE_TS
} else if (what == "discharge") {
test <- hasName(x, "discharge_ts")
if(test) {
data <- collect_listc(x$discharge_ts, acc=TRUE)
for(pred in seq_along(data)) {
name <- paste0(filename, "_", names(data)[pred], ".csv")
test <- requireNamespace("readr")
if(test) {
readr::write_csv(as.data.frame(data[[pred]]), name)
} else {
write.csv(as.data.frame(data[[pred]]), file = name)
}
}
} else {
stop("No discharge timeseries in the input - no output written")
}
######################
# WRITE OUT A TABLE OF CONTROL_TS
} else if (what == "control") {
test <- hasName(x, "control_ts")
if(test) {
data <- collect_listc(x$control_ts, acc=TRUE)
for(pred in seq_along(data)) {
name <- paste0(filename, "_", names(data)[pred], ".csv")
test <- requireNamespace("readr")
if(test) {
readr::write_csv(data[[pred]], name)
} else {
write.csv(data[[pred]], file = name)
}
}
} else {
stop("No runoff timeseries in the input - no output written")
}
}
}