1. 武内候補の得票率

d1 <- c(14,30,61,110,117,100,127,62) # パーセントの基数
d2 <- c(3,11,36,51,62,44,47,20)
d3 <- d1 - d2
round(d2/d1*100,digits = 1)

## [1] 21.4 36.7 59.0 46.4 53.0 44.0 37.0 32.3

d2 # 武内得票数

## [1]  3 11 36 51 62 44 47 20

d3 # その他候補得票数

## [1] 11 19 25 59 55 56 80 42

m <- matrix(c(d2,d3),nrow = 8)
m

##      [,1] [,2]
## [1,]    3   11
## [2,]   11   19
## [3,]   36   25
## [4,]   51   59
## [5,]   62   55
## [6,]   44   56
## [7,]   47   80
## [8,]   20   42

dimnames(m) <- list(
  Age = c("18-19","20s","30s","40s","50s","60s","70s","80-"),
  Candidate = c("Takeuchi","Others")
)

m

##        Candidate
## Age     Takeuchi Others
##   18-19        3     11
##   20s         11     19
##   30s         36     25
##   40s         51     59
##   50s         62     55
##   60s         44     56
##   70s         47     80
##   80-         20     42

# 行列の保存
m82 <- m

モザイク図(1)

mosaicplot(m,color = T,main = "")

モザイク図(2)

par(family= "HiraKakuProN-W3", cex=0.86) 
mosaicplot(m,shade=TRUE, main = "",dir=c("h","v"))

2. 2候補とその他に分類

d1 <- c(14,30,61,110,117,100,127,62) # 基数
d2 <- c(3,11,36,51,62,44,47,20) # 武内候補


d4 <- c(28,46,23,39,34,44,48,51)/100 # 帯グラフより読み取り（津森候補）
d4

## [1] 0.28 0.46 0.23 0.39 0.34 0.44 0.48 0.51

d5 <- round(d1 * d4, digits = 0) # 津森候補得票数（推定）
d5

## [1]  4 14 14 43 40 44 61 32

d6 <- d1 - d2 - d5 # 2候補以外の得票数を計算

m <- matrix(c(d2,d5,d6),nrow = 8)
m

##      [,1] [,2] [,3]
## [1,]    3    4    7
## [2,]   11   14    5
## [3,]   36   14   11
## [4,]   51   43   16
## [5,]   62   40   15
## [6,]   44   44   12
## [7,]   47   61   19
## [8,]   20   32   10

dimnames(m) <- list(
  Age = c("18-19","20s","30s","40s","50s","60s","70s","80-"),
  Candidate = c("Takeuchi","Tsumori","Others")
)

m

##        Candidate
## Age     Takeuchi Tsumori Others
##   18-19        3       4      7
##   20s         11      14      5
##   30s         36      14     11
##   40s         51      43     16
##   50s         62      40     15
##   60s         44      44     12
##   70s         47      61     19
##   80-         20      32     10

# 行列の保存
m83 <- m

knitr::kable(m)

	Takeuchi	Tsumori	Others
18-19	3	4	7
20s	11	14	5
30s	36	14	11
40s	51	43	16
50s	62	40	15
60s	44	44	12
70s	47	61	19
80-	20	32	10

分割表の独立性の検定（リサンプリング法）

chisq.test(m,simulate.p.value = T)

## 
##  Pearson's Chi-squared test with simulated p-value (based on 2000
##  replicates)
## 
## data:  m
## X-squared = 33.906, df = NA, p-value = 0.001999

年代と得票率のクロス表

round(100*prop.table(m,1),digits = 1)

##        Candidate
## Age     Takeuchi Tsumori Others
##   18-19     21.4    28.6   50.0
##   20s       36.7    46.7   16.7
##   30s       59.0    23.0   18.0
##   40s       46.4    39.1   14.5
##   50s       53.0    34.2   12.8
##   60s       44.0    44.0   12.0
##   70s       37.0    48.0   15.0
##   80-       32.3    51.6   16.1

モザイク図(3)

