Free Statistics

of Irreproducible Research!

Author's title

Author*The author of this computation has been verified*
R Software Modulerwasp_multipleregression.wasp
Title produced by softwareMultiple Regression
Date of computationMon, 05 Nov 2012 17:10:42 -0500
Cite this page as followsStatistical Computations at FreeStatistics.org, Office for Research Development and Education, URL https://freestatistics.org/blog/index.php?v=date/2012/Nov/05/t1352153455mdso9g0o16w2t2f.htm/, Retrieved Sun, 05 Feb 2023 23:15:10 +0000
Statistical Computations at FreeStatistics.org, Office for Research Development and Education, URL https://freestatistics.org/blog/index.php?pk=186329, Retrieved Sun, 05 Feb 2023 23:15:10 +0000
QR Codes:

Original text written by user:
IsPrivate?No (this computation is public)
User-defined keywords
Estimated Impact41
Family? (F = Feedback message, R = changed R code, M = changed R Module, P = changed Parameters, D = changed Data)
-       [Multiple Regression] [workshop 7] [2012-11-05 22:10:42] [eeec99d459a890eb36d32eb90406e4cb] [Current]
Feedback Forum

Post a new message
Dataseries X:
  56	 61	 51	 84	1	1911
 73	 74	 48	 47	  2	2599
 62	 57	 46	 63	  3	2145
 42	 50	 42	 28	  4	1331
 27	  3	 42	 18	  5	7375
 59	 48	 39	 22	  6	1445
 56	 62	 38	 37	  7	1595
 59	 41	 36	 20	  8	1134
 78	 31	 36	 27	  9	1235
 47	 12	 35	 23	 10	1552
 51	 46	 34	 67	 11	2110
 51	 27	 34	 10	 12	1430
 54	 47	 34	 27	 13	1726
 47	 31	 34	 28	 14	1348
 47	 16	 32	 15	 15	1569
 55	 60	 32	 36	 16	1534
 47	 37	 32	 28	 17	1515
 35	 49	 31	 45	 18	 843
 48	 33	 31	 28	 19	1075
 42	 28	 30	 12	 20	1600
 55	 56	 30	 30	 21	1233
 60	 41	 30	 43	 22	 945
 12	 71	 28	 24	 23	1149
 47	 30	 28	 28	 24	1360
 38	 28	 27	 21	 25	1758
 52	 40	 27	 27	 26	1313
 47	 28	 27	 22	 27	1318
 48	 56	 26	 52	 28	1276
 42	 37	 26	 21	 29	1553
 47	 36	 26	 21	 30	1180
 56	 32	 26	 29	 31	 868
 27	 19	 26	 12	 32	1098
 32	 25	 26	 19	 33	1487
 46	 58	 26	 24	 34	1071
 60	 29	 26	 12	 35	 968
 32	 26	 26	 17	 36	1066
 48	 54	 26	 24	 37	1254
 48	 41	 25	 27	 38	1508
 41	 39	 25	 17	 39	1367
 45	 29	 25	 22	 40	1428
 47	 19	 25	 19	 41	1290
 42	 32	 25	 34	 42	1216
 46	 26	 25	 18	 43	 863
 58	 42	 25	 71	 44	 903
 41	 10	 24	 13	 45	 826
 48	 57	 24	 27	 46	1470
 60	 48	 24	 36	 47	1065
 41	 43	 24	 32	 48	1218
 39	 37	 24	 26	 49	 923
 52	 49	 23	 14	 50	 874
 39	 28	 23	 19	 51	1491
 39	 55	 23	 19	 52	 853
 36	 13	 23	 17	 53	1016
 49	 17	 23	 15	 54	 713
 49	 36	 23	 30	 55	1218
 50	 22	 23	 21	 56	 983
 48	 37	 22	 31	 57	1672
 52	 29	 22	 28	 58	1231
 55	  3	 22	  8	 59	1107
 45	 15	 22	 16	 60	1132
 45	 38	 21	 24	 61	 804
 48	 19	 21	 10	 62	 775
 41	 35	 21	 16	 63	1206
 51	 38	 20	 27	 64	1233
 22	 23	 20	 14	 65	 988
 52	 27	 20	 30	 66	 614
 47	 43	 19	 29	 67	1172
 54	 32	 19	 20	 68	1216
 43	 37	 18	 16	 69	 619
 27	  7	 18	 10	 70	 934
 41	 62	 18	 30	 71	 874
 40	 17	 18	  7	 72	 713
 45	 39	 18	 34	 73	 932
 52	 18	 18	 13	74	 706
  9	 30	 17	 25	 75	 760
 57	 18	 17	 10	 76	 828
 46	  0	 16	  0	 77	 792
 24	 34	 16	 18	 78	 844
 31	 37	 16	 22	 79	 918
 41	 33	 16	 31	 80	 796
 30	 35	 16	 31	 81	1061
 44	 17	 15	  9	 82	 847
 45	 25	 15	 27	 83	 575
 35	 21	 15	 10	 84	 707
 32	 26	 15	 22	 85	 548
 33	 40	 15	 14	 86	 835
 21	 29	 15	  6	 87	 563
 37	 40	 15	 24	 88	 487
 46	 13	 15	 10	 89	 504
 64	  9	 15	  9	 90	 641
 32	 54	 15	 55	 91	 862
 20	 29	 14	 11	 92	 715
 21	 25	 14	  8	 93	 872
 21	  9	 14	 61	 94	 564
 26	 32	 14	  8	 95	 997
 19	  4	 13	  1	 96	 476
 20	 17	 13	 13	 97	 646
 13	 28	 13	 10	 98	 637
 34	  4	 13	  1	 99	 598
 33	 18	 13	 16	100	 960
 36	 17	 13	 29	101	 959
 31	 15	 13	 16	102	 563
 58	 16	 13	 11	103	 500
 32	 25	 12	 12	104	 694
 15	  1	 12	  3	105	 620
 40	 10	 12	  5	106	 831
 15	 10	 12	 26	107	 791
 24	 10	 12	 10	108	 428
 37	  7	 11	  5	109	 573
 31	 25	 11	 19	110	 623
 26	 27	 11	 24	111	 590
 47	 16	 11	 10	112	 584
 18	 11	 10	  8	113	 533
 28	 16	 10	  7	114	 508
  9	  0	 10	 37	115	 488
 32	 15	 10	 69	116	 723
 45	 36	  9	 13	117	 476
 35	  5	  9	 38	118	 387
 29	 14	  9	 30	119	 511
  1	 43	  9	  8	120	 585
 20	 10	  9	  2	121	 581
 11	  8	  8	  2	122	 413
 33	 12	  8	 11	123	 496
 10	 39	  7	 23	124	 350
 41	  0	  7	  0	125	 427
 31	  0	  6	 10	126	 267
 10	 10	  6	  4	127	 350
  0	  7	  6	  2	128	 335
 38	  0	  5	  9	129	 229
 28	  8	  5	  0	130	 470
 24	  3	  5	  4	131	 310
 25	  1	  5	  0	132	 242
  0	  8	  5	 13	133	 244
  4	  8	  5	  5	134	 431
 40	  0	  5	  0	135	 352
 23	  5	  5	  1	136	 285
  6	  0	  4	 39	137	 291
 13	  0	  4	  0	138	 242
  3	  3	  3	  3	139	 211
  0	  0	  3	  1	140	 136
  0	  0	  2	  0	141	 231
  7	  0	  2	  0	142	 268
  2	  0	  2	  0	143	 126
  0	  0	  2	  0	144	  44
  0	  0	  2	  0	145	 340
  5	  2	  1	  0	146	 143
  0	  0	  1	  0	147	 104
  0	  0	  1	  0	148	  25
  0	  0	  0	  0	149	  11




