r语言作业：基于线圈数据的交通流密速分析

目录

1.数据读取：提取全部NHNX40(1)检测器的数据。

2.冗余和缺失处理

3.数据聚集

4.可视化与分析

5.选择第一天的数据分析

6.总体代码

---

1.数据读取：提取全部NHNX40(1)检测器的数据。

通过Excel打开几个文件并查找后，确认仅有tmp02和tmp04中含有NHNX40（1）监测器结果，因此将两个文件合并为data文件，并针对data文件进一步通过函数过滤监测器NHNX40（1）的数据至新文件bind_data中。再用order函数将得到的数据进行排列。

输出结果如图1：

图1

 

 

2.冗余和缺失处理

1.统计冗余的记录数

2.冗余数据处理：如有冗余数据，则流量、占有率和速度采用冗余记录的平均值作为该时刻的记录值。

3.统计每天的记录数，得到每天的记录缺失个数：缺失是指按照固定间隔采集的记录中，某时刻的记录不存在。

4.对于缺失数据，采用前三个周期的平均值代替。（数据中可能有多个连续时刻记录缺失的情况，对于本次实验来说，仍依次按照前三周期均值修复）

将日期值提取出后，用后一列日期值减去前一列日期值，得到前后日期数据的差值。以时间差值为第一列，顺序编号为第二列新建数据框diff，并将diff按照差值由低到高排列，如图所示：

  

图2                              图3

图中difftime为0secs的即为冗余值，difftime = 20 secs的为正常数据，difftime > 20secs的即为缺失值。

查找原表，发现冗余值为一个重复值，可以直接将其删去。同时也发现缺失值应有58个。

确定了冗余和缺失的情况后，就可以对其进行修改。

新建一个包含顺序编号的完整日期数据框，并将其与原数据框进行left_join操作。

找出数据框中的缺失部分，并利用for循环将每个缺失值用前三个周期的数据进行填补，从结果展示一个原来的缺失区域，现填补如图5：

图5

 

 

3.数据聚集

聚集函数如下：

 

4.可视化与分析

（1）分别基于20s， 5min，15min的所有数据，绘制V-O, V-Q, Q-O散点图（参见p113）：同一时间间隔的三张图可以作为子图包含在一张图中；说明不同时间分辨率时三种图的异同点（V: FINT_SPEED, Q: FIN T_VOLUME, O: FINT_OCCUPY, V-O图是指：V为纵坐标，O为横坐标）

20s

5 min

15min

可以看出，三组图中数据之间的关系是类似的，但是周期取值越长，分布越紧密。

（2）基于5min数据的图，估计通行能力、自由流车速、最佳占有率、最佳车速、阻塞占有率（参考《交通数据采集与分析》112页内容，各指数看图取估计值即可）

由该图可以大致取得，通行能力约为2250veh/h，自由流车速约为67km/h，最佳占有率约为27，最佳车速约为37km/h，阻塞占有率约为55

（3）基于5min的O-V的数据，移除明显的异常数据，建立占有率O和速度V的线性回归模型，给出关系式，并对模型参数进行统计检验。（异常数据可以根据散点图的结果，对明显偏离可能的回归直线的数据点设置条件进行删除）

输出如下：

在Pr(>|t|)栏，可以看到回归系数（-1.319188）显著不为0（p<0.001），R平方项（0.9321）表明模型可以解释93.21%的方差。

 

5.选择第一天的数据分析

a.分别绘制流量、速度、占有率时序图，在同一张图中包含某变量的20s、5min和15min间隔下的变化曲线，对图表进行讨论。

可以看出，无论采用何种时间间隔，曲线大致图形相同，但时间间隔越大，波动越小。

b.基于15min数据，绘制流量-速度时变图，说明二者的变化关系。（即在同一张图中包含流量随时间变化的曲线和速度随时间变化的曲线，两条曲线分别采用左右两个纵坐标）

c.基于15min的数据

（1）估计车辆平均有效长度

（2）绘制车长的时序图

（3）绘制车长的分布

6.总体代码

library(tidyverse)
library(dplyr)
library(readxl)
xls1 <- read_excel("F:/data/tmp002.xls")
xls2 <- read_excel("F:/data/tmp004.xls")
data<- bind_rows(xls1,xls2) 
bind_data<- filter(data,FSTR_LOOPGROUPID=='NHNX40(1)') 
data1<-bind_data[order(bind_data$FDT_TIME),]
data1 <- data1[,-1] #合并数据，筛选，剔除第一列并从小到大排列

library(lubridate)
datatime<-as.POSIXlt(data1$FDT_TIME)
datatime2<-datatime[-c(1:1),]
datatime3<-datatime[-c(30183:30183),]
diff<-difftime(datatime2,datatime3)
diff2<-data.frame(difftime=diff,id=1:30182,datatime=datatime2)
diff2<-diff2[order(diff2$difftime),]
data[1,1:5]#利用时间差观察冗余和缺失情况，展示冗余值

temp<-data.frame(FDT_TIME=strptime("2010-04-17 23:59:40","%Y-%m-%d %H:%M:%S")+20*1:30240,id=1:30240)
as.character(data1$FDT_TIME)
as.character(temp$FDT_TIME)
temp2<- left_join(temp,data1,by='FDT_TIME')
table(is.na(temp2[3]))#新建日期数据框，合并后确定冗余数目