par(family= "HiraKakuProN-W3", cex=0.86) 
mosaicplot(m,shade=TRUE, main = "",dir=c("h","v"))

モザイク図(4)

mosaicplot(m,color = T,main = "")

対応分析

library(ca)
ca(m)

## 
##  Principal inertias (eigenvalues):
##            1       2      
## Value      0.03106 0.02354
## Percentage 56.89%  43.11% 
## 
## 
##  Rows:
##             18-19       20s       30s      40s      50s       60s       70s
## Mass     0.022544  0.048309  0.098229 0.177134 0.188406  0.161031  0.204509
## ChiDist  0.969251  0.151505  0.362974 0.045330 0.178626  0.099979  0.158840
## Inertia  0.021179  0.001109  0.012942 0.000364 0.006012  0.001610  0.005160
## Dim. 1  -1.878378 -0.859621  1.849441 0.250167 1.002049 -0.094374 -0.860007
## Dim. 2  -5.937475 -0.008814 -1.041036 0.068653 0.174852  0.642561  0.309693
##               80-
## Mass     0.099839
## ChiDist  0.249704
## Inertia  0.006225
## Dim. 1  -1.400480
## Dim. 2   0.246704
## 
## 
##  Columns:
##         Takeuchi   Tsumori    Others
## Mass    0.441224  0.405797  0.152979
## ChiDist 0.197846  0.204775  0.364391
## Inertia 0.017271  0.017016  0.020313
## Dim. 1  1.113951 -0.996239 -0.570214
## Dim. 2  0.159800  0.686872 -2.282914

par(pty="s",family= "HiraKakuProN-W3")
plot(ca(m),lines = c("F","F"),contrib=c("none","none"))

summary(ca(m))

## 
## Principal inertias (eigenvalues):
## 
##  dim    value      %   cum%   scree plot               
##  1      0.031060  56.9  56.9  **************           
##  2      0.023540  43.1 100.0  ***********              
##         -------- -----                                 
##  Total: 0.054600 100.0                                 
## 
## 
## Rows:
##     name   mass  qlt  inr    k=1  cor ctr    k=2 cor ctr  
## 1 | 1819 |   23 1000  388 | -331  117  80 | -911 883 795 |
## 2 |  20s |   48 1000   20 | -151 1000  36 |   -1   0   0 |
## 3 |  30s |   98 1000  237 |  326  806 336 | -160 194 106 |
## 4 |  40s |  177 1000    7 |   44  946  11 |   11  54   1 |
## 5 |  50s |  188 1000  110 |  177  977 189 |   27  23   6 |
## 6 |  60s |  161 1000   29 |  -17   28   1 |   99 972  66 |
## 7 |  70s |  205 1000   95 | -152  911 151 |   48  89  20 |
## 8 |   80 |  100 1000  114 | -247  977 196 |   38  23   6 |
## 
## Columns:
##     name   mass  qlt  inr    k=1 cor ctr    k=2 cor ctr  
## 1 | Tkch |  441 1000  316 |  196 985 548 |   25  15  11 |
## 2 | Tsmr |  406 1000  312 | -176 735 403 |  105 265 191 |
## 3 | Othr |  153 1000  372 | -100  76  50 | -350 924 797 |

対応分析

m <- m83

plot(ca(m),map="rowprincipal", main="rowprincipal")

plot(ca(m,suprow=1))

3. 18歳と19歳、20歳代を合併する

m <- m83

d7 <- m[1,] + m[2,]
d7 # 18歳・19歳、20歳代の併合

## Takeuchi  Tsumori   Others 
##       14       18       12

m_ <- m[-c(1,2),]
m_ # 30代以降のみの行列

##      Candidate
## Age   Takeuchi Tsumori Others
##   30s       36      14     11
##   40s       51      43     16
##   50s       62      40     15
##   60s       44      44     12
##   70s       47      61     19
##   80-       20      32     10

合併したクロス表

m <- rbind(d7,m_)
row.names(m)[1] <- "18-29"
m

