Fuwafuwa's memorandum

Fuwafuwa's memorandum

Data analysis, development, reading, daily feeling.
MENU

R: ODBC認証でSQL serverに接続する

library(RODBC)

##SQL serverへの接続
connect<-odbcDriverConnect("Driver={Your Database Source Name};
	Server=your server name; Database=database name; 
	Uid=user name; pwd=pass; trusted_connection=no")
##trusted_connectionはWindows認証に関する設定
##ここではWindows認証しない

##テーブルを変数に格納する
table<-sqlQuery(connect,paste("select * from [テーブル名];"))

##connectionを閉じる
odbcClose(connect)

R: ディレクトリの確認、変更

##ディレクトリの確認
getwd()

##変更
setwd("C:/Users")

R: テキストを形態素解析し頻度計算

data = read.csv("file_name.csv")

library(RMeCab)
##名詞のみを取り出す
df <- docMatrixDF(data$text,pos=c("名詞"),minFreq=65)

apply(df,MARGIN=2,sum)

R: テキストを形態素解析してwordcloudを作成する

久しぶりにやったら方法がまったくわからなくなっていたのでメモ。

data = read.csv("file_name.csv")

library(RMeCab)
##名詞のみを取り出す
df <- docMatrixDF(data$text,pos=c("名詞"),minFreq=65)
##転置
df_t<-t(df)

library(wordcloud)
##scale:第1引数文字サイズ、第二引数文字間隔
wordcloud(colnames(df_t), df_t[,1], scale = c(5, .5),min.freq=1,
          random.order = FALSE, rot.per = .1, random.color = TRUE, colors = brewer.pal(8, "Dark2"))

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,
	)
}

このカテゴリーに該当する記事はありません。