Hatena::ブログ(Diary)

極めて個人的なメモ

Θ・)ノシ Bob#3のメモ帳です。
1972 | 12 |
2003 | 03 | 04 | 05 | 06 | 11 | 12 |
2004 | 01 | 02 | 03 | 04 | 05 | 06 | 09 | 10 | 11 | 12 |
2005 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 09 | 10 | 11 |
2006 | 03 | 04 | 05 | 06 | 07 | 09 | 10 | 11 | 12 |
2007 | 01 | 02 | 03 | 05 | 06 | 07 | 10 | 11 | 12 |
2008 | 01 | 02 | 04 | 05 | 08 | 09 | 10 | 11 |
2009 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2010 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 |
2011 | 05 | 06 | 09 | 10 |
2012 | 02 | 03 | 05 | 06 | 08 |
2013 | 01 | 02 | 03 |
2015 | 02 |

2013-03-22

[]Rでコンジョイント分析 Rでコンジョイント分析 - 極めて個人的なメモ を含むブックマーク Rでコンジョイント分析 - 極めて個人的なメモ のブックマークコメント

Rにはコンジョイント分析用のパッケージが無いなー、とずいぶん前から思っていましたがいつの間にやら登録されていたようです。

コンジョイント分析とは何か?についてはアルベルト社の解説が分かりやすいと思います。


install.packages("conjoint") #パッケージのインストール。初回のみ。

library(conjoint) #パッケージの呼び出し。

data(tea) #サンプルデータの呼び出し

# 各プロファイルの表示
# 13プロファイル(4属性(3水準、3水準、3水準、2水準))
print(tprof) # 各プロファイルの表示
#    price variety kind aroma
# 1      3       1    1     1
# 2      1       2    1     1
# 3      2       2    2     1
# 4      2       1    3     1
# 5      3       3    3     1
# 6      2       1    1     2
# 7      3       2    1     2
# 8      2       3    1     2
# 9      3       1    2     2
# 10     1       3    2     2
# 11     1       1    3     2
# 12     2       2    3     2
# 13     3       2    3     2

# 各水準のラベル
print(tlevn)
#        levels
# 1         low
# 2      medium
# 3        high
# 4       black
# 5       green
# 6         red
# 7        bags
# 8  granulated
# 9       leafy
# 10        yes
# 11         no

# 選好マトリクス。数値が大きい方が高評価。
head(tprefm) #100名×13プロファイル
#   profil1 profil2 profil3 profil4 profil5 profil6 profil7 profil8 profil9 profil10 profil11 profil12 profil13
# 1       8       1       1       3       9       2       7       2       2        2        2        3        4
# 2       0      10       3       5       1       4       8       6       2        9        7        5        2
# 3       4      10       3       5       4       1       2       0       0        1        8        9        7
# 4       6       7       4       9       6       3       7       4       8        5        2       10        9
# 5       5       1       7       8       6      10       7      10       6        6        6       10        7
# 6      10       1       1       5       1       0       0       0       0        0        0        1        1

# 分析する。最小二乗法。
# 引数は順に選好マトリクス、プロファイル、水準のラベル
Conjoint(tprefm, tprof, tlevn)
# [1] "Part worths (utilities) of levels (model parameters for whole sample):"
#        levnms    utls
# 1   intercept  3,5534
# 2         low  0,2402
# 3      medium -0,1431
# 4        high -0,0971
# 5       black  0,6149
# 6       green  0,0349
# 7         red -0,6498
# 8        bags  0,1369
# 9  granulated -0,8898
# 10      leafy  0,7529
# 11        yes  0,4108
# 12         no -0,4108
# [1] "Average importance of factors (attributes):"
# [1] 24,76 32,22 27,15 15,88
# [1] Sum of average importance:  100,01
# [1] "Chart of average factors importance"

各水準の部分効用値と各属性寄与率のグラフも同時に出力される。


price

f:id:bob3:20130323011752p:image


variety

f:id:bob3:20130323011753p:image


kind

f:id:bob3:20130323011754p:image


aroma

f:id:bob3:20130323011755p:image


寄与

f:id:bob3:20130323011756p:image


また、結果の分析だけでなくプロファイルの作成もできる。

experiment <- expand.grid(
  price   = c("low", "medium", "high"),
  variety = c("black", "green", "red"),
  kind    = c("bags", "granulated", "leafy"),
  aroma   = c("yes", "no"))
design <- caFactorialDesign(data=experiment, type="orthogonal")
# フルプロファイル法はtype="full"
# 直交計画はtype="orthogonal"
# を指定した計画type="fractional", cards=16
design
#     price variety       kind aroma
# 3    high   black       bags   yes
# 5  medium   green       bags   yes
# 10    low   black granulated   yes
# 17 medium     red granulated   yes
# 22    low   green      leafy   yes
# 27   high     red      leafy   yes
# 34    low     red       bags    no
# 42   high   green granulated    no
# 47 medium   black      leafy    no

# 分析に使うときはこれをさらにコーディングする。
caEncodedDesign(design)
#    price variety kind aroma
# 3      3       1    1     1
# 5      2       2    1     1
# 10     1       1    2     1
# 17     2       3    2     1
# 22     1       2    3     1
# 27     3       3    3     1
# 34     1       3    1     2
# 42     3       2    2     2
# 47     2       1    3     2

ちなみにできたプロファイルの直交性を確認したい時は、プロファイルコーディングした後、相関係数を見ればよい。

cor(caEncodedDesign(design))
#         price variety kind aroma
# price       1       0    0     0
# variety     0       1    0     0
# kind        0       0    1     0
# aroma       0       0    0     1