##       Takeuchi Tsumori Others
## 18-29       14      18     12
## 30s         36      14     11
## 40s         51      43     16
## 50s         62      40     15
## 60s         44      44     12
## 70s         47      61     19
## 80-         20      32     10

# 行列の保存
m73 <- m
saveRDS(m73,file = "data/m73.RDS")

カイ2乗検定（クロス表）

chisq.test(m)

## 
##  Pearson's Chi-squared test
## 
## data:  m
## X-squared = 25.701, df = 12, p-value = 0.01183

chisq.test(m,simulate.p.value = T)

## 
##  Pearson's Chi-squared test with simulated p-value (based on 2000
##  replicates)
## 
## data:  m
## X-squared = 25.701, df = NA, p-value = 0.01199

# fisher.test(m73)

2候補の得票率の得票率の差を年代別にみる

# データを準備する
m0 <- round(100*prop.table(m,1),digits = 1)
m0 # 行パーセントの計算

##       Takeuchi Tsumori Others
## 18-29     31.8    40.9   27.3
## 30s       59.0    23.0   18.0
## 40s       46.4    39.1   14.5
## 50s       53.0    34.2   12.8
## 60s       44.0    44.0   12.0
## 70s       37.0    48.0   15.0
## 80-       32.3    51.6   16.1

data <- m0[,1]- m0[,2]
data

## 18-29   30s   40s   50s   60s   70s   80- 
##  -9.1  36.0   7.3  18.8   0.0 -11.0 -19.3

# バーチャートを描画する
par(family= "HiraKakuProN-W3")
barplot(data, main = "年代別にみた2候補の得票率の差(武内候補−津森候補)", xlab = "年代", ylab = "値（パーセント）")

モザイク図(5)

par(family= "HiraKakuProN-W3", cex=0.86) 
mosaicplot(m,shade=TRUE, main = "",dir=c("h","v"))

対応分析

m <- m73

par(pty="s",family= "HiraKakuProN-W3")
plot(ca(m),lines = c("F","F"),contrib = c("none","none"))

plot(ca(m),lines = c("F","F"),contrib = c("none","none"),arrows = c("T","T"))

plot(ca(m),map="rowprincipal", main="rowprincipal")

analysis_ca <- ca(m)
analysis_ca

## 
##  Principal inertias (eigenvalues):
##            1        2       
## Value      0.030879 0.010507
## Percentage 74.61%   25.39%  
## 
## 
##  Rows:
##             18-29      30s       40s       50s       60s       70s       80-
## Mass     0.070853 0.098229  0.177134  0.188406  0.161031  0.204509  0.099839
## ChiDist  0.357875 0.362974  0.045330  0.178626  0.099979  0.158840  0.249704
## Inertia  0.009075 0.012942  0.000364  0.006012  0.001610  0.005160  0.006225
## Dim. 1  -0.972548 1.953385  0.241513  0.978247 -0.163593 -0.889431 -1.420463
## Dim. 2   3.067461 1.151217 -0.155377 -0.473644 -0.934161 -0.276315 -0.067364
## 
## 
##  Columns:
##          Takeuchi   Tsumori    Others
## Mass     0.441224  0.405797  0.152979
## ChiDist  0.193158  0.197171  0.244543
## Inertia  0.016462  0.015776  0.009148
## Dim. 1   1.085482 -1.073830 -0.282283
## Dim. 2  -0.296905 -0.557831  2.336056

summary(analysis_ca)

