#Allan Strand 12/03/02
#
#This function is intended to check and see if a landscape is of the correct form
#
#
is.landscape <- function(Rland=NULL,verb=TRUE,exact=FALSE,do.check=TRUE)
{
if (do.check)
{
ok<-TRUE;
if (!is.list(Rland))
{
if (verb) {print("Landscape not a list");}
ok<-FALSE;
}
if (is.null(Rland$intparam))
{
if (verb) {print("intparam not found.");}
ok<-FALSE;
} else if (sum(c(Rland$intparam$xdim,Rland$intparam$ydim)>0)>0) { #theres a landscape extent
if (sum(c(Rland$intparam$xdim,Rland$intparam$ydim)>0)<2)
{
if (verb) {
print(paste("there's a zero x or y dimension where the other is a number. xdim=",
Rland$intparam$xdim,"ydim=",Rland$intparam$ydim))
}
ok <- FALSE
}
if (prod(c(Rland$intparam$xdim,Rland$intparam$ydim))!=Rland$intparam$habitats)
{
if (verb) print("product of x and y dimensions does not equal habitat number")
ok <- FALSE
}
}
if (is.null(Rland$switchparam))
{
if (verb) {print("switchparam not found.");}
ok<-FALSE;
}
if (is.null(Rland$floatparam))
{
if (verb) {print("floatparam not found.");}
ok<-FALSE;
}
#check integer parameters
#check boolean parameters
#check float parameters
#check demography
if (is.null(Rland$demography))
{
if (verb) {print("demography not found.");}
ok<-FALSE;
}
else
{
#check if the matrices have the correct dimensions
for (i in 1:length(Rland$demo$localdem))
{
if
(
(
nrow(Rland$demo$localdem[[i]]$LocalS)!=c(Rland$intparam$stages) ||
nrow(Rland$demo$localdem[[i]]$LocalR)!=c(Rland$intparam$stages) ||
nrow(Rland$demo$localdem[[i]]$LocalM)!=c(Rland$intparam$stages)
)
)
{
if (verb) {
print("One or more of the local demography matrices is not of the correct dimensions")
print(paste("Rland$inparame$stages",Rland$intparam$stages))
}
ok <- FALSE
}
if (max(apply(Rland$demography$localdem[[i]]$LocalS,2,sum))>1)
{
if (verb) {print(paste("Local survival matrix",i,"has a column that sums to a number greater than one"))}
ok <- FALSE
}
}
for (i in 1:length(Rland$demo$epochs))
{
if (
(length(Rland$demo$epochs[[i]]$Extinct)!=Rland$intparam$habitats) ||
(length(Rland$demo$epochs[[i]]$Carry)!=Rland$intparam$habitats) ||
(length(Rland$demo$epochs[[i]]$Localprob)!=Rland$intparam$numdemos) ||
# (length(Rland$demo$epochs[[i]]$RndChooseProb)!=Rland$intparam$numepochs) ||
(min(dim(Rland$demo$epochs[[i]]$S)==c(Rland$intparam$stages*Rland$intparam$habitats,Rland$intparam$stages*Rland$intparam$habitats))==0) ||
(min(dim(Rland$demo$epochs[[i]]$R)==c(Rland$intparam$stages*Rland$intparam$habitats,Rland$intparam$stages*Rland$intparam$habitats))==0) ||
(min(dim(Rland$demo$epochs[[i]]$M)==c(Rland$intparam$stages*Rland$intparam$habitats,Rland$intparam$stages*Rland$intparam$habitats))==0)
)
{
if (verb) {print(paste("One or more of the epoch paramters is of incorrect dimension in epoch",i))}
ok <- FALSE
}
if (Rland$switchparam$randdemo==1||length(Rland$demography$localdem)==1)#still needs to check when more than one localdem and not random placement of demographies
{
for (j in 1:length(Rland$demography$localdem))
{
strt <- seq(1,dim(Rland$demo$epochs[[i]]$S)[1],dim(Rland$demography$localdem[[j]]$LocalS)[1])
stp <- strt+(dim(Rland$demography$localdem[[j]]$LocalS)[1]-1)
slice <- cbind(strt,stp)
# print(slice)
tmpS <- Rland$demography$epochs[[i]]$S
if (Rland$intparam$habitats!=1)
for (l in 1:Rland$intparam$habitats)
{
tmpS[c(slice[l,1]:slice[l,2]),c(slice[l,1]:slice[l,2])] <- Rland$demography$localdem[[j]]$LocalS
}
if (max(apply(tmpS,2,sum))>1)
{
if (verb) {
tcls <- which(apply(tmpS,2,sum)>1)
print(paste("Columns",paste(tcls,collapse=", ")," in the landscape S matrix associated with localdem",j,"total more than 1"))}
ok <- FALSE
}
}
}
}
}
#check loci
if (is.null(Rland$loci))
{
if (verb) {print("loci not found.");}
ok<-FALSE;
}
else
{
#first see if the number of loci match the number given in intparam
if (length(Rland$loci)!=Rland$intparam$locusnum)
{
if (verb) {print("conflict between size of loci object and size specified in $intparam");}
ok <- FALSE
}
## now check to make sure that there is an appropriate relationship between types and allele states
types <- do.call(rbind,lapply(Rland$loci,function(l){
states=unique(sapply(l$alleles,function(a){a$state}))
atyp = ifelse(sum(is.character(states))>0,"char","int")
data.frame(ltype=l$type,atyp=atyp)
}))
mismatch <- apply(types,1,
function(x){
res=FALSE
if ((x[2]=="char")&(as.character(x[1])!="253")) res <- TRUE
if ((x[2]!="char")&(!as.character(x[1]) %in% c("251","252"))) res <- TRUE
res
})
if (sum(mismatch)>0) {ok <- FALSE; if (verb) print("allele state types don't match the locus-level mutation model/type")}
}
#check individuals
if (is.null(Rland$individuals))
{
if (verb) {print("no individuals section found.");}
ok<-FALSE;
}
else
{
#check if popsize>0
if (!(dim(Rland$individuals)[1]>0))
{
if (verb) {print("No individuals in this landscape: spontaneous generation is notallowed")}
ok <- FALSE
}
#check if the max number of classes corresponds to the number in demography
if (max(Rland$individuals[,1])>((Rland$intparam$habitats*Rland$intparam$stages)-1))
{
if (verb) {print("There are individuals in stages other than demography allows")}
ok <- FALSE
}
#check if the number and ploidy of loci work out
if (dim(Rland$individuals)[2]!=(landscape.democol() + sum(landscape.ploidy(Rland))))
{
if (verb) {print("The number of loci do not correspond to the number of columns in $individuals\nThis indicates a problem with locus number and/or ploidy")}
ok <- FALSE
}
#check if birthdates are later than the current generation
if (max(Rland$individuals[,3])>Rland$intparam$currentgen)
{
if (verb) {print("There are individuals born in the future")}
ok <- FALSE
}
}
} else {ok <- TRUE}
return(ok)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.