Merge pull request #89 from lawinslow/master

Fixes from calibration NECSC runs

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: mda.lakes
 Type: Package
 Title: Tools for combining models, data, and processing for lakes
-Version: 3.0.1
+Version: 3.0.4
 Date: 2015-12-03
 Author: Luke Winslow, Jordan Read
 Maintainer: Luke Winslow <[email protected]>

NAMESPACE

@@ -50,6 +50,8 @@ export(prep_run_chained_glm)
 export(prep_run_chained_glm_kd)
 export(prep_run_glm_kd)
 export(sens_seasonal_site)
+export(set_driver_url)
+export(write_error_log)
 import(GLMr)
 import(glmtools)
 import(lakeattributes)

R/AAA.R

@@ -1,2 +1,4 @@
 #AAA
-base_url='http://cida-test.er.usgs.gov/mda.lakes/'
+pkg_info = new.env()
+
+pkg_info$dvr_url='http://cida-test.er.usgs.gov/mda.lakes/'

R/calc_mod_obs_metric.R

@@ -20,7 +20,7 @@ calc_mod_obs_metric = function(mod_obs_df, metric){
 	for(lid in uids){
 		lake_data = subset(mod_obs_df, site_id == lid)
 		lake_data$site_id = NULL
-		bathy = getBathy(strsplit(lid, '_')[[1]][2])
+		bathy = get_bathy(lid)
 
 		lake_data = ddply(lake_data, 'DateTime', function(df){
 									if(nrow(na.omit(df)) >= 5){

R/get_driver_nhd.R

@@ -21,11 +21,16 @@ get_driver_nhd = function(id, driver_name, loc_cache, timestep){
 	#grab (and open?) Rdata files
 	for(i in 1:length(match_i)){
 		fname = indx[match_i[i], 'file.name']
-		driver_url = paste0(base_url, 'drivers_GLM_', driver_name, '/', fname)
+		driver_url = paste0(pkg_info$dvr_url, 'drivers_GLM_', driver_name, '/', fname)
 		dest = file.path(tempdir(), driver_name, fname)
 
-		if(!download_helper(driver_url, dest)){
-			stop('failure downloading ', fname, '\n')
+
+		if(substr(driver_url, 0,7) == 'file://'){
+		  dest = sub('file://', '', driver_url)
+		}else{
+		  if(!download_helper(driver_url, dest)){
+		    stop('failure downloading ', fname, '\n')
+		  }
 		}
 
 		load(dest, envir=driver_env)
@@ -47,7 +52,18 @@ get_driver_nhd = function(id, driver_name, loc_cache, timestep){
 		daily = trunc(as.POSIXct(glm_drivers$time), units='days')
 		glm_drivers$time = format(daily,'%Y-%m-%d %H:%M:%S')
 
-		glm_drivers = plyr::ddply(glm_drivers,'time', function(df){colMeans(df[,-1])})
+		glm_drivers = plyr::ddply(glm_drivers,'time', function(df){
+
+			data.frame(
+				ShortWave = mean(df$ShortWave),
+				LongWave  = mean(df$LongWave),
+				AirTemp   = mean(df$AirTemp),
+				RelHum    = mean(df$RelHum),
+				WindSpeed = mean(df$WindSpeed^3)^(1/3),
+				Rain      = mean(df$Rain),
+				Snow      = mean(df$Snow)
+			)
+		})
 
 	}
 
@@ -75,7 +91,7 @@ get_driver_nhd = function(id, driver_name, loc_cache, timestep){
 #' @export
 get_driver_index = function(driver_name, loc_cache=TRUE){
 	#see if index file exists already
-	index_url = paste0(base_url, 'drivers_GLM_', driver_name, '/driver_index.tsv')
+	index_url = paste0(pkg_info$dvr_url, 'drivers_GLM_', driver_name, '/driver_index.tsv')
 	dest = file.path(tempdir(), driver_name, 'driver_index.tsv')
 
 	#If it exists, return without downloading
@@ -90,6 +106,18 @@ get_driver_index = function(driver_name, loc_cache=TRUE){
 	return(read.table(dest, sep='\t', header=TRUE, as.is=TRUE))
 }
 
+#' @title Set driver URL
+#' 
+#' @param url New base URL to set
+#' 
+#' @description 
+#' Sets the default URL to access driver data. 
+#' 
+#' @export
+set_driver_url = function(url){
+  pkg_info$dvr_url = url
+}
+
 drivers_to_glm = function(driver_df){
 
 	## convert and downsample wind

R/lake_attribute_functions.R

@@ -122,7 +122,7 @@ getResidenceTime	<-	local(
 #' 
 #' 
 #' @export
-getCanopy = function(site_id, default.if.null=FALSE, method="aster"){
+getCanopy = function(site_id, default.if.null=FALSE, method="landcover"){
 
 	if (tolower(method) == 'aster'){
 
@@ -137,28 +137,13 @@ getCanopy = function(site_id, default.if.null=FALSE, method="aster"){
 		return(vals$MEAN_HT)
 
 	}else if (tolower(method) == "landcover"){
-
-		fname = system.file('supporting_files/buffers_land_cover.csv', 
-												package=packageName())
-		d = read.table(fname, header=TRUE, sep=',')
-		#100 urban
-		#110 ag
-		#150 grassland
-		#160 forest 
-		#200 open water
-		#210 wetland
-		lc_types = data.frame(majority_cover=c(200, 160,  100, 150,  110, 210),
-													height=        c(0.5, 11.5, 0.5, 0.65, 0.8, 0.5))
-
-		vals = merge(data.frame(site_id, order=1:length(site_id)),
-								 d, by='site_id', all.x=TRUE)
-
-		heights = merge(vals, lc_types, all.x=TRUE, by='majority_cover')
-
-		#merge does not preserve order, re-order before returning
-		heights = heights[order(heights$order),]
-
-		return(heights$height)
+		data(canopy)
+	  id = site_id
+		d = subset(canopy, `site_id` == id & source == 'nlcd')
+		if(nrow(d) < 1){
+		  return(NA)
+		}
+		return(d$canopy_m)
 
 	}else{
 		stop('Unidentified method ', method, ' for getCanopy [aster, landcover]')
@@ -494,9 +479,9 @@ getCD	<-	function(site_id=NULL, Wstr=NULL, method='Hondzo'){
 #'
 #'
 #'@export
-getWstr	<-	function(WBIC, method='Markfort', canopy=NULL){
+getWstr	<-	function(site_id, method='Markfort', canopy=NULL){
 
-	lkeArea	<-	get_area(WBIC)
+	lkeArea	<-	get_area(site_id)
 
   if(is.na(lkeArea)){
     return(NA)
@@ -506,7 +491,7 @@ getWstr	<-	function(WBIC, method='Markfort', canopy=NULL){
 		# Markfort et al. 2010
 		minWstr	<-	0.0001
 		if (is.null(canopy)){
-			hc	<-	max(c(getCanopy(WBIC),1))
+			hc	<-	max(c(getCanopy(site_id),1))
 		} else {
 			hc	<-	canopy
 		}
@@ -530,14 +515,14 @@ getWstr	<-	function(WBIC, method='Markfort', canopy=NULL){
 		# Markfort et al. 2010
 		minWstr	<-	0.0001
 		if (is.null(canopy)){
-			hc	<-	max(c(getCanopy(WBIC),1))
+			hc	<-	max(c(getCanopy(site_id),1))
 		} else {
 			hc	<-	canopy
 		}
 
 		Xt	<-	50*hc
 
-		perim	<-	getPerim(WBIC)
+		perim	<-	getPerim(site_id)
 		shelArea	<-	perim*hc*12.5 # 25% of Markfort, as sheltering is single direction...
 		shelter	<-	(lkeArea-shelArea)/lkeArea
 		wind.shelter	<-	max(c(shelter,minWstr))