Forced Nest Migration Simulation for New Nesting Species Added with Kanto-2 Event 2018

Forced Nest Migration Script 09-14-18.R

# for nest migrations - source functions, modify vectors of lists of nesting species, then run
# use kable to produce markdown table for pasting to Silph Road

#approximate ranges for each species in the nesting lists
getRangesForNestingSpecies<-function(nestingSpecies, arbMax=256){
	nNesting<-length(nestingSpecies)
	intLength<-arbMax/nNesting
	lowBound<-((1:nNesting)-1)*intLength
	upperBound<-lowBound+intLength
	res<-cbind(lowBound,upperBound)
	rownames(res)<-nestingSpecies
	return(res)
	}

# find new species for each old nesting seed range
findNew<-function(oldRange,newRanges){
	newRanges<-round(newRanges,5)
	oldLow<-round(oldRange[1],5)
	oldHigh<-round(oldRange[2],5)
	#
	newLowRow<-which(newRanges[,1]<=oldLow & newRanges[,2]>oldLow)
	newHighRow<-which(newRanges[,1]<oldHigh & newRanges[,2]>=oldHigh)
	#
	#print(c(newLowRow,newHighRow))
	newRows<-newLowRow:newHighRow
	newNestNames<-rownames(newRanges)[newRows]
	# calculate proportion of overlap (prob of shift)
	propOverlap<-sapply(newRows,function(x)
		 getPropOverlap(X=newRanges[x,],Y=oldRange))
	# paste them together
	res<-paste0(newNestNames," (",round(propOverlap*100,1),"%)")
	return(res)
	}
	
getPropOverlap<-function(X,Y){
	# calculate how much range X overlaps with range Y
	overlapRange<-c(max(X[1],Y[1]),min(X[2],Y[2]))
	overlap<-overlapRange[2]-overlapRange[1]
	# divide by length of Y
	propOverlap<-overlap/(Y[2]-Y[1])
	return(propOverlap)
	}

# master function
predictNestingShifts<-function(oldNestingList,newNestingList){
	oldRanges<-getRangesForNestingSpecies(currentNesting)
	newRanges<-getRangesForNestingSpecies(newNesting)
	#
	nestShifts<-apply(oldRanges,1,findNew,newRanges=newRanges)
	if(length(dim(nestShifts))!=2){
		# need to add NAs when there are uneven number of possible species
			# for different nests to potentially migrate to
		maxNSlength<-max(sapply(nestShifts,length))
		nestShifts<-sapply(nestShifts,function(x){
			if(length(x)<maxNSlength){
				res<-c(x,rep(NA,maxNSlength-length(x)))
			}else{
				res<-x
				}
			return(res)
			})
		}
	nestShifts<-t(nestShifts)
	#print(nestShifts)
	nestShifts<-cbind(oldNestingSpecies=rownames(nestShifts),nestShifts)
	colnames(nestShifts)[2:ncol(nestShifts)]<-paste0("NewNestingSpecies",
		1:(ncol(nestShifts)-1))
	rownames(nestShifts)<-NULL
	return(nestShifts)
	}


###
# Example for Migration if Larvitar Nests on Community Day
###