Summary of computational transaction
Raw Inputview raw input (R code)
Raw Outputview raw output of R engine
Computing time1 seconds
R Server'George Udny Yule' @ yule.wessa.net

\begin{tabular}{lllllllll}
\hline
Summary of computational transaction \tabularnewline
Raw Input & view raw input (R code)  \tabularnewline
Raw Output & view raw output of R engine  \tabularnewline
Computing time & 1 seconds \tabularnewline
R Server & 'George Udny Yule' @ yule.wessa.net \tabularnewline
\hline
\end{tabular}
%Source: https://freestatistics.org/blog/index.php?pk=186329&T=0

[TABLE]
[ROW][C]Summary of computational transaction[/C][/ROW]
[ROW][C]Raw Input[/C][C]view raw input (R code) [/C][/ROW]
[ROW][C]Raw Output[/C][C]view raw output of R engine [/C][/ROW]
[ROW][C]Computing time[/C][C]1 seconds[/C][/ROW]
[ROW][C]R Server[/C][C]'George Udny Yule' @ yule.wessa.net[/C][/ROW]
[/TABLE]
Source: https://freestatistics.org/blog/index.php?pk=186329&T=0

Globally Unique Identifier (entire table): ba.freestatistics.org/blog/index.php?pk=186329&T=0

