Package contains several functions that retrieve, filter, and store NOAA data in a local/remote Postgres database. One useful function is that that takes weather station location in a region and constructs a Voronoi tessellation over that region (you will need a GIS software to visualize the output which is a set of geometries/polygones). Another useful function within the package is that that iteratively request several years of data from the NOAA digital warehouse. Since NOAA permits only one year of data requested at a time, via the rnoaa package. It is particular useful when many years of information are needed.
Problems:
Some system libraries are needed before you can start using the ws2pgdb. Some of the methods necesitate the octave development tools, gdal, proj (octave-dev, liboctave, libgdal, libproj-dev). Try to install the ws2pgdb and the installer will let you know when a library is needed. This maybe a slow process but if you are using any debian-like, you can make used of the package manager to install them (apt-get).
During a fresh installation, after a couple of months without touching this libraries, I tried devtools::install_github(rabravo/ws2pgdb) and it complained that some of the dependencies were not compatible. To install these dependencies you shall do as in the following example:
devtools::install_github("rstats-db/RPostgres")
or
sudo su - -c "R -e \"install.packages('packagename', repos='http://cran.rstudio.com/')\""
CENSUS DATA
Function in this bundle request information from your local database. The database is assumed to contain U.S. Census data. The data is the cartographic boundary files a.k.a TIGER files in SHAPEFILE format. In the past I used QGIS to upload this files into my Geographic-enable Postgres database but these shapefiles can very well be uploaded via command line using psql and shp2psql script.
The data is available in the following website. https://www.census.gov/geo/maps-data/data/cbf/cbf_counties.html
For my dissertation, the TIGER files from the year 2013 were used: nation, state, county. In the future, I will add a variable so that the functions in the libraries can make use of any available year. Since the convention for file naming varies only the year of file for the corresponding new data set.
The following function enables the communication between the vector-borne simulator and the pgsql ( database ).
Copy, paste, and execute these queries on the pgsql server.
```
CREATE TYPE all_coor_ws_type AS (id text ,lon text ,lat text );
CREATE TYPE r_voronoi_type AS (id integer, polygon geometry);
CREATE OR REPLACE FUNCTION public.r_all_coor_ws(text, text, text) RETURNS SETOF all_coor_ws_type AS $BODY$
ghcnd <- arg1 geoid <- arg2 type <- arg3
ws <- ws2pgdb::all_coor_ws( ghcnd, geoid, type) return(ws[,c("id","longitude","latitude")]) $BODY$ LANGUAGE plr;
--This function below here is not properly working; fix this or remove soon.
CREATE OR REPLACE FUNCTION public.r_column_names(text, text, text, text) RETURNS SETOF text AS $BODY$
geoid <- as.character(arg1) span <- as.character(arg2) disease<- arg3 num <- as.integer(arg4)
file <- base::paste(Sys.getenv("HOME"), "/", "pg_config.yml", sep = "") config <- yaml::yaml.load_file(file)
drv <- RPostgres::Postgres() conn <- RPostgres::dbConnect( drv, host = config$dbhost, port = config$dbport, dbname = config$dbname, user = config$dbuser, password = config$dbpwd )
res <- RPostgres::dbSendQuery(conn, sprintf("SELECT r_table_prefix('%1$s')", geoid)) prefix <- base::as.character(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res)
t1 <- base::paste(prefix, "ws_data_span_", span, "avg_tmax", sep = "") t2 <- base::paste(prefix, "ws_data_span", span, "avg_tmax", disease, sep = "")
res <- RPostgres::dbSendQuery( conn, sprintf( "SELECT g.column_name FROM ( SELECT column_name, data_type FROM information_schema.columns WHERE table_name = '%1$s' ) as g", t1 ) ) wsName <- base::data.frame(RPostgres::dbFetch(res)) wsName <- wsName[2:length(wsName[,1]),] RPostgres::dbClearResult(res)
res <- RPostgres::dbSendQuery( conn, sprintf( "SELECT g.column_name FROM ( SELECT column_name, data_type FROM information_schema.columns WHERE table_name = '%1$s' ) as g", t2 ) )
wsModel <- base::data.frame(RPostgres::dbFetch(res)) wsTempAndModel <- data.frame(c(wsName[num], wsModel[num])) RPostgres::dbClearResult(res)
return(wsTempAndModel)
$BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_county_centroid(text, text) RETURNS SETOF double precision AS $BODY$
file <- base::paste(Sys.getenv("HOME"), "/", "pg_config.yml", sep = "") config <- yaml::yaml.load_file( file )
geoid <- arg1
pos <- arg2
driver <- "PostgreSQL" drv <- RPostgres::Postgres() conn <- RPostgres::dbConnect( drv, host = config$dbhost, port = config$dbport, dbname = config$dbname, user = config$dbuser, password = config$dbpwd )
if ( pos == 'lat') { q1 <- base::paste("SELECT ST_Y( ( ST_DumpPoints( ( g.geom ).geom ) ).geom ) as lat FROM ( SELECT ST_Dump( ST_CollectionHomogenize( geom ) ) as geom FROM cb_2013_us_county_20m WHERE geoid = '", geoid ,"') AS g", sep="") res <-RPostgres::dbSendQuery(conn, q1) coord <- data.frame(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res) } if ( pos == 'lon') { q1 <- base::paste("SELECT ST_X( ( ST_DumpPoints( ( g.geom ).geom ) ).geom ) as lon FROM ( SELECT ST_Dump( ST_CollectionHomogenize( geom ) ) as geom FROM cb_2013_us_county_20m WHERE geoid = '", geoid ,"') AS g", sep="") res <-RPostgres::dbSendQuery(conn, q1) coord <- data.frame(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res) } RPostgres::dbDisconnect(conn)
return(coord)
$BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_create_canopi_voronoi(text, text) RETURNS text AS $BODY$
geoid <- arg1
tableName <- arg2
return(ws2pgdb::canopiVoronoi(tableName, geoid))
$BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_create_county_info(text, text, text) RETURNS text AS $BODY$ #i.e. SELECT r_create_county_info('12087', 'TMAX', '10') geoid <- arg1 type <- arg2 span <- arg3 ghcnd <- 'GHCND'
pgfile <- base::paste(Sys.getenv("PWD"), "/", "pg_config.yml", sep = "") config <- yaml::yaml.load_file(pgfile) drv <- RPostgres::Postgres()
conn <- RPostgres::dbConnect( drv, host = config$dbhost, port = config$dbport, dbname = config$dbname, user = config$dbuser, password = config$dbpwd )
stations <- ws2pgdb::all_coor_ws( ghcnd, geoid, type) ws_metadata <- ws2pgdb::ws_metadata_span_2_pgdb( geoid, type, stations, span )
res <- RPostgres::dbSendQuery(conn, sprintf("SELECT r_create_tiger_tracts_table('%1$s')", geoid)) tigertableName <- as.character(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res)
if ( identical(all.equal(tigertableName, ""), TRUE) ) { RPostgres::dbDisconnect(conn) return(tigertableName) }
table_cluster <- base::paste( tigertableName, "_clustered_by_nearest_ws", sep = "")
# tractce) Build the distance matrix from a centroid in a subregion to all weather stations # geoid: tract geoid; path2Hub: text form of geom; # geom As poly: tract polygone # geom: line between the a) a tract centroid, b) a weather station; # dist: length of the geometry # name: name of weather station
res <- RPostgres::dbSendQuery(conn, sprintf("SELECT r_create_midas_synth_hh_table('%1$s')", geoid)) midastableName <- as.character(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res)
temp <- tigertableName midas_pop <- base::gsub("tiger_tracts", "midas_pop", temp) midas_pop_clustered_by_nearest_ws <- base::paste(midas_pop, "_clustered_by_nearest_ws", sep = "")
res <- RPostgres::dbSendQuery(conn, sprintf("SELECT r_table_exists('%1$s')", table_cluster)) midasExist <- as.integer(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res)
q1 <- base::paste("\ with\ tractce As(\ SELECT tract.geoid10 as geoid, tract.the_geom as geom, ST_MakeLine(ST_Centroid( tract.the_geom ), coord.geom ) as geomLine, ST_Length( ST_MakeLine(ST_Centroid( tract.the_geom ), coord.geom ) ) as dist, coord.name, ST_Centroid( tract.the_geom ) as centroid FROM ", tigertableName, " tract, ", ws_metadata, " coord\ ), \ geoidDistance As(\ SELECT geoid, min( dist ) as min_dist FROM tractce GROUP BY geoid\ ),\ line2Hub As(\ SELECT tractce.geoid, tractce.geom as poly, ST_AsText(tractce.geomLine), tractce.centroid, name, min_dist FROM tractce, geoidDistance WHERE geoidDistance.min_dist = dist ORDER BY tractce.name \ ),\ cluster_ws As(\ SELECT name, ST_MULTI( ST_UNION(poly) ) FROM line2Hub GROUP BY name\ )\ SELECT * INTO ", table_cluster, " FROM cluster_ws ", sep = "")
if ( midasExist ) { print("Exists!"); } else { res <- RPostgres::dbSendQuery(conn, q1) q1_out <- as.integer(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res) }
res <- RPostgres::dbSendQuery(conn, sprintf("SELECT r_table_exists('%1$s')", midas_pop_clustered_by_nearest_ws)) midasClusterExist <- as.integer(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res)
q2 <- base::paste("
with\
tractce As(\
SELECT ogc_fid as ws_id, tract.geoid10 as geoid, tract.the_geom as geom, ST_MakeLine(ST_Centroid( tract.the_geom), coord.geom ) as geomLine, ST_Length( ST_MakeLine(ST_Centroid( tract.the_geom), coord.geom ) ) as dist, coord.name, ST_Centroid( tract.the_geom ) as centroid FROM ", tigertableName, " tract, ", ws_metadata , " coord ORDER BY dist ASC\
),\
geoidDistance As(\
SELECT geoid, min( dist ) as dist FROM tractce GROUP BY geoid --ORDER BY dist\
),\
line2Hub As(\
SELECT DISTINCT ON (gd.geoid) ws_id, t.geomLine, t.geom as poly, t.name, gd.geoid, gd.dist FROM geoidDistance gd, tractce t WHERE gd.geoid = t.geoid AND abs(gd.dist - t.dist) < 0.0000001\
),\
ind_per_bg As(\
SELECT stcotrbg As geoid, SUM(hh_size) As hh FROM ", midastableName," GROUP BY stcotrbg ORDER BY stcotrbg\
),\
ind_per_tract As(\
SELECT substring( geoid for 11 ) As geoid, SUM(hh) As hh FROM ind_per_bg GROUP BY substring( geoid for 11) ORDER BY substring( geoid for 11)\
),
syn_pop As(\
SELECT ws_id, t.name, t.geoid, t.poly, midas.hh FROM ind_per_tract midas, line2Hub t WHERE midas.geoid = t.geoid\
),\
cluster_pop As(\
SELECT ws_id, name, sum(hh) as hh, ST_MULTI( ST_UNION(poly) ) as poly FROM syn_pop GROUP BY name, ws_id\
)\
SELECT * INTO ", midas_pop_clustered_by_nearest_ws, " FROM cluster_pop ORDER BY ws_id", sep = "")
if ( midasClusterExist ) { print("Exists!"); } else { res <- RPostgres::dbSendQuery(conn, q2) q2_out <- as.integer(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res) }# endIF/ELSE
ws2pgdb::ws_data_avg_span_2_pgdb( ghcnd, geoid, type, span, ws_metadata ) ws2pgdb::ws_data_na_span_2_pgdb( ghcnd, geoid, type, span, ws_metadata )
RPostgres::dbDisconnect(conn) return(midas_pop_clustered_by_nearest_ws)
$BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_create_midas_synth_hh_table(text) RETURNS text AS $BODY$
pwd <- base::Sys.getenv("PWD") geoid <- arg1
file <- base::paste(Sys.getenv("HOME"), "/", "pg_config.yml", sep = "") config <- yaml::yaml.load_file( file )
drv <- RPostgres::Postgres() conn <- RPostgres::dbConnect( drv, host = config$dbhost, port = config$dbport, dbname = config$dbname, user = config$dbuser, password = config$dbpwd )
res <- RPostgres::dbSendQuery( conn, sprintf("SELECT r_table_prefix('%1$s')", geoid) ) pre <- as.character(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res)
tableName <- paste(pre, "midas_synth_hh", sep = "") res <- RPostgres::dbSendQuery( conn, sprintf("SELECT r_table_exists('%1$s')", tableName) ) tableExist <- as.integer(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res)
if (tableExist) { RPostgres::dbDisconnect(conn) return(tableName) } else {
res <- RPostgres::dbSendQuery(conn, sprintf( "SELECT r_create_synth_hh_table_template('%1$s')", tableName ) )
debug <- as.character(RPostgres::dbFetch(res))
RPostgres::dbClearResult(res)
url <- "http://www.epimodels.org/10_Midas_Docs/SynthPop/2010/counties/"
file <- base::paste("2010_ver1_", geoid, sep = "")
pfile <- base::paste("/tmp/2010_ver1_", geoid, sep = "")
zipFile <- base::paste(pfile, ".zip", sep = "")
download <- base::paste(url, file, ".zip", sep = "")
err <- try( utils::download.file(download, zipFile, "wget", quiet = TRUE))
if ( class(err) == "try-error" ) {
RPostgres::dbClearResult(res)
RPostgres::dbDisconnect(conn)
return("")
}# endIF
extractedFile <- base::paste(file, "_synth_households.txt", sep = "")
utils::unzip(paste(pfile, ".zip", sep = ""), file = extractedFile, exdir = "/tmp")
input <- utils::read.csv( file = base::paste("/tmp/", extractedFile, sep = ""), head = TRUE, sep = ",")
out <- input[c("stcotrbg", "hh_race", "hh_income","hh_size", "hh_age", "longitude", "latitude")]
updatedFile <- base::paste(pfile, "_synth_hh.csv", sep = "")
utils::write.csv(out, file = updatedFile, row.names = FALSE)
res <- RPostgres::dbSendQuery(conn, sprintf( "COPY \"%1$s\" FROM '%2$s' DELIMITER ',' CSV HEADER;", tableName, updatedFile))
RPostgres::dbClearResult(res)
q5 <- paste("rm ", zipFile, " ", updatedFile, " /tmp/", extractedFile, sep = "")
system(q5)
return(tableName)
}# endIF/ELSE
$BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_create_synth_hh_table_template(arg1 text) RETURNS text AS $BODY$ DECLARE c INT; BEGIN EXECUTE 'CREATE TABLE "' || arg1 ||'" (stcotrbg CHAR(14), hh_race SMALLINT, hh_income DOUBLE PRECISION, hh_size SMALLINT, hh_age SMALLINT, latitude DOUBLE PRECISION, longitude DOUBLE PRECISION );'; RETURN arg1; END; $BODY$ LANGUAGE plpgsql;
CREATE OR REPLACE FUNCTION public.r_create_table(var text) RETURNS integer AS $BODY$ DECLARE c INT; BEGIN EXECUTE 'CREATE TABLE "' || var ||'" (stcotrbg CHAR(14), hh_race SMALLINT, hh_income DOUBLE PRECISION, hh_size SMALLINT, hh_age SMALLINT, latitude DOUBLE PRECISION, longitude DOUBLE PRECISION );'; RETURN 0; EXCEPTION WHEN SQLSTATE '42P07' THEN RETURN 1; END;
$BODY$ LANGUAGE plpgsql;
CREATE OR REPLACE FUNCTION public.r_create_tiger_tracts_table(text) RETURNS text AS $BODY$
pgfile <- base::paste(Sys.getenv("PWD"), "/", "pg_config.yml", sep = "") print(pgfile) pwd <- base::Sys.getenv("PWD") print(pwd) config <- yaml::yaml.load_file( pgfile ) geoid <- arg1
# To override auth, provide your passwd via the .pgpass (see postgresql documentation) drv <- RPostgres::Postgres() conn <- RPostgres::dbConnect( drv, host = config$dbhost, port = config$dbport, dbname = config$dbname, user = config$dbuser, password = config$dbpwd )
res <- RPostgres::dbSendQuery(conn, sprintf("SELECT r_table_prefix('%1$s')", geoid)) prefix <- base::as.character(RPostgres::dbFetch(res)) pretableName <- base::paste(prefix, "tiger_tracts", sep = "") RPostgres::dbClearResult(res)
res <- RPostgres::dbSendQuery(conn, sprintf("SELECT r_table_exists('%1$s')", pretableName) ) tableExist <- base::as.integer( RPostgres::dbFetch(res) ) RPostgres::dbClearResult(res)
if ( tableExist ) { return(pretableName) } else {
res <- RPostgres::dbSendQuery(conn, sprintf("SELECT r_fips_2_state('%1$s')", geoid) )
state <- base::as.character(RPostgres::dbFetch(res))
RPostgres::dbClearResult(res)
state <- gsub(" ", "_", state)
ftp <- "ftp://ftp2.census.gov/geo/pvs/tiger2010st/"
url <- base::paste(ftp, substr(geoid, 1, 2), "_", state, "/", geoid, "/", sep = "")
file <- base::paste("tl_2010_", geoid, "_tract10", sep = "")
tableName <- base::paste(file, sep = "")
ext <- ".zip"
pfile <- base::paste("/tmp/", file, sep = "")
download <- base::paste(url, file, ext, sep="")
zipFile <- base::paste("/tmp/", file, ext, sep = "")
err <- try( utils::download.file(download, zipFile, "wget", quiet = TRUE, extra = getOption(" --user=Anonymous --password=guest ")))
if (class(err) == "try-error" ) {
RPostgres::dbClearResult(res)
RPostgres::dbDisconnect(conn)
return("")
}
dir <- base::paste("/tmp", sep = "")
utils::unzip(zipFile, overwrite = 'TRUE', exdir = dir)
scriptFile <- base::paste(file, ".sql", sep = "")
sqlscriptPath <- base::paste("/tmp/", scriptFile, sep = "")
q5 <- base::paste("shp2pgsql -c -s 4269 -g the_geom -W latin1 /tmp/", file, ".shp", " public.", pretableName, " " ,config$dbname," > ", sqlscriptPath, sep = "")
result <- system(q5)
q6 <- base::paste("set PGPASSWORD=config$dbpwd & psql ",
" -d ", config$dbname,
" -U ", config$dbuser,
" -p ", config$dbport,
" -q --file='", sqlscriptPath, "'",
sep = ""
)
system(q6)
q7 <- paste("rm /tmp/tl_2010*.???", sep = "")
system(q7)
return(pretableName)
}
$BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_gen_data_avg_span_2_pgdb(text, text, text, text) RETURNS text AS $BODY$ # i.e. SELECT r_gen_data_avg_span_2_pgdb('GHCND','12087','TMAX','10') ghcnd <- arg1 geoid <- arg2 type <- arg3 stations <- as.data.frame( ws2pgdb::all_coor_ws( ghcnd, geoid, type) ) span <- arg4 ws_metadata <- ws2pgdb::ws_metadata_span_2_pgdb( geoid, type, stations, span ) ws_data <- ws2pgdb::ws_data_avg_span_2_pgdb( ghcnd, geoid, type, span, ws_metadata ) return(ws_data) $BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_gen_data_na_span_2_pgdb(text, text, text, text) RETURNS text AS $BODY$ # i.e. SELECT r_gen_data_na_span_2_pgdb('GHCND','12087','TMAX','10') ghcnd <- arg1 geoid <- arg2 type <- arg3 stations <- as.data.frame( ws2pgdb::all_coor_ws( ghcnd, geoid, type) ) span <- arg4 ws_metadata <- ws2pgdb::ws_metadata_span_2_pgdb( geoid, type, stations, span ) ws_data <- ws2pgdb::ws_data_na_span_2_pgdb( ghcnd, geoid, type, span, ws_metadata ) return(ws_data) $BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_gen_data_span_avg_2_pgdb(text, text, text, text) RETURNS text AS $BODY$ # i.e. SELECT r_gen_data_span_avg_2_pgdb('GHCND','12087','TMAX','10') ghcnd <- arg1 geoid <- arg2 type <- arg3 stations <- as.data.frame( ws2pgdb::all_coor_ws( ghcnd, geoid, type) ) span <- arg4 stations <- ws2pgdb::ws_metadata_span_2_pgdb( geoid, type, stations, span ) ws_metadata <- ws2pgdb::ws_data_span_avg_2_pgdb( ghcnd, geoid, type, span, ws_metadata ) return(ws_metadata) $BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_gen_data_span_na_2_pgdb(text, text, text, text) RETURNS text AS $BODY$ # i.e. SELECT r_gen_data_span_na_2_pgdb('GHCND','12087','TMAX','10') ghcnd <- arg1 geoid <- arg2 type <- arg3 stations <- as.data.frame( ws2pgdb::all_coor_ws( ghcnd, geoid, type) ) span <- arg4 stations <- ws2pgdb::ws_metadata_span_2_pgdb( geoid, type, stations, span ) ws_metadata <- ws2pgdb::ws_data_span_na_2_pgdb( ghcnd, geoid, type, span, ws_metadata ) return(ws_metadata) $BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_gen_model(text, text, text, text) RETURNS text AS $BODY$
library(RcppOctave) geoid <- arg1 type <- arg2 span <- arg3 disease <- arg4 return(ws2pgdb::stretch_delay_latent_period(geoid, type, span, disease))
$BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_get_octave_version() RETURNS text AS $BODY$ return(RcppOctave::.CallOctave('version')) $BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_get_population_size(text) RETURNS integer AS $BODY$
file <- base::paste(Sys.getenv("HOME"), "/", "pg_config.yml", sep = "") config <- yaml::yaml.load_file( file ) driver <- "PostgreSQL" drv <- RPostgres::Postgres() conn <- RPostgres::dbConnect( drv, host = config$dbhost, port = config$dbport, dbname = config$dbname, user = config$dbuser, password = config$dbpwd ) geoid <- arg1 q1 <- base::paste("SELECT r_table_prefix('",geoid,"')", sep = "") res <- RPostgres::dbSendQuery(conn, q1) nameTable <- data.frame(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res) midasTable <- base::paste(nameTable, "midas_pop_clustered_by_nearest_ws" , sep = "") q2 <- base::paste("SELECT r_table_exists('", midasTable, "')", sep = "") res <- RPostgres::dbSendQuery(conn, q2) exists <- as.integer(RPostgres::dbFetch(res))
if ( exists ) { q3 <- base::paste("SELECT SUM(hh) FROM ", midasTable, sep = "") res <- RPostgres::dbSendQuery(conn, q3) total <- data.frame(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res) } else { midasTable <- base::paste(nameTable, "midas_synth_hh", sep = "") q3 <- base::paste("SELECT SUM(hh_size) FROM ", midasTable, sep = "") res <- RPostgres::dbSendQuery(conn, q3) total <- data.frame(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res) }# endIF/ELSE RPostgres::dbDisconnect(conn) return(total)
$BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_get_pos(text, text) RETURNS SETOF double precision AS $BODY$
file <- base::paste(Sys.getenv("HOME"), "/", "pg_config.yml", sep = "") config <- yaml::yaml.load_file( file )
# geoid is the fips number. This function only accept fips for counties (5 digits) geoid <- arg1 pos <- arg2
# Weathe variable type <- 'TMAX' # Look-back in time span <- '3'
driver <- "PostgreSQL" drv <- RPostgres::Postgres() conn <- RPostgres::dbConnect( drv, host = config$dbhost, port = config$dbport, dbname = config$dbname, user = config$dbuser, password = config$dbpwd )
if ( pos == 'lat') { q1 <- base::paste("SELECT r_table_prefix('", geoid, "')", sep = "") res <-RPostgres::dbSendQuery(conn, q1) tableName <- data.frame(RPostgres::dbFetch(res)) type <- tolower(type) tableName <- paste(tableName, "ws_metadata_span_", span, "_", type, sep = "") RPostgres::dbClearResult(res)
q2 <- base::paste("SELECT ST_Y(lat.geom) FROM ", tableName, " as lat", sep = "")
res <-RPostgres::dbSendQuery(conn, q2)
coord <- data.frame(RPostgres::dbFetch(res))
RPostgres::dbClearResult(res)
}# endIF if ( pos == 'lon') { q1 <- base::paste("SELECT r_table_prefix('", geoid, "')", sep = "") res <-RPostgres::dbSendQuery(conn, q1) tableName <- data.frame(RPostgres::dbFetch(res)) type <- tolower(type) tableName <- paste(tableName, "ws_metadata_span_", span, "_", type, sep = "") RPostgres::dbClearResult(res) q2 <- base::paste("SELECT ST_X(lon.geom) FROM ", tableName, " as lon", sep = "") res <-RPostgres::dbSendQuery(conn, q2) coord <- data.frame(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res) }# endIF RPostgres::dbDisconnect(conn) return(coord)
$BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_get_r_version() RETURNS text AS $BODY$
return(getRversion())
$BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_get_tract_size(text, text) RETURNS integer AS $BODY$
file <- base::paste(Sys.getenv("HOME"), "/", "pg_config.yml", sep = "") config <- yaml::yaml.load_file( file ) driver <- "PostgreSQL" drv <- RPostgres::Postgres() conn <- RPostgres::dbConnect( drv, host = config$dbhost, port = config$dbport, dbname = config$dbname, user = config$dbuser, password = config$dbpwd ) geoid <- as.character(arg1) wsNum <- as.integer(arg2) if (wsNum == 0) { return(0) }# endIF q1 <- base::paste("SELECT r_table_prefix('", geoid, "')", sep = "") res <- RPostgres::dbSendQuery(conn, q1) nameTable <- data.frame(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res) midasTable <- base::paste(nameTable, "midas_pop_clustered_by_nearest_ws ", sep = "") q2 <- base::paste("SELECT r_table_exists('", midasTable, "')", sep = "") res <- RPostgres::dbSendQuery(conn, q2) exists <- as.integer(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res)
if ( exists ) { # Fail badly if table entry does not exist wsNum <- wsNum - 1 str1 <- base::paste("SELECT ws_id FROM ", midasTable, " LIMIT 1 OFFSET ", wsNum, sep = "") res <- RPostgres::dbSendQuery(conn,str1) rowNum <- data.frame(RPostgres::dbFetch(res)) q3 <- base::paste("SELECT hh FROM ", midasTable, "WHERE ws_id = ", rowNum, sep = "") res <- RPostgres::dbSendQuery(conn, q3) total <- data.frame(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res) } else { total <- 0 }# endIF/ELSE RPostgres::dbDisconnect(conn) return(total)
$BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_model_colname(text, text, text, text) RETURNS SETOF text AS $BODY$
geoid <- as.character(arg1) span <- as.character(arg2) disease<- arg3 wsNum <- as.integer(arg4) file <- base::paste(Sys.getenv("HOME"), "/", "pg_config.yml", sep = "") config <- yaml::yaml.load_file( file ) driver <- "PostgreSQL" drv <- RPostgres::Postgres() conn <- RPostgres::dbConnect( drv, host = config$dbhost, port = config$dbport, dbname = config$dbname, user = config$dbuser, password = config$dbpwd ) res <- RPostgres::dbSendQuery(conn, sprintf("SELECT r_table_prefix('%1$s')", geoid)) prefix <- base::as.character(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res) t1 <- base::paste(prefix,"ws_data_span_",span,"avg_tmax",disease,sep="")
res <- RPostgres::dbSendQuery(conn, sprintf("SELECT g.column_name FROM ( SELECT column_name, data_type FROM information_schema.columns WHERE table_name = '%1$s' ) as g", t1)) wsModel <- base::data.frame(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res) wsModel <- wsModel[1:length(wsModel[,1]),] ws <- base::paste("\"", wsModel[wsNum], "\"", sep = "") return(ws)
$BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_model_values(text, text, text, text, text) RETURNS SETOF text AS $BODY$ # i.e. SELECT r_model_values('12087','10','dengue','4','TMAX') # i.e. SELECT r_model_values('48061','10','malaria','4','TMIN')
geoid <- base::as.character(arg1) span <- base::as.character(arg2) disease<- base::as.character(arg3) wsNum <- base::as.integer(arg4) type <- base::as.character(arg5) type <- base::tolower(type) file <- base::paste(Sys.getenv("HOME"), "/", "pg_config.yml", sep = "") config <- yaml::yaml.load_file( file ) driver <- "PostgreSQL" drv <- RPostgres::Postgres() conn <- RPostgres::dbConnect( drv, host = config$dbhost, port = config$dbport, dbname = config$dbname, user = config$dbuser, password = config$dbpwd )
res <- RPostgres::dbSendQuery(conn, sprintf("SELECT r_table_prefix('%1$s')", geoid)) prefix <- base::as.character(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res) t1 <- base::paste(prefix, "ws_data_span_", span, "avg", type, "_", disease, sep = "")
res <- RPostgres::dbSendQuery(conn, sprintf("SELECT g.column_name FROM ( SELECT column_name, data_type FROM information_schema.columns WHERE table_name = '%1$s' ) as g", t1)) wsModel <- base::data.frame(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res) wsModel <- wsModel[1:length(wsModel[,1]),] ws <- base::paste("\"", wsModel[wsNum], "\"", sep = "") res <- RPostgres::dbSendQuery(conn, sprintf("SELECT %1$s FROM %2$s", ws, t1) ) wsValue <- base::data.frame(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res) return(wsValue)
$BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_name_2_fips(text, text) RETURNS text AS $BODY$
# First arguments needs the Official name that is it has to include Capitalization # Second arguments can take the value of 'st' for state, or 'co' for county # Return one or more fips # i.e. SELECT r_name_2_fips('Monroe', 'co')
file <- base::paste(Sys.getenv("HOME"), "/", "pg_config.yml", sep = "") config <- yaml::yaml.load_file( file ) name <- arg1 key <- arg2 drv <- RPostgres::Postgres() conn <- RPostgres::dbConnect( drv, host = config$dbhost, port = config$dbport, dbname = config$dbname, user = config$dbuser, password = config$dbpwd ) if ( key == 'st') { q1 <- base::paste("select GEOID from cb_2013_us_state_20m where NAME = '", name, "'", sep = "") res <- RPostgres::dbSendQuery(conn, q1) nom <- RPostgres::dbFetch(res) RPostgres::dbClearResult(res) }# endIF
if ( key == 'co') { q1 <- base::paste("select GEOID from cb_2013_us_county_20m where NAME = '", name, "'", sep = "") res <-RPostgres::dbSendQuery(conn, q1) nom <- RPostgres::dbFetch(res) RPostgres::dbClearResult(res) }# endIF return(nom)
$BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_fips_2_state(text) RETURNS text AS $BODY$
# i.e. SELECT r_fips_2_state('12') or SELECT r_fips_2_state('12087') # out: 'Florida'
file <- base::paste(Sys.getenv("HOME"), "/", "pg_config.yml", sep = "") config <- yaml::yaml.load_file( file ) geoid <- arg1 drv <- RPostgres::Postgres() conn <- RPostgres::dbConnect( drv, host = config$dbhost, port = config$dbport, dbname = config$dbname, user = config$dbuser, password = config$dbpwd ) res <- RPostgres::dbSendQuery(conn, sprintf("select NAME from cb_2013_us_state_20m where GEOID='%1$s'", substr(geoid, 1, 2) ) ) nom <- RPostgres::dbFetch(res) RPostgres::dbClearResult(res) return(nom)
$BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_read_population_size(text) RETURNS integer AS $BODY$
file <- base::paste(Sys.getenv("HOME"), "/", "pg_config.yml", sep = "") config <- yaml::yaml.load_file( file ) drv <- RPostgres::Postgres() conn <- RPostgres::dbConnect( drv, host = config$dbhost, port = config$dbport, dbname = config$dbname, user = config$dbuser, password = config$dbpwd ) geoid <- arg1 q1 <- base::paste("SELECT r_table_prefix('", geoid, "')", sep = "") res <- RPostgres::dbSendQuery(conn, q1) nameTable <- data.frame(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res)
midasTable <- base::paste(nameTable, "midas_pop_clustered_by_nearest_ws", sep = "") q2 <- base::paste("SELECT r_table_exists('", midasTable, "')", sep = "") res <- RPostgres::dbSendQuery(conn, q2) exists <- as.integer(RPostgres::dbFetch(res))
if ( exists ) { q3 <- base::paste("SELECT SUM(hh) FROM ", midasTable, sep = "") res <- RPostgres::dbSendQuery(conn, q3) total <- data.frame(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res) } else { midasTable <- base::paste(nameTable, "midas_synth_hh", sep = "") q3 <- base::paste("SELECT SUM(hh_size) FROM ", midasTable, sep = "") res <- RPostgres::dbSendQuery(conn, q3) total <- data.frame(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res) # return(base::paste(midasTable, " does not exists , sep = "") ) } RPostgres::dbDisconnect(conn) return(total)
$BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_read_ws(text, text, text) RETURNS SETOF text AS $BODY$ # SELECT r_read_ws('12087', 'TMAX', '10') geoid <- arg1 type <- arg2 span <- arg3
file <- base::paste(Sys.getenv("HOME"), "/", "pg_config.yml", sep = "") config <- yaml::yaml.load_file( file ) driver <- "PostgreSQL" drv <- RPostgres::Postgres() conn <- RPostgres::dbConnect( drv, host = config$dbhost, port = config$dbport, dbname = config$dbname, user = config$dbuser, password = config$dbpwd ) res <- RPostgres::dbSendQuery(conn, sprintf("SELECT r_table_prefix('%1$s')", geoid) ) nameTable <- data.frame(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res) metainfoTable <- base::paste(nameTable, "ws_metadata_span_", span, "_", type, sep = "") res <- RPostgres::dbSendQuery(conn, sprintf("SELECT name FROM %1$s", metainfoTable) ) ws <- data.frame(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res) RPostgres::dbDisconnect(conn) return(ws)
$BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_table_exists(var text) RETURNS integer AS $BODY$ DECLARE c INT; BEGIN EXECUTE 'SELECT * FROM ' || var ||';'; RETURN 1; EXCEPTION WHEN SQLSTATE '42P01' THEN RETURN 0; END;
$BODY$ LANGUAGE plpgsql;
CREATE OR REPLACE FUNCTION public.r_table_prefix(text) RETURNS text AS $BODY$
# i.e. SELECT r_table_prefix('12087')
file <- base::paste(Sys.getenv("HOME"), "/", "pg_config.yml", sep = "") config <- yaml::yaml.load_file( file ) geoid <- arg1
drv <- RPostgres::Postgres() conn <- RPostgres::dbConnect( drv, host = config$dbhost, port = config$dbport, dbname = config$dbname, user = config$dbuser, password = config$dbpwd ) if (as.integer(geoid) < 100) { res <- RPostgres::dbSendQuery(conn, sprintf("select NAME from cb_2013_us_state_20m where GEOID='%1$s'", geoid)) state <- RPostgres::dbFetch(res) RPostgres::dbClearResult(res) tableName <- base::paste(state, "", geoid, "", sep = "") } else { res <- RPostgres::dbSendQuery(conn, sprintf("select NAME from cb_2013_us_county_20m where GEOID='%1$s'", geoid)) county<- RPostgres::dbFetch(res) RPostgres::dbClearResult(res) res <- RPostgres::dbSendQuery(conn, sprintf("select NAME from cb_2013_us_state_20m where GEOID='%1$s'", substr(geoid, 1, 2))) state <- RPostgres::dbFetch(res) RPostgres::dbClearResult(res) tableName <- base::paste(state, "", county, "", geoid, "_", sep = "") }# endIF/ELSE
varTable <- tolower( tableName ) tableName <- gsub(" ", "", varTable) tableName <- gsub("-", "", varTable) return(tableName)
$BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_typenames() RETURNS SETOF r_typename AS $BODY$ x <- ls(name = .GlobalEnv, pat = "OID") y <- vector() for (i in 1:length(x)) {y[i] <- eval(parse(text = x[i]))} data.frame(typename = x, typeoid = y)
$BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_version() RETURNS SETOF r_version_type AS $BODY$
cbind(names(version),unlist(version))
$BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_voronoi(text, text, text) RETURNS SETOF r_voronoi_type AS $BODY$ library(deldir) # select the point x/y coordinates into a data frame points <- pg.spi.exec( sprintf( "SELECT ST_X(%2$s) AS x, ST_Y(%2$s) AS y FROM %1$s;", arg1, arg2 ) ) # calculate an appropriate buffer distance (~10%): # Update: (~50%) for further operations with in POSTGRESQL buffer_distance = ( ( abs(max(points$x) - min(points$x)) + abs(max(points$y) - min(points$y)) ) / 2 ) * (0.50)
buffer_set <- pg.spi.exec( sprintf( "SELECT ST_Buffer(ST_Convexhull(ST_Union(%2$s)),%3$.6f) AS ewkb FROM %1$s;", arg1, arg2, buffer_distance ) ) # the following use of deldir uses high precision and digits to prevent # slivers between the output polygons, and uses a relatively large bounding # box with four dummy points included to ensure that points in the # peripheral areas of the dataset are appropriately enveloped by their # corresponding polygons: voro = deldir( points$x, points$y, digits=22, frac=0.00000000000000000000000001, list(ndx=2,ndy=2), rw=c( min( points$x ) - abs( min( points$x ) - max( points$x) ), max( points$x ) + abs( min( points$x ) - max( points$x) ), min( points$y ) - abs( min( points$y ) - max( points$y) ), max( points$y ) + abs( min( points$y ) - max( points$y) ) ) ) tiles = tile.list(voro) poly = array() id = array() p = 1
for (i in 1:length(tiles)) { tile = tiles[[i]] curpoly = "POLYGON((" for (j in 1:length(tile$x)) { curpoly = sprintf( "%s %.6f %.6f,", curpoly, tile$x[[j]], tile$y[[j]] ) } curpoly = sprintf( "%s %.6f %.6f))", curpoly, tile$x[[1]], tile$y[[1]] ) # this bit will find the original point that corresponds to the current # polygon, along with its id and the SRID used for the point geometry # (presumably this is the same for all points)...this will also filter # out the extra polygons created for the four dummy points, as they # will not return a result from this query: ipoint <- pg.spi.exec( sprintf( "SELECT %3$s AS id, st_intersection('SRID='||st_srid(%2$s)||';%4$s'::text,'%5$s') AS polygon FROM %1$s WHERE st_intersects(%2$s::text,'SRID='||st_srid(%2$s)||';%4$s');", arg1, arg2, arg3, curpoly, buffer_set$ewkb[1] ) ) if (length(ipoint) > 0) { poly[[p]] <- ipoint$polygon[1] id[[p]] <- ipoint$id[1] p = (p + 1) } } return(data.frame(id,poly)) $BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_voronoi_scale(text, text, text, double precision) RETURNS SETOF r_voronoi_type AS $BODY$ library(deldir)
points <- pg.spi.exec( sprintf( "SELECT ST_X(%2$s) AS x, ST_Y(%2$s) AS y FROM %1$s;", arg1, arg2 ) )
buffer_distance = ( ( abs(max(points$x) - min(points$x)) + abs(max(points$y) - min(points$y)) ) / 2 ) * (arg4)
buffer_set <- pg.spi.exec( sprintf( "SELECT ST_Buffer(ST_Convexhull(ST_Union(%2$s)),%3$.6f) AS ewkb FROM %1$s;", arg1, arg2, buffer_distance ) ) # the following use of deldir uses high precision and digits to prevent # slivers between the output polygons, and uses a relatively large bounding # box with four dummy points included to ensure that points in the # peripheral areas of the dataset are appropriately enveloped by their # corresponding polygons: voro = deldir( points$x, points$y, digits=22, frac=0.00000000000000000000000001, list(ndx=2,ndy=2), rw=c( min( points$x ) - abs( min( points$x ) - max( points$x) ), max( points$x ) + abs( min( points$x ) - max( points$x) ), min( points$y ) - abs( min( points$y ) - max( points$y) ), max( points$y ) + abs( min( points$y ) - max( points$y) ) ) ) tiles = tile.list(voro) poly = array() id = array() p = 1
for (i in 1:length(tiles)) { tile = tiles[[i]] curpoly = "POLYGON((" for (j in 1:length(tile$x)) { curpoly = sprintf( "%s %.6f %.6f,", curpoly, tile$x[[j]], tile$y[[j]] ) } curpoly = sprintf( "%s %.6f %.6f))", curpoly, tile$x[[1]], tile$y[[1]] )
ipoint <- pg.spi.exec( sprintf( "SELECT %3$s AS id, st_intersection('SRID='||st_srid(%2$s)||';%4$s'::text,'%5$s') AS polygon FROM %1$s WHERE st_intersects(%2$s::text,'SRID='||st_srid(%2$s)||';%4$s');", arg1, arg2, arg3, curpoly, buffer_set$ewkb[1] ) ) if (length(ipoint) > 0) { poly[[p]] <- ipoint$polygon[1] id[[p]] <- ipoint$id[1] p = (p + 1) } } return(data.frame(id,poly)) $BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_ws_colname(text, text, text, text) RETURNS SETOF text AS $BODY$ # i.e. SELECT r_ws_colname('12087','10','dengue','4') geoid <- as.character(arg1) span <- as.character(arg2) disease<- arg3 wsNum <- as.integer(arg4)
file <- base::paste(Sys.getenv("HOME"), "/", "pg_config.yml", sep = "") config <- yaml::yaml.load_file( file ) drv <- RPostgres::Postgres() conn <- RPostgres::dbConnect( drv, host = config$dbhost, port = config$dbport, dbname = config$dbname, user = config$dbuser, password = config$dbpwd )
res <- RPostgres::dbSendQuery(conn, sprintf("SELECT r_table_prefix('%1$s')", geoid) ) prefix <- base::as.character(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res)
t1 <- base::paste(prefix, "ws_data_span_", span, "_avg_tmax", sep = "")
res <- RPostgres::dbSendQuery(conn, sprintf("SELECT g.column_name FROM ( SELECT column_name, data_type FROM information_schema.columns WHERE table_name = '%1$s' ) as g", t1) ) wsName <- base::data.frame(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res)
wsName <- wsName[2:length(wsName[,1]),] ws <- base::paste("\"",wsName[wsNum],"\"",sep="") return(ws) $BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_ws_values(text, text, text, text) RETURNS SETOF text AS $BODY$ # i.e. SELECT r_ws_values('12087','10','TMAX','4') # Just in case DROP FUNCTION r_ws_values(text,text,text,text) CASCADE
geoid <- as.character(arg1) span <- as.character(arg2) type <- as.character(arg3) type <- tolower(type) wsNum <- as.integer(arg4)
file <- base::paste(Sys.getenv("HOME"), "/", "pg_config.yml", sep = "") config <- yaml::yaml.load_file( file ) drv <- RPostgres::Postgres() conn <- RPostgres::dbConnect( drv, host = config$dbhost, port = config$dbport, dbname = config$dbname, user = config$dbuser, password = config$dbpwd ) res <- RPostgres::dbSendQuery( conn, sprintf("SELECT r_table_prefix('%1$s')", geoid) ) prefix <- as.character(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res) t1 <- base::paste(prefix,"ws_data_span_",span,"avg",type,sep="")
res <- RPostgres::dbSendQuery( conn, sprintf("SELECT g.column_name FROM ( SELECT column_name, data_type FROM information_schema.columns WHERE table_name = '%1$s' ) as g", t1) )
wsName <- base::data.frame(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res) wsName <- wsName[2:length(wsName[,1]),] ws <- base::paste("\"", wsName[wsNum], "\"", sep = "") res <- RPostgres::dbSendQuery(conn, sprintf("SELECT %1$s FROM %2$s", ws, t1)) wsValue <- data.frame(RPostgres::dbFetch(res)) RPostgres::dbClearResult(res) RPostgres::dbDisconnect(conn) return(wsValue)
$BODY$ LANGUAGE plr;
CREATE OR REPLACE FUNCTION public.r_check_libpaths() RETURNS text AS $BODY$
return(.libPaths())
$BODY$ LANGUAGE plr;
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.