맨위로 컨텐츠 아래로

Home ›커뮤니티 ›우수 코드 공유

✔ 뷰어로 보기

2016.03.03 20:30

NBA data 회귀분석 / Adult data 로지스틱 회귀분석, 나이브베이즈, 의사결정나무 - 5기 정현재

정현재

조회 수 59824 추천 수 0 댓글 2

단축키

Prev이전 문서

Next다음 문서

가 + - Up Down Comment Print Files

단축키

Prev이전 문서

Next다음 문서

가 + - Up Down Comment Print Files

NBA data 회귀분석

rm(list=ls())

#데이터 불러오기

nba <- read.csv(file="C:/toBigs/6주차/NBA.csv",stringsAsFactors = F)

#데이터 탐색

head(nba)

dim(nba) # 105 row 10 column

summary(nba)

# 목표변수 생성(Point per minutes) - ppm

nba$ppm<-nba$games*nba$point/nba$minutes

# 목표변수 분포 파악해보기

# 히스토그램과 박스플랏을 통해서 정규분포와 같은 모양이지만 이상치일 수 있는 값들이 존재하고 있음을 알 수 있었다.

summary(nba$ppm)

hist(nba$ppm,breaks=10)

boxplot(nba$ppm)

# 잘못된 데이터 처리 - height를 numeric으로 변환

for(i in 1:length(letters)){

nba[,2]<-gsub(letters[i],"",nba[,2])

}

nba[,2] <- as.numeric(nba[,2])

#필요없는 열 삭제

nba<-nba[,-1]

# histogram을 통해 각 변수들의 분포 파악

hist(nba$height,breaks=10)

hist(nba$games,breaks=10)

hist(nba$minutes,breaks=10)

hist(nba$age,breaks=10)

hist(nba$point,breaks=10)

hist(nba$assist,breaks=10)

hist(nba$rebound,breaks=10)

hist(nba$fieldgoal,breaks=10)

hist(nba$freethrow,breaks=10)

# 상관관계 알아보기 - 상관관계가 높은 변수는 제거하기 위해서

# minutes은 games, point, assist, rebound와 상관성이 높다는 것을 확인했기 때문에 제거하기로 결정

library(psych)

pairs.panels(nba[,-10])

# 추가적으로 지워야할 변수

## games는 point, assist, rebound 변수를 구할 때 per game으로 구했기 때문에 제거하기로 결정

## point 역시 결과변수를 만드는 데 사용되었기 때문에 제거하기로 결정

data<-nba[,-c(2,3,5)]

#train / test 생성

set.seed(100)

index<-sample(nrow(data),size=nrow(data)*0.7)

data_train <- data[index,]

data_test <- data[-index,]

#회귀분석 실시

data.lm<-lm(ppm~.,data=data_train)

data.con<-lm(ppm~1.,data=data_train)

data.step<-step(data.con,scope=list(upper=data.lm,lower=data.con,direction="both"))

summary(data.step)

x11()

par(mfrow=c(2,2))

plot(data.step)

#잔차는 정규분포를 이루고 있는 것을 확인 - 정상성

#그래프를 확인해본 결과, row.num이 104번인 것은 모델로 설명이 안된다고 판단(아웃라이어)

#생성된 모델을 test set에 적용

fit_value <- predict(data.step,data_test[,-8],interval='prediction',level=0.95)

head(fit_value)

par(mfrow=c(1,2))

#실제 목표값들을 시각화

plot(data_test[,7],ylim=c(0,1.2),ylab='ppm',main='Regression Model')

#추정한 값을 선으로 표현 - 회귀식

lines(fit_value[,1],lwd=2)

#upper과 lower를 각각 점선으로 표현 - 구간추정

lines(fit_value[,2],lty=9,lwd=2,col='blue')

lines(fit_value[,3],lty=9,lwd=2,col='blue')

#아웃라이어 테스트 해보기

#row num 104번이 아웃라이어라는 결과를 알 수 있었다.

library(car)

outlierTest(data.step)

#아웃라이어인 104번 제거한 데이터

#위의 방법과 같은 방식으로 회귀분석 실시

data_train_out<-data_train[-which(row.names(data_train)==104),]

