R で Vanishing Component Analysis

機械学習 R

行けなかった ICML 読み会で紹介されてた Vanishing Component Analysis (Livni+ ICML2013)、うちの社内勉強会でも光成さんが紹介してくれて、ふむふむしていたところに、試作実装がでてきて、おーおもしろいと思ったんだけど、Matlab なので試せない orz


というわけで貧乏人の Matlab (失礼) である R で実装してみた。
極力、論文の pseudo code そのままで書くという変なところに情熱を注ぎ込んでいる。*1
ところどころにある i<-i や g<-g みたいなのは、遅延評価対策。

Sm <- matrix(1:8, ncol=2, byrow=T); # data

n <- ncol(Sm); # dimension of data space
m <- nrow(Sm); # data size
e <- 0.5; # tolerance

findrangenull <- function(F,C,Sm,e) {
    Ftilda <- lapply(C, function(fi){
        fism <- apply(Sm,1,fi);
        function(x)fi(x)-sum(sapply(F, function(g)sum(fism*apply(Sm,1,g))*g(x)))
    });
    A <- sapply(Ftilda, function(f)apply(Sm,1,f));
    x <- svd(A);
    U <- x$v;
    G <- apply(U, 2, function(u){u<-u; function(x)sum(u*sapply(Ftilda, function(f)f(x)))});
    F1 <- lapply(G[x$d>e], function(g){z<-sqrt(sum(apply(Sm,1,g)**2)); function(x)g(x)/z});
    list(F=F1, V=G[x$d<=e]);
};

F <- c(function(x)1/sqrt(m));
C1 <- lapply(1:n, function(i){i<-i; function(x)x[i];});

pre <- findrangenull(F, C1, Sm, e);
F1 <- pre$F;
V <- pre$V;
while(length(pre$F)>0) {
    F <- append(F, pre$F);
    C <- list();
    for (h in F1) {
        C <- append(C, lapply(pre$F, function(g){g<-g; function(x)g(x)*h(x)}));
    };
    pre <- findrangenull(F, C, Sm, e);
    V <- append(V, pre$V);
}


VCA では多項式環上での演算が入ってくるわけだが、そこは手抜きで function の入れ子で新しい function を定義する、とやったらイテレーションが進むごとに評価すべき function の数が文字通り指数的に増えてしまって重過ぎに……。
評価する点は最初に与えたデータ点に限られるので、メモ化すれば線形に落ちて大丈夫になるはずなのだが、連想配列がない R でメモ化のコードを簡単に書く方法がパッと出てこない。いやそりゃがんばりゃいくらでも手はあるけど、そこでがんばろうという気にあんまりならない。
というわけで、R で簡単にメモ化する方法を緩募中。

*1:良くあることだが、論文の pseudo code は2ヶ所バグっているので注意