世論調査における政党支持と回答者の世帯年収との関係
読売新聞社の世論調査について検討した。所得階層の関連で捉えれば、立憲民主党と維新のプロファイルは、かけ離れており、両党の支持者が政治に期待する内容にずれがあるはずである。したがって、たとえ有権者への呼びかけが選挙協力についてなされても、両党の支持者の投票行動に大きく影響を及ぼすことがあるとは想定しにくい。(公明と自民の場合には、明らかに、別の要因があって協力がなされているのであろう。)
以下が、上記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」カテゴリの記事
- プライド・アイデンティティ・ブランド・シンボル・スピリット(2024.10.21)
- 門司港地域複合公共施設の建設を優先する北九州市に対する市議会各会派の見解についての毎日新聞の記事(2024.10.17)
- 10月19日に市民団体の2つが協力して市民を集めて意見交換会をするという。(2024.10.16)
- 市有地の開発行為で埋蔵文化財の保護について文化財保護審議会への諮問がなされていない場合に、住民監査請求をおこなうことができますか。(2024.10.11)
- 複合公共施設建設事業と初代門司港駅遺構の保存(2024.10.11)
「Politics」カテゴリの記事
- 「門司港地域複合公共施設既存構造物とりこわし工事監理業務委託」の入札に関する疑問(2024.11.06)
- 文化企画課(市民スポーツ局あるいは都市ブランド創造局)に、教育委員会や文化財保護審議会に代わって文化財保護の重要なものを決定する権限はない。(2024.11.06)
- 門司港地域複合公共施設既存構造物とりこわし工事契約及び同工事監理業務委託契約の破棄を求める住民監査請求(2024.11.04)
- 2023年10月以降の新築工事の入札(2024.11.03)
- 2023年10月以降の監理業務委託が13件ある。(2024.11.02)