Rnn

La Consejería de Empleo de la Función General de la Comunidad Autónoma de Ordenación Provincia de la Audiencia Profesional

Ciencia De Datos

Ese es el nombre agramatical de una nueva consejería pergeñada por una red neuronal recurrente que he ajustado usando un año de BOEs.

El código, adaptado de aquí y sustancialmente mejorado, es

library(mxnet)

batch.size     <- 32
seq.len        <- 64
num.hidden     <- 128
num.embed      <- 8
num.lstm.layer <- 1
num.round      <- 1
learning.rate  <- 0.1
wd             <- 0.00001
clip_gradient  <- 1
update.period  <- 1

make.data <- function(dir.boe, seq.len = 32,
  max.vocab=10000, dic = NULL) {
  text <- lapply(dir(dir.boe), readLines)
  text <- lapply(text, paste, collapse = "\n")
  text <- paste(text, collapse = "\n")

  char.lst <- strsplit(text, '')[[1]]
  chars <- unique(char.lst)

  num.seq  <- floor(length(char.lst) / seq.len)
  char.lst <- char.lst[1:(num.seq * seq.len)]
  data <- matrix(match(char.lst, chars) - 1, seq.len, num.seq)

  dic <- as.list(1:length(chars))
  names(dic) <- chars

  lookup.table <- as.list(chars)

  return (list(data = data, dic = dic,
    lookup.table = lookup.table))
}


ret <- make.data(".", seq.len=seq.len)

X   <- ret$data
dic <- ret$dic
lookup.table <- ret$lookup.table

vocab <- length(dic)

train.val.fraction <- 0.9
train.cols <- floor(ncol(X) * train.val.fraction)

drop.tail <- function(x, batch.size) {
  nstep <- floor(ncol(x) / batch.size)
  x[, 1:(nstep * batch.size)]
}

get.label <- function(X)
  matrix(c(X[-1], X[1]), nrow(X), ncol(X))

X.train.data   <- X[, 1:train.cols]
X.train.data   <- drop.tail(X.train.data, batch.size)
X.train.label  <- get.label(X.train.data)
X.train        <- list(data=X.train.data, label=X.train.label)

X.val.data     <- X[, -(1:train.cols)]
X.val.data     <- drop.tail(X.val.data, batch.size)
X.val.label    <- get.label(X.val.data)
X.val          <- list(data=X.val.data, label=X.val.label)


model <- mx.lstm(X.train, X.val,
    ctx=mx.cpu(),
    num.round=num.round,
    update.period=update.period,
    num.lstm.layer=num.lstm.layer,
    seq.len=seq.len,
    num.hidden=num.hidden,
    num.embed=num.embed,
    num.label=vocab,
    batch.size=batch.size,
    input.size=vocab,
    initializer=mx.init.uniform(0.1),
    learning.rate=learning.rate,
    wd=wd,
    clip_gradient=clip_gradient)


get.sample <- function(n, start = "<", random.sample = TRUE){

  make.output <- function(prob, sample = FALSE) {
    prob <- as.numeric(as.array(prob))
    if (!sample)
      return(which.max(as.array(prob)))
    sample(1:length(prob), 1, prob = prob^2)
  }

  infer.model <- mx.lstm.inference(
      num.lstm.layer=num.lstm.layer,
      input.size=vocab,
      num.hidden=num.hidden,
      num.embed=num.embed,
      num.label=vocab,
      arg.params=model$arg.params,
      ctx=mx.cpu())

  out <- start
  last.id <- dic[[start]]

  for (i in 1:(n-1)) {
    ret <- mx.lstm.forward(infer.model, last.id - 1, FALSE)
    infer.model <- ret$model
    last.id <- make.output(ret$prob, random.sample)
    out <- paste0(out, lookup.table[[last.id]])
  }
  out
}

cat(get.sample(1000, start = "A", random.sample = T))

Lo anterior genera cosas tales como: