双対尺度法     Last modified: Jun 20, 2008

目的

順位データについて,双対尺度法による解析を行う

使用法

ro.dual(F)

summary(object, nf=ncol(object), weighted=FALSE, digits=3) 
plot(object, first=1, second=2, weighted=FALSE)

引数

F	   順位データを行列として与える

object     dual が返すオブジェクト
nf         いくつの解を出力するか(デフォルトは最大数)
weighted   相関比で重み付けした解を対象にするかどうか(デフォルトは,重み付けしない解)
digits     出力する数値の小数点以下の桁数

first      横軸に取る解の番号(デフォルトは 1)
second     縦軸に取る解の番号(デフォルトは 2)
color.row  行に与えられる数値を描く記号(デフォルトは "blue")
color.col  列に与えられる数値を描く記号(デフォルトは "black")
mark.row   行に与えられる数値を描く記号(デフォルトは 19)
mark.col   列に与えられる数値を描く記号(デフォルトは 15)
xlab       横座標軸名(デフォルトは paste("Axis", first, sep="-"))
ylab       縦座標軸名(デフォルトは paste("Axis", second, sep="-"))
axis       座標軸を点線で描くなら TRUE(デフォルトは FALSE)
xcgx       横軸に取る座標の符号反転が必要なら TRUE(デフォルトは FALSE)
xcgy       縦軸に取る座標の符号反転が必要なら TRUE(デフォルトは FALSE)
...        points, text 等に渡されるその他の引数

ソース

インストールは,以下の 1 行をコピーし,R コンソールにペーストする
source("http://aoki2.si.gunma-u.ac.jp/R/src/ro.dual.R", encoding="euc-jp")

# 順位データを双対尺度法で分析する
ro.dual <- function(F)                                               # 順位データ
{
        F <- data.matrix(F)                                          # データフレームも行列にする
        N <- nrow(F)                                                 # 評価者の数
        if (is.null(rownames(F))) {                                     # 行名(評価者名)がないとき,
                row.names <-  paste("Row", 1:N, sep="-")             # 行名の補完
        }
        n <- ncol(F)                                                 # 評価対象の数
        if (is.null(colnames(F))) {                                     # 列名(評価対象名)がないとき,
                col.names <- paste("Col", 1:n, sep="-")              # 列名の補完
        }
        E <- n+1-2*F
        Hn <- t(E)%*%E/(N*n*(n-1)^2)
        ans <- eigen(Hn)                                             # 固有値・固有ベクトルを求める
        ne <- nrow(Hn)-1                                             # 有効な固有値・固有ベクトルの個数
        eta2 <- ans$values[1:ne]                                     # 固有値(相関比の二乗)
        eta <- sqrt(eta2)                                            # 相関比
        contribution <- eta2/sum(ans$values[1:ne])*100               # 寄与率
        cumcont <- cumsum(contribution)                              # 累積寄与率
        result <- rbind(eta2, eta, contribution, cumcont)    # 結果
        dimnames(result) <- list(c("eta square", "correlation", "contribution", "cumulative contribution"),
                                 paste("Axis", 1:ne, sep="-"))
        W <- ans$vectors[, 1:ne, drop=FALSE]                 # 固有ベクトル
        col.score <- W*sqrt(n)                                       # 列スコア
        col.score2 <- t(t(col.score)*eta)                            # 相関比で重み付けした列スコア
        row.score2 <- t(t(E%*%W/sqrt(n)/(n-1)))                      # 相関比で重み付けした行スコア
        row.score <- t(t(row.score2)/eta)                            # 行スコア
        colnames(col.score) <- colnames(row.score) <- colnames(result)
        rownames(col.score) <- col.names
        rownames(row.score) <- row.names
        dimnames(col.score2) <- dimnames(col.score)
        dimnames(row.score2) <- dimnames(row.score)
        result <- list(      result=result,
                        row.score=row.score,
                        col.score=col.score, 
                        row.score.weighted=row.score2, 
                        col.score.weighted=col.score2)
        class(result) <- "dual"                                      # summary, plot メソッドがある
        return(result)
}       

インストールは,以下の 1 行をコピーし,R コンソールにペーストする
source("http://aoki2.si.gunma-u.ac.jp/R/src/summary.dual.R", encoding="euc-jp")

# dual クラス のための summary メソッド (dual, pc.dual, ro.dual が利用する)
summary.dual <- function(    x,                              # dual が返すオブジェクト
                                nf=ncol(x[[1]]),                # 出力する解の数
                                weighted=FALSE,                 # 相関比で重み付けした解を出力するなら TRUE
                                digits=3)                       # 出力する数値の小数点以下の桁数
{
        suf <- if (weighted) 4 else 2                                # 相関比で重み付けした解も選べる
        str <- if (weighted) "weighted " else ""
        print(round(x[[1]][, 1:nf, drop=FALSE], digits=digits))
        cat(sprintf("\n%srow score\n", str))
        print(round(x[[suf]][, 1:nf, drop=FALSE], digits=digits))
        cat(sprintf("\n%scolumn score\n", str))
        print(round(x[[suf+1]][, 1:nf, drop=FALSE], digits=digits))
}

