# Quanthon Homework #######
options(scipen=999)
# Packages #####
library(readr)
library(stringr)
library(tidyverse)
## ── Attaching packages ─────────────────────────────────────── tidyverse 1.3.1 ──
## ✓ ggplot2 3.3.6 ✓ purrr 0.3.4
## ✓ tibble 3.1.6 ✓ dplyr 1.0.8
## ✓ tidyr 1.2.0 ✓ forcats 0.5.1
## Warning: package 'tidyr' was built under R version 4.0.5
## Warning: package 'dplyr' was built under R version 4.0.5
## ── Conflicts ────────────────────────────────────────── tidyverse_conflicts() ──
## x dplyr::filter() masks stats::filter()
## x dplyr::lag() masks stats::lag()
library(haven)
library(reshape2)
##
## Attaching package: 'reshape2'
## The following object is masked from 'package:tidyr':
##
## smiths
library(stargazer)
## Warning: package 'stargazer' was built under R version 4.0.5
##
## Please cite as:
## Hlavac, Marek (2022). stargazer: Well-Formatted Regression and Summary Statistics Tables.
## R package version 5.2.3. https://CRAN.R-project.org/package=stargazer
library(xtable)
library(flextable)
##
## Attaching package: 'flextable'
## The following object is masked from 'package:xtable':
##
## align
## The following object is masked from 'package:purrr':
##
## compose
library(magrittr)
##
## Attaching package: 'magrittr'
## The following object is masked from 'package:purrr':
##
## set_names
## The following object is masked from 'package:tidyr':
##
## extract
# read data #####
inc109 <- read_sav("~/Documents/科技部111年大專學生研究計畫/109年 家庭收支調查/inc109.sav")
###############################################################################
# 表1 家庭收支綜合結果 #######
df <- inc109
# 中位數 ##########
df[is.na(df)] <- 0
df %<>%
mutate(每戶可支配所得 = itm400 - itm600,
每人可支配所得 = 每戶可支配所得 / a8)
`每戶可支配所得中位數` <- median(rep(df$每戶可支配所得, df$a20), na.rm = TRUE)
`每人可支配所得中位數` <- median(rep(df$每人可支配所得, df$a8 * df$a20), na.rm = TRUE)
# 平均數 ########
df$折舊 <- ifelse(df$c1 == 1, df$itm1042 - df$itm390, 0)
df$財產所得 <- df$itm330 + df$itm390 + df$折舊
df$移轉收入 <- df$itm410 + df$itm490
table1 <- df %>%
summarise_at(c("每戶人數（人）" = "a8",
"每戶所得總額（元）" = "itm500",
"合計每戶所得總額（元）" = "itm400",
"受僱報酬" = "itm190",
"產業主所得" = "itm240",
"財產所得" = "財產所得",
"移轉收入" = "移轉收入",
"非消費支出" = "itm600",
"每戶消費支出平均數" = "itm1000"),
weighted.mean, df$a20, na.rm = TRUE) %>%
mutate(`每人所得總額（元）` =`每戶所得總額（元）` / round(`每戶人數（人）`, 2),
`每戶可支配所得平均數（元）` = `合計每戶所得總額（元）` - `非消費支出`,
`每人可支配所得平均數（元）` = `每戶可支配所得平均數（元）` / round(`每戶人數（人）`, 2),
`每人消費支出平均數` = `每戶消費支出平均數` / round(`每戶人數（人）`, 2),
`每戶儲蓄平均數` = `每戶可支配所得平均數（元）` - `每戶消費支出平均數`,
`每人儲蓄平均數` = `每戶儲蓄平均數` / round(`每戶人數（人）`, 2))%>%
melt(value.name = "金額", variable.name = "項目") %>%
print
## No id variables; using all as measure variables
## 項目 金額
## 1 每戶人數（人） 2.921027
## 2 每戶所得總額（元） 1356342.899753
## 3 合計每戶所得總額（元） 1293719.054211
## 4 受僱報酬 725931.712520
## 5 產業主所得 155827.769141
## 6 財產所得 195400.539975
## 7 移轉收入 279171.439065
## 8 非消費支出 214070.783803
## 9 每戶消費支出平均數 815099.824164
## 10 每人所得總額（元） 464500.993066
## 11 每戶可支配所得平均數（元） 1079648.270409
## 12 每人可支配所得平均數（元） 369742.558359
## 13 每人消費支出平均數 279143.775399
## 14 每戶儲蓄平均數 264548.446245
## 15 每人儲蓄平均數 90598.782961
# 分配比 #######
table1$分配比 <- table1$金額/table1[which(table1$項目 == "每戶所得總額（元）"), "金額"] * 100
attach(table1)
table1$分配比[which(!(`項目` %in% c("每戶所得總額（元）", "受僱報酬",
"產業主所得", "財產所得", "移轉收入")))] <- NA
table1 <- table1[which(!(`項目` %in% c("非消費支出", "合計每戶所得總額（元）"))), ]
detach(table1)
# 調整資料類型 #######
table1$項目 <- as.character(table1$項目)
table1$金額 <- as.numeric(table1$金額)
table1$分配比 <- as.numeric(table1$分配比)
# 全台家庭戶數為8829466
n <- 8829466
# 合併平均數和中位數 #######3
table1 <- rbind(table1, c("每戶可支配所得中位數",`每戶可支配所得中位數` , NA),
c("每人可支配所得中位數", `每人可支配所得中位數`, NA))
# 調整變數順序 ######
table1 <- table1[c(1, 8, 2, 3, 4, 5, 6, 9, 10, 14, 15, 7, 11, 12, 13), ]
table1$金額 <- as.numeric(table1$金額)
# 合併總體資料 ######
table1 <- rbind(c("所得總額（百萬元）",
table1[which(table1$項目 == "每戶所得總額（元）"), "金額"] * n / 1000000, NA),
c("家庭戶數（戶）", n, NA), table1)
# 四捨五入 ########
table1$金額 <- as.numeric(table1$金額)
table1$分配比 <- as.numeric(table1$分配比)
table1$金額 <- round(table1$金額)
table1$分配比 <- round(table1$分配比, 1)
#家庭戶數為2.92，格式限制所以顯示3，需手動修改
print(table1)
## 項目 金額 分配比
## 1 所得總額（百萬元） 11975784 NA
## 2 家庭戶數（戶） 8829466 NA
## 16 每戶人數（人） 3 NA
## 10 每人所得總額（元） 464501 NA
## 21 每戶所得總額（元） 1356343 100.0
## 4 受僱報酬 725932 53.5
## 5 產業主所得 155828 11.5
## 6 財產所得 195401 14.4
## 7 移轉收入 279171 20.6
## 11 每戶可支配所得平均數（元） 1079648 NA
## 12 每人可支配所得平均數（元） 369743 NA
## 141 每戶可支配所得中位數 928518 NA
## 151 每人可支配所得中位數 320264 NA
## 9 每戶消費支出平均數 815100 NA
## 13 每人消費支出平均數 279144 NA
## 14 每戶儲蓄平均數 264548 NA
## 15 每人儲蓄平均數 90599 NA
###############################################################################
# 表6 家庭設備普及率及住宅狀況 #####
# 持有數量轉換成是否擁有 #######
df %<>%
mutate(across(c(f1, f59, f4, f6, f41, f44, f60, f34, f52, f55, f38),
~ ifelse(.x != 0, 1, 0)))
df$tv <- with(df,
ifelse(f1 + f59 != 0, 1, 0))
df$linetv <- with(df,
ifelse(f44 + f60 != 0, 1, 0))
df$c1 <- ifelse(df$c1 == 1, 1, 0)
df$f57 <- ifelse(df$f57 ==1, 1, 0)
df$f61 <- ifelse(df$f61 ==1, 1, 0)
df$net <- ifelse(df$f57 + df$f61 != 0, 1, 0)
# 計算持有率 #######
table6 <- df %>%
summarise_at(c("彩色電視機" = "tv",
"電話機" = "f4",
"冷暖氣機" = "f6",
"除濕機" = "f41",
"有線電視頻道設備" = "linetv",
"家用汽車" = "f34",
"行動電話" = "f52",
"數位相機" = "f55",
"家用電腦" = "f38",
"連網比率" = "net",
"自有住宅比率" = "c1",
"平均每戶住宅坪數（坪）" = "c6b"), weighted.mean, df$a20, na.rm = TRUE)
# 四捨五入及百分比 #######
table6 <- table6 %>%
mutate_if(is.numeric, round, digits = 3) %>%
mutate_if(is.numeric, function(x) x*100)
table6$`平均每戶住宅坪數（坪）` <- table6$`平均每戶住宅坪數（坪）`/100
print(table6)
## # A tibble: 1 × 12
## 彩色電視機 電話機 冷暖氣機 除濕機 有線電視頻道設備 家用汽車 行動電話 數位相機
## <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 98.8 85.9 96 40.6 85.2 60.3 96.2 12.7
## # … with 4 more variables: 家用電腦 <dbl>, 連網比率 <dbl>, 自有住宅比率 <dbl>,
## # `平均每戶住宅坪數（坪）` <dbl>
# 輸出表格#########
save_as_docx("表1 家庭收支綜合結果" = flextable(table1),
"表6 家庭設備普及率及住宅狀況" = flextable(table6), path = "table.docx")