Created
January 20, 2014 06:25
-
-
Save emhart/8515826 to your computer and use it in GitHub Desktop.
An answer to Florian Hartig's blog post: http://theoreticalecology.wordpress.com/2014/01/14/sampling-design-combinatorics/
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
### "Smart brute force" algorithm. Works in most mortal situations. | |
### Works by looping through a matrix that is m by k and putting numbers in | |
### Is aware of the top and left cell, and works by sampling based on the probabilities of | |
### numbers that are left in the set of valid possible numbers, e.g. those not excluded by the neighborhood rules (von Neumann) | |
### Parameters: | |
### k -- The number of rows | |
### m -- The number of columns | |
### n -- 1:N vector of desired outcomes (plants in the blog post), e.g. if N = 3, your n parameter would be n <- 1:3 | |
### maxiter -- The maximum number of iterations you want to use in the algorithm (default is 100. | |
brute_force_fill <- function(m,k,n,maxiter = 100){ | |
### Some error handling if k*m isn't a multiple of n | |
if((k*m) %% length(n) > 0){ | |
stop("Whoa slow down there, m*k needs to be a multiple on n") | |
} | |
keeploopin <- FALSE | |
count <- 1 | |
while(!keeploopin && count < maxiter){ | |
out <- fill_grid(m,k,n) | |
keeploopin <- is.matrix(out) | |
count <- 1 + count | |
} | |
if(is.matrix(out)){ | |
return(out) | |
} else {cat("Uh oh, looks like we need more brute force! Consider upping maxiter")} | |
} | |
fill_grid <- function(m,k,n){ | |
out <- matrix(NA,nrow = m, ncol = k) | |
full_set <- rep(n,((m*k)/length(n))) | |
topcell <- NA | |
leftcell <- NA | |
for(i in 1:m){ | |
for(j in 1:k){ | |
### Define the set of possible outcomes | |
### Written out this way for clarity over code conciseness. | |
topcell <- out[i,(j-1)] | |
leftcell <- out[(i-1),j] | |
## Create set of numbers to exclude | |
ex_set <- c(topcell,leftcell) | |
pos_set <- full_set[!( full_set %in% ex_set)] | |
## error checking | |
if(length(pos_set) == 0 || any(is.na(pos_set)) || any(is.na(full_set))){ | |
return(FALSE) | |
} else { | |
### Handle annoying R sample behavior | |
val <- sample(pos_set,1) | |
if(length(pos_set == 1)){val <- sample(rep(pos_set,2),1)} | |
full_set <- full_set[-which(full_set == val)[1]] | |
### Make sure we didn't hit an NA when popping off our fake stack | |
if(any(is.na(full_set))){return(FALSE)} | |
out[i,j] <- val | |
} | |
} | |
} | |
return(out) | |
} | |
### Test scenario from the blog post | |
m <- 12 | |
k <- 12 | |
n <- 1:3 | |
results <- brute_force_fill(m,k,n) | |
### Check to make sure that there are an equal number of each n | |
table(results) | |
### Check that no values are 0 in any diffs by rows or columns | |
### If this value is greater than 0 the algorithm failed :( | |
sum(apply(results,2,diff)==0) + sum(apply(results,1,diff)==0) | |
### Plot it! | |
### Level plots make it pretty | |
library(lattice) | |
levelplot(results) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment