« ピラミッド型組織を連想させる「緊急連絡網」について | Main | Rehearsal for hybrid procedures in the Chamber of the House of Commons »

June 26, 2023

世論調査における政党支持と回答者の世帯年収との関係

Screenshot-20230626-at-100438

読売新聞社の世論調査について検討した。所得階層の関連で捉えれば、立憲民主党と維新のプロファイルは、かけ離れており、両党の支持者が政治に期待する内容にずれがあるはずである。したがって、たとえ有権者への呼びかけが選挙協力についてなされても、両党の支持者の投票行動に大きく影響を及ぼすことがあるとは想定しにくい。(公明と自民の場合には、明らかに、別の要因があって協力がなされているのであろう。)

 

以下が、上記note記事のもとになったRmdファイル

---
title: "世帯年収と支持率"
author: "Yutaka Moteki"
date: "2023-05-06"
output:
html_document:
df_print: paged
toc: yes
toc_float: false
toc_depth: '2'
---

# 政党支持と回答者の世帯年収との関係

## 数値(パーセント)の入力

```{r}
a <- c(17,31,19,12,8,8) # 世帯年収
b <- c(34,10,6,4,2,1,1,1,0,0,39,1) # 政党支持
c <- c(12,12,18,19,17,23) # 年代
d <- 2184 # 有効回答総数
```

## 数値の変換(実際の人数にする)

```{r}
(世帯年収 <- round(a/100*d,digits = 0)) # 世帯年収別回答者数
(政党支持 <- round(b/100*d,digits = 0)) # 政党支持回答数
(年齢  <- round(c/100*d,digits = 0)) # 年齢別回答者数
```

## 第5層と第6層の維新と立民(回答者数)

```{r}
世帯年収[5]*.12
世帯年収[5]*.04
世帯年収[6]*.15
世帯年収[6]*.04

```

## 表よりの入力(維新世帯年収、パーセント)

```{r}
e <- c(11,10,10,8,12,15) # 維新世帯年収(パーセント)を表より
f <- e/100 # パーセントを比率に直す
維新世帯年収 <- round(世帯年収*t(f),digits=0) # 人数にする
維新世帯年収

```

```{r}

# バーチャートを描画する
par(family= "HiraKakuProN-W3")
barplot(e, main = "世帯年収別にみた「維新」支持率", xlab = "世帯年収", ylab = "支持率(パーセント)",names= c("第1層","第2層","第3層","第4層","第5層","第6層"))

```

```{r}
維新世帯年収
others <- 世帯年収 - 維新世帯年収
others
```

## data

## 維新とそれ以外

```{r}
data <- matrix(c(維新世帯年収, others), nrow=6)
data
mosaicplot(data,shade = TRUE)
```

## data_

## 世帯年収の3分類化

```{r}
(世帯年収_l <- data[1,] + data[2,])
(世帯年収_m <- data[3,]+ data[4,])
(世帯年収_h <- data[5,]+ data[6,])

 

data_ <- matrix(c(世帯年収_l,世帯年収_m,世帯年収_h),nrow=3,byrow = TRUE)
data_
```

```{r}
mosaicplot(data_,shade = TRUE)
mosaicplot(data_,shade = FALSE)
```

```{r,fig.asp=0.9,out.width="80%"}
par(family= "HiraKakuProN-W3", cex=0.86)
mosaicplot(data_,shade=TRUE, main = "",dir=c("v","h"))

```

## data01

## 「維新・立民・その他」、世帯収入6分類

```{r}
g <- c(8,8,5,6,4,4) # 立憲民主党、世帯収入別、パーセント
(h <- round(世帯年収*t(g/100),digits=0))
(h <- round(世帯年収*(g/100),digits=0))
data
others01 <- data[,2]- h
data01 <- matrix(c(data[,1],h,others01),nrow = 6)
data01
row.names(data01) <- c("第1層","第2層","第3層","第4層","第5層","第6層")
colnames(data01) <- c("維新","立民","その他")
data01
```

```{r}
prop.table(data01,1)
```

```{r,fig.asp=0.9,out.width="90%"}
par(family= "HiraKakuProN-W3", cex=0.86)
mosaicplot(data01,shade = TRUE, main = "「維新・立民・その他」、世帯年収6分類")
```

## data01

## 「維新・自民・その他」、世帯年収3分類

```{r}
i <- round(c(109*34/10,63*35/9,47*38/13),digits = 0)
i # 自民党支持者
```

```{r}
others02 <- data_[,2] - i
others02
```

