Weighted Linear regression

Question

I have a list of observation data {x,y} and its densityplot is as follows. The blue solid line is the linear least squares fitting with unique weighting. Theoretically, x and y should be linearly related. The linear fitting (blue line) on the plot seems not align with the data with maximum counts.

I expect a linear fitting would be something like the red dashed line. I want to perform a linear least sqaures fitting with a weighting inversely proportional to y error over standard deviation, for example,

for 30 <= x < 31, 1/w_i = Abs[y_i - mean[y]]/SD[y]

I tried to make a weight list using the above criteria but it was extremely time-consuming. Is there any built in function for achieving my purpose?

I also upload the data here if anyone would like to take a look. https://drive.google.com/file/d/0B3sHo6MIAjziaTloRnlGbm1Nam8/view?usp=sharing

Many thanks in advance.

Answer 1

In your previous question on this dataset, you received a great answer from Anton Antonov that used quantile regression to reject outliers in your data via a statistically rigorous method.

Using his QuantileRegression package as he proposed there, the resulting linear fit on the remaining points seems to fit your current request quite well:

raw = Import["your/data/file.txt", "CSV"];
data2 = Map[Reverse, RandomSample[raw, 10000]];
qs = {0.1, 0.9};
qFuncs = QuantileRegression[data2, 20, qs];
pred2 = Map[
           #[[2]] >= qFuncs[[1]][#[[1]]] && #[[2]] <= qFuncs[[2]][#[[1]]] &, 
           Reverse /@ raw
        ];

in = Pick[raw, pred2];
out = Complement[raw, in];

inFit = LinearModelFit[in, {1, x}, x];
allFit = LinearModelFit[raw, {1, x}, x];

Plot[
  {Style[allFit[x], Blue], Style[inFit[x], Red, Dashed]}, {x, 10, 60},
  PlotStyle -> Thickness[0.01], PlotRange -> {-22, 7},
  Prolog -> {Gray, Point@out, Green, Point@in},
  Axes -> False, Frame -> True, ImageSize -> Large
]

If this is not acceptable, then perhaps you should further clarify your question.

Answer 2

This is an extended comment. First, to agree with @MarcoB, Anton Antonov gave you a great answer. Second, despite the theory stating things are linear, your data provides no support for that theory (at least not across the whole range of the predictor variable).

Because your data has multiple observations for each predictor value, it makes sense to plot the means and confidence intervals associated with each unique predictor value. That plot is created below and maybe things are approximately linear from the predictor values from about 33 and higher, the remaining data supports a separate and smaller slope. Also note that the confidence intervals are so small that only for values below 20 and above about 55 can they even be distinquished from the red point representing the mean.

Quantile regression bends with your data. Try it.

Update

I used R to create the above plot. Here are the Mathematica commands to produce an equivalent plot:

se = StandardDeviation[#]/Sqrt[Length[#]] & /@ GatherBy[data, First];
means = Mean[#] & /@ GatherBy[data, First];
lower = means - 1.96 se;
upper = means + 1.95 se;
Show[ListPlot[{data, means}, 
  PlotStyle -> {Automatic, {PointSize[0.01], Red}}],
 ListPlot[Transpose[{lower, upper}], Joined -> True, PlotStyle -> Red]]

2nd Update

Because you've now stated that the data is essentially censored so that the dependent variable values can't go below -16.1363, your data are censored. This suggests that the median might be a better descriptor of the relationship in that it is less influenced by the censoring.

medians = Median[#] & /@ GatherBy[data, First];
means = Mean[#] & /@ GatherBy[data, First];
ListPlot[{data, means, medians}, 
 PlotStyle -> {Automatic, {PointSize[0.01], Red}, {PointSize[0.01], 
    Blue}}, PlotLegends -> {"Raw data", "Means", "Medians"}]