Basic R analysis (Keep updating)
Published:
I will record everything I have learned about R here. Especially for basic statistic and figuring.
Introduction to R
During my undergraduate studies, the teacher who used SAS said that journals would not accept figures made by Excel. The teacher who taught SPSS said that they only believe data proceed by SPSS. At this time, the person who used Matlab came forward and said that they have the best tools. However, the ultimate pursuit of data science should be a tool that has extremely rich functons in mathematical processing and the greatest freedom in chart output, which can be achieved byMatlabR. But the more free the functionality, the more difficult the operation. People always hope to have a GUI or even voice control to easily process data. But in reality, we always have to spend an afternoon searching for code on GitHub to complete some simple regression statistics.
R language plays a small role in other disciplines, but in ecology, due to its open source, flexibility, free, and simplicity, more than 50% of relevant scholars have chosen R language as their research tool. Currently, more than 50% of ecology related SCI articles use R language for scientific analysis, with the top 10 packages being lme4, vegan, nlme, ape, MuMIn, MASS, mgcv, ade4, multcomp, and car.
Hence, in this introductory study of R, I hope to
- Share the progress of learning R, while also pushing myself to learn it.
- To avoid becoming a ruthless code copyer without delving into the details.
- Introduction to R
- Discriminant analysis
- Data Prfiling and Visualization in R
- Regressive analysis
- Ramdom forest
- Grey Prediction
- Structural equation model (SEM)
- Word cloud analysis
- Redundancy Analysis (RDA) and variance partitioning analysis (VPA)
- Meta analysis
- Predicting the future - Application of time series model
- Introduction to Deep Learning
Starting from installing R and R packages
Install R Do not need say anything about these… You can also install R Studio, which is an IDE for R language. It also has powerful debugging functions and supports pure R scripts and Rmarkdown (which is particularly useful when downloading some R tutorials!). Just remember choose the free version when downloading. Tip: In Rstudio, we can set breakpoints and chunks to check bugs in segments. I would also like to recommend an environmental management software called Anaconda. Anaconda can create multiple non interfering environments (similar to Python’s env) to run different versions of software packages. Anaconda also comes with Jupyter Notebook, which allows for flexible note taking, operation, and interaction, making it the ultimate companion for machine learning. At the same time, this software also comes with R studio, which integrates almost all the mathematical tools you know.
Install R Packages Congratulations on becoming a data scientist! Basically we can do likae this:
install.packages()
We can also check the packages we have already installed:
installed.packages()
And their versions:
rp <- available.packages()
> dim(rp)
Some R package I really recommend:
Tools: The readxl package can directly read data from Excel, while the tidyxl and tidyr packages can organize messy Excel files; The dplyr package is the strongest package for categorizing and organizing datasets such as Excel or csv; The RMySQL package can be integrated with SQL; The smartdata package can perform data preprocessing.
Figuring: ggplot2 package can be used to make any figure you want, and ggraph package can expand various functions of ggplot2. vioplot is used to create violin charts, while rainbow is used to make rainbow, box, and bar charts. The rgl package can achieve 3D interactive visualization in R.
Statistics: The car package is used for variance analysis, the lme4 and the nlme packages are used to implement linear/nonlinear mixed effects models, the rendomForest package can implement random forest models in machine learning, the multcomp package can perform multiple comparison analysis, and the MuMIn package can be used to solve mixed effects models and model selection.
Deep learning: The nnet package is the simplest single-layer neural network package, neuralnet is a multi-layer multi node neural network algorithm package, keras package is a Keras interface (API) based on TensorFlow, and automl is a deep learning package based on meta heuristics such as ant colony algorithm and particle swarm algorithm.
Basic operations of R
Firstly, add a question mark before the function to get what you want if you are indecisive.
We can check the runtime directory of our R program: we can put our data and other files in the directory to let us directly cite them in R.
# current runtime directory
getwd()
# set a runtime directory
setwd("where you want")
We can create a series of subfolders in our running directory to facilitate our work
# create a temporary folder
dir.create("Temp")
# use this function to view all subfolders in the current working directory
dir()
# you can directly return to the home directory through ".."
R is an object-oriented language, and we have six types of objects to choose from: vectors, factors, matrices, data frames, lists, and functions:
Vectors
It can be divided into numerical vectors, feature vectors, and logic vectors. Let’s mainly explain the last one, which is the Logic Vector:
It has only three elements - True, False, NA (not available):
a >= 1 # 'a' is higher or equal to 1? (TRUE)
is.factor(ex) # It is a factor? (FALSE)
Matric
A matrix is a multiple arrangement of vectors. We can view/count/modify matrices through the following functions:
# create a matric
matx <- matrix(1:45, nrow = 15)
rownames(matx) <- LETTERS[1:15]
colnames(matx) <- c("Sample01", "Sample02", "Sample03")
# view a matric
matx
# check the object type
class(matx)
# Select a row or a column in the matrix using square brackets
matx[, 1]
matx[1, ]
# head and tail of a matric
head(matx)
tail(matx)
# Compact display the internal structure of objects
str(matx)
# overall
summary(matx)
In general, the head() function will only return the first 6 rows of the matrix when we explore data. But we can add another parameter to the function. For example, head (matx, 10) can simply add the number 10 after a comma to see the first 10 lines. It is particularly useful when the matrix is larger than 500 rows.
Data frame
The difference between a data frame and a matrix is that data frame can handle different types of vectors, which feels similar to an Excel sheet.
# create a data frame
df <- data.frame(species = c("rufus", "cristatus", "albogularis", "paraguayae"), habitat = factor(c("forest", "savanna", "urban", "transition")), high = c(10, 2, 7, 4), distance = c(3, 9, 5, 6))
# check the object type
class(df)
# try to convert the previous matrix into a data frame
matx2 <- as.data.frame(matx)
# see the difference
class(matx2)
str(df)
List
List is a series of objects.
lst <- list(data, df, matx)
str(lst)
class(lst)
# use double brackets [[]] to check the objects in our list
lst[[1]]
Horizontal analysis
One-way anova
We can perform a simple one-way ANOVA analysis to compare whether the differences in experimental results are random or level dependent by using the built-in function (aov) in the R language.
organ.name<-factor(rep(c("root","stem","leaf","flower"),c(4,6,8,6)))
exp.gen<-
c(0.5,0.46,0.23,0.29,0.2,0.11,0.14,0.14,0.13,0.19,0.19,0.19,0.34,0.43,0.57,0.75,0.78,0.71,0.88,0.39,0.45,0.28,0.53,0.88)
# t-test for mean value comparison analysis
pairwise.t.test(exp.gen,organ.name)
# annova
aov(exp.gen~organ.name)
# Convert the data to data.frame for opening in ggplot2
d <- data.frame(organ.name,exp.gen)
# figuring
library("ggplot2")
library("magrittr")
library("ggpubr")
# annotate and export figure, and use ggplot to add boxplots and data
p<-ggboxplot(d,x="organ.name",y="exp.gen",palette = c("#00AFBB", "#E7B800", "#FC4E07"))
# add comparison objects
my_comparisons <- list(c("flower", "leaf"), c("leaf", "root"), c("root", "stem"))
# add anova analysis again and set the y-axis height to 1.2 (to display the anova values)
p+stat_compare_means(comparisons = my_comparisons) +
stat_compare_means(method = "anova",label.y = 1.2)
Next, you can make an anova figure with annotations based on the p-value:
p + stat_compare_means(method = "anova",label.y = 1) +
stat_compare_means(label = "p.signif", method = "t.test", ref.group = ".all.")
Correlation analysis
The cor function is commonly used for analysis correlation coefficient, which can be calculated by specify vectors or a data frame.
cor(x,y=NULL,use="everything",method= c("pearson","kendall","spearman"))
Among them, use is used to handle missing values: everything, all.obs, complete.obs, pairwise.complete.obs and na.or.complete.
The default setting of method is pearson correlation coefficient, which is applicable to continuous variables, kendall is applicable to categorical variables, Spearman is applicable to categorical ordinal variables (such as large, medium, small, etc.).
cor.test(x, y, alternative = c("two.sided", "less", "greater"), method = "spearman", conf.level = 0.95, ...)
corrplot Package
The basic function is as follows:
corrplot(# need matrix calculated by cor function
corr,
# method is for visualization
method = c("circle", "square", "ellipse", "number", "shade", "color", "pie"),
# Demonstrations
type = c("full", "lower", "upper"), add = FALSE,
# col for colour，bg for background's color，is.corr for displaying the correlation coefficient
col = NULL, bg = "white", title = "", is.corr = TRUE,
#'Diag' for displaying the results on the diagonal, 'outline' is whether to show the contour, and 'mar' is the spacing between the four sides of the figure
diag = TRUE, outline = FALSE, mar = c(0,0,0,0),
# addgrid.col: When the selected display method is color or shadow, the default gridlines are white, otherwise they are gray
# addCoef.col: add color for correlation coefficients, only works when method = 'number'.
# addCoefasPercent can convert the correlation coefficient into a percentage format to save space
addgrid.col = NULL, addCoef.col = NULL, addCoefasPercent = FALSE,
# The methods for sorting correlation coefficients, can be original order (original), angular order of the eigenvectors (AOE), first principal component (FPC), hierarchical cluster (hcluster), and alphabetical order. Generally, AOE is better than FPC.
order = c("original", "AOE", "FPC", "hclust", "alphabet"),
# When the order is hcluster, this parameter can be one of the seven methods in hierarchical clustering, such as Ward method...
hclust.method = c("complete", "ward", "single", "average",
"mcquitty", "median", "centroid"),
# When the order is hcluster, a box can be added to the correlation coefficient graph, rect.col and lwd are for color and frame of box.
addrect = NULL, rect.col = "black", rect.lwd = 2,
# Specify the position (lower for left and diagonal, upper for top and diagonal, full for left and top) and size of the text label.
tl.pos = NULL, tl.cex = 1,
# color of text
tl.col = "red", tl.offset = 0.4, tl.srt = 90,
# color and position of legend
cl.pos = NULL, cl.lim = NULL,
cl.length = NULL, cl.cex = 0.8, cl.ratio = 0.15,
cl.align.text = "c",cl.offset = 0.5,
addshade = c("negative", "positive", "all"),
# This parameter is only useful when method = shade.
shade.lwd = 1, shade.col = "white",
p.mat = NULL, sig.level = 0.05,
insig = c("pch","p-value","blank", "n"),
pch = 4, pch.col = "black", pch.cex = 3,
plotCI = c("n","square", "circle", "rect"),
lowCI.mat = NULL, uppCI.mat = NULL, ...)
Load relevant packages, this data is non-public
library(corrplot)
cor <- read.csv("cor.csv", header = T)
First, calculate the correlation coefficient between our samples:
matrix <- cor(cor)
Mapping them:
# without any parameter
corrplot(corr=matrix)
控制单元格形状和内容：
# 换用不同method，分别显示数字和颜色（method can be "circle", "square", "ellipse", "number", "shade", "color", "pie"）
# method 默认为“circle”
corrplot(matrix, method = "number")
#只展示上三角的一半，并且内容改为方块
corrplot(matrix, type = "upper", method = "color")
设置可以混合显示：
corrplot.mixed(matrix, lower = "number", upper = "ellipse",lower.col = "black", number.cex = 1)
#tl.col 修改对角线的颜色,lower.col 修改下三角的颜色，number.cex修改下三角字体大小
对变量进行聚类等：
corrplot(corr=matrix,method = "color",order = "hclust",tl.col="black",addrect=4,addCoef.col = "grey")
Cluster analysis
Systematic clustering
将分类的对象按照数据本身的特征的不同进行分类的方法称为聚类分析法。其中对样品进行聚类称为Q型聚类，而对变量进行聚类称为R型聚类。 在聚类分析中我们通过举例与相似系数来对各种数据进行聚类，与距离有关的参数为“马氏距离”，“欧氏距离”，“兰氏距离”，而与相似度有关的参数为“相关系数”和“余弦夹角”，在确定了数据间的这些系数后，我们可以根据最短距离法、最长距离法、中间距离法、离差平方和（ward）法、重心法和类平均法来进行分类。 可以使用一个非发布的R包“mvstats”进行各类聚类计算，数据与包在我的github中：
#X为数据矩阵/数据框，d为各类计算方法，m为系统聚类方法，proc为是否输出聚类过程，plot为是否绘图
H.clust <- function(X, d = "euc", m = "comp", proc = F, plot = T)
我们使用相关数据进行练习：
#导入数据
d1<-read.csv("/Users/desktop/r/comdata.csv", header = T)
#如果这样做的话似乎表头就会自动附带一列行号而且删不掉，不知道为什么，因此我们用其他方式导入数据
#使用openxlsx包
library(openxlsx)
d1 <- read.xlsx("/Users/desktop/r/comdata.xlsx",rowNames = TRUE)
#基于最短距离法画图
H.clust(d1,"euclidean","single",plot = T)
#此时尴尬的发现“极为先进”的osx原生不支持UTF-8中文输出，因此画图出来全是乱码
#用plot函数画图，使用family="STKaiti"来支持中文
plot(H.clust(d1,"euclidean","single"),ylab="euclidean",main="single",family="STKaiti")
结果如下： 
加下来分别使用其他方法再试试：
#最长距离法
plot(H.clust(d1,"euclidean","complete"),ylab="euclidean",main="single",family="STKaiti")
#中间距离法
plot(H.clust(d1,"euclidean","median"),ylab="euclidean",main="single",family="STKaiti")
#类平均法
plot(H.clust(d1,"euclidean","average"),ylab="euclidean",main="single",family="STKaiti")
#重心法
plot(H.clust(d1,"euclidean","centroid"),ylab="euclidean",main="single",family="STKaiti")
#ward法
plot(H.clust(d1,"euclidean","ward"),ylab="euclidean",main="single",family="STKaiti")
比较一番我们即可发现北京、上海、浙江、江苏、广东、天津、福建处在消费能力的第一梯队。
Kmeans clustering
使用系统聚类的方法时一旦样本量数据较大，可能会死机，因此可以使用K均值法进行快速且准确的聚类，该方法是将数据随机分成k个聚类然后根据平方误差准则不断迭代来实现的。但是kmeans只能产生我们制定数量的聚类结果而且其对==噪声==很敏感，而系统聚类法则可以自动产生一系列的聚类结果。
#x为数据框，centers为聚类数/初始聚类中心
kmeans(x,centers,...)
下面模拟正态随机变量$x\sim N(\mu ,\sigma ^2)$并进行kmeans聚类：
#模拟一个有1000个均值为0，标准差为0.3的正态分布随机数，它们被分成一个共有10列的矩阵中
x1=matrix(rnorm(1000, mean = 0, sd = 0.3), ncol = 10)
#模拟一个有1000个均值为1...
x2=matrix(rnorm(1000, mean = 1, sd = 0.3), ncol = 10)
#利用rbind()把向量按行合并（cbind()为按列合并
x = rbind(x1, x2)
#先用系统聚类看看
H.clust(x, "euclidean", "complete")
这图炸了啊 
#再用kmeans看看，分为两类进行聚类
cl = kmeans(x,2)
#pch为point character之意，对第一类我们标记为1，用rep函数循环100次标记在图上
pch1 = rep("1",100)
pch2 = rep("2",100)
#通过col函数按聚类分色，pch函数指定描点的样式，cex函数指定点的大小
plot(x, col = cl$cluster, pch = c(pch1,pch2),cex = 0.7)
#将每类的中心点标出来
points(cl$centers, col = 3, pch = "*", cex = 3)
从结果上看kmeans聚类确实能将均值为1的数和均值为0的数有效区分开： 
Principal component analysis (PCA)
对于某一问题可以同时考虑多种变量时，我们通过主成分分析将这些变量放在一起处理并选出做主要的变量。从数学角度而言，求主成分就是寻找$\textup{X}$的线性函数$\theta \textup{X}$，使相应的方差达到最大。 我们将原始数据标准化并求相关矩阵，获得相关矩阵的特征值和特征向量，通过计算方差贡献率和累计方差贡献率来获得每个主成分的贡献率，进而得到综合评价函数。关于主成分分析的原理，详见CSDN上的李春春_的一篇博文。
#主成分分析函数，x为数据框；cor为是否使用相关阵，默认为协差阵；scores为是否输出成分得分
princomp(x, cor = FALSE, scores = TRUE,...)
#碎石图函数，obj为主成分分析对象，type为图形类型
screeplot(obj, type = c("barplot", "lines"),...)
#自编综合得分函数，需要mvstats包，PCA为主成分对象，m为主成分个数，plot为是否画图
princomp.rank <- function(PCA, m = 2, plot = F)
下面使用上面的各省消费数据进行实际使用： ```r {class=line-numbers} library(mvstats) library(openxlsx) #在这里导入csv会报错，好像原因和上面一样… #一个想法，会不会是我数据以字符串储存而不是以数字储存所以除了问题，可以用data_m$d1 <- as.numeric(data_m$d1)来变换 d1 <- read.xlsx(“/Users/calice/desktop/r/comdata.xlsx”,rowNames = TRUE) #计算相关系数 cor(d1) #主成分分析 PCA = princomp(d1, cor = T) summary(PCA) #主成分载荷 PCA $loadings #绘制流石图 screeplot(PCA, type = “lines”) #选取贡献率占80%的前两个主成分，计算主成分得分 PCA$scores[,1:2] #主成分排名并绘图 princomp.rank(PCA, m = 2, plot = T) #但是弱智mac无法显示中文，因此我们先将结果导出为csv，给地区变量价格name的title再加载进来？ d2 <- write.csv(princomp.rank(PCA, m = 2)) d2 <- read.csv(“/Users/calice/desktop/PCA.csv”, header = T) #使用theme函数设定的字体对于geom_text并没有用，所以只能在geom_text中单独设置字体为STKaiti才能显示中文 ggplot(d2, aes(x = Comp.1,y = Comp.2))+ geom_point()+ geom_text(aes(y = Comp.2 + .2, label = name), family = “STKaiti”)
流石图：
最后结果：
也可以通过biplot()来绘制更加时尚的主成分分析图：
```r
#osx用户需要设定family，win就不用了
biplot(PCA, family = "STKaiti")
就很nb。 
Statistical test
假设检验的目的是看看数据是否有差异，数据、因子、结果等等的不同究竟是真的不同，还是其实就是随机的一些变化呢？如果检验成立，那就说明这些数据之间确实是有显著不同的，不是随便凑数的。 首先是关于各种分布的解释
Test of Distribution
Shapiro–Wilk test
shapiro.test()
当p值小于某个显著性水平α(比如0.05)时，则认为样本不是来自正态分布的总体，否则则承认样本来自正态分布的总体。
Kolmogorov-Smirnov test
ks.test()
如果P值很小，说明拒绝原假设，表明数据不符合F(n,m)分布。
Parametric test
参数假设检验，是指对参数平均值、方差进行的统计检验，条件是总体分布已知（比如已知是正态分布等等）。 T-test 做t-test的目的是为了检验在符合正态分布的样本中两个平均数是否有显著的差异，且该样本的总体方差也是未知的，否则可以用u检验。适用用样本总数较少的情况，但有研究说样本总数小于20时也尽量避免t检验。
t.test(x, y = NULL,
alternative = c("two.sided", "less", "greater"),
mu = 0, paired = FALSE, var.equal = FALSE,
conf.level = 0.95, ...)
其中x（和y）为进行检验的数据，alternative为设定的备择假设，默认为双尾，mu单样本检验时设定的均值（检验是否超过均值为准）,var.equal双样本检验时方差是否相等。
当双样本时： 要比较的两个样本的总体方差未知，但相等时（判断方差是否相等可以借助方差同质性检验F-test），可以使用t-test。
F-test 这是检验两个正态随机变量的总体方差是否相等的一种假设检验方法。
var.test(x, y, ratio = 1,
alternative = c("two.sided", "less", "greater"),
conf.level = 0.95, ...)
var.test()的零假设是x和y的方差比值（ratio）为1（默认），即是x与y的方差相等。
成组数据（pooled data）是两个样本的各个变量从各自总体中抽取，也就是说两个样本间的变量没有任何关联，两个抽样样本彼此独立。成组数据的两个样本的容量未必相同，但是方差需要相等才能进行t-test。
t.test(x, y, var.equal = T)
配对样本（paired data）的比较要求两个样本间配偶成对，每一对样本除随机地给予不同处理外，其他实验条件应尽量一致。即为配对，两样本的容量必定相等。
t.test(x, y, var.equal = T, paired = T)
Test of binomial distribution
#例：某蔬菜种子的发芽率为p=0.85. 现随机抽取500粒种子，
#用药水处理一下，然后测的发芽的种子数为445粒。
#请问药水有没有提高发芽率的作用。
#p值很小，接受对立假说，有好的作用
#95%的置信区间不包括0.85
binom.test(445,500,p=0.85,
alternative="greater")
alternative参数中的双边还是单边（大于和小于）就是接受的假设是要双边呢（离假设很远），或者好于假设或者差于假设。
Nonparametric test
Pearson’s chi-squared test 皮尔森建立了一个准则，以判定一组相关变量与其或然值的偏差，可否被合理地解释为是由于随机抽样所致。 检查两个数据集中的类别分量是否不同，在统计中会碰到离散型数据与计数数据，比如性别分男、女，某个问题的态度分为赞成、反对，成绩可分优良差，能力可分高中低。对这类数据的统计处理的假设检验一般用计数数据的统计方法进行非参数检验。 卡方检验主要用于两个方面，一是对总体分布进行拟合性检验，检验观查次数是否与某种理论次数相一致。 二是独立性检验，用于检验两组或者多组资料相互关联还是彼此独立。 下面就是皮尔逊卡方独立性检验：
chisq.test()
p<0.05即为显著差异。有时候会提示不够精确那么就可能需要fisher.test()进行费舍尔精确检验了。 Kruskal-Wallis test 秩和检验是一种非参数检验法, 它是一种用样本秩来代替样本值的检验法；秩和检验可以用于样本容量不相等的两个或多个样本。 用于两两检验，看看a（离散？）是否与b有关 例如： 先进行总体的：
library(spdep)
library(pgirmess)
A=c(3.5,4.0,6.7,5.6,8.9,7.8)
B=c(4.5,3.0,8.0,5.4,6.9,2.8,7.7,3.9)
C=c(2.1,4.8,3.3,8.8)
jianyan=list(A,B,C)
kruskal.test(jianyan)
再进行两两的：
resp<-c(3.5,4.0,6.7,5.6,8.9,7.8,4.5,3.0,8.0,5.4,6.9,2.8,7.7,3.9,2.1,4.8,3.3,8.8) #将A，B，C三组数据依次放在一个向量里
categ<-factor(rep(1:3,c(6,8,4))) #6,8,4依次为A,B,C对应的样本容量
kruskalmc(resp, categ, probs=0.05) #②再使用kruskalmc函数做两两样本的比较
Kruskal–Wallis秩和检验有时得不到精确的p值，对于Kruskal–Wallis秩和检验差异显著的多个样本，想知道具体差异在哪些样本之间同时又想获得精确的p值，可以采用Nemenyi进行两两样本检验，方法如下：
install.packages("PMCMRplus")
library(PMCMRplus)
library(PMCMR)
posthoc.kruskal.nemenyi.test(jianyan) #未校正
posthoc.kruskal.nemenyi.test(jianyan,dist="Chisq") #校正
对csv数据：
kruskal.test(data, a ~ b)
library(pgirmess)
library(coin)
library(multcomp)
kruskalmc(zhi~group, data = cd, probs=0.05)
Nemenyi进行两两样本检验
library(PMCMR)
posthoc.kruskal.nemenyi.test(zhi~group,data=cd) #未校正
posthoc.kruskal.nemenyi.test(zhi~group,data=cd,dist="Chisq")
Wilcoxon test
wilcox.test(x, y = NULL, alternative = c("two.sided", "less", "greater"), mu = 0, paired = FALSE, exact = NULL, correct = TRUE, conf.int = FALSE, conf.level = 0.95, ...)
原假设：中位数大于，小于，不等于mu, p < 0.05 时拒绝原假设
Discriminant analysis
Discriminant analysis是一种分类的手段，就是在已经确定分类的情况下根据新的值推断新的东西属于哪一类。
Linear discriminant analysis (lda)
使用的数据来自Guerin Chloe关于利用棕榈科内植物不饱和脂肪酸的各种含量推断其所属的亚族的案例，可以在链接中的supplementry中的表S7中获得。 准备数据与环境
library(MASS)
seed <- read.csv("seed.csv", head = T)
head(seed)
# class C8.0 C10.0 C12.0 C14.0 C16.0 C16.1 C17.0 C18.0
# 1 Attaleinae 9.4 8.2 49.2 13.9 6.0 0 0 3.2
# 2 Attaleinae 8.9 5.9 41.0 14.6 8.9 0 0 5.3
# 3 Attaleinae 6.0 5.2 53.8 17.9 6.3 0 0 1.7
# 4 Attaleinae 13.5 15.5 36.2 7.2 4.8 0 0 2.1
# 5 Attaleinae 15.0 13.0 44.5 8.0 3.9 0 0 1.7
# 6 Attaleinae 9.2 6.7 49.1 18.4 8.5 0 0 2.8
# C18.1n7 C18.1n9 C18.2 C18.3n3 C18.3n6 C20.0 C20.1n9 C22.0
# 1 0 8.6 1.5 0 0 0.0 0 0
# 2 0 12.8 2.4 0 0 0.1 0 0
# 3 0 7.3 1.8 0 0 0.0 0 0
# 4 0 16.6 4.1 0 0 0.0 0 0
# 5 0 9.6 4.2 0 0 0.1 0 0
# 6 0 4.4 0.9 0 0 0.0 0 0
# C22.1 C24.0
# 1 0 0
# 2 0 0
# 3 0 0
# 4 0 0
# 5 0 0
# 6 0 0
进行lda分析
ord <- lda(class ~., seed)
ord
# Call:
# lda(class ~ ., data = seed)
# 各个分类数据占总体的比重，用ord$prior调用
# Prior probabilities of groups:
# Attaleinae Bactridinae Dypsidinae
# 0.2682927 0.2926829 0.1219512
# Livistoninae Ptychospermatinae
# 0.1951220 0.1219512
# 各个分类的均值向量，用ord$means调用
# Group means:
# C8.0 C10.0 C12.0 C14.0
# Attaleinae 10.354545 9.645455 44.27273 12.67273
# Bactridinae 2.358333 2.091667 52.99167 23.90833
# Dypsidinae 1.060000 1.360000 41.08000 21.52000
# Livistoninae 0.400000 0.512500 25.46250 12.51250
# Ptychospermatinae 0.100000 0.120000 7.40000 15.58000
# C16.0 C16.1 C17.0 C18.0
# Attaleinae 6.263636 0.00000000 0.0000 2.727273
# Bactridinae 6.083333 0.09166667 0.0000 1.941667
# Dypsidinae 10.900000 0.04000000 0.1000 2.020000
# Livistoninae 14.275000 0.17500000 0.0875 3.075000
# Ptychospermatinae 22.280000 0.18000000 0.1200 4.260000
# C18.1n7 C18.1n9 C18.2 C18.3n3
# Attaleinae 0.00 11.43636 2.572727 0.0000
# Bactridinae 0.00 7.75000 2.750000 0.0000
# Dypsidinae 0.00 11.22000 9.820000 0.2400
# Livistoninae 0.00 25.18750 17.475000 0.2625
# Ptychospermatinae 0.18 26.56000 22.100000 0.4200
# C18.3n6 C20.0 C20.1n9 C22.0
# Attaleinae 0.00 0.018181818 0.009090909 0.0000
# Bactridinae 0.00 0.008333333 0.008333333 0.0000
# Dypsidinae 0.04 0.180000000 0.120000000 0.1200
# Livistoninae 0.00 0.112500000 0.225000000 0.0375
# Ptychospermatinae 0.00 0.300000000 0.120000000 0.2000
# C22.1 C24.0
# Attaleinae 0.0000 0.0
# Bactridinae 0.0000 0.0
# Dypsidinae 0.0000 0.2
# Livistoninae 0.0625 0.1
# Ptychospermatinae 0.0000 0.2
# 降维后的矩阵，用ord$scaling调用
# Coefficients of linear discriminants:
# LD1 LD2 LD3 LD4
# C8.0 7.455291 -2.314600 1.2084649 2.7055447
# C10.0 8.246015 -3.005224 0.7405566 2.8601837
# C12.0 7.699031 -2.804182 0.7473331 2.8390547
# C14.0 7.928075 -2.752640 0.8793914 2.9278632
# C16.0 8.274876 -2.662281 0.7989097 2.6498807
# C16.1 4.627508 -3.913803 -0.3161783 3.2083925
# C17.0 -9.159284 -38.262766 16.2293611 0.8829658
# C18.0 7.525268 -2.621863 1.2263565 3.2447562
# C18.1n7 17.025776 -14.368888 10.4090349 3.7960774
# C18.1n9 7.831366 -2.761313 0.8586662 2.9637938
# C18.2 7.969108 -2.650793 0.7212941 3.0479520
# C18.3n3 8.678906 -1.848086 2.8712302 1.6793984
# C18.3n6 3.298594 -14.894372 8.8791414 -1.3915681
# C20.0 28.289201 -5.148618 -3.5760683 -3.9201428
# C20.1n9 6.289320 -31.485980 13.9892531 -10.0222421
# C22.0 -9.382732 27.562065 -20.5810418 4.4250677
# C22.1 12.005084 9.744644 -2.5442515 7.6616473
# C24.0 10.673824 5.938224 -4.1534212 -2.1033277
# 降维后各个分量的权重
# Proportion of trace:
# LD1 LD2 LD3 LD4
# 0.8202 0.1070 0.0531 0.0197
查看预测结果
result <- predict(ord, seed)
table(seed$class, result$class)
# Attaleinae Bactridinae Dypsidinae Livistoninae Ptychospermatinae
# Attaleinae 9 2 0 0 0
# Bactridinae 1 11 0 0 0
# Dypsidinae 0 0 5 0 0
# Livistoninae 0 0 0 8 0
# Ptychospermatinae 0 0 0 0 5
Figuring by ggord
library(ggord)
p <- ggord(ord, seed$class)
p
有点丑，凑合吧。 
Back to the top
- Basic R analysis
Data Prfiling and Visualization in R
Introduction
开始写人生第一篇sci的时候才发现其实科研的最大问题就是如何分析数据，和将分析结果呈现出来，本章的目标就是将学习中遇到的数据可视化方案记录下来
- Data Prfiling and Visualization in R
ggplot2
ggplot2是R中最高效的绘图工具，在ggplot2中，我们的数据集必须得是data.frame格式，这种格式易于保存数据，而且能在保留原有的绘图参数下, 用%+%方便地变更已有数据集。ggplot2由数据与映射、几何对象(geom)、统计变化(stats)、标度、坐标系(coord)和分面(facet)这几个部分构成。在实际操作中，我们通过”+”将这些功能以图层的形式连接在一起。 我们对数据进行绘图，使用df = ggplot(data, aes(x,y))即可以得到一个数据源于data，横坐标为x，纵坐标为y的图框（只是一个框） 我们通过+ geom_point()的方式给框里添加一个散点图进去，散点的透明度可以用alpha函数去指导（0< alpha <1)，而我们还可以通过position = position_对图形元素进行调整:（在从lm()开始进行简单线性回归中的的第一张图里我们会用到这个） dodge为避免重叠，并排放置；fill为堆叠图形元素并将高度标准为1（标准化），position为描述；identity为不做变化；jitter为对点添加扰动以免重合（不知道这样会不会对数据的严谨性造成影响），stack为将图形元素堆叠
data.frame
一般翻译为数据框，就是R语言中的表，由行和列组成，与Matrix不同的是，其每个列可以是不同的数据类型。 我们可以使用data.frame函数初始化一个Data Frame（听起来有点像SQL语言） ```r {class=line-numbers} #这里的c()是将括号中的元素连接起来，但不创建向量，而paste()则会创建向量。 #我们就会得到一个列名为ID、Name、Gender的表格 student<-data.frame(ID=c(1,2,),Name=c(“Eden”,”Edward”),Gender=c(“M”,”M”)) #我们可以访问里面的元素，比如我们想看第二列： student[,2] #那要看其中几列，我们可以（注意是：）： idname<-student[1:2] #也可以是 idname<-student[c(“ID”,”Name”)]
那么其实还是得装一个“sqldf”包，然后就可以用SQL语言去查询了，属实方便：
```r
library(sqldf)
result<-sqldf(“select XX from XX")
那么接下来我们去生成这样的一个数据框来熟悉一下： ```r {class=line-numbers} #生成一个数据框，其中列x为1-8和1-8（共16个数），列y为使用runif()函数生成的16个服从正态分布的随机数。runif(n,min=0,max=1)意为生成一个数量为n，分布下限为0，上限为1的正态分布的数。 #我们将group1定义为一个循环2次（rep(x,n)为将x循环n次）的一组数 #这组数通过gl()函数定义为了2级因子，重复4次，水平为a和b的两组数。 d <-data.frame(x = c(1:8, 1:8), y = runif(16), group1 = rep(gl(2, 4, labels = c(“a”, “b”)), 2) group2 = gl(2,8)) head(d)
我们使用ggplot2可以将它们画出来，我们使用`facet_grid()`函数将表格按group分面并且group显示在表头:
```r
ggplot(data = d, aes(x = x, y = y, colour = group1)) + geom_point() +
facet_grid(~group2)
可得： 
利用随机数我们可以验证许多数学方法！如模拟正态随机变量并用于kmeans聚类。 接下来我们使用加拉帕戈斯雀的数据进行练习……这个数据大概要一直用到博客更完，数据来源在http://bioquest.org/birdd/morph.php。这是Sato等在2000于Mol. Biol. Evol.上发的文章中的数据 http://mbe.oxfordjournals.org/content/18/3/299.full。 ```r {class=line-numbers} #我们通过stringsAsFactors = FALSE来避免R将字符串string的列当成变量/因子factor去瞎搞 morph <- read.csv(“data/raw/Morph_for_Sato.csv”, stringsAsFactors = FALSE) #tolower()函数将字母全变成小写，toupper()则相反 names(morph) <- tolower(names(morph)) #通过filter(.data=,condition_1,condition_2)来根据condition进行数据的筛选，我们筛选出“Flor_Chrl”岛的数据 morph <- filter(morph, islandid == “Flor_Chrl”) #选择我们用来分析作图的数据 morph <- select(morph, taxonorig, sex, wingl, beakh, ubeakl) #重命名列 morph <- rename(morph, taxon = taxonorig) #使用na.omit删去所有的na行，即删去所有数据缺失的行 morph <- data.frame(na.omit(morph)) # remove all rows with any NAs to make this simple #把morph作为一个data.frame，但此时R会说”as_data_frame() is deprecated, use as_tibble() (but mind the new semantics).“，那就用as_tibble()？？？，但是tibble不能使用glimpse()工具…… morph <- as_data_frame(morph) #使用set.seed()函数保证我们设置的随机数每次都一样，此时()内的数只是一个标记，对结果没有影响 set.seed(1) #使用sample(x=x,size=n,replace=T)来对数据集x进行有放回的n次抽样 #使用seq(from,to,lenth),来对生成一组从什么到什么间隔什么的数，而seq_len(nrow(morph))即为从morph的行数中生成一个从1开始，步长为1的向量/也可以说是从1开始步长为1的一列数去对应morph的各行 那么我们要从morph列的各行中随机挑选200个数据作为morph的数据集 morph <- morph[base::sample(seq_len(nrow(morph)), 200), ] morph #使用glimpse功能转置数据以便更好地研究变量 glimpse(morph) ##这是原效果
taxon sex wingl beakh ubeakl
1 Geospiza scandens M 66 9.2 18.7
2 Camarhynchus pauper M 67 8.5 14
3 Geospiza fuliginosa M 59 8.1 13
4 Geospiza fuliginosa M 66 8.4 13
5 Geospiza fortis M 71 13.3 18
6 Geospiza fortis M 70 12.3 15.8
7 Camarhynchus psittacula M 70 11.1 14.2
8 Geospiza fortis M 75 15.4 19.4
9 Geospiza fuliginosa F 64 8 11.9
#10 Geospiza fortis M 72 12.6 16.2 ##这是glimpse后的效果： #Observations: 200 #Variables: 5 #$ taxon
### geom
几何对象就是图标中的点线面，geom有以下这些功能：
geom | Description ——————- | ———– geom_point() | Points geom_line() | Lines geom_ribbon() | 可以指定函数的上下边界，geom_ribbon(aes(ymin = a+b, ymax=a-b)) + geom_line来做一个关于a在直线上活动范围（往往是置信区间）的图表 geom_polygon() | 绘制多边形 geom_pointrange() | 中间有点的线状图？ geom_linerange() | 一种用三条直线来表示的箱形图？ geom_path() | 高级的geom_line，但是不限制画线的方向 geom_histogram() | 直方图 geom_text() | 将文本和数值插入到图中，比如给散点图每个点做注释，我们可以使用(check_overlap = TRUE)来让所有的注释不重叠。 geom_label() | 高级的geom_text()，可以给注释文字加个框 geom_violin() | Violin plot (another name for a beanplot)，beanplot是高级的小提琴图，有个包可以去研究研究 geom_map() | 画地图，然而我用ArcGIS，不谈 geom_bar() | 柱状图
我们来应用一下：
```r
#考察翅膀长度和性别之间的关系
ggplot(morph, aes(sex, wingl)) +
geom_violin()
#r通过箱型图翅膀长度和物种间的关系，箱型图中的小点为异常值
ggplot(morph, aes(taxon, wingl)) + geom_boxplot()
结果发现下面的物种名字我们都看不见了…… 因此我们使用coord()来设置坐标系，就非常好了
ggplot(morph, aes(taxon, wingl)) + geom_boxplot() + coord_flip()
我们可以在geom_boxplot(aes(fill = …))中设置箱子的颜色，这样我们就可以按supp（变量）去设置颜色。 我们也可以使用position = position_dodge()来调整箱型图之间的距离。
Aesthetics of ggplot2
我们可以对图表进行各种美学上的设置，这些设置往往会自动附加一个图例：
ggplot(morph, aes(wingl, beakh)) +
geom_point(aes(colour = sex))
我们还可以通过图例里再加一个别的数据，如上喙长(ubeakl)，实现表格数据的套娃：
ggplot(morph, aes(wingl, beakh)) +
geom_point(aes(size = ubeakl))
这样可能太丑了，我们需要换一种方式来表达：
ggplot(morph, aes(wingl, beakh)) +
geom_point(aes(colour = ubeakl))
那我们可以把这些参数都加入，制作一张终极套娃： 
我们要分类出图的话需要使用facet函数：其中warp是对一个因子分类，而grid是对多个因子：
facet_wrap(facets, nrow = NULL, ncol = NULL, scales = "fixed", shrink = TRUE, as.table = TRUE, drop = TRUE)
#nrow,ncol为设置的行和列，scales为坐标轴刻度，其中参数fixed表示固定坐标轴刻度，而free表示反馈坐标轴刻度；shrink也和坐标轴刻度有关，如果为TRUE（默认值）则按统计后的数据调整刻度范围
#drop表示是否去掉没有数据的分组，默认情况下不显示，逻辑值为FALSE；as.table为和小图排列顺序有关的选项；space表示分面空间是否可以按照数据进行缩放，和scales一样
facet_grid(facets, margins = FALSE, scales = "fixed", space = "fixed", shrink = TRUE, labeller = "label_value", as.table = TRUE, drop = TRUE)
如：
ggplot(morph, aes(wingl, beakh)) + geom_point() +
facet_wrap(~taxon, scales = "free")
或：
ggplot(morph, aes(wingl, beakh)) + geom_point() +
facet_grid(sex~taxon)
接下来我们制作pointrange图？其实不知道有啥用…… 准备数据并绘图： ```r {class=line-numbers} morph_quant <- morph %>% #quantile()是取百分位的函数，[[1]]似乎是一个引用函数？ group_by(taxon) %>% summarise( l = quantile(wingl, 0.25)[[1]], m = median(wingl), u = quantile(wingl, 0.75)[[1]]) %>% #创造一个新列方便处理 mutate(taxon = reorder(taxon, m, function(x) x)) ggplot(morph_quant, aes(x = taxon, y = m, ymin = l, ymax = u)) + ylab(“Wing length”) + xlab(“”) + geom_pointrange() + coord_flip()
### Add p-value to ggplot
可以通过`stat_compare_means`函数给ggplot图像添加P值。该函数的表达式为：
```r
stat_compare_means(mapping = NULL, data = NULL, method = NULL, paired = FALSE, ref.group = NULL, comparisons = NULL, hide.ns = FALSE, label.sep = ", ", label = NULL, label.x.npc = "left", label.y.npc = "top", label.x = NULL, label.y = NULL, geom = "text", position = "identity", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, ...)
一般来说我们通过“+”将这个图层附在我们的ggplot图层后，我们只需要使用：
stat_compare_means(method = NULL, ref.group = NULL, comparisons = NULL, label = NULL)
其中，method为我们进行统计时采用的方法，默认是Kruskal-Wallis，也可以设置为anova、t-test之类的，而comparisons是用来设置组间比较的并显示的函数，label函数则是选择怎样的显著性标记，而label.y可以调整添加的p值标志的高度。
Color in R
可以通过定义col参数自定义颜色，在r语言中可以使用col=c()来设定颜色填充，通过输入数字2(palette的第一种颜色)，或“red”这种英文，或rgb(1,0,0)这种rgb值或“#FF0000”这种rgb的代码表示来确定我们实际填充的颜色。 而通过palette()函数我们可以设置我们的调色板。 还可以使用RcolorBrewer包的brewer.pal()函数来填充颜色，包中颜色被分为了序列型(sequential)(display.brewer.all(type = “seq”))和分类型(qualitative)(display.brewer.all(type = "qual")和离散型(diverging)(display.brewer.all(type = "div") 在ggplot中，scale_fill_brewer()函数控制着图表的颜色变化，我们可以使用scale_fill_brewer(palette ="")来调节颜色，而颜色模板的名字则可以通过在包RColorBrewer中 - 运行 display.brewer.all()查看。
Export our figures
如果有RStudio，那么我们在图片的边上选择Export，格式的话也许可以选择EPS，这样我们可以在Adobe illustrator中打开并编辑。同时我们还可以使用“export”包进行导出，这里我们可以自定义图像的质量等参数：
library(export)
filen <- tempfile(pattern = "ggplot")
graph2tif(x=x, file = filen, dpi = 400, height = 5)
Data cleaning by dplyr
dplyr包可以处理r语言内部或外部的一切结构化数据，它高效、快速、简洁，专注于dataframe对象，有着稳健的数据库接口，是学习r语言必备的数据简化工具。 一般而言我们在使用dplyr时会用到5个常用的函数：select为选择数据，filter为筛选数据，arrange为排序数据，mutate为列的修改，summarise为汇总整理。 可以下载http://esapubs.org/archive/ecol/E090/184/的PanTHERIA数据库获得关于物种和环境的数据作为dplyr操作的练手工具。
pantheria <-
"http://esapubs.org/archive/ecol/E090/184/PanTHERIA_1-0_WR05_Aug2008.txt"
download.file(pantheria, destfile = "data/raw/mammals.txt")
接下来加载dplyr包并对数据进行简化并查看： ```r {class=line-numbers} mammals <- readr::read_tsv(“data/raw/mammals.txt”) #使用sub和gsub函数进行替换，sub()和gsub()的区别在于，前者只替换第一次匹配的字串（请注意输出结果中world的首字母），而后者会替换掉所有匹配的字串。 #将表中的0-9(如05_这种)都删了，这种表达式为正则表达式 names(mammals) <- sub(“[0-9.-]+”, “”, names(mammals)) #将表中的MSW给删了 names(mammals) <- sub(“MSW”, “”, names(mammals)) mammals <- select(mammals, Order, Binomial, AdultBodyMass_g, AdultHeadBodyLen_mm, HomeRange_km2, LitterSize) #把所有大写字母变成小写并在前面加上“” names(mammals) <- gsub(“([A-Z])”, “\L\1”, names(mammals), perl = TRUE) #把词首的“”删去 names(mammals) <- gsub(“^”, “”, names(mammals), perl = TRUE) #把表格中的-999换成空值 mammals[mammals == -999] <- NA #将binomial替换为species names(mammals)[names(mammals) == “binomial”] <- “species” #变成数据框格式并打开 mammals <- as_data_frame(mammals) mammals
接下来横过来看看数据：
```r
glimpse(mammals)
#Observations: 5,416
#Variables: 6
#$ order <chr> "Artiodactyla", "Carnivora", "Carnivora", "Carnivora", "Carnivora", "Artioda…
#$ species <chr> "Camelus dromedarius", "Canis adustus", "Canis aureus", "Canis latrans", "Ca…
#$ adult_body_mass_g <dbl> 492714.47, 10392.49, 9658.70, 11989.10, 31756.51, 800143.05, 500000.00, 6359…
#$ adult_head_body_len_mm <dbl> NA, 745.32, 827.53, 872.39, 1055.00, 2700.00, NA, 2075.00, 354.99, NA, NA, N…
#$ home_range_km2 <dbl> 1.963200e+02, 1.010000e+00, 2.950000e+00, 1.888000e+01, 1.598600e+02, NA, NA…
#$ litter_size <dbl> 0.98, 4.50, 3.74, 5.72, 4.98, 1.22, 1.00, 1.22, 1.01, NA, 1.02, 1.02, 1.02, …
使用select函数可以选取我们需要的数据：
#select(.data,...)来选取我们想要的信息
#可以根据列名选取
select(mammals, adult_head_body_len_mm, litter_size)
#可以选取某列到某列
select(mammals, adult_head_body_len_mm: litter_size)
#可以选取除了某列的其他列
select(mammals, -adult_head_body_len_mm)
#也可以在select()中插入函数，如starts_with()可以按首字母(或首更多字母)来查找变量，而ends_with()则正相反，而contains()函数则对查找的位置没有限制，同时我们也可以按列号的数字来查找我们要的变量。
Filter函数可以方便地筛选数据（行数据）：
#筛选adult_body_mass_g行中数据大于1*10^7的行，而要筛选等于的数据用“==”来表示全等
filter(mammals, adult_body_mass_g > 1e7)
#筛选科为Cetacea的且成体生物量小于200的行数据，我们用逗号“,”表示和，用竖线“|”表示或。我们也可以用is.xxx()来指定行为xxx
filter(mammals, order == "Carnivora", adult_body_mass_g < 200)
arrange函数可以排序，默认从小到大，我们也可以通过desc()来设置成从大到小排序。同样地，我们可以使用group_by()函数进行分组
#对数据mammals，我们先按order排序，再按adult_body_mass_g从大到小排序
> arrange(mammals, order, desc(adult_body_mass_g))
Mutate函数可以调整列：
#给mutate表增加一个新列
glimpse(mutate(mammals, adult_body_mass_kg = adult_body_mass_g / 1000))
summarise函数可以进行一些总结性的工作：
#按科分类后计算平均质量，同时使用rm函数将na缺失值删除
head(summarise(group_by(mammals, order),
mean_mass = mean(adult_body_mass_g, na.rm = TRUE)))
基于这些内容，我们可以通过函数嵌套的方式创建一个质量与长度之间的关系数据（在程序语言中我们通过缩进来表示函数的关系，相同缩进的都在一起）：
select(
arrange(
mutate(mammals,
mass_to_length = adult_body_mass_g / adult_head_body_len_mm),
desc(mass_to_length)),
species, mass_to_length)
dplyr部分暂时完结。
Phylogenetic figuring
Tree figurring
设置路径、包、数据
setwd('/Users/calice/desktop/pictree')
library(picante)
library(ape)
library(vegan)
library(permute)
library(geiger)
library(nlme)
library(phytools)
library(caper)
library(rgl)
#install.packages("plotrix")
tree <- read.tree("Sampletree_1.tre")
dat<- read.csv("Species with geographical range size and height for figure1_ordered.csv",head=T)
head(dat)
准备一个来自张剑老师的函数
tiplabels.New <- function (text, dist=1,tip, adj = c(0.5, 0.5), frame = "rect", pch = NULL,
thermo = NULL, pie = NULL, piecol = NULL, col = "black",
bg = "yellow", horiz = FALSE, width = NULL, height = NULL,
...){
lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
if (missing(tip))
tip <- 1:lastPP$Ntip
XX <- lastPP$xx[tip]/(sqrt(lastPP$xx[tip]^2 + lastPP$yy[tip]^2)) * dist + lastPP$xx[tip]
YY <- lastPP$yy[tip]/(sqrt(lastPP$xx[tip]^2 + lastPP$yy[tip]^2)) * dist + lastPP$yy[tip]
BOTHlabels(text, tip, XX, YY, adj, frame, pch, thermo, pie,
piecol, col, bg, horiz, width, height, ...)
}
绘制…线条？
fami <- tree$tip.label
pch.fami <- data.frame(fami = fami, cols1st=NA)
for (i in 1:length(fami)){
pch.fami$cols1st[which(pch.fami$fami==fami[i])] <- dat$ORDER_classification[which(dat$tip.lab==fami[i])]
}
pch.fami$cols1st[which(pch.fami$cols1st=="A")] <- "black"
pch.fami$cols1st[which(pch.fami$cols1st=="B")] <- "black"
pch.fami$cols1st[which(pch.fami$cols1st=="C")] <- "black"
pch.fami$cols1st[which(pch.fami$cols1st=="D")] <- "black"
pch.fami$cols1st[which(pch.fami$cols1st=="E")] <- "black"
pch.fami$cols1st[which(pch.fami$cols1st=="F")] <- "black"
pch.fami$cols1st[which(pch.fami$cols1st=="G")] <- "black"
pch.fami$cols1st[which(pch.fami$cols1st=="H")] <- "black"
pch.fami$cols1st[which(pch.fami$cols1st=="NoPIC")] <- "white"
# 清空变量
rm(i,fami)
绘制…边缘？
edge.fami<- tree$edge[,2]
fami <- tree$tip.label
edge.fami[which(edge.fami> length(fami))]= NA
for(i in 1:length(fami)){
edge.fami[which(edge.fami==i)]<- dat$height_classification[which(dat$tip.lab==fami[i])]
}
edge.fami[which(is.na(edge.fami))]<- "black"
edge.fami[which(edge.fami=="A")]<- colors()[29]
edge.fami[which(edge.fami=="B")]<- colors()[564]
edge.fami[which(edge.fami=="C")]<- colors()[590]
edge.fami[which(edge.fami=="D")]<- colors()[410]
edge.fami[which(edge.fami=="E")]<- colors()[622]
edge.fami[which(edge.fami=="F")]<- colors()[632]
edge.fami[which(edge.fami=="G")]<- colors()[504]
edge.fami[which(edge.fami=="H")]<- colors()[555]
edge.fami[which(edge.fami=="NoDATA")]<- "black"
绘制系统系统发育树
#设置一个tiff图
tiff(file="Tree_plant height.tif",width=200,height=200,units='mm',res=800,compression='lzw',pointsize=4)
#绘制树并确定规格
plot(tree,type="fan",show.tip.label=FALSE,edge.width=0.2, show.node.label=FALSE,edge.col=edge.fami)
#tiplabels(cex=0.005,col=edge.fami)
lastPP<- get("last_plot.phylo",envir=.PlotPhyloEnv)
add.scale.bar(x=min(lastPP$x.lim)+230,y=min(lastPP$y.lim)+180,cex=2.4,font=2.4,col="black",lwd=1.5,length=40,pos=4,offset=0.5)##offset is the distance betweeen legend and text
legend(x=min(lastPP$x.lim)+390,y=min(lastPP$y.lim)+88,legend=c("< 0.2","0.2 - 0.5","0.5 - 1","1 - 2","2 - 5","5 - 10","10 - 20","20 - 40 ", "No data"),bty="n",lty=1,col=c("blue3","royalblue2","skyblue1","lightgoldenrod","tan2","tomato2","orangered1","red3","black"),cex=2.4,lwd=1.5)
tiplabels.New(pch=22, dist=8,bg=pch.fami$cols1st, col=rgb(0,0,0,alpha=0) ,frame="none",cex = 1, adj=c(0,0)) # Use circles for the first (inner) la
###设置透明度alpha非常重要
dev.off()
ggtree
G Yu的教程无敌 ggtree是结合了ggplot2绘图功能的用来处理基于treeio所得的系统发育数据的一个程序包。
Back to the top
- Basic R analysis
Regressive analysis
- Regressive analysis
Distribution of data
回顾GLMs和GLMMs中最常用的概率分布 了解参数如何影响分布形状 正态分布
library(manipulate)
x <- seq(-10, 10, length.out = 300)
manipulate({
y <- dnorm(
x = x,
mean = mean,
sd = sd)
plot(x = x, y = y, type = "l", ylim = c(0, max(y)),
main = "Normal")},
mean = slider(-10, 10, 0),
sd = slider(0.1, 10, 2))
log变换下的正态分布
x <- seq(0, 100, length.out = 300)
manipulate({
y <- dlnorm(
x = x,
meanlog = meanlog,
sdlog = sdlog)
plot(x = x, y = y, type = "l", xlim = c(0, 100), ylim = c(0, max(y)),
main = "Lognormal")},
meanlog = slider(0.1, 10, 3),
sdlog = slider(0.01, 2, 1))
Gamma分布 可以理解为n个指数分布的独立随机变量的加总
x <- seq(0, 100, length.out = 300)
manipulate({
y <- dgamma(
x = x,
shape = shape,
scale = scale)
plot(x = x, y = y, type = "l", ylim = c(0, max(y)),
main = "Gamma")},
shape = slider(1, 10, 3),
scale = slider(0.1, 30, 2))
接下来是离散分布 泊松分布
x <- seq(0, 100)
manipulate({
y <- dpois(x,
lambda = lambda)
plot(x = x, y = y, type = "h", xlim = c(0, 60), ylim = c(0, max(y)),
main = "Poisson")},
lambda = slider(0.1, 30, 3))
负二项分布
x <- seq(0, 100)
manipulate({
y <- dnbinom(
x = x,
size = size,
mu = mu)
plot(x = x, y = y, type = "h", ylim = c(0, max(y)),
main = "Negative binomial")},
size = slider(0.1, 10, 1),
mu = slider(0.1, 60, 4))
二项分布
x <- seq(0, 10)
manipulate({
y <- dbinom(x,
size = size,
prob = prob)
plot(x = x, y = y, type = "h", xlim = c(0, 10), ylim = c(0, max(y)),
main = "Binomial")},
size = slider(1, 10, initial = 1, step = 1),
prob = slider(0, 1, initial = 0.5, step = 0.1))
size = 1, prob = 0.5 
size = 10, prob = 0.4 
Starting from lm()
首先需要从gapminder上获得一些练习数据，gapminder是一个有着全球各种数据的公益网站，我们可以通过R包“gapminder”去下载(http://github.com/jennybc/gapminder)。 我们先加载一些必要的包和数据：
library(tidyverse)
library(broom)
d <- gapminder::gapminder
tidyverse包是个合集，里面有dplyr实现数据整理，tidyr实现数据筛选，stringr实现字符串操作，还有ggplot2去作图。 broom包接受R中内置函数的杂乱输出（如lm和nls），并将它们转为整齐的数据帧。 第三行中我们使用双冒号在不打开包的情况下加载包中的某一功能，其语法为packagename::functionname。同时双冒号还可以在多个包下有同名函数时指定我们需要的包。 接下来我们打开d，这是一个6列1704行的表格
d
然后我们对数据进行绘图：
x = ggplot(d, aes(year,lifeExp))+
geom_point(alpha = 0.5, position = position_jitter(width = 0.6))
x
可以得到这样一张图：
接着我们来尝试进行寿命与年份间的简单线性回归：最简单的lm模型可以表示为df <- lm(a<-b)，即为用b去拟合a，并将结果输出到df里，然后我们输入summary(df)就能看到拟合结果了。我们可以利用coef()函数读取回归系数，并通过tidy()函数将回归结果整理成表格。
lm1 <- lm(lifeExp ~ year, data = d)
summary(lm1)
coef(lm1)
tidy(lm1)
##得到结果如下
#Residuals:
# Min 1Q Median 3Q Max
#-39.949 -9.651 1.697 10.335 22.158
#
#Coefficients:
# Estimate Std. Error t value Pr(>|t|)
#(Intercept) -585.65219 32.31396 -18.12 <2e-16 ***
#year 0.32590 0.01632 19.96 <2e-16 ***
#---
#Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
#
#Residual standard error: 11.63 on 1702 degrees of freedom
#Multiple R-squared: 0.1898, Adjusted R-squared: 0.1893
#F-statistic: 398.6 on 1 and 1702 DF, p-value: < 2.2e-16
如何理解这里面的各种玩意儿呢？我们直接看Coefficients部分： 其中Estimate为估值，Std.Error为标准误差，t value为T值，Pr为P值，一般而言，P<0.05以为数据有显著差异，我们认为这些数据通过了显著性检验，可以用了，有了统计学意义，而P<0.001意为数据有极显著差异（现在一般不提这个，误导性比较强）。 接下来可以看看Multiple R-squared（拟合优度）和Adjusted R-squared（修正的拟合优度），就是所谓的R方了，数值越高说明拟合程度越好。 而F-statistic则是F检验，是用来检验方程的整体显著性的，我们通过观察它的P值去看看方程整体是否显著。
About P-value and R^2
以前一直说什么显著差异极显著差异的，这时候我tm就要问了，我们线性回归为什么要扯什么显著差异，又不是做因素分析。所以P值有什么P用呢？ P-value是拒绝原假设犯第一类假设错误的概率（？），百度说是“原假设是正确的，但我们却拒绝了原假设”（？）。举个例子就是假设抛均匀硬币正面的概率是50%（P=0.5），那么现在抛5次硬币都是正面的概率显然为0.5^5=0.03125，如果我抛5次硬币都是正面，那么P=0.03125<0.05，有统计学意义了，就可以得出结论推翻原先的关于均匀硬币的说法了，我们据此可以认为这个硬币是不均匀的。 那么在线性回归中，原假设即为“其实这些数据是随机的，根本不存在什么线性”，我们通过P值检验推翻了这一原假设，即可正面“这些数据真不是随机的，而是有关系的”。 R方是什么，在SPSS中我们可以看到R-squared = SSR/TSS = 1-RSS/TSS，其中SSR为解释方差，RSS为残差平方和，TSS为固有方差。那么显然，可以用公式来表示这个R-squared： \(R^{2}=1-\frac{\sum_{i}\left (y^{(i)}-\hat{y}^{(i)}\right )^2}{\sum_{i}\left (y^{(i)}-\bar{y}\right )^2}\) 对于$\sum_{i}\left (y^{(i)}-\hat{y}^{(i)}\right )^2$，我们已经很熟悉了，而对于$\sum_{i}\left (y^{(i)}-\bar{y}\right )^2$，这就是使用平均数来预测产生的错误（损失函数）（在ML中称为基准模型（Baseline Model），那么如果说我们辛辛苦苦回归来的错误甚至多于随便求个平均值的错误，$R^2$就会小于0，就白给了。所以R方的值应当在0-1之间，且越大说明预测越准确。 那么调整R方又是什么呢？在R方的计算中，不断增加变量会提升模型的效果，但是其实并没有什么效果，而调整R方可以惩罚那些不显著的变量，来略微调低原先的R方。
回到正题，我们继续对gapminder数据进行一些处理并回归，在tidyverse包中，我们可以通过管道符%>%将前一个命令的输出作为后一个命令的输入，而不是使用嵌套函数搞一堆简称出来： ```r {class=line-numbers} #我们先将上面的数据d称为life（套娃），然后按国家进行分类 life <- d %>% group_by(country) %>% #接着把分类完的数据使用summarise这个统计描述函数，将lifeExp定义为算术平均寿命，将gdpPercap定义为算术平均gdp。 summarise(lifeExp = mean(lifeExp), gdpPercap = mean(gdpPercap)) #对数据带了log，取了对数，然后画成散点图 ggplot(life, aes(log(gdpPercap), log(lifeExp))) + geom_point() #回归 lm2 <- lm(log(lifeExp) ~ log(gdpPercap), data = life) summary(lm2) ##接着系统会生成结果： #lm(formula = log(lifeExp) ~ log(gdpPercap), data = life) # #Residuals:
Min 1Q Median 3Q Max
#-0.42480 -0.05350 0.01827 0.05729 0.23078 # #Coefficients:
Estimate Std. Error t value Pr(>|t|)
#(Intercept) 2.920294 0.060789 48.04 <2e-16 * #log(gdpPercap) 0.139064 0.007296 19.06 <2e-16 *** #— #Signif. codes: 0 ‘’ 0.001 ‘**’ 0.01 ‘’ 0.05 ‘.’ 0.1 ‘ ’ 1 # #Residual standard error: 0.1036 on 140 degrees of freedom #Multiple R-squared: 0.7219, Adjusted R-squared: 0.7199 #F-statistic: 363.3 on 1 and 140 DF, p-value: < 2.2e-16
我们注意一下现在的$R^2$是**0.7219**，结果很好，所以……
### Logarithmic transformation before regression
我们先试试上面的数据不取对数会如何？
代码就不列了，结果如下：
```r
#lm(formula = lifeExp ~ gdpPercap, data = life)
#
#Residuals:
# Min 1Q Median 3Q Max
#-42.058 -5.709 1.995 6.082 12.468
#
#Coefficients:
# Estimate Std. Error t value Pr(>|t|)
#(Intercept) 5.308e+01 9.106e-01 58.29 <2e-16 ***
#gdpPercap 8.862e-04 8.192e-05 10.82 <2e-16 ***
#---
#Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
#
#Residual standard error: 8.255 on 140 degrees of freedom
#Multiple R-squared: 0.4553, Adjusted R-squared: 0.4514
#F-statistic: 117 on 1 and 140 DF, p-value: < 2.2e-16
此时不仅仅是图丑出天际的问题了，而是$R^2$变成了0.4553，数据的拟合程度都下降了好多！ 首先要说明的是对数函数在其定义域内单调增，所以取对数后不会改变数据的相对关系，因此不用担心取了对数后数据不严谨了，乱了之类的。 接下来我尝试解释一下为什么取对数后我们的R方会提高，这也许可以从百度搜索引擎的机制开始讲起： 如果要搜索我们想要的信息，比如想去搜“薛定谔的猫”，那么搜索引擎是这么找到目标的呢？我们易得如果一个词在网页中出现的次数越少那么它越重要，因为显然我们搜索出的结果中肯定是首先与“薛定谔”有关的，而不是与“的”有关的，或者与“猫”有关的。也就是说如果一个关键词只在很少的网页中出现，我们通过它就容易锁定搜索目标，它的权重也就应该大。反之如果一个词在大量网页中出现，我们看到它仍然不很清楚要找什么内容，因此它应该小。概括地讲，假定一个关键词$w$在$Dw$个网页中出现过，那么$Dw$越大，$w$的权重越小，反之亦然。 这里就引入了“逆文本频率指数”（Inverse document frequency缩写为IDF）的概念，它的公式为 \(IDF=log(D/Dw)\)
假定现在有D=10亿个网页，且“的”在所有网页中都出现，那么IDF(的)=log(10亿/1o亿)=0。而“薛定谔”只在200万个网页中出现，那么IDF(薛定谔)=6.2，而我们假设猫在其中1亿个网页都出现了，所以IDF(猫)=2.3，那么我们可以认为在“薛定谔的猫”中，“薛定谔”贡献最大，“猫”也有贡献，而“的”其实没用，这也是符合我们现实逻辑的。 由此我们可以得知，取对数可以将数据在整个值域中因不同区间而带来的差异降到最小。而且可以改变变量的尺度，使得数据更加平稳。
The goodness of fit: from entropy to AIC
信息熵反映了一个系统的有序化程度，一个系统越是有序，那么它的信息熵就越低，反之就越高，以下为熵的定义： 如果一个随机变量$X$的可能取值为$X=\left {x_1,x_2,…,x_n\right }$，对应的概率为$p(X=x_i)(i=1,2,…,n)$，则随机变量X的熵为： \(H(x)=-\sum_{i=1}^{n}p(x_i)\textup{log}p(x_i)\) 那么相对熵又称交叉熵，Kullback-Leible散度（KL散度），设$p(x)$和$q(x)$式X取值的两个概率分布，则$p$对$q$的相对熵为： \(D(p||q)=\sum_{i=1}^{n}p(x)\textup{log}\frac{p(x)}{q(x)}\) 在一定程度上，熵可以度量两个随机变量的距离，KL散度是衡量两个概率分布$p$和$q$的非对称性度量。 该相对熵有以下两个性质： 1.KL散度并非两者的距离函数，因为它是非对称的：$D(p||q)\neq D(q||p)$ 2.相对熵的值非负（可通过吉布斯不等式证明） Akaike发现K-L距离的估计在实际情况中存在着过估计，且过估计的量近似等于需要估计的模型的参数个数K+1。于是他进行了优化，并定义了最小信息化准则AIC作为模型挑选的准则(L为模型的极大似然函数)： \(AIC=2k-2ln(L)\) 当模型的误差服从独立正态分布时： \(AIC=nlog(\hat{\sigma}^2)+2(k+1)\) 其中$\hat{\sigma}^2=\frac{RSS}{n}$，k为参数个数，$\hat{\sigma}^2$是$\sigma^2$的极大似然估计，$n$为样本大小，$RSS$为残差平方和。 AIC为模型选择提供了有效的规则，但也有不足之处。当样本容量很大时，在AIC准则中拟合误差提供的信息就要受到样本容量的放大，而参数个数的惩罚因子却和样本容量没关系，因此当样本容量很大时，使用AIC准则选择的模型不收敛与真实模型，它通常比真实模型所含的未知参数个数要多。BIC（Bayesian InformationCriterion）贝叶斯信息准则是Schwartz在1978年根据Bayes理论提出的判别准则，称为SBC准则(也称BIC)，弥补了AIC的不足。SBC的定义为： \(BIC = ln(k) - 2ln(L)\)
Quantile regression
分位数回归可以用R包quantreg实现：
library(SparseM)
library(quantreg)
data("engel")
#engel是quantreg中的自由数据，有235条，2个变量，一个是income收入，一个是foodexp食品支出，我们可以借此考察收入与食品支出的关系
#建立一个0.5分位数回归，rq函数就是quantreg里进行分位数回归的函数，tau即为分位数值
#是不是可以这么理解：所谓的α分位数回归，就是希望回归曲线之下能够包含α（一个百分数）的数据点？
fit1 <- rq(foodexp ~ income, tau = .5, data = engel)
fit1
summary(fit1)
##可得到：
#Call: rq(formula = foodexp ~ income, tau = 0.5, data = engel)
#
#tau: [1] 0.5
##coefficient列给出了估计的截距和斜率
##lower bd和upper bd则是估计的置信区间
#Coefficients:
# coefficients lower bd upper bd
#(Intercept) 81.48225 53.25915 114.01156
#income 0.56018 0.48702 0.60199
```r {class=line-numbers} #接着使用其内置的函数计算模型拟合残差，并绘制残差图 r1 <- resid(fit1) plot(r1) #得到结果表明残差均匀分布在(-200,200)区间内，说明拟合效果还不错 #绘制income和foodexp的散点图，并绘制不同分位数的分位数回归曲线： #attach命令可以避免通过$来每次调用数据框中的变量 attach(engel) #绘制散点图 plot(income, foodexp, cex = 0.25, type = “n”, xlab =”Household Income”, ylab =”Food Expenditure”) points(income,foodexp , cex = 0.25, col = “blue”) #通过abline绘制直线，这里绘制0.5分位回归线 abline(rq(foodexp ~income , tau = 0.5), col = “blue”) #绘制线性回归线 abline(lm(foodexp ~income ), lty = 2, col = “red”) #给定下列分位数 taus <- c(0.05, 0.1, 0.25, 0.75, 0.9, 0.95) #分别分位数回归 for (i in 1:length(taus)) { abline(rq(foodexp ~income , tau = taus[i]), col = “gray”) } #接触attach()的绑定 detach(engel)
接下来探讨分位数回归与恩格尔系数的关系：
```r
#使用within函数添加一列xx变量，xx为不同人群不同收入的占比
engel<-within(engel,xx <- income - mean(income))
fit1 <- summary(rq(foodexp~xx,tau=2:98/100,data = engel))
#通过mfrow功能实现1页放2幅图
plot(fit1,mfrow = c(1:2))
上图绘制了0.02到0.98这个区间中，每隔0.01做一次分位回归，其中黑色实心点代表回归曲线的截距值，阴影部分代表95%置信区间，红色实线和虚线分别代表的是，线性回归曲线的截距值和置信区间。从图中可以看出，收入对于0.02分位的foodexp的影响在0.35左右，对于0.98分位的影响在0.7左右。即为不同的分位数回归对应着不同的置信区间。 不同分位数的分位回归的截距值是否是由于抽样误差造成的，我们同样需要假设检验进行验证，那么我们使用Wald检验进行验证。得到如下结果，P值小于0.05可以认为不同分位数回归的截距之间值是有差异的。
fit1 <- rq(foodexp ~ income, tau = .25, data = engel)
fit2 <- rq(foodexp ~ income, tau = .5, data = engel)
fit3 <- rq(foodexp ~ income, tau = .75, data = engel)
anova(fit1, fit2, fit3)
结果有显著差异。
Mixed Linear model (lmm)
Fixed factors and random factors
混合线性模型考察既有随机因子，又有固定因子的模型的线性回归问题。而关于固定因子和随机因子，可参考csdn上的一篇博文：固定效应模型与随机效应模型 固定效应和随机效应的选择是大家做面板数据常常要遇到的问题，一个常见的方法是做huasman检验，即先估计一个随机效应，然后做检验，如果拒绝零假设，则可以使用固定效应，反之如果接受零假设，则使用随机效应。但这种方法往往得到事与愿违的结果。另一个想法是在建立模型前根据数据性质确定使用那种模型，比如数据是从总体中抽样得到的，则可以使用随机效应，比如从N个家庭中抽出了M个样本，则由于存在随机抽样，则建议使用随机效应，反之如果数据是总体数据，比如31个省市的Gdp，则不存在随机抽样问题，可以使用固定效应。同时，从估计自由度角度看，由于固定效应模型要估计每个截面的参数，因此随机效应比固定效应有较大的自由度. ***
lme4 package
混合线性回归：回归是研究因变量与自变量之间的关系，但是如果因变量有着不同的来源呢？比如研究全市学生成绩与学习时间的关系，但是全市众多学校每所学校水平不同，为了平衡/解决学校水平不同的差异，就需要利用混合线性回归。
我们还是使用之前的加拉帕戈斯地雀模型作为练习数据，对此进行预处理： ```r {class=line-numbers} library(tidyverse) morph <- read.csv(“data/raw/Morph_for_Sato.csv”, stringsAsFactors = FALSE, strip.white = TRUE) #使用tolower函数改成小写 names(morph) <- tolower(names(morph)) morph <- morph %>% dplyr::select(islandid, taxonorig, genusl69, speciesl69, sex, wingl, beakh, ubeakl) %>% dplyr::rename(taxon = taxonorig, genus = genusl69, species = speciesl69) morph <- data.frame(na.omit(morph)) morph <- dplyr::filter(morph, genus == “Geospiza”) %>% as_data_frame() d <- morph #把数据保存为RDS格式 saveRDS(d, file = “data/generated/morph-geospiza.rds”)
我们希望看一看喙长和翅膀长度有什么关系没有：
```r
#取对数缩小范围，并直接在图里进行线性回归，geom_smooth是添加平滑曲线
ggplot(d, aes(log(wingl), log(beakh))) +
geom_point(aes(colour = taxon)) +
geom_smooth(method = "lm")
但如果我们把aes(colour = taxon)移到上面会把我们默认的回归对象变成每个种 我们可以发现在种水平每个种的规律都不一样。
ggplot(d, aes(log(wingl), log(beakh), colour = taxon)) +
geom_point() +
#se指置信区间
geom_smooth(method = "lm", se = FALSE)
接下来使用R包“lme4”来对数据进行混合线性回归，我们要建立一个混合效应模型，让每个分类单元都有自己的随机截距：
library(tidyr)
library(Matrix)
library(lme4)
#先普通地线性回归看一看
m_lm <- lm(log(beakh) ~ log(wingl), data = d)
summary(m_lm)
#进行混合线性模型，1表示截距而taxon为随机因子
m_lmer <- lmer(log(beakh) ~ log(wingl) + (1 | taxon), data = d)
#利用这个混合模型进行预测，再拿预测值画回归线
d$predict_lmer <- predict(m_lmer)
ggplot(d, aes(log(wingl), log(beakh), colour = taxon)) +
geom_point(alpha = 0.1) +
geom_line(aes(y = predict_lmer))
我们发现各个元素分别回归的斜率已经相同了。 
我们可以将这些线条合并，从群落结构去考察：
#使用re.form = NA函数来合并taxon数据
d$predict_lmer_population <- predict(m_lmer, re.form = NA)
ggplot(d, aes(log(wingl), log(beakh), colour = taxon)) +
geom_point(alpha = 0.1) +
geom_line(aes(y = predict_lmer)) +
geom_line(aes(y = predict_lmer_population), colour = "black", size = 1)
我们也可以提取所有这些物种各个的随机截距
ranef(m_lmer)
或者查看这些随机截距的均值
round(mean(ranef(m_lmer)$taxon[, 1]), 2)
所以所以每个分类单元的截距估计值等于“固定效应”截距加上“随机”偏差。 最后我们可以查看回归效果：
summary(m_lmer)
##关于数据的查看上文已经提及，不再赘述：
#Linear mixed model fit by REML ['lmerMod']
#Formula: log(beakh) ~ log(wingl) + (1 | taxon)
# Data: d
#
#REML criterion at convergence: -3656.1
#
#Scaled residuals:
# Min 1Q Median 3Q Max
#-6.2724 -0.6086 -0.0306 0.6211 3.6835
#
#Random effects:
# Groups Name Variance Std.Dev.
# taxon (Intercept) 0.050586 0.22491
# Residual 0.004278 0.06541
#Number of obs: 1434, groups: taxon, 15
#
#Fixed effects:
# Estimate Std. Error t value
#(Intercept) -2.60848 0.18819 -13.86
#log(wingl) 1.18318 0.04232 27.96
#
#Correlation of Fixed Effects:
# (Intr)
#log(wingl) -0.951
一个小技巧，可以通过arm::display(m_lmer)(这里使用了arm包）命令来让我们的结果更加直观：
#lmer(formula = log(beakh) ~ log(wingl) + (1 | taxon),data = d)
# coef.est coef.se
#(Intercept) -2.61 0.19
#log(wingl) 1.18 0.04
#
#Error terms:
# Groups Name Std.Dev.
# taxon (Intercept) 0.22
# Residual 0.07
#---
#number of obs: 1434, groups: taxon, 15
#AIC = -3648.1, DIC = -3672.8
#deviance = -3664.4
不过需要注意的是，组的数量少于5个时就不建议使用混合线性模型了。
综上，对于lmer()下的混合线性回归，有：
fit = lmer(data = , formula = DV ~ Fixed_Factor + (Random_intercept + Random_Slope | Random_Factor))
其中formula为表达式，DV为因变量，Fixed_Factor为固定因子（自变量），Random_intercept为随机截距（不同群体的因变量分布不同，有人在起点，有人在终点），Random_Slope为随机斜率（不同群体受到固定因子的影响不同），Random_Factor为随机因子 。
# nlme::lme()
y ~ x, random = ~1 | group # varying intercepts
y ~ x, random = ~1 + x | group # varying intercepts and slopes
# 上述即为x受到了group的影响（斜率/效果上的）
y ~ x, random = list(group = pdDiag(~ x)) # uncorrelated varying intercepts and slopes
y ~ x, random = ~1 | group/subgroup # nested
# crossed... some structures possible but not easy,
# e.g. Pinheiro and Bates 2000 p163
# e.g. http://stackoverflow.com/questions/36643713/how-to-specify-different-random-effects-in-nlme-vs-lme4
# lme4::lmer()
y ~ x + (1 | group) # varying intercepts
y ~ x + (1 + x | group) # varying intercepts and slopes
y ~ x + (1 | group) + (x - 1 | group) # uncorrelated varying intercepts and slopes
y ~ x + (1 | group/subgroup) # nested
y ~ x + (1 | group1) + (1 | group2) # varying intercepts, crossed
y ~ x + (1 + x | group1) + (1 + x | group2) # varying intercepts and slopes, crossed
一群研究生正在尝试将log（青蛙密度）作为植被特征的函数来建模。在以下情况下（使用“lme4::lmer”）它们的模型会是什么样子？只给出具有随机截距的情况，以及具有随机截距和斜率的情况。 Jerry测量了6个独立池塘（“pond”）内1个样带（“transect”）的青蛙密度和植被特征。
# random intercepts
log(frog_dens) ~ vegetation +
(1 | pond) # exercise
# random slopes and intercepts:
log(frog_dens) ~ vegetation +
(1 + vegetation | pond) # exercise
lmerTest package
R语言中实现混合线性模型可以使用lme4包或lmerTest包，这里以lmerTest包为例，其基本表达式为：
fit = lmer(data = , formula = DV ~ Fixed_Factor + (Random_intercept + Random_Slope | Random_Factor))
其中data为我们要处理的数据集，formula为表达式，DV是因变量，Fixed_Factor是固定因子（自变量），Random_intercept是随机截距（可以理解为因变量分布的不同？），Random_Slope是随机斜率，即认为不同群体受固定因子的影响不同，Random_Factor是随机因子。 我们以politeness数据为例进行计算： politeness数据可以在github：https://github.com/usplos/Eye-movement-related/blob/master/politeness_data.csv中获得，本篇关于混合线性的模型的计算也源自该项目。该数据收集了若干被试（subject）的性别（gender），以及用不同的态度（attitude）在不同场合（scenario）下说话的音高（frequency）。 这是一个典型的被试内设计（7 * 2设计）。 先打开数据并加载相关r包：
politeness = readr::read_csv('/Users/desktop/r/politeness_data.csv')
library(lme4)
library(Matrix)
library(lmerTest)
#将scenairo变为因子型变量（离散型，原来是字符型）
politeness$scenario = factor(politeness$scenario)
politeness
进行混合线性计算：
#音高与固定因子态度和场合的关系，随机因子是性别与被试，它们基于的设计矩阵是态度，即为我们认为性别和被试对回归的影响的随机的
fit1 = lmer(frequency ~ scenario * attitude + attitude|subject + attitude|gender, data = politeness)
这时候系统提示：boundary (singular) fit: see ?isSingular这表明有些效应是彼此的线性组合或者某个地方的方差是0。当p»n(比样本更多的参数)时也会发生这种情况。这也意味着模型可能被过度拟合和/或遭受数值稳定性问题。
summary(fit1)
##得到结果：
#Linear mixed model fit by REML. t-tests use #Satterthwaite's method ['lmerModLmerTest']
#Formula: frequency ~ scenario * attitude + (1 + attitude | subject) +
# (1 + attitude | gender)
# Data: politeness
#
#REML criterion at convergence: 680.1
#
#Scaled residuals:
# Min 1Q Median 3Q Max
#-1.65342 -0.68640 -0.03677 0.50256 2.85422
##这里是随机效应的结果，variance为方差，Std.Dev为标准差，可以看出确实对不同的被试组合性别组而言，态度的影响是不同的
#Random effects:
# Groups Name Variance Std.Dev. Corr
# subject (Intercept) 6.037e+02 24.5696
# attitudepol 1.076e-02 0.1037 1.00
# gender (Intercept) 6.467e+03 80.4167
# attitudepol 1.118e+02 10.5749 -1.00
# Residual 6.101e+02 24.7001
#Number of obs: 83, groups: subject, 6; gender, 2
##固定效应的结果如下，我们发现场合3和4的音高是较显著的
#Fixed effects:
# Estimate Std. Error df t value Pr(>|t|)
#(Intercept) 180.767 58.615 1.065 3.084 0.18720
#scenario2 17.450 14.261 63.998 1.224 0.22557
#scenario3 46.667 14.261 63.998 3.272 0.00172 **
#scenario4 44.833 14.261 63.998 3.144 0.00253 **
#scenario5 16.800 14.261 63.998 1.178 0.24313
#scenario6 8.867 14.261 63.998 0.622 0.53631
#scenario7 18.133 14.261 63.998 1.272 0.20813
#attitudepol -9.717 16.102 9.583 -0.603 0.56023
#scenario2:attitudepol 15.133 20.168 63.998 0.750 0.45578
#scenario3:attitudepol -31.283 20.168 63.998 -1.551 0.12579
#scenario4:attitudepol -4.650 20.168 63.998 -0.231 0.81839
#scenario5:attitudepol -4.783 20.168 63.998 -0.237 0.81327
#scenario6:attitudepol -14.703 20.701 64.030 -0.710 0.48011
#scenario7:attitudepol -30.033 20.168 63.998 -1.489 0.14135
#---
#Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
#Correlation matrix not shown by default, as p = 14 > 12.
#Use print(x, correlation=TRUE) or
# vcov(x) if you need it
#
#convergence code: 0
#boundary (singular) fit: see ?isSingular
但是这里的固定效应不是主效应和交互作用，要查看主效应和交互作用需要用anova()函数得到；
anova(fit1)
#Type III Analysis of Variance Table with #Satterthwaite's method
# Sum Sq Mean Sq NumDF DenDF F value Pr(>F)
#scenario 19400.1 3233.4 6 64.006 5.2998 #0.000173 ***
#attitude 2789.7 2789.7 1 1.143 4.5725 0.253068
#scenario:attitude 4985.4 830.9 6 64.006 1.3619 0.243577
#---
#Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
可见只有场景的主效应显著，态度的主效应和交互作用都不显著。在上面建立的模型中，包含随机斜率和随机截距，但是注意到，有两个固定效应，是把两个固定效应及其交互作用全都作为随机效应，还是选其中部分作为随机效应呢？这里我们课题组的标准是：首先考虑全模型，即如下命令：
fitAll = lmer(frequency ~ scenario * attitude + (attitude * scenario|subject) + (attitude * scenario|gender), data = politeness)
然后报错，观测量的个数少于随机因子的个数，因此移除交互作用：
fitAll2 = lmer(frequency ~ scenario * attitude + (attitude + scenario|subject) + (attitude + scenario|gender), data = politeness)
结果模型似乎炸了，变成金字塔了，于是我们尝试移除一些随机因子：同时设立一个只有随机截距的零模型：
fitAll3_1 = lmer(frequency ~ scenario * attitude + (attitude|subject) + (attitude + scenario|gender), data = politeness);
fitAll3_2 = lmer(frequency ~ scenario * attitude + (scenario|subject) + (attitude + scenario|gender), data = politeness);
fitAll3_3 = lmer(frequency ~ scenario * attitude + (attitude+ scenario|subject) + (attitude|gender), data = politeness);
fitAll3_4 = lmer(frequency ~ scenario * attitude + (attitude + scenario|subject) + (scenario|gender), data = politeness)
fitZero = lmer(frequency ~ scenario * attitude + (1|subject) + (1|gender), data = politeness)
使用anova()分别比较各个模型和零模型的P值，发现都不显著，这时选取P值最小的作为实际在论文中使用的模型，即选取fitAll3_3。
An lmm Example
这里还是使用gapminder数据集 读取数据：
library(lme4)
library(tidyverse)
theme_set(theme_light())
gap <- gapminder::gapminder
gap <- mutate(gap, decade = (year - 1990)/10,
log_gdp_percap_cent = log(gdpPercap) - mean(log(gdpPercap)))
我们增加了以1990年为中心的十年新列，并增加了一个“log_gdp_percap_cent”列，即以平均值为中心的人均gdp的对数列，这样可以提升结果的准确性。 在开始建模之前，让我们先画一个数据图。
ggplot(gap, aes(log_gdp_percap_cent, lifeExp, colour = continent)) +
geom_point(alpha = 0.3) +
geom_smooth(aes(group = country), method = "lm", se = FALSE, alpha = 0.5, lwd = 0.5)
我们已经将一个更简单的模型拟合到这个数据集。让我们试着拟合一个线性混合效应模型（使用lmer()），根据“log_gdp_percap_cent”和“decade”预测“lifeExp”。根据上面的情节和你对世界的理解，决定是只允许截距变化还是截距和斜率因国家而异。
m <- lmer(lifeExp ~
log_gdp_percap_cent + decade + # exercise
(log_gdp_percap_cent + decade | country), data = gap) # exercise
arm::display(m)
# lmer(formula = lifeExp ~ log_gdp_percap_cent + decade + (log_gdp_percap_cent +
# decade | country), data = gap)
# coef.est coef.se
# (Intercept) 62.02 0.64
# log_gdp_percap_cent 4.29 0.38
# decade 2.56 0.18
# Error terms:
# Groups Name Std.Dev. Corr
# country (Intercept) 7.09
# log_gdp_percap_cent 3.21 -0.17
# decade 2.01 0.01 -0.72
# Residual 1.96
# ---
# number of obs: 1704, groups: country, 142
# AIC = 8410.1, DIC = 8387.2
# deviance = 8388.7
国家在各大洲之间相互依存。尝试拟合上述模型的另一个版本，其中随机效果因大陆和嵌套在大陆中的国家而异：
m2 <- lmer(lifeExp ~
log_gdp_percap_cent + decade + # exercise
(log_gdp_percap_cent + decade | continent/country), data = gap) # exercise
arm::display(m2)
# lmer(formula = lifeExp ~ log_gdp_percap_cent + decade + (log_gdp_percap_cent +
# decade | continent/country), data = gap)
# coef.est coef.se
# (Intercept) 64.92 2.84
# log_gdp_percap_cent 3.38 0.46
# decade 2.59 0.43
# Error terms:
# Groups Name Std.Dev.
# country:continent (Intercept) 5.14
# log_gdp_percap_cent 2.66
# decade 1.66
# continent (Intercept) 5.97
# log_gdp_percap_cent 0.59
# decade 0.86
# Residual 1.97
# Corr
# -0.14
# 0.04 -0.67
# -1.00
# -0.36 0.36
# ---
# number of obs: 1704, groups: country:continent, 142; continent, 5
# AIC = 8317.9, DIC = 8292.6
# deviance = 8289.2
看看你拟合的第一个模型的拟合值和残差。 你可能想把它们按大陆分开，让它们更容易看。可以使用“broom:：augment()`并使用ggplot自己绘制它们，也可以像我们在方差结构练习中使用的那样使用快捷语法。 还可以根据模型中的预测值和数据集中未包含在模型中的任何其他投影仪绘制残差。你觉得这些怎么样？
plot(m, resid(.) ~ fitted(.) | continent, abline = 0)
plot(m, resid(.) ~ log(pop) | continent, abline = 0) # exercise
plot(m, resid(.) ~ decade | continent, abline = 0) # exercise
plot(m, resid(.) ~ log_gdp_percap_cent | continent, abline = 0) # exercise
检查随机效应是否近似正态分布：
re <- ranef(m)
qqnorm(re$country[,"(Intercept)"])
qqline(re$country[,"(Intercept)"])
qqnorm(re$country[,"log_gdp_percap_cent"])
qqline(re$country[,"log_gdp_percap_cent"])
尝试绘制模型预测。让我们关注人均GDP的影响。因此，我们必须将预测值“decade”设置为某个值。我们把它设为’0’，它代表1990年，因为我们是通过减去1990来计算这个列的。
newdata <- mutate(gap, decade = 0)
newdata$predict <- predict(m, newdata = newdata)
# 绘图
ggplot(newdata, aes(log_gdp_percap_cent, lifeExp, colour = continent)) +
geom_line(aes(y = predict, group = country), alpha = 0.5)
让我们添加一个组级预测器，代表每个国家人均GDP的平均对数。同时，让我们把每个国家人均GDP中心化：
gap <- group_by(gap, country) %>%
mutate(mean_log_gdp_percap_cent = mean(log_gdp_percap_cent),
log_gdp_percap_group_cent = log_gdp_percap_cent - mean(log_gdp_percap_cent)) %>%
ungroup()
现在将其添加到您适合的初始模型中。这个模型不会收敛于大陆内部的嵌套随机效应。所以，让影响因国家而异:
m3 <- lmer(lifeExp ~ log_gdp_percap_group_cent + decade +
mean_log_gdp_percap_cent +
(log_gdp_percap_cent + decade | country), data = gap)
# 绘图
newdata <- mutate(gap, decade = 0)
newdata$predict3 <- predict(m3, newdata = newdata)
ggplot(newdata, aes(log_gdp_percap_cent, lifeExp, colour = continent)) +
geom_line(aes(y = predict3, group = country), alpha = 0.5)
和上一个模型对比一下：
arm::display(m)
# lmer(formula = lifeExp ~ log_gdp_percap_cent + decade + (log_gdp_percap_cent +
# decade | country), data = gap)
# coef.est coef.se
# (Intercept) 62.02 0.64
# log_gdp_percap_cent 4.29 0.38
# decade 2.56 0.18
# Error terms:
# Groups Name Std.Dev. Corr
# country (Intercept) 7.09
# log_gdp_percap_cent 3.21 -0.17
# decade 2.01 0.01 -0.72
# Residual 1.96
# ---
# number of obs: 1704, groups: country, 142
# AIC = 8410.1, DIC = 8387.2
# deviance = 8388.7
arm::display(m3)
# lmer(formula = lifeExp ~ log_gdp_percap_group_cent + decade +
# mean_log_gdp_percap_cent + (log_gdp_percap_cent + decade |
# country), data = gap)
# coef.est coef.se
# (Intercept) 62.18 0.54
# log_gdp_percap_group_cent 3.05 0.40
# decade 2.77 0.18
# mean_log_gdp_percap_cent 8.15 0.51
# Error terms:
# Groups Name Std.Dev. Corr
# country (Intercept) 5.86
# log_gdp_percap_cent 3.05 -0.23
# decade 1.93 0.20 -0.68
# Residual 1.95
# ---
# number of obs: 1704, groups: country, 142
# AIC = 8341.7, DIC = 8317.1
# deviance = 8318.4
接下来进行模型解释
round(fixef(m3)["decade"], 1)
# decade
# 2.8
# 查看每十年预期寿命增长的95%置信区间
fe <- fixef(m3)["decade"] # exercise
se <- arm::se.fixef(m3)["decade"] # exercise
fe + c(-1.96, 1.96) * se # exercise
# [1] 2.421557 3.110131
人均国内生产总值的影响是在国家内部还是在国家之间哪个更强？
arm::display(m3)
# lmer(formula = lifeExp ~ log_gdp_percap_group_cent + decade +
# mean_log_gdp_percap_cent + (log_gdp_percap_cent + decade |
# country), data = gap)
# coef.est coef.se
# (Intercept) 62.18 0.54
# log_gdp_percap_group_cent 3.05 0.40
# decade 2.77 0.18
# mean_log_gdp_percap_cent 8.15 0.51
# Error terms:
# Groups Name Std.Dev. Corr
# country (Intercept) 5.86
# log_gdp_percap_cent 3.05 -0.23
# decade 1.93 0.20 -0.68
# Residual 1.95
# ---
# number of obs: 1704, groups: country, 142
# AIC = 8341.7, DIC = 8317.1
# deviance = 8318.4
除去国内生产总值的差异，加拿大、中国和津巴布韦每十年预期寿命的估计变化是多少?(提示:要么使用’ coef() ‘，要么结合使用’ fixef() ‘和’ ranef() ‘的固定和随机效果。看看输出，这里不需要用R代码提取值。)
re <- coef(m3)$country # exercise
re$country <- row.names(re) # exercise
filter(re, country == "Canada") %>% pull(decade)
# [1] 1.497968
filter(re, country == "China") %>% pull(decade)
# [1] 6.883605
filter(re, country == "Zimbabwe") %>% pull(decade)
# [1] -1.362036
Geospatial autocorrelation——based on nlme
学习通过nlme中的相关结构识别和处理空间自相关。我们将使用nlme包中的一个示例数据集。这个数据集代表了在不同纬度和经度采集的不同小麦品种的产量。
library(nlme)
library(tidyverse)
d <- nlme::Wheat2
glimpse(d)
ggplot(d, aes(longitude, latitude, size = yield, colour = variety)) +
geom_point()
到目前为止，我们已经使用nlme包中的lme函数来拟合线性混合效应模型。这个软件包还具有函数“gls”，它允许您在拟合线性模型时使用nlme的特性而不产生随机效果。
m1 <- gls(yield ~ variety - 1, data = d)
m1
# Generalized least squares fit by REML
# Model: yield ~ variety - 1
# Data: d
# Log-restricted-likelihood: -620.3709
# Coefficients:
# varietyARAPAHOE varietyBRULE
# 29.4375 26.0750
# varietyBUCKSKIN varietyCENTURA
# 25.5625 21.6500
# varietyCENTURK78 varietyCHEYENNE
# 30.3000 28.0625
# varietyCODY varietyCOLT
# 21.2125 27.0000
# varietyGAGE varietyHOMESTEAD
# 24.5125 27.6375
# varietyKS831374 varietyLANCER
# 24.1250 28.5625
# varietyLANCOTA varietyNE83404
# 26.5500 27.3875
# varietyNE83406 varietyNE83407
# 24.2750 22.6875
# varietyNE83432 varietyNE83498
# 19.7250 30.1250
# varietyNE83T12 varietyNE84557
# 21.5625 20.5250
# varietyNE85556 varietyNE85623
# 26.3875 21.7250
# varietyNE86482 varietyNE86501
# 24.2875 30.9375
# varietyNE86503 varietyNE86507
# 32.6500 23.7875
# varietyNE86509 varietyNE86527
# 26.8500 22.0125
# varietyNE86582 varietyNE86606
# 24.5375 29.7625
# varietyNE86607 varietyNE86T666
# 29.3250 21.5375
# varietyNE87403 varietyNE87408
# 25.1250 26.3000
# varietyNE87409 varietyNE87446
# 21.3750 27.6750
# varietyNE87451 varietyNE87457
# 24.6125 23.9125
# varietyNE87463 varietyNE87499
# 25.9125 20.4125
# varietyNE87512 varietyNE87513
# 23.2500 26.8125
# varietyNE87522 varietyNE87612
# 25.0000 21.8000
# varietyNE87613 varietyNE87615
# 29.4000 25.6875
# varietyNE87619 varietyNE87627
# 31.2625 23.2250
# varietyNORKAN varietyREDLAND
# 24.4125 30.5000
# varietyROUGHRIDER varietySCOUT66
# 21.1875 27.5250
# varietySIOUXLAND varietyTAM107
# 30.1125 28.4000
# varietyTAM200 varietyVONA
# 21.2375 23.6000
# Degrees of freedom: 224 total; 168 residual
# Residual standard error: 7.711373
我们可以自己提取和绘制空间上的残差（通过颜色）。
d$res <- as.numeric(residuals(m1))
ggplot(d, aes(longitude, latitude, colour = res)) +
geom_point(size = 5) + scale_color_gradient2()
我们可以清楚地看到，残差具有空间聚集模式。为什么这是个问题？ nlme软件包附带了一个用于绘制半变异函数的内置函数。这表示在彼此距离增加的情况下，残差之间的平均平方差的一半。所以这和相关性成反比。小值意味着残差彼此非常相似。这是空间统计中的一个常见情节，你可以在网上找到很多关于这个主题的参考资料。
plot(Variogram(m1, form = ~ latitude + longitude, data = d))
如果我们看半变异函数，我们可以猜测一个范围值和掘金效应的良好初始值。对于“nlme:：corsphere()`相关结构，nugget表示截距值，range表示半变异函数达到1的距离。 通过观察上面的半变异函数，我们可以看到这些值应该是什么。我们将给相关函数的起始值接近我们所需要的 期待。
m2 <- update(m1,
corr = corSpher(c(30, 0.2), form = ~ latitude + longitude, nugget = TRUE))
m2
事实上，这是一个例子，如果我们不给相关结构适当的起始值，它会得到错误的答案：
m3 <- update(m1,
corr = corSpher(form = ~ latitude + longitude, nugget = TRUE))
m3
让我们试着在空间上绘制残差，并制作另一个半变异函数。请再次注意，为了将相关结构合并到残差计算中，使用type=“normalized”非常重要。
d$res2 <- as.numeric(residuals(m2, type = "normalized"))
ggplot(d, aes(longitude, latitude, colour = res2)) + geom_point(size = 5) +
scale_color_gradient2()
plot(Variogram(m2, form = ~ latitude + longitude, resType = "normalized", data = d))
我们还可以查看他们的deltaAIC：
bbmle::AICtab(m1, m2)
# dAIC df
# m2 0.0 59
# m1 169.3 57
这种方法建模空间相关性的一个缺点是，没有简单的方法来提取预测的空间曲面。另一种处理空间自相关的方法是用GAM将空间过程建模为二维光滑项。GAM超出了本次研讨会的范围，但重要的是要知道它们的存在。 GAM和GLMs一样，只是可以允许预测因子沿着平滑的摆动线。在拟合算法中可以客观地确定摆动程度。 作为演示，我们将用GAM安装此模型的一个版本。在R中安装这些模型的主要包是mgcv。我们将用最大似然法修正“gls”模型，以便与GAM进行比较。
library(mgcv)
m1_ml <- gls(yield ~ variety - 1, data = d, method = "ML")
m_gam1 <- gam(yield ~ variety - 1, data = d) # the same
bbmle::AICtab(m_gam1, m1_ml)
m_gam2 <- gam(yield ~ variety - 1 + te(latitude, longitude), data = d)
bbmle::AICtab(m_gam1, m_gam2)
# dAIC df
# m_gam1 0 57
# m1_ml 0 57
# dAIC df
# m_gam2 0.0 75.2
# m_gam1 269.8 57
我们现在可以绘制出一个空间预测图，并像以前一样在空间上检查残差：：
plot(m_gam2, pers = TRUE)
Generalized Linear Model (glm)
在R语言中可以通过glm()函数解决广义线性模型，此处我们运用logistic模型进行广义线性回归：
glm(formula,family = gaussian,data,...)
其中formula为要拟合的模型，而family为分布族，包括正态分布、泊松分布、二项分布等…分布族可以通过link=来选择连接函数，data为数据框。 首先导入数据，数据来源于教材《多元线性回归与R》：
data = readr::read_csv('/Users/desktop/r/result.csv')
#其中x1为视力状况，1是好0是不好；x2为年龄；x3为驾车教育，1是有0是没有；y为是否出过事故，1是有0是没有
data
在这里y是因变量，只有两个值，因此我们可以把它看作是成功概率为$p$的Bernoulli试验的结果（这种方法在进行二分类问题时很有用！），现在用Logistic回归模型进行分析： 假定模型为： \(\textup{ln}(\frac{p}{1-p})=\beta _0+\beta _1x_1+\beta _2x_2+\beta _3x_3\) 有：
logit.glm <- glm(y ~ X1 + X2 + X3, family = binomial,data = data)
summary(logit.glm)
#glm(formula = y ~ X1 + X2 + X3, family = binomial, data = data)
#
#Deviance Residuals:
# Min 1Q Median 3Q Max
#-1.5636 -0.9131 -0.7892 0.9637 1.6000
#
#Coefficients:
# Estimate Std. Error z value Pr(>|z|)
#(Intercept) 0.597610 0.894831 0.668 0.5042
#X1 -1.496084 0.704861 -2.123 0.0338 *
#X2 -0.001595 0.016758 -0.095 0.9242
#X3 0.315865 0.701093 0.451 0.6523
#---
#Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
#
#(Dispersion parameter for binomial family taken to be 1)
#
# Null deviance: 62.183 on 44 degrees of freedom
#Residual deviance: 57.026 on 41 degrees of freedom
#AIC: 65.026
#
#Number of Fisher Scoring iterations: 4
由此得到初步的Logistic回归模型： \(p=\frac{\textup{exp}(0.598-1.496x_1-0.002x_2+0.316x_3)}{1+\textup{exp}(0.598-1.496x_1-0.002x_2+0.316x_3)}\) 即为： \(\textup{Logit}(p)=0.598-1.496x_1-0.002x_2+0.316x_3\) 由于参数$\beta _2$和$\beta _3$没有通过P值检验，可通过step()作变量筛选，不断筛选出AIC值最小的结果：
logit.step <- step(logit.glm, direction = "both")
summary(logit.step)
#glm(formula = y ~ X1, family = binomial, data = data)
#
#Deviance Residuals:
# Min 1Q Median 3Q Max
#-1.4490 -0.8782 -0.8782 0.9282 1.5096
#
#Coefficients:
# Estimate Std. Error z value Pr(>|z|)
#(Intercept) 0.6190 0.4688 1.320 0.1867
#X1 -1.3728 0.6353 -2.161 0.0307 *
#---
#Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
#
#(Dispersion parameter for binomial family taken to be 1)
#
# Null deviance: 62.183 on 44 degrees of freedom
#Residual deviance: 57.241 on 43 degrees of freedom
#AIC: 61.241
#
#Number of Fisher Scoring iterations: 4
可以得到新的回归方程为： \(p=\frac{\textup{exp}(0.619-1.373x_1)}{1+\textup{exp}(0.619-1.373x_1)}\) 可见$p_1=0.32,p_2=0.65$，即实力有问题的司机发生交通事故的概率是正常司机的两倍！
Excessive dispersion in Poisson and binomial distributions
在拟合中可能出错的一个常见问题是，数据中的可变性比分布所允许的要大。对于正态分布、Gamma分布或负二项分布来说，这不是问题，因为这些分布有一个参数，使它们可以根据需要窄或宽。 但是一些分布，特别是泊松分布和二项式分布（有多个样本），对于给定的平均值假设了一个固定的可变性水平。但现实世界很混乱，情况并非总是如此。让我们看看这意味着什么。 我们将从生成已知泊松分布过大的计数数据开始。
library(ggplot2)
library(dplyr)
set.seed(111)
N <- 500
x <- runif(N, -1, 1)
a <- 0.5
b <- 1.3
d <- data_frame(x = x)
inverse_logit <- function(x) plogis(x)
y_true <- exp(a + b * x)
rqpois <- function (n, lambda, d = 1) { # generate random quasipoisson values
if (d == 1)
rpois(n, lambda)
else
rnbinom(n, size = (lambda / (d - 1)), mu = lambda)
}
set.seed(1234)
y <- rqpois(N, lambda = y_true, d = 5)
plot(x, y)
让我们看看我们刚刚创建的数据。 在下面的图中，虚线表示一对一的线（泊松），蓝线表示方差与平均值成线性比例，而不是一对一（此处的真实关系为准泊松），红线表示方差与平均值成二次比例（负二项式）。 为了绘制这个图，我把x轴上的值分成了15个箱子。
d$y <- y
d$x_group <- findInterval(d$x, seq(min(d$x), max(d$x), length.out = 15))
group_by(d, x_group) %>%
summarise(m = mean(y), v = var(y)) %>%
ggplot(aes(m, v)) +
geom_smooth(method = "lm",
formula = y ~ x - 1, se = F, colour = "blue") +
geom_smooth(method = "lm",
formula = y ~ I(x^2) + offset(x) - 1, colour = "red", se = F) +
geom_abline(intercept = 0, slope = 1, lty = 2) +
geom_point()
让我们用泊松分布和日志链接拟合GLM，即使我们知道数据被过度显示。
(m_poisson <- glm(y ~ x, family = poisson(link = "log"), data = d))
# Call: glm(formula = y ~ x, family = poisson(link = "log"), data = d)
# Coefficients:
# (Intercept) x
# 0.4951 1.2743
# Degrees of Freedom: 499 Total (i.e. Null); 498 Residual
# Null Deviance: 2274
# Residual Deviance: 1820 AIC: 2566
ggeffects::ggpredict(m_poisson, "x", full.data = TRUE) %>%
ggplot(aes(x, predicted)) +
geom_line(colour = "red") +
geom_ribbon(aes(ymin = conf.low, ymax = conf.high), alpha = .2) +
geom_point()
如果我们看残差，它们应该和预测的平均值保持不变。在残差中很难看到这些模式。虽然我们知道有过度分散，但这里没有太多可看的东西。
plot(fitted(m_poisson), residuals(m_poisson))
可以使用离散验证：
AER::dispersiontest(m_poisson)
# Overdispersion test
# data: m_poisson
# z = 6.0335, p-value = 8.023e-10
# alternative hypothesis: true dispersion is greater than 1
# sample estimates:
# dispersion
# 4.805502
p < 0.01，显著离散。 为了解决过度分散的问题，我们将用拟泊松族对模型进行修正。这只是估计数据的过度分散程度，并适当地调整参数估计的标准误差。 但这意味着我们离开了可能性的世界，不能简单地计算AIC之类的值。（有qAIC等）
(m_qp <- glm(y ~ x, family = quasipoisson(link = "log"), data = d))
# Call: glm(formula = y ~ x, family = quasipoisson(link = "log"), data = d)
# Coefficients:
# (Intercept) x
# 0.4951 1.2743
# Degrees of Freedom: 499 Total (i.e. Null); 498 Residual
# Null Deviance: 2274
# Residual Deviance: 1820 AIC: NA
confint(m_qp)
# 2.5 % 97.5 %
# (Intercept) 0.3219956 0.6566294
# x 1.0031108 1.5555660
confint(m_poisson)
# 2.5 % 97.5 %
# (Intercept) 0.4176408 0.5701738
# x 1.1493870 1.4012934
如果我们有重复的试验，我们可以得到二项分布的过度分散的数据。（如果我们是模拟单次试验，即0和1，就不存在过度分散的问题。） 什么时候会这样？举个例子，也许你是在测量青蛙在一个给定的水箱中存活的比例。 在这个例子中，假设每个水箱有30只青蛙，共40个水箱。 让我们模拟一下，在数据过度分散的情况下，以及在没有过度分散的情况下，一些实验后存活下来的青蛙的比例：
set.seed(1)
n <- 30
y <- emdbook::rbetabinom(40, 0.5, size = n, theta=1)
y2 <- rbinom(40, 0.5, size = n)
par(mfrow = c(2, 1))
plot(table(y/n)/length(y), xlim = c(0, 1), ylab = "prop.",
main = "Overdispersed")
plot(table(y2/n)/length(y2), xlim = c(0, 1), ylab = "prop.",
main = "Not overdispersed")
我们在这里看到的是每个水箱中存活的青蛙比例的柱状图。请注意，与纯二项分布相比，过度分散场景中的值要分散得多。 让我们用二项误差分布拟合的GLM和准多项式分布允许过度分布的GLM来绘制估计的平均存活比例。
par(mfrow = c(1, 1))
plot(table(y/n)/length(y), xlim = c(0, 1), ylab = "prop.", col = "grey80")
abline(v = 0.5, col = "black", lwd = 10)
ss <- rep(n, length(y))
m <- glm(y/n ~ 1, family = binomial(link = "logit"),
weights = ss)
ci <- inverse_logit(confint(m))
abline(v = ci, col = "red", lwd = 5)
m2 <- glm(y/n ~ 1, family = quasibinomial(link = "logit"),
weights = rep(n, length(y)))
ci2 <- inverse_logit(confint(m2))
abline(v = ci2, col = "blue", lwd = 5)
在上面的图中，真实值由粗黑色垂直线表示。 二项式GLM 95%置信区间用红色垂直线表示。 拟多项式GLM 95%置信区间用蓝色垂直线表示。 注意，如果不考虑过度分散，我们的置信区间看起来太小了。 由于这是一个关于GLMMs的课程，处理过度分散的另一种方法是为每个水箱建立一个随机拦截模型。但我们现在还不涉及这个。
Predicting the survival rate of Titanic passengers
以下数据集来自Kaggle。它代表了泰坦尼克号上的乘客，无论他们是否幸存，以及他们的一些特征。我们将使用代表乘客年龄、乘客性别（女性=1，男性=0）以及他们为机票支付的票价的列。我们将使用这些特征来预测乘客是否幸存（是=1，否=0）。
library(tidyverse)
d <- read_csv("data/raw/titanic.csv")
d <- mutate(d, female = ifelse(Sex == "female", 1, 0))
names(d) <- tolower(names(d))
d <- select(d, survived, age, fare, female) %>% na.omit %>% as_data_frame()
d
# View(d)
head(d)
# A tibble: 6 x 4
# survived age fare female
# <dbl> <dbl> <dbl> <dbl>
# 1 0 22 7.25 0
# 2 1 38 71.3 1
# 3 1 26 7.92 1
# 4 1 35 53.1 1
# 5 0 35 8.05 0
# 6 0 54 51.9 0
先花几分钟的时间以图形方式浏览数据。当你对这些数据建模时，你看到了什么样的模式，你会期望什么？ 年龄与幸存情况
ggplot(d, aes(age, survived, colour = as.factor(female), size = fare)) + # exercise
geom_point(position = position_jitter(height = 0.2)) # exercise
票价与幸存情况
ggplot(d, aes(fare, survived, colour = as.factor(female), size = age)) + # exercise
geom_point(position = position_jitter(height = 0.2)) # exercise
性别与幸存情况
ggplot(d, aes(age, survived, colour = log(fare))) + # exercise
geom_point(position = position_jitter(height = 0.2)) + # exercise
facet_wrap(~female) # exercise
从一个简单的模型开始，有3个预测因子，没有交互作用。我们正在处理二进制数据作为响应。什么样的分布和联系才有意义？
m <- glm(survived ~
age + fare + female, data = d, family = binomial(link = "logit")) # exercise
arm::display(m)
# glm(formula = survived ~ age + fare + female, family = binomial(link = "logit"),
# data = d)
# coef.est coef.se
# (Intercept) -1.41 0.23
# age -0.01 0.01
# fare 0.01 0.00
# female 2.35 0.19
# ---
# n = 714, k = 4
# residual deviance = 716.1, null deviance = 964.5 (difference = 248.4)
plot(ggeffects::ggpredict(m)) %>%
cowplot::plot_grid(plotlist = .)
sjPlot::plot_model(m, type = "est")
请注意，sjPlot::plot_model()显示的是优势比，而不是我们在summary()或arm::display()`中看到的对数优势比。 在这个初始模型中，女性乘客的存活几率比男性乘客大多少？ 现在尝试添加所有双向交互。记住这是有捷径的。尝试通过AIC将此模型与没有任何交互的模型进行比较。
m2 <- glm(survived ~
(age + fare + female) ^ 2, data = d, family = binomial(link = "logit")) # exercise
arm::display(m2)
# glm(formula = survived ~ (age + fare + female)^2, family = binomial(link = "logit"),
# data = d)
# coef.est coef.se
# (Intercept) -0.66 0.35
# age -0.03 0.01
# fare 0.00 0.01
# female 0.98 0.45
# age:fare 0.00 0.00
# age:female 0.04 0.01
# fare:female 0.01 0.01
# ---
# n = 714, k = 7
bbmle::AICtab(m, m2) # exercise
# dAIC df
# m2 0 7
# m 7 4
sjPlot::plot_model(m2, type = "est")
在上述模型中，大多数系数看起来都很小。为什么？ 接着可以进行数据标准化： 现在，我们将用已缩放（除以2个标准差）和居中（减去它们的平均值）的预测值版本重新调整上述模型。对于二进制预测器（female），变量将以其平均值为中心，但不按比例缩放。该标准化程序将使系数的大小近似可比。
d$age_scaled <- arm::rescale(d$age)
d$fare_scaled <- arm::rescale(d$fare)
d$female_centered <- arm::rescale(d$female)
# or
# d$female_centered <- d$female - mean(d$female) # same thing
# or:
# m3 <- arm::standardize(m2)
# but we will use arm::rescale so it is clear what we are doing
现在用所有双向交互重新调整模型，但使用年龄和票价的缩放版本：age_scaled和fare_scaled。这次使用“female”的0-1版本：
m3 <- glm(survived ~
(age_scaled + fare_scaled + female)^2, data = d, family = binomial()) # exercise
arm::display(m3)
# glm(formula = survived ~ (age_scaled + fare_scaled + female)^2,
# family = binomial(), data = d)
# coef.est coef.se
# (Intercept) -1.33 0.12
# age_scaled -0.72 0.25
# fare_scaled 0.95 0.32
# female 2.51 0.21
# age_scaled:fare_scaled 0.73 0.60
# age_scaled:female 1.04 0.41
# fare_scaled:female 1.40 0.77
# ---
# n = 714, k = 7
# residual deviance = 703.0, null deviance = 964.5 (difference = 261.5)
sjPlot::plot_model(m3, type = "est")
现在拟合同样的模型，但使用female_centered：
m4 <- glm(survived ~
(age_scaled + fare_scaled + female_centered)^2, data = d, family = binomial()) # exercise
arm::display(m4)
# glm(formula = survived ~ (age_scaled + fare_scaled + female_centered)^2,
# family = binomial(), data = d)
# coef.est coef.se
# (Intercept) -0.42 0.10
# age_scaled -0.34 0.20
# fare_scaled 1.46 0.33
# female_centered 2.51 0.21
# age_scaled:fare_scaled 0.73 0.60
# age_scaled:female_centered 1.04 0.41
# fare_scaled:female_centered 1.40 0.77
# ---
# n = 714, k = 7
# residual deviance = 703.0, null deviance = 964.5 (difference = 261.5)
sjPlot::plot_model(m4, type = "est")
解读标准化模型 如果泰坦尼克号上的一个人花了250美元买票，那么与另一个花了150美元的人相比，他活下来的几率有多大？（请注意，其中一个标准化预测值的单位变化表示原始变量的2个标准偏差。fare的两个标准差约为100美元）。即：
round(sd(d$fare) * 2, 1)
# [1] 105.8
我们如何使用“m4”中的系数来确定为一个男人和一个女人的票多支付大约100美元的效果？ 请记住，这些模型所做的预测是相同的，只是它们的参数化略有不同。
exp(coef(m4)[["fare_scaled"]] + coef(m4)[["fare_scaled:female_centered"]] * 0.63) # exercise
# [1] 10.38939
exp(coef(m4)[["fare_scaled"]] + coef(m4)[["fare_scaled:female_centered"]] * -0.37) # exercise
# [1] 2.564542
Model selection in multiple regression（MuMIn）
翻译自谷歌，似乎是MuMIn包作者本人写的教程，侵删。
MuMIn是一个相当灵活的R包，用于对各种线性模型（包括普通线性回归和广义混合模型）进行模型选择和模型平均。如果您不知道后者是什么，请不必担心，本教程仍然有用。我将假定你对R有点熟悉，并且知道以下内容：＃用于向R代码添加注释，R脚本的使用与安装，工作目录的指定，以及如何读写数据文件。如果不是这样，你可能需要再学点基础的。在继续本教程之前，请确保已安装MuMIn和R软件包lme4。您可能还需要下载两个用逗号分隔的示例数据文件：example data.csv和Westslope.csv。包含以下所有代码的脚本位于此处，并且此网站的pdf副本位于此处。
为了演示MuMIn中的许多有用功能，让我们使用示例数据。
#直接从网上下载数据
dater <- read.csv("https://sites.google.com/site/rforfishandwildlifegrads/home/mumin_usage_examples/Example%20data.csv?attredirects=0&d=1")
#或者下载后从本地读取
#dater<-read.csv("Example data.csv")
#简单看看数据
head(dater)
数据包括3个响应变量：数量，密度和存在度。以及5个解释变量：elev（海拔），slope（坡度），面积，距离（至最近的种群的）和覆盖率（％）。一个好的做法是使用summary来查看关于数据的摘要，以确保没有任何丢失的数据。
#确保所有数值都没有丢失
summary(dater)
使用“require”或“library”功能加载程序包。
#加载“MuMIn包”
require(MuMIn)
接下来应该做的一件事是更改R函数处理丢失数据的方式的全局选项。通过进行此更改，如果缺少数据，该功能将不起作用。如果你使用“dredge”功能进行探索性数据分析，则这是必需的。
#更改“na. action”函数，使得有NA时会报错
options(na.action = "na.fail")
好，我们准备出发了。让我们拟合四个解释动物密度变化的候选模型。理想情况下，这些模型将代表假设。根据响应的性质，我们将普通线性回归与“lm”函数结合使用。
#首先，拟合4个候选线性模型以解释密度变化
mod1<-lm(density~distance+elev, data = dater)
mod2<-lm(density~slope+pct.cover, data = dater)
mod3<-lm(density~slope+distance, data = dater)
mod4<-lm(density~slope+distance+elev, data = dater)
现在，我们可以使用mod.sel或model.sel函数（相同）进行模型选择。默认的模型选择标准是Akaike的信息标准（AIC），并带有较小的样本偏差调整AICc。 在这里，我们将创建一个包含所有模型选择信息的对象“out.put”。
#使用mod.sel函数进行模型选择
#并将输出放入对象out.put
out.put<-mod.sel(mod1,mod2,mod3,mod4)
#看看结果如何，这会是带有小样本偏差调整AICc和AIC
out.put
> Model selection table
(Int) dst elv pct.cvr slp df logLik AICc delta
mod1 -0.013280 5.195e-05 1.832e-05 4 863.907 -1719.7 0.00
mod4 -0.013080 5.181e-05 2.002e-05 -0.01096 5 863.944 -1717.6 2.01
mod3 -0.012920 5.207e-05 0.08634 4 860.130 -1712.1 7.55
mod2 0.003614 2.777e-05 0.05374 4 819.492 -1630.8 88.83
weight
mod1 0.720
mod4 0.264
mod3 0.016
mod2 0.000
Models ranked by AICc(x)
结果显示在上方>后，模型从最佳（顶部）到最差（底部）分类。 看起来像mod1最好,包含距离（dst），仰角（elev）两个预测变量，截距权重为0.72。 密度变化的最好解释（假设）是0.72 / 0.264 = 2.72次。请注意，该函数不使用全名作为模型参数，而是创建缩写。 我们经常需要通过使用某些规则指定模型的置信度集来表达模型选择的不确定性。在这里，我们可以使用子集函数来选择符合条件的模型。请注意，权重针对所选模型进行了重新标准化。即，将它们调整为加在一起。
#使用子集函数创建模型的置信度集
#选择deltaAICc小于5的模型
#重要提示：权重已重新归一化！
subset(out.put, delta <5)
> Model selection table
(Int) dst elv slp df logLik AICc delta weight
mod1 -0.01328 5.195e-05 1.832e-05 4 863.907 -1719.7 0.00 0.732
mod4 -0.01308 5.181e-05 2.002e-05 -0.01096 5 863.944 -1717.6 2.01 0.268
Models ranked by AICc(x)
#使用Royall的1/8规则选择模型以获取证据强度
#重要提示：权重已重新归一化！
subset(out.put, 1/8 < weight/max(out.put$weight))
> Model selection table
(Int) dst elv slp df logLik AICc delta weight
mod1 -0.01328 5.195e-05 1.832e-05 4 863.907 -1719.7 0.00 0.732
mod4 -0.01308 5.181e-05 2.002e-05 -0.01096 5 863.944 -1717.6 2.01 0.268
Models ranked by AICc(x)
与上述delta < 5并无太大差异。让我们尝试基于模型权重的总和的另一个条件。
#选择95％累积权重的模型
#重要提示：权重已重新归一化！
> Model selection table
(Int) dst elv df logLik AICc delta weight
mod1 -0.01328 5.195e-05 1.832e-05 4 863.907 -1719.7 0 1
Models ranked by AICc(x)
在大多数情况下，你希望将模型选择结果包括在报告，出版物或论文的表格中。在这里，我们需要将mod.sel函数的输出强制转换为data.frame。该数据帧的前c个元素包含我们想要的内容。我怎么知道这些的呢？我首先创建了数据框，然后使用“str”函数查看数据框中的元素。
#将对象强制输出到数据帧中
#out.put中的6-10行的元素中有我们想要的内容
sel.table<-as.data.frame(out.put)[6:10]
sel.table
> df logLik AICc delta weight
mod1 4 863.9067 -1719.653 0.000000 7.196856e-01
mod4 5 863.9437 -1717.646 2.006937 2.638408e-01
mod3 4 860.1296 -1712.099 7.554120 1.647353e-02
mod2 4 819.4916 -1630.823 88.830152 3.697604e-20
这有点混乱，无法准备任何报告。让我们先整理一下。
#稍微清理一下，用round函数四舍五入
sel.table[,2:3]<- round(sel.table[,2:3],2)
sel.table[,4:5]<- round(sel.table[,4:5],3)
#这样就更好看了
> sel.table df logLik AICc delta weight
mod1 4 863.91 -1719.65 0.000 0.720
mod4 5 863.94 -1717.65 2.007 0.264
mod3 4 860.13 -1712.10 7.554 0.016
mod2 4 819.49 -1630.82 88.830 0.000
#如何稍微重命名列以适合适当的约定
# number of parameters (df) should be K
names(sel.table)[1] = "K"
##确保将模型名称放在一列中
sel.table$Model<-rownames(sel.table)
#用公式替换模型名称有点棘手，所以要小心
for(i in 1:nrow(sel.table)) sel.table$Model[i]<- as.character(formula(paste(sel.table$Model[i])))[3]
#结果
sel.table
> df logLik AICc delta weight Model
mod1 4 863.91 -1719.65 0.000 0.720 distance + elev
mod4 5 863.94 -1717.65 2.007 0.264 slope + distance + elev
mod3 4 860.13 -1712.10 7.554 0.016 slope + distance
mod2 4 819.49 -1630.82 88.830 0.000 slope + pct.cover
#列的重新排序很少
sel.table<-sel.table[,c(6,1,2,3,4,5)]
sel.table
> Model K logLik AICc delta weight
mod1 distance + elev 4 863.91 -1719.65 0.000 0.720
mod4 slope + distance + elev 5 863.94 -1717.65 2.007 0.264
mod3 slope + distance 4 860.13 -1712.10 7.554 0.016
mod2 slope + pct.cover 4 819.49 -1630.82 88.830 0.000
现在各个模型从最佳拟合到最差拟合排序。你通常可以删除AICc，因为它位于表中的Log Likelihood（logLik），但我们将其保留在此处。我们已准备好生成报告，因此可以将其写入以逗号分隔的文件中。
#写入文件，此处为逗号分隔的值格式
#确保正确指定了您的工作目录
write.csv(sel.table,"My model selection table.csv", row.names = F)
所有MuMIn功能的默认模型选择标准是AICc。如果你不喜欢或没有其他收藏夹，则可以使用mod.sel中的“排名”选项指定该方法。以下是使用贝叶斯或Schwartz信息标准（BIC）一致的AIC，Fishers信息矩阵（CAICF）和准AIC（QAIC，下面将详细介绍）选择模型的代码。
#用标准BIC进行模型选择
mod.sel(mod1,mod2,mod3,mod4, rank = BIC) Model selection table
> (Int) dst elv pct.cvr slp df logLik BIC delta
mod1 -0.013280 5.195e-05 1.832e-05 4 863.907 -1705.6 0.00
mod4 -0.013080 5.181e-05 2.002e-05 -0.01096 5 863.944 -1700.2 5.47
mod3 -0.012920 5.207e-05 0.08634 4 860.130 -1698.1 7.55
mod2 0.003614 2.777e-05 0.05374 4 819.492 -1616.8 88.83
weight
mod1 0.919
mod4 0.060
mod3 0.021
mod2 0.000
Models ranked by BIC(x)
#AIC与Fishers信息矩阵一致
mod.sel(mod1,mod2,mod3,mod4, rank = CAICF) Model selection table
> (Int) dst elv pct.cvr slp df logLik CAICF delta
mod3 -0.012920 5.207e-05 0.08634 4 860.130 -1642.9 0.00
mod1 -0.013280 5.195e-05 1.832e-05 4 863.907 -1633.1 9.80
mod4 -0.013080 5.181e-05 2.002e-05 -0.01096 5 863.944 -1619.2 23.66
mod2 0.003614 2.777e-05 0.05374 4 819.492 -1565.5 77.37
weight
mod3 0.993
mod1 0.007
mod4 0.000
mod2 0.000
Models ranked by CAICF(x)
还有一些MuMin函数可用于计算模型选择标准，例如AIC，AICc，BIC和Mallows Cp（不建议使用的临时模型选择标准）。
#Mallows Cp
Cp(mod4)
> [1] 0.01757519
#AIC
AIC(mod1,mod2)
> df AIC
mod1 4 -1719.813
mod2 4 -1630.983
请注意，在df上方实际上是模型参数的数量，通常定义为K。
# CAICF
CAICF(mod1, mod2)
> CAICF
mod1 -1633.082
mod2 -1565.503
各个参数的相对重要性也可以使用模型权重进行检查。在此，对包含感兴趣参数的每个模型的Akaike权重进行求和。这些已定义为重要性权重，您可以使用“importance”函数从mod.sel对象中获取它们。
#各个预测变量的重要性权重
#使用重要性函数计算
importance(out.put)
> importance(out.put) distance elev slope pct.cover
Importance: 1 0.98 0.28 <0.01
N containing models: 3 2 3 1
查看上面的输出，有足够的证据证明距离和高度（权重接近1）是影响密度的因子，而pct.cover则少得多。参数出现的候选模型的数量可能对重要性权重产生很大影响。例如，截距包含在所有模型中，因此重要性权重为1（因此从未显示）。在以上输出中，pct.cover仅在一种模型中，因此请谨慎解释权重。 模型平均是合并模型选择不确定性的一种手段。 在此，使用每个候选模型的相应模型权重对参数估计值进行加权并求和。 Burnham和Anderson定义了两种用于模型平均的方法，其中，对发生预测变量xj的所有模型进行参数估计，并对所有模型进行预测，而不只是对发生预测变量xj的模型进行参数估计。 MuMIn函数model.avg进行两种类型的模型平均，并将第一种类型的模型平均报告为“子集”，将第二种类型的模型报告为“完整”。
#使用所有候选模型的模型平均值，请始终使用modified.var = TRUE
MA.ests <- model.avg(out.put, revised.var = TRUE)
> Call:
model.avg.model.selection(object = out.put, revised.var = TRUE)
Component models:
‘12’ ‘124’ ‘14’ ‘34’
Coefficients:
(Intercept) distance elev slope pct.cover
subset -0.01322053 5.191484e-05 1.877402e-05 -0.005241959 2.777260e-05
full -0.01322053 5.191484e-05 1.846475e-05 -0.001469396 1.026921e-24
上面是两种类型的模型平均系数。 这是你的估计值，无条件标准误差，你需要调整后的SE和上下CL.
MA.ests$avg.model
> Estimate Std. Error Adjusted SE Lower CI Upper CI
(Intercept) -1.322053e-02 2.196457e-03 2.207049e-03 -1.754627e-02 -8.894795e-03
distance 5.191484e-05 5.221077e-06 5.246295e-06 4.163229e-05 6.219739e-05
elev 1.877402e-05 4.910574e-06 4.933771e-06 9.104006e-06 2.844403e-05
slope -5.241959e-03 4.582284e-02 4.598957e-02 -9.537986e-02 8.489594e-02
pct.cover 2.777260e-05 2.716872e-05 2.729983e-05 -2.573408e-05 8.127928e-05
#这是Beta tilda bar MA的估算值
MA.ests$coef.shrinkage
> (Intercept) distance elev slope pct.cover
-1.322053e-02 5.191484e-05 1.846475e-05 -1.469396e-03 1.026921e-24
#您还可以获取各个参数的重要性权重
MA.ests$importance
> distance elev slope pct.cover
Importance: 1 0.98 0.28 <0.01
N containing models: 3 2 3 1
我们可以使用其他选项来选择并创建仅根据我们的信任集中的那些模型创建的复合模型。 例如
#仅使用子集命令为模型的置信度集中的参数创建模型的平均估计值
MA.ests<-model.avg(out.put, subset= delta < 5, revised.var = TRUE)
MA.ests$avg.model
> Estimate Std. Error Adjusted SE Lower CI Upper CI
(Intercept) -1.322554e-02 2.194158e-03 2.204742e-03 -1.754676e-02 -8.904326e-03
distance 5.191232e-05 5.219487e-06 5.244699e-06 4.163290e-05 6.219174e-05
elev 1.877402e-05 4.910574e-06 4.933771e-06 9.104006e-06 2.844403e-05
slope -1.096031e-02 4.060037e-02 4.079708e-02 -9.092112e-02 6.900050e-02
#让我们整理一点并将表写入文件
MA.est.table<-round(MA.ests$avg.model[,c(1,3:5)],6)
MA.est.table
> Estimate Adjusted SE Lower CI Upper CI
(Intercept) -0.013226 0.002205 -0.017547 -0.008904
distance 0.000052 0.000005 0.000042 0.000062
elev 0.000019 0.000005 0.000009 0.000028
slope -0.010960 0.040797 -0.090921 0.069001
#输出为csv
write.csv(MA.est.table, "My model averaged estimates.csv")
对于正常的线性模型，可以使用模型平均参数估计来预测自变量（也称为预测变量）的各种值的响应，此处为密度。 这等效于预测每个候选模型的响应，并使用相应的模型权重平均预测值。请注意，这不适用于非正常模型，例如逻辑回归或泊松回归。我们可以使用MuMIn函数的输出对预测值进行模型平均。在这里，我们在MuMIn中使用一些功能，在基本R函数中使用一些功能。例如，以下是用于计算模型平均预测的代码。
#extract parameters and weights from confidence model set
#使用get.models函数
pred.parms<-get.models(out.put, subset= delta < 5)
#使用每个模型预测值，这里仅使用示例数据集，您可以使用新的数据集
model.preds = sapply(pred.parms, predict, newdata = dater)
> model.preds mod1 mod4 mod3 mod2
1 1.572387e-02 1.561711e-02 1.647889e-02 0.009264373
2 8.710879e-03 8.812682e-03 8.035629e-03 0.007606412
3 4.596332e-03 4.510560e-03 3.989456e-03 0.011867896
4 1.125713e-02 1.133978e-02 8.993757e-03 0.011941525
(rest of output not shown)
上面是对每种候选模型所做的预测（将其切掉一点）。现在我们需要通过模型权重和总和对权重进行加权（就像上面的模型平均系数一样）。最简单的方法是使用矩阵乘法。
#通过其AIC权重对每个模型的预测进行加权
#“Weights”功能提取权重
#我们还使用矩阵乘法％*％
mod.ave.preds<-model.preds %*% Weights(out.put)
mod.ave.preds
> [,1]
1 1.570814e-02
2 8.726615e-03
3 4.563705e-03
4 1.124165e-02
5 1.518054e-02
6 7.068765e-03`
(rest of output not shown)
模型平均用于绘图的一个更有趣的应用是创建一个数据集，其中将除单个预测变量（下面的海拔高度）以外的所有值都设置为其平均值。
#海拔范围从观察到的最小值到最大值
elev=c(min(dater$elev):max(dater$elev))
#用平均值创建plotdata数据框
plotdata<-as.data.frame(lapply(lapply(dater[5:8],mean),rep,length(elev))))
plotdata<-cbind(elev,plotdata)
#现在可以预测每个模型的绘图数据的密度
model.preds = sapply(pred.parms, predict, newdata = plotdata)
#通过其AIC权重和和（矩阵乘法）对每个模型的预测进行加权
mod.ave4plot<-model.preds %*% Weights(out.put)
#绘制模型平均预测密度与海拔的关系
plot(mod.ave4plot~ elev, type = 'l', xlab="Elevation (m)", ylab="Model averaged predicted density")
MuMIn的另一个有用功能是dredge。但是，你仅应将其用于探索目的。强烈不鼓励进行数据挖掘，并且可能导致虚假（无关紧要的或更糟糕的是，错误的）结果和推断。因此，请阅读以下消息，请用户当心。
#仅供探索用途！！！别整活
#使用所有参数拟合模型
all.parms<-lm(density~slope+distance+elev+ pct.cover, data = dater)
#dredge功能适合所有上面的all.parms模型中的变量的拟合
results<-dredge(all.parms)
results
> Model selection table
(Int) dst elv pct.cvr slp df logLik AICc delta
4 -0.013280 5.195e-05 1.832e-05 4 863.907 -1719.7 0.00
8 -0.014560 5.177e-05 1.860e-05 2.362e-05 5 864.448 -1718.7 1.00
12 -0.013080 5.181e-05 2.002e-05 -0.01096 5 863.944 -1717.6 2.01
16 -0.014360 5.162e-05 2.044e-05 2.377e-05 -0.01187 6 864.491 -1716.6 3.01
(rest not shown)
#获取最佳支持的模型
subset(results, delta <5)
> Model selection table
(Int) dst elv pct.cvr slp df logLik AICc delta weight
4 -0.01328 5.195e-05 1.832e-05 4 863.907 -1719.7 0.00 0.455
8 -0.01456 5.177e-05 1.860e-05 2.362e-05 5 864.448 -1718.7 1.00 0.276
12 -0.01308 5.181e-05 2.002e-05 -0.01096 5 863.944 -1717.6 2.01 0.167
16 -0.01436 5.162e-05 2.044e-05 2.377e-05 -0.01187 6 864.491 -1716.6 3.01 0.101
Models ranked by AICc(x)
#获取最好的模型
subset(results, delta == 0)
> Global model call: lm(formula = density ~ slope + distance + elev + pct.cover, data = dater)
---
Model selection table
(Int) dst elv df logLik AICc delta weight
4 -0.01328 5.195e-05 1.832e-05 4 863.907 -1719.7 0 1
Models ranked by AICc(x)
#计算可变重要性权重
> importance(results)
distance elev pct.cover slope
Importance: 1.00 0.98 0.38 0.28
N containing models: 8 8 8 8
上面请注意，每个参数都具有相同数量的模型。
#使用其他模型选择标准
results<-dredge(all.parms, rank = BIC)
results
> Global model call: lm(formula = density ~ slope + distance + elev + pct.cover, data = dater)
---
Model selection table
(Int) dst elv pct.cvr slp df logLik BIC delta
4 -0.013280 5.195e-05 1.832e-05 4 863.907 -1705.6 0.00
8 -0.014560 5.177e-05 1.860e-05 2.362e-05 5 864.448 -1701.2 4.46
12 -0.013080 5.181e-05 2.002e-05 -0.01096 5 863.944 -1700.2 5.47
10 -0.012920 5.207e-05 0.08634 4 860.130 -1698.1 7.55
(rest not shown)
#每个模型最多只允许3个参数，最小1个参数
results<-dredge(all.parms,m.max =3, m.min = 1)
results
> Model selection table
(Int) dst elv pct.cvr slp df logLik AICc delta
4 -0.013280 5.195e-05 1.832e-05 4 863.907 -1719.7 0.00
8 -0.014560 5.177e-05 1.860e-05 2.362e-05 5 864.448 -1718.7 1.00
12 -0.013080 5.181e-05 2.002e-05 -0.01096 5 863.944 -1717.6 2.01
10 -0.012920 5.207e-05 0.08634 4 860.130 -1712.1 7.55
(rest not shown)
#适合所有模型，但不包括同时具有坡度和高程的模型
results<-dredge(all.parms, subset= !(slope && elev))
results
> Model selection table
(Int) dst elv pct.cvr slp df logLik AICc delta weight
4 -0.013280 5.195e-05 1.832e-05 4 863.907 -1719.7 0.00 0.609
8 -0.014560 5.177e-05 1.860e-05 2.362e-05 5 864.448 -1718.7 1.00 0.370
10 -0.012920 5.207e-05 0.08634 4 860.130 -1712.1 7.55 0.014
(rest not shown)
#在所有模型中都包括高程
results<-dredge(all.parms,fixed =c("elev"))
results
> Model selection table
(Int) dst elv pct.cvr slp df logLik AICc delta weight
2 -0.013280 5.195e-05 1.832e-05 4 863.907 -1719.7 0.00 0.455
4 -0.014560 5.177e-05 1.860e-05 2.362e-05 5 864.448 -1718.7 1.00 0.276
6 -0.013080 5.181e-05 2.002e-05 -0.01096 5 863.944 -1717.6 2.01 0.167
(rest not shown)
#使用dredge创建的对象也可以用于创建模型平均参数
MA.ests<-model.avg(results, subset= delta < 2, revised.var = TRUE)
MA.ests$avg.model
> Estimate Std. Error Adjusted SE Lower CI Upper CI
(Intercept) -1.376386e-02 2.373991e-03 2.384677e-03 -1.843774e-02 -9.089980e-03
distance 5.188373e-05 5.210960e-06 5.236138e-06 4.162108e-05 6.214637e-05
elev 1.842395e-05 3.598801e-06 3.616170e-06 1.133638e-05 2.551151e-05
pct.cover 2.362281e-05 2.286638e-05 2.297717e-05 -2.141161e-05 6.865722e-05
上面的所有功能都可以与通过使用glm函数拟合线性模型而创建的对象一起使用。 以上所有内容均适用于这些glm对象。但是，你应该知道一个重要的区别。由于存在额外的差异，GLM（例如Poisson回归和Logistic回归）通常无法满足统计假设。通常将其定义为过度分散（对于正常的线性回归而言不是问题！），并且需要使用准AIC进行模型选择。这是使用泊松回归和glm函数拟合计数数据时过度分散的示例。
#拟合全局泊松回归模型
global.mod<-glm(count~area+distance+elev+ slope, data = dater, family = poisson)
summary(global.mod)
> Call:
glm(formula = count ~ area + distance + elev + slope, family = poisson,
data = dater)
Deviance Residuals:
Min 1Q Median 3Q Max
-5.6618 -2.0085 -0.9933 0.9147 3.6812
Coefficients:
Estimate Std. Error z value Pr(>|z|)
(Intercept) -2.972e+00 1.113e-01 -26.709 < 2e-16 ***
area 2.654e-03 5.533e-05 47.972 < 2e-16 ***
distance 5.317e-03 1.552e-04 34.248 < 2e-16 ***
elev 2.095e-03 2.765e-04 7.576 3.57e-14 ***
slope -4.664e+00 1.589e+00 -2.936 0.00333 **
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
(Dispersion parameter for poisson family taken to be 1)
Null deviance: 4460.39 on 254 degrees of freedom
Residual deviance: 898.82 on 250 degrees of freedom
AIC: 1603.1
#计算chat以评估模型假设，chat>1表示过度分散
chat<-sum(residuals(glob.mod,"pearson")^2)/glob.mod$df.residual
chat
> [1] 2.898076
为了说明过度分散，我们使用拟泊松回归并在glm函数中指定“拟泊松”。
#使全局拟泊松回归模型适合全局模型
global.mod<-glm(count~area+distance+elev+ slope, data = dater, family = quasipoisson)
summary(global.mod)
> Call:
glm(formula = count ~ area + distance + elev + slope, family = quasipoisson,
data = dater)
Deviance Residuals:
Min 1Q Median 3Q Max
-5.6618 -2.0085 -0.9933 0.9147 3.6812
Coefficients:
Estimate Std. Error t value Pr(>|t|)
(Intercept) -2.9715045 0.1898075 -15.655 < 2e-16 ***
area 0.0026545 0.0000944 28.118 < 2e-16 ***
distance 0.0053167 0.0002649 20.074 < 2e-16 ***
elev 0.0020946 0.0004717 4.440 1.35e-05 ***
slope -4.6641697 2.7104978 -1.721 0.0865 .
---
Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
(Dispersion parameter for quasipoisson family taken to be 2.910718)
Null deviance: 4460.39 on 254 degrees of freedom
Residual deviance: 898.82 on 250 degrees of freedom
AIC: NA
然后，就像创建lm函数和密度响应变量一样，我们创建候选模型集。
#候选集
modl2<-glm(count~area+slope, data = dater, family = quasipoisson)
modl3<-glm(count~area+distance, data = dater, family = quasipoisson)
modl4<-glm(count~area+elev, data = dater, family = quasipoisson)
#尝试使用准AICc，QAICc选择模型，请确保使用model.set函数中的rank.args提供全局模型的聊天记录
quasi.MS<-model.sel(global.mod,modl2,modl3,modl4, rank = QAICc, rank.args = alist(chat = chat))
#让我们看看我们得到了什么
as.data.frame(quasi.MS)
> (Intercept) area distance elev slope df logLik
global.mod -2.9715045 0.002654473 0.005316652 0.002094616 -4.664170 5 NA
modl2 -0.7917247 0.002441674 NA NA 3.750308 3 NA
modl3 -2.5867633 0.002665374 0.005324297 NA NA 3 NA
modl4 -0.8972105 0.002437204 NA 0.001056615 NA 3 NA
QAICc delta weight
global.mod NA NA NA
modl2 NA NA NA
modl3 NA NA NA
modl4 NA NA NA
休斯顿，我们有问题！查看所有这些出现NA的地方：QAIC，增量和权重-出问题了。这是因为glm不为拟回归（和拟二项式）回归提供对数似然性。我们需要创建一个函数来欺骗glm放弃对数可能性。
#这是获得可能性并计算QAICc所必需的
x.quasipoisson <- function(...) {
res <- quasipoisson(...)
res$aic <- poisson(...)$aic
res
}
现在，我们使用功能和“updata”功能来设置模型选择。 这应该在每个候选模型上完成。
#更新模型，以便获得对数似然
global.mod<-update(global.mod,family = "x.quasipoisson")
modl2<-update(modl2,family = "x.quasipoisson")
modl3<-update(modl3,family = "x.quasipoisson")
modl4<-update(modl4,family = "x.quasipoisson")
现在，我们很高兴使用QAICc选择模型。
#现在进行模型选择
quasi.MS<-model.sel(global.mod,modl2,modl3,modl4, rank = QAICc, rank.args = alist(chat = chat))
as.data.frame(quasi.MS)
> (Intercept) area distance elev slope df logLik
global.mod -2.9715045 0.002654473 0.005316652 0.002094616 -4.664170 5 -796.5328
modl3 -2.5867633 0.002665374 0.005324297 NA NA 3 -856.1141
modl4 -0.8972105 0.002437204 NA 0.001056615 NA 3 -1325.0153
modl2 -0.7917247 0.002441674 NA NA 3.750308 3 -1345.5074
QAICc delta weight
global.mod 562.0363 0.00000 1.000000e+00
modl3 598.9754 36.93913 9.522895e-09
modl4 922.5702 360.53391 5.141100e-79
modl2 936.7121 374.67577 4.367061e-82
现在，我们可以像上面一样使用其他任何MuMIn函数。例如，我们可以使用子集来选择最佳模型。
#获得最佳模型
subset(quasi.MS, delta == 0)
> Model selection table
(Intrc) area dstnc elev slope df logLik QAICc delta
global.mod -2.972 0.002654 0.005317 0.002095 -4.664 5 -796.533 562 0
weight
global.mod 1
Models ranked by QAICc(x, chat = chat)
#是的，dredge有效，但仅适用于更新的模型
dredge(global.mod, rank = "QAICc", chat = chat)
> Global model call: glm(formula = count ~ area + distance + elev + slope, family = "x.quasipoisson", data = dater)
---
Model selection table
(Intrc) area dstnc elev slope df logLik QAICc delta weight
16 -2.9720 0.002654 0.005317 0.002095 -4.664 5 -796.533 562.0 0.00 0.612
8 -3.0120 0.002636 0.005336 0.001364 4 -800.893 562.9 0.91 0.388
(rest not shown)
MuMIn函数还可用于广义线性混合模型的模型选择。在这里，我们将使用lmer4软件包，并使用分层逻辑回归模型进行一些模型选择。确保已安装lme4。让我们加载示例数据集。
#直接从网站读取数据
trout<-read.csv("http://sites.google.com/site/rforfishandwildlifegrads/home/week-8/Westslope.csv?attredirects=0&d=1")
#或读取下载的文件
#trout<-read.csv("Westslope.csv")
head(trout)
该数据包含内陆哥伦比亚河流域内流域内溪流的威斯洛普特（Westslope）凶猛鳟鱼的有无数据。 该文件包含以下数据：
- 存在-物种存在（1）或不存在（0）
- WSHD-分水岭ID
- SOIL_PROD-生产性土壤流域的百分比
- 梯度-河流的梯度（％）
- WIDTH-河流的平均宽度，以米为单位 与所有模型选择练习一样，您应该首先拟合全局模型并评估模型假设，例如残差的分布，独立性等。在下面，我们拟合全局模型（使用带glmer函数的westslope数据的model1和4个候选模型 Logistic回归如此“类型（family） = 二项式（binomial）”。
##拟合logistic回归并将随机效应输出到model1 model1 <-glmer(PRESENCE ~ SOIL_PROD + GRADIENT + WIDTH + (1|WSHD),data = trout, family = binomial) summary(model1) > Generalized linear mixed model fit by maximum likelihood (Laplace Approximation) [glmerMod] Family: binomial ( logit ) Formula: PRESENCE ~ SOIL_PROD + GRADIENT + WIDTH + (1 | WSHD) Data: trout AIC BIC logLik deviance df.resid 423.0 448.1 -206.5 413.0 1115 Scaled residuals: Min 1Q Median 3Q Max -3.2280 -0.1067 -0.0278 -0.0053 13.9827 Random effects: Groups Name Variance Std.Dev. WSHD (Intercept) 19.41 4.406 Number of obs: 1120, groups: WSHD, 56 Fixed effects: Estimate Std. Error z value Pr(>|z|) (Intercept) -6.40275 1.83118 -3.497 0.000471 *** SOIL_PROD 0.07282 0.03178 2.291 0.021964 * GRADIENT 0.32147 0.04009 8.019 1.06e-15 *** WIDTH -0.60649 0.07601 -7.979 1.47e-15 *** --- Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1 Correlation of Fixed Effects: (Intr) SOIL_P GRADIE SOIL_PROD -0.808 GRADIENT -0.362 0.156 WIDTH 0.019 -0.140 -0.485 #拟合剩余的候选模型 model2 <-glmer(PRESENCE ~ GRADIENT + WIDTH + (1|WSHD),data = trout, family = binomial) model3 <-glmer(PRESENCE ~ SOIL_PROD + (1|WSHD),data = trout, family = binomial) model4 <-glmer(PRESENCE ~ SOIL_PROD + WIDTH + (1 + SOIL_PROD|WSHD),data = trout, family = binomial) model5 <-glmer(PRESENCE ~ SOIL_PROD + WIDTH + (1 |WSHD),data = trout, family = binomial) #使用BIC进行模型选择 my.models<-model.sel(model1,model2,model3,model4,model5,rank=BIC) my.models > Model selection table (Int) GRA SOI_PRO WID random df logLik BIC delta weight model2 -3.410 0.3186 -0.6040 W 4 -209.270 446.6 0.00 0.681 model1 -6.403 0.3215 0.07282 -0.6065 W 5 -206.520 448.1 1.52 0.319 model4 -6.667 0.12800 -0.4401 1+S_P|W 6 -257.123 556.4 109.75 0.000 model5 -1.910 0.04778 -0.4397 W 4 -264.977 558.0 111.41 0.000 model3 -5.233 0.04074 W 3 -309.658 640.4 193.75 0.000 Models ranked by NULL Random terms: W = ‘1 | WSHD’ 1+S_P|W = ‘1 + SOIL_PROD | WSHD’最好的近似模型是模型2，其中包含梯度，宽度和随机变化的截距。 我们还可以使用任何其他MuMIn函数，例如
#计算重要性权重 importance(my.models) > GRADIENT WIDTH SOIL_PROD Importance: 1.00 1.00 0.32 N containing models: 2 4 4 #是的，dredge也可以在这里工作，谢谢！ dredge(model1, rank = BIC) > Model selection table (Int) GRA SOI_PRO WID df logLik BIC delta weight 6 -3.41000 0.3186 -0.6040 4 -209.270 446.6 0.00 0.681 8 -6.40300 0.3215 0.07282 -0.6065 5 -206.520 448.1 1.52 0.319 2 -6.80900 0.2375 3 -262.364 545.8 99.17 0.000 4 -9.05000 0.2390 0.05337 4 -259.790 547.7 101.04 0.000 5 0.07927 -0.4396 3 -267.178 555.4 108.79 0.000 7 -1.91000 0.04778 -0.4397 4 -264.977 558.0 111.41 0.000 1 -3.54100 2 -311.858 637.8 191.13 0.000 3 -5.23300 0.04074 3 -309.658 640.4 193.75 0.000 Models ranked by BIC(x) Random terms (all models): ‘1 | WSHD’一句话警告，不要为混合模型估算模型平均参数！ 但是，您可以对GLMM的预测进行平均模型化。
Phylogenetic regression
Phylogenetic data
了解数据对于研究生物多样性非常重要，而现在使用的一个常见数据是描述谱系之间以及谱系之间的进化关系的系统发育树。从这里到本简短教程的结尾，我们将尝试解释如何导入/导出和处理系统发育信息的基础知识。
一些格式 储存系统发育树的最常见格式是Newick，Nexus(Maddison et al. 1997)。 Newick格式将系统发育关系表示为”(“，”,“，”:“，具体如下： 括号将谱系链接到树的特定节点，而逗号“，”将从该节点下降的谱系分隔开。 节点名称后可以使用冒号标点“：”，后续数字值表示分支长度。 最后，用分号标点“;” 表示系统发育树的末端：
library(ape)
#建树
newick_tree <- "((A:10,B:9)D:5,C:15)F;"
#读树
newick_tree <- read.tree(text = newick_tree)
#画树
plot(newick_tree, show.node.label = TRUE)
还有一种格式是Nexus，它有着更大的灵活性。
#首先在工作目录里创建一个Nexus文件的树
cat(
"#NEXUS
BEGIN TAXA;
DIMENSIONS NTAXA=3;
TaxLabels A B C;
END;
BEGIN TREES;
TREE=((A:10,B:9)D:5,C:15)F;
END;",
file = "Data/Nexus_tree.nex"
)
#读树（使用read.nexus）
nexus_tree <- read.nexus("Data/Nexus_tree.nex")
#画树，图和上面一样，就不放了
plot(nexus_tree, show.node.label = TRUE)
#可以检查我们的树
#概览我们的树
str(nexus_tree)
#List of 5
# $ edge : int [1:4, 1:2] 4 5 5 4 5 1 2 3
# $ edge.length: num [1:4] 5 10 9 15
# $ Nnode : int 2 ##节点数？
# $ node.label : chr [1:2] "F" "D"
# $ tip.label : chr [1:3] "A" "B" "C"
# - attr(*, "class")= chr "phylo"
# - attr(*, "order")= chr "cladewise"
nexus_tree$tip.label
#[1] "A" "B" "C"
#查看枝长
nexus_tree$edge.length
#[1] 5 10 9 15
#nexus_tree$edge
#可以查看发育树的边的矩阵。在此矩阵中，每一行代表树中的一个分支，第一列显示该分支的祖先节点的索引，第二列显示该分支的后代节点。
nexus_tree$edge
#[,1] [,2]
#[1,] 4 5
#[2,] 5 1
#[3,] 5 2
#[4,] 4 3
#这些数据让人摸不着头脑，我们可以在树上显示数字代号以便理解
plot(nexus_tree, show.tip.label = FALSE)
nodelabels()
tiplabels()
最后，系统发育树也可以列表的形式导入，并且在系统发育比较方法中，系统发育树的列表称为multiPhylo，我们可以两种格式导入/导出这些multiPhylos。
#模拟10个不同的系统发育树，每个系统发育树内有5个种
multitree <- replicate(10, rcoal(5), simplify = FALSE)
#将这些一起保存为一个multiPhylo项目
class(multitree) <- "multiPhylo"
#把其中的第10个发育树画出来
plot(multitree[[10]])
#分成2行2列来显示下面4个发育树
par(mfrow = c(2, 2))
#下面是四个发育树
plot(multitree[[1]])
plot(multitree[[3]])
plot(multitree[[7]])
plot(multitree[[10]])
#导入导出这些数据
#作为newick导入
write.tree(phy = multitree, file = "Data/multitree_example_newick.txt")
#导出
multitree_example_newick <- read.tree("Data/multitree_example_newick.txt")
#查看
multitree_example_newick
#10 phylogenetic trees
#作为nexus导入
write.nexus(phy = multitree, file = "Data/multitree_example_nexus.nex")
multitree_example_nexus <- read.nexus("Data/multitree_example_nexus.nex")
multitree_example_nexus
#10 phylogenetic trees
Loop and algorithm
编程中最重要的就是活用for进行循环，其基本结构是：for (variable in vector 向量中的变量) {execute defined statements执行定义的语句} 在编程时，通常使用循环变量i来确定步数因为i是iteration一词的第一个字母，不过你也可以使用任何字母或单词作为循环变量。
#cat函数将里面的数据排排站输出
for (i in 1:10){
cat(i, sep = '')
}
#12345678910
#让1-10的数据换行输出，结果不列
for (i in 1:10){
cat(i, sep = '\n')
}
BioSciNames <- c("Jeannine", "Jesús", "Bailey","Kalli", "Ariadna", "Samantha", "Maxell",
"Sara", "Nicholas", "Carmen", "Ashley", "Mikkel", "Shana", "Kirsten",
"Lucy", "Joe", "Joshua")
for (i in 12:length(BioSciNames)){
cat("Hi,", BioSciNames[i], ", welcome to the first practice!","\n");
}
#从第12个人开始套娃输出这句话
#Hi, Mikkel , welcome to the first practice!
#Hi, Shana , welcome to the first practice!
#Hi, Kirsten , welcome to the first practice!
#Hi, Lucy , welcome to the first practice!
#Hi, Joe , welcome to the first practice!
#Hi, Joshua , welcome to the first practice!
Comparative under the background of phylogenetic
当比较不同生物的多种性状之间的关系时，我们往往使用遗传距离和系统发育比较法（PCMs）：密切相关的生物由于从一个共同的祖先遗传而来，通常具有相似的特征，而跨生物体的性状的依赖性则可以通过性状-性状与性状-环境的关系来测试。在执行回归时，广义最小二乘法（GLS）可以控制观测值之间的相关性，GLS中残差（预测值和观测值之间的差值）是协变的，而协方差矩阵用于修改最小二乘计算：随机进化产生了近亲，由于他们在共同祖先中获得的共同变异，他们观察到的特征将是协变的。
PCMs的第一步是根据无系统发育信号的零模型来估计和测试系统发育信号。Pagel的$\lambda$或Blomberg的$K$是系统发育信号的常用检验统计量。默认时，性状从进化树的祖先到树梢的分支是随机的，而加入进化后，两个物种性状值残差之间的协方差与共享进化史的数量成正比。
本小结内容与系统发育可视化，为离散和连续性状确定祖源相关信息，性状-发育模型的测试模型，执行回归模型的系统发育校正有关。该课程数据基于Luke Harmon的试验和课程： http://lukejharmon.github.io/ilhabela/instruction/2015/07/03/PGLS/ 我们需要下面这两个数据：
- anolisDataAppended.csv
- anolis.phy 这是一组（Anolis）安乐蜥属的蜥蜴有关的系统发育数据和性状数据。相关的文件在我的github可以下载。
Phylogenetic regression by phylolm
基于phylolm包的系统发育回归，它提供拟合系统发育线性模型和系统发育广义线性模型的功能。计算使用了一种算法，该算法在树中的提示数上是线性的。该软件包还提供了模拟系统发育树上连续或二元性状的函数。
#该函数将一个（单变量）性状拟合到系统发育树上 OUshifts(y, phy, method = c("mbic", "aic", "bic", "saic", "sbic")) #进行系统发育广义线性回归 phyloglm(formula, data, phy, method = c("logistic_MPLE", "logistic_IG10", "poisson_GEE"), btol = 10, log.alpha.bound = 4, boot = 0) #btol：（仅限逻辑回归）在线性预测值上绑定搜索范围 #boot：进行bootstrap找范围 phyloglmstep(formula,starting.formula = NULL, data = list(), phy, method = c("logistic_MPLE", "logistic_IG10"), direction = c("both", "backward", "forward"), trace = 2, btol = 10, boot = 0) #btol：在线性预测器上绑定搜索空间。 #此函数使用树中提示数为线性的算法来计算可能性。误差项的可能系统发育模型有布朗运动模型（BM）、根的祖先状态估计的Ornstein-Uhlenbeck模型（OUfixedRoot）、根的祖先状态具有平稳分布的Ornstein-Uhlenbeck模型（OUrandomRoot）、Pagel的λ模型（lambda），Pagelκ模型（kappa）、Pagelδ模型（delta）、早期突发模型（EB）和具有趋势的布朗运动模型（trend）。 phylolm(formula, data = list(), phy, model = c("BM", "OUrandomRoot", "OUfixedRoot", "lambda", "kappa", "delta", "EB", "trend"),lower.bound = NULL, upper.bound = NULL,starting.value = NULL, measurement_error = FALSE, boot=0,full.matrix = TRUE, ...) #它的模型选择为 phylostep(formula, starting.formula = NULL, data = list(), phy, model = c("BM", "OUrandomRoot","OUfixedRoot", "lambda", "kappa", "delta", "EB", "trend"), direction = c("both", "backward", "forward"), trace = 2,lower.bound = NULL, upper.bound = NULL,starting.value = NULL, k=2, ...) #计算超度量树中所有内部节点的分支时间或年龄，这些节点的内部表示是按“修剪”顺序进行的。 pruningwise.branching.times(phy) #计算从根到所有节点的距离，在一个内部表示为“修剪”顺序的树中。 pruningwise.distFromRoot(phy)Generalized least squares method for phylogenetics (PGLS)
来源：R course in Ilhabela, Brazil, June 2015 首先，我们需要安装一些程序包
library(ape) library(geiger) library(nlme) library(maps) library(phytools) #打开树 anoleTree <- read.tree('Data/anolis.phy') #显示一些树的基本信息 anoleTree #显示分支长度 str(anoleTree) #显示树内的物种名 anoleTree$tip.label #树的节点数，完全分支的话会比物种数少一个 anoleTree$Nnode #所有起点和终点的位置与长度 anoleTree$edge #显示树的图像 plot(anoleTree) #树太丑了可以整理一下，把树设为环形，字体大小0.7，填满屏幕 plot.phylo(anoleTree, type="fan", no.margin=T, cex=0.7) #再加上分支长度和编号变成终极版 plot.phylo(anoleTree, type="fan", no.margin=T, cex=0.7,label.offset=0.1) nodelabels(cex=0.5) tiplabels(cex=0.5)
布朗运动模型下的PGLS 在课程中，我们讨论了一种进化模型，称为布朗运动模型。该模型假设特征是根据随机运动从起始状态（z0）演变而来，其随机性由速率参数sigma-squared（sigsq）指定。蜥蜴中的Awesomemess布朗运动的演变是什么样的？
#加入数据
anoleData <- read.csv('Data/anolisDataAppended.csv',row.name = 1)
#可以简单看看数据
View(anoleData)
#Geiger有一个函数可以查看树内的物种是否和数据内的物种名匹配
name.check(anoleTree, anoleData)
#[1] "OK"
#使用awesomeness这一列数据
awe<-anoleData[,"awesomeness"]
#数据向量必须用相关树的尖端名称标记
names(awe)<-rownames(anoleData)
#在课程中，我们讨论了一种进化模型，称为布朗运动模型。该模型假设特征是根据随机运动从起始状态（z0）演变而来，其随机性由速率参数sigma-squared（sigsq）指定。蜥蜴中的Awesomemess布朗运动的演变是什么样的？
brownianModel <- fitContinuous(anoleTree, awe)
brownianModel
#fitted ‘BM’ model parameters:
# sigsq = 3.943316
# z0 = 0.246690
在这里，您可以看到祖先状态的估计值(z0)和速率参数(sigsq)，以及模型拟合的一些度量。使用最大似然确定模型的拟合，并表示为对数似然。 lnL越高，给定模型的数据就越可能。但是，在比较不同模型时，我们不能使用lnL，因为它不能解决模型之间参数数量的差异。参数更多的模型总会更适合，但它们是否显着更好？例如，一个OU模型具有4个参数(alpha，theta，z0和sigsq)，因此它应比仅包含z0和sigsq的BM模型更好。为了解决这个问题，统计学家开发了另一种适合度的度量标准，称为AIC（赤池信息准则）：AIC =(2xn)-2xlnL，其中n是参数的数量。这对添加参数的似然分数不利。在一组模型中进行选择时，首选AIC最低的模型。我们稍后将在本实验中使用AIC。 除了评估模型适合度之外，我们还可以使用布朗运动模型来重建树上角色的祖先状态。 在树上可视化此特征的BM演变情况。phytools中的contMap()命令估计祖先状态并将其绘制在树上。 根据颜色可以查看awesomeness在进化树上各个物种间的速率变化情况。
contMap(anoleTree, awe, fsize = 0.5, lwd = 3)
让我们继续测试一些别的假设。敌意是数据矩阵中的另一个特征。让我们评估一下，蜥蜴的敌对程度与它的强大程度之间是否存在相关性？我们将从数据矩阵中提取“敌对性”列，并为其指定物种名称，就像上面对“令人敬畏”所做的一样。
host<-anoleData[,"hostility"]
names(host)<-rownames(anoleData)
#画图查看数据awesomeness和hostility是否关联
plot(host, awe, xlab = "hostility", ylab = "awesomeness")
#我们认为其线性相关
#线性回归
lm_awehost <- lm(awe ~ host)
#绘制趋势线并查看结果
abline(lm_awehost)
summary(lm_awehost)
#lm(formula = awe ~ host)
#Residuals:
# Min 1Q Median 3Q Max
#-0.66437 -0.32868 -0.04684 0.21507 1.03350
#
#Coefficients:
# Estimate Std. Error t value Pr(>|t|)
#(Intercept) 0.14725 0.04041 3.644 0.000431 ***
#host -0.97092 0.04030 -24.091 < 2e-16 ***
#---
#Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
#Residual standard error: 0.3997 on 98 degrees of freedom
#Multiple R-squared: 0.8555, Adjusted R-squared: 0.8541
#F-statistic: 580.4 on 1 and 98 DF, p-value: < 2.2e-16
来自summary()命令的系数表显示了线性模型的斜率和截距，该线性模型描述了可怕程度与敌对性的关系。每行显示估计的系数(Estimate)，该估计的标准误差(Std.Error)以及t统计量和关联的p值，以测试这些参数是否等于0。预测变量可以解释响应变量中有多少方差的估计。 但是，我们没有考虑过这些蜥蜴在系统发育上彼此相关的事实。因此，他们可能仅由于其祖先是敌对的或强大的事实而导致自己也有敌意和强大的特性。换句话说，我们需要考虑由于系统发育导致的残差的非独立性。一种方法是使用系统发育广义最小二乘回归（PGLS）
#先尝试手动计算PGLS
#我们可以查看数据awesomeness和hostility是否关联
plot(anoleData[,c("awesomeness", "hostility")])
#两数据关联，那么我们可以检测它们的PIC（多态信息量）
#提取列
host<-anoleData[,"hostility"]
awe<-anoleData[,"awesomeness"]
#赋名
names(host)<-names(awe)<-rownames(anoleData)
#计算PIC
hPic<-pic(host, anoleTree)
aPic<-pic(awe, anoleTree)
#建模（回归）
picModel<-lm(hPic~aPic-1)
#结果
summary(picModel)
#lm(formula = hPic ~ aPic - 1)
#
#Residuals:
# Min 1Q Median 3Q Max
#-2.1051 -0.4188 0.0103 0.3137 4.9991
#
#Coefficients:
# Estimate Std. Error t value Pr(>|t|)
#aPic -0.97758 0.04516 -21.65 <2e-16 ***
#---
#Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ #0.1 ‘ ’ 1
#
#Residual standard error: 0.8967 on 98 degrees of freedom
#Multiple R-squared: 0.827, Adjusted R-squared: 0.8253
#F-statistic: 468.6 on 1 and 98 DF, p-value: < 2.2e-16
#绘图
plot(hPic~aPic)
abline(a=0, b=coef(picModel))
我们也可以直接用函数包去做。 让我们分解一下下面这个函数。该函数认为强大与敌对线性相关（gls（awesomness〜敌对性，data = anoleData）），同时它将数据中的现有相关结构(correlation =)即协方差指定为基于anolis树(phy = anoleTree)的布朗运动模型(corBrowinan())。然后使用最大似然（方法=“ ML”）拟合模型。结果如下：
pglsModel <- gls(awesomeness ~ hostility, data = anoleData, correlation = corBrownian(phy = anoleTree), method = "ML")
summary(pglsModel)
#Generalized least squares fit by maximum likelihood
# Model: awesomeness ~ hostility
# Data: anoleData
# AIC BIC logLik
# 176.5222 184.3377 -85.26109
#Coefficients:
# Value Std.Error t-value p-value
#(Intercept) 0.1700421 0.24412080 0.696549 0.4877
#hostility -0.8460104 0.03908066 -21.647804 0.0000
# Correlation:
# (Intr)
#hostility 0.015
#Standardized residuals:
# Min Q1 Med Q3 Max
#-0.88294306 -0.39063739 -0.07057664 0.30315385 1.41114453
#Residual standard error: 0.8258384
#Degrees of freedom: 100 total; 98 residual
coef(pglsModel)
#(Intercept) hostility
# 0.1700421 -0.8460104
abline(a = coef(pglsModel)[1], b = coef(pglsModel)[2], col = "red")
#改良一番
plot(host, awe, xlab = "hostility", ylab = "awesomeness", main = "Awesomeness as a Function of Hostility")
abline(lm_awehost, lty = 2) #uncorrected LM
abline(a = coef(pglsModel)[1], b = coef(pglsModel)[2]) #BM
legend("topright", lty = c(1, 2), legend = c("PGLS", "uncorrected"))
面对这两条线我们可能会发现，这些回归在预测敌对行为带来的强大能力方面是否真的有所不同。换句话说就是这两个回归的斜率有统计学的显著区别吗？我们需要知道，斜率参数的95％置信区间为b（斜率）正负1.96标准误差（这是从正态分布得出的）。那么接下来要计算你的95％置信区间：
awehost.sum <- summary(lm_awehost)
awehost.sum$coef[2, 1]+c(-1, 1)*awehost.sum$coef[2, 2]
coef(pglsModel)[2]+c(-1, 1)*sqrt(pglsModel$varBeta[2, 2])
#确实不大一样
PGLS的功能还有很多，我们还可以给数据增加anova分析来判断离散程度,也可以同时模拟多个变量：
pglsModel2<-gls(hostility~ecomorph, correlation=corBrownian(phy=anoleTree), data=anoleData, method="ML")
anova(pglsModel2)
#Denom. DF: 93
# numDF F-value p-value
#(Intercept) 1 0.01986379 0.8882
#ecomorph 6 0.23482069 0.9641
coef(pglsModel2)
#同时拟合多个变量
pglsModel3<-gls(hostility~ecomorph*awesomeness, correlation=corBrownian(phy=anoleTree), data=anoleData, method="ML")
anova(pglsModel3)
#Denom. DF: 86
# numDF F-value p-value
#(Intercept) 1 0.1416 0.7076
#ecomorph 6 1.6740 0.1371
#awesomeness 1 549.8314 <.0001
#ecomorph:awesomeness 6 4.5226 0.0005
OU与EM模型下的PGLS 布朗运动只是连续变量演化的一种模型。另一个模型是Ornstein-Uhlenbeck(OU)模型，该模型允许特征均值通过选择力(alpha)向新状态(theta)演化。这两个新参数，加上BM模型的起始状态（z0）和演化速率（sigsq）参数，构成了一个4参数模型。早期爆发模型(EB)模型允许整个树的进化速率发生变化，树的早期进化速率很高并且会随时间而下降（大概是在适应性辐射状的扩散过程中，生态位被填满了。进化速率随时间呈指数变化） 并在模型r[t] = r[0] x exp(axt)下指定，其中r[0]是初始速率，a是速率更改参数，t是时间，最大范围设置为-0.000001，代表进化速度的降低，最小范围设置为log（10 ^ -5）/进化树的长度。 让我们评估这三个模型与Awesomeness特征的相对适合度。
#和发育树匹配
brownianModel <- fitContinuous(anoleTree, awe)
OUModel <- fitContinuous(anoleTree, awe, model = "OU")
EBModel <- fitContinuous(anoleTree, awe, model = "EB")
#查看结果
brownianModel
OUModel
EBModel
那么，根据AIC，OU模型可以更好地拟合这些数据。
#不要收敛，不然难以固定
pglsModelLambda<-gls(hostility~awesomeness, correlation=corPagel(1, phy=anoleTree, fixed=FALSE), data=anoleData, method="ML")
#报错，这是规模问题。我们可以通过增加分支长度来快速固定参数。除了重新调整讨厌的参数外，这不会影响分析。
tempTree<-anoleTree
tempTree$edge.length<-tempTree$edge.length * 100
pglsModelLambda<-gls(hostility~awesomeness, correlation=corPagel(1, phy=tempTree, fixed=FALSE), data=anoleData, method="ML")
summary(pglsModelLambda)
#Generalized least squares fit by maximum likelihood
# Model: hostility ~ awesomeness
# Data: anoleData
# AIC BIC logLik
# 72.56056 82.98124 -32.28028
#Correlation Structure: corPagel
# Formula: ~1
# Parameter estimate(s):
# lambda
#-0.1585633
#Coefficients:
# Value Std.Error t-value p-value
#(Intercept) 0.0612470 0.01581847 3.871868 2e-04
#awesomeness -0.8776519 0.03104246 -28.272628 0e+00
# Correlation:
# (Intr)
#awesomeness -1
#Standardized residuals:
# Min Q1 Med Q3 Max
#-1.78946302 -0.71477505 0.00309539 0.78509306 2.23215144
#Residual standard error: 0.3709858
#Degrees of freedom: 100 total; 98 residual
pglsModelOU<-gls(hostility~awesomeness, correlation=corMartins(1, phy=tempTree), data=anoleData, method="ML")
summary(pglsModelOU)
#Generalized least squares fit by maximum likelihood
# Model: hostility ~ awesomeness
# Data: anoleData
# AIC BIC logLik
# 96.63478 107.0555 -44.31739
#Correlation Structure: corMartins
# Formula: ~1
# Parameter estimate(s):
# alpha
#4.441625
#Coefficients:
# Value Std.Error t-value p-value
#(Intercept) 0.1084258 0.03952884 2.742954 0.0072
#awesomeness -0.8811632 0.03657646 -24.090988 0.0000
# Correlation:
# (Intr)
#awesomeness -0.269
#Standardized residuals:
# Min Q1 Med Q3 Max
#-1.8664557 -0.8132899 -0.1103815 0.6474918 2.0919152
#Residual standard error: 0.376904
#Degrees of freedom: 100 total; 98 residual
#看看图
abline(pglsModelOU)
plot(host, awe, xlab = "hostility", ylab = "awesomeness")
abline(a = coef(pglsModelOU)[1], b = coef(pglsModelOU)[2], col = "red")
Phylogenetic matching of discrete variables
到目前为止，我们一直在处理连续字符，即那些沿某个连续统取值的字符。诸如身高，体重，长度，温度，湿度等是连续变量。 还有另一种类型的变量称为离散变量，该变量具有离散值：颜色（例如红色，蓝色，绿色）； 运动类型（例如，掘土，陆行）是离散变量的几个例子。 在我们的数据矩阵中，已经为每个物种编码了Island。让我们通过重建祖先的岛屿（即起源区域）和散布的历史来研究这些蜥蜴的一些生物地理特征。 我们可以同时使用离散特征映射模型(sym: symmetric model)进行拟合，并使用一种称为随机特征映射的方法来创建一组合理的特征历史记录：该分析产生一个“Q”矩阵，该矩阵显示了状态之间变化的相对概率。对于这个数值，这将代表岛屿之间的分散事件。值越高，该类型的更改的可能性越高。(还有ARD: All Rates Different matrix和ER单参数等速率模型可供选择) 现在，你可以根据上面推断的值绘制此字符变化的随机模拟。
#提取变量
island <- anoleData$island
names(island) <- rownames(anoleData)
island_anc <- make.simmap(anoleTree, island, model = "SYM", nsim = 100)
#100个模拟中的第一个图
plotSimmap(island_anc[[1]], fsize = 0.5)
我们可以总结这些模拟并估计每个岛作为系统发育树上每个节点的祖先的相对概率：
island_summary <- summary(island_anc)
plot(island_summary, cex = c(0.5, 0.2), fsize = 0.5, offset = 90)
legend("bottomleft", fill = c("black", "red", "green", "blue"),
legend = c("Cuba", "Hispanola", "Jamaica", "PR"))
Back to the top
- Basic R analysis
Ramdom forest
Introduction
随机森林（Random Forest）是一种集成学习（Ensemble Learning）中的套袋算法（bagging），具体说来是一种Bootstrap方法。
Bootstrap是一种非参数统计蒙特卡洛方法，原理就是通过抽样来对总体特征进行统计推断。其通过大量的重抽样（Re-sample）来获得大量的新样本，根据大量新样本的方差和协方差来推断出原先样本的均值与标准误等统计量。
那么套袋算法又是什么呢？简单来说就是在原始数据中用Bootstrap抽取指定（n）个训练样本，进行k轮抽取，得到k个相互独立的训练集（如有1000个数据，我们以5个数据作为一个训练集，抽500次）。接着我们利用这k个训练集训练k个模型（模型由具体问题而定，如决策树（备注，一般是决策树，很多很多决策树组成了森林所以叫随机森林）或者knn），那么对于分类问题，由投票表决产生分类结果，而对于回归问题，则通过k个模型的结果的均值作为预测结果。
优点：很准，缺点：算是个黑箱。
随机森林在大部分分类问题中的训练速度和精度远大于knn和svm。knn易于实现但是预测缓慢，是惰性学习算法。svm的优势是效果不错且稳定，预测速度快（只需要和支持向量进行比较，支持向量往往很少）。 大部分竞赛中，随机森林比knn和svm用的要多。
randomForest package
我们主要通过R包randomForest和它的优化包randomForestExplainer来实现。 来源: vignettes/randomForestExplainer.Rmd
#安装并启动相关包
library(randomForest)
#此包在git上下载
#devtools::install_github("MI2DataLab/randomForestExplainer")
library(randomForestExplainer)
在这里用于演示随机森林模型运算的数据来自R包MASS中的Boston数据，这是波士顿郊区的房价数据，其中crim为按城镇划分的犯罪率，zn为25000尺以上面积的豪宅的比例，indus为每个城镇的非零售业务的商业用地比例，chas为是否在查理河边，1为在，0为不在，nox为氮氧化物浓度，rm为每间房屋的平均房间数，age1940年前就住在这里的自建房户数的比例，dis距离五个就业中心的加权平均数，rad公路可达性指数，tax每10000美元的增值税率，ptratio按城镇划分的教师比例，black黑人比例，lstat底层人口比例，medv房价的中值。
#提取数据
data(Boston, package = "MASS")
#将chas转为逻辑变量，即FALSE和TURE
Boston$chas <- as.logical(Boston$chas)
#显示数据
str(Boston)
接下来可以使用randomForest包进行随机森林的拟合
#mtry函数为指定随机森林的训练次数，默认是500
forest <- randomForest(medv ~ ., data = Boston, localImp = TRUE)
forest
#Call:
# randomForest(formula = medv ~ ., data = Boston, localImp = TRUE)
# Type of random forest: regression
# Number of trees: 500
#No. of variables tried at each split: 4
#
# Mean of squared residuals: 9.671408
#endregion % Var explained: 88.54
这就是随机森林模型的简单实现了
randomForestExplainer package
Decision Tree of Random Forest 决策树是一个递归过程，即通过对变量（节点）进行不断分类，细分出最符合结果的特征。在决策树的基本算法中，有三种情形会导致递归返回：(1)当前的节点所包含的样本全属于同一类别，无需划分；(2)当前属性集为空或是所有样本在所有属性上取值相同，无需划分；(3)当前节点包含的样本集合为空，不能划分。
另外，我们还可以看到决策树学习的关键是算法，即如何选择最优划分属性？一般而言，随着划分过程不断进行，我们希望决策树的分支节点所包含的样本尽可能属于同一类别，即节点的“纯度”越来越高。
变量重要性是通过考虑节点纯度的平均增加程度决定的（该变量导致的分裂）来计算的。哪个变量的分裂导致节点纯度的更大增加在这一指标中显得尤为重要。一般而言第一次分裂通常会导致节点纯度的最大增加因此往往这个变量的重要性最高。而最小深度表示此变量首次用于拆分树的时间是什么。如果是这种情况，则有意义的是，更重要的变量具有较低的最小深度值。导致纯度增加较大的分裂较早发生，因此重要变量会在早期分裂，因此最小深度较低的变量有着更高的重要性。
Min depth distribution 函数plot_min_depth_distribution用于绘制随机森林的最小深度分布，其在默认设置下根据随机森林使用的顶部树（mean_sample = “top_trees”）计算的平均最小深度来获得前十个变量的最小深度分布图。我们也可以将随机森林的直接传递给绘图函数，但是如果要制作多个深度最小分布图，则将传递min_depth_frame给绘图函数更有效，这样就不会为每个绘图再次计算。
#显示决策树的最小深度分布
min_depth_frame <- min_depth_distribution(forest)
save(min_depth_frame, file = "min_depth_frame.rda")
load("min_depth_frame.rda")
head(min_depth_frame, n = 10)
#绘制最小分布图像
#也可以这样：plot_min_depth_distribution(forest)
plot_min_depth_distribution(min_depth_frame)
函数 plot_min_depth_distribution 计算平均最小深度时，该函数提供了三种可能性，它们的不同之处在于，它们处理在不使用变量在树的分支时出现的缺失值。它们可以描述如下：
mean_sample = "relevant_trees"：这仅考虑存在交互作用的树。mean_sample = "all_trees"：relevant_trees存在一个主要问题，即对于仅出现在少量树中的交互，采用条件最小深度的平均值会忽略这种交互并不那么重要的事实。在这种情况下，较小的平均条件最小深度并不意味着交互是重要的。为了解决这个问题，该函数用根变量的最大子树的平均深度替换相关的有交互作用的条件最小深度。基本上，如果我们查看x1：x2的交互作用，则表示对于不存在这种交互作用的树，请为其提供根为x1的最深树的值。这为mean_min_depth交互提供了一个（希望是很大的）数值，以免因为x1:x2的交互作用使其重要性下降。mean_sample = "top_trees": 这是的默认选项，它类似于all_trees，但是尝试降低替换缺失值的贡献。原因是当有许多参数但观测不足时，即树的长度比较浅时，all_trees将其拉近mean_min_depth相同的值。为了减少替换缺失值的影响，top_trees仅计算子树n的平均条件最小深度，其中n是存在与指定根的任何交互的树数。 下面我们只查看有交互作用的树产生的结果：#添加k参数可以控制绘制的最大变量数，mean_scale可以将平均最小深度的值缩放至[0,1] #main可以调整图的标题，mean_round调整平均最小深度的小数点位数 plot_min_depth_distribution(min_depth_frame, mean_sample = "relevant_trees", k = 15, mean_round = 1, main = "plot", mean_scale = 1)
Importance of virables 使用measure_importance函数获得变量的各种重要性。
importance_frame <- measure_importance(forest)
#储存计算结果，以免以后调动时占用cpu资源
save(importance_frame, file = "importance_frame.rda")
load("importance_frame.rda")
# importance_frame
# variable mean_min_depth no_of_nodes mse_increase node_purity_increase
# 1 age 3.208000 8934 4.0855711 1134.2629
# 2 black 3.428000 7889 1.4867754 765.1144
# 3 chas 6.428656 789 1.1975552 258.2084
# 4 crim 2.376000 9571 9.2249340 2493.8493
# 5 dis 2.562000 9261 7.9411435 2534.7189
# 6 indus 3.287496 4151 6.2116244 2449.1251
# 7 lstat 1.248000 11331 57.2785166 12817.6106
# 8 nox 2.474000 6069 10.3533262 2879.2618
# 9 ptratio 2.708000 4521 8.2257481 2798.4201
# 10 rad 4.871496 2618 1.6589265 416.1605
# 11 rm 1.538000 11424 32.9913736 11762.1410
# 12 tax 3.478000 4361 4.2818940 1417.1772
# 13 zn 5.973904 1536 0.4787724 292.5830
# no_of_trees times_a_root p_value
# 1 500 1 1.078759e-225
# 2 500 1 3.641439e-85
# 3 414 0 1.000000e+00
# 4 500 16 0.000000e+00
# 5 500 0 3.453578e-282
# 6 499 65 1.000000e+00
# 7 500 141 0.000000e+00
# 8 500 49 9.998443e-01
# 9 500 61 1.000000e+00
# 10 499 5 1.000000e+00
# 11 500 126 0.000000e+00
# 12 500 29 1.000000e+00
# 13 476 6 1.000000e+00
关于上述数据的解释，其每列均为一个重要性的衡量指标：
- accuracy_decrease（分类问题中会出现） 变量被排序后的预测准确率的平均下降程度
- gini_decrease（分类问题中会出现） 变量分裂后节点杂质的平均减少程度
- mse_increase（回归问题中出现，比如这次）变量被排序后的均方误差（MSE）
- node_purity_increase（回归问题中出现）变量分裂后节点纯度的平均增加值，以平方和的减少表示
- mean_minimal_depth 平均最小深度，不谈
- no_of_trees 变量被排序完成后所使用的决策树的数量
- no_of_nodes 变量排序后决策树的节点总数（树很浅的时候往往等于树的数量）
- times_a_root 变量用于拆分根节点所用的树的总数（第一次二分类或者n分类所用的树）（一般这个就是指重要性值）
- p_value 似乎也不用解释？
接下来我们可以绘制重要性指标图：
#也可以用最上面的forest这个最早的随机森林的结果来绘图，是一样的
plot_multi_way_importance(importance_frame, size_measure = "no_of_nodes")
显然由图可以得知底层人口数量和住宅的房间数量与房价显著相关，但可以更进一步，看一看树的结构相关的数据与变量的关系
#x/y_measure指定坐标轴类型，size_measure指定颜色，no_of_labels指定显示前5个优秀的变量的名称
plot_multi_way_importance(importance_frame, x_measure = "mse_increase", y_measure = "node_purity_increase", size_measure = "p_value", no_of_labels = 5)
Select suitable importance indicators
一般来说，多向重要性图提供了多种可能性，因此很难选择最重要的那一个。克服这一障碍的一个想法是，首先探索不同重要性指标之间的关系，然后选择三个最不一致的指标，并将它们运用到多因素重要性图中，以选择最重要的变量。第一种方法很容易实现，方法是使用下面的plot_importance_ggpairs函数将选定的重要性度量成对地绘制出来。当然，我们可以在图中包含所有七个度量值，但默认情况下，p值和树的数量被排除在外，因为它们携带的信息与节点数相似。
#plot_importance_ggpairs(forest)
plot_importance_ggpairs(importance_frame)
我们可以看到，所有描述的测量值都是高度相关的（当然，任何测量值与平均最小深度的相关性都是负相关），但是有些测量值比其他测量值低。此外，无论我们比较哪种度量，似乎总有两个点是突出的，而这两个点最有可能对应于lstat和rm，它们可以是主要的预测因子/重要的影响因子。
Interactions between variables
这里我们可以使用有条件的最小深度来衡量基于交互作用修正后的各个因子之间的最小深度。 在选择了一组最重要的变量之后，我们可以研究它们之间的相互作用，即在最大子树中出现的与所选变量之一相关的分裂。为了根据变量出现的树的平均最小深度和树数，我们提取5个最重要变量，将我们的重要性评价系统传递给函数重要变量。
#(vars <- important_variables(forest, k = 5, measures = c("mean_min_depth", "no_of_trees")))
(vars <- important_variables(importance_frame, k = 5, measures = c("mean_min_depth", "no_of_trees")))
结果：[1] "lstat" "rm" "crim" "nox" "dis" 我们将结果和研究出的forest一起传递给min_depth_interactions函数，以获得一个东西，其中包含关于变量的每个元素的变量的平均条件最小深度的信息（缺失值与无条件最小深度类似地填充，用mean_sample指定的三种方式之一）。如果我们不指定vars参数，那么默认情况下，条件变量的向量将使用重要变量measure_importance（forest）获得。
#interactions_frame <- min_depth_interactions(forest, vars)
#save(interactions_frame, file = "interactions_frame.rda")
load("interactions_frame.rda")
head(interactions_frame[order(interactions_frame$occurrences, decreasing = TRUE), ])
然后，我们将我们的interactions_frame传递给绘图函数plot_min_depth_interactions，得到以下结果：
# plot_min_depth_interactions(forest)
plot_min_depth_interactions(interactions_frame)
交互作用是通过减少出现次数来排序的,即为最频繁的一次，所以lstat和rm有最小平均条件最小深度。值得注意的是，以lstat为根变量，rm在森林中的无条件平均最小深度几乎等于其在最大子树上的最小平均深度。 需要注意的是，使用默认的“top_trees”会惩罚出现频率低于最频繁的交互。所以如果在计算最小深度时设置mean_sample = "relevant_trees" 会有不一样的结果。
Using RF to predict
预测的话很简单，如下
#仅用于演示，实际上没有testdata
predict(forest, newdata = testdata)
但为了进一步研究房价和最相关的两个变量rm与lstat之间的关系，我们使用函数plot_predict_interaction来绘制我们的随机森林预测结果图像。该函数需要随机森林本体，训练集与x和y轴所用的变量。在内存不足的情况下，可以使用参数grid从默认值100开始减少网格的两个维度中的点数
plot_predict_interaction(forest, Boston, "rm", "lstat")
在上面的图中我们可以清楚地看到相互作用的影响：当lstat较低时，预测的中间状态（模糊？）最高，反之则为rm的高低。为了进一步研究交互作用的影响，我们可以在网格上绘制其他频繁的交互作用。
Visualization of RF
可以直接输出上述的所有结果，通过网页的形式：(非常占用计算资源与内存！！！)
explain_forest(forest, interactions = TRUE, data = Boston)
Back to the top
- Basic R analysis
Grey Prediction
一般适用于一些社会、经济、生态学等让人摸不着头脑的地方，就是一个系统，一个因素，受到很多已知条件的影响，也受到很多未知条件…就可以用灰色预测来进行预测（不知所云中） 接下来是GM11灰色预测的R程序： 来源：DATAKilimanjaro的CSDN博客 灰色预测的执行
gm <- function(x0,t) #gm(xO,t)，其中xO是向量，为原始数据，t为表示预测到第几个数据 { xl <- cumsum(x0) #读原始数列xO,并用cumsum(xO)累加生成数列文1;步骤1完成 b <- numeric(length (x0)-1) #lengthO计算xO的长度，numericO生成指定长度的0向量，这里生成比xO长度少1的0向量，记作b，实质是向量b的初始化 n <- length(x0)-1 #向量xO的长度减1，记作n for(i in 1:n){ #循环语句i从1到n循环，步进为1 b[i]<--(xl[i] + xl[i+1])/2 }#b[i]:向量b的第i个元素 d <- numeric(length(b)) # 向量 d 初始化 d[] <- 1#向量d的元素全部赋值1，即单位向量 B <- cbind(b,d) #cbind(,)以列方式将向量b和d合并成矩阵B;步骤2中矩阵B生成 BT <- t(B) #t(),将矩阵B的转置，记作BT M <- solve(BT%*%B) #solve(A，b),解方程Ax=b，返回x的值，如果b缺失，则返回A的逆矩阵，这里M是BT * B的逆矩阵* %是乘法运箅符记作BT yn<-numeric(length(x0)-1) # 向量 yn 初始化 yn<-x0[2:length(x0)] #将原始向量xO除第一个外的其余元素赋与yn步骤2的yn生成 alpha<-M%*%BT%*%yn #最小二乘法计算微分方程参数,a和u赋予向量alpha alpha2<-matrix(alpha, ncol =1) a<-alpha2[1] #提取参数a似乎直接从alpha提也行 u<-alpha2[2] #提取参数u步骤3完成 y<-numeric(length(c(1:t))) # 向量 y 初始化 y[1]<-x0[1] #原数列的第一个数值付给y的第一个数值 for(w in 1:(t-1)) { y[w+1]<-(x0[1]-u/a)*exp(-a*w) + u/a } #建模生成模型计算值完成步骤4 xy<-numeric(length(y)) #向量xy 初始化 xy[1]<-y[1] #向量xy的第1个与y的第1个值不变,初始化 for(o in 2:t) { xy[o]<-y[o]-y[o-1] } #数据还原xy为还原值。完成步骤5 xy<-round(xy,4) m<-length(x0) e<-numeric(length(x0)) #残差向量 e 初始化 for(L in 1 :m) { e[L]<-xy[L]-x0[L] } #循环语句计算残差向量e e<-round(e,4) q<-numeric(length(x0)) #相对误差向量初始化 for(L in 1:m){ q[L]<-(e[L]/x0[L]) * 100 } #循环语句计算相对误差向量q完成步骤6 q<-round(q,4) se<-sd(e) #计算残差向量e标准差 sx<-sd(x0) #计算原数列xO标准差 cv<-se/sx #计算后验差比值C #窗口打印后验差比值 pe<-abs(e-mean(e))#小频率误差 P i<-length(pe) accumulator=0 for(L in 1:i){ if (pe[L]<0.6745 * sx) accumulator = accumulator+1 } pv=accumulator/i #小频率误差P，完成步骤7 if((pv>0.95)&(cv<0.35)) d<-c("predictions is Good") else if((pv>0.8)&(cv<0.4)) d<-c("predictions is Qualified") else if((pv>0.7)&(cv<0.45)) d<-c("predictions is Reluctantly") else d<-c("predictions is not good") list(model=paste("a=",round(a,4),"u=",round(u,4)),original.data=x0, lAGO.predictions=y,predict.values=xy,Residuals=e,relative.error=q,C=cv,P=pv,test.re=d) }绘图函数 ```r plot.gm<-function(list,start=1,frequency=0)#plot.gm(上面的结果) { m1<-list x0<-m1$original.data xy<-m1$predict.values lonx0<-length(x0) lonxy<-length(xy) mx<-max(max(xy),max(x0)) mn<-min(min(xy),min(x0)) one<-(mx-mn)/25 if((start&TRUE)&(frequency&TRUE)){ x1<-seq(start,start+(lonxy-1)frequency,frequency) x2<-seq(start,start+(lonx0-1)frequency,frequency) plot(x1,xy,col=’blue’,type=’b’,pch= 16,xlab=’Time series’,ylab=’Values’,ylim = c(mn-one,mx+one)) points(x2,x0,col=’red’,type=’b’,pch=18) legend(locator(1),c(‘Predictions’,’Raw data’),pch = c(16,18),lty=1,col = c(‘blue’,’red’))} else if((start&T)&(frequency==F)){ frequency<-1 x1<-seq(start,start+(lonxy-1)frequency,frequency) x2<-seq(start,start+(lonx0-1)frequency,frequency) plot(x1,xy,col=’blue’,type=’b’,pch= 16,xlab=’Time series’,ylab=’Values’,ylim = c(mn-one,mx+one)) points(x2,x0,col=’red’,type=’b’,pch=18) legend(locator(1),c(‘Predictions’,’Raw data’),pch = c(16,18),lty=1,col = c(‘blue’,’red’)) } else{plot(xy,col=’blue’,type=’b’,pch= 16,xlab=’Time series’,ylab=’Values’,ylim = c(mn-one,mx+one)) points(x0,col=’red’,type=’b’,pch=18) legend(locator(1),inset = 0.5,c(‘Predictions’,’Raw data’),pch = c(16,18),lty=1,col = c(‘blue’,’red’)) }
}
结果输出为excel
```r
putout.gm<-function(list,file="")
{
m1<-list
x0<-m1$original.data
xy<-m1$predict.values
e<-m1$Residuals
q<-m1$relative.error
t<-length(xy)
original.data<-numeric(t) # 结果输出阶段
original.data[]<-'NA'#全缺失值填充向量
original.data[1:length(x0)]<-x0 #原数据填充向量前端，[length(x0)5 t]的元素值缺失
predict.values<-round(xy,4)
Residuals<-numeric(t)
Residuals[]<-'NA'
Residuals[1:length(e)]<-round(e,4) # 误差数据填充向量前端，[length(x0)： t]的元素值缺失
Relative.error<-numeric(t)
Relative.error[]<-'NA'
Relative.error[1:length(e)]<- round(q,4)#相对误差数据填充向量前端，[length(xO) : t]的元素值缺失
result<-cbind(original.data,predict.values,Residuals,Relative.error)#合并输出原数据、预测值、残差、相对误差
colnames(result)<-c("原始数据","预测值","残差","相对误差")
if(file == ""){
wd<-getwd()
wd2<-paste(wd,"result.csv",sep="/")
print(wd2)
write.table(result,file=wd2,sep=",",row.names = F)
}
else{
write.table(result,file=file,sep=",",row.names = F)
print(file)
}
}
Back to the top
- Basic R analysis
Structural equation model (SEM)
基于Yves Rosseel的论文，doi: 10.18637/jss.v048.i02 据说有本书叫Latent Variable Modeling Using R，没看过，先mark
该结构方程模型（SEM）基于R语言的lavaan函数包运行。lavaan是潜在变量分析的缩写，它的名字揭示了长期目标：提供一系列工具，可用于探索、估计和理解各种潜在变量模型，包括因子分析、结构方程、纵向、多级、潜在类、项目反应和缺失数据模型。
#为了获得与商业软件相似的输出，lavaan开发了下面的功能
#lavan将努力产生与Mplus的输出相似的输出，无论是在数字上还是视觉上
mimic = “Mplus”
#lavan产生的输出接近EQS的输出，至少在数字上（不是视觉上），
simic= “EQS”
Introduction
首先了解测量模型（measurement model）和结构模型（structural model），测量模型关注的是因子的载荷和结构（EFA和CFA），结构模型则关注的是跨因子间的预测和解释（回归，相关等等）。 CFA是结构强度（Confirmatory Factor Analysis），是确定当前设定的变量之间是有关系的，如果CFA通过，那可以把模型继续下去了。 那么所有的SEM模型都是这几个步骤：
- CFA通过，就是保证结构
- 路径分析（ANOVA & Correlation），显示相关分析，零阶相关矩阵要显著相关才能进入下一步，然后就是共同方法偏差检验，如测量方式相同就要做这个，就是对所有变量做单因素的CFA，如果没有拟合，说明不怎么出现共同方法偏差，就比较好了。接着是路径分析，就是画一个饱和模型然后删到仅存的路径的效应量和sig都比较好了。然后可以多做几个算是竞争模型看看情况。
- 中介及调节检验，做bootstrap什么的，然后就好了
About SEM 路径图通常是研究人员寻求拟合SEM模型的起点。非正式地说，路径图是一种示意图，它代表了研究人员要拟合的模型的简明概述。它包括所有相关的观察变量（通常用方框表示）和潜在变量（用圆圈表示），并用箭头说明这些变量之间的（假设的）关系。一个变量对另一个变量的直接影响用单箭头表示，而变量之间（未解释的）相关性用双头箭头表示。研究者的主要问题通常是将此图转换为SEM程序所期望的适当输入。此外，研究人员必须格外小心，以确保模型是可识别和可估计的。 在lavan软件包中，模型是通过一种功能强大、易于使用的基于文本的语法（称为“lavan模型语法”）来指定的。考虑一个简单的回归模型，其中有一个连续的因变量$y$，以及四个自变量$x_1$、$x_2$、$x_3$和$x_4$。通常的回归模型可以写如下： \(y_{i}=\beta _{0}+\beta _{1}x_{1i}+\beta _{2}x_{2i}+\beta _{3}x_{3i}+\beta _{4}x_{4i}+\varepsilon _{i}\) 其中$β_0$被称为截距，$β_1$到$β_4$是四个变量中每一个的回归系数，$ε_i$是观测值i的残差。R环境的一个吸引人的特点是我们可以用紧凑的方式来表达一个类似于上述的回归公式：
y ~ x1 + x2 + x3 + x4
在这个公式中，~是回归运算符。在运算符的左侧，我们有因变量y，在右侧，我们有自变量，用+分隔。注意，公式中没有明确包含截距与残差项。但是当这个模型被拟合时（例如使用lm()函数），残差的截距和方差都将被估计。当然，其基本逻辑是截距和残差项（几乎）总是（线性）回归模型的一部分，而且在回归公式中不需要提及它们。只需要指定结构部分（因变量和自变量），其余部分由lm()函数负责。 看待SEM模型的一种方法是，它们只是线性回归的扩展。第一个扩展是可以同时拥有多个回归方程。第二个扩展是，一个方程中的自变量（外生变量）可以是另一个方程中的因变量（内生变量）。使用与R中单个方程相同的语法来指定这些回归方程似乎很自然；我们只有一个以上的回归方程。例如，我们可以有一组三个回归方程：
y1 ~ x1 + x2 + x3 + x4
y2 ~ x5 + x6 + x7 + x8
y3 ~ y1 + y2
SEM模型的第三个扩展是它们包含连续的潜在变量。在lavaan中，任何回归公式都可以包含作为因变量或自变量的潜在变量。例如，在下面显示的语法中，以f开头的变量是潜在变量：
y1 ~ f1 + f2 + x1 + x2
f1 ~ x1 + x2
模型语法的这一部分与SEM模型的“结构部分”相对应。为了描述模型的“测量部分”，我们需要为每个潜在变量指定（观察到的或潜在的）指标。在lavaan中，这是用特殊运算符’=~’来完成的，这可以从中看出。此公式的左侧包含潜在变量的名称。右侧包含此潜在变量的指示符，用“+”运算符分隔。例如：
f1 =~ item1 + item2 + item3
f2 =~ item4 + item5 + item6 + item7
f3 =~ f1 + f2
在本例中，变量item1到item7是观察变量。因此，潜在变量f1和f2是一阶因子。潜在变量f3是一个二阶因子，因为它的所有指标本身都是潜在变量。 为了在模型语法中指定（残差）方差和协方差，lavaan提供了~~运算符。如果左右两侧的变量名相同，则为方差(var)。如果名字不同，那就是协方差(covar)。残差(协)方差和非残差(协)方差之间的区别是自动进行的。例如：
item1 ~~ item1 # variance
item1 ~~ item2 # covariance
最后，观察变量和潜在变量的截距是简单的回归公式（使用“~”运算符），只有一个截距（用数字“1”明确表示）作为唯一的预测因子：
item1 ~ 1 # intercept of an observed variable
f1 ~ 1 # intercept of a latent variable
描述SEM模型的典型模型语法将包含多个公式类型。在lavaan中，要将它们粘在一起，必须将它们指定为文本字符串。环境中可以用单引号括起来。例如:
myModel <- '# regressions
y ~ f1 + f2
y ~ x1 + x2
f1 ~ x1 + x2
# latent variables
f1 =~ item1 + item2 + item3
f2 =~ item4 + item5 + item6 + item7
f3 =~ f1 + f2
# (residual) variances and covariances item1 ~~ item1
item1 ~~ item2
# intercepts
item1 ~ 1
f1 ~ 1'
这段代码将生成一个名为myModel的模型语法对象，稍后在调用一个函数时可以使用该对象来估计给定数据集的\模型，它说明了lavaan模型语法的几个特性。公式可以拆分为多行，您可以在单引号内使用注释（以“#”字符开头）和空行，以提高模型语法的可读性。公式的指定顺序无关紧要。因此，即使在使用“=~”运算符定义回归公式之前，也可以使用它们。最后，由于这个模型语法只不过是一个文本字符串，所以您可以在单独的文本文件中键入语法，然后使用readLines()之类的函数来读入它。或者，R的文本处理基础设施可以用来为各种模型生成语法。
Confirmatory Factor Analysis by lavaan
lavaan包包含一个名为HolzingerSwineford1939的内置数据集。1939年Holzinger&Swineford数据集是一个“经典”数据集，已在许多关于结构方程建模的论文和书籍中使用，包括一些商业SEM软件包的手册。数据包括来自两所不同学校（巴斯德和格兰特怀特）的七年级和八年级儿童的智力测试分数。在我们的数据集版本中，最初26个测试中只有9个包含在内。通常针对这9个变量提出的CFA模型由三个相关的潜在变量（或因子）组成，每个变量都有三个指标：
- 视觉相关的因素由3个变量决定: x1, x2, x3,
- 文本相关的因素由3个变量决定: x4, x5, x6,
- 速度相关的因素由3个变量决定: x7, x8, x9. 因此，我们从装载Lavaan包与数据开始：
library("lavaan")在下面的内容中，我们将把这个三因素模型称为“H&S模型”，图1以图形方式表示。注意，图中的路径图是简化的：它不表示观测变量的残差方差或外生潜在变量的方差。不过，它抓住了模型的本质。在讨论该模型的lavan模型语法之前，首先需要确定该模型中的自由参数。在这个模型中有三个潜在变量（因子），每个变量有三个指标，因此需要估计九个因子的负荷。潜在变量之间还有三个协方差-另外三个参数。这些参数分别用双头箭头和双头箭头表示。此外，我们还需要估计9个观测变量的残差方差和潜在变量的方差，从而得到12个额外的自由参数。我们总共有24个参数。但是模型还没有确定，因为我们需要设置潜在变量的度量。通常有两种方法可以做到这一点：（1）对于每个潜在变量，将其中一个指标（通常是第一个）的因子负荷固定为常数（通常为1.0），或（2）标准化潜在变量的方差。不管怎样，我们修复了其中的三个参数，并且有21个参数仍然是自由的。由parTable（）方法生成的表2包含了该模型所有相关参数的概述，包括三个固定因子荷载。表中的每一行对应于一个参数。“rhs”、“op”和“lhs”列唯一地定义了模型的参数。所有带有“=~”运算符的参数都是因子加载，而带有“~~”运算符的所有参数都是方差或协方差。“free”列中的非零元素是模型的自由参数。“free”列中的零元素对应于固定参数，其值在“ustart”列中找到。“用户”栏的含义将在下面解释。 Lavaan有三种方法来指定模型。在第一种方法中，用户对模型的最小描述由程序自动添加其余元素。这种“用户友好”的方法在fitting函数
cfa()和sem()中实现。在第二种方法中，所有模型参数的完整说明必须由用户提供，不会自动添加任何内容。这是“超级用户”方法，在函数lavaan()中实现。最后，在第三种方法中，通过在模型语法中提供对模型的不完整描述，但使用lavan函数的auto.*参数添加选定的参数组，从而混合了最简方法和完整方法。我们依次说明和讨论这些方法。cfa() and sem()
在第一种方法中，用户提供的模型语法应该尽可能简洁易懂。为了实现这一点，模型语法中通常只包含潜在变量（使用“=~”运算符）和回归（使用“~”运算符）。其他模型参数（对于该模型：观测变量的残差方差、因子的方差和因子之间的协方差）是自动添加的。由于H&S示例包含三个潜在变量，但没有回归，因此最简语法非常简短：
HS.model <- 'visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 speed =~ x7 + x8 + x9'我们导入数据：
fit <- cfa(HS.model, data = HolzingerSwineford1939)函数cfa()是用于拟合验证性因子分析(cfa)模型的专用函数。第一个参数是包含lavaan模型语法的对象。第二个参数是包含观察到的变量的数据集。下表中的“user”列显示哪些参数显式包含在用户指定的模型语法（=1）中，哪些参数是由cfa()函数（=0）添加的。如果已安装模型，则始终可以（且信息量很大）使用以下命令检查此参数表：
parTable(fit)id lhs op rhs user block group free ustart exo label plabel start est se 1 1 visual =~ x1 1 1 1 0 1 0 .p1. 1.000 1.000 0.000 2 2 visual =~ x2 1 1 1 1 NA 0 .p2. 0.778 0.554 0.100 3 3 visual =~ x3 1 1 1 2 NA 0 .p3. 1.107 0.729 0.109 4 4 textual =~ x4 1 1 1 0 1 0 .p4. 1.000 1.000 0.000 5 5 textual =~ x5 1 1 1 3 NA 0 .p5. 1.133 1.113 0.065 6 6 textual =~ x6 1 1 1 4 NA 0 .p6. 0.924 0.926 0.055 7 7 speed =~ x7 1 1 1 0 1 0 .p7. 1.000 1.000 0.000 8 8 speed =~ x8 1 1 1 5 NA 0 .p8. 1.225 1.180 0.165 9 9 speed =~ x9 1 1 1 6 NA 0 .p9. 0.854 1.082 0.151 10 10 x1 ~~ x1 0 1 1 7 NA 0 .p10. 0.679 0.549 0.114 11 11 x2 ~~ x2 0 1 1 8 NA 0 .p11. 0.691 1.134 0.102 12 12 x3 ~~ x3 0 1 1 9 NA 0 .p12. 0.637 0.844 0.091 13 13 x4 ~~ x4 0 1 1 10 NA 0 .p13. 0.675 0.371 0.048 14 14 x5 ~~ x5 0 1 1 11 NA 0 .p14. 0.830 0.446 0.058 15 15 x6 ~~ x6 0 1 1 12 NA 0 .p15. 0.598 0.356 0.043 16 16 x7 ~~ x7 0 1 1 13 NA 0 .p16. 0.592 0.799 0.081 17 17 x8 ~~ x8 0 1 1 14 NA 0 .p17. 0.511 0.488 0.074 18 18 x9 ~~ x9 0 1 1 15 NA 0 .p18. 0.508 0.566 0.071 19 19 visual ~~ visual 0 1 1 16 NA 0 .p19. 0.050 0.809 0.145 20 20 textual ~~ textual 0 1 1 17 NA 0 .p20. 0.050 0.979 0.112 21 21 speed ~~ speed 0 1 1 18 NA 0 .p21. 0.050 0.384 0.086 22 22 visual ~~ textual 0 1 1 19 NA 0 .p22. 0.000 0.408 0.074 23 23 visual ~~ speed 0 1 1 20 NA 0 .p23. 0.000 0.262 0.056 24 24 textual ~~ speed 0 1 1 21 NA 0 .p24. 0.000 0.173 0.049当使用cfa()或sem()函数时，default会包含多组参数。这些参数集的完整列表为：
auto.fix.first默认true，将第一个指标的系数荷载固定为1auto.fix.single默认true，将单个指标的残差方差固定为0int.ov.free默认true，自由估计观测变量的截距 （仅当包含平均结构时）int.lv.free默认false，自由估计潜在变量的截获（仅 如果包括平均结构） 在我们的例子中，只使用了第一个函数（固定第一个指标的因子负荷）。第二个仅当模型包含由单个指标表示的潜在变量时才需要。第三和第四个只有在向模型中添加平均结构时才需要。 在我们继续下一个方法之前，必须强调所有这些“自动”操作都可以被覆盖。模型语法始终优先于自动生成的操作。例如，如果不希望固定第一个指标的因子负荷，而是要固定潜在方差的方差，则模型语法将调整如下：HS.model.bis <- 'visual =~ NA*x1 + x2 + x3 textual =~ NA*x4 + x5 + x6 speed =~ NA*x7 + x8 + x9 visual ~~ 1*visual textual ~~ 1*textual speed ~~ 1*speed'如上所示，通过将模型参数与数值相乘来固定模型参数，否则通过将固定参数与
NA相乘来释放固定参数。上面的模型语法覆盖了固定第一个因子加载和估计因子方差的默认行为。然而，在实践中，使用此参数化的一个更方便的方法是保留原始语法，通过添加std.lv = TRUE到cfa()函数中即可：fit <- cfa(HS.model, data = HolzingerSwineford1939, std.lv = TRUE)lavaan()
在许多情况下，将简洁的模型语法与cfa()和sem()函数结合使用非常方便，特别是对于许多传统模型。但有时，这些自动操作可能会妨碍工作，特别是当需要指定非标准模型时。对于这些情况，用户可能更喜欢使用lavaan()数。lavaan()函数的“特性”是，默认情况下它不会向模型添加任何额外的参数，也不会尝试使模型可识别。如果在不使用auto.*参数的情况下调用lavaan()函数，则用户有责任指定正确的模型语法。这可能导致更长的型号规格，但用户可以完全控制。对于H&S模型，完整的Lavan模型语法为：
HS.model.full <- '# latent variables latent variables visual=~1*x1+x2+x3 textual =~ 1*x4 + x5 + x6 speed =~ 1*x7 + x8 + x9 # residual variances observed variables x1~~x1 x2~~x2 x3~~x3 x4~~x4 x5~~x5 x6~~x6 x7~~x7 x8~~x8 x9~~x9 # factor variances visual ~~ visual textual ~~ textual speed ~~ speed factor covariances visual ~~ textual + speed textual ~~ speed' fit <- lavaan(HS.model.full, data = HolzingerSwineford1939)也可以结合auto.*参数一起使用： 当使用lavan()函数时，用户可以完全控制，但模型语法可能很长，并且包含许多可以轻松自动添加的公式。为了在使用Lavan语法的完整模型规范和自动添加某些参数之间进行比较，lavan()函数提供了几个可选参数，这些参数可用于向模型中添加一组特定参数，或固定一组特定参数。例如，在下面的模型语法中，第一个因子的加载显式地固定为1，并且因子之间的协方差是手动添加的。然而，在模型语法中省略残差方差和因子方差会更方便和简洁。以下模型语法和对lavan()的调用实现了这一点：
HS.model.mixed <- '# latent variables visual =~1*x1+x2+x3 textual =~ 1*x4 + x5 + x6 speed =~ 1*x7 + x8 + x9 # factor covariances visual ~~ textual + speed textual ~~ speed' fit <- lavaan(HS.model.mixed, data = HolzingerSwineford1939, auto.var = TRUE)Check results
上述三种方法都适用于同一模型。cfa()、sem()和lavan()拟合函数都返回一个
lavan类的对象，对于这个对象，有几种方法可用于检查模型拟合统计信息和参数估计值:summary()可以通过fit.measures,standardized和rsquare进行进一步设定，这个会输出一个关于模型的超长总结show()输出一个短的总结coef()以命名的数值向量的形式返回模型中自由参数的估计值fitted()返回模型的隐含矩（协方差矩阵和平均向量）resid()返回原始的、标准化的或标准化的残差（隐含和观察到的力矩之间的差异）vcov()返回估计参数的协方差矩阵predict()计算因子得分logLik()返回拟合模型的对数似然（如果使用了最大似然估计）AIC()BIC()计算信息准则（如果使用最大似然估计）update()更新为合适的的Lavaan对象inspect()窥视模型的内部；默认情况下，它返回计算模型中自由参数的模型矩阵列表；还可用于提取起始值、渐变值等 如果其中一个或多个设置为TRUE，输出将分别使用因变量的附加拟合测量、标准化估计和$R^{2}$值来丰富。在下面的示例中，我们只请求附加的拟合度:HS.model <- 'visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 speed =~x7+x8+x9' fit <- cfa(HS.model, data = HolzingerSwineford1939) summary(fit, fit.measures = TRUE)输出包括三个部分。第一部分（前6行）包含包版本号、模型是否收敛（以及迭代次数）以及分析中使用的有效观察数。接下来，打印模型$χ^2$检验统计量、自由度和$p$值。如果fit.measures = TRUE，则导出第二部分，其中包含基线模型的测试统计数据（假设所有观测变量都不相关）和几个常用拟合指数。如果使用最大似然估计，本节还将包含关于对数似然、AIC和BIC的信息。第三部分概述了参数估计，包括使用的标准误差类型，以及是否使用观测或预期信息矩阵来计算标准误差。然后，对于每个模型参数，显示估计值和标准误差，如果合适，还显示基于Wald检验的z值和相应的双侧p值。为了便于参数估计值的读取，它们被分为三个部分：（1）因子负荷，（2）因子协方差，（3）观测变量和因子的残差方差。
我们也可以使用parameterEstimates()函数。 尽管summary()方法提供了一个很好的模型结果摘要，但它只对数据的可视化有用。另一种方法是parameterEstimates()方法，它将参数估计值作为数据帧，使信息易于访问以进行进一步处理。默认情况下，parameterEstimates()方法包括所有模型参数的估计值、标准误差、z值、p值和95%置信区间。
parameterEstimates(fit)
通过设置level参数可以更改置信级别。设置ci=FALSE会抑制置信区间。此函数的另一个用途是通过设置standardized=TRUE来获得估算的几个标准版本：
Est <- parameterEstimates(fit, ci = FALSE, standardized = TRUE)
subset(Est, op == "=~")
这里只显示系数荷载。相对于先前的输出，添加了三列具有标准化值。在第一列(std.lv)，只有潜在变量被标准化；在第二列(std.all)，潜在变量和观察变量均已标准化；在第三列(std.nox)中，除外生观测变量外，潜变量和观测变量均已标准化。如果外生观测变量的标准化意义不大（例如，二元协变量），那么最后一个选项可能会有用。由于此模型中没有外部协变量，因此最后两列在输出中是相同的。
还可以使用modificationIndices()函数。 如果模型拟合度不高，检查修正指数（MIs）及其相应的期望参数变化（EPCs）可能是有益的。本质上，修正指数提供了一个粗略的估计，如果一个特定的参数是无约束的，模型的χ2检验统计量将如何改善。预期的参数更改是此参数作为自由参数包含时的值。modificationIndices()方法（或具有较短名称的别名modifications()）将打印出一长串参数作为data.frame. 在下面的输出中，我们只显示修改指数为10或更高的那些参数:
MI <- modificationIndices(fit)
subset(MI, mi >10)
最后三列包含标准化的epc，使用与普通参数估计相同的标准化约定。
SEM modeling by lavaan
在我们的第二个例子中，我们将探讨“工业化和政治民主”数据集，该数据集以前由Bollen在1989年出版的《结构方程建模》（Bollen 1989）一书中使用，并包含在Lavaan中. 数据集包含了发展中国家政治民主和工业化的各种衡量标准。在模型中，定义了三个潜在变量。分析的重点是模型的结构部分（即潜在变量之间的回归）。
model <- '
# measurement model
ind60 =~ x1 + x2 + x3
dem60 =~ y1 + y2 + y3 + y4
dem65 =~ y5 + y6 + y7 + y8
# regressions
dem60 ~ ind60
dem65 ~ ind60 + dem60
# residual covariances
y1~~y5
y2~~y4 +y6
y3~~y7
y4 ~~ y8
y6 ~~ y8'
fit <- sem(model, data = PoliticalDemocracy)
summary(fit, standardized = TRUE)
可以给定参数标签和进行简单的等式约束： 在lavaan中，每个参数都有一个名称，称为“参数标签(parameter label)”。命名方案是自动的，遵循一组简单的规则。每个标签由三个组件组成，它们描述了定义参数的相关公式。第一部分是显示在公式运算符左侧的变量名。第二部分是公式的运算符类型，第三部分是运算符右侧与参数对应的变量。要查看实际的命名机制，我们可以使用coef()函数，该函数返回自由参数的（估计）值及其相应的参数标签。
coef(fit)
用户可以在模型语法中通过预先将变量名与该标签相乘来提供自定义标签。例如，考虑以下回归公式：
y ~ b1*x1 + b2*x2 + b3*x3 + b4*x4
这里我们将四个回归系数命名为b1、b2、b3和b4。自定义标签很方便，因为您可以在模型语法的其他地方引用它们。特别是，标签可用于对某些参数施加相等约束。如果两个参数具有相同的名称，那么它们将被视为相同的，并且只为它们计算一个值（即，一个简单的等式约束）。为了说明这一点，我们将重新指定政治民主数据的模型语法。在博伦书中的原始示例中，dem60因子的因子载荷被约束为等于dem65因子的因子载荷。这是有意义的，因为这是在两个时间点上测量的同一个结构。为了执行这些等式约束，我们将dem60因子的因子加载（任意）标记为d1、d2和d3。注意，我们没有标记第一个因子加载，因为它是一个固定参数（等于1.0）。接下来，我们对dem65因子的因子加载使用相同的标签，有效地施加了三个等式约束:
model.equal <- '# measurement model
ind60 =~ x1 + x2+x3
dem60 =~ y1 + d1*y2 + d2*y3 + d3*y4
dem65 =~ y5 + d1*y6 + d2*y7 + d3*y8
# regressions
dem60 ~ ind60
dem65 ~ ind60 + dem60
# residual covariances
y1~~y5
y2~~y4 +y6
y3~~y7
y4~~y8
y6 ~~ y8'
fit.equal <- sem(model.equal, data = PoliticalDemocracy)
summary(fit.equal)
与无约束模型相比，约束模型的拟合稍差。但情况是否明显更糟？为了比较两个嵌套模型，我们可以使用anova()函数，该函数将计算$χ^2$差异检验：
anova(fit, fit.equal)
接下来可以提取拟合测度： 带有参数的summary()方法合适的措施=TRUE将输出多个拟合度量值。如果进一步处理需要fit统计信息，则首选fitMeasures()方法。fitMeasures()的第一个参数是fitted对象，第二个参数是包含要提取的fit度量值名称的字符向量。例如，如果我们只需要CFI和RMSEA值，我们可以使用：
fitMeasures(fit, c("cfi", "rmsea"))
为了完成我们的SEM示例，我们将简要介绍inspect()方法，该方法允许用户从lavaan对象的引擎盖下窥视。默认情况下，对已安装的Lavan对象调用inspect()将返回一个模型矩阵列表，这些矩阵在内部用于表示模型。自由参数是非零整数。
inspect(fit)
输出显示，lavaan目前使用的是LISREL矩阵表示法，尽管没有区分内生变量和外生变量。这就是所谓的“all-y”表示法。在将来的版本中，我计划考虑替代矩阵表示，包括Bentler-Weeks和网状作用模型（RAM）方法（Bollen 1989，第9章）。要查看每个模型矩阵中参数的起始值，请键入
inspect(fit, what = "start")
Lavaan软件包完全支持多组SEM。要请求多组分析，可以将数据集中定义组成员身份的变量传递给cfa()、sem()或lavaan()函数调用的group参数。默认情况下，在所有组中都会拟合同一个模型，而对模型参数没有任何相等约束。在下面的例子中，我们将H&S模型应用于这两所学校（Pasteur和Grant-White）:
HS.model <- 'visual =~ x1 + x2 + x3
textual =~ x4 + x5 + x6
speed =~ x7 + x8 + x9'
fit <- cfa(HS.model, data = HolzingerSwineford1939, group = "school")
summary()输出相当长，此处未显示。基本上，它显示了巴斯德群的一组参数估计值，然后是格兰特怀特群的另一组参数估计值。如果我们希望跨组对模型参数施加相等约束，可以使用组。相等争论。例如，group.equal = c(“loading”, “intercepts”)将约束系数荷载和观测变量截距在各组之间相等。可以包含在组。相等参数在拟合函数的帮助页中进行了描述。作为一个简单的例子，我们将拟合两个学派的H&S模型，但约束因子载荷和截距相等。方差分析函数可以用来比较两种模型的拟合:
fit.metric <- cfa(HS.model, data = HolzingerSwineford1939,
+ group = "school", group.equal = c("loadings", "intercepts"))
anova(fit, fit.metric)
如果group.equal参数用于约束组之间的因子加载，所有因子加载都会受到影响。如果需要一些异常，可以使用group.partial参数，它接受一个参数标签向量，指定哪些参数将在组之间重新自由使用。因此，结合group.equal以及group.partial参数为用户提供了一种灵活的机制来指定跨组相等约束。
Other functions
Asymptotic distributionless estimation（ADF）
在lavaan中，可以通过在一个拟合函数中使用估计器自变量来设置估计器。默认为最大似然估计，或estimator=“ML”。要切换到ADF estimator，可以设置estimator=“WLS”。
Satorra-Bentler test and robust standard deviation
另一种策略是使用最大似然（ML）来估计模型参数，即使已知数据是非正态的。在这种情况下，参数估计仍然是一致的（如果模型被识别并正确指定），但是标准误差往往太小（高达25–50%），这意味着我们可能会过多地拒绝零假设（参数为零）。另外，模型（$χ^2$）检验统计量往往过大，这意味着我们可能会经常拒绝模型。 在SEM文献中，一些作者扩展了ML方法来产生标准误差，这些标准误差对于任意分布（具有有限的四阶矩）是渐近正确的，并且其中重新缩放的检验统计量用于整体模型评估。 在lavaan中，test参数可用于在不同的测试统计之间切换。设置test=“Satorra-Bentler"用标度版补充标准$χ^2$模型试验。在summary()方法生成的输出中，缩放和未缩放的模型测试（以及相应的拟合指数）都显示在相邻的列中。因为人们通常需要稳健的标准误差和标度检验统计量，所以指定estimator=“MLM”可以使用标准最大似然来估计模型参数，但要使用稳健的标准误差和Satorra-Bentler标度检验统计量来拟合模型。
fit <- cfa(HS.model, data = HolzingerSwineford1939, missing = "listwise", + estimator = "MLM", mimic = "Mplus")
summary(fit, estimates = FALSE, fit.measures = TRUE)
在这个例子中，simic=“Mplus”参数被用来模拟Mplus程序计算Satorra Bentler标度测试统计的方式。默认情况下（即，当省略模拟参数时），Lavan将使用EQS程序使用的方法。为了模拟由EQS程序报告的Satorra-Bentler标度检验统计量的准确值，可以使用:
fit <- cfa(HS.model, data = HolzingerSwineford1939, estimator = "MLM", mimic = "EQS")
fit
Bootstrapping：naıve bootstrap and Bollen-Stine bootstrap
在lavaan中，通过设置se=“bootstrap”可以获得引导标准误差。在这种情况下，parameterEstimates()方法生成的置信区间将是基于引导的置信区间。如果test=“bootstrap”或test=“bollen.stine"，首先转换数据以执行基于模型的“Bollen-Stine”引导。bootstrap标准误差也基于这些基于模型的bootstrap绘图，并用bootstrap概率值来补充χ2检验统计量的标准p值，该值是通过计算引导样本中的检验统计量超过原始（父）样本的检验统计量值的比例得到的。 默认情况下，lavaan生成$R=1000$的引导绘制，但是这个数字可以通过设置bootstrap参数来更改。设置verbose=TRUE以监视引导过程可能会提供信息。
Missing value (NA)
如果数据包含缺失值，lavan中的默认行为是列表删除。如果缺失机制是MCAR（随机完全缺失）或MAR（随机缺失），则Lavan软件包提供了case-wise（或“full info”）最大似然（FIML）估计。在调用fitting函数时，可以通过指定参数missing=“ml”（或其别名missing=“FIML”）来启用FIML估计。一个非限制（h1）模型将被自动估计，以便所有常用拟合指数都可用。稳健的标准误差也可用，如果数据是不完整的和非正态的，则是标度检验统计量。
Linear and nonlinear equality/inequality constraints
在许多应用中，需要对一些模型参数施加约束。例如，可以强制要求方差参数严格为正。对于某些模型，重要的是指定一个参数等于其他参数的某个（线性或非线性）函数。lavaan包的目的是使用lavaan模型语法使这些约束易于指定。一个简短的例子将说明lavaan中的约束语法。考虑以下回归：
y ~ b1*x1 + b2*x2 + b3*x3
其中我们明确地将回归系数标记为$b_1$、$b_2$和$b_3$。我们创建一个包含这四个变量的演示数据集，并拟合回归模型：
set.seed(1234)
Data <- data.frame(y = rnorm(100), x1 = rnorm(100), x2 = rnorm(100), + x3 = rnorm(100))
model <- 'y ~ b1*x1 + b2*x2 + b3*x3'
fit <- sem(model, data = Data)
coef(fit)
假设我们希望对b1施加两个（非线性）约束：$b_1=(b_2+b_3)^2$和$b_1≥exp(b_2+b_3)$。第一个约束是等式约束，而第二个约束是不等式约束。这两个约束都是非线性的。在lavaan，这是通过以下方式实现的：
model.constr <- '# model with labeled parameters
y ~ b1*x1 + b2*x2 + b3*x3
# constraints
b1 == (b2 + b3)^2
b1 > exp(b2 + b3)'
fit <- sem(model.constr, data = Data)
summary(fit)
Indirect effects and mediation analysis
一旦对模型参数进行了拟合，我们就可以对模型的原始函数值进行估计。一个例子是两个（或更多）回归系数的乘积的间接效应。考虑一个具有三个变量的经典中介设置：Y是因变量，X是预测因子，M是中介变量。为了说明这一点，我们再次创建一个包含这三个变量的演示数据集，并拟合一个包含X对Y的直接作用和X通过M对Y的间接作用:
set.seed(1234)
X <- rnorm(100)
M <- 0.5 * X + rnorm(100)
Y <- 0.7 * M + rnorm(100)
Data <- data.frame(X = X, Y = Y, M = M) R> model <- '# direct effect
Y ~ c*X
# mediator
M ~ a*X
Y ~ b*M
# indirect effect (a*b)
ab := a*b
# total effect
total := c + (a*b)'
fit <- sem(model, data = Data)
summary(fit)
该示例说明了lavaan模型语法中:=运算符的用法。此运算符“定义”新参数，这些参数采用原始模型参数的任意函数。但是，必须根据模型语法中明确提到的参数标签来指定函数。默认情况下，这些定义参数的标准误是使用delta方法计算的。与其他模型一样，只需在fitting函数中指定se = “bootstrap”，就可以请求引导标准误。
Word cloud analysis
也就是关键词分析（TF-IDF），需要下面这两个包：
#加载包
library(jiebaR)
library(wordcloud2)
jiebaR Package
其主体为worker函数：
worker(type = "mix", #type就是选择模型，其中mix是混合模型，mp是最大概率法，hmm是隐式马尔科夫模型，query是索引模型，tag是标记模型，simhash是simhash模型，keywords是关键词模型，根据IDF搞
dict = DICTPATH, #系统词典
hmm = HMMPATH,
user = USERPATH, #用户词典
idf = IDFPATH, #IDF词典
stop_word = STOPPATH, #关键词用停止词库
write = T, #是否将文件分词结果写入文件，默认FALSE
qmax = 20,
topn = 5, #关键词数,默认5个
encoding = "UTF-8", detect = T, symbol = F, lines = 1e+05,
output = NULL, bylines = F, user_weight = "max" #用户权重
)
使用方法：
wk = worker()
#wk["这里放文字，或者txt"]
segment("这里放文字，或者txt",wk)
该函数可以自动**计算频数：
wk = worker()
words = "数模竞赛不会真出这么难的题目吧，不会吧不会吧"
freq(segment(words,wk))
处理文件的词频需要加行代码：
out=file("like_segment.txt")
freq <- freq(strsplit(readLines(out,encoding="UTF-8")," ")[[1]])
也可以提取关键词：
wk = worker(type = "keywords", topn = 2)
wk <= words
Wordcloud2 package
这个包可以绘制词云分析的结果：
#去除数字
freq <- freq[!grepl('[0-9]+',names(freq))]
#去除字母
freq <- freq[!grepl('a-zA-Z',names(freq))]
#查看处理完后剩余的词数
length(freq)
#降序排序，并提取出现次数最多的前100个词语
freq <- sort(freq, decreasing = TRUE)[1:100]
#查看100个词频最高的
freq
#提取前150个结果
freq <- f[1:150,]
#形状设置为一颗五角星等等
wordcloud2(f2, size = 0.8, shape = "star") #或者"cardioid"或"diamond"
可以基于JavaScript定义词云的颜色：
js_color_fun = "function (word, weight) {
return (weight > 2000) ? '#f02222' : '#c09292';
}"
wordcloud2(demoFreqC, color = htmlwidgets::JS(js_color_fun),
backgroundColor = 'black')
#也可以这样：
wordcloud2(demoFreqC, color = ifelse(demoFreqC[, 2] > 2000, '#f02222', '#c09292')
一个小小的实现：基于淘宝搜索的词云分析 关于tf-idf：
TF-IDF = TF(词频) * 逆文档频率(IDF)
library(jiebaR)
readChineseWords <- function (path) {
# 读取网页或文件 去除标点和英文
rawstring = readLines(path)
rawstring = paste0(rawstring, collapse = ' ')
s = gsub('\\w', '', rawstring, perl=TRUE)
s = gsub('[[:punct:]]', ' ', s)
return(s)
}
# 淘宝首页搜索'男'和'女'对应的网页链接
male_link = 'https://s.taobao.com/search?q=%E7%94%B7&search_type=item&sourceId=tb.index'
female_link = 'https://s.taobao.com/search?q=%E5%A5%B3&search_type=item&sourceId=tb.index'
male_str = readChineseWords(male_link)
female_str = readChineseWords(female_link)
# 分词
cc = worker()
new_user_word(cc,'打底裤','ddk')
male_words = cc[male_str]
female_words = cc[female_str]
# 计算tf-idf
idf = get_idf(list(male_words, female_words))
get_tf_idf <- function(words){
words_freq = table(words)
df = data.frame(name=names(words_freq), freq=as.numeric(words_freq))
df = merge(df, idf, all.x = TRUE)
wc_df = data.frame(words=df$name, freq=ceiling(df$count * df$freq * 10))
# 缺失和0值替换成1
wc_df$freq[wc_df$freq == 0 | is.na(wc_df$freq)] = 1
return(wc_df)
}
# 绘制词云
male_df = get_tf_idf(male_words)
female_df = get_tf_idf(female_words)
wordcloud2(male_df,
backgroundColor = 'black', color = 'random-light')
wordcloud2(female_df,
backgroundColor = 'black', color = 'random-light')
Back to the top
- Basic R analysis
Redundancy Analysis (RDA) and variance partitioning analysis (VPA)
Redundancy Analysis
本教程使用了在Evolutionary Applications(Jenkins et al.，2019)上发表的欧洲龙虾（Homarus gammarus）种群遗传学研究中的双等位基因SNP基因型数据，数据可通过以下链接下载 原版教程来自Tom-Jenkins 本教程使用的相关R环境的下载可以前往我的github 在使用本教材进行RDA实践操作及基于此利用RDA方法撰写论文时，请按如下格式引用该文献 Jenkins, T. L., Ellis, C. D., & Stevens, J. R. (2019). SNP discovery in European lobster (Homarus gammarus) using RAD sequencing. Conservation Genetics Resources, 11, 253– 257.
Data preparation
Genetic data
加载相关R包与环境
# adegenet包加载失败就把所有包更新一下，再重启一下 library(adegenet) library(poppr) library(tidyverse) # setwd('/Users/calice/desktop/Rstats/rda') load("lobster_1278ind_79snps_40pop.RData")探索相关数据
data_filt nLoc(data_filt) # number of loci nPop(data_filt) # number of sites nInd(data_filt) # number of individuals summary(data_filt$pop) # sample size整理数据
# 结合撒丁岛的时间样本 popNames(data_filt) = gsub("Sar13", "Sar", popNames(data_filt)) popNames(data_filt) = gsub("Sar17", "Sar", popNames(data_filt)) # 合并拉齐奥的样本 popNames(data_filt) = gsub("Tar", "Laz", popNames(data_filt)) # 合并Idr的时间样本 popNames(data_filt) = gsub("Idr16", "Idr", popNames(data_filt)) popNames(data_filt) = gsub("Idr17", "Idr", popNames(data_filt)) # 新数据 data_filt nPop(data_filt) # number of sites nInd(data_filt) # number of individuals summary(data_filt$pop) # sample size计算变量
# 计算等位基因频率 allele_freqs = data.frame(rraf( # 为每个地点计算等位基因频率 allele_freqs = data.frame(rraf(data_filt, by_pop=TRUE, correction = FALSE), check.names = FALSE) # 每个SNP只保留两个等位基因中的第一个（p = 1-q） allele_freqs = allele_freqs[, seq(1, dim(allele_freqs)[2], 2)] # 导出 write.csv(allele_freqs, file = "allele_freqs.csv", row.names = TRUE) # 计算次等位基因频率 # 按地点分离genind对象 site_list = seppop(data_filt) names(site_list) # 为每个地点计算次等位基因频率 maf_list = lapply(site_list, FUN = minorAllele) # 将它们加入数据框 maf = as.data.frame(maf_list) %>% t() %>% as.data.frame() head(maf) # 导出 write.csv(maf, file = "minor_allele_freqs.csv", row.names = TRUE)可视化等位基因频率
# 添加地点记号 allele_freqs$site = rownames(allele_freqs) # 在数据框中添加区域 addregion = function(x){ # If pop label is present function will output the region if(x=="Ale"|x=="The"|x=="Tor"|x=="Sky") y = " Aegean Sea " if(x=="Sar"|x=="Laz") y = " Central Mediterranean " if(x=="Vig"|x=="Brd"|x=="Cro"|x=="Eye"|x=="Heb"|x=="Iom"|x=="Ios"|x=="Loo"|x=="Lyn"|x=="Ork"|x=="Pad"|x=="Pem"|x=="She"|x=="Sbs"|x=="Sul") y = " Atlantic " if(x=="Jer"|x=="Idr"|x=="Cor"|x=="Hoo"|x=="Kil"|x=="Mul"|x=="Ven") y = " Atlantic " if(x=="Hel"|x=="Oos"|x=="Tro"|x=="Ber"|x=="Flo"|x=="Sin"|x=="Gul"|x=="Kav"|x=="Lys") y = " Scandinavia " return(y) } # 增加区域记号 allele_freqs$region = sapply(rownames(allele_freqs), addregion) # 将数据帧转换为长格式 allele_freqs.long = allele_freqs %>% pivot_longer(cols = 1:79, names_to = "allele", values_to = "frequency") allele_freqs.long # 使用factor中的levels参数定义地点的顺序 unique(allele_freqs.long$site) site_order = c("Tro","Ber","Flo","Gul","Kav","Lys","Sin","Hel","Oos", "Cro","Brd","Eye", "She","Ork","Heb","Sul","Cor","Hoo","Iom","Ios","Jer","Kil", "Loo","Lyn","Mul","Pad","Pem","Sbs","Ven", "Idr","Vig", "Sar","Laz","Ale","Sky","The","Tor") allele_freqs.long$site_ord = factor(allele_freqs.long$site, levels = site_order) # 定义区域顺序 region_order = c(" Scandinavia "," Atlantic "," Central Mediterranean ", " Aegean Sea ") allele_freqs.long$region = factor(allele_freqs.long$region, levels = region_order) # 创建配色方案 # blue=#377EB8, green=#7FC97F, orange=#FDB462, red=#E31A1C col_scheme = c("#7FC97F","#377EB8","#FDB462","#E31A1C") # SNP位点到子集的向量 desired_loci = c("7502","25608","31462","35584","42395","53314","58053","65064","65576") desired_loci_ID = sapply(paste(desired_loci, "..", sep = ""), grep, unique(allele_freqs.long$allele), value = TRUE) %>% as.vector() # 绘制所需SNP位点的子集数据集 allele_freqs.sub = allele_freqs.long %>% filter(allele %in% desired_loci_ID) # 设置ggplot2主题 ggtheme = theme( axis.text.x = element_blank(), axis.text.y = element_text(colour="black", size=6), axis.title = element_text(colour="black", size=15), panel.background = element_rect(fill="white"), panel.grid.minor = element_blank(), panel.grid.major = element_blank(), panel.border = element_rect(colour="black", fill=NA, size=0.5), plot.title = element_text(hjust = 0.5, size=18), legend.title = element_blank(), legend.text = element_text(size=15), legend.position = "top", legend.justification = "centre", # facet labels strip.text = element_text(colour="black", size=14) ) # 绘制柱状图 ggplot(data = allele_freqs.sub, aes(x = site_ord, y = frequency, fill = region))+ geom_bar(stat = "identity", colour = "black", size = 0.3)+ facet_wrap(~allele, scales = "free")+ scale_y_continuous(limits = c(0,1), expand = c(0,0))+ scale_fill_manual(values = col_scheme)+ ylab("Allele frequency")+ xlab("Site")+ ggtheme # ggsave("allele_freq.png", width=10, height=8, dpi=600) # ggsave("allele_freq.pdf", width=10, height=8)
Spatial data
准备运行环境
library(marmap) library(tidyverse) library(ade4) library(adespatial) library(SoDA)# 计算最小耗费距离 # 使用marmap软件包从NOAA获取水深数据 bathydata = getNOAA.bathy(lon1 = -15, lon2 = 30, lat1 = 35, lat2 = 65, resolution = 2) # 输入各个采样区的坐标 coords = read.csv("coordinates.csv") head(coords) coords.gps = dplyr::select(coords, Lon, Lat) # 获取坐标处的水深 depths = cbind(site = coords$Site, get.depth(bathydata, coords.gps, locator = FALSE)) depths # 看看水深是否大于10m depths$depth <= -10 # 绘制水深数据与坐标 plot(bathydata) points(coords$Lon, coords$Lat, pch = 21, bg = "yellow", col = "black", cex = 2)
Tips: marmap作者的推荐： 使用最小深度-10来避免路径穿过陆地块；使用最大深度-200来限制通往大陆架的路径
# trans1 = trans.mat(bathydata, min.depth = -10, max.depth = NULL)
# save(trans1, file = "transition_object.RData")
# load("transition_object.RData")
# Compute least-cost paths [long run time]
# lc_paths = lc.dist(trans1, coords.gps, res = "path")
# save(lc_paths, file = "least_cost_paths.RData")
在地图上绘制距离（很慢）
load("least_cost_paths.RData")
# 底图
plot.bathy(bathydata, image= TRUE, land = TRUE, n = 0,
bpal = list(c(0, max(bathydata), "grey"),
c(min(bathydata), 0, "royalblue")))
# 轨迹
lapply(lc_paths, lines, col = "orange", lwd = 2, lty = 1)
计算最小耗费距离矩阵
lc_dist = lc.dist(trans1, coords.gps, res = "dist")
# 转换为矩阵，重命名列和行，并导出为csv文件
lc_mat = as.matrix(lc_dist)
colnames(lc_mat) = as.vector(coords$Site)
rownames(lc_mat) = as.vector(coords$Site)
lc_mat
# write.csv(lc_mat, file="lc_distances_km.csv")
计算基于距离的Moran特征向量映射（空间相关矩阵？
# 查看学习资料
vignette("tutorial", package = "adespatial")
# 将地理坐标转换为笛卡尔坐标
# 计算欧几里得距离(km)
# cart = geoXY(coords$Lat, coords$Lon, unit = 1000)
# euclidian_distances = dist(cart, method = "euclidean")
dbmems = dbmem(lc_dist, MEM.autocor = "non-null")
dbmems
# write.csv(dbmems, file = "dbmems.csv", row.names = FALSE)
Environmental data
数据如下： 平均海面温度(SST):当前(摄氏) 平均海底温度(SBT):当前(摄氏度) 平均海表盐度(SSS):当前(实际盐度标) 平均海底盐度(SBS):当前(实际盐度标) 平均海面叶绿素浓度(SSC):当前(mg/m3) 平均海面钙含量(SSCa):当前(mol/m3) 数据来源：http://www.bio-oracle.org 具体asc数据也可以发邮件找我要 加载环境
library(raster)
library(dplyr)
# devtools::install_github("ropenscilabs/rnaturalearth")
# devtools::install_github("ropenscilabs/rnaturalearthdata")
# devtools::install_github("ropenscilabs/rnaturalearthhires")
library(rnaturalearth)
library(rnaturalearthdata)
library(rnaturalearthhires)
library(ggplot2)
library(RColorBrewer)
library(ggpubr)
加载数据
sst.present = raster("Present.Surface.Temperature.Mean.asc")
sbt.present = raster("Present.Benthic.Max.Depth.Temperature.Mean.asc")
sss.present = raster("Present.Surface.Salinity.Mean.asc")
sbs.present = raster("Present.Benthic.Max.Depth.Salinity.Mean.asc")
ssc.present = raster("Present.Surface.Chlorophyll.Mean.asc")
ssca.present = raster("Present.Surface.Calcite.Mean.asc")
提取环境数据
# 导入坐标
coords = read.csv("coordinates.csv")
names(coords)
# 用坐标创建空间点
points = SpatialPoints(subset(coords, select = c("Lon","Lat")))
# 利用坐标提取环境数据
df = data.frame(site = coords$Site,
sst_mean = extract(sst.present, points),
sbt_mean = extract(sbt.present, points),
sss_mean = extract(sss.present, points),
sbs_mean = extract(sbs.present, points),
ssc_mean = extract(ssc.present, points),
ssca_mean = extract(ssca.present, points)
)
# write.csv(df, file="environmental_data.csv", row.names = FALSE)
绘制热力图
#设置图的边界 (xmin, xmax, ymin, ymax)
extent(points)
boundary = extent(-20, 30, 35, 65)
boundary
# 裁剪栅格到边界并转换成点的数据框
sst.df = crop(sst.present, y = boundary) %>% rasterToPoints() %>% data.frame()
sbt.df = crop(sbt.present, y = boundary) %>% rasterToPoints() %>% data.frame()
sss.df = crop(sss.present, y = boundary) %>% rasterToPoints() %>% data.frame()
sbs.df = crop(sbs.present, y = boundary) %>% rasterToPoints() %>% data.frame()
ssc.df = crop(ssc.present, y = boundary) %>% rasterToPoints() %>% data.frame()
ssca.df = crop(ssca.present, y = boundary) %>% rasterToPoints() %>% data.frame()
# 加载基础底图
basemap = ne_countries(scale = "large")
# 裁剪到边界并转换为数据框
basemap = crop(basemap, y = boundary) %>% fortify()
准备ggplot主题
# 准备ggplot主题
ggtheme = theme(axis.title = element_text(size = 12),
axis.text = element_text(size = 10, colour = "black"),
panel.border = element_rect(fill = NA, colour = "black", size = 0.5),
legend.title = element_text(size = 13),
legend.text = element_text(size = 12),
plot.title = element_text(size = 15, hjust = 0.5),
panel.grid = element_blank())
# 准备颜色
temp.cols = colorRampPalette(c("blue","white","red"))
sal.cols = colorRampPalette(c("darkred","white"))
chlor.cols = colorRampPalette(c("white","green"))
calct.cols = colorRampPalette(c("white","#662506"))
绘制海洋表明温度
sst.plt = ggplot()+
geom_tile(data = sst.df, aes(x = x, y = y, fill = sst.df[, 3]))+
geom_polygon(data = basemap, aes(x = long, y = lat, group = group))+
coord_quickmap(expand = F)+
xlab("Longitude")+
ylab("Latitude")+
ggtitle("Sea surface temperature (present-day)")+
scale_fill_gradientn(expression(~degree~C), colours = temp.cols(10), limits = c(-1.5,24))+
ggtheme
sst.plt
ggsave("1.sst_heatmap.png", width = 10, height = 9, dpi = 600)
# ggsave("Rplot15.png", width = 10, height = 9, dpi = 300)
绘制海底温度
sbt.plt = ggplot()+
geom_tile(data = sbt.df, aes(x = x, y = y, fill = sbt.df[, 3]))+
geom_polygon(data = basemap, aes(x = long, y = lat, group = group))+
coord_quickmap(expand = F)+
xlab("Longitude")+
ylab("Latitude")+
ggtitle("Sea bottom temperature (present-day)")+
scale_fill_gradientn(expression(~degree~C), colours = temp.cols(10), limits = c(-1.5,24))+
ggtheme
sbt.plt
ggsave("2.sbt_heatmap.png", width = 10, height = 9, dpi = 600)
绘制海面盐度
sss.plt = ggplot()+
geom_tile(data = sss.df, aes(x = x, y = y, fill = sss.df[, 3]))+
geom_polygon(data = basemap, aes(x = long, y = lat, group = group))+
coord_quickmap(expand = F)+
xlab("Longitude")+
ylab("Latitude")+
ggtitle("Sea surface salinity (present-day)")+
scale_fill_gradientn("PPS", colours = sal.cols(10), limits = c(1,40))+
ggtheme
sss.plt
ggsave("3.sss_heatmap.png", width = 10, height = 9, dpi = 600)
绘制海底盐度
sbs.plt = ggplot()+
geom_tile(data = sbs.df, aes(x = x, y = y, fill = sbs.df[, 3]))+
geom_polygon(data = basemap, aes(x = long, y = lat, group = group))+
coord_quickmap(expand = F)+
xlab("Longitude")+
ylab("Latitude")+
ggtitle("Sea bottom salinity (present-day)")+
scale_fill_gradientn("PPS", colours = sal.cols(10), limits = c(1,40))+
ggtheme
sbs.plt
ggsave("4.sbs_heatmap.png", width = 10, height = 9, dpi = 600)
绘制海面叶绿体浓度
ssc.plt = ggplot()+
geom_tile(data = ssc.df, aes(x = x, y = y, fill = ssc.df[, 3]))+
geom_polygon(data = basemap, aes(x = long, y = lat, group = group))+
coord_quickmap(expand = F)+
xlab("Longitude")+
ylab("Latitude")+
ggtitle("Sea surface chlorophyll (present-day)")+
scale_fill_gradientn(expression(paste("mg/m"^"3")), colours = chlor.cols(10))+
ggtheme
ssc.plt
ggsave("5.ssc_heatmap.png", width = 10, height = 9, dpi = 600)
绘制海面钙含量
ssca.plt = ggplot()+
geom_tile(data = ssca.df, aes(x = x, y = y, fill = ssca.df[, 3]))+
geom_polygon(data = basemap, aes(x = long, y = lat, group = group))+
coord_quickmap(expand = F)+
xlab("Longitude")+
ylab("Latitude")+
ggtitle("Sea surface calcite (present-day)")+
scale_fill_gradientn(expression(paste("mol/m"^"3")), colours = calct.cols(10))+
ggtheme
ssca.plt
ggsave("6.ssca_heatmap.png", width = 10, height = 9, dpi = 600)
组合图片
# 组合两张关于温度的
figAB = ggarrange(sst.plt + labs(tag = "A") + ggtheme + theme(axis.title.y = element_blank()),
sbt.plt + labs(tag = "B") + ggtheme + theme(axis.title.y = element_blank()),
ncol = 2, common.legend = TRUE, legend = "right")
figAB = annotate_figure(figAB,
left = text_grob("Latitude", size = 12, rot = 90))
# 组合两张关于盐分的
figCD = ggarrange(sss.plt + labs(tag = "C") + ggtheme + theme(axis.title.y = element_blank()),
sbs.plt + labs(tag = "D") + ggtheme + theme(axis.title.y = element_blank()),
ncol = 2, common.legend = TRUE, legend = "right")
figCD = annotate_figure(figCD,
left = text_grob("Latitude", size = 12, rot = 90))
# 把他们加起来
fig = ggarrange(figAB, figCD, nrow = 2)
ggsave("7.temp_sal_heatmap.png", width = 10, height = 10, dpi = 600)
# ggsave("7.temp_sal_heatmap.pdf", width = 10, height = 10)
Start RDA
加载环境与数据
library(tidyverse)
library(psych)
library(adespatial)
library(vegan)
# 加载基因数据
allele_freqs = read.csv("allele_freqs.csv", row.names = 1, check.names = FALSE)
# 加载空间数据
dbmem.raw = read.csv("dbmems.csv")
# 加载环境数据
env.raw = read.csv("environmental_data.csv", row.names = 1)
# 加载随机种子
set.seed(123)
多重共线性检验
# 对环境变量进行相关检验
pairs.panels(env.raw, scale = TRUE)
# 移除相关性强的变量
env.data = subset(env.raw, select = -c(sst_mean, sbs_mean))
pairs.panels(env.data, scale = TRUE)
识别重要变量
# 使用前向选择来确定重要的环境变量
env.for = forward.sel(Y = allele_freqs, X = env.data, alpha = 0.01)
env.for
# variables order R2 R2Cum AdjR2Cum F pvalue
# 1 sbt_mean 1 0.31150411 0.3115041 0.2918328 15.835453 0.001
# 2 sss_mean 2 0.09469125 0.4061954 0.3712657 5.421821 0.001
# 3 ssca_mean 4 0.07470387 0.4808992 0.4337083 4.749035 0.005
# 使用前向选择来确定重要的dbmems
dbmem.for = forward.sel(Y = allele_freqs, X = dbmem.raw, alpha = 0.01)
dbmem.for
# variables order R2 R2Cum AdjR2Cum F pvalue
# 1 MEM1 1 0.51661196 0.5166120 0.5028009 37.405598 0.001
# 2 MEM2 2 0.08518943 0.6018014 0.5783780 7.273860 0.001
# 3 MEM5 5 0.08000465 0.6818060 0.6528793 8.297309 0.001
# 4 MEM3 3 0.04720013 0.7290062 0.6951319 5.573574 0.001
# 5 MEM6 6 0.02189658 0.7509028 0.7107258 2.725016 0.010
我们只将重要的自变量子集包含在RDA中
env.sig = subset(env.data, select = env.for$variables)
str(env.sig)
dbmem.sig = subset(dbmem.raw, select = dbmem.for$variables)
str(dbmem.sig)
# 组合这些变量
env.dbmems = cbind(env.sig, dbmem.sig)
str(env.dbmems)
进行冗余分析
# 为所有变量进行冗余分析
rda1 = rda(allele_freqs ~ ., data = env.dbmems, scale = TRUE)
rda1
# Call: rda(formula = allele_freqs ~ sbt_mean + sss_mean +
# ssca_mean + MEM1 + MEM2 + MEM5 + MEM3 + MEM6, data = env.dbmems,
# scale = TRUE)
# Inertia Proportion Rank
# Total 79.0000 1.0000
# Constrained 44.9918 0.5695 8
# Unconstrained 34.0082 0.4305 28
# Inertia is correlations
# Eigenvalues for constrained axes:
# RDA1 RDA2 RDA3 RDA4 RDA5 RDA6 RDA7 RDA8
# 22.319 10.537 3.837 2.995 2.540 1.194 0.966 0.604
# Eigenvalues for unconstrained axes:
# PC1 PC2 PC3 PC4 PC5 PC6 PC7 PC8
# 4.940 3.197 2.488 2.400 2.121 1.732 1.655 1.617
# (Showing 8 of 28 unconstrained eigenvalues)
Model summaries
adjusted Rsquared
RsquareAdj(rda1)
# $r.squared
# [1] 0.5695167
# $adj.r.squared
# [1] 0.4465215
方差膨胀因子
# variance inflation factor (<10 OK)
vif.cca(rda1)
全模型
anova.cca(rda1, permutations = 1000)
# sbt_mean sss_mean ssca_mean MEM1 MEM2 MEM5 MEM3
# 8.590561 1.791776 1.979065 7.012236 2.107733 1.105811 2.055020
# MEM6
# 1.078194
每个变量
anova.cca(rda1, permutations = 1000, by="margin")
# Permutation test for rda under reduced model
# Marginal effects of terms
# Permutation: free
# Number of permutations: 1000
# Model: rda(formula = allele_freqs ~ sbt_mean + sss_mean + ssca_mean + MEM1 + MEM2 + MEM5 + MEM3 + MEM6, data = env.dbmems, scale = TRUE)
# Df Variance F Pr(>F)
# sbt_mean 1 0.913 0.7513 0.662338
# sss_mean 1 1.868 1.5381 0.125874
# ssca_mean 1 1.948 1.6040 0.082917 .
# MEM1 1 4.059 3.3418 0.001998 **
# MEM2 1 1.771 1.4579 0.182817
# MEM5 1 7.091 5.8379 0.000999 ***
# MEM3 1 1.814 1.4934 0.102897
# MEM6 1 2.973 2.4479 0.038961 *
# Residual 28 34.008
# ---
# Signif. codes: 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
每个标准轴的解释方差
summary(eigenvals(rda1, model = "constrained"))
screeplot(rda1)
Visualization of RDA
# 创建一个数据框来正确地为区域着色
col_dframe = data.frame("site" = rownames(allele_freqs))
# 一个函数将区域标签添加到数据帧
addregion = function(x){
# If pop label is present function will output the region
if(x=="Ale"|x=="The"|x=="Tor"|x=="Sky") y = "Aegean Sea"
if(x=="Sar"|x=="Laz") y = "Central Mediterranean"
if(x=="Vig"|x=="Brd"|x=="Cro"|x=="Eye"|x=="Heb"|x=="Iom"|x=="Ios"|x=="Loo"|x=="Lyn"|x=="Ork"|x=="Pad"|x=="Pem"|x=="She"|x=="Sbs"|x=="Sul") y = "Atlantic"
if(x=="Jer"|x=="Idr"|x=="Cor"|x=="Hoo"|x=="Kil"|x=="Mul"|x=="Ven") y = "Atlantic"
if(x=="Hel"|x=="Oos"|x=="Tro"|x=="Ber"|x=="Flo"|x=="Sin"|x=="Gul"|x=="Kav"|x=="Lys") y = "Scandinavia"
return(y)
}
# 增加区域标记
col_dframe$region = sapply(col_dframe$site, addregion)
# 增加因子水平
region_order = c("Scandinavia","Atlantic","Central Mediterranean", "Aegean Sea")
col_dframe$region = factor(col_dframe$region, levels = region_order)
# 创建调色板
# blue=#377EB8, green=#7FC97F, orange=#FDB462, red=#E31A1C
cols = c("#7FC97F","#377EB8","#FDB462","#E31A1C")
RDA的可视化
png("rda.png", width = 8, height = 7, units = "in", res = 600)
plot(rda1, type="n", scaling = 3)
title("Seascape redundancy analysis")
# SITES
points(rda1, display="sites", pch=21, scaling=3, cex=1.5, col="black",
bg=cols[col_dframe$region]) # sites
# text(rda1, display="sites", scaling = 3, col="black", font=2, pos=4)
# PREDICTORS
text(rda1, display="bp", scaling=3, col="red1", cex=1, lwd=2)
# SNPS
# text(rda1, display="species", scaling = 3, col="blue", cex=0.7, pos=4) # SNPs
# LEGEND
legend("bottomleft", legend=levels(col_dframe$region), bty="n", col="black",
pch=21, cex=1.2, pt.bg=cols)
# OTHER LABELS
adj.R2 = round(RsquareAdj(rda1)$adj.r.squared, 3)
mtext(bquote(italic("R")^"2"~"= "~.(adj.R2)), side = 3, adj = 0.5)
dev.off()
Partial redundancy analysis
在控制地理位置的同时执行RDA
pRDA = rda(allele_freqs ~ sbt_mean + sss_mean + ssca_mean + Condition(MEM1+MEM2+MEM3+MEM5),
data = env.dbmems, scale = TRUE)
pRDA
RsquareAdj(pRDA) # adjusted Rsquared
vif.cca(pRDA) # variance inflation factor (<10 OK)
anova.cca(pRDA, permutations = 1000) # full model
anova.cca(pRDA, permutations = 1000, by = "margin") # per variable
可视化
png("partial_rda.png", width = 9, height = 7, units = "in", res = 600)
plot(pRDA, type="n", scaling = 3)
title("Seascape partial redundancy analysis")
# SITES
points(pRDA, display="sites", pch=21, scaling=3, cex=1.5, col="black",
bg=cols[col_dframe$region]) # sites
text(pRDA, display="sites", scaling = 3, col="black", font=2, pos=4)
# PREDICTORS
text(pRDA, display="bp", scaling=3, col="red1", cex=1, lwd=2)
# SNPS
# text(pRDA, display="species", scaling = 3, col="blue", cex=0.7, pos=4) # SNPs
# LEGEND
legend("topleft", legend=levels(col_dframe$region), bty="n", col="black",
pch=21, cex=1.2, pt.bg=cols)
# OTHER LABELS
adj.R2 = round(RsquareAdj(pRDA)$adj.r.squared, 3)
mtext(bquote(italic("R")^"2"~"= "~.(adj.R2)), side = 3, adj = 0.5)
dev.off()
Candidate SNPs for local adaptation？ 考察候选核苷酸多态性和当地适宜性的关系
# 在图中，哪个轴比较重要呢？
anova.cca(pRDA, permutations = 1000, by = "axis")
# 提取带显著性的SNP的载荷轴
snp.load = scores(pRDA, choices = 1, display = "species")
# 绘制SNP载荷直方图
hist(snp.load, main = "SNP loadings on RDA1")
确定分布尾部的SNP Function from https://popgen.nescent.org/2018-03-27_RDA_GEA.html
outliers = function(x,z){
lims = mean(x) + c(-1, 1) * z * sd(x) # find loadings +/-z sd from mean loading
x[x < lims[1] | x > lims[2]] # locus names in these tails
}
# x = loadings vector, z = number of standard deviations to use
candidates = outliers(x = snp.load, z = 2.5)
Convert matric to dataframe
snp.load.df = snp.load %>% as.data.frame
snp.load.df$SNP_ID = rownames(snp.load.df)
str(snp.load.df)
# Extract locus ID
snp.load.df %>% dplyr::filter(RDA1 %in% candidates)
variance partitioning analysis
Simple VPA
方差分解可以将每个解释变量（环境因子）独立进行CCA或RDA分析，获得每个解释变量对相应变量的方差变异的解释贡献度，之后通过多组数据取交集的方式获得每个解释变量的独立解释贡献度记忆环境因子共同解释的贡献度。 可以使用内置的数据进行测试
library(vegan)
data("mite")
data("mite.pcnm")
data("mite.env")
# mite是物种群落结构，也就是因变量，第一行是物种名称，之后每行是样本/样地数，差不多意思是就是每个样地的不同物种的数量
head(mite)
# Brachy PHTH HPAV RARD SSTR Protopl MEGR MPRO TVIE HMIN HMIN2 NPRA TVEL ONOV
# 1 17 5 5 3 2 1 4 2 2 1 4 1 17 4
# 2 2 7 16 0 6 0 4 2 0 0 1 3 21 27
# 3 4 3 1 1 2 0 3 0 0 0 6 3 20 17
# 4 23 7 10 2 2 0 4 0 1 2 10 0 18 47
# 5 5 8 13 9 0 13 0 0 0 3 14 3 32 43
# 6 19 7 5 9 3 2 3 0 0 20 16 2 13 38
# ...
# 这是环境因子，有一些是因子变量
head(mite.env)
# SubsDens WatrCont Substrate Shrub Topo
# 1 39.18 350.15 Sphagn1 Few Hummock
# 2 54.99 434.81 Litter Few Hummock
# 3 46.07 371.72 Interface Few Hummock
# 4 48.19 360.50 Sphagn1 Few Hummock
# 5 23.55 204.13 Sphagn1 Few Hummock
# 6 57.32 311.55 Sphagn1 Few Hummock
# 另一个环境因子，是pcnm的结果
head(mite.pcnm)
# V1 V2 V3 V4 V5 V6
# 1 0.01936957 -0.03564740 -0.004243617 0.013606215 -0.05189017 -0.03474468
# 2 0.02327134 -0.04809322 -0.004319021 -0.004129358 -0.06717623 -0.05795898
# 3 0.02553531 -0.05844679 -0.003091072 -0.025699042 -0.07594608 -0.07619106
# 4 0.03065998 -0.07805595 -0.001108683 -0.056124820 -0.08546514 -0.09535844
# 5 0.03105726 -0.08758357 0.003294018 -0.092445741 -0.05775704 -0.08126478
# 6 0.04127819 -0.12060082 0.004167658 -0.126085915 -0.10026023 -0.13218923
# ...
# 可以对数据进行转换，进行hellinger转化
# 但如果因变量只有一列则不需要转换
mod <- varpart(mite,mite.env,mite.pcnm,transfo = "hel")
结果如下：
Partition of variance in RDA
Call: varpart(Y = mite, X = mite.env, mite.pcnm, transfo = "hel")
Species transformation: hellinger
Explanatory tables:
X1: mite.env
X2: mite.pcnm
No. of explanatory tables: 2
Total variation (SS): 27.205
Variance: 0.39428
No. of observations: 70
Partition table:
Df R.squared Adj.R.squared Testable
[a+b] = X1 11 0.52650 0.43670 TRUE
[b+c] = X2 22 0.62300 0.44653 TRUE
[a+b+c] = X1+X2 33 0.75893 0.53794 TRUE
Individual fractions
# x1对群落的贡献
[a] = X1|X2 11 0.09141 TRUE
[b] 0 0.34530 FALSE
# x2对群落的贡献
[c] = X2|X1 22 0.10124 TRUE
# 无法解释的部分
[d] = Residuals 0.46206 FALSE
---
Use function ‘rda’ to test significance of fractions of interest
可视化：
plot(mod, bg = c("hotpink", "skyblue"))
Whole process of VPA
来自微信公众号：生态R学社 加载数据
# setwd()
# 使载入信息更简洁
# col_types = cols()同理
suppressMessages(library(tidyverse))
species <- read_csv("species.csv", col_types = cols())
env <- read_csv("env.csv", col_types = cols())
# 数据结构和上面那个一样的
glimpse(species)
glimpse(env)
变量筛选
suppressMessages(library(vegan))
# 从全模型逐渐消除变量的筛选方式
# 其实也算是一种回归
# 设置全模型与零模型
rda_full <- rda(species~., data = env)
# 从零模型逐渐增加变量
rda_null <- rda(species~1, data = env)
# 双向选择/向左/向右筛选
rda_back <- ordistep(rda_full, direction = 'backward', trace = 0)
rda_frwd <- ordistep(rda_null, formula(rda_full), direction = 'forward', trace = 0)
rda_both <- ordistep(rda_null, formula(rda_full), direction = 'both', trace = 0)
# 查看结果
rda_back
# Call: rda(formula = species ~ SM + AK, data = env)
# Inertia Proportion Rank
# Total 9.224e+03 1.000e+00
# Constrained 8.653e+02 9.381e-02 2
# Unconstrained 8.358e+03 9.062e-01 35
# Inertia is variance
# Eigenvalues for constrained axes:
# RDA1 RDA2
# 851.2 14.1
# Eigenvalues for unconstrained axes:
# PC1 PC2 PC3 PC4 PC5 PC6 PC7 PC8
# 7433 323 153 114 101 57 43 40
# (Showing 8 of 35 unconstrained eigenvalues)
rda_frwd
# Call: rda(formula = species ~ TK, data = env)
# Inertia Proportion Rank
# Total 9223.5835 1.0000
# Constrained 598.6051 0.0649 1
# Unconstrained 8624.9784 0.9351 35
# Inertia is variance
# Eigenvalues for constrained axes:
# RDA1
# 598.6
# Eigenvalues for unconstrained axes:
# PC1 PC2 PC3 PC4 PC5 PC6 PC7 PC8
# 7744 316 130 101 92 59 44 37
# (Showing 8 of 35 unconstrained eigenvalues)
rda_both
# Call: rda(formula = species ~ AK, data = env)
# Inertia Proportion Rank
# Total 9.224e+03 1.000e+00
# Constrained 5.511e+02 5.975e-02 1
# Unconstrained 8.673e+03 9.403e-01 35
# Inertia is variance
# Eigenvalues for constrained axes:
# RDA1
# 551.1
# Eigenvalues for unconstrained axes:
# PC1 PC2 PC3 PC4 PC5 PC6 PC7 PC8
# 7667 382 157 117 101 57 49 43
# (Showing 8 of 35 unconstrained eigenvalues)
筛选后使用rda_back的结果，即species ~ SM + AK
# 根据模型将变量分为土壤与气候
clim <- env %>% select(SM)
soil <- env %>% select(AK)
进行方差分解
vpa <- varpart(species, clim, soil)
vpa
# Partition of variance in RDA
# Call: varpart(Y = species, X = clim, soil)
# Explanatory tables:
# X1: clim
# X2: soil
# No. of explanatory tables: 2
# Total variation (SS): 627204
# Variance: 9223.6
# No. of observations: 69
# Partition table:
# Df R.squared Adj.R.squared Testable
# [a+b] = X1 1 0.00171 -0.01318 TRUE
# [b+c] = X2 1 0.05975 0.04571 TRUE
# [a+b+c] = X1+X2 2 0.09381 0.06635 TRUE
# Individual fractions
# [a] = X1|X2 1 0.02064 TRUE
# [b] 0 -0.03383 FALSE
# [c] = X2|X1 1 0.07954 TRUE
# [d] = Residuals 0.93365 FALSE
# ---
# Use function ‘rda’ to test significance of fractions of interest
绘制韦恩图
plot(vpa, bg = 2:5, id.size = 1.1, cex = 1.2, Xnames = c('Climate', 'Soil properties'))
title('VPA')
接下来需要检验方差结果的显著性。
anova(rda(species ~ AK + Condition(SM), data = env))
# Permutation test for rda under reduced model
# Permutation: free
# Number of permutations: 999
# Model: rda(formula = species ~ AK + Condition(SM), data = env)
# Df Variance F Pr(>F)
# Model 1 849.5 6.7078 0.01 **
# Residual 66 8358.3
# ---
# Signif. codes:
# 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
anova(rda(species ~ Condition(SM) + AK, data = env))
# Permutation test for rda under reduced model
# Permutation: free
# Number of permutations: 999
# Model: rda(formula = species ~ Condition(SM) + AK, data = env)
# Df Variance F Pr(>F)
# Model 1 849.5 6.7078 0.008 **
# Residual 66 8358.3
# ---
# Signif. codes:
# 0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
Multiple variance decomposition
导入数据
data <- read.csv("nature.csv", head = T, row.names = "NUM_Final")
head(data)
# COU ELEVATION LAT SINLONG COSLONG SLO
# 1 Argentina 1214 -41.80778 -0.5323537 0.8465220 1.10
# 2 Argentina 1067 -41.23785 -0.9658973 0.2589256 0.60
# 3 Argentina 1134 -41.10671 -0.9789990 -0.2038651 5.70
# 4 Argentina 1128 -41.00428 -0.9309997 -0.3650200 1.14
# 6 Argentina 1072 -41.03350 -0.9870183 0.1606081 0.60
# 9 Argentina 157 -38.76398 -0.7833883 -0.6215326 0.50
# ARIDITY SAND PH SR CWM_logH CWV_logH
# 1 0.7848 72.85806 6.816498 7 3.711949 0.27751995
# 2 0.6269 90.25353 6.903776 10 3.869944 0.17866506
# 3 0.4051 79.42284 6.563219 10 3.533342 0.16405435
# 4 0.2688 67.18043 6.451785 9 3.790257 0.07100068
# 6 0.5835 77.67463 6.790220 9 3.900902 0.28703764
# 9 0.7744 83.52515 7.718229 9 4.854603 0.68409263
# CWS_logH CWK_logH CWM_logSLA CWV_logSLA CWS_logSLA
# 1 -0.7637778 1.51160947 4.060573 0.1205683 0.67722158
# 2 -1.2828283 2.96032008 4.291668 0.1575433 0.48483503
# 3 -0.5325850 -0.03714558 4.641273 0.4576920 -0.07818039
# 4 -2.7101555 9.50886526 4.714749 0.1706934 -1.51295106
# 6 -1.3590901 3.13852514 4.129284 0.2935952 0.87061919
# 9 -0.1683289 0.24123964 4.263180 0.1563341 1.37789764
# CWK_logSLA BGL FOS AMP NTR
# 1 -0.01011663 0.4377014 1.1229754 0.1014598 0.6105888
# 2 -0.96646930 0.4322344 1.0173889 -0.1683013 1.0122487
# 3 -1.46946238 1.1322424 3.5938745 0.7232067 3.0018218
# 4 0.96103395 1.2320621 3.2734592 0.8042662 3.1684659
# 6 0.76680427 0.9465925 1.5959195 -0.1961237 1.2015001
# 9 2.60828591 0.5010997 0.6338614 -0.3300716 -0.3393366
# I.NDVI
# 1 3.4635
# 2 4.2668
# 3 7.0073
# 4 6.1115
# 6 4.2859
# 9 7.5435
# 进行对数转换
data[,c(11,12,15,16)] <- log(data[,c(11,12,15,16)])
data[,13] <- log(data[,13]-min(data[,13])+1)
data[,14] <- log(data[,14]-min(data[,14])+1)
data[,17] <- log(data[,17]-min(data[,17])+1)
data[,18] <- log(data[,18]-min(data[,18])+1)
环境变量标准化
data$ELEVATION<-(data$ELEVATION-mean(data$ELEVATION))/sd(data$ELEVATION)
data$LAT<-(data$LAT-mean(data$LAT))/sd(data$LAT)
data$SINLONG<-(data$SINLONG-mean(data$SINLONG))/sd(data$SINLONG)
data$COSLONG<-(data$COSLONG-mean(data$COSLONG))/sd(data$COSLONG)
data$SLO<-(data$SLO-mean(data$SLO))/sd(data$SLO)
data$ARIDITY<-(data$ARIDITY-mean(data$ARIDITY))/sd(data$ARIDITY)
data$SAND<-(data$SAND-mean(data$SAND))/sd(data$SAND)
data$PH<-(data$PH-mean(data$PH))/sd(data$PH)
data$SR<-(data$SR-mean(data$SR))/sd(data$SR)
瞬时指标标准化
data$CWM_logH<-(data$CWM_logH-mean(data$CWM_logH))/sd(data$CWM_logH)
data$CWV_logH<-(data$CWV_logH-mean(data$CWV_logH))/sd(data$CWV_logH)
data$CWS_logH<-(data$CWS_logH-mean(data$CWS_logH))/sd(data$CWS_logH)
data$CWK_logH<-(data$CWK_logH-mean(data$CWK_logH))/sd(data$CWK_logH)
data$CWM_logSLA<-(data$CWM_logSLA-mean(data$CWM_logSLA))/sd(data$CWM_logSLA)
data$CWV_logSLA<-(data$CWV_logSLA-mean(data$CWV_logSLA))/sd(data$CWV_logSLA)
data$CWS_logSLA<-(data$CWS_logSLA-mean(data$CWS_logSLA))/sd(data$CWS_logSLA)
data$CWK_logSLA<-(data$CWK_logSLA-mean(data$CWK_logSLA))/sd(data$CWK_logSLA)
生态功能指标标准化
data$BGL<-(data$BGL-mean(data$BGL))/sd(data$BGL)
data$FOS<-(data$FOS-mean(data$FOS))/sd(data$FOS)
data$AMP<-(data$AMP-mean(data$AMP))/sd(data$AMP)
data$NTR<-(data$NTR-mean(data$NTR))/sd(data$NTR)
data$I.NDVI<-(data$I.NDVI-mean(data$I.NDVI))/sd(data$I.NDVI)
文章将这24个变量分别归类为Skew、Mean、Richness、Abiotic、Geo五大类，并进行了标准化和对数转化。 提取其中的生态功能数据：
colnames(data)
M5 <- rowMeans(data[,c(19,20,21,22,23)])
data <- cbind(data, M5)
logM5 <- log(data$M5 - min(data$M5)+1)
data <- cbind(data,logM5)
计算R方
library(MuMIn)
# 全模型
# 为什么出现I()函数，原因是x^2表示x和x的相互作用，而I(x)表示单纯的x乘x
mod12<-lm(logM5 ~ LAT + SINLONG + COSLONG +
ARIDITY + SLO + SAND + PH + I(PH^2) + ELEVATION+
CWM_logSLA + I(CWM_logSLA^2)+ CWV_logSLA + I(CWV_logSLA^2) + CWS_logSLA + CWK_logSLA + I(CWK_logSLA^2) +
CWM_logH + I(CWM_logH^2)+ CWV_logH + I(CWV_logH^2) + CWS_logH + CWK_logH + I(CWK_logH^2) +
SR
, data=data)
#此全模型的r2即为论文中的r2
library(performance)
r2(mod12)
# R2 for Linear Regression
# R2: 0.724
# adj. R2: 0.657
# 模型筛选
#通过模型进行指标筛选
dd12 <- dredge(mod12, subset = ~ LAT & SINLONG & COSLONG & ARIDITY & SLO & SAND & PH &SR & ELEVATION &
dc(CWM_logSLA,I(CWM_logSLA^2)) & dc(CWV_logSLA,I(CWV_logSLA^2)) & dc(CWK_logSLA,I(CWK_logSLA^2))
& dc(CWM_logH,I(CWM_logH^2)) & dc(CWV_logH,I(CWV_logH^2)) & dc(CWK_logH,I(CWK_logH^2)), options(na.action = "na.fail"))
#提取最优模型集
subset(dd12,delta<2)
#求模型平均后的参数估计值
de12 <- model.avg(dd12, subset = delta < 2)
summary(de12)
# Model-averaged coefficients:
# (full average)
# Estimate Std. Error Adjusted SE z value
# (Intercept) 0.697322 0.035206 0.035556 19.612
# ARIDITY -0.136000 0.027174 0.027484 4.948
# COSLONG -0.040117 0.021512 0.021753 1.844
# CWK_logH -0.002993 0.029684 0.030021 0.100
# I(CWK_logH^2) -0.057877 0.019492 0.019688 2.940
# CWK_logSLA -0.087745 0.029044 0.029335 2.991
# I(CWK_logSLA^2) -0.023259 0.021497 0.021614 1.076
# CWS_logH -0.132267 0.033251 0.033631 3.933
# CWS_logSLA -0.022152 0.026052 0.026150 0.847
# CWV_logH 0.043475 0.030028 0.030272 1.436
# I(CWV_logH^2) 0.032969 0.019856 0.020006 1.648
# CWV_logSLA -0.071439 0.025785 0.026051 2.742
# I(CWV_logSLA^2) 0.070926 0.015442 0.015602 4.546
# ELEVATION 0.016273 0.020789 0.021019 0.774
# LAT 0.003561 0.027182 0.027464 0.130
# PH -0.086922 0.029385 0.029723 2.924
# I(PH^2) -0.056956 0.019178 0.019395 2.937
# SAND -0.106034 0.018628 0.018844 5.627
# SINLONG -0.011265 0.018722 0.018938 0.595
# SLO -0.001518 0.023037 0.023300 0.065
# SR 0.056643 0.023038 0.023275 2.434
# CWM_logSLA 0.015673 0.025068 0.025143 0.623
# Pr(>|z|)
# (Intercept) < 2e-16 ***
# ARIDITY 7.00e-07 ***
# COSLONG 0.06516 .
# CWK_logH 0.92057
# I(CWK_logH^2) 0.00328 **
# CWK_logSLA 0.00278 **
# I(CWK_logSLA^2) 0.28188
# CWS_logH 8.39e-05 ***
# CWS_logSLA 0.39694
# CWV_logH 0.15096
# I(CWV_logH^2) 0.09937 .
# CWV_logSLA 0.00610 **
# I(CWV_logSLA^2) 5.50e-06 ***
# ELEVATION 0.43883
# LAT 0.89684
# PH 0.00345 **
# I(PH^2) 0.00332 **
# SAND < 2e-16 ***
# SINLONG 0.55196
# SLO 0.94804
# SR 0.01495 *
# CWM_logSLA 0.53307
#求各类型参数贡献的百分比
d1<-summary(de12)
d2<-d1$coefficients
d3<-d2[1,]
d4<-d3[c(2:22)]
d5<-abs(d4)
# 这就是模型总斜率
sum(d5)
[1] 1.076063
查看Geo地理参数对总斜率的贡献：
# ELEVATION + LAT + SINLONG + COSLONG
(0.016272654+0.003560670+0.011264754+0.040117124)/sum(d5)
# [1] 0.06618123
意思是Geo参数在模型解释的R2中的占比为3.9%。 以此类推。 绘制森林图
d2<-as.data.frame(d1$coefmat.full)
d3<-tibble::rownames_to_column(d2)
d3$factor<-d3$rowname
View(d3)
d3<-d3[c(2:22),]
library(ggplot2)
d3$factor<-factor(d3$factor, levels=c("COSLONG", "SINLONG",
"LAT","ELEVATION", "ARIDITY", "SAND", "I(PH^2)", "PH",
"SLO" , "SR", "CWV_logSLA" , "CWM_logSLA","I(CWV_logH^2)", "CWV_logH",
"I(CWV_logSLA^2)","CWS_logH","CWK_logSLA", "I(CWK_logH^2)","I(CWK_logSLA^2)",
"CWS_logSLA", "CWK_logH"))
f1 <- ggplot(d3, aes(x=factor, y=Estimate)) + # , fill=Response_ord
geom_point(size=1.5,stroke = 1.5)+
geom_errorbar(aes(ymin=Estimate-1.96*`Std. Error`, ymax=Estimate+1.96*`Std. Error`), width=0)+
coord_flip() +
ylab('Parameter estimates') +
xlab("") +
theme(axis.text=element_text(size=12,face="bold"),
axis.title=element_text(size=12,face="bold"))+
geom_hline(yintercept=0, lty=2, size=1, color="red")
plot(f1)
注意： 回归的Estimate就是B值就是beta就是回归的斜率 
Back to the top
- Basic R analysis
Meta analysis
Meta分析（荟萃分析）是什么呢…感觉就是研究别人的研究，因为对于许多单独进行的研究而言，样本观察组太小可能会对结论产生影响。所以荟萃分析是将系统评价中的不同结果的同类研究合并为一个量化指标的统计学方法，算是一种系统评价的方法。既然是所谓的systematic review，那就有着严格的纳入标准与全面的系统检索，因此其实要说简单那也不能算简单：
- 文献检索与筛选：Web of Science高级检索
- 数据提取：制作特征表：整合所有文献的信息；接着制作质量评价表：对入选文献打分（Cochrane手册？）
- 统计学分析：数据有两种形式：二分类（好/坏），或者连续变量（也可以是离散的？），分析后制作为 1）森林图，一个指标一个图，看看有效性，异质性（$I^2>50?$），效应尺度？ 2）漏斗图，对称表示满意发表性偏倚。 如果存在异质性，还需要进行敏感性分析/亚组分析. 接着就是R语言基于metafor包进行meta分析了！
Related packages
首推metafor和meta包 这些软件包使用户能够计算出在荟萃分析（escalc()函数）中经常使用的各种效应大小和结果度量，包括：（不懂这些是啥，翻译了放上去就完事儿了）
- 2×2表格数据的风险差异RD，风险比RR和优势比（Odds Ratio），
- 两组人时数据的发生率比率和差异，
- 原始和标准化的均值差和响应率（均值比），
- Raw和Fisher的r-z转换相关系数，
- 原始，对数，logit，反正弦和Freeman-Tukey双反正弦变换比例，
- 原始，对数和平方根转换的发生率，
- 原始均值，均值变化和标准均值变化，
- 原始和转换后的Cronbach的alpha值。
也提供了多种模型与分析方法：
- 使用反方差方法（rma()函数）的固定，随机和混合效应模型，
- Mantel-Haenszel和Peto的（一步式）方法用于2×2表格和两组人时数据（rma.mh()和rma.peto()功能），
- 用于分析2×2表数据，两组人时数据，比例和发生率（rma.glmm()函数）的广义线性（混合效应）模型（即混合效应（条件）对数模型和Poisson回归模型），
- 多层次和多元荟萃分析（rma.mv()功能）的模型，
- 网络荟萃分析和混合治疗比较（rma.mv()功能）的模型，
- 系统发育荟萃分析的模型（rma.mv()功能），
- 时空荟萃分析模型（rma.mv()函数），
- 分组和（混合效应）元回归分析，
- 具有用户定义的权重的模型。
图片与表格的绘制：
- 漏斗图（funnel()函数），
- 森林图（forest()和addpoly()功能），
- Baujat图（baujat()函数），
- L’Abbé图（labbe()函数），
- 径向（Galbraith）图（radial()函数），
- GOSH图（gosh()函数），
- 轮廓似然图（profile()函数），
- 正常分位数（QQ）图（qqnorm()函数）。
发表性偏倚，可以通过多种方法来检查是否存在发布偏差（或更准确地说，是漏斗图不对称或“小研究效应”）及其对结果的潜在影响，包括：
- 等级相关检验（ranktest()函数），
- Egger回归测试（regtest()函数），
- 修剪和填充方法（trimfill()功能），
- Henmi和Copas方法（hc()函数），
- 使用Rosenthal，Orwin和Rosenberg方法（fsn()功能）进行文件抽屉分析（故障安全N计算），
- 重要性检验（tes()功能）。
该软件包提供了标准和高级方法，用于基于元分析数据得出推论并评估模型拟合，包括：
- 似然比和Wald型检验（anova()函数），
- 异质性统计量（confint()函数）的置信区间，
- 排列测试（permutest()功能），
- （集群）健壮测试和置信区间（robust()函数），
- 累积荟萃分析（cumul()函数），
- 拟合和预测的结果（fitted()和predict()功能），
- 最佳线性无偏预测（ranef()和blup()函数），
- 使用Knapp和Hartung方法改善了测试/置信区间，
- 模型拟合标准（logLik()和deviance()函数），
- 信息标准（AIC()，BIC()和fitstats()功能），
- 模拟来自拟合模型（simulate()功能）的数据。
该软件包还可以兼容glmulti和MuMIn包进行模型选择和（多）模型推理，可以在boot包进行bootstrapping，并在mice和Amelia包进行多重插补。
离群值/影响诊断，有多种方法可用于识别异常值和/或有影响力的研究，以及进行敏感性分析，包括：
- 生/标准化/学生化残差（residuals()，rstandard()，和rstudent()函数），
- DFFITS值，库克距离，协方差比和DFBETAS值（influence()函数），
- 模型权重和帽子值（weights()和hatvalues()函数），
- 留一法分析（leave1out()和influence()功能）。
计算结果变量： 主函数：
escalc(measure, ai, bi, ci, di, n1i, n2i, m1i, m2i, sd1i, sd2i, xi, mi, ri, ni, data = NULL, add = 1/2, to = "only0", vtype = "LS", append = FALSE)
其中measure是一个字符串，指定应计算哪个结果度量值（参见下面的各种选项），参数ai到ni用于提供计算各种度量值所需的信息（取决于measure下指定的结果度量值，需要提供不同的参数），data可用于指定一个数据帧，其中包含给前面参数的变量，add和to是处理2×2表格数据（可能包含带零单元格）时所需的参数，vtype是一个参数，指定应计算的采样方差估计值（见下文）。当设置append=TRUE时，通过data参数指定的数据帧将与效果大小估计值和相应的采样方差一起返回。
Protocol
Example
van Houwelingen, H. C., Arends, L. R., & Stijnen, T. (2002). Advanced methods in meta-analysis: Multivariate approach and meta-regression. Statistics in Medicine, 21(4), 589-624.
加载数据
library(metafor)
dat <- dat.colditz1994
dat
(我将数据集复制到“dat”中，它更短一些，因此更容易在下面输入)。数据集中的变量tpos和tneg表示接种(治疗)组中结核阳性和阴性的个体数量，而cpos和cneg表示未接种(对照组)组中结核阳性和阴性的个体数量。 我们可以计算单个对数比值比和相应的抽样方差:
dat <- escalc(measure="OR", ai=tpos, bi=tneg, ci=cpos, di=cneg, data=dat)
此外，我们还可以将年份变量重新编码如下表所示：
dat$year <- dat$year - 1900
建立混合效应模型：
res <- rma(yi, vi, data=dat, method="FE")
res
为便于解释，可将这些结果反向转换为比值比尺度:
predict(res, transf=exp, digits=3)
对于相同的数据，可以拟合一个随机效应模型(使用最大似然估计):
res <- rma(yi, vi, data=dat, method="ML")
res
同样，我们可以将这些结果反向转换为优势比尺度:
predict(res, transf=exp, digits=3)
下图给出了试间方差的似然函数曲线。可以得到相同的图:
profile(res, xlim=c(0.01,2), steps=100, log="x", cex=0, lwd=2)
abline(h=logLik(res) - 1.92, lwd=2)
abline(v=c(0.12, 0.89), lty="dashed")
基于概率的95%轮廓置信区间的边界也被添加到数字。然而，利用最大似然获得的ci为$\tau ^2$经常达不到名义上的覆盖概率，特别是当基于ML估计。在这种情况下，间隔可能太窄。另一方面，用Q-profile方法得到的ci为$\tau ^2$，通常可以达到名义覆盖概率。这样的CI很容易通过以下方法得到:
confint(res)
为平均处理效果(即$\mu$)构建一个似然曲线(见文章中的图2)和相应的CI则稍微复杂一些(见第598页)。然而，作为另一种选择，我建议使用Knapp和Hartung方法为$\mu$构建CI。众所周知，它在大多数情况下基本上实现名义上的覆盖。该CI可由以下得出，数值会宽一点:
res <- rma(yi, vi, data=dat, method="ML", test="knha")
predict(res, transf=exp, digits=3)
下图显示了在95% ci下观察到的对数比值比和相应的95%后验置信区间的经验贝叶斯估计。通过一些工作，同样的图形可以创建与:
res <- rma(yi, vi, data=dat, method="ML")
sav <- blup(res)
par(family="mono", mar=c(5,4,1,2))
forest(res, refline=res$b, addpred=TRUE, xlim=c(-7,8), alim=c(-3,3), slab=1:13, psize=0.8,
ilab=paste0("(n = ", formatC(apply(dat[,c(4:7)], 1, sum), width=7, big.mark=","), ")"),
ilab.xpos=-3.5, ilab.pos=2, rows=13:1+0.15, header="Trial (total n)")
arrows(sav$pi.lb, 13:1 - 0.15, sav$pi.ub, 13:1 - 0.15, length=0.03, angle=90, code=3, lty="dotted")
points(sav$pred, 13:1 - 0.15, pch=15, cex=0.8)
底部显示的预测区间(通过总结多边形的虚线)比本文中报告的略宽，因为它也考虑到了$\hat{\mu}$中的不确定性。这个区间(即-1.875到.391)也可以通过:
predict(res, digits=3)
接下来可以考虑多变量的情景： 在文章的下一部分，作者介绍了元分析的二元模型。为此，以不同的方式处理数据集，每个研究为分析贡献两个数据点，即接种(处理)组的结果(即log odds)和未接种(对照组)组的结果(即log odds)。L’abbe的图使这个想法很明确:
res <- rma(measure="OR", ai=tpos, bi=tneg, ci=cpos, di=cneg, data=dat, method="ML")
labbe(res, xlim=c(-7,-1), ylim=c(-7,-1), xlab="ln(odds) not-vaccinated group", ylab="ln(odds) vaccinated group")
虚线表示基于模型的估计效果: 
对应的长格式数据集可以通过:
dat.long <- to.long(measure="OR", ai=tpos, bi=tneg, ci=cpos, di=cneg, data=dat.colditz1994)
具有相应采样方差的特定结果(即log odds)可以添加到数据集:
dat.long <- escalc(measure="PLO", xi=out1, mi=out2, data=dat.long)
dat.long$tpos <- dat.long$tneg <- dat.long$cpos <- dat.long$cneg <- NULL
levels(dat.long$group) <- c("EXP", "CON")
dat.long$group <- relevel(dat.long$group, ref="CON")
dat.long
由于用于计算这些特定结果的数据没有重叠，观察到的结果是(有条件的)独立的。然而，相应的真实结果可能是相关的。双变量模型允许我们估计两组真实结果的方差和相关性:
res <- rma.mv(yi, vi, mods = ~ group - 1, random = ~ group | trial, struct="UN", data=dat.long, method="ML")
res
不去除截距(将对照组作为组因子的参考水平)，直接从该模型得到估计的(平均)对数比值比:
res <- rma.mv(yi, vi, mods = ~ group, random = ~ group | trial, struct="UN", data=dat.long, method="ML")
$\mu$的估计数(即-0.74)与之前基于(log)优势比的随机效应模型得到的估计数基本相同。同时，基于二元模型，我们可以通过以下方法来估计真实对数比值比的异质性程度:
res$tau2[1] + res$tau2[2] - 2*res$rho*sqrt(res$tau2[1]*res$tau2[2])
这个值与之前得到的$\tau ^2$的估计值非常接近。
Data import and process
load("_data/Meta_Analysis_Data.RData")
madata <- Meta_Analysis_Data
colnames(madata)[6:12] = c("Intervention_Duration", "Intervention_Type", "Population",
"Type_of_Students", "Prevention_Type", "Gender", "Mode_of_Delivery")
#干预持续时间，干预的类型，被试类型，预防的类型，性别，交付方式？
madata <- Meta_Analysis_Data
#删除一些列
madata$`ROB streng`=NULL
madata$`ROB superstreng`=NULL
#查看数据结构
str(madata)
虽然这个输出看起来有点乱，但它已经提供了很多信息。它显示了我的数据结构。在本例中，我使用的数据已经计算出了效应大小。这就是变量TE和seTE出现的原因。我还看到了许多其他变量，它们对应于为这个数据集编码的子组。 接下来可以以表格的形式查看数据：
library(kableExtra)
library(magrittr)
madata.s<-madata[,1:7]
madata.s$population=NULL
madata.s %>%
kable("html") %>%
kable_styling(font_size = 10)
现在我们在RStudio中有了荟萃分析数据，让我们对数据做一些操作。当我们稍后进行分析时，这些函数可能会派上用场。 假设我们有偏倚风险亚组(其中偏倚评级风险被编码)，并希望它是一个具有两个不同级别的因素:“低”和“高”。 要做到这一点，我们需要变量ROB作为一个因子。但是，这个变量当前存储为字符(chr)。我们可以通过键入数据集的名称来查看这个变量，然后添加选择器$，然后添加我们想查看的变量。滞后我们把这些高（high）和低（low）变量都转为数字变量（1和2）。
madata = Meta_Analysis_Data
madata$ROB<-madata$`ROB streng`
madata$ROB
str(madata$ROB)
madata$ROB<-factor(madata$ROB)
madata$ROB
str(madata$ROB)
现在让我们来看看干预类型亚组变量。该列目前也是作为character(chr)变量存储的。 假设我们想要一个变量它只包含一个研究是否是正念干预的信息。logical类型的数据非常适合于此。为了将数据转换为逻辑数据，我们使用as.logical。我们将创建一个包含此信息的新变量，称为intervention.type.logical。为了告诉我们哪些为TRUE，哪些为FALSE，我们必须使用==命令定义特定的干预类型。
intervention.type.logical<-as.logical(madata$`intervention type`=="mindfulness")
intervention.type.logical
我们看到R已经为我们将字符信息转换成正确和错误两种形式。为了检查这个操作是否正确，让我们比较原始变量和新变量。
n <- data.frame(intervention.type.logical,madata$`intervention type`)
names <- c("New", "Original")
colnames(n) <- names
kable(n)
选择某些研究进行进一步的分析，或者在进一步的分析中排除某些研究(例如，如果它们是异常值)，这通常是有用的。为此，我们可以使用dplyrpackage中的过滤器函数，它是我们之前安装的tidyverse包的一部分:
library(dplyr)
#筛选这三个人的数据
madata.new <- dplyr::filter(madata, Author %in% c("Cavanagh et al.",
"Frazier et al.",
"Phang et al."))
#并查看
madata.new %>%
kable("html") %>%
kable_styling(font_size = 9)
#只选择那些被编码为正念研究的研究
madata.new.mf <- dplyr::filter(madata,`intervention type` %in% c("mindfulness"))
#排除特定的研究
madata.new.excl <- dplyr::filter(madata,!Author %in% c("Cavanagh et al.",
"Frazier et al.",
"Phang et al."))
#查看行列并修改
madata[6,1]
madata[6,1] <- "Frogelli et al."
Merge effect values
这是为了得到一个对研究总体效应大小的估计： 在荟萃分析中汇聚效应规模时，我们可以使用两种方法:固定效应模型或随机效应模型。关于哪种模式在哪种背景下最适合，存在着广泛的争论，目前尚无明确的共识。虽然在临床心理学和健康科学中建议只使用随机效应池模型，但我们将在这里描述如何在R中进行。
这两个模型只需要每个研究的效应大小，和一个离散(方差)估计，两者取反比。这就是为什么这些方法通常被称为泛型反方差方法。
Fixed effect model
我们首先要用一般的心理测量数据和心理测量数据来描述这些差异。稍后，我们将把这些知识扩展到使用多变量数据的荟萃分析，如果你专注于预防试验，这可能很重要。 对于所有的meta分析，我们将使用meta包。在第2.1节中，我们展示了如何安装包。从库开始加载程序包。
library(meta)
library(tidyverse)
library(knitr)
固定效应模型假设所有的研究以及它们的效应大小都来自一个单一的同质群体。因此，为了计算整体效应，我们平均所有效应大小，但给予研究更高精度更高的权重。在这种情况下，更高的精度意味着研究有一个更大的N，这导致其效应大小估计的标准误差较小。
为了获得权重，我们必须使用每个研究$k$的逆方差 $1/\hat\sigma^2_k$。然后我们计算所有研究的加权平均值，即我们的固定效应大小估计值$\hat\theta_F$: \(\hat\theta_F = \frac{\sum\limits_{k=1}^K \hat\theta_k/ \hat\sigma^2_k}{\sum\limits_{k=1}^K 1/\hat\sigma^2_k}\)
- 它可以存储为原始数据（包括每个研究的平均值M、参与数N和标准差SD）
- 或者它只包含计算的效果大小和标准误差（SE）。 ```r load(“_data/Meta_Analysis_Data.RData”) madata<-Meta_Analysis_Data str(madata)
此数据集中的效果大小基于**连续结果数据**。因为我们的效果大小已经计算好了，所以我们可以使用`meta::metagen`函数。对于这个函数，我们可以指定参数的加载，所有这些参数都可以通过输入`?metagen`包后显示。
让我们先分析一下这个荟萃代码的影响。我们将给出这个分析结果的简单名称`m`:
```r
m <- metagen(TE,
seTE,
data=madata,
studlab=paste(Author),
comb.fixed = TRUE,
comb.random = FALSE,
prediction=TRUE,
sm="SMD")
m
# SMD 95%-CI %W(fixed)
#Call et al. 0.7091 [ 0.1979; 1.2203] 3.6
#Cavanagh et al. 0.3549 [-0.0300; 0.7397] 6.3
#DanitzOrsillo 1.7912 [ 1.1139; 2.4685] 2.0
#de Vibe et al. 0.1825 [-0.0484; 0.4133] 17.5
#Frazier et al. 0.4219 [ 0.1380; 0.7057] 11.6
#Frogeli et al. 0.6300 [ 0.2458; 1.0142] 6.3
#Gallego et al. 0.7249 [ 0.2846; 1.1652] 4.8
#Hazlett-Stevens & Oren 0.5287 [ 0.1162; 0.9412] 5.5
#Hintz et al. 0.2840 [-0.0453; 0.6133] 8.6
#Kang et al. 1.2751 [ 0.6142; 1.9360] 2.1
#Kuhlmann et al. 0.1036 [-0.2781; 0.4853] 6.4
#Lever Taylor et al. 0.3884 [-0.0639; 0.8407] 4.6
#Phang et al. 0.5407 [ 0.0619; 1.0196] 4.1
#Rasanen et al. 0.4262 [-0.0794; 0.9317] 3.6
#Ratanasiripong 0.5154 [-0.1731; 1.2039] 2.0
#Shapiro et al. 1.4797 [ 0.8618; 2.0977] 2.4
#SongLindquist 0.6126 [ 0.1683; 1.0569] 4.7
#Warnecke et al. 0.6000 [ 0.1120; 1.0880] 3.9
#
#Number of studies combined: k = 18
#
# SMD 95%-CI z p-value
#Fixed effect model 0.4805 [ 0.3840; 0.5771] 9.75 < 0.0001
#Prediction interval [-0.0344; 1.1826]
#
#Quantifying heterogeneity:
# tau^2 = 0.0752 [0.0357; 0.3046]; tau = 0.2743 [0.1891; 0.5519];
# I^2 = 62.6% [37.9%; 77.5%]; H = 1.64 [1.27; 2.11]
#
#Test of heterogeneity:
# Q d.f. p-value
# 45.50 17 0.0002
#
#Details on meta-analytical method:
#- Inverse variance method
#- DerSimonian-Laird estimator for tau^2
#- Jackson method for confidence interval of tau^2 and tau
我们现在看到了meta分析的结果，包括
- 每个研究的个体效应大小individual effect sizes及他们的权重
- 研究的总数number of included studies ($k$)
- 总体效应overall effect (本例中 $g$ = 0.48) 及置信区间与$p$-value
- 不同研究异质性的度量between-study heterogeneity, 如$tau^2$或$I^2$或者 异质性的$Q$-test 使用
$命令，我们还可以直接查看各种输出。例如：#95%置信区间的下限 m$lower.I2可以把结果保存为一个txt
sink("results.txt") print(m) sink()
要从原始数据进行固定效果模型荟萃分析，我们必须使用meta:：metacont()函数。然而，代码的结构看起来非常相似。
#加载并查看数据
load("_data/metacont_data.RData")
metacont$Ne<-as.numeric(metacont$Ne)
metacont$Me<-as.numeric(metacont$Me)
metacont$Se<-as.numeric(metacont$Se)
metacont$Mc<-as.numeric(metacont$Mc)
metacont$Sc<-as.numeric(metacont$Sc)
str(metacont)
进行Meta分析：
m.raw <- metacont(Ne,
Me,
Se,
Nc,
Mc,
Sc,
data=metacont,
studlab=paste(Author),
comb.fixed = TRUE,
comb.random = FALSE,
prediction=TRUE,
sm="SMD")
m.raw
# SMD 95%-CI %W(fixed)
#Cavanagh -0.4118 [-0.8081; -0.0155] 13.8
#Day -0.2687 [-0.6154; 0.0781] 18.0
#Frazier -0.7734 [-1.0725; -0.4743] 24.2
#Gaffney -0.7303 [-1.2542; -0.2065] 7.9
#Greer -0.7624 [-1.0992; -0.4256] 19.1
#Harrer -0.1669 [-0.5254; 0.1916] 16.9
#
#Number of studies combined: k = 6
#
# SMD 95%-CI z p-value
#Fixed effect model -0.5245 [-0.6718; -0.3773] -6.98 < 0.0001
#Prediction interval [-1.1817; 0.1494]
#
#Quantifying heterogeneity:
# tau^2 = 0.0441 [0.0000; 0.4236]; tau = 0.2101 [0.0000; 0.6509];
# I^2 = 56.1% [0.0%; 82.3%]; H = 1.51 [1.00; 2.38]
#
#Test of heterogeneity:
# Q d.f. p-value
# 11.39 5 0.0441
#
#Details on meta-analytical method:
#- Inverse variance method
#- DerSimonian-Laird estimator for tau^2
#- Jackson method for confidence interval of tau^2 and tau
#- Hedges' g (bias corrected standardised mean difference)
如您所见，所有计算的效果大小现在都是负数，包括总效应。然而，所有的研究都报告了一个积极的结果，这意味着干预组的症状（如抑郁症）减轻了。消极取向的结果是，在许多临床试验中，较低的分数表示更好的结果（例如，更少的抑郁）。像这样报告价值是没有问题的：事实上，这是传统的。 然而，一些不熟悉荟萃分析的读者可能会对此感到困惑，所以你可以考虑在你的论文中报告之前改变你的价值取向。
Random effect model
之前，我们展示了如何使用metagen和metacont函数执行固定效果模型的荟萃分析。
然而，我们只能在假设所有包含的研究来自同一人群时使用固定效应模型。在实践中，几乎没有这种情况：干预措施可能在某些特征上有所不同，每个研究中使用的样本可能略有不同，或者其方法也可能略有不同。在这种情况下，我们不能假设所有的研究都来自同一个假设的“总体”研究。
一旦我们在固定效应模型meta分析中检测到统计异质性，情况也是如此，$I^{2}>0\%$。 你很可能会用荟萃模型来分析。谢天谢地，当我们在R中进行随机效应模型元分析而不是固定效应模型荟萃分析时，我们不需要考虑太多。
在随机效应模型中，我们想解释我们的假设，即研究效果估计值比从单个总体得出的结果显示出更多的方差。随机效应模型是在所谓的交换性假设下工作的。这意味着，在随机效应模型的元分析中，我们不仅假设个别研究的效果因抽样误差而偏离所有研究的真实干预效果，而且还有另一个方差来源，即研究并非来自一个单一群体，而是来自于一个“大范围的”种群。 因此，我们假设不仅存在一个真实效应大小，而且一个真实效应大小的分布。因此，我们要估计真实效应大小分布的平均值。固定效应模型假设，当单个研究$k$的观测效应大小$\hat\theta_k$与真实效应大小$\theta_F$有偏差时，唯一的原因是估计值受到（抽样）误差$\epsilon_k$的负担。 \(\hat\theta_k = \theta_F + \epsilon_k\) 而随机效应模型假设，除此之外，还有第二个误差源$\zeta_k$。这第二个误差源是由这样一个事实引入的：即使我们的研究$k$的真实效应大小$\theta_k$也只是真实效应大小平均值$\mu$的过度分布的一部分。 因此，随机效应模型的公式如下所示： \(\hat\theta_k = \mu + \epsilon_k + \zeta_k\) 因此，在计算随机效应模型元分析时，我们还必须考虑误差$\zeta_k$。要做到这一点，我们必须估计真实效果大小分布的方差，它用$\tau^{2}$，或tau^2^表示。$\tau^{2}$有几个估值器，其中许多是在“meta”中实现的。我们将在下一节中为您提供更多有关它们的详细信息。 尽管在心理结果研究中使用随机效应模型元分析是传统的方法，但应用该模型并不是无可争议的。随机效应模型在荟萃分析中综合总体效应时更注重小规模研究。然而，特别是小型研究往往充满了偏见(bias)。这就是为什么有些人认为固定效应模型几乎总是更可取的。
随机效应模型中$\tau^2$的估计量:
在操作上，在R中进行随机效应模型元分析与进行固定效应模型元分析没有太大区别。但是，我们确实为$\tau^{2}$选择了一个估计量。在这里，我们可以选择使用method.tau:
所有这些估计量都使用稍微不同的方法得出$\tau ^{2}$，从而导致不同的合并效应大小估计和置信区间。如果这些方法中有一种或多或少有失偏颇，通常取决于背景和参数，例如研究的数量$k$、每个研究中的参与者数量$n$、每个研究的$n$有多大以及$\tau^{2}$有多大。 Veroniki及其同事的一篇综述性论文提供了一个关于当前证据的极好总结，即在何种情况下，估计量可能或多或少会有偏差。这篇文章是公开的，你可以在这里阅读它. 特别是在医学和心理学研究中，迄今为止最常用的估计量是D-L estimator。这种广泛使用的部分原因可能是，像RevMan或Comprehensive Meta Analysis（旧版本）这样的程序只使用这个估计器。它也是R中“meta”包中的默认选项。然而，在模拟研究中，最大似然、Sidik Jonkman和经验Bayes估计在估计研究间方差方面具有更好的性质。
Hartung-Knapp-Sidik-Jonkman法： 批评D-L方法的研究者认为，当估计我们的集合效应$var（\hat\theta_F）$的方差时，这种方法容易产生假阳性。尤其是当研究的数量很小，并且存在大量异质性时。不幸的是，当我们在医学领域做元分析的时候，我们经常这样做。这是一个相当大的问题，因为我们不想发现集合效应在统计学上是显著的，而事实上它们并不显著！ 因此，Hartung-Knapp-Sidik-Jonkman（HKSJ）方法被提出一种产生更稳健的$var（\hat\theta_F）$估计值的方法。结果表明，在许多情况下，这种方法大大优于德西蒙尼亚莱德方法。HKSJ方法也可以很容易地在R中应用，而其他程序还没有这个选项。这是在R中进行元分析的另一大好处。香港证券交易所通常会产生更为保守的结果，这是由更宽的置信区间表示的。
然而，应该指出的是，HKSJ方法并非没有争议。一些作者认为，在HKSJ之外，其他(标准)联营模型也应该被用作敏感性分析**。Jackson和他的同事提出了这个方法的四个剩余问题，你可以在选择元分析方法之前考虑这些问题。本文可在此处阅读。
预先计算的效应大小数据: 在所有这些输入之后，您将看到，即使是随机效应模型元分析也很容易用R编写代码。与固定效应模型相比，我们只需要定义三个额外的参数。特别是，如前所述，我们必须告诉R我们要使用哪种研究间方差估计量（$\tau^{2}$），以及是否要使用Knapp-Hartung（-Sidik-Jonkman）调整。 我将再次使用我的madata数据集进行meta分析。为了便于说明，让我们使用Sidik-Jonkman估计量（“SJ”）和HKSJ方法。要进行此分析，请确保在R中加载了meta和metafor。 加载包并导入数据
library(meta)
library(metafor)
load("_data/Meta_Analysis_Data.RData")
madata<-Meta_Analysis_Data
进行分析：
m.hksj <- metagen(TE,
seTE,
data = madata,
studlab = paste(Author),
comb.fixed = FALSE,
comb.random = TRUE,
method.tau = "SJ",
hakn = TRUE,
prediction = TRUE,
sm = "SMD")
m.hksj
# SMD 95%-CI %W(random)
#Call et al. 0.7091 [ 0.1979; 1.2203] 5.2
#Cavanagh et al. 0.3549 [-0.0300; 0.7397] 6.1
#DanitzOrsillo 1.7912 [ 1.1139; 2.4685] 4.2
#de Vibe et al. 0.1825 [-0.0484; 0.4133] 7.1
#Frazier et al. 0.4219 [ 0.1380; 0.7057] 6.8
#Frogeli et al. 0.6300 [ 0.2458; 1.0142] 6.1
#Gallego et al. 0.7249 [ 0.2846; 1.1652] 5.7
#Hazlett-Stevens & Oren 0.5287 [ 0.1162; 0.9412] 5.9
#Hintz et al. 0.2840 [-0.0453; 0.6133] 6.5
#Kang et al. 1.2751 [ 0.6142; 1.9360] 4.3
#Kuhlmann et al. 0.1036 [-0.2781; 0.4853] 6.1
#Lever Taylor et al. 0.3884 [-0.0639; 0.8407] 5.6
#Phang et al. 0.5407 [ 0.0619; 1.0196] 5.4
#Rasanen et al. 0.4262 [-0.0794; 0.9317] 5.3
#Ratanasiripong 0.5154 [-0.1731; 1.2039] 4.1
#Shapiro et al. 1.4797 [ 0.8618; 2.0977] 4.5
#SongLindquist 0.6126 [ 0.1683; 1.0569] 5.7
#Warnecke et al. 0.6000 [ 0.1120; 1.0880] 5.4
#
#Number of studies combined: k = 18
#
# SMD 95%-CI t p-value
#Random effects model 0.5935 [ 0.3891; 0.7979] 6.13 < 0.0001
#Prediction interval [-0.2084; 1.3954]
#
#Quantifying heterogeneity:
# tau^2 = 0.1337 [0.0295; 0.3533]; tau = 0.3657 [0.1717; 0.5944];
# I^2 = 62.6% [37.9%; 77.5%]; H = 1.64 [1.27; 2.11]
#
#Test of heterogeneity:
# Q d.f. p-value
# 45.50 17 0.0002
#
#Details on meta-analytical method:
#- Inverse variance method
#- Sidik-Jonkman estimator for tau^2
#- Q-profile method for confidence interval of tau^2 and tau
#- Hartung-Knapp adjustment for random effects model
结果表明，我们的估计效果是$g=0.59$，95%的置信区间从$g=0.39$延伸到$0.80$（四舍五入）。我们也很清楚，这种效应与我们在之前固定效应模型荟萃分析中发现的效应不同（而且更大）（$g=0.48$）。 让我们将其与使用DerSimonian Laird估计器以及设置hakn=FALSE时的输出进行比较。由于这个估计器是默认，所以我不必定义tau方法这次。
m.dl <- metagen(TE,
seTE,
data=madata,
studlab=paste(Author),
comb.fixed = FALSE,
comb.random = TRUE,
hakn = FALSE,
prediction=TRUE,
sm="SMD")
m.dl
我们看到，使用该估计量的总体效应大小估计值与前一个估计值（$g=0.57$）相似，但置信区间较窄，因为我们没有使用HKSJ方法对其进行调整。
TE<-c(m.hksj$TE.random,m.dl$TE.random)
seTE<-c(m.hksj$seTE.random,m.dl$seTE.random)
Method<-c("Knapp-Hartung-Sidik-Jonkman","DerSimonian-Laird")
frst.data<-data.frame(Method,TE,seTE)
m.frst<-metagen(TE,
seTE,
data=frst.data,
studlab=paste(Method),
comb.fixed = FALSE,
comb.random = FALSE,
hakn = FALSE,
prediction=FALSE)
meta::forest.meta(m.frst,xlim = c(0.34,0.85))
原始的效应大小数据：
load("_data/metacont_data.RData")
metacont$Ne<-as.numeric(metacont$Ne)
metacont$Me<-as.numeric(metacont$Me)
metacont$Se<-as.numeric(metacont$Se)
metacont$Mc<-as.numeric(metacont$Mc)
metacont$Sc<-as.numeric(metacont$Sc)
save(metacont, file = "_data/metacont_data.RData")
m.hksj.raw <- metacont(Ne,
Me,
Se,
Nc,
Mc,
Sc,
data = metacont,
studlab = paste(Author),
comb.fixed = FALSE,
comb.random = TRUE,
method.tau = "SJ",
hakn = TRUE,
prediction = TRUE,
sm = "SMD")
m.hksj.raw
Output of binary variables
在某些情况下，研究人员将不得不使用二元结果数据（例如，死亡/活着、抑郁障碍/无抑郁障碍）而不是连续的结果数据。在这种情况下，你可能会对合并优势比、相对风险（Cochrane手册建议使用该方法代替优势比，因为它们更容易解释）或发病率比率等结果更感兴趣。有两种常见的二进制结果数据类型：
- 事件率数据。在这些数据中，我们只处理每个组中经历事件的人数，以及每个组中的总样本量。从这些数据中我们可以计算出的效应大小是优势比、相对风险或风险差异等。
- 发病率数据。事件率数据通常不包含事件发生或未发生的时间跨度的任何信息。考虑到研究通常有完全不同的随访时间（例如，8周vs.2年），通常还需要考虑事件发生的时间间隔。在流行病学中，发病率通常用来表示在标准时间范围内（例如一年）发生了多少事件。相应的影响大小是发病率比率（IRR），它将干预组和对照组的发病率进行比较。
For both event rate data and incidence rate data, there are again two options to pool effect sizes using the meta package:
对于事件率数据和发生率数据，同样有两个选项可以使用meta包集中效果大小：
- 效果大小已经计算出来了。在这种情况下，我们可以像以前一样使用metagen函数，并使用一些其他规范。我们将在第4.3.3章中描述如何使用metagen函数来处理预先计算的二进制结果数据。
- 我们只有原始的结果数据。如果是这种情况，我们将不得不使用meta::metain()或meta:：metainc()函数。我们将在下面向您演示如何执行此操作。
Back to the top
- Basic R analysis
Predicting the future - Application of time series model
Introduction
来自澳大利亚莫纳什大学的教材Forecast：Principles and Practice 所有计算与建模均基于R语言，可以通过在CRAN上安装fpp2软件包以便进行下面所有的操作。 *** Hyndman, R.J., & Athanasopoulos, G. (2018) Forecasting: principles and practice, 2nd edition, OTexts: Melbourne, Australia. OTexts.com/fpp2.
- Predicting the future - Application of time series model
About prediction
有些预测很简单，而有些预测很难，事件的预测取决于以下三个因素：
- 我们对造成这种情况的因素的了解程度（对变量的了解
- 有多少数据可供预测
- 预测是否会影响我们要预测的事物
一个好的预测模型可以捕捉事物变化的方式，我们通常假定环境变化的方式将持续到未来，即高度波动的环境将继续高度波动…等。 如果没有可用数据，或可用数据与预测不相关，则必须使用定性预测的方法，而当有关于过去的数字信息且有理由假设过去模式的某些方面将持续到将来时，则可以采用定量预测的方式，定量预测可以通过时间序列数据进行预测。 在预测时，我们通常不直接指出预测的值，而是给出预测区间，该区间给出了随机变量可以相对较高的概率获取的一系列值。例如，一个95％的预测区间包含一系列值，其中应包括概率为95％的实际未来值。其中给了一条线表示了各个预测结果的平均值，这种预测方法称点预测。
预测任务可以分解为以下5个步骤：
- 问题定义：怎么预测
- 搜集信息：相关专业知识与数据
- 初步分析：绘制图表，探讨趋势
- 选择模型：就是选择模型啦
- 使用模型：并评估其效果
Figuring of time series images
ts object
时间可以作为ts对象存储与r中，如2012年的数据为10，2013年为11，2014年为15：
y <- ts(c(10,11,15), start = 2012)
对于每年进行一次以上的观察，我们需要添加fraquency参数，如每月数据我们储存为了z，则：
y <- ts(z, start = 2012, frequency = 12)
备注：一年有52周
time <- read.csv("你的文件")
#b为列名为b的你要分析的数据
time$b
#把数据框的数据变为时间序列，从1900年开始，到1986年截至
a <- ts(time$b, frequency = 1, start = c(1900,1), end = c(1986))
str(a)
Time series figure (line)
对于时间序列数据，首先应当绘制相关的时间图。即将观察值相对于观察时间绘制，连续观察由直线连接。下图显示了澳大利亚两个最大城市之间的安捷航空每周的经济客运量。 
#autoplot可以自动生成合适的图表
autoplot(melsyd[,"Economy.Class"]) +
ggtitle("Economy class passengers: Melbourne-Sydney") +
xlab("Year") +
ylab("Thousands")
由图片可以知道：
- 1989年有一段时期没有乘客载运-这是由于劳资纠纷造成的。
- 在1992年有一段时间，载客量有所减少。这是由于试验将某些经济舱座位替换为商务舱座位。
- 1991年下半年客运量大大增加。
- 每年年初，负载都有一些大的下降。这些是由于假期的影响。
- 该系列的水平存在长期波动，该波动在1987年增加，在1989年减少，并在1990年和1991年再次增加。
- 有些时期缺少观察结果。
也有一些简单的时间序列图：
autoplot(a10) +
ggtitle("Antidiabetic drug sales") +
ylab("$ million") +
xlab("Year")
这是澳大利亚抗糖尿病药物的月销售额。显然这里的趋势是不断增长，每年年初的下降则与政府年初的补贴有关。
对于那些有季节性变化趋势的数据，我们可以将不同年份的数据进行对比，如上面的澳大利亚糖尿病药物数据：
ggseasonplot(a10, year.labels=TRUE, year.labels.left=TRUE) +
ylab("$ million") +
ggtitle("Seasonal plot: antidiabetic drug sales")
我们可以直观的观察到，在这种情况下，很明显，每年一月份的销售额都有很大的增长。实际上，这些可能是12月下旬的销售，因为客户在年末之前有库存，但是直到一两周后才向政府注册销售。该图还显示，2008年3月的销售额异常少（大多数其他年份显示2月至3月之间有所增长）。2008年6月的销售量很少，可能是由于在收集数据时对销售的计数不完整。
也许我们还可以用极坐标来显示：
ggseasonplot(a10, polar=TRUE) +
ylab("$ million") +
ggtitle("Polar seasonal plot: antidiabetic drug sales")
也可以把每个季节的数据搜集在一起来显示：
ggsubseriesplot(a10) +
ylab("$ million") +
ggtitle("Seasonal subseries plot: antidiabetic drug sales")
Scatter plot
散点图可以探索不同因素的时间序列图像之间的关系。 下图显示了两个时间序列：澳大利亚维多利亚州2014年的半小时用电需求（千兆瓦）和温度（摄氏度）。温度是墨尔本（维多利亚州最大的城市）的温度，而需求值是整个州的温度。
autoplot(elecdemand[,c("Demand","Temperature")], facets=TRUE) +
xlab("Year: 2014") + ylab("") +
ggtitle("Half-hourly electricity demand: Victoria, Australia")
我们可以通过绘制一个序列与另一个序列的散点图来研究用电需求与温度之间的关系。
qplot(Temperature, Demand, data=as.data.frame(elecdemand)) +
ylab("Demand (GW)") + xlab("Temperature (Celsius)")
此散点图有助于我们可视化变量之间的关系。显然，由于空调的影响，当温度高时会出现高需求。但是相反的，对于非常低的温度，需求增加。 相关系数就是衡量两个变量之间是否是线性关系的一种手段，相关系数仅测量线性关系的强度，有时会产生误导，因此还需要查看数据图来获得更多详细结论。
散点图矩阵 当存在多个潜在的预测变量时，将每个变量相对于另一个变量作图很有用。下图显示了五个时间序列，该序列显示了澳大利亚新南威尔士州五个地区的季度访客人数。
autoplot(visnights[,1:5], facets=TRUE) +
ylab("Number of visitor nights each quarter (millions)")
显示它们的散点图矩阵（需要GGally包）
GGally::ggpairs(as.data.frame(visnights[,1:5]))
散点图矩阵的值是可以快速查看所有变量对之间的关系。在此示例中，曲线的第二列显示，新南威尔士州北部海岸的游客和新南威尔士州南部海岸的游客之间存在很强的正相关关系，但新南威尔士州北部海岸的游客和新南威尔士州南部内陆的游客之间没有可检测的关系。异常值也可以看到。新南威尔士州都会区有一个异常高的季度，与2000年悉尼奥运会相对应。
Lag figure
滞后嘛，就是滞后，比如5月数据一阶滞后后就算到4月里去了，那种意思。下图显示了澳大利亚啤酒季度产量的散点图，其中横轴显示了时间序列的滞后值。
beer2 <- window(ausbeer, start=1992)
gglagplot(beer2)
我们可以发现啤酒产量有4个月的滞后期，即生产4个月后可能才进入销售渠道。
Autocorrelation
自相关性度量时间序列的滞后值之间的线性关系，即数据是否自己有规律地变动。 对于上图中的九个散点图分别求相关系数可得其自相关情况。
ggAcf(beer2)
蓝色虚线外表示相关性是否显着不为零。
当数据具有趋势时，小的滞后的自相关往往会很大并且是正的，因为及时附近的观测值的大小也很近。因此，趋势时间序列的ACF倾向于具有正值，而正值随着滞后的增加而逐渐降低。
当数据是季节性的时，季节性滞后（以季节性频率的倍数）的自相关将大于其他滞后。
如澳大利亚每月电力需求及其自相关：
aelec <- window(elec, start=1980)
autoplot(aelec) + xlab("Year") + ylab("GWh")
ggAcf(aelec, lag=48)
White noise
没有自相关的时间序列称为白噪声 如：
set.seed(30)
y <- ts(rnorm(50))
autoplot(y) + ggtitle("White noise")
ggAcf(y)
对于白噪声系列，我们希望每个自相关接近于零。当然，由于存在一些随机变化，它们将不完全等于零。对于白噪声系列，我们预计ACF中95％的尖峰位于$\pm 2/\sqrt{\check{\textup{T}}}$内,其中$\check{\textup{T}}$是时间序列的长度。
Prediction toolbox
Simple prediction
- 取平均，未来预测值等于历史数据的均值
meanf(y, h) # y contains the time series # h is the forecast horizon - 随机游走预测(naive)，将所有预测设为最后一次观察的值
naive(y, h) rwf(y, h) # Equivalent alternative - 季节性随机游走预测,预测设为某个时间循环前观察的值
snaive(y, h) - 漂移法，随机游走的方法的一种变化是允许预测随时间增加或减少，其中随时间的变化量（称为“漂移”）设置为历史数据中的平均变化。差不多就是在第一个观察值和最后一个观察值之间连线，将其外推到将来。
rwf(y, h, drift=TRUE)可以借此预测澳大利亚啤酒产量：
# Set training data from 1992 to 2007 beer2 <- window(ausbeer,start=1992,end=c(2007,4)) # Plot some forecasts autoplot(beer2) + autolayer(meanf(beer2, h=11), series="Mean", PI=FALSE) + autolayer(naive(beer2, h=11), series="Naïve", PI=FALSE) + autolayer(snaive(beer2, h=11), series="Seasonal naïve", PI=FALSE) + ggtitle("Forecasts for quarterly beer production") + xlab("Year") + ylab("Megalitres") + guides(colour=guide_legend(title="Forecast"))
当然，这些方法都不是很靠谱。Data preprocessing
- 日历调整，
monthdays可以消除因为每月日数不同而带来的差异。如下图中的每月数据因为每月日期不同而产生了“锯齿”。dframe <- cbind(Monthly = milk, DailyAverage = milk/monthdays(milk)) autoplot(dframe, facet=TRUE) + xlab("Years") + ylab("Pounds") + ggtitle("Milk production per cow")
- 人口调整，尽量使用人均数据而不是人数数据。
- 通货膨胀调整，根据价格指数或者CPI进行调整。
- 数字转换，幂变换等，
BoxCox函数可以自动寻找一个合适的lambda进行幂变化。(lambda <- BoxCox.lambda(elec)) #> [1] 0.2654 autoplot(BoxCox(elec,lambda)) - 偏差调整，使用数学变换（例如Box-Cox变换）的一个问题是，逆变换的点预测将不是预测分布的均值。实际上，它通常是预测分布的中位数（假设变换空间上的分布是对称的）。但有时需要平均预测，例如，您可能希望汇总各个地区的销售预测以形成整个国家的预测。但是，中位数不会相加，而平均值却会相加。可以使用
biasadj=TRUE显示预测的平均数。fc <- rwf(eggs, drift=TRUE, lambda=0, h=50, level=80) fc2 <- rwf(eggs, drift=TRUE, lambda=0, h=50, level=80, biasadj=TRUE) autoplot(eggs) + autolayer(fc, series="Simple back transformation") + autolayer(fc2, series="Bias adjusted", PI=FALSE) + guides(colour=guide_legend(title="Forecast"))
Residual diagnosis
即为预测值与实际值的偏差。以谷歌股价为例，我们使用随机游走预测谷歌的股价，并计算它的残差。 绘制谷歌股价：
autoplot(goog200) + xlab("Day") + ylab("Closing Price (US$)") + ggtitle("Google Stock (daily ending 6 December 2013)")
进行朴素预测：autoplot(naive(goog200)) + xlab("Day") + ylab("Closing Price (US$)") ggtitle("Google Stock (daily ending 6 December 2013)")计算残差,可以发现大的正残差是第166天意外价格上涨的结果。：
res <- residuals(naive(goog200)) autoplot(res) + xlab("Day") + ylab("") + ggtitle("Residuals from naïve method")
绘制残差直方图，右尾确实有点长：gghistogram(res) + ggtitle("Histogram of residuals")
绘制ACF，可以认为缺乏相关性，因此预测结果不错ggAcf(res) + ggtitle("ACF of residuals")
这些图表明，朴素的方法(随机游走)所产生的预测似乎可以说明所有可用信息。残差的平均值接近零，并且在残差序列中没有显着的相关性。残差的时间图显示，除一个异常值外，残差的变化在整个历史数据中保持几乎相同，因此残差方差可以视为恒定值。这也可以在残差的直方图中看到。直方图表明残差可能不正常-即使我们忽略异常值，右尾也似乎太长。因此，使用此方法进行的预测可能会很好，但是假设正态分布而计算出的预测区间可能不准确。 同时还可以进行Portmanteau自相关检验，包括Box-Pierce检验（Box.test(res, lag=10, fitdf=0)）和Ljung-Box测试（Box.test(res,lag=10, fitdf=0, type="Lj")），也可以用一个函数包搞定上面所有：checkresiduals(naive(goog200))。Estimate the accuracy of the prediction
需要将数据分为训练集与测试集进行评估，测试集通常为总样本的20%。我们在训练集上与结果的差称为残差，在测试集上则称为误差 可以使用
window函数提取时间序列中的一部分作为子集。#提取所有95年以后的数据 window(ausbeer, start=1995) #使用subset进行筛选，提取最近5年的观测值 subset(ausbeer, start=length(ausbeer)-4*5) #提取所有年份第一季度的值 subset(ausbeer, quarter = 1) #用tail提取后5年的值，或者用head提取前5年 tail(ausbeer, 4*5)可以通过百分比误差（平均绝对百分比误差MAPE）和比例误差（平均绝对比例误差MASE）进行误差的衡量 首先我们对啤酒产量进行预测：
beer2 <- window(ausbeer,start=1992,end=c(2007,4)) beerfit1 <- meanf(beer2,h=10) beerfit2 <- rwf(beer2,h=10) beerfit3 <- snaive(beer2,h=10) autoplot(window(ausbeer, start=1992)) + autolayer(beerfit1, series="Mean", PI=FALSE) + autolayer(beerfit2, series="Naïve", PI=FALSE) + autolayer(beerfit3, series="Seasonal naïve", PI=FALSE) + xlab("Year") + ylab("Megalitres") + ggtitle("Forecasts for quarterly beer production") + guides(colour=guide_legend(title="Forecast"))
接着我们来看看它的准确性，显然，季节性随机游走预测比较好：beer3 <- window(ausbeer, start=2008) accuracy(beerfit1, beer3) # ME RMSE MAE MPE MAPE #Training set 0.000 43.62858 35.23438 -0.9365102 7.886776 #Test set -13.775 38.44724 34.82500 -3.9698659 8.283390 # MASE ACF1 Theil's U #Training set 2.463942 -0.10915105 NA #Test set 2.435315 -0.06905715 0.801254 accuracy(beerfit2, beer3) # ME RMSE MAE MPE MAPE #Training set 0.4761905 65.31511 54.73016 -0.9162496 12.16415 #Test set -51.4000000 62.69290 57.40000 -12.9549160 14.18442 # MASE ACF1 Theil's U #Training set 3.827284 -0.24098292 NA #Test set 4.013986 -0.06905715 1.254009 accuracy(beerfit3, beer3) # ME RMSE MAE MPE MAPE MASE #Training set -2.133333 16.78193 14.3 -0.5537713 3.313685 1.0000000 #Test set 5.200000 14.31084 13.4 1.1475536 3.168503 0.9370629 # ACF1 Theil's U #Training set -0.2876333 NA #Test set 0.1318407 0.298728训练/测试集的一个更复杂的版本是时间序列交叉验证。在此过程中，有一系列测试集，每个测试集包含一个观察值。由于结果随时间而变化，因此相应的训练集仅包含在形成测试集的观察之前发生的观察。因此将来的观察结果都不能用于构建预测。由于不可能基于小的训练集获得可靠的预测，因此最早的观察结果不被视为测试集。 预测准确性是通过对测试集进行平均计算得出的。此过程有时称为“滚动预测原点评估”，因为预测所基于的“原点”会及时向前滚动。 时间序列交叉验证是通过
tsCV()函数实现的。在以下示例中，我们将通过时间序列交叉验证获得的RMSE与剩余的RMSE进行比较。e <- tsCV(goog200, rwf, drift=TRUE, h=1) sqrt(mean(e^2, na.rm=TRUE)) #> [1] 6.233 sqrt(mean(residuals(rwf(goog200, drift=TRUE))^2, na.rm=TRUE)) #> [1] 6.169不出所料，来自残差的RMSE较小，因为相应的“预测”基于适合整个数据集的模型，而不是真实的预测。 选择最佳预测模型的一个好方法是找到使用时间序列交叉验证计算出的最小RMSE的模型。 对谷歌股价进行朴素预测，并用
tsCV()进行时间序列交叉验证：e <- tsCV(goog200, forecastfunction=naive, h=8) # Compute the MSE values and remove missing values mse <- colMeans(e^2, na.rm = T) # Plot the MSE values against the forecast horizon data.frame(h = 1:8, MSE = mse) %>% ggplot(aes(x = h, y = MSE)) + geom_point()
时间序列交叉验证表明，预测误差随着预测范围的增加而增加。 如果我们在预测参数中加入bootstrap=TRUE，就可以看到预测结果在不同的置信区间内的情况。fpp2 package
forecast()函数是主要的预测手段，其主要输入时间序列模型。其还有自动绘图功能autoplot()Judgmental prediction
判断性预测即指在没有历史数据的情况下进行预测，通常比较主观。
Delphi method
德尔菲认为群体的预测要比个体准确，因此他设计了一套流程：
- 组成了一个专家小组。
- 设置了预测任务/挑战并将其分发给专家。
- 专家会返回初步的预测和理由。汇总并汇总了这些内容以提供反馈。
- 向专家提供了反馈，专家们现在根据反馈检查了他们的预测。可以重复执行此步骤，直到达到令人满意的共识水平。
- 最终预测是通过汇总专家的预测来构建的。 值得注意的是专家应当是匿名，且平等的。
Analogous prediction
找一些别的相似的例子，或是进行结构化类比：
- 聚集了可能具有类似情况经验的专家小组。
- 设置任务/挑战并将其分发给专家。
- 专家会识别并描述尽可能多的类比，并根据每个类比生成预测。
- 专家列出每个类比与目标情况的相似性和差异，然后在一个量表上评估每个类比与目标情况的相似性。
- 预测是由主持人使用设定规则得出的。这可以是加权平均值，其中权重可以由专家对每个类比的排名分数进行指导。
Time series regression model
其基本概念是我们要预测的感兴趣的时间序列假设它与其他变量的时间序列具有线性关系。
事前预测是仅使用预先提供的信息进行的预测。例如，对样本结束后每个季度美国消费百分比变化的事前预测，只能使用2016年第三季度之前（含）的可用信息。这些是真实的预测，使用当时可用的信息预先进行。因此，为了生成事前预测，模型需要预测变量的预测。为了获得这些，我们可以使用在节中介绍的简单的方法。可替代地，来自其他来源（例如政府机构）的预测可能可用并且可以使用。 事后预测是使用以后的预测因素信息进行的预测。例如，对消费量的事后预测可以使用对预测变量的实际观察，一旦观测到。这些不是真正的预测，但对于研究预测模型的行为很有用。 不应使用预测期间的数据来估计生成事后预测的模型。也就是说，事后预测可以假设您了解预测变量。
Simple linear regression
如研究美国消费支出： 我们认为和收入有关：
autoplot(uschange[,c("Consumption","Income")]) +
ylab("% change") + xlab("Year")
显然消费和支出有线性关系： 绘图：
uschange %>%
as.data.frame() %>%
ggplot(aes(x=Income, y=Consumption)) +
ylab("Consumption (quarterly % change)") +
xlab("Income (quarterly % change)") +
geom_point() +
geom_smooth(method="lm", se=FALSE)
#> `geom_smooth()` using formula 'y ~ x'
计算回归系数：
tslm(Consumption ~ Income, data=uschange)
#>
#> Call:
#> tslm(formula = Consumption ~ Income, data = uschange)
#>
#> Coefficients:
#> (Intercept) Income
#> 0.545 0.281
当有两个以上的预测变量时，回归模型称为多元回归模型。如我们预测美国的消费支出和工业生产、个人储蓄、收入与失业率的关系：
uschange %>%
as.data.frame() %>%
GGally::ggpairs()
least squares estimation
最小二乘原理提供了一种通过最小化平方误差之和来有效选择回归系数的方法。该tslm()函数将线性回归模型拟合到时间序列数据。它类似于lm()广泛用于线性模型的功能。 如还是上面的我美国的消费支出和工业生产、个人储蓄、收入与失业率的关系，通过tslm我们可以得到多元回归的系数：
fit.consMR <- tslm(
Consumption ~ Income + Production + Unemployment + Savings,
data=uschange)
summary(fit.consMR)
#>
#> Call:
#> tslm(formula = Consumption ~ Income + Production + Unemployment +
#> Savings, data = uschange)
#>
#> Residuals:
#> Min 1Q Median 3Q Max
#> -0.8830 -0.1764 -0.0368 0.1525 1.2055
#>
#> Coefficients:
#> Estimate Std. Error t value Pr(>|t|)
#> (Intercept) 0.26729 0.03721 7.18 1.7e-11 ***
#> Income 0.71448 0.04219 16.93 < 2e-16 ***
#> Production 0.04589 0.02588 1.77 0.078 .
#> Unemployment -0.20477 0.10550 -1.94 0.054 .
#> Savings -0.04527 0.00278 -16.29 < 2e-16 ***
#> ---
#> Signif. codes:
#> 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
#>
#> Residual standard error: 0.329 on 182 degrees of freedom
#> Multiple R-squared: 0.754, Adjusted R-squared: 0.749
#> F-statistic: 139 on 4 and 182 DF, p-value: <2e-16
根据多元回归的模型绘图并比较：
autoplot(uschange[,'Consumption'], series="Data") +
autolayer(fitted(fit.consMR), series="Fitted") +
xlab("Year") + ylab("") +
ggtitle("Percent change in US consumption expenditure") +
guides(colour=guide_legend(title=" "))
cbind(Data = uschange[,"Consumption"],
Fitted = fitted(fit.consMR)) %>%
as.data.frame() %>%
ggplot(aes(x=Data, y=Fitted)) +
geom_point() +
ylab("Fitted (predicted values)") +
xlab("Data (actual values)") +
ggtitle("Percent change in US consumption expenditure") +
geom_abline(intercept=0, slope=1)
接下来我们可以评估该结果：
checkresiduals(fit.consMR)
# Breusch-Godfrey test for serial correlation of order up to
# 8
#
#data: Residuals from Linear regression model
#LM test = 14.874, df = 8, p-value = 0.06163
我们希望残差被随机分散而不显示任何系统模式。一种简单快速的检查方法是针对每个预测变量检查残差的散点图。如果这些散点图显示了一种模式，则该关系可能是非线性的，因此需要相应地修改模型:
df <- as.data.frame(uschange)
df[,"Residuals"] <- as.numeric(residuals(fit.consMR))
p1 <- ggplot(df, aes(x=Income, y=Residuals)) +
geom_point()
p2 <- ggplot(df, aes(x=Production, y=Residuals)) +
geom_point()
p3 <- ggplot(df, aes(x=Savings, y=Residuals)) +
geom_point()
p4 <- ggplot(df, aes(x=Unemployment, y=Residuals)) +
geom_point()
gridExtra::grid.arrange(p1, p2, p3, p4, nrow=2)
许多时候我们的变量也许并不是连续的数值，而是诸如是/否或者是季节，我们可以设置一个虚拟变量，该变量包含两个数：0和1…对于季节：春夏秋冬，我们应该设置3个虚拟变量，春（0和1），夏（0和1），秋（0和1），当春夏秋都为0时自然就是冬天… 我们也可以设置一些干预变量，干预变量时仅仅在某些特定时期起很大作用的变量，一般而言，在干预时为1，在其他时期为0。而对于交易日来说也可以用这种方法，或者使用bizdays()函数过滤月度或季度的交易日数据。
Select appropriate predictor variables
提供了CV函数包可以计算各种变量是否准确：
CV(fit.consMR)
#> CV AIC AICc BIC AdjR2
#> 0.1163 -409.2980 -408.8314 -389.9114 0.7486
在可能的情况下，应拟合所有潜在的回归模型（如上述示例中所述），并应根据所讨论的一种方法选择最佳模型。这称为“最佳子集”回归或“所有可能的子集”回归。 如果存在大量预测变量，则不可能拟合所有可能的模型。这时可以采取逐步回归的手法，特别是向后逐步回归，这可以一直迭代到回归效果没有进一步改善位置。
Nonlinear regression / piecewise linear regression
tips：不建议在预测中使用二次或更高阶趋势。对其进行推断时，得出的预测通常是不现实的。如研究波士顿马拉松比赛获胜时间：
h <- 10
fit.lin <- tslm(marathon ~ trend)
fcasts.lin <- forecast(fit.lin, h = h)
fit.exp <- tslm(marathon ~ trend, lambda = 0)
fcasts.exp <- forecast(fit.exp, h = h)
t <- time(marathon)
t.break1 <- 1940
t.break2 <- 1980
tb1 <- ts(pmax(0, t - t.break1), start = 1897)
tb2 <- ts(pmax(0, t - t.break2), start = 1897)
fit.pw <- tslm(marathon ~ t + tb1 + tb2)
t.new <- t[length(t)] + seq(h)
tb1.new <- tb1[length(tb1)] + seq(h)
tb2.new <- tb2[length(tb2)] + seq(h)
newdata <- cbind(t=t.new, tb1=tb1.new, tb2=tb2.new) %>%
as.data.frame()
fcasts.pw <- forecast(fit.pw, newdata = newdata)
fit.spline <- tslm(marathon ~ t + I(t^2) + I(t^3) +
I(tb1^3) + I(tb2^3))
fcasts.spl <- forecast(fit.spline, newdata = newdata)
autoplot(marathon) +
autolayer(fitted(fit.lin), series = "Linear") +
autolayer(fitted(fit.exp), series = "Exponential") +
autolayer(fitted(fit.pw), series = "Piecewise") +
autolayer(fitted(fit.spline), series = "Cubic Spline") +
autolayer(fcasts.pw, series="Piecewise") +
autolayer(fcasts.lin, series="Linear", PI=FALSE) +
autolayer(fcasts.exp, series="Exponential", PI=FALSE) +
autolayer(fcasts.spl, series="Cubic Spline", PI=FALSE) +
xlab("Year") + ylab("Winning times in minutes") +
ggtitle("Boston Marathon") +
guides(colour = guide_legend(title = " "))
上面的图显示了拟合线和来自线性，指数，分段线性和三次样条曲线趋势的预测。最好的预测似乎来自分段线性趋势，而三次样条曲线最适合历史数据，但预测较差。 三次样条曲线的另一种表示形式（称为自然三次平滑样条曲线）具有一些约束，因此样条曲线函数的末尾是线性的，通常可以在不影响拟合的情况下提供更好的预测。 我们使用该splinef()函数来生成三次样条曲线预测。与我们在上图中使用的结相比，它使用了更多的结，但为防止过度拟合，系数受到限制，并且曲线的两端均为线性。这具有附加的优点，即结点选择不是主观的。我们还使用了对数转换（lambda=0）来处理异方差性。
marathon %>%
splinef(lambda=0) %>%
autoplot()
Decomposition of time series
时间序列数据可以表现出各种模式，将时间序列划分为几个组成部分通常很有帮助，每个组成部分代表一个基础的模式类别。 我们已经讨论了三种时间序列模式：趋势，季节性和周期。当我们将时间序列分解为各个组成部分时，通常将趋势和周期组合为单个趋势周期性的组成。因此，我们认为时间序列包括三个部分：趋势周期部分，季节性部分和余下部分。组成如下： \(y_{t}=S_{t}+T_{t}+R_{t}\) $S_{t}$为季节性因素，$T_{t}$为趋势周期，$R_{t}$为剩余部分。
Moving average method
移动平均值是一个最老也是最流行的技术分析工具。若依次得到一组测定值时，按顺序取一定数量的数据并算得其全部算术平均值，得到的数据就叫做移动平均值。移动平均的本质是一种低通滤波。它的目的是过滤掉时间序列中的高频扰动，保留有用的低频趋势。 \(\hat{T}_{t}=\frac{1}{m}\sum_{j=-k}^{k}y_{t+j}\) 式中$m=2k+1$。也就是说，t是通过k个周期内的时间序列的平均值来获得的。在时间上接近的观测值也可能在值上接近。因此，平均值消除了数据中的一些随机性，留下平滑的趋势周期成分。我们称之为m-MA，意思是m阶的移动平均值。 以下是南澳大利亚的用电销售状况
autoplot(elecsales) + xlab("Year") + ylab("GWh") +
ggtitle("Annual electricity sales: South Australia")
进行5阶平均：
ma(elecsales, 5)
绘制趋势周期图
autoplot(elecsales, series="Data") +
autolayer(ma(elecsales,5), series="5-MA") +
xlab("Year") + ylab("GWh") +
ggtitle("Annual electricity sales: South Australia") +
scale_colour_manual(values=c("Data"="grey50","5-MA"="red"),
breaks=c("Data","5-MA"))
我们设置可以将移动平均的数据进行移动平均以获得更好的数据。 但这也有缺点：前几个和最后几个观察都无法获得趋势周期的估计值。
X11 decomposition method
此方法基于经典分解，但是包括许多额外的步骤和功能，以克服上一部分中讨论的经典分解的缺点。特别是，趋势周期估计值可用于所有观测值（包括终点），并且季节性分量可以随时间缓慢变化。X11还具有一些复杂的方法来处理交易日变化，假日影响和已知预测因素的影响。它处理加法分解和乘法分解。该过程是完全自动的，并且对时间序列中的异常值和水平移位趋向于高度鲁棒。 R语言seasonal包中可以使用X11方法对电气设备订单数据进行分解：
library(seasonal)
elecequip %>% seas(x11="") -> fit
autoplot(fit) +
ggtitle("X11 decomposition of electrical equipment index")
给定seas()函数的输出，seasonal()将提取季节性成分，trendcycle()将提取趋势周期成分，remainder()将提取余数成分，并seasadj()计算经季节性调整的时间序列。 下图显示了趋势周期分量和经季节性调整的数据以及原始数据：
autoplot(elecequip, series="Data") +
autolayer(trendcycle(fit), series="Trend") +
autolayer(seasadj(fit), series="Seasonally Adjusted") +
xlab("Year") + ylab("New orders index") +
ggtitle("Electrical equipment manufacturing (Euro area)") +
scale_colour_manual(values=c("gray","blue","red"),
breaks=c("Data","Seasonally Adjusted","Trend"))
使用季节性部分的季节性图和季节性子系列图可能很有用。这些有助于我们直观地看到季节性成分随时间的变化。下图显示了上图中季节部分的季节子序列图。在这种情况下，随着时间的推移只有很小的变化。
fit %>% seasonal() %>% ggsubseriesplot() + ylab("Seasonal")
SEATS decomposition
“SEATS”代表“ARIMA时间序列中的季节提取”。此程序是在西班牙银行开发的，现在已被世界各地的政府机构广泛使用。该过程仅适用于季度和月度数据。因此，其他类型的季节性，例如每日数据，每小时数据或每周数据，则需要另一种方法。下面还是对电气设备订单数据进行分解：
library(seasonal)
elecequip %>% seas() %>%
autoplot() +
ggtitle("SEATS decomposition of electrical equipment index")
与X11的方法类似，我们可以使用seasonal()，trendcycle()和remainder()函数提取的各个组件，并通过seasadj()计算季节性调整的时间序列。
STL decomposition
STL：使用局部加权回归进行季节与趋势分解。 还是对电气设备订单数据进行分解：
elecequip %>%
stl(t.window=13, s.window="periodic", robust=TRUE) %>%
autoplot()
使用STL时要选择的两个主要参数是趋势周期窗口（t.window）和季节窗口（s.window）。这些控制着趋势周期和季节成分变化的速度。较小的值允许更快速的更改。t.window与s.window应该是奇数; t.window是在估计趋势周期时要使用的连续观察数；s.window是用于估计季节部分中每个值的连续年份。用户必须指定，s.window因为没有默认值。将其设置为无限等效于强制将季节性成分设置为周期性（即跨年相同）。指定t.window是可选的，如果省略，将使用默认值。
mstl()功能使用提供了便利的自动STL分解s.window=13，并且t.window也可以自动选择。通常，这可以在过度适应季节性和使其随时间缓慢变化之间取得良好的平衡。但是，与任何自动过程一样，默认设置需要针对某些时间序列进行调整。
与本书中讨论的其他分解方法一样，要获得单独成分的分析，请使用seasonal()季节性成分trendcycle()函数，趋势周期成分remainder()函数和其余成分函数。该seasadj()函数可用于计算季节性调整后的序列。
Exponential smoothing
指数平滑法实际上是一种特殊的加权移动平均法。使用指数平滑方法生成的预测是过去观测值的加权平均值，并且随着观测值变老，权重呈指数衰减。换句话说，观察越近，相关的权重就越高。该框架可在广泛的时间范围内快速生成可靠的预测，这是一个巨大的优势，对工业应用至关重要。
Simple exponential smoothing
自然地，最简单的指数平滑方法称为简单指数平滑（SES）。此方法适用于没有明确趋势或季节性模式的预测数据。 我们探索一下阿拉伯石油数据：
oildata <- window(oil, start=1996)
autoplot(oildata) +
ylab("Oil (millions of tonnes)") + xlab("Year")
进行简单指数平滑：
oildata <- window(oil, start=1996)
# Estimate parameters
fc <- ses(oildata, h=5)
# Accuracy of one-step-ahead training errors
round(accuracy(fc),2)
#> ME RMSE MAE MPE MAPE MASE ACF1
#> Training set 6.4 28.12 22.26 1.1 4.61 0.93 -0.03
autoplot(fc) +
autolayer(fitted(fc), series="Fitted") +
ylab("Oil (millions of tonnes)") + xlab("Year")
Trending method
Holt线性趋势法，不再像以前一样预测出一条平行的直线，而是一条带有斜率的东西了。但Holt线性方法生成的预测在未来无限期地显示出恒定的趋势（增加或减少）。经验证据表明，这些方法倾向于过度预测，特别是对于较长的预测范围。受此观察的启发，Gardner＆McKenzie（1985）引入了一个参数，该参数在将来的某个时候将趋势“抑制”到一条平坦的线上。包含衰减趋势的方法被证明是非常成功的，并且可以说是当许多序列需要自动进行预测时最受欢迎的单个方法。 比如我们对澳大利亚航司载客量进行研究：
air <- window(ausair, start=1990)
fc <- holt(air, h=15)
fc2 <- holt(air, damped=TRUE, phi = 0.9, h=15)
autoplot(air) +
autolayer(fc, series="Holt's method", PI=FALSE) +
autolayer(fc2, series="Damped Holt's method", PI=FALSE) +
ggtitle("Forecasts from Holt's method") + xlab("Year") +
ylab("Air passengers in Australia (millions)") +
guides(colour=guide_legend(title="Forecast"))
Seasonal method based on Holt-Winters
Holt-Winters季节性方法考虑了季节变化的影响。 如考察澳大利亚国际游客待的夜数：
aust <- window(austourists,start=2005)
fit1 <- hw(aust,seasonal="additive")
fit2 <- hw(aust,seasonal="multiplicative")
autoplot(aust) +
autolayer(fit1, series="HW additive forecasts", PI=FALSE) +
autolayer(fit2, series="HW multiplicative forecasts",
PI=FALSE) +
xlab("Year") +
ylab("Visitor nights (millions)") +
ggtitle("International visitors nights in Australia") +
guides(colour=guide_legend(title="Forecast"))
这也有一种阻尼法，可以具有衰减的趋势：
hw(y, damped=TRUE, seasonal="multiplicative")
如研究Hyndsight博客自2014年4月30日起一年的每日综合浏览量：
fc <- hw(subset(hyndsight,end=length(hyndsight)-35),
damped = TRUE, seasonal="multiplicative", h=35)
autoplot(hyndsight) +
autolayer(fc, series="HW multi damped", PI=FALSE)+
guides(colour=guide_legend(title="Daily forecasts"))
Model selection and estimation
est函数可以进行模型的估计与选择：
ets(y, model="ZZZ", damped=NULL, alpha=NULL, beta=NULL,
gamma=NULL, phi=NULL, lambda=NULL, biasadj=FALSE,
additive.only=FALSE, restrict=TRUE,
allow.multiplicative.trend=FALSE)
其中: y 要预测的时间序列。 model 如果为damped=TRUE，则将使用阻尼趋势（A或M）。如果为damped=FALSE，则将使用非阻尼趋势。如果damped=NULL（默认），则将选择阻尼趋势还是非阻尼趋势，具体取决于哪个模型的信息标准值最小。 alpha, beta, gamma, phi 可以使用这些参数指定平滑参数的值。如果将它们设置为NULL（每个参数的默认设置），则会估计参数。 lambda Box-Cox转换参数。如果lambda=NULL（默认值），它将被忽略。否则，将在估计模型之前对时间序列进行转换。如果lambda不是NULL，additive.only设置为TRUE。 biasadj 如果TRUE和lambda不是NULL，则将对反向转换后的拟合值和预测进行偏差调整。 additive.only 如果仅考虑具有加性成分的模型additive.only=TRUE。否则，将考虑所有模型。 restrict 如果为restrict=TRUE（默认值），则在模型选择中不考虑引起数值困难的模型。 allow.multiplicative.trend 也可以使用乘法趋势模型，但本次不做介绍。将此参数设置TRUE为允许考虑这些模型。 那么，如何处理ets对象呢？ 该ets()函数将返回class的对象ets。有许多R函数旨在简化ets对象的处理。其中一些描述如下。 coef()返回所有拟合的参数。 accuracy()返回根据训练数据计算出的准确性测度。 summary()打印有关拟合模型的一些摘要信息。 autoplot() 和 plot()生成组件的时间图。 residuals()从估计的模型返回残差。 fitted()返回训练数据的一步预测。 simulate()将从拟合模型中模拟将来的样本路径。 forecast()计算点预测和预测区间，如下一节所述。 使用该ets()功能，默认的估计方法是最大似然而不是最小平方和。 我们可以基于此，结合上面的数据，再来使用ETS统计框架来预测2016-2019年期间国际入境游客在澳大利亚的游客住宿天数。
aust <- window(austourists, start=2005)
fit <- ets(aust)
summary(fit)
#> ETS(M,A,M)
#>
#> Call:
#> ets(y = aust)
#>
#> Smoothing parameters:
#> alpha = 0.1908
#> beta = 0.0392
#> gamma = 2e-04
#>
#> Initial states:
#> l = 32.3679
#> b = 0.9281
#> s = 1.022 0.9628 0.7683 1.247
#>
#> sigma: 0.0383
#>
#> AIC AICc BIC
#> 224.9 230.2 240.9
#>
#> Training set error measures:
#> ME RMSE MAE MPE MAPE MASE
#> Training set 0.04837 1.671 1.25 -0.1846 2.693 0.4095
#> ACF1
#> Training set 0.2006
绘图：
autoplot(fit)
获得残差：
cbind('Residuals' = residuals(fit),
'Forecast errors' = residuals(fit,type='response')) %>%
autoplot(facet=TRUE) + xlab("Year") + ylab("")
ETS点预测等于预测分布的中位数。对于仅具有加性成分的模型，预测分布为正态，因此中位数和均值相等。对于具有乘法误差或季节性乘积的ETS模型，点预测将不等于预测分布的均值。 为了从ETS模型获得预测，我们使用该forecast()函数。
fit %>% forecast(h=8) %>%
autoplot() +
ylab("International visitor night in Australia (millions)")
使用forecast函数进行预测的通式：
forecast(object, h=ifelse(object$m>1, 2*object$m, 10),
level=c(80,95), fan=FALSE, simulate=FALSE, bootstrap=FALSE,
npaths=5000, PI=TRUE, lambda=object$lambda, biasadj=NULL, ...)
object函数返回的对象ets()。 h预测范围-要预测的期间数。 level预测区间的置信度。 fan如果fan=TRUE，level=seq(50,99,by=1)。这适用于风扇图。 simulate如果为simulate=TRUE，则预测区间是通过模拟而不是使用代数公式生成.simulate=FALSE在没有适用于特定模型的代数公式的情况下，也将使用仿真（即使是）。 bootstrap如果bootstrap=TRUE和simulate=TRUE，则模拟的预测区间使用重新采样的误差而不是正态分布的误差。 npaths计算模拟的预测区间时使用的样本路径数。 PI如果为PI=TRUE，则产生预测区间；否则仅计算点预测。 lambdaBox-Cox转换参数。如果忽略此选项lambda=NULL。否则，将通过逆Box-Cox逆变换对预测进行反变换。 biasadj如果lambda不是NULL，则对逆变换的预测（和预测区间）进行偏差调整。
Arima model
时间序列是指将同一统计指标的数值按其先后发生的时间顺序排列而成的数列。时间序列分析的主要目的是根据已有的历史数据对未来进行预测。常用的时间序列模型有四种：自回归模型 AR(p)、移动平均模型 MA(q)、自回归移动平均模型 ARMA(p,q)、自回归差分移动平均模型 ARIMA(p,d,q), 可以说前三种都是 ARIMA(p,d,q)模型的特殊形式，其中p为自相关系数，q为平均移动系数， ARIMA 模型是在平稳的时间序列基础上建立起来的，因此时间序列的平稳性是建模的重要前提。检验时间序列模型平稳的方法一般采用 ADF 单位根检验模型去检验。当然如果时间序列不稳定，也可以通过一些操作去使得时间序列稳定（比如取对数，差分），然后进行 ARIMA 模型预测，得到稳定的时间序列的预测结果，然后对预测结果进行之前使序列稳定的操作的逆操作（取指数，差分的逆操作），就可以得到原始数据的预测结果。 一般而言会运用到差分法，即时间序列在t与t-1时刻的差值。差分（d）：现在数列=现时刻数值-前一时刻数值，也就是本时刻与前一时刻的差值作为新的数列，可以让数列更加平稳，数据.diff(1)代表数据与前一时刻的差值
Autoregressive model (AR)
P阶自回归： \(y_{t}=\mu +\sum_{i=1}^{P }\gamma _{i}y_{t-i}+\epsilon_{t}\) 其中$y_{t}$是当前值，$\mu$是常数项，$P$是阶数，$\gamma _{i}$是自相关系数。 自回归简单来说就是当前值只与历史值有关。p阶自回归就是当前值与前p个值有关，求常数与自回归系数。 在多元回归模型中，我们使用预测变量的线性组合来预测目标变量。在自回归模型中，我们使用变量的过去值的线性组合来预测目标变量。术语自动回归表示它是变量相对于自身的回归。 自回归模型的限制：
- 自回归模型是用自身的数据来进行预测 必须具有平稳性
- 必须具有自相关性，如果自相关系数(φi)小于0.5，则不宜采用
- 自回归只适用于预测与自身前期相关的现象
Moving average model (MA)
q阶移动平均： \(y_{t}=\mu +\epsilon_{t}+\sum_{i=1}^{q }\theta_{i}\epsilon_{t-i}\) 其中q为移动平均项数，q阶与前q个误差有关。 移动平均模型关注的是自回归模型中的误差项的累加，移动平均法能有效地消除预测中的随机波动。移动平均模型不是在回归中使用预测变量的过去值，而是在类似回归的模型中使用过去的预测误差。移动平均模型不应与我们在之前中讨论过的移动平均平滑处理混淆。我们一般使用移动平均模型来预测未来值，而使用移动平均平滑来估计过去值的趋势周期。
(Non seasonal) ARIMA model
ARIMA模型称为差分自回归移动平均模型。 其中AR就是自回归，p为自回归项，MA就是移动平均，q为移动平均项数，d为时间序列成为平稳时所做的差分次数。 公式为： \(y_{t}=\mu +\sum_{i=1}^{P }\gamma _{i}y_{t-i}+\epsilon_{t}+\sum_{i=1}^{q }\theta_{i}\epsilon_{t-i}\) 其原理是将非平稳时间序列转化为平稳时间序列；然后将因变量仅对它的滞后值以及随机误差项的现值和滞后值进行回归所建立的模型。 将差分与自回归和移动平均模型相结合，则将获得非季节性的ARIMA模型。ARIMA是AutoRegressive集成移动平均线的首字母缩写（在这种情况下，“积分”是差分的反面）。称$\textup{ARIMA}(p,d,q)$模型。$p$为自回归的顺序，$d$为所涉及的第一次差异程度，$q$为移动平均线部分的顺序。 白噪声为ARIMA(0,0,0)，随机漫步为ARIMA(0,1,0)且没有常数，带漂移项的随机游走为ARIMA（0,1,0）且具有常数，自回归 为ARIMA(p,0,0)，移动平均为ARIMA(0,0,q) 我们研究一下美国消费支出的季度百分比：
autoplot(uschange[,"Consumption"]) +
xlab("Year") + ylab("Quarterly percentage change")
以下R代码用于自动选择模型:
fit <- auto.arima(uschange[,"Consumption"], seasonal=FALSE)
#Series: uschange[, "Consumption"]
#ARIMA(1,0,3) with non-zero mean
#
#Coefficients:
# ar1 ma1 ma2 ma3 mean
# 0.5885 -0.3528 0.0846 0.1739 0.7454
#s.e. 0.1541 0.1658 0.0818 0.0843 0.0930
#
#sigma^2 estimated as 0.3499: log likelihood=-164.81
#AIC=341.61 AICc=342.08 BIC=361
这是ARIMA（1,0,3）模型： \(y_t = c + 0.589y_{t-1} -0.353 \varepsilon_{t-1} + 0.0846 \varepsilon_{t-2} + 0.174 \varepsilon_{t-3} + \varepsilon_{t}\) 这里$c= 0.745 \times (1 - 0.589) = 0.307$，通式$\varepsilon_t$是白噪声，标准差为$0.592 = \sqrt{0.350}$， 进行预测：
fit %>% forecast(h=10) %>% autoplot(include=80)
该auto.arima()功能很有用，但是任何自动化操作都可能会有些危险，即使您依靠自动过程为您选择模型，也值得了解模型的某些行为。
常数C对从这些模型获得的长期预测具有重要影响。 如果C=0且d=0，则长期预测将为零。 如果C=0和d=1，则长期预测将变为非零常数。 如果C=0和d=2，则长期预测将遵循一条直线。 如果C≠0且d=0，则长期预测将取数据的平均值。 如果C≠0且d=1，则长期预测将遵循一条直线。 如果C≠0且d=2，则长期预测将遵循二次趋势。 d对预测区间也有影响：d值越高，预测区间的大小增长越快。对于d=0，则长期预测标准差将变为历史数据的标准差，因此预测区间将基本相同。
通常仅凭时间图就不可能知道p和q是否适用于数据。但是，有时可以使用ACF图和密切相关的PACF图来确定p和q。 如对美国消费图进行测试：
ggAcf(uschange[,"Consumption"])
ggPacf(uschange[,"Consumption"])
如果数据来自$\textup{ARIMA}(p, d, 0)$或$\textup{ARIMA}(0, d, q)$模型，则ACF和PACF图可以帮助确定p或q： 如果p和q都是正的，那么这些图就无助于找到合适的p和q。 如果差异数据的ACF和PACF图显示以下模式，数据可能遵循$\textup{ARIMA}(p, d, 0)$建模：ACF呈指数衰减或正弦曲线；滞后有明显的峰值p在PACF中，但没有滞后p。 如果差异数据的ACF和PACF图显示以下模式，那么数据可以遵循$\textup{ARIMA}(0, d, q)$模型：PACF呈指数衰减或正弦曲线；滞后在ACF中有明显的峰值q，但没有滞后q。
或者说： 如果ACF的衰减趋于0（几何型或震荡型）且PACFp阶后截尾，则使用AR(p) 如果ACFq阶后截尾且PACF的衰减趋于0（几何型或震荡型），则使用MA(q) 如果ACF的衰减趋于0（几何型或震荡型）且PACF的衰减趋于0（几何型或震荡型），则使用ARMA(p,q)
根据上图的ACF，我们看到ACF中出现三个尖峰，随后在滞后4处出现了一个明显的尖峰。在PACF中，出现了三个显着尖峰，然后此后没有任何明显的尖峰（除了位于边界范围外的一个尖峰）。如果每个曲线都在极限范围内，而不是在最初的几个滞后中，我们可以忽略每个曲线中的一个明显的峰值。毕竟，突然出现尖峰的概率约为二十分之一，我们在每个图中绘制了22个尖峰。前三个峰值中的模式是ARIMA（3,0,0）所期望的，因为PACF趋于减少。因此，在这种情况下，ACF和PACF导致我们认为ARIMA（3,0,0）模型可能是合适的。
(fit2 <- Arima(uschange[,"Consumption"], order=c(3,0,0)))
#> Series: uschange[, "Consumption"]
#> ARIMA(3,0,0) with non-zero mean
#>
#> Coefficients:
#> ar1 ar2 ar3 mean
#> 0.227 0.160 0.203 0.745
#> s.e. 0.071 0.072 0.071 0.103
#>
#> sigma^2 estimated as 0.349: log likelihood=-165.2
#> AIC=340.3 AICc=340.7 BIC=356.5
该模型实际上比所标识的模型稍好auto.arima()（AICc值为340.67，而342.08）。该auto.arima()函数找不到此模型，因为它没有在搜索中考虑所有可能的模型。您可以使用参数stepwise=FALSE和来使其更有效率地工作approximation=FALSE：
(fit3 <- auto.arima(uschange[,"Consumption"], seasonal=FALSE,
stepwise=FALSE, approximation=FALSE))
#> Series: uschange[, "Consumption"]
#> ARIMA(3,0,0) with non-zero mean
#>
#> Coefficients:
#> ar1 ar2 ar3 mean
#> 0.227 0.160 0.203 0.745
#> s.e. 0.071 0.072 0.071 0.103
#>
#> sigma^2 estimated as 0.349: log likelihood=-165.2
#> AIC=340.3 AICc=340.7 BIC=356.5
我们还可以使用该参数seasonal=FALSE来防止它搜索季节性ARIMA模型。
Seasonal ARIMA model
需要在ARIMA(p,d,q)后加一个(P,D,Q)12来表示季节的循环，这个12表示在PACF的滞后12出现一个明显的峰值。后面的(P,D,Q)可以模拟ACF季节滞后的指数衰减。 如我们模拟欧洲季度零售贸易数据：
autoplot(euretail) + ylab("Retail index") + xlab("Year")
数据显然是不稳定的，具有一定的季节性，因此我们先考察季节性差异：
euretail %>% diff(lag=4) %>% ggtsdisplay()
euretail %>% diff(lag=4) %>% diff() %>% ggtsdisplay()
接下来根据ACF和PACF找到合适的ARIMA模型，ACF的滞后1处的显着尖峰表明非季节性MA(1)分量，ACF的滞后4处的显着尖峰表明存在季节性MA(1)分量。因此模型可以写为ARIMA(1,1,0)(1,1,0)4，加下来进行拟合：
euretail %>%
Arima(order=c(0,1,1), seasonal=c(0,1,1)) %>%
residuals() %>% ggtsdisplay()
ACF和PACF都在滞后2处显示出明显的峰值，而在滞后3处显示出明显的峰值，这表明模型中还需要包含一些其他非季节性项。ARIMA(0,1,2)(0,1,1)4的AICc是74.36，而ARIMA(0,1,3)(0,1,1)是68.53。我们还尝试了其他带有AR值的模型，但没有一个模型给出较小的AICc值。因此，我们选择ARIMA(0,1,3)(0,1,1)4 模型。其残差绘制在下中。现在所有的尖峰都在有效范围内，因此残差似乎是白噪声。Ljung-Box测试还显示残差没有剩余的自相关。
fit3 <- Arima(euretail, order=c(0,1,3), seasonal=c(0,1,1))
checkresiduals(fit3)
# Ljung-Box test
#
#data: Residuals from ARIMA(0,1,3)(0,1,1)[4]
#Q* = 0.51128, df = 4, p-value = 0.9724
#
#Model df: 4. Total lags used: 8 Ljung-Box test
#
#data: Residuals from ARIMA(0,1,3)(0,1,1)[4]
#Q* = 0.51128, df = 4, p-value = 0.9724
#
#Model df: 4. Total lags used: 8
因此，我们现在有了一个季节性的ARIMA模型，该模型可以通过所需的检查并可以进行预测:
fit3 %>% forecast(h=12) %>% autoplot()
也可以用auto.arima()一步到位。
Dynamic regression model
前两章中的时间序列模型允许包含来自系列的过去观察的信息，但不允许包含也可能相关的其他信息。例如，假期，竞争对手活动，法律变化，更广泛的经济状况或其他外部变量的影响可能解释了某些历史变化，并可能导致更准确的预测。另一方面，之前的回归模型允许包含来自预测变量的许多相关信息，但不允许有类似ARIMA模型可以处理的细微时间序列动态。在本章中，我们考虑如何扩展ARIMA模型，以便允许其他信息包含在模型中。 时间序列预测基本上就是自己预测自己，但经过改进后的ARIMA允许把额外的一个或多个变量纳入其中，然后作为额外的补充信息，进行回归: \(y_t = \beta_0 + \beta_1 x_t + \eta_t,\) 其中$\eta_t$为ARIMA模型
Dynamic regression in R
fit <- Arima(y, xreg=x, order=c(1,1,0))
其中xreg参数可以放入额外的解释变量。 如研究美国的个人消费与收入的关系：
autoplot(uschange[,1:2], facets=TRUE) +
xlab("Year") + ylab("") +
ggtitle("Quarterly changes in US consumption
and personal income")
把收入作为一个预测变量加入模型：
(fit <- auto.arima(uschange[,"Consumption"],
xreg=uschange[,"Income"]))
#Series: uschange[, "Consumption"]
#Regression with ARIMA(1,0,2) errors
#
#Coefficients:
# ar1 ma1 ma2 intercept xreg
# 0.6922 -0.5758 0.1984 0.5990 0.2028
#s.e. 0.1159 0.1301 0.0756 0.0884 0.0461
#
#sigma^2 estimated as 0.3219: log likelihood=-156.95
#AIC=325.91 AICc=326.37 BIC=345.29
模型可以写为： \(y_t = 0.599 + 0.203 x_t + \eta_t \\ \eta_t = 0.692 \eta_{t-1} + \varepsilon_t-0.576 \varepsilon_{t-1} + 0.198 \varepsilon_{t-2}\\ \varepsilon_t \sim \text{NID}(0,0.322)\) 可以分别查看$\eta_t$和$\varepsilon_t$的估计：
cbind("Regression Errors" = residuals(fit, type="regression"),
"ARIMA errors" = residuals(fit, type="innovation")) %>%
autoplot(facets=TRUE)
也可以查看整个ARIMA模型和白噪声：
checkresiduals(fit)
进行预测：
fcast <- forecast(fit, xreg=rep(mean(uschange[,2]),8))
autoplot(fcast) + xlab("Year") +
ylab("Percentage change")
Random and deterministic trends
有两种不同的线性趋势建模方法：随机的趋势/增长率或者确定的趋势。这种趋势可以通过xreg函数进行定义，如我们对国际游客到澳大利亚的人数进行研究：
autoplot(austa) + xlab("Year") +
ylab("millions of people") +
ggtitle("Total annual international visitors to Australia")
我们使用确定趋势的模型：
trend <- seq_along(austa)
(fit1 <- auto.arima(austa, d=0, xreg=trend))
#> Series: austa
#> Regression with ARIMA(2,0,0) errors
#>
#> Coefficients:
#> ar1 ar2 intercept xreg
#> 1.113 -0.380 0.416 0.171
#> s.e. 0.160 0.158 0.190 0.009
#>
#> sigma^2 estimated as 0.0298: log likelihood=13.6
#> AIC=-17.2 AICc=-15.2 BIC=-9.28
其估计的游客人数每年增长17万人。 模型可以写为： \(y_t = 0.416 + 0.171t + \eta_t \\ \eta_t = 1.113 \eta_{t-1} - 0.380 \eta_{t-2} + \varepsilon_t\\ \varepsilon_t \sim \text{NID}(0,0.030)\) 也可以选择随机趋势模型：
(fit2 <- auto.arima(austa, d=1))
#> Series: austa
#> ARIMA(0,1,1) with drift
#>
#> Coefficients:
#> ma1 drift
#> 0.301 0.173
#> s.e. 0.165 0.039
#>
#> sigma^2 estimated as 0.0338: log likelihood=10.62
#> AIC=-15.24 AICc=-14.46 BIC=-10.57
模型可以写为： \(y_t = y_0 + 0.173t + \eta_t \\ \eta_t = \eta_{t-1} + 0.301 \varepsilon_{t-1} + \varepsilon_t\\ \varepsilon_t \sim \text{NID}(0,0.034)\) 在这种情况下，游客人数的估计增长也是每年17万人。尽管增长估计相似，但预测区间却不一样，随机趋势的预测区间要宽得多，因为误差是非平稳的。
fc1 <- forecast(fit1,
xreg = length(austa) + 1:10)
fc2 <- forecast(fit2, h=10)
autoplot(austa) +
autolayer(fc2, series="Stochastic trend") +
autolayer(fc1, series="Deterministic trend") +
ggtitle("Forecasts from trend models") +
xlab("Year") + ylab("Visitors to Australia (millions)") +
guides(colour=guide_legend(title="Forecast"))
Dynamic harmonic regression
当季节较长时，使用傅立叶项进行动态回归通常比我们在本书中考虑的其他模型更好。例如，每日数据的年度季节性可以为365，每周数据的季节性周期约为52，而半小时数据可以具有多个季节周期，其中最短的是周期48的每日模式。 ARIMA和ETS模型的季节性版本设计用于较短的时间段，例如12个用于月度数据或4个用于季度数据。该ets()功能将季节性限制为最大24个周期，以允许每小时数据，但不允许具有较大季节性频率的数据。而Arima()和auto.arima()功能将允许季节性长达m=350，但实际上通常会在季节周期超过200左右时耗尽内存。 我们可以通过谐波回归方法，特别是使用傅立叶项对季节性模式进行建模，就可以用ARMA模型处理复杂的季节性数据了。我们可以使用参数k进行傅里叶变换。 如我们研究澳大利亚外出就餐的支出：
cafe04 <- window(auscafe, start=2004)
plots <- list()
for (i in seq(6)) {
fit <- auto.arima(cafe04, xreg = fourier(cafe04, K = i),
seasonal = FALSE, lambda = 0)
plots[[i]] <- autoplot(forecast(fit,
xreg=fourier(cafe04, K=i, h=24))) +
xlab(paste("K=",i," AICC=",round(fit[["aicc"]],2))) +
ylab("") + ylim(1.5,4.7)
}
gridExtra::grid.arrange(
plots[[1]],plots[[2]],plots[[3]],
plots[[4]],plots[[5]],plots[[6]], nrow=3)
Lagged predictor variable
有一些场景中变量具有滞后性，比如投放广告与实际销量增长之间的关系。以美国电视广告与保险报价之间的关系为例：
autoplot(insurance, facets=TRUE) +
xlab("Year") + ylab("") +
ggtitle("Insurance advertising and quotations")
我们将考虑包括最多四个月的广告支出；也就是说，该模型可能包括当月及其之前三个月的广告支出。比较模型时，重要的是它们都使用相同的训练集。在下面的代码中，我们将前三个月排除在外，以便进行公平比较。
# Lagged predictors. Test 0, 1, 2 or 3 lags.
Advert <- cbind(
AdLag0 = insurance[,"TV.advert"],
AdLag1 = stats::lag(insurance[,"TV.advert"],-1),
AdLag2 = stats::lag(insurance[,"TV.advert"],-2),
AdLag3 = stats::lag(insurance[,"TV.advert"],-3)) %>%
head(NROW(insurance))
# Restrict data so models use same fitting period
fit1 <- auto.arima(insurance[4:40,1], xreg=Advert[4:40,1],
stationary=TRUE)
fit2 <- auto.arima(insurance[4:40,1], xreg=Advert[4:40,1:2],
stationary=TRUE)
fit3 <- auto.arima(insurance[4:40,1], xreg=Advert[4:40,1:3],
stationary=TRUE)
fit4 <- auto.arima(insurance[4:40,1], xreg=Advert[4:40,1:4],
stationary=TRUE)
接下来，我们根据AICc选择广告的最佳滞后时间:
c(fit1[["aicc"]],fit2[["aicc"]],fit3[["aicc"]],fit4[["aicc"]])
#> [1] 68.500 60.024 62.833 65.457
那么最好的模型（具有最小的AICc值）具有两个滞后的预测因子。也就是说，它仅包括当月和上个月的广告所起的作用：
(fit <- auto.arima(insurance[,1], xreg=Advert[,1:2],
stationary=TRUE))
#> Series: insurance[, 1]
#> Regression with ARIMA(3,0,0) errors
#>
#> Coefficients:
#> ar1 ar2 ar3 intercept AdLag0 AdLag1
#> 1.412 -0.932 0.359 2.039 1.256 0.162
#> s.e. 0.170 0.255 0.159 0.993 0.067 0.059
#>
#> sigma^2 estimated as 0.217: log likelihood=-23.89
#> AIC=61.78 AICc=65.4 BIC=73.43
可见其为AR(3)型模型，可以写为： \(y_t = 2.039 + 1.256 x_t + 0.162 x_{t-1} + \eta_t\) 其中，$y_t$是保险报价，$x_t$是广告支出，其中又有： \(\eta_t = 1.412 \eta_{t-1} - 0.932 \eta_{t-2} + 0.359 \eta_{t-3} + \varepsilon_t\) 那么$\varepsilon_t$是白噪声。 假设未来每月广告支出为8，进行预测：
fc8 <- forecast(fit, h=20,
xreg=cbind(AdLag0 = rep(8,20),
AdLag1 = c(Advert[40,1], rep(8,19))))
autoplot(fc8) + ylab("Quotes") +
ggtitle("Forecast quotes with future advertising set to 8")
Prediction of hierarchical/group time series
时间序列通常可以根据感兴趣的各种属性进行自然分解。例如，自行车制造商销售的自行车总数可以按产品类型（例如公路自行车，山地自行车，儿童自行车和混合动力车）分类。这些中的每一个都可以细分为更细的类别。例如，混合动力自行车可以分为城市，通勤，舒适和徒步自行车。等等。这些类别嵌套在较大的组类别中，因此时间序列的集合遵循分层聚合结构。因此，我们将它们称为“分层时间序列”。
暂时还在研究
Advanced prediction methods
Complex season prediction
有些时候时间序列是很复杂的，比如一个每日的数据它可能有每日的规律，同时又有每周的规律，而设置它还有每季度的规律。之前的ts函数只能处理一种时间序列的变化，因此引入了msts函数来处理多个时间序列的变化，下面以33周内每个工作日上午7点到晚上9点05之间每5分钟收到的银行胡椒数据为例，也就是这个数据每天有169次记录：
#所有33周记录形成的规律
p1 <- autoplot(calls) +
ylab("Call volume") + xlab("Weeks")
#一个月内的规律
p2 <- autoplot(window(calls, end = 4)) +
ylab("Call volume") + xlab("Weeks")
gridExtra::grid.arrange(p1,p2)
探索趋势：
calls %>% mstl() %>%
autoplot() + xlab("Week")
进行预测：
calls %>% stlf() %>%
autoplot() + xlab("Week")
也可以结合ARMA和傅里叶变换来减少AICc值以增加预测精度：
fit <- auto.arima(calls, seasonal = FALSE, lambda = 0, xreg = fourier(calls, K = c(10,10)))
fit %>%
forecast(xreg = fourier(calls, K = c(10,10), h=2*169)) %>%
autoplot(include=5*169) +
ylab("Call volume") + xlab("Weeks")
Vector autoregression
有时候我们应当考虑变量之间的相互影响与双向反馈。因此基于自回归而发展出的向量自回归（VAR），这是一种计量经济学模型，VAR模型把系统中每一个内生变量作为系统中所有内生变量的滞后值的函数来构造模型，同一样本期间内的n个变量（内生变量）可以作为它们过去值的线性函数，从而将单变量自回归模型推广到由多元时间序列变量组成的“向量”自回归模型。该功能使用R中的vars包实现。 我们建立用于预测美国消费的VAR模型：
library(vars)
#用于选择滞后次数的各种标准，SC是BIC，HQ是Hunnan-Quinn准则，FPE是最终误差准则
VARselect(uschange[,1:2], lag.max=8,
type="const")[["selection"]]
# AIC(n) HQ(n) SC(n) FPE(n)
# 5 1 1 5
基于BIC选择var(1)试试：
var1 <- VAR(uschange[,1:2], p=1, type="const")
serial.test(var1, lags.pt=10, type="PT.asymptotic")
v
#Portmanteau Test (asymptotic)
#
#data: Residuals of VAR object var1
#Chi-squared = 49.102, df = 36, p-value = 0.07144
似乎有一定的残差相关性，那么试试var(2)：
var2 <- VAR(uschange[,1:2], p=2, type="const")
serial.test(var2, lags.pt=10, type="PT.asymptotic")
#还是有
试试var(3)：
var3 <- VAR(uschange[,1:2], p=3, type="const")
serial.test(var3, lags.pt=10, type="PT.asymptotic")
# Portmanteau Test (asymptotic)
#
#data: Residuals of VAR object var3
#Chi-squared = 33.617, df = 28, p-value = 0.2138
p>0.05了没有了，就可以生成预测图像了：
forecast(var3) %>%
autoplot() + xlab("Year")
Neural network model
用于预测响应变量与其预测变量之间存在复杂的非线性关系。利用时间序列数据，时间序列的滞后值可以用作神经网络的输入，就像我们在线性自回归模型中使用滞后值一样。我们称其为神经网络自回归或NNAR模型。NNAR(p,k)中p为滞后输入的值，k为隐藏层的神经元数量。 太阳的表面包含显示为黑点的磁性区域。这些会影响无线电波的传播，因此电信公司喜欢预测黑子的活动，以计划将来的任何困难： 先对数据想进行Box-Cox转换，设置lambda使得数据更加平滑，有10个观察值用作预测变量，并且在隐藏层中有6个神经元。
fit <- nnetar(sunspotarea, lambda=0)
autoplot(forecast(fit,h=30))
神经网络的预测区间可以通过反复模拟进行实现：
#针对黑子数据的9种可能的未来样本路径的模拟。每个样本路径覆盖了观测数据之后的30年
sim <- ts(matrix(0, nrow=30L, ncol=9L),
start=end(sunspotarea)[1L]+1L)
for(i in seq(9))
sim[,i] <- simulate(fit, nsim=30L)
autoplot(sunspotarea) + autolayer(sim)
不断重复就能画出预测区间了，PI就是预测次数，默认是FALSE，因为很占用计算资源。
fcast <- forecast(fit, PI=TRUE, h=30)
autoplot(fcast)
Repeated sampling and bagging
Bootstrapping算法，指的就是利用有限的样本资料经由多次重复抽样，重新建立起足以代表母体样本分布的新样本，如针对冰岛零售借记卡每月支出的十个不同的多次抽样版本：
bootseries <- bld.mbb.bootstrap(debitcards, 10) %>%
as.data.frame() %>% ts(start=2000, frequency=12)
autoplot(debitcards) +
autolayer(bootseries, colour=TRUE) +
autolayer(debitcards, colour=FALSE) +
ylab("Bootstrapped series") + guides(colour="none")
时间序列模型的几乎所有预测区间都太窄。这是一个众所周知的现象，是由于它们不能解决所有不确定因素而引起的。我们可以使用自举时间序列来解决该问题。我们使用debitcards数据来证明这个想法。首先，我们使用上述的重复抽样程序模拟了许多与原始数据相似的时间序列：
nsim <- 1000L
sim <- bld.mbb.bootstrap(debitcards, nsim)
对于每个系列，我们都拟合一个ETS模型并从该模型中模拟一个样本路径:
h <- 36L
future <- matrix(0, nrow=nsim, ncol=h)
for(i in seq(nsim))
future[i,] <- simulate(ets(sim[[i]]), nsim=h)
最后，我们采用这些模拟样本路径的均值和分位数来形成点预测和预测区间：
start <- tsp(debitcards)[2]+1/12
simfc <- structure(list(
mean = ts(colMeans(future), start=start, frequency=12),
lower = ts(apply(future, 2, quantile, prob=0.025),
start=start, frequency=12),
upper = ts(apply(future, 2, quantile, prob=0.975),
start=start, frequency=12),
level=95),
class="forecast")
这些预测区间将大于从直接应用于原始数据的ETS模型获得的预测区间：
etsfc <- forecast(ets(debitcards), h=h, level=95)
autoplot(debitcards) +
ggtitle("Monthly retail debit card usage in Iceland") +
xlab("Year") + ylab("million ISK") +
autolayer(simfc, series="Simulated") +
autolayer(etsfc, series="ETS")
与上面相对应的，我们可以运用套袋的方法生成多个预测值并进行平均，这样就能得到更加精确的预测值： 对冰岛信用卡数据进行了10次预测：
sim <- bld.mbb.bootstrap(debitcards, 10) %>%
as.data.frame() %>%
ts(frequency=12, start=2000)
fc <- purrr::map(as.list(sim),
function(x){forecast(ets(x))[["mean"]]}) %>%
as.data.frame() %>%
ts(frequency=12, start=start)
autoplot(debitcards) +
autolayer(sim, colour=TRUE) +
autolayer(fc, colour=TRUE) +
autolayer(debitcards, colour=FALSE) +
ylab("Bootstrapped series") +
guides(colour="none")
这些预测的平均值给出了原始数据的套袋预测。整个过程可以用baggedETS()功能处理。默认情况下，使用100个自举序列，用于获取自举残差的块的长度设置为每月数据24：
etsfc <- debitcards %>% ets() %>% forecast(h=36)
baggedfc <- debitcards %>% baggedETS() %>% forecast(h=36)
autoplot(debitcards) +
autolayer(baggedfc, series="BaggedETS", PI=FALSE) +
autolayer(etsfc, series="ETS", PI=FALSE) +
guides(colour=guide_legend(title="Forecasts"))
一般而言，套袋法比直接应用袋能提供更好的预测。
Back to the top
- Basic R analysis
Introduction to Deep Learning
Introduction
R语言上与深度学习相关的原生程序包很少，大多其实是基于Python的二道贩子包。但是也勉强够用了，这里就简单介绍一些深度学习与图像识别的相关思路与方法
- 深度学习
- 前言
- 简单的神经网络预测
- 复杂一点的简单神经网络
- 神经网络的参数优化
- 文本分析
- 模型1
- 尝试其他模型结构
- 模型2 我们需要安装相关程序包和程序：
#安装程序包 install.packages("keras") #安装相关组件 #for mac keras::install_keras(method = "conda") #for win/win keras::install_keras() #看看安装是否成功，ture才行 keras::is_keras_available() #如果不成功再试试安装这些 reticulate::py_config() tensorflow::tf_config()Simple neural network prediction
在运行一个简单的神经网络前需要加载这些包与数据
library(cowplot) library(keras) library(dplyr) library(tensorflow) library(ggplot2) #从美国国家标准与技术研究院数据库（NMIST）获取手写数字图像数据 mnist = dataset_mnist() #看看这些数据的结构 str(mnist) #设置测试集与训练集 x_train = mnist$train$x y_train = mnist$train$y x_test = mnist$test$x y_test = mnist$test$y #并查看他们的结构array_reshape函数允许我们将三维数组（如在mnist数据集中找到的三维数组）整形为矩阵。我们的28x28像素图像将变成具有长度的数组/向量28*28=784。#L表示整数 height = 28L width = 28L #转为矩阵 x_train = array_reshape(x_train, c(nrow(x_train), height * width)) x_test = array_reshape(x_test, c(nrow(x_test), height * width)) #我们看看结构，可以发现这些已经不是二维数据了 str(x_train) str(x_test) summary(x_train[, 500:550]) #查看数据，可以注意到每个像素变成了介于0（色谱的黑端）到255（色谱的白端）之间的像素值 x_train[1, ] #将数据缩放至0-1之间 x_train = x_train / 255 x_test = x_test / 255 summary(x_train[, 500:520]) #通过找到每个像素列的最大值，然后取该向量的最大值来明确地确认它。 max(apply(x_train, MARGIN = 2, max)) #最大值都是1现在我们可以定义模型了。我们要建立一个顺序的层堆栈。该
units参数定义了我们在每个层中应该有多少个节点（神经元）。input_shape允许我们在初始输入层中定义图像尺寸。该activation参数允许我们传入激活函数的名称作为参数。model = keras_model_sequential() model %>% #输入层加一层隐藏层的结构 #layer_dense可以增加隐藏层. #input_shape参数实际指定输入层；“units=”and“activation=”定义第一个隐藏层。 #或者我们在layer_dense()前有一个单独的layer_input(). layer_dense(units = 64, activation = 'relu', input_shape = 784) %>% layer_dropout(rate = 0.4) %>% # 第二层隐藏层 layer_dense(units = 16, activation = 'relu') %>% layer_dropout(rate = 0.3) %>% #输出层 layer_dense(units = 10, activation = 'softmax') summary(model)我们使用
sparse_categorical_crossentropy作为损失函数，因为我们要处理多个分类（即分类变量），而使用optimizer_rmsprop()作为优化器，因为它的性能可能比带动量的梯度下降要好一些。什么是lr参数呢？我们还选择“accuracy”作为我们的指标，以便为结果产生简单的分类率。model %>% compile( loss = 'sparse_categorical_crossentropy', # loss = "mean_squared_error", optimizer = optimizer_rmsprop(lr = 0.001), metrics = c('accuracy') )Training and evaluation
现在我们可以使用训练模型了
fit，在这里，我们只需传递X和Y变量以及其他超参数即可。 观看模型构建时代。一个时期（epoch）是所有训练数据的一次迭代，此处通过批处理128个观测值来完成。(history = model %>% fit( x_train, y_train, epochs = 45, batch_size = 128, validation_split = 0.2 ))
如何解释这些参数呢： loss：损失是每批训练数据中平均损失的平均值。我们希望早期批次的损失高于晚期批次的损失，因为模型应该随着时间的推移而不断学习。我们希望以后的数据损失更少。 acc：训练的准确性 val_loss和val_acc是测试数据的损失和准确性。 可以通过ggplot绘制训练历史：plot(history) + theme_minimal() #ggsave()来保存
评估测试数据的性能：model %>% evaluate(x_test, y_test) #结果非常好 #313/313 [==============================] - 0s 1ms/step - loss: 0.1895 - accuracy: 0.9634 # loss accuracy #0.1894975 0.9634000 #对测试数据生成预测，无需显式评估。 preds = model %>% predict(x_test) dim(preds) head(round(preds, 4)) glimpse(preds)Simple neural network
setwd("your way") #为测试集和训练集指定文件路径 train_path = "data-raw/dog-human/TRAIN" val_path = "data-raw/dog-human/VAL" #再定义两个变量作为文件的实际名称 train_images = list.files(train_path, full.names = TRUE, recursive = TRUE) val_images = list.files(val_path, full.names = TRUE, recursive = TRUE) #我们有600个训练集图像和100个验证集图像 length(train_images) length(val_images) #查看图像 train_images[1] val_images[1] #绘制图像 library(cowplot) ggdraw() + draw_image(train_images[20]) ggdraw() + draw_image(val_images[1])
训练集的狗狗 
测试集的狗狗Model definition
我们想在模型之外定义一些特征。这样，我们可以每次都传递相同的变量而不是值。
#预期的图像宽度和高度为96像素。 img_width = img_height = 96L #每次迭代要分析的观察数。 batch_size = 100L #训练集数量(600)。 (num_train_samples = length(list.files(train_path, recursive = TRUE))) #验证集数量。 num_validation_samples = 100L #完全通过训练数据的次数。 epochs = 30L我们可以使用
image_data_generator执行数据扩充，但是，我们将仅使用单独的rescale参数将数据缩放到一堆二进制矩阵-每个数字代表深色或浅色像素。#训练集 train_datagen = keras::image_data_generator(rescale = 1/255) #验证集 val_datagen = keras::image_data_generator(rescale = 1/255) train_datagen在定义模型之前，我们还需要向keras提供更多关于图像属性的细节。我们将在
train_datagen和val_datagen上使用flow_from_directory方法来定义新变量。#配置培训模型 #指定训练图像的文件路径与图像性状与批量（batch）大小 #class_mode为分类模板，binary就是二元（人/狗）颜色配置为灰度图像 train_gen = train_datagen$flow_from_directory(train_path, target_size = c(img_width, img_height), batch_size = batch_size, class_mode = "binary", color_mode = "grayscale") #配置验证模型 val_gen = val_datagen$flow_from_directory(val_path, target_size = c(img_width, img_height), batch_size = batch_size, class_mode = "binary", color_mode = "grayscale")
# %>%与magrittr函数来自这里
library(dplyr)
#负责关于神经网络的layer_flatten, layer_dense, layer_dropout等等指令
library(keras)
model = keras::keras_model_sequential()
model %>%
#输入层
#layer_flatten将把我们的三维阵列变成一维阵列
#Note: 在第1部分中，我们没有必要这样做，因为数据已经变平了
layer_flatten(input_shape = c(img_width, img_height, 1)) %>%
#隐藏层
#layer_dense允许我们实际添加输入层。我们指定了哪些参数？
layer_dense(units = 96, activation = 'relu', input_shape = c(img_width, img_height)) %>%
#layer_dropout允许我们对模型应用正则化。
layer_dropout(rate = 0.4) %>%
#隐藏层
layer_dense(units = 192, activation = 'relu') %>%
layer_dropout(rate = 0.3) %>%
#输出层
#在这里，我们可以将我们的激活改为一个二元结果的sigmoid函数?
layer_dense(units = 1, activation = 'sigmoid')
summary(model)
Model output and evaluation
我们可以使用通用compile函数来指定损失和优化器函数以及分类指标。
model %>% compile(
#看看是狗是人
loss = 'binary_crossentropy',
#把学习速度放慢一点。。。
optimizer = optimizer_adam(lr = 0.000001),
#如何评估模型性能
metrics = c('accuracy')
)
训练模型： 注意，这次我们必须使用fit_generator拟合模型，因为我们还使用了自定义flow_from_directory函数，而不是之前的简单格式。
batch_size = 100
#会有警告WARNING:tensorflow:Your input ran out of data; interrupting training. Make sure that your dataset or generator can generate at least `steps_per_epoch * epochs` batches (in this case, 10 batches). You may need to use the repeat() function when building your dataset.
#batch_size = 10
num_validation_samples
history = model %>%
fit_generator(train_gen,
steps_per_epoch = as.integer(num_train_samples / batch_size),
epochs = epochs,
#epochs = 13,
validation_data = val_gen,
validation_steps = as.integer(num_validation_samples / batch_size))
# Review fitting history.
plot(history) + theme_bw()
model %>% evaluate_generator(generator = val_gen, steps = 10)
Parameter optimization of neural networks
在此之前需要安装magic包，ImageMagick是C ++的开源图像处理库，许多不同的语言都支持它。我们正在使用与C ++代码对接的R包。 以及其他包：
library(keras)
# Set the seed immediately after loading keras library.
# If the library was already loaded, we may want to run .rs.restartR() to restart
# our R session.
# This is broken right now.
#use_session_with_seed(1, disable_gpu = FALSE, disable_parallel_cpu = FALSE)
library(dplyr)
library(ggplot2)
# Gives us the tf object for certain manipulations.
library(tensorflow)
Retrieve, specify, and check data
模型用于训练的数据需要单独下载，我们不会将图像数据直接存储在GitHub存储库中，因为Git旨在跟踪更改文本文件，并且不适用于图像之类的二进制文件。我们将下载一个zip文件并以编程方式将其解压缩。这样可以使存储库的大小更小，并且可以更快地克隆或下载。
local_file = "data-raw/Open_I_abd_vs_CXRs.zip"
#如果我们的工作目录中还没有zip文件，请下载它，大约13.5MB。
#也可以顺着链接去手动下载
if (!file.exists(local_file)) {
download.file("https://raw.githubusercontent.com/paras42/Hello_World_Deep_Learning/master/Open_I_abd_vs_CXRs.zip", local_file)
}
#将本地文件解压到data raw目录中（如果还没有的话）。
if (!file.exists("data-raw/Open_I_abd_vs_CXRs")) {
unzip(local_file, exdir = "data-raw")
}
我们将使用该dirs列表将不同的目录组织为几个变量： dirs$base -解压图像后的主目录路径。 dirs$train -训练集文件夹的路径。 dirs$val -验证集文件夹的路径。 将多个设置组织到一个列表对象中是一个好习惯。首先，它可以使环境更加井井有条，并且还可以更轻松地将这些设置保存到RData文件中以供后代使用。
#把我们的目录整理成一个列表。
dirs = list(base = "data-raw/Open_I_abd_vs_CXRs/")
#不要在结尾加“/”，因为list.files()将稍后添加这些。
dirs$train = paste0(dirs$base, "TRAIN")
dirs$val = paste0(dirs$base, "VAL")
#打印出我们的目录配置。
dirs
每个目录中有多少个图像？
#图像被组织到两个子目录中（每种图像类型一个），我们将recursive=TRUE设置为进入每个子目录。
length((train_files = list.files(dirs$train, recursive = TRUE, full.names = TRUE)))
#检查前两个文件元素。两者都是腹部x光片（注意子目录）。
train_files[1:2]
#挑战：
#我们的验证目录中有多少个文件？
#验证文件列表中的第二和第三个元素是什么？
# Hint:
# length((val_files = list.files(_________, ________, ________)))
绘制图像：
#magick包是显示图像的一种方式。
library(magick)
#在R上显示这些图
print(image_read(train_files[5]))
#打开系统查看以查看图像。
image_browse(image_read(train_files[5]))
#或者，我们可以使用cowplot在ggplot内部打印图像。
library(cowplot)
#使用ggplot, cowplot, magick包绘图
ggdraw() + draw_image(train_files[1])
#同时绘制第二幅图像，这次添加了一个标题并删除了额外的项目。
ggdraw() + draw_image(train_files[2]) + ggtitle("2nd image") + theme_minimal() +
theme(axis.text = element_blank(), panel.grid = element_blank())
###
#挑战：绘制第三张图片并在标题中输入文件名。
#额外提示：basename()将从文件路径中删除所有目录。
###
Pre trained networks and fine-tuning
为了达到较高的准确性，神经网络通常需要非常深，这意味着许多隐藏层。这使网络可以对输入数据建立复杂的理解，因为更深的层次建立在较早的层次上，以“设计”它已学习的与准确预测有关的新功能。
但是，深度神经网络由神经元之间的数百万个链接（权重）组成，如果我们只有100个观察值，则网络没有足够的信息来准确地调整权重。而从头开始构建的深度神经网络需要进行大量观察：最好是数百万个观察结果，取决于任务。
克服此限制的一种方法是“预训练+微调”。首先，我们在一个大型数据集上训练一个复杂的（深度）神经网络，这使各层能够很好地校准其权重。我们希望它针对该数据集设计的功能将适用于我们的新的较小数据集。这就是所谓的“基础模型”，Keras提供了10种这样的预训练模型供我们使用。
接下来，我们将该预训练的神经网络应用于较小的数据集。我们删除最原始的数据集的最后一两层，然后添加随机初始化的一两层。然后，微调将在我们较小的数据集上重新运行网络，并主要将这些新图层更新为我们的小型数据集；我们也可能会稍微更新“基本”神经网络权重。
设置数据与核心模型：
#让我们图像的尺寸与神经结构所期望的一样。
img_width = img_height = 299L
batch_size = 5L
train_datagen = keras::image_data_generator(rescale = 1/255)
val_datagen = keras::image_data_generator(rescale = 1/255)
#使用目标大小
train_gen = train_datagen$flow_from_directory(dirs$train, target_size = c(img_width, img_height), batch_size = batch_size, class_mode = "binary")
val_gen = val_datagen$flow_from_directory(dirs$val, target_size = c(img_width, img_height), batch_size = batch_size, class_mode = "binary")
#这将在首次运行时下载初始权重(~84 MB)
base_model = keras::application_inception_v3(include_top = FALSE, pooling = "avg", input_shape = c(img_width, img_height, 3L))
#导出一个8x8x2048的tensor.
base_model$output_shape
?application_inception_v3
summary(base_model)
添加自定义层：
#第一：只训练顶层（随机初始化）
#i.e. 冻结所有的InceptionV3层
#不起作用，kares可能有bug
freeze_weights(base_model)
#添加自定义层到初始。
model_top = base_model$output %>%
#layer_global_average_pooling_2d() %>%
layer_dense(units = 128, activation = "relu") %>%
layer_dropout(0.5) %>%
layer_dense(units = 1, activation = "sigmoid")
#这是我们将要训练的模型
model = keras_model(inputs = base_model$input, outputs = model_top)
length(model$layers)
#手动冻结初始初始层，只需训练最后3层。
freeze_weights(model, 1, length(model$layers) - 3)
summary(model)
#编译模型（应在*将图层设置为不可训练后*完成）
model %>%
compile(optimizer = optimizer_adam(#lr = 0.00001或lr = 0.0005或lr = 0.0001试试, epsilon是adam优化器的配置设置
epsilon = 1e-08),
#或者可以使用字符类型的命令:loss=“binary_crossentry”
loss = loss_binary_crossentropy,
metrics = "accuracy")
(num_train_samples = length(train_files))
num_validation_samples = 10L
拟合模型：
#在新数据的基础上训练几个时期的模型
history = model %>%
fit_generator(train_gen,
steps_per_epoch = as.integer(num_train_samples / batch_size),
epochs = 5,
validation_data = val_gen,
validation_steps = as.integer(num_validation_samples / batch_size))
#查看拟合历史
plot(history)
训练完整模型：
#Unfreeze_weights()似乎要求我们具体指定层。
unfreeze_weights(model, 1, length(model$layers))
model %>%
compile(optimizer =
#注意这里的学习速率很低
optimizer_adam(lr = 0.00001,
epsilon = 1e-08),
loss = loss_binary_crossentropy,
metrics = "accuracy")
#训练全套图层，但仅限于几个时期。
history = model %>%
fit_generator(train_gen,
steps_per_epoch = as.integer(num_train_samples / batch_size),
epochs = 4,
validation_data = val_gen,
validation_steps = as.integer(num_validation_samples / batch_size))
现在，我们的验证损失低于培训损失-为什么会有这样的想法？
挑战： 返回第一个模型并尝试修改一些设置：隐藏单元数，其他隐藏层和/或辍学率。它们各自如何影响您的结果？ 查看帮助页面中的optimizer_adam，然后尝试更改一个或两个设置。单击其他优化器，然后尝试使用其他优化器。 其他/扩充： 作为可选的作业，以下是用于更复杂的图像数据生成器的示例代码。该代码使用数据增强，将数据随机随机的小扰动应用于原始图像，以：1）近似具有较大的样本大小； 2）鼓励网络对原始图像特征不那么敏感。结果，与不这样做相比，此增强步骤应使我们可以获得更好的性能。
train_datagen =
keras::image_data_generator(rescale = 1 / 255,
shear_range = 0.2,
zoom_range = 0.2,
rotation_range = 20,
width_shift_range = 0.2,
height_shift_range = 0.2,
horizontal_flip = TRUE)
Text analysis
分析特朗普的推特 加载相关程序包
knitr::opts_chunk$set(echo = TRUE)
library(dplyr)
library(rio)
library(ggplot2)
library(keras)
下载相关数据：
data_file = "data-raw/condensed_2018.json"
if (!file.exists(data_file)) {
file_url = "https://github.com/bpb27/trump_tweet_data_archive/raw/master/condensed_2018.json.zip"
(local_file = paste0("data-raw/", basename(file_url)))
if (!file.exists(local_file)) {
download.file(file_url, local_file)
}
unzip(local_file, exdir = "data-raw")
}
data = rio::import(data_file)
探索数据结构：
dplyr::glimpse(data)
summary(data$favorite_count)
#哪条推文最受欢迎？
data %>% arrange(desc(favorite_count)) %>% filter(row_number() == 1)
qplot(data$favorite_count)
qplot(log(data$favorite_count + 1))
qplot(data$retweet_count)
summary(data)
table(data$source, useNA = "ifany")
我们试着预测一条特朗普推特会收到多少转发呢？ 数据准备
max_words <- 5000
batch_size <- 32
epochs <- 5
cat('Loading data...\n')
text_col = "text"
outcome_col = "retweet_count"
data[[text_col]] = tolower(data[[text_col]])
#分为训练与测试集
set.seed(1)
data$train = 0L
data$train[sample(nrow(data), ceiling(nrow(data) * 0.8))] = 1L
table(data$train, useNA = "ifany")
prop.table(table(data$train, useNA = "ifany"))
train = data[data$train == 1, ]
test = data[data$train == 0, ]
x_train <- train[[text_col]]
y_train <- train[[outcome_col]]
x_test <- test[[text_col]]
y_test <- test[[outcome_col]]
cat(length(x_train), 'train sequences\n')
cat(length(x_test), 'test sequences\n')
cat('Vectorizing sequence data...\n')
x_train[[1]]
tokenizer <- text_tokenizer(num_words = max_words)
tokenizer$fit_on_texts(data[[text_col]])
#找到的唯一单词（标记）总数。
length(tokenizer$word_index)
x_train_seq = texts_to_sequences(tokenizer, x_train)
x_train_seq[[1]]
str(x_train_seq)
#检查标记长度的分布。
summary(sapply(x_train_seq, length))
maxlen = 61L
train_data <- pad_sequences(
x_train_seq,
#value = word_index_df %>% filter(word == "<PAD>") %>% select(idx) %>% pull(),
padding = "post",
maxlen = maxlen,
)
str(train_data)
train_data[1, ]
x_test_seq = texts_to_sequences(tokenizer, x_test)
test_data <- pad_sequences(
x_test_seq,
# value = word_index_df %>% filter(word == "<PAD>") %>% select(idx) %>% pull(),
padding = "post",
maxlen = maxlen,
)
Model 1
建立模型：
#vocab_size <- 10000
(vocab_size = tokenizer$num_words)
model <- keras_model_sequential()
model %>%
layer_embedding(input_dim = vocab_size, output_dim = 16) %>%
layer_global_average_pooling_1d() %>%
layer_dense(units = 16, activation = "relu") %>%
layer_dropout(rate = 0.3) %>%
layer_dense(units = 1, activation = "linear")
model %>% summary()
model %>% compile(
optimizer = optimizer_adam(lr = 0.005),
loss = 'mean_squared_error'
)
训练模型：
history <- model %>% fit(
train_data,
y_train,
epochs = 50,
batch_size = 4,
validation_split = 0.2,
callbacks = list(
callback_early_stopping(patience = 8L, restore_best_weights = TRUE),
callback_reduce_lr_on_plateau(patience = 4L)
)
)
history
plot(history)
评估模型：
(eval_loss = model %>% evaluate(test_data, y_test, verbose = 0))
# We're typically off by 10,483 retweets
sqrt(eval_loss)
# Just predicting the mean would only be off by 11,519 retweets typically.
sd(y_test)
# Look at predictions.
preds = model %>% predict(test_data)
head(preds)
summary(preds)
mean(y_train)
qplot(preds)
qplot(preds, y_test) + geom_smooth() + theme_minimal()
# Correlation of 0.44, p is highly significant.
cor.test(preds, y_test)
# Spearman correlation of 0.575
cor.test(rank(preds), rank(y_test))
Another model structure
(vocab_size = tokenizer$num_words)
model <- keras_model_sequential()
model %>%
layer_embedding(input_dim = vocab_size, output_dim = 32) %>%
#layer_lstm(16) %>%
layer_conv_1d(64, kernel_size = 1) %>%
layer_global_average_pooling_1d() %>%
layer_dense(units = 16, activation = "relu") %>%
layer_dropout(0.3) %>%
layer_dense(units = 1, activation = "linear")
model %>% summary()
model %>% compile(
optimizer = optimizer_adam(lr = 0.001),
loss = 'mean_squared_error'
)
训练模型2：
history <- model %>% fit(
train_data,
y_train,
epochs = 50,
batch_size = 32,
validation_split = 0.2,
callbacks = list(
callback_early_stopping(patience = 6L, restore_best_weights = TRUE, verbose = 1),
callback_reduce_lr_on_plateau(patience = 3L, verbose = 1))
)
plot(history)
Model 2
评估模型2：
(eval_loss = model %>% evaluate(test_data, y_test, verbose = 0))
#通常会被10750次转发
sqrt(eval_loss)
#查看预测值
preds = model %>% predict(test_data)
head(preds)
summary(preds)
#开始在我们的预测中传播开来
qplot(preds)
qplot(preds, y_test) + geom_smooth() + theme_minimal()
# Pearson linear correlation of 0.395
cor.test(preds, y_test)
# Spearman correlation of 0.563
cor.test(rank(preds), rank(y_test))
# Same thing:
cor.test(preds, y_test, method = "spearman", exact = FALSE)
# Kendall's tau 0.402
cor.test(preds, y_test, method = "kendall", exact = FALSE)
Back to the top