インストールは,以下の 1 行をコピーし,R コンソールにペーストする
source("http://aoki2.si.gunma-u.ac.jp/R/src/plot.dual.R", encoding="euc-jp")

# dual クラス のための plot メソッド (dual, pc.dual, ro.dual が利用する)
plot.dual <- function(       x,                                      # dual が返すオブジェクト
                        first=1,                                # 横軸にプロットする解
                        second=2,                               # 縦軸にプロットする解
                        weighted=FALSE,                         # 相関比で重み付けした解をプロットするなら TRUE
                        color.row="blue", color.col="black",    # 行と列のプロット色
                        mark.row=19, mark.col=15,               # 行と列のプロット記号
                        xlab=paste("Axis", first, sep="-"),     # 横座標軸名
                        ylab=paste("Axis", second, sep="-"),    # 縦座標軸名
                        axis=FALSE,                             # 座標軸を点線で描くなら TRUE
                        xcgx=FALSE,                             # 横軸に取る座標の符号反転が必要なら TRUE 
                        xcgy=FALSE,                             # 縦軸に取る座標の符号反転が必要なら TRUE
                        ...)                                    # points, text 等に渡されるその他の引数
{
        if (ncol(x[[1]]) == 1) {
                warning("解が1個しかありません。二次元配置図は描けません。")
                return
        }
        suf <- if (weighted) 4 else 2                                # 相関比で重み付けした解も選べる
        old <- par(xpd=TRUE, mar=c(5.1, 5.1, 2.1, 5.1))              # 左右を大きめに空ける
        row1 <- x[[suf]]  [, first]                          # 横軸に取る解
        col1 <- x[[suf+1]][, first]
        if (xcgx) {                                             # 必要なら符号反転
                row1 <- -row1
                col1 <- -col1
        }
        row2 <- x[[suf]]  [, second]                         # 縦軸に取る解
        col2 <- x[[suf+1]][, second]
        if (xcgy) {                                             # 必要なら符号反転
                row2 <- -row2
                col2 <- -col2
        }
        plot(c(row1, col1), c(row2, col2), type="n", xlab=xlab, ylab=ylab, ...)
        points(row1, row2, pch=mark.row, col=color.row, ...)
        text(row1, row2, labels=names(row1), pos=3, col=color.row, ...)
        points(col1, col2, pch=mark.col, col=color.col, ...)
        text(col1, col2, labels=names(col1), pos=3, col=color.col, ...)
        par(old)
        if (axis) {                                             # 座標軸を点線で描くならば
                abline(v=0, h=0, lty=3, ...)
        }
}


使用例

西里 P.164 のデータ

F <- matrix(c(
6,1,5,3,2,8,4,7,
3,8,1,6,7,5,4,2,
5,7,1,6,8,2,4,3,
4,6,2,3,8,7,1,5,
2,4,6,3,7,5,1,8,
2,4,5,3,8,7,1,6,
1,7,6,3,8,5,2,4,
7,5,3,1,8,4,6,2,
4,2,7,3,8,6,5,1,
5,1,2,4,7,6,3,8,
6,4,3,2,8,7,5,1,
3,8,4,2,5,6,1,7,
3,2,1,6,4,7,5,8,
5,8,1,4,7,3,6,2), byrow=TRUE, ncol=8)

ans <- ro.dual(F)
summary(ans)
summary(ans, weighted=TRUE)
plot(ans)

出力結果例

> ans <- pc.dual(F)
> summary(ans) # 相関比で重み付けしない解を,小数点以下3桁で出力(デフォルト)

                        Axis-1 Axis-2 Axis-3 Axis-4 Axis-5 Axis-6  Axis-7
eta square               0.141  0.123  0.066  0.055  0.023  0.016   0.005
correlation              0.376  0.350  0.257  0.235  0.150  0.127   0.070
contribution            33.010 28.623 15.361 12.865  5.257  3.738   1.147
cumulative contribution 33.010 61.633 76.993 89.858 95.115 98.853 100.000

row score
       Axis-1 Axis-2 Axis-3 Axis-4 Axis-5 Axis-6 Axis-7