As an alternative you can also use a QR Code:  

The GUIDs for individual cells are displayed in the table below:

Summary of computational transaction
Raw Inputview raw input (R code)
Raw Outputview raw output of R engine
Computing time1 seconds
R Server'George Udny Yule' @ yule.wessa.net



Parameters (Session):
par2 = Do not include Seasonal Dummies ; par3 = No Linear Trend ;
Parameters (R input):
par1 = ; par2 = Do not include Seasonal Dummies ; par3 = No Linear Trend ;
R code (references can be found in the software module):
library(lattice)
library(lmtest)
n25 <- 25 #minimum number of obs. for Goldfeld-Quandt test
par1 <- as.numeric(par1)
x <- t(y)
k <- length(x[1,])
n <- length(x[,1])
x1 <- cbind(x[,par1], x[,1:k!=par1])
mycolnames <- c(colnames(x)[par1], colnames(x)[1:k!=par1])
colnames(x1) <- mycolnames #colnames(x)[par1]
x <- x1
if (par3 == 'First Differences'){
x2 <- array(0, dim=c(n-1,k), dimnames=list(1:(n-1), paste('(1-B)',colnames(x),sep='')))
for (i in 1:n-1) {
for (j in 1:k) {
x2[i,j] <- x[i+1,j] - x[i,j]
}
}
x <- x2
}
if (par2 == 'Include Monthly Dummies'){
x2 <- array(0, dim=c(n,11), dimnames=list(1:n, paste('M', seq(1:11), sep ='')))
for (i in 1:11){
x2[seq(i,n,12),i] <- 1
}
x <- cbind(x, x2)
}
if (par2 == 'Include Quarterly Dummies'){
x2 <- array(0, dim=c(n,3), dimnames=list(1:n, paste('Q', seq(1:3), sep ='')))
for (i in 1:3){
x2[seq(i,n,4),i] <- 1
}
x <- cbind(x, x2)
}
k <- length(x[1,])
if (par3 == 'Linear Trend'){
x <- cbind(x, c(1:n))
colnames(x)[k+1] <- 't'
}
x
k <- length(x[1,])
df <- as.data.frame(x)
(mylm <- lm(df))
(mysum <- summary(mylm))
if (n > n25) {
kp3 <- k + 3
nmkm3 <- n - k - 3
gqarr <- array(NA, dim=c(nmkm3-kp3+1,3))
numgqtests <- 0
numsignificant1 <- 0
numsignificant5 <- 0
numsignificant10 <- 0
for (mypoint in kp3:nmkm3) {
j <- 0
numgqtests <- numgqtests + 1
for (myalt in c('greater', 'two.sided', 'less')) {
j <- j + 1
gqarr[mypoint-kp3+1,j] <- gqtest(mylm, point=mypoint, alternative=myalt)$p.value
}
if (gqarr[mypoint-kp3+1,2] < 0.01) numsignificant1 <- numsignificant1 + 1
if (gqarr[mypoint-kp3+1,2] < 0.05) numsignificant5 <- numsignificant5 + 1
if (gqarr[mypoint-kp3+1,2] < 0.10) numsignificant10 <- numsignificant10 + 1
}
gqarr
}
bitmap(file='test0.png')
plot(x[,1], type='l', main='Actuals and Interpolation', ylab='value of Actuals and Interpolation (dots)', xlab='time or index')
points(x[,1]-mysum$resid)
grid()
dev.off()
bitmap(file='test1.png')
plot(mysum$resid, type='b', pch=19, main='Residuals', ylab='value of Residuals', xlab='time or index')
grid()
dev.off()
bitmap(file='test2.png')
hist(mysum$resid, main='Residual Histogram', xlab='values of Residuals')
grid()
dev.off()
bitmap(file='test3.png')
densityplot(~mysum$resid,col='black',main='Residual Density Plot', xlab='values of Residuals')
dev.off()
bitmap(file='test4.png')
qqnorm(mysum$resid, main='Residual Normal Q-Q Plot')
qqline(mysum$resid)
grid()
dev.off()
(myerror <- as.ts(mysum$resid))
bitmap(file='test5.png')
dum <- cbind(lag(myerror,k=1),myerror)
dum
dum1 <- dum[2:length(myerror),]
dum1
z <- as.data.frame(dum1)
z
plot(z,main=paste('Residual Lag plot, lowess, and regression line'), ylab='values of Residuals', xlab='lagged values of Residuals')
lines(lowess(z))
abline(lm(z))
grid()
dev.off()
bitmap(file='test6.png')
acf(mysum$resid, lag.max=length(mysum$resid)/2, main='Residual Autocorrelation Function')
grid()
dev.off()
bitmap(file='test7.png')
pacf(mysum$resid, lag.max=length(mysum$resid)/2, main='Residual Partial Autocorrelation Function')
grid()
dev.off()
bitmap(file='test8.png')
opar <- par(mfrow = c(2,2), oma = c(0, 0, 1.1, 0))
plot(mylm, las = 1, sub='Residual Diagnostics')
par(opar)
dev.off()
if (n > n25) {
bitmap(file='test9.png')
plot(kp3:nmkm3,gqarr[,2], main='Goldfeld-Quandt test',ylab='2-sided p-value',xlab='breakpoint')
grid()
dev.off()
}
load(file='createtable')
a<-table.start()
a<-table.row.start(a)
a<-table.element(a, 'Multiple Linear Regression - Estimated Regression Equation', 1, TRUE)
a<-table.row.end(a)
myeq <- colnames(x)[1]
myeq <- paste(myeq, '[t] = ', sep='')
for (i in 1:k){
if (mysum$coefficients[i,1] > 0) myeq <- paste(myeq, '+', '')
myeq <- paste(myeq, mysum$coefficients[i,1], sep=' ')
if (rownames(mysum$coefficients)[i] != '(Intercept)') {
myeq <- paste(myeq, rownames(mysum$coefficients)[i], sep='')
if (rownames(mysum$coefficients)[i] != 't') myeq <- paste(myeq, '[t]', sep='')
}
}
myeq <- paste(myeq, ' + e[t]')
a<-table.row.start(a)
a<-table.element(a, myeq)
a<-table.row.end(a)
a<-table.end(a)
table.save(a,file='mytable1.tab')
a<-table.start()
a<-table.row.start(a)
a<-table.element(a,hyperlink('ols1.htm','Multiple Linear Regression - Ordinary Least Squares',''), 6, TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'Variable',header=TRUE)
a<-table.element(a,'Parameter',header=TRUE)
a<-table.element(a,'S.D.',header=TRUE)
a<-table.element(a,'T-STAT
H0: parameter = 0',header=TRUE)
a<-table.element(a,'2-tail p-value',header=TRUE)
a<-table.element(a,'1-tail p-value',header=TRUE)
a<-table.row.end(a)
for (i in 1:k){
a<-table.row.start(a)
a<-table.element(a,rownames(mysum$coefficients)[i],header=TRUE)
a<-table.element(a,mysum$coefficients[i,1])
a<-table.element(a, round(mysum$coefficients[i,2],6))
a<-table.element(a, round(mysum$coefficients[i,3],4))
a<-table.element(a, round(mysum$coefficients[i,4],6))
a<-table.element(a, round(mysum$coefficients[i,4]/2,6))
a<-table.row.end(a)
}
a<-table.end(a)
table.save(a,file='mytable2.tab')
a<-table.start()
a<-table.row.start(a)
a<-table.element(a, 'Multiple Linear Regression - Regression Statistics', 2, TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a, 'Multiple R',1,TRUE)
a<-table.element(a, sqrt(mysum$r.squared))
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a, 'R-squared',1,TRUE)
a<-table.element(a, mysum$r.squared)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a, 'Adjusted R-squared',1,TRUE)
a<-table.element(a, mysum$adj.r.squared)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a, 'F-TEST (value)',1,TRUE)
a<-table.element(a, mysum$fstatistic[1])
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a, 'F-TEST (DF numerator)',1,TRUE)
a<-table.element(a, mysum$fstatistic[2])
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a, 'F-TEST (DF denominator)',1,TRUE)
a<-table.element(a, mysum$fstatistic[3])
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a, 'p-value',1,TRUE)
a<-table.element(a, 1-pf(mysum$fstatistic[1],mysum$fstatistic[2],mysum$fstatistic[3]))
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a, 'Multiple Linear Regression - Residual Statistics', 2, TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a, 'Residual Standard Deviation',1,TRUE)
a<-table.element(a, mysum$sigma)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a, 'Sum Squared Residuals',1,TRUE)
a<-table.element(a, sum(myerror*myerror))
a<-table.row.end(a)
a<-table.end(a)
table.save(a,file='mytable3.tab')
a<-table.start()
a<-table.row.start(a)
a<-table.element(a, 'Multiple Linear Regression - Actuals, Interpolation, and Residuals', 4, TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a, 'Time or Index', 1, TRUE)
a<-table.element(a, 'Actuals', 1, TRUE)
a<-table.element(a, 'Interpolation
Forecast', 1, TRUE)
a<-table.element(a, 'Residuals
Prediction Error', 1, TRUE)
a<-table.row.end(a)
for (i in 1:n) {
a<-table.row.start(a)
a<-table.element(a,i, 1, TRUE)
a<-table.element(a,x[i])
a<-table.element(a,x[i]-mysum$resid[i])
a<-table.element(a,mysum$resid[i])
a<-table.row.end(a)
}
a<-table.end(a)
table.save(a,file='mytable4.tab')
if (n > n25) {
a<-table.start()
a<-table.row.start(a)
a<-table.element(a,'Goldfeld-Quandt test for Heteroskedasticity',4,TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'p-values',header=TRUE)
a<-table.element(a,'Alternative Hypothesis',3,header=TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'breakpoint index',header=TRUE)
a<-table.element(a,'greater',header=TRUE)
a<-table.element(a,'2-sided',header=TRUE)
a<-table.element(a,'less',header=TRUE)
a<-table.row.end(a)
for (mypoint in kp3:nmkm3) {
a<-table.row.start(a)
a<-table.element(a,mypoint,header=TRUE)
a<-table.element(a,gqarr[mypoint-kp3+1,1])
a<-table.element(a,gqarr[mypoint-kp3+1,2])
a<-table.element(a,gqarr[mypoint-kp3+1,3])
a<-table.row.end(a)
}
a<-table.end(a)
table.save(a,file='mytable5.tab')
a<-table.start()
a<-table.row.start(a)
a<-table.element(a,'Meta Analysis of Goldfeld-Quandt test for Heteroskedasticity',4,TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'Description',header=TRUE)
a<-table.element(a,'# significant tests',header=TRUE)
a<-table.element(a,'% significant tests',header=TRUE)
a<-table.element(a,'OK/NOK',header=TRUE)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'1% type I error level',header=TRUE)
a<-table.element(a,numsignificant1)
a<-table.element(a,numsignificant1/numgqtests)
if (numsignificant1/numgqtests < 0.01) dum <- 'OK' else dum <- 'NOK'
a<-table.element(a,dum)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'5% type I error level',header=TRUE)
a<-table.element(a,numsignificant5)
a<-table.element(a,numsignificant5/numgqtests)
if (numsignificant5/numgqtests < 0.05) dum <- 'OK' else dum <- 'NOK'
a<-table.element(a,dum)
a<-table.row.end(a)
a<-table.row.start(a)
a<-table.element(a,'10% type I error level',header=TRUE)
a<-table.element(a,numsignificant10)
a<-table.element(a,numsignificant10/numgqtests)
if (numsignificant10/numgqtests < 0.1) dum <- 'OK' else dum <- 'NOK'
a<-table.element(a,dum)
a<-table.row.end(a)
a<-table.end(a)
table.save(a,file='mytable6.tab')
}