# full list as estimated as of 02-08-18
currentNesting<-c("Bulbasaur", "Charmander", "Squirtle", 
"Caterpie", "Weedle", "Pidgey", "Rattata", "Spearow", "Ekans", 
"Pikachu", "Sandshrew", "NidoranF", "NidoranM", "Clefairy", "Vulpix", 
"Jigglypuff", "Zubat", "Oddish", "Paras", "Venonat", "Diglett", 
"Meowth", "Psyduck", "Mankey", "Growlithe", "Poliwag", "Abra", 
"Machop", "Bellsprout", "Tentacool", "Geodude", "Ponyta", "Slowpoke", 
"Magnemite", "Doduo", "Seel", "Shellder", "Gastly", "Onix", "Drowzee", 
"Krabby", "Voltorb", "Exeggcute", "Cubone", "Rhyhorn", "Horsea", 
"Goldeen", "Staryu", "Scyther", "Jynx", "Electabuzz", "Magmar", 
"Pinsir", "Magikarp", "Eevee", "Omanyte", "Kabuto", 
"Chikorita", "Cyndaquil", "Totodile", "Sentret", "Hoot-hoot", "Ledyba", 
"Spinarak", "Chinchou", "Natu", "Marill", "Hoppip", "Aipom", "Sunkern", 
"Yanma", "Wooper", "Misdreavus", "Wobbufett", "Girafarig", "Dunsparce", 
"Snubbull", "Qwilfish", "Shuckle", "Sneasle", "Teddiursa", "Slugma", 
"Swinnub", "Remoraid", "Hondour","Treecko", "Torchic", "Mudkip", 
"Poochyena", "Zigzagoon", "Wurmple", "Seedot", "Taillow", "Wingull", 
"Surskit", "Shroomish", "Whismur", "Makuhita", "Nosepass", "Skitty", 
"Aron", "Meditite", "Electrike", "Gulpin", "Carvanha", "Wailmer", 
"Numel", "Spoink", "Swablu", "Barboach", "Corphish", "Baltoy", 
"Shuppet", "Duskull", "Spheal", "Luvdisc")



newNesting<-c("Bulbasaur", "Charmander", "Squirtle", 
"Caterpie", "Weedle", "Pidgey", "Rattata", "Spearow", "Ekans", 
"Pikachu", "Sandshrew", "NidoranF", "NidoranM", "Clefairy", "Vulpix", 
"Jigglypuff", "Zubat", "Oddish", "Paras", "Venonat", "Diglett", 
"Meowth", "Psyduck", "Mankey", "Growlithe", "Poliwag", "Abra", 
"Machop", "Bellsprout", "Tentacool", "Geodude", "Ponyta", "Slowpoke", 
"Magnemite", "Doduo", "Seel",			# "Grimer",
"Shellder", "Gastly", "Onix", "Drowzee", 
"Krabby", "Voltorb", "Exeggcute", "Cubone", "Rhyhorn", "Horsea", 
"Goldeen", "Staryu", "Scyther", "Jynx", "Electabuzz", "Magmar", 
"Pinsir", "Magikarp", "Eevee", "Omanyte", "Kabuto", 
"Chikorita", "Cyndaquil", "Totodile", "Sentret", "Hoot-hoot", "Ledyba", 
"Spinarak", "Chinchou", "Natu", "Marill",
"Sudowoodo",
"Hoppip", "Aipom", "Sunkern", 
"Yanma", "Wooper", "Misdreavus", "Wobbufett", "Girafarig", "Dunsparce", 
"Snubbull", "Qwilfish", "Shuckle", "Sneasle", "Teddiursa", "Slugma", 
"Swinnub", "Remoraid", 
"Mantine", "Skarmory",
"Hondour",
"Phanpy", "Stantler",
"Treecko", "Torchic", "Mudkip", 
"Poochyena", "Zigzagoon", "Wurmple", "Seedot", "Taillow", "Wingull", 
"Surskit", "Shroomish", "Whismur", "Makuhita", "Nosepass", "Skitty", 
"Sableye",
"Aron", "Meditite", "Electrike",
"Plusle","Minun",
"Gulpin", "Carvanha", "Wailmer", 
"Numel", "Spoink", "Swablu", "Barboach", "Corphish", "Baltoy", 
"Lileep","Anorith",
"Shuppet", "Duskull", "Spheal", "Luvdisc")


nestShifts<-predictNestingShifts(oldNestingList=currentNesting,newNestingList=newNesting)

nestShifts

# use knitr to convert the table of nest shifts to markdown
x<-knitr::kable(nestShifts)
cat(x,file="nesting_species_predictions_kantoEventNestShift.09-13-18.txt", sep = "\n")