## 
## Principal inertias (eigenvalues):
## 
##  dim    value      %   cum%   scree plot               
##  1      0.030879  74.6  74.6  *******************      
##  2      0.010507  25.4 100.0  ******                   
##         -------- -----                                 
##  Total: 0.041386 100.0                                 
## 
## 
## Rows:
##     name   mass  qlt  inr    k=1 cor ctr    k=2 cor ctr  
## 1 | 1829 |   71 1000  219 | -171 228  67 |  314 772 667 |
## 2 |  30s |   98 1000  313 |  343 894 375 |  118 106 130 |
## 3 |  40s |  177 1000    9 |   42 877  10 |  -16 123   4 |
## 4 |  50s |  188 1000  145 |  172 926 180 |  -49  74  42 |
## 5 |  60s |  161 1000   39 |  -29  83   4 |  -96 917 141 |
## 6 |  70s |  205 1000  125 | -156 968 162 |  -28  32  16 |
## 7 |   80 |  100 1000  150 | -250 999 201 |   -7   1   0 |
## 
## Columns:
##     name   mass  qlt  inr    k=1 cor ctr    k=2 cor ctr  
## 1 | Tkch |  441 1000  398 |  191 975 520 |  -30  25  39 |
## 2 | Tsmr |  406 1000  381 | -189 916 468 |  -57  84 126 |
## 3 | Othr |  153 1000  221 |  -50  41  12 |  239 959 835 |

# str(summary(analysis_ca))
smmry <- summary(analysis_ca)
rp <- smmry$rows[,c(5,8)]/1000 # 行主座標
cp <-smmry$columns[,c(5,8)]/1000 # 列主座標

rp_cp <- rbind(rp,cp)
plot(rp_cp)
abline(h=0)
abline(v=0)

analysis_ca$sv # 特異値（固有値の平方根）

## [1] 0.1757236 0.1025059

analysis_ca$rownames

## [1] "18-29" "30s"   "40s"   "50s"   "60s"   "70s"   "80-"

analysis_ca$rowmass # Row masses

## [1] 0.07085346 0.09822866 0.17713366 0.18840580 0.16103060 0.20450886 0.09983897

analysis_ca$rowdist # Row chi-square distances to centroid

## [1] 0.35787540 0.36297413 0.04532985 0.17862594 0.09997901 0.15883987 0.24970436

analysis_ca$rowinertia # Row inertias　慣性は分散と同義

## [1] 0.0090745430 0.0129416480 0.0003639733 0.0060115062 0.0016096301
## [6] 0.0051597796 0.0062251864

analysis_ca$rowcoord # Row standard coordinates

##             Dim1        Dim2
## 18-29 -0.9725482  3.06746095
## 30s    1.9533852  1.15121734
## 40s    0.2415135 -0.15537744
## 50s    0.9782470 -0.47364385
## 60s   -0.1635928 -0.93416066
## 70s   -0.8894314 -0.27631546
## 80-   -1.4204626 -0.06736388

analysis_ca$colnames

## [1] "Takeuchi" "Tsumori"  "Others"

analysis_ca$colmass

## [1] 0.4412238 0.4057971 0.1529791

analysis_ca$coldist

## [1] 0.1931576 0.1971708 0.2445433

analysis_ca$colinertia

## [1] 0.01646199 0.01577590 0.00914837

analysis_ca$colcoord

##                Dim1       Dim2
## Takeuchi  1.0854818 -0.2969052
## Tsumori  -1.0738299 -0.5578307
## Others   -0.2822828  2.3360562

analysis_ca$N # The frequency table

##      [,1] [,2] [,3]
## [1,]   14   18   12
## [2,]   36   14   11
## [3,]   51   43   16
## [4,]   62   40   15
## [5,]   44   44   12
## [6,]   47   61   19
## [7,]   20   32   10

##       Takeuchi Tsumori Others
## 18-29       14      18     12
## 30s         36      14     11
## 40s         51      43     16
## 50s         62      40     15
## 60s         44      44     12
## 70s         47      61     19
## 80-         20      32     10

apply(m,1,sum) # 各列の計を計算

## 18-29   30s   40s   50s   60s   70s   80- 
##    44    61   110   117   100   127    62

sum(apply(m,1,sum)) # それを合計

## [1] 621

apply(m,1,sum) / sum(apply(m,1,sum)) # 行質量（周辺割合）

##      18-29        30s        40s        50s        60s        70s        80- 
## 0.07085346 0.09822866 0.17713366 0.18840580 0.16103060 0.20450886 0.09983897

