VOCALOIDのタグを付けて投稿される動画は爆発的に増えている。
タグの共起を抽出してネットワークを描いた。初音ミクが中心にくることは予想に難くないので初音ミクのところを拡大した。
共演ネットワークはいわゆる複雑ネットワークになるだろうと思ったら案の定なった。各次数のノードたちの総登場回数もプロット点の大きさに反映させたが、初音ミクの登場回数が最も多かった。
VOCALOID 初音ミク 鏡音リン 巡音ルカ KAITO 鏡音レン GUMI UTAU 215163 85376 22741 17997 16608 16521 11381 8044
ネットワークの登場人物は指数関数的に増えてはいるが、人口爆発モデル的に考えるとどこかで飽和するだろうという仮定で、3パラメータによるロジスティックカーブへの当てはめをして予測した。2015年始めには320人で飽和するかもしれない。下限は0だとして
へfittingした。
Coefficients: b:(Intercept) d:(Intercept) e:(Intercept) -0.07783 320.57843 51.82008
### Python3 で!!! import json import re import os import tarfile import gzip import unicodedata from multiprocessing import Pool ### parallel computing def processor(files): wd = "/niconico/" # ニコニコデータセットが置いてあるディレクトリ outwd = "/output/" # タグ抽出結果を出力するディレクトリ voice = ["VOCALOID"] # ここをいじればいろんなタグが取れる labels = ["video_id", "upload_time", "title", "length", "view_counter", "comment_counter", "mylist_counter"] comment = ["date", "no", "vpos", "comment"] tmpf = files w0 = open(outwd + "meta/" + str(tmpf) + ".txt", "w") # 動画データはひとまとめにする w0.write("\t".join(labels + ["tag"])+"\n") f0 = gzip.open(wd + "meta/" + str(tmpf) + ".dat.gz", "rb") tmpg = f0.read().decode("utf-8").split("\n") p0 = tmpg.pop(-1) # 最後は \n のため "" になる map0 = list(map(lambda x: json.loads(x, "utf-8"), tmpg)) for tmp in map0: tags = [t0["tag"] for t0 in tmp["tags"]] # tag を分解 tags = list(map(lambda x: unicodedata.normalize('NFKC', x), tags)) # 半角文字に変換 if any(map(lambda x: x in voice, tags)): # tag が声優をひとつでも含んでいるか。voice のところをいじる。 a0 = list(map(lambda x: str(tmp[x]), labels)) # 動画情報 if str(tmpf)+"/"+tmp["video_id"]+".dat" in dat: # 削除か何かですべての動画がダンプされているわけではなさそう w0.write("\t".join(a0 + [",".join(tags)]) + "\n") w0.close() # 動画データの終わり p = Pool(4) p.map(processor, files)
ここで大量のmeta fileがあるので統合する。
# R wd <- "/output/meta/" setwd(wd) files <- list.files(wd) # meta file 一覧 meta <- NULL for(i in seq(files)){ pb <- txtProgressBar(min=1, max=length(files), style=3) setTxtProgressBar(pb, i) meta <- rbind(meta, read.delim(files[i])) } write.csv(meta, "meta.txt")
meta <- read.csv("meta.txt") tag0 <- strsplit(as.character(meta[,"tag"]), ",") # 各動画のタグ tag1 <- sort(table(unlist(tag0)), decreasing=TRUE) # タグ数 # ボーカロイド一覧やレイアウトデータを読み込む vocaloid <- read.csv("select.csv") lay0 <- read.csv("graphlayout2.csv") rownames(lay0) <- lay0$X lay0 <- as.matrix(lay0[, -1]) # グラフを描く colab <- diag(0, nrow(vocaloid)) dimnames(colab) <- list(vocaloid$name, vocaloid$name) for(i in seq(tag0)){ tf <- tag0[[i]] %in% vocaloid$name # タグにボーカロイドを含むか v0 <- tag0[[i]][tf] # 含まれていたボーカロイド colab[v0, v0] <- colab[v0, v0] + 1 } freq0 <- diag(colab) diag(colab) <- 0 colab1 <- colab2 <- colab[rowSums(colab)>0, colSums(colab)>0] colab2 <- colab1 colab1[colab1 > 0] <- 1 freq1 <- freq0[rownames(colab1)] elist <- rowSums(upper.tri(colab1) & colab1 > 0) # edge list elist1 <- elist[elist > 0] elist2 <- unlist(mapply(rep, seq(elist1), elist1)) edgename <- NULL for(i in 1:(nrow(colab1) - 1)){ for(j in (i+1):ncol(colab1)){ if(colab1[i, j] > 0){ hoge <- paste(rownames(colab1)[i], colnames(colab1)[j], sep="-") edgename <- c(edgename, hoge) } } } library(igraph) g1 <- graph.adjacency(colab1, mode="undirected") V(g1)$size <- log(freq1, 10) V(g1)$label <- NA par(mar=c(0,0,0,0)) lay0 <- layout.auto(g1) rownames(lay0) <- rownames(colab1) plot(g1, layout=lay0)
時系列変化をGIFにする。
# 時系列変化 upd <- as.Date(meta$upload_date) datetag <- seq(min(upd), max(upd), by="month") dateidx <- cut(upd, datetag) # ノードの調整 tmpc <- c("black", "blue", "red", "green", "orange", rep(grey(0.6), 4), "orange", "purple") tlevel <- c("クリプトン","インターネット","AH-Software","ヤマハ","1st PLACe", "EXIT TUNE", "ZERO-G","PowerFX","SBS Artech","Voctro labs","UTAU") Vcols <- unlist(mapply(function(x) tmpc[which(tlevel==x)], vocaloid$campany[match(rownames(colab1), vocaloid$name)])) colab.time <- vector("list", length(datetag)) hoge0 <- hoge1 <- matrix(0, nrow(colab2), ncol(colab2), dimnames=list(rownames(colab2), colnames(colab2))) nodes <- rep(0, length(colab.time)) # ネットワークに登場する人数 #saveGIF({ # GIF にするなら使用する。 for(k in 1:length(colab.time)){ colab.time0 <- hoge0 tmptag <- tag0[which(dateidx == levels(dateidx)[k])] # 時系列 j の動画のタグ for(i in seq(tmptag)){ tf <- tmptag[[i]] %in% rownames(hoge0) # タグにボーカロイドを含むか v0 <- tmptag[[i]][tf] # 含まれていたボーカロイド hoge1[v0, v0] <- hoge1[v0, v0] + 1 } hoge2 <- hoge1 hogefreq1 <- diag(hoge2) diag(hoge2) <- 0 hoge2[hoge2 > 0] <- 1 tmphoge2 <- hoge2[rowSums(hoge2)>0, colSums(hoge2)>0] if(prod(dim(tmphoge2)) == 0){ tmphoge2 <- diag(0, sum(hogefreq1 > 0)) dimnames(tmphoge2) <- list(names(hogefreq1)[hogefreq1 > 0], names(hogefreq1)[hogefreq1 > 0]) } elist <- rowSums(upper.tri(tmphoge2) & tmphoge2 > 0) # edge list elist1 <- elist[elist > 0] elist2 <- unlist(mapply(rep, seq(elist1), elist1)) edgename <- NULL for(i in 1:(nrow(tmphoge2) - 1)){ for(j in (i+1):ncol(tmphoge2)){ if(tmphoge2[i, j] > 0){ hoge <- paste(rownames(tmphoge2)[i], colnames(tmphoge2)[j], sep="-") edgename <- c(edgename, hoge) } } } g3 <- graph.adjacency(hoge2, mode="undirected") V(g3)$size <- log(hogefreq1, 10) n0 <- vocaloid$campany[match(rownames(colab1), vocaloid$name)] V(g3)$color <- c("green","yellow","yellow","pink","blue","red",rep("lightblue",length(V(g3))-6)) V(g3)$label.color <- Vcols cols <- replace(rep(grey(0.8), length(elist2)), grep("初音ミク", edgename), "darkgreen") E(g3)$color <- cols nodes[k] <- sum(V(g3)$size >= 0) #png(paste("~/Desktop/20131110/", k, ".png", sep=""), 800, 800) par(mar=c(0, 1, 0, 1)) plot(g3, layout=lay0) text(par()$usr[1], par()$usr[4], paste(datetag[k], "~"), cex=3, adj=c(-0.2, 1.5)) #dev.off() } }, interval=0.2, ani.width=800, ani.height=800)
スケールフリー性
# Scale-free network g4 <- graph.adjacency(hoge1, mode="undirected", diag=FALSE) node <- tail(table(degree(g3)), -1) plot(names(node), node, log="xy", xlab="Degree", ylab="#Nodes") n0 <- table(factor(degree(g3), 1:max(degree(g3)))) n1 <- degree(g3) # 共演した人数 n2 <- degree(g4) # 動画に登場した回数 n3 <- mapply(function(x) sum(n2[n1==x]), as.numeric(names(n0))) par(mar=c(5, 4.5, 1, 6), xpd=TRUE, bty="o") plot(names(node), node, cex=log(n3[n3>0], 20), pch=16, log="xy", xlab="Degree", ylab="#Nodes", cex.axis=1.5, cex.lab=1.8) voc <- c("初音ミク", "鏡音リン", "鏡音レン", "巡音ルカ", "MEIKO", "KAITO") voccol <- c("green" ,"yellow", "yellow", "pink", "red", "blue") xp <- c(0.13, 0.2, 0.2, 0.2, 0.2, 0.2) yp <- c(0.1, 0.3, 0.6, 0.5, 0.4, 0.2) for(i in seq(voc)){ x0 <- n1[voc[i]]; y0 <- n0[names(n0) == n1[voc[i]]] segments(x0, y0, 10^(par()$usr[2]+0.05), y0*10^yp[i], lwd=4, col=voccol[i]) points(x0, y0, cex=log(n2[voc[i]], 10), pch=16, col=voccol[i]) text(10^(par()$usr[2]+0.05), y0*10^yp[i], voc[i], adj=c(-0.02,NA), cex=1.5) } legend("topright", legend=expression(10^1,10^2,10^3,10^4), bty="n", cex=2.5, pt.cex=1:4, pch=16)
ネットワークに登場する人数の解析
par(mar=c(5.5, 4.5, 1, 1)) plot(nodes, xaxt="n", xlab="", ylab="ネットワークに登場するボーカロイド人数", cex=2.5, pch=16, cex.lab=1.6, cex.axis=1.5) idx0 <- ceiling(seq(1, length(nodes), length=15)) axis(1, at=idx0, NA) text(idx0, rep(par()$usr[3], length(idx0)) ,datetag[idx0], srt=45, cex=1.3, xpd=TRUE ,adj=c(1.1, 1.6)) arrows(13, nodes[13]+35, y1=nodes[13]+10, length=0.1, lwd=3) # UTAU は2008-03-06 text(13, nodes[13]+35, "UTAU", cex=2, adj=c(0.5, -0.5)) # ロジスティックモデルによる回帰と予測 library(drc) drm0 <- drm(nodes ~ seq(nodes), fct=L.4(fixed=c(NA, 0, NA, NA))) # 回帰 par(mar=c(5.5, 4.5, 1, 1)) pred0 <- predict(drm0, as.data.frame(seq(120))) # 予測 plot(nodes, xlab="", ylab="ネットワークに登場するボーカロイド人数", xaxt="n", cex=2.5, pch=16, cex.lab=1.6, cex.axis=1.5, xlim=c(1, 120), ylim=c(1,330)) lines(pred0, lwd=7, col=3) lastday <- as.Date(paste(2013+(length(pred0)-70)%/%12, "-", 1+(length(pred0)-70)%%12-1, "-06", sep="")) # 予測した月数に応じて延長する date0 <- unique(c(datetag, seq(max(datetag), lastday, by="month"))) idx1 <- ceiling(seq(1, length(date0), length=15)) axis(1, at=idx1, NA) text(idx1, rep(par()$usr[3], length(idx1)) ,date0[idx1], srt=45, cex=1.3, xpd=TRUE ,adj=c(1.1, 1.6)) arrows(13, nodes[13]+35, y1=nodes[13]+10, length=0.1, lwd=3) # UTAU は2008-03-06 text(13, nodes[13]+35, "UTAU", cex=2, adj=c(0.5, -0.5))
