set.seed(111)
n.trial = 1000; N = 10; sigma = 1
Q.star = runif(N); Q = rep(0, N)
count = rep(0,N); Q.cum = rep(0, N)
rew.earned = rep(0,n.trial)
### playing slot-machine
for (i.trial in 1:n.trial){
max.a = max(Q)
max.idx = which(Q == max.a)
if (length(max.idx)>1){
max.idx = sample(max.idx, 1)
}
r.t = rnorm(1, Q.star[max.idx], sd = sigma)
Q.cum[max.idx] = Q.cum[max.idx] + r.t
count[max.idx] = count[max.idx] + 1
Q[max.idx] = Q.cum[max.idx] / count[max.idx]
rew.earned[i.trial] = r.t
}
plot(rew.earned,type='l')
Q
Category Archives: 認知情報解析
認知情報解析学演習b
init.RNN <- function(n.uniq,size.hidden){
W.h = matrix(rnorm(size.hidden*size.hidden), nrow = size.hidden)*0.01
W.x = matrix(rnorm(n.uniq*size.hidden), nrow = n.uniq)*0.01
b.h = matrix(rnorm(size.hidden), nrow = 1)*0.01
W.o = matrix(rnorm(n.uniq*size.hidden),nrow = size.hidden)*0.01
b.o = matrix(rnorm(n.uniq), nrow = 1)*0.01
return(list(W.h = W.h, W.x= W.x, b.h = b.h, W.o = W.o, b.o = b.o))
}
affine.forwd <- function(x, W, b){
return(x%*%W + matrix(1, nrow = nrow(x), ncol = 1)%*%b)
}
affine.bckwd <- function(x, W, b, dout){
dx = dout%*%t(W)
dW = t(x)%*%dout
db = colSums(dout)
return(list(dx = dx, dW = dW, db = db))
}
softmax.forwd <- function(x, target){
max.x = apply(x,1,max)
C = ncol(x)
x = x - max.x%*%matrix(1,nrow=1,ncol=C)
y = exp(x)/rowSums(exp(x))
delta = 1e-7;
R = nrow(as.matrix(y))
return(-sum(target*log(y + delta))/R)
}
softmax.pred <- function(x, target){
max.x = apply(x,1,max)
C = ncol(x)
x = x - max.x%*%matrix(1,nrow=1,ncol=C)
y = exp(x)/rowSums(exp(x))
return(y)
}
softmax.bckwd <- function(x, target, dout = 1){
max.x = apply(x, 1, max)
R = nrow(x)
C = ncol(x)
x = x - max.x%*%matrix(1,nrow=1,ncol=C)
y = exp(x)/rowSums(exp(x))
return((y-target)/R)
}
RNN.forward <- function(h.prev, x, network){
b.size = nrow(x)
h = h.prev%*%network$W.h + x%*%network$W.x
hb = h+matrix(1,nrow=b.size,ncol=1)%*%network$b.h
h.next = tanh(hb)
return(h.next = h.next)
}
RNN.backward <- function(dh.next, network, x, h.next, h.prev){
dt = dh.next * (1- h.next^2)
db = colSums(dt)
dW.h = t(h.prev)%*%dt
dh.prev = dt%*%t(network$W.h)
dW.x = t(x)%*%dt
dx = dt%*%t(network$W.x)
return(list(db = db, dW.h = dW.h, dh.prev = dh.prev, dW.x = dW.x, dx=dx))
}
txt = "You say goodbye and I say hello. you say goodbay and I say hello"
txt2corpus <- function(txt){
txt = tolower(txt)
txt = gsub('[.]', ' . sos',txt)
words = unlist(strsplit(c('sos',txt), " "))
uniq.words = unique(words)
n.uniq = length(uniq.words)
n.words = length(words)
corpus = rep(0,n.words)
corpus = match(words,uniq.words)
return(corpus)
}
corp2contxt1SRNN = function(corpus){
len.corp = length(corpus)
# creating target matrix
idxT = cbind(1:(len.corp-1), corpus[2:len.corp])
targ1S = matrix(0,nrow=len.corp-1,ncol=length(unique(corpus)))
targ1S[idxT]=1
# creating context matrices
idxC = cbind(1:(len.corp-1),corpus[1:(len.corp-1)])
contxt = matrix(0,nrow=len.corp-1,ncol=length(unique(corpus)))
contxt[idxC]=1
return(list(y=targ1S,x=contxt))
}
corp = txt2corpus(txt)
dat = corp2contxt1SRNN(corp)
size.hidden = 7
network <- init.RNN(8,size.hidden)
n.rep = 100000;lambda = 0.01;batch.size = 3; time = 3;
h.prev =array(0, c(batch.size, size.hidden, time))
h.next = array(0, c(batch.size, size.hidden, (time+1)))
loss = rep(0,n.rep)
for (i.rep in 1:n.rep){
for (i.t in 1:time){
idx = seq(i.t, corp.len, time)
h.next[, , i.t] = RNN.forward(h.prev[, , i.t], dat$x[idx,], network)
if (i.t < time){
h.prev[, , (i.t+1)] = h.next[, , i.t]
}
}
dWHs = matrix(0,nrow=nrow(network$W.h),ncol=ncol(network$W.h))
dWXs = matrix(0,nrow=nrow(network$W.x),ncol=ncol(network$W.x))
dBHs = matrix(0,nrow=nrow(network$b.h),ncol=ncol(network$b.h))
dWOs = matrix(0,nrow=nrow(network$W.o),ncol=ncol(network$W.o))
dBOs = matrix(0,nrow=nrow(network$b.o),ncol=ncol(network$b.o))
d.prev = matrix(0,nrow=batch.size,ncol=size.hidden)
L = 0
for (i.t in time:1){
idx = idx = seq(i.t, corp.len, time)
O = affine.forwd(h.next[,,i.t], network$W.o, network$b.o)
L = L + softmax.forwd(O, dat$y[idx,])
ds = softmax.bckwd(O, dat$y[idx,], 1)
dW.o = affine.bckwd(h.next[,,i.t], network$W.o, network$b.o, ds)
dWOs = dWOs + dW.o$dW
dBOs = dBOs + dW.o$db
RNN.d = RNN.backward(dW.o$dx+d.prev, network, dat$x[idx,],h.next[,,(i.t+1)],h.prev[,,i.t])
dWHs = dWHs + RNN.d$dW.h
dWXs = dWXs + RNN.d$dW.x
dBHs = dBHs + RNN.d$db
d.prev = RNN.d$dh.prev
}
loss[i.rep] = L
network$W.o = network$W.o - lambda*dWOs
network$b.o = network$b.o - lambda*dBOs
network$W.h = network$W.h - lambda*dWHs
network$W.x = network$W.x - lambda*dWXs
network$b.h = network$b.h - lambda*dBHs
}
plot(loss,type='l')
par(mfrow=c(9,1))
for (i.t in 1:time){
idx = idx = seq(i.t, corp.len, time)
O = affine.forwd(h.next[,,i.t], network$W.o, network$b.o)
print(softmax.pred(O, dat$y[idx,]))
for (i in 1:3){
barplot(softmax.pred(O, dat$y[idx,])[i,])
}
}
認知情報解析学演習 DL-2 ch.5
txt = "You say goodbye and I say hello."
txt2corpus <- function(txt){
txt = tolower(txt)
txt = gsub('[.]', ' . sos',txt)
words = unlist(strsplit(c('sos',txt), " "))
uniq.words = unique(words)
n.uniq = length(uniq.words)
n.words = length(words)
corpus = rep(0,n.words)
corpus = match(words,uniq.words)
return(corpus)
}
corp = txt2corpus(txt)
corp2contxt1SRNN = function(corpus){
len.corp = length(corpus)
# creating target matrix
idxT = cbind(1:(len.corp-1), corpus[2:len.corp])
targ1S = matrix(0,nrow=len.corp-1,ncol=length(unique(corpus)))
targ1S[idxT]=1
# creating context matrices
idxC = cbind(1:(len.corp-1),corpus[1:(len.corp-1)])
contxt = matrix(0,nrow=len.corp-1,ncol=length(unique(corpus)))
contxt[idxC]=1
return(list(y=targ1S,x=contxt))
}
dat<-corp2contxt1SRNN(corp)
init.RNN <- function(n.uniq,size.hidden){
W.h = matrix(rnorm(size.hidden*size.hidden),nrow=size.hidden)*0.01
W.x = matrix(rnorm(n.uniq*size.hidden),nrow=n.uniq)*0.01
b = matrix(rnorm(size.hidden),nrow=1)*0.01
return(list(W.h = W.h, W.x= W.x, b = b))
}
RNN.forward <- function(h.prev, x, network){
b.size = nrow(x)
h = h.prev%*%network$W.h + x.temp%*%network$W.x
hb = h+matrix(1,nrow=b.size,ncol=1)%*%network$b
h.next = tanh(hb)
return(h.next = h.next)
}
RNN.backward <- function(dh.next, network, x, h.next, h.prev){
dt = dh.next * (1- h.next^2)
db = colSums(dt)
dW.h = t(h.prev)%*%dt
dh.prev = dt%*%t(network$W.h)
dW.x = t(x)%*%dt
dx = dt%*%t(network$W.x)
return(list(db = db, dW.h = dW.h, dh.prev = dh.prev, dW.x = dW.x, dx=dx))
}
affine.forwd <- function(x, W, b){
return(x%*%W + matrix(1, nrow = nrow(x), ncol = 1)%*%b)
}
affine.bckwd <- function(x, W, b, dout){
dx = dout%*%t(W)
dW = t(x)%*%dout
db = colSums(dout)
return(list(dx = dx, dW = dW, db = db))
}
softmax.forwd <- function(x, target){
max.x = apply(x,1,max)
C = ncol(x)
x = x - max.x%*%matrix(1,nrow=1,ncol=C)
y = exp(x)/rowSums(exp(x))
delta = 1e-7;
R = nrow(as.matrix(y))
return(-sum(target*log(y + delta))/R)
}
softmax.bckwd <- function(x, target, dout = 1){
max.x = apply(x, 1, max)
R = nrow(x)
C = ncol(x)
x = x - max.x%*%matrix(1,nrow=1,ncol=C)
y = exp(x)/rowSums(exp(x))
return((y-target)/R)
}
# checking modules
batch.size = 3; time = 3
corp.len = nrow(dat$y)
size.hidden = 5
h.prev =array(0, c(batch.size, size.hidden, time))
h.next = array(0, c(batch.size, size.hidden, time))
for (i.t in 1:time){
idx = seq(i.t, corp.len, batch.size)
h.next[, , i.t] = RNN.forward(h.prev[, , i.t], dat$x[idx,], network)
if (i.t < time){
h.prev[, , (i.t+1)] = h.next[, , i.t]
}
}
W.out = matrix(rnorm(size.hidden * 8), nrow = size.hidden)
b.out = matrix(rnorm(8), nrow = 1)
O = affine.forwd(h.next[,,3], W.out, b.out)
L = softmax.forwd(O, dat$y[c(3,6,9),])
ds = softmax.bckwd(O, dat$y[c(3,6,9),], 1)
dW.o = affine.bckwd(O, W.out, ds)
認知情報解析演習 DL-V2 ch4
# p136
embed.forwd <- function(W, idx){
return(W[idx,])
}
h1 <- embed.forwd(W,idx1)
h2 <- embed.forwd(W,idx2)
h = (h1 + h2)/2
embed.dot.forwd <- function(W, h, idx){
return(O=rowSums(W[idx,]*h))
}
s = embed.dot.forwd(network$W.out,h,batch.y)
sigmoid.forwd <- function(O){
return(1/(1+exp(-O)))
}
sigmoidWL.forwd <- function(O,target){
y = 1/(1+exp(-O))
loss=-sum(target*log(y)+(1-target)*log(1 - y))
return(loss)
}
sigmoidWL.backwd <- function(O,target,dout=1){
y = 1/(1+exp(-O))
dW = (y - target)*dout
return(dW)
}
embed.dot.backwd <- function(W,h,idx,dout){
dh = dout * W[idx,]
dW = dout * h
return(list(dh = dh, dW = dW))
}
embed.backwd <- function(W, idx, dout){
dW = matrix(0,nrow(W),ncol(W))
for (i.idx in 1:length(idx)){
dW[idx[i.idx], ] = dW[idx[i.idx], ] + dout[i.idx, ]
}
return(dW)
}
# 158
txt2corpus <- function(txt){
txt = tolower(txt)
txt = gsub('[.]', ' .',txt)
words = unlist(strsplit(txt, " "))
uniq.words = unique(words)
n.uniq = length(uniq.words)
n.words = length(words)
corpus = rep(0,n.words)
corpus = match(words,uniq.words)
return(corpus)
}
corp2contxt <- function(corpus){
len.corp = length(corpus)
target = corpus[2:(len.corp-1)]
col1 = corpus[1:(len.corp-2)]
col2 = corpus[3:len.corp]
context = cbind(col1,col2)
return(list(context=context,target = target))
}
init.W2V <- function(n.uniq,size.hidden){
W.in = matrix(rnorm(n.uniq*size.hidden),nrow=n.uniq)*0.01
W.out = matrix(rnorm(n.uniq*size.hidden),nrow=n.uniq)*0.01
return(list(W.in = W.in, W.out= W.out))
}
### running example
network<-init.W2V(8,5)
n.batch = 3;
txt = "You say goodbye and I say hello.."
corp = txt2corpus(txt)
corp = c(8,8,corp)
dat<-corp2contxt(corp)
n.data = length(dat$target)
n.iter = 3000;
lambda=0.1;
loss = rep(0, n.iter)
for (i.iter in 1:n.iter){
samp.idx = sample(1:n.data,n.batch)
batch.c1 = dat$context[samp.idx,1]
batch.c2 = dat$context[samp.idx,2]
batch.y = dat$target[samp.idx]
h1 <- embed.forwd(network$W.in,batch.c1)
h2 <- embed.forwd(network$W.in,batch.c2)
h = 0.5 * (h1 + h2)
# positive only
s = embed.dot.forwd(network$W.out,h,batch.y)
z = sigmoidWL.forwd(s,1)
loss[i.iter] = z
ds = sigmoidWL.backwd(s, 1, 1)
dE = embed.dot.backwd(network$W.out,h, batch.y, ds)
dh = dE$dh*0.5
dIn1 = embed.backwd(network$W.in,dat$context[samp.idx,1], dh)
dIn2 = embed.backwd(network$W.in,dat$context[samp.idx,2], dh)
network$W.out[batch.y,] = network$W.out[batch.y,] - lambda*dE$dW
network$W.in = network$W.in - lambda*dIn1
network$W.in = network$W.in - lambda*dIn2
}
plot(loss, type='l')
samp.idx = c(2:6,8,9,1)
batch.c1 = dat$context[samp.idx,1]
batch.c2 = dat$context[samp.idx,2]
batch.y = dat$target[samp.idx]
h1 <- embed.forwd(network$W.in,batch.c1)
h2 <- embed.forwd(network$W.in,batch.c2)
h = 0.5 * (h1 + h2)
s = MatMult.forwd(h,t(network$W.out))
z = sigmoid.forwd(s)
res=cbind(z,batch.y)
par(mfrow=c(8,1))
for (i in 1:8){
col.spec = rep("black",8)
col.spec[i]="orange"
barplot(res[i, 1:8],col=col.spec)
}
# with negative sampling
# p158
unigram.sampler <- function(corpus, target, power, sample.size){
neg.corpus <- corpus[-which(corpus == target)]
uniq.word = unique(neg.corpus)
n.word = length(neg.corpus)
prob = (as.vector(table(neg.corpus))/n.word)^power
prob = prob/sum(prob)
sample.idx = sample(uniq.word, sample.size, prob = prob)
return(sort(sample.idx))
}
get.neg.sample <- function(corpus, target, power, sample.size){
sample.id = matrix(0, nrow = length(target), ncol = sample.size)
for (i.targ in 1:length(target)){
sample.id[i.targ,] = unigram.sampler(corpus, target[i.targ], power, sample.size)
}
return(sample.id)
}
init.W2V <- function(n.uniq,size.hidden){
W.in = matrix(rnorm(n.uniq*size.hidden),nrow=n.uniq)*0.01
W.out = matrix(rnorm(n.uniq*size.hidden),nrow=n.uniq)*0.01
return(list(W.in = W.in, W.out= W.out))
}
network<-init.W2V(8,5)
n.batch = 3;
txt = "You say goodbye and I say hello.."
corp = txt2corpus(txt)
corp = c(8,8,corp)
dat<-corp2contxt(corp)
n.data = length(dat$target)
n.iter = 3000;
lambda=0.1;
loss = rep(0, n.iter)
sample.size = 2
for (i.iter in 1:n.iter){
samp.idx = sample(1:n.data,n.batch)
batch.c1 = dat$context[samp.idx,1]
batch.c2 = dat$context[samp.idx,2]
batch.y = dat$target[samp.idx]
h1 <- embed.forwd(network$W.in,batch.c1)
h2 <- embed.forwd(network$W.in,batch.c2)
h = 0.5 * (h1 + h2)
# positive
s = embed.dot.forwd(network$W.out,h,batch.y)
z = sigmoidWL.forwd(s,1)
loss[i.iter] = z
ds = sigmoidWL.backwd(s, 1, 1)
dE = embed.dot.backwd(network$W.out,h, batch.y, ds)
dh = dE$dh*0.5
dIn1 = embed.backwd(network$W.in,dat$context[samp.idx,1], dh)
dIn2 = embed.backwd(network$W.in,dat$context[samp.idx,2], dh)
network$W.out[batch.y,] = network$W.out[batch.y,] - lambda*dE$dW
network$W.in = network$W.in - lambda*dIn1
network$W.in = network$W.in - lambda*dIn2
# negative
neg.set <- get.neg.sample(corp,batch.y, 0.75, sample.size)
for (i.neg in 1:sample.size){
s = embed.dot.forwd(network$W.out,h,neg.set[,i.neg])
z = sigmoidWL.forwd(s,0)
loss[i.iter] = loss[i.iter] + z
ds = sigmoidWL.backwd(s, 0, dout=1)
dE = embed.dot.backwd(network$W.out,h,neg.set[,i.neg], ds)
dh = dE$dh*0.5
dIn1 = embed.backwd(network$W.in, dat$context[samp.idx,1],dh)
dIn2 = embed.backwd(network$W.in, dat$context[samp.idx,2],dh)
network$W.out[neg.set[,i.neg],] = network$W.out[neg.set[,i.neg],] - lambda/sample.size*dE$dW
network$W.in = network$W.in - lambda*dIn1
network$W.in = network$W.in - lambda*dIn2
}
}
plot(loss, type='l')
samp.idx = c(2:6,8,9,1)
batch.c1 = dat$context[samp.idx,1]
batch.c2 = dat$context[samp.idx,2]
batch.y = dat$target[samp.idx]
h1 <- embed.forwd(network$W.in,batch.c1)
h2 <- embed.forwd(network$W.in,batch.c2)
h = 0.5 * (h1 + h2)
s = MatMult.forwd(h,t(network$W.out))
z = sigmoid.forwd(s)
res=cbind(z,batch.y)
par(mfrow=c(8,1))
for (i in 1:8){
col.spec = rep("black",8)
col.spec[i]="orange"
barplot(res[i, 1:8],col=col.spec)
}
par(mfrow=c(4,1))
for (i in 1:4){
col.spec = rep("black",8)
col.spec[i]="orange"
barplot(res[i, 1:8],col=col.spec)
}
認知情報解析演習B DL2 Ch 3
# p99
ctxt = c(1,rep(0,6))
W = matrix(rnorm(7*3),nrow=7)
h = ctxt%*%W
# p 100
MatMult.forwd <- function(x, W){
return(x%*%W)
}
res <- MatMult.forwd(ctxt,W)
# p105
c1 = c(1,rep(0,6))
c2 = rep(0,7); c2[3]=1
W.in = matrix(rnorm(7*3),nrow=7)
W.out = matrix(rnorm(7*3),nrow=3)
h1 = MatMult.forwd(c1,W.in)
h2 = MatMult.forwd(c2,W.in)
h = 0.5*(h1+h2)
s = MatMult.forwd(h,W.out)
print(s)
# p107
softmax1.pred <- function(x){
max.x = max(x)
x = x - max.x
y = exp(x)/sum(exp(x))
return(y)
}
softmaxCE1.forwd <- function(x, target){
max.x = max(x)
x = x - max.x
y = exp(x)/sum(exp(x))
delta = 1e-7;
return(-sum(target*log(y + delta)))
}
targ=rep(0,7); targ[2]=1
# p112
txt = "You say goodbye and I say hello."
txt = tolower(txt)
txt = gsub('[.]', ' .',txt)
words = unlist(strsplit(txt, " "))
uniq.words = unique(words)
n.uniq = length(uniq.words)
n.words = length(words)
corpus = rep(0,n.words)
corpus = match(words,uniq.words)
txt = "You say goodbye and I say hello.";
txt2corpus <- function(txt){
txt = tolower(txt)
txt = gsub('[.]', ' .',txt)
words = unlist(strsplit(txt, " "))
uniq.words = unique(words)
n.uniq = length(uniq.words)
n.words = length(words)
corpus = rep(0,n.words)
corpus = match(words,uniq.words)
return(corpus)
}
corp = txt2corpus(txt)
len.corp = length(corp)
target = corp[2:(len.corp-1)]
col1 = corp[1:(len.corp-2)]
col2 = corp[3:len.corp]
context = cbind(col1,col2)
corp2contxt <- function(corpus){
len.corp = length(corpus)
target = corpus[2:(len.corp-1)]
col1 = corpus[1:(len.corp-2)]
col2 = corpus[3:len.corp]
context = cbind(col1,col2)
return(list(context=context,target = target))
}
# p114
len.corp = length(corpus)
idxT = cbind(1:(len.corp-2), corpus[2:(len.corp-1)])
targ1S = matrix(0,nrow=len.corp-2,ncol=length(unique(corpus)))
targ1S[idxT]=1
idxC1 = cbind(1:(len.corp-2),corpus[1:(len.corp-2)])
idxC2 = cbind(1:(len.corp-2),corpus[3:len.corp])
contxt1 = matrix(0,nrow=len.corp-2,ncol=length(unique(corpus)))
contxt2 = matrix(0,nrow=len.corp-2,ncol=length(unique(corpus)))
contxt1[idxC1]=1
contxt2[idxC2]=1
corp2contxt1S = function(corpus){
len.corp = length(corpus)
# creating target matrix
idxT = cbind(1:(len.corp-2), corpus[2:(len.corp-1)])
targ1S = matrix(0,nrow=len.corp-2,ncol=length(unique(corpus)))
targ1S[idxT]=1
# creating context matrices
idxC1 = cbind(1:(len.corp-2),corpus[1:(len.corp-2)])
idxC2 = cbind(1:(len.corp-2),corpus[3:len.corp])
contxt1 = matrix(0,nrow=len.corp-2,ncol=length(unique(corpus)))
contxt2 = matrix(0,nrow=len.corp-2,ncol=length(unique(corpus)))
contxt1[idxC1]=1
contxt2[idxC2]=1
return(list(target=targ1S,contxt1=contxt1,contxt2=contxt2))
}
# p116~
init.W2V <- function(n.uniq,size.hidden){
W.in = matrix(rnorm(n.uniq*size.hidden),nrow=n.uniq)*0.01
W.out = matrix(rnorm(n.uniq*size.hidden),nrow=size.hidden)*0.01
return(list(W.in = W.in, W.out= W.out))
}
softmax.forwd <- function(x, target){
max.x = apply(x,1,max)
C = ncol(x)
x = x - max.x%*%matrix(1,nrow=1,ncol=C)
y = exp(x)/rowSums(exp(x))
delta = 1e-7;
R = nrow(as.matrix(y))
return(-sum(target*log(y + delta))/R)
}
softmax.bckwd <- function(x, target, dout = 1){
max.x = apply(x, 1, max)
R = nrow(x)
C = ncol(x)
x = x - max.x%*%matrix(1,nrow=1,ncol=C)
y = exp(x)/rowSums(exp(x))
return((y-target)/R)
}
MatMult.bckwd <- function(x, W, dout){
dx = dout%*%t(W)
dW = t(x)%*%dout
return(list(dx = dx, dW = dW))
}
softmax.pred <- function(x, target){
max.x = apply(x,1,max)
C = ncol(x)
x = x - max.x%*%matrix(1,nrow=1,ncol=C)
y = exp(x)/rowSums(exp(x))
return(y)
}
network<-init.W2V(7,5)
n.batch = 3;
n.data = nrow(dat$target)
n.iter = 1000;
lambda=0.1;
loss = rep(0, n.iter)
for (i.iter in 1:n.iter){
samp.idx = sample(1:n.data,n.batch)
batch.c1 = dat$contxt1[samp.idx,]
batch.c2 = dat$contxt2[samp.idx,]
batch.y = dat$target[samp.idx,]
h1 <- MatMult.forwd(batch.c1, network$W.in)
h2 <- MatMult.forwd(batch.c2, network$W.in)
h = 0.5 * (h1 + h2)
s = MatMult.forwd(h,network$W.out)
z = softmax.forwd(s,batch.y)
loss[i.iter] = z
ds = softmax.bckwd(s, batch.y, 1)
da = MatMult.bckwd(h,network$W.out,ds)
da$dW = da$dW*0.5
dIn1 = MatMult.bckwd(batch.c1,network$W.in,da$dx)
dIn2 = MatMult.bckwd(batch.c2,network$W.in,da$dx)
network$W.out = network$W.out - lambda*da$dW
network$W.in = network$W.in - lambda*dIn1$dW
network$W.in = network$W.in - lambda*dIn2$dW
}
plot(loss, type='l')
認知情報解析演習b DL2 – ch.2
txt = "You say goodbye and I say hello.";txt = tolower(txt)
txt = gsub('[.]', ' .',txt)
words = unlist(strsplit(txt, " "))
uniq.words = unique(words)
uniq.words[1]
which(uniq.words=="say")
n.uniq = length(uniq.words)
n.words = length(words)
# creating corpus
corpus = rep(0,n.words)
corpus = match(words,uniq.words)
## co-occurance matrix
cc = matrix(0,nrow=n.uniq, ncol=n.uniq)
for (i.c in 1:n.uniq){
loc = which(corpus==i.c)
L = which(match(uniq.words,words[pmax(loc-1,1)])!='NA')
R = which(match(uniq.words,words[pmin(loc+1,n.words)])!='NA')
cc[i.c, c(L,R)]=cc[i.c, c(L,R)]+1
}
diag(cc)=0
## ppmi matrix
ppmi <- function(cc, eps = 1e-8){
n.uniq = ncol(cc)
PPMI = matrix(0, n.uniq, n.uniq)
N = sum(cc)
r.sum = rowSums(cc)
pmi = log2(cc*N/outer(r.sum,r.sum))
PPMI=pmax(0,pmi)
return(PPMI)
}
# performing SVD
s = svd(PPMI)
plot(s$u[,1],s$u[,2],pch=20,col='red')
text(s$u[,1],s$u[,2],row.names(cc))
# calc. simliarity b/w words
words.sim <- function(word1, word2, eps=1e-8){
nw1 = word1/(sqrt(sum(word1^2)) + eps)
nw2 = word2/(sqrt(sum(word2^2)) + eps)
return(nw1%*%nw2)
}
w1 = cc[which(uniq.words=="you"),]
w2 = cc[which(uniq.words=="i"),]
words.sim(w1,w2)
# reporting most simliar words
most.sim <- function(word, uniq.words, cc, N=5){
n.uniq = length(uniq.words)
word2 = cc[which(uniq.words==word),]
res = data.frame(words = uniq.words, similarity = rep(0,n.uniq))
top = data.frame(words = rep("",N+1), similarity=rep(0,N+1))
res$similarity = apply(cc,1, function(x) words.sim(x,word2))
sort.res = sort(res$similarity, decreasing = T, index.return=T)
top$words = res$words[sort.res$ix[1:(N+1)]]
top$similarity = res$similarity[sort.res$ix[1:(N+1)]]
self.idx = which(top$words == word)
return(top[-self.idx,])
}
## Penn TB
f = file("~/courses/CogMod/CMA2018/ptb.tex")
ptb<-readLines(con=f)
ptb = paste(ptb,"")
words = unlist(strsplit(ptb, " "))
uniq.words = unique(words)
n.uniq = length(uniq.words)
n.words = length(words)
corpus = rep(0,n.words)
corpus = match(words,uniq.words)
cc <- contxt(corpus,uniq.words,words)
PPMI<-ppmi(cc)
library(rsvd)
## 時間がかかります。
s = rsvd(PPMI)
認知情報解析 DL1の復習
sigmoid.forwd <- function(x){
return(1/(1+exp(-x)))
}
sigmoid.bckwd <- function(x, dout){
y = sigmoid.forwd(x)
return(dout*(1-y)*y)
}
affine.forwd <- function(x, W, b){
return(x%*%W + matrix(1, nrow = nrow(x), ncol = 1)%*%b)
}
affine.bckwd <- function(x, W, b, dout){
dx = dout%*%t(W)
dW = t(x)%*%dout
db = colSums(dout)
return(list(dx = dx, dW = dW, db = db))
}
softmax.forwd <- function(x, target){
max.x = apply(x,1,max)
C = ncol(x)
x = x - max.x%*%matrix(1,nrow=1,ncol=C)
y = exp(x)/rowSums(exp(x))
delta = 1e-7;
R = nrow(as.matrix(y))
return(-sum(target*log(y + delta))/R)
}
softmax.bckwd <- function(x, target, dout = 1){
max.x = apply(x, 1, max)
R = nrow(x)
C = ncol(x)
x = x - max.x%*%matrix(1,nrow=1,ncol=C)
y = exp(x)/rowSums(exp(x))
return((y-target)/R)
}
softmax.pred <- function(x, target){
max.x = apply(x,1,max)
C = ncol(x)
x = x - max.x%*%matrix(1,nrow=1,ncol=C)
y = exp(x)/rowSums(exp(x))
return(y)
}
N = 100; dim = 2; n.class =3;
x = matrix(0,nrow=N*n.class, ncol = dim)
t = matrix(0,nrow=N*n.class, ncol = n.class)
for (i.cl in 1:n.class){
for (i.N in 1:N){
radius = i.N/N
theta = i.cl*4+4*radius+rnorm(1,0,0.2)
idx = N*(i.cl-1)+i.N
x[idx,]=c(radius*sin(theta),radius*cos(theta))
t[idx,i.cl] = 1
}
}
# spiral data
plot(x[1:100,1],x[1:100,2],pch=20,col='black',cex=2,xlim=c(-1,1),ylim=c(-1,1))
points(x[101:200,1],x[101:200,2],pch=20,col='blue',cex=2)
points(x[201:300,1],x[201:300,2],pch=20,col='green',cex=2)
init.network <- function(n.neurons){
n.layer = length(n.neurons)
W = list(); b = list()
for (i.layer in 1:(n.layer-1)){
W[[i.layer]] =
matrix(rnorm(n.neurons[i.layer]*n.neurons[(i.layer+1)],sd = 0.01),nrow=n.neurons[i.layer])
b[[i.layer]] = matrix(rnorm(n.neurons[(i.layer+1)],sd = 0.01), nrow = 1)
}
return(list(W = W,b = b))
}
train.x = x
train.y = t
params = init.network(c(2,30,30,3))
batch_size = 50; n.iter =50000; lambda =0.3
n.train = nrow(train.x)
loss = rep(0,n.iter)
for (i.iter in 1:n.iter){
batch_mask = sample(1:n.train, batch_size)
x.batch = train.x[batch_mask,]
t.batch = train.y[batch_mask,]
a1 = affine.forwd(x.batch,params$W[[1]],params$b[[1]])
z1 = sigmoid.forwd(a1)
a2 = affine.forwd(z1,params$W[[2]],params$b[[2]])
z2 = sigmoid.forwd(a2)
a3 = affine.forwd(z2,params$W[[3]],params$b[[3]])
z3 = softmax.forwd(a3,t.batch)
loss[i.iter] = z3
dwSM = softmax.bckwd(a3, t.batch, 1)
dwA3 = affine.bckwd(a2,params$W[[3]],params$b[[3]],dwSM)
dwSG2 = sigmoid.bckwd(a2,dwA3$dx)
dwA2 = affine.bckwd(a1,params$W[[2]],params$b[[2]],dwSG2)
dwSG = sigmoid.bckwd(a1,dwA2$dx)
dwA1 = affine.bckwd(x.batch,params$W[[1]],params$b[[1]],dwSG)
params$W[[3]] = params$W[[3]] - lambda*dwA3$dW
params$b[[3]] = params$b[[3]] - lambda*dwA3$db
params$W[[2]] = params$W[[2]] - lambda*dwA2$dW
params$b[[2]] = params$b[[2]] - lambda*dwA2$db
params$W[[1]] = params$W[[1]] - lambda*dwA1$dW
params$b[[1]] = params$b[[1]] - lambda*dwA1$db
}
# plotting results
plot(loss,type='l', xlab = "trial")
library(plot3D)
M <- mesh(seq(-1,1,length.out = 300),seq(-1,1,length.out = 300))
temp.x = cbind(as.vector(M$x),as.vector(M$y))
a1 = affine.forwd(temp.x,params$W[[1]],params$b[[1]])
z1 = sigmoid.forwd(a1)
a2 = affine.forwd(z1,params$W[[2]],params$b[[2]])
z2 = sigmoid.forwd(a2)
a3 = affine.forwd(z2,params$W[[3]],params$b[[3]])
cl = softmax.pred(a3)
cl.pred = apply(cl,1,which.max)
image(matrix(cl.pred,300,300))
x2= x*0.5+0.5
points(x2[1:100,1],x2[1:100,2],pch=20,col='black',cex=2)
points(x2[101:200,1],x2[101:200,2],pch=20,col='blue',cex=2)
points(x2[201:300,1],x2[201:300,2],pch=20,col='green',cex=2)
認知情報解析演習 強化学習２
# example 3.8: Gridworld
# initializing value vector
V=rep(0,25);
# defining probability matrix
P=matrix(1/4,nrow=25,ncol=4) #
# defining deterministic transition matrix
north=c(2:25,25)
north[ c(5,10,15,20,25)]=c(5,10,15,20,25)
east=c(6:25,21:25)
west=c(1:5,1:20)
south=c(1,1:24)
south[ c(1,6,11,16,21)]=c(1,6,11,16,21)
trM=cbind(north,east,south,west)
trM[10,]=6
trM[20,]=18
# defining reward matrix
R=matrix(0,nrow=25,ncol=4)
R[which(trM==1:25)]=-1
R[10,]=10
R[20,]=5
# calculating state-values iteratively
# fixed number of iterations
nRep=1000; gamma=0.9;
for (i_rep in 1:nRep) {
V.old=V
for (i_state in 1:25) {
V[i_state]=sum(P[i_state,]*(R[i_state,]+gamma*V.old[trM[i_state,]]))
}
}
### example 2
north=c(1:3,15,1:10)
east=2:15;east[ c(3,7,11)]=c(3,7,11)
south=c(5:15,12:14)
west=c(15,1:13);west[ c(4,8,12)]=c(4,8,12)
trM=cbind(north,east,south,west)
###
V.star=V; # V calculated as in exp3.8
iter=0;maxItr=1000;delta=1;tol=1e-5;
while(iter < maxItr & delta > tol) {
delta=0;iter=iter+1
V.star.old=V.star
for (i_state in 1:25) {
v=V.star[i_state]
V.star[i_state]=max(R[i_state,]+gamma*V.star.old[trM[i_state,]])
delta=max(delta,abs(v-V.star[i_state]))
}
}
#######################################
# ch4.1 policy evaluation
########################################
# example 4.1 - bug fixed on 2017.03.21
# defining deterministic trans. matrix
north=c(1:3,15,1:10)
east=2:15;east[ c(3,7,11)]=c(3,7,11)
south=c(5:15,12:14)
west=c(15,1:13);west[ c(4,8,12)]=c(4,8,12)
trM=cbind(north,east,south,west)
# defining Reward & trans. prob.
R=-1;P=0.25;
# iterative policy evaluation
delta=1; gamma=1; tol=1e-8; V=rep(0,15);
while (delta>tol) {
delta=0;
for (i_state in 1:14) {
v=V[i_state]
V[i_state]=sum(P*(R+gamma*V[trM[i_state,]]))
delta=max(delta,abs(v-V[i_state]));
}
}
#####################################
# ch4.3 Policy Improvement
# easier one
#####################################
north=c(1:3,15,1:10)
east=2:15;east[ c(3,7,11)]=c(3,7,11)
south=c(5:15,12:14)
west=c(15,1:13);west[ c(4,8,12)]=c(4,8,12)
trM=cbind(north,east,south,west)
R=-1;V=rep(0,15);
delta=1; gamma=1; tol=1e-5;
bestP=sample(1:4,14,replace=T)
stable=F;counter=0
while (stable==F){
counter=counter+1
Vmat=matrix(V[trM],ncol=4)
Ppolicy=t(apply(Vmat,1,function(x) exp(10*x)/sum(exp(10*x))))
# iterative policy evaluation
while (delta>tol) {
delta=0;
for (i_state in 1:14) {
v=V[i_state]
V[i_state]=sum(Ppolicy[i_state]*(R+gamma*V[trM[i_state,]]))
delta=max(delta,abs(v-V[i_state]))
}
}
# policy improvement
stable=F
for (i_state in 1:14) {
b=bestP[i_state]
bestP[i_state]=which.max(V[trM[i_state,]])
ifelse((bestP[i_state]==b),stable<-T,stable<-F)
}
}
#####################################
# ch4.4 Value Iteration
#####################################
# example 4.3
V=c(rep(0,100),1);V.hist=c()
p=c(0.4,0.6);
gamma=1;delta=1; tol=1e-20
max.a=rep(0,101)
while (delta>tol) {
delta=0;
for (i_state in 1:99) {
v=V[i_state+1]
temp=matrix(0,nrow=1,ncol=i_state)
for (i_action in 1:i_state) {
temp[i_action]=sum(p*(gamma*c(V[(min(i_state+i_action,100)+1)],
V[(max(i_state-i_action,0)+1)])))
}
V[i_state+1]=max(temp)
max.a[i_state+1]=which.max(round(temp,8))
delta=max(delta,abs(v-V[i_state+1]))
}
V.hist=rbind(V.hist,V)
}
# plotting results
par(mfrow=c(1,2))
plot(V.hist[1,],type='l',lwd=2,xlab="Capital",ylab="Value Estimates",col='red')
lines(V.hist[2,],lwd=2,col='blue')
lines(V.hist[3,],lwd=2,col='green')
lines(V.hist[32,],lwd=2,col='black')
legend("topleft",c("sweep 1","sweep 2","sweep 3", "sweep 32"),
col=c("red","blue","green","black"),lwd=2)
barplot(max.a,xlab="Capital",ylab="Final Policy",col="white")
認知情報解析学演習 PSO
funZ<-function(x) {
x[1]^4-16*x[1]^2-5*x[1]+x[2]^4-16*x[2]^2-5*x[2]
}
n.theta = 10;
n.iter = 1000;
Wp = 0.1;
Wg = 0.1;
theta = matrix(rnorm(n.theta*2), nrow=n.theta)
v = matrix(rnorm(n.theta*2), nrow=n.theta)
theta.hist = array(0,c(n.theta,2,n.iter))
theta.hist[,,1]=theta
p.b.v <- apply(theta,1,funZ)
p.best = theta
g.b.v = min(p.b.v)
g.b.idx = which.min(p.b.v)
g.best <- theta[g.b.idx,]
v = v + Wp*runif(n.theta)*(p.best - theta)+ Wg*runif(n.theta)*t(g.best - t(theta))
theta = theta + v
for (i.iter in 2:n.iter){
v = v + Wp*runif(n.theta)*(p.best - theta)+ Wg*runif(n.theta)*t(g.best - t(theta))
theta = theta + v
fitG = apply(theta,1,funZ)
if (min(fitG) < g.b.v){
g.best = theta[which.min(fitG),]
g.b.v = min(fitG)
}
idx = which(fitG < p.b.v)
p.best[idx,] = theta[idx,]
p.b.v= fitG
theta.hist[,,i.iter]=theta
}
funZ2<-function(x,y) {x^4-16*x^2-5*x+y^4-16*y^2-5*y}
xmin=-5;xmax=5;n_len=100;
x<-seq(xmin, xmax,length.out=n_len);
y<-x;
z<-outer(x,y,funZ2)
contour(x,y,z,nlevels= 50, ,lwd = 0.3,drawlabels = F,col='blue')
for (i.agent in 1:n.theta){
lines(theta.hist[i.agent,1,],theta.hist[i.agent,2,],col=i.agent)
points(theta[1,1],theta[1,2],pch=20,cex=2,col=i.agent)
}
n.trial = 1000; n.rep = 100
Q.true = rnorm(10);
opt.act = which.max(Q.true)
r.hist = matrix(0,n.rep, n.trial)
oa.hist = matrix(0,n.rep, n.trial)
for (i.rep in 1:n.rep){
Q.est = rep(0,10);R.cum = rep(0,10)
act.count = rep(0,10)
for (i.trial in 1:n.trial){
max.id = which(Q.est == max(Q.est))
if (length(max.id)>1){
action = sample(max.id,1)
} else {
action = max.id
}
if (action == opt.act){
oa.hist[i.rep, i.trial] = 1
}
r = rnorm(1, Q.true[action],1)
r.hist[i.rep, i.trial] = r
R.cum[action] = R.cum[action] + r
act.count[action] = act.count[action] + 1
Q.est = R.cum / (act.count + 0.01)
}
}
plot(colMeans(r.hist),type='l')
plot(colMeans(oa.hist),type='l',ylim=c(0,1))
### epsilon greedy
n.trial = 1000; n.rep = 1000
r.hist = matrix(0,n.rep, n.trial)
oa.hist = matrix(0,n.rep, n.trial)
epsilon = 0.01
for (i.rep in 1:n.rep){
Q.est = rep(0,10);R.cum = rep(0,10)
act.count = rep(0,10)
Q.true = rnorm(10);
opt.act = which.max(Q.true)
for (i.trial in 1:n.trial){
if (runif(1)>epsilon){
max.id = which(Q.est == max(Q.est))
if (length(max.id)>1){
action = sample(max.id,1)
} else {
action = max.id
}
} else {
action = sample(10,1)
}
if (action == opt.act){
oa.hist[i.rep, i.trial] = 1
}
r = rnorm(1, Q.true[action],1)
r.hist[i.rep, i.trial] = r
R.cum[action] = R.cum[action] + r
act.count[action] = act.count[action] + 1
Q.est[action] = R.cum[action] / act.count[action]
}
}
### softmax
n.trial = 1000; n.rep = 1000
r.hist = matrix(0,n.rep, n.trial)
oa.hist = matrix(0,n.rep, n.trial)
gamma = 3
for (i.rep in 1:n.rep){
Q.est = rep(0,10);R.cum = rep(0,10)
act.count = rep(0,10)
Q.true = rnorm(10);
opt.act = which.max(Q.true)
for (i.trial in 1:n.trial){
action = sample(10, 1, prob=exp(gamma*Q.est)/sum(exp(gamma*Q.est)))
if (action == opt.act){
oa.hist[i.rep, i.trial] = 1
}
r = rnorm(1, Q.true[action],1)
r.hist[i.rep, i.trial] = r
R.cum[action] = R.cum[action] + r
act.count[action] = act.count[action] + 1
Q.est[action] = R.cum[action] / act.count[action]
}
認知情報解析演習A W12
ES
n.parent = 10
n.theta = 10
parent = list(theta = matrix(rnorm(n.parent*n.theta),nrow=n.parent),
sigma = matrix(runif(n.parent*n.theta)+1,nrow = n.parent))
ES_crossover<-function(parent){
n.parent = nrow(parent$theta)
rand.order = sample(1:n.parent)
p1.idx= rand.order[1:(n.parent/2)]
p2.idx= rand.order[(n.parent/2+1):n.parent]
co.idx = sample(1:(length(parent)/2),length(parent)/4)
c1 = parent$theta[p1.idx,]
c1.copy = c1
c2 = parent$theta[p2.idx,]
c1[co.idx] = c2[co.idx]
c2[co.idx] = c1.copy[co.idx]
sigma = (parent$sigma[p1.idx,]+parent$sigma[p2.idx,])/2
return(child = list(theta = rbind(c1,c2), sigma = rbind(sigma,sigma)))
}
ES_mutate<-function(child, tau){
child$sigma = child$sigma*
exp(tau*matrix(rnorm(length(child$sigma)),nrow=nrow(child$sigma)))
child$theta = child$theta + matrix(rnorm(length(child$sigma),0,child$sigma),nrow=nrow(child$sigma))
return(child)
}
ES_survive<-function(parent, child, fitP, fitC){
nPop=nrow(parent$theta);
fitT=c(fitP,fitC);
fitMax=sort(fitT,index.return=TRUE,decreasing = FALSE)
tempTheta=rbind(parent$theta, child$theta)
tempSigma=rbind(parent$sigma, child$sigma)
fittest=list(theta = tempTheta[fitMax$ix[1:nPop],], sigma = tempSigma[fitMax$ix[1:nPop],])
return(fittest)
}
set.seed(20); nData = 100
X=matrix(rnorm(9*nData,mean=10,sd=2),ncol=9);X=cbind(rep(1,nData),X)
y=X%*%c(10,2,5,-3,-5,0,0,0,0,0)+rnorm(nData,mean=0,sd=2);
#summary(lm(y~X[,2:10]))
reg.error<-function(b,X,y){
yhat<-X%*%b
return(sum((y-yhat)^2))
}
apply(child$theta,1,reg.error, X, y)
ES<-function(parent, nGen,tau,X,Y){
optHist=matrix(0,nrow=nGen,ncol=1)
fittest.hist = matrix(0,nrow=nGen,ncol = ncol(parent$theta))
nPop = nrow(parent$theta)
nVar = ncol(parent$theta)
fitP = apply(parent$theta, 1, reg.error, X, Y)
#fitC = fitP
optHist[1]=max(c(fitP))
fittest.hist[1,] = parent$theta[which.max(fitP),]
for (i_gen in 2:nGen) {
child<-ES_crossover(parent)
child<-ES_mutate(child,tau)
fitP = apply(parent$theta,1, reg.error, X, Y)
fitC = apply(child$theta, 1, reg.error, X, Y)
parent<-ES_survive(parent, child, fitP, fitC)
optHist[i_gen]=max(c(fitP,fitC))
fittest.hist[i_gen, ] = parent$theta[1,]
}
return(list(fittest = parent, optHist = optHist, fittest.hist = fittest.hist))
}
> res<-ES(parent,50000,1,X,y)
> res$fittest$theta[1,]
[1] 9.508492513 2.074884770 4.929865865 -2.989781723 -5.129436719 0.050919574 0.024012318
[8] -0.003250697 0.081489175 -0.028049091
> coef(lm(y~X[,2:9]))
(Intercept) X[, 2:9]1 X[, 2:9]2 X[, 2:9]3 X[, 2:9]4 X[, 2:9]5 X[, 2:9]6 X[, 2:9]7
9.424585305 2.072861468 4.929182784 -2.993701821 -5.135528730 0.048416459 0.023772334 -0.005105199
X[, 2:9]8
0.078469949
ES & PSO
funZ<-function(x,y) {x^4-16*x^2-5*x+y^4-16*y^2-5*y}
xmin=-5;xmax=5;n_len=100;
x<-seq(xmin, xmax,length.out=n_len);
y<-x;
z<-outer(x,y,funZ)
contour(x,y,z,nlevels= 50, drawlabels = F,col='blue')
# useful memo
funZ<-function(x,y) {x^4-16*x^2-5*x+y^4-16*y^2-5*y}
funZ<-function(x) {
x[1]^4-16*x[1]^2-5*x[1]+x[2]^4-16*x[2]^2-5*x[2]
}
n.theta = 10;
n.iter = 100;
Wp = 1;
Wg = 1;
theta = matrix(rnorm(n.theta*2), nrow=n.theta)
v = matrix(rnorm(n.theta*2), nrow=n.theta)
theta.hist = array(0,c(n.theta,2,n.iter))
theta.hist[,,1]=theta
p.best.v <- apply(theta,1,funZ)
p.best = theta
g.b.v = min(p.best.v)
g.b.idx = which.min(p.best.v)
g.best <- theta[g.b.idx,]
v = v + Wp*runif(n.theta)*(p.best - theta)+ Wg*runif(n.theta)*t(g.best - t(theta))
theta = theta + v