Robust regression in R
simulate 20 observations from a linear model with errors that follow a normal distribution
set.seed=112358
nobs<-20
sdy<-1
x<-seq(0,1,length=nobs)
y<-10+5*x+rnorm(nobs,sd=sdy)
add outlier at high leverage point
y[nobs]<-7
fit linear model
ols<-lm(y~x)
fit robust linear model
library(MASS)
mEst<-rlm(y~x)
plot results
plot(x,y)
abline(ols,lwd=2)
abline(mEst,col="red",lwd=2)
legend("topleft",legend=c("OLS","M-estimation"),lwd=2,col=1:2)

round(mEst$w,3)
[1] 1.000 1.000 1.000 1.000 1.000 1.000
[7] 1.000 1.000 0.954 1.000 1.000 1.000
[13] 0.962 1.000 1.000 1.000 1.000 1.000
[19] 1.000 0.192
Implement it yourself
start from ols fit
lmMod=ols
Use robust variance estimator to calculate the z
res=lmMod$res
stdev=mad(res)
median(abs(res-median(res)))*1.4826
[1] 1.512416
z=res/stdev
calculate weights
use psi.huber function
w=psi.huber(z)
plot(x,y)

plot(x,lmMod$res)

plot(x,lmMod$res,cex=w)

plot results
plot(x,y)
abline(ols,lwd=2)
abline(mEst,col="red",lwd=2)
abline(lmMod,col="blue",lwd=2)
legend("topleft",legend=c("OLS","M-estimation","Our Impl"),lwd=2,col=c("black","red","blue"))

repeat this many times
lmMod=ols
for (k in 1:10)
{
######repeat this part several times until convergence
#use robust variance estimator to calculate the z
res=lmMod$res
stdev=mad(res)
median(abs(res-median(res)))*1.4826
z=res/stdev
#calculate weights
#use psi.huber function
w=psi.huber(z)
#perform a weighted regression use lm with weights=w
lmMod=lm(y~x,weights=w)
#plot results
plot(x,y)
abline(ols,lwd=2)
abline(mEst,col="red",lwd=2)
abline(lmMod,col="blue",lwd=2)
legend("topleft",legend=c("OLS","M-estimation","Our Impl"),lwd=2,col=c("black","red","blue"))
####################################
}










