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 16:54:51 -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/t1352152504dcxoyik2e8a8f5k.htm/, Retrieved Wed, 01 Feb 2023 16:33:32 +0000
Statistical Computations at FreeStatistics.org, Office for Research Development and Education, URL https://freestatistics.org/blog/index.php?pk=186319, Retrieved Wed, 01 Feb 2023 16:33:32 +0000
QR Codes:

Original text written by user:
IsPrivate?No (this computation is public)
User-defined keywords
Estimated Impact75
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 21:54:51] [eeec99d459a890eb36d32eb90406e4cb] [Current]
Feedback Forum

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




Summary of computational transaction
Raw Inputview raw input (R code)
Raw Outputview raw output of R engine
Computing time0 seconds
R Server'Gertrude Mary Cox' @ cox.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 & 0 seconds \tabularnewline
R Server & 'Gertrude Mary Cox' @ cox.wessa.net \tabularnewline
\hline
\end{tabular}
%Source: https://freestatistics.org/blog/index.php?pk=186319&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]0 seconds[/C][/ROW]
[ROW][C]R Server[/C][C]'Gertrude Mary Cox' @ cox.wessa.net[/C][/ROW]
[/TABLE]
Source: https://freestatistics.org/blog/index.php?pk=186319&T=0

Globally Unique Identifier (entire table): ba.freestatistics.org/blog/index.php?pk=186319&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 time0 seconds
R Server'Gertrude Mary Cox' @ cox.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')
}