close_btn
?

단축키

Prev이전 문서

Next다음 문서

+ - Up Down Comment Print Files
?

단축키

Prev이전 문서

Next다음 문서

+ - Up Down Comment Print Files
#1. NBA 회귀분석

rm(list=ls()) # 기존변수 제거

library(dplyr) # mutate사용하기 위한 패키지불러오기
library(psych) # 산점도 행렬 pairs.panels함수 이용하기 위한 패키지
library(stats)
#install.packages("car", repos=c("http://rstudio.org/_packages", "http://cran.rstudio.com"))
library(car)#다중공선성의 지표인 VIF를 확인할수있는 패키지


setwd("C:\\Users\\Dohyun\\Desktop\\regression")
list.files()
nba <- read.csv("NBA.csv",stringsAsFactors = F)


nba <- mutate(nba, ppm = (games*point)/minutes) # PPM변수 추가


nba <- nba[,-1]#이름은 데이터 분석에 영향을 주는 변수가 아니므로 제거


# PPM에 들어가는 변수들 제거 
#(명확한 인과관계를 가지므로 다른 변수의 영향력을 측정하는데 방해)
names(nba)

nba <- nba[,-2] # games제거
nba <- nba[,-2] # minutes 제거
nba <- nba[,-3] # point 제거

head(nba)

#산점도행렬
pairs.panels(nba[names(nba)]) 
산점도행렬.jpg


# 1) 단일변수의 히스토그램을 보면 대부분 정규성을 만족하는 것처럼 보이지만,
# height 변수의 경우, 키에 따라 포지션이 나뉘어서 봉우리가 두개인 쌍봉형태인것으로 보임.
# 그러므로 분석시에 height를 기반으로 가변수를 만들어서 분석.
# 그리고 age와 ppm의 산점도에서 마치 이차식의 위로볼록한 형태를 볼 수 있으므로,
# age^2항을 추가해주는 것도 확인해볼 필요가 있다.


# 2) assist와 rebound와 선형 관계가 어느정도 나타남.
# 상관계수가 0.6 
# 따라서 다중공선성이 존재하는 것을 의심해 볼 수 있다.


#height변수의 히스토그램이 쌍봉형태.
# 점수를 따는 포지션이 따로 있을 것으로 추측
#따라서 포지션을 나누어 본다.

#키에 관한 가변수 position 생성
nba <- mutate(nba, position = height)
mean(nba$height)# 평균이 190이네
median(nba$height) # 중앙값 191 평균과 비슷

#키190을 기준으로 가변수 생성
nba$position[nba$position > 190] <- "A"
nba$position[nba$position <= 190] <- "B"
head(nba)

#그냥 회귀식 적합
fit1 <- lm(ppm~., data=nba)
summary(fit1)
#수정된 결정계수 0.2751 너무 낮다.
#rebound,fieldgoal빼고 모두 p-value가  
#유의수준(0.05기준)보다 커서 유의하지 않게나옴.
#이상치 등을 제거해서 보완이 필요해보임


#age 이차항까지 더해서 회귀식 적합
fit2 <- lm(ppm ~ height+age+I(age^2)+assist+rebound+fieldgoal+freethrow + position, data=nba)
summary(fit2)
#일단 수정된 결정계수값 0.2798 조금올랐지만 여전히 낮다. 
#산점도 보고 특이값이나 영향력관측치를 제거해야할듯


#일단 결과를 살펴보면
#유의수준을 0.05로 잡았을때, 그보다 p-value가 큰 경우는
#유의하지 않은 변수라고 볼 수 있다. 결과로 볼때  
#rebound,fieldgoal를 제외한 나머지 변수는 유의하지 않은 변수로 나타난다.
#우선 특이값이 있는지 살펴보겠다.

opar <- par(mfrow = c(2, 2))
plot(fit2) # 잔차 관련 산점도 그리기
par(opar)
산점도1.jpg

#잔차 분석에 관한 얘기는 최종모형에서 하고,
#우선 특이값 91, 104,105번째 관측치,
#2, 105번째 관측치도 특이값, 70번째 관측치가 높은 지렛값으나 나타난다. 


nba1<-nba # nba보존을 위해
nba <- nba1

#특이값, 높은 지렛값 제거
a<-c(2,70,91,104,105)
nba <- nba[-a,]

#특이값, 영향력관측치 제거후 다시 모델적합
fit3 <- lm(ppm ~ height+age+I(age^2)+assist+rebound+fieldgoal+freethrow + position, data=nba)
summary(fit3)
#수정된 결정계수 0.3572로 많이 오름. 그러나 여전히 좀 작다..
#rebound, fieldgoal,freethrow의 변수가 유의해졌다(p-value가 유의수준보다 작아짐)


