423homework
TZUYING
20180507
Q2
library(dplyr)
dta <- read.table("C:/Users/ILT/Documents/langMathDutch.txt", header = TRUE) %>%
mutate(Size = cut(size, quantile(size, probs = c(0, .33, .67, 1)),
c("Small", "Midium", "Large"),
include.lowest = TRUE, ordered = TRUE),
IQ = cut(IQV, quantile(IQV, probs = c(0, .33, .67, 1)),
c("Low", "Middle", "High"),
include.lowest = TRUE, ordered = TRUE),
Size.IQ = factor(paste(Size, IQ, sep = "."),
levels = c("Small.Low", "Small.Middle", "Small.High",
"Midium.Low", "Midium.Middle", "Midium.High",
"Large.Low", "Large.Middle", "Large.High")))
library(ggplot2)
ggplot(dta, aes(lang, arith))+
geom_point()+
stat_smooth(method = "lm")+
facet_wrap(~ Size.IQ)+
scale_y_continuous(breaks = seq(5, 35, 5))+
labs(x = "Language Socre", y = "Arithmetic Score")
Q3
1.性別
2.個體
dta <- read.table("C:/Users/ILT/Documents/stateAnxiety.txt", header = TRUE) %>%
mutate(index = 1:50) %>%
gather("Week", "Anxiety", 1:10) %>%
mutate(Gender = factor(rep(c("Female", "Male"), each = 250)),
Week = paste0("Week", parse_number(Week)),
Subject = factor(rep(paste0("Sub", 101:200), times = 5))) %>%
group_by(Week) %>%
mutate(mean_g = mean(Anxiety)) %>%
ungroup
theme_set(theme_bw())plot1
ggplot(dta, aes(Week, Anxiety, color = Gender))+
geom_line(aes(group = Subject), color = "gray50", alpha = .8, linetype = "dotted")+
stat_smooth(aes(group = 1), method = "lm", alpha = .5)+
stat_summary(aes(group = Gender), fun.y = mean, geom = "line")+
stat_summary(fun.data = mean_cl_boot, geom = "pointrange")
plot2
ggplot(dta, aes(reorder(Subject, Anxiety, mean), Anxiety))+
stat_summary(fun.data = mean_cl_boot, geom = "pointrange")+
coord_flip()+
labs(x = "Subject reorder by averge anxiety socre")
Q4
散佈圖
dta <- read.table("C:/Users/ILT/Documents/math_attainment.txt", header = TRUE)
ggplot(dta, aes(math1, math2, color = cc))+
geom_point(size = rel(2))+
stat_smooth(method = "lm", color = "steelblue")+
theme(legend.position = c(.8, .2))+
labs(x = "Math score at Year 1",
y = "Math score at Year 2",
color = "Curriculum coverage")
模型 標準殘差圖
# model
m <- lm(math2 ~ -1 + math1 + cc, dta)
# standardized residual plot
dta %>% mutate(s.resi = scale(residuals(m)),
pred = fitted.values(m)) %>%
ggplot(., aes(pred, s.resi))+
geom_point()+
geom_hline(yintercept = 0, linetype = "dotted")+
labs(x = "Fitted values", y = "Standardized residuals")
QQ Plot
ggqqplot <- function(data)
{
y <- quantile(data[!is.na(data)], c(0.25, 0.75))
x <- qnorm(c(0.25, 0.75))
slope <- diff(y)/diff(x)
int <- y[1L] - slope * x[1L]
d <- data.frame(resids = data)
ggplot(d, aes(sample = resids))+
stat_qq()+
geom_abline(slope = slope, intercept = int)
}
ggqqplot(scale(resid(m)))
模型適配
dta %>% mutate(pred = fitted.values(m)) %>%
ggplot(., aes(math1, math2, color = cc))+
geom_point(alpha = .7, pch = 21, size = rel(2))+
geom_point(aes(math1, pred, color = cc), size = rel(2))+
stat_smooth(aes(math1, pred, color = cc), method = "lm", color = "steelblue")+
theme(legend.position = c(.8, .2))+
labs(x = "Math score at Year 1",
y = "Fitted Values Math score at Year 2",
color = "Curriculum coverage")
參數
tidy(m, conf.int = TRUE) %>%
ggplot(., aes(term, estimate))+
geom_pointrange(aes(ymin = conf.low, ymax = conf.high))+
geom_hline(yintercept = 0, linetype = "dotted")+
scale_x_discrete(labels = c("Curriculum coverage", "Math score at Year 1"))+
labs(x = "term", y = "parameter coefficients")
Q5
dta <- read.table("C:/Users/ILT/Documents/hs0.txt", h = T)
# eigen vector
cor <- cov(dta$write, dta$read)
v <- matrix(c(1,cor,cor,1), 2, 2)
slope <- eigen(v)$vector[1, 1]
intercept <- mean(dta$write)-slope*mean(dta$read)
# plot
p <- ggplot(dta, aes(read, write)) +
geom_point(shape = 21) +
stat_ellipse() +
geom_abline(intercept = 0, slope = 1, color = "gray") +
geom_abline(intercept = intercept, slope = slope, color = "tomato", size = rel(2)) +
geom_vline(xintercept = mean(dta$read), color = "gray") +
geom_hline(yintercept = mean(dta$write), color = "gray") +
stat_smooth(method = "lm", size = rel(1.1)) +
xlim(25, 80) +
ylim(25, 80) +
labs(x = "Reading score", y = "Writing score")
library(ggExtra)
ggMarginal(p, type = "histogram",
xparams = list(binwidth = (IQR(dta$read)*2)/(200)^(1/3),
fill = "gray"),
yparams = list(binwidth = (IQR(dta$write)*2)/(200)^(1/3),
fill = "gray"))
Q7
dta <- as.data.frame(USPersonalExpenditure) %>%
mutate(Item = rownames(USPersonalExpenditure)) %>%
gather(key = "Year", value = "Expenditure", 1:5) 畫圖
qplot(log(Expenditure), Item, data = dta) +
geom_segment(aes(xend = 0, yend = Item)) +
geom_vline(xintercept = 0, colour = "grey50") +
facet_wrap(~ Year, nrow = 1)
Q8
dta <- read.table("C:/Users/ILT/Documents/hs0.txt", header = T)
ggplot(dta, aes(write, read, fill = female))+
stat_density2d(aes(color = ..level..))+
theme(legend.position = c(.05, .75))+
geom_point(pch = 21, alpha = .5)+
facet_wrap(~female)+
labs(x = "Writing score", y = "Reading score")
Q9
dta <- data.frame(Race = c("White", "White", "Black", "Black"),
Gender = c("Male", "Female", "Male", "Female"),
Yes = c(43, 26, 29, 22),
No = c(134, 149, 23, 36)) %>%
mutate(P_yes = Yes/(Yes+No), P_no = No/(Yes+No))
new.dta <- dta %>% select(1:4) %>%
gather(Intercourse, Freq, 3:4) %>%
mutate(P = c(dta$P_yes, dta$P_no),
SE = sqrt(P*(1-P)/Freq))
ggplot(new.dta, aes(Intercourse, P, fill = Gender))+
geom_bar(position = "dodge", stat = "identity")+
geom_errorbar(aes(ymin = P - SE, ymax = P + SE), position = "dodge")+
facet_wrap(~ Race)+
labs(y = "Proportion")
Q11
dta11 <- MASS::Cushings %>%
mutate(Type = factor(Type, levels = c("u", "b", "c", "a"),
labels = c("Unknown", "Bilateral Hyperplasia", "Carcinoma", "Adenoma")),
Label = "")
dta11$Label[c(1, 13, 21, 27)] = c("Adenoma", "Bilateral Hyperplasia", "Carcinoma", "Unknown")
ggplot(dta11, aes(Tetrahydrocortisone, Pregnanetriol, fill = Type))+
geom_point(pch = 21, size = rel(2))+
geom_text_repel(aes(label = Label, color = Type))+
scale_fill_discrete(guide = FALSE)+
scale_color_discrete(guide = FALSE)+
theme_hc()+
labs(x = "Tetrahydrocortisone (mg/24 hours)", y = "Pregnanetriol (mg/24 hours)",
title = "Cushings's syndrome")+
theme(plot.title = element_text(hjust = 1))
Q12
library(car)## Loading required package: carData##
## Attaching package: 'car'## The following object is masked from 'package:dplyr':
##
## recode## The following object is masked from 'package:purrr':
##
## somedta <- Vocab
str(dta)## 'data.frame': 30351 obs. of 4 variables:
## $ year : num 1974 1974 1974 1974 1974 ...
## $ sex : Factor w/ 2 levels "Female","Male": 2 2 1 1 1 2 2 2 1 1 ...
## $ education : num 14 16 10 10 12 16 17 10 12 11 ...
## $ vocabulary: num 9 9 9 5 8 8 9 5 3 5 ...
## - attr(*, "na.action")=Class 'omit' Named int [1:32115] 1 2 3 4 5 6 7 8 9 10 ...
## .. ..- attr(*, "names")= chr [1:32115] "19720001" "19720002" "19720003" "19720004" ...ggplot(dta, aes(education))+
geom_histogram(aes(y = ..density..), breaks = c(0, 6, 9, 12, 16, 20),
fill = "gray", color = "black")+
scale_y_continuous(breaks = seq(0, 0.15, 0.05), limits = c(0, 0.15),
minor_breaks = seq(0, 0.15, 0.01)) +
scale_x_continuous(breaks = c(0, 6, 9, 12, 16, 20))+
theme(panel.grid.major.x = element_blank(),
panel.grid.minor.x = element_blank(),
panel.grid.major.y = element_line(linetype = "dotted", color = "gray50"),
panel.grid.minor.y = element_line(linetype = "dotted", color = "gray50"))+
labs(x = "Education level (years)", y = "Density")