票房线性回归 Linear regression of film box office

the-order 发表于 2022/04/18 19:53:08 2022/04/18
【摘要】 1 数据统计与预览library(raster)a = read.csv("film.csv", header = T) ##读入数据,不要将字符串视为factorsummary(a) ##查看数据基本情况,检查缺失情况a = n...

1 数据统计与预览

library(raster)
a = read.csv("film.csv", header = T)                  ##读入数据,不要将字符串视为factor
summary(a)                                                                 ##查看数据基本情况,检查缺失情况
a = na.omit(a)                                                             ##将数据集里全部NA所在行删除
film_high = a[which.max(a$boxoffice),]                                     ##查看票房最高纪录
film_low = a[which.min(a$boxoffice),]                                      ##查看票房最低纪录

在这里插入图片描述

2 数据预览

library(wordcloud)
col<-brewer.pal(8,"Accent")
h<-hist(a$boxoffice,breaks=12,col=col)
xfit <-seq(min(a$boxoffice),max(a$boxoffice),length=40)
yfit <-dnorm(xfit,mean=mean(a$boxoffice),sd=sd(a$boxoffice))  #dnorm返回的是正态分布概率函数值
yfit <- yfit*diff(h$mids[1:2]) *length(a$boxoffice)
lines(xfit,yfit,col='red',lwd=2)
summary(a$boxoffice)

在这里插入图片描述
数据右偏分布数据,对y取对数处理,左偏数据开方处理

3 分箱处理数据与预览

##票房直方图
boxbar<-as.data.frame(table(cut(a$boxoffice,breaks=c(1000*(1:5),7000,10000,50000,100000,130000),
                                labels=c('1-2千万','2-3千万','3-4千万','4-5千万',
                                         '5-7千万','7千万-1亿','1-5亿','5-10亿','大于10亿'))))
barplot(boxbar$Freq,names.arg=boxbar$Var1,col="dodgerblue",xlab="票房(万元)",ylab="频数")

as.data.frame(table(a$genre))

在这里插入图片描述

boxplot(log(boxoffice)~genre,xlab="电影类型",
        data=a,col="indianred1",ylab="对数票房",varwidth=T)                ##电影类型箱线图