#다시 잔차산점도 확인

opar <- par(mfrow = c(2, 2))
plot(fit3) # 잔차 관련 산점도 그리기
par(opar)
산점도2.jpg

#19,25,64번째 관측치가 특이값 
#71이 높은 지렛값
#결정계수가 높아야 모형의 적합도가 높은 것이므로 그걸 높이기 위해 다시 제거해본다.
#근데 왜인지모르게 순서가 맨처음 nba데이터가 기준이되어서 제대로 제거가 안됨.

#그래서
nba <- nba1 # nba 데이터 소생
b<-c(2,70,91,104,105,19,25,64,71) #아까 제거했던거에 추가제거
nba <- nba[-b,]

#다시 회귀식 적합
fit4 <- lm(ppm ~ height+age+I(age^2)+assist+rebound+fieldgoal+freethrow + position, data=nba)
summary(fit4)
#수정된 결정계수 0.3904 좀 더 오르긴했다..
#유의한 변수는 여전히 rebound, fieldgoal,freethrow 셋뿐

opar <- par(mfrow = c(2, 2))
plot(fit4) # 잔차 관련 산점도 그리기
par(opar)

산점도3.jpg

#우선 이정도면 큰 이상치들은 대개 제거한 것 같다.


vif(fit4)#다중공선성의 지표인 VIF체크

vif.jpg

# age와 age^2은 당연히 상관이 있으므로 다중공선성이 존재.
# VIF기준은 다 다른듯

# 저는 학교에서 회귀분석 시간에 배울 때 10이상이어야 다중공선성이 존재한다고 배웠는데
# 구글링해보니까 2.5라는 사람도 있고
#sqrt(vif)값이 2보다 크면, 즉 VIF가 4보다 크면 다중공선성이 있다고 판단하는 사람도 있네요.
# 개인차가 좀 있는것 같음.

#여튼 다중공선성이 존재하면 우선 '하나만' 먼저 제거한 후 다중공선성이 있는지 재확인해야한다.
# 보통 하나의 변수만 제거하면 대개 다중공선성은 해결되기 때문.


fit.con <-lm(ppm~1,data=nba) #상수항으로만 적합한 회귀식 생성

#stepwise 회귀식 적합 / 단계별 회귀
fit.both <- step(fit.con, scope=list(lower=fit.con , upper= fit4), direction = "both")

summary(fit.both) 
#적합된 결과를보면 age, age^2 , height , position은 모두 제거됨
#남은 변수들(fieldgoal,rebound,freethrow,assist)는 모두 유의하다(p-value가 유의수준 0.05보다 작음)


vif(fit.both)
#단계별회귀로 다른 변수를 제거했더니 작아졌음을 확인할 수 있다.
#모든 변수의 VIF값이 2 이하이므로 다중공선성 문제또한 해결되었음을 볼 수 있다.

#간단하게 잔차분석을 하자면
opar <- par(mfrow = c(2, 2))
plot(fit.both) # 잔차 관련 산점도 그리기
par(opar)
잔차분석.jpg
#그린 plot으로 간단하게 잔차분석을 해보자

# Residuals vs Fitted (잔차 대 예측값? 적합값?) 의 산점도에서 
#특정한 경향을 나타내지 않고 랜덤하게 나타나므로 등분산성을 만족한다고 할 수 있다.

# Normal Q-Q plot에서 잔차들이 대부분 직선 위에 있으므로, 정규성을 만족한다고 볼 수 있다.

# Scale-Location 은 표준화잔차에 루트씌운 값 vs 예측값(적합값?)의 산점도인데 
#이것도 등분산성을 판단하는 데 참고한다. 

#  Residuals vs Leverage (잔차 대 지렛값)의 산점도에서 위쪽으로 벗어난 값은 특이값
# x축에서 오른쪽으로 벗어난값은 높은지렛값으로 영향력 관측치를 보기 위함인 것 같다.

nba <- nba1 # 본래 nba 데이터 소생(결측치 제거 전) 
pre_ppm<- predict(fit.both, newdata = nba)

#회귀식을 바탕으로 계산한 ppm의 예측값 확인
pre_ppm<- as.data.frame(pre_ppm)

#실제 ppm값

summary(nba$ppm)
#대충 어느정도 값을 가지는지 체크
#최소 0.1593, 최대 0.8291

real_ppm <- as.data.frame(nba$ppm)

#차이가 얼마나 날까?
gap <- pre_ppm - real_ppm
gap
gap[abs(gap) > 0.1]
#차이가 0.1이상나는게 26개임을 확인해볼 수 있다.
#수정된 결정계수 0.4쯤 인것치고는 예측률 꽤 높은 편인듯.
#터무니 없이 차이가 많이나는건 제거했던 특이값들일 것이다.

