# 7. Harjoitus ################# # 7.4 ######### car.pref <- read.table("C:\\Kurssit\\Glim\\Glim02\\Datat\\Car.preferences.txt", header = TRUE, sep = ",") car.pref.d <- read.table("C:\\Kurssit\\Glim\\Glim02\\Datat\\Car.pref.d.txt", header = TRUE, sep = ",") # car.pref names(car.pref) library(nnet) # library(MASS) pref<- multinom(response ~ sex + age ,weight=frequency, data = car.pref) pref.d<- multinom(response ~ x1 + x2 + x3,weight=frequency, data = car.pref.d) pref.d ###################### Call: multinom(formula = response ~ x1 + x2 + x3, data = car.pref.d, weights = frequency) Coefficients: (Intercept) x1 x2 x3 important -0.590803 -0.3881203 1.128274 1.587701 very important -1.039064 -0.8130260 1.478106 2.916771 Residual Deviance: 580.7022 AIC: 596.7022 # Tässä mallissa 1. luokka on perusluokka. Tarkastellaan siis suureita # log(pi_j/pi_1), j=2,3 ###################### xx <- expand.grid(x1 = c(0,0,0,1,1,1), x2= c(0,1,0,0,1,0), x3= c(0,0,1,0,0,1)) px <-predict(pref.d,xx,type="prob") expand.grid(x3 = c(0,1), x2= c(0,1), x1= c(0,1)) x3 x2 x1 1 0 0 0 2 1 0 0 3 0 1 0 4 1 1 0 5 0 0 1 6 1 0 1 7 0 1 1 8 1 1 1 > xx <- expand.grid(x3 = c(0,1), x2= c(0,1), x1= c(0,1)) > px <-predict(pref.d,xx,type="prob") > px a/little important very important 1 0.52420024 0.2903452 0.1854545 2 0.09757663 0.2644193 0.6380041 3 0.23458246 0.4015284 0.3638891 4 0.02628588 0.2201268 0.7535873 5 0.65247564 0.2451451 0.1023792 6 0.17427384 0.3203472 0.5053790 7 0.35099195 0.4075298 0.2414783 8 0.05155801 0.2928789 0.6555631 #################################################### # 7.5 car.pref <- read.table("C:\\Kurssit\\Glim\\Glim02\\Datat\\Car.preferences.txt", header = TRUE, sep = ",") names(car.pref) # car.pref pref<- multinom(response ~ sex + age ,weight=frequency, data = car.pref) pref pref<- multinom(response ~ sex + age ,weight=frequency, data = car.pref) # weights: 15 (8 variable) initial value 329.583687 iter 10 value 290.412110 final value 290.351099 converged > pref Call: multinom(formula = response ~ sex + age, data = car.pref, weights = frequency) Coefficients: (Intercept) sexwomen age18-23 age24-40 no/little -0.6087465 -0.3881158 1.587691 0.4594173 very important 0.4558404 0.4248789 -1.329069 -0.9792138 Residual Deviance: 580.7022 AIC: 596.7022 # Tässä mallissa 2. luokka on perusluokka. Tarkastellaan siis suureita # log(pi_j/pi_2), j=1,3 ############################### # 7.6 pref<- multinom(response ~ sex + age ,weight=frequency, data = car.pref) pref.s<- multinom(response ~ sex ,weight=frequency, data = car.pref) pref.a<- multinom(response ~ age ,weight=frequency, data = car.pref) pref pref.s pref.a > pref<- multinom(response ~ sex + age ,weight=frequency, data = car.pref) # weights: 15 (8 variable) initial value 329.583687 iter 10 value 290.412110 final value 290.351099 converged > pref.s<- multinom(response ~ sex ,weight=frequency, data = car.pref) # weights: 9 (4 variable) initial value 329.583687 final value 323.140601 converged > pref.a<- multinom(response ~ age ,weight=frequency, data = car.pref) # weights: 12 (6 variable) initial value 329.583687 iter 10 value 293.606194 final value 293.603688 converged > > pref Call: multinom(formula = response ~ sex + age, data = car.pref, weights = frequency) Coefficients: (Intercept) sexwomen age18-23 age24-40 no/little -0.6087465 -0.3881158 1.587691 0.4594173 very important 0.4558404 0.4248789 -1.329069 -0.9792138 Residual Deviance: 580.7022 AIC: 596.7022 > pref.s Call: multinom(formula = response ~ sex, data = car.pref, weights = frequency) Coefficients: (Intercept) sexwomen no/little 0.3242470 -0.4854917 very important -0.2125769 0.5055388 Residual Deviance: 646.2812 AIC: 654.2812 ######## # Testaus/Age ######## 646.2812-580.7022 [1] 65.579 vapausasteet 4 pchisq(65.579, 4, lower.tail = F) # p-arvo 1.943045e-13, joten ikä on erittäin merkitsevä ############### > pref.a Call: multinom(formula = response ~ age, data = car.pref, weights = frequency) Coefficients: (Intercept) age18-23 age24-40 no/little -0.8023189 1.624695 0.4769395 very important 0.7101923 -1.369497 -0.9978951 Residual Deviance: 587.2074 AIC: 599.2074 ######## # Testaus/sex ######## 587.2074-580.7022 6.5052 vapausasteet 2 pchisq(6.5052, 2, lower.tail = F) # p-arvo 0.03867353, joten sex on merkitsevä 5%:n tasolla, mutta ei 1%:n tasolla ################################# # 7.7 ####### library(nnet) pref.aq<- multinom(response ~ x1 + age ,weight=frequency, data = car.pref.d) pref.aqt<- multinom(response ~ x1*age ,weight=frequency, data = car.pref.d) pref.ak <- multinom(response ~ sex+age ,weight=frequency, data = car.pref) pref.akt<- multinom(response ~ sex*age ,weight=frequency, data = car.pref) pref.aq # Age kvantitatiivinen pref.aqt # Age kvantitatiivinen, Age*sukupuoli mukana pref.ak # Age luokittelumuuttuja pref.akt # Age luokittelumuuttuja, täysi malli pref.aq<- multinom(response ~ x1 + age ,weight=frequency, data = car.pref.d) # weights: 12 (6 variable) initial value 329.583687 iter 10 value 291.051804 final value 291.050160 converged > pref.aqt<- multinom(response ~ x1*age ,weight=frequency, data = car.pref.d) # weights: 15 (8 variable) initial value 329.583687 iter 10 value 290.005187 final value 289.789567 converged > pref.aq # Age kvantitatiivinen Call: multinom(formula = response ~ x1 + age, data = car.pref.d, weights = frequency) Coefficients: (Intercept) x1 age important -0.5019456 -0.3889737 0.830373 very important -1.0922996 -0.8130416 1.521452 Residual Deviance: 582.1003 AIC: 594.1003 > pref.aqt # Age kvantitatiivinen, Age*sukupuoli mukana Call: multinom(formula = response ~ x1 * age, data = car.pref.d, weights = frequency) Coefficients: (Intercept) x1 age x1:age important -0.570717 -0.2901400 0.986565 -0.2423253 very important -1.437177 -0.1512471 1.873754 -0.6665059 Residual Deviance: 579.5791 AIC: 595.5791 ########### # 582.1003-579.5791=2.5212 # df=8-6=2 pchisq(2.5212, 2, lower.tail = F) 0.2834839 # Additiivinen malli sopii, sama kulmakerroin ########### > pref.ak # Age luokittelumuuttuja Call: multinom(formula = response ~ sex + age, data = car.pref, weights = frequency) Coefficients: (Intercept) sexwomen age18-23 age24-40 no/little -0.6087465 -0.3881158 1.587691 0.4594173 very important 0.4558404 0.4248789 -1.329069 -0.9792138 Residual Deviance: 580.7022 AIC: 596.7022 > pref.akt # Age luokittelumuuttuja, täysi malli Call: multinom(formula = response ~ sex * age, data = car.pref, weights = frequency) Coefficients: (Intercept) sexwomen age18-23 age24-40 sexwomen:age18-23 no/little -0.6286113 -0.4010045 1.4842783 0.7537765 0.3185437 very important 0.1823054 0.8922010 -0.9360736 -0.4054411 -0.6774444 sexwomen:age24-40 no/little -0.5714394 very important -1.0055405 Residual Deviance: 576.7635 AIC: 600.7635 # Sovitetun mallin (ikä luokitteleva) devianssi on # 580.7022-576.7635 # [1] 3.9387 , vapausasteet 12-8=4 # "Täydellä mallilla" 12 ja sovitetulla mallilla 8 parametria # pchisq(3.9387, 4, lower.tail = F) # [1] 0.4143655 ################# # Vertaillaan vantitatiivisen ja kvalitatiivisen iän malleja 582.1003-580.7022 # 1.3981, vapausasteet 8-6=2 pchisq(1.3981, 2, lower.tail = F) # 0.4970573 # Ikä kvantitatiivinen selittäjä, paras malli xx1<-c(rep(0,150),rep(1,150)) > xx1 [1] 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 [38] 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 [75] 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 [112] 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 [149] 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 [186] 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 [223] 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 [260] 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 [297] 1 1 1 1 > sum(car.pref.d[1:3,5]) [1] 45 > sum(car.pref.d[4:6,5]);sum(car.pref.d[7:12,5]);sum(car.pref.d[13:15,5]);sum(car.pref.d[16:18,5]) [1] 45 [1] 125 [1] 44 [1] 41 > xx2<-c(rep(0,45),rep(1,45),rep(0,125),rep(1,44),rep(0,41)) > sum(car.pref.d[1:6,5]);sum(car.pref.d[7:9,5]);sum(car.pref.d[10:15,5]);sum(car.pref.d[16:18,5]) [1] 90 [1] 60 [1] 109 [1] 41 > xx3<-c(rep(0,90),rep(1,60),rep(0,109),rep(1,41)) > car.pref.d[,5] [1] 26 12 7 9 21 15 5 14 41 40 17 8 17 15 12 8 15 18 > resp<-c(rep(1,90),rep(1,60),rep(0,109),rep(1,41)) > resp<-c(rep(1,26),rep(2,12),rep(3,7),rep(1,9),rep(2, 21),rep(3, 15),rep(1, 5),rep(2, 14),rep(3, 41),rep(1, 40),rep(2, 17),rep(3, 8),rep(1, 17),rep(2, 15),rep(3, 12),rep(1, 8),rep(2, 15),rep(3, 18)) > resp [1] 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 [38] 2 3 3 3 3 3 3 3 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 [75] 2 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 3 3 [112] 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 [149] 3 3 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 [186] 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 3 3 3 3 3 3 3 3 1 1 1 1 1 1 1 [223] 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 3 3 3 3 3 3 3 3 3 3 3 3 [260] 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 3 3 3 3 3 3 3 3 3 3 3 3 3 3 [297] 3 3 3 3 > Resp<-factor(resp) > library(nnet) > multinom(Resp ~ xx1+xx2+xx3) # weights: 15 (8 variable) initial value 329.583687 iter 10 value 290.490920 final value 290.351099 converged Call: multinom(formula = Resp ~ xx1 + xx2 + xx3) Coefficients: (Intercept) xx1 xx2 xx3 2 -0.590803 -0.3881203 1.128274 1.587701 3 -1.039064 -0.8130260 1.478106 2.916771 Residual Deviance: 580.7022 AIC: 596.7022