need help to improve efficiency of my code in R - r

I am trying to study different estimators and trying do their simulation. However, my current code is too slow, and I would like to make it more efficient. Below is the relevant excerpt:
covsn<-function(x,y){
v=rep(0,n)
for(i in 1:n)
{
if(n%%2==1){
m0=floor(n/2)
} else{
m0=floor((n+1)/2)
}
x_other=x[-i]
y_other=y[-i]
v[i]=sort((x[i]-x_other)*(y[i]-y_other),decreasing=F)[c(m0)]
}
m1=floor((n+1)/2)
return(sncov=sort(v)[c(m1)])
}
M=matrix(0,p,p)
D=matrix(0,p,p)
for(i in 1:p)
{
for(j in 1:p)
{
M[i,j]=covsn(X[,i],X[,j])
if(i==j){
library(robustbase)
d=1/Sn(X[,i], constant=1.196)
D[i,j]=d
}}}

Related

For>while>for loops slowing down this R code?

I apologize in advance for the elementary question, but thought it may be a quick pointer from someone out there.
I am looking at this publicly-available code and wondering why it runs slow (or stalls completely), when the mu for the negative binomial generation is >1. Is it related to the nested loops?
Thank you.
for(i in 1:runs) {
cases <- seed
t <- rep(0,seed)
times <- t
while(cases > 0) {
secondary <- rnbinom(cases,size=fit.cases$estimate[1],mu=fit.cases$estimate[2])
t.new <- numeric()
for(j in 1:length(secondary)) {
t.new <- c(t.new,t[j] + rgamma(secondary[j],shape=fit.serial$estimate[1],
rate=fit.serial$estimate[2]))
}
cases <- length(t.new)
t <- t.new
times <- c(times,t.new)
}
lines(sort(times),1:length(times),col=cols[i],lwd=1)
points(max(times),length(times),col=cols[i],pch=16)
}
https://github.com/calthaus/Ebola/blob/master/Superspreading%20(Lancet%20Inf%20Dis%202015)/Ebola_superspreading_analysis.R

R - Loop to get ARMA coeftest output in list

R-newbie question.
I have some troubles understanding how to compute the coeftest function on ALL looped ARMA models and display the related output in the list.
How would you most simply adjust the following code?
library(lmtest)
bchain_2012_logreturns=diff(log(prices_2012))
bchain_2013_logreturns=diff(log(prices_2013))
bchain_logreturns_Arima_coef=list()
k=1
for(i in 2012:2013){
for(p in 0:1){
for(q in 0:1){
bchain_logreturns_Arima=Arima(get(paste("bchain_",i,"_logreturns",sep="")),order=c(p,0,q))
bchain_logreturns_Arima_coef[[k]]=round(transpose(coeftest(bchain_logreturns_Arima)),digit=3)
}
}
k=k+1
}
I did not understand how accumulator k works. Now it' fine.
library(lmtest)
bchain_2012_logreturns=diff(log(prices_2012))
bchain_2013_logreturns=diff(log(prices_2013))
bchain_logreturns_Arima_coef=list()
k=1
for(i in 2012:2013){
for(p in 0:1){
for(q in 0:1){
bchain_logreturns_Arima=Arima(get(paste("bchain_",i,"_logreturns",sep="")),order=c(p,0,q))
bchain_logreturns_Arima_coef[[k]]=round(transpose(coeftest(bchain_logreturns_Arima)),digit=3)
k=k+1
}
}
}

Mode Constrained likelihood maximisation using alabama package in R