which(abs(gap) > 0.2)
#아까 제거했던 결측치들이 2,70,91,104,105,19,25,64,71인데
#차이가 큰것은 2  70  91 104 105로 제거했던 것이 확인 가능.


--------------------------------------------------------------------------------------
  
  #2. adult 로지스틱회귀, 나이브베이즈, 의사결정나무
  
  rm(list=ls()) # 기존변수 제거

library(stats)
library(arules)

setwd("C:\\Users\\Dohyun\\Desktop\\regression\\adult")
list.files()
adult <- read.csv("train_adult.csv",stringsAsFactors = F)

head(adult)
adult <- adult[,-1]#
adult <- adult[,-1]# 일련번호 두개 제거
adult <- adult[,-14] # 출신국가는 대부분 미국이므로 제거. 아니면 미국인과 그 외로 분류해도 좋을듯


#capital.gain과 capital.loss 범주화 필요

e <- adult$capital.gain
e[adult$capital.gain == 0 ] <- "없음"
e[adult$capital.gain>0&adult$capital.gain<=5000] <- "5000이하"
e[adult$capital.gain>5000&adult$capital.gain<=10000] <- "5000~10000"
e[adult$capital.gain>10000&adult$capital.gain<=15000] <- "10000~15000"
e[adult$capital.gain>15000&adult$capital.gain<=20000] <- "15000~20000"
e[adult$capital.gain>20000] <- "20000초과"
table(e)
adult$capital.gain <- e

f <- adult$capital.loss
f[adult$capital.loss == 0 ] <- "없음"
f[adult$capital.loss>0&adult$capital.loss<=2000] <- "2000이하"
f[adult$capital.loss>2000] <- "2000초과"
table(f)
adult$capital.loss <- f

#회귀분석을 위해 income 변환
adult$income[adult$income=="small"] <- 0
adult$income[adult$income=="large"] <- 1
adult$income <- as.factor(adult$income)

head(adult)


#결측치가 존재할경우엔 다양한 대치법이 존재하지만,
#결측치가 있는 데이터는 불완전하므로, 제거하는 방법 사용
sum(is.na(adult)) # 결측치 총 2468개.. 뭐이리 많지ㅋㅋㅋㅋ 10분의1 넘게 결측치 포함이네
colSums(is.na(adult)) # workclass랑 occupation에만 결측치존재
adult <- na.omit(adult) # 결측값이 포함된 행 통채로 제거
head(adult)#아까 head에서 보였던 결측치하나가 사라졌음을 확인할 수 있음

# y(income)이 범주형이므로 로지스틱회귀분석
lfit <- glm(income~., data=adult, family = "binomial")
summary(lfit)

#predict 결과 미리테스트
predict<-predict(lfit,type='response')
head(predict)
predict[predict >= 0.5 ] <- 1
predict[predict < 0.5 ] <- 0
head(adult$income) #오 얼추 맞음

#모델적합 단계별(stepwise) 
lfit.con <- glm(income~1,data=adult, family = "binomial")
lfit.step <- step(lfit.con, scope=list(lower=lfit.con, upper= lfit), direction = "both")
summary(lfit.step)

#예측결과나 보자. 
test <- read.csv("test_adult.csv",stringsAsFactors = F)
head(test)


#그전에 예측데이터 다듬기

test <- test[,-1]#
test <- test[,-1]# 일련번호 두개 제거
test <- test[,-14] # 출신국 제거


#capital.gain과 capital.loss 범주화 필요

e <- test$capital.gain
e[test$capital.gain == 0 ] <- "없음"
e[test$capital.gain>0&test$capital.gain<=5000] <- "5000이하"
e[test$capital.gain>5000&test$capital.gain<=10000] <- "5000~10000"
e[test$capital.gain>10000&test$capital.gain<=15000] <- "10000~15000"
e[test$capital.gain>15000&test$capital.gain<=20000] <- "15000~20000"
e[test$capital.gain>20000] <- "20000초과"
table(e)
test$capital.gain <- e

f <- test$capital.loss
f[test$capital.loss == 0 ] <- "없음"
f[test$capital.loss>0&test$capital.loss<=2000] <- "2000이하"
f[test$capital.loss>2000] <- "2000초과"
table(f)
test$capital.loss <- f

# income
test$income[test$income=="small"] <- 0
test$income[test$income=="large"] <- 1
test$income <- as.factor(test$income)

#결측치제거
sum(is.na(test)) 
colSums(is.na(test)) # workclass랑 occupation에만 결측치존재
test <- na.omit(test)

#테스트해보기

pre_test <- predict(lfit.step, newdata=test ,type='response')

pre_test[pre_test >= 0.5 ] <- 1
pre_test[pre_test < 0.5 ] <- 0