data.lm.out<-lm(ppm~.,data=data_train_out)

data.con.out <- lm(ppm~1.,data=data_train_out)

data.step.out<-step(data.con.out,scope=list(upper=data.lm.out,lower=data.con.out,direction="both"))

summary(data.step.out)

fit_value_2<-predict.lm(data.step.out,data_test[,-8],interval='prediction',level=0.95)

plot(data_test[,7],ylim=c(0,1.2),ylab='ppm',main='Regression Model(Outlier.delete)')

lines(fit_value_2[,1],lwd=2)

lines(fit_value_2[,2],lty=9,lwd=2,col='blue')

lines(fit_value_2[,3],lty=9,lwd=2,col='blue')

#다중공산성 vif함수 - car packages

#보통 10을 넘어가면 다중공산성 문제를 가지고 있다고 판단 - 이상없음

vif(data.step)

vif(data.step.out)

#SSE로 모델 평가해보기

##아웃라이어 제거하지 않은 모델

sse<-sum((data_test[,7]-fit_value[,1])^2)

sse #0.5064937

##아웃라이어 제거한 모델

sse_2<-sum((data_test[,7]-fit_value_2[,1])^2)

sse_2 #0.5917317

-----------------------------------------------------------------------------------------------------------------------------------------------

Adult data 로지스틱 회귀분석, 나이브베이즈, 의사결정나무

rm(list=ls())

library(ROCR) # ROC curve를 그리기 위한 패키지 'ROCR'

#데이터 불러오기

adult_train<-read.csv(file="C:/toBigs/6주차/train_adult.csv",stringsAsFactors = F)

adult_test<-read.csv(file="C:/toBigs/6주차/test_adult.csv",stringsAsFactors=F)

#데이터 탐색

head(adult_train)

dim(adult_train) # 48842 / 16

summary(adult_train)

str(adult_train)

#NA값 제거하기

aa <- is.na(adult_train)

index<-sapply(1:nrow(adult_train),function(i) any(aa[i,]))

adult_train_2<-adult_train[!index,]

summary(adult_train_2)

#가중치의 의미를 지닌 fnlwgt는 제거하고

#education.num은 education을 숫자적으로 표현한 것이라 중복되는 열이라 판단하여 제거

adult_train2<-adult_train_2[,-c(1,2,5,7)]

head(adult_train2)

str(adult_train2)

#의사결정나무와, 나이브베이즈를 위한 데이터 전처리

##나이 나누기 20, 30, 40, 50, other

adult_train2$age[which(adult_train2$age<20)] <- '10s'

adult_train2$age[which(adult_train2$age>=20&adult_train2$age<30)] <- '20s'

adult_train2$age[which(adult_train2$age>=30&adult_train2$age<40)] <- '30s'

adult_train2$age[which(adult_train2$age>=40&adult_train2$age<50)] <- '40s'

adult_train2$age[which(adult_train2$age>=50)] <- 'other'

##북미 지역이 19373개로 대다수를 차지하기 때문에 북미와 북미가 아닌 것으로

adult_train2$native.country[which(adult_train2$native.country=='Canada')] <- 'North_Ame'

adult_train2$native.country[which(adult_train2$native.country=='United-States')] <- 'North_Ame'

adult_train2$native.country[which(adult_train2$native.country!='North_Ame')] <- 'etc'

##education column 1st - 12th 값들 범주화

adult_train2$education[which(adult_train2$education=='10th')] <- 'HS-undergrad'

adult_train2$education[which(adult_train2$education=='11th')] <- 'HS-undergrad'

adult_train2$education[which(adult_train2$education=='12th')] <- 'HS-undergrad'

adult_train2$education[which(adult_train2$education=='1st-4th')] <- 'HS-undergrad'

adult_train2$education[which(adult_train2$education=='5th-6th')] <- 'HS-undergrad'

adult_train2$education[which(adult_train2$education=='7th-8th')] <- 'HS-undergrad'

adult_train2$education[which(adult_train2$education=='9th')] <- 'HS-undergrad'

## capital.loss - 0인 row가 20149개이기 때문에 0인것과 0보다 큰것으로 범주화

adult_train2$capital.loss[which(adult_train2$capital.loss>0)]<-'capital.loss>0'