I have been trying to minimize the function \sum n_i*log(p_i) where p_i's are the unknown probability parameters, satisfying usual constraints, namely p_i>0 and \sum(p_i)=1.
Further I have constraints of the form p_1<=p_2<=...<=p_(11)>=p_(12)>=...>=p(21). I plan to use the alabama package in R for the above. I wrote out a code -
############## Generating multinomial with specified probability ##################
p=seq(0.01,0.01+9*0.007,0.007)
pr=c(p,(1-2*sum(p)),rev(p))
y=sample(21,1000,prob=pr,replace=T)
############### Obtaining Frequency distribution #################
freq=numeric(21)
for(i in 1:21)
freq[i]=sum(as.numeric(y==i))
############# Negative Log-likelihood #################
fn=function(x)
{
sum=0
for(i in 1:21)
sum=sum+freq[i]*log(x[i])
return(-sum)
}
############# Gradient vector #################
gr=function(x)
{
g=numeric(length(x))
for(i in 1:length(x))
g[i]=freq[i]/x[i]
return(g)
}
############# Equality constraints ################
heq=function(x)
{
h=rep(0,1)
h=sum(x)-1
return(h)
}
heq.jac=function(x)
{
j=matrix(0,1,length(x))
j[1,]=rep(1,length(x))
return(j)
}
############## Inequality constraints ################
hin=function(x)
{
h=rep(0,41)
for(i in 1:21)
{
h[i+20]=x[i]
}
for(i in 1:20)
{
if(i<=10)
h[i]=x[i+1]-x[i]
if(i>10)
h[i]=x[i]-x[i+1]
}
return(h)
}
hin.jac=function(x)
{
j=matrix(0,41,21)
for(i in 1:21)
j[(i+20),i]=1
for(i in 1:20)
{
if(i<=10)
{
j[i,(i+1)]=1
j[i,i]=-1
}
if(i>10)
{
j[i,i]=1
j[i,(i+1)]=-1
}
}
return(j)
}
################ Function call ##################
init=runif(21,0,1)
est=auglag(par=init, fn=fn, gr=gr, heq=heq, heq.jac=heq.jac, hin=hin, hin.jac=hin.jac)
Now the above snippet doesn't work. The algorithm does not converge and instead yields warnings, namely
In log(x[i]) : NaNs produced
Can you please help me figure out where I am going wrong? Thank you.
P.S. I do understand there are some redundant constraints in the code.

R GP Implementation Error

