Selecting representative tokens in R

alldata <- read.csv("Exp1CompRRVals.csv", stringsAsFactors=FALSE)

meaning.columns <- (ncol(alldata)-7) : ncol(alldata)
colnames(alldata)[meaning.columns] <- tolower(colnames(alldata)[meaning.columns])

meanings <- colnames(alldata)[meaning.columns]

cells <- NULL
cellsize <- 25
onewordperarea <- TRUE

selecttop <- function(ordereddata, meaning, n=cellsize) {
  thismeaningcolumn <- match(meaning, colnames(ordereddata))
  colnames(ordereddata)[thismeaningcolumn] <- "TargetMeaningRR"

  # split matching and non-matching words into two data sets
  correct <- subset(ordereddata, Meaning == meaning)
  correctwords <- unique(correct$Word)

  # only consider incorrect words which are of comparable length
  correctwordlength <- range(sapply(correctwords, nchar))
  incorrect <- subset(ordereddata, Meaning != meaning &
  # only consider phonetic words which are incorrect in all languages
                                   !(Word %in% correctwords) &
                                   Length >= correctwordlength[1] &
                                   Length <= correctwordlength[2])

#  incorrectwords <- setdiff(unique(incorrect$Word), correctwords)
  incorrectwords <- unique(incorrect$Word)

  if (onewordperarea) {
    # find n unique words which are also from n different glotto families
    correctwordrows <- 1
    incorrectwordrows <- 1
    for (i in 2:n) {
      # find next entry which is a new phonetic word and new glotto family
      nextcorrectword <- subset(correct,
        !(Word %in% correct$Word[correctwordrows]) &
        !(Glotto %in% correct$Glotto[correctwordrows]))[1, c("Language", "Word")]
      nextincorrectword <- subset(incorrect,
        !(Word %in% incorrect$Word[incorrectwordrows]) &
        !(Glotto %in% incorrect$Glotto[incorrectwordrows]))[1, c("Language", "Word")]
      correctwordrows[i] <- which(correct$Language == nextcorrectword[[1]] & correct$Word == nextcorrectword[[2]])
      incorrectwordrows[i] <- which(incorrect$Language == nextincorrectword[[1]] & incorrect$Word == nextincorrectword[[2]])
    }
  } else {
    correctwordrows <- match(head(correctwords, n), correct$Word)
    incorrectwordrows <- match(head(incorrectwords, n), incorrect$Word)
  }

  rbind(cbind(TargetMeaning=meaning, Matching=TRUE,
          correct[correctwordrows, -setdiff(meaning.columns, thismeaningcolumn)]),
        cbind(TargetMeaning=meaning, Matching=FALSE,
          incorrect[incorrectwordrows, -setdiff(meaning.columns, thismeaningcolumn)]))
}

for (meaning in meanings) {
  print(paste("Meaning", meaning))
  data <- alldata[order(alldata[[meaning]], na.last=NA),]
  mean <- mean(data[[meaning]])
  median <- median(data[[meaning]])
  print(paste("RR range from", data[1, meaning], "to", data[nrow(data), meaning],
    "mean", mean, "median", median))

  # simply reverse data frame order for highest
  cells <- rbind(cells, cbind(RRclass="H", selecttop(data[nrow(data):1,], meaning)),
                        cbind(RRclass="L", selecttop(data, meaning)))

  # select middle range:

  # find range that is 
  highestlow <- max(subset(cells, TargetMeaning==meaning & RRclass=="L")$TargetMeaningRR)
  lowesthigh <- min(subset(cells, TargetMeaning==meaning & RRclass=="H")$TargetMeaningRR)
  untakenrangemean <- mean(c(highestlow, lowesthigh))
  untakenrangemedian <- mean(sapply(c(highestlow, lowesthigh),
    function(rr) which(data[[meaning]] == rr)[1]))

  # order by absolute difference from mean or median (or untakenrangemean)
#  data <- data[order(abs(data[[meaning]] - freerangemean)),]
  # order by rank difference from median (nrow(data)/2) or untakenrangemedian
  data <- data[order(abs(1:nrow(data) - untakenrangemedian)),]

  cells <- rbind(cells, cbind(RRclass="M", selecttop(data, meaning)))
}

# safety check that all cells are completely filled
nrow(cells) == cellsize * length(meanings) * 6

# and that we have the right number of unique (phonetic) words per target meaning
max(unique(xtabs(~ TargetMeaning + Word, data=cells))) == 1

# reorder levels logically
cells$RRclass <- factor(cells$RRclass, levels = c("L", "M", "H"))

knitr::kable(sapply(as.character(unique(cells$TargetMeaning)),
  function(m) sapply(levels(cells$RRclass),
    function(rr) rev(range(subset(cells, RRclass==rr & TargetMeaning==m)$TargetMeaningRR)))))

cells[which(duplicated(cells[, c("TargetMeaning", "Language", "Word")])),
  c("RRclass", "TargetMeaning", "Meaning", "Language", "Word", "TargetMeaningRR")]

if (onewordperarea)
  cells[which(duplicated(cells[, c("RRclass", "TargetMeaning", "Matching", "Glotto")]))]

x <- xtabs(~ Matching + TargetMeaning + RRclass + Length, data=cells)
lattice::barchart(x/array(rowSums(x, dim=3), dim=dim(x)), auto.key=TRUE)

perglotto <- table(cells$Glotto, cells$TargetMeaning)

knitr::kable(cbind(perglotto, total=rowSums(perglotto)))

write.csv(cells, file="Exp1-meanings-by-matching-by-RR.csv", row.names=FALSE, quote=FALSE)

longdata <- reshape2::melt(data, id.vars="Meaning", measure.vars=meaning.columns)
# distribution of RRs per meaning (accurate words only)
#lattice::histogram(~ value | Meaning, type="count", layout=c(4, 2))
lattice::densityplot(~ value, groups=Meaning, subset(longdata, Meaning == variable),
  plot.points=FALSE, auto.key=TRUE, xlim=c(-6, 4))

# distribution of RRs per meaning (incorrect words only)
#lattice::histogram(~ value | variable, type="count", layout=c(4, 2))
lattice::densityplot(~ value, groups=variable, subset(longdata, Meaning != variable),
  plot.points=FALSE, auto.key=TRUE, xlim=c(-6, 4))