table(pre_test, test$income) 
# 예측결과확인 
# 전체데이터 9163개중 틀린거 1371개


#나이브베이즈 이전데이터 adult, test 그대로 사용
library(e1071)

nb <- e1071::naiveBayes(income ~ ., data=adult) 
# income이 종속변수, income 제외하고 나머지
table(predict(nb, test), test$income) 
#전체데이터 9163개중 틀린거 1908개


#의사결정나무
library(rpart)
rp <- rpart(income~., data=adult)
rp_pre<-predict(rp, newdata=test)
head(rp_pre)
rp_pre <- rp_pre[,-1]
rp_pre[rp_pre < 0.5 ] <- 0
rp_pre[rp_pre >= 0.5 ] <- 1


table(rp_pre, test$income) 
#전체데이터 9163개 중 틀린거 1481개


# 결과정리
# 전체데이터 9163개중
# 로지스틱 오차갯수 1371개, 일치율 85.0377% 
# 나이브베이즈 오차갯수 1908개, 일치율 79.1771%
# 의사결정나무 1481개 , 일치율 83.8371%
# 로지스틱이 제일 오래걸리지만 제일 예측도가 높음.
  • ?
    2016.03.03 22:59
    뭐이리 많지ㅋㅋㅋㅋ 뭐이리 많지ㅋㅋㅋㅋ 뭐이리 많지ㅋㅋㅋㅋ ㅋㅋㅋㅋㅋㅋㅋㅋㅋㅋㅋ 그런데 알빈이 뭐에요?
  • ?
    알빈 2016.03.06 02:05
    초딩때 다녔던 영어학원에서 쓰던 영어이름 제맘대로 발음한거요ㅋㅋㅋㅋㅋ
  • ?
    Alan 2016.03.06 15:48
    와... 그래프 ㅋㅋㅋㅋㅋ 정성 가득 감사합니다

List of Articles
번호 제목 글쓴이 날짜 조회 수
공지 우수 코드 게시판 이용 관련 공지사항 DataMarket 2014.05.21 39655
53 투빅스 5&6기 2주차과제 1번 회귀분석 -6기 한동훈 2 file 투빅스6기한동훈 2016.08.04 11245
52 투빅스 5&6기 2주차 과제 2번 마방진 만들기 - 6기 임진주 4 file 진주 2016.08.04 10958
51 투빅스 5&6기 1주차 과제 2번 재석 2016.07.28 9416
50 5&6기 1주차 과제 1번 - 6기 이윤섭 겨뽀 2016.07.28 10122
49 투빅스 5&6기 1주차 과제코드 Alan 2016.07.27 9557
48 크롤링 - 전국 이디야 매장정보를 중심으로 (5기 이승은) 2 file 켜져있는멀티탭 2016.03.26 26750
47 crawling - 5기 이제형 4 trevor 2016.03.24 14413
46 PCA (주성분 분석) - 5기 이제형 trevor 2016.03.09 14750
45 NBA data 회귀분석 / Adult data 로지스틱 회귀분석, 나이브베이즈, 의사결정나무 - 5기 정현재 2 file 정현재 2016.03.03 17936
» NBA 회귀분석 / adult 로지스틱회귀, 나이브베이즈, 의사결정나무 - 5기 최도현 3 file 알빈 2016.03.03 20270
43 K-Means Funtion (5기 이제형) 3 trevor 2016.02.25 13734
42 박이삭_기초스터디__반복문 및 apply함수 및 데이터프레임다루기 지니상 2016.02.12 10685
41 최도현_기초스터디_R기초 지니상 2016.02.12 11377
40 양우식_기초스터디_dplyr_sqldf 지니상 2016.02.12 12171
39 이정민_기초스터디_stringr패키지 지니상 2016.02.12 17660
38 고가영_기초스터디_파일불러오기 및 Rmarkdown 지니상 2016.02.12 13563
37 입출금 처리 프로그램 (4주차 과제) - 5기 방정훈 file Alan 2016.02.10 12430
36 연관성 분석(3주차 과제) & KNN 함수만들기(3주차 과제) - 4기 김선지 순지 2016.02.09 13667
35 연관성 분석(3주차 과제) - 5기 이정민 1 file 쩡마 2016.02.07 14118
34 KNN 함수만들기 (3주차 과제) - 5기 방정훈 Alan 2016.02.03 14394
Board Pagination ‹ Prev 1 ... 2 3 4 5 6 7 ... 8 Next ›
/ 8

나눔글꼴 설치 안내


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

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

설치 취소

Designed by sketchbooks.co.kr / sketchbook5 board skin

Sketchbook5, 스케치북5

Sketchbook5, 스케치북5

Sketchbook5, 스케치북5

Sketchbook5, 스케치북5