So I am very new to R. I was having some trouble importing data with Mathematica, so I decided to make a switch since R is much better suited to analytics. I'm building a few machine learning techniques to do analysis on the data that I can now import. This is a genetic programming implementation that when finished should do symbolic regression on some data. Other than the errors, the script should be almost complete (I need to program the composition operator, make the division protected, and finish the list of base functions). I had a previous problem while programming the script that was resolved (R Error Genetic Programming Implementation). I've been debugging the script for about a day and I'm all out of ideas.
My error message is:
Error in makeStrName(nextGen) : object 'nextGen' not found
>
> #Print the string versions of the five functions with the lowest RMSE evolved.
> byRMSEList<-sortByRMSE(populationsBestTenStr)
Error: object 'totalTwo' not found
> for(i in 1:5)
+ {
+ byRMSEList[[i]]
+ }
Error: object 'byRMSEList' not found
Here is my script. I am currently using RStudio. Thanks for taking the time to help:
library("datasets")
operators<-list("+","*","-","/","o")
funcs<-list("x","log(x)","sin(x)","cos(x)","tan(x)")
#Allows me to map a name to each element in a numerical list.
makeStrName<-function(listOfItems)
{
for(i in 1:length(listOfItems))
{
names(listOfItems)[i]=paste("x",i,sep="")
}
return(listOfItems)
}
#Allows me to replace each random number in a vector with the corresponding
#function in a list of functions.
mapFuncList<-function(funcList,rndNumVector)
{
for(i in 1:length(funcList))
{
rndNumVector[rndNumVector==i]<-funcList[i]
}
return(rndNumVector)
}
#Will generate a random function from the list of functions and a random sample.
generateOrganism<-function(inputLen,inputSeed, funcList)
{
set.seed(inputSeed)
rnd<-sample(1:length(funcList),inputLen,replace=T)
Org<-mapFuncList(funcList,rnd)
return(Org)
}
#Will generate a series of "Organisms"
genPopulation<-function(popSize,initialSeed,initialSize,functions)
{
population<-list()
for(i in 1:popSize)
{
population <- c(population,generateOrganism(initialSize,initialSeed+i,functions))
}
populationWithNames<-makeStrName(population)
return(populationWithNames)
}
#Turns the population of functions (which are actually strings in "") into
#actual functions. (i.e. changes the mode of the list from string to function).
funCreator<-function(snippet)
{
txt=snippet
function(x)
{
exprs <- parse(text = txt)
eval(exprs)
}
}
#Applies a fitness function to the population. Puts the best organism in
#the hallOfFame.
evalPopulation<-function(populationFuncList, inputData, outputData, populationStringList)
{
#rmse <- sqrt( mean( (sim - obs)^2))
for(i in 1:length(populationStringList))
{
stringFunc<-populationStringList[[i]]
total<-list(mode="numeric",length=length(inputData))
topTenPercentFunctionList<-list()
topTenPercentRMSEList<-list()
topTenPercentStringFunctionList<-list()
tempFunc<-function(x){x}
for(z in 1:length(inputData))
{
total<-c(total,(abs(populationFuncList[[i]](inputData[[z]])-outputData[[z]])))
tempFunc<-populationFuncList[[i]]
}
rmse<-sqrt(mean(total*total))
topTenPercentVal<-length(populationFuncList)*0.1
if(length(topTenPercentFunctionList)<topTenPercentVal||RMSE<min(topTenPercentRMSEList))
{
topTenPercentStringFunctionList<-c(topTenPercentStringFunctionList,stringFunc)
topTenPercentRMSEList<-c(topTenPercentRMSEList, rmse)
topTenPercentFunctionList<-c(topTenPercentFunctionList, tempFunc)
}
}
return(topTenPercentStringFunctionList)
}
#Get random operator
getRndOp<-function(seed)
{
set.seed(seed)
rndOpNum<-sample(1:length(operators),1,replace=T)
operation<-operators[[rndOpNum]]
return(operation)
}
#Mutation Operators
#This attaches a new appendage to an organism
endNodeMutation<-function(strFunc,seed)
{
op<-getRndOp(seed)
strFunc<-c(strFunc,op)
newAppendage<-generateOrganism(1,seed+2,funcs)
strFunc<-c(strFunc,newAppendage)
return(strFunc)
}
#This is a mutation that occurs at a random locaiton in an organism
rndNodeMutation<-function(strFunc,seed,secondSeed)
{
op<-getRndOp(seed)
halfStrFunc<-((length(strFunc))/2)
set.seed(seed)
randomStart<-sample(1:halfStrFunc,1,replace=T)
set.seed(secondSeed)
randomEnd<-2*(sample(1:length(halfStrFunc),1,replace=T))
strFuncUpdate<-substr(strFunc,randomStart,randomEnd)
strFuncUpdate<-c(strFuncUpdate,op)
newAppendage<-generateOrganism(1,seed+2,funcs)
strFuncUpdate<-c(strFuncUpdate,newAppendage)
return(strFuncUpdate)
}
#Crossover Operators
#Crossover operator that attaches otherStrFunc to strFunc at the endpoint of strFunc
crossoverConcatenationOperator<-function(strFunc,otherStrFunc)
{
newStrFunc<-c(strFunc,otherStrFunc)
return(newStrFunc)
}
#Crossover Operation that starts and ends at random points in the concatenation
randomCrossoverOperator<-function(strFunc,otherStrFunc,seed,secondSeed)
{
set.seed(seed)
wholeLength<-(length(strFunc)+length(otherStrFunc))
startRndNum<-sample(1:length(strFunc),1,replace=T)
set.seed(secondSeed)
endRndNum<-sample(length(strFunc):wholeLength,1,replace=T)
concatenatedFunc<-c(strFunc,otherStrFunc)
newFunc<-substr(concatenatedFunc,startRndNum,endRndNum)
return(newFunc)
}
evolve<-function(strFuncList,tenPercentStrFuncList)
{
#Detach the bottom ninety percent to the top ten percent
evolveList<-substr(strFuncList,length(tenPercentStrFuncList),length(strFuncList))
#Get sizes. Will use a random mutation, then random crossover, then
#random mutation, then random crossover at percentages with 0.05,0.45,0.05,0.45
#respectively
size<-length(evolveList)
mutateNum<-0.1*size
crossoverNum<-0.9*size
halfMutateNum<-0.05*size
halfCrossoverNum<-0.45*size
roundedMutateNum<-floor(mutateNum)
roundedCrossoverNum<-floor(crossoverNum)
roundedHalfMutateNum<-floor(halfMutateNum)
roundedHalfCrossoverNum<-floor(halfCrossoverNum)
#Calls the functions for those percentage of organisms in that order
for(i in 1:roundedHalfMutateNum)
{
set.seed(i)
rndOne<-sample(0:1000,1,replace=T)
set.seed(i+10000)
rndTwo<-sample(0:10000,1,replace=T)
newFunc<-rndNodeMutation(evolveList[[i]],rndOne,rndTWo)
evolveList[[i]]<-newFunc
}
for (i in roundedHalfMutateNum:(roundedHalfCrossoverNum+roundedHalfMutateNum))
{
set.seed(i)
rndOne<-sample(0:1000,1,replace=T)
set.seed(i+10000)
rndTwo<-sample(0:10000,1,replace=T)
newFunc<-rndCrossoverOperation(evolveList[[i]],evolveList[[i+1]],rndOne,rndTwo)
firstSubstr<-substr(evolveList,1,i-1)
secondSubstr<-substr(evolveLIst,i+2,length(evolveList))
halfSubstr<-c(firstSubstr,newFunc)
evolveList<-c(halfSubstr,secondSubstr)
}
for(i in (roundedHalfCrossoverNum+roundedHalfMutateNum):(roundedHalfCrossoverNum+roundedMutateNum))
{
set.seed(i)
rndOne<-sample(0:1000,1,replace=T)
set.seed(i+10000)
rndTwo<-sample(0:10000,1,replace=T)
newFunc<-rndNodeMutation(evolveList[[i]],rndOne,rndTWo)
evolveList[[i]]<-newFunc
}
for(i in (roundedHalfCrossoverNum+roundedMutateNum):(roundedCrossoverNum+roundedHalfMutateNum))
{
set.seed(i)
rndOne<-sample(0:1000,1,replace=T)
set.seed(i+10000)
rndTwo<-sample(0:10000,1,replace=T)
newFunc<-rndCrossoverOperation(evolveList[[i]],evolveList[[i+1]],rndOne,rndTwo)
firstSubstr<-substr(evolveList,1,i-1)
secondSubstr<-substr(evolveLIst,i+2,length(evolveList))
halfSubstr<-c(firstSubstr,newFunc)
evolveList<-c(halfSubstr,secondSubstr)
}
}
#Calculates the root mean squared of the functions in a string list.
#Then sorts the list by RMSE.
sortByRMSE<-function(strL)
{
for (z in 1:length(strL))
{
for(i in 1:length(strL))
{
nonStrFuncList<-lapply(strL,function(x){funCreator(x)})
totalTwo<-c(totalTwo,(abs(nonStrFuncList[[z]](inputData[[i]])-outputData[[i]])))
}
rmse<-sqrt(mean(totalTwo*totalTwo))
strFuncsLists<-strL[order(sapply(strL, '[[', rmse))]
}
return(strFuncsLists)
}
#Data, Output Goal
desiredFuncOutput<-list(1,4,9,16,25)
dataForInput<-list(1,2,3,4,5)
#Generate Initial Population
POpulation<-genPopulation(4,1,1,funcs)
POpulationFuncList <- lapply(setNames(POpulation,names(POpulation)),function(x){funCreator(x)})
#Get and save top ten percent in bestDudes
bestDudes<-evalPopulation(POpulationFuncList,dataForInput,desiredFuncOutput,POpulation)
#Evolve the rest
NewBottomNinetyPercent<-evolve(POpulation,bestDudes)
#Concatenate the two to make a new generation
nextGen<-c(bestDudes,NewBottomNinetyPercent)
#Declare lists,
populationsBestTenStr<-list()
populationsFuncList<-list()
#Run ten generations.
for(i in 1:10)
{
nextGen<-makeStrName(nextGen)
populationsFuncList<-lapply(setNames(nextGen,names(nextGen)),function(x){funCreator(x)})
populationsBestTenStr<-evalPopulation(populationsFuncList,dataForInput,desiredFuncOutput,nextGen)
nextGen<-evolve(populations,populationsBestTenStr)
}
#Print the string versions of the five functions with the lowest RMSE evolved.
byRMSEList<-sortByRMSE(populationsBestTenStr)
for(i in 1:5)
{
byRMSEList[[i]]
}
library("datasets")
operators<-list("+","*","-","/","o")
funcs<-list("x","log(x)","sin(x)","cos(x)","tan(x)")
# Fixed:
# evolveLIst inconsistently typed as evolveList
# rndCrossoverOperation inconsistently typed as randomCrossoverOperator
# rndTWo inconsistently typed as rndTwo
# broken substr
# broken condition leading to for(i in 1:0)
# misc. others
#Allows me to map a name to each element in a numerical list.
makeStrName<-function(listOfItems)
{
for(i in 1:length(listOfItems))
{
names(listOfItems)[i]=paste("x",i,sep="")
}
return(listOfItems)
}
#Allows me to replace each random number in a vector with the corresponding
#function in a list of functions.
mapFuncList<-function(funcList,rndNumVector)
{
for(i in 1:length(funcList))
{
rndNumVector[rndNumVector==i]<-funcList[i]
}
return(rndNumVector)
}
#Will generate a random function from the list of functions and a random sample.
generateOrganism<-function(inputLen,inputSeed, funcList)
{
set.seed(inputSeed)
rnd<-sample(1:length(funcList),inputLen,replace=T)
Org<-mapFuncList(funcList,rnd)
return(Org)
}
#Will generate a series of "Organisms"
genPopulation<-function(popSize,initialSeed,initialSize,functions)
{
population<-list()
for(i in 1:popSize)
{
population <- c(population,generateOrganism(initialSize,initialSeed+i,functions))
}
populationWithNames<-makeStrName(population)
return(populationWithNames)
}
#Turns the population of functions (which are actually strings in "") into
#actual functions. (i.e. changes the mode of the list from string to function).
funCreator<-function(snippet)
{
txt=snippet
function(x)
{
exprs <- parse(text = txt)
eval(exprs)
}
}
#Applies a fitness function to the population. Puts the best organism in
#the hallOfFame.
evalPopulation<-function(populationFuncList=POpulationFuncList, inputData=dataForInput, outputData=desiredFuncOutput,
populationStringList=POpulation)
{
#rmse <- sqrt( mean( (sim - obs)^2))
for(i in 1:length(populationStringList))
{
stringFunc<-populationStringList[[i]]
total<-as.numeric(length(inputData))
topTenPercentFunctionList<-list()
topTenPercentRMSEList<-list()
topTenPercentStringFunctionList<-list()
tempFunc<-function(x){x}
for(z in 1:length(inputData))
{
total<-c(total,(abs(populationFuncList[[i]](inputData[[z]])-outputData[[z]])))
tempFunc<-populationFuncList[[i]]
}
rmse<-sqrt(mean(total^2))
topTenPercentVal<-length(populationFuncList)*0.1
if(length(topTenPercentFunctionList)<topTenPercentVal||RMSE<min(topTenPercentRMSEList))
{
topTenPercentStringFunctionList<-c(topTenPercentStringFunctionList,stringFunc)
topTenPercentRMSEList<-c(topTenPercentRMSEList, rmse)
topTenPercentFunctionList<-c(topTenPercentFunctionList, tempFunc)
}
}
return(topTenPercentStringFunctionList)
}
#Get random operator
getRndOp<-function(seed)
{
set.seed(seed)
rndOpNum<-sample(1:length(operators),1,replace=T)
operation<-operators[[rndOpNum]]
return(operation)
}
#Mutation Operators
#This attaches a new appendage to an organism
endNodeMutation<-function(strFunc,seed)
{
op<-getRndOp(seed)
strFunc<-c(strFunc,op)
newAppendage<-generateOrganism(1,seed+2,funcs)
strFunc<-c(strFunc,newAppendage)
return(strFunc)
}
#This is a mutation that occurs at a random locaiton in an organism
rndNodeMutation<-function(strFunc,seed,secondSeed)
{
op<-getRndOp(seed)
halfStrFunc<-((length(strFunc))/2)
set.seed(seed)
randomStart<-sample(1:halfStrFunc,1,replace=T)
set.seed(secondSeed)
randomEnd<-2*(sample(1:length(halfStrFunc),1,replace=T))
strFuncUpdate<-substr(strFunc,randomStart,randomEnd)
strFuncUpdate<-c(strFuncUpdate,op)
newAppendage<-generateOrganism(1,seed+2,funcs)
strFuncUpdate<-c(strFuncUpdate,newAppendage)
return(strFuncUpdate)
}
#Crossover Operators
#Crossover operator that attaches otherStrFunc to strFunc at the endpoint of strFunc
crossoverConcatenationOperator<-function(strFunc,otherStrFunc)
{
newStrFunc<-c(strFunc,otherStrFunc)
return(newStrFunc)
}
#Crossover Operation that starts and ends at random points in the concatenation
rndCrossoverOperation<-function(strFunc,otherStrFunc,seed,secondSeed) # fixed function name
{
set.seed(seed)
wholeLength<-(length(strFunc)+length(otherStrFunc))
startRndNum<-sample(1:length(strFunc),1,replace=T)
set.seed(secondSeed)
endRndNum<-sample(length(strFunc):wholeLength,1,replace=T)
concatenatedFunc<-c(strFunc,otherStrFunc)
newFunc<-substr(concatenatedFunc,startRndNum,endRndNum)
return(newFunc)
}
evolve<-function(strFuncList=POpulation,tenPercentStrFuncList=bestDudes)
{
#Detach the bottom ninety percent to the top ten percent
evolveList<-strFuncList[!strFuncList %in% tenPercentStrFuncList] # fixed broken substring
#Get sizes. Will use a random mutation, then random crossover, then
#random mutation, then random crossover at percentages with 0.05,0.45,0.05,0.45
#respectively
size<-length(evolveList)
mutateNum<-0.1*size
crossoverNum<-0.9*size
halfMutateNum<-0.05*size
halfCrossoverNum<-0.45*size
roundedMutateNum<-floor(mutateNum)
roundedCrossoverNum<-floor(crossoverNum)
roundedHalfMutateNum<-floor(halfMutateNum)
roundedHalfCrossoverNum<-floor(halfCrossoverNum)
#Calls the functions for those percentage of organisms in that order
if(roundedHalfMutateNum < 1) roundedHalfMutateNum <- 1
for(i in 1:roundedHalfMutateNum)
{
set.seed(i)
rndOne<-sample(0:1000,1,replace=T)
set.seed(i+10000)
rndTwo<-sample(0:10000,1,replace=T)
newFunc<-rndNodeMutation(evolveList[[i]],rndOne,rndTwo) # fixed case
evolveList[[i]]<-newFunc
}
for (i in roundedHalfMutateNum:(roundedHalfCrossoverNum+roundedHalfMutateNum))
{
set.seed(i)
rndOne<-sample(0:1000,1,replace=T)
set.seed(i+10000)
rndTwo<-sample(0:10000,1,replace=T)
newFunc<-rndCrossoverOperation(evolveList[[i]],evolveList[[i+1]],rndOne,rndTwo)
firstSubstr<-substr(evolveList,1,i-1)
secondSubstr<-substr(evolveList,i+2,length(evolveList))
halfSubstr<-c(firstSubstr,newFunc)
evolveList<-c(halfSubstr,secondSubstr)
}
for(i in (roundedHalfCrossoverNum+roundedHalfMutateNum):(roundedHalfCrossoverNum+roundedMutateNum))
{
set.seed(i)
rndOne<-sample(0:1000,1,replace=T)
set.seed(i+10000)
rndTwo<-sample(0:10000,1,replace=T)
newFunc<-rndNodeMutation(evolveList[[i]],rndOne,rndTwo)
evolveList[[i]]<-newFunc
}
for(i in (roundedHalfCrossoverNum+roundedMutateNum):(roundedCrossoverNum+roundedHalfMutateNum))
{
set.seed(i)
rndOne<-sample(0:1000,1,replace=T)
set.seed(i+10000)
rndTwo<-sample(0:10000,1,replace=T)
newFunc<-rndCrossoverOperation(evolveList[[i]],evolveList[[i+1]],rndOne,rndTwo)
firstSubstr<-substr(evolveList,1,i-1)
secondSubstr<-substr(evolveList,i+2,length(evolveList))
halfSubstr<-c(firstSubstr,newFunc)
evolveList<-c(halfSubstr,secondSubstr)
}
}
#Calculates the root mean squared of the functions in a string list.
#Then sorts the list by RMSE.
sortByRMSE<-function(strL)
{
for (z in 1:length(strL))
{
for(i in 1:length(strL))
{
nonStrFuncList<-lapply(strL,function(x){funCreator(x)})
totalTwo<-c(totalTwo,(abs(nonStrFuncList[[z]](inputData[[i]])-outputData[[i]])))
}
rmse<-sqrt(mean(totalTwo*totalTwo))
strFuncsLists<-strL[order(sapply(strL, '[[', rmse))]
}
return(strFuncsLists)
}
#Data, Output Goal
desiredFuncOutput<-list(1,4,9,16,25)
dataForInput<-list(1,2,3,4,5)
#Generate Initial Population
POpulation<-genPopulation(4,1,1,funcs)
POpulationFuncList <- lapply(setNames(POpulation,names(POpulation)),function(x){funCreator(x)})
#Get and save top ten percent in bestDudes
bestDudes<-evalPopulation(POpulationFuncList,dataForInput,desiredFuncOutput,POpulation)
#Evolve the rest
NewBottomNinetyPercent<-evolve(POpulation,bestDudes)
#Concatenate the two to make a new generation
nextGen<-c(bestDudes,NewBottomNinetyPercent)
#Declare lists,
populationsBestTenStr<-list()
populationsFuncList<-list()
#Run ten generations.
for(i in 1:10)
{
nextGen<-makeStrName(nextGen)
populationsFuncList<-lapply(setNames(nextGen,names(nextGen)),function(x){funCreator(x)})
populationsBestTenStr<-evalPopulation(populationsFuncList,dataForInput,desiredFuncOutput,nextGen)
nextGen<-evolve(populations,populationsBestTenStr)
}
#Print the string versions of the five functions with the lowest RMSE evolved.
byRMSEList<-sortByRMSE(populationsBestTenStr)
for(i in 1:5)
{
byRMSEList[[i]]
}

