Assignment 3 - Diamond Price Estimation
Umut Mete Saka
Introduction
This Assignment aims to imply explanatory data analysis on diamonds data from ggplot2 package and build a multiple linear regression model on the data to predict the price indicator using the other inputs. This is going to be a supervised learning model.
Starting Points
First of all I am going to load required packages. My data is in the ggplot2 package which is in tidyverse. Therefore I do not need to import my data exclusively.
library(tidyverse)
library(lubridate)
library(tidyr)
library(knitr)
library(gridExtra)
library(tree)Now I can glimpse my data to understand its characteristics.
glimpse(diamonds)## Rows: 53,940
## Columns: 10
## $ carat <dbl> 0.23, 0.21, 0.23, 0.29, 0.31, 0.24, 0.24, 0.26, 0.22, 0.23, 0…
## $ cut <ord> Ideal, Premium, Good, Premium, Good, Very Good, Very Good, Ve…
## $ color <ord> E, E, E, I, J, J, I, H, E, H, J, J, F, J, E, E, I, J, J, J, I…
## $ clarity <ord> SI2, SI1, VS1, VS2, SI2, VVS2, VVS1, SI1, VS2, VS1, SI1, VS1,…
## $ depth <dbl> 61.5, 59.8, 56.9, 62.4, 63.3, 62.8, 62.3, 61.9, 65.1, 59.4, 6…
## $ table <dbl> 55, 61, 65, 58, 58, 57, 57, 55, 61, 61, 55, 56, 61, 54, 62, 5…
## $ price <int> 326, 326, 327, 334, 335, 336, 336, 337, 337, 338, 339, 340, 3…
## $ x <dbl> 3.95, 3.89, 4.05, 4.20, 4.34, 3.94, 3.95, 4.07, 3.87, 4.00, 4…
## $ y <dbl> 3.98, 3.84, 4.07, 4.23, 4.35, 3.96, 3.98, 4.11, 3.78, 4.05, 4…
## $ z <dbl> 2.43, 2.31, 2.31, 2.63, 2.75, 2.48, 2.47, 2.53, 2.49, 2.39, 2…There are 10 attributes in the data. These attributes are:
Carat : Weight of the diamond
Cut : Quality of the cut
Color : Diamond colour, from D (best) to J (worst)
Clarity : A measurement of how clear the diamond is (I1 (worst), SI2, SI1, VS2, VS1, VVS2, VVS1, IF (best))
Depth : Total depth percentage = z / mean(x, y)
Table : Width of top of diamond relative to widest point
Price : Price in US dollars Which is going to be my output in the predictive model
x : Length in mm
y : Width in mm
z : Depth in mm
I observe that there are 6 numerical input attributes. So I am going to see the correlation between these attributes and price.
Diamonds_num <- diamonds %>%
select(carat,depth,table,price,x,y,z)
kable(cor(Diamonds_num$price, Diamonds_num), caption = "Correlation between price")| carat | depth | table | price | x | y | z |
|---|---|---|---|---|---|---|
| 0.9215913 | -0.0106474 | 0.1271339 | 1 | 0.8844352 | 0.8654209 | 0.8612494 |
From the correlation table I can see that, carat, x, y and z have high positive correlation with price. However table and depth seems uncorrelated. So I am going to plot the correlated attributes with price.
plot1 <- Diamonds_num %>% select(-table, -depth) %>% filter(x>3)%>% ggplot(aes(price,x)) + geom_line(color = "blue")
plot2 <- Diamonds_num %>% select(-table, -depth) %>% filter(y<20) %>% ggplot(aes(price,y)) + geom_line(color = "red")
plot3 <- Diamonds_num %>% select(-table, -depth) %>% filter(z<10) %>% ggplot(aes(price,z)) + geom_line(color = "green")
plot4 <- Diamonds_num %>% select(-table, -depth) %>% ggplot(aes(price,carat)) + geom_line(color = "orange")
grid.arrange(plot1,plot2,plot3,plot4,nrow = 2)
Now I want to see the effect of the categorical variables on price. There are 3 categorical variables which are cut, color and clarity.
Diamonds_cat <- diamonds %>% select(price,cut,color,clarity)
Diamonds_cat %>% select(price,cut) %>% group_by(cut) %>% mutate(mean_price = mean(price)) %>% ggplot(aes(x = cut)) + geom_point(aes(y = mean_price),color = "blue",cex= 1.3) + geom_point(aes(y=mean(price)),color = "red",cex = 1) +xlab("Cut")+ylab("Price")+ggtitle("Price vs Cut")
It seems that some cut types has significant effect on the price. Premium and Fair cuts are much more expensive than average price and Ideal cut is much lower.
Diamonds_cat %>% select(price,color) %>% group_by(color) %>% mutate(mean_price = mean(price)) %>% ggplot(aes(x = color)) + geom_point(aes(y = mean_price),color = "blue",cex= 1.3) + geom_point(aes(y=mean(price)),color = "red",cex = 1) +xlab("Color")+ylab("Price")+ggtitle("Price vs Color")
Also Color seems to have significant effect on Price.
Diamonds_cat %>% select(price,clarity) %>% group_by(clarity) %>% mutate(mean_price = mean(price)) %>% ggplot(aes(x = clarity)) + geom_point(aes(y = mean_price),color = "blue",cex= 1.3) + geom_point(aes(y=mean(price)),color = "red",cex = 1) +xlab("Clarity")+ylab("Price")+ggtitle("Price vs Clarity")
Also some types of clarity has effect on price.
Predictive Models
First I will start with dividing data into test and train datasets. Train data set will use random 70% of the data.
set.seed(48)
a <- sample(1:nrow(diamonds),nrow(diamonds)*0.7)
diamonds_train <- diamonds[a,]
diamonds_test <- diamonds[-a,]Multiple Linear Regression
I am going to build a multiple linear regression model to predict the price. In my first model I am going to use every input attribute and see their significance levels.
model1 <- lm(price~.,diamonds_train)
summary(model1)##
## Call:
## lm(formula = price ~ ., data = diamonds_train)
##
## Residuals:
## Min 1Q Median 3Q Max
## -14942.1 -584.6 -182.5 374.9 10698.7
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 6341.544 459.401 13.804 < 2e-16 ***
## carat 11449.056 57.178 200.237 < 2e-16 ***
## cut.L 567.189 26.417 21.471 < 2e-16 ***
## cut.Q -284.168 21.098 -13.469 < 2e-16 ***
## cut.C 130.198 18.309 7.111 1.17e-12 ***
## cut^4 -6.709 14.598 -0.460 0.64584
## color.L -1962.658 20.515 -95.669 < 2e-16 ***
## color.Q -673.933 18.678 -36.081 < 2e-16 ***
## color.C -169.825 17.387 -9.767 < 2e-16 ***
## color^4 48.236 15.901 3.033 0.00242 **
## color^5 -89.616 15.023 -5.965 2.47e-09 ***
## color^6 -35.321 13.681 -2.582 0.00983 **
## clarity.L 4051.192 36.281 111.662 < 2e-16 ***
## clarity.Q -1888.771 33.900 -55.716 < 2e-16 ***
## clarity.C 947.523 28.927 32.755 < 2e-16 ***
## clarity^4 -338.225 22.988 -14.713 < 2e-16 ***
## clarity^5 224.721 18.649 12.050 < 2e-16 ***
## clarity^6 29.676 16.155 1.837 0.06622 .
## clarity^7 91.474 14.283 6.404 1.53e-10 ***
## depth -68.335 5.217 -13.099 < 2e-16 ***
## table -26.743 3.406 -7.852 4.19e-15 ***
## x -1169.985 48.692 -24.028 < 2e-16 ***
## y 97.182 39.303 2.473 0.01342 *
## z -53.552 34.726 -1.542 0.12305
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 1114 on 37734 degrees of freedom
## Multiple R-squared: 0.922, Adjusted R-squared: 0.922
## F-statistic: 1.94e+04 on 23 and 37734 DF, p-value: < 2.2e-16My r^2 value is 0.92 which shows a nice fit to the data.
Now I will run the model on test data and calculate Mean Absolute Percentage Error.
diamonds_test <- diamonds_test %>% mutate(predicted_values_lm = predict(model1,diamonds_test))
MAPE_model_lm <- mean(abs((diamonds_test$price - diamonds_test$predicted_values_lm) / diamonds_test$price)) * 100My Multiple Linear Regression model worked with 39.19% Error.
Tree Model
My second model is a decision tree.
model2 <- tree(price~.,diamonds_train)
summary(model2)##
## Regression tree:
## tree(formula = price ~ ., data = diamonds_train)
## Variables actually used in tree construction:
## [1] "carat" "y" "clarity"
## Number of terminal nodes: 6
## Residual mean deviance: 1908000 = 7.203e+10 / 37750
## Distribution of residuals:
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## -9757.0 -530.2 -158.2 0.0 545.3 13170.0It is a tree with 6 nodes. Lets visualize it:
plot(model2)
text(model2)
diamonds_test <- diamonds_test %>% mutate(predicted_values_tree = predict(model2,diamonds_test))
MAPE_model_tree <- mean(abs((diamonds_test$price - diamonds_test$predicted_values_tree) / diamonds_test$price)) * 100My tree model worked with 32.46% Error.
Finally I want to visualize the model outcomes with the real data.
b <- seq(1:nrow(diamonds_test))
diamonds_test %>% mutate(index=b) %>% ggplot(aes(x=price)) + geom_point(aes(y=predicted_values_tree),color = "red") + geom_point(aes(y=predicted_values_lm),color = "blue") + geom_abline(aes(intercept=0,slope=1),cex =2) + ylab("Predicted Values")
When we look at the predicted value points (blue is from lm model and red is from tree model) There is a obvious fit with the x=y line which shows us our predictions fit well to the real price data.