analysis_ca$rowcoord

##             Dim1        Dim2
## 18-29 -0.9725482  3.06746095
## 30s    1.9533852  1.15121734
## 40s    0.2415135 -0.15537744
## 50s    0.9782470 -0.47364385
## 60s   -0.1635928 -0.93416066
## 70s   -0.8894314 -0.27631546
## 80-   -1.4204626 -0.06736388

library(ggplot2)
dim1_dim2_r <- as.data.frame(analysis_ca$rowcoord)
names.r <- row.names(dim1_dim2_r)

p1 <- ggplot(dim1_dim2_r,aes(x=Dim1, y=Dim2)) +
  geom_text(aes(label=names.r),size=4) +
  geom_hline(yintercept = 0, linetype="dashed") +
  geom_vline(xintercept = 0,linetype="dashed") +
  theme_bw()

library(ggplot2)
dim1_dim2_c <- as.data.frame(analysis_ca$colcoord)
names.c <- abbreviate(row.names(dim1_dim2_c),3)

p2 <- ggplot(dim1_dim2_c,aes(x=Dim1, y=Dim2)) +
  geom_text(aes(label=names.c),size=4) +
  geom_hline(yintercept = 0, linetype="dashed") +
  geom_vline(xintercept = 0,linetype="dashed") +
    theme_bw()

library(patchwork)
p1 + p2

ggplot(dim1_dim2_r,aes(x=Dim1, y=Dim2)) +
  geom_text(aes(label=names.r),size=4) +
  geom_hline(yintercept = 0, linetype="dashed") +
  geom_vline(xintercept = 0,linetype="dashed")+
  theme_bw()

par(pty="s",family= "HiraKakuProN-W3")
plot(ca(m,suprow=1),lines = c("F","F"),contrib=c("none","none"))

res.ca <- ca(m,suprow=1)
summary(res.ca)

## 
## Principal inertias (eigenvalues):
## 
##  dim    value      %   cum%   scree plot               
##  1      0.031230  92.2  92.2  ***********************  
##  2      0.002638   7.8 100.0  **                       
##         -------- -----                                 
##  Total: 0.033868 100.0                                 
## 
## 
## Rows:
##        name   mass  qlt  inr    k=1 cor  ctr    k=2 cor  ctr  
## 1 | (*)1829 | <NA> 1000 <NA> |  127 104 <NA> |  372 896 <NA> |
## 2 |     30s |  106 1000  402 | -347 935  408 |   92  65  336 |
## 3 |     40s |  191 1000    5 |  -30 987    6 |    4  13    1 |
## 4 |     50s |  203 1000  154 | -152 902  150 |  -50  98  193 |
## 5 |     60s |  173 1000   36 |   53 387   15 |  -66 613  287 |
## 6 |     70s |  220 1000  185 |  167 982  197 |   22  18   42 |
## 7 |      80 |  107 1000  218 |  255 949  224 |   59  51  141 |
## 
## Columns:
##     name   mass  qlt  inr    k=1 cor ctr    k=2 cor ctr  
## 1 | Tkch |  451 1000  431 | -178 984 460 |  -23  16  90 |
## 2 | Tsmr |  406 1000  502 |  204 991 539 |  -19   9  55 |
## 3 | Othr |  144 1000   68 |  -15  15   1 |  125 985 855 |

4. 検定について

10代と20代の比較

prop.test関数の利用

2-sample test for equality of proportions with continuity correction

prop.test(c(11,3),c(30,14))

## Warning in prop.test(c(11, 3), c(30, 14)): カイ自乗近似は不正確かもしれません

## 
##  2-sample test for equality of proportions with continuity correction
## 
## data:  c(11, 3) out of c(30, 14)
## X-squared = 0.44, df = 1, p-value = 0.5071
## alternative hypothesis: two.sided
## 95 percent confidence interval:
##  -0.1755613  0.4803232
## sample estimates:
##    prop 1    prop 2 
## 0.3666667 0.2142857

数値の比較

