Nothing
# accessor functions for methods
.subsetSQLstring <- function(dbcon, subset = list() ) {
if(length(subset) == 0) sql = NULL else {
if(is.null(names(subset))) stop(sQuote('subset'), " must be a named list!")
m = subset[grep("^MAP_", names(subset))]
b = subset[grep("^BIO_", names(subset))]
r = subset[which(names(subset)=="metadata_ranges")]
msql = if(length(m) > 0) paste(paste("r.id in (SELECT id FROM", names(m), "WHERE", m, ")"), collapse = " AND ") else NULL
bsql = if(length(b) > 0) paste(paste("r.bioid in (SELECT",
sapply(names(b), function(x) .extract.indexed(dbcon, x)) ,
"FROM", names(b), "WHERE", b, ")"), collapse = " AND ") else NULL
rsql = if(length(r) > 0) paste(paste("r.bioid in (SELECT bioid FROM", names(r), "WHERE", r, ")"), collapse = " AND ") else NULL
sql = paste( c(msql, bsql, rsql), collapse = " AND ")
}
sql
}
setGeneric("rangeMapSave", function(object,FUN,formula, ...) standardGeneric("rangeMapSave") )
# method for species richness,
setMethod("rangeMapSave",
signature = c(object = "rangeMapSave", FUN = "missing", formula = "missing"),
definition = function(object, FUN, formula, ...){
if(length(object@tableName) == 0) object@tableName = "species_richness"
#build tableName
tableName = paste(object@MAP, object@tableName, sep = "")
# build sql subset
sset = .subsetSQLstring(object@CON, object@subset)
# build sql string
richnessSQL = paste("SELECT id, count(r.id) as", object@tableName ,"from ranges as r",
if(!is.null(sset)) paste("WHERE", sset), "group by r.id")
# build table and index
RMQuery(object@CON, paste("CREATE TABLE" ,tableName, "(", object@ID, "INTEGER,",object@tableName, "NUMERIC)"))
RMQuery(object@CON,paste("CREATE INDEX", paste(object@tableName, object@ID, sep = "_") ,"ON", tableName, "(id)") )
RMQuery(object@CON, paste("INSERT INTO" ,tableName, richnessSQL) )
return(.dbtable.exists(object@CON, tableName))
}
)
# agggregate method using sqlite
setMethod("rangeMapSave",
signature = c(object = "rangeMapSave", FUN = "character", formula = "missing"),
definition = function(object, FUN, formula, ...) {
# CHECKS
biotab = paste(object@BIO, object@biotab, sep = "")
if(!.dbtable.exists(object@CON,biotab) )
stop( paste(sQuote(object@biotab), "is not a table of", sQuote(dbGetInfo(object@CON)$dbname)))
# object@biotrait should exist as a field in biotab
if(!.dbfield.exists(object@CON,biotab, object@biotrait) )
stop(paste(sQuote(object@biotrait), "is not a field of", sQuote(object@biotab)))
# fun should be known by sqlite
.sqlAggregate(FUN)
# BIO_tab name
biotab = paste(object@BIO, object@biotab, sep = "")
#build MAP_ tableName
tableName = paste(object@MAP, object@tableName, sep = "")
# build sql subset
sset = .subsetSQLstring(object@CON, object@subset)
# build sql string
sql = paste("SELECT r.id, b.",object@biotrait,"FROM ranges r left join ",
biotab, " b WHERE r.bioid = b.", .extract.indexed(object@CON, biotab),
if(!is.null(sset)) paste("AND", sset) )
sql = paste("SELECT id,", FUN ,"(", object@biotrait, ") as", object@biotrait, "from (",sql,") group by id")
# build table and index
RMQuery(object@CON, paste("CREATE TABLE" ,tableName, "(", object@ID, "INTEGER,",object@biotrait, "NUMERIC)"))
RMQuery(object@CON, paste("CREATE INDEX", paste(tableName, "id", sep = "_") , "ON", tableName, "(id)") )
RMQuery(object@CON, paste("INSERT INTO" ,tableName, sql) )
return(.dbtable.exists(object@CON, tableName))
cat(strwrap(sql, width = 100))
}
)
.rangeMapSaveData <-function(object) {
# CHECKS
biotab = paste(object@BIO, object@biotab, sep = "")
if(!.dbtable.exists(object@CON,biotab) )
stop( paste(sQuote(object@biotab), "is not a table of", sQuote(dbGetInfo(object@CON)$dbname)))
# object@biotrait should exist as a field in biotab
if(!.dbfield.exists(object@CON,biotab, object@biotrait) )
stop(paste(sQuote(object@biotrait), "is not a field of", sQuote(object@biotab)))
# BIO_tab name
biotab = paste(object@BIO, object@biotab, sep = "")
# sql subset
sset = .subsetSQLstring(object@CON, object@subset)
# sql string
sql = paste("SELECT r.id, b.* FROM ranges r left join ",
biotab, " b WHERE r.bioid = b.", .extract.indexed(object@CON, biotab),
if(!is.null(sset)) paste("AND", sset) )
# fetch table
d = RMQuery(object@CON, sql)
if(nrow(d) == 0) {
stop( paste("The map is going to be empty! Maybe the bioid in", sQuote(object@biotab), " BIO table was wrongly set.") ) }
# return list
split(d, d[, object@ID])
}
# agggregate method using R functions called directly on the data
setMethod("rangeMapSave",
signature = c(object = "rangeMapSave", FUN = "function", formula = "missing"),
definition = function(object, FUN, formula, ...) {
# tableName
tableName = paste(object@MAP, object@tableName, sep = "")
# get data afer checking
dl = .rangeMapSaveData (object)
# apply R function
X = sapply(dl, FUN = function(x) FUN(x[, object@biotrait], ...) )
X = data.frame(id = names(X), X)
names(X) = c(object@ID, object@biotrait)
row.names(X) = NULL
# build table and index
RMQuery(object@CON, paste("CREATE TABLE" ,tableName, "(", object@ID, "INTEGER,",object@biotrait, "NUMERIC)"))
RMQuery(object@CON, paste("CREATE INDEX", paste(tableName, "id", sep = "_") , "ON", tableName, "(id)") )
dbWriteTable(object@CON, tableName, X, row.names = FALSE, append = TRUE)
return(.dbtable.exists(object@CON, tableName))
}
)
# agggregate method using R functions called directly using formula, data interface
setMethod("rangeMapSave",
signature = c(object = "rangeMapSave", FUN = "function", formula = "formula"),
definition = function(object, FUN, formula, ...) {
# tableName
tableName = paste(object@MAP, object@tableName, sep = "")
# get data afer checking
dl = .rangeMapSaveData (object)
# apply R function
X = sapply(dl, FUN = function(x) FUN(formula = formula, data = x, ...) )
X = data.frame(id = names(X), X)
names(X) = c(object@ID, object@biotrait)
row.names(X) = NULL
# build table and index
RMQuery(object@CON, paste("CREATE TABLE" ,tableName, "(", object@ID, "INTEGER,",object@biotrait, "NUMERIC)"))
RMQuery(object@CON, paste("CREATE INDEX", paste(tableName, "id", sep = "_") , "ON", tableName, "(id)") )
dbWriteTable(object@CON, tableName, X, row.names = FALSE, append = TRUE)
return(.dbtable.exists(object@CON, tableName))
}
)
# IMPORT RASTER
setGeneric("rangeMapImport", function(object,FUN, ...) standardGeneric("rangeMapImport") )
# method for importing external files
setMethod("rangeMapImport",
signature = c(object = "MapImport", FUN = "function"),
definition = function(object,FUN, ...) {
filenam = basename(object@path)
if(length(object@tableName)== 0) tableName = make.db.names.default(filenam)
tableName = paste(object@MAP, object@tableName, sep = "")
cnv = canvas.fetch(object@CON)
message("Converting canvas to polygons...")
cnv = rasterToPolygons(raster(cnv))
message("Loading external MAP data...")
rst = raster(object@path)
# is there any other way to compare CRS-s ?
if(!CRSargs(CRS(proj4string(cnv))) == CRSargs(projection(rst, FALSE)))
warning(sQuote(filenam), " may have a different PROJ4 string;\n", "canvas:", CRSargs(CRS(proj4string(cnv))), "\n", filenam, ":", CRSargs(projection(rst, FALSE)) )
rstp = as(as(rst, "SpatialGridDataFrame"), "SpatialPointsDataFrame")
message("Extracting Layer 1...")
rstp = rstp[which(!is.na(rstp@data[,1])), ]
rstp@data$ptid = as.numeric(rownames(rstp@data)) # add point id
message(paste("Performing overlay: canvas polygons over", filenam, "...") )
o = overlay(cnv, rstp) # #TODO change with over
o$ptid = as.numeric(rownames(o))
o = merge(o, rstp@data, by = "ptid")
o$ptid = NULL
message("Agregating data...")
o = aggregate(o[, 2], list(o[,1]), FUN = FUN, na.rm = TRUE, ...)
names(o) = c(object@ID, object@tableName)
# build table and index
message("Creating table and indexes...")
RMQuery(object@CON, paste("CREATE TABLE" ,tableName, "(", object@ID, "INTEGER,",object@tableName, "FLOAT)"))
RMQuery(object@CON, paste("CREATE INDEX", paste(tableName, "id", sep = "_") , "ON", tableName, "(id)") )
dbWriteTable(object@CON, tableName, o, row.names = FALSE, append = TRUE)
res = .dbtable.exists(object@CON, tableName)
if(res) message(paste(sQuote(basename(object@path)), "imported"))
return(res)
}
)
# user level function calling rangeMapSave
rangeMap.save <- function(CON, tableName, FUN, biotab, biotrait, subset = list(), path , overwrite = FALSE, ...) {
if(overwrite)
try(RMQuery(CON, paste("DROP TABLE", paste("MAP", tableName, sep = "_"))), silent = TRUE)
if(!missing(path)) { # external map
if(missing(tableName))
rmap = new("MapImport", CON = CON, path = path) else
rmap = new("MapImport", CON = CON, path = path, tableName = tableName)
rangeMapImport(rmap, FUN = FUN)
}
if(missing(FUN) ) { #species richness
if(missing(tableName))
rmap = new("rangeMapSave", CON = CON, subset = subset) else
rmap = new("rangeMapSave", CON = CON, tableName = tableName, subset = subset)
rangeMapSave(rmap)
}
if(!missing(FUN) & missing(path)) { # SQL or R function
rmap = new("rangeMapSave", CON = CON, biotab = biotab, biotrait = biotrait, tableName = tableName, subset = subset)
rangeMapSave(rmap, FUN = FUN, ...)
}
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.