R/getSWATcfsr.R

In hydroMet: Meteorological Data for Hydrological Modeling

#######################################################################################################
#          *** Copyright (C) Andrew Sommerlot - All Rights Reserved ***           					  #
# Unauthorized Copying, Distrubution, or editing of this file, via any medium is strictly prohibited  #
#                               Proprietary and Confidential                                          #
#               Written by Andrew R Sommerlot <andrewrs@vt.edu>, Februrary 2015                       #
#######################################################################################################

###############################################################################################
# 					           *** Version 1.0.2 *** 										  #
# *This code is designed to create swat weather files for multiple subbasin centroids         #
# 		from the redimentioned CFSR data set located at cfsr.bse.vt.edu/swat-cfsr-v02.pl	  #
# *Does not include elevation capabiliteis for modeling different elevation bands in swat 	  #
# *Inputs are csv subbasin centiod file in csv format and character string indicating         #
#		the directory the swat files will be saved in                                         #
###############################################################################################
#' Gets met data from the redimentioned CFSR data set and outputs SWAT IO format weather input files
#' @param centroids
#' @param outDir
#' @return returns cfsr met data in swat IO format
#' @export 


getSWATcfsr <- function(centroids, outDir = getwd()){
	
#libraries
require(SWATmodel)

tag1 <- '\n... Requesting Data from cfsr.bse.vt.edu/swat-cfsr-v02.pl ...\n'

cat(gettext(tag1),"\n", sep <- "", file = stderr())


#read in csv file of centorids 
setwd(outDir)


if(class(centroids) == 'character'){
	cent <- read.csv(centroids)
} else if(class(centroids) == 'data.frame'){
	cent <- centroids
}

# row number of centroids 
ln <- nrow(cent)

####################################format for tmax
#make headers with lat lon and evelatiuon la

cfsr <- list()
tmpls <- list()
pcpls <- list()
hmdls <- list()
slrls <- list()
wndls <- list()

for(i in 1:ln){

cfsr[[i]] <- get_cfsr_latlon(cent[i,1], cent[i,2])

}

for(a in 1:ln){


#tmax.agg
date.full <- getSWATdates(cfsr[[a]]$DATE)

###Recombine for matrix

tmax.format <- data.frame(date.full, cfsr[[a]]$TMX)

colnames(tmax.format) <- c('date', 'tmax')


tmax.format$tmax <- formatC(tmax.format$tmax, digits = 1, width = 5, flag = '0', format = 'f')



############################################################################################################
############################################################################################################
##format for tmin

tmin.format <- data.frame(tmax.format$date, cfsr[[a]]$TMN)

colnames(tmin.format) <- c('date', 'tmin')

tmin.format$tmin <- formatC(tmin.format$tmin, digits = 1, width = 5, flag = '0', format ='f')

colnames(tmin.format) <- c('date', 'tmin')

############################################################################################################

############################################################################################################
############################################################################################################
###Combine max and min into one temp file
temp.format <- data.frame(tmax.format, tmin.format$tmin)

colnames(temp.format) <- c('date', 'tmax', 'tmin')


############################################################################################################
############################################################################################################
##for rhum

rhum.format <- data.frame(tmax.format$date, cfsr[[a]]$AVGRH)

colnames(rhum.format) <- c('date', 'rhum')

rhum.format$rhum <- formatC(rhum.format$rhum, digits = 3, width = 5, flag = '0', format ='f')

colnames(rhum.format) <- c('date', 'rhum')

############################################################################################################
############################################################################################################
##for pcp
pcp.format <- data.frame(tmax.format$date, cfsr[[a]]$PRECIP)

colnames(pcp.format) <- c('date', 'pcp')

pcp.format$pcp <- formatC(pcp.format$pcp, digits = 1, width = 5, flag = '0', format ='f')

colnames(pcp.format) <- c('date', 'pcp')

############################################################################################################
############################################################################################################
##for wnd
wnd.format <- data.frame(tmax.format$date, cfsr[[a]]$WIND)

colnames(wnd.format) <- c('date', 'wnd')


wnd.format$wnd<- formatC(wnd.format$wnd, digits = 3, width = 8, flag = '0', format = 'f')

colnames(wnd.format) <- c('date', 'wnd')


############################################################################################################
############################################################################################################
##for slr
slr.format <- data.frame(tmax.format$date, cfsr[[a]]$SOLAR)

colnames(slr.format) <- c('date', 'slr')


slr.format$slr <- formatC(slr.format$slr, digits = 3, width = 8, flag = '0', format ='f')

colnames(slr.format) <- c('date', 'slr')


############################################################################################################
############################################################################################################
#everthing into there own big ass lists
tmpls[[a]] <- temp.format
pcpls[[a]] <- pcp.format
hmdls[[a]] <- rhum.format
slrls[[a]] <- slr.format
wndls[[a]] <- wnd.format

#temp is different than the rest, but get the lists ready for c bind
	tmpls[[a]][,1] <- NULL
	tmpls[[a]]$full <- paste(tmpls[[a]][,1],tmpls[[a]][,2], sep = '')
	tmpls[[a]]$tmax <- NULL
	tmpls[[a]]$tmin <- NULL
	pcpls[[a]][,1] <- NULL
	hmdls[[a]][,1] <- NULL
	slrls[[a]][,1] <- NULL
	wndls[[a]][,1] <- NULL
############################################################################################################
############################################################################################################
	
	
}


#bind all the stations together
alltmps <- do.call('cbind', tmpls)
allpcps <- do.call('cbind', pcpls)
allhmds <- do.call('cbind', hmdls)
allslrs <- do.call('cbind', slrls)
allwnds <- do.call('cbind', wndls)

# get the full thing for printing
tmpprint <- data.frame(tmax.format$date, alltmps)
pcpprint <- data.frame(tmax.format$date, allpcps)
hmdprint <- data.frame(tmax.format$date, allhmds)
slrprint <- data.frame(tmax.format$date, allslrs)
wndprint <- data.frame(tmax.format$date, allwnds)

############################################################################################################
############################################################################################################
#make the headers for tmp and pcp 

Lati <- centroids[,1]

Long <- centroids[,2]

headtmp <- c('Station  tmp	Source cfsr', paste('Lati', paste(Lati, collapse = '   '), sep = '   '), paste('Long', paste(Long, collapse = '   '), sep = '   '), 'Elev')

headpcp <- c('Station  pcp	Source cfsr', paste('Lati', paste(Lati, collapse = '   '), sep = '   '), paste('Long', paste(Long, collapse = '   '), sep = '   '), 'Elev')

headhmd <- 'Relative Humidity % 	Source cfsr'

headwnd <- 'Wind Speed m/s 	Source cfsr'

headslr <- 'Solar Radiation MJ/m^2 	Source cfsr'


############################################################################################################
############################################################################################################
#write tmp and pcp header files and append the data 

writeLines(headtmp, 'tmp1.tmp')

writeLines(headpcp, 'pcp1.pcp')

writeLines(headhmd, 'hmd.hmd')

writeLines(headwnd, 'slr.slr')

writeLines(headslr, 'wnd.wnd')

write.table(tmpprint, 'tmp1.tmp', append = TRUE, sep = '', row.names = FALSE, col.names = FALSE, quote = FALSE)

write.table(pcpprint, 'pcp1.pcp', append = TRUE, sep = '', row.names = FALSE, col.names = FALSE, quote = FALSE)

write.table(hmdprint, 'hmd.hmd', append = TRUE, sep = '', row.names = FALSE, col.names = FALSE, quote = FALSE)

write.table(slrprint, 'slr.slr', append = TRUE, sep = '', row.names = FALSE, col.names = FALSE, quote = FALSE)

write.table(wndprint, 'wnd.wnd', append = TRUE, sep = '', row.names = FALSE, col.names = FALSE, quote = FALSE)

############################################################################################################
############################################################################################################

}