adult_train2$capital.loss[which(adult_train2$capital.loss=='0')]<-'capital.loss=0'

## capital.gain - 0인 row가 19379개이기 때문에 0인것과 0보다 큰것으로 범주화

adult_train2$capital.gain[which(adult_train2$capital.gain>0)]<-'capital.gain>0'

adult_train2$capital.gain[which(adult_train2$capital.gain=='0')]<-'capital.gain=0'

##hours.per.week

adult_train2$hours.per.week[which(adult_train2$hours.per.week<=40)]<-'hours<=40'

adult_train2$hours.per.week[which(adult_train2$hours.per.week!='hours<=40')]<-'hours>40'

##테스트 데이터셋 위와 같이 전처리하기

aaa <- is.na(adult_test)

index<-sapply(1:nrow(adult_test),function(i) any(aaa[i,]))

adult_test_2<-adult_test[!index,]

adult_test2<-adult_test_2[,-c(1,2,5,7)]

adult_test2$age[which(adult_test2$age<20)] <- '10s'

adult_test2$age[which(adult_test2$age>=20&adult_test2$age<30)] <- '20s'

adult_test2$age[which(adult_test2$age>=30&adult_test2$age<40)] <- '30s'

adult_test2$age[which(adult_test2$age>=40&adult_test2$age<50)] <- '40s'

adult_test2$age[which(adult_test2$age>=50)] <- 'other'

adult_test2$native.country[which(adult_test2$native.country=='Canada')] <- 'North_Ame'

adult_test2$native.country[which(adult_test2$native.country=='United-States')] <- 'North_Ame'

adult_test2$native.country[which(adult_test2$native.country!='North_Ame')] <- 'etc'

adult_test2$education[which(adult_test2$education=='10th')] <- 'HS-undergrad'

adult_test2$education[which(adult_test2$education=='11th')] <- 'HS-undergrad'

adult_test2$education[which(adult_test2$education=='12th')] <- 'HS-undergrad'

adult_test2$education[which(adult_test2$education=='1st-4th')] <- 'HS-undergrad'

adult_test2$education[which(adult_test2$education=='5th-6th')] <- 'HS-undergrad'

adult_test2$education[which(adult_test2$education=='7th-8th')] <- 'HS-undergrad'

adult_test2$education[which(adult_test2$education=='9th')] <- 'HS-undergrad'

adult_test2$capital.loss[which(adult_test2$capital.loss>0)]<-'capital.loss>0'

adult_test2$capital.loss[which(adult_test2$capital.loss=='0')]<-'capital.loss=0'

adult_test2$capital.gain[which(adult_test2$capital.gain>0)]<-'capital.gain>0'

adult_test2$capital.gain[which(adult_test2$capital.gain=='0')]<-'capital.gain=0'

adult_test2$hours.per.week[which(adult_test2$hours.per.week<=40)]<-'hours<=40'

adult_test2$hours.per.week[which(adult_test2$hours.per.week!='hours<=40')]<-'hours>40'

#decision tree를 위해 전처리된 데이터 확인

str(adult_tarin2)

str(adult_test2)

#의사결정나무 분석실시

library(rpart)

library(rpart.plot)

library(rattle)

library(RColorBrewer)

adult_rp<-rpart(income~., adult_train2)

rattle::fancyRpartPlot(adult_rp)

printcp(adult_rp)

#최적의 임계치는 0.01

adult_rp$cptable[which.min(adult_rp$cptable[,"xerror"]),1]

dt_tb<-table(predict(adult_rp,adult_test2[,-13],type='class'),adult_test2[,13])

dt_tb #정분류율 7403/9001 = 0.822 82%

#같은 데이터로 나이브 베이즈 분석

#나이브베이즈를 위하여, character를 factor형으로 변환

adult_train2_nb <- adult_train2

adult_test2_nb <- adult_test2

for(i in 1:13){

adult_train2_nb[,i] <- as.factor(adult_train2[,i])

adult_test2_nb[,i] <- as.factor(adult_test2[,i])

}

#나이브베이즈 분석 실시

library(e1071)

library(MASS)

adult_nb<-e1071::naiveBayes(income~.,data=adult_train2_nb, laplace = 0)

adult_nb

