├── .Rbuildignore ├── .gitignore ├── vignettes ├── figures │ ├── crossover1.png │ ├── crossover2.png │ ├── linkMutate.png │ ├── nodeMutate.png │ ├── pointMutate.png │ ├── genotype-phenotype.png │ ├── squareRootNetwork.png │ └── enableDisableMutate.png ├── rneat-vignette.R └── rneat-vignette.Rmd ├── RNeat.Rproj ├── DESCRIPTION ├── man ├── NEATSimulation.GetStateHistoryForGenomeAndSpecies.Rd ├── newConfigNEAT.Rd ├── NEATSimulation.RunSingleGeneration.Rd ├── compute.Rd ├── rneatneuralnetcontinuetraining.Rd ├── rneatneuralnet.Rd └── newNEATSimulation.Rd ├── NAMESPACE └── R ├── Examples ├── squareRoot.R └── polebalance.R ├── neatFormula.R ├── neatCharting.R └── neat.R /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | inst/doc 2 | .Rproj.user 3 | .Rhistory 4 | -------------------------------------------------------------------------------- /vignettes/figures/crossover1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ah-box/RNeat/HEAD/vignettes/figures/crossover1.png -------------------------------------------------------------------------------- /vignettes/figures/crossover2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ah-box/RNeat/HEAD/vignettes/figures/crossover2.png -------------------------------------------------------------------------------- /vignettes/figures/linkMutate.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ah-box/RNeat/HEAD/vignettes/figures/linkMutate.png -------------------------------------------------------------------------------- /vignettes/figures/nodeMutate.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ah-box/RNeat/HEAD/vignettes/figures/nodeMutate.png -------------------------------------------------------------------------------- /vignettes/figures/pointMutate.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ah-box/RNeat/HEAD/vignettes/figures/pointMutate.png -------------------------------------------------------------------------------- /vignettes/figures/genotype-phenotype.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ah-box/RNeat/HEAD/vignettes/figures/genotype-phenotype.png -------------------------------------------------------------------------------- /vignettes/figures/squareRootNetwork.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ah-box/RNeat/HEAD/vignettes/figures/squareRootNetwork.png -------------------------------------------------------------------------------- /vignettes/figures/enableDisableMutate.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ah-box/RNeat/HEAD/vignettes/figures/enableDisableMutate.png -------------------------------------------------------------------------------- /RNeat.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | PackageCheckArgs: --as-cran 22 | PackageRoxygenize: rd,collate,namespace,vignette 23 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: RNeat 2 | Type: Package 3 | Title: Neuroevolution of Augmenting Topologies - NEAT 4 | Version: 0.1.0 5 | Author: Andrew Hunter 6 | Description: Implementation of the Neuroevolution of Augmenting Topologies (NEAT) algorithm 7 | for training neural networks through a genetic evolution approach. This is a port of the LUA 8 | code produced by Seth Bling as made famous through MarI/O video. 9 | Imports: igraph, animation, methods 10 | Maintainer: Andrew Hunter 11 | License: GPL 12 | LazyData: TRUE 13 | RoxygenNote: 5.0.1 14 | Suggests: knitr, 15 | rmarkdown 16 | VignetteBuilder: knitr 17 | -------------------------------------------------------------------------------- /man/NEATSimulation.GetStateHistoryForGenomeAndSpecies.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/neat.R 3 | \name{NEATSimulation.GetStateHistoryForGenomeAndSpecies} 4 | \alias{NEATSimulation.GetStateHistoryForGenomeAndSpecies} 5 | \title{Runs a genome and tracks the state history (will run the most fit by default)} 6 | \usage{ 7 | NEATSimulation.GetStateHistoryForGenomeAndSpecies(simulation, genomeNum = NA, 8 | speciesNum = NA) 9 | } 10 | \arguments{ 11 | \item{simulation}{Takes a NEATSimulation class} 12 | 13 | \item{genomeNum}{the genome number to run} 14 | 15 | \item{speciesNum}{the species number to run} 16 | } 17 | \value{ 18 | State history 19 | } 20 | \description{ 21 | Runs a genome and tracks the state history (will run the most fit by default) 22 | } 23 | 24 | -------------------------------------------------------------------------------- /man/newConfigNEAT.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/neat.R 3 | \name{newConfigNEAT} 4 | \alias{newConfigNEAT} 5 | \title{Configuration for setting the number of system inputs/outputs, the max number of nodes and the total number of genomes} 6 | \usage{ 7 | newConfigNEAT(numInputs, numOutputs, maxNumOfNodes, speciesPopulation = 200) 8 | } 9 | \arguments{ 10 | \item{numInputs}{The number of inputs to the neural network} 11 | 12 | \item{numOutputs}{The number of outputs from the neural network} 13 | 14 | \item{maxNumOfNodes}{The maximum number of neural network nodes} 15 | 16 | \item{speciesPopulation}{The number of genomes to simulate} 17 | } 18 | \value{ 19 | configNEAT class 20 | } 21 | \description{ 22 | Configuration for setting the number of system inputs/outputs, the max number of nodes and the total number of genomes 23 | } 24 | 25 | -------------------------------------------------------------------------------- /man/NEATSimulation.RunSingleGeneration.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/neat.R 3 | \name{NEATSimulation.RunSingleGeneration} 4 | \alias{NEATSimulation.RunSingleGeneration} 5 | \title{Runs a single generation} 6 | \usage{ 7 | NEATSimulation.RunSingleGeneration(simulation, createVideo = F, 8 | videoPath = "videos", videoName = "", framesPerSecond = 1) 9 | } 10 | \arguments{ 11 | \item{simulation}{Takes a NEATSimulation class} 12 | 13 | \item{createVideo}{True/False to save a video of the highest fitness simulation} 14 | 15 | \item{videoPath}{Path to where to save the video} 16 | 17 | \item{videoName}{Name of the video} 18 | 19 | \item{framesPerSecond}{The frames per second of the video} 20 | } 21 | \value{ 22 | NEATSimulation class with new generation of genomes 23 | } 24 | \description{ 25 | Takes in a simulation, runs all the genomes, evaluates fitness and breeds the new generation 26 | } 27 | 28 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(plot,NEATFormulaSimulation) 4 | S3method(plot,NEATSimulation) 5 | S3method(plot,rneatneuralnet) 6 | export(NEATSimulation.GetStateHistoryForGenomeAndSpecies) 7 | export(NEATSimulation.RunSingleGeneration) 8 | export(compute) 9 | export(createBoxFunc) 10 | export(createCircleFunc) 11 | export(createSceneFunc) 12 | export(newConfigNEAT) 13 | export(newNEATSimulation) 14 | export(rneatneuralnet) 15 | export(rneatneuralnetcontinuetraining) 16 | importFrom(animation,ani.options) 17 | importFrom(animation,saveVideo) 18 | importFrom(grDevices,dev.new) 19 | importFrom(graphics,box) 20 | importFrom(graphics,layout) 21 | importFrom(graphics,legend) 22 | importFrom(graphics,lines) 23 | importFrom(graphics,mtext) 24 | importFrom(graphics,par) 25 | importFrom(graphics,plot) 26 | importFrom(graphics,polygon) 27 | importFrom(graphics,symbols) 28 | importFrom(graphics,text) 29 | importFrom(igraph,add_edges) 30 | importFrom(igraph,add_vertices) 31 | importFrom(igraph,layout.circle) 32 | importFrom(igraph,make_empty_graph) 33 | importFrom(methods,is) 34 | importFrom(stats,median) 35 | importFrom(stats,runif) 36 | -------------------------------------------------------------------------------- /R/Examples/squareRoot.R: -------------------------------------------------------------------------------- 1 | 2 | #Generate traing data y = sqrt(x) 3 | trainingData <- as.data.frame(cbind(sqrt(seq(0.1,1,0.1)),seq(0.1,1,0.1))) 4 | colnames(trainingData) <- c("y","x") 5 | 6 | #Train the neural network for 5 generations, and plot the fitness 7 | rneatsim <- rneatneuralnet(y~x,trainingData,5) 8 | plot(rneatsim) 9 | 10 | #Continue training the network for another 5 generations 11 | rneatsim <- rneatneuralnetcontinuetraining(rneatsim,5) 12 | plot(rneatsim) 13 | 14 | #Construct some fresh data to stick through the neural network and hopefully get square rooted 15 | liveData <- as.data.frame(seq(0.1,1,0.01)) 16 | colnames(liveData) <- c("x") 17 | 18 | liveDataExpectedOutput <- sqrt(liveData) 19 | colnames(liveDataExpectedOutput) <- "yExpected" 20 | 21 | #Pass the data through the network 22 | results <- compute(rneatsim,liveData) 23 | 24 | #Calculate the difference between yPred the neural network output, and yExpected the actual square root of the input 25 | error <- liveDataExpectedOutput[,"yExpected"] - results[,"yPred"] 26 | results <- cbind(results,liveDataExpectedOutput,error) 27 | print(results) 28 | 29 | dev.new() 30 | layout(matrix(c(3,3,3,1,4,2), 2, 3, byrow = TRUE),heights=c(1,2)) 31 | plot(x=results[,"x"],y=results[,"yExpected"],type="l", main="Neural Network y=sqrt(x) expected vs predicted",xlab="x",ylab="y") 32 | lines(x=results[,"x"],y=results[,"yPred"],col="red",type="l") 33 | legend(x='bottomright', c('yExpected','yPredicted'), col=c("black","red"), fill=1:2, bty='n') 34 | plot(rneatsim) 35 | plot(rneatsim$simulation) 36 | 37 | -------------------------------------------------------------------------------- /man/compute.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/neatFormula.R 3 | \name{compute} 4 | \alias{compute} 5 | \title{Takes a pool of trained neural networks, selects the most fit and uses it to predict the depend variable from the input data} 6 | \usage{ 7 | compute(rneatsim, data) 8 | } 9 | \arguments{ 10 | \item{rneatsim}{Is the class rneatneuralnet created using rneatneuralnet function} 11 | 12 | \item{data}{is input data} 13 | } 14 | \value{ 15 | data.frame class with predicted dependent variable 16 | } 17 | \description{ 18 | Takes a pool of trained neural networks, selects the most fit and uses it to predict the depend variable from the input data 19 | } 20 | \examples{ 21 | 22 | #Generate traing data y = sqrt(x) 23 | trainingData <- as.data.frame(cbind(sqrt(seq(0.1,1,0.1)),seq(0.1,1,0.1))) 24 | colnames(trainingData) <- c("y","x") 25 | 26 | #Train the neural network for 5 generations, and plot the fitness 27 | rneatsim <- rneatneuralnet(y~x,trainingData,5) 28 | plot(rneatsim) 29 | 30 | #Continue training the network for another 5 generations 31 | rneatsim <- rneatneuralnetcontinuetraining(rneatsim,5) 32 | plot(rneatsim) 33 | 34 | #Construct some fresh data to stick through the neural network and hopefully get square rooted 35 | liveData <- as.data.frame(seq(0.1,1,0.01)) 36 | colnames(liveData) <- c("x") 37 | 38 | liveDataExpectedOutput <- sqrt(liveData) 39 | colnames(liveDataExpectedOutput) <- "yExpected" 40 | 41 | #Pass the data through the network 42 | results <- compute(rneatsim,liveData) 43 | 44 | #Calculate the difference between yPred the neural network output, and yExpected the actual square root of the input 45 | error <- liveDataExpectedOutput[,"yExpected"] - results[,"yPred"] 46 | results <- cbind(results,liveDataExpectedOutput,error) 47 | print(results) 48 | 49 | dev.new() 50 | layout(matrix(c(3,3,3,1,4,2), 2, 3, byrow = TRUE),heights=c(1,2)) 51 | plot(x=results[,"x"],y=results[,"yExpected"],type="l", main="Neural Network y=sqrt(x) expected vs predicted",xlab="x",ylab="y") 52 | lines(x=results[,"x"],y=results[,"yPred"],col="red",type="l") 53 | legend(x='bottomright', c('yExpected','yPredicted'), col=c("black","red"), fill=1:2, bty='n') 54 | plot(rneatsim) 55 | plot(rneatsim$simulation) 56 | 57 | } 58 | 59 | -------------------------------------------------------------------------------- /man/rneatneuralnetcontinuetraining.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/neatFormula.R 3 | \name{rneatneuralnetcontinuetraining} 4 | \alias{rneatneuralnetcontinuetraining} 5 | \title{Continues the training of the neural networks / runs more generations} 6 | \usage{ 7 | rneatneuralnetcontinuetraining(rneatsim, nTrainingGenerations) 8 | } 9 | \arguments{ 10 | \item{rneatsim}{Is the class rneatneuralnet created using rneatneuralnet function} 11 | 12 | \item{nTrainingGenerations}{Number of new generations to train} 13 | } 14 | \value{ 15 | rneatneuralnet class with pool of genomes and training data 16 | } 17 | \description{ 18 | Continues the training of the neural networks / runs more generations 19 | } 20 | \examples{ 21 | 22 | #Generate traing data y = sqrt(x) 23 | trainingData <- as.data.frame(cbind(sqrt(seq(0.1,1,0.1)),seq(0.1,1,0.1))) 24 | colnames(trainingData) <- c("y","x") 25 | 26 | #Train the neural network for 5 generations, and plot the fitness 27 | rneatsim <- rneatneuralnet(y~x,trainingData,5) 28 | plot(rneatsim) 29 | 30 | #Continue training the network for another 5 generations 31 | rneatsim <- rneatneuralnetcontinuetraining(rneatsim,5) 32 | plot(rneatsim) 33 | 34 | #Construct some fresh data to stick through the neural network and hopefully get square rooted 35 | liveData <- as.data.frame(seq(0.1,1,0.01)) 36 | colnames(liveData) <- c("x") 37 | 38 | liveDataExpectedOutput <- sqrt(liveData) 39 | colnames(liveDataExpectedOutput) <- "yExpected" 40 | 41 | #Pass the data through the network 42 | results <- compute(rneatsim,liveData) 43 | 44 | #Calculate the difference between yPred the neural network output, and yExpected the actual square root of the input 45 | error <- liveDataExpectedOutput[,"yExpected"] - results[,"yPred"] 46 | results <- cbind(results,liveDataExpectedOutput,error) 47 | print(results) 48 | 49 | dev.new() 50 | layout(matrix(c(3,3,3,1,4,2), 2, 3, byrow = TRUE),heights=c(1,2)) 51 | plot(x=results[,"x"],y=results[,"yExpected"],type="l", main="Neural Network y=sqrt(x) expected vs predicted",xlab="x",ylab="y") 52 | lines(x=results[,"x"],y=results[,"yPred"],col="red",type="l") 53 | legend(x='bottomright', c('yExpected','yPredicted'), col=c("black","red"), fill=1:2, bty='n') 54 | plot(rneatsim) 55 | plot(rneatsim$simulation) 56 | 57 | } 58 | 59 | -------------------------------------------------------------------------------- /man/rneatneuralnet.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/neatFormula.R 3 | \name{rneatneuralnet} 4 | \alias{rneatneuralnet} 5 | \title{Create a new pool of neural networks trained using the NEAT algorithm using formula notation} 6 | \usage{ 7 | rneatneuralnet(formula, trainingData, nTrainingGenerations = 10, 8 | maxNumberOfNodes = 500, speciesPopulation = 200) 9 | } 10 | \arguments{ 11 | \item{formula}{specifies the dependent and explantory varibles using a formula} 12 | 13 | \item{trainingData}{Is the data used to train the networks} 14 | 15 | \item{nTrainingGenerations}{Number of generations / breeding cycles to use in the genetic mating} 16 | 17 | \item{maxNumberOfNodes}{The maximum number of neural network nodes} 18 | 19 | \item{speciesPopulation}{The maximum bumber of species} 20 | } 21 | \value{ 22 | rneatneuralnet class with pool of genomes and training data 23 | } 24 | \description{ 25 | Create a new pool of neural networks trained using the NEAT algorithm using formula notation 26 | } 27 | \examples{ 28 | 29 | #Generate traing data y = sqrt(x) 30 | trainingData <- as.data.frame(cbind(sqrt(seq(0.1,1,0.1)),seq(0.1,1,0.1))) 31 | colnames(trainingData) <- c("y","x") 32 | 33 | #Train the neural network for 5 generations, and plot the fitness 34 | rneatsim <- rneatneuralnet(y~x,trainingData,5) 35 | plot(rneatsim) 36 | 37 | #Continue training the network for another 5 generations 38 | rneatsim <- rneatneuralnetcontinuetraining(rneatsim,5) 39 | plot(rneatsim) 40 | 41 | #Construct some fresh data to stick through the neural network and hopefully get square rooted 42 | liveData <- as.data.frame(seq(0.1,1,0.01)) 43 | colnames(liveData) <- c("x") 44 | 45 | liveDataExpectedOutput <- sqrt(liveData) 46 | colnames(liveDataExpectedOutput) <- "yExpected" 47 | 48 | #Pass the data through the network 49 | results <- compute(rneatsim,liveData) 50 | 51 | #Calculate the difference between yPred the neural network output, and yExpected the actual square root of the input 52 | error <- liveDataExpectedOutput[,"yExpected"] - results[,"yPred"] 53 | results <- cbind(results,liveDataExpectedOutput,error) 54 | print(results) 55 | 56 | dev.new() 57 | layout(matrix(c(3,3,3,1,4,2), 2, 3, byrow = TRUE),heights=c(1,2)) 58 | plot(x=results[,"x"],y=results[,"yExpected"],type="l", main="Neural Network y=sqrt(x) expected vs predicted",xlab="x",ylab="y") 59 | lines(x=results[,"x"],y=results[,"yPred"],col="red",type="l") 60 | legend(x='bottomright', c('yExpected','yPredicted'), col=c("black","red"), fill=1:2, bty='n') 61 | plot(rneatsim) 62 | plot(rneatsim$simulation) 63 | 64 | } 65 | 66 | -------------------------------------------------------------------------------- /R/Examples/polebalance.R: -------------------------------------------------------------------------------- 1 | 2 | drawPoleFunc <- function(fixedEnd.x,fixedEnd.y,poleLength, theta, 3 | fillColour=NA, borderColour="black"){ 4 | floatingEnd.x <- fixedEnd.x-poleLength * sin(theta) 5 | floatingEnd.y <- fixedEnd.y+poleLength * cos(theta) 6 | 7 | polygon(c(fixedEnd.x,floatingEnd.x,floatingEnd.x,fixedEnd.x), 8 | c(fixedEnd.y,floatingEnd.y,floatingEnd.y,fixedEnd.y), 9 | col = fillColour, border=borderColour) 10 | } 11 | 12 | drawPendulum <- function(fixedEnd.x,fixedEnd.y,poleLength, theta, 13 | radius,fillColour=NA, borderColour="black"){ 14 | floatingEnd.x <- fixedEnd.x-poleLength * sin(theta) 15 | floatingEnd.y <- fixedEnd.y+poleLength * cos(theta) 16 | createCircleFunc(floatingEnd.x,floatingEnd.y,radius,fillColour,borderColour) 17 | } 18 | 19 | #Parameters to control the simulation 20 | simulation.timestep = 0.005 21 | simulation.gravity = 9.8 #meters per second^2 22 | simulation.numoftimesteps = 2000 23 | 24 | pole.length = 1 #meters, total pole length 25 | pole.width = 0.2 26 | pole.theta = pi 27 | pole.thetaDot = 0 28 | pole.thetaDotDot = 0 29 | pole.colour = "purple" 30 | 31 | 32 | pendulum.centerX = NA 33 | pendulum.centerY = NA 34 | pendulum.radius = 0.1 35 | pendulum.mass = 0.1 36 | pendulum.colour = "purple" 37 | 38 | cart.width=0.5 39 | cart.centerX = 0 40 | cart.centerY = 0 41 | cart.height=0.2 42 | cart.colour="red" 43 | cart.centerXDot = 0 44 | cart.centerXDotDot = 0 45 | cart.mass = 0.4 46 | cart.force = 0 47 | cart.mu=2 48 | 49 | 50 | track.limit= 10 #meters from center 51 | track.x = -track.limit 52 | track.height=0.01 53 | track.y = 0.5*track.height 54 | track.colour = "blue" 55 | 56 | leftBuffer.width=0.1 57 | leftBuffer.height=0.2 58 | leftBuffer.x=-track.limit-0.5*cart.width-leftBuffer.width 59 | leftBuffer.y=0.5*leftBuffer.height 60 | leftBuffer.colour = "blue" 61 | 62 | rightBuffer.width=0.1 63 | rightBuffer.height=0.2 64 | rightBuffer.x=track.limit+0.5*cart.width 65 | rightBuffer.y=0.5*rightBuffer.height 66 | rightBuffer.colour = "blue" 67 | 68 | #Define the size of the scene (used to visualise what is happening in the simulation) 69 | scene.width = 2*max(rightBuffer.x+rightBuffer.width,track.limit+pole.length+pendulum.radius) 70 | scene.bottomLeftX = -0.5*scene.width 71 | scene.height=max(pole.length+pendulum.radius,scene.width) 72 | scene.bottomLeftY = -0.5*scene.height 73 | 74 | poleBalance.InitialState <- function(){ 75 | state <- list() 76 | state[1] <- cart.centerX 77 | state[2] <- cart.centerXDot 78 | state[3] <- cart.centerXDotDot 79 | state[4] <- cart.force 80 | state[5] <- pole.theta 81 | state[6] <- pole.thetaDot 82 | state[7] <- pole.thetaDotDot 83 | return(state) 84 | } 85 | 86 | poleBalance.ConvertStateToNeuralNetInputs <- function(currentState){ 87 | return (currentState) 88 | } 89 | 90 | poleBalance.UpdatePoleState <- function(currentState,neuralNetOutputs){ 91 | #print("Updating pole state") 92 | #print(neuralNetOutputs) 93 | cart.centerX <- currentState[[1]] 94 | cart.centerXDot <- currentState[[2]] 95 | cart.centerXDotDot <- currentState[[3]] 96 | cart.force <- currentState[[4]]+neuralNetOutputs[[1]] 97 | pole.theta <- currentState[[5]] 98 | pole.thetaDot <- currentState[[6]] 99 | pole.thetaDotDot <- currentState[[7]] 100 | 101 | costheta = cos(pole.theta) 102 | sintheta = sin(pole.theta) 103 | totalmass = cart.mass+pendulum.mass 104 | masslength = pendulum.mass*pole.length 105 | 106 | pole.thetaDotDot = (simulation.gravity*totalmass*sintheta+costheta* 107 | (cart.force-masslength*pole.thetaDot^2*sintheta-cart.mu*cart.centerXDot))/ 108 | (pole.length*(totalmass-pendulum.mass*costheta^2)) 109 | 110 | cart.centerXDotDot =(cart.force+masslength*(pole.thetaDotDot*costheta-pole.thetaDot^2*sintheta)- 111 | cart.mu*cart.centerXDot)/totalmass 112 | 113 | cart.centerX = cart.centerX+simulation.timestep*cart.centerXDot 114 | cart.centerXDot = cart.centerXDot+simulation.timestep*cart.centerXDotDot 115 | pole.theta = (pole.theta +simulation.timestep*pole.thetaDot ) 116 | pole.thetaDot = pole.thetaDot+simulation.timestep*pole.thetaDotDot 117 | 118 | currentState[1] <- cart.centerX 119 | currentState[2] <- cart.centerXDot 120 | currentState[3] <- cart.centerXDotDot 121 | currentState[4] <- cart.force 122 | currentState[5] <- pole.theta 123 | currentState[6] <- pole.thetaDot 124 | currentState[7] <- pole.thetaDotDot 125 | return (currentState) 126 | } 127 | 128 | 129 | 130 | poleBalance.UpdateFitness <- function(oldState,updatedState,oldFitness){ 131 | #return (oldFitness+1) #fitness is just how long we've ran for 132 | #return (oldFitness+((track.limit-abs(updatedState[[1]]))/track.limit)^2) 133 | #More reward for staying near middle of track 134 | 135 | height <- cos(updatedState[[5]]) #is -ve if below track 136 | heightFitness <- max(height,0) 137 | centerFitness <- (track.limit-abs(updatedState[[1]]))/track.limit 138 | return (oldFitness+(heightFitness + heightFitness*centerFitness)) 139 | } 140 | 141 | poleBalance.CheckForTermination <- function(frameNum,oldState,updatedState,oldFitness,newFitness){ 142 | cart.centerX <- updatedState[[1]] 143 | cart.centerXDot <- updatedState[[2]] 144 | cart.centerXDotDot <- updatedState[[3]] 145 | cart.force <- updatedState[[4]] 146 | pole.theta <- updatedState[[5]] 147 | pole.thetaDot <- updatedState[[6]] 148 | pole.thetaDotDot <- updatedState[[7]] 149 | 150 | oldpole.theta <- oldState[[5]] 151 | if(frameNum > 20000){ 152 | print("Max Frame Num Exceeded , stopping simulation") 153 | return (TRUE) 154 | } 155 | 156 | height <- cos(pole.theta) 157 | oldHeight <- cos(oldpole.theta) 158 | if(height==-1 & cart.force==0){ 159 | return(TRUE) 160 | } 161 | 162 | if(oldHeight >= 0 & height < 0){ 163 | #print("Pole fell over") 164 | return (TRUE) 165 | } 166 | if(cart.centerX < track.x | cart.centerX > (track.x+2*track.limit)){ 167 | #print("Exceeded track length") 168 | return (TRUE) 169 | } else { 170 | return (FALSE) 171 | } 172 | } 173 | 174 | poleBalance.PlotState <-function(updatedState){ 175 | cart.centerX <- updatedState[[1]] 176 | cart.centerXDot <- updatedState[[2]] 177 | cart.centerXDotDot <- updatedState[[3]] 178 | cart.force <- updatedState[[4]] 179 | pole.theta <- updatedState[[5]] 180 | pole.thetaDot <- updatedState[[6]] 181 | pole.thetaDotDot <- updatedState[[7]] 182 | 183 | createSceneFunc(scene.bottomLeftX,scene.bottomLeftY,scene.width,scene.height, 184 | main="Simulation of Inverted Pendulum - www.gekkoquant.com",xlab="", 185 | ylab="",xlim=c(-0.5*scene.width,0.5*scene.width), 186 | ylim=c(-0.5*scene.height,0.5*scene.height)) 187 | 188 | createBoxFunc(track.x,track.y,track.limit*2,track.height,track.colour) 189 | createBoxFunc(leftBuffer.x,leftBuffer.y,leftBuffer.width,leftBuffer.height,leftBuffer.colour) 190 | createBoxFunc(rightBuffer.x,rightBuffer.y,rightBuffer.width, 191 | rightBuffer.height,rightBuffer.colour) 192 | createBoxFunc(cart.centerX-0.5*cart.width,cart.centerY+0.5*cart.height,cart.width,cart.height, 193 | cart.colour) 194 | drawPoleFunc(cart.centerX,cart.centerY,2*pole.length,pole.theta,pole.colour) 195 | drawPendulum(cart.centerX,cart.centerY,2*pole.length,pole.theta,pendulum.radius,pendulum.colour) 196 | 197 | } 198 | 199 | config <- newConfigNEAT(7,1,500,50) 200 | poleSimulation <- newNEATSimulation(config, poleBalance.InitialState, 201 | poleBalance.UpdatePoleState, 202 | poleBalance.ConvertStateToNeuralNetInputs, 203 | poleBalance.UpdateFitness, 204 | poleBalance.CheckForTermination, 205 | poleBalance.PlotState) 206 | 207 | nMax <- 1 #Number of generations to run 208 | for(i in seq(1,nMax)){ 209 | poleSimulation <- NEATSimulation.RunSingleGeneration(poleSimulation) 210 | #poleSimulation <- NEATSimulation.RunSingleGeneration(poleSimulation,T,"videos", 211 | # "poleBalance",1/simulation.timestep) 212 | } 213 | 214 | 215 | 216 | 217 | -------------------------------------------------------------------------------- /vignettes/rneat-vignette.R: -------------------------------------------------------------------------------- 1 | ## ----eval=FALSE---------------------------------------------------------- 2 | # 3 | # drawPoleFunc <- function(fixedEnd.x,fixedEnd.y,poleLength, theta, 4 | # fillColour=NA, borderColour="black"){ 5 | # floatingEnd.x <- fixedEnd.x-poleLength * sin(theta) 6 | # floatingEnd.y <- fixedEnd.y+poleLength * cos(theta) 7 | # 8 | # polygon(c(fixedEnd.x,floatingEnd.x,floatingEnd.x,fixedEnd.x), 9 | # c(fixedEnd.y,floatingEnd.y,floatingEnd.y,fixedEnd.y), 10 | # col = fillColour, border=borderColour) 11 | # } 12 | # 13 | # drawPendulum <- function(fixedEnd.x,fixedEnd.y,poleLength, theta, 14 | # radius,fillColour=NA, borderColour="black"){ 15 | # floatingEnd.x <- fixedEnd.x-poleLength * sin(theta) 16 | # floatingEnd.y <- fixedEnd.y+poleLength * cos(theta) 17 | # createCircleFunc(floatingEnd.x,floatingEnd.y,radius,fillColour,borderColour) 18 | # } 19 | # 20 | # #Parameters to control the simulation 21 | # simulation.timestep = 0.005 22 | # simulation.gravity = 9.8 #meters per second^2 23 | # simulation.numoftimesteps = 2000 24 | # 25 | # pole.length = 1 #meters, total pole length 26 | # pole.width = 0.2 27 | # pole.theta = pi 28 | # pole.thetaDot = 0 29 | # pole.thetaDotDot = 0 30 | # pole.colour = "purple" 31 | # 32 | # 33 | # pendulum.centerX = NA 34 | # pendulum.centerY = NA 35 | # pendulum.radius = 0.1 36 | # pendulum.mass = 0.1 37 | # pendulum.colour = "purple" 38 | # 39 | # cart.width=0.5 40 | # cart.centerX = 0 41 | # cart.centerY = 0 42 | # cart.height=0.2 43 | # cart.colour="red" 44 | # cart.centerXDot = 0 45 | # cart.centerXDotDot = 0 46 | # cart.mass = 0.4 47 | # cart.force = 0 48 | # cart.mu=2 49 | # 50 | # 51 | # track.limit= 10 #meters from center 52 | # track.x = -track.limit 53 | # track.height=0.01 54 | # track.y = 0.5*track.height 55 | # track.colour = "blue" 56 | # 57 | # leftBuffer.width=0.1 58 | # leftBuffer.height=0.2 59 | # leftBuffer.x=-track.limit-0.5*cart.width-leftBuffer.width 60 | # leftBuffer.y=0.5*leftBuffer.height 61 | # leftBuffer.colour = "blue" 62 | # 63 | # rightBuffer.width=0.1 64 | # rightBuffer.height=0.2 65 | # rightBuffer.x=track.limit+0.5*cart.width 66 | # rightBuffer.y=0.5*rightBuffer.height 67 | # rightBuffer.colour = "blue" 68 | # 69 | # #Define the size of the scene (used to visualise what is happening in the simulation) 70 | # scene.width = 2*max(rightBuffer.x+rightBuffer.width,track.limit+pole.length+pendulum.radius) 71 | # scene.bottomLeftX = -0.5*scene.width 72 | # scene.height=max(pole.length+pendulum.radius,scene.width) 73 | # scene.bottomLeftY = -0.5*scene.height 74 | # 75 | # poleBalance.InitialState <- function(){ 76 | # state <- list() 77 | # state[1] <- cart.centerX 78 | # state[2] <- cart.centerXDot 79 | # state[3] <- cart.centerXDotDot 80 | # state[4] <- cart.force 81 | # state[5] <- pole.theta 82 | # state[6] <- pole.thetaDot 83 | # state[7] <- pole.thetaDotDot 84 | # return(state) 85 | # } 86 | # 87 | # poleBalance.ConvertStateToNeuralNetInputs <- function(currentState){ 88 | # return (currentState) 89 | # } 90 | # 91 | # poleBalance.UpdatePoleState <- function(currentState,neuralNetOutputs){ 92 | # #print("Updating pole state") 93 | # #print(neuralNetOutputs) 94 | # cart.centerX <- currentState[[1]] 95 | # cart.centerXDot <- currentState[[2]] 96 | # cart.centerXDotDot <- currentState[[3]] 97 | # cart.force <- currentState[[4]]+neuralNetOutputs[[1]] 98 | # pole.theta <- currentState[[5]] 99 | # pole.thetaDot <- currentState[[6]] 100 | # pole.thetaDotDot <- currentState[[7]] 101 | # 102 | # costheta = cos(pole.theta) 103 | # sintheta = sin(pole.theta) 104 | # totalmass = cart.mass+pendulum.mass 105 | # masslength = pendulum.mass*pole.length 106 | # 107 | # pole.thetaDotDot = (simulation.gravity*totalmass*sintheta+costheta* 108 | # (cart.force-masslength*pole.thetaDot^2*sintheta-cart.mu*cart.centerXDot))/ 109 | # (pole.length*(totalmass-pendulum.mass*costheta^2)) 110 | # 111 | # cart.centerXDotDot =(cart.force+masslength*(pole.thetaDotDot*costheta-pole.thetaDot^2*sintheta)- 112 | # cart.mu*cart.centerXDot)/totalmass 113 | # 114 | # cart.centerX = cart.centerX+simulation.timestep*cart.centerXDot 115 | # cart.centerXDot = cart.centerXDot+simulation.timestep*cart.centerXDotDot 116 | # pole.theta = (pole.theta +simulation.timestep*pole.thetaDot ) 117 | # pole.thetaDot = pole.thetaDot+simulation.timestep*pole.thetaDotDot 118 | # 119 | # currentState[1] <- cart.centerX 120 | # currentState[2] <- cart.centerXDot 121 | # currentState[3] <- cart.centerXDotDot 122 | # currentState[4] <- cart.force 123 | # currentState[5] <- pole.theta 124 | # currentState[6] <- pole.thetaDot 125 | # currentState[7] <- pole.thetaDotDot 126 | # return (currentState) 127 | # } 128 | # 129 | # 130 | # 131 | # poleBalance.UpdateFitness <- function(oldState,updatedState,oldFitness){ 132 | # #return (oldFitness+1) #fitness is just how long we've ran for 133 | # #return (oldFitness+((track.limit-abs(updatedState[[1]]))/track.limit)^2) 134 | # #More reward for staying near middle of track 135 | # 136 | # height <- cos(updatedState[[5]]) #is -ve if below track 137 | # heightFitness <- max(height,0) 138 | # centerFitness <- (track.limit-abs(updatedState[[1]]))/track.limit 139 | # return (oldFitness+(heightFitness + heightFitness*centerFitness)) 140 | # } 141 | # 142 | # poleBalance.CheckForTermination <- function(frameNum,oldState,updatedState,oldFitness,newFitness){ 143 | # cart.centerX <- updatedState[[1]] 144 | # cart.centerXDot <- updatedState[[2]] 145 | # cart.centerXDotDot <- updatedState[[3]] 146 | # cart.force <- updatedState[[4]] 147 | # pole.theta <- updatedState[[5]] 148 | # pole.thetaDot <- updatedState[[6]] 149 | # pole.thetaDotDot <- updatedState[[7]] 150 | # 151 | # oldpole.theta <- oldState[[5]] 152 | # if(frameNum > 20000){ 153 | # print("Max Frame Num Exceeded , stopping simulation") 154 | # return (TRUE) 155 | # } 156 | # 157 | # height <- cos(pole.theta) 158 | # oldHeight <- cos(oldpole.theta) 159 | # if(height==-1 & cart.force==0){ 160 | # return(TRUE) 161 | # } 162 | # 163 | # if(oldHeight >= 0 & height < 0){ 164 | # #print("Pole fell over") 165 | # return (TRUE) 166 | # } 167 | # if(cart.centerX < track.x | cart.centerX > (track.x+2*track.limit)){ 168 | # #print("Exceeded track length") 169 | # return (TRUE) 170 | # } else { 171 | # return (FALSE) 172 | # } 173 | # } 174 | # 175 | # poleBalance.PlotState <-function(updatedState){ 176 | # cart.centerX <- updatedState[[1]] 177 | # cart.centerXDot <- updatedState[[2]] 178 | # cart.centerXDotDot <- updatedState[[3]] 179 | # cart.force <- updatedState[[4]] 180 | # pole.theta <- updatedState[[5]] 181 | # pole.thetaDot <- updatedState[[6]] 182 | # pole.thetaDotDot <- updatedState[[7]] 183 | # 184 | # createSceneFunc(scene.bottomLeftX,scene.bottomLeftY,scene.width,scene.height, 185 | # main="Simulation of Inverted Pendulum - www.gekkoquant.com",xlab="", 186 | # ylab="",xlim=c(-0.5*scene.width,0.5*scene.width), 187 | # ylim=c(-0.5*scene.height,0.5*scene.height)) 188 | # 189 | # createBoxFunc(track.x,track.y,track.limit*2,track.height,track.colour) 190 | # createBoxFunc(leftBuffer.x,leftBuffer.y,leftBuffer.width,leftBuffer.height,leftBuffer.colour) 191 | # createBoxFunc(rightBuffer.x,rightBuffer.y,rightBuffer.width, 192 | # rightBuffer.height,rightBuffer.colour) 193 | # createBoxFunc(cart.centerX-0.5*cart.width,cart.centerY+0.5*cart.height,cart.width,cart.height, 194 | # cart.colour) 195 | # drawPoleFunc(cart.centerX,cart.centerY,2*pole.length,pole.theta,pole.colour) 196 | # drawPendulum(cart.centerX,cart.centerY,2*pole.length,pole.theta,pendulum.radius,pendulum.colour) 197 | # 198 | # } 199 | # 200 | # config <- newConfigNEAT(7,1,500,50) 201 | # poleSimulation <- newNEATSimulation(config, poleBalance.InitialState, 202 | # poleBalance.UpdatePoleState, 203 | # poleBalance.ConvertStateToNeuralNetInputs, 204 | # poleBalance.UpdateFitness, 205 | # poleBalance.CheckForTermination, 206 | # poleBalance.PlotState) 207 | # 208 | # nMax <- 1 #Number of generations to run 209 | # for(i in seq(1,nMax)){ 210 | # poleSimulation <- NEATSimulation.RunSingleGeneration(poleSimulation) 211 | # #poleSimulation <- NEATSimulation.RunSingleGeneration(poleSimulation,T,"videos", 212 | # # "poleBalance",1/simulation.timestep) 213 | # } 214 | # 215 | # 216 | # 217 | # 218 | # 219 | 220 | -------------------------------------------------------------------------------- /R/neatFormula.R: -------------------------------------------------------------------------------- 1 | #' Create a new pool of neural networks trained using the NEAT algorithm using formula notation 2 | #' 3 | #' @param formula specifies the dependent and explantory varibles using a formula 4 | #' @param trainingData Is the data used to train the networks 5 | #' @param nTrainingGenerations Number of generations / breeding cycles to use in the genetic mating 6 | #' @param maxNumberOfNodes The maximum number of neural network nodes 7 | #' @param speciesPopulation The maximum bumber of species 8 | #' @return rneatneuralnet class with pool of genomes and training data 9 | #' @example R/Examples/squareRoot.R 10 | #' @export 11 | rneatneuralnet <- function(formula,trainingData,nTrainingGenerations=10,maxNumberOfNodes = 500, speciesPopulation = 200){ 12 | result <- varify.variables(formula,trainingData,nTrainingGenerations,maxNumberOfNodes,speciesPopulation) 13 | 14 | config<-newConfigNEAT(length(result$model.list$variables),length(result$model.list$response),result$maxNumberOfNodes,result$speciesPopulation) 15 | neatSim <- newNEATFormulaSimulation(config) 16 | 17 | rneatsim <- list(inputs=result,neatConfig=config,simulation=neatSim) 18 | class(rneatsim) <- "rneatneuralnet" 19 | return (rneatneuralnetcontinuetraining(rneatsim,nTrainingGenerations)) 20 | } 21 | 22 | #' Continues the training of the neural networks / runs more generations 23 | #' 24 | #' @param rneatsim Is the class rneatneuralnet created using rneatneuralnet function 25 | #' @param nTrainingGenerations Number of new generations to train 26 | #' @example R/Examples/squareRoot.R 27 | #' @return rneatneuralnet class with pool of genomes and training data 28 | #' @export 29 | rneatneuralnetcontinuetraining <- function(rneatsim,nTrainingGenerations){ 30 | assertTrueFunc(is(rneatsim,"rneatneuralnet"),"rneatsim must be a of class rneatneuralnet") 31 | for(i in seq(1,nTrainingGenerations)){ 32 | rneatsim <- NEATFormulaSimulation.RunSingleGeneration(rneatsim) 33 | } 34 | return(rneatsim) 35 | } 36 | 37 | varify.variables <- function (formula,trainingData,nTrainingGenerations,maxNumberOfNodes,speciesPopulation){ 38 | if (is.null(trainingData)) 39 | stop("'trainingData' is missing", call. = FALSE) 40 | if (is.null(formula)) 41 | stop("'formula' is missing", call. = FALSE) 42 | if(is.null(nTrainingGenerations) || !is.numeric(nTrainingGenerations)){ 43 | nTrainingGenerations <- 10 44 | } 45 | if(is.null(maxNumberOfNodes) || !is.numeric(maxNumberOfNodes)){ 46 | maxNumberOfNodes <- 500 47 | } 48 | if(is.null(speciesPopulation) || !is.numeric(speciesPopulation)){ 49 | speciesPopulation <- 200 50 | } 51 | 52 | trainingData <- as.data.frame(trainingData) 53 | formula <- as.formula(formula) 54 | model.vars <- attr(terms(formula), "term.labels") 55 | formula.reverse <- formula 56 | formula.reverse[[3]] <- formula[[2]] 57 | model.resp <- attr(terms(formula.reverse), "term.labels") 58 | model.list <- list(response = model.resp, variables = model.vars) 59 | 60 | formulaNames <- c(model.list$response,model.list$variables) 61 | trainingDataInNames <- colnames(trainingData) 62 | missingtrainingData <- formulaNames[!formulaNames %in% trainingDataInNames] 63 | if(length(missingtrainingData)!=0){ 64 | stop(paste("The formula requests variables '",toString(missingtrainingData),"' not present in the input trainingData", call. = FALSE)) 65 | } 66 | return(list(trainingData = trainingData, formula = formula,model.list=model.list,nTrainingGenerations=nTrainingGenerations,maxNumberOfNodes=maxNumberOfNodes,speciesPopulation=speciesPopulation)) 67 | } 68 | 69 | 70 | #' Takes a pool of trained neural networks, selects the most fit and uses it to predict the depend variable from the input data 71 | #' 72 | #' @param rneatsim Is the class rneatneuralnet created using rneatneuralnet function 73 | #' @param data is input data 74 | #' @example R/Examples/squareRoot.R 75 | #' @return data.frame class with predicted dependent variable 76 | #' @export 77 | compute <- function(rneatsim,data){ 78 | result <- varify.compute.variables(rneatsim,data) 79 | genome <- findMostFitGenome(result$rneatsim$simulation) 80 | genome <- generateNetwork(genome,rneatsim$simulation$Config) 81 | 82 | nnetInputData <- as.data.frame(result$data[,result$rneatsim$inputs$model.list$variables]) 83 | colnames(nnetInputData) <- result$rneatsim$inputs$model.list$variables 84 | nnetOutput <- t(as.data.frame(apply(nnetInputData,1,function(x) { evaluateNetwork(genome$Network,x,result$rneatsim$simulation$Config) }))) 85 | colnames(nnetOutput) <- paste(result$rneatsim$inputs$model.list$response,"Pred",sep="") 86 | res <- cbind(nnetInputData,nnetOutput) 87 | rownames(res) <- rownames(result$data) 88 | return(res) 89 | } 90 | 91 | varify.compute.variables <- function(rneatsim,data){ 92 | assertTrueFunc(is(rneatsim,"rneatneuralnet"),"rneatsim must be a of class rneatneuralnet") 93 | 94 | formulaNames <- c(rneatsim$model.list$response,rneatsim$model.list$variables) 95 | dataInNames <- colnames(data) 96 | missingDataNames <- formulaNames[!formulaNames %in% dataInNames] 97 | if(length(missingDataNames)!=0){ 98 | stop(paste("The formula requests variables '",toString(missingDataNames),"' not present in the input data", call. = FALSE)) 99 | } 100 | return(list(rneatsim=rneatsim,data=as.data.frame(data))) 101 | } 102 | 103 | findMostFitGenome <- function(simulation){ 104 | maxFitness <- -Inf 105 | maxFitnessGenome <- NA 106 | for(i in seq(1,length(simulation$Pool$species))){ 107 | if(length(simulation$Pool$species[[i]]$genomes) > 0){ 108 | for(j in seq(1,length(simulation$Pool$species[[i]]$genomes))){ 109 | fitness <- simulation$Pool$species[[i]]$genomes[[j]]$Fitness 110 | if(fitness > maxFitness){ 111 | maxFitness <- fitness 112 | maxFitnessGenome <-simulation$Pool$species[[i]]$genomes[[j]] 113 | } 114 | } 115 | } 116 | } 117 | return(maxFitnessGenome) 118 | } 119 | 120 | newNEATFormulaSimulation <- function(neatConfig){ 121 | performanceTracker <- data.frame(generation=numeric(),minFitness=numeric(),maxFitness=numeric(),meanFitness=numeric(),medianFitness=numeric(),stringsAsFactors=FALSE) 122 | res <- list(Config=neatConfig,Pool=initialisePool(neatConfig),PerformanceTracker=performanceTracker) 123 | class(res) <- "NEATFormulaSimulation" 124 | return(res) 125 | } 126 | 127 | NEATFormulaSimulation.RunSingleGeneration <- function(rneatsim){ 128 | assertTrueFunc(is(rneatsim,"rneatneuralnet"),"rneatsim must be a of class rneatneuralnet") 129 | counter <- 1 130 | nTot <- calcTotalNumOfGenomes(rneatsim$simulation) 131 | for(i in seq(1,length(rneatsim$simulation$Pool$species))){ 132 | for(j in seq(1,length(rneatsim$simulation$Pool$species[[i]]$genomes))){ 133 | rneatsim$simulation <- simulationFormulaRunner(rneatsim$simulation,i,j,100*counter/nTot,rneatsim$inputs$trainingData,rneatsim$inputs$model.list) 134 | counter <- counter + 1 135 | } 136 | } 137 | rneatsim$simulation$Pool <- newGeneration(rneatsim$simulation$Pool,rneatsim$simulation$Config) 138 | #print(paste("MaxFitness:",simulation$Pool$maxFitness)) 139 | 140 | rneatsim$simulation$PerformanceTracker[rneatsim$simulation$Pool$generation,] <- c(rneatsim$simulation$Pool$generation,rneatsim$simulation$Pool$minFitness,rneatsim$simulation$Pool$maxFitness,rneatsim$simulation$Pool$meanFitness,rneatsim$simulation$Pool$medianFitness) 141 | print(rneatsim$simulation$PerformanceTracker[rneatsim$simulation$Pool$generation,]) 142 | return (rneatsim) 143 | } 144 | 145 | 146 | simulationFormulaRunner <- function(simulation,speciesNum,genomeNum,pctSimulated,data,model.list){ 147 | i<-speciesNum 148 | j <-genomeNum 149 | if(length(simulation$Pool$species[[i]]$genomes[[j]]$ConnectionGenes)>0){ 150 | 151 | simulation$Pool$species[[i]]$genomes[[j]] <- generateNetwork(simulation$Pool$species[[i]]$genomes[[j]],simulation$Config) 152 | simulation$Pool$species[[i]]$genomes[[j]]$Fitness <- 0 153 | 154 | nnetInputData <- as.data.frame(data[,model.list$variables]) 155 | nnetTargetOutputData <- as.data.frame(data[,model.list$response]) 156 | #print(model.list$variables) 157 | #print(nnetInputData) 158 | nnetOutput <- t(as.data.frame(apply(nnetInputData,1,function(x) { evaluateNetwork(simulation$Pool$species[[i]]$genomes[[j]]$Network,x,simulation$Config) }))) 159 | outsum <- cbind(nnetTargetOutputData,nnetOutput) 160 | #print(outsum) 161 | mse <- sum((nnetTargetOutputData - nnetOutput)^2) 162 | updatedFitness<-1/mse 163 | #print(paste("mse",mse,"fitness",updatedFitness)) 164 | 165 | simulation$Pool$species[[i]]$genomes[[j]]$Fitness <- updatedFitness 166 | print(paste(round(pctSimulated,2),"% Finished simulation of species",i,"/",length(simulation$Pool$species),"genome",j,"/",length(simulation$Pool$species[[i]]$genomes),"with fitness",updatedFitness,"mse",mse)) 167 | #print(paste(round(pctSimulated,2),"% Finished simulation of species",i,"genome",j,"with fitness",updatedFitness)) 168 | } else { 169 | print(paste("Skipped simulation of species",i,"genome",j,"due to no connection genes")) 170 | } 171 | 172 | return(simulation) 173 | } 174 | 175 | #' @export 176 | plot.rneatneuralnet <- function(data){ 177 | plotPerformanceTracker(data$simulation$PerformanceTracker) 178 | } 179 | 180 | #' @export 181 | plot.NEATFormulaSimulation <- function(data){ 182 | genome <- findMostFitGenome(data) 183 | drawGenotypeNEAT(genome,data$Config) 184 | drawPhenotypeNEAT(genome,data$Config) 185 | } 186 | -------------------------------------------------------------------------------- /man/newNEATSimulation.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/neat.R 3 | \name{newNEATSimulation} 4 | \alias{newNEATSimulation} 5 | \title{Create a new NEAT Simulation which contains the pool of species and genomes} 6 | \usage{ 7 | newNEATSimulation(neatConfig, processInitialStateFunc, processUpdateStateFunc, 8 | processStateToNeuralInputFunc, fitnessUpdateFunc, terminationCheckFunc, 9 | plotStateFunc) 10 | } 11 | \arguments{ 12 | \item{neatConfig}{Takes a NEATConfig class} 13 | 14 | \item{processInitialStateFunc}{A function that specifies the initial condition (state) of the system} 15 | 16 | \item{processUpdateStateFunc}{A function that takes the current system state and updates the state} 17 | 18 | \item{processStateToNeuralInputFunc}{A function that takes the current state and converts it to neural net input} 19 | 20 | \item{fitnessUpdateFunc}{A function that takes the current fitness level, old state and new state and returns the new fitness} 21 | 22 | \item{terminationCheckFunc}{A function that returns TRUE if the simulation should be terminated} 23 | 24 | \item{plotStateFunc}{A function that will plot what the current state is} 25 | } 26 | \value{ 27 | NEATSimulation class with new pool of genomes 28 | } 29 | \description{ 30 | Create a new NEAT Simulation which contains the pool of species and genomes 31 | } 32 | \examples{ 33 | 34 | drawPoleFunc <- function(fixedEnd.x,fixedEnd.y,poleLength, theta, 35 | fillColour=NA, borderColour="black"){ 36 | floatingEnd.x <- fixedEnd.x-poleLength * sin(theta) 37 | floatingEnd.y <- fixedEnd.y+poleLength * cos(theta) 38 | 39 | polygon(c(fixedEnd.x,floatingEnd.x,floatingEnd.x,fixedEnd.x), 40 | c(fixedEnd.y,floatingEnd.y,floatingEnd.y,fixedEnd.y), 41 | col = fillColour, border=borderColour) 42 | } 43 | 44 | drawPendulum <- function(fixedEnd.x,fixedEnd.y,poleLength, theta, 45 | radius,fillColour=NA, borderColour="black"){ 46 | floatingEnd.x <- fixedEnd.x-poleLength * sin(theta) 47 | floatingEnd.y <- fixedEnd.y+poleLength * cos(theta) 48 | createCircleFunc(floatingEnd.x,floatingEnd.y,radius,fillColour,borderColour) 49 | } 50 | 51 | #Parameters to control the simulation 52 | simulation.timestep = 0.005 53 | simulation.gravity = 9.8 #meters per second^2 54 | simulation.numoftimesteps = 2000 55 | 56 | pole.length = 1 #meters, total pole length 57 | pole.width = 0.2 58 | pole.theta = pi 59 | pole.thetaDot = 0 60 | pole.thetaDotDot = 0 61 | pole.colour = "purple" 62 | 63 | 64 | pendulum.centerX = NA 65 | pendulum.centerY = NA 66 | pendulum.radius = 0.1 67 | pendulum.mass = 0.1 68 | pendulum.colour = "purple" 69 | 70 | cart.width=0.5 71 | cart.centerX = 0 72 | cart.centerY = 0 73 | cart.height=0.2 74 | cart.colour="red" 75 | cart.centerXDot = 0 76 | cart.centerXDotDot = 0 77 | cart.mass = 0.4 78 | cart.force = 0 79 | cart.mu=2 80 | 81 | 82 | track.limit= 10 #meters from center 83 | track.x = -track.limit 84 | track.height=0.01 85 | track.y = 0.5*track.height 86 | track.colour = "blue" 87 | 88 | leftBuffer.width=0.1 89 | leftBuffer.height=0.2 90 | leftBuffer.x=-track.limit-0.5*cart.width-leftBuffer.width 91 | leftBuffer.y=0.5*leftBuffer.height 92 | leftBuffer.colour = "blue" 93 | 94 | rightBuffer.width=0.1 95 | rightBuffer.height=0.2 96 | rightBuffer.x=track.limit+0.5*cart.width 97 | rightBuffer.y=0.5*rightBuffer.height 98 | rightBuffer.colour = "blue" 99 | 100 | #Define the size of the scene (used to visualise what is happening in the simulation) 101 | scene.width = 2*max(rightBuffer.x+rightBuffer.width,track.limit+pole.length+pendulum.radius) 102 | scene.bottomLeftX = -0.5*scene.width 103 | scene.height=max(pole.length+pendulum.radius,scene.width) 104 | scene.bottomLeftY = -0.5*scene.height 105 | 106 | poleBalance.InitialState <- function(){ 107 | state <- list() 108 | state[1] <- cart.centerX 109 | state[2] <- cart.centerXDot 110 | state[3] <- cart.centerXDotDot 111 | state[4] <- cart.force 112 | state[5] <- pole.theta 113 | state[6] <- pole.thetaDot 114 | state[7] <- pole.thetaDotDot 115 | return(state) 116 | } 117 | 118 | poleBalance.ConvertStateToNeuralNetInputs <- function(currentState){ 119 | return (currentState) 120 | } 121 | 122 | poleBalance.UpdatePoleState <- function(currentState,neuralNetOutputs){ 123 | #print("Updating pole state") 124 | #print(neuralNetOutputs) 125 | cart.centerX <- currentState[[1]] 126 | cart.centerXDot <- currentState[[2]] 127 | cart.centerXDotDot <- currentState[[3]] 128 | cart.force <- currentState[[4]]+neuralNetOutputs[[1]] 129 | pole.theta <- currentState[[5]] 130 | pole.thetaDot <- currentState[[6]] 131 | pole.thetaDotDot <- currentState[[7]] 132 | 133 | costheta = cos(pole.theta) 134 | sintheta = sin(pole.theta) 135 | totalmass = cart.mass+pendulum.mass 136 | masslength = pendulum.mass*pole.length 137 | 138 | pole.thetaDotDot = (simulation.gravity*totalmass*sintheta+costheta* 139 | (cart.force-masslength*pole.thetaDot^2*sintheta-cart.mu*cart.centerXDot))/ 140 | (pole.length*(totalmass-pendulum.mass*costheta^2)) 141 | 142 | cart.centerXDotDot =(cart.force+masslength*(pole.thetaDotDot*costheta-pole.thetaDot^2*sintheta)- 143 | cart.mu*cart.centerXDot)/totalmass 144 | 145 | cart.centerX = cart.centerX+simulation.timestep*cart.centerXDot 146 | cart.centerXDot = cart.centerXDot+simulation.timestep*cart.centerXDotDot 147 | pole.theta = (pole.theta +simulation.timestep*pole.thetaDot ) 148 | pole.thetaDot = pole.thetaDot+simulation.timestep*pole.thetaDotDot 149 | 150 | currentState[1] <- cart.centerX 151 | currentState[2] <- cart.centerXDot 152 | currentState[3] <- cart.centerXDotDot 153 | currentState[4] <- cart.force 154 | currentState[5] <- pole.theta 155 | currentState[6] <- pole.thetaDot 156 | currentState[7] <- pole.thetaDotDot 157 | return (currentState) 158 | } 159 | 160 | 161 | 162 | poleBalance.UpdateFitness <- function(oldState,updatedState,oldFitness){ 163 | #return (oldFitness+1) #fitness is just how long we've ran for 164 | #return (oldFitness+((track.limit-abs(updatedState[[1]]))/track.limit)^2) 165 | #More reward for staying near middle of track 166 | 167 | height <- cos(updatedState[[5]]) #is -ve if below track 168 | heightFitness <- max(height,0) 169 | centerFitness <- (track.limit-abs(updatedState[[1]]))/track.limit 170 | return (oldFitness+(heightFitness + heightFitness*centerFitness)) 171 | } 172 | 173 | poleBalance.CheckForTermination <- function(frameNum,oldState,updatedState,oldFitness,newFitness){ 174 | cart.centerX <- updatedState[[1]] 175 | cart.centerXDot <- updatedState[[2]] 176 | cart.centerXDotDot <- updatedState[[3]] 177 | cart.force <- updatedState[[4]] 178 | pole.theta <- updatedState[[5]] 179 | pole.thetaDot <- updatedState[[6]] 180 | pole.thetaDotDot <- updatedState[[7]] 181 | 182 | oldpole.theta <- oldState[[5]] 183 | if(frameNum > 20000){ 184 | print("Max Frame Num Exceeded , stopping simulation") 185 | return (TRUE) 186 | } 187 | 188 | height <- cos(pole.theta) 189 | oldHeight <- cos(oldpole.theta) 190 | if(height==-1 & cart.force==0){ 191 | return(TRUE) 192 | } 193 | 194 | if(oldHeight >= 0 & height < 0){ 195 | #print("Pole fell over") 196 | return (TRUE) 197 | } 198 | if(cart.centerX < track.x | cart.centerX > (track.x+2*track.limit)){ 199 | #print("Exceeded track length") 200 | return (TRUE) 201 | } else { 202 | return (FALSE) 203 | } 204 | } 205 | 206 | poleBalance.PlotState <-function(updatedState){ 207 | cart.centerX <- updatedState[[1]] 208 | cart.centerXDot <- updatedState[[2]] 209 | cart.centerXDotDot <- updatedState[[3]] 210 | cart.force <- updatedState[[4]] 211 | pole.theta <- updatedState[[5]] 212 | pole.thetaDot <- updatedState[[6]] 213 | pole.thetaDotDot <- updatedState[[7]] 214 | 215 | createSceneFunc(scene.bottomLeftX,scene.bottomLeftY,scene.width,scene.height, 216 | main="Simulation of Inverted Pendulum - www.gekkoquant.com",xlab="", 217 | ylab="",xlim=c(-0.5*scene.width,0.5*scene.width), 218 | ylim=c(-0.5*scene.height,0.5*scene.height)) 219 | 220 | createBoxFunc(track.x,track.y,track.limit*2,track.height,track.colour) 221 | createBoxFunc(leftBuffer.x,leftBuffer.y,leftBuffer.width,leftBuffer.height,leftBuffer.colour) 222 | createBoxFunc(rightBuffer.x,rightBuffer.y,rightBuffer.width, 223 | rightBuffer.height,rightBuffer.colour) 224 | createBoxFunc(cart.centerX-0.5*cart.width,cart.centerY+0.5*cart.height,cart.width,cart.height, 225 | cart.colour) 226 | drawPoleFunc(cart.centerX,cart.centerY,2*pole.length,pole.theta,pole.colour) 227 | drawPendulum(cart.centerX,cart.centerY,2*pole.length,pole.theta,pendulum.radius,pendulum.colour) 228 | 229 | } 230 | 231 | config <- newConfigNEAT(7,1,500,50) 232 | poleSimulation <- newNEATSimulation(config, poleBalance.InitialState, 233 | poleBalance.UpdatePoleState, 234 | poleBalance.ConvertStateToNeuralNetInputs, 235 | poleBalance.UpdateFitness, 236 | poleBalance.CheckForTermination, 237 | poleBalance.PlotState) 238 | 239 | nMax <- 1 #Number of generations to run 240 | for(i in seq(1,nMax)){ 241 | poleSimulation <- NEATSimulation.RunSingleGeneration(poleSimulation) 242 | #poleSimulation <- NEATSimulation.RunSingleGeneration(poleSimulation,T,"videos", 243 | # "poleBalance",1/simulation.timestep) 244 | } 245 | 246 | 247 | 248 | 249 | } 250 | 251 | -------------------------------------------------------------------------------- /vignettes/rneat-vignette.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "RNeat - Neuroevolution of Augmenting Topologies" 3 | author: "Andrew Hunter" 4 | date: "`r Sys.Date()`" 5 | output: rmarkdown::html_vignette 6 | vignette: > 7 | %\VignetteIndexEntry{RNeat} 8 | %\VignetteEngine{knitr::rmarkdown} 9 | %\VignetteEncoding{UTF-8} 10 | --- 11 | RNeat provides an implementation of the Neuroevolution of Augmenting Topologies algorithm. This is a genetic algorithm for training neural networks which evolves not only the weight space but the topological space too starting from a minimalist structure. 12 | 13 | ## Overview 14 | 15 | The NEAT algorithm aims to develop a genetic algorithm that searching through neural network weight and structure space that has the following properties: 16 | 17 | * Have genetic representation that allows structure to be crossed over in a meaningful way 18 | * Protect topological innovations that need a few evolutions to be optimised so that it doesn’t disappear from the gene pool prematurely 19 | * Minimise topologies throughout training without specially contrived network complexity penalisation functions 20 | 21 | A through treatment of the algorithm can be found in the paper **Evolving Neural Networks through Augmenting Topologies by Kenneth O. Stanley and Risto Miikkulainen** (http://nn.cs.utexas.edu/downloads/papers/stanley.ec02.pdf). 22 | 23 | 24 | ## Genetic Representation 25 | A genome contains a number of genes, each gene represents a connection between nodes in the neural network. Each node is either an input, hidden or output node. The input nodes take in the state of the system, the hidden nodes are used by the neural network to do calculations and the output is used to update the state / make a decision. 26 | 27 | 28 | 29 | Genes have an input node, an output node, a weight, an enabled/disabled flag and an innovation number. The innovation number is tracking the historical origin of each gene. If two genes have the same innovation number then they must represent the same topology (although the weights may be different). This is exploited during the gene crossover. 30 | 31 | ## Genome Mutation 32 | The following mutations can happen to the genomes. 33 | 34 | ### Point Mutate 35 | 36 | Randomly updates the weight of a randomly selected connection gene 37 | 38 | The updates are either: 39 | 40 | New Weight = Old Weight +/- Random number between 0 and genome$MutationRate[[“Step”]] 41 | 42 | or 43 | 44 | New Weight = Random number between -2 and 2 45 | 46 | 47 | 48 | 49 | ### Link Mutate 50 | 51 | Randomly adds a new connection to the network with a random weight between -2 and 2 52 | 53 | 54 | 55 | 56 | ### Node Mutate 57 | 58 | This mutation adds a new node to the network by disabling a connection, replacing it with a connection of weight 1, a node and a connection with the same weight as the disabled connection. In essence it’s been replaced with an identically functioning equivalent. 59 | 60 | 61 | 62 | 63 | ### Enable Disable Mutate 64 | 65 | Randomly enables and disables connections 66 | 67 | 68 | 69 | 70 | ## Genome Crossover (Mating) 71 | 72 | Genomes crossover takes two parent genomes (lets call them A and B) and creates a new genome (lets call it the child) taking the strongest genes from A and B copying any topological structures along the way. 73 | 74 | During the crossover genes from both genomes are lined up using their innovation number. For each innovation number the gene from the most fit parent is selected and inserted into the child genome. If both parent genomes are the same fitness then the gene is randomly selected from either parent with equal probability. If the innovation number is only present in one parent then this is known as a disjoint or excess gene and represents a topological innovation, it too is inserted into the child. 75 | 76 | The image below shows the crossover process for two genomes of the same fitness. 77 | 78 | 79 |
80 | ## Speciation 81 | 82 | Speciation takes all the genomes in a given genome pool and attempts to split them into distinct groups known as species. The genomes in each species will have similar characteristics. 83 | 84 | A way of measuring the similarity between two genomes is required, if two genomes are “similar” they are from the same species. A natural measure to use would be a weighted sum of the number of disjoint & excess genes (representing topological differences) and the difference in weights between matching genes. If the weighted sum is below some threshold then the genomes are of the same species. 85 | 86 | The advantage of splitting the genomes into species is that during the genetic evolution step where genomes with low fitness are culled (removed entirely from the genome pool) **rather than having each genome fight for it’s place against every other genome in the entire genome pool we can make it fight for it’s place against genomes of the same species**. This way species that form from a new topological innovation that might not have a high fitness yet due to not having it’s weights optimised will survive the culling. 87 | 88 | #Usage 89 | Pole balancing example 90 | 91 | ```{r,eval=FALSE} 92 | 93 | drawPoleFunc <- function(fixedEnd.x,fixedEnd.y,poleLength, theta, 94 | fillColour=NA, borderColour="black"){ 95 | floatingEnd.x <- fixedEnd.x-poleLength * sin(theta) 96 | floatingEnd.y <- fixedEnd.y+poleLength * cos(theta) 97 | 98 | polygon(c(fixedEnd.x,floatingEnd.x,floatingEnd.x,fixedEnd.x), 99 | c(fixedEnd.y,floatingEnd.y,floatingEnd.y,fixedEnd.y), 100 | col = fillColour, border=borderColour) 101 | } 102 | 103 | drawPendulum <- function(fixedEnd.x,fixedEnd.y,poleLength, theta, 104 | radius,fillColour=NA, borderColour="black"){ 105 | floatingEnd.x <- fixedEnd.x-poleLength * sin(theta) 106 | floatingEnd.y <- fixedEnd.y+poleLength * cos(theta) 107 | createCircleFunc(floatingEnd.x,floatingEnd.y,radius,fillColour,borderColour) 108 | } 109 | 110 | #Parameters to control the simulation 111 | simulation.timestep = 0.005 112 | simulation.gravity = 9.8 #meters per second^2 113 | simulation.numoftimesteps = 2000 114 | 115 | pole.length = 1 #meters, total pole length 116 | pole.width = 0.2 117 | pole.theta = pi 118 | pole.thetaDot = 0 119 | pole.thetaDotDot = 0 120 | pole.colour = "purple" 121 | 122 | 123 | pendulum.centerX = NA 124 | pendulum.centerY = NA 125 | pendulum.radius = 0.1 126 | pendulum.mass = 0.1 127 | pendulum.colour = "purple" 128 | 129 | cart.width=0.5 130 | cart.centerX = 0 131 | cart.centerY = 0 132 | cart.height=0.2 133 | cart.colour="red" 134 | cart.centerXDot = 0 135 | cart.centerXDotDot = 0 136 | cart.mass = 0.4 137 | cart.force = 0 138 | cart.mu=2 139 | 140 | 141 | track.limit= 10 #meters from center 142 | track.x = -track.limit 143 | track.height=0.01 144 | track.y = 0.5*track.height 145 | track.colour = "blue" 146 | 147 | leftBuffer.width=0.1 148 | leftBuffer.height=0.2 149 | leftBuffer.x=-track.limit-0.5*cart.width-leftBuffer.width 150 | leftBuffer.y=0.5*leftBuffer.height 151 | leftBuffer.colour = "blue" 152 | 153 | rightBuffer.width=0.1 154 | rightBuffer.height=0.2 155 | rightBuffer.x=track.limit+0.5*cart.width 156 | rightBuffer.y=0.5*rightBuffer.height 157 | rightBuffer.colour = "blue" 158 | 159 | #Define the size of the scene (used to visualise what is happening in the simulation) 160 | scene.width = 2*max(rightBuffer.x+rightBuffer.width,track.limit+pole.length+pendulum.radius) 161 | scene.bottomLeftX = -0.5*scene.width 162 | scene.height=max(pole.length+pendulum.radius,scene.width) 163 | scene.bottomLeftY = -0.5*scene.height 164 | 165 | poleBalance.InitialState <- function(){ 166 | state <- list() 167 | state[1] <- cart.centerX 168 | state[2] <- cart.centerXDot 169 | state[3] <- cart.centerXDotDot 170 | state[4] <- cart.force 171 | state[5] <- pole.theta 172 | state[6] <- pole.thetaDot 173 | state[7] <- pole.thetaDotDot 174 | return(state) 175 | } 176 | 177 | poleBalance.ConvertStateToNeuralNetInputs <- function(currentState){ 178 | return (currentState) 179 | } 180 | 181 | poleBalance.UpdatePoleState <- function(currentState,neuralNetOutputs){ 182 | #print("Updating pole state") 183 | #print(neuralNetOutputs) 184 | cart.centerX <- currentState[[1]] 185 | cart.centerXDot <- currentState[[2]] 186 | cart.centerXDotDot <- currentState[[3]] 187 | cart.force <- currentState[[4]]+neuralNetOutputs[[1]] 188 | pole.theta <- currentState[[5]] 189 | pole.thetaDot <- currentState[[6]] 190 | pole.thetaDotDot <- currentState[[7]] 191 | 192 | costheta = cos(pole.theta) 193 | sintheta = sin(pole.theta) 194 | totalmass = cart.mass+pendulum.mass 195 | masslength = pendulum.mass*pole.length 196 | 197 | pole.thetaDotDot = (simulation.gravity*totalmass*sintheta+costheta* 198 | (cart.force-masslength*pole.thetaDot^2*sintheta-cart.mu*cart.centerXDot))/ 199 | (pole.length*(totalmass-pendulum.mass*costheta^2)) 200 | 201 | cart.centerXDotDot =(cart.force+masslength*(pole.thetaDotDot*costheta-pole.thetaDot^2*sintheta)- 202 | cart.mu*cart.centerXDot)/totalmass 203 | 204 | cart.centerX = cart.centerX+simulation.timestep*cart.centerXDot 205 | cart.centerXDot = cart.centerXDot+simulation.timestep*cart.centerXDotDot 206 | pole.theta = (pole.theta +simulation.timestep*pole.thetaDot ) 207 | pole.thetaDot = pole.thetaDot+simulation.timestep*pole.thetaDotDot 208 | 209 | currentState[1] <- cart.centerX 210 | currentState[2] <- cart.centerXDot 211 | currentState[3] <- cart.centerXDotDot 212 | currentState[4] <- cart.force 213 | currentState[5] <- pole.theta 214 | currentState[6] <- pole.thetaDot 215 | currentState[7] <- pole.thetaDotDot 216 | return (currentState) 217 | } 218 | 219 | 220 | 221 | poleBalance.UpdateFitness <- function(oldState,updatedState,oldFitness){ 222 | #return (oldFitness+1) #fitness is just how long we've ran for 223 | #return (oldFitness+((track.limit-abs(updatedState[[1]]))/track.limit)^2) 224 | #More reward for staying near middle of track 225 | 226 | height <- cos(updatedState[[5]]) #is -ve if below track 227 | heightFitness <- max(height,0) 228 | centerFitness <- (track.limit-abs(updatedState[[1]]))/track.limit 229 | return (oldFitness+(heightFitness + heightFitness*centerFitness)) 230 | } 231 | 232 | poleBalance.CheckForTermination <- function(frameNum,oldState,updatedState,oldFitness,newFitness){ 233 | cart.centerX <- updatedState[[1]] 234 | cart.centerXDot <- updatedState[[2]] 235 | cart.centerXDotDot <- updatedState[[3]] 236 | cart.force <- updatedState[[4]] 237 | pole.theta <- updatedState[[5]] 238 | pole.thetaDot <- updatedState[[6]] 239 | pole.thetaDotDot <- updatedState[[7]] 240 | 241 | oldpole.theta <- oldState[[5]] 242 | if(frameNum > 20000){ 243 | print("Max Frame Num Exceeded , stopping simulation") 244 | return (TRUE) 245 | } 246 | 247 | height <- cos(pole.theta) 248 | oldHeight <- cos(oldpole.theta) 249 | if(height==-1 & cart.force==0){ 250 | return(TRUE) 251 | } 252 | 253 | if(oldHeight >= 0 & height < 0){ 254 | #print("Pole fell over") 255 | return (TRUE) 256 | } 257 | if(cart.centerX < track.x | cart.centerX > (track.x+2*track.limit)){ 258 | #print("Exceeded track length") 259 | return (TRUE) 260 | } else { 261 | return (FALSE) 262 | } 263 | } 264 | 265 | poleBalance.PlotState <-function(updatedState){ 266 | cart.centerX <- updatedState[[1]] 267 | cart.centerXDot <- updatedState[[2]] 268 | cart.centerXDotDot <- updatedState[[3]] 269 | cart.force <- updatedState[[4]] 270 | pole.theta <- updatedState[[5]] 271 | pole.thetaDot <- updatedState[[6]] 272 | pole.thetaDotDot <- updatedState[[7]] 273 | 274 | createSceneFunc(scene.bottomLeftX,scene.bottomLeftY,scene.width,scene.height, 275 | main="Simulation of Inverted Pendulum - www.gekkoquant.com",xlab="", 276 | ylab="",xlim=c(-0.5*scene.width,0.5*scene.width), 277 | ylim=c(-0.5*scene.height,0.5*scene.height)) 278 | 279 | createBoxFunc(track.x,track.y,track.limit*2,track.height,track.colour) 280 | createBoxFunc(leftBuffer.x,leftBuffer.y,leftBuffer.width,leftBuffer.height,leftBuffer.colour) 281 | createBoxFunc(rightBuffer.x,rightBuffer.y,rightBuffer.width, 282 | rightBuffer.height,rightBuffer.colour) 283 | createBoxFunc(cart.centerX-0.5*cart.width,cart.centerY+0.5*cart.height,cart.width,cart.height, 284 | cart.colour) 285 | drawPoleFunc(cart.centerX,cart.centerY,2*pole.length,pole.theta,pole.colour) 286 | drawPendulum(cart.centerX,cart.centerY,2*pole.length,pole.theta,pendulum.radius,pendulum.colour) 287 | 288 | } 289 | 290 | config <- newConfigNEAT(7,1,500,50) 291 | poleSimulation <- newNEATSimulation(config, poleBalance.InitialState, 292 | poleBalance.UpdatePoleState, 293 | poleBalance.ConvertStateToNeuralNetInputs, 294 | poleBalance.UpdateFitness, 295 | poleBalance.CheckForTermination, 296 | poleBalance.PlotState) 297 | 298 | nMax <- 1 #Number of generations to run 299 | for(i in seq(1,nMax)){ 300 | poleSimulation <- NEATSimulation.RunSingleGeneration(poleSimulation) 301 | #poleSimulation <- NEATSimulation.RunSingleGeneration(poleSimulation,T,"videos", 302 | # "poleBalance",1/simulation.timestep) 303 | } 304 | 305 | 306 | 307 | 308 | 309 | ``` 310 | 311 | 312 | -------------------------------------------------------------------------------- /R/neatCharting.R: -------------------------------------------------------------------------------- 1 | 2 | #' @importFrom grDevices dev.new 3 | #' @importFrom graphics box layout legend lines mtext par plot polygon symbols text 4 | #' @importFrom igraph add_edges add_vertices layout.circle make_empty_graph 5 | 6 | 7 | 8 | config.nodegene.drawwidth <- 60 9 | config.nodegene.drawheight <- 35 10 | config.nodegene.textmargin <- 3 11 | config.nodegene.radius <- 5 12 | config.nodegene.nodemargin <- 5*config.nodegene.radius 13 | 14 | config.connectiongene.drawwidth <- 60 15 | config.connectiongene.drawheight <- 60 16 | config.connectiongene.textmargin <- 3 17 | 18 | # Function to create a blank canvas / scene for drawing objects onto later 19 | #' @export 20 | # @param bottomLeftX Bottom left x co-ordinate of the canvas 21 | # @param bottomLeftY Bottom left y co-ordinate of the canvas 22 | # @param width Canvas width 23 | # @param height Canvas height 24 | # @param main Text title of the plot 25 | # @param xlab Label for x-axis 26 | # @param ylab Label for y-axis 27 | # @param ann See plot ann 28 | # @param xaxt See plot xaxt 29 | # @param yaxt See plot yaxt 30 | # @param xlim See plot xlim 31 | # @param ylim See plot ylim 32 | # @param frame.plot Bool to enable or disable drawing of a frame around the canvas 33 | createSceneFunc <- function(bottomLeftX, bottomLeftY, width,height,main="",xlab="",ylab="",ann=T,xaxt=NULL,yaxt=NULL,xlim=NULL,ylim=NULL,frame.plot=T){ 34 | plot(c(bottomLeftX, bottomLeftX+width), c(bottomLeftY,bottomLeftY+height), type = "n",ann=ann, xaxt=xaxt, yaxt=yaxt,xlim=xlim,ylim=ylim,main=main,xlab=xlab,ylab=ylab,frame.plot=frame.plot ) 35 | } 36 | 37 | # Function to draw a box on the scene 38 | # @param topLeftX x co-ordinate of top left corner of box 39 | # @param topLeftY y co-ordinate of top left corner of box 40 | # @param width Width of the box 41 | # @param height Height of the box 42 | # @param fillColour Colour to fill the box in with 43 | # @param borderColour Colour of the box edge 44 | #' @export 45 | createBoxFunc <- function(topLeftX, topLeftY, width, height, fillColour=NA, borderColour="black"){ 46 | polygon(c(topLeftX,topLeftX+width,topLeftX+width,topLeftX), 47 | c(topLeftY,topLeftY,topLeftY-height,topLeftY-height), 48 | col = fillColour, border=borderColour) 49 | } 50 | 51 | # Function to draw a circle on the scene 52 | # @param centerX x co-ordinate of the center of the circle 53 | # @param centerY y co-ordinate of the center of the circle 54 | # @param radius Radius of the circle 55 | # @param fillColour Colour to fill the circle in with 56 | # @param borderColour Colour of the circle edge 57 | #' @export 58 | createCircleFunc <- function(centerX,centerY,radius,fillColour=NA, borderColour="black"){ 59 | symbols(centerX,centerY,circles=radius,inches=F,add=T,fg=borderColour,bg=fillColour) 60 | } 61 | 62 | #Function to write text scene 63 | createTextFunc <- function(topLeftX, topLeftY, width, height, message,adjustment=c(0,1),textcolour="black"){ 64 | text(topLeftX,topLeftY,message,adj=adjustment,col=textcolour) 65 | } 66 | 67 | 68 | drawGenotypeNEAT <- function(object,neatConfig,x,y){ 69 | UseMethod("drawGenotypeNEAT") 70 | } 71 | 72 | drawGenotypeNEAT.connectiongene <- function(connectiongene,neatConfig,topLeftX,topLeftY){ 73 | #print("drawing connectiongene") 74 | createBoxFunc(topLeftX,topLeftY,config.connectiongene.drawwidth,config.connectiongene.drawheight) 75 | 76 | txtSpace <- config.connectiongene.drawheight / 6 77 | txtColour <- "black" 78 | if(!connectiongene$Enabled){ 79 | txtColour <- "red" 80 | } 81 | createTextFunc(topLeftX+config.connectiongene.textmargin,topLeftY-config.connectiongene.textmargin-txtSpace*0,message=paste("InNode:",connectiongene$InNode),textcolour=txtColour) 82 | createTextFunc(topLeftX+config.connectiongene.textmargin,topLeftY-config.connectiongene.textmargin-txtSpace*1,message=paste("OutNode:",connectiongene$OutNode),textcolour=txtColour) 83 | createTextFunc(topLeftX+config.connectiongene.textmargin,topLeftY-config.connectiongene.textmargin-txtSpace*2,message=paste("Weight:",round(connectiongene$Weight,5)),textcolour=txtColour) 84 | createTextFunc(topLeftX+config.connectiongene.textmargin,topLeftY-config.connectiongene.textmargin-txtSpace*3,message=paste("Enabled:",connectiongene$Enabled),textcolour=txtColour) 85 | createTextFunc(topLeftX+config.connectiongene.textmargin,topLeftY-config.connectiongene.textmargin-txtSpace*4,message=paste("Innovation:",connectiongene$Innovation),textcolour=txtColour) 86 | 87 | } 88 | 89 | drawGenotypeNEAT.genome <- function(genome,neatConfig,topLeftX=0,topLeftY=0){ 90 | #print("drawing genome") 91 | 92 | connectionOffset <- 5 93 | 94 | nodeGenesHeight <- config.nodegene.drawheight 95 | nodeGenesWidth <- (sum(unlist(lapply(generateNetwork(genome,neatConfig)$Network$Neurons,function(x) { return(!is.null(x))}))) 96 | )*config.connectiongene.drawwidth 97 | connectionGenesWidth <- max(length(genome$ConnectionGenes)*config.connectiongene.drawwidth) 98 | connectionGenesHeight <- config.nodegene.drawheight+connectionOffset+config.connectiongene.drawheight 99 | 100 | width <- max(nodeGenesWidth,connectionGenesWidth) 101 | height <- max(nodeGenesHeight,connectionGenesHeight) 102 | 103 | par(mar=c(1,1,1,1) + 0.0) 104 | createSceneFunc(0,-height,width,height,xaxt="n",yaxt="n") 105 | 106 | 107 | networkNeurons <- generateNetwork(genome,neatConfig)$Network$Neurons 108 | drawCount <- 1 109 | for(i in seq(1,length(networkNeurons))){ 110 | networkNeuron <- networkNeurons[[i]] 111 | if(!is.null(networkNeuron)){ 112 | nodeType <- "Hidden" 113 | if(i <= neatConfig$Inputs){ 114 | nodeType <- "Input" 115 | } 116 | if(i >= neatConfig$MaxNodes-neatConfig$Outputs){ 117 | nodeType <- "Output" 118 | } 119 | 120 | createBoxFunc((drawCount-1)*config.connectiongene.drawwidth,topLeftY,config.nodegene.drawwidth,config.nodegene.drawheight) 121 | txtSpace <- config.nodegene.drawheight / 3 122 | createTextFunc((drawCount-1)*config.connectiongene.drawwidth+config.nodegene.textmargin,topLeftY-config.nodegene.textmargin-txtSpace*0,message=paste("NodeId:",i),textcolour="black") 123 | createTextFunc((drawCount-1)*config.connectiongene.drawwidth+config.nodegene.textmargin,topLeftY-config.nodegene.textmargin-txtSpace*1,message=paste("NodeType:",nodeType),textcolour="black") 124 | drawCount <- drawCount +1 125 | } 126 | 127 | } 128 | 129 | for(i in seq(1,length(genome$ConnectionGenes))){ 130 | drawGenotypeNEAT(genome$ConnectionGenes[[i]],neatConfig,(i-1)*config.connectiongene.drawwidth,-config.nodegene.drawheight-connectionOffset) 131 | } 132 | 133 | } 134 | 135 | 136 | drawPhenotypeNEAT <- function(object,neatConfig,x,y){ 137 | UseMethod("drawPhenotypeNEAT") 138 | } 139 | 140 | drawPhenotypeNEAT.nodegene <- function(nodegene,neatConfig,topLeftX,topLeftY){ 141 | centerOffset <- config.nodegene.nodemargin+config.nodegene.radius 142 | centerX <- topLeftX + centerOffset 143 | centerY <- topLeftY - centerOffset 144 | fillColour <- "white" 145 | if(nodegene$NodeType=="input"){ fillColour <- "cadetblue1" } 146 | if(nodegene$NodeType=="output"){ fillColour <- "coral" } 147 | createCircleFunc(centerX,centerY,radius=config.nodegene.radius,fillColour) 148 | createTextFunc(centerX,centerY,message=nodegene$NodeId,adjustment=c(0.5,0.5)) 149 | } 150 | 151 | drawPhenotypeNEAT.connectiongene <- function(connectiongene,neatConfig,topLeftX,topLeftY){ 152 | stop("Not implemented, connections drawn in the drawPhenotypeNEAT.genome function") 153 | } 154 | 155 | 156 | drawPhenotypeNEAT.genome <- function(genome,neatConfig,topLeftX,topLeftY){ 157 | 158 | #inputNodeGenes <- Filter(function(x) { return(x$NodeType=="input")},genomeOne$NodeGenes) 159 | #hiddenNodeGenes <- Filter(function(x) { return(x$NodeType=="hidden")},genomeOne$NodeGenes) 160 | #outputGenes <- Filter(function(x) { return(x$NodeType=="output")},genomeOne$NodeGenes) 161 | 162 | #http://www.shizukalab.com/toolkits/sna/plotting-directed-networks 163 | #set.seed(1) 164 | 165 | 166 | gg <- createGraph(genome,neatConfig) 167 | 168 | #cleanLayout <- layout.fruchterman.reingold(gg) 169 | cleanLayout <- layout.circle(gg) 170 | # cleanLayout[c(inputsIdx,outputsIdx),] <- ll[c(inputsIdx,outputsIdx),] 171 | # plot(gg,layout=ll) 172 | plot(gg,layout=cleanLayout) 173 | #print(gg) 174 | 175 | 176 | } 177 | 178 | createGraph <- function(genome,neatConfig){ 179 | g <- make_empty_graph() 180 | nodeIdToVertexIdMap <- list() 181 | 182 | drawnNodes <- list() 183 | counter <- 1 184 | 185 | 186 | neurons <- generateNetwork(genome,neatConfig)$Network$Neurons 187 | for(i in seq(1,length(neurons))){ 188 | vertexColour <- "white" 189 | if(i <= neatConfig$Inputs){ vertexColour<-"cadetblue1"} 190 | if(i > neatConfig$MaxNodes){ vertexColour<-"coral"} 191 | if(!is.null(neurons[[i]])){ 192 | g<-add_vertices(g,1, color = vertexColour,name=i) 193 | nodeIdToVertexIdMap[i] <- counter 194 | counter <- counter+1 195 | } 196 | } 197 | 198 | for(i in seq(1,length(neurons))){ 199 | neuron <- neurons[[i]] 200 | if(!is.null(neuron) && !is.null(neuron$Incoming)){ 201 | for(connectionGene in neuron$Incoming){ 202 | edgeColour <- "black" 203 | if(!connectionGene$Enabled){ 204 | edgeColour <- "red" 205 | } 206 | g<-add_edges(g,color=edgeColour,c(nodeIdToVertexIdMap[connectionGene$InNode],nodeIdToVertexIdMap[connectionGene$OutNode]),attr=list(weight=c(connectionGene$Weight))) 207 | } 208 | } 209 | } 210 | return (g) 211 | } 212 | 213 | 214 | drawNEAT <- function(object,neatConfig){ 215 | UseMethod("drawNEAT") 216 | } 217 | 218 | drawNEAT.genome <- function(genome,neatConfig){ 219 | dev.new() 220 | layout(matrix(c(1,2), 2, 1, byrow = TRUE),heights=c(1,2)) 221 | drawGenotypeNEAT(genome,neatConfig) 222 | drawPhenotypeNEAT(genome,neatConfig) 223 | } 224 | 225 | drawSideBySideNEAT <- function(genomeOne,genomeTwo,neatConfig,chartDescription){ 226 | dev.new() 227 | layout(matrix(c(5,5,1,3,2,4), 3, 2, byrow = TRUE),heights=c(1,4,8)) 228 | 229 | drawGenotypeNEAT(genomeOne,neatConfig) 230 | drawPhenotypeNEAT(genomeOne,neatConfig) 231 | 232 | box(lty = '1373', col = 'red') 233 | drawGenotypeNEAT(genomeTwo,neatConfig) 234 | drawPhenotypeNEAT(genomeTwo,neatConfig) 235 | box(lty = '1373', col = 'red') 236 | createSceneFunc(0,-0,0,0,ann=F,xaxt="n",yaxt="n",frame.plot=F) 237 | mtext(chartDescription, outer = F, cex = 1.5,side=1) 238 | 239 | } 240 | 241 | drawCrossoverNEAT <- function(genomeA,genomeB,neatConfig,genomeCross){ 242 | dev.new() 243 | layout(matrix(c(5,5,5,4,4,4,1,2,3), 3, 3, byrow = TRUE),heights=c(1,6,10)) 244 | 245 | par(mar=c(1,1,1,1)) 246 | drawPhenotypeNEAT(genomeA,neatConfig) 247 | box(lty = '1373', col = 'red') 248 | par(mar=c(1,1,1,1)) 249 | drawPhenotypeNEAT(genomeB,neatConfig) 250 | box(lty = '1373', col = 'red') 251 | par(mar=c(1,1,1,1)) 252 | drawPhenotypeNEAT(genomeCross,neatConfig) 253 | box(lty = '1373', col = 'blue') 254 | 255 | 256 | smalloffset <- 5 257 | largeoffset <-10 258 | innovationsA <- unlist(lapply(genomeA$ConnectionGenes,function(x){x$Innovation})) 259 | innovationsB <- unlist(lapply(genomeB$ConnectionGenes,function(x){x$Innovation})) 260 | innovationsCross <- unlist(lapply(genomeCross$ConnectionGenes,function(x){x$Innovation})) 261 | uniqueInnovations <- unique(sort(c(innovationsA,innovationsB))) 262 | #print(innovationsA) 263 | #print(innovationsB) 264 | #print(uniqueInnovations) 265 | width <- max(length(uniqueInnovations),length(innovationsCross))*config.connectiongene.drawwidth 266 | height <- 3*config.connectiongene.drawheight+smalloffset+largeoffset 267 | 268 | #print(width) 269 | #print(height) 270 | par(mar=c(1,1,1,1) + 0.0) 271 | createSceneFunc(0,-height,width,height,xaxt="n",yaxt="n") 272 | 273 | 274 | for(i in seq(1,length(genomeA$ConnectionGenes))){ 275 | drawGenotypeNEAT(genomeA$ConnectionGenes[[i]],neatConfig,(match(genomeA$ConnectionGenes[[i]]$Innovation,uniqueInnovations)-1)*config.connectiongene.drawwidth,0) 276 | } 277 | for(i in seq(1,length(genomeB$ConnectionGenes))){ 278 | drawGenotypeNEAT(genomeB$ConnectionGenes[[i]],neatConfig,(match(genomeB$ConnectionGenes[[i]]$Innovation,uniqueInnovations)-1)*config.connectiongene.drawwidth,-config.connectiongene.drawheight-smalloffset) 279 | } 280 | for(i in seq(1,length(genomeCross$ConnectionGenes))){ 281 | drawGenotypeNEAT(genomeCross$ConnectionGenes[[i]],neatConfig,(i-1)*config.connectiongene.drawwidth,-2*config.connectiongene.drawheight-smalloffset-largeoffset) 282 | } 283 | 284 | createSceneFunc(0,-0,0,0,ann=F,xaxt="n",yaxt="n",frame.plot=F) 285 | mtext("Genome Crossover - Combining the topological features", outer = F, cex = 1.5,side=1) 286 | } 287 | 288 | #inNodeOne <- newConnectiongene() 289 | #inNodeOne$InNode <- 1 290 | #inNodeOne$OutNode <- 3 291 | #inNodeOne$Enabled = T 292 | #inNodeOne$Weight=7 293 | #inNodeOne$Innovation=1 294 | # 295 | #hiddenNodeOne <- newConnectiongene() 296 | #hiddenNodeOne$InNode <- 2 297 | #hiddenNodeOne$OutNode <- 3 298 | #hiddenNodeOne$Enabled = T 299 | #hiddenNodeOne$Weight=5 300 | #hiddenNodeOne$Innovation=2 301 | # 302 | #hiddenNodeTwo <- newConnectiongene() 303 | #hiddenNodeTwo$InNode <- 2 304 | #hiddenNodeTwo$OutNode <- config.MaxNodes+1 305 | #hiddenNodeTwo$Enabled = T 306 | #hiddenNodeTwo$Weight=3 307 | #hiddenNodeTwo$Innovation=4 308 | # 309 | #outNodeOne <- newConnectiongene() 310 | #outNodeOne$InNode <- 3 311 | #outNodeOne$OutNode <- config.MaxNodes+1 312 | #outNodeOne$Enabled = T 313 | #outNodeOne$Weight=3 314 | #outNodeOne$Innovation=3 315 | # 316 | #genomeOne = newGenome() 317 | #genomeOne$ConnectionGenes <-list(inNodeOne,outNodeOne,hiddenNodeOne,hiddenNodeTwo) 318 | #genomeOne$MaxNeuron <- 5 319 | #genomeOne 320 | #drawNEAT(genomeOne) 321 | # 322 | #genomeOne <- generateNetwork(genomeOne) 323 | # 324 | #netInputs <- list() 325 | #netInputs[1] <- 1.2 326 | #netInputs[2] <- 2.5 327 | #evaluateNetwork(genomeOne$Network,netInputs) 328 | # 329 | ##expect to see (1.2*7+2.5*5)*3 = 62.7 (if override sigmoid with sum) 330 | ##drawNEAT(mutateGenome(genomeOne)) 331 | #innovationGlob <- 4; t <-nodeMutate(genomeOne); drawNEAT(t) 332 | #innovationGlob <- 4; t<- enableDisableMutate(genomeOne,F); drawNEAT(t) 333 | #innovationGlob <- 4; t<-pointMutate(genomeOne); drawNEAT(t) 334 | # 335 | # 336 | # 337 | #demoConnection <- newConnectiongene() 338 | #demoConnection$InNode <- 2 339 | #demoConnection$OutNode <- config.MaxNodes+1 340 | #demoConnection$Enabled = T 341 | #demoConnection$Weight=5 342 | #demoConnection$Innovation=1 343 | #innovationGlob <- 1 344 | # 345 | #demoGenome = newGenome() 346 | #demoGenome$ConnectionGenes <-list(demoConnection) 347 | #demoGenome$MaxNeuron <- 2 348 | #demoGenome 349 | # 350 | #drawNEAT(demoGenome) 351 | #innovationGlob <- 2; drawNEAT(linkMutate(demoGenome,T)) #Adds a new connection 352 | #innovationGlob <- 2; drawNEAT(pointMutate(demoGenome)) #Changes the weight in the network 353 | #innovationGlob <- 2; drawNEAT(nodeMutate(demoGenome)) #Adds a new node 354 | #innovationGlob <- 2; drawNEAT(enableDisableMutate(demoGenome,F)) 355 | # 356 | # 357 | #set.seed(2) 358 | #imgWidth <- 1600 359 | #imgHeight <- 1200 360 | ##png(filename="linkMutate.png",width=imgWidth,height=imgHeight) 361 | #innovationGlob <- 1; mutatedGenome<-linkMutate(demoGenome,T) 362 | #drawSideBySideNEAT(demoGenome,mutatedGenome,"Link Mutate - Add a new connection") 363 | ##dev.off() 364 | # 365 | ##png(filename="pointMutate.png",width=imgWidth,height=imgHeight) 366 | #innovationGlob <- 1; mutatedGenome<-pointMutate(demoGenome) 367 | #drawSideBySideNEAT(demoGenome,mutatedGenome,"Point Mutate - Mutate the weights") 368 | ##dev.off() 369 | # 370 | ##png(filename="nodeMutate.png",width=imgWidth,height=imgHeight) 371 | #innovationGlob <- 1; mutatedGenome<-nodeMutate(demoGenome) 372 | #drawSideBySideNEAT(demoGenome,mutatedGenome,"Node Mutate - Add a new node, by replacing a connection with equivalent connections") 373 | ##dev.off() 374 | # 375 | ##png(filename="enableDisableMutate.png",width=imgWidth,height=imgHeight) 376 | #innovationGlob <- 1; mutatedGenome<-enableDisableMutate(demoGenome,F) 377 | #drawSideBySideNEAT(demoGenome,mutatedGenome,"Enable/Disable Mutate - Enables/Disables a connection") 378 | ##dev.off() 379 | 380 | 381 | 382 | 383 | 384 | -------------------------------------------------------------------------------- /R/neat.R: -------------------------------------------------------------------------------- 1 | 2 | #' @importFrom methods is 3 | #' @importFrom stats median runif 4 | #' @importFrom animation saveVideo ani.options 5 | 6 | config.video.phenotypedurationseconds = 1 7 | config.video.performancedurationseconds = 1 8 | 9 | #' Configuration for setting the number of system inputs/outputs, the max number of nodes and the total number of genomes 10 | #' 11 | #' @param numInputs The number of inputs to the neural network 12 | #' @param numOutputs The number of outputs from the neural network 13 | #' @param maxNumOfNodes The maximum number of neural network nodes 14 | #' @param speciesPopulation The number of genomes to simulate 15 | #' @return configNEAT class 16 | #' @export 17 | newConfigNEAT <- function(numInputs,numOutputs,maxNumOfNodes, speciesPopulation=200){ 18 | assertTrueFunc(is(numInputs,"numeric"),"NumInputs must be a number") 19 | assertTrueFunc(is(numOutputs,"numeric"),"NumOutputs must be a number") 20 | assertTrueFunc(is(maxNumOfNodes,"numeric"),"MaxNumOfNodes must be a number") 21 | assertTrueFunc(is(speciesPopulation,"numeric"),"SpeciesPopulation must be a number") 22 | 23 | assertTrueFunc(numInputs>0,"NumInputs must be greater than 0") 24 | assertTrueFunc(numOutputs>0,"NumOutputs must be greater than 0") 25 | assertTrueFunc(maxNumOfNodes>0,"MaxNumOfNodes must be greater than 0") 26 | assertTrueFunc(speciesPopulation>0,"SpeciesPopulation must be greater than 0") 27 | 28 | res <- list(MutateConnectionChance=0.25, 29 | MutateLinkChance=2, 30 | MutateBiasChance=0.4, 31 | MutateNodeChance=0.5, 32 | MutateEnableChance=0.2, 33 | MutateDisableChance=0.4, 34 | MutateStepSize=0.1, 35 | MutationIncOrDecRate=0.05, 36 | PerturbChance=0.9, 37 | StaleSpecies=25, 38 | CrossoverChance=0.75, 39 | SpeciesPopulation=speciesPopulation, 40 | SpeciesDeltaDisjoint=2, 41 | SpeciesDeltaWeight=0.4, 42 | SpeciesDeltaThreshold=1, 43 | Inputs=numInputs, 44 | Outputs=numOutputs, 45 | MaxNodes=maxNumOfNodes 46 | ) 47 | class(res) <- "configNEAT" 48 | return(res) 49 | } 50 | 51 | 52 | print.newConfigNEAT <- function(configNEAT){ 53 | dumpItemFunc(configNEAT) 54 | } 55 | 56 | neatseq <- function(from,to){ 57 | if(to==0){ 58 | return (list()) 59 | } else { 60 | return (seq(from,to)) 61 | } 62 | } 63 | 64 | assertTrueFunc <- function(testExpression, messageIfNotTrue){ 65 | if(!testExpression){ 66 | cat(paste("Assertion Fail:",messageIfNotTrue,"\n")) 67 | stop() 68 | } 69 | } 70 | 71 | dumpItemFunc <- function(item){ 72 | for(key in ls(item)){ 73 | print(paste(key,item[key])) 74 | } 75 | } 76 | 77 | sigmoid <- function(x,mu=4.9){ 78 | return(2/(1+exp(-mu*x))-1) 79 | } 80 | 81 | 82 | newInnovation <- function(){ 83 | UseMethod("newInnovation") 84 | } 85 | 86 | pkg.env <- new.env() 87 | pkg.env$innovation <- 0 88 | newInnovation.default <- function(){ 89 | #stop("New innovation function not implemented") 90 | pkg.env$innovation <- pkg.env$innovation + 1 91 | return (pkg.env$innovation) 92 | } 93 | 94 | newPool <- function(neatConfig){ 95 | UseMethod("newPool") 96 | } 97 | 98 | newPool.default <- function(neatConfig){ 99 | res <- list(species=list(),generation=0,innovation=neatConfig$Outputs,currentSpecies=1,currentGenome=1,currentFrame=0,maxFitness=0,minFitness=0,meanFitness=0,medianFitness=0) 100 | class(res) <- "pool" 101 | return(res) 102 | } 103 | 104 | print.pool <- function(pool){ 105 | dumpItemFunc(pool) 106 | } 107 | 108 | newSpecies <- function(){ 109 | UseMethod("newSpecies") 110 | } 111 | 112 | newSpecies.default <- function(){ 113 | res <- list(topFitness=0,staleness=0,genomes=list(),averageFitness=0) 114 | class(res) <- "species" 115 | return(res) 116 | } 117 | 118 | print.species <- function(species){ 119 | dumpItemFunc(species) 120 | } 121 | 122 | newGenome <- function(neatConfig){ 123 | UseMethod("newGenome") 124 | } 125 | 126 | newGenome.default <- function(neatConfig){ 127 | #for(item in nodeGenes) { assertTrueFunc(is(item,"nodegene"),"Node genes list must only contain nodegene class") } 128 | #for(item in connectionGenes) { assertTrueFunc(is(item,"connectiongene"),"Connection genes list must only contain connectiongene class") } 129 | res <- list(ConnectionGenes=list(), 130 | Fitness=0, 131 | AdjustedFitness=0, 132 | Network=list(), 133 | MaxNeuron=neatConfig$Inputs, 134 | GlobalRank=0, 135 | MutationRate=list(Connections=neatConfig$MutateConnectionChance, 136 | Link=neatConfig$MutateLinkChance, 137 | Bias=neatConfig$MutateBiasChance, 138 | Node=neatConfig$MutateNodeChance, 139 | Enable=neatConfig$MutateEnableChance, 140 | Disable=neatConfig$MutateDisableChance, 141 | Step=neatConfig$MutateStepSize)) 142 | class(res) <- "genome" 143 | return(res) 144 | } 145 | 146 | print.genome <- function(genome){ 147 | dumpItemFunc(genome) 148 | } 149 | 150 | basicgenome <- function(neatConfig){ 151 | g <- newGenome(neatConfig) 152 | g$MaxNeuron <- neatConfig$Inputs 153 | return (mutateGenome(g,neatConfig)) 154 | } 155 | 156 | newConnectiongene <- function(){ 157 | UseMethod("newConnectiongene") 158 | } 159 | 160 | newConnectiongene.default <- function(){ 161 | #assertTrueFunc(is(inNode,"nodegene"),"InNode must be a node gene") 162 | #assertTrueFunc(is(outNode,"nodegene"),"OutNode must be a node gene") 163 | #assertTrueFunc(is.numeric(weight),"Weight must be a numeric value") 164 | #assertTrueFunc(is(enabled,"logical"),"Enabled must be a boolean") 165 | #assertTrueFunc(is.numeric(innovation),"Innovation must be a numeric value") 166 | res <- list(InNode=NA,OutNode=NA,Weight=0,Enabled=T,Innovation=0) 167 | class(res) <- "connectiongene" 168 | return(res) 169 | } 170 | 171 | print.connectiongene <- function(connectiongene){ 172 | dumpItemFunc(connectiongene) 173 | } 174 | 175 | newNeuron <- function(){ 176 | UseMethod("newNeuron") 177 | } 178 | 179 | newNeuron.default <- function(){ 180 | res <- list(Incoming=list(),Value=0) 181 | class(res) <- "neuron" 182 | return(res) 183 | } 184 | 185 | print.neuron <- function(neuron){ 186 | dumpItemFunc(neuron) 187 | } 188 | 189 | newNetwork <- function(){ 190 | UseMethod("newNetwork") 191 | } 192 | 193 | newNetwork.default <- function(){ 194 | res <- list(Neurons=list()) 195 | class(res) <- "network" 196 | return (res) 197 | } 198 | 199 | print.network <- function(network){ 200 | dumpItemFunc(network) 201 | } 202 | 203 | #NEED TO BE EXCEPTIONALLY CAREFUL DUE TO PASS BY VALUE AND NOT REF LIKE LUA 204 | generateNetwork <- function(genome,neatConfig){ 205 | assertTrueFunc(is(genome,"genome"),"Genome must be a of class genome") 206 | network <- newNetwork() 207 | 208 | for(i in seq(1,neatConfig$Inputs)){ 209 | network$Neurons[[i]] <- newNeuron() 210 | } 211 | 212 | for(o in seq(1,neatConfig$Outputs)){ 213 | network$Neurons[[o+neatConfig$MaxNodes]] <- newNeuron() 214 | } 215 | #print(network) 216 | sortOutNodeIndex <- order(sapply(genome$ConnectionGenes,"[[","OutNode"),na.last=F) #NA Treatment? 217 | #print(sortOutNodeIndex) 218 | for(idx in sortOutNodeIndex){ 219 | gene <- genome$ConnectionGenes[[idx]] 220 | #if(gene$Enabled){ 221 | if(is.null(network$Neurons[[gene$OutNode]])){ 222 | network$Neurons[[gene$OutNode]] <- newNeuron() 223 | } 224 | #print("Trying to set the gene") 225 | #print(gene) 226 | network$Neurons[[gene$OutNode]]$Incoming[[length(network$Neurons[[gene$OutNode]]$Incoming)+1]] <- gene 227 | 228 | if(is.null(network$Neurons[gene$InNode])){ 229 | network$Neurons[[gene$InNode]] <- newNeuron() 230 | } 231 | #} 232 | } 233 | 234 | genome$Network <- network 235 | return (genome) 236 | 237 | } 238 | 239 | 240 | evaluateNetwork <- function(network,inputs,neatConfig){ 241 | assertTrueFunc(is(network,"network"),"Network must be a of class network") 242 | 243 | 244 | #print("EvaluateNetwork") 245 | #print(network) 246 | if(length(inputs) != neatConfig$Inputs){ 247 | stop("Number of inputs does not match the number in the config") 248 | } 249 | 250 | for(i in seq(1,neatConfig$Inputs)){ 251 | network$Neurons[[i]]$Value <- inputs[[i]] 252 | } 253 | 254 | #print(network$Neurons) 255 | for(j in seq(1,length(network$Neurons))){ 256 | totalSum <- 0 257 | if(!is.null(network$Neurons[[j]])){ 258 | 259 | for(i in neatseq(1,length(network$Neurons[[j]]$Incoming))){ #Do i need a null filter here? 260 | incoming <- network$Neurons[[j]]$Incoming[[i]] 261 | if(!is.null(incoming) && incoming$Enabled){ 262 | other <- network$Neurons[[incoming$InNode]] 263 | # print("incoming") 264 | # print(incoming) 265 | # print("other") 266 | # print(other) 267 | # print(paste("Incoming weight is:",incoming$Weight,"Incoming value",other$Value)) 268 | totalSum <- totalSum + incoming$Weight * other$Value 269 | # print(paste("Total sum",totalSum)) 270 | } 271 | } 272 | if(!is.null(network$Neurons[[j]]$Incoming) && length(network$Neurons[[j]]$Incoming) >0){ 273 | network$Neurons[[j]]$Value <- sigmoid(totalSum) 274 | } 275 | } 276 | } 277 | 278 | # print(network$Neurons) 279 | 280 | outputs <- list() 281 | for(i in seq(1,neatConfig$Outputs)){ 282 | #if(network$Neurons[[i+config.MaxNodes]]$Value > 0){ 283 | # outputs[i] <- T 284 | #} else { 285 | # outputs[i] <- F 286 | #} 287 | #print("Seting output") 288 | #print(network$Neurons[[i+config.MaxNodes]]) 289 | outputs[i] <- network$Neurons[[i+neatConfig$MaxNodes]]$Value 290 | } 291 | 292 | return (outputs) 293 | } 294 | 295 | crossover <- function(g1,g2,neatConfig){ 296 | assertTrueFunc(is(g1,"genome"),"g1 must be a of class genome") 297 | assertTrueFunc(is(g2,"genome"),"g2 must be a of class genome") 298 | 299 | # print("crossover g1") 300 | # print(g1) 301 | # print("crossover g2") 302 | # print(g2) 303 | #Make sure g1 is higher fitness genome 304 | if(g2$Fitness > g1$Fitness){ 305 | tmp <- g1 306 | g1 <- g2 307 | g2 <- tmp 308 | } 309 | 310 | child <- newGenome(neatConfig) 311 | 312 | g1Innovations <- unlist(lapply(g1$ConnectionGenes,function(x) { x$Innovation })) 313 | g2Innovations <- unlist(lapply(g2$ConnectionGenes,function(x) { x$Innovation })) 314 | 315 | 316 | innovations1 <- list() 317 | for(i in seq(1,length(g1$ConnectionGenes))){ 318 | gene <- g1$ConnectionGenes[[i]] 319 | innovations1[[gene$Innovation]]<-gene 320 | } 321 | 322 | innovations2 <- list() 323 | for(i in seq(1,length(g2$ConnectionGenes))){ 324 | gene <- g2$ConnectionGenes[[i]] 325 | innovations2[[gene$Innovation]]<-gene 326 | } 327 | 328 | 329 | for(innovation in unique(sort(c(g1Innovations,g2Innovations)))){ 330 | gene1 <- innovations1[innovation] 331 | gene2 <- innovations2[innovation] 332 | #print(innovation) 333 | #print(gene1) 334 | #print(gene2) 335 | if(!is.null(gene1[[1]]) & !is.null(gene2[[1]])){ 336 | 337 | if(g1$Fitness == g2$Fitness){ 338 | #Randomly select either 339 | if(sample(1:2,1)==1){ 340 | child$ConnectionGenes[[length(child$ConnectionGenes)+1]] <- gene1[[1]] 341 | } else { 342 | child$ConnectionGenes[[length(child$ConnectionGenes)+1]] <- gene2[[1]] 343 | } 344 | } else { 345 | #Select the most fit gene 346 | child$ConnectionGenes[[length(child$ConnectionGenes)+1]] <- gene1[[1]] 347 | } 348 | } else { 349 | if(!is.null(gene1[[1]])){ 350 | child$ConnectionGenes[[length(child$ConnectionGenes)+1]] <- gene1[[1]] 351 | } else { 352 | 353 | child$ConnectionGenes[[length(child$ConnectionGenes)+1]] <- gene2[[1]] 354 | } 355 | 356 | } 357 | } 358 | 359 | child$MaxNeuron = max(g1$MaxNeuron,g2$MaxNeuron) 360 | child$MutationRate <- g1$MutationRate 361 | return(child) 362 | } 363 | 364 | randomNeuron <- function(genes,nonInput,neatConfig){ 365 | assertTrueFunc(is(nonInput,"logical"),"nonInput must be a of class logical") 366 | neurons <- list() 367 | #print("genes randomNeuron") 368 | #print(genes) 369 | if(!nonInput){ 370 | for(i in seq(1,neatConfig$Inputs)){ 371 | neurons[i] <- T 372 | } 373 | } 374 | 375 | for(i in seq(1,neatConfig$Outputs)){ 376 | neurons[neatConfig$MaxNodes+i] <- T 377 | } 378 | 379 | for(gene in genes){ 380 | #print("RandomNeuron") 381 | #print(gene) 382 | #print(class(gene)) 383 | if(!nonInput | gene$InNode > neatConfig$Inputs){ 384 | neurons[gene$InNode] <- T 385 | } 386 | 387 | if(!nonInput | gene$OutNode > neatConfig$Inputs){ 388 | neurons[gene$OutNode] <- T 389 | } 390 | } 391 | 392 | matches <- unlist(lapply(neurons,function(x) { return(!is.null(x))})) 393 | candidates <- seq(1,length(matches))[matches] #Index of non-null neurons 394 | idx <- sample(candidates,1) 395 | return (idx) 396 | 397 | } 398 | 399 | containsLink <- function(genes,link){ 400 | for(gene in genes){ 401 | if(gene$InNode == link$InNode & gene$OutNode == link$OutNode){ 402 | return (T) 403 | } 404 | } 405 | 406 | return (F) 407 | } 408 | 409 | pointMutate <- function(genome,neatConfig){ 410 | assertTrueFunc(is(genome,"genome"),"Genome must be a of class genome") 411 | 412 | stepSize <- genome$MutationRate[["Step"]] 413 | 414 | for(i in neatseq(1,length(genome$ConnectionGenes))){ 415 | if(runif(1) < neatConfig$PerturbChance){ 416 | genome$ConnectionGenes[[i]]$Weight <- genome$ConnectionGenes[[i]]$Weight+runif(1)*stepSize*2-stepSize 417 | } else { 418 | genome$ConnectionGenes[[i]]$Weight <- runif(1)*4-2 419 | } 420 | } 421 | return(genome) 422 | } 423 | 424 | 425 | 426 | linkMutate <- function(genome,forceBias,neatConfig){ 427 | assertTrueFunc(is(genome,"genome"),"Genome must be a of class genome") 428 | assertTrueFunc(is(forceBias,"logical"),"forceBias must be a of class logical") 429 | 430 | neuron1 <- randomNeuron(genome$ConnectionGenes,F,neatConfig) 431 | neuron2 <- randomNeuron(genome$ConnectionGenes,T,neatConfig) 432 | 433 | newLink <- newConnectiongene() 434 | 435 | if(neuron1 <= neatConfig$Inputs & neuron2 <= neatConfig$Inputs){ 436 | #Both neurons are input nodes 437 | return(genome) 438 | } 439 | 440 | if(neuron2 <= neatConfig$Inputs){ 441 | #Swap output and input 442 | tmp <- neuron1 443 | neuron1<-neuron2 444 | neuron2<-tmp 445 | } 446 | 447 | 448 | 449 | newLink$InNode <- neuron1 450 | newLink$OutNode <- neuron2 451 | if(newLink$InNode > neatConfig$MaxNodes){ 452 | return(genome) #avoids wiring an outnode to another node 453 | } 454 | 455 | if(forceBias){ 456 | newLink$InNode <- neatConfig$Inputs 457 | } 458 | 459 | if(newLink$InNode == newLink$OutNode){ 460 | return(genome) #Avoids creating a link that points to itself 461 | } 462 | 463 | if(containsLink(genome$ConnectionGenes,newLink)){ 464 | return(genome) 465 | } 466 | 467 | newLink$Innovation <- newInnovation() 468 | newLink$Weight <- runif(1)*4-2 469 | genome$ConnectionGenes[[length(genome$ConnectionGenes)+1]] <- newLink 470 | return (genome) 471 | } 472 | 473 | #Disables a connection and replaces it with two that mimic the original 474 | #Is adding a node 475 | nodeMutate <- function(genome){ 476 | assertTrueFunc(is(genome,"genome"),"Genome must be a of class genome") 477 | 478 | if(length(genome$ConnectionGenes)==0){ 479 | return(genome) 480 | } 481 | 482 | genome$MaxNeuron <- genome$MaxNeuron + 1 483 | 484 | geneIndex <- sample(1:length(genome$ConnectionGenes),1) 485 | gene <- genome$ConnectionGenes[[geneIndex]] 486 | 487 | if(!gene$Enabled){ 488 | return (genome) 489 | } 490 | 491 | genome$ConnectionGenes[[geneIndex]]$Enabled = F 492 | 493 | gene1 <- gene 494 | gene1$OutNode <- genome$MaxNeuron 495 | gene1$Weight <- 1 496 | gene1$Innovation <- newInnovation() 497 | gene1$Enabled <- T 498 | genome$ConnectionGenes[[length(genome$ConnectionGenes)+1]] <- gene1 499 | 500 | gene2 <- gene 501 | gene2$InNode <- genome$MaxNeuron 502 | gene2$Innovation <- newInnovation() 503 | gene2$Enabled <- T 504 | genome$ConnectionGenes[[length(genome$ConnectionGenes)+1]] <- gene2 505 | 506 | 507 | return (genome) 508 | } 509 | 510 | enableDisableMutate <- function(genome,state){ 511 | assertTrueFunc(is(genome,"genome"),"Genome must be a of class genome") 512 | assertTrueFunc(is(state,"logical"),"State must be a of class logical") 513 | matches <- unlist(lapply(genome$ConnectionGenes,function(x) { return(x$Enabled!=state)})) 514 | candidates <- seq(1,length(matches))[matches] #Index of matching candidates 515 | 516 | if(length(candidates)==0){ 517 | return (genome) 518 | } 519 | 520 | idx <- sample(candidates,1) 521 | genome$ConnectionGenes[[idx]]$Enabled <- state 522 | return (genome) 523 | } 524 | 525 | mutateGenome <- function(genome,neatConfig){ 526 | assertTrueFunc(is(genome,"genome"),"Genome must be a of class genome") 527 | 528 | #Update the rate at which things mutate 529 | for(key in names(genome$MutationRate)){ 530 | rate <- genome$MutationRate[[key]] 531 | if(sample(1:2,1)==1){ 532 | genome$MutationRate[[key]] <- rate * (1-neatConfig$MutationIncOrDecRate) 533 | } else { 534 | genome$MutationRate[[key]] <- rate * (1/(1-neatConfig$MutationIncOrDecRate)) 535 | } 536 | } 537 | 538 | if(runif(1) < genome$MutationRate[["Connections"]]){ 539 | genome <- pointMutate(genome,neatConfig) #Done 540 | } 541 | 542 | p <- genome$MutationRate[["Link"]] 543 | while(p>0){ 544 | if(runif(1)0){ 552 | if(runif(1)0){ 560 | if(runif(1)0){ 568 | if(runif(1)0){ 576 | if(runif(1)0){ 692 | fitness <- unlist(lapply(pool$species[[i]]$genomes,function(x){x$Fitness})) 693 | if(!is.numeric(fitness)){ 694 | fitness <- 0 695 | } 696 | fitnessCutoff <- 0 697 | if(cutToOne){ 698 | fitnessCutoff <- max(fitness) 699 | } else { 700 | fitnessCutoff <- median(fitness) 701 | } 702 | 703 | survivedGenomeIdx <- fitness >= fitnessCutoff 704 | pool$species[[i]]$genomes<-pool$species[[i]]$genomes[survivedGenomeIdx] 705 | } 706 | } 707 | return (pool) 708 | } 709 | 710 | breedChild <- function(species,neatConfig){ 711 | #assertTrueFunc(is(species,"species"),"species must be a of class species") 712 | if(runif(1) pool$species[[i]]$topFitness){ 731 | pool$species[[i]]$topFitness <- max(fitness) 732 | pool$species[[i]]$staleness <- 0 733 | } else { 734 | pool$species[[i]]$staleness <- pool$species[[i]]$staleness + 1 735 | } 736 | } 737 | survivedIdx <- unlist(lapply(pool$species, function(x) { return (x$staleness < neatConfig$StaleSpecies ||x$topFitness >= pool$maxFitness) })) 738 | #print("survivedIdx") 739 | #print(survivedIdx) 740 | pool$species <- pool$species[survivedIdx] 741 | return (pool) 742 | } 743 | 744 | removeWeakSpecies <- function(pool,neatConfig){ 745 | assertTrueFunc(is(pool,"pool"),"pool must be a of class pool") 746 | tavf <- totalAverageFitness(pool) 747 | survivedIdx <- unlist(lapply(pool$species,function(x){ return (floor(x$averageFitness/tavf*neatConfig$SpeciesPopulation) >= 1)})) 748 | pool$species <- pool$species[survivedIdx] 749 | return (pool) 750 | } 751 | 752 | addToSpecies <- function(pool,child,neatConfig){ 753 | assertTrueFunc(is(pool,"pool"),"pool must be a of class pool") 754 | assertTrueFunc(is(child,"genome"),"child must be a of class genome") 755 | assertTrueFunc(is(neatConfig,"configNEAT"),"neatConfig must be a of class configNEAT") 756 | # print("child") 757 | # print(child) 758 | foundSpecies <- F 759 | 760 | for(i in neatseq(1,length(pool$species))){ 761 | #print(pool$species[[i]]) 762 | if(sameSpecies(child,pool$species[[i]]$genomes[[1]],neatConfig)){ 763 | pool$species[[i]]$genomes[[length(pool$species[[i]]$genomes)+1]] <- child 764 | foundSpecies <- T 765 | break 766 | } 767 | } 768 | 769 | if(!foundSpecies){ 770 | childspecies <- newSpecies() 771 | childspecies$genomes[[1]]<- child 772 | pool$species[[length(pool$species)+1]]<-childspecies 773 | } 774 | return (pool) 775 | } 776 | 777 | newGeneration <- function(pool,neatConfig){ 778 | pool <- cullSpecies(pool,F) 779 | pool <- rankGlobally(pool) 780 | pool <- removeStaleSpecies(pool,neatConfig) 781 | pool <- rankGlobally(pool) 782 | pool <- calculateAverageFitness(pool) 783 | pool <- removeWeakSpecies(pool,neatConfig) 784 | tavf <- totalAverageFitness(pool) 785 | 786 | children <- list() 787 | 788 | for(i in neatseq(1,length(pool$species))){ 789 | if(length(pool$species[[i]]$genomes) > 0){ 790 | nBreed <- floor(pool$species[[i]]$averageFitness/tavf*neatConfig$SpeciesPopulation)-1 791 | if(!is.numeric(nBreed)){ 792 | nBreed <- 0 793 | } 794 | #print(paste("nBreed",nBreed)) 795 | #print(paste("averageFitness",pool$species[[i]]$averageFitness)) 796 | #print(paste("tavf",tavf)) 797 | if(nBreed >0){ 798 | for(j in seq(1,nBreed)){ 799 | children[[length(children)+1]]<-breedChild(pool$species[[i]],neatConfig) 800 | } 801 | } 802 | } 803 | } 804 | 805 | pool <- cullSpecies(pool,T) 806 | while((length(children)+length(pool$species))0){ 881 | if(plotScene){ 882 | tCount <- 0 883 | while(tCount < config.video.phenotypedurationseconds){ 884 | tryCatch({drawPhenotypeNEAT(simulation$Pool$species[[i]]$genomes[[j]],simulation$Config)},error=function(e) print(paste("Error during draw:",e))) 885 | tCount <- tCount + 1/framesPerSecond 886 | } 887 | } 888 | #print(paste("Started simulation of species",i,"/",length(simulation$Pool$species),"genome",j,"/",length(simulation$Pool$species[[i]]$genomes))) 889 | state <- simulation$ProcessInitialStateFunc() 890 | fitness <- 0 891 | simulation$Pool$species[[i]]$genomes[[j]] <- generateNetwork(simulation$Pool$species[[i]]$genomes[[j]],simulation$Config) 892 | simulation$Pool$species[[i]]$genomes[[j]]$Fitness <- 0 893 | #Repeat acts like a do-while loop 894 | frameNum <- 0 895 | repeat{ 896 | if(plotScene){ 897 | simulation$PlotState(state) 898 | } 899 | neuralNetInputs <- simulation$ProcessStateToNeuralInputFunc(state) 900 | 901 | # print(simulation$Pool$species[[i]]$genomes[[j]]) 902 | pkg.env$debugGenome <-simulation$Pool$species[[i]]$genomes[[j]] 903 | neuralNetOutputs <- evaluateNetwork(simulation$Pool$species[[i]]$genomes[[j]]$Network,neuralNetInputs,simulation$Config) 904 | updatedState<-simulation$ProcessUpdateStateFunc(state,neuralNetOutputs) 905 | updatedFitness <- simulation$FitnessUpdateFunc(state,updatedState,simulation$Pool$species[[i]]$genomes[[j]]$Fitness) 906 | simulation$Pool$species[[i]]$genomes[[j]]$Fitness <- updatedFitness 907 | 908 | 909 | if(simulation$TerminationCheckFunc(frameNum,state,updatedState,fitness,updatedFitness)){ 910 | break 911 | } 912 | 913 | fitness <- updatedFitness 914 | state <- updatedState 915 | frameNum <- frameNum + 1 916 | } 917 | simulation$Pool$species[[i]]$genomes[[j]]$Fitness <- updatedFitness 918 | print(paste(round(pctSimulated,2),"% Finished simulation of species",i,"/",length(simulation$Pool$species),"genome",j,"/",length(simulation$Pool$species[[i]]$genomes),"with fitness",updatedFitness)) 919 | #print(paste(round(pctSimulated,2),"% Finished simulation of species",i,"genome",j,"with fitness",updatedFitness)) 920 | } else { 921 | print(paste("Skipped simulation of species",i,"genome",j,"due to no connection genes")) 922 | } 923 | 924 | if(plotScene){ 925 | tCount <- 0 926 | while(tCount < config.video.performancedurationseconds){ 927 | plotPerformanceTracker(simulation$PerformanceTracker) 928 | tCount <- tCount + 1/framesPerSecond 929 | } 930 | } 931 | return(simulation) 932 | } 933 | 934 | pkg.env$debugGenome <- 0 935 | 936 | #' Runs a single generation 937 | #' 938 | #' Takes in a simulation, runs all the genomes, evaluates fitness and breeds the new generation 939 | #' @param simulation Takes a NEATSimulation class 940 | #' @param createVideo True/False to save a video of the highest fitness simulation 941 | #' @param videoPath Path to where to save the video 942 | #' @param videoName Name of the video 943 | #' @param framesPerSecond The frames per second of the video 944 | #' @return NEATSimulation class with new generation of genomes 945 | #' @export 946 | NEATSimulation.RunSingleGeneration <- function(simulation, createVideo=F, videoPath="videos",videoName="", framesPerSecond=1){ 947 | assertTrueFunc(is(simulation,"NEATSimulation"),"simulation must be a of class NEATSimulation") 948 | oldMaxFitness <- simulation$Pool$maxFitness 949 | 950 | print("Starting simulations...") 951 | counter <- 1 952 | nTot <- calcTotalNumOfGenomes(simulation) 953 | for(i in seq(1,length(simulation$Pool$species))){ 954 | for(j in seq(1,length(simulation$Pool$species[[i]]$genomes))){ 955 | simulation <- simulationRunner(simulation,i,j,F,100*counter/nTot) 956 | counter <- counter + 1 957 | } 958 | } 959 | simulation$Pool <- newGeneration(simulation$Pool,simulation$Config) 960 | #print(paste("MaxFitness:",simulation$Pool$maxFitness)) 961 | 962 | simulation$PerformanceTracker[simulation$Pool$generation,] <- c(simulation$Pool$generation,simulation$Pool$minFitness,simulation$Pool$maxFitness,simulation$Pool$meanFitness,simulation$Pool$medianFitness) 963 | print(simulation$PerformanceTracker[simulation$Pool$generation,]) 964 | if(createVideo){ 965 | createdVid <- F 966 | for(i in seq(1,length(simulation$Pool$species))){ 967 | for(j in neatseq(1,length(simulation$Pool$species[[i]]$genomes))){ 968 | if(simulation$Pool$species[[i]]$genomes[[j]]$Fitness==simulation$Pool$maxFitness & !createdVid){ 969 | if(oldMaxFitness != simulation$Pool$maxFitness){ 970 | videoName = paste(videoPath,"/",videoName,"generation",simulation$Pool$generation,"fitness",simulation$Pool$maxFitness,"species",i,"genome",j,".mpeg",sep="") 971 | print(paste("Creating video",videoName,"...")) 972 | oopt = ani.options(ani.width = 1200, ani.height = 800, other.opts = "-define png:color-type=2") 973 | saveVideo(simulationRunner(simulation,i,j,T,100,framesPerSecond),interval=1/framesPerSecond,ani.options=oopt,video.name=videoName) 974 | ani.options(oopt) 975 | } else { 976 | print("Max Fitness did not increase on this generation so skipping creating a video") 977 | } 978 | createdVid <- T 979 | } 980 | } 981 | } 982 | } 983 | 984 | return (simulation) 985 | } 986 | 987 | #' Runs a genome and tracks the state history (will run the most fit by default) 988 | #' 989 | #' Runs a genome and tracks the state history (will run the most fit by default) 990 | #' @param simulation Takes a NEATSimulation class 991 | #' @param genomeNum the genome number to run 992 | #' @param speciesNum the species number to run 993 | #' @return State history 994 | #' @export 995 | NEATSimulation.GetStateHistoryForGenomeAndSpecies <- function(simulation, genomeNum=NA, speciesNum=NA){ 996 | assertTrueFunc(is(simulation,"NEATSimulation"),"simulation must be a of class NEATSimulation") 997 | if(is.na(genomeNum) || is.na(speciesNum)){ 998 | print("No genome or species specified, using the most fit genome") 999 | genome <- findMostFitGenome(simulation) 1000 | } else { 1001 | assertTrueFunc(is(genomeNum,"numeric"),"genomeNum must be numeric") 1002 | assertTrueFunc(is(speciesNum,"numeric"),"speciesNum must be numeric") 1003 | genome <- simulation$Pool$species[[i]]$genomes[[j]] 1004 | assertTrueFunc(is(genome,"genome"),"Invalid species or genome number") 1005 | } 1006 | 1007 | 1008 | state <- simulation$ProcessInitialStateFunc() 1009 | stateHist <- as.data.frame(t(unlist(state))) 1010 | fitness <- 0 1011 | genome$Fitness <- fitness 1012 | genome <- generateNetwork(genome,simulation$Config) 1013 | 1014 | #Repeat acts like a do-while loop 1015 | frameNum <- 0 1016 | repeat{ 1017 | 1018 | neuralNetInputs <- simulation$ProcessStateToNeuralInputFunc(state) 1019 | neuralNetOutputs <- evaluateNetwork(genome$Network,neuralNetInputs,simulation$Config) 1020 | updatedState<-simulation$ProcessUpdateStateFunc(state,neuralNetOutputs) 1021 | updatedFitness <- simulation$FitnessUpdateFunc(state,updatedState,genome$Fitness) 1022 | genome$Fitness <- updatedFitness 1023 | 1024 | stateHist<-rbind(stateHist,unlist(updatedState)) 1025 | 1026 | if(simulation$TerminationCheckFunc(frameNum,state,updatedState,fitness,updatedFitness)){ 1027 | break 1028 | } 1029 | 1030 | fitness <- updatedFitness 1031 | state <- updatedState 1032 | frameNum <- frameNum + 1 1033 | } 1034 | genome <- updatedFitness 1035 | 1036 | return((stateHist)) 1037 | 1038 | } 1039 | 1040 | #' @export 1041 | plot.NEATSimulation <- function(simulation){ 1042 | plotPerformanceTracker(simulation$PerformanceTracker) 1043 | } 1044 | 1045 | plotPerformanceTracker <- function(data){ 1046 | plot(x=data[,"generation"],y=data[,"maxFitness"],col="blue",main="Fitness",xlab="Generation",ylab="Fitness",type="o",ylim=c(0,max(data[,"maxFitness"])),lwd=2) 1047 | lines(x=data[,"generation"],y=data[,"minFitness"],col="red",type="o",lwd=2) 1048 | lines(x=data[,"generation"],y=data[,"meanFitness"],col="green",type="o",lwd=2) 1049 | lines(x=data[,"generation"],y=data[,"medianFitness"],col="purple",type="o",lwd=2) 1050 | legend(x='bottomright', c("Min","Max","Mean","Median"), fill=c("red","blue","green","purple"), bty='n') 1051 | 1052 | } 1053 | 1054 | 1055 | 1056 | 1057 | 1058 | 1059 | 1060 | 1061 | 1062 | 1063 | 1064 | 1065 | 1066 | 1067 | 1068 | --------------------------------------------------------------------------------