Trying to use a for loop for population simulation(2)

Im sorry to say that I have a problem with a for loop, again. I'm trying to save the final number from a population estimate for loop into a new matrix but I am only able to get the population estimate to show up in row 100. I know it relates to breedingPop2 but I cant figure it out. Any help would be much appreciated. Please find the code below:
finalPop=matrix(nrow=102, ncol=1)
for(i in 1:100){
SWWAyears=data.frame(iteration=rep(NA,101),pop=NA)
breedingPop<-90000
fallMig<-.825
springMig<-.825
winterSurvival<-rbeta(100,.95,.05)
npFecund<-rbinom(100, 3.0, .9)
pFecund<-rbeta(100, .85,.25)
breedingSurvival<-rbeta(100,.95,.05)
# Set initial starting condition
SWWAyears[1,2]=breedingPop
for(years in 2:101) {
fallPop<-(SWWAyears[years-1,2]*fallMig)
for (i in 1:100){
winterPop<-(fallPop*winterSurvival[i])}
springPop<-(winterPop*springMig)
for (i in 1:100){
summerPop<-(springPop*breedingSurvival[i])
}
for(i in 1:100){
breedingPop2<-((summerPop*.26)*npFecund[i])+((summerPop*.14)*pFecund[i])+(summerPop*.60)
}
SWWAyears[years,1]=years
SWWAyears[years,2]<-breedingPop2
}
finalPop[i,1]<-breedingPop2
}
I think you have more fundamental issues with your looping structure and you're not getting the correct results you're expecting. However, the reason for your specific question about only the 100th row being updated is:
Your variable i is being updated inside your 'inner' for() loops, so by the time you reach finalPop[i, 1] <- breedingPop2, i always equals 100.
You need to use a different variable, j for example, in your inner for() loops.
finalPop=matrix(nrow=102, ncol=1)
for(i in 1:100){
SWWAyears = data.frame(iteration=rep(NA,101),pop=NA)
breedingPop <- 90000
fallMig <- .825
springMig <- .825
winterSurvival <- rbeta(100,.95,.05)
npFecund <- rbinom(100, 3.0, .9)
pFecund <- rbeta(100, .85,.25)
breedingSurvival <- rbeta(100,.95,.05)
# Set initial starting condition
SWWAyears[1,2] = breedingPop
for(years in 2:101) {
fallPop <- (SWWAyears[years-1,2]*fallMig)
for (j in 1:100){
winterPop <- (fallPop*winterSurvival[j])
}
springPop <- (winterPop*springMig)
for (j in 1:100){
summerPop <- (springPop*breedingSurvival[j])
}
for(j in 1:100){
breedingPop2 <- ((summerPop*.26)*npFecund[j])+((summerPop*.14)*pFecund[j])+(summerPop*.60)
}
SWWAyears[years,1] = years
SWWAyears[years,2] <- breedingPop2
}
finalPop[i,1] <- breedingPop2
}
Having said that, using multiple nested for() loops is generally not recommended in R; you should be able to use matrix multiplication / vectorisation to achieve the same result.
Other Issues
your values of winterPop and summerPop will only ever be fallPop * winterSurvival[100] and springPop * breedingSurvival[100] respectively. Is this what you intended?

Resources