m01  <- matrix(c(11,3,19,11),2) 
m01

##      [,1] [,2]
## [1,]   11   19
## [2,]    3   11

chisq.test(m01)

s1 <- chisq.test(m01)

## Warning in chisq.test(m01): カイ自乗近似は不正確かもしれません

cat("X_squared=", s1$statistic, "\n")

## X_squared= 0.44

cat("p値 =", s1$p.value, "\n")

## p値 = 0.5071225

chisq.test(m01,correct = F)

# correct = F
s2 <- chisq.test(m01,correct = F)

## Warning in chisq.test(m01, correct = F): カイ自乗近似は不正確かもしれません

cat("X_squared=", s2$statistic, "\n")

## X_squared= 1.021678

cat("p値 =", s2$p.value, "\n")

## p値 = 0.3121213

fisher.test(m01)

s3 <- fisher.test(m01)
cat("p.value=", s3$p.value, "\n")

## p.value= 0.4892126

30歳未満と30歳代を比較

# 比率の差を計算
prop1 <- (3+11)/(14+30)
prop2 <- 36/61
diff <- prop1 - prop2

# サンプルサイズ
n1 <- 14+30
n2 <- 61

 prop1

## [1] 0.3181818

 prop2

## [1] 0.5901639

 diff

## [1] -0.2719821

n1

## [1] 44

n2

## [1] 61

# サンプルaとサンプルbの比率を設定
p1 <- 0.318
p2 <- 0.590

# サンプルaとサンプルbのサイズを設定
n1 <- 44
n2 <- 61

# 母比率の推定値
p_hat <- (p1 * n1 + p2 * n2) / (n1 + n2)
p_hat

## [1] 0.476019

# 検定統計量zを計算
z <- (p1 - p2) / sqrt(p_hat * (1 - p_hat) * (1/n1 + 1/n2))

# p値を計算
p_value <- 2 * (1 - pnorm(abs(z)))

# 結果を表示
cat("検定統計量 z =", z, "\n")

## 検定統計量 z = -2.753567

cat("p値 =", p_value, "\n")

## p値 = 0.005894976

# 有意水準0.05での検定
if (p_value < 0.05) {
  cat("2つの比率に有意な差があります。\n")
} else {
  cat("2つの比率に有意な差はありません。\n")
}

## 2つの比率に有意な差があります。

prop.test関数の利用

prop1 <- (3+11)/(14+30)
prop2 <- 36/61

prop.test(c(14,36),c(44,61))

## 
##  2-sample test for equality of proportions with continuity correction
## 
## data:  c(14, 36) out of c(44, 61)
## X-squared = 6.5297, df = 1, p-value = 0.01061
## alternative hypothesis: two.sided
## 95 percent confidence interval:
##  -0.47639932 -0.06756491
## sample estimates:
##    prop 1    prop 2 
## 0.3181818 0.5901639

30歳代と40歳代の比較

# データの確認
m73

##       Takeuchi Tsumori Others
## 18-29       14      18     12
## 30s         36      14     11
## 40s         51      43     16
## 50s         62      40     15
## 60s         44      44     12
## 70s         47      61     19
## 80-         20      32     10

# 比率の差を計算
prop1 <- 36/(36+14+11)
prop2 <- 51/(51+43+16)
diff <- prop1 - prop2

# サンプルサイズ
n1 <- 36+14+11
n2 <- 51+43+16

 prop1

## [1] 0.5901639

 prop2

## [1] 0.4636364

 diff

## [1] 0.1265276

prop.test関数の利用

prop1 <- 36/(36+14+11)
prop2 <- 51/(51+43+16)
diff <- prop1 - prop2
# サンプルサイズ
(n1 <- 36+14+11)

## [1] 61

(n2 <- 51+43+16)

## [1] 110

prop.test(c(36,51),c(61,110))