as.data.frame(table(a$month))                                                             ##上映月份统计
boxplot(log(boxoffice)~month,xlab="月份",
        data=a,col="dodgerblue",ylab="对数票房",varwidth=T) 
        ```

在这里插入图片描述
在这里插入图片描述

4 完成数据清理函数


dataclean<-function(a){
  a$dangqi<-cut(a$month,breaks=c(0,2,4,6,9,11),labels=c('贺岁档','普通档','黄金1档','暑期档','黄金2档'))
  a$dangqi[is.na(a$dangqi)]<-'贺岁档'
  a$distribute<-factor(a$distribute,levels=c('C','G','L','S'),
                       labels=c('联合发行','国有宣发','小私营公司','明星私企'))
  a$reality<-factor(a$reality,levels=c(0,1),labels=c('否','是'))
  a$story<-factor(a$story,levels=c('N','S'),labels=c('原创','虚构'))
  a$remake<-factor(a$remake,levels=c(0,1),labels=c('否','是'))
  a$sequel<-factor(a$sequel,levels=c(0,1),labels=c('否','是'))
  a$导演得奖情况<-factor(a$导演得奖情况,levels=c(0,1),labels=c('否','是'))
  a$导演是否转型<-factor(a$导演是否转型,levels=c(0,1),labels=c('否','是'))
  a$导演年代[a$导演年代<50]="50以下"                                     ##将3040年代合并为50以下
  a$导演年代=factor(a$导演年代,c("50以下","50","60","70","80"))          ##更改因子水平顺序
  return(a)

a<-dataclean(a)

table(a$dangqi)                                                            ##上映档期统计
boxplot(log(boxoffice)~dangqi,xlab="档期",
        data=a,col="yellow",ylab="对数票房",varwidth=T)                    ##上映档期箱线图

table(a$distribute)                                                        ##宣发公司统计
boxplot(log(boxoffice)~distribute,xlab="宣发公司",
        data=a,col="dodgerblue",ylab="对数票房",varwidth=T)                ##宣发公司箱线图

par(mfrow=c(2,2))                                                          ##输出22列图形
boxplot(log(boxoffice)~reality,data=a,col=c("dodgerblue"),
        ylab="对数票房",xlab="是否真实",varwidth=T)                        ##是否真实
boxplot(log(boxoffice)~story,data=a,col=c("indianred1"),
        ylab="",xlab="是否改编",varwidth=T)                                ##是否原创
boxplot(log(boxoffice)~remake,data=a,col=c("lightgreen"),
        ylab="",xlab="是否翻拍",varwidth=T)                                ##是否翻拍
boxplot(log(boxoffice)~sequel,data=a,col=c("purple"),
        ylab="",xlab="是否有续集",varwidth=T)                              ##是否续集

par(mfrow=c(1,2))                                                          ##输出12列图形
boxplot(log(boxoffice)~导演得奖情况,data=a,col=c("indianred1"),
        ylab="对数票房",xlab="",main="导演获奖 vs 票房",varwidth=T)        ##导演是否获奖
boxplot(log(boxoffice)~导演是否转型,data=a,col=c("purple"),
        ylab="",xlab="",main="导演转型 vs 票房",varwidth=T)                ##导演是否转型
par(mfrow=c(1,1))  
## 在比较导演年代时,我建议把3040的统计归为50年代以下,这样不需要删样本
boxplot(log(boxoffice)~导演年代,data=a,col=c("orange"),                    ##不同年代导演的区别
        ylab="对数票房",xlab="导 演 年 代",varwidth=T)
table(a$导演年代)
summary(a$boxoffice)
lm=lm(log(boxoffice)~genre+as.factor(year)+runtime+dangqi+distribute
      +reality+story+remake+sequel+导演得奖情况+导演是否转型,data=a)    ##拟合线性模型
summary(lm)                                                                ##给出估计结果
lm_s<-step(lm,direction="both")
summary(lm_s)
plot(resid(lm_s)~predict(lm_s))
abline(h=0)
sum(resid(lm_s)^2)/sum(predict(lm_s))

在这里插入图片描述
在这里插入图片描述

5 建模与评估

lm=lm(log(boxoffice)~genre+as.factor(year)+runtime+dangqi+distribute
      +reality+story+remake+sequel+导演得奖情况+导演是否转型,data=a)    ##拟合线性模型
summary(lm)                                                                ##给出估计结果
lm_s<-step(lm,direction="both")
summary(lm_s)
plot(resid(lm_s)~predict(lm_s))
abline(h=0)
sum(resid(lm_s)^2)/sum(predict(lm_s))

在这里插入图片描述
残差占比

在这里插入图片描述

6 残差分析

residplot=function(fit,nbreak=10){
  z=rstandard(fit)
  hist(z,breaks=nbreak,freq=F,xlab="Resuduals",main="Distribution of Errors")
  curve(dt(x,1),
        add=T,col="blue",lwd=2)
  curve(dnorm(x,mean =mean(z),sd=sd(z)),add=T,col="green",lwd=2)
  legend("topright",legend=c("Normal Curve","t curve"),lty=1:2,col=c("green","blue"),cex=0.8)
}

qqnorm(lm_s$residuals)
qqline(lm_s$residuals)
residplot(lm_s)

在这里插入图片描述

在这里插入图片描述
残差的结果符合正态性检验

7预测结果

library(car)
vif(lm_s)    #viff方差膨胀系数,用于检测多重共线性


##预测第一部电影的票房
b = read.csv("predict.csv", header = T)  
b<-dataclean(b)
bb = exp(predict(lm,b))
bb

在这里插入图片描述

【版权声明】本文为华为云社区用户原创内容,转载时必须标注文章的来源(华为云社区),文章链接,文章作者等基本信息,否则作者和本社区有权追究责任。如果您发现本社区中有涉嫌抄袭的内容,欢迎发送邮件至:cloudbbs@huaweicloud.com进行举报,并提供相关证据,一经查实,本社区将立刻删除涉嫌侵权内容。
  • 点赞
  • 收藏
  • 关注作者

评论(0

0/1000
抱歉,系统识别当前为高风险访问,暂不支持该操作

全部回复

上滑加载中

设置昵称

在此一键设置昵称,即可参与社区互动!

*长度不超过10个汉字或20个英文字符,设置后3个月内不可修改。

*长度不超过10个汉字或20个英文字符,设置后3个月内不可修改。