Regression Lines With Same Intercept

Question

So, I struggle with Regression a lot. I just found out how to get 2 lines with the same slope, but I cannot manage to get 2 lines with the same intercept. I read about ANCOVA a lot (because I thought this was what I needed), but no one uses the same intercepts; just the same slope. Can someone help out with this?

Answer 1

library(ggplot2)
set.seed(1)
x <-  1:10
dd <- rbind(data.frame(x=x,fac="a", y=x+rnorm(10)),
            data.frame(x=2*x,fac="b", y=x+rnorm(10)))
coef <- lm(y~x:fac, data=dd)$coefficients
qplot(data=dd, x=x, y=y, color=fac)+
  geom_abline(slope=coef["x:faca"], intercept=coef["(Intercept)"])+
  geom_abline(slope=coef["x:facb"], intercept=coef["(Intercept)"])

Answer 2

Although this is a quite old thread, it is probably noteworthy that @jem77bfp's answer appears to work only when the intercept term is zero or close to zero. Consider:

set.seed(1)
x <-  1:10
dd <- rbind(data.frame(x=10+x,fac="a", y=x+rnorm(10)),
            data.frame(x=10+2*x,fac="b", y=x+rnorm(10)))
coef <- lm(y~x:fac, data=dd)$coefficients

#(Intercept)      x:faca      x:facb 
# -7.0223128   0.8243321   0.6023107

And even more drastically off:

set.seed(1)
x <-  1:10
dd <- rbind(data.frame(x=100+x,fac="a", y=x+rnorm(10)),
            data.frame(x=100+4*x,fac="b", y=x+rnorm(10)))
coef <- lm(y~x:fac, data=dd)$coefficients

# (Intercept)      x:faca      x:facb 
# -32.4026986   0.3610346   0.3122729 

@Ben Bolker's suggestion lm(y~x+f:x) fits two slopes and two intercepts, which can be seen from "correctly" predicting the slopes when both intercepts are different.

I don't know if there is a way to exploit lm, but you can certainly exploit minpack.lm::nls.lm specifying your own error model.

test <- data.frame(x = 1:10, 
                   y1 = 10 + 2*1:10 + rnorm(10, sd = 0.05), 
                   y2 = 10 + 8*1:10 + rnorm(10, sd = 0.05))

my_fun <- function(a, x, b1, b2) data.frame(y1 = a + x * b1, y2 = a + x * b2)

# this is the function which will yield the residuals; note that we need to unlist the data.frame finally
my_fun.res <- function(p, obs, x) unlist(obs - do.call(my_fun, c(list(x = x), as.list(p))))

minpack.lm::nls.lm(par = list(a = 1, b1 = 1, b2 = 1), fn = my_fun.res, 
                   obs = test[, c("y1", "y2")], x = test$x) -> pred

summary(pred)

# Parameters:
#    Estimate Std. Error t value Pr(>|t|)    
# a  10.009693   0.025435   393.5   <2e-16 ***
# b1  2.001747   0.004517   443.1   <2e-16 ***
# b2  7.996578   0.004517  1770.3   <2e-16 ***
```