在特定日期的线性模型中绘制残差

Question

编辑：给出了第一个答案，并提供了一个函数以供进一步使用，但不使用dplyr-package。不过，它在很大程度上依赖于给定的答案，所以谢谢你。

plot_one_day <- function(LM,Day,DF) {Residuals<-resid(LM)
Filter=cbind(DF,Residuals)
Filterdata= Filter[Filter$Time>=paste(Day,"00:00:00") & Filter$Time<=paste(Day,"23:50:00"),]
Filter_NARM=Filterdata[!is.na(Filterdata$Residuals),]
plot(Residuals ~ Time, data=Filter_NARM, main=paste("Correlation for the",substr(Filter_NARM[1,1],1,10)),xlab="Time",
     xlim=range(Filterdata$Time), ylim=range(Filter_NARM$Residuals))
abline(h=0, col="red")
}

plot_one_day(LM_1,"2015-05-07",MyData)

如果您有这样的数据框：

start <- as.POSIXct("2015-05-05 06:00:00", format="%Y-%m-%d %H:%M:%S")
end   <- as.POSIXct("2015-05-07 20:00:00", format= "%Y-%m-%d %H:%M:%S")
Time=seq.POSIXt(start, end, by="10 min")

MyData=data.frame(Time=Time,Rain=rep(0,(length(Time))),Rain_Binary=rep(0,(length(Time))),People=rep(0,(length(Time))))
MyData[c(2:4,154:157,324:328),2]=5
MyData$People=round(runif(length(Time),0,50), digits=0)

for (Z in 1:nrow(MyData)) {Today= substr(MyData[Z,1], 1, 10)
if(any(MyData$Rain[((MyData$Time>= strptime(paste(Today, "06:30:00", sep = " "),format="%Y-%m-%d %H:%M:%S"))&
                    (MyData$Time<= strptime(paste(Today, "09:00:00", sep = " "),format="%Y-%m-%d %H:%M:%S")))]>0)) {MyData$Rain_Binary[(MyData$Time>=strptime(paste(Today, "06:30:00", sep = " "),format="%Y-%m-%d %H:%M:%S"))&
                                                                                                                                         (MyData$Time<= strptime(paste(Today, "20:00:00", sep = " "),format="%Y-%m-%d %H:%M:%S"))]=1
}
}
MyData$Rain_Binary=as.factor(MyData$Rain_Binary)

并生成它的线性模型：

LM_1 = lm(People ~ Time + Rain_Binary, data=MyData, na.action = na.exclude)

你检查它的残差：

plot(resid(LM_1) ~ c(1:dim(MyData)[1]), data=MyData, main="Correlation complete",xlab="Time")

问题：如何在数据框中仅对一天进行地址处理，并在其中绘制残差？这会出错：

plot(resid(LM_1) ~ MyData$Time[substr(MyData$Time,1,10)==strptime("2015-05-06",format="%Y-%m-%d")], data=MyData, main="Correlation 1 Day \n 2015-09-03", xlab="Time")

Answer 1

首先我无法在绘图之前重现您的代码，它会出错：

start <- as.POSIXct("2015-05-05 06:00:00", format="%Y-%m-%d %H:%M:%S")
> end   <- as.POSIXct("2015-05-07 20:00:00", format= "%Y-%m-%d %H:%M:%S")
> Time=seq.POSIXt(start, end, by="10 min")
> 
> MyData=data.frame(Time=Time,Rain=rep(0,(length(Time))),Rain_Binary=rep(0,(length(Time))),People=rep(0,(length(Time))))
> MyData[c(2:4,154:157,324:328),2]=5
> MyData$People=round(runif(length(Time),0,50), digits=0)
> MyData$Rain_Binary=as.factor(MyData$Rain_Binary)
> 
> for (Z in 1:nrow(MyData)) {Today= substr(MyData[Z,1], 1, 10)
+ if(any(MyData$Rain[((MyData$Time>= strptime(paste(Today, "06:30:00", sep = " "),format="%Y-%m-%d %H:%M:%S"))&
+                     (MyData$Time<= strptime(paste(Today, "09:00:00", sep = " "),format="%Y-%m-%d %H:%M:%S")))]>0)) {MyData$Rain_Binary[(MyData$Time>=strptime(paste(Today, "06:30:00", sep = " "),format="%Y-%m-%d %H:%M:%S"))&
+                                                                                                                                          (MyData$Time<= strptime(paste(Today, "20:00:00", sep = " "),format="%Y-%m-%d %H:%M:%S"))]=1
+ }
+ }
There were 50 or more warnings (use warnings() to see the first 50)
> 
> LM_1 = lm(People ~ Time + Rain_Binary, data=MyData, na.action = na.exclude)
Error in `contrasts<-`(`*tmp*`, value = contr.funs[1 + isOF[nn]]) : 
  contrasts can be applied only to factors with 2 or more levels

所以猜测你可能想要的东西我改变了代码：

start <- as.POSIXct("2015-05-05 06:00:00", format="%Y-%m-%d %H:%M:%S")
end   <- as.POSIXct("2015-05-07 20:00:00", format= "%Y-%m-%d %H:%M:%S")
Time=seq.POSIXt(start, end, by="10 min")

MyData=data.frame(Time=Time,Rain=rep(0,(length(Time))),Rain_Binary=rep(0,(length(Time))),People=rep(0,(length(Time))))
MyData[c(2:4,154:157,324:328),2]=5
MyData$People=round(runif(length(Time),0,50), digits=0)
for (Z in 1:nrow(MyData)) {Today= substr(MyData[Z,1], 1, 10)
if(any(MyData$Rain[((MyData$Time>= strptime(paste(Today, "06:30:00", sep = " "),format="%Y-%m-%d %H:%M:%S"))&
                    (MyData$Time<= strptime(paste(Today, "09:00:00", sep = " "),format="%Y-%m-%d %H:%M:%S")))]>0)) {
  MyData$Rain_Binary[(MyData$Time>=strptime(paste(Today, "06:30:00", sep = " "),format="%Y-%m-%d %H:%M:%S"))&
  (MyData$Time<= strptime(paste(Today, "20:00:00", sep = " "),format="%Y-%m-%d %H:%M:%S"))]=1
}
}
MyData$Rain_Binary=as.factor(as.character(MyData$Rain_Binary))

最后，我们专门针对一天绘制残差：＆＃34; 2015-05-06＆＃34;

library(dplyr)
LM_1 = lm(People ~ Time + Rain_Binary, data=MyData)
MyData$Residuals<-resid(LM_1)
filteredData<-filter(MyData,Time>"2015-05-06 00:00"&Time<"2015-05-06 23:50")
plot(Residuals ~ Time, data=filteredData, main="Correlation 1 Day \n 2015-09-03",xlab="Time")

希望这有帮助