Nothing
#' @export
setGeneric('formatPopulation',
function(popdata,
aggregate.by=NULL,
breaks=NULL, ...) {
standardGeneric("formatPopulation")
}
)
setMethod("formatPopulation",
signature("SpatVector"),
function(popdata, aggregate.by=NULL, breaks=NULL, ...) {
popdata = values(popdata)
methods::callGeneric()
}
)
# data is a raster. grid is ignored
setMethod("formatPopulation",
signature("data.frame"),
function(popdata, aggregate.by=NULL, breaks=NULL,...) {
ageBreaks = getBreaks(names(popdata), breaks)
####reshape the popdata:
poplong = stats::reshape(popdata, varying=ageBreaks$oldNames, direction="long",
v.names="POPULATION", timevar="GROUP", times = ageBreaks$newNames)
# create age and sex variables
agecol = grep("^age$", names(poplong), value=TRUE, ignore.case=TRUE)
sexcol = grep("^sex$", names(poplong), value=TRUE, ignore.case=TRUE)
if("GROUP" %in% names(poplong)) {
if(!length(sexcol)){
poplong$sex = factor(toupper(substr(poplong$GROUP, 1, 1)))
}
if(!length(agecol)){
ageNumeric = as.numeric(substr(poplong$GROUP, 3, 4))
poplong$age = cut(ageNumeric, ageBreaks$breaks, right=FALSE)
}else {
warning("no age and sex variables found or no group variable found in popdata")
}
}
row.names(poplong)<-NULL
if(length(aggregate.by)) {
aggregateByMatch = grep(
paste("^(", paste(aggregate.by, collapse='|'), ")$", sep=''),
names(poplong),
value=TRUE, ignore.case=TRUE)
poplong <- stats::aggregate(
poplong[,'POPULATION', drop=FALSE],
poplong[, aggregateByMatch, drop=FALSE],
sum, na.rm=TRUE)
}
if(length(sexcol)) poplong[,sexcol] <- toupper(poplong[,sexcol])
attributes(poplong)$breaks = ageBreaks
poplong
}
)
setMethod("formatPopulation",
signature("list"),
function(popdata, aggregate.by=NULL, breaks = NULL,
years=as.integer(names(popdata)), year.range=NULL, time="YEAR",
personYears=TRUE,...) {
time<-toupper(time)
#If aggregate, then see if YEAR is there or not, if so, remove it
if(!is.null(aggregate.by)){
# agg<-aggregate.by<-toupper(aggregate.by)
agg<-aggregate.by
byYear<- time %in% aggregate.by
if(byYear){aggregate.by<-aggregate.by[-which(aggregate.by==time)]}
}
listpop<-lapply(popdata,formatPopulation,aggregate.by, breaks= breaks)
breaks = attributes(listpop[[1]])$breaks
listdataframe<-lapply(listpop,as.data.frame)
#if did not aggregate, then the data frames will have differnt columns
pop<-NULL
for (i in 1:length(listdataframe)){
temp<-listdataframe[[i]]
temp[,time]<-years[i]
pop<-rbind(pop,temp)
}
attributes(pop)$breaks = breaks
if(personYears){
if (is.null(year.range)) {
year.range = range(pop[,time])
}
times <- c(year.range[1], sort(years), year.range[2])
times <- as.numeric(times)
inter <- diff(times)/2
nseq <- 1:length(inter) - 1
mseq <- 2:length(inter)
interval <- inter[mseq] + inter[nseq]
names(interval) <- names(table(pop[,time]))
pop$yearsForCensus = interval[as.character(pop[,time])]
pop$POPULATION = pop$POPULATION * pop$yearsForCensus
pop[,time] = factor(pop[,time], levels = unique(pop[,time]))
pop[,time] = factor(pop[,time])
pop <- pop[!is.na(pop$POPULATION), ]
pop <- pop[pop$POPULATION > 0, ]
}
pop
}
)
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.