## 
##  2-sample test for equality of proportions with continuity correction
## 
## data:  c(36, 51) out of c(61, 110)
## X-squared = 2.0328, df = 1, p-value = 0.1539
## alternative hypothesis: two.sided
## 95 percent confidence interval:
##  -0.04086304  0.29391818
## sample estimates:
##    prop 1    prop 2 
## 0.5901639 0.4636364

5. caとggplot2によるグラフ作成

m <- m73
m

##       Takeuchi Tsumori Others
## 18-29       14      18     12
## 30s         36      14     11
## 40s         51      43     16
## 50s         62      40     15
## 60s         44      44     12
## 70s         47      61     19
## 80-         20      32     10

par(pty="s",family= "HiraKakuProN-W3")
plot(ca(m))

ca_analysis <- ca(m)

if (!require(ggrepel)) {
    install.packages('ggrepel')
    library(ggrepel)
}

##  要求されたパッケージ ggrepel をロード中です

ca_analysis$sv ** 2

## [1] 0.03087880 0.01050747

summary(ca_analysis)

## 
## Principal inertias (eigenvalues):
## 
##  dim    value      %   cum%   scree plot               
##  1      0.030879  74.6  74.6  *******************      
##  2      0.010507  25.4 100.0  ******                   
##         -------- -----                                 
##  Total: 0.041386 100.0                                 
## 
## 
## Rows:
##     name   mass  qlt  inr    k=1 cor ctr    k=2 cor ctr  
## 1 | 1829 |   71 1000  219 | -171 228  67 |  314 772 667 |
## 2 |  30s |   98 1000  313 |  343 894 375 |  118 106 130 |
## 3 |  40s |  177 1000    9 |   42 877  10 |  -16 123   4 |
## 4 |  50s |  188 1000  145 |  172 926 180 |  -49  74  42 |
## 5 |  60s |  161 1000   39 |  -29  83   4 |  -96 917 141 |
## 6 |  70s |  205 1000  125 | -156 968 162 |  -28  32  16 |
## 7 |   80 |  100 1000  150 | -250 999 201 |   -7   1   0 |
## 
## Columns:
##     name   mass  qlt  inr    k=1 cor ctr    k=2 cor ctr  
## 1 | Tkch |  441 1000  398 |  191 975 520 |  -30  25  39 |
## 2 | Tsmr |  406 1000  381 | -189 916 468 |  -57  84 126 |
## 3 | Othr |  153 1000  221 |  -50  41  12 |  239 959 835 |

# 標準座標値に特異値(固有値の平方根)をかける。
# sv: singular value


ca_analysis$rowcoord[,1]*ca_analysis$sv[1]

##       18-29         30s         40s         50s         60s         70s 
## -0.17089972  0.34325597  0.04243963  0.17190112 -0.02874712 -0.15629413 
##         80- 
## -0.24960887

ca_analysis$colcoord[,1]*ca_analysis$sv[1]

##    Takeuchi     Tsumori      Others 
##  0.19074481 -0.18869730 -0.04960377

ca_analysis$rowcoord[,2]*ca_analysis$sv[2]

##        18-29          30s          40s          50s          60s          70s 
##  0.314432960  0.118006613 -0.015927110 -0.048551307 -0.095757014 -0.028323975 
##          80- 
## -0.006905198

ca_analysis$colcoord[,2]*ca_analysis$sv[2]

##    Takeuchi     Tsumori      Others 
## -0.03043454 -0.05718095  0.23945963

r1 <- ca_analysis$rowcoord[,1]*ca_analysis$sv[1]
c1 <- ca_analysis$colcoord[,1]*ca_analysis$sv[1]
r2 <- ca_analysis$rowcoord[,2]*ca_analysis$sv[2]
c2 <- ca_analysis$colcoord[,2]*ca_analysis$sv[2]
plot(r1,r2)

plot(c1,c2)

(c <- cbind(c1,c2, type='columns'))

##          c1                   c2                    type     
## Takeuchi "0.190744814066183"  "-0.0304345407825001" "columns"
## Tsumori  "-0.188697304893081" "-0.057180954759738"  "columns"
## Others   "-0.049603770748186" "0.239459629198516"   "columns"