Row-1   1.083 -0.995 -1.010  0.672 -1.316  0.738 -0.529
Row-2  -1.401  0.437  0.834  0.646  0.606  1.758 -0.364
Row-3  -1.306  0.686  0.746  0.883  0.837 -1.245 -1.373
Row-4  -1.308 -1.058  0.046  0.637 -0.699  0.484 -1.546
Row-5  -0.344 -1.668  0.322 -0.694  0.495 -1.380  0.483
Row-6  -0.801 -1.606 -0.248 -0.381  0.600  0.251 -0.203
Row-7  -1.224 -0.791  0.370 -1.455  0.524  0.352  1.106
Row-8  -1.089  0.589 -1.448  0.366 -1.226 -1.403  1.237
Row-9  -0.547 -0.076 -2.062 -1.010  1.407  0.552  0.073
Row-10 -0.054 -1.275 -0.598  1.707  0.662 -1.459 -0.303
Row-11 -1.105  0.149 -1.824  0.474 -0.558  0.945 -0.246
Row-12 -0.718 -1.174  1.084 -0.399 -2.094  0.241  0.420
Row-13  0.464 -0.899  0.310  2.060  0.992  1.048  1.967
Row-14 -1.322  1.027  0.345  0.711 -0.482 -0.193  1.443

column score
      Axis-1 Axis-2 Axis-3 Axis-4 Axis-5 Axis-6 Axis-7
Col-1 -0.351 -0.839  0.910 -0.764  1.298  0.956  1.470
Col-2  1.256 -0.665 -1.665  0.660  1.241 -0.440 -0.196
Col-3 -0.866  0.248  0.543  2.396 -0.227  0.234  0.212
Col-4 -0.564 -0.598 -1.094 -0.526 -1.763 -0.584  1.184
Col-5  2.004  0.508  0.819 -0.114 -1.094  0.913 -0.106
Col-6  0.041  1.187  0.882 -0.484  0.510 -2.075  0.109
Col-7 -0.588 -1.463  0.634 -0.459 -0.263 -0.158 -1.951
Col-8 -0.932  1.621 -1.028 -0.709  0.298  1.154 -0.723

> summary(ans, weighted=TRUE) # 相関比で重み付けした解を,小数点以下3桁で出力

                        Axis-1 Axis-2 Axis-3 Axis-4 Axis-5 Axis-6  Axis-7
eta square               0.141  0.123  0.066  0.055  0.023  0.016   0.005
correlation              0.376  0.350  0.257  0.235  0.150  0.127   0.070
contribution            33.010 28.623 15.361 12.865  5.257  3.738   1.147
cumulative contribution 33.010 61.633 76.993 89.858 95.115 98.853 100.000

weighted row score
       Axis-1 Axis-2 Axis-3 Axis-4 Axis-5 Axis-6 Axis-7
Row-1   0.407 -0.348 -0.259  0.158 -0.198  0.093 -0.037
Row-2  -0.527  0.153  0.214  0.152  0.091  0.223 -0.026
Row-3  -0.491  0.240  0.191  0.207  0.126 -0.158 -0.096
Row-4  -0.492 -0.371  0.012  0.150 -0.105  0.061 -0.108
Row-5  -0.129 -0.584  0.083 -0.163  0.074 -0.175  0.034
Row-6  -0.301 -0.562 -0.064 -0.089  0.090  0.032 -0.014
Row-7  -0.460 -0.277  0.095 -0.342  0.079  0.045  0.078
Row-8  -0.410  0.206 -0.372  0.086 -0.184 -0.178  0.087
Row-9  -0.206 -0.027 -0.529 -0.237  0.211  0.070  0.005
Row-10 -0.020 -0.447 -0.153  0.401  0.099 -0.185 -0.021
Row-11 -0.416  0.052 -0.468  0.111 -0.084  0.120 -0.017
Row-12 -0.270 -0.411  0.278 -0.094 -0.314  0.030  0.029
Row-13  0.174 -0.315  0.080  0.484  0.149  0.133  0.138
Row-14 -0.497  0.360  0.089  0.167 -0.072 -0.024  0.101

weighted column score
      Axis-1 Axis-2 Axis-3 Axis-4 Axis-5 Axis-6 Axis-7
Col-1 -0.132 -0.294  0.233 -0.179  0.195  0.121  0.103
Col-2  0.472 -0.233 -0.427  0.155  0.186 -0.056 -0.014
Col-3 -0.326  0.087  0.139  0.563 -0.034  0.030  0.015
Col-4 -0.212 -0.209 -0.281 -0.124 -0.265 -0.074  0.083
Col-5  0.754  0.178  0.210 -0.027 -0.164  0.115 -0.007
Col-6  0.015  0.416  0.226 -0.114  0.077 -0.263  0.008
Col-7 -0.221 -0.512  0.163 -0.108 -0.039 -0.020 -0.137
Col-8 -0.350  0.568 -0.264 -0.166  0.045  0.146 -0.051

> plot(ans)

fig

参考文献
 西里静彦「質的データの数量化−双対尺度法とその応用−」,朝倉書店,1982


・ 直前のページへ戻る  ・ E-mail to Shigenobu AOKI

Made with Macintosh