speed improvements and bug fixes

R/landscape.ind.freq.R

@@ -1,35 +1,29 @@
 
-landscape.ind.freq <- function(Rland,include.states=TRUE)
-  {
-      l <- Rland
-      aml <- vector("list",length(landscape.ploidy(l)))
-      for (loc in 1:length(aml))
-      {
-          genos <- landscape.locus(l,loc)[,-1:-landscape.democol()]
-          ploidy <- landscape.ploidy(l)[loc]
-          if (l$loci[[loc]]$type!=253)
-          {
-              lst <- landscape.locus.states(l,loc)
-              names(lst$state) <- lst$aindex
-              if (ploidy==2)
-              {
-                  genos[,1] <- unname(lst$state[as.character(genos[,1])])
-                  genos[,2] <- unname(lst$state[as.character(genos[,2])])
-              } else {
-                  genos <- unname(lst$state[as.character(genos)])
-              }
-          }
-          amat <- sapply(names(table(genos)),function(x,genos,pl)
-          {
-              if (pl==2)
-              {
-                  (as.character(genos[,1])==as.character(x))+(as.character(genos[,2])==as.character(x))
-              } else
-              {
-                  as.character(genos)==as.character(x)
-              }
-          },genos=genos,pl=ploidy)
-          aml[[loc]] <- apply(amat,2,function(x,pl){x/pl},pl=ploidy) #allele freqs per ind
+landscape.ind.freq <- function(Rland,include.states=TRUE) {
+  l <- Rland
+  ploidy <- landscape.ploidy(l)
+  aml <- vector("list", length(ploidy))
+  for (loc in 1:length(aml)) {
+    genos <- landscape.locus(l, loc)[, -(1:landscape.democol())]
+    loc.ploidy <- ploidy[loc]
+    if (l$loci[[loc]]$type != 253) {
+      lst <- landscape.locus.states(l, loc)
+      names(lst$state) <- lst$aindex
+      if (loc.ploidy == 2) {
+        genos[, 1] <- unname(lst$state[as.character(genos[, 1])])
+        genos[, 2] <- unname(lst$state[as.character(genos[, 2])])
+      } else {
+        genos <- unname(lst$state[as.character(genos)])
       }
-      do.call(cbind,aml)
+    }
+    unique.genos <- sort(as.character(unique(as.vector(genos))))
+    aml[[loc]] <- sapply(unique.genos, function(x) {
+      if (loc.ploidy == 2) {
+        (as.character(genos[, 1]) == x) + (as.character(genos[, 2]) == x)
+      } else {
+        as.character(genos) == x
+      }
+    }) / loc.ploidy
   }
+  do.call(cbind, aml)
+}

R/landscape.make.genind.R

@@ -1,11 +1,15 @@
 #Create genind object from landscape
 #ignores the haploid loci
-landscape.make.genind <- function(Rland)
-  {
-      tab <- landscape.ind.freq(Rland)*2
-      dimnames(tab) <- list(rownames=1:dim(tab)[1],colnames=landscape.freq.locnames(Rland))
-      pl <- landscape.ploidy(Rland)
-      populations <- landscape.populations(Rland)
-      gi=genind(tab,pop=as.factor(populations),ploidy=2)
-      gi[,loc=which(pl>1)]
-  }
+landscape.make.genind <- function(Rland) {
+  tab <- landscape.ind.freq(Rland) * 2
+  dimnames(tab) <- list(
+    rownames = 1:dim(tab)[1],
+    colnames = landscape.freq.locnames(Rland)
+  )
+  gi <- adegenet::genind(
+    tab,
+    pop = as.factor(landscape.populations(Rland)),
+    ploidy = 2
+  )
+  gi[, loc = which(landscape.ploidy(Rland) > 1)]
+}

R/landscape.setallelefreq.R

@@ -14,30 +14,21 @@ landscape.setpopfreq <- function(rland,af=NULL,states=TRUE)
 {
     if (FALSE)
     {
-        af <- list('1'=list('1'=c('1'=0.5,'2'=0.25,'5'=0.25),   #population 1 locus 1 
+        af <- list('1'=list('1'=c('1'=0.5,'2'=0.25,'5'=0.25),   #population 1 locus 1
                             '2'=c('1'=0.5,'2'=0.25,'3'=0.25)),  #population 1 locus 2
                    '2'=list('1'=c('3'=0.5,'2'=0.35,'5'=0.15),   #population 2 locus 1
                             '2'=c('2'=0.25,'3'=0.75)))          ##population 2 locus 2
     }
     posspops <- sort(unique(landscape.populations(rland)))
-    s=rland$intparam$stages
-    h=rland$intparam$habitats
-    newaf <- NULL
-    for (p in names(af))
-    {
-        pnum <- as.numeric(p)
-        stages <- ((pnum-1)*s):((pnum-1)*s + (s) - 1)
-        a <- af[[p]]
-        newaf <- c(newaf,lapply(stages,function(s)
-        {
-            lst <- list(a)
-            names(lst) <- s
-            lst
-        })
-        )
-    }
-    newaf <- unlist(newaf,recursive=F)
-    landscape.setallelefreq(rland,newaf,states)
+    s = rland$intparam$stages
+    h = rland$intparam$habitats
+    newaf <- lapply(names(af), function(p) {
+      pnum <- as.numeric(p)
+      stages <- ((pnum - 1) * s):((pnum - 1) * s + s - 1)
+      lapply(stages, function(s) stats::setNames(list(af[[p]]), s))
+    })
+    newaf <- unlist(newaf, recursive = F)
+    landscape.setallelefreq(rland, newaf, states)
 }
 
 
@@ -60,45 +51,40 @@ landscape.setallelefreq <- function(rland,af=NULL,states=TRUE)
         af <- list('0'=list('1'=c('1'=0.5,'2'=0.25,'5'=0.25),'2'=c('1'=0.5,'2'=0.25,'3'=0.25)),
                    '2'=list('1'=c('1'=0.5,'2'=0.35,'5'=0.15),'2'=c('1'=0.10,'2'=0.15,'3'=0.75)))
     }
-
-    if (is.null(af))
-    {
-        print("specify at least some allele frequencies")
-    } else #there was an attempt to specify allelefreqs
-    {
-        locposition <- landscape.locusvec(rland) 
-        possLoc <- as.character(1:length(rland$loci))
-        possStgs <- as.character(0:((rland$intparam$habitats*rland$intparam$stages)-1))
-        ##check to see if stage names in af correspond to possStgs
-        if (length(which(!(names(af) %in% possStgs)))>0)
-        {
-            stop(paste("some stages in af do not exist in landscape"))
-        } else { #looks like we can truck through the stages
-            for (s in names(af)) #each s is a stage
-            {
-                inds <- rland$individuals[rland$individuals[,1]==as.numeric(s),]
-                for (l in names(af[[s]])) #cruise through the loci
-                    if (length(which(!(l%in%possLoc)))>0)
-                    {
-                        stop(paste("a locus name is not found in the landscape"))
-                    } else { #this locus is legal, lets make the changes
-                        av <- af[[s]][[l]] #this should be the allele frequency vector for l/pop
-                        if (sum(av)>1) {stop("allele freq vector sums to > 1")}
-                        lcols <- (which(as.character(locposition)==l)+landscape.democol())
-                        n=dim(inds)[1]
 
-                        if (states)
-                            {
-                                ai <- landscape.locus.states(rland,as.numeric(l),do.check=F)
-                                aindex <- ai$aindex[ai$state %in% names(av)]
-                            } else aindex <- names(av)
-                        for (a in lcols)
-                            inds[,a] <- as.numeric(sample(aindex,n,replace=T,prob=av))
-                    }
-                rland$individuals[s==as.character(rland$individuals[,1]),] <- inds
-            }
-
+  if (is.null(af)) {
+    cat("specify at least some allele frequencies\n")
+  } else {
+    locposition <- as.character(landscape.locusvec(rland))
+    possLoc <- as.character(1:length(rland$loci))
+    possStgs <- as.character(0:((rland$intparam$habitats * rland$intparam$stages) - 1))
+    democol <- landscape.democol()
+    if (length(which(!(names(af) %in% possStgs))) > 0) {
+      stop(paste("some stages in af do not exist in landscape"))
+    }
+    else {
+      for (s in names(af)) {
+        s.inds <- rland$individuals[, 1] == as.numeric(s)
+        inds <- rland$individuals[s.inds, ]
+        n <- dim(inds)[1]
+        if(!all(names(af[[s]]) %in% possLoc)) {
+          stop("a locus name is not found in the landscape")
+        }
+        for (l in names(af[[s]])) {
+          av <- af[[s]][[l]]
+          if (sum(av) > 1) stop("allele freq vector sums to > 1")
+          aindex <- if (states) {
+            ai <- landscape.locus.states(rland, as.numeric(l), do.check = F)
+            ai$aindex[ai$state %in% names(av)]
+          } else names(av)
+          lcols <- which(locposition == l) + democol
+          inds[, lcols] <- as.numeric(
+            sample(aindex, n * length(lcols), replace = T, prob = av)
+          )
         }
+        rland$individuals[s.inds, ] <- inds
+      }
     }
-    rland
+  }
+  rland
 }