Fuwafuwa's memorandum

Fuwafuwa's memorandum

Data analysis, development, reading, daily feeling.
MENU

R: 任意のキーワードに基づく多次元尺度構成法

下記記事で出力したDTMデータを用いてRにより多次元尺度構成法をプロットする。
http://hibari1121.blog.fc2.com/blog-entry-74.html

入力データ以外に関する記述はすべて
KH-Coderからrファイルを書きだしたものをコピーしたものである。
(KH-Coder: http://khc.sourceforge.net/)

各データから任意のキーワードの出現数をDTMとし
データを圧縮したものを二次元上にプロットする。

下記のコードでここ(http://hibari1121.blog.fc2.com/blog-entry-4.html)の
図と同じものがプロットされる。

data <- read.csv("dtm_dataframe.csv")
d<-t(data)

library(amap)
check4mds <- function(d){
	jm <- as.matrix(Dist(d, method="binary"))
	jm[upper.tri(jm,diag=TRUE)] <- NA
	if ( length( which(jm==0, arr.ind=TRUE) ) ){
		return( which(jm==0, arr.ind=TRUE)[,1][1] )
	} else {
		return( NA )
	}
}

while ( is.na(check4mds(d)) == 0 ){
	n <-  check4mds(d)
	print( paste( "Dropped object:", row.names(d)[n]) )
	d <- d[-n,]
}

dj <- Dist(d,method="binary")
library(MASS)
c <- isoMDS(dj, k=2)
cl <- c$points
use_alpha <- 1

		if ( exists("saving_emf") || exists("saving_eps") ){
			use_alpha <- 0 
		}
	plot_mode <- "color"
font_size <- 1
n_cls <- 7
cls_raw <- 0
dim_n <- 2
name_dim <- '次元'
name_dim1 <- paste(name_dim,'1')
name_dim2 <- paste(name_dim,'2')
name_dim3 <- paste(name_dim,'3')
name_dim <- '次元'
text_font <- 1
std_radius <- 0
bubble_size <- 100
bubble_var <- 100


ylab_text <- ""
if ( dim_n == 2 ){
	ylab_text <- name_dim2
}
if ( dim_n == 1 ){
	cl <- cbind(cl[,1],cl[,1])
}


if (plot_mode == "color"){
	col_txt_words <- "black"
	col_dot_words <- "#00CED1"
	col_dot_vars  <- "#FF6347"
	col_bg_words  <- "NA"
}

if (plot_mode == "dots"){
	col_txt_words <- NA
	col_dot_words <- "black"
	col_dot_vars  <- "black"
	col_bg_words  <- NA
}

if ( use_alpha == 1 ){
	rgb <- c(179, 226, 205) / 255
	col_bg_words <- rgb( rgb[1], rgb[2], rgb[3], alpha=0.5 )
	rgb <- rgb * 0.5
	col_dot_words  <- rgb( rgb[1], rgb[2], rgb[3], alpha=0.5 )
}

# バブルのサイズを決定
neg_to_zero <- function(nums){
  temp <- NULL
  for (i in 1:length(nums) ){
    if ( is.na( nums[i] ) ){
      temp[i] <- 1
    } else {
	    if (nums[i] < 1){
	      temp[i] <- 1
	    } else {
	      temp[i] <-  nums[i]
	    }
	}
  }
  return(temp)
}

b_size <- NULL
for (i in rownames(cl)){
	if ( is.na(i) || is.null(i) || is.nan(i) ){
		b_size <- c( b_size, 1 )
	} else {
		b_size <- c( b_size, sum( d[i,] ) )
	}
}

b_size <- sqrt( b_size / pi ) # 出現数比=面積比になるように半径を調整

if (std_radius){ # 円の大小をデフォルメ
	if ( sd(b_size) == 0 ){
		b_size <- rep(10, length(b_size))
	} else {
		b_size <- b_size / sd(b_size)
		b_size <- b_size - mean(b_size)
		b_size <- b_size * 5 * bubble_var / 100 + 10
		b_size <- neg_to_zero(b_size)
	}
}

# クラスター分析
if (n_cls > 0){
	library( RColorBrewer )
	
	if (nrow(d) < n_cls){
		n_cls <- nrow(d)
	}
	
	if (cls_raw == 1){
		djj <- dj
	} else {
		djj <- dist(cl,method="euclid")
	}
	
	if (
		   ( as.numeric( R.Version()$major ) >= 3 )
		&& ( as.numeric( R.Version()$minor ) >= 1.0)
	){                                                      # >= R 3.1.0
		hcl <- hclust(djj,method="ward.D2")
	} else {                                                # <= R 3.0
		djj <- djj^2
		hcl <- hclust(djj,method="ward")
		#hcl$height <- sqrt( hcl$height )
	}

	col_bg_words <- brewer.pal(12, "Set3")[cutree(hcl, k=n_cls)]
	col_dot_words <- "gray40"

	if ( use_alpha == 1 ){
		rgb <- col2rgb( brewer.pal(12, "Set3") ) / 255
		col_bg_words <- rgb(
			red  =rgb[1,],
			green=rgb[2,],
			blue =rgb[3,],
			alpha=0.5
		)[cutree(hcl, k=n_cls)]
		rgb <- rgb * 0.5
		col_dot_words <- rgb(
			red  =rgb[1,],
			green=rgb[2,],
			blue =rgb[3,],
			alpha=0.92
		)[cutree(hcl, k=n_cls)]
	}

}

# バブル描画
plot(
	cl,
	pch=NA,
	col="black",
	xlab=name_dim1,
	ylab=ylab_text,
	#bty="l"
)

symbols(
	cl[,1],
	cl[,2],
	circles=b_size,
	inches=0.5 * bubble_size / 100,
	fg=col_dot_words,
	bg=col_bg_words,
	add=T,
)

# ラベル位置を決定
library(maptools)
labcd <- pointLabel(
	x=cl[,1],
	y=cl[,2],
	labels=rownames(cl),
	cex=font_size,
	offset=0,
	doPlot=F
)

# ラベル再調整
xorg <- cl[,1]
yorg <- cl[,2]
cex  <- font_size

if ( length(xorg) < 300 ) {
	library(wordcloud)

# fix for "wordlayout" function
filename <- tempfile()
writeLines("wordlayout <- function (x, y, words, cex = 1, rotate90 = FALSE, xlim = c(-Inf, 
	Inf), ylim = c(-Inf, Inf), tstep = 0.1, rstep = 0.1, ...) 
{
	tails <- \"g|j|p|q|y\"
	n <- length(words)
	sdx <- sd(x, na.rm = TRUE)
	sdy <- sd(y, na.rm = TRUE)
	iterations <- 0
	if (sdx == 0) 
		sdx <- 1
	if (sdy == 0) 
		sdy <- 1
	if (length(cex) == 1) 
		cex <- rep(cex, n)
	if (length(rotate90) == 1) 
		rotate90 <- rep(rotate90, n)
	boxes <- list()
	for (i in 1:length(words)) {
		rotWord <- rotate90[i]
		r <- 0
		theta <- runif(1, 0, 2 * pi)
		x1 <- xo <- x[i]
		y1 <- yo <- y[i]
		wid <- strwidth(words[i], cex = cex[i], ...)
		ht <- strheight(words[i], cex = cex[i], ...)
		if (grepl(tails, words[i])) 
			ht <- ht + ht * 0.2
		if (rotWord) {
			tmp <- ht
			ht <- wid
			wid <- tmp
		}
		isOverlaped <- TRUE
		while (isOverlaped) {
			if (!.overlap(x1 - 0.5 * wid, y1 - 0.5 * ht, wid, 
				ht, boxes) && x1 - 0.5 * wid > xlim[1] && y1 - 
				0.5 * ht > ylim[1] && x1 + 0.5 * wid < xlim[2] && 
				y1 + 0.5 * ht < ylim[2]) {
				boxes[[length(boxes) + 1]] <- c(x1 - 0.5 * wid, 
				  y1 - 0.5 * ht, wid, ht)
				isOverlaped <- FALSE
			}
			else {
				theta <- theta + tstep
				r <- r + rstep * tstep/(2 * pi)
				x1 <- xo + sdx * r * cos(theta)
				y1 <- yo + sdy * r * sin(theta)
				iterations <- iterations + 1
				if (iterations > 500000){
					boxes[[length(boxes) + 1]] <- c(x1 - 0.5 * wid, 
				  y1 - 0.5 * ht, wid, ht)
					isOverlaped = FALSE
				}
			}
		}
	}
	print( paste(\"iterations: \", iterations) )
	result <- do.call(rbind, boxes)
	colnames(result) <- c(\"x\", \"y\", \"width\", \"ht\")
	rownames(result) <- words
	result
}
", filename)
insertSource(filename, package="wordcloud", force=FALSE)

nc <- wordlayout(
		labcd$x,
		labcd$y,
		rownames(cl),
		cex=cex * 1.25,
		xlim=c(  par( "usr" )[1], par( "usr" )[2] ),
		ylim=c(  par( "usr" )[3], par( "usr" )[4] )
	)

	xlen <- par("usr")[2] - par("usr")[1]
	ylen <- par("usr")[4] - par("usr")[3]

	for (i in 1:length(rownames(cl)) ){
		x <- ( nc[i,1] + .5 * nc[i,3] - labcd$x[i] ) / xlen
		y <- ( nc[i,2] + .5 * nc[i,4] - labcd$y[i] ) / ylen
		dst <- sqrt( x^2 + y^2 )
		if ( dst > 0.05 ){
			# print( paste( rownames(cb)[i], d ) )
			
			if (plot_mode == "color") {
				segments(
					nc[i,1] + .5 * nc[i,3], nc[i,2] + .5 * nc[i,4],
					xorg[i], yorg[i],
					col="gray60",
					lwd=1
				)
			}
		}
	}

	xorg <- labcd$x
	yorg <- labcd$y
	labcd$x <- nc[,1] + .5 * nc[,3]
	labcd$y <- nc[,2] + .5 * nc[,4]
}

# ラベル描画
if (plot_mode == "color") {
	text(
		labcd$x,
		labcd$y,
		rownames(cl),
		cex=font_size,
		offset=0,
		font = text_font,
		col=col_txt_words,
	)
}

Pthon: 重回帰分析で切片と係数を出力する

import pandas as pd
from sklearn import linear_model

data = read_csv('data.csv')
data_model = data.iloc[:,1:6]##独立変数のみ格納


lm_x = data_model.as_matrix()
lm_y = data[0]

clf = linear_model.LinearRegression()
clf.fit(lm_x, lm_y)

print("intercept: ", clf.intercept_)
print(pd.DataFrame({"Name": data_model.columns,
	"Coefficients": clf.coef_}).sort_values(by='Coefficients'))

Python: デンドログラムでクラスタ数を同定しk-meansで分類する

サイズが大きくクラスタ数が不明なデータをクラスタリングする時。

import pandas as pd

###データの読み込み
data = pd.read_csv('data.csv')

###ランダムサンプリングで標本1000格納
sample_data = data.sample(1000)

###非類似度の指標とクラスタ連結法を指定し、階層的クラスタリングでデンドログラムを描画
from matplotlib.byplot import show
from scipy.cluster.hierarchy import linkage, dendrogram

result = linkage(sample_data.loc[:,['val0','val1','val2']], metric = 'chebyshev', method = 'average')
dendrogram(result)
show()

###k-meansでデータにクラスタをレイベリングする
###クラスタリングに使用する変数のみ格納しarray型に変換する
data_array = data.loc[:,['val0','val1','val2']].as_matrix()

###クラスタ数と初期値を設定してk-meansを実行する
from sklearn.cluster import KMeans

model = KMeans(n_clusters=5, random_state=20).fit(data_array)
labels = model.labels_

###labelをpandas型に変換する
labels_pandas = pd.DataFrame(labels)

###元データにラベルを結合する
data_labels = pd.concat([data,labels_pandas],axis=1)
data_labels = data_labels.rename(columns={0:'label'})

R: 任意のキーワードに基づく対応分析

前回下記記事で出力したDTMおよび圧縮データを用いてRにより対応分析を行う。
http://hibari1121.blog.fc2.com/blog-entry-74.html

入力データ以外に関する記述はすべて
KH-Coderからrファイルを書きだしたものをコピーしたものである。
(KH-Coder: http://khc.sourceforge.net/)

各データから任意のキーワードの出現数をDTMとし
データを圧縮したものを二次元上にプロットする。
その際下記手順ではdata中カラムpriorityを
テンパーセンタイルごとにカテゴライズし、キーワードの散布と対応させる。

data<-read.csv("ファイル名")

dtm_data<-read.csv("dtm_df.csv")
pca_data<-read.csv("pca_df.csv")

d<-dtm_data
doc_length_mtr<-pca_data

v_count <- 0
v_pch   <- NULL

v0<-ceiling((rank(data$priority)*10)/length(data$priority))
name_nav <- '欠損値'

aggregate_with_var <- function(d, doc_length_mtr, v) {
	d              <- aggregate(d,list(name = v), sum)
	doc_length_mtr <- aggregate(doc_length_mtr,list(name = v), sum)

	row.names(d) <- d$name
	d$name <- NULL
	row.names(doc_length_mtr) <- doc_length_mtr$name
	doc_length_mtr$name <- NULL

	d              <- d[              order(rownames(d             )), ]
	doc_length_mtr <- doc_length_mtr[ order(rownames(doc_length_mtr)), ]

	doc_length_mtr <- subset(
		doc_length_mtr,
		row.names(d) != name_nav & row.names(d) != "." & row.names(d) != "missing"
	)
	d <- subset(
		d,
		row.names(d) != name_nav & row.names(d) != "." & row.names(d) != "missing"
	)

	# doc_length_mtr <- subset(doc_length_mtr, rowSums(d) > 0)
	# d              <- subset(d,              rowSums(d) > 0)

	return( list(d, doc_length_mtr) )
}

dd <- NULL
nn <- NULL

for (i in list(v0)){

	cur <- aggregate_with_var(d, doc_length_mtr, i)
	dd <- rbind(dd, cur[[1]])
	nn <- rbind(nn, cur[[2]])
	v_count <- v_count + 1
	v_pch <- c( v_pch, rep(v_count + 2, nrow(cur[[1]]) ) )
}

d              <- dd
doc_length_mtr <- nn


		if ( length(v_pch) == 0 ) {
			v_pch   <- 3
			v_count <- 1
		}
	if ( length(v_pch) > 1 ){ v_pch <- v_pch[rowSums(d) > 0] }
doc_length_mtr <- subset(doc_length_mtr, rowSums(d) > 0)
d              <- subset(d,              rowSums(d) > 0)
n_total <- doc_length_mtr[,2]
d <- t(d)
d <- subset(d, rowSums(d) > 0)
d <- t(d)
# END: DATA
r_max <- 150
d_x <- 1
d_y <- 2
flt <- 0
flw <- 60
biplot <- 1
cex=1
use_alpha <- 1

		if ( exists("saving_emf") || exists("saving_eps") ){
			use_alpha <- 0 
		}
	name_dim <- '成分'
name_eig <- '固有値'
name_exp <- '寄与率'
library(MASS)

# Filter words by chi-square value ※日本語コメント
if ( (flw > 0) && (flw < ncol(d)) ){
	sort  <- NULL
	for (i in 1:ncol(d) ){
		# print( paste(colnames(d)[i], chisq.test( cbind(d[,i], n_total - d[,i]) )$statistic) )
		sort <- c(
			sort, 
			chisq.test( cbind(d[,i], n_total - d[,i]) )$statistic
		)
	}
	d <- d[,order(sort,decreasing=T)]
	d <- d[,1:flw]
	d <- subset(d, rowSums(d) > 0)
}

c <- corresp(d, nf=min( nrow(d), ncol(d) ) )

# Dilplay Labels only for distinctive words
if ( (flt > 0) && (flt < nrow(c$cscore)) ){
	sort  <- NULL
	limit <- NULL
	names <- NULL
	ptype <- NULL
	
	# compute distance from (0,0)
	for (i in 1:nrow(c$cscore) ){
		sort <- c(sort, c$cscore[i,d_x] ^ 2 + c$cscore[i,d_y] ^ 2 )
	}
	
	# Put labels to top words
	limit <- sort[order(sort,decreasing=T)][flt]
	for (i in 1:nrow(c$cscore) ){
		if ( sort[i] >= limit ){
			names <- c(names, rownames(c$cscore)[i])
			ptype <- c(ptype, 1)
		} else {
			names <- c(names, NA)
			ptype <- c(ptype, 2)
		}
	}
	rownames(c$cscore) <- names;
} else {
	ptype <- 1
}

pch_cex <- 1
if ( v_count > 1 ){
	pch_cex <- 1.25
}

k <- c$cor^2
txt <- cbind( 1:length(k), round(k,4), round(100*k / sum(k),2) )
colnames(txt) <- c(name_dim,name_eig,name_exp)
print( txt )
k <- round(100*k / sum(k),2)

# configure the slab function
s.label_my <- function (dfxy, xax = 1, yax = 2, label = row.names(dfxy),
    clabel = 1, 
    pch = 20, cpoint = if (clabel == 0) 1 else 0, boxes = TRUE, 
    neig = NULL, cneig = 2, xlim = NULL, ylim = NULL, grid = TRUE, 
    addaxes = TRUE, cgrid = 1, include.origin = TRUE, origin = c(0, 
        0), sub = "", csub = 1.25, possub = "bottomleft", pixmap = NULL, 
    contour = NULL, area = NULL, add.plot = FALSE) 
{
    dfxy <- data.frame(dfxy)
    opar <- par(mar = par("mar"))
    on.exit(par(opar))
    par(mar = c(0.1, 0.1, 0.1, 0.1))
    coo <- scatterutil.base(dfxy = dfxy, xax = xax, yax = yax, 
        xlim = xlim, ylim = ylim, grid = grid, addaxes = addaxes, 
        cgrid = cgrid, include.origin = include.origin, origin = origin, 
        sub = sub, csub = csub, possub = possub, pixmap = pixmap, 
        contour = contour, area = area, add.plot = add.plot)
    if (!is.null(neig)) {
        if (is.null(class(neig))) 
            neig <- NULL
        if (class(neig) != "neig") 
            neig <- NULL
        deg <- attr(neig, "degrees")
        if ((length(deg)) != (length(coo$x))) 
            neig <- NULL
    }
    if (!is.null(neig)) {
        fun <- function(x, coo) {
            segments(coo$x[x[1]], coo$y[x[1]], coo$x[x[2]], coo$y[x[2]], 
                lwd = par("lwd") * cneig)
        }
        apply(unclass(neig), 1, fun, coo = coo)
    }
    if (clabel > 0) 
        scatterutil.eti_my(coo$x, coo$y, label, clabel, boxes)
    if (cpoint > 0 & clabel < 1e-06) 
        points(coo$x, coo$y, pch = pch, cex = par("cex") * cpoint)
    #box()
    invisible(match.call())
}
scatterutil.eti_my <- function (x, y, label, clabel, boxes = TRUE, coul = rep(1, length(x)), 
    horizontal = TRUE) 
{
    if (length(label) == 0) 
        return(invisible())
    if (is.null(label)) 
        return(invisible())
    if (any(label == "")) 
        return(invisible())
    cex0 <- par("cex") * clabel
    for (i in 1:(length(x))) {
        cha <- as.character(label[i])
        cha2 <- paste( " ", cha, " ", sep = "")
        x1 <- x[i]
        y1 <- y[i]
        xh <- strwidth(cha2, cex = cex0)
        yh <- strheight(cha, cex = cex0) * 5/3
        if (!horizontal) {
            tmp <- scatterutil.convrot90(xh, yh)
            xh <- tmp[1]
            yh <- tmp[2]
        }
        if (boxes) {
            rect(x1 - xh/2, y1 - yh/2, x1 + xh/2, y1 + yh/2, 
                col = "white", border = coul[i])
        }
        if (horizontal) {
            text(x1, y1, cha, cex = cex0, col = coul[i])
            print("looks ok...")
        }
        else {
            text(x1, y1, cha, cex = cex0, col = coul[i], srt = 90)
        }
    }
}
font_size <- 1
std_radius <- 1
resize_vars <- 1
bubble_size <- 100
bubble_var <- 100
labcd <- NULL

plot_mode <- "color"


col_bg_words <- NA
col_bg_vars  <- NA

if (plot_mode == "color"){
	col_txt_words <- "black"
	col_txt_vars  <- "#DC143C"
	col_dot_words <- "#00CED1"
	col_dot_vars  <- "#FF6347"
	if ( use_alpha == 1 ){
		col_bg_words <- "#48D1CC"
		col_bg_vars  <- "#FFA07A"
		
		rgb <- col2rgb(col_bg_words) / 255
		col_bg_words <- rgb( rgb[1], rgb[2], rgb[3], alpha=0.15 )
		rgb <- rgb * 0.75
		col_dot_words  <- rgb( rgb[1], rgb[2], rgb[3], alpha=0.6 )
		
		rgb <- col2rgb(col_bg_vars) / 255
		col_bg_vars <- rgb( rgb[1], rgb[2], rgb[3], alpha=0.15 )
	}
}

if (plot_mode == "gray"){
	col_txt_words <- "black"
	col_txt_vars  <- "black"
	col_dot_words <- "gray55"
	col_dot_vars  <- "gray30"
}

if (plot_mode == "vars"){
	col_txt_words <- NA
	col_txt_vars  <- "black"
	col_dot_words <- "#ADD8E6"
	col_dot_vars  <- "red"
}

if (plot_mode == "dots"){
	col_txt_words <- NA
	col_txt_vars  <- NA
	col_dot_words <- "black"
	col_dot_vars  <- "black"
}

# Bubble size
neg_to_zero <- function(nums){
  temp <- NULL
  for (i in 1:length(nums) ){
    if (nums[i] < 1){
      temp[i] <- 1
    } else {
      temp[i] <-  nums[i]
    }
  }
  return(temp)
}

b_size <- NULL
for (i in rownames(c$cscore)){
	if ( is.na(i) || is.null(i) || is.nan(i) ){
		b_size <- c( b_size, 1 )
	} else {
		b_size <- c( b_size, sum( d[,i] ) )
	}
}

b_size <- sqrt( b_size / pi ) # adjust bubble size: frequency ratio = square measure ratio

if (std_radius){ # standardize (enphasize) bubble size
	if ( sd(b_size) == 0 ){
		b_size <- rep(10, length(b_size))
	} else {
		b_size <- b_size / sd(b_size)
		b_size <- b_size - mean(b_size)
		b_size <- b_size * 5 * bubble_var / 100 + 10
		b_size <- neg_to_zero(b_size)
	}
}

# set plot area
plot(
	rbind(
		cbind(c$cscore[,d_x], c$cscore[,d_y], ptype),
		cbind(c$rscore[,d_x], c$rscore[,d_y], v_pch)
	),
	pch=NA,
	col="black",
	xlab=paste(name_dim,d_x," (",k[d_x],"%)",sep=""),
	ylab=paste(name_dim,d_y," (",k[d_y],"%)",sep=""),
	#bty="l"
)

# draw bubbles of words
symbols(
	c$cscore[,d_x],
	c$cscore[,d_y],
	circles=b_size,
	inches=0.5 * bubble_size / 100,
	fg=c(col_dot_words,"#ADD8E6")[ptype],
	bg=c(col_bg_words,"#ADD8E6")[ptype],
	add=T,
)

# draw bubbles of variables
if (biplot){
	# bubble size
	if (resize_vars){
		pch_cex <- sqrt(n_total);
		pch_cex <- pch_cex * ( 10 / max(pch_cex) )
		if (std_radius){ # standardize (enphasize) bubble size
			if ( sd(pch_cex) == 0 ){
				pch_cex <- rep(10,length(pch_cex))
			} else {
				pch_cex <- pch_cex / sd(pch_cex)
				pch_cex <- pch_cex - mean(pch_cex)
				pch_cex <- pch_cex * 5 + 10
				pch_cex <- neg_to_zero(pch_cex)
				pch_cex <- pch_cex * ( 10 / max(pch_cex) )
			}
		}
		pch_cex <- pch_cex * bubble_size / 100
	}
	# plot points of variables
	points(
		cbb <- cbind(c$rscore[,d_x], c$rscore[,d_y], v_pch),
		pch=c(20,1,22,23:25,21,4-14)[cbb[,3]],
		col=c("#66CCCC","#ADD8E6",rep( col_dot_vars, v_count ))[cbb[,3]],
		bg=col_bg_vars,
		cex=pch_cex,
	)
}

# compute label positions
if (biplot){
	cb <- rbind(
		cbind(c$cscore[,d_x], c$cscore[,d_y], ptype),
		cbind(c$rscore[,d_x], c$rscore[,d_y], v_pch)
	)
} else {
	cb <- cbind(c$cscore[,d_x], c$cscore[,d_y], ptype)
}

if ( is.null(labcd) ){
	library(maptools)
	labcd <- pointLabel(
		x=cb[,1],
		y=cb[,2],
		labels=rownames(cb),
		cex=font_size,
		offset=0,
		doPlot=F
	)

	xorg <- cb[,1]
	yorg <- cb[,2]
	#cex  <- 1

	n_words_chk <- c( length(c$cscore[,d_x]) )
	if (flt > 0) {
		n_words_chk <- c(n_words_chk, flt)
	}
	if (flw > 0) {
		n_words_chk <- c(n_words_chk, flw)
	}
	if ( 
		   ( (biplot == 0) && (min(n_words_chk) < 300) )
		|| (
			   (biplot == 1)
			&& ( min(n_words_chk) < 300 )
			&& ( length(c$rscore[,d_x]) < r_max )
		)
	){
		library(wordcloud)
		nc <- wordlayout(
			labcd$x,
			labcd$y,
			rownames(cb),
			cex=cex * 1.25,
			xlim=c(  par( "usr" )[1], par( "usr" )[2] ),
			ylim=c(  par( "usr" )[3], par( "usr" )[4] )
		)

		xlen <- par("usr")[2] - par("usr")[1]
		ylen <- par("usr")[4] - par("usr")[3]

		segs <- NULL
		for (i in 1:length( rownames(cb) ) ){
			x <- ( nc[i,1] + .5 * nc[i,3] - labcd$x[i] ) / xlen
			y <- ( nc[i,2] + .5 * nc[i,4] - labcd$y[i] ) / ylen
			dst <- sqrt( x^2 + y^2 )
			if ( dst > 0.05 ){
				segs <- rbind(
					segs,
					c(
						nc[i,1] + .5 * nc[i,3], nc[i,2] + .5 * nc[i,4],
						xorg[i], yorg[i]
					) 
				)
				#segments(
				#	nc[i,1] + .5 * nc[i,3], nc[i,2] + .5 * nc[i,4],
				#	xorg[i], yorg[i],
				#	col="gray60",
				#	lwd=1
				#)
				
			}
		}

		xorg <- labcd$x
		yorg <- labcd$y
		labcd$x <- nc[,1] + .5 * nc[,3]
		labcd$y <- nc[,2] + .5 * nc[,4]
	}

}

# draw labels
if (plot_mode == "gray"){
	cb  <- cbind(cb, labcd$x, labcd$y)
	cb1 <-  subset(cb, cb[,3]==1)
	cb2 <-  subset(cb, cb[,3]>=3)
	text(cb1[,4], cb1[,5], rownames(cb1),cex=font_size,offset=0,col="black",)
	library(ade4)
	s.label_my(
		cb2,
		xax=4,
		yax=5,
		label=rownames(cb2),
		boxes=T,
		clabel=font_size,
		addaxes=F,
		include.origin=F,
		grid=F,
		cpoint=0,
		cneig=0,
		cgrid=0,
		add.plot=T,
	)
	if (resize_vars == 0){
		points(cb2[,1], cb2[,2], pch=c(20,1,0,2,4:15)[cb2[,3]], col="gray30")
	}
	if ( exists("segs") ){
		if ( is.null(segs) == F){
			for (i in 1:nrow(segs) ){
				segments(
					segs[i,1],segs[i,2],segs[i,3],segs[i,4],
					col="gray60",
					lwd=1
				)
			}
		}
	}
} else if (plot_mode == "vars") {
	cb  <- cbind(cb, labcd$x, labcd$y)
	cb2 <-  subset(cb, cb[,3]>=3)
	text(
		cb2[,4],
		cb2[,5],
		rownames(cb2),
		cex=font_size,
		offset=0,
		col=col_txt_vars
	)
} else if (plot_mode == "color") {
	text(
		labcd$x,
		labcd$y,
		rownames(cb),
		cex=font_size,
		offset=0,
		col=c(col_txt_words,NA,rep(col_txt_vars,v_count) )[cb[,3]]
	)
	if ( exists("segs") ){
		if ( is.null(segs) == F){
			for (i in 1:nrow(segs) ){
				segments(
					segs[i,1],segs[i,2],segs[i,3],segs[i,4],
					col="gray60",
					lwd=1
				)
			}
		}
	}
}
python上でも対応分析およびコレスポンデンス分析は可能だが
現在私が知っている中で上記ソースコードによるプロットがもっとも美しいため
データを前処理後Rでプロットした。
可視化の美しさは多少の工数の削減よりも優先される。

Python: 任意のキーワードを用いてDTMを作成する

任意のキーワードの各データにおける出現数を値とした
id×キーワードのデータフレームを作成する。

(既存のモジュールに依らないドキュメントタームマトリクスの作成)
(形態素解析器が依拠する辞書の書き換えでも可だがより汎用性のある形式としたいため)

キーワードの内容および総数は不明なものとする。
元データはひとつ以上のキーワードをカンマ区切りとしたもの

import pandas as pd

f = pd.read_csv('ファイル名')

##キーワードをリスト化
key = []
for item in f['keyword']:
    for i in item.split(','):
        key.append(i)
    
##セットにして重複を除く
keyword = set(key)
##キーワードの総数を一応確認
len(category)

##データごとのキーワードリストを作成
keywords = []
for line in f['keyword']:
    line_list = []
    line_list.append(line.split(','))
    keywords.append(line_list)

##データごとのキーワードの出現数を数える
dtm = []
for text in keywords: ##データ内のキーワード
    for line in text:
        k_list = []
        for k in keyword: ##数え上げるキーワードをリストにしたもの
            k_list.append(line.count(k))
        dtm.append(k_list)
上記の操作により形態素解析器に依拠せず任意のキーワードリストから
ドキュメントタームマトリクスを作成する事ができる。

また、下記ではデータの圧縮および描画、書き出しを行っている。
##配列にしてPCAで二次元に圧縮
import numpy as np
import sklearn.decomposition

dtm_array = np.array(dtm)
pca = sklearn.decomposition.PCA(n_components = 2)
pca.fit(dtm_array)
dtm_pca = pca.transform(dtm_array)

##numpyの配列をpandasのデータフレームに変換する
dtm_dataframe = pd.DataFrame(dtm_array, columns = keyword)
pca_dataframe = pd.DataFrame(dtm_pca, columns = ['length_c', 'length_w'])

##二次元上に散布
import matplotlib.pyplot as plt

fig = plt.figure()
ax = fig.add_subplot(111)
ax.scatter(pca_dataframe['length_c'], pca_dataframe['length_w'],c='red')
 
fig.show()
上記のドキュメントタームマトリクスおよび圧縮データを用いて
キーワードを二次元上にプロットすることもできる
なお今回は前述の操作の後Rでグラフィックにしたが省略。
必要あれば追記か別記事。

該当の記事は見つかりませんでした。