他に

といった関数が実装されています。


評価の無いプロファイルがある場合に対応してないとか、最小二乗法以外の解法が無いとか物足りない点もありますが、けっこう使い勝手が良さそうじゃないですか?これ。


なお、選択型コンジョイント分析(CBC)についてはデータ解析環境Rによる選択型コンジョイント分析入門(PDF注意)を参照されたい。

Bob3Bob3 2013/03/23 10:11 プロファイルの作成のところでexperimentを設定するコードが抜けてました。PC持たずに外出してしまったので夜に追記します。

2013-01-20 このエントリーを含むブックマーク このエントリーのブックマークコメント

メモ

http://flowingdata.com/2010/08/31/how-to-visualize-data-with-cartoonish-faces/

http://blogs.iq.harvard.edu/sss/archives/2006/11/chernoff_faces_1.shtml


青木先生

source("http://aoki2.si.gunma-u.ac.jp/R/src/face_plot.R", encoding="euc-jp")

source("http://aoki2.si.gunma-u.ac.jp/R/src/face_data.R", encoding="euc-jp")

test <- cbind(1:9,50)

pos <- c(1,rep(2,17),1)

x <- face.data(test, pos)

old <- par(mfrow=c(3, 3))

for(i in 1:9) {

face.plot(x[i,])

}

par(old)

2013-01-14 このエントリーを含むブックマーク このエントリーのブックマークコメント

メモ

library(RFinanceYJ)
library(aplpack)
library(RColorBrewer)

SINCE <- '2012-01-01'
DATE.END <- '2012-12-31'

Yahoo <- quoteStockTsData('4689.T',since=SINCE, date.end=DATE.END)
DeNA <- quoteStockTsData('2432.T',since=SINCE, date.end=DATE.END)
GREE <- quoteStockTsData('3632.T',since=SINCE, date.end=DATE.END)
Mixi <- quoteStockTsData('2121.T',since=SINCE, date.end=DATE.END)
CA <- quoteStockTsData('4751.T',since=SINCE, date.end=DATE.END)
GungHo <- quoteStockTsData('3765.Q',since=SINCE, date.end=DATE.END)
Intage <- quoteStockTsData('4326.T',since=SINCE, date.end=DATE.END)

X <- format(DeNA[,1], "%m/%d")
Y <- cbind(	Yahoo[,7]/Yahoo[1,7],
		DeNA[,7]/DeNA[1,7],
		GREE[,7]/GREE[1,7],
		CA[,7]/CA[1,7],
		Mixi[,7]/Mixi[1,7],
	#	GungHo[,7]/GungHo[1,7],
		Intage[,7]/Intage[1,7])
cols <- brewer.pal(7, "Dark2")
par(xaxt="n")
matplot(
	y=Y,
	lwd=2,
	col=cols,
	lty=1:6,
	type="l",
	xlab="date",
	ylab="per_close")
par(xaxt="s")
axis(1,at=1:length(X),labels=X)

#abline(h=1:5,lty=2,col="gray")
#legend(100, 4, c(	"Yahoo","DeNA","GREE","CA","Mixi","GunHo","Intage"),
#       lwd=2,lty=1:6, col = cols)

abline(h=seq(0.4,1.2,0.2),lty=2,col="gray")
abline(h=1,col="gray")
legend(1, 0.7, c(	"Yahoo","DeNA","GREE","CA","Mixi","Intage"),
       lwd=2,lty=1:6, col = cols)

library(animation)
# http://www.imagemagick.org
#Define path to convert.exe (http://www.imagemagick.org)
ani.options(
	convert = shQuote('C:/Program Files/ImageMagick-6.8.1-Q16/convert.exe')
	)

test <- function(){
	for (i in 1:nrow(DeNA)) {
	DAT <- rbind(DeNA[i,-1],GREE[i,-1])
	faces(DAT,print.info=FALSE, face.type=1, main=Yahoo$date[i],labels=c("DeNA","GREE"))
	}
}

saveMovie(test(),interval=0.3,moviename="TEST",movietype="gif",outdir=getwd())

Chernoff face

WIKIPEDIA http://en.wikipedia.org/wiki/Chernoff_face

元論文(1973) http://www.apprendre-en-ligne.net/mathematica/3.3/chernoff.pdf

http://flowingdata.com/2010/08/31/how-to-visualize-data-with-cartoonish-faces/

library(aplpack)

http://www.wiwi.uni-bielefeld.de/com/wolf/software/aplpack.html

representation of the rows of a data matrix by faces. The features paramters of this implementation are:

1-height of face

2-width of face

3-shape of face

4-height of mouth

5-width of mouth

6-curve of smile

7-height of eyes

8-width of eyes

9-height of hair

10-width of hair

11-styling of hair

12-height of nose

13-width of nose

14-width of ears

15-height of ears.

http://aoki2.si.gunma-u.ac.jp/R/face.html

library(symbols)

symbol(iris,type="face",scheme=3,sortby=2,colin=5)

http://www.e-stat.go.jp/SG1/estat/List.do?bid=000001027245&cycode=0

アニメーションパッケージについては

http://d.hatena.ne.jp/EulerDijkstra/20120129/1327834316

http://www.slideshare.net/sleipnir002/animation10-11306609

http://d.hatena.ne.jp/ryamada/20110809/1312750005

http://www.slideshare.net/mickey24/r-de-animation

http://menugget.blogspot.jp/2013/01/producing-animated-gifs-and-videos.html#more