adult_nb$apriori

adult_nb$tables

adult_nb$levels

adult_nb$call

summary(adult_nb)

nb_tb<-table(predict(adult_nb,adult_test2[,-13]),adult_test2[,13])

nb_tb #정분류율 7269/9001 = 0.808 81%

#logistic을 위한 데이터 전처리 실시

#연속형 변수들은 원래 상태로 변환

#목표치인 income변수는 large = 1, small = 0 으로 변환

adult_train3<-adult_train2

adult_test3<-adult_test2

adult_train3$age <-adult_train_2$age

adult_train3$capital.gain <-adult_train_2$capital.gain

adult_train3$capital.loss <-adult_train_2$capital.loss

adult_train3$hours.per.week <-adult_train_2$hours.per.week

adult_train3$income[which(adult_train3$income=='large')] <- 1

adult_train3$income[which(adult_train3$income=='small')] <- 0

adult_train3$income<-as.numeric(adult_train3$income)

adult_test3$age <-adult_test_2$age

adult_test3$capital.gain <-adult_test_2$capital.gain

adult_test3$capital.loss <-adult_test_2$capital.loss

adult_test3$hours.per.week <-adult_test_2$hours.per.week

adult_test3$income[which(adult_test3$income=='large')] <- 1

adult_test3$income[which(adult_test3$income=='small')] <- 0

adult_test3$income<-as.numeric(adult_test3$income)

#로지스틱 회귀분석을 위한 데이터확인

str(adult_train3)

str(adult_test3)

# 로지스틱 회귀분석 실시

adult.glm<-glm(income~.,data=adult_train3,family='binomial')

adult.con<-glm(income~1,data=adult_train3,family='binomial')

adult.step<-step(adult.con,scope=list(upper=adult.glm,lower=adult.con),direction="both")

summary(adult.step)

result<-predict(adult.step,adult_test3[,-13],type='response')

result<-round(result)

table(result,adult_test3[,13]) # 정분류율은 7645/9001 = 0.85 85%

#정분류율 정리

##의사결정나무 82%, 나이브베이즈 81%, 로지스틱 회귀분석 85%

x11()

par(mfrow=c(1,3))

#세 가지모델을 ROC curve를 통해 비교

#ROC curve - decision tree

dt_target<-predict(adult_rp,adult_test2[,-13],type='class')

#ROC curve를 그리기 위해 target변수들을 연속형 변수로 변환

#small은 0, large는 1

dt_target<-as.character(dt_target)

dt_target[which(dt_target=='small')] <- 0

dt_target[which(dt_target!='0')] <- 1

dt_target<-as.numeric(dt_target)

dt_label<-adult_test2[,13]

dt_label<-as.character(dt_label)

dt_label[which(dt_label=='small')] <- 0

dt_label[which(dt_label!='0')] <- 1

dt_label<-as.numeric(dt_label)

#prediction, performance함수를 사용하여 ROC curve 그리기

dt_pred<-prediction(dt_target,dt_label)

dt_perf<-performance(dt_pred,'tpr','fpr')

plot(dt_perf,col="green",lwd=2,main="ROC Curve for Decision Tree")

abline(a=0,b=1,lwd=2,lty=2,col="gray")

#AUC(Area Under the Curve) 도출

dt_auc <- performance(dt_pred,"auc")

dt_auc <- unlist(slot(dt_auc, "y.values"))

dt_auc<-round(dt_auc, digits = 2)

#AUC값 그래프에 나타내기

dt_auct <- paste(c("AUC = "),dt_auc,sep="")

legend(0.3,0.6,dt_auct,border="white",cex=1.7,box.col = "white")

#ROC curve - Naive

#위와 같은 방식으로 진행

nb_target<-predict(adult_nb,adult_test2[,-13])

nb_target<-as.character(nb_target)

nb_target[which(nb_target=='small')] <- 0

nb_target[which(nb_target!='0')] <- 1

nb_target<-as.numeric(nb_target)

label<-adult_test2[,13]

label<-as.character(label)

label[which(label=='small')] <- 0

label[which(label!='0')] <- 1

label<-as.numeric(label)

nb_pred<-prediction(nb_target,label)

nb_perf<-performance(nb_pred,'tpr','fpr')

plot(nb_perf,col="green",lwd=2,main="ROC Curve for Naive")

abline(a=0,b=1,lwd=2,lty=2,col="gray")

#AUC값 도출

nb_auc <- performance(nb_pred,"auc")

nb_auc <- unlist(slot(nb_auc, "y.values"))

nb_auc<-round(nb_auc, digits = 2)

nb_auct <- paste(c("AUC = "),nb_auc,sep="")

legend(0.3,0.6,nb_auct,border="white",cex=1.7,box.col = "white")

#Roc curve - Logistic

#이미 target변수들이 0과 1 로 연속형이기 때문에 따로 변환할 필요가 없음

glm_pred<-prediction(result,adult_test3[,13])

glm_perf<-performance(glm_pred,'tpr','fpr')

plot(glm_perf,col="green",lwd=2,main="ROC Curve for Logistic")

abline(a=0,b=1,lwd=2,lty=2,col="gray")

#AUC값 도출

glm_auc <- performance(glm_pred,"auc")

glm_auc <- unlist(slot(glm_auc, "y.values"))

glm_auc<-round(glm_auc, digits = 2)

glm_auct <- paste(c("AUC = "),glm_auc,sep="")

legend(0.3,0.6,glm_auct,border="white",cex=1.7,box.col = "white")

« Prev 인공신경망(Aritificial Neuron Network)

인공신경망(Aritificial Neuron Network) 2015.09.16by 자꾸생각나 〈

♥ 0

Atachment
첨부파일 '2'	Regression.jpeg, roc curve.jpeg,

List of Articles
번호	제목	글쓴이	날짜	조회 수
공지	우수 코드 게시판 이용 관련 공지사항	DataMarket	2014.05.21	327208
304	투빅스 9&10기 5주차 NLP Basic - 10기 장유영	장유영	2018.08.22	384476
303	투빅스 10기&11기 7주차 NLP - 11기 김유민	윰	2019.03.21	362644
302	투빅스 10기&11기 1주차 Algorithm - 11기 한재연 1	한재연	2019.01.31	198795
301	투빅스 10기&11기 2주차 SVM, Naive Bayes, KNN - 11기 김대웅	김대웅	2019.01.31	147639
300	투빅스 6&7기 2주차 과제 - 회귀분석 6기 장재석 2	재석	2017.02.04	134686
299	투빅스 10&11기 1주차 Logistic Regression - 11기 김대웅	김대웅	2019.01.23	117475
298	투빅스 11기&12기 4주차 Decision Tree - 12기 김탁영	탁	2019.08.17	116096
297	투빅스 9&10기 4주차 PCA-mnist - 10기 강인구	kaig	2018.08.16	106225
296	투빅스 7&8기 1주차 과제 알고리즘 - 8기 김강열	김강열	2017.07.27	105025
295	SNA(Social Network Analysis) 분석	바키똥	2015.04.03	94880
294	투빅스 9&10기 2주차 Naive Bayes - 10기 장유영 2	장유영	2018.08.01	91603
293	투빅스 7&8기 6주차 과제 TF-IDF 문서유사도 측정 - 8기 최서현	최서현	2017.08.31	87364
292	인공신경망(Artificial Neural Network) 분석 3	권도영	2015.04.13	79823
291	KNN (K-Nearest Neighbor)	바키똥	2015.09.28	71391
290	능형 회귀 분석	자꾸생각나	2015.05.05	65163
289	지도 만들기	조호	2015.04.15	63864
288	크롤링 - 전국 이디야 매장정보를 중심으로 (5기 이승은) 2	켜져있는멀티탭	2016.03.26	62741
287	인공신경망(Aritificial Neuron Network)	자꾸생각나	2015.09.16	60041
»	NBA data 회귀분석 / Adult data 로지스틱 회귀분석, 나이브베이즈, 의사결정나무 - 5기 정현재 2	정현재	2016.03.03	59824

나눔글꼴 설치 안내

이 PC에는 나눔글꼴이 설치되어 있지 않습니다.

이 사이트를 나눔글꼴로 보기 위해서는
나눔글꼴을 설치해야 합니다.

✔ 설치 취소

전체메뉴

데이터마켓