R Notebook - Multi-Layer Perceptron

Notebook com códigos R para a implementação do Multi-Layer Perceptron - ERAMIA 2020

Código baseado na implementação do professor Rodrigo Mello - ICMC/USP

https://www.youtube.com/watch?v=FSvD2HT0Zfg

Primeiro vamos implementar uma função de ativação

funcao.ativacao <- function(v){

  # Função logística
  y <- 1 / (1 + exp(-v))

  return(y)
}

Vamos também precisar da derivada da função de ativação

der.funcao.ativacao <- function(y){

  # Derivada da logística
  derivada <- y * (1 - y)

  return(derivada)
}

Vamos criar uma arquitetura para nossa MLP

arquitetura <- function(num.entrada, num.escondida, num.saida,
                        funcao.ativacao, der.funcao.ativacao){

  arq <- list()

  # Parametros da rede    
  arq$num.entrada <- num.entrada
  arq$num.escondida <- num.escondida
  arq$num.saida <- num.saida
  arq$funcao.ativacao <- funcao.ativacao
  arq$der.funcao.ativacao <- der.funcao.ativacao

  # 2 neuronios na camada escondida
  # 
  #       Ent1    Ent2   Bias 
  # 1     w11     w12    w13
  # 2     w21     w22    w23

  # Pesos conectando entrada e escondida
  num.pesos.entrada.escondida <- (num.entrada+1)*num.escondida
  arq$escondida <- matrix(runif(min=-0.5,max=0.5, num.pesos.entrada.escondida),
                                nrow=num.escondida, ncol=num.entrada+1)

  # Pesos conectando escondida e saida
  num.pesos.escondida.saida <- (num.escondida+1)*num.saida
  arq$saida <- matrix(runif(min=-0.5,max=0.5,  num.pesos.escondida.saida),
                            nrow=num.saida, ncol=num.escondida+1)


  return(arq)
}

Precisamos de um código para a fase de propagação da MLP

mlp.propagacao <- function(arq, exemplo){

  # Entrada -> Cama Escondida
  v.entrada.escondida <- arq$escondida %*% as.numeric(c(exemplo,1))
  y.entrada.escondida <- arq$funcao.ativacao(v.entrada.escondida)

  # Camada Escondida -> Camada de Saida
  v.escondida.saida <- arq$saida %*% c(y.entrada.escondida,1)
  y.escondida.saida <- arq$funcao.ativacao(v.escondida.saida)

  # Resultados
  resultado <- list()
  resultado$v.entrada.escondida <- v.entrada.escondida
  resultado$y.entrada.escondida <- y.entrada.escondida
  resultado$v.escondida.saida <- v.escondida.saida
  resultado$y.escondida.saida <- y.escondida.saida

  return(resultado)
}

Agora o código para a fase de treinamento da MLP, usando o algoritmo Back-propagation

mlp.retropropagacao <- function(arq, dados, n, limiar){

  erroQuadratico <- 2 * limiar
  epocas <- 0

  # Treina eqto o erro quadratico for maior que um limiar
  while(erroQuadratico > limiar){
    erroQuadratico <- 0

    # Treino para todos os exemplos (epoca)
    for(i in 1:nrow(dados)){

      # Pego um exemplo de entrada
      x.entrada <- dados[i,1:arq$num.entrada]
      x.saida <- dados[i,ncol(dados)]

      # Pego a saida da rede para o exemplo
      resultado <- mlp.propagacao(arq,x.entrada)
      y <- resultado$y.escondida.saida

      # Calculo do erro para o exemplo
      erro <- x.saida - y

      # Soma erro quadratico
      erroQuadratico <- erroQuadratico + erro*erro

      # Gradiente local no neuronio de saida
      # erro * derivada da funcao de ativacao
      grad.local.saida <- erro * arq$der.funcao.ativacao(y)

      # Gradiente local no neuronio escondido
      # derivada da funcao de ativacao no neuronio escondido * soma dos gradientes
      # locais dos neuronios conectados na proxima camada * pesos conectando a camada
      # escondida com a saida
      pesos.saida <- arq$saida[,1:arq$num.escondida]
      grad.local.escondida <-
        as.numeric(arq$der.funcao.ativacao(resultado$y.entrada.escondida)) *
        (grad.local.saida %*% pesos.saida)

      # Ajuste dos pesos
      # Saida
      arq$saida <- arq$saida + n * (grad.local.saida %*%
                                     c(resultado$y.entrada.escondida,1))
      # Escondida
      arq$escondida <- arq$escondida + n * (t(grad.local.escondida) %*%
                                             as.numeric(c(x.entrada,1)))
    } # Fim for(i in 1:nrow(dados))

    erroQuadratico <- erroQuadratico / nrow(dados)
    cat("Erro Quadratico Medio = ",erroQuadratico, "\n")
    epocas <- epocas+1
    
  } # Fim while(erroQuadratico > limiar)

  retorno <- list()
  retorno$arq <- arq
  retorno$epocas <- epocas

  return(retorno)
}

Leitura de uma tabela com os dados do problema XOR

dados <- read.table('XOR.txt')
dados

Vamos treinar nossa MLP

arq <- arquitetura(2,2,1,funcao.ativacao, der.funcao.ativacao)
modelo <- mlp.retropropagacao(arq,dados,0.1,1e-3)

Vamos testar em dados novos

retorno <- mlp.propagacao(modelo$arq,c(0,1))
retorno$y.escondida.saida

mlp.propagacao(modelo$arq,c(1,0))$y.escondida.saida

mlp.propagacao(modelo$arq,c(1,1))$y.escondida.saida

mlp.propagacao(modelo$arq,c(0,0))$y.escondida.saida

---

Leitura de dados sobre risco de crédito.

Queremos prever, com base nas variáveis de entrada, se ocorrerá ou não um calote em 10 anos

dataset <- read.csv("creditset.csv")
head(dataset)

# clientid: identificação do cliente
# income: renda anual
# age: idade
# loan: empréstimo com data de no mínimo 10 anos atrás
# LTI: razão entre valor do empréstimo e renda anual
# default10yr: se ocorrerá (1) ou não (0) um calote em 10 anos

Vamos utilizar como variáveis de entrada LTI e age

dados <- dataset[,c(3,5,6)]
dados[,1:2] <- scale(dados[,1:2]) # normalização dos dados (media 0 e desvio 1)

Vamos escolher aleatoriamente dados para treino e teste O conjunto de dados já está randomizado. Assim, Vamos pegar os primeiros 1400 exemplos para treino e o restante para teste

dados.treino <- dados[1:1400,]
dados.teste <- dados[1401:2000,]

Vamos treinar nossa rede com 4 neurônios na camada escondida

arq <- arquitetura(2,4,1,funcao.ativacao, der.funcao.ativacao)
modelo <- mlp.retropropagacao(arq,dados.treino,0.3,1e-3)

Fazendo predicoes para cada exemplo de teste

predicoes <- vector()
for(i in 1:nrow(dados.teste)){

  pred <- mlp.propagacao(modelo$arq,dados.teste[i,1:2])$y.escondida.saida
    
  predicoes <- c(predicoes,pred)
}

Criando uma matriz para comparação dos resultados

matriz.comparacao <- cbind(dados.teste[,3],predicoes)
colnames(matriz.comparacao) <- c('V','P')
matriz.comparacao

Matriz de confusão com o arredondamento das predições

table(matriz.comparacao[,1],round(matriz.comparacao[,2]))