LS0tCnRpdGxlOiAiUm9idXN0IFJlZ3Jlc3Npb24iCmF1dGhvcjogIkxpZXZlbiBDbGVtZW50IgpkYXRlOiAiMjkgU2VwIDIwMTUiCm91dHB1dDogaHRtbF9ub3RlYm9vawotLS0KI1JvYnVzdCByZWdyZXNzaW9uIGluIFIKIyNzaW11bGF0ZSAyMCBvYnNlcnZhdGlvbnMgZnJvbSBhIGxpbmVhciBtb2RlbCB3aXRoIGVycm9ycyB0aGF0IGZvbGxvdyBhIG5vcm1hbCBkaXN0cmlidXRpb24KYGBge3J9CnNldC5zZWVkPTExMjM1OApub2JzPC0yMApzZHk8LTEKeDwtc2VxKDAsMSxsZW5ndGg9bm9icykKeTwtMTArNSp4K3Jub3JtKG5vYnMsc2Q9c2R5KQpgYGAKI2FkZCBvdXRsaWVyIGF0IGhpZ2ggbGV2ZXJhZ2UgcG9pbnQKYGBge3J9Cnlbbm9ic108LTcKYGBgCgojI2ZpdCBsaW5lYXIgbW9kZWwKYGBge3J9Cm9sczwtbG0oeX54KQpgYGAKIyNmaXQgcm9idXN0IGxpbmVhciBtb2RlbApgYGB7cn0KbGlicmFyeShNQVNTKQptRXN0PC1ybG0oeX54KQpgYGAKCiMjcGxvdCByZXN1bHRzCmBgYHtyfQpwbG90KHgseSkKYWJsaW5lKG9scyxsd2Q9MikKYWJsaW5lKG1Fc3QsY29sPSJyZWQiLGx3ZD0yKQpsZWdlbmQoInRvcGxlZnQiLGxlZ2VuZD1jKCJPTFMiLCJNLWVzdGltYXRpb24iKSxsd2Q9Mixjb2w9MToyKQpyb3VuZChtRXN0JHcsMykKYGBgCgojSW1wbGVtZW50IGl0IHlvdXJzZWxmCiMjc3RhcnQgZnJvbSBvbHMgZml0CmBgYHtyfQpsbU1vZD1vbHMKYGBgCgojI1VzZSByb2J1c3QgdmFyaWFuY2UgZXN0aW1hdG9yIHRvIGNhbGN1bGF0ZSB0aGUgegpgYGB7cn0KcmVzPWxtTW9kJHJlcwpzdGRldj1tYWQocmVzKQptZWRpYW4oYWJzKHJlcy1tZWRpYW4ocmVzKSkpKjEuNDgyNgp6PXJlcy9zdGRldgpgYGAKIyNjYWxjdWxhdGUgd2VpZ2h0cwojI3VzZSBwc2kuaHViZXIgZnVuY3Rpb24KYGBge3J9Cnc9cHNpLmh1YmVyKHopCnBsb3QoeCx5KQpwbG90KHgsbG1Nb2QkcmVzKQpwbG90KHgsbG1Nb2QkcmVzLGNleD13KQpgYGAKI3BlcmZvcm0gYSB3ZWlnaHRlZCByZWdyZXNzaW9uIHVzZSBsbSB3aXRoIHdlaWdodHM9dwpgYGB7cn0KbG1Nb2Q9bG0oeX54LHdlaWdodHM9dykKYGBgCiNwbG90IHJlc3VsdHMKYGBge3J9CnBsb3QoeCx5KQphYmxpbmUob2xzLGx3ZD0yKQphYmxpbmUobUVzdCxjb2w9InJlZCIsbHdkPTIpCmFibGluZShsbU1vZCxjb2w9ImJsdWUiLGx3ZD0yKQpsZWdlbmQoInRvcGxlZnQiLGxlZ2VuZD1jKCJPTFMiLCJNLWVzdGltYXRpb24iLCJPdXIgSW1wbCIpLGx3ZD0yLGNvbD1jKCJibGFjayIsInJlZCIsImJsdWUiKSkKYGBgCiNyZXBlYXQgdGhpcyBtYW55IHRpbWVzCmBgYHtyfQpsbU1vZD1vbHMKZm9yIChrIGluIDE6MTApCnsKIyMjIyMjcmVwZWF0IHRoaXMgcGFydCBzZXZlcmFsIHRpbWVzIHVudGlsIGNvbnZlcmdlbmNlCiN1c2Ugcm9idXN0IHZhcmlhbmNlIGVzdGltYXRvciB0byBjYWxjdWxhdGUgdGhlIHoKcmVzPWxtTW9kJHJlcwpzdGRldj1tYWQocmVzKQptZWRpYW4oYWJzKHJlcy1tZWRpYW4ocmVzKSkpKjEuNDgyNgoKej1yZXMvc3RkZXYKCiNjYWxjdWxhdGUgd2VpZ2h0cwojdXNlIHBzaS5odWJlciBmdW5jdGlvbgp3PXBzaS5odWJlcih6KQoKI3BlcmZvcm0gYSB3ZWlnaHRlZCByZWdyZXNzaW9uIHVzZSBsbSB3aXRoIHdlaWdodHM9dwpsbU1vZD1sbSh5fngsd2VpZ2h0cz13KQoKI3Bsb3QgcmVzdWx0cwpwbG90KHgseSkKYWJsaW5lKG9scyxsd2Q9MikKYWJsaW5lKG1Fc3QsY29sPSJyZWQiLGx3ZD0yKQphYmxpbmUobG1Nb2QsY29sPSJibHVlIixsd2Q9MikKbGVnZW5kKCJ0b3BsZWZ0IixsZWdlbmQ9YygiT0xTIiwiTS1lc3RpbWF0aW9uIiwiT3VyIEltcGwiKSxsd2Q9Mixjb2w9YygiYmxhY2siLCJyZWQiLCJibHVlIikpCiMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIwp9CmBgYA==