/
expdb_met.R
355 lines (332 loc) · 11.5 KB
/
expdb_met.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
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
# * Author: Bangyou Zheng (Bangyou.Zheng@csiro.au)
# * Created: 10:31 PM Sunday, 19 August 2012
# * Copyright: AS IS
# *
# expDB API for met
# Get the database file name
# @param con a connection object as produced by dbConnect
dbGetDBName <- function(con)
{
methods::slot(con, 'dbname')
}
#' Insert and update met into expDB
#' @param con a connection object as produced by dbConnect
#' @param data Met design
#' @return no return values
#' @export
dbAddMets <- function(con, data)
{
names(data) <- tolower(names(data))
if (!tibble::has_name(data, 'type'))
{
type <- rep('daily', nrow(data))
} else
{
type <- tolower(data$type)
}
data$type <- ifelse(type %in% 'daily', 1, 2)
# Check existing met file
unique_id <- getIdByUniqueIndex(con,
'expdb_met', data, 'name')
if (class(con) == 'MySQLConnection') {
for (i in seq(length = nrow(data)))
{
if (!is.na(unique_id[i]))
{
next
}
dbInsertUpdateByRow(con, 'expdb_met', data,
unique_col = 'name')
}
} else if (class(con) == 'SQLiteConnection') {
file_lim <- 300
for (i in seq(length = nrow(data)))
{
if (!is.na(unique_id[i]))
{
next
}
sql <- sprintf('SELECT * FROM expdb_met_file WHERE type=%s ORDER BY id',
data$type[i])
met_file <- DBI::dbGetQuery(con, sql)
if (sum(met_file$num < file_lim) > 0)
{
temp <- met_file[met_file$num < file_lim,]
file_id <- temp$id[1]
c_num <- temp$num[1]
} else
{
# Create a new data base for met
filename <- sprintf('%s_%smet_',
gsub('\\.db', '', basename(dbGetDBName(con))),
type[i])
idx <- ifelse(nrow(met_file) > 0,
1 + as.numeric(sub(sprintf('%s(\\d+)\\.db',
filename), '\\1', met_file$name)),
0)
filename <- file.path(
dirname(dbGetDBName(con)),
paste(filename, idx, '.db', sep = ''))
db <- DBI::dbConnect(RSQLite::SQLite(), dbname = ":memory:")
if (type[i] == "daily") {
sql <- '
CREATE TABLE [expdb_met_daily] (
[met_id] INTEGER NOT NULL ON CONFLICT IGNORE,
[year] INTEGER NOT NULL ON CONFLICT IGNORE,
[day] INTEGER NOT NULL ON CONFLICT IGNORE,
[radn] FLOAT,
[maxt] FLOAT,
[mint] FLOAT,
[rain] FLOAT,
[evap] FLOAT,
[vp] FLOAT,
CONSTRAINT [] PRIMARY KEY ([met_id], [year], [day]) ON CONFLICT IGNORE);
'
} else {
sql <- '
CREATE TABLE [expdb_met_hourly](
[met_id] INTEGER NOT NULL ON CONFLICT IGNORE,
[timestamp] TIMESTAMP NOT NULL ON CONFLICT IGNORE,
[temperature] FLOAT,
PRIMARY KEY([met_id], [timestamp]) ON CONFLICT IGNORE);
'
}
sql <- gsub('\t+', '', sql)
sql <- sql[nchar(sql) > 0]
DBI::dbBegin(db)
for (j in seq(along = sql))
{
res <- DBI::dbSendQuery(db, sql[j])
DBI::dbClearResult(res)
}
success <- DBI::dbCommit(db)
RSQLite::sqliteCopyDatabase(db, filename)
DBI::dbDisconnect(db)
f_data <- as.data.frame(list(
name = basename(filename),
type = data$type[i],
num = 0))
dbInsertUpdateByRow(con, 'expdb_met_file', f_data,
unique_col = 'name')
sql <- sprintf('SELECT id FROM expdb_met_file WHERE name="%s"',
f_data$name)
file_id <- as.numeric(unlist(DBI::dbGetQuery(con, sql)))
c_num <- 0
}
data$file_id <- file_id
dbInsertUpdateByRow(con, 'expdb_met', data[i,],
unique_col = 'name')
sql <- sprintf('UPDATE expdb_met_file SET NUM=%s WHERE id=%s',
c_num + 1, file_id)
DBI::dbExecute(con, sql)
}
} else {
warning('not implemented')
}
}
#' Add weather records into expDB
#' @param con a connection object as produced by dbConnect
#' @param data A string character for the path to met file,
#' a WeaAna object, or a data frame.
#' @param name The met name in the database
#' if data is a data frame.
#' @return no return values
#' @export
dbAddWeather <- function(con, data, name=NULL)
{
if (class(data) == 'character')
{
stop('NOT implemented')
# records <- readWeatherRecords(data)
# records <- getWeatherRecords(records)
} else if (class(data) == 'WeaAna')
{
if (is.null(name))
{
site_infor <- weaana::siteInfor(data)
site_infor$Name <- tolower(site_infor$Name)
dbAddMets(con, site_infor)
name <- site_infor$Name
}
met_id <- getIdByUniqueIndex(con, 'expdb_met',
as.character(name), 'name')
if (is.na(met_id))
{
stop('met id doesn\'t exist')
}
records <- weaana::getWeatherRecords(data)
} else if (class(data) == 'data.frame')
{
met_id <- getIdByUniqueIndex(con, 'expdb_met', name)
if (sum(is.na(met_id)) > 0)
{
stop(sprintf('Met %s is not in the database', name))
}
records <- data
} else
{
stop('NOT implemented')
}
if (class(con) == 'MySQLConnection') {
sql <- sprintf('SELECT * FROM expdb_met WHERE id = %s', met_id)
met_meta <- DBI::dbGetQuery(con, sql)
if (met_meta$type == 1)
{
records$met_id <- met_id
dbcols <- DBI::dbListFields(con, 'expdb_met_daily')
missing_cols <- dbcols[!(dbcols %in% names(records))]
for (k in seq(along = missing_cols))
{
records[[missing_cols[k]]] <- NA
}
records <- records[,dbcols]
DBI::dbAppendTable(con, 'expdb_met_daily',
as.data.frame(records))
} else {
warning("Not implemented")
}
} else if (class(con) == 'SQLiteConnection') {
sql <- sprintf('SELECT M.id, M.type, F.name as filename
FROM expdb_met M LEFT OUTER JOIN expdb_met_file F ON
M.[file_id]=F.[id] WHERE M.id = %s', met_id)
met_meta <- DBI::dbGetQuery(con, sql)
records$met_id <- met_id
filename <- file.path(
dirname(dbGetDBName(con)),
met_meta$filename)
if (!file.exists(filename))
{
stop(sprintf('%s does not existed', filename))
}
m <- DBI::dbDriver("SQLite")
conf <- DBI::dbConnect(m, dbname = filename)
if (met_meta$type == 1)
{
dbcols <- DBI::dbListFields(conf, 'expdb_met_daily')
missing_cols <- dbcols[!(dbcols %in% names(records))]
for (k in seq(along = missing_cols))
{
records[[missing_cols[k]]] <- NA
}
records <- records[,dbcols]
DBI::dbAppendTable(conf, 'expdb_met_daily',
as.data.frame(records))
DBI::dbDisconnect(conf)
} else if (met_meta$type == 2)
{
# Assume the hourly records are csv format and have columns (timestamp, temperature)
names(records) <- tolower(names(records))
if (!tibble::has_name(records, "timestamp")) {
stop("missing the timestamp column in hourly climate")
}
if (!tibble::has_name(records, "temperature")) {
warning("missing the temperature column in hourly climate")
}
if (!("POSIXct" %in% class(records$timestamp))) {
stop("timestamp column should be class POSIXct")
}
if (sum(is.na(records$timestamp)) > 0 ) {
stop("Missing values in the timestamp column")
}
dbcols <- DBI::dbListFields(conf, 'expdb_met_hourly')
missing_cols <- dbcols[!(dbcols %in% names(records))]
for (k in seq(along = missing_cols))
{
records[[missing_cols[k]]] <- NA
}
records <- records[,dbcols]
DBI::dbAppendTable(conf, 'expdb_met_hourly',
as.data.frame(records))
DBI::dbDisconnect(conf)
}
} else {
warning('not implemented')
}
}
#' Get weather records from expDB
#' @param con a connection object as produced by dbConnect
#' @param name The met name
#' @param format The format of export dataset.
#' @param na The character for missing value with default NA
#' @param tz Time zone applied for hourly temperature
#' @return a data.frame for all weather records
#' @export
dbGetWeather <- function(con, name, format = 'data_frame', na = NA_character_, tz = "UTC")
{
met_id <- getIdByUniqueIndex(con, 'expdb_met', name)
if (sum(is.na(met_id)) > 0)
{
stop(sprintf('Met %s is not in the database', name))
}
sql <- sprintf('SELECT M.id, M.type, M.name, M.number,
M.latitude, M.longitude, F.name as filename
FROM expdb_met M LEFT OUTER JOIN expdb_met_file F ON
M.[file_id]=F.[id] WHERE M.id = %s', met_id)
met_infor <- DBI::dbGetQuery(con, sql)
m <- DBI::dbDriver("SQLite")
filename <- file.path(
dirname(dbGetDBName(con)),
met_infor$filename)
conf <- DBI::dbConnect(m, dbname = filename)
if (met_infor$type == 1) {
sql <- sprintf('SELECT * FROM expdb_met_daily WHERE met_id=%s', met_id)
} else if (met_infor$type == 2 ) {
sql <- sprintf('SELECT * FROM expdb_met_hourly WHERE met_id=%s', met_id)
} else {
stop('NOT IMPLEMENTED')
}
res <- DBI::dbGetQuery(conf, sql)
DBI::dbDisconnect(conf)
res$met_id <- NULL
if (!is.na(na)) {
res[is.na(res)] <- na
}
# Only date frame for hourly data
if (met_infor$type == 1 ) {
if (format == 'weaana')
{
res <- weaana::createWeaAna(
list(Name = met_infor$name,
Number = met_infor$number,
Latitude = met_infor$latitude,
Longitude = met_infor$longitude,
Records = res))
} else if (format == 'data_frame')
{
res$date <- yearDay2Date(res$day, res$year)
res$name <- met_infor$name
res$number <- met_infor$number
res$latitude <- met_infor$latitude
res$longitude <- met_infor$longitude
res <- tibble::tibble(res)
} else if (format == 'sirius') {
res <- res %>%
dplyr::select(dplyr::all_of(c('year', 'day', 'mint', 'maxt', 'rain', 'radn')))
}
} else {
res$timestamp <- as.POSIXct(res$timestamp,
origin = as.POSIXct("1970-01-01 00:00.00", tz = "UTC"),
tz = "UTC")
res$timestamp <- lubridate::with_tz(res$timestamp, tz)
res$name <- met_infor$name
res$number <- met_infor$number
res$latitude <- met_infor$latitude
res$longitude <- met_infor$longitude
res <- tibble::tibble(res)
}
return(res)
}
#' Get met information
#'
#' @param con a connection object as produced by dbConnect
#' @param name The met name
#' @return a data.frame for met information
#' @export
dbGetMetInfo <- function(con, name)
{
sql <- sprintf('SELECT id, type, name, number,
latitude, longitude from expdb_met WHERE name in (%s)',
paste(paste0('"', name, '"'), collapse = ','))
met_infor <- DBI::dbGetQuery(con, sql)
met_infor
}