```{r}
data_1 <- matrix(c(data_[,1],i,others02),nrow = 3)
# data_1の作成
row.names(data_1) <- c("世帯年収_低","世帯年収_中","世帯年収_高")

colnames(data_1) <- c("維新","自民","その他")
data_1
```

```{r}
round(100*prop.table(data_1,1),digits = 1)
```

```{r,fig.asp=0.9,out.width="90%"}
par(family= "HiraKakuProN-W3", cex=0.86)
mosaicplot(data_1,shade = TRUE,main = "「維新・自民・その他」、世帯年収3分類")
```

## 対応分析

## data01

```{r,out.width="100%"}
library(ca)
par(family= "HiraKakuProN-W3")
plot(ca(data01))
```

```{r}
summary(ca(data01,cor=T))
```

```{r}
cacoord(ca(data01),type= "symmetric",dim = c(1,2))
```

## data02 無党派、自民をデータに入れる

```{r}
np <- c(35,38,39,42,46,39)
np <- np/100
無党派 <- round(世帯年収 * t(np), digits = 0)
無党派

自民 <- c(33,34,33,37,35,38)
自民 <- 自民 / 100
自民 <- round(世帯年収 * t(自民), digits = 0)
自民

data01
その他 <- data01[,3] - 無党派 - 自民
その他
```

```{r}
data02 <- c(自民, data01[,c(1,2)],その他,無党派)
data02 <- matrix(data02,6)
data02
row.names(data02) <-
c("第1層","第2層","第3層","第4層","第5層","第6層")
colnames(data02) <- c("自民","維新","立民","その他","無党派")
data02
round(100*prop.table(data02,1),digits=0)
```

```{r,out.width= "95%"}
library(ca)
par(family= "HiraKakuProN-W3")
plot(ca(data02), arrows = c(F,T))
plot(ca(data02, supcol=5))
plot(ca(data02, supcol=4))

plot(ca(data02, supcol=c(4,5)))
plot(ca(data02, supcol=c(1,5)))
plot(ca(data02, supcol=c(1)))

```

```{r}
summary(ca(data02))
summary(ca(data02,supcol=4))
```

```{r}
cacoord(ca(data02),type= "symmetric",dim = c(1,2))
cacoord(ca(data02, supcol=4),type= "symmetric",dim = c(1,2))
```

```{r,fig.asp=0.9}
par(family= "HiraKakuProN-W3")
mosaicplot(data02,shade = T, main = "自民・維新・立民・その他・無党派\n 世帯年収別")
```

```{r}
knitr::kable(data02)
knitr::kable(round(100*prop.table(data02,1),digits=0))

```

```{r,fig.asp=0.9}
par(family= "HiraKakuProN-W3")
mosaicplot(t(data02),shade = T, main = "自民・維新・立民・その他・無党派\n 政党別", dir = c("h","v"))
```
```{r}
round(prop.table(data02,1)*100, digits = 1)
```
# 求める格差対策

```{r}
o <- c(36,34,29) # 社会保障の充実
p <- c(30,40,43) # 教育の無償化
```

```{r}
p
p <- p/100
p
```

```{r}
par(family= "HiraKakuProN-W3")
barplot(世帯年収,names= c("第1層","第2層","第3層","第4層","第5層","第6層"))
q01 <- 世帯年収[1] + 世帯年収[2]
q02 <- 世帯年収[3] + 世帯年収[4]
q03 <- 世帯年収[5] + 世帯年収[6]
q <- c(q01,q02,q03)
q

r <- round(p*q,digits = 0)
r

prop.test(c(314,271),c(1048,677))

r_1 <- q[1]-r[1]
r_2 <- q[2]-r[2]
r_3 <- q[3]-r[3]

r_ <- c(r_1,r_2,r_3)
r_

```

```{r}
s <- matrix(c(r,r_),2,byrow = T)
s
mosaicplot(t(s),shade=T)
```

```{r}
par(family= "HiraKakuProN-W3")
barplot(年齢,names= c("18-29","30s","40s","50s","60s","70-"))
```

-----------------------------------------
以下は、Rmdファイルをknittしたもの(PDFファイル)

ダウンロード - e4b896e5b8afe5b9b4e58f8ee381a8e694afe68c81e78e87.pdf

 

 

|

« ピラミッド型組織を連想させる「緊急連絡網」について | Main | Rehearsal for hybrid procedures in the Chamber of the House of Commons »

Society」カテゴリの記事

Politics」カテゴリの記事