#找到缺失项
index1<-which(is.na(temp2$FINT_VOLUME))
indexl_sum<-sum(is.na(temp2$FINT_VOLUME))
#对缺失项填补数据
for (i in index1)
{
+ temp2$FSTR_LOOPGROUPID[i]="NHNX40(1)";
＋ temp2$FINT_VOLUME[i]=(temp2$FINT_VOLUME[i-1]+temp2$FINT_VOLUME[i-2]+temp2$FINT_VOLUME[i-3])/3;
+ temp2$FINT_SPEED[i]=(temp2$FINT_SPEED[i-1]+temp2$FINT_SPEED[i-2]+temp2$FINT_SPEED[i-3])/3;
+temp2$FINT_OCCUPY[i]=(temp2$FINT_OCCUPY[i-1]+temp2$FINT_OCCUPY[i-2]+temp2$FINT_OCCUPY[i-3])/3;
+}


myfunction <- function( temp,x){
t<-x/20
temp$group<-(temp$id-1)%/%t
# 指定分组变量
grouped <- group_by(.data = temp, group)
# 聚合统计
stats1<- summarise(.data = grouped, A_VOLUME= mean(FINT_VOLUME)*(3600/20) ,A_SPEED= sum(FINT_VOLUME)/sum(FINT_VOLUME/FINT_SPEED),A_OCCUPY=mean(FINT_OCCUPY))
stats2<-na.omit(stats1)
return(stats2)
}

s1<-myfunction(temp2,20)
s2<-myfunction(temp2,300)
s3<-myfunction(temp2,900)

p1<-ggplot(s1,aes(x=A_OCCUPY,y=A_SPEED))+geom_point(colour="#003366")+ labs(title = "v-o") 
p2<-ggplot(s1,aes(x=A_VOLUME,y=A_SPEED))+geom_point(colour="#CC6666")+ labs(title = "v-q") 
p3<-ggplot(s1,aes(x=A_OCCUPY,y=A_VOLUME))+geom_point(colour="#FFCC99")+ labs(title = "q-o") 
p4<- cowplot::plot_grid(p1, p2, p3, nrow = 2)
p4

p5<-ggplot(s2,aes(x=A_OCCUPY,y=A_SPEED))+geom_point(colour="#003366")+ labs(title = "v-o") 
p6<-ggplot(s2,aes(x=A_VOLUME,y=A_SPEED))+geom_point(colour="#CC6666")+ labs(title = "v-q") 
p7<-ggplot(s2,aes(x=A_OCCUPY,y=A_VOLUME))+geom_point(colour="#FFCC99")+ labs(title = "q-o") 
p8<- cowplot::plot_grid(p5, p6, p7, nrow = 2)
p8

p9<-ggplot(s3,aes(x=A_OCCUPY,y=A_SPEED))+geom_point(colour="#003366")+ labs(title = "v-o") 
p10<-ggplot(s3,aes(x=A_VOLUME,y=A_SPEED))+geom_point(colour="#CC6666")+ labs(title = "v-q") 
p11<-ggplot(s3,aes(x=A_OCCUPY,y=A_VOLUME))+geom_point(colour="#FFCC99")+ labs(title = "q-o") 
p12<- cowplot::plot_grid(p9, p10, p11, nrow = 2)
p12

#筛选离群点
n1= which(s2$A_SPEED == 0)
n2= which(s2$A_OCCUPY<10&&s2$A_SPEED<50)
n3= which(s2$A_OCCUPY<15&&s2$A_SPEED<40)
s2[-n1,]
s2[-n2,]
s2[-n3,]

#选取第一天数据
temp3<-temp2[c(1:4320),]
s4<-myfunction(temp3,20)
s5<-myfunction(temp3,300)
s6<-myfunction(temp3,900)

#画时序图
SPEED_20s=ts(s4$A_SPEED,start=0,deltat=20)  
OCCUPY_20s=ts(s4$A_OCCUPY,start=0,deltat=20)  
VOLUME_20s=ts(s4$A_VOLUME,start=0,deltat=20)  
SPEED_5min=ts(s5$A_SPEED,start=0,deltat=300)  
OCCUPY_5min=ts(s5$A_OCCUPY,start=0,deltat=300)  
VOLUME_5min=ts(s5$A_VOLUME,start=0,deltat=300)
SPEED_15min=ts(s6$A_SPEED,start=0,deltat=900)  
OCCUPY_15min=ts(s6$A_OCCUPY,start=0,deltat=900)  
VOLUME_15min=ts(s6$A_VOLUME,start=0,deltat=900)
par(mfrow=c(3,3))
plot(SPEED_20s)
plot(OCCUPY_20s)
plot(VOLUME_20s)
plot(SPEED_5min)
plot(OCCUPY_5min)
plot(VOLUME_5min)
plot(SPEED_15min)
plot(OCCUPY_15min)
plot(VOLUME_15min)

p <- ggplot(s6, aes(x = group))+ geom_line(aes(y=A_OCCUPY),colour="blue")+ geom_line(aes(y=A_SPEED/2))+ scale_y_continuous(sec.axis = sec_axis(~.*2, name = "“SPEED")) + labs(y = "occupy",x ="time/20s")

s6$k<-s6$A_VOLUME/s6$A_SPEED
s6$L<-s6$A_OCCUPY/s6$k
l<-mean(s6$L)
l_15min=ts(s6$L,start=0,deltat=900)

ggplot(s6,aes(x=group,y=L))+geom_point(colour="blue"))