(r <- cbind(r1,r2,type='rowcoord'))

##       r1                    r2                     type      
## 18-29 "-0.170899718354824"  "0.314432959800224"    "rowcoord"
## 30s   "0.343255966762923"   "0.118006612738511"    "rowcoord"
## 40s   "0.0424396281691305"  "-0.0159271099846492"  "rowcoord"
## 50s   "0.171901121532175"   "-0.0485513073312092"  "rowcoord"
## 60s   "-0.0287471186121365" "-0.0957570144522014"  "rowcoord"
## 70s   "-0.156294132893811"  "-0.028323974991156"   "rowcoord"
## 80-   "-0.249608870065599"  "-0.00690519811450292" "rowcoord"

(d <- rbind(c,r))

##          c1                    c2                     type      
## Takeuchi "0.190744814066183"   "-0.0304345407825001"  "columns" 
## Tsumori  "-0.188697304893081"  "-0.057180954759738"   "columns" 
## Others   "-0.049603770748186"  "0.239459629198516"    "columns" 
## 18-29    "-0.170899718354824"  "0.314432959800224"    "rowcoord"
## 30s      "0.343255966762923"   "0.118006612738511"    "rowcoord"
## 40s      "0.0424396281691305"  "-0.0159271099846492"  "rowcoord"
## 50s      "0.171901121532175"   "-0.0485513073312092"  "rowcoord"
## 60s      "-0.0287471186121365" "-0.0957570144522014"  "rowcoord"
## 70s      "-0.156294132893811"  "-0.028323974991156"   "rowcoord"
## 80-      "-0.249608870065599"  "-0.00690519811450292" "rowcoord"

xca_analysis <- ca(m)
contrib = ca_analysis$sv ** 2
contrib = contrib / sum(contrib)
colcoord = as.data.frame(ca_analysis$colcoord)

rowcoord = as.data.frame(ca_analysis$rowcoord)
coords = rbind(
    cbind(rowcoord, type='rowcoord'),
    cbind(colcoord, type='columns')
)


# 以下の部分を追加した。
coords[,1] <- coords[,1]*ca_analysis$sv[1]
coords[,2] <- coords[,2]*ca_analysis$sv[2]
coords

row.names(coords) <- gsub('_', ' ', row.names(coords))
# row.names(coords)
# ここでgsub()は、アンダースコアを空白に換えることをしているが、意味があるか不明。

graph <- ggplot(coords, aes(x=Dim1, y=Dim2, color=type, label=rownames(coords), shape=type)) +
    geom_hline(yintercept=0, linetype='dotted', color='#444444') + 
    geom_vline(xintercept = 0, linetype='dotted', color='#444444') +
    geom_point(size=3) +
    geom_text_repel() +
ylim(c(-.4,.4))+
xlim(c(-.4,.4))+
    xlab(sprintf('Dimension 1 (%.1f%%)', 100 * contrib[1])) +
    ylab(sprintf('Dimension 2 (%.1f%%)', 100 * contrib[2])) +
    scale_color_manual(values = c('red', 'blue')) +
    scale_shape_manual(values = c(17,16))+
    scale_fill_manual(values = c("red","blue"))+
    theme_bw() +
    theme(legend.position = "none") 
graph

出口調査の研究

Yutaka Moteki

2023-07-02

1. 武内候補の得票率

モザイク図(1)

モザイク図(2)

2. 2候補とその他に分類

分割表の独立性の検定（リサンプリング法）

年代と得票率のクロス表

モザイク図(3)

モザイク図(4)

対応分析

対応分析

3. 18歳と19歳、20歳代を合併する

合併したクロス表

カイ2乗検定（クロス表）

2候補の得票率の得票率の差を年代別にみる

モザイク図(5)

対応分析

4. 検定について

10代と20代の比較

prop.test関数の利用

数値の比較

30歳未満と30歳代を比較

prop.test関数の利用

30歳代と40歳代の比較

prop.test関数の利用

5. caとggplot2によるグラフ作成