close_btn
?

단축키

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')

Regression.jpeg
#다중공산성 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")

roc curve.jpeg
  • ?
    2016.03.03 22:58

    와....정리 엄청 깔끔하게 잘 해주셨네요 고생했구 시험 잘보구 합격후기 들려줘요 ㅋㅋ

  • ?
    Alan 2016.03.06 15:45
    와 쩐당...

List of Articles
번호 제목 글쓴이 날짜 조회 수
공지 우수 코드 게시판 이용 관련 공지사항 DataMarket 2014.05.21 41264
87 투빅스 7&8기 6주차 과제 TF-IDF 문서유사도 측정 - 8기 최서현 최서현 2017.08.31 8103
86 투빅스 7&8기 5주차 과제 Selenium Crawling - 8기 김강열 김강열 2017.08.24 7365
85 투빅스 7&8기 5주차 과제 Image Augmentation - 8기 김민정 김소희 최수정 황다솔 file 민정e 2017.08.24 7264
84 투빅스 7&8기 5주차 과제 Beautiful Soup 이용한 Crawling - 8기 류호성 file 류호성 2017.08.24 7293
83 투빅스 7&8기 4주차 과제 tree, RF, bagging, boosting 이용 분석 - 8기 조양규 file dial123 2017.08.17 7633
82 투빅스 7&8기 4주차 과제 의사결정나무&랜덤포레스트 - 8기 김강열 김강열 2017.08.17 7575
81 투빅스 7&8기 3주차 과제 클러스터링 구현 - 8기 권문정 김강열 이현경 조양규 1 이현경 2017.08.10 8184
80 투빅스 7&8기 3주차 과제 PCA - 8기 이현경 file 이현경 2017.08.12 7191
79 투빅스 7&8기 2주차 과제 연관성 분석 - 8기 조양규 file dial123 2017.08.03 8345
78 투빅스 7&8기 2주차 과제 나이브베이즈 구현 - 8기 이현경 file 이현경 2017.08.03 8125
77 투빅스 7&8기 2주차 과제 로지스틱/Ridge/Lasso&알고리즘 - 8기 김강열 file 김강열 2017.08.03 7797
76 투빅스 7&8기 1주차 과제 알고리즘 - 8기 김강열 file 김강열 2017.07.27 7424
75 투빅스 7&8기 1주차 과제 회귀분석 - 8기 황다솔 file 다솔 2017.07.27 7637
74 투빅스 6&7기 8주차 과제 PCA(주성분 분석) - 7기 이동수 1 탱탱볼 2017.03.18 10321
73 투빅스 6&7기 8주차 과제 LBP 알고리즘 구현 - 7기 이광록 1 file 2017.03.16 9554
72 투빅스 6&7기 8주차 과제 SVM - 7기 이광록 1 file 2017.03.16 10344
71 투빅스 6&7기 6주차 과제 소멸언어 분류 예측 데이터분석 - 이동수(7기) 2 file 탱탱볼 2017.03.02 11957
70 투빅스 6&7기 5주차 과제 의사결정나무&앙상블 - 7기 최희정 2 file 히둥 2017.02.23 15497
69 투빅스 6&7기 4주차 과제 K-means 분석 및 구현 - 7기 이광록 2 2017.02.19 11069
68 투빅스 6&7기 4주차 과제 KNN 구현 - 전종섭(7기) 2 뻐엉 2017.02.16 10906
Board Pagination ‹ Prev 1 ... 2 3 4 5 6 7 8 9 ... 10 Next ›
/ 10

나눔글꼴 설치 안내


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

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

설치 취소

Designed by sketchbooks.co.kr / sketchbook5 board skin

Sketchbook5, 스케치북5

Sketchbook5, 스케치북5

Sketchbook5, 스케치북5

Sketchbook5, 스케치북5