Repository of Reproducible Computations

Free Statistics

of Irreproducible Research!

Author's title

Author

*The author of this computation has been verified*

R Software Module

rwasp_multipleregression.wasp

Title produced by software

Multiple Regression

Date of computation

Mon, 05 Nov 2012 08:43:33 -0500

Cite this page as follows

Statistical Computations at FreeStatistics.org, Office for Research Development and Education, URL https://freestatistics.org/blog/index.php?v=date/2012/Nov/05/t1352123026ged2fpbx1ylrni8.htm/, Retrieved Wed, 29 Nov 2023 22:55:10 +0000

Statistical Computations at FreeStatistics.org, Office for Research Development and Education, URL https://freestatistics.org/blog/index.php?pk=186054, Retrieved Wed, 29 Nov 2023 22:55:10 +0000

QR Codes:

Paste this QR Code to cite your computation.

Original text written by user:

IsPrivate?

No (this computation is public)

User-defined keywords

Estimated Impact

Family? (F = Feedback message, R = changed R code, M = changed R Module, P = changed Parameters, D = changed Data)

-     [Multiple Regression] [] [2010-11-17 09:55:05] [b98453cac15ba1066b407e146608df68]
-    D    [Multiple Regression] [] [2012-11-05 13:43:33] [c138fbd6e7c7784b8fd4dab04951100b] [Current]

Feedback Forum

Post a new message

Dataseries X:

Download CSV

Histogram

Boxplots

1910	 61	17	 56	 84	 4	 21	 51
2598	 74	19	 73	 47	 3	 15	 48
2144	 57	18	 62	 63	 3	 17	 46
1331	 50	15	 42	 28	 3	 20	 42
1431	 48	15	 59	 22	 2	 12	 38
7334	  2	12	 27	 18	 6	  4	 38
1133	 41	15	 59	 20	 5	  9	 36
1195	 31	20	 78	 27	 5	 11	 35
1522	 61	14	 56	 37	 5	 12	 35
1551	 12	12	 47	 23	 6	  7	 35
2108	 46	13	 51	 67	 5	 14	 34
1335	 31	17	 47	 28	 4	 11	 34
1065	 33	12	 48	 28	 5	  9	 31
 842	 49	10	 35	 45	 3	 14	 31
1539	 15	13	 47	 15	 5	  4	 31
1508	 59	15	 55	 36	 5	 11	 31
1598	 28	12	 42	 12	 2	 10	 30
1219	 55	16	 55	 30	 6	  9	 30
1443	 35	13	 47	 28	 9	  8	 30
1546	 44	15	 54	 27	 2	 14	 30
 914	 41	15	 60	 43	 5	 13	 30
1371	 26	13	 51	 10	 3	 10	 28
1318	 28	12	 47	 22	 4	  9	 27
1313	 40	15	 52	 27	 4	 11	 27
1743	 28	12	 38	 21	11	  7	 27
1102	 67	12	 12	 24	 5	 10	 26
1275	 56	12	 48	 52	 3	 15	 26
1253	 54	12	 48	 24	 5	  7	 26
1487	 25	 8	 32	 19	 5	 10	 26
1098	 19	 9	 27	 12	--	  4	 26
1176	 36	12	 47	 21	 3	 10	 25
 903	 42	16	 58	 71	 4	 13	 25
1290	 19	14	 47	 19	 4	  5	 25
1050	 57	13	 46	 24	 5	 10	 25
 930	 28	15	 60	 12	 2	 10	 25
 821	 32	15	 56	 29	 5	 11	 24
 826	 10	12	 41	 13	 3	  7	 24
1402	 28	12	 45	 22	11	  6	 24
1495	 41	12	 48	 27	 5	  8	 24
1064	 48	15	 60	 36	 5	 10	 24
1469	 57	12	 48	 27	 3	  9	 24
1493	 35	13	 42	 21	 5	  8	 24
1239	 30	12	 47	 28	 4	 11	 24
1317	 39	12	 41	 17	 3	  5	 23
 708	 17	15	 49	 15	 8	  5	 23
 872	 33	12	 39	 26	 3	 10	 23
 853	 55	12	 39	 19	 3	  8	 23
1174	 30	12	 42	 34	11	  9	 23
 982	 22	13	 50	 21	 4	  7	 23
1202	 42	12	 41	 32	 6	  8	 23
 873	 49	15	 52	 14	14	  5	 23
1000	 13	 9	 36	 17	 6	  5	 22
1131	 15	13	 45	 16	 3	  7	 22
 793	 24	12	 46	 18	 5	 10	 22
1106	  3	13	 55	  8	 8	  2	 22
1205	 35	13	 49	 30	 8	  5	 22
1671	 37	13	 48	 31	 3	 13	 22
1374	 28	13	 39	 19	 3	 10	 21
 775	 19	12	 48	 10	 3	  5	 21
 804	 38	15	 45	 24	 5	 10	 21
1224	 29	14	 52	 28	 6	  8	 21
1233	 38	15	 51	 27	 3	  7	 20
1170	 35	14	 41	 16	 3	 10	 20
 923	 23	 9	 32	 17	 3	  5	 20
 613	 27	14	 52	 30	 3	  9	 20
1204	 32	16	 54	 20	 4	  6	 19
 933	  7	 9	 27	 10	 5	  6	 18
 861	 57	12	 41	 30	 3	  9	 18
 932	 39	12	 45	 34	 5	 11	 18
 705	 18	13	 52	 13	13	  6	 18
 828	 18	16	 57	 10	 5	  3	 17
 893	 22	12	 22	 14	 5	  6	 17
1082	 41	12	 47	 29	 6	  9	 17
 918	 37	10	 31	 22	 4	  9	 16
 779	 33	12	 41	 31	 4	  6	 16
 587	 35	12	 43	 16	 4	 10	 16
 843	 34	12	 24	 18	 9	  7	 16
1060	 35	15	 30	 31	 5	 10	 16
 649	 16	10	 40	  7	 7	  5	 16
 792	  0	12	 46	  0	--	  0	 16
 846	 17	14	 44	  9	 9	  3	 15
 547	 26	15	 32	 22	 7	  7	 15
 575	 25	12	 45	 27	 2	  8	 15
 486	 40	12	 37	 24	 3	 10	 15
 861	 54	12	 32	 55	 6	  8	 15
 503	 13	13	 46	 10	 3	  5	 15
 743	 30	13	  9	 25	 8	  7	 15
 634	  9	16	 64	  9	 5	  5	 15
 715	 29	12	 20	 11	 3	  6	 14
 871	 25	12	 21	  8	 8	  4	 14
 812	 40	12	 33	 14	 4	  5	 14
 970	 32	13	 26	  8	 3	  5	 14
 959	 17	12	 36	 29	 7	  6	 13
 960	 18	11	 33	 16	 3	  5	 13
 646	 17	16	 20	 13	 7	  5	 13
 562	 15	 8	 31	 16	 3	  5	 13
 636	 28	12	 13	 10	 5	  5	 13
 646	 18	13	 35	 10	--	  0	 13
 830	 10	12	 40	  5	 5	  2	 12
 428	 10	11	 24	 10	 5	  2	 12
 781	 10	12	 15	 26	 5	  8	 12
 475	 16	15	 58	 11	 3	  6	 12
 567	  2	13	 34	  1	--	  0	 12
 485	 28	 8	 21	  6	 6	  3	 12
 694	 25	13	 32	 12	 4	  4	 12
 480	  7	 8	 21	 61	--	  3	 11
 613	 25	12	 31	 19	 6	  3	 11
 582	 27	14	 26	 24	 6	  8	 11
 569	 16	16	 47	 10	 5	  3	 11
 559	  7	12	 37	  5	 5	  2	 11
 507	 16	 9	 28	  7	 2	  2	 10
 488	  0	 5	  9	 37	37	  1	 10
 383	  2	 8	 19	  1	 1	  2	 10
 475	 36	13	 45	 13	 4	  4	  9
 630	 15	10	 32	 69	23	  3	  9
 386	  5	13	 35	 38	 5	  7	  9
 510	 14	12	 29	 30	10	  3	  9
 566	 43	13	  1	  8	 4	  6	  9
 580	 10	12	 20	  2	--	  1	  9
 516	  0	 4	 15	  3	 3	  1	  9
 413	  8	12	 11	  2	--	  2	  8
 478	 10	13	 18	  8	 4	  4	  8
 495	 12	12	 33	 11	 6	  2	  8
 350	 39	 5	 10	 23	 6	  5	  7
 427	  0	12	 41	  0	--	  0	  7
 349	 10	 9	 10	  4	 2	  3	  6
 335	  7	 6	  0	  2	--	  0	  6
 470	  8	15	 28	  0	--	  0	  5
 250	  0	 9	 31	 10	--	  0	  5
 308	  3	12	 24	  4	 4	  2	  5
 229	  0	11	 38	  9	 9	  1	  5
 244	  8	 0	  0	 13	 4	  4	  5
 242	  1	 8	 25	  0	--	  0	  5
 352	  0	12	 40	  0	--	  0	  5
 428	  8	 3	  4	  5	 5	  3	  5
 270	  3	 9	 23	  1	--	  1	  5
 242	  0	 4	 13	  0	--	  0	  4
 291	  0	14	  6	 39	--	  2	  4
 135	  0	 0	  0	  1	--	  1	  3
 210	  3	 1	  3	  3	 3	  3	  3
 231	  0	 0	  0	  0	--	  0	  2
 267	  0	 6	  7	  0	--	  0	  2
 126	  0	 6	  2	  0	--	  0	  2
 340	  0	 0	  0	  0	--	  0	  2
  44	  0	 0	  0	  0	--	  0	  2
  25	  0	 0	  0	  0	--	  0	  1
 104	  0	 0	  0	  0	--	  0	  1
 142	  2	 2	  5	  0	--	  0	  1
  11	  0	 0	  0	  0	--	  0	  0

Summary of computational transaction
Raw Input	view raw input (R code)
Raw Output	view raw output of R engine
Computing time	0 seconds
R Server	'Gwilym Jenkins' @ jenkins.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 & 'Gwilym Jenkins' @ jenkins.wessa.net \tabularnewline
\hline
\end{tabular}
%Source: https://freestatistics.org/blog/index.php?pk=186054&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]'Gwilym Jenkins' @ jenkins.wessa.net[/C][/ROW]
[/TABLE]
Source: https://freestatistics.org/blog/index.php?pk=186054&T=0

Globally Unique Identifier (entire table): ba.freestatistics.org/blog/index.php?pk=186054&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 Input	view raw input (R code)
Raw Output	view raw output of R engine
Computing time	0 seconds
R Server	'Gwilym Jenkins' @ jenkins.wessa.net

Parameters (Session):

par1 = 8 ; par2 = Do not include Seasonal Dummies ; par3 = No Linear Trend ;

Parameters (R input):

par1 = 8 ; 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')
}

Free Statistics

Description of Statistical Computation

Tree of Dependent Computations

Dataset

Tables (Output of Computation)

Figures (Output of Computation)

Input Parameters & R Code