SamplingLesson20140128Commands

source("http://pastebin.com/raw.php?i=BU2tycrK")

pop.param <- mean(studentdat$commties) #Measures population
pop.param <- round(pop.param, digits = 3)
first.five <- which(studentdat$timerank %in% 1:5) #Samples
convien.param <- mean(studentdat$commties[first.five]) #Measures sample
cat("\n  Population parameter = ", pop.param, ", Sample parameter = ", convien.param, "\n")

m <- sort(studentdat$timerank[which(studentdat$male)])[1] #First male times
f <- sort(studentdat$timerank[which(!studentdat$male)])[1:4] #First four females times
quota.samp <- which(studentdat$timerank %in% c(m, f)) #Samples
quota.param <- mean(studentdat$commties[quota.samp]) #Measures sample
cat("\n  Population parameter = ", pop.param, ", Sample parameter = ", quota.param, "\n")

set.seed(666) #Standardizes random number generator
sb.samp <- function(n, rr = .5, nseeds = 1, net = studentel){
  recruit.wave <- rep(NA, times=vcount(studentel))
  orig.seeds <- sample.int(nrow(studentdat), nseeds)
  new.seeds <- orig.seeds
  ncount <- nseeds
  wave <- 1
  recruit.wave[orig.seeds] <- wave
  deadend <- FALSE
  while ((ncount < n) & !deadend){
    wave <- wave + 1
    new.seeds <- unlist(sapply(new.seeds, neighbors, graph = net))
    if (all(new.seeds %in% orig.seeds))
      deadend <- TRUE
    else{
      new.seeds <- new.seeds[which(new.seeds %in% orig.seeds == FALSE)]
      recruited <- which(rbinom(length(new.seeds), 1, rr)==1)
      new.seeds <- new.seeds[recruited]
      if ((length(recruited) == 0) | (length(new.seeds) == 0))
        deadend <- TRUE
      else{
        orig.seeds <- c(orig.seeds, new.seeds)
        recruit.wave[new.seeds] <- wave
        ncount <- length(orig.seeds)
        }
      }
    }
  return(recruit.wave)
  }

#General plot of "population" sociogram
library(RColorBrewer)
plot.wrap <- function(...)
  plot(studentel, edge.width=7, vertex.label.family="sans", vertex.label.cex=1.25, vertex.label.dist=.85, vertex.label.degree=-1.9*pi/4, ...)
plot.wrap.sb <- function(sb.recruited){
  sb.param <- mean(degree(studentel)[which(!is.na(sb.recruited))])
  sb.param <- round(sb.param, digits = 3)
  sb.maintitle <- "Snowball Sample Simulation"
  sb.sub <- paste("Population Parameter = ", pop.param, ", Sample parameter = ", sb.param, sep="")
  sb.recruits.color <- rev(brewer.pal(max(sb.recruited, na.rm=TRUE), "Blues"))[sb.recruited]
  sb.recruits.color[is.na(sb.recruited)] <- "white"
  plot.wrap(vertex.color = sb.recruits.color, main = sb.maintitle, sub = sb.sub)
  }
plot.wrap.sb(sb.samp(5)) #Sample size of 5, response rate of .5, 1 seed
plot.wrap.sb(sb.samp(10, rr = .3, nseeds = 2)) #Sample size of 10, response rate of .3, 2 seeds
plot.wrap.sb(sb.samp(10, rr = .8, nseeds = 2)) #Same as above, yet with a higher response rate

set.seed(666)
random.samp <- sample.int(1000, 10)
random.samp
random.samp.meanfun <- function(ss)
  return(mean(studentdat$commties[sample.int(vcount(studentel), ss)]))
cat("\n  Population parameter = ", pop.param, ", Sample parameter = ", round(random.samp.meanfun(5), digits = 3), "\n")

#To demonstrate the central limit theorem
random.mean.5samp.1k <- replicate(1000, random.samp.meanfun(5))
mean.across.randomsamples <- mean(random.mean.5samp.1k)
mean.across.randomsamples <- round(mean.across.randomsamples, digits = 3)
hist(random.mean.5samp.1k, main = "Frequency of Mean Communication Ties\nin 1000 Random Samples of 5", sub = paste("Population Parameter = ", pop.param, ", Mean Across Distributions = ", mean.across.randomsamples, sep=""), xlab = "Mean Number of Communication Partners")

#To demonstrate systematic samples
start.point <- sample.int(vcount(studentel), 1)
k <- 4
first.half <- seq(from = 1, to = start.point, by = k)
second.half <- seq(from = start.point, to = vcount(studentel), by = k)
syst.samp <- unique(c(first.half, second.half))
syst.samp
syst.samp.mean <- mean(studentdat$commties[syst.samp])
syst.samp.mean <- round(syst.samp.mean, digits = 3)
cat("\n  Population parameter = ", pop.param, ", Sample parameter